let hsModule = mkModule modName symName imports decls
imports = mkImports useGZip
- decls = concat [ resourceDecl symName useGZip
- , entityTagDecl eTag
- , lastModifiedDecl lastMod
- , contentTypeDecl mimeType
- , if useGZip then
- dataDecl (name "gzippedData") gzippedB64
- else
- dataDecl (name "rawData") rawB64
- ]
+ decls = concat ([ resourceDecl symName useGZip
+ , entityTagDecl eTag
+ , lastModifiedDecl lastMod
+ , contentTypeDecl mimeType
+ ]
+ ⧺
+ if useGZip then
+ [ gunzipAndPutChunkDecl
+ , dataDecl (name "gzippedData") gzippedB64
+ ]
+ else
+ [ dataDecl (name "rawData") rawB64 ]
+ )
hPutStrLn output header
hPutStrLn output (prettyPrint hsModule)
]
⧺
if useGZip then
- [ ImportDecl (⊥) (ModuleName "Codec.Compression.GZip")
+ [ 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
[]
]
where
valExp ∷ Exp
- valExp = RecUpdate (var $ name "emptyResource")
+ valExp = RecUpdate (function "emptyResource")
[ FieldUpdate (UnQual (name "resGet" )) resGet
, FieldUpdate (UnQual (name "resHead")) resHead
]
resHead ∷ Exp
resHead
- = infixApp (var $ name "Just")
- (op $ name "$" )
- (doE [ foundEntityStmt
- , setContentTypeStmt
- ])
+ = function "Just" `app`
+ paren (doE [ foundEntityStmt
+ , setContentTypeStmt
+ ])
resGetGZipped ∷ Exp
resGetGZipped
- = infixApp (var $ name "Just")
- (op $ name "$" )
- (doE [ foundEntityStmt
- , setContentTypeStmt
- , bindGZipStmt
- , conditionalOutputStmt
- ])
+ = function "Just" `app`
+ paren (doE [ foundEntityStmt
+ , setContentTypeStmt
+ , bindGZipStmt
+ , conditionalOutputStmt
+ ])
where
condVarName ∷ Name
condVarName = name "gzipAllowed"
bindGZipStmt
= genStmt (⊥)
(pvar condVarName)
- (metaFunction "isEncodingAcceptable" [strE "gzip"])
+ (function "isEncodingAcceptable" `app` strE "gzip")
conditionalOutputStmt ∷ Stmt
conditionalOutputStmt
(doE [ setContentEncodingGZipStmt
, outputStmt (var dataVarName)
])
- (metaFunction "output"
- [paren (metaFunction "decompress" [var dataVarName])])
+ (function "gunzipAndPutChunk" `app` var dataVarName)
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
- = qualStmt $
- metaFunction "setContentEncoding" $
- [ listE [ strE "gzip" ] ]
+ = qualStmt
+ ( function "setContentEncoding"
+ `app`
+ listE [ strE "gzip" ]
+ )
foundEntityStmt ∷ Stmt
foundEntityStmt
= qualStmt $
- metaFunction "foundEntity" $
- [ var $ name "entityTag"
- , var $ name "lastModified"
- ]
+ metaFunction "foundEntity"
+ [ var (name "entityTag")
+ , var (name "lastModified")
+ ]
setContentTypeStmt ∷ Stmt
setContentTypeStmt
- = qualStmt $
- metaFunction "setContentType" $
- [var $ name "contentType"]
+ = qualStmt
+ ( function "setContentType"
+ `app`
+ function "contentType"
+ )
outputStmt ∷ Exp → Stmt
outputStmt e
- = qualStmt $
- metaFunction "output" [e]
+ = qualStmt $ function "putChunk" `app` e
entityTagDecl ∷ ETag → [Decl]
entityTagDecl eTag
varName = name "entityTag"
valExp ∷ Exp
- valExp = metaFunction "parseETag" [strE $ eTagToString eTag]
+ valExp = function "parseETag" `app` strE (eTagToString eTag)
lastModifiedDecl ∷ UTCTime → [Decl]
lastModifiedDecl lastMod
varName = name "lastModified"
valExp ∷ Exp
- valExp = metaFunction "read" [strE $ show lastMod]
+ valExp = function "read" `app` strE (show lastMod)
contentTypeDecl ∷ MIMEType → [Decl]
contentTypeDecl mime
varName = name "contentType"
valExp ∷ Exp
- valExp = metaFunction "parseMIMEType" [strE $ mimeToString mime]
+ valExp = function "parseMIMEType" `app` strE (mimeToString mime)
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")))
" Compression: gzip\n"
else
" Compression: disabled\n"
- , " MIME Type: ", show mimeType, "\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
= case modNameOpts of
- [] → fail "a module name must be given."
- (OptModName modName):[] → return $ ModuleName modName
- _ → fail "too many --module options."
+ [] → 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
getSymbolName ∷ [CmdOpt] → ModuleName → IO Name
getSymbolName opts (ModuleName modName)
= case symNameOpts of
- [] → return defaultSymName
- (OptSymName symName):[] → return $ name symName
- _ → fail "too many --symbol options."
+ [] → return defaultSymName
+ OptSymName symName:[] → return $ name symName
+ _ → fail "too many --symbol options."
where
symNameOpts ∷ [CmdOpt]
symNameOpts = filter (\ x → case x of
getMIMEType opts srcFile
= case mimeTypeOpts of
[] → return defaultType
- (OptMIMEType ty):[]
+ OptMIMEType ty:[]
→ case A.fromChars ty of
Just a → return $ parseMIMEType a
Nothing → fail "MIME type must not contain any non-ASCII letters."
getETag ∷ [CmdOpt] → Lazy.ByteString → IO ETag
getETag opts input
= case eTagOpts of
- [] → return $ mkETagFromInput
- (OptETag str):[] → return $ strToETag str
- _ → fail "too many --etag options."
+ [] → return mkETagFromInput
+ OptETag str:[] → return $ strToETag str
+ _ → fail "too many --etag options."
where
eTagOpts ∷ [CmdOpt]
eTagOpts = filter (\ x → case x of
openOutput ∷ [CmdOpt] → IO Handle
openOutput opts
= case outputOpts of
- [] → return stdout
- (OptOutput fpath):[] → openFile fpath WriteMode
- _ → fail "two many --output options."
+ [] → return stdout
+ OptOutput fpath:[] → openFile fpath WriteMode
+ _ → fail "two many --output options."
where
outputOpts ∷ [CmdOpt]
outputOpts = filter (\ x → case x of
, resGet
= Just $ do foundEntity entityTag lastModified
setContentType contentType
- output rawData
+ putChunk rawData
, resHead
= Just $ do foundEntity entityTag lastModified
setContentType contentType
壓縮される場合は次のやうに變はる:
------------------------------------------------------------------------------
-- 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
gzipAllowed ← isEncodingAcceptable "gzip"
if gzipAllowed then
do setContentEncoding ["gzip"]
- output gzippedData
+ putChunk gzippedData
else
- output (decompress gzippedData)
+ gunzipAndPutChunk gzippedData
, resHead
= Just $ do foundEntity entityTag lastModified
setContentType contentType
, 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
projects / Lucu.git / blobdiff