-import Codec.Compression.GZip
-import Control.Monad
-import Data.Bits
-import qualified Data.ByteString as BS
+{-# 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 C8
-import qualified Data.ByteString.Lazy as Lazy (ByteString)
-import qualified Data.ByteString.Lazy as LS 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
+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
| OptHelp
deriving (Eq, Show)
-
-options :: [OptDescr CmdOpt]
+options ∷ [OptDescr CmdOpt]
options = [ Option ['o'] ["output"]
(ReqArg OptOutput "FILE")
"Output to the FILE."
"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 ""
+ 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 = withOpenSSL $
- do (opts, sources, errors) <- return . getOpt Permute options =<< getArgs
+main ∷ IO ()
+main = do (opts, sources, errors) ← getOpt Permute options <$> getArgs
unless (null errors)
- $ do mapM_ putStr errors
- exitWith $ ExitFailure 1
+ $ do mapM_ putStr errors
+ exitWith $ ExitFailure 1
- when (any (== OptHelp) opts)
- $ do printUsage
- exitWith ExitSuccess
+ 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
+ = 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 = LS.length input
- gzippedLen = LS.length gzippedData
+ originalLen = Lazy.length input
+ gzippedLen = Lazy.length gzippedData
useGZip = originalLen > gzippedLen
- rawB64 = B64.encode $ BS.concat $ LS.toChunks input
- gzippedB64 = B64.encode $ BS.concat $ LS.toChunks 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 "Data.ByteString.Base64")
- True (Just (Module "B64")) Nothing
- , HsImportDecl undefined (Module "Data.ByteString.Char8")
- True (Just (Module "C8")) Nothing
- , HsImportDecl undefined (Module "Data.ByteString.Lazy")
- True (Just (Module "LS")) 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]
+ 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"))
]
)
- 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"))))
(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 "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) []]
- ]
+ hPutStrLn output header
+ hPutStrLn output (prettyPrint hsModule)
+ hClose output
- defLastModified :: HsExp
- defLastModified
- = HsApp (HsVar (UnQual (HsIdent "read")))
- (HsLit (HsString $ show lastMod))
-
+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"
- declContentType :: [HsDecl]
- declContentType
- = [ HsTypeSig undefined [HsIdent "contentType"]
- (HsQualType []
- (HsTyCon (UnQual (HsIdent "MIMEType"))))
- , HsFunBind [HsMatch undefined (HsIdent "contentType")
- [] (HsUnGuardedRhs defContentType) []]
- ]
+ valExp ∷ Exp
+ valExp = metaFunction "parseETag" [strE $ eTagToString eTag]
- defContentType :: HsExp
- defContentType
- = HsApp (HsVar (UnQual (HsIdent "read")))
- (HsLit (HsString $ show mimeType))
+ eTagToString ∷ ETag → String
+ eTagToString = A.toString ∘ A.fromAsciiBuilder ∘ printETag
- declGZippedData :: [HsDecl]
- declGZippedData
- = [ HsTypeSig undefined [HsIdent "gzippedData"]
- (HsQualType []
- (HsTyCon (Qual (Module "LS") (HsIdent "ByteString"))))
- , HsFunBind [HsMatch undefined (HsIdent "gzippedData")
- [] (HsUnGuardedRhs defGZippedData) []]
- ]
+lastModifiedDecl ∷ UTCTime → [Decl]
+lastModifiedDecl lastMod
+ = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "UTCTime")))
+ , nameBind (⊥) varName valExp
+ ]
+ where
+ varName ∷ Name
+ varName = name "lastModified"
- defGZippedData :: HsExp
- defGZippedData
- = HsApp (HsVar (Qual (Module "LS") (HsIdent "fromChunks")))
- (HsList [HsApp (HsVar (Qual (Module "B64") (HsIdent "decodeLenient")))
- (HsParen
- (HsApp (HsVar (Qual (Module "C8") (HsIdent "pack")))
- (HsLit (HsString $ C8.unpack gzippedB64))))])
-
- declRawData :: [HsDecl]
- declRawData
- = [ HsTypeSig undefined [HsIdent "rawData"]
- (HsQualType []
- (HsTyCon (Qual (Module "LS") (HsIdent "ByteString"))))
- , HsFunBind [HsMatch undefined (HsIdent "rawData")
- [] (HsUnGuardedRhs defRawData) []]
- ]
+ valExp ∷ Exp
+ valExp = metaFunction "read" [strE $ show lastMod]
- defRawData :: HsExp
- defRawData
- = HsApp (HsVar (Qual (Module "LS") (HsIdent "fromChunks")))
- (HsList [HsApp (HsVar (Qual (Module "B64") (HsIdent "decodeLenient")))
- (HsParen
- (HsApp (HsVar (Qual (Module "C8") (HsIdent "pack")))
- (HsLit (HsString $ C8.unpack 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 -> UTCTime -> IO 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 localLastMod <- utcToLocalZonedTime 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 == "-"
+ " Source: " ++ (if srcFile ≡ "-"
then "(stdin)"
else srcFile) ++ "\n" ++
" Original Length: " ++ show originalLen ++ " bytes\n" ++
" -}")
-getModuleName :: [CmdOpt] -> IO String
+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
+ 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
+ [] → 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 UTCTime
+getLastModified ∷ FilePath → IO UTCTime
getLastModified "-" = getCurrentTime
-getLastModified fpath = fmap (posixSecondsToUTCTime . fromRational . toRational . modificationTime)
- $ getFileStatus fpath
+getLastModified fpath = (posixSecondsToUTCTime ∘ fromRational ∘ toRational ∘ modificationTime)
+ <$>
+ getFileStatus fpath
-getETag :: [CmdOpt] -> Lazy.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
- [] -> fmap (mkETagFromInput . fromJust) (getDigestByName "SHA1")
- (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 :: Digest -> String
+ mkETagFromInput ∷ Digest → String
mkETagFromInput sha1 = "SHA-1:" ++ toHex (digestLBS sha1 input)
- toHex :: String -> String
- toHex = foldr ((++) . hexByte . fromEnum) ""
+ toHex ∷ String → String
+ toHex = foldr ((++) ∘ hexByte ∘ fromEnum) ""
- hexByte :: Int -> String
+ hexByte ∷ Int → String
hexByte n
= [ 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
- | otherwise = undefined
+ | otherwise = (⊥)
-openInput :: FilePath -> IO Lazy.ByteString
-openInput "-" = LS.getContents
-openInput fpath = LS.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."
{-
作られるファイルの例 (壓縮されない場合):
ETag: d41d8cd98f00b204e9800998ecf8427e
Last Modified: 2007-11-05 13:53:42.231882 JST
-}
+ {-# LANGUAGE OverloadedStrings #-}
module Foo.Bar.Baz (baz) where
import qualified Data.ByteString.Base64 as B64
- import qualified Data.ByteString.Char8 as C8
- import qualified Data.ByteString.Lazy as LS
+ import qualified Data.ByteString.Lazy as Lazy
import Data.Time
import Network.HTTP.Lucu
- baz :: ResourceDef
+ baz ∷ ResourceDef
baz = ResourceDef {
resUsesNativeThread = False
, resIsGreedy = False
, resGet
- = Just (do foundEntity entityTag lastModified
- setContentType contentType
- outputLBS 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 :: UTCTime
+ 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 :: LS.ByteString
- rawData = LS.fromChunks [B64.decodeLenient (C8.pack "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
- outputLBS (decompress gzippedData)
- else
- do setContentEncoding ["gzip"]
- outputLBS 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 :: LS.ByteString
- gzippedData = LS.fromChunks [B64.decodeLenient (C8.pack "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAAB...")]
+ gzippedData ∷ Lazy.ByteString
+ gzippedData = Lazy.fromChunks
+ [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQ..."
+ , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGA..."
+ ]
------------------------------------------------------------------------------
-}
)
where
import qualified Blaze.ByteString.Builder.HTTP as BB
-import qualified Data.Ascii as A
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
+import qualified Data.Ascii as A
import Data.Monoid.Unicode
import qualified Data.Sequence as S
import Data.Sequence (ViewR(..))
, cReader ∷ !ThreadId
}
+data Phase = Initial
+ | WroteContinue
+ | WroteHeader
+ deriving (Eq, Ord, Show)
+
responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO ()
responseWriter cnf h tQueue readerTID
= awaitSomethingToWrite (Context cnf h tQueue readerTID)
atomically $
-- キューが空でなくなるまで待つ
do queue ← readTVar cQueue
- -- GettingBody 状態にあり、Continue が期待されてゐて、それがま
- -- だ送信前なのであれば、Continue を送信する。
case S.viewr queue of
- EmptyR → retry
- _ :> itr → do state ← readTVar $ itrState itr
- if state ≡ GettingBody then
- writeContinueIfNeeded ctx itr
- else
- if state ≥ DecidingBody then
- writeHeaderOrBodyIfNeeded ctx itr
- else
- retry
+ EmptyR → retry
+ queue' :> itr → do writeTVar cQueue queue'
+ return $ awaitSomethingToWriteOn ctx itr Initial
-writeContinueIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ())
-writeContinueIfNeeded ctx itr@(Interaction {..})
- = do expectedContinue ← readTVar itrExpectedContinue
- if expectedContinue then
- do wroteContinue ← readTVar itrWroteContinue
- if wroteContinue then
- -- 既に Continue を書込み濟
- retry
- else
- do reqBodyWanted ← readTVar itrReqBodyWanted
- if reqBodyWanted ≢ Nothing then
- return $ writeContinue ctx itr
- else
- retry
+-- GettingBody 状態にあり、Continue が期待されてゐて、それがまだ送信前
+-- なのであれば、Continue を送信する。
+awaitSomethingToWriteOn ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Phase
+ → IO ()
+awaitSomethingToWriteOn ctx itr phase
+ = join $
+ atomically $
+ do state ← readTVar $ itrState itr
+ if state ≡ GettingBody then
+ writeContinueIfNeeded ctx itr phase
else
- retry
+ if state ≥ DecidingBody then
+ writeHeaderOrBodyIfNeeded ctx itr phase
+ else
+ retry
+
+writeContinueIfNeeded ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Phase
+ → STM (IO ())
+writeContinueIfNeeded ctx itr@(Interaction {..}) phase
+ | phase ≡ Initial ∧ itrExpectedContinue ≡ Just True
+ = do reqBodyWanted ← readTVar itrReqBodyWanted
+ if reqBodyWanted > 0 then
+ return $ writeContinue ctx itr
+ else
+ retry
+ | otherwise
+ = retry
-- DecidingBody 以降の状態にあり、まだヘッダを出力する前であれば、ヘッ
-- ダを出力する。ヘッダ出力後であり、bodyToSend が空でなければ、それを
-- 出力する。空である時は、もし状態がDone であれば後処理をする。
-writeHeaderOrBodyIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ())
-writeHeaderOrBodyIfNeeded ctx itr@(Interaction {..})
- = do wroteHeader ← readTVar itrWroteHeader
- if not wroteHeader then
- return $ writeHeader ctx itr
- else
- do noBodyToWrite ← isEmptyTMVar itrBodyToSend
- if noBodyToWrite then
- do state ← readTVar itrState
- if state ≡ Done then
- return $ finalize ctx itr
- else
- retry
- else
- return $ writeBodyChunk ctx itr
+writeHeaderOrBodyIfNeeded ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Phase
+ → STM (IO ())
+writeHeaderOrBodyIfNeeded ctx itr@(Interaction {..}) phase
+ | phase < WroteHeader
+ = return $ writeHeader ctx itr
+ | otherwise
+ = do noBodyToWrite ← isEmptyTMVar itrBodyToSend
+ if noBodyToWrite then
+ do state ← readTVar itrState
+ if state ≡ Done then
+ return $ finalize ctx itr
+ else
+ retry
+ else
+ return $ writeBodyChunk ctx itr phase
writeContinue ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-writeContinue ctx@(Context {..}) (Interaction {..})
+writeContinue ctx@(Context {..}) itr@(Interaction {..})
= do let cont = Response {
resVersion = HttpVersion 1 1
, resStatus = Continue
cont' ← completeUnconditionalHeaders cConfig cont
hPutBuilder cHandle $ A.toBuilder $ printResponse cont'
hFlush cHandle
- atomically $ writeTVar itrWroteContinue True
- awaitSomethingToWrite ctx
+ awaitSomethingToWriteOn ctx itr WroteContinue
-writeHeader ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-writeHeader ctx@(Context {..}) (Interaction {..})
- = do res ← atomically
- $ do writeTVar itrWroteHeader True
- readTVar itrResponse
+writeHeader ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → IO ()
+writeHeader ctx@(Context {..}) itr@(Interaction {..})
+ = do res ← atomically $ readTVar itrResponse
hPutBuilder cHandle $ A.toBuilder $ printResponse res
hFlush cHandle
- awaitSomethingToWrite ctx
+ awaitSomethingToWriteOn ctx itr WroteHeader
-writeBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-writeBodyChunk ctx@(Context {..}) (Interaction {..})
+writeBodyChunk ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Phase
+ → IO ()
+writeBodyChunk ctx@(Context {..}) itr@(Interaction {..}) phase
= join $
atomically $
do willDiscardBody ← readTVar itrWillDiscardBody
if willDiscardBody then
do _ ← tryTakeTMVar itrBodyToSend
- return $ awaitSomethingToWrite ctx
+ return $ awaitSomethingToWriteOn ctx itr phase
else
do willChunkBody ← readTVar itrWillChunkBody
chunk ← takeTMVar itrBodyToSend
else
hPutBuilder cHandle chunk
hFlush cHandle
- awaitSomethingToWrite ctx
+ awaitSomethingToWriteOn ctx itr phase
finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
finishBodyChunk (Context {..}) (Interaction {..})
projects / Lucu.git / commitdiff