X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=ImplantFile.hs;fp=ImplantFile.hs;h=67633f763e3db855c6b4d4f6c39eeb62bb56aa1b;hp=b085a9876b859c4463c11609524da25082b48f4d;hb=1789cee5ee66d2f7f2b26280be2f13eac4df7980;hpb=1f3ac4a08b413a7438258c8e196873f5e8a9718f

diff --git a/ImplantFile.hs b/ImplantFile.hs
index b085a98..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
                ]
@@ -215,17 +225,14 @@ resGetGZipped
                (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
@@ -240,8 +247,8 @@ foundEntityStmt ∷ Stmt
 foundEntityStmt
     = qualStmt $
       metaFunction "foundEntity"
-                       [ var $ name "entityTag"
-                       , var $ name "lastModified"
+                       [ var (name "entityTag")
+                       , var (name "lastModified")
                        ]
 
 setContentTypeStmt ∷ Stmt
@@ -249,12 +256,12 @@ setContentTypeStmt
     = 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
@@ -295,6 +302,84 @@ contentTypeDecl 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")))
@@ -472,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
@@ -500,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
@@ -514,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
@@ -524,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