Many many changes

[Lucu.git] / ImplantFile.hs

diff --git a/ImplantFile.hs b/ImplantFile.hs
index b95c45508cd23d11a134451081edd61c4de45a42..67633f763e3db855c6b4d4f6c39eeb62bb56aa1b 100644 (file)
--- a/ImplantFile.hs
+++ b/ImplantFile.hs
@@ -1,16 +1,17 @@
 {-# LANGUAGE
 {-# LANGUAGE

-    UnicodeSyntax
+    OverloadedStrings
+  , UnicodeSyntax

   #-}
 module Main where
 import Codec.Compression.GZip
 import Control.Applicative
 import Control.Monad
 import qualified Data.Ascii as A
   #-}
 module Main where
 import Codec.Compression.GZip
 import Control.Applicative
 import Control.Monad
 import qualified Data.Ascii as A

-import Data.Bits

 import qualified Data.ByteString.Base64 as B64
 import qualified Data.ByteString.Char8 as Strict
 import qualified Data.ByteString.Lazy as Lazy
 import Data.Char
 import qualified Data.ByteString.Base64 as B64
 import qualified Data.ByteString.Char8 as Strict
 import qualified Data.ByteString.Lazy as Lazy
 import Data.Char

+import Data.Digest.Pure.SHA

 import Data.Int
 import Data.Maybe
 import Data.Time
 import Data.Int
 import Data.Maybe
 import Data.Time


@@ -99,7 +100,7 @@ main = do (opts, sources, errors) ← getOpt Permute options <$> getArgs
                     exitWith $ ExitFailure 1
 
           when (length sources ≥ 2)
                     exitWith $ ExitFailure 1
 
           when (length sources ≥ 2)

-               $ error "too many input files."
+               $ fail "too many input files."

 
           generateHaskellSource opts (head sources)
 
 
           generateHaskellSource opts (head sources)
 


@@ -123,155 +124,144 @@ generateHaskellSource opts srcFile
 
          header ← mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
 
 
          header ← mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
 

-         let hsModule = mkModule (ModuleName modName) (name symName) imports decls
+         let hsModule = mkModule modName symName imports decls

              imports  = mkImports useGZip
              imports  = mkImports useGZip

-             decls    = concat [ declResourceDef
-                               , entityTagDecl eTag
-                               , lastModifiedDecl lastMod
-                               , contentTypeDecl mimeType
-                               , if useGZip then
-                                     dataDecl (name "gzippedData") gzippedB64
-                                 else
-                                     dataDecl (name "rawData") rawB64
-                               ]
-             declResourceDef
-                 = [ HsTypeSig (⊥) [HsIdent symName]
-                               (HsQualType []
-                                (HsTyCon (UnQual (HsIdent "ResourceDef"))))
-                   , HsFunBind [HsMatch (⊥) (HsIdent symName)
-                                [] (HsUnGuardedRhs defResourceDef) []]
-                   ]
-
-             defResourceDef ∷ HsExp
-             defResourceDef 
-                 = let defResGet = if useGZip
-                                   then defResGetGZipped
-                                   else resGetRaw
-                   in 
-                     (HsRecConstr (UnQual (HsIdent "ResourceDef"))
-                      [ HsFieldUpdate (UnQual (HsIdent "resUsesNativeThread"))
-                                      (HsCon (UnQual (HsIdent "False")))
-                      , HsFieldUpdate (UnQual (HsIdent "resIsGreedy"))
-                                      (HsCon (UnQual (HsIdent "False")))
-                      , HsFieldUpdate (UnQual (HsIdent "resGet")) defResGet
-                      , HsFieldUpdate (UnQual (HsIdent "resHead"))
-                                      (HsCon (UnQual (HsIdent "Nothing")))
-                      , HsFieldUpdate (UnQual (HsIdent "resPost"))
-                                      (HsCon (UnQual (HsIdent "Nothing")))
-                      , HsFieldUpdate (UnQual (HsIdent "resPut"))
-                                      (HsCon (UnQual (HsIdent "Nothing")))
-                      , HsFieldUpdate (UnQual (HsIdent "resDelete"))
-                                      (HsCon (UnQual (HsIdent "Nothing")))
-                      ]
-                     )
-
-             defResGetGZipped ∷ HsExp
-             defResGetGZipped
-                 = let doExp = HsDo [ foundEntityStmt
-                                    , setContentTypeStmt
-                                    , bindMustGunzip
-                                    , doConditionalOutput
+             decls    = concat ([ resourceDecl symName useGZip
+                                , entityTagDecl eTag
+                                , lastModifiedDecl lastMod
+                                , contentTypeDecl mimeType
+                                ]
+                                ⧺
+                                if useGZip then
+                                    [ gunzipAndPutChunkDecl
+                                    , dataDecl (name "gzippedData") gzippedB64

                                     ]
                                     ]

-                       bindMustGunzip
-                           = HsGenerator (⊥)
-                             (HsPVar (HsIdent "mustGunzip"))
-                             (HsApp (HsApp (HsVar (UnQual (HsIdent "liftM")))
-                                     (HsVar (UnQual (HsIdent "not"))))
-                              (HsParen
-                               (HsApp (HsVar (UnQual (HsIdent "isEncodingAcceptable")))
-                                      (HsLit (HsString "gzip")))))
-                       doConditionalOutput
-                           = HsQualifier
-                             (HsIf (HsVar (UnQual (HsIdent "mustGunzip")))
-                                   expOutputGunzipped
-                                   expOutputGZipped)
-                       expOutputGunzipped
-                           = (HsApp (HsVar (UnQual (HsIdent "outputLBS")))
-                              (HsParen
-                               (HsApp (HsVar (UnQual (HsIdent "decompress")))
-                                      (HsVar (UnQual (HsIdent "gzippedData"))))))
-                       expOutputGZipped
-                           = HsDo [ setContentEncodingGZipStmt
-                                  , outputStmt (var $ name "gzippedData")
-                                  ]
-                   in 
-                     HsApp (HsCon (UnQual (HsIdent "Just")))
-                           (HsParen doExp)
+                                else
+                                    [ dataDecl (name "rawData") rawB64 ]
+                               )

 
          hPutStrLn output header
          hPutStrLn output (prettyPrint hsModule)
          hClose output
 
 
          hPutStrLn output header
          hPutStrLn output (prettyPrint hsModule)
          hClose output
 

-mkModule ∷ ModuleName → Name → [ImportDecl] → [Decl]
+mkModule ∷ ModuleName → Name → [ImportDecl] → [Decl] → Module

 mkModule modName symName imports decls
 mkModule modName symName imports decls

-    = let modPragma = [ LanguagePragma (⊥) [ name (show OverloadedStrings)
-                                           ]
-                      ]
-          exports   = [ EVar (UnQual symName)
-                      ]
+    = let modPragma = [ LanguagePragma (⊥) [ name (show OverloadedStrings) ] ]
+          exports   = [ EVar (UnQual symName) ]

       in
         Module (⊥) modName modPragma Nothing (Just exports) imports decls
 
 mkImports ∷ Bool → [ImportDecl]
 mkImports useGZip
     = [ ImportDecl (⊥) (ModuleName "Data.ByteString.Base64")
       in
         Module (⊥) modName modPragma Nothing (Just exports) imports decls
 
 mkImports ∷ Bool → [ImportDecl]
 mkImports useGZip
     = [ ImportDecl (⊥) (ModuleName "Data.ByteString.Base64")

-                   True False (Just (ModuleName "B64")) Nothing
+                   True False Nothing (Just (ModuleName "B64")) Nothing

       , ImportDecl (⊥) (ModuleName "Data.ByteString.Lazy")
       , ImportDecl (⊥) (ModuleName "Data.ByteString.Lazy")

-                   True False (Just (ModuleName "Lazy")) Nothing
+                   True False Nothing (Just (ModuleName "Lazy")) Nothing

       , ImportDecl (⊥) (ModuleName "Data.Time")
       , ImportDecl (⊥) (ModuleName "Data.Time")

-                   False False Nothing Nothing
+                   False False Nothing Nothing Nothing

       , ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu")
       , ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu")

-                   False False Nothing Nothing
+                   False False Nothing Nothing Nothing

       ]
       ⧺
       if useGZip then
       ]
       ⧺
       if useGZip then

-          [ ImportDecl (⊥) (ModuleName "Codec.Compression.GZip")
-                       False False Nothing Nothing
+          [ ImportDecl (⊥) (ModuleName "Blaze.ByteString.Builder.ByteString")
+                       True False Nothing (Just (ModuleName "BB")) Nothing
+          , ImportDecl (⊥) (ModuleName "Codec.Compression.Zlib.Internal")
+                       False False Nothing Nothing Nothing
+          , ImportDecl (⊥) (ModuleName "Data.Text")
+                       True False Nothing (Just (ModuleName "T")) Nothing

           ]
       else
           []
 
           ]
       else
           []
 

+resourceDecl ∷ Name → Bool → [Decl]
+resourceDecl symName useGZip
+    = [ TypeSig (⊥) [symName] (TyCon (UnQual (name "ResourceDef")))
+      , nameBind (⊥) symName valExp
+      ]
+    where
+      valExp ∷ Exp
+      valExp = RecUpdate (function "emptyResource")
+               [ FieldUpdate (UnQual (name "resGet" )) resGet
+               , FieldUpdate (UnQual (name "resHead")) resHead
+               ]
+
+      resGet ∷ Exp
+      resGet | useGZip   = resGetGZipped
+             | otherwise = resGetRaw
+

 resHead ∷ Exp
 resHead
 resHead ∷ Exp
 resHead

-    = infixApp (var $ name "Just")
-               (op  $ name "$"   )
-               (doE [ foundEntityStmt
-                    , setContentTypeStmt
+    = function "Just" `app`
+      paren (doE [ foundEntityStmt
+                 , setContentTypeStmt
+                 ])
+
+resGetGZipped ∷ Exp
+resGetGZipped
+    = function "Just" `app`
+      paren (doE [ foundEntityStmt
+                 , setContentTypeStmt
+                 , bindGZipStmt
+                 , conditionalOutputStmt
+                 ])
+    where
+      condVarName ∷ Name
+      condVarName = name "gzipAllowed"
+
+      dataVarName ∷ Name
+      dataVarName = name "gzippedData"
+
+      bindGZipStmt ∷ Stmt
+      bindGZipStmt
+          = genStmt (⊥)
+            (pvar condVarName)
+            (function "isEncodingAcceptable" `app` strE "gzip")
+
+      conditionalOutputStmt ∷ Stmt
+      conditionalOutputStmt
+          = qualStmt $
+            If (var condVarName)
+               (doE [ setContentEncodingGZipStmt
+                    , outputStmt (var dataVarName)

                     ])
                     ])

+               (function "gunzipAndPutChunk" `app` var dataVarName)

 
 resGetRaw ∷ Exp
 resGetRaw
 
 resGetRaw ∷ Exp
 resGetRaw

-    = infixApp (var $ name "Just")
-               (op  $ name "$"   )
-               (doE [ foundEntityStmt
-                    , setContentTypeStmt
-                    , outputStmt (var $ name "rawData")
-                    ])
+    = function "Just" `app`
+      paren (doE [ foundEntityStmt
+                 , setContentTypeStmt
+                 , outputStmt (function "rawData")
+                 ])

 
 setContentEncodingGZipStmt ∷ Stmt
 setContentEncodingGZipStmt
 
 setContentEncodingGZipStmt ∷ Stmt
 setContentEncodingGZipStmt

-    = qualStmt $
-      metaFunction "setContentEncoding" $
-      [ listE [ strE "gzip" ] ]
+    = qualStmt
+      ( function "setContentEncoding"
+        `app`
+        listE [ strE "gzip" ]
+      )

 
 foundEntityStmt ∷ Stmt
 foundEntityStmt
     = qualStmt $
 
 foundEntityStmt ∷ Stmt
 foundEntityStmt
     = qualStmt $

-      metaFunction "foundEntity" $
-      [ var $ name "entityTag"
-      , var $ name "lastModified"
-      ]
+      metaFunction "foundEntity"
+                       [ var (name "entityTag")
+                       , var (name "lastModified")
+                       ]

 
 setContentTypeStmt ∷ Stmt
 setContentTypeStmt
 
 setContentTypeStmt ∷ Stmt
 setContentTypeStmt

-    = qualStmt $
-      metaFunction "setContentType" $
-      [var $ name "contentType"]
+    = qualStmt
+      ( function "setContentType"
+        `app`
+        function "contentType"
+      )

 
 outputStmt ∷ Exp → Stmt
 outputStmt e
 
 outputStmt ∷ Exp → Stmt
 outputStmt e

-    = qualStmt $
-      metaFunction "output" [e]
+    = qualStmt $ function "putChunk" `app` e

 
 entityTagDecl ∷ ETag → [Decl]
 entityTagDecl eTag
 
 entityTagDecl ∷ ETag → [Decl]
 entityTagDecl eTag


@@ -283,10 +273,7 @@ entityTagDecl eTag
       varName = name "entityTag"
 
       valExp ∷ Exp
       varName = name "entityTag"
 
       valExp ∷ Exp

-      valExp = metaFunction "parseETag" [strE $ eTagToString eTag]
-
-      eTagToString ∷ ETag → String
-      eTagToString = A.toString ∘ A.fromAsciiBuilder ∘ printETag
+      valExp = function "parseETag" `app` strE (eTagToString eTag)

 
 lastModifiedDecl ∷ UTCTime → [Decl]
 lastModifiedDecl lastMod
 
 lastModifiedDecl ∷ UTCTime → [Decl]
 lastModifiedDecl lastMod


@@ -298,7 +285,7 @@ lastModifiedDecl lastMod
       varName = name "lastModified"
 
       valExp ∷ Exp
       varName = name "lastModified"
 
       valExp ∷ Exp

-      valExp = metaFunction "read" [strE $ show lastMod]
+      valExp = function "read" `app` strE (show lastMod)

 
 contentTypeDecl ∷ MIMEType → [Decl]
 contentTypeDecl mime
 
 contentTypeDecl ∷ MIMEType → [Decl]
 contentTypeDecl mime


@@ -310,11 +297,89 @@ contentTypeDecl mime
       varName = name "contentType"
 
       valExp ∷ Exp
       varName = name "contentType"
 
       valExp ∷ Exp

-      valExp = metaFunction "parseMIMEType" [mimeToString mime]
+      valExp = function "parseMIMEType" `app` strE (mimeToString mime)

 
       mimeToString ∷ MIMEType → String
       mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
 
 
       mimeToString ∷ MIMEType → String
       mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
 

+gunzipAndPutChunkDecl ∷ [Decl]
+gunzipAndPutChunkDecl
+    = [ TypeSig (⊥) [funName]
+                    (TyFun (TyCon (Qual (ModuleName "Lazy") (name "ByteString")))
+                           tyResourceUnit)
+      , sfun (⊥) funName [] (UnGuardedRhs funExp) (binds goDecl)
+      ]
+    where
+      funName ∷ Name
+      funName = name "gunzipAndPutChunk"
+
+      goName ∷ Name
+      goName = name "go"
+
+      tyResourceUnit ∷ Type
+      tyResourceUnit
+          = TyApp (TyCon (UnQual (name "Resource")))
+                  (TyTuple Boxed [])
+
+      funExp ∷ Exp
+      funExp = var goName
+               `app`
+               function "."
+               `app`
+               metaFunction "decompressWithErrors"
+                                [ function "gzipFormat"
+                                , function "defaultDecompressParams"
+                                ]
+
+      goDecl ∷ [Decl]
+      goDecl = [ TypeSig (⊥) [goName]
+                             (TyFun (TyCon (UnQual (name "DecompressStream")))
+                                    tyResourceUnit)
+               , FunBind [ Match (⊥) goName [pvar (name "StreamEnd")]
+                                 Nothing (UnGuardedRhs endExp) (binds [])
+                         , Match (⊥) goName [pApp (name "StreamChunk")
+                                                  [ pvar (name "x")
+                                                  , pvar (name "xs") ]]
+                                 Nothing (UnGuardedRhs chunkExp) (binds [])
+                         , Match (⊥) goName [pApp (name "StreamError")
+                                                   [ wildcard
+                                                   , pvar (name "msg") ]]
+                                 Nothing (UnGuardedRhs errorExp) (binds [])
+                         ]
+               ]
+
+      endExp ∷ Exp
+      endExp = function "return" `app` tuple []
+
+      chunkExp ∷ Exp
+      chunkExp = function "putBuilder"
+                 `app`
+                 paren ( qvar (ModuleName "BB") (name "fromByteString")
+                         `app`
+                         var (name "x")
+                       )
+                 `app`
+                 function ">>"
+                 `app`
+                 function "go" `app` var (name "xs")
+
+      errorExp ∷ Exp
+      errorExp = metaFunction "abort"
+                 [ var (name "InternalServerError")
+                 , listE []
+                 , function "Just"
+                   `app`
+                   paren ( qvar (ModuleName "T") (name "pack")
+                           `app`
+                           paren ( strE "gunzip: "
+                                   `app`
+                                   function "++"
+                                   `app`
+                                   var (name "msg")
+                                 )
+                         )
+                 ]
+

 dataDecl ∷ Name → [Strict.ByteString] → [Decl]
 dataDecl varName chunks
     = [ TypeSig (⊥) [varName] (TyCon (Qual (ModuleName "Lazy") (name "ByteString")))
 dataDecl ∷ Name → [Strict.ByteString] → [Decl]
 dataDecl varName chunks
     = [ TypeSig (⊥) [varName] (TyCon (Qual (ModuleName "Lazy") (name "ByteString")))


@@ -332,64 +397,80 @@ dataDecl varName chunks
             `app`
             strE (Strict.unpack chunk)
 
             `app`
             strE (Strict.unpack chunk)
 

-mkHeader ∷ FilePath → Int64 → Int64 → Bool → MIMEType → String → UTCTime → IO String
+mkHeader ∷ FilePath → Int64 → Int64 → Bool → MIMEType → ETag → UTCTime → IO String

 mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
     = do localLastMod ← utcToLocalZonedTime lastMod
 mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod
     = do localLastMod ← utcToLocalZonedTime lastMod

-         return ("{- DO NOT EDIT THIS FILE.\n" ++
-                 "   This file is automatically generated by the lucu-implant-file program.\n" ++
-                 "\n" ++
-                 "              Source: " ++ (if srcFile ≡ "-"
-                                              then "(stdin)"
-                                              else srcFile) ++ "\n" ++
-                 "     Original Length: " ++ show originalLen ++ " bytes\n" ++
-                 (if useGZip
-                  then "   Compressed Length: " ++ show gzippedLen ++ " bytes\n" ++
-                       "         Compression: gzip\n"
-                  else "         Compression: disabled\n") ++
-                 "           MIME Type: " ++ show mimeType ++ "\n" ++
-                 "                ETag: " ++ eTag ++ "\n" ++
-                 "       Last Modified: " ++ show localLastMod ++ "\n" ++
-                 " -}")
-
-
-getModuleName ∷ [CmdOpt] → IO String
+         return $ concat
+                    [ "{- DO NOT EDIT THIS FILE.\n"
+                    , "   This file is automatically generated by the lucu-implant-file program.\n"
+                    , "\n"
+                    , "              Source: ", if srcFile ≡ "-" then
+                                                    "(stdin)"
+                                                else
+                                                    srcFile
+                    , "\n"
+                    , "     Original Length: ", show originalLen, " bytes\n"
+                    , if useGZip then
+                          "   Compressed Length: " ⧺ show gzippedLen ⧺ " bytes\n" ⧺
+                          "         Compression: gzip\n"
+                      else
+                          "         Compression: disabled\n"
+                    , "           MIME Type: ", mimeTypeToString mimeType, "\n"
+                    , "                ETag: ", eTagToString eTag, "\n"
+                    , "       Last Modified: ", show localLastMod, "\n"
+                    , " -}"
+                    ]
+
+eTagToString ∷ ETag → String
+eTagToString = A.toString ∘ A.fromAsciiBuilder ∘ printETag
+
+mimeTypeToString ∷ MIMEType → String
+mimeTypeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
+
+getModuleName ∷ [CmdOpt] → IO ModuleName

 getModuleName opts
 getModuleName opts

-    = let modNameOpts = filter (\ x → case x of
-                                         OptModName _ → True
-                                         _            → False) opts
-      in
-        case modNameOpts of
-          []                      → error "a module name must be given."
-          (OptModName modName):[] → return modName
-          _                       → error "too many --module options."
-
-
-getSymbolName ∷ [CmdOpt] → String → IO String
-getSymbolName opts modName
-    = let symNameOpts    = filter (\ x → case x of
-                                            OptSymName _ → True
-                                            _            → False) opts
-          -- モジュール名をピリオドで分割した時の最後の項目の先頭文字を
-          -- 小文字にしたものを使ふ。
-          defaultSymName  = mkDefault modName
-          mkDefault       = headToLower ∘ getLastComp
-          headToLower str = case str of
-                              []     → error "module name must not be empty"
-                              (x:xs) → toLower x : xs
-          getLastComp     = reverse ∘ fst ∘ break (≡ '.') ∘ reverse
-      in
-        case symNameOpts of
-          []                      → return defaultSymName
-          (OptSymName symName):[] → return symName
-          _                       → error "too many --symbol options."
+    = case modNameOpts of
+        []                    → fail "a module name must be given."
+        OptModName modName:[] → return $ ModuleName modName
+        _                     → fail "too many --module options."
+    where
+      modNameOpts ∷ [CmdOpt]
+      modNameOpts = filter (\ x → case x of
+                                     OptModName _ → True
+                                     _            → False) opts
+
+getSymbolName ∷ [CmdOpt] → ModuleName → IO Name
+getSymbolName opts (ModuleName modName)
+    = case symNameOpts of
+        []                    → return defaultSymName
+        OptSymName symName:[] → return $ name symName
+        _                     → fail "too many --symbol options."
+    where
+      symNameOpts ∷ [CmdOpt]
+      symNameOpts = filter (\ x → case x of
+                                     OptSymName _ → True
+                                     _            → False) opts
+
+      defaultSymName ∷ Name
+      defaultSymName
+          = name $ headToLower $ getLastComp modName

 
 

+      headToLower ∷ String → String
+      headToLower []     = error "module name must not be empty"
+      headToLower (x:xs) = toLower x : xs
+
+      getLastComp ∷ String → String
+      getLastComp = reverse ∘ fst ∘ break (≡ '.') ∘ reverse

 
 getMIMEType ∷ [CmdOpt] → FilePath → IO MIMEType
 getMIMEType opts srcFile
     = case mimeTypeOpts of
 
 getMIMEType ∷ [CmdOpt] → FilePath → IO MIMEType
 getMIMEType opts srcFile
     = case mimeTypeOpts of

-        []                  → return defaultType
-        (OptMIMEType ty):[] → return $ read ty
-        _                   → error "too many --mime-type options."
+        []  → return defaultType
+        OptMIMEType ty:[]
+            → case A.fromChars ty of
+                 Just a  → return $ parseMIMEType a
+                 Nothing → fail "MIME type must not contain any non-ASCII letters."
+        _   → fail "too many --mime-type options."

     where
       mimeTypeOpts ∷ [CmdOpt]
       mimeTypeOpts
     where
       mimeTypeOpts ∷ [CmdOpt]
       mimeTypeOpts


@@ -404,59 +485,49 @@ getMIMEType opts srcFile
       defaultType = fromMaybe octetStream
                     $ guessTypeByFileName defaultExtensionMap srcFile
 
       defaultType = fromMaybe octetStream
                     $ guessTypeByFileName defaultExtensionMap srcFile
 

-

 getLastModified ∷ FilePath → IO UTCTime
 getLastModified "-"   = getCurrentTime
 getLastModified fpath = (posixSecondsToUTCTime ∘ fromRational ∘ toRational ∘ modificationTime)
                         <$>
                         getFileStatus fpath
 
 getLastModified ∷ FilePath → IO UTCTime
 getLastModified "-"   = getCurrentTime
 getLastModified fpath = (posixSecondsToUTCTime ∘ fromRational ∘ toRational ∘ modificationTime)
                         <$>
                         getFileStatus fpath
 

-
-getETag ∷ [CmdOpt] → Lazy.ByteString → IO String
+getETag ∷ [CmdOpt] → Lazy.ByteString → IO ETag

 getETag opts input
 getETag opts input

-    = let eTagOpts = filter (\ x → case x of
-                                      OptETag _ → True
-                                      _         → False) opts
-      in
-        case eTagOpts of
-          []               → fmap (mkETagFromInput ∘ fromJust) (getDigestByName "SHA1")
-          (OptETag str):[] → return str
-          _                → error "too many --etag options."
+    = case eTagOpts of
+        []             → return mkETagFromInput
+        OptETag str:[] → return $ strToETag str
+        _              → fail "too many --etag options."

     where
     where

-      mkETagFromInput ∷ Digest → String
-      mkETagFromInput sha1 = "SHA-1:" ++ toHex (digestLBS sha1 input)
-
-      toHex ∷ String → String
-      toHex = foldr ((++) ∘ hexByte ∘ fromEnum) ""
-
-      hexByte ∷ Int → String
-      hexByte n
-          = [ hex4bit ((n `shiftR` 4) .&. 0x0F)
-            , hex4bit ( n             .&. 0x0F)
-            ]
+      eTagOpts ∷ [CmdOpt]
+      eTagOpts = filter (\ x → case x of
+                                  OptETag _ → True
+                                  _         → False) opts

 
 

-      hex4bit ∷ Int → Char
-      hex4bit n
-          | n < 10    = chr $ ord '0' + n
-          | n < 16    = chr $ ord 'a' + n - 10
-          | otherwise = (⊥)
+      mkETagFromInput ∷ ETag
+      mkETagFromInput
+          = strToETag $ "SHA-1:" ⧺ showDigest (sha1 input)

 
 

+      strToETag ∷ String → ETag
+      strToETag str
+          = case A.fromChars str of
+              Just a  → strongETag a
+              Nothing → error "ETag must not contain any non-ASCII letters."

 
 openInput ∷ FilePath → IO Lazy.ByteString
 openInput "-"   = Lazy.getContents
 openInput fpath = Lazy.readFile fpath
 
 
 openInput ∷ FilePath → IO Lazy.ByteString
 openInput "-"   = Lazy.getContents
 openInput fpath = Lazy.readFile fpath
 

-

 openOutput ∷ [CmdOpt] → IO Handle
 openOutput opts
 openOutput ∷ [CmdOpt] → IO Handle
 openOutput opts

-    = let outputOpts = filter (\ x → case x of
-                                        OptOutput _ → True
-                                        _           → False) opts
-      in
-        case outputOpts of
-          []                   → return stdout
-          (OptOutput fpath):[] → openFile fpath WriteMode
-          _                    → error "two many --output options."
+    = case outputOpts of
+        []                 → return stdout
+        OptOutput fpath:[] → openFile fpath WriteMode
+        _                  → fail "two many --output options."
+    where
+      outputOpts ∷ [CmdOpt]
+      outputOpts = filter (\ x → case x of
+                                    OptOutput _ → True
+                                    _           → False) opts

 
 {-
   作られるファイルの例 (壓縮されない場合):
 
 {-
   作られるファイルの例 (壓縮されない場合):


@@ -469,7 +540,7 @@ openOutput opts
      Compressed Length: 453 bytes  -- これは Compression: disabled の時には無い
            Compression: disabled
              MIME Type: image/png
      Compressed Length: 453 bytes  -- これは Compression: disabled の時には無い
            Compression: disabled
              MIME Type: image/png

-                  ETag: d41d8cd98f00b204e9800998ecf8427e
+                  ETag: "d41d8cd98f00b204e9800998ecf8427e"

          Last Modified: 2007-11-05 13:53:42.231882 JST
    -}
   {-# LANGUAGE OverloadedStrings #-}
          Last Modified: 2007-11-05 13:53:42.231882 JST
    -}
   {-# LANGUAGE OverloadedStrings #-}


@@ -486,7 +557,7 @@ openOutput opts
         , resGet
             = Just $ do foundEntity entityTag lastModified
                         setContentType contentType
         , resGet
             = Just $ do foundEntity entityTag lastModified
                         setContentType contentType

-                        output rawData
+                        putChunk rawData

         , resHead
             = Just $ do foundEntity entityTag lastModified
                         setContentType contentType
         , resHead
             = Just $ do foundEntity entityTag lastModified
                         setContentType contentType


@@ -514,7 +585,9 @@ openOutput opts
   壓縮される場合は次のやうに變はる:
   ------------------------------------------------------------------------------
   -- import に追加
   壓縮される場合は次のやうに變はる:
   ------------------------------------------------------------------------------
   -- import に追加

-  import Codec.Compression.GZip
+  import qualified Blaze.ByteString.Builder.ByteString as BB
+  import Codec.Compression.Zlib.Internal
+  import qualified Data.Text as T

 
   -- ResourceDef は次のやうに變化
   baz ∷ ResourceDef
 
   -- ResourceDef は次のやうに變化
   baz ∷ ResourceDef


@@ -525,12 +598,12 @@ openOutput opts
             = Just $ do foundEntity entityTag lastModified
                         setContentType contentType
 
             = Just $ do foundEntity entityTag lastModified
                         setContentType contentType
 

-                        gzip ← isEncodingAcceptable "gzip"
-                        if gzip then
+                        gzipAllowed ← isEncodingAcceptable "gzip"
+                        if gzipAllowed then

                             do setContentEncoding ["gzip"]
                             do setContentEncoding ["gzip"]

-                               output gzippedData
+                               putChunk gzippedData

                         else
                         else

-                            output (decompress gzippedData)
+                            gunzipAndPutChunk gzippedData

         , resHead
             = Just $ do foundEntity entityTag lastModified
                         setContentType contentType
         , resHead
             = Just $ do foundEntity entityTag lastModified
                         setContentType contentType


@@ -538,6 +611,15 @@ openOutput opts
         , resPut    = Nothing
         , resDelete = Nothing
         }
         , resPut    = Nothing
         , resDelete = Nothing
         }

+
+  -- 追加
+  gunzipAndPutChunk :: Lazy.ByteString -> Resource ()
+  gunzipAndPutChunk = go . decompressWithErrors gzipFormat defaultDecompressParams
+      where
+        go :: DecompressStream -> Resource ()
+        go StreamEnd = return ()
+        go (StreamChunk x xs) = putBuilder (BB.fromByteString x) >> go xs
+        go (StreamError _ msg) = abort InternalServerError [] (Just (T.pack ("gunzip: " ++ msg)))

   
   -- rawData の代はりに gzippedData
   gzippedData ∷ Lazy.ByteString
   
   -- rawData の代はりに gzippedData
   gzippedData ∷ Lazy.ByteString