X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=ImplantFile.hs;h=60f9b54755911f631c693a053129867bb836f687;hp=67633f763e3db855c6b4d4f6c39eeb62bb56aa1b;hb=b22e702f8161447a460847c6e6c97104c150534f;hpb=1789cee5ee66d2f7f2b26280be2f13eac4df7980 diff --git a/ImplantFile.hs b/ImplantFile.hs index 67633f7..60f9b54 100644 --- a/ImplantFile.hs +++ b/ImplantFile.hs @@ -1,34 +1,22 @@ {-# LANGUAGE - OverloadedStrings - , UnicodeSyntax + UnicodeSyntax #-} -module Main where -import Codec.Compression.GZip +module Main (main) where import Control.Applicative import Control.Monad import qualified Data.Ascii as A -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 -import Data.Time.Clock.POSIX -import Language.Haskell.Exts.Build -import Language.Haskell.Exts.Extension -import Language.Haskell.Exts.Pretty -import Language.Haskell.Exts.Syntax +import Language.Haskell.TH.PprLib +import Language.Haskell.TH.Syntax import Network.HTTP.Lucu.ETag +import Network.HTTP.Lucu.Implant +import Network.HTTP.Lucu.Implant.PrettyPrint import Network.HTTP.Lucu.MIMEType -import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap -import Network.HTTP.Lucu.MIMEType.Guess import Prelude.Unicode import System.Console.GetOpt import System.Environment import System.Exit -import System.Posix.Files import System.IO data CmdOpt @@ -41,27 +29,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." ] @@ -73,7 +61,7 @@ printUsage = do mapM_ putStrLn msg where msg = [ "" , "Description:" - , concat [ " lucu-implant-file is an utility that generates " + , concat [ " lucu-implant-file is an utility that generates " , "Haskell code containing an arbitrary file to " , "compile it directly into programs and serve it " , "statically with the Lucu HTTP server." @@ -104,373 +92,15 @@ main = do (opts, sources, errors) ← getOpt Permute options <$> getArgs generateHaskellSource opts (head sources) -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 - - let compParams = defaultCompressParams { compressLevel = bestCompression } - gzippedData = compressWith compParams input - originalLen = Lazy.length input - gzippedLen = Lazy.length gzippedData - useGZip = originalLen > gzippedLen - rawB64 = B64.encode <$> Lazy.toChunks input - gzippedB64 = B64.encode <$> Lazy.toChunks gzippedData - - header ← mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag 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 ] - ) - - hPutStrLn output header - hPutStrLn output (prettyPrint hsModule) - hClose output - -mkModule ∷ ModuleName → Name → [ImportDecl] → [Decl] → Module -mkModule modName symName imports decls - = 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 Nothing (Just (ModuleName "B64")) Nothing - , ImportDecl (⊥) (ModuleName "Data.ByteString.Lazy") - True False Nothing (Just (ModuleName "Lazy")) Nothing - , ImportDecl (⊥) (ModuleName "Data.Time") - False False Nothing Nothing Nothing - , ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu") - 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 - [] - -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 - = 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 - = function "Just" `app` - paren (doE [ foundEntityStmt - , setContentTypeStmt - , outputStmt (function "rawData") - ]) - -setContentEncodingGZipStmt ∷ Stmt -setContentEncodingGZipStmt - = qualStmt - ( function "setContentEncoding" - `app` - listE [ strE "gzip" ] - ) - -foundEntityStmt ∷ Stmt -foundEntityStmt - = qualStmt $ - metaFunction "foundEntity" - [ var (name "entityTag") - , var (name "lastModified") - ] - -setContentTypeStmt ∷ Stmt -setContentTypeStmt - = qualStmt - ( function "setContentType" - `app` - function "contentType" - ) - -outputStmt ∷ Exp → Stmt -outputStmt e - = qualStmt $ function "putChunk" `app` e - -entityTagDecl ∷ ETag → [Decl] -entityTagDecl eTag - = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "ETag"))) - , nameBind (⊥) varName valExp - ] - where - varName ∷ Name - varName = name "entityTag" - - valExp ∷ Exp - valExp = function "parseETag" `app` strE (eTagToString eTag) - -lastModifiedDecl ∷ UTCTime → [Decl] -lastModifiedDecl lastMod - = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "UTCTime"))) - , nameBind (⊥) varName valExp - ] - where - varName ∷ Name - varName = name "lastModified" - - valExp ∷ Exp - valExp = function "read" `app` strE (show lastMod) - -contentTypeDecl ∷ MIMEType → [Decl] -contentTypeDecl mime - = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "MIMEType"))) - , nameBind (⊥) varName valExp - ] - where - varName ∷ Name - varName = name "contentType" - - valExp ∷ Exp - 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"))) - , nameBind (⊥) varName valExp - ] - where - valExp ∷ Exp - valExp = qvar (ModuleName "Lazy") (name "fromChunks") - `app` - listE (chunkToExp <$> chunks) - - chunkToExp ∷ Strict.ByteString → Exp - chunkToExp chunk - = qvar (ModuleName "B64") (name "decodeLenient") - `app` - strE (Strict.unpack chunk) - -mkHeader ∷ FilePath → Int64 → Int64 → Bool → MIMEType → ETag → UTCTime → IO String -mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod - = do localLastMod ← utcToLocalZonedTime lastMod - 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 - = 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 +getMIMEType ∷ [CmdOpt] → Maybe MIMEType +getMIMEType opts = case mimeTypeOpts of - [] → return defaultType + [] → Nothing 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." + Just a → Just $ parseMIMEType a + Nothing → error "MIME types must not contain any non-ASCII letters." + _ → error "too many --mime-type options." where mimeTypeOpts ∷ [CmdOpt] mimeTypeOpts @@ -478,50 +108,31 @@ getMIMEType opts srcFile OptMIMEType _ → True _ → False) opts - octetStream ∷ MIMEType - octetStream = parseMIMEType "application/octet-stream" - - defaultType ∷ MIMEType - 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 ETag -getETag opts input +getETag ∷ [CmdOpt] → Maybe ETag +getETag opts = case eTagOpts of - [] → return mkETagFromInput - OptETag str:[] → return $ strToETag str - _ → fail "too many --etag options." + [] → Nothing + OptETag str:[] → Just $ strToETag str + _ → error "too many --etag options." where eTagOpts ∷ [CmdOpt] eTagOpts = filter (\ x → case x of OptETag _ → True _ → False) opts - 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 = case outputOpts of [] → return stdout - OptOutput fpath:[] → openFile fpath WriteMode + OptOutput fpath:[] → do h ← openFile fpath WriteMode + hSetEncoding h utf8 + return h _ → fail "two many --output options." where outputOpts ∷ [CmdOpt] @@ -529,103 +140,51 @@ openOutput opts OptOutput _ → True _ → False) opts -{- - 作られるファイルの例 (壓縮されない場合): - ------------------------------------------------------------------------------ - {- DO NOT EDIT THIS FILE. - This file is automatically generated by the lucu-implant-file program. - - Source: baz.png - Original Length: 302 bytes - Compressed Length: 453 bytes -- これは Compression: disabled の時には無い - Compression: disabled - MIME Type: image/png - ETag: "d41d8cd98f00b204e9800998ecf8427e" - Last Modified: 2007-11-05 13:53:42.231882 JST - -} - {-# LANGUAGE OverloadedStrings #-} - module Foo.Bar.Baz (baz) where - import qualified Data.ByteString.Base64 as B64 - import qualified Data.ByteString.Lazy as Lazy - import Data.Time - import Network.HTTP.Lucu - - baz ∷ ResourceDef - baz = ResourceDef { - resUsesNativeThread = False - , resIsGreedy = False - , resGet - = Just $ do foundEntity entityTag lastModified - setContentType contentType - putChunk rawData - , resHead - = Just $ do foundEntity entityTag lastModified - setContentType contentType - , resPost = Nothing - , resPut = Nothing - , resDelete = Nothing - } - - entityTag ∷ ETag - entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e" - - lastModified ∷ UTCTime - lastModified = read "2007-11-05 04:47:56.008366 UTC" - - contentType ∷ MIMEType - contentType = parseMIMEType "image/png" +getModuleName ∷ [CmdOpt] → ModName +getModuleName opts + = case modNameOpts of + [] → error "a module name must be given." + OptModName name:[] → mkModName name + _ → error "too many --module options." + where + modNameOpts ∷ [CmdOpt] + modNameOpts = filter (\ x → case x of + OptModName _ → True + _ → False) opts - rawData ∷ Lazy.ByteString - rawData = Lazy.fromChunks - [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRG..." - , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAA..." - ] - ------------------------------------------------------------------------------ +getSymbolName ∷ [CmdOpt] → Maybe Name +getSymbolName opts + = case symNameOpts of + [] → Nothing + OptSymName name:[] → Just $ mkName name + _ → fail "too many --symbol options." + where + symNameOpts ∷ [CmdOpt] + symNameOpts = filter (\ x → case x of + OptSymName _ → True + _ → False) opts - 壓縮される場合は次のやうに變はる: - ------------------------------------------------------------------------------ - -- import に追加 - import qualified Blaze.ByteString.Builder.ByteString as BB - import Codec.Compression.Zlib.Internal - import qualified Data.Text as T +defaultSymName ∷ ModName → Name +defaultSymName = headToLower ∘ getLastComp + where + headToLower ∷ String → Name + headToLower [] = error "module name must not be empty" + headToLower (x:xs) = mkName (toLower x:xs) - -- ResourceDef は次のやうに變化 - baz ∷ ResourceDef - baz = ResourceDef { - resUsesNativeThread = False - , resIsGreedy = False - , resGet - = Just $ do foundEntity entityTag lastModified - setContentType contentType + getLastComp ∷ ModName → String + getLastComp = reverse ∘ fst ∘ break (≡ '.') ∘ reverse ∘ modString - gzipAllowed ← isEncodingAcceptable "gzip" - if gzipAllowed then - do setContentEncoding ["gzip"] - putChunk gzippedData - else - gunzipAndPutChunk gzippedData - , resHead - = Just $ do foundEntity entityTag lastModified - setContentType contentType - , resPost = Nothing - , resPut = Nothing - , resDelete = Nothing - } +generateHaskellSource ∷ [CmdOpt] → FilePath → IO () +generateHaskellSource opts srcFile + = do i ← openInput srcFile (getMIMEType opts) (getETag opts) + o ← openOutput opts + doc ← pprInput i modName symName + hPutStrLn o ∘ show $ to_HPJ_Doc doc + hClose o + where + modName ∷ ModName + modName = getModuleName opts - -- 追加 - 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 - gzippedData = Lazy.fromChunks - [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQ..." - , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGA..." - ] - ------------------------------------------------------------------------------ - -} + symName ∷ Name + symName = fromMaybe (defaultSymName modName) + $ getSymbolName opts