Lucu-0.1: ImplantFile.hs
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 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
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..."))
------------------------------------------------------------------------------
-}