X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=ImplantFile.hs;h=b95c45508cd23d11a134451081edd61c4de45a42;hb=ea2b7838f1b3d9d4923a220a601be2e04cc559d7;hp=29c11450deab634a6a0c3c0b5d72637f51fecb92;hpb=e0fbd70ccc0690e5f5723db87fdd2bab371a33f2;p=Lucu.git diff --git a/ImplantFile.hs b/ImplantFile.hs index 29c1145..b95c455 100644 --- a/ImplantFile.hs +++ b/ImplantFile.hs @@ -1,25 +1,34 @@ -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 +{-# LANGUAGE + UnicodeSyntax + #-} +module Main where +import Codec.Compression.GZip +import Control.Applicative +import Control.Monad +import qualified Data.Ascii as A +import Data.Bits +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as Strict +import qualified Data.ByteString.Lazy as Lazy +import Data.Char +import Data.Int +import Data.Maybe +import Data.Time +import Data.Time.Clock.POSIX +import Language.Haskell.Exts.Build +import Language.Haskell.Exts.Extension +import Language.Haskell.Exts.Pretty +import Language.Haskell.Exts.Syntax +import Network.HTTP.Lucu.ETag +import Network.HTTP.Lucu.MIMEType +import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap +import Network.HTTP.Lucu.MIMEType.Guess +import Prelude.Unicode +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.Posix.Files +import System.IO data CmdOpt = OptOutput FilePath @@ -30,8 +39,7 @@ data CmdOpt | OptHelp deriving (Eq, Show) - -options :: [OptDescr CmdOpt] +options ∷ [OptDescr CmdOpt] options = [ Option ['o'] ["output"] (ReqArg OptOutput "FILE") "Output to the FILE." @@ -57,110 +65,88 @@ options = [ Option ['o'] ["output"] "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) + $ error "too many input files." generateHaskellSource opts (head sources) - -generateHaskellSource :: [CmdOpt] -> FilePath -> IO () +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 + = 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 = Lazy.length input + gzippedLen = Lazy.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] + rawB64 = B64.encode <$> Lazy.toChunks input + gzippedB64 = B64.encode <$> Lazy.toChunks gzippedData + + header ← mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod + + let hsModule = mkModule (ModuleName modName) (name symName) imports decls + imports = mkImports useGZip + decls = concat [ declResourceDef + , entityTagDecl eTag + , lastModifiedDecl lastMod + , contentTypeDecl mimeType + , if useGZip then + dataDecl (name "gzippedData") gzippedB64 + else + dataDecl (name "rawData") rawB64 + ] declResourceDef - = [ HsTypeSig undefined [HsIdent symName] + = [ HsTypeSig (⊥) [HsIdent symName] (HsQualType [] (HsTyCon (UnQual (HsIdent "ResourceDef")))) - , HsFunBind [HsMatch undefined (HsIdent symName) + , HsFunBind [HsMatch (⊥) (HsIdent symName) [] (HsUnGuardedRhs defResourceDef) []] ] - defResourceDef :: HsExp + defResourceDef ∷ HsExp defResourceDef = let defResGet = if useGZip then defResGetGZipped - else defResGetRaw + else resGetRaw in (HsRecConstr (UnQual (HsIdent "ResourceDef")) [ HsFieldUpdate (UnQual (HsIdent "resUsesNativeThread")) @@ -179,22 +165,15 @@ generateHaskellSource opts srcFile ] ) - defResGetGZipped :: HsExp + defResGetGZipped ∷ HsExp defResGetGZipped - = let doExp = HsDo [ doFoundEntity - , doSetContentType + = let doExp = HsDo [ foundEntityStmt + , setContentTypeStmt , 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 + = HsGenerator (⊥) (HsPVar (HsIdent "mustGunzip")) (HsApp (HsApp (HsVar (UnQual (HsIdent "liftM"))) (HsVar (UnQual (HsIdent "not")))) @@ -207,240 +186,277 @@ generateHaskellSource opts srcFile expOutputGunzipped expOutputGZipped) expOutputGunzipped - = (HsApp (HsVar (UnQual (HsIdent "outputBS"))) + = (HsApp (HsVar (UnQual (HsIdent "outputLBS"))) (HsParen (HsApp (HsVar (UnQual (HsIdent "decompress"))) (HsVar (UnQual (HsIdent "gzippedData")))))) expOutputGZipped - = HsDo [ doSetContentEncodingGZip - , doOutputGZipped + = HsDo [ setContentEncodingGZipStmt + , outputStmt (var $ name "gzippedData") ] - 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) []] - ] + hPutStrLn output header + hPutStrLn output (prettyPrint hsModule) + hClose output - 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) []] - ] +mkModule ∷ ModuleName → Name → [ImportDecl] → [Decl] +mkModule modName symName imports decls + = let modPragma = [ LanguagePragma (⊥) [ name (show OverloadedStrings) + ] + ] + exports = [ EVar (UnQual symName) + ] + in + Module (⊥) modName modPragma Nothing (Just exports) imports decls + +mkImports ∷ Bool → [ImportDecl] +mkImports useGZip + = [ ImportDecl (⊥) (ModuleName "Data.ByteString.Base64") + True False (Just (ModuleName "B64")) Nothing + , ImportDecl (⊥) (ModuleName "Data.ByteString.Lazy") + True False (Just (ModuleName "Lazy")) Nothing + , ImportDecl (⊥) (ModuleName "Data.Time") + False False Nothing Nothing + , ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu") + False False Nothing Nothing + ] + ⧺ + if useGZip then + [ ImportDecl (⊥) (ModuleName "Codec.Compression.GZip") + False False Nothing Nothing + ] + else + [] + +resHead ∷ Exp +resHead + = infixApp (var $ name "Just") + (op $ name "$" ) + (doE [ foundEntityStmt + , setContentTypeStmt + ]) + +resGetRaw ∷ Exp +resGetRaw + = infixApp (var $ name "Just") + (op $ name "$" ) + (doE [ foundEntityStmt + , setContentTypeStmt + , outputStmt (var $ name "rawData") + ]) + +setContentEncodingGZipStmt ∷ Stmt +setContentEncodingGZipStmt + = qualStmt $ + metaFunction "setContentEncoding" $ + [ listE [ strE "gzip" ] ] + +foundEntityStmt ∷ Stmt +foundEntityStmt + = qualStmt $ + metaFunction "foundEntity" $ + [ var $ name "entityTag" + , var $ name "lastModified" + ] + +setContentTypeStmt ∷ Stmt +setContentTypeStmt + = qualStmt $ + metaFunction "setContentType" $ + [var $ name "contentType"] + +outputStmt ∷ Exp → Stmt +outputStmt e + = qualStmt $ + metaFunction "output" [e] + +entityTagDecl ∷ ETag → [Decl] +entityTagDecl eTag + = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "ETag"))) + , nameBind (⊥) varName valExp + ] + where + varName ∷ Name + varName = name "entityTag" - defContentType :: HsExp - defContentType - = HsApp (HsVar (UnQual (HsIdent "read"))) - (HsLit (HsString $ show mimeType)) + valExp ∷ Exp + valExp = metaFunction "parseETag" [strE $ eTagToString eTag] - declGZippedData :: [HsDecl] - declGZippedData - = [ HsTypeSig undefined [HsIdent "gzippedData"] - (HsQualType [] - (HsTyCon (UnQual (HsIdent "ByteString")))) - , HsFunBind [HsMatch undefined (HsIdent "gzippedData") - [] (HsUnGuardedRhs defGZippedData) []] - ] + eTagToString ∷ ETag → String + eTagToString = A.toString ∘ A.fromAsciiBuilder ∘ printETag - defGZippedData :: HsExp - defGZippedData - = HsApp (HsVar (Qual (Module "L") (HsIdent "pack"))) - (HsParen - (HsApp (HsVar (UnQual (HsIdent "decode"))) - (HsLit (HsString gzippedB64)))) +lastModifiedDecl ∷ UTCTime → [Decl] +lastModifiedDecl lastMod + = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "UTCTime"))) + , nameBind (⊥) varName valExp + ] + where + varName ∷ Name + varName = name "lastModified" - declRawData :: [HsDecl] - declRawData - = [ HsTypeSig undefined [HsIdent "rawData"] - (HsQualType [] - (HsTyCon (UnQual (HsIdent "ByteString")))) - , HsFunBind [HsMatch undefined (HsIdent "rawData") - [] (HsUnGuardedRhs defRawData) []] - ] + valExp ∷ Exp + valExp = metaFunction "read" [strE $ show lastMod] - defRawData :: HsExp - defRawData - = HsApp (HsVar (Qual (Module "L") (HsIdent "pack"))) - (HsParen - (HsApp (HsVar (UnQual (HsIdent "decode"))) - (HsLit (HsString rawB64)))) +contentTypeDecl ∷ MIMEType → [Decl] +contentTypeDecl mime + = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "MIMEType"))) + , nameBind (⊥) varName valExp + ] + where + varName ∷ Name + varName = name "contentType" - hPutStrLn output header - hPutStrLn output (prettyPrint hsModule) - hClose output + valExp ∷ Exp + valExp = metaFunction "parseMIMEType" [mimeToString mime] + mimeToString ∷ MIMEType → String + mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType -mkHeader :: FilePath -> Int64 -> Int64 -> Bool -> MIMEType -> String -> ClockTime -> String +dataDecl ∷ Name → [Strict.ByteString] → [Decl] +dataDecl varName chunks + = [ TypeSig (⊥) [varName] (TyCon (Qual (ModuleName "Lazy") (name "ByteString"))) + , nameBind (⊥) varName valExp + ] + where + valExp ∷ Exp + valExp = qvar (ModuleName "Lazy") (name "fromChunks") + `app` + listE (chunkToExp <$> chunks) + + chunkToExp ∷ Strict.ByteString → Exp + chunkToExp chunk + = qvar (ModuleName "B64") (name "decodeLenient") + `app` + strE (Strict.unpack chunk) + +mkHeader ∷ FilePath → Int64 → Int64 → Bool → MIMEType → String → UTCTime → IO 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 + = 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 + = 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." + [] → error "a module name must be given." + (OptModName modName):[] → return modName + _ → error "too many --module options." -getSymbolName :: [CmdOpt] -> String -> IO String +getSymbolName ∷ [CmdOpt] → String → IO String getSymbolName opts modName - = let symNameOpts = filter (\ x -> case x of - OptSymName _ -> True - _ -> False) opts + = 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 + 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." + [] → return defaultSymName + (OptSymName symName):[] → return symName + _ → error "too many --symbol options." -getMIMEType :: [CmdOpt] -> FilePath -> IO MIMEType +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." + = case mimeTypeOpts of + [] → return defaultType + (OptMIMEType ty):[] → return $ read ty + _ → error "too many --mime-type options." + where + mimeTypeOpts ∷ [CmdOpt] + mimeTypeOpts + = filter (\ x → case x of + OptMIMEType _ → True + _ → False) opts + + octetStream ∷ MIMEType + octetStream = parseMIMEType "application/octet-stream" + defaultType ∷ MIMEType + defaultType = fromMaybe octetStream + $ guessTypeByFileName defaultExtensionMap srcFile -getLastModified :: FilePath -> IO ClockTime -getLastModified "-" = getClockTime -getLastModified fpath = getModificationTime fpath +getLastModified ∷ FilePath → IO UTCTime +getLastModified "-" = getCurrentTime +getLastModified fpath = (posixSecondsToUTCTime ∘ fromRational ∘ toRational ∘ modificationTime) + <$> + getFileStatus fpath -getETag :: [CmdOpt] -> ByteString -> IO String + +getETag ∷ [CmdOpt] → Lazy.ByteString → IO String getETag opts input - = let eTagOpts = filter (\ x -> case x of - OptETag _ -> True - _ -> False) opts + = 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." + [] → fmap (mkETagFromInput ∘ fromJust) (getDigestByName "SHA1") + (OptETag str):[] → return str + _ → error "too many --etag options." where - mkETagFromInput :: String - mkETagFromInput = "SHA-1:" ++ (toHex $ hash $ L.unpack input) + mkETagFromInput ∷ Digest → String + mkETagFromInput sha1 = "SHA-1:" ++ toHex (digestLBS sha1 input) - toHex :: [Word8] -> String - toHex [] = "" - toHex (x:xs) = hexByte (fromIntegral x) ++ toHex xs + toHex ∷ String → String + toHex = foldr ((++) ∘ hexByte ∘ fromEnum) "" - hexByte :: Int -> String + hexByte ∷ Int → String hexByte n - = hex4bit ((n `shiftR` 4) .&. 0x0F) : hex4bit (n .&. 0x0F) : [] + = [ hex4bit ((n `shiftR` 4) .&. 0x0F) + , hex4bit ( n .&. 0x0F) + ] - hex4bit :: Int -> Char + hex4bit ∷ Int → Char hex4bit n - | n < 10 = (chr $ ord '0' + n ) - | n < 16 = (chr $ ord 'a' + n - 10) + | n < 10 = chr $ ord '0' + n + | n < 16 = chr $ ord 'a' + n - 10 + | otherwise = (⊥) -openInput :: FilePath -> IO ByteString -openInput "-" = L.getContents -openInput fpath = L.readFile fpath +openInput ∷ FilePath → IO Lazy.ByteString +openInput "-" = Lazy.getContents +openInput fpath = Lazy.readFile fpath -openOutput :: [CmdOpt] -> IO Handle +openOutput ∷ [CmdOpt] → IO Handle openOutput opts - = let outputOpts = filter (\ x -> case x of - OptOutput _ -> True - _ -> False) 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." - + [] → return stdout + (OptOutput fpath):[] → openFile fpath WriteMode + _ → error "two many --output options." {- 作られるファイルの例 (壓縮されない場合): @@ -454,71 +470,80 @@ openOutput opts Compression: disabled MIME Type: image/png ETag: d41d8cd98f00b204e9800998ecf8427e - Last Modified: Wed, 03 Oct 2007 00:55:45 JST + Last Modified: 2007-11-05 13:53:42.231882 JST -} + {-# LANGUAGE OverloadedStrings #-} module Foo.Bar.Baz (baz) where - import Codec.Binary.Base64 - import Data.ByteString.Lazy (ByteString) - import qualified Data.ByteString.Lazy as L + import qualified Data.ByteString.Base64 as B64 + import qualified Data.ByteString.Lazy as Lazy + import Data.Time import Network.HTTP.Lucu - import System.Time - baz :: ResourceDef + baz ∷ ResourceDef baz = ResourceDef { resUsesNativeThread = False , resIsGreedy = False , resGet - = Just (do foundEntity entityTag lastModified - setContentType contentType - outputBS rawData) - , resHead = Nothing + = Just $ do foundEntity entityTag lastModified + setContentType contentType + output rawData + , resHead + = Just $ do foundEntity entityTag lastModified + setContentType contentType , resPost = Nothing , resPut = Nothing , resDelete = Nothing } - entityTag :: ETag + entityTag ∷ ETag entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e" - lastModified :: ClockTime - lastModified = TOD 1191340545 0 + lastModified ∷ UTCTime + lastModified = read "2007-11-05 04:47:56.008366 UTC" - contentType :: MIMEType - contentType = read "image/png" + contentType ∷ MIMEType + contentType = parseMIMEType "image/png" - rawData :: ByteString - rawData = L.pack (decode "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRGlzdHJ...") + rawData ∷ Lazy.ByteString + rawData = Lazy.fromChunks + [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRG..." + , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAA..." + ] ------------------------------------------------------------------------------ 壓縮される場合は次のやうに變はる: ------------------------------------------------------------------------------ -- import に追加 - import Control.Monad import Codec.Compression.GZip -- ResourceDef は次のやうに變化 - baz :: 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 + = Just $ do foundEntity entityTag lastModified + setContentType contentType + + gzip ← isEncodingAcceptable "gzip" + if gzip then + do setContentEncoding ["gzip"] + output gzippedData + else + output (decompress gzippedData) + , resHead + = Just $ do foundEntity entityTag lastModified + setContentType contentType , resPost = Nothing , resPut = Nothing , resDelete = Nothing } -- rawData の代はりに gzippedData - gzippedData :: ByteString - gzippedData = L.pack (decode "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAAB...") + gzippedData ∷ Lazy.ByteString + gzippedData = Lazy.fromChunks + [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQ..." + , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGA..." + ] ------------------------------------------------------------------------------ -}