X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=ImplantFile.hs;h=67633f763e3db855c6b4d4f6c39eeb62bb56aa1b;hb=1f0a19cbad7c4b64a773d7f1c1ae9180448624e6;hp=b95c45508cd23d11a134451081edd61c4de45a42;hpb=ea2b7838f1b3d9d4923a220a601be2e04cc559d7;p=Lucu.git diff --git a/ImplantFile.hs b/ImplantFile.hs index b95c455..67633f7 100644 --- a/ImplantFile.hs +++ b/ImplantFile.hs @@ -1,16 +1,17 @@ {-# LANGUAGE - UnicodeSyntax + OverloadedStrings + , UnicodeSyntax #-} module Main where import Codec.Compression.GZip import Control.Applicative import Control.Monad import qualified Data.Ascii as A -import Data.Bits import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as Strict import qualified Data.ByteString.Lazy as Lazy import Data.Char +import Data.Digest.Pure.SHA import Data.Int import Data.Maybe import Data.Time @@ -99,7 +100,7 @@ main = do (opts, sources, errors) ← getOpt Permute options <$> getArgs exitWith $ ExitFailure 1 when (length sources ≥ 2) - $ error "too many input files." + $ fail "too many input files." generateHaskellSource opts (head sources) @@ -123,155 +124,144 @@ generateHaskellSource opts srcFile header ← mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod - let hsModule = mkModule (ModuleName modName) (name symName) imports decls + let hsModule = mkModule modName symName imports decls imports = mkImports useGZip - decls = concat [ declResourceDef - , entityTagDecl eTag - , lastModifiedDecl lastMod - , contentTypeDecl mimeType - , if useGZip then - dataDecl (name "gzippedData") gzippedB64 - else - dataDecl (name "rawData") rawB64 - ] - declResourceDef - = [ HsTypeSig (⊥) [HsIdent symName] - (HsQualType [] - (HsTyCon (UnQual (HsIdent "ResourceDef")))) - , HsFunBind [HsMatch (⊥) (HsIdent symName) - [] (HsUnGuardedRhs defResourceDef) []] - ] - - defResourceDef ∷ HsExp - defResourceDef - = let defResGet = if useGZip - then defResGetGZipped - else resGetRaw - in - (HsRecConstr (UnQual (HsIdent "ResourceDef")) - [ HsFieldUpdate (UnQual (HsIdent "resUsesNativeThread")) - (HsCon (UnQual (HsIdent "False"))) - , HsFieldUpdate (UnQual (HsIdent "resIsGreedy")) - (HsCon (UnQual (HsIdent "False"))) - , HsFieldUpdate (UnQual (HsIdent "resGet")) defResGet - , HsFieldUpdate (UnQual (HsIdent "resHead")) - (HsCon (UnQual (HsIdent "Nothing"))) - , HsFieldUpdate (UnQual (HsIdent "resPost")) - (HsCon (UnQual (HsIdent "Nothing"))) - , HsFieldUpdate (UnQual (HsIdent "resPut")) - (HsCon (UnQual (HsIdent "Nothing"))) - , HsFieldUpdate (UnQual (HsIdent "resDelete")) - (HsCon (UnQual (HsIdent "Nothing"))) - ] - ) - - defResGetGZipped ∷ HsExp - defResGetGZipped - = let doExp = HsDo [ foundEntityStmt - , setContentTypeStmt - , bindMustGunzip - , doConditionalOutput + decls = concat ([ resourceDecl symName useGZip + , entityTagDecl eTag + , lastModifiedDecl lastMod + , contentTypeDecl mimeType + ] + ⧺ + if useGZip then + [ gunzipAndPutChunkDecl + , dataDecl (name "gzippedData") gzippedB64 ] - bindMustGunzip - = HsGenerator (⊥) - (HsPVar (HsIdent "mustGunzip")) - (HsApp (HsApp (HsVar (UnQual (HsIdent "liftM"))) - (HsVar (UnQual (HsIdent "not")))) - (HsParen - (HsApp (HsVar (UnQual (HsIdent "isEncodingAcceptable"))) - (HsLit (HsString "gzip"))))) - doConditionalOutput - = HsQualifier - (HsIf (HsVar (UnQual (HsIdent "mustGunzip"))) - expOutputGunzipped - expOutputGZipped) - expOutputGunzipped - = (HsApp (HsVar (UnQual (HsIdent "outputLBS"))) - (HsParen - (HsApp (HsVar (UnQual (HsIdent "decompress"))) - (HsVar (UnQual (HsIdent "gzippedData")))))) - expOutputGZipped - = HsDo [ setContentEncodingGZipStmt - , outputStmt (var $ name "gzippedData") - ] - in - HsApp (HsCon (UnQual (HsIdent "Just"))) - (HsParen doExp) + else + [ dataDecl (name "rawData") rawB64 ] + ) hPutStrLn output header hPutStrLn output (prettyPrint hsModule) hClose output -mkModule ∷ ModuleName → Name → [ImportDecl] → [Decl] +mkModule ∷ ModuleName → Name → [ImportDecl] → [Decl] → Module mkModule modName symName imports decls - = let modPragma = [ LanguagePragma (⊥) [ name (show OverloadedStrings) - ] - ] - exports = [ EVar (UnQual symName) - ] + = let modPragma = [ LanguagePragma (⊥) [ name (show OverloadedStrings) ] ] + exports = [ EVar (UnQual symName) ] in Module (⊥) modName modPragma Nothing (Just exports) imports decls mkImports ∷ Bool → [ImportDecl] mkImports useGZip = [ ImportDecl (⊥) (ModuleName "Data.ByteString.Base64") - True False (Just (ModuleName "B64")) Nothing + True False Nothing (Just (ModuleName "B64")) Nothing , ImportDecl (⊥) (ModuleName "Data.ByteString.Lazy") - True False (Just (ModuleName "Lazy")) Nothing + True False Nothing (Just (ModuleName "Lazy")) Nothing , ImportDecl (⊥) (ModuleName "Data.Time") - False False Nothing Nothing + False False Nothing Nothing Nothing , ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu") - False False Nothing Nothing + False False Nothing Nothing Nothing ] ⧺ if useGZip then - [ ImportDecl (⊥) (ModuleName "Codec.Compression.GZip") - False False Nothing Nothing + [ 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 + = [ TypeSig (⊥) [symName] (TyCon (UnQual (name "ResourceDef"))) + , nameBind (⊥) symName valExp + ] + where + valExp ∷ Exp + valExp = RecUpdate (function "emptyResource") + [ FieldUpdate (UnQual (name "resGet" )) resGet + , FieldUpdate (UnQual (name "resHead")) resHead + ] + + resGet ∷ Exp + resGet | useGZip = resGetGZipped + | otherwise = resGetRaw + resHead ∷ Exp resHead - = infixApp (var $ name "Just") - (op $ name "$" ) - (doE [ foundEntityStmt - , setContentTypeStmt + = function "Just" `app` + paren (doE [ foundEntityStmt + , setContentTypeStmt + ]) + +resGetGZipped ∷ Exp +resGetGZipped + = function "Just" `app` + paren (doE [ foundEntityStmt + , setContentTypeStmt + , bindGZipStmt + , conditionalOutputStmt + ]) + where + condVarName ∷ Name + condVarName = name "gzipAllowed" + + dataVarName ∷ Name + dataVarName = name "gzippedData" + + bindGZipStmt ∷ Stmt + bindGZipStmt + = genStmt (⊥) + (pvar condVarName) + (function "isEncodingAcceptable" `app` strE "gzip") + + conditionalOutputStmt ∷ Stmt + conditionalOutputStmt + = qualStmt $ + If (var condVarName) + (doE [ setContentEncodingGZipStmt + , outputStmt (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" - ] + 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] + = qualStmt $ function "putChunk" `app` e entityTagDecl ∷ ETag → [Decl] entityTagDecl eTag @@ -283,10 +273,7 @@ entityTagDecl eTag varName = name "entityTag" valExp ∷ Exp - valExp = metaFunction "parseETag" [strE $ eTagToString eTag] - - eTagToString ∷ ETag → String - eTagToString = A.toString ∘ A.fromAsciiBuilder ∘ printETag + valExp = function "parseETag" `app` strE (eTagToString eTag) lastModifiedDecl ∷ UTCTime → [Decl] lastModifiedDecl lastMod @@ -298,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 @@ -310,11 +297,89 @@ contentTypeDecl mime varName = name "contentType" valExp ∷ Exp - valExp = metaFunction "parseMIMEType" [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"))) @@ -332,64 +397,80 @@ dataDecl varName chunks `app` strE (Strict.unpack chunk) -mkHeader ∷ FilePath → Int64 → Int64 → Bool → MIMEType → String → UTCTime → IO String +mkHeader ∷ FilePath → Int64 → Int64 → Bool → MIMEType → ETag → UTCTime → IO String mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod = do localLastMod ← utcToLocalZonedTime lastMod - return ("{- DO NOT EDIT THIS FILE.\n" ++ - " This file is automatically generated by the lucu-implant-file program.\n" ++ - "\n" ++ - " Source: " ++ (if srcFile ≡ "-" - then "(stdin)" - else srcFile) ++ "\n" ++ - " Original Length: " ++ show originalLen ++ " bytes\n" ++ - (if useGZip - then " Compressed Length: " ++ show gzippedLen ++ " bytes\n" ++ - " Compression: gzip\n" - else " Compression: disabled\n") ++ - " MIME Type: " ++ show mimeType ++ "\n" ++ - " ETag: " ++ eTag ++ "\n" ++ - " Last Modified: " ++ show localLastMod ++ "\n" ++ - " -}") - - -getModuleName ∷ [CmdOpt] → IO String + return $ concat + [ "{- DO NOT EDIT THIS FILE.\n" + , " This file is automatically generated by the lucu-implant-file program.\n" + , "\n" + , " Source: ", if srcFile ≡ "-" then + "(stdin)" + else + srcFile + , "\n" + , " Original Length: ", show originalLen, " bytes\n" + , if useGZip then + " Compressed Length: " ⧺ show gzippedLen ⧺ " bytes\n" ⧺ + " Compression: gzip\n" + else + " Compression: disabled\n" + , " MIME Type: ", mimeTypeToString mimeType, "\n" + , " ETag: ", eTagToString eTag, "\n" + , " Last Modified: ", show localLastMod, "\n" + , " -}" + ] + +eTagToString ∷ ETag → String +eTagToString = A.toString ∘ A.fromAsciiBuilder ∘ printETag + +mimeTypeToString ∷ MIMEType → String +mimeTypeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType + +getModuleName ∷ [CmdOpt] → IO ModuleName getModuleName opts - = let modNameOpts = filter (\ x → case x of - OptModName _ → True - _ → False) opts - in - case modNameOpts of - [] → error "a module name must be given." - (OptModName modName):[] → return modName - _ → error "too many --module options." - - -getSymbolName ∷ [CmdOpt] → String → IO String -getSymbolName opts modName - = let symNameOpts = filter (\ x → case x of - OptSymName _ → True - _ → False) opts - -- モジュール名をピリオドで分割した時の最後の項目の先頭文字を - -- 小文字にしたものを使ふ。 - defaultSymName = mkDefault modName - mkDefault = headToLower ∘ getLastComp - headToLower str = case str of - [] → error "module name must not be empty" - (x:xs) → toLower x : xs - getLastComp = reverse ∘ fst ∘ break (≡ '.') ∘ reverse - in - case symNameOpts of - [] → return defaultSymName - (OptSymName symName):[] → return symName - _ → error "too many --symbol options." + = case modNameOpts of + [] → 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 + OptModName _ → True + _ → False) 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." + where + symNameOpts ∷ [CmdOpt] + symNameOpts = filter (\ x → case x of + OptSymName _ → True + _ → False) opts + + defaultSymName ∷ Name + defaultSymName + = name $ headToLower $ getLastComp modName + headToLower ∷ String → String + headToLower [] = error "module name must not be empty" + headToLower (x:xs) = toLower x : xs + + getLastComp ∷ String → String + getLastComp = reverse ∘ fst ∘ break (≡ '.') ∘ reverse getMIMEType ∷ [CmdOpt] → FilePath → IO MIMEType getMIMEType opts srcFile = case mimeTypeOpts of - [] → return defaultType - (OptMIMEType ty):[] → return $ read ty - _ → error "too many --mime-type options." + [] → return defaultType + OptMIMEType ty:[] + → case A.fromChars ty of + Just a → return $ parseMIMEType a + Nothing → fail "MIME type must not contain any non-ASCII letters." + _ → fail "too many --mime-type options." where mimeTypeOpts ∷ [CmdOpt] mimeTypeOpts @@ -404,59 +485,49 @@ getMIMEType opts srcFile defaultType = fromMaybe octetStream $ guessTypeByFileName defaultExtensionMap srcFile - getLastModified ∷ FilePath → IO UTCTime getLastModified "-" = getCurrentTime getLastModified fpath = (posixSecondsToUTCTime ∘ fromRational ∘ toRational ∘ modificationTime) <$> getFileStatus fpath - -getETag ∷ [CmdOpt] → Lazy.ByteString → IO String +getETag ∷ [CmdOpt] → Lazy.ByteString → IO ETag getETag opts input - = let eTagOpts = filter (\ x → case x of - OptETag _ → True - _ → False) opts - in - case eTagOpts of - [] → fmap (mkETagFromInput ∘ fromJust) (getDigestByName "SHA1") - (OptETag str):[] → return str - _ → error "too many --etag options." + = case eTagOpts of + [] → return mkETagFromInput + OptETag str:[] → return $ strToETag str + _ → fail "too many --etag options." where - mkETagFromInput ∷ Digest → String - mkETagFromInput sha1 = "SHA-1:" ++ toHex (digestLBS sha1 input) - - toHex ∷ String → String - toHex = foldr ((++) ∘ hexByte ∘ fromEnum) "" - - hexByte ∷ Int → String - hexByte n - = [ hex4bit ((n `shiftR` 4) .&. 0x0F) - , hex4bit ( n .&. 0x0F) - ] + eTagOpts ∷ [CmdOpt] + eTagOpts = filter (\ x → case x of + OptETag _ → True + _ → False) opts - hex4bit ∷ Int → Char - hex4bit n - | n < 10 = chr $ ord '0' + n - | n < 16 = chr $ ord 'a' + n - 10 - | otherwise = (⊥) + mkETagFromInput ∷ ETag + mkETagFromInput + = strToETag $ "SHA-1:" ⧺ showDigest (sha1 input) + strToETag ∷ String → ETag + strToETag str + = case A.fromChars str of + Just a → strongETag a + Nothing → error "ETag must not contain any non-ASCII letters." openInput ∷ FilePath → IO Lazy.ByteString openInput "-" = Lazy.getContents openInput fpath = Lazy.readFile fpath - openOutput ∷ [CmdOpt] → IO Handle openOutput opts - = let outputOpts = filter (\ x → case x of - OptOutput _ → True - _ → False) opts - in - case outputOpts of - [] → return stdout - (OptOutput fpath):[] → openFile fpath WriteMode - _ → error "two many --output options." + = case outputOpts of + [] → return stdout + OptOutput fpath:[] → openFile fpath WriteMode + _ → fail "two many --output options." + where + outputOpts ∷ [CmdOpt] + outputOpts = filter (\ x → case x of + OptOutput _ → True + _ → False) opts {- 作られるファイルの例 (壓縮されない場合): @@ -469,7 +540,7 @@ openOutput opts Compressed Length: 453 bytes -- これは Compression: disabled の時には無い Compression: disabled MIME Type: image/png - ETag: d41d8cd98f00b204e9800998ecf8427e + ETag: "d41d8cd98f00b204e9800998ecf8427e" Last Modified: 2007-11-05 13:53:42.231882 JST -} {-# LANGUAGE OverloadedStrings #-} @@ -486,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 @@ -514,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 @@ -525,12 +598,12 @@ openOutput opts = Just $ do foundEntity entityTag lastModified setContentType contentType - gzip ← isEncodingAcceptable "gzip" - if gzip then + 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 @@ -538,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