From e0fbd70ccc0690e5f5723db87fdd2bab371a33f2 Mon Sep 17 00:00:00 2001 From: pho Date: Wed, 3 Oct 2007 17:12:34 +0900 Subject: [PATCH] Implemented the lucu-implant-file but not tested it well. darcs-hash:20071003081234-62b54-696e6b3bf414040468512e62e3c96bb12c6ddbd7.gz --- ImplantFile.hs | 524 +++++++++++++++++++++++++++++++++++++++++++++++++ Lucu.cabal | 10 +- 2 files changed, 533 insertions(+), 1 deletion(-) create mode 100644 ImplantFile.hs diff --git a/ImplantFile.hs b/ImplantFile.hs new file mode 100644 index 0000000..29c1145 --- /dev/null +++ b/ImplantFile.hs @@ -0,0 +1,524 @@ +import Codec.Binary.Base64 +import Codec.Compression.GZip +import Control.Monad +import Data.Bits +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as L +import Data.Char +import Data.Digest.SHA1 +import Data.Int +import Data.Maybe +import Data.Word +import Language.Haskell.Pretty +import Language.Haskell.Syntax +import Network.HTTP.Lucu.MIMEType +import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap +import Network.HTTP.Lucu.MIMEType.Guess +import System.Console.GetOpt +import System.Directory +import System.Environment +import System.Exit +import System.IO +import System.Time + +data CmdOpt + = OptOutput FilePath + | OptModName String + | OptSymName String + | OptMIMEType String + | OptETag String + | OptHelp + deriving (Eq, Show) + + +options :: [OptDescr CmdOpt] +options = [ Option ['o'] ["output"] + (ReqArg OptOutput "FILE") + "Output to the FILE." + + , Option ['m'] ["module"] + (ReqArg OptModName "MODULE") + "Specify the resulting module name. (required)" + + , Option ['s'] ["symbol"] + (ReqArg OptSymName "SYMBOL") + "Specify the resulting symbol name." + + , Option ['t'] ["mime-type"] + (ReqArg OptMIMEType "TYPE") + "Specify the MIME Type of the file." + + , Option ['e'] ["etag"] + (ReqArg OptETag "TAG") + "Specify the ETag of the file." + + , Option ['h'] ["help"] + (NoArg OptHelp) + "Print this message." + ] + + +printUsage :: IO () +printUsage = do putStrLn "" + putStrLn "Description:" + putStrLn (" 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.") + putStrLn "" + putStrLn "Usage:" + putStrLn " lucu-implant-file [OPTIONS...] FILE" + putStrLn "" + putStr $ usageInfo "Options:" options + putStrLn "" + + +main :: IO () +main = do (opts, sources, errors) <- return . getOpt Permute options =<< getArgs + + when (not $ null errors) + $ do mapM_ putStr errors + exitWith $ ExitFailure 1 + + when (any (\ x -> x == OptHelp) opts) + $ do printUsage + exitWith ExitSuccess + + when (null sources) + $ do printUsage + exitWith $ ExitFailure 1 + + when (length sources >= 2) + $ error "too many input files." + + 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 gzippedData = compressWith BestCompression input + originalLen = L.length input + gzippedLen = L.length gzippedData + useGZip = originalLen > gzippedLen + rawB64 = encode $ L.unpack input + gzippedB64 = encode $ L.unpack gzippedData + + header = mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod + + hsModule = HsModule undefined (Module modName) (Just exports) imports decls + exports = [HsEVar (UnQual (HsIdent symName))] + imports = [ HsImportDecl undefined (Module "Codec.Binary.Base64") + False Nothing Nothing + , HsImportDecl undefined (Module "Data.ByteString.Lazy") + False Nothing (Just (False, [HsIVar (HsIdent "ByteString")])) + , HsImportDecl undefined (Module "Data.ByteString.Lazy") + True (Just (Module "L")) Nothing + , HsImportDecl undefined (Module "Network.HTTP.Lucu") + False Nothing Nothing + , HsImportDecl undefined (Module "System.Time") + False Nothing Nothing + ] + ++ + (if useGZip then + [ HsImportDecl undefined (Module "Control.Monad") + False Nothing Nothing + , HsImportDecl undefined (Module "Codec.Compression.GZip") + False Nothing Nothing + ] + else + []) + decls = declResourceDef + ++ + declEntityTag + ++ + declLastModified + ++ + declContentType + ++ + (if useGZip + then declGZippedData + else declRawData) + + declResourceDef :: [HsDecl] + declResourceDef + = [ HsTypeSig undefined [HsIdent symName] + (HsQualType [] + (HsTyCon (UnQual (HsIdent "ResourceDef")))) + , HsFunBind [HsMatch undefined (HsIdent symName) + [] (HsUnGuardedRhs defResourceDef) []] + ] + + defResourceDef :: HsExp + defResourceDef + = let defResGet = if useGZip + then defResGetGZipped + else defResGetRaw + 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 [ doFoundEntity + , doSetContentType + , bindMustGunzip + , doConditionalOutput + ] + doFoundEntity + = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity"))) + (HsVar (UnQual (HsIdent "entityTag")))) + (HsVar (UnQual (HsIdent "lastModified")))) + doSetContentType + = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType"))) + (HsVar (UnQual (HsIdent "contentType")))) + bindMustGunzip + = HsGenerator undefined + (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 "outputBS"))) + (HsParen + (HsApp (HsVar (UnQual (HsIdent "decompress"))) + (HsVar (UnQual (HsIdent "gzippedData")))))) + expOutputGZipped + = HsDo [ doSetContentEncodingGZip + , doOutputGZipped + ] + doSetContentEncodingGZip + = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentEncoding"))) + (HsList [HsLit (HsString "gzip")])) + doOutputGZipped + = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputBS"))) + (HsVar (UnQual (HsIdent "gzippedData")))) + in + HsApp (HsCon (UnQual (HsIdent "Just"))) + (HsParen doExp) + + defResGetRaw :: HsExp + defResGetRaw + = let doExp = HsDo [ doFoundEntity + , doSetContentType + , doOutputRawData + ] + doFoundEntity + = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity"))) + (HsVar (UnQual (HsIdent "entityTag")))) + (HsVar (UnQual (HsIdent "lastModified")))) + doSetContentType + = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType"))) + (HsVar (UnQual (HsIdent "contentType")))) + doOutputRawData + = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputBS"))) + (HsVar (UnQual (HsIdent "rawData")))) + in + HsApp (HsCon (UnQual (HsIdent "Just"))) + (HsParen doExp) + + declEntityTag :: [HsDecl] + declEntityTag + = [ HsTypeSig undefined [HsIdent "entityTag"] + (HsQualType [] + (HsTyCon (UnQual (HsIdent "ETag")))) + , HsFunBind [HsMatch undefined (HsIdent "entityTag") + [] (HsUnGuardedRhs defEntityTag) []] + ] + + defEntityTag :: HsExp + defEntityTag + = HsApp (HsVar (UnQual (HsIdent "strongETag"))) + (HsLit (HsString eTag)) + + declLastModified :: [HsDecl] + declLastModified + = [ HsTypeSig undefined [HsIdent "lastModified"] + (HsQualType [] + (HsTyCon (UnQual (HsIdent "ClockTime")))) + , HsFunBind [HsMatch undefined (HsIdent "lastModified") + [] (HsUnGuardedRhs defLastModified) []] + ] + + defLastModified :: HsExp + defLastModified + = let TOD a b = lastMod + in + (HsApp (HsApp (HsCon (UnQual (HsIdent "TOD"))) + (HsLit (HsInt a))) + (HsLit (HsInt b))) + + + declContentType :: [HsDecl] + declContentType + = [ HsTypeSig undefined [HsIdent "contentType"] + (HsQualType [] + (HsTyCon (UnQual (HsIdent "MIMEType")))) + , HsFunBind [HsMatch undefined (HsIdent "contentType") + [] (HsUnGuardedRhs defContentType) []] + ] + + defContentType :: HsExp + defContentType + = HsApp (HsVar (UnQual (HsIdent "read"))) + (HsLit (HsString $ show mimeType)) + + declGZippedData :: [HsDecl] + declGZippedData + = [ HsTypeSig undefined [HsIdent "gzippedData"] + (HsQualType [] + (HsTyCon (UnQual (HsIdent "ByteString")))) + , HsFunBind [HsMatch undefined (HsIdent "gzippedData") + [] (HsUnGuardedRhs defGZippedData) []] + ] + + defGZippedData :: HsExp + defGZippedData + = HsApp (HsVar (Qual (Module "L") (HsIdent "pack"))) + (HsParen + (HsApp (HsVar (UnQual (HsIdent "decode"))) + (HsLit (HsString gzippedB64)))) + + declRawData :: [HsDecl] + declRawData + = [ HsTypeSig undefined [HsIdent "rawData"] + (HsQualType [] + (HsTyCon (UnQual (HsIdent "ByteString")))) + , HsFunBind [HsMatch undefined (HsIdent "rawData") + [] (HsUnGuardedRhs defRawData) []] + ] + + defRawData :: HsExp + defRawData + = HsApp (HsVar (Qual (Module "L") (HsIdent "pack"))) + (HsParen + (HsApp (HsVar (UnQual (HsIdent "decode"))) + (HsLit (HsString rawB64)))) + + hPutStrLn output header + hPutStrLn output (prettyPrint hsModule) + hClose output + + +mkHeader :: FilePath -> Int64 -> Int64 -> Bool -> MIMEType -> String -> ClockTime -> String +mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod + = "{- 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 lastMod ++ "\n" ++ + " -}" + + +getModuleName :: [CmdOpt] -> IO String +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 + (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." + + +getMIMEType :: [CmdOpt] -> FilePath -> IO MIMEType +getMIMEType opts srcFile + = let mimeTypeOpts = filter (\ x -> case x of + OptMIMEType _ -> True + _ -> False) opts + defaultType = fromMaybe (read "application/octet-stream") + $ guessTypeByFileName defaultExtensionMap srcFile + in + case mimeTypeOpts of + [] -> return defaultType + (OptMIMEType mimeType):[] -> return $ read mimeType + _ -> error "too many --mime-type options." + + +getLastModified :: FilePath -> IO ClockTime +getLastModified "-" = getClockTime +getLastModified fpath = getModificationTime fpath + + +getETag :: [CmdOpt] -> ByteString -> IO String +getETag opts input + = let eTagOpts = filter (\ x -> case x of + OptETag _ -> True + _ -> False) opts + in + case eTagOpts of + [] -> return mkETagFromInput + (OptETag str):[] -> return str + _ -> error "too many --etag options." + where + mkETagFromInput :: String + mkETagFromInput = "SHA-1:" ++ (toHex $ hash $ L.unpack input) + + toHex :: [Word8] -> String + toHex [] = "" + toHex (x:xs) = hexByte (fromIntegral x) ++ toHex xs + + hexByte :: Int -> String + hexByte n + = hex4bit ((n `shiftR` 4) .&. 0x0F) : hex4bit (n .&. 0x0F) : [] + + hex4bit :: Int -> Char + hex4bit n + | n < 10 = (chr $ ord '0' + n ) + | n < 16 = (chr $ ord 'a' + n - 10) + + +openInput :: FilePath -> IO ByteString +openInput "-" = L.getContents +openInput fpath = L.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." + + +{- + 作られるファイルの例 (壓縮されない場合): + ------------------------------------------------------------------------------ + {- 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: Wed, 03 Oct 2007 00:55:45 JST + -} + module Foo.Bar.Baz (baz) where + import Codec.Binary.Base64 + import Data.ByteString.Lazy (ByteString) + import qualified Data.ByteString.Lazy as L + import Network.HTTP.Lucu + import System.Time + + baz :: ResourceDef + baz = ResourceDef { + resUsesNativeThread = False + , resIsGreedy = False + , resGet + = Just (do foundEntity entityTag lastModified + setContentType contentType + outputBS rawData) + , resHead = Nothing + , resPost = Nothing + , resPut = Nothing + , resDelete = Nothing + } + + entityTag :: ETag + entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e" + + lastModified :: ClockTime + lastModified = TOD 1191340545 0 + + contentType :: MIMEType + contentType = read "image/png" + + rawData :: ByteString + rawData = L.pack (decode "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRGlzdHJ...") + ------------------------------------------------------------------------------ + + 壓縮される場合は次のやうに變はる: + ------------------------------------------------------------------------------ + -- import に追加 + import Control.Monad + import Codec.Compression.GZip + + -- ResourceDef は次のやうに變化 + baz :: ResourceDef + baz = ResourceDef { + resUsesNativeThread = False + , resIsGreedy = False + , resGet + = Just (do foundEntity entityTag lastModified + setContentType contentType + + mustGunzip <- liftM not (isEncodingAcceptable "gzip") + if mustGunzip then + outputBS (decompress gzippedData) + else + do setContentEncoding ["gzip"] + outputBS gzippedData + , resHead = Nothing + , resPost = Nothing + , resPut = Nothing + , resDelete = Nothing + } + + -- rawData の代はりに gzippedData + gzippedData :: ByteString + gzippedData = L.pack (decode "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAAB...") + ------------------------------------------------------------------------------ + -} diff --git a/Lucu.cabal b/Lucu.cabal index 8eb1c62..5006ea4 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -17,7 +17,7 @@ Homepage: http://ccm.sherry.jp/lucu/ Category: Network Tested-With: GHC == 6.6.1 Build-Depends: - base, mtl, network, stm, hxt, haskell-src, unix + base, mtl, network, stm, hxt, haskell-src, unix, zlib, Crypto Exposed-Modules: Network.HTTP.Lucu Network.HTTP.Lucu.Abortion @@ -60,6 +60,14 @@ ghc-options: -funbox-strict-fields -O3 +Executable: lucu-implant-file +Main-Is: ImplantFile.hs +ghc-options: + -fglasgow-exts + -fwarn-missing-signatures + -fwarn-unused-imports + -funbox-strict-fields + -O3 --Executable: HelloWorld --Main-Is: HelloWorld.hs -- 2.40.0