import Codec.Binary.Base64 import Codec.Compression.GZip import Control.Monad import Data.Bits import qualified Data.ByteString.Lazy as Lazy (ByteString) import qualified Data.ByteString.Lazy as L hiding (ByteString) import Data.Char import Data.Int import Data.Maybe import Data.Time import Data.Time.Clock.POSIX 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 OpenSSL import OpenSSL.EVP.Digest import System.Console.GetOpt import System.Environment import System.Exit import System.Posix.Files import System.IO 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 = withOpenSSL $ 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 compParams = defaultCompressParams { compressLevel = BestCompression } gzippedData = compressWith compParams 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 let 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") True (Just (Module "L")) Nothing , HsImportDecl undefined (Module "Data.Maybe") False Nothing Nothing , HsImportDecl undefined (Module "Data.Time") False Nothing Nothing , HsImportDecl undefined (Module "Network.HTTP.Lucu") 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 "outputLBS"))) (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 "outputLBS"))) (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 "outputLBS"))) (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 "UTCTime")))) , HsFunBind [HsMatch undefined (HsIdent "lastModified") [] (HsUnGuardedRhs defLastModified) []] ] defLastModified :: HsExp defLastModified = HsApp (HsVar (UnQual (HsIdent "read"))) (HsLit (HsString $ show lastMod)) 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 (Qual (Module "L") (HsIdent "ByteString")))) , HsFunBind [HsMatch undefined (HsIdent "gzippedData") [] (HsUnGuardedRhs defGZippedData) []] ] defGZippedData :: HsExp defGZippedData = HsApp (HsVar (Qual (Module "L") (HsIdent "pack"))) (HsParen (HsApp (HsVar (UnQual (HsIdent "fromJust"))) (HsParen (HsApp (HsVar (UnQual (HsIdent "decode"))) (HsLit (HsString gzippedB64)))))) declRawData :: [HsDecl] declRawData = [ HsTypeSig undefined [HsIdent "rawData"] (HsQualType [] (HsTyCon (Qual (Module "L") (HsIdent "ByteString")))) , HsFunBind [HsMatch undefined (HsIdent "rawData") [] (HsUnGuardedRhs defRawData) []] ] defRawData :: HsExp defRawData = HsApp (HsVar (Qual (Module "L") (HsIdent "pack"))) (HsParen (HsApp (HsVar (UnQual (HsIdent "fromJust"))) (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 -> 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 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." 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 UTCTime getLastModified "-" = getCurrentTime getLastModified fpath = getFileStatus fpath >>= return . posixSecondsToUTCTime . fromRational . toRational . modificationTime getETag :: [CmdOpt] -> Lazy.ByteString -> IO String getETag opts input = let eTagOpts = filter (\ x -> case x of OptETag _ -> True _ -> False) opts in case eTagOpts of [] -> getDigestByName "SHA1" >>= return . mkETagFromInput . fromJust (OptETag str):[] -> return str _ -> error "too many --etag options." where mkETagFromInput :: Digest -> String mkETagFromInput sha1 = "SHA-1:" ++ (toHex $ digestLBS sha1 input) toHex :: [Char] -> String toHex [] = "" toHex (x:xs) = hexByte (fromEnum 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) | otherwise = undefined openInput :: FilePath -> IO Lazy.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: 2007-11-05 13:53:42.231882 JST -} module Foo.Bar.Baz (baz) where import Codec.Binary.Base64 import qualified Data.ByteString.Lazy as L import Data.Maybe import Data.Time import Network.HTTP.Lucu baz :: ResourceDef baz = ResourceDef { resUsesNativeThread = False , resIsGreedy = False , resGet = Just (do foundEntity entityTag lastModified setContentType contentType outputLBS rawData) , resHead = Nothing , 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 = read "image/png" rawData :: L.ByteString rawData = L.pack (fromJust (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 outputLBS (decompress gzippedData) else do setContentEncoding ["gzip"] outputLBS gzippedData , resHead = Nothing , resPost = Nothing , resPut = Nothing , resDelete = Nothing } -- rawData の代はりに gzippedData gzippedData :: L.ByteString gzippedData = L.pack (fromJust (decode "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAAB...")) ------------------------------------------------------------------------------ -}