X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=ImplantFile.hs;h=60f9b54755911f631c693a053129867bb836f687;hp=22fafeaa5acd35d413c827701265aead3a0d2349;hb=b22e702f8161447a460847c6e6c97104c150534f;hpb=4ff7f4b48f372e1cbea63873c5604ee3b4b56d09 diff --git a/ImplantFile.hs b/ImplantFile.hs index 22fafea..60f9b54 100644 --- a/ImplantFile.hs +++ b/ImplantFile.hs @@ -1,26 +1,23 @@ -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.Digest.SHA1 -import Data.Int -import Data.Maybe -import Data.Time -import Data.Time.Clock.POSIX -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.Environment -import System.Exit -import System.Posix.Files -import System.IO +{-# LANGUAGE + UnicodeSyntax + #-} +module Main (main) where +import Control.Applicative +import Control.Monad +import qualified Data.Ascii as A +import Data.Char +import Data.Maybe +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 Prelude.Unicode +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.IO data CmdOpt = OptOutput FilePath @@ -31,493 +28,163 @@ data CmdOpt | OptHelp deriving (Eq, Show) - -options :: [OptDescr CmdOpt] -options = [ Option ['o'] ["output"] +options ∷ [OptDescr CmdOpt] +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." ] - -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 "" +printUsage ∷ IO () +printUsage = do mapM_ putStrLn msg 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 + where + msg = [ "" + , "Description:" + , 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." + ] + , "" + , "Usage:" + , " lucu-implant-file [OPTIONS...] FILE" + , "" + ] + +main ∷ IO () +main = do (opts, sources, errors) ← getOpt Permute options <$> getArgs + + unless (null errors) + $ do mapM_ putStr errors + exitWith $ ExitFailure 1 + + when (any (≡ OptHelp) opts) + $ do printUsage + exitWith ExitSuccess when (null sources) - $ do printUsage - exitWith $ ExitFailure 1 + $ do printUsage + exitWith $ ExitFailure 1 - when (length sources >= 2) - $ error "too many input files." + when (length sources ≥ 2) + $ fail "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.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 "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 "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 - [] -> return mkETagFromInput - (OptETag str):[] -> return str - _ -> error "too many --etag options." +getMIMEType ∷ [CmdOpt] → Maybe MIMEType +getMIMEType opts + = case mimeTypeOpts of + [] → Nothing + OptMIMEType ty:[] + → case A.fromChars ty of + Just a → Just $ parseMIMEType a + Nothing → error "MIME types must not contain any non-ASCII letters." + _ → error "too many --mime-type 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) - | otherwise = undefined - - -openInput :: FilePath -> IO Lazy.ByteString -openInput "-" = L.getContents -openInput fpath = L.readFile fpath - - -openOutput :: [CmdOpt] -> IO Handle + mimeTypeOpts ∷ [CmdOpt] + mimeTypeOpts + = filter (\ x → case x of + OptMIMEType _ → True + _ → False) opts + +getETag ∷ [CmdOpt] → Maybe ETag +getETag opts + = case eTagOpts of + [] → Nothing + OptETag str:[] → Just $ strToETag str + _ → error "too many --etag options." + where + eTagOpts ∷ [CmdOpt] + eTagOpts = filter (\ x → case x of + OptETag _ → True + _ → False) opts + + strToETag ∷ String → ETag + strToETag str + = case A.fromChars str of + Just a → strongETag a + Nothing → error "ETag must not contain any non-ASCII letters." + +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.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" + = case outputOpts of + [] → return stdout + OptOutput fpath:[] → do h ← openFile fpath WriteMode + hSetEncoding h utf8 + return h + _ → fail "two many --output options." + where + outputOpts ∷ [CmdOpt] + outputOpts = filter (\ x → case x of + OptOutput _ → True + _ → False) opts - contentType :: MIMEType - contentType = read "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 + +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 - rawData :: L.ByteString - rawData = L.pack (decode "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRGlzdHJ...") - ------------------------------------------------------------------------------ +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) - 壓縮される場合は次のやうに變はる: - ------------------------------------------------------------------------------ - -- import に追加 - import Control.Monad - import Codec.Compression.GZip + getLastComp ∷ ModName → String + getLastComp = reverse ∘ fst ∘ break (≡ '.') ∘ reverse ∘ modString - -- ResourceDef は次のやうに變化 - baz :: ResourceDef - baz = ResourceDef { - resUsesNativeThread = False - , resIsGreedy = False - , resGet - = Just (do foundEntity entityTag lastModified - setContentType contentType +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 - 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 (decode "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAAB...") - ------------------------------------------------------------------------------ - -} + symName ∷ Name + symName = fromMaybe (defaultSymName modName) + $ getSymbolName opts