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)
False False Nothing Nothing Nothing
]
⧺
- [ ImportDecl (⊥) (ModuleName "Codec.Compression.GZip")
- False False Nothing Nothing Nothing
- | useGZip
- ]
+ if useGZip then
+ [ 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
+ []
resourceDecl ∷ Name → Bool → [Decl]
resourceDecl symName useGZip
]
where
valExp ∷ Exp
- valExp = RecUpdate (var $ name "emptyResource")
+ valExp = RecUpdate (function "emptyResource")
[ FieldUpdate (UnQual (name "resGet" )) resGet
, FieldUpdate (UnQual (name "resHead")) resHead
]
(doE [ setContentEncodingGZipStmt
, outputStmt (var dataVarName)
])
- ( function "output"
- `app`
- paren (function "decompress" `app` var dataVarName)
- )
+ (function "gunzipAndPutChunk" `app` var dataVarName)
resGetRaw ∷ Exp
resGetRaw
= function "Just" `app`
paren (doE [ foundEntityStmt
, setContentTypeStmt
- , outputStmt (var $ name "rawData")
+ , outputStmt (function "rawData")
])
setContentEncodingGZipStmt ∷ Stmt
foundEntityStmt
= qualStmt $
metaFunction "foundEntity"
- [ var $ name "entityTag"
- , var $ name "lastModified"
+ [ var (name "entityTag")
+ , var (name "lastModified")
]
setContentTypeStmt ∷ Stmt
= qualStmt
( function "setContentType"
`app`
- var (name "contentType")
+ function "contentType"
)
outputStmt ∷ Exp → Stmt
outputStmt e
- = qualStmt $ function "output" `app` e
+ = qualStmt $ function "putChunk" `app` e
entityTagDecl ∷ ETag → [Decl]
entityTagDecl eTag
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")))
, 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