X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=ImplantFile.hs;h=67633f763e3db855c6b4d4f6c39eeb62bb56aa1b;hb=0aa4f6d758fc12fba468f7cd399bbcc48f693d1e;hp=3b80e60844d3835cda549d64b5bd99325d7b282f;hpb=6126eb9cbe5b38c300d855d96d2238831e59b5dd;p=Lucu.git diff --git a/ImplantFile.hs b/ImplantFile.hs index 3b80e60..67633f7 100644 --- a/ImplantFile.hs +++ b/ImplantFile.hs @@ -126,15 +126,19 @@ generateHaskellSource opts srcFile 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) @@ -159,10 +163,16 @@ mkImports useGZip 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 @@ -171,7 +181,7 @@ 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 ] @@ -182,21 +192,19 @@ resourceDecl symName useGZip 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" @@ -208,7 +216,7 @@ resGetGZipped bindGZipStmt = genStmt (⊥) (pvar condVarName) - (metaFunction "isEncodingAcceptable" [strE "gzip"]) + (function "isEncodingAcceptable" `app` strE "gzip") conditionalOutputStmt ∷ Stmt conditionalOutputStmt @@ -217,42 +225,43 @@ resGetGZipped (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" + [ 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 @@ -264,7 +273,7 @@ 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 @@ -276,7 +285,7 @@ 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 @@ -288,11 +297,89 @@ 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"))) @@ -328,7 +415,7 @@ mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod " 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" , " -}" @@ -337,6 +424,9 @@ mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod 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 @@ -467,7 +557,7 @@ openOutput opts , resGet = Just $ do foundEntity entityTag lastModified setContentType contentType - output rawData + putChunk rawData , resHead = Just $ do foundEntity entityTag lastModified setContentType contentType @@ -495,7 +585,9 @@ openOutput opts 壓縮される場合は次のやうに變はる: ------------------------------------------------------------------------------ -- 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 @@ -509,9 +601,9 @@ openOutput opts 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 @@ -519,6 +611,15 @@ openOutput opts , 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