From: PHO Date: Wed, 12 Oct 2011 18:01:43 +0000 (+0900) Subject: The library now compiles, and I'm now working on ImplantFile.hs X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=ea2b7838f1b3d9d4923a220a601be2e04cc559d7;p=Lucu.git The library now compiles, and I'm now working on ImplantFile.hs Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa --- diff --git a/ImplantFile.hs b/ImplantFile.hs index fd57fad..b95c455 100644 --- a/ImplantFile.hs +++ b/ImplantFile.hs @@ -1,28 +1,34 @@ -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 @@ -33,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." @@ -60,112 +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 "" + 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")) @@ -184,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")))) @@ -217,128 +191,154 @@ generateHaskellSource opts srcFile (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" ++ @@ -352,104 +352,111 @@ mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod " -}") -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." {- 作られるファイルの例 (壓縮されない場合): @@ -465,69 +472,78 @@ openOutput opts 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..." + ] ------------------------------------------------------------------------------ -} diff --git a/Lucu.cabal b/Lucu.cabal index 2521c48..0667fe2 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -8,7 +8,7 @@ Description: without messing around FastCGI. It is also intended to be run behind a reverse-proxy so it doesn't have some facilities like logging, client filtering or such like. -Version: 0.7.0.3 +Version: 1.0 License: PublicDomain License-File: COPYING Author: PHO @@ -58,7 +58,7 @@ Library containers-unicode-symbols == 0.3.*, filepath == 1.2.*, directory == 1.1.*, - haskell-src == 1.0.*, + haskell-src-exts == 1.11.*, hxt == 9.1.*, mtl == 2.0.*, network == 2.3.*, @@ -94,7 +94,6 @@ Library Network.HTTP.Lucu.Chunk Network.HTTP.Lucu.ContentCoding Network.HTTP.Lucu.DefaultPage - Network.HTTP.Lucu.Format Network.HTTP.Lucu.HandleLike Network.HTTP.Lucu.Headers Network.HTTP.Lucu.Interaction diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs index 52315d6..79b7414 100644 --- a/Network/HTTP/Lucu.hs +++ b/Network/HTTP/Lucu.hs @@ -33,8 +33,6 @@ -- wicked clients. No attacker should be able to cause a -- buffer-overflow but can possibly DoS it. -- - - module Network.HTTP.Lucu ( -- * Entry Point runHttpd @@ -65,9 +63,11 @@ module Network.HTTP.Lucu , ETag(..) , strongETag , weakETag + , parseETag -- *** MIME Type , MIMEType(..) + , parseMIMEType -- *** Authorization , AuthChallenge(..) @@ -79,7 +79,6 @@ module Network.HTTP.Lucu , module Network.HTTP.Lucu.StaticFile ) where - import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Authorization import Network.HTTP.Lucu.Config diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs index c36ebc0..4e237c4 100644 --- a/Network/HTTP/Lucu/Abortion.hs +++ b/Network/HTTP/Lucu/Abortion.hs @@ -1,11 +1,9 @@ {-# LANGUAGE Arrows - , BangPatterns , DeriveDataTypeable , TypeOperators , UnicodeSyntax #-} -{-# OPTIONS_HADDOCK prune #-} -- |Aborting the computation of 'Network.HTTP.Lucu.Resource.Resource' -- in any 'Prelude.IO' monads or arrows. @@ -101,7 +99,7 @@ abortA = proc (status, (headers, msg)) → -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な -- ければならない。 abortPage :: Config → Maybe Request → Response → Abortion → Lazy.Text -abortPage !conf !reqM !res !abo +abortPage conf reqM res abo = case aboMessage abo of Just msg → let [html] = runLA ( mkDefaultPage conf (aboStatus abo) (txt $ T.unpack msg) diff --git a/Network/HTTP/Lucu/Authorization.hs b/Network/HTTP/Lucu/Authorization.hs index 11de199..d91fe29 100644 --- a/Network/HTTP/Lucu/Authorization.hs +++ b/Network/HTTP/Lucu/Authorization.hs @@ -2,7 +2,6 @@ OverloadedStrings , UnicodeSyntax #-} -{-# OPTIONS_HADDOCK prune #-} -- |Manipulation of WWW authorization. module Network.HTTP.Lucu.Authorization @@ -13,7 +12,7 @@ module Network.HTTP.Lucu.Authorization , Password , printAuthChallenge - , authCredentialP -- private + , authCredentialP ) where import Data.Ascii (Ascii) diff --git a/Network/HTTP/Lucu/ETag.hs b/Network/HTTP/Lucu/ETag.hs index acc496f..7e61878 100644 --- a/Network/HTTP/Lucu/ETag.hs +++ b/Network/HTTP/Lucu/ETag.hs @@ -2,12 +2,10 @@ OverloadedStrings , UnicodeSyntax #-} -{-# OPTIONS_HADDOCK prune #-} - -- |Manipulation of entity tags. module Network.HTTP.Lucu.ETag ( ETag(..) - + , parseETag , printETag , strongETag @@ -16,14 +14,15 @@ module Network.HTTP.Lucu.ETag , eTagListP ) where +import Control.Applicative import Control.Monad -import Control.Monad.Unicode import Data.Ascii (Ascii) import qualified Data.Ascii as A import Data.Attoparsec.Char8 import Data.Monoid.Unicode import Network.HTTP.Lucu.Parser.Http hiding (token) import Network.HTTP.Lucu.Utils +import Prelude.Unicode -- |An entity tag is made of a weakness flag and a opaque string. data ETag = ETag { @@ -47,6 +46,19 @@ printETag et ⊕ quoteStr (etagToken et) ) +-- |Parse 'Etag' from an 'Ascii'. This functions throws an exception +-- for parse error. +parseETag ∷ Ascii → ETag +parseETag str + = let p = do et ← eTagP + endOfInput + return et + bs = A.toByteString str + in + case parseOnly p bs of + Right et → et + Left err → error ("unparsable ETag: " ⧺ A.toString str ⧺ ": " ⧺ err) + -- |This is equivalent to @'ETag' 'Prelude.False'@. If you want to -- generate an ETag from a file, try using -- 'Network.HTTP.Lucu.StaticFile.generateETagFromFile'. @@ -58,7 +70,7 @@ weakETag ∷ Ascii → ETag weakETag = ETag True eTagP ∷ Parser ETag -eTagP = do isWeak ← option False (string "W/" ≫ return True) +eTagP = do isWeak ← option False (string "W/" *> return True) str ← quotedStr return $ ETag isWeak str diff --git a/Network/HTTP/Lucu/Format.hs b/Network/HTTP/Lucu/Format.hs deleted file mode 100644 index 8db643d..0000000 --- a/Network/HTTP/Lucu/Format.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE - OverloadedStrings - , ScopedTypeVariables - , UnboxedTuples - , UnicodeSyntax - #-} --- 本當にこんなものを自分で書く必要があったのだらうか。Printf は重いの --- で駄目だが、それ以外のモジュールを探しても見付からなかった。 -module Network.HTTP.Lucu.Format - ( {-fmtInt - - , fmtDec - , fmtHex-} - ) - where -import qualified Blaze.ByteString.Builder.Char8 as BC -import Data.Ascii (AsciiBuilder) -import qualified Data.ByteString.Char8 as BS -import qualified Data.Ascii as A -import Data.Char -import Data.Monoid.Unicode -import Prelude.Unicode - -fmtInt ∷ ∀n. Integral n ⇒ n → Int → n → AsciiBuilder -{-# INLINEABLE fmtInt #-} -fmtInt base minWidth n - = let (# raw, len #) = fmt' (abs n) (∅) 0 - in - if n < 0 then - ( A.toAsciiBuilder "-" ⊕ - mkPad (minWidth - 1) len ⊕ - raw - ) - else - mkPad minWidth len ⊕ raw - where - fmt' ∷ n → AsciiBuilder → Int → (# AsciiBuilder, Int #) - {-# INLINEABLE fmt' #-} - fmt' x b len - | x < base - = let b' = b ⊕ fromDigit x - in - (# b', len + 1 #) - | otherwise - = let x' = x `div` base - y = x `mod` base - b' = b ⊕ fromDigit y - in - fmt' x' b' (len + 1) - -mkPad ∷ Int → Int → AsciiBuilder -{-# INLINEABLE mkPad #-} -mkPad minWidth len - = A.toAsciiBuilder $ - A.unsafeFromByteString $ - BS.replicate (minWidth - len) '0' - -fmtDec ∷ Integral n ⇒ Int → n → AsciiBuilder -{-# INLINE fmtDec #-} -fmtDec minWidth n - | minWidth == 2 = fmtDec2 n -- optimization - | minWidth == 3 = fmtDec3 n -- optimization - | minWidth == 4 = fmtDec4 n -- optimization - | otherwise = fmtInt 10 minWidth n - -fmtDec2 ∷ Integral n ⇒ n → AsciiBuilder -{-# INLINEABLE fmtDec2 #-} -fmtDec2 n - | n < 0 ∨ n ≥ 100 = fmtInt 10 2 n -- fallback - | n < 10 = A.toAsciiBuilder "0" ⊕ - fromDigit n - | otherwise = fromDigit (n `div` 10) ⊕ - fromDigit (n `mod` 10) - -fmtDec3 ∷ Integral n ⇒ n → AsciiBuilder -{-# INLINEABLE fmtDec3 #-} -fmtDec3 n - | n < 0 ∨ n ≥ 1000 = fmtInt 10 3 n -- fallback - | n < 10 = A.toAsciiBuilder "00" ⊕ - fromDigit n - | n < 100 = A.toAsciiBuilder "0" ⊕ - fromDigit ((n `div` 10) `mod` 10) ⊕ - fromDigit ( n `mod` 10) - | otherwise = fromDigit (n `div` 100) ⊕ - fromDigit ((n `div` 10) `mod` 10) ⊕ - fromDigit ( n `mod` 10) - -fmtDec4 ∷ Integral n ⇒ n → AsciiBuilder -{-# INLINEABLE fmtDec4 #-} -fmtDec4 n - | n < 0 ∨ n ≥ 10000 = fmtInt 10 4 n -- fallback - | n < 10 = A.toAsciiBuilder "000" ⊕ - fromDigit n - | n < 100 = A.toAsciiBuilder "00" ⊕ - fromDigit ((n `div` 10) `mod` 10) ⊕ - fromDigit ( n `mod` 10) - | n < 1000 = A.toAsciiBuilder "0" ⊕ - fromDigit ((n `div` 100) `mod` 10) ⊕ - fromDigit ((n `div` 10) `mod` 10) ⊕ - fromDigit ( n `mod` 10) - | otherwise = fromDigit (n `div` 1000) ⊕ - fromDigit ((n `div` 100) `mod` 10) ⊕ - fromDigit ((n `div` 10) `mod` 10) ⊕ - fromDigit ( n `mod` 10) - -fmtHex ∷ Integral n ⇒ Int → n → AsciiBuilder -{-# INLINE fmtHex #-} -fmtHex = fmtInt 16 - -digitToChar ∷ Integral n ⇒ n → Char -{-# INLINE digitToChar #-} -digitToChar n - | n < 0 = (⊥) - | n < 10 = chr (ord '0' + fromIntegral n ) - | n < 16 = chr (ord 'A' + fromIntegral (n-10)) - | otherwise = (⊥) - -fromDigit ∷ Integral n ⇒ n → AsciiBuilder -{-# INLINE fromDigit #-} -fromDigit = A.unsafeFromBuilder ∘ BC.fromChar ∘ digitToChar diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 5821579..ac5c1d6 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -41,7 +41,7 @@ data Interaction = Interaction { , itrExpectedContinue ∷ !(Maybe Bool) , itrReqBodyLength ∷ !(Maybe RequestBodyLength) - , itrReqBodyWanted ∷ !(TVar (Maybe Int)) + , itrReqBodyWanted ∷ !(TVar Int) , itrReqBodyWasteAll ∷ !(TVar Bool) , itrReqChunkIsOver ∷ !(TVar Bool) , itrReceivedBody ∷ !(TVar (Seq BS.ByteString)) @@ -88,9 +88,9 @@ newInteraction conf@(Config {..}) port addr cert request , resHeaders = singleton "Content-Type" defaultPageContentType } - reqBodyWanted ← newTVarIO Nothing -- Resource が要求してゐるチャンク長 - reqBodyWasteAll ← newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求 - reqChunkIsOver ← newTVarIO False -- 最後のチャンクを讀み終へた + reqBodyWanted ← newTVarIO 0 + reqBodyWasteAll ← newTVarIO False + reqChunkIsOver ← newTVarIO False receivedBody ← newTVarIO S.empty receivedBodyLen ← newTVarIO 0 diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs index ce637d5..acd76b6 100644 --- a/Network/HTTP/Lucu/MIMEType.hs +++ b/Network/HTTP/Lucu/MIMEType.hs @@ -2,7 +2,6 @@ OverloadedStrings , UnicodeSyntax #-} -{-# OPTIONS_HADDOCK prune #-} -- |Manipulation of MIME Types. module Network.HTTP.Lucu.MIMEType @@ -18,7 +17,6 @@ import Control.Applicative import Data.Ascii (Ascii, AsciiBuilder, CIAscii) import qualified Data.Ascii as A import Data.Attoparsec.Char8 as P -import qualified Data.ByteString.Char8 as C8 import Data.Map (Map) import Data.Monoid.Unicode import Data.Text (Text) @@ -54,7 +52,7 @@ parseMIMEType str in case parseOnly p bs of Right t → t - Left err → error ("unparsable MIME Type: " ⧺ C8.unpack bs ⧺ ": " ⧺ err) + Left err → error ("unparsable MIME Type: " ⧺ A.toString str ⧺ ": " ⧺ err) mimeTypeP ∷ Parser MIMEType mimeTypeP = do maj ← A.toCIAscii <$> token diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index 3e3df16..3917cf2 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -1,6 +1,5 @@ {-# LANGUAGE - BangPatterns - , UnicodeSyntax + UnicodeSyntax #-} -- |MIME Type guessing by a file extension. This is a poor man's way -- of guessing MIME Types. It is simple and fast. @@ -25,8 +24,10 @@ import Data.Maybe import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding -import Language.Haskell.Pretty -import Language.Haskell.Syntax +import Language.Haskell.Exts.Build +import Language.Haskell.Exts.Extension +import Language.Haskell.Exts.Pretty +import Language.Haskell.Exts.Syntax import Network.HTTP.Lucu.MIMEType import Prelude.Unicode import System.FilePath @@ -36,7 +37,7 @@ type ExtMap = Map Text MIMEType -- |Guess the MIME Type of file. guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType -guessTypeByFileName !extMap !fpath +guessTypeByFileName extMap fpath = let ext = T.pack $ takeExtension fpath in M.lookup ext extMap @@ -99,45 +100,39 @@ compile = M.fromList ∘ concat ∘ map tr -- surely generated using this function. serializeExtMap ∷ ExtMap → String → String → String serializeExtMap extMap moduleName variableName - = let hsModule = HsModule (⊥) modName (Just exports) imports decls - modName = Module moduleName - exports = [HsEVar (UnQual (HsIdent variableName))] - imports = [ HsImportDecl (⊥) (Module "Network.HTTP.Lucu.MIMEType") False Nothing Nothing - , HsImportDecl (⊥) (Module "Network.HTTP.Lucu.MIMEType.Guess") False Nothing Nothing - , HsImportDecl (⊥) (Module "Data.Ascii") True (Just (Module "A")) Nothing - , HsImportDecl (⊥) (Module "Data.Map") True (Just (Module "M")) Nothing - , HsImportDecl (⊥) (Module "Data.Text") True (Just (Module "T")) Nothing - ] - decls = [ HsTypeSig (⊥) [HsIdent variableName] - (HsQualType [] - (HsTyCon (UnQual (HsIdent "ExtMap")))) - , HsFunBind [HsMatch (⊥) (HsIdent variableName) - [] (HsUnGuardedRhs extMapExp) []] - ] - extMapExp = HsApp (HsVar (Qual (Module "M") (HsIdent "fromList"))) (HsList records) - comment = "{- !!! WARNING !!!\n" - ⧺ " This file is automatically generated.\n" - ⧺ " DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n" + = let hsModule = Module (⊥) (ModuleName moduleName) modPragma + Nothing (Just exports) imports decls + modPragma = [ LanguagePragma (⊥) [ name (show OverloadedStrings) ] ] + exports = [ EVar (UnQual (name variableName)) ] + imports = [ ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu.MIMEType") + False False Nothing Nothing Nothing + , ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu.MIMEType.Guess") + False False Nothing Nothing Nothing + , ImportDecl (⊥) (ModuleName "Data.Ascii") + False False Nothing Nothing (Just (False, [])) + , ImportDecl (⊥) (ModuleName "Data.Map") + True False Nothing (Just (ModuleName "M")) Nothing + ] + decls = [ TypeSig (⊥) [name variableName] + (TyCon (UnQual (name "ExtMap"))) + , nameBind (⊥) (name variableName) extMapExp + ] + comment = concat [ "{- !!! WARNING !!!\n" + , " This file is automatically generated.\n" + , " DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n" + ] + extMapExp = qvar (ModuleName "M") (name "fromList") `app` listE records in comment ⧺ prettyPrint hsModule ⧺ "\n" where - records ∷ [HsExp] + records ∷ [Exp] records = map record $ M.assocs extMap - record ∷ (Text, MIMEType) → HsExp + record ∷ (Text, MIMEType) → Exp record (ext, mime) - = HsTuple - [ HsApp (HsVar (Qual (Module "T") (HsIdent "pack"))) - (HsLit (HsString (T.unpack ext))) - , mimeToExp mime - ] - - mimeToExp ∷ MIMEType → HsExp - mimeToExp mt - = HsApp (HsVar (UnQual (HsIdent "parseMIMEType"))) - (HsParen - (HsApp (HsVar (Qual (Module "A") (HsIdent "unsafeFromString"))) - (HsLit (HsString $ mimeToString mt)))) + = tuple [ strE (T.unpack ext) + , metaFunction "parseMIMEType" [strE $ mimeToString mime] + ] mimeToString ∷ MIMEType → String mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index fbc8551..49317a9 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -185,16 +185,14 @@ observeChunkedRequest ctx itr input remaining if isOver then return $ acceptRequest ctx input else - do wantedM ← readTVar $ itrReqBodyWanted itr - case wantedM of - Nothing - → do wasteAll ← readTVar $ itrReqBodyWasteAll itr - if wasteAll then - return $ wasteCurrentChunk ctx itr input remaining - else - retry - Just wanted - → return $ readCurrentChunk ctx itr input wanted remaining + do wanted ← readTVar $ itrReqBodyWanted itr + case wanted of + 0 → do wasteAll ← readTVar $ itrReqBodyWasteAll itr + if wasteAll then + return $ wasteCurrentChunk ctx itr input remaining + else + retry + _ → return $ readCurrentChunk ctx itr input wanted remaining wasteCurrentChunk ∷ HandleLike h ⇒ Context h @@ -226,9 +224,7 @@ readCurrentChunk ctx itr input wanted remaining = do let bytesToRead = fromIntegral $ min wanted remaining (chunk, input') = Lazy.splitAt bytesToRead input actualReadBytes = fromIntegral $ Lazy.length chunk - newWanted = case wanted - actualReadBytes of - 0 → Nothing - n → Just n + newWanted = wanted - actualReadBytes newRemaining = remaining - actualReadBytes chunk' = S.fromList $ Lazy.toChunks chunk updateStates = atomically $ @@ -289,16 +285,14 @@ observeNonChunkedRequest ∷ HandleLike h observeNonChunkedRequest ctx itr input remaining = join $ atomically $ - do wantedM ← readTVar $ itrReqBodyWanted itr - case wantedM of - Nothing - → do wasteAll ← readTVar $ itrReqBodyWasteAll itr - if wasteAll then - return $ wasteNonChunkedRequestBody ctx itr input remaining - else - retry - Just wanted - → return $ readNonChunkedRequestBody ctx itr input wanted remaining + do wanted ← readTVar $ itrReqBodyWanted itr + case wanted of + 0 → do wasteAll ← readTVar $ itrReqBodyWasteAll itr + if wasteAll then + return $ wasteNonChunkedRequestBody ctx itr input remaining + else + retry + _ → return $ readNonChunkedRequestBody ctx itr input wanted remaining wasteNonChunkedRequestBody ∷ HandleLike h ⇒ Context h @@ -322,12 +316,13 @@ readNonChunkedRequestBody ctx itr input wanted remaining = do let bytesToRead = min wanted remaining (chunk, input') = Lazy.splitAt (fromIntegral bytesToRead) input actualReadBytes = fromIntegral $ Lazy.length chunk + newWanted = wanted - actualReadBytes newRemaining = remaining - actualReadBytes isOver = actualReadBytes < bytesToRead ∨ newRemaining ≡ 0 chunk' = S.fromList $ Lazy.toChunks chunk atomically $ do writeTVar (itrReqChunkIsOver itr) isOver - writeTVar (itrReqBodyWanted itr) Nothing + writeTVar (itrReqBodyWanted itr) newWanted writeTVar (itrReceivedBody itr) chunk' writeTVar (itrReceivedBodyLen itr) actualReadBytes if isOver then diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 298b9b2..01b6181 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -5,7 +5,6 @@ , RecordWildCards , UnicodeSyntax #-} -{-# OPTIONS_HADDOCK prune #-} -- |This is the Resource Monad; monadic actions to define the behavior -- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO' @@ -70,7 +69,7 @@ module Network.HTTP.Lucu.Resource -- * Types Resource , FormData(..) - , runRes -- private + , runRes -- * Actions @@ -624,7 +623,7 @@ input limit $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit) -- Reader にリクエスト liftIO $ atomically - $ writeTVar itrReqBodyWanted (Just actualLimit) + $ writeTVar itrReqBodyWanted actualLimit -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。 chunk ← liftIO $ atomically $ do chunkLen ← readTVar itrReceivedBodyLen @@ -692,7 +691,7 @@ inputChunk limit $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit) -- Reader にリクエスト liftIO $ atomically - $ writeTVar itrReqBodyWanted (Just actualLimit) + $ writeTVar itrReqBodyWanted actualLimit -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 chunk ← liftIO $ atomically $ do chunkLen ← readTVar itrReceivedBodyLen diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index 6bf422f..8fbe2bf 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -4,7 +4,6 @@ , RecordWildCards , UnicodeSyntax #-} -{-# OPTIONS_HADDOCK prune #-} -- | Repository of the resources in httpd. module Network.HTTP.Lucu.Resource.Tree diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 034bd78..872e078 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -9,11 +9,11 @@ module Network.HTTP.Lucu.ResponseWriter ) 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(..)) @@ -34,6 +34,11 @@ data Context h , 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) @@ -52,57 +57,69 @@ awaitSomethingToWrite ctx@(Context {..}) 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 @@ -111,26 +128,30 @@ writeContinue ctx@(Context {..}) (Interaction {..}) 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 @@ -140,7 +161,7 @@ writeBodyChunk ctx@(Context {..}) (Interaction {..}) else hPutBuilder cHandle chunk hFlush cHandle - awaitSomethingToWrite ctx + awaitSomethingToWriteOn ctx itr phase finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO () finishBodyChunk (Context {..}) (Interaction {..}) diff --git a/data/Makefile b/data/Makefile index 23c69ed..04bd97f 100644 --- a/data/Makefile +++ b/data/Makefile @@ -1,10 +1,18 @@ -../Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs: mime.types CompileMimeTypes - ./CompileMimeTypes $< $@ +../Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs: dist/DefaultExtensionMap.hs + cp -f $< $@ -CompileMimeTypes: - ghc --make $@ -i.. +dist/DefaultExtensionMap.hs: mime.types compiler + ./CompileMimeTypes $< $@.tmp + if diff $@ $@.tmp >/dev/null; then \ + rm -f $@.tmp; \ + else \ + mv -f $@.tmp $@; \ + fi + +compiler: + ghc --make CompileMimeTypes -i.. -odir dist -hidir dist clean: - rm -f *.hi *.o CompileMimeTypes + rm -rf dist DefaultExtensionMap.hs CompileMimeTypes -.PHONY: clean +.PHONY: clean compiler diff --git a/examples/Makefile b/examples/Makefile index abd928e..26d6670 100644 --- a/examples/Makefile +++ b/examples/Makefile @@ -10,7 +10,7 @@ TARGETS = \ build: $(TARGETS) %: %.hs - ghc --make $@ -threaded -O3 -fwarn-unused-imports + ghc --make $@ -threaded -O3 -Wall run: build ./HelloWorld