X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=ImplantFile.hs;h=c253c2abd05395b3311dba1fd9d3ed999d37d89b;hp=67633f763e3db855c6b4d4f6c39eeb62bb56aa1b;hb=48bc90d66a45c0b9b6f52272b46cf2949ed802e3;hpb=1789cee5ee66d2f7f2b26280be2f13eac4df7980 diff --git a/ImplantFile.hs b/ImplantFile.hs index 67633f7..c253c2a 100644 --- a/ImplantFile.hs +++ b/ImplantFile.hs @@ -41,27 +41,27 @@ data CmdOpt deriving (Eq, Show) options ∷ [OptDescr CmdOpt] -options = [ Option ['o'] ["output"] +options = [ Option "o" ["output"] (ReqArg OptOutput "FILE") "Output to the FILE." - , Option ['m'] ["module"] + , Option "m" ["module"] (ReqArg OptModName "MODULE") "Specify the resulting module name. (required)" - , Option ['s'] ["symbol"] + , Option "s" ["symbol"] (ReqArg OptSymName "SYMBOL") "Specify the resulting symbol name." - , Option ['t'] ["mime-type"] + , Option "t" ["mime-type"] (ReqArg OptMIMEType "TYPE") "Specify the MIME Type of the file." - , Option ['e'] ["etag"] + , Option "e" ["etag"] (ReqArg OptETag "TAG") "Specify the ETag of the file." - , Option ['h'] ["help"] + , Option "h" ["help"] (NoArg OptHelp) "Print this message." ] @@ -106,13 +106,13 @@ main = do (opts, sources, errors) ← getOpt Permute options <$> getArgs generateHaskellSource ∷ [CmdOpt] → FilePath → IO () generateHaskellSource opts srcFile - = do modName ← getModuleName opts - symName ← getSymbolName opts modName - mimeType ← getMIMEType opts srcFile - lastMod ← getLastModified srcFile - input ← openInput srcFile - output ← openOutput opts - eTag ← getETag opts input + = do modName ← getModuleName opts + symName ← getSymbolName opts modName + mType ← getMIMEType opts srcFile + lastMod ← getLastModified srcFile + input ← openInput srcFile + output ← openOutput opts + tag ← getETag opts input let compParams = defaultCompressParams { compressLevel = bestCompression } gzippedData = compressWith compParams input @@ -122,23 +122,19 @@ generateHaskellSource opts srcFile rawB64 = B64.encode <$> Lazy.toChunks input gzippedB64 = B64.encode <$> Lazy.toChunks gzippedData - header ← mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod + header ← mkHeader srcFile originalLen gzippedLen useGZip mType tag lastMod let hsModule = mkModule modName symName imports decls imports = mkImports useGZip - decls = concat ([ resourceDecl symName useGZip - , entityTagDecl eTag - , lastModifiedDecl lastMod - , contentTypeDecl mimeType - ] - ⧺ - if useGZip then - [ gunzipAndPutChunkDecl - , dataDecl (name "gzippedData") gzippedB64 - ] - else - [ dataDecl (name "rawData") rawB64 ] - ) + decls = concat [ resourceDecl symName useGZip + , entityTagDecl tag + , lastModifiedDecl lastMod + , contentTypeDecl mType + , if useGZip then + dataDecl (name "gzippedData") gzippedB64 + else + dataDecl (name "rawData") rawB64 + ] hPutStrLn output header hPutStrLn output (prettyPrint hsModule) @@ -163,16 +159,9 @@ mkImports useGZip False False Nothing Nothing Nothing ] ⧺ - 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 - [] + [ ImportDecl (⊥) (ModuleName "Codec.Compression.GZip") + False False Nothing Nothing Nothing + | useGZip ] resourceDecl ∷ Name → Bool → [Decl] resourceDecl symName useGZip @@ -223,16 +212,18 @@ resGetGZipped = qualStmt $ If (var condVarName) (doE [ setContentEncodingGZipStmt - , outputStmt (var dataVarName) + , putChunksStmt (var dataVarName) ]) - (function "gunzipAndPutChunk" `app` var dataVarName) + (putChunksExp + (paren + (function "decompress" `app` var dataVarName))) resGetRaw ∷ Exp resGetRaw = function "Just" `app` paren (doE [ foundEntityStmt , setContentTypeStmt - , outputStmt (function "rawData") + , putChunksStmt (function "rawData") ]) setContentEncodingGZipStmt ∷ Stmt @@ -259,12 +250,14 @@ setContentTypeStmt function "contentType" ) -outputStmt ∷ Exp → Stmt -outputStmt e - = qualStmt $ function "putChunk" `app` e +putChunksExp ∷ Exp → Exp +putChunksExp = app (function "putChunks") + +putChunksStmt ∷ Exp → Stmt +putChunksStmt = qualStmt ∘ putChunksExp entityTagDecl ∷ ETag → [Decl] -entityTagDecl eTag +entityTagDecl tag = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "ETag"))) , nameBind (⊥) varName valExp ] @@ -273,12 +266,13 @@ entityTagDecl eTag varName = name "entityTag" valExp ∷ Exp - valExp = function "parseETag" `app` strE (eTagToString eTag) + valExp = function "parseETag" `app` strE (eTagToString tag) lastModifiedDecl ∷ UTCTime → [Decl] lastModifiedDecl lastMod = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "UTCTime"))) , nameBind (⊥) varName valExp + , InlineSig (⊥) False AlwaysActive (UnQual varName) ] where varName ∷ Name @@ -291,6 +285,7 @@ contentTypeDecl ∷ MIMEType → [Decl] contentTypeDecl mime = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "MIMEType"))) , nameBind (⊥) varName valExp + , InlineSig (⊥) False AlwaysActive (UnQual varName) ] where varName ∷ Name @@ -302,88 +297,11 @@ 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"))) , nameBind (⊥) varName valExp + , InlineSig (⊥) False AlwaysActive (UnQual varName) ] where valExp ∷ Exp @@ -398,7 +316,7 @@ dataDecl varName chunks strE (Strict.unpack chunk) mkHeader ∷ FilePath → Int64 → Int64 → Bool → MIMEType → ETag → UTCTime → IO String -mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod +mkHeader srcFile originalLen gzippedLen useGZip mType tag lastMod = do localLastMod ← utcToLocalZonedTime lastMod return $ concat [ "{- DO NOT EDIT THIS FILE.\n" @@ -415,8 +333,8 @@ mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod " Compression: gzip\n" else " Compression: disabled\n" - , " MIME Type: ", mimeTypeToString mimeType, "\n" - , " ETag: ", eTagToString eTag, "\n" + , " MIME Type: ", mimeTypeToString mType, "\n" + , " ETag: ", eTagToString tag, "\n" , " Last Modified: ", show localLastMod, "\n" , " -}" ] @@ -570,12 +488,15 @@ openOutput opts entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e" lastModified ∷ UTCTime + {-# NOINLINE lastModified #-} lastModified = read "2007-11-05 04:47:56.008366 UTC" contentType ∷ MIMEType + {-# NOINLINE contentType #-} contentType = parseMIMEType "image/png" rawData ∷ Lazy.ByteString + {-# NOINLINE rawData #-} rawData = Lazy.fromChunks [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRG..." , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAA..." @@ -585,9 +506,7 @@ openOutput opts 壓縮される場合は次のやうに變はる: ------------------------------------------------------------------------------ -- import に追加 - import qualified Blaze.ByteString.Builder.ByteString as BB - import Codec.Compression.Zlib.Internal - import qualified Data.Text as T + import Codec.Compression.Zlib -- ResourceDef は次のやうに變化 baz ∷ ResourceDef @@ -601,9 +520,9 @@ openOutput opts gzipAllowed ← isEncodingAcceptable "gzip" if gzipAllowed then do setContentEncoding ["gzip"] - putChunk gzippedData + putChunks gzippedData else - gunzipAndPutChunk gzippedData + putChunks (decompress gzippedData) , resHead = Just $ do foundEntity entityTag lastModified setContentType contentType @@ -612,17 +531,9 @@ openOutput opts , 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 + {-# NOINLINE gzippedData #-} gzippedData = Lazy.fromChunks [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQ..." , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGA..."