--- /dev/null
+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...")
+ ------------------------------------------------------------------------------
+ -}
projects / Lucu.git / commitdiff