X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=ImplantFile.hs;h=c253c2abd05395b3311dba1fd9d3ed999d37d89b;hp=0e91f1c6bdbb7bd2b5667d68790325ad5ad88a95;hb=48bc90d66a45c0b9b6f52272b46cf2949ed802e3;hpb=558205096e7f51da7018458d173584ac31808082 diff --git a/ImplantFile.hs b/ImplantFile.hs index 0e91f1c..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,14 +122,14 @@ 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 + , entityTagDecl tag , lastModifiedDecl lastMod - , contentTypeDecl mimeType + , contentTypeDecl mType , if useGZip then dataDecl (name "gzippedData") gzippedB64 else @@ -159,12 +159,9 @@ mkImports useGZip False False Nothing Nothing Nothing ] ⧺ - if useGZip then - [ ImportDecl (⊥) (ModuleName "Codec.Compression.GZip") - False False Nothing Nothing Nothing - ] - else - [] + [ ImportDecl (⊥) (ModuleName "Codec.Compression.GZip") + False False Nothing Nothing Nothing + | useGZip ] resourceDecl ∷ Name → Bool → [Decl] resourceDecl symName useGZip @@ -173,7 +170,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 ] @@ -184,21 +181,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" @@ -210,54 +205,59 @@ resGetGZipped bindGZipStmt = genStmt (⊥) (pvar condVarName) - (metaFunction "isEncodingAcceptable" [strE "gzip"]) + (function "isEncodingAcceptable" `app` strE "gzip") conditionalOutputStmt ∷ Stmt conditionalOutputStmt = qualStmt $ If (var condVarName) (doE [ setContentEncodingGZipStmt - , outputStmt (var dataVarName) + , putChunksStmt (var dataVarName) ]) - (metaFunction "output" - [paren (metaFunction "decompress" [var dataVarName])]) + (putChunksExp + (paren + (function "decompress" `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 + , putChunksStmt (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] +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 ] @@ -266,31 +266,33 @@ entityTagDecl eTag varName = name "entityTag" valExp ∷ Exp - valExp = metaFunction "parseETag" [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 varName = name "lastModified" valExp ∷ Exp - valExp = metaFunction "read" [strE $ show lastMod] + valExp = function "read" `app` strE (show lastMod) contentTypeDecl ∷ MIMEType → [Decl] contentTypeDecl mime = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "MIMEType"))) , nameBind (⊥) varName valExp + , InlineSig (⊥) False AlwaysActive (UnQual varName) ] where varName ∷ Name 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 @@ -299,6 +301,7 @@ 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 @@ -313,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" @@ -330,8 +333,8 @@ mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod " Compression: gzip\n" else " Compression: disabled\n" - , " MIME Type: ", show mimeType, "\n" - , " ETag: ", eTagToString eTag, "\n" + , " MIME Type: ", mimeTypeToString mType, "\n" + , " ETag: ", eTagToString tag, "\n" , " Last Modified: ", show localLastMod, "\n" , " -}" ] @@ -339,12 +342,15 @@ 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 - [] → 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 @@ -354,9 +360,9 @@ getModuleName opts 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 @@ -378,7 +384,7 @@ getMIMEType ∷ [CmdOpt] → FilePath → IO MIMEType 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." @@ -406,9 +412,9 @@ getLastModified fpath = (posixSecondsToUTCTime ∘ fromRational ∘ toRational 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 @@ -432,9 +438,9 @@ openInput fpath = Lazy.readFile fpath 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 @@ -469,7 +475,7 @@ openOutput opts , resGet = Just $ do foundEntity entityTag lastModified setContentType contentType - output rawData + putChunk rawData , resHead = Just $ do foundEntity entityTag lastModified setContentType contentType @@ -482,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..." @@ -497,7 +506,7 @@ openOutput opts 壓縮される場合は次のやうに變はる: ------------------------------------------------------------------------------ -- import に追加 - import Codec.Compression.GZip + import Codec.Compression.Zlib -- ResourceDef は次のやうに變化 baz ∷ ResourceDef @@ -511,9 +520,9 @@ openOutput opts gzipAllowed ← isEncodingAcceptable "gzip" if gzipAllowed then do setContentEncoding ["gzip"] - output gzippedData + putChunks gzippedData else - output (decompress gzippedData) + putChunks (decompress gzippedData) , resHead = Just $ do foundEntity entityTag lastModified setContentType contentType @@ -521,9 +530,10 @@ openOutput opts , resPut = Nothing , resDelete = Nothing } - + -- rawData の代はりに gzippedData gzippedData ∷ Lazy.ByteString + {-# NOINLINE gzippedData #-} gzippedData = Lazy.fromChunks [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQ..." , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGA..."