From: PHO Date: Mon, 31 Oct 2011 17:27:19 +0000 (+0900) Subject: Merge branch 'attoparsec' X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=commitdiff_plain;h=3eb69879d3b336c7c3e613c0ce4bfb3c67989ff3;hp=a4baee3c1411a3e256b111b4cde2ae98a6623a32 Merge branch 'attoparsec' --- diff --git a/.gitignore b/.gitignore index 0b4ee08..00bc286 100644 --- a/.gitignore +++ b/.gitignore @@ -8,6 +8,10 @@ Setup dist report.html +Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs + +data/CompileMimeTypes + examples/HelloWorld examples/Implanted examples/ImplantedSmall diff --git a/GNUmakefile b/GNUmakefile index 8b9ab31..3b5520e 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -4,14 +4,5 @@ CONFIGURE_ARGS = -O include cabal-package.mk -update-web: update-web-doc update-web-ditz - -update-web-doc: doc - rsync -av --delete \ - dist/doc/html/Lucu/ \ - www@nem.cielonegro.org:static.cielonegro.org/htdocs/doc/Lucu - -update-web-ditz: ditz - rsync -av --delete \ - dist/ditz/ \ - www@nem.cielonegro.org:static.cielonegro.org/htdocs/ditz/Lucu +build-hook: + $(MAKE) -C data diff --git a/ImplantFile.hs b/ImplantFile.hs index fd57fad..c253c2a 100644 --- a/ImplantFile.hs +++ b/ImplantFile.hs @@ -1,28 +1,35 @@ -import Codec.Compression.GZip -import Control.Monad -import Data.Bits -import qualified Data.ByteString as BS +{-# LANGUAGE + OverloadedStrings + , UnicodeSyntax + #-} +module Main where +import Codec.Compression.GZip +import Control.Applicative +import Control.Monad +import qualified Data.Ascii as A 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.Digest.Pure.SHA +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,423 +40,412 @@ data CmdOpt | OptHelp deriving (Eq, Show) - -options :: [OptDescr CmdOpt] -options = [ Option ['o'] ["output"] +options ∷ [OptDescr CmdOpt] +options = [ Option "o" ["output"] (ReqArg OptOutput "FILE") "Output to the FILE." - , Option ['m'] ["module"] + , Option "m" ["module"] (ReqArg OptModName "MODULE") "Specify the resulting module name. (required)" - , Option ['s'] ["symbol"] + , Option "s" ["symbol"] (ReqArg OptSymName "SYMBOL") "Specify the resulting symbol name." - , Option ['t'] ["mime-type"] + , Option "t" ["mime-type"] (ReqArg OptMIMEType "TYPE") "Specify the MIME Type of the file." - , Option ['e'] ["etag"] + , Option "e" ["etag"] (ReqArg OptETag "TAG") "Specify the ETag of the file." - , Option ['h'] ["help"] + , Option "h" ["help"] (NoArg OptHelp) "Print this message." ] - -printUsage :: IO () -printUsage = do putStrLn "" - putStrLn "Description:" - putStrLn (" lucu-implant-file is an utility that generates " ++ - "Haskell code containing an arbitrary file to " ++ - "compile it directly into programs and serve it " ++ - "statically with the Lucu HTTP server.") - putStrLn "" - putStrLn "Usage:" - putStrLn " lucu-implant-file [OPTIONS...] FILE" - putStrLn "" +printUsage ∷ IO () +printUsage = do mapM_ putStrLn msg putStr $ usageInfo "Options:" options putStrLn "" + 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) + $ fail "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 + mType ← getMIMEType opts srcFile + lastMod ← getLastModified srcFile + input ← openInput srcFile + output ← openOutput opts + tag ← 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] - declResourceDef - = [ HsTypeSig undefined [HsIdent symName] - (HsQualType [] - (HsTyCon (UnQual (HsIdent "ResourceDef")))) - , HsFunBind [HsMatch undefined (HsIdent symName) - [] (HsUnGuardedRhs defResourceDef) []] - ] - - defResourceDef :: HsExp - defResourceDef - = let defResGet = if useGZip - then defResGetGZipped - else defResGetRaw - in - (HsRecConstr (UnQual (HsIdent "ResourceDef")) - [ HsFieldUpdate (UnQual (HsIdent "resUsesNativeThread")) - (HsCon (UnQual (HsIdent "False"))) - , HsFieldUpdate (UnQual (HsIdent "resIsGreedy")) - (HsCon (UnQual (HsIdent "False"))) - , HsFieldUpdate (UnQual (HsIdent "resGet")) defResGet - , HsFieldUpdate (UnQual (HsIdent "resHead")) - (HsCon (UnQual (HsIdent "Nothing"))) - , HsFieldUpdate (UnQual (HsIdent "resPost")) - (HsCon (UnQual (HsIdent "Nothing"))) - , HsFieldUpdate (UnQual (HsIdent "resPut")) - (HsCon (UnQual (HsIdent "Nothing"))) - , HsFieldUpdate (UnQual (HsIdent "resDelete")) - (HsCon (UnQual (HsIdent "Nothing"))) - ] - ) - - defResGetGZipped :: HsExp - defResGetGZipped - = let doExp = HsDo [ doFoundEntity - , doSetContentType - , bindMustGunzip - , doConditionalOutput - ] - doFoundEntity - = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity"))) - (HsVar (UnQual (HsIdent "entityTag")))) - (HsVar (UnQual (HsIdent "lastModified")))) - doSetContentType - = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType"))) - (HsVar (UnQual (HsIdent "contentType")))) - bindMustGunzip - = HsGenerator undefined - (HsPVar (HsIdent "mustGunzip")) - (HsApp (HsApp (HsVar (UnQual (HsIdent "liftM"))) - (HsVar (UnQual (HsIdent "not")))) - (HsParen - (HsApp (HsVar (UnQual (HsIdent "isEncodingAcceptable"))) - (HsLit (HsString "gzip"))))) - doConditionalOutput - = HsQualifier - (HsIf (HsVar (UnQual (HsIdent "mustGunzip"))) - expOutputGunzipped - expOutputGZipped) - expOutputGunzipped - = (HsApp (HsVar (UnQual (HsIdent "outputLBS"))) - (HsParen - (HsApp (HsVar (UnQual (HsIdent "decompress"))) - (HsVar (UnQual (HsIdent "gzippedData")))))) - expOutputGZipped - = HsDo [ doSetContentEncodingGZip - , doOutputGZipped - ] - doSetContentEncodingGZip - = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentEncoding"))) - (HsList [HsLit (HsString "gzip")])) - doOutputGZipped - = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS"))) - (HsVar (UnQual (HsIdent "gzippedData")))) - in - HsApp (HsCon (UnQual (HsIdent "Just"))) - (HsParen doExp) - - defResGetRaw :: HsExp - defResGetRaw - = let doExp = HsDo [ doFoundEntity - , doSetContentType - , doOutputRawData - ] - doFoundEntity - = HsQualifier (HsApp (HsApp (HsVar (UnQual (HsIdent "foundEntity"))) - (HsVar (UnQual (HsIdent "entityTag")))) - (HsVar (UnQual (HsIdent "lastModified")))) - doSetContentType - = HsQualifier (HsApp (HsVar (UnQual (HsIdent "setContentType"))) - (HsVar (UnQual (HsIdent "contentType")))) - doOutputRawData - = HsQualifier (HsApp (HsVar (UnQual (HsIdent "outputLBS"))) - (HsVar (UnQual (HsIdent "rawData")))) - in - HsApp (HsCon (UnQual (HsIdent "Just"))) - (HsParen doExp) - - declEntityTag :: [HsDecl] - declEntityTag - = [ HsTypeSig undefined [HsIdent "entityTag"] - (HsQualType [] - (HsTyCon (UnQual (HsIdent "ETag")))) - , HsFunBind [HsMatch undefined (HsIdent "entityTag") - [] (HsUnGuardedRhs defEntityTag) []] - ] - - defEntityTag :: HsExp - defEntityTag - = HsApp (HsVar (UnQual (HsIdent "strongETag"))) - (HsLit (HsString eTag)) - - declLastModified :: [HsDecl] - declLastModified - = [ HsTypeSig undefined [HsIdent "lastModified"] - (HsQualType [] - (HsTyCon (UnQual (HsIdent "UTCTime")))) - , HsFunBind [HsMatch undefined (HsIdent "lastModified") - [] (HsUnGuardedRhs defLastModified) []] - ] - - defLastModified :: HsExp - defLastModified - = HsApp (HsVar (UnQual (HsIdent "read"))) - (HsLit (HsString $ show lastMod)) - - - declContentType :: [HsDecl] - declContentType - = [ HsTypeSig undefined [HsIdent "contentType"] - (HsQualType [] - (HsTyCon (UnQual (HsIdent "MIMEType")))) - , HsFunBind [HsMatch undefined (HsIdent "contentType") - [] (HsUnGuardedRhs defContentType) []] - ] - - defContentType :: HsExp - defContentType - = HsApp (HsVar (UnQual (HsIdent "read"))) - (HsLit (HsString $ show mimeType)) - - declGZippedData :: [HsDecl] - declGZippedData - = [ HsTypeSig undefined [HsIdent "gzippedData"] - (HsQualType [] - (HsTyCon (Qual (Module "LS") (HsIdent "ByteString")))) - , HsFunBind [HsMatch undefined (HsIdent "gzippedData") - [] (HsUnGuardedRhs defGZippedData) []] - ] - - 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) []] - ] - - 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))))]) + rawB64 = B64.encode <$> Lazy.toChunks input + gzippedB64 = B64.encode <$> Lazy.toChunks gzippedData + + header ← mkHeader srcFile originalLen gzippedLen useGZip mType tag lastMod + + let hsModule = mkModule modName symName imports decls + imports = mkImports useGZip + decls = concat [ resourceDecl symName useGZip + , entityTagDecl tag + , lastModifiedDecl lastMod + , contentTypeDecl mType + , if useGZip then + dataDecl (name "gzippedData") gzippedB64 + else + dataDecl (name "rawData") rawB64 + ] hPutStrLn output header hPutStrLn output (prettyPrint hsModule) hClose output - -mkHeader :: FilePath -> Int64 -> Int64 -> Bool -> MIMEType -> String -> UTCTime -> IO String -mkHeader srcFile originalLen gzippedLen useGZip mimeType eTag lastMod - = do localLastMod <- utcToLocalZonedTime lastMod - return ("{- DO NOT EDIT THIS FILE.\n" ++ - " This file is automatically generated by the lucu-implant-file program.\n" ++ - "\n" ++ - " Source: " ++ (if srcFile == "-" - then "(stdin)" - else srcFile) ++ "\n" ++ - " Original Length: " ++ show originalLen ++ " bytes\n" ++ - (if useGZip - then " Compressed Length: " ++ show gzippedLen ++ " bytes\n" ++ - " Compression: gzip\n" - else " Compression: disabled\n") ++ - " MIME Type: " ++ show mimeType ++ "\n" ++ - " ETag: " ++ eTag ++ "\n" ++ - " Last Modified: " ++ show localLastMod ++ "\n" ++ - " -}") - - -getModuleName :: [CmdOpt] -> IO String -getModuleName opts - = let modNameOpts = filter (\ x -> case x of - OptModName _ -> True - _ -> False) opts - in - case modNameOpts of - [] -> error "a module name must be given." - (OptModName modName):[] -> return modName - _ -> error "too many --module options." - - -getSymbolName :: [CmdOpt] -> String -> IO String -getSymbolName opts modName - = let symNameOpts = filter (\ x -> case x of - OptSymName _ -> True - _ -> False) opts - -- モジュール名をピリオドで分割した時の最後の項目の先頭文字を - -- 小文字にしたものを使ふ。 - defaultSymName = mkDefault modName - mkDefault = headToLower . getLastComp - headToLower str = case str of - [] -> error "module name must not be empty" - (x:xs) -> toLower x : xs - getLastComp = reverse . fst . break (== '.') . reverse - in - case symNameOpts of - [] -> return defaultSymName - (OptSymName symName):[] -> return symName - _ -> error "too many --symbol options." - - -getMIMEType :: [CmdOpt] -> FilePath -> IO MIMEType -getMIMEType opts srcFile - = let mimeTypeOpts = filter (\ x -> case x of - OptMIMEType _ -> True - _ -> False) opts - defaultType = fromMaybe (read "application/octet-stream") - $ guessTypeByFileName defaultExtensionMap srcFile +mkModule ∷ ModuleName → Name → [ImportDecl] → [Decl] → Module +mkModule modName symName imports decls + = let modPragma = [ LanguagePragma (⊥) [ name (show OverloadedStrings) ] ] + exports = [ EVar (UnQual symName) ] in - case mimeTypeOpts of - [] -> return defaultType - (OptMIMEType mimeType):[] -> return $ read mimeType - _ -> error "too many --mime-type options." - + Module (⊥) modName modPragma Nothing (Just exports) imports decls + +mkImports ∷ Bool → [ImportDecl] +mkImports useGZip + = [ ImportDecl (⊥) (ModuleName "Data.ByteString.Base64") + True False Nothing (Just (ModuleName "B64")) Nothing + , ImportDecl (⊥) (ModuleName "Data.ByteString.Lazy") + True False Nothing (Just (ModuleName "Lazy")) Nothing + , ImportDecl (⊥) (ModuleName "Data.Time") + False False Nothing Nothing Nothing + , ImportDecl (⊥) (ModuleName "Network.HTTP.Lucu") + False False Nothing Nothing Nothing + ] + ⧺ + [ ImportDecl (⊥) (ModuleName "Codec.Compression.GZip") + False False Nothing Nothing Nothing + | useGZip ] + +resourceDecl ∷ Name → Bool → [Decl] +resourceDecl symName useGZip + = [ TypeSig (⊥) [symName] (TyCon (UnQual (name "ResourceDef"))) + , nameBind (⊥) symName valExp + ] + where + valExp ∷ Exp + valExp = RecUpdate (function "emptyResource") + [ FieldUpdate (UnQual (name "resGet" )) resGet + , FieldUpdate (UnQual (name "resHead")) resHead + ] + + resGet ∷ Exp + resGet | useGZip = resGetGZipped + | otherwise = resGetRaw + +resHead ∷ Exp +resHead + = function "Just" `app` + paren (doE [ foundEntityStmt + , setContentTypeStmt + ]) + +resGetGZipped ∷ Exp +resGetGZipped + = function "Just" `app` + paren (doE [ foundEntityStmt + , setContentTypeStmt + , bindGZipStmt + , conditionalOutputStmt + ]) + where + condVarName ∷ Name + condVarName = name "gzipAllowed" + + dataVarName ∷ Name + dataVarName = name "gzippedData" + + bindGZipStmt ∷ Stmt + bindGZipStmt + = genStmt (⊥) + (pvar condVarName) + (function "isEncodingAcceptable" `app` strE "gzip") + + conditionalOutputStmt ∷ Stmt + conditionalOutputStmt + = qualStmt $ + If (var condVarName) + (doE [ setContentEncodingGZipStmt + , putChunksStmt (var dataVarName) + ]) + (putChunksExp + (paren + (function "decompress" `app` var dataVarName))) + +resGetRaw ∷ Exp +resGetRaw + = function "Just" `app` + paren (doE [ foundEntityStmt + , setContentTypeStmt + , putChunksStmt (function "rawData") + ]) + +setContentEncodingGZipStmt ∷ Stmt +setContentEncodingGZipStmt + = qualStmt + ( function "setContentEncoding" + `app` + listE [ strE "gzip" ] + ) + +foundEntityStmt ∷ Stmt +foundEntityStmt + = qualStmt $ + metaFunction "foundEntity" + [ var (name "entityTag") + , var (name "lastModified") + ] + +setContentTypeStmt ∷ Stmt +setContentTypeStmt + = qualStmt + ( function "setContentType" + `app` + function "contentType" + ) + +putChunksExp ∷ Exp → Exp +putChunksExp = app (function "putChunks") + +putChunksStmt ∷ Exp → Stmt +putChunksStmt = qualStmt ∘ putChunksExp + +entityTagDecl ∷ ETag → [Decl] +entityTagDecl tag + = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "ETag"))) + , nameBind (⊥) varName valExp + ] + where + varName ∷ Name + varName = name "entityTag" + + valExp ∷ Exp + valExp = function "parseETag" `app` strE (eTagToString tag) + +lastModifiedDecl ∷ UTCTime → [Decl] +lastModifiedDecl lastMod + = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "UTCTime"))) + , nameBind (⊥) varName valExp + , InlineSig (⊥) False AlwaysActive (UnQual varName) + ] + where + varName ∷ Name + varName = name "lastModified" + + valExp ∷ Exp + valExp = function "read" `app` strE (show lastMod) + +contentTypeDecl ∷ MIMEType → [Decl] +contentTypeDecl mime + = [ TypeSig (⊥) [varName] (TyCon (UnQual (name "MIMEType"))) + , nameBind (⊥) varName valExp + , InlineSig (⊥) False AlwaysActive (UnQual varName) + ] + where + varName ∷ Name + varName = name "contentType" -getLastModified :: FilePath -> IO UTCTime -getLastModified "-" = getCurrentTime -getLastModified fpath = fmap (posixSecondsToUTCTime . fromRational . toRational . modificationTime) - $ getFileStatus fpath + valExp ∷ Exp + valExp = function "parseMIMEType" `app` strE (mimeToString mime) + mimeToString ∷ MIMEType → String + mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType -getETag :: [CmdOpt] -> Lazy.ByteString -> IO String -getETag opts input - = 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." +dataDecl ∷ Name → [Strict.ByteString] → [Decl] +dataDecl varName chunks + = [ TypeSig (⊥) [varName] (TyCon (Qual (ModuleName "Lazy") (name "ByteString"))) + , nameBind (⊥) varName valExp + , InlineSig (⊥) False AlwaysActive (UnQual varName) + ] + 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 → ETag → UTCTime → IO String +mkHeader srcFile originalLen gzippedLen useGZip mType tag lastMod + = do localLastMod ← utcToLocalZonedTime lastMod + return $ concat + [ "{- 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: ", mimeTypeToString mType, "\n" + , " ETag: ", eTagToString tag, "\n" + , " Last Modified: ", show localLastMod, "\n" + , " -}" + ] + +eTagToString ∷ ETag → String +eTagToString = A.toString ∘ A.fromAsciiBuilder ∘ printETag + +mimeTypeToString ∷ MIMEType → String +mimeTypeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType + +getModuleName ∷ [CmdOpt] → IO ModuleName +getModuleName opts + = case modNameOpts of + [] → fail "a module name must be given." + OptModName modName:[] → return $ ModuleName modName + _ → fail "too many --module options." + where + modNameOpts ∷ [CmdOpt] + modNameOpts = filter (\ x → case x of + OptModName _ → True + _ → False) opts + +getSymbolName ∷ [CmdOpt] → ModuleName → IO Name +getSymbolName opts (ModuleName modName) + = case symNameOpts of + [] → return defaultSymName + OptSymName symName:[] → return $ name symName + _ → fail "too many --symbol options." where - mkETagFromInput :: Digest -> String - mkETagFromInput sha1 = "SHA-1:" ++ toHex (digestLBS sha1 input) + symNameOpts ∷ [CmdOpt] + symNameOpts = filter (\ x → case x of + OptSymName _ → True + _ → False) opts - toHex :: String -> String - toHex = foldr ((++) . hexByte . fromEnum) "" + defaultSymName ∷ Name + defaultSymName + = name $ headToLower $ getLastComp modName - hexByte :: Int -> String - hexByte n - = [ hex4bit ((n `shiftR` 4) .&. 0x0F) - , hex4bit ( n .&. 0x0F) - ] + headToLower ∷ String → String + headToLower [] = error "module name must not be empty" + headToLower (x:xs) = toLower x : xs - hex4bit :: Int -> Char - hex4bit n - | n < 10 = chr $ ord '0' + n - | n < 16 = chr $ ord 'a' + n - 10 - | otherwise = undefined + getLastComp ∷ String → String + getLastComp = reverse ∘ fst ∘ break (≡ '.') ∘ reverse +getMIMEType ∷ [CmdOpt] → FilePath → IO MIMEType +getMIMEType opts srcFile + = case mimeTypeOpts of + [] → return defaultType + OptMIMEType ty:[] + → case A.fromChars ty of + Just a → return $ parseMIMEType a + Nothing → fail "MIME type must not contain any non-ASCII letters." + _ → fail "too many --mime-type options." + where + mimeTypeOpts ∷ [CmdOpt] + mimeTypeOpts + = filter (\ x → case x of + OptMIMEType _ → True + _ → False) opts -openInput :: FilePath -> IO Lazy.ByteString -openInput "-" = LS.getContents -openInput fpath = LS.readFile fpath + octetStream ∷ MIMEType + octetStream = parseMIMEType "application/octet-stream" + defaultType ∷ MIMEType + defaultType = fromMaybe octetStream + $ guessTypeByFileName defaultExtensionMap srcFile -openOutput :: [CmdOpt] -> IO Handle -openOutput opts - = let outputOpts = filter (\ x -> case x of - OptOutput _ -> True - _ -> False) opts - in - case outputOpts of - [] -> return stdout - (OptOutput fpath):[] -> openFile fpath WriteMode - _ -> error "two many --output options." +getLastModified ∷ FilePath → IO UTCTime +getLastModified "-" = getCurrentTime +getLastModified fpath = (posixSecondsToUTCTime ∘ fromRational ∘ toRational ∘ modificationTime) + <$> + getFileStatus fpath +getETag ∷ [CmdOpt] → Lazy.ByteString → IO ETag +getETag opts input + = case eTagOpts of + [] → return mkETagFromInput + OptETag str:[] → return $ strToETag str + _ → fail "too many --etag options." + where + eTagOpts ∷ [CmdOpt] + eTagOpts = filter (\ x → case x of + OptETag _ → True + _ → False) opts + + mkETagFromInput ∷ ETag + mkETagFromInput + = strToETag $ "SHA-1:" ⧺ showDigest (sha1 input) + + strToETag ∷ String → ETag + strToETag str + = case A.fromChars str of + Just a → strongETag a + Nothing → error "ETag must not contain any non-ASCII letters." + +openInput ∷ FilePath → IO Lazy.ByteString +openInput "-" = Lazy.getContents +openInput fpath = Lazy.readFile fpath + +openOutput ∷ [CmdOpt] → IO Handle +openOutput opts + = case outputOpts of + [] → return stdout + OptOutput fpath:[] → openFile fpath WriteMode + _ → fail "two many --output options." + where + outputOpts ∷ [CmdOpt] + outputOpts = filter (\ x → case x of + OptOutput _ → True + _ → False) opts {- 作られるファイルの例 (壓縮されない場合): @@ -462,72 +458,85 @@ openOutput opts Compressed Length: 453 bytes -- これは Compression: disabled の時には無い Compression: disabled MIME Type: image/png - ETag: d41d8cd98f00b204e9800998ecf8427e + 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 + putChunk 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 + {-# NOINLINE lastModified #-} lastModified = read "2007-11-05 04:47:56.008366 UTC" - contentType :: MIMEType - contentType = read "image/png" + contentType ∷ MIMEType + {-# NOINLINE contentType #-} + contentType = parseMIMEType "image/png" - rawData :: LS.ByteString - rawData = LS.fromChunks [B64.decodeLenient (C8.pack "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRGlzdHJ...")] + rawData ∷ Lazy.ByteString + {-# NOINLINE rawData #-} + rawData = Lazy.fromChunks + [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRG..." + , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAA..." + ] ------------------------------------------------------------------------------ 壓縮される場合は次のやうに變はる: ------------------------------------------------------------------------------ -- import に追加 - import Control.Monad - import Codec.Compression.GZip + import Codec.Compression.Zlib -- 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 + + gzipAllowed ← isEncodingAcceptable "gzip" + if gzipAllowed then + do setContentEncoding ["gzip"] + putChunks gzippedData + else + putChunks (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 + {-# NOINLINE gzippedData #-} + gzippedData = Lazy.fromChunks + [ B64.decodeLenient "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQ..." + , B64.decodeLenient "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGA..." + ] ------------------------------------------------------------------------------ -} diff --git a/Lucu.cabal b/Lucu.cabal index f9c03c7..46fabcf 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -1,14 +1,15 @@ Name: Lucu -Synopsis: HTTP Daemonic Library +Synopsis: Embedded HTTP Server Description: - Lucu is an HTTP daemonic library. It can be embedded in any - Haskell program and runs in an independent thread. Lucu is - not a replacement for Apache or lighttpd. It is intended to be - used to create an efficient web-based RESTful application - 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 + + Lucu is an embedded HTTP server library. + + It's not a replacement for Apache nor lighttpd. It is intended + to be used to build an efficient web-based RESTful application + which runs behind a reverse-proxy so it doesn't have some + functionalities like logging, client filtering and such. + +Version: 1.0 License: PublicDomain License-File: COPYING Author: PHO @@ -24,6 +25,7 @@ Extra-Source-Files: ImplantFile.hs NEWS data/CompileMimeTypes.hs + data/Makefile data/mime.types examples/HelloWorld.hs examples/Implanted.hs @@ -44,28 +46,34 @@ Flag build-lucu-implant-file Library Build-Depends: - HsOpenSSL == 0.10.*, - base == 4.3.*, - base-unicode-symbols == 0.2.*, - base64-bytestring == 0.1.*, - bytestring == 0.9.*, - containers == 0.4.*, - filepath == 1.2.*, - directory == 1.1.*, - haskell-src == 1.0.*, - hxt == 9.1.*, - mtl == 2.0.*, - network == 2.3.*, - stm == 2.2.*, - time == 1.2.*, - time-http == 0.1.*, - unix == 2.4.*, - zlib == 0.5.* + HsOpenSSL == 0.10.*, + ascii == 0.0.*, + attoparsec == 0.9.*, + base == 4.*, + base-unicode-symbols == 0.2.*, + base64-bytestring == 0.1.*, + blaze-builder == 0.3.*, + blaze-textual == 0.2.*, + bytestring == 0.9.*, + containers == 0.4.*, + containers-unicode-symbols == 0.3.*, + filepath == 1.2.*, + haskell-src-exts == 1.11.*, + hxt == 9.1.*, + mtl == 2.0.*, + network == 2.3.*, + stm == 2.2.*, + stringsearch == 0.3.*, + text == 0.11.*, + time == 1.2.*, + time-http == 0.2.*, + transformers == 0.2.*, + unix == 2.4.* Exposed-Modules: Network.HTTP.Lucu Network.HTTP.Lucu.Abortion - Network.HTTP.Lucu.Authorization + Network.HTTP.Lucu.Authentication Network.HTTP.Lucu.Config Network.HTTP.Lucu.ETag Network.HTTP.Lucu.HttpVersion @@ -73,8 +81,10 @@ Library Network.HTTP.Lucu.MIMEType Network.HTTP.Lucu.MIMEType.DefaultExtensionMap Network.HTTP.Lucu.MIMEType.Guess - Network.HTTP.Lucu.Parser + Network.HTTP.Lucu.MultipartForm Network.HTTP.Lucu.Parser.Http + Network.HTTP.Lucu.Parser + Network.HTTP.Lucu.RFC2231 Network.HTTP.Lucu.Request Network.HTTP.Lucu.Resource Network.HTTP.Lucu.Resource.Tree @@ -83,23 +93,22 @@ Library Network.HTTP.Lucu.Utils Other-Modules: + Network.HTTP.Lucu.Abortion.Internal 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 - Network.HTTP.Lucu.MultipartForm Network.HTTP.Lucu.Postprocess Network.HTTP.Lucu.Preprocess Network.HTTP.Lucu.RequestReader + Network.HTTP.Lucu.Resource.Internal Network.HTTP.Lucu.ResponseWriter Network.HTTP.Lucu.SocketLike ghc-options: -Wall - -funbox-strict-fields Executable lucu-implant-file if flag(build-lucu-implant-file) @@ -109,9 +118,12 @@ Executable lucu-implant-file Main-Is: ImplantFile.hs + Build-Depends: + SHA == 1.5.*, + zlib == 0.5.* + ghc-options: -Wall - -funbox-strict-fields --Executable HelloWorld -- Main-Is: HelloWorld.hs diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs index 52315d6..901ae00 100644 --- a/Network/HTTP/Lucu.hs +++ b/Network/HTTP/Lucu.hs @@ -1,92 +1,81 @@ --- | Lucu is an HTTP daemonic library. It can be embedded in any --- Haskell program and runs in an independent thread. +-- | Lucu is an embedded HTTP server library. -- -- Features: -- +-- [/Affinity for RESTafarians/] Lucu is specifically designed to be +-- suitable for RESTful applications. +-- -- [/Full support of HTTP\/1.1/] Lucu supports request pipelining, -- chunked I\/O, ETag comparison and \"100 Continue\". -- --- [/Performance/] Lucu doesn't fork\/exec to handle requests like --- CGI. It just spawns a new thread. Inter-process communication is --- done with STM. --- --- [/Affinity for RESTafarians/] Lucu is a carefully designed --- web server for RESTful applications. --- --- [/SSL connections/] Lucu can handle HTTP connections over SSL --- layer. +-- [/SSL connections/] Lucu can handle HTTP connections over Secure +-- Socket Layer. -- -- Lucu is not a replacement for Apache or lighttpd. It is intended to --- be used to create an efficient web-based RESTful application --- without messing around FastCGI. It is also intended to be run --- behind a reverse-proxy so it doesn't have the following (otherwise --- essential) facilities: +-- be used to build an efficient web-based RESTful application which +-- runs behind a reverse-proxy so it doesn't have the following +-- (otherwise essential) functionalities: -- --- [/Logging/] Lucu doesn't log any requests from any clients. +-- [/Logging/] Lucu doesn't write logs of any requests from any +-- clients. -- -- [/Client Filtering/] Lucu always accepts any clients. No IP -- filter is implemented. -- -- [/Bandwidth Limitting/] Lucu doesn't limit bandwidth it consumes. -- --- [/Protection Against Wicked Clients/] Lucu is fragile against --- wicked clients. No attacker should be able to cause a +-- [/Protection Against Wicked Clients/] Lucu is somewhat fragile +-- against wicked clients. No attacker should be able to cause a -- buffer-overflow but can possibly DoS it. -- - - module Network.HTTP.Lucu ( -- * Entry Point runHttpd - -- * Configuration + -- * 'Config'uration , module Network.HTTP.Lucu.Config -- * Resource Tree - , ResourceDef(..) - , emptyResource , ResTree , mkResTree - -- * Resource Monad + -- * 'Resource' Monad , module Network.HTTP.Lucu.Resource -- ** Things to be used in the Resource monad - -- *** Status Code , StatusCode(..) - -- *** Abortion - , abort - , abortPurely - , abortA + -- *** 'Abortion' + , module Network.HTTP.Lucu.Abortion -- *** ETag , ETag(..) , strongETag , weakETag + , parseETag -- *** MIME Type , MIMEType(..) + , mkMIMEType + , parseMIMEType - -- *** Authorization + -- *** Authentication , AuthChallenge(..) , AuthCredential(..) - -- * Utility - + -- * Utilities -- ** Static file handling , module Network.HTTP.Lucu.StaticFile ) where - import Network.HTTP.Lucu.Abortion -import Network.HTTP.Lucu.Authorization +import Network.HTTP.Lucu.Authentication import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.ETag import Network.HTTP.Lucu.Httpd import Network.HTTP.Lucu.MIMEType -import Network.HTTP.Lucu.Resource hiding (driftTo) +import Network.HTTP.Lucu.Resource import Network.HTTP.Lucu.Resource.Tree import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.StaticFile diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs index 26ea8b0..40a8cb5 100644 --- a/Network/HTTP/Lucu/Abortion.hs +++ b/Network/HTTP/Lucu/Abortion.hs @@ -1,117 +1,50 @@ {-# LANGUAGE - DeriveDataTypeable - , UnicodeSyntax + UnicodeSyntax #-} -{-# OPTIONS_HADDOCK prune #-} - -- |Aborting the computation of 'Network.HTTP.Lucu.Resource.Resource' -- in any 'Prelude.IO' monads or arrows. module Network.HTTP.Lucu.Abortion - ( Abortion(..) + ( Abortion + , mkAbortion + , mkAbortion' + , abort - , abortPurely - , abortSTM - , abortA - , abortPage ) where - -import Control.Arrow -import Control.Arrow.ArrowIO -import Control.Concurrent.STM -import Control.Exception -import Control.Monad.Trans -import qualified Data.ByteString.Char8 as C8 -import Data.Typeable -import GHC.Conc (unsafeIOToSTM) -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.DefaultPage -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.Request -import Network.HTTP.Lucu.Response -import System.IO.Unsafe -import Text.XML.HXT.Arrow.WriteDocument -import Text.XML.HXT.Arrow.XmlArrow -import Text.XML.HXT.Arrow.XmlState - - -data Abortion = Abortion { - aboStatus :: !StatusCode - , aboHeaders :: !Headers - , aboMessage :: !(Maybe String) - } deriving (Show, Typeable) - -instance Exception Abortion - --- |Computation of @'abort' status headers msg@ aborts the --- 'Network.HTTP.Lucu.Resource.Resource' monad with given status, --- additional response headers, and optional message string. --- --- What this really does is to throw a special --- 'Control.Exception.Exception'. The exception will be caught by the --- Lucu system. --- --- 1. If the 'Network.HTTP.Lucu.Resource.Resource' is in the /Deciding --- Header/ or any precedent states, it is possible to use the --- @status@ and such like as a HTTP response to be sent to the --- client. --- --- 2. Otherwise the HTTP response can't be modified anymore so the --- only possible thing the system can do is to dump it to the --- stderr. See --- 'Network.HTTP.Lucu.Config.cnfDumpTooLateAbortionToStderr'. --- --- Note that the status code doesn't have to be an error code so you --- can use this action for redirection as well as error reporting e.g. --- --- > abort MovedPermanently --- > [("Location", "http://example.net/")] --- > (Just "It has been moved to example.net") -abort :: MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a -abort status headers msg - = status `seq` headers `seq` msg `seq` - let abo = Abortion status (toHeaders $ map pack headers) msg - in - liftIO $ throwIO abo - where - pack (x, y) = (C8.pack x, C8.pack y) - --- |This is similar to 'abort' but computes it with --- 'System.IO.Unsafe.unsafePerformIO'. -abortPurely :: StatusCode -> [ (String, String) ] -> Maybe String -> a -abortPurely = ((unsafePerformIO .) .) . abort - --- |Computation of @'abortSTM' status headers msg@ just computes --- 'abort' in a 'Control.Monad.STM.STM' monad. -abortSTM :: StatusCode -> [ (String, String) ] -> Maybe String -> STM a -abortSTM status headers msg - = status `seq` headers `seq` msg `seq` - unsafeIOToSTM $! abort status headers msg - --- | Computation of @'abortA' -< (status, (headers, msg))@ just --- computes 'abort' in an 'Control.Arrow.ArrowIO.ArrowIO'. -abortA :: ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c -abortA - = arrIO3 abort - --- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、 --- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な --- ければならない。 -abortPage :: Config -> Maybe Request -> Response -> Abortion -> String -abortPage conf reqM res abo - = conf `seq` reqM `seq` res `seq` abo `seq` - case aboMessage abo of - Just msg - -> let [html] = unsafePerformIO - $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg) - >>> - writeDocumentToString [ withIndent True ] - ) - in - html - Nothing - -> let res' = res { resStatus = aboStatus abo } - res'' = foldl (.) id [setHeader name value - | (name, value) <- fromHeaders $ aboHeaders abo] res' - in - getDefaultPage conf reqM res'' +import Control.Exception +import Control.Monad.Trans +import Data.Ascii (Ascii, CIAscii) +import Data.Monoid.Unicode +import Data.Text (Text) +import Network.HTTP.Lucu.Abortion.Internal +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.Response +import Prelude.Unicode + +-- |Construct an 'Abortion' with additional headers and an optional +-- message text. +mkAbortion ∷ StatusCode → [(CIAscii, Ascii)] → Maybe Text → Abortion +{-# INLINE mkAbortion #-} +mkAbortion sc hdr msg + = Abortion { + aboStatus = sc + , aboHeaders = toHeaders hdr + , aboMessage = msg + } + +-- |Construct an 'Abortion' without any additional headers but with a +-- message text. +mkAbortion' ∷ StatusCode → Text → Abortion +{-# INLINE mkAbortion' #-} +mkAbortion' sc msg + = Abortion { + aboStatus = sc + , aboHeaders = (∅) + , aboMessage = Just msg + } + +-- |Throw an 'Abortion' in a 'MonadIO', including the very +-- 'Network.HTTP.Lucu.Resource.Resource' monad. +abort ∷ MonadIO m ⇒ Abortion → m a +{-# INLINE abort #-} +abort = liftIO ∘ throwIO diff --git a/Network/HTTP/Lucu/Abortion/Internal.hs b/Network/HTTP/Lucu/Abortion/Internal.hs new file mode 100644 index 0000000..f71e045 --- /dev/null +++ b/Network/HTTP/Lucu/Abortion/Internal.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE + DeriveDataTypeable + , UnicodeSyntax + #-} +module Network.HTTP.Lucu.Abortion.Internal + ( Abortion(..) + , abortPage + ) + where +import Blaze.ByteString.Builder (Builder) +import qualified Blaze.ByteString.Builder.Char.Utf8 as BB +import Control.Arrow.ListArrow +import Control.Arrow.Unicode +import Control.Exception +import Data.Text (Text) +import qualified Data.Text as T +import Data.Typeable +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.DefaultPage +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Response +import Prelude.Unicode +import Text.XML.HXT.Arrow.WriteDocument +import Text.XML.HXT.Arrow.XmlArrow +import Text.XML.HXT.Arrow.XmlState + +-- |'Abortion' is an 'Exception' that aborts the execution of +-- 'Network.HTTP.Lucu.Resource.Resource' monad with a 'StatusCode', +-- additional response headers, and an optional message text. +-- +-- 1. If the 'Network.HTTP.Lucu.Resource.Resource' is in the /Deciding +-- Header/ or any precedent states, throwing an 'Abortion' affects +-- the HTTP response to be sent to the client. +-- +-- 2. Otherwise it's too late to overwrite the HTTP response so the +-- only possible thing the system can do is to dump the exception +-- to the stderr. See 'cnfDumpTooLateAbortionToStderr'. +-- +-- Note that the status code doesn't necessarily have to satisfy +-- 'isError' so you can abuse this exception for redirections as well +-- as error reporting e.g. +-- +-- > abort $ mkAbortion MovedPermanently +-- > [("Location", "http://example.net/")] +-- > "It has been moved to example.net" +data Abortion = Abortion { + aboStatus ∷ !StatusCode + , aboHeaders ∷ !Headers + , aboMessage ∷ !(Maybe Text) + } deriving (Eq, Show, Typeable) + +instance Exception Abortion + +instance HasHeaders Abortion where + getHeaders = aboHeaders + setHeaders abo hdr = abo { aboHeaders = hdr } + +abortPage ∷ Config → Maybe Request → Response → Abortion → Builder +abortPage conf reqM res abo + = case aboMessage abo of + Just msg + → let [html] = runLA ( mkDefaultPage conf (aboStatus abo) (txt $ T.unpack msg) + ⋙ + writeDocumentToString [ withIndent True ] + ) () + in + BB.fromString html + Nothing + → let res' = res { resStatus = aboStatus abo } + res'' = foldl (∘) id [setHeader name value + | (name, value) ← fromHeaders $ aboHeaders abo] res' + in + getDefaultPage conf reqM res'' diff --git a/Network/HTTP/Lucu/Authentication.hs b/Network/HTTP/Lucu/Authentication.hs new file mode 100644 index 0000000..753af6e --- /dev/null +++ b/Network/HTTP/Lucu/Authentication.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE + OverloadedStrings + , UnicodeSyntax + #-} +-- |HTTP Authentication +module Network.HTTP.Lucu.Authentication + ( AuthChallenge(..) + , AuthCredential(..) + , Realm + , UserID + , Password + + , printAuthChallenge + , authCredential + ) + where +import Control.Monad +import Data.Ascii (Ascii) +import qualified Data.Ascii as A +import Data.Attoparsec.Char8 +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as C8 +import Data.Monoid.Unicode +import Network.HTTP.Lucu.Parser.Http +import Network.HTTP.Lucu.Utils +import Prelude.Unicode + +-- |Authentication challenge to be sent to clients with +-- \"WWW-Authenticate\" header field. See +-- 'Network.HTTP.Lucu.Resource.setWWWAuthenticate'. +data AuthChallenge + = BasicAuthChallenge !Realm + deriving (Eq) + +-- |'Realm' is just an 'Ascii' string. +type Realm = Ascii + +-- |Authorization credential to be sent by client with +-- \"Authorization\" header. See +-- 'Network.HTTP.Lucu.Resource.getAuthorization'. +data AuthCredential + = BasicAuthCredential !UserID !Password + deriving (Show, Eq) + +-- |'UserID' is just an 'Ascii' string containing no colons (\':\'). +type UserID = Ascii + +-- |'Password' is just an 'Ascii' string. +type Password = Ascii + +-- |Convert an 'AuthChallenge' to 'Ascii'. +printAuthChallenge ∷ AuthChallenge → Ascii +printAuthChallenge (BasicAuthChallenge realm) + = A.fromAsciiBuilder $ + A.toAsciiBuilder "Basic realm=" ⊕ quoteStr realm + +-- |'Parser' for an 'AuthCredential'. +authCredential ∷ Parser AuthCredential +authCredential + = do void $ string "Basic" + skipMany1 lws + b64 ← takeWhile1 base64 + case C8.break (≡ ':') (B64.decodeLenient b64) of + (user, cPassword) + | C8.null cPassword + → fail "no colons in the basic auth credential" + | otherwise + → do u ← asc user + p ← asc (C8.tail cPassword) + return (BasicAuthCredential u p) + where + base64 ∷ Char → Bool + base64 = inClass "a-zA-Z0-9+/=" + + asc ∷ C8.ByteString → Parser Ascii + asc bs = case A.fromByteString bs of + Just as → return as + Nothing → fail "Non-ascii character in auth credential" diff --git a/Network/HTTP/Lucu/Authorization.hs b/Network/HTTP/Lucu/Authorization.hs deleted file mode 100644 index 6b0e1c2..0000000 --- a/Network/HTTP/Lucu/Authorization.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE - UnicodeSyntax - #-} -{-# OPTIONS_HADDOCK prune #-} - --- |Manipulation of WWW authorization. -module Network.HTTP.Lucu.Authorization - ( AuthChallenge(..) - , AuthCredential(..) - , Realm - , UserID - , Password - - , authCredentialP -- private - ) - where -import qualified Data.ByteString.Base64 as B64 -import qualified Data.ByteString.Char8 as C8 -import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Parser.Http -import Network.HTTP.Lucu.Utils -import Prelude.Unicode - --- |Authorization challenge to be sent to client with --- \"WWW-Authenticate\" header. See --- 'Network.HTTP.Lucu.Resource.setWWWAuthenticate'. -data AuthChallenge - = BasicAuthChallenge Realm - deriving (Eq) - --- |'Realm' is just a string which must not contain any non-ASCII letters. -type Realm = String - --- |Authorization credential to be sent by client with --- \"Authorization\" header. See --- 'Network.HTTP.Lucu.Resource.getAuthorization'. -data AuthCredential - = BasicAuthCredential UserID Password - deriving (Show, Eq) - --- |'UserID' is just a string which must not contain colon and any --- non-ASCII letters. -type UserID = String - --- |'Password' is just a string which must not contain any non-ASCII --- letters. -type Password = String - -instance Show AuthChallenge where - show (BasicAuthChallenge realm) - = "Basic realm=" ⧺ quoteStr realm - -authCredentialP ∷ Parser AuthCredential -authCredentialP - = allowEOF $! - do _ ← string "Basic" - _ ← many1 lws - b64 ← many1 - $ satisfy (\c → (c ≥ 'a' ∧ c ≤ 'z') ∨ - (c ≥ 'A' ∧ c ≤ 'Z') ∨ - (c ≥ '0' ∧ c ≤ '9') ∨ - c ≡ '+' ∨ - c ≡ '/' ∨ - c ≡ '=') - case break (≡ ':') (decode b64) of - (uid, ':' : password) - → return (BasicAuthCredential uid password) - _ → failP - where - decode ∷ String → String - decode = C8.unpack ∘ B64.decodeLenient ∘ C8.pack diff --git a/Network/HTTP/Lucu/Chunk.hs b/Network/HTTP/Lucu/Chunk.hs index 27deb74..e8c9de4 100644 --- a/Network/HTTP/Lucu/Chunk.hs +++ b/Network/HTTP/Lucu/Chunk.hs @@ -1,38 +1,34 @@ +{-# LANGUAGE + UnicodeSyntax + #-} module Network.HTTP.Lucu.Chunk - ( chunkHeaderP -- Num a => Parser a - , chunkFooterP -- Parser () - , chunkTrailerP -- Parser Headers + ( chunkHeader + , chunkFooter + , chunkTrailer ) where - -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Parser.Http -import Numeric - - -chunkHeaderP :: Num a => Parser a -chunkHeaderP = do hexLen <- many1 hexDigit - _ <- extension - _ <- crlf - - let [(len, _)] = readHex hexLen - return len +import Control.Applicative +import Data.Attoparsec.Char8 +import Data.Bits +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.Parser.Http + +chunkHeader ∷ (Integral a, Bits a) ⇒ Parser a +{-# INLINEABLE chunkHeader #-} +chunkHeader = do len ← hexadecimal + extension + crlf + return len where - extension :: Parser () - extension = many ( char ';' >> - token >> - char '=' >> - ( token <|> quotedStr ) - ) - >> - return () -{-# SPECIALIZE chunkHeaderP :: Parser Int #-} - - -chunkFooterP :: Parser () -chunkFooterP = crlf >> return () - - -chunkTrailerP :: Parser Headers -chunkTrailerP = headersP + extension ∷ Parser () + extension + = skipMany ( char ';' *> + token *> + char '=' *> + (token <|> quotedStr) ) + +chunkFooter ∷ Parser () +chunkFooter = crlf + +chunkTrailer ∷ Parser Headers +chunkTrailer = headers diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs index cb3f4a8..2ea2055 100644 --- a/Network/HTTP/Lucu/Config.hs +++ b/Network/HTTP/Lucu/Config.hs @@ -1,113 +1,108 @@ --- |Configurations for the Lucu httpd like a port to listen. +{-# LANGUAGE + OverloadedStrings + , UnicodeSyntax + #-} +-- |Configurations for the Lucu httpd. module Network.HTTP.Lucu.Config ( Config(..) , SSLConfig(..) , defaultConfig ) where - -import qualified Data.ByteString as Strict (ByteString) -import qualified Data.ByteString.Char8 as C8 hiding (ByteString) -import Network -import Network.BSD -import Network.HTTP.Lucu.MIMEType.Guess -import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap -import OpenSSL.Session -import System.IO.Unsafe - --- |Configuration record for the Lucu httpd. You need to use --- 'defaultConfig' or setup your own configuration to run the httpd. +import Data.Ascii (Ascii) +import Data.Text (Text) +import qualified Data.Text as T +import Network +import Network.BSD +import Network.HTTP.Lucu.MIMEType.Guess +import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap +import OpenSSL.Session +import System.IO.Unsafe + +-- |Configuration record for to run the httpd. data Config = Config { - -- |A string which will be sent to clients as \"Server\" field. - cnfServerSoftware :: !Strict.ByteString + -- |A banner string to be sent to clients with \"Server\" response + -- header field. + cnfServerSoftware ∷ !Ascii -- |The host name of the server. This value will be used in -- built-in pages like \"404 Not Found\". - , cnfServerHost :: !Strict.ByteString + , cnfServerHost ∷ !Text - -- |A port number (or service name) to listen to HTTP clients. - , cnfServerPort :: !ServiceName + -- |A port number (or a service name) to listen to HTTP clients. + , cnfServerPort ∷ !ServiceName -- |Local IPv4 address to listen to both HTTP and HTTPS -- clients. Set this to @('Just' "0.0.0.0")@ if you want to accept -- any IPv4 connections. Set this to 'Nothing' to disable IPv4. - , cnfServerV4Addr :: !(Maybe HostName) + , cnfServerV4Addr ∷ !(Maybe HostName) -- |Local IPv6 address to listen to both HTTP and HTTPS -- clients. Set this to @('Just' "::")@ if you want to accept any -- IPv6 connections. Set this to 'Nothing' to disable IPv6. Note - -- that there is currently no way to assign separate ports to IPv4 - -- and IPv6 server sockets. - , cnfServerV6Addr :: !(Maybe HostName) + -- that there is currently no ways to assign separate ports to + -- IPv4 and IPv6 server sockets (but I don't think that will be a + -- problem.) + , cnfServerV6Addr ∷ !(Maybe HostName) -- |Configuration for HTTPS connections. Set this 'Nothing' to -- disable HTTPS. - , cnfSSLConfig :: !(Maybe SSLConfig) + , cnfSSLConfig ∷ !(Maybe SSLConfig) - -- |The maximum number of requests to accept in one connection - -- simultaneously. If a client exceeds this limitation, its last + -- |The maximum number of requests to simultaneously accept in one + -- connection. If a client exceeds this limitation, its last -- request won't be processed until a response for its earliest -- pending request is sent back to the client. - , cnfMaxPipelineDepth :: !Int + , cnfMaxPipelineDepth ∷ !Int - -- |The maximum length of request entity to accept in bytes. Note - -- that this is nothing but the default value which is used when - -- 'Network.HTTP.Lucu.Resource.input' and such like are applied to - -- 'Network.HTTP.Lucu.Resource.defaultLimit', so there is no - -- guarantee that this value always constrains all the requests. - , cnfMaxEntityLength :: !Int + -- |The maximum length of request entity to accept in octets. Note + -- that this is nothing but a default value used by + -- 'Network.HTTP.Lucu.Resource.getForm' and such when they are + -- applied to 'Nothing', so there is no guarantee that this value + -- always constrains all the requests. + , cnfMaxEntityLength ∷ !Int - -- |The maximum length of chunk to output. This value is used by - -- 'Network.HTTP.Lucu.Resource.output' and such like to limit the - -- chunk length so you can safely output an infinite string (like - -- a lazy stream of \/dev\/random) using those actions. - , cnfMaxOutputChunkLength :: !Int - - -- | Whether to dump too late abortion to the stderr or not. See + -- |Whether to dump too late abortions to the stderr or not. See -- 'Network.HTTP.Lucu.Abortion.abort'. - , cnfDumpTooLateAbortionToStderr :: !Bool + , cnfDumpTooLateAbortionToStderr ∷ !Bool - -- |A mapping from extension to MIME Type. This value is used by - -- 'Network.HTTP.Lucu.StaticFile.staticFile' to guess the MIME - -- Type of static files. Note that MIME Types are currently - -- guessed only by file name. + -- |A mapping table from file extensions to MIME Types. This value + -- is used by 'Network.HTTP.Lucu.StaticFile.staticFile' to guess + -- the MIME Type of static files. Note that MIME Types are + -- currently guessed only by file name. -- - -- Guessing by file magic is indeed a wonderful idea but that is - -- not implemented (yet). But, don't you think it's better a file - -- system got a MIME Type as a part of inode? Or it might be a - -- good idea to use GnomeVFS - -- () - -- instead of vanilla FS. - , cnfExtToMIMEType :: !ExtMap + -- Guessing by file magic might be a good idea but that's not + -- implemented (yet). + , cnfExtToMIMEType ∷ !ExtMap } -- |Configuration record for HTTPS connections. data SSLConfig = SSLConfig { - -- |A port ID to listen to HTTPS clients. Local addresses - -- (both for IPv4 and IPv6) will be derived from the parent - -- 'Config'. - sslServerPort :: !ServiceName - - -- |An SSL context for accepting connections. - , sslContext :: !SSLContext + -- |A port number (or a service name) to listen to HTTPS + -- clients. Local addresses (both for IPv4 and IPv6) will be + -- derived from the parent 'Config'. + sslServerPort ∷ !ServiceName + + -- |An SSL context for accepting connections. You must set it + -- up yourself with at least a server certification. + , sslContext ∷ !SSLContext } -- |The default configuration. Generally you can use this value as-is, -- or possibly you just want to replace the 'cnfServerSoftware' and -- 'cnfServerPort'. SSL connections are disabled by default. -defaultConfig :: Config +defaultConfig ∷ Config defaultConfig = Config { - cnfServerSoftware = C8.pack "Lucu/1.0" - , cnfServerHost = C8.pack (unsafePerformIO getHostName) + cnfServerSoftware = "Lucu/1.0" + , cnfServerHost = T.pack (unsafePerformIO getHostName) , cnfServerPort = "http" , cnfServerV4Addr = Just "0.0.0.0" , cnfServerV6Addr = Just "::" , cnfSSLConfig = Nothing , cnfMaxPipelineDepth = 100 , cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB - , cnfMaxOutputChunkLength = 5 * 1024 * 1024 -- 5 MiB , cnfDumpTooLateAbortionToStderr = True , cnfExtToMIMEType = defaultExtensionMap } diff --git a/Network/HTTP/Lucu/ContentCoding.hs b/Network/HTTP/Lucu/ContentCoding.hs index 27a8941..a5f02b1 100644 --- a/Network/HTTP/Lucu/ContentCoding.hs +++ b/Network/HTTP/Lucu/ContentCoding.hs @@ -1,48 +1,58 @@ +{-# LANGUAGE + OverloadedStrings + , UnicodeSyntax + #-} module Network.HTTP.Lucu.ContentCoding - ( acceptEncodingListP + ( AcceptEncoding(..) + + , acceptEncodingList , normalizeCoding , unnormalizeCoding - , orderAcceptEncodings ) where - -import Data.Char -import Data.Ord -import Data.Maybe -import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Parser.Http - - -acceptEncodingListP :: Parser [(String, Maybe Double)] -acceptEncodingListP = allowEOF $! listOf accEncP - - -accEncP :: Parser (String, Maybe Double) -accEncP = do coding <- token - qVal <- option Nothing - $ do _ <- string ";q=" - q <- qvalue - return $ Just q - return (normalizeCoding coding, qVal) - - -normalizeCoding :: String -> String +import Control.Applicative +import Data.Ascii (CIAscii, toCIAscii) +import Data.Attoparsec.Char8 +import Data.Ord +import Data.Maybe +import Network.HTTP.Lucu.Parser.Http +import Prelude.Unicode + +data AcceptEncoding + = AcceptEncoding { + aeEncoding ∷ !CIAscii + , aeQValue ∷ !(Maybe Double) + } + deriving (Eq, Show) + +instance Ord AcceptEncoding where + (AcceptEncoding c1 q1) `compare` (AcceptEncoding c2 q2) + | q1' > q1' = GT + | q1' < q2' = LT + | otherwise = compare c1 c2 + where + q1' = fromMaybe 0 q1 + q2' = fromMaybe 0 q2 + +acceptEncodingList ∷ Parser [AcceptEncoding] +acceptEncodingList = listOf accEnc + +accEnc ∷ Parser AcceptEncoding +accEnc = do coding ← toCIAscii <$> token + qVal ← option Nothing + $ do _ ← string ";q=" + q ← qvalue + return $ Just q + return $ AcceptEncoding (normalizeCoding coding) qVal + +normalizeCoding ∷ CIAscii → CIAscii normalizeCoding coding - = case map toLower coding of - "x-gzip" -> "gzip" - "x-compress" -> "compress" - other -> other - + | coding ≡ "x-gzip" = "gzip" + | coding ≡ "x-compress" = "compress" + | otherwise = coding -unnormalizeCoding :: String -> String +unnormalizeCoding ∷ CIAscii → CIAscii unnormalizeCoding coding - = case map toLower coding of - "gzip" -> "x-gzip" - "compress" -> "x-compress" - other -> other - - -orderAcceptEncodings :: (String, Maybe Double) -> (String, Maybe Double) -> Ordering -orderAcceptEncodings (_, q1) (_, q2) - = comparing (fromMaybe 0) q1 q2 - + | coding ≡ "gzip" = "x-gzip" + | coding ≡ "compress" = "x-compress" + | otherwise = coding diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index 12aba15..19a7293 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -1,93 +1,82 @@ {-# LANGUAGE - BangPatterns - , UnboxedTuples + OverloadedStrings , UnicodeSyntax #-} module Network.HTTP.Lucu.DefaultPage ( getDefaultPage - , writeDefaultPage + , defaultPageContentType , mkDefaultPage ) where - -import Control.Arrow -import Control.Arrow.ArrowList -import Control.Concurrent.STM -import Control.Monad -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Lazy.Char8 as L8 -import Data.Maybe -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.Format -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.Interaction -import Network.HTTP.Lucu.Request -import Network.HTTP.Lucu.Response -import Network.URI hiding (path) -import System.IO.Unsafe -import Text.XML.HXT.Arrow.WriteDocument -import Text.XML.HXT.Arrow.XmlArrow -import Text.XML.HXT.Arrow.XmlState -import Text.XML.HXT.DOM.TypeDefs - - -getDefaultPage :: Config -> Maybe Request -> Response -> String -getDefaultPage !conf !req !res - = let msgA = getMsg req res +import Blaze.ByteString.Builder (Builder) +import qualified Blaze.ByteString.Builder.Char.Utf8 as BB +import Control.Arrow +import Control.Arrow.ArrowList +import Control.Arrow.ListArrow +import Control.Arrow.Unicode +import Data.Ascii (Ascii) +import qualified Data.Ascii as A +import Data.Maybe +import qualified Data.Text as T +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Response +import Network.URI hiding (path) +import Prelude.Unicode +import Text.XML.HXT.Arrow.WriteDocument +import Text.XML.HXT.Arrow.XmlArrow +import Text.XML.HXT.Arrow.XmlState +import Text.XML.HXT.DOM.TypeDefs + +getDefaultPage ∷ Config → Maybe Request → Response → Builder +{-# INLINEABLE getDefaultPage #-} +getDefaultPage conf req res + = let msgA = getMsg req res + [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA + ⋙ + writeDocumentToString [ withIndent True ] + ) () in - unsafePerformIO $ - do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA - >>> - writeDocumentToString [ withIndent True ] - ) - return xmlStr - - -writeDefaultPage :: Interaction -> STM () -writeDefaultPage !itr - -- Content-Type が正しくなければ補完できない。 - = do res <- readItr itr itrResponse id - when (getHeader (C8.pack "Content-Type") res == Just defaultPageContentType) - $ do reqM <- readItr itr itrRequest id - - let conf = itrConfig itr - page = L8.pack $ getDefaultPage conf reqM res - - writeTVar (itrBodyToSend itr) - $ page - - -mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree -mkDefaultPage !conf !status !msgA - = let (# sCode, sMsg #) = statusCode status - sig = C8.unpack (cnfServerSoftware conf) - ++ " at " - ++ C8.unpack (cnfServerHost conf) + BB.fromString xmlStr + +defaultPageContentType ∷ Ascii +{-# INLINE defaultPageContentType #-} +defaultPageContentType = "application/xhtml+xml" + +mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree +{-# INLINEABLE mkDefaultPage #-} +mkDefaultPage conf status msgA + = let sStr = A.toString $ A.fromAsciiBuilder $ printStatusCode status + sig = concat [ A.toString (cnfServerSoftware conf) + , " at " + , T.unpack (cnfServerHost conf) + ] in ( eelem "/" += ( eelem "html" += sattr "xmlns" "http://www.w3.org/1999/xhtml" += ( eelem "head" += ( eelem "title" - += txt (fmtDec 3 sCode ++ " " ++ C8.unpack sMsg) + += txt sStr )) += ( eelem "body" += ( eelem "h1" - += txt (C8.unpack sMsg) + += txt sStr ) += ( eelem "p" += msgA ) += eelem "hr" += ( eelem "address" += txt sig )))) -{-# SPECIALIZE mkDefaultPage :: Config -> StatusCode -> IOSArrow b XmlTree -> IOSArrow b XmlTree #-} -getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree -getMsg !req !res +getMsg ∷ (ArrowXml a) ⇒ Maybe Request → Response → a b XmlTree +{-# INLINEABLE getMsg #-} +getMsg req res = case resStatus res of -- 1xx は body を持たない -- 2xx の body は補完しない -- 3xx MovedPermanently - -> txt ("The resource at " ++ path ++ " has been moved to ") + → txt ("The resource at " ⧺ path ⧺ " has been moved to ") <+> eelem "a" += sattr "href" loc += txt loc @@ -95,7 +84,7 @@ getMsg !req !res txt " permanently." Found - -> txt ("The resource at " ++ path ++ " is currently located at ") + → txt ("The resource at " ⧺ path ⧺ " is currently located at ") <+> eelem "a" += sattr "href" loc += txt loc @@ -103,7 +92,7 @@ getMsg !req !res txt ". This is not a permanent relocation." SeeOther - -> txt ("The resource at " ++ path ++ " can be found at ") + → txt ("The resource at " ⧺ path ⧺ " can be found at ") <+> eelem "a" += sattr "href" loc += txt loc @@ -111,7 +100,7 @@ getMsg !req !res txt "." TemporaryRedirect - -> txt ("The resource at " ++ path ++ " is temporarily located at ") + → txt ("The resource at " ⧺ path ⧺ " is temporarily located at ") <+> eelem "a" += sattr "href" loc += txt loc @@ -120,43 +109,40 @@ getMsg !req !res -- 4xx BadRequest - -> txt "The server could not understand the request you sent." + → txt "The server could not understand the request you sent." Unauthorized - -> txt ("You need a valid authentication to access " ++ path) + → txt ("You need a valid authentication to access " ⧺ path) Forbidden - -> txt ("You don't have permission to access " ++ path) + → txt ("You don't have permission to access " ⧺ path) NotFound - -> txt ("The requested URL " ++ path ++ " was not found on this server.") + → txt ("The requested URL " ⧺ path ⧺ " was not found on this server.") Gone - -> txt ("The resource at " ++ path ++ " was here in past times, but has gone permanently.") + → txt ("The resource at " ⧺ path ⧺ " was here in past times, but has gone permanently.") RequestEntityTooLarge - -> txt ("The request entity you sent for " ++ path ++ " was too big to accept.") + → txt ("The request entity you sent for " ⧺ path ⧺ " was too large to accept.") RequestURITooLarge - -> txt "The request URI you sent was too big to accept." + → txt "The request URI you sent was too large to accept." -- 5xx InternalServerError - -> txt ("An internal server error has occured during the process of your request to " ++ path) + → txt ("An internal server error has occured during the process of your request to " ⧺ path) ServiceUnavailable - -> txt "The service is temporarily unavailable. Try later." + → txt "The service is temporarily unavailable. Try later." - _ -> none + _ → none - where - path :: String - path = let uri = reqURI $! fromJust req + path ∷ String + path = let uri = reqURI $ fromJust req in uriPath uri - loc :: String - loc = C8.unpack $! fromJust $! getHeader (C8.pack "Location") res - -{-# SPECIALIZE getMsg :: Maybe Request -> Response -> IOSArrow b XmlTree #-} \ No newline at end of file + loc ∷ String + loc = A.toString $ fromJust $ getHeader "Location" res diff --git a/Network/HTTP/Lucu/ETag.hs b/Network/HTTP/Lucu/ETag.hs index d607ad1..76df183 100644 --- a/Network/HTTP/Lucu/ETag.hs +++ b/Network/HTTP/Lucu/ETag.hs @@ -1,58 +1,90 @@ -{-# OPTIONS_HADDOCK prune #-} - --- |Manipulation of entity tags. +{-# LANGUAGE + OverloadedStrings + , UnicodeSyntax + #-} +-- |Entity tags module Network.HTTP.Lucu.ETag ( ETag(..) + , parseETag + , printETag + , strongETag , weakETag - , eTagP - , eTagListP + , eTag + , eTagList ) where +import Control.Applicative +import Control.Monad +import Data.Ascii (Ascii, AsciiBuilder) +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 -import Control.Monad -import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Parser.Http hiding (token) -import Network.HTTP.Lucu.Utils - --- |An entity tag is made of a weakness flag and a opaque string. +-- |An entity tag consists of a weakness flag and an opaque string. data ETag = ETag { -- |The weakness flag. Weak tags looks like W\/\"blahblah\" and - -- strong tags are like \"blahblah\". - etagIsWeak :: !Bool + -- strong tags are like \"blahblah\". See: + -- + etagIsWeak ∷ !Bool -- |An opaque string. Only characters from 0x20 (sp) to 0x7e (~) -- are allowed. - , etagToken :: !String - } deriving (Eq) - -instance Show ETag where - show (ETag isWeak token) = (if isWeak then - "W/" - else - "") - ++ - quoteStr token - --- |This is equivalent to @'ETag' 'Prelude.False'@. If you want to --- generate an ETag from a file, try using + , etagToken ∷ !Ascii + } deriving (Eq, Show) + +-- |Convert an 'ETag' to an 'AsciiBuilder'. +printETag ∷ ETag → AsciiBuilder +{-# INLINEABLE printETag #-} +printETag et + = ( if etagIsWeak et then + A.toAsciiBuilder "W/" + else + (∅) + ) + ⊕ + quoteStr (etagToken et) + +-- |Parse 'Etag' from an 'Ascii'. This functions throws an exception +-- for parse error. +parseETag ∷ Ascii → ETag +{-# INLINEABLE parseETag #-} +parseETag str + = case parseOnly p $ A.toByteString str of + Right et → et + Left err → error ("unparsable ETag: " ⧺ A.toString str ⧺ ": " ⧺ err) + where + p ∷ Parser ETag + {-# INLINE p #-} + p = do et ← eTag + endOfInput + return et + +-- |This is equivalent to @'ETag' 'False'@. If you want to generate an +-- ETag from a file, try using -- 'Network.HTTP.Lucu.StaticFile.generateETagFromFile'. -strongETag :: String -> ETag +strongETag ∷ Ascii → ETag +{-# INLINE strongETag #-} strongETag = ETag False --- |This is equivalent to @'ETag' 'Prelude.True'@. -weakETag :: String -> ETag +-- |This is equivalent to @'ETag' 'True'@. +weakETag ∷ Ascii → ETag +{-# INLINE weakETag #-} weakETag = ETag True +-- |'Parser' for an 'ETag'. +eTag ∷ Parser ETag +{-# INLINEABLE eTag #-} +eTag = do isWeak ← option False (string "W/" *> return True) + str ← quotedStr + return $ ETag isWeak str -eTagP :: Parser ETag -eTagP = do isWeak <- option False (string "W/" >> return True) - str <- quotedStr - return $ ETag isWeak str - - -eTagListP :: Parser [ETag] -eTagListP = allowEOF - $! do xs <- listOf eTagP - when (null xs) - $ fail "" - return xs +-- |'Parser' for a list of 'ETag's. +eTagList ∷ Parser [ETag] +{-# INLINEABLE eTagList #-} +eTagList = do xs ← listOf eTag + when (null xs) $ + fail "empty list of ETags" + return xs diff --git a/Network/HTTP/Lucu/Format.hs b/Network/HTTP/Lucu/Format.hs deleted file mode 100644 index 93c2cda..0000000 --- a/Network/HTTP/Lucu/Format.hs +++ /dev/null @@ -1,131 +0,0 @@ --- 本當にこんなものを自分で書く必要があったのだらうか。Printf は重いの --- で駄目だが、それ以外のモジュールを探しても見付からなかった。 - -module Network.HTTP.Lucu.Format - ( fmtInt - - , fmtDec - , fmtHex - ) - where - - -fmtInt :: Int -> Bool -> Int -> Char -> Bool -> Int -> String -fmtInt base upperCase minWidth pad forceSign n - = base `seq` minWidth `seq` pad `seq` forceSign `seq` n `seq` - let raw = reverse $! fmt' (abs n) - sign = if forceSign || n < 0 then - if n < 0 then "-" else "+" - else - "" - padded = padStr (minWidth - length sign) pad raw - in - sign ++ padded - where - fmt' :: Int -> String - fmt' m - | m < base = [intToChar upperCase m] - | otherwise = (intToChar upperCase $! m `mod` base) : fmt' (m `div` base) - - -fmtDec :: Int -> Int -> String -fmtDec minWidth n - | minWidth == 2 = fmtDec2 n -- optimization - | minWidth == 3 = fmtDec3 n -- optimization - | minWidth == 4 = fmtDec4 n -- optimization - | otherwise = fmtInt 10 undefined minWidth '0' False n -{-# INLINE fmtDec #-} - - -fmtDec2 :: Int -> String -fmtDec2 n - | n < 0 || n >= 100 = fmtInt 10 undefined 2 '0' False n -- fallback - | n < 10 = [ '0' - , intToChar undefined n - ] - | otherwise = [ intToChar undefined (n `div` 10) - , intToChar undefined (n `mod` 10) - ] - - -fmtDec3 :: Int -> String -fmtDec3 n - | n < 0 || n >= 1000 = fmtInt 10 undefined 3 '0' False n -- fallback - | n < 10 = [ '0' - , '0' - , intToChar undefined n - ] - | n < 100 = [ '0' - , intToChar undefined ((n `div` 10) `mod` 10) - , intToChar undefined ( n `mod` 10) - ] - | otherwise = [ intToChar undefined ((n `div` 100) `mod` 10) - , intToChar undefined ((n `div` 10) `mod` 10) - , intToChar undefined ( n `mod` 10) - ] - - -fmtDec4 :: Int -> String -fmtDec4 n - | n < 0 || n >= 10000 = fmtInt 10 undefined 4 '0' False n -- fallback - | n < 10 = [ '0' - , '0' - , '0' - , intToChar undefined n - ] - | n < 100 = [ '0' - , '0' - , intToChar undefined ((n `div` 10) `mod` 10) - , intToChar undefined ( n `mod` 10) - ] - | n < 1000 = [ '0' - , intToChar undefined ((n `div` 100) `mod` 10) - , intToChar undefined ((n `div` 10) `mod` 10) - , intToChar undefined ( n `mod` 10) - ] - | otherwise = [ intToChar undefined ((n `div` 1000) `mod` 10) - , intToChar undefined ((n `div` 100) `mod` 10) - , intToChar undefined ((n `div` 10) `mod` 10) - , intToChar undefined ( n `mod` 10) - ] - - -fmtHex :: Bool -> Int -> Int -> String -fmtHex upperCase minWidth - = fmtInt 16 upperCase minWidth '0' False - - -padStr :: Int -> Char -> String -> String -padStr minWidth pad str - = let delta = minWidth - length str - in - if delta > 0 then - replicate delta pad ++ str - else - str - - -intToChar :: Bool -> Int -> Char -intToChar _ 0 = '0' -intToChar _ 1 = '1' -intToChar _ 2 = '2' -intToChar _ 3 = '3' -intToChar _ 4 = '4' -intToChar _ 5 = '5' -intToChar _ 6 = '6' -intToChar _ 7 = '7' -intToChar _ 8 = '8' -intToChar _ 9 = '9' -intToChar False 10 = 'a' -intToChar True 10 = 'A' -intToChar False 11 = 'b' -intToChar True 11 = 'B' -intToChar False 12 = 'c' -intToChar True 12 = 'C' -intToChar False 13 = 'd' -intToChar True 13 = 'D' -intToChar False 14 = 'e' -intToChar True 14 = 'E' -intToChar False 15 = 'f' -intToChar True 15 = 'F' -intToChar _ _ = undefined diff --git a/Network/HTTP/Lucu/HandleLike.hs b/Network/HTTP/Lucu/HandleLike.hs index aa4dacb..c4a4c62 100644 --- a/Network/HTTP/Lucu/HandleLike.hs +++ b/Network/HTTP/Lucu/HandleLike.hs @@ -1,68 +1,58 @@ +{-# LANGUAGE + DoAndIfThenElse + , UnicodeSyntax + #-} module Network.HTTP.Lucu.HandleLike ( HandleLike(..) + , hPutBuilder ) where - +import Blaze.ByteString.Builder (Builder) +import qualified Blaze.ByteString.Builder as BB import qualified Data.ByteString as B import qualified Data.ByteString.Lazy.Char8 as L import qualified OpenSSL.Session as SSL -import OpenSSL.X509 +import OpenSSL.X509 +import Prelude.Unicode import qualified System.IO as I - class HandleLike h where - hGetLBS :: h -> IO L.ByteString - hPutLBS :: h -> L.ByteString -> IO () - - hGetBS :: h -> Int -> IO B.ByteString - hPutBS :: h -> B.ByteString -> IO () + hGetLBS ∷ h → IO L.ByteString - hPutChar :: h -> Char -> IO () + hGetBS ∷ h → Int → IO B.ByteString + hPutBS ∷ h → B.ByteString → IO () - hPutStr :: h -> String -> IO () - hPutStrLn :: h -> String -> IO () - - hGetPeerCert :: h -> IO (Maybe X509) + hGetPeerCert ∷ h → IO (Maybe X509) hGetPeerCert = const $ return Nothing - hFlush :: h -> IO () - hClose :: h -> IO () - + hFlush ∷ h → IO () + hClose ∷ h → IO () instance HandleLike I.Handle where hGetLBS = L.hGetContents - hPutLBS = L.hPut hGetBS = B.hGet hPutBS = B.hPut - hPutChar = I.hPutChar - - hPutStr = I.hPutStr - hPutStrLn = I.hPutStrLn - hFlush = I.hFlush hClose = I.hClose - instance HandleLike SSL.SSL where - hGetLBS = SSL.lazyRead - hPutLBS = SSL.lazyWrite - - hGetBS = SSL.read - hPutBS = SSL.write + hGetLBS = SSL.lazyRead - hPutChar s = hPutLBS s . L.singleton - - hPutStr s = hPutLBS s . L.pack - hPutStrLn s = hPutLBS s . L.pack . (++ "\n") + hGetBS = SSL.read + hPutBS = SSL.write hGetPeerCert s = do isValid <- SSL.getVerifyResult s if isValid then SSL.getPeerCertificate s - else + else return Nothing - hFlush _ = return () -- unneeded - hClose s = SSL.shutdown s SSL.Bidirectional + hFlush _ = return () -- No need to do anything. + hClose s = SSL.shutdown s SSL.Bidirectional + +hPutBuilder ∷ HandleLike h ⇒ h → Builder → IO () +{-# INLINE hPutBuilder #-} +hPutBuilder = BB.toByteStringIO ∘ hPutBS diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index 87d858c..a47f2ac 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -1,165 +1,109 @@ +{-# LANGUAGE + GeneralizedNewtypeDeriving + , OverloadedStrings + , UnicodeSyntax + #-} module Network.HTTP.Lucu.Headers ( Headers , HasHeaders(..) - , noCaseCmp - , noCaseEq + , singleton - , emptyHeaders , toHeaders , fromHeaders - , headersP - , hPutHeaders + , headers + , printHeaders ) where - -import qualified Data.ByteString as Strict (ByteString) -import Data.ByteString.Internal (toForeignPtr, w2c, inlinePerformIO) -import qualified Data.ByteString.Char8 as C8 hiding (ByteString) -import Data.Char -import Data.List -import Data.Map (Map) +import Control.Applicative +import Control.Monad +import Data.Ascii (Ascii, AsciiBuilder, CIAscii) +import qualified Data.Ascii as A +import Data.Attoparsec.Char8 as P +import qualified Data.ByteString as BS +import Data.List +import Data.Map (Map) import qualified Data.Map as M -import Data.Ord -import Data.Word -import Foreign.ForeignPtr -import Foreign.Ptr -import Foreign.Storable -import Network.HTTP.Lucu.HandleLike -import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Parser.Http -import Network.HTTP.Lucu.Utils - -type Headers = Map NCBS Strict.ByteString -newtype NCBS = NCBS Strict.ByteString - -toNCBS :: Strict.ByteString -> NCBS -toNCBS = NCBS -{-# INLINE toNCBS #-} - -fromNCBS :: NCBS -> Strict.ByteString -fromNCBS (NCBS x) = x -{-# INLINE fromNCBS #-} - -instance Eq NCBS where - (NCBS a) == (NCBS b) = a == b - -instance Ord NCBS where - (NCBS a) `compare` (NCBS b) = a `noCaseCmp` b - -instance Show NCBS where - show (NCBS x) = show x - -noCaseCmp :: Strict.ByteString -> Strict.ByteString -> Ordering -noCaseCmp a b = a `seq` b `seq` - toForeignPtr a `cmp` toForeignPtr b - where - cmp :: (ForeignPtr Word8, Int, Int) -> (ForeignPtr Word8, Int, Int) -> Ordering - cmp (x1, s1, l1) (x2, s2, l2) - | x1 `seq` s1 `seq` l1 `seq` x2 `seq` s2 `seq` l2 `seq` False = undefined - | l1 == 0 && l2 == 0 = EQ - | x1 == x2 && s1 == s2 && l1 == l2 = EQ - | otherwise - = inlinePerformIO $ - withForeignPtr x1 $ \ p1 -> - withForeignPtr x2 $ \ p2 -> - noCaseCmp' (p1 `plusPtr` s1) l1 (p2 `plusPtr` s2) l2 - - --- もし先頭の文字列が等しければ、短い方が小さい。 -noCaseCmp' :: Ptr Word8 -> Int -> Ptr Word8 -> Int -> IO Ordering -noCaseCmp' p1 l1 p2 l2 - | p1 `seq` l1 `seq` p2 `seq` l2 `seq` False = undefined - | l1 == 0 && l2 == 0 = return EQ - | l1 == 0 = return LT - | l2 == 0 = return GT - | otherwise - = do c1 <- peek p1 - c2 <- peek p2 - case comparing (toLower . w2c) c1 c2 of - EQ -> noCaseCmp' (p1 `plusPtr` 1) (l1 - 1) (p2 `plusPtr` 1) (l2 - 1) - x -> return x - - -noCaseEq :: Strict.ByteString -> Strict.ByteString -> Bool -noCaseEq a b = a `seq` b `seq` - toForeignPtr a `cmp` toForeignPtr b - where - cmp :: (ForeignPtr Word8, Int, Int) -> (ForeignPtr Word8, Int, Int) -> Bool - cmp (x1, s1, l1) (x2, s2, l2) - | x1 `seq` s1 `seq` l1 `seq` x2 `seq` s2 `seq` l2 `seq` False = undefined - | l1 /= l2 = False - | l1 == 0 && l2 == 0 = True - | x1 == x2 && s1 == s2 && l1 == l2 = True - | otherwise - = inlinePerformIO $ - withForeignPtr x1 $ \ p1 -> - withForeignPtr x2 $ \ p2 -> - noCaseEq' (p1 `plusPtr` s1) (p2 `plusPtr` s2) l1 - - -noCaseEq' :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool -noCaseEq' p1 p2 l - | p1 `seq` p2 `seq` l `seq` False = undefined - | l == 0 = return True - | otherwise - = do c1 <- peek p1 - c2 <- peek p2 - if toLower (w2c c1) == toLower (w2c c2) then - noCaseEq' (p1 `plusPtr` 1) (p2 `plusPtr` 1) (l - 1) - else - return False +import qualified Data.Map.Unicode as M +import Data.Monoid +import Data.Monoid.Unicode +import Network.HTTP.Lucu.Parser.Http +import Prelude.Unicode +newtype Headers + = Headers (Map CIAscii Ascii) + deriving (Eq, Show, Monoid) class HasHeaders a where - getHeaders :: a -> Headers - setHeaders :: a -> Headers -> a + getHeaders ∷ a → Headers + setHeaders ∷ a → Headers → a - getHeader :: Strict.ByteString -> a -> Maybe Strict.ByteString + getHeader ∷ CIAscii → a → Maybe Ascii getHeader key a - = key `seq` a `seq` - M.lookup (toNCBS key) (getHeaders a) - - deleteHeader :: Strict.ByteString -> a -> a + = case getHeaders a of + Headers m → M.lookup key m + + hasHeader ∷ CIAscii → a → Bool + {-# INLINE hasHeader #-} + hasHeader key a + = case getHeaders a of + Headers m → key M.∈ m + + getCIHeader ∷ CIAscii → a → Maybe CIAscii + {-# INLINE getCIHeader #-} + getCIHeader key a + = A.toCIAscii <$> getHeader key a + + deleteHeader ∷ CIAscii → a → a + {-# INLINE deleteHeader #-} deleteHeader key a - = key `seq` a `seq` - setHeaders a $ M.delete (toNCBS key) (getHeaders a) + = case getHeaders a of + Headers m + → setHeaders a $ Headers $ M.delete key m - setHeader :: Strict.ByteString -> Strict.ByteString -> a -> a + setHeader ∷ CIAscii → Ascii → a → a + {-# INLINE setHeader #-} setHeader key val a - = key `seq` val `seq` a `seq` - setHeaders a $ M.insert (toNCBS key) val (getHeaders a) - - -emptyHeaders :: Headers -emptyHeaders = M.empty - - -toHeaders :: [(Strict.ByteString, Strict.ByteString)] -> Headers -toHeaders xs = mkHeaders xs M.empty - - -mkHeaders :: [(Strict.ByteString, Strict.ByteString)] -> Headers -> Headers -mkHeaders [] m = m -mkHeaders ((key, val):xs) m = mkHeaders xs $ - case M.lookup (toNCBS key) m of - Nothing -> M.insert (toNCBS key) val m - Just old -> M.insert (toNCBS key) (merge old val) m + = case getHeaders a of + Headers m + → setHeaders a $ Headers $ M.insert key val m + +instance HasHeaders Headers where + getHeaders = id + setHeaders _ = id + +singleton ∷ CIAscii → Ascii → Headers +{-# INLINE singleton #-} +singleton key val + = Headers $ M.singleton key val + +toHeaders ∷ [(CIAscii, Ascii)] → Headers +{-# INLINE toHeaders #-} +toHeaders = flip mkHeaders (∅) + +mkHeaders ∷ [(CIAscii, Ascii)] → Headers → Headers +mkHeaders [] (Headers m) = Headers m +mkHeaders ((key, val):xs) (Headers m) + = mkHeaders xs $ Headers $ + case M.lookup key m of + Nothing → M.insert key val m + Just old → M.insert key (merge old val) m where - merge :: Strict.ByteString -> Strict.ByteString -> Strict.ByteString - -- カンマ區切りである事を假定する。RFC ではカンマ區切りに出來ない - -- ヘッダは複數個あってはならない事になってゐる。 + merge ∷ Ascii → Ascii → Ascii + {-# INLINE merge #-} merge a b - | C8.null a && C8.null b = C8.empty - | C8.null a = b - | C8.null b = a - | otherwise = C8.concat [a, C8.pack ", ", b] - + | nullA a ∧ nullA b = (∅) + | nullA a = b + | nullA b = a + | otherwise = a ⊕ ", " ⊕ b -fromHeaders :: Headers -> [(Strict.ByteString, Strict.ByteString)] -fromHeaders hs = [(fromNCBS a, b) | (a, b) <- M.toList hs] + nullA ∷ Ascii → Bool + {-# INLINE nullA #-} + nullA = BS.null ∘ A.toByteString +fromHeaders ∷ Headers → [(CIAscii, Ascii)] +fromHeaders (Headers m) = M.toList m {- message-header = field-name ":" [ field-value ] @@ -172,49 +116,42 @@ fromHeaders hs = [(fromNCBS a, b) | (a, b) <- M.toList hs] field-value の先頭および末尾にある LWS は全て削除され、それ以外の LWS は單一の SP に變換される。 -} -headersP :: Parser Headers -headersP = do xs <- many header - _ <- crlf - return $! toHeaders xs +headers ∷ Parser Headers +{-# INLINEABLE headers #-} +headers = do xs ← P.many header + crlf + return $ toHeaders xs where - header :: Parser (Strict.ByteString, Strict.ByteString) - header = do name <- token - _ <- char ':' - -- FIXME: これは多少インチキだが、RFC 2616 のこの部分 - -- の記述はひどく曖昧であり、この動作が本當に間違って - -- ゐるのかどうかも良く分からない。例へば - -- quoted-string の内部にある空白は纏めていいのか惡い - -- のか？直勸的には駄目さうに思へるが、そんな記述は見 - -- 付からない。 - contents <- many (lws <|> many1 text) - _ <- crlf - let value = foldr (++) "" contents - norm = normalize value - return (C8.pack name, C8.pack norm) - - normalize :: String -> String - normalize = trimBody . trim isWhiteSpace - - trimBody = concat - . map (\ s -> if head s == ' ' then - " " - else - s) - . group - . map (\ c -> if isWhiteSpace c - then ' ' - else c) - - -hPutHeaders :: HandleLike h => h -> Headers -> IO () -hPutHeaders h hds - = h `seq` hds `seq` - mapM_ putH (M.toList hds) >> hPutBS h (C8.pack "\r\n") + header ∷ Parser (CIAscii, Ascii) + header = do name ← A.toCIAscii <$> token + void $ char ':' + skipMany lws + values ← content `sepBy` try lws + skipMany (try lws) + crlf + return (name, joinValues values) + + content ∷ Parser Ascii + {-# INLINE content #-} + content = A.unsafeFromByteString + <$> + takeWhile1 (\c → isText c ∧ c ≢ '\x20') + + joinValues ∷ [Ascii] → Ascii + {-# INLINE joinValues #-} + joinValues = A.fromAsciiBuilder + ∘ mconcat + ∘ intersperse (A.toAsciiBuilder "\x20") + ∘ map A.toAsciiBuilder + +printHeaders ∷ Headers → AsciiBuilder +printHeaders (Headers m) + = mconcat (map printHeader (M.toList m)) ⊕ + A.toAsciiBuilder "\x0D\x0A" where - putH :: (NCBS, Strict.ByteString) -> IO () - putH (name, value) - = name `seq` value `seq` - do hPutBS h (fromNCBS name) - hPutBS h (C8.pack ": ") - hPutBS h value - hPutBS h (C8.pack "\r\n") + printHeader ∷ (CIAscii, Ascii) → AsciiBuilder + printHeader (name, value) + = A.toAsciiBuilder (A.fromCIAscii name) ⊕ + A.toAsciiBuilder ": " ⊕ + A.toAsciiBuilder value ⊕ + A.toAsciiBuilder "\x0D\x0A" diff --git a/Network/HTTP/Lucu/HttpVersion.hs b/Network/HTTP/Lucu/HttpVersion.hs index d48f6ec..36b6c49 100644 --- a/Network/HTTP/Lucu/HttpVersion.hs +++ b/Network/HTTP/Lucu/HttpVersion.hs @@ -1,28 +1,26 @@ {-# LANGUAGE - BangPatterns + OverloadedStrings , UnicodeSyntax #-} -{-# OPTIONS_HADDOCK prune #-} - --- |Manipulation of HTTP version string. +-- |HTTP version number module Network.HTTP.Lucu.HttpVersion ( HttpVersion(..) - , httpVersionP - , hPutHttpVersion + , printHttpVersion + , httpVersion ) where - -import qualified Data.ByteString.Char8 as C8 -import Network.HTTP.Lucu.HandleLike -import Network.HTTP.Lucu.Parser -import Prelude hiding (min) - --- |@'HttpVersion' major minor@ represents \"HTTP\/major.minor\". -data HttpVersion = HttpVersion !Int !Int - deriving (Eq) - -instance Show HttpVersion where - show (HttpVersion maj min) = "HTTP/" ++ show maj ++ "." ++ show min +import Control.Applicative +import Control.Applicative.Unicode +import Data.Ascii (AsciiBuilder) +import qualified Data.Ascii as A +import Data.Attoparsec.Char8 +import Data.Monoid.Unicode +import Prelude hiding (min) + +-- |An HTTP version consists of major and minor versions. +data HttpVersion + = HttpVersion !Int !Int + deriving (Eq, Show) instance Ord HttpVersion where (HttpVersion majA minA) `compare` (HttpVersion majB minB) @@ -32,30 +30,22 @@ instance Ord HttpVersion where | minA < minB = LT | otherwise = EQ - -httpVersionP :: Parser HttpVersion -httpVersionP = string "HTTP/" - >> - -- 頻出するので高速化 - choice [ string "1.0" >> return (HttpVersion 1 0) - , string "1.1" >> return (HttpVersion 1 1) - -- 一般の場合 - , do major <- many1 digit - _ <- char '.' - minor <- many1 digit - return $ HttpVersion (read major) (read minor) - ] - - -hPutHttpVersion :: HandleLike h => h -> HttpVersion -> IO () -hPutHttpVersion !h !v +-- |Convert an 'HttpVersion' to 'AsciiBuilder'. +printHttpVersion ∷ HttpVersion → AsciiBuilder +printHttpVersion v = case v of - -- 頻出するので高速化 - HttpVersion 1 0 -> hPutBS h (C8.pack "HTTP/1.0") - HttpVersion 1 1 -> hPutBS h (C8.pack "HTTP/1.1") - -- 一般の場合 - HttpVersion !maj !min - -> do hPutBS h (C8.pack "HTTP/") - hPutStr h (show maj) - hPutChar h '.' - hPutStr h (show min) + -- Optimisation for special cases. + HttpVersion 1 0 → A.toAsciiBuilder "HTTP/1.0" + HttpVersion 1 1 → A.toAsciiBuilder "HTTP/1.1" + -- General (but almost never stumbling) cases. + HttpVersion maj min + → A.toAsciiBuilder "HTTP/" ⊕ + A.toAsciiBuilder (A.unsafeFromString $ show maj) ⊕ + A.toAsciiBuilder "." ⊕ + A.toAsciiBuilder (A.unsafeFromString $ show min) + +-- |'Parser' for an 'HttpVersion'. +httpVersion ∷ Parser HttpVersion +httpVersion = string "HTTP/" + *> + (HttpVersion <$> decimal ⊛ (char '.' *> decimal)) diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs index 0bb92b1..595403a 100644 --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -1,36 +1,38 @@ +{-# LANGUAGE + UnicodeSyntax + #-} -- |The entry point of Lucu httpd. module Network.HTTP.Lucu.Httpd ( FallbackHandler , runHttpd ) where - -import Control.Concurrent -import Control.Exception -import Control.Monad -import Data.Maybe -import Network.BSD -import Network.Socket -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.Interaction -import Network.HTTP.Lucu.RequestReader -import Network.HTTP.Lucu.Resource.Tree -import Network.HTTP.Lucu.ResponseWriter -import Network.HTTP.Lucu.SocketLike as SL -import System.Posix.Signals +import Control.Concurrent +import Control.Exception +import Control.Monad +import Control.Monad.Unicode +import Data.Maybe +import Network.BSD +import Network.Socket +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.RequestReader +import Network.HTTP.Lucu.Resource.Tree +import Network.HTTP.Lucu.ResponseWriter +import Network.HTTP.Lucu.SocketLike as SL +import System.Posix.Signals -- |This is the entry point of Lucu httpd. It listens to a socket and --- waits for clients. Computation of 'runHttpd' never stops by itself --- so the only way to stop it is to raise an exception in the thread --- computing it. +-- waits for clients. 'runHttpd' never stops by itself so the only way +-- to stop it is to raise an exception in the thread running it. -- -- Note that 'runHttpd' automatically makes SIGPIPE be ignored by --- computing @'System.Posix.Signals.installHandler' --- 'System.Posix.Signals.sigPIPE' 'System.Posix.Signals.Ignore' --- 'Prelude.Nothing'@. This can hardly cause a problem but it may do. +-- calling @'installHandler' 'sigPIPE' 'Ignore' 'Nothing'@. This can +-- hardly cause a problem though. -- -- Example: -- +-- > {-# LANGUAGE OverloadedStrings #-} -- > module Main where -- > import Network.HTTP.Lucu -- > @@ -41,81 +43,72 @@ import System.Posix.Signals -- > runHttpd config resourcees [] -- > -- > helloWorld :: ResourceDef --- > helloWorld = ResourceDef { --- > resUsesNativeThread = False --- > , resIsGreedy = False --- > , resGet --- > = Just $ do setContentType $ read "text/plain" --- > output "Hello, world!" --- > , resHead = Nothing --- > , resPost = Nothing --- > , resPut = Nothing --- > , resDelete = Nothing +-- > helloWorld = emptyResource { +-- > resGet +-- > = Just $ do setContentType $ parseMIMEType "text/plain" +-- > putChunk "Hello, world!" -- > } -runHttpd :: Config -> ResTree -> [FallbackHandler] -> IO () +runHttpd ∷ Config → ResTree → [FallbackHandler] → IO () runHttpd cnf tree fbs = withSocketsDo $ - do _ <- installHandler sigPIPE Ignore Nothing - + do void $ installHandler sigPIPE Ignore Nothing let launchers = catMaybes - [ do scnf <- cnfSSLConfig cnf - addr <- cnfServerV4Addr cnf - return ( do so <- listenOn AF_INET addr (sslServerPort scnf) + [ do scnf ← cnfSSLConfig cnf + addr ← cnfServerV4Addr cnf + return ( do so ← listenOn AF_INET addr (sslServerPort scnf) launchListener (sslContext scnf, so) ) - , do scnf <- cnfSSLConfig cnf - addr <- cnfServerV6Addr cnf - return ( do so <- listenOn AF_INET6 addr (sslServerPort scnf) + , do scnf ← cnfSSLConfig cnf + addr ← cnfServerV6Addr cnf + return ( do so ← listenOn AF_INET6 addr (sslServerPort scnf) launchListener (sslContext scnf, so) ) - , do addr <- cnfServerV4Addr cnf - return ( launchListener =<< listenOn AF_INET addr (cnfServerPort cnf) + , do addr ← cnfServerV4Addr cnf + return ( launchListener =≪ listenOn AF_INET addr (cnfServerPort cnf) ) - , do addr <- cnfServerV6Addr cnf - return ( launchListener =<< listenOn AF_INET6 addr (cnfServerPort cnf) + , do addr ← cnfServerV6Addr cnf + return ( launchListener =≪ listenOn AF_INET6 addr (cnfServerPort cnf) ) ] - sequence_ launchers waitForever where - launchListener :: SocketLike s => s -> IO () + launchListener ∷ SocketLike s ⇒ s → IO () launchListener so - = do p <- SL.socketPort so + = do p ← SL.socketPort so -- FIXME: Don't throw away the thread ID as we can't -- kill it later then. [1] - _ <- forkIO $ httpLoop p so - return () + void $ forkIO $ httpLoop p so - listenOn :: Family -> HostName -> ServiceName -> IO Socket + listenOn ∷ Family → HostName → ServiceName → IO Socket listenOn fam host srv - = do proto <- getProtocolNumber "tcp" + = do proto ← getProtocolNumber "tcp" let hints = defaultHints { addrFlags = [AI_PASSIVE] , addrFamily = fam , addrSocketType = Stream , addrProtocol = proto } - addrs <- getAddrInfo (Just hints) (Just host) (Just srv) + addrs ← getAddrInfo (Just hints) (Just host) (Just srv) let addr = head addrs bracketOnError (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) - (sClose) - (\ sock -> + sClose + (\ sock → do setSocketOption sock ReuseAddr 1 bindSocket sock (addrAddress addr) listen sock maxListenQueue return sock ) - httpLoop :: SocketLike s => PortNumber -> s -> IO () + httpLoop ∷ SocketLike s ⇒ PortNumber → s → IO () httpLoop port so - = do (h, addr) <- SL.accept so - tQueue <- newInteractionQueue - readerTID <- forkIO $ requestReader cnf tree fbs h port addr tQueue - _writerTID <- forkIO $ responseWriter cnf h tQueue readerTID + = do (h, addr) ← SL.accept so + tQueue ← mkInteractionQueue + readerTID ← forkIO $ requestReader cnf tree fbs h port addr tQueue + _writerTID ← forkIO $ responseWriter cnf h tQueue readerTID httpLoop port so - waitForever :: IO () + waitForever ∷ IO () waitForever = forever (threadDelay 1000000) diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 638d1b0..f1e7ab3 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -1,183 +1,228 @@ {-# LANGUAGE - BangPatterns + DeriveDataTypeable + , ExistentialQuantification + , OverloadedStrings + , RecordWildCards , UnicodeSyntax #-} module Network.HTTP.Lucu.Interaction ( Interaction(..) - , InteractionState(..) - , InteractionQueue - , newInteractionQueue - , newInteraction - , defaultPageContentType - - , writeItr - , readItr - , readItrF - , updateItr - , updateItrF - ) - where - -import Control.Concurrent.STM -import qualified Data.ByteString as Strict (ByteString) -import qualified Data.ByteString.Lazy as Lazy (ByteString) -import Data.ByteString.Char8 as C8 hiding (ByteString) -import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString) -import qualified Data.Sequence as S -import Data.Sequence (Seq) -import Network.Socket -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.HttpVersion -import Network.HTTP.Lucu.Request -import Network.HTTP.Lucu.Response -import OpenSSL.X509 - -data Interaction = Interaction { - itrConfig :: !Config - , itrLocalPort :: !PortNumber - , itrRemoteAddr :: !SockAddr - , itrRemoteCert :: !(Maybe X509) - , itrResourcePath :: !(Maybe [String]) - , itrRequest :: !(TVar (Maybe Request)) -- FIXME: TVar である必要無し - , itrResponse :: !(TVar Response) - - , itrRequestHasBody :: !(TVar Bool) -- FIXME: TVar である必要無し - , itrRequestIsChunked :: !(TVar Bool) -- FIXME: TVar である必要無し - , itrExpectedContinue :: !(TVar Bool) -- FIXME: TVar である必要無し - - , itrReqChunkLength :: !(TVar (Maybe Int)) - , itrReqChunkRemaining :: !(TVar (Maybe Int)) - , itrReqChunkIsOver :: !(TVar Bool) - , itrReqBodyWanted :: !(TVar (Maybe Int)) - , itrReqBodyWasteAll :: !(TVar Bool) - , itrReceivedBody :: !(TVar Lazy.ByteString) -- Resource が受領した部分は削除される - - , itrWillReceiveBody :: !(TVar Bool) - , itrWillChunkBody :: !(TVar Bool) - , itrWillDiscardBody :: !(TVar Bool) - , itrWillClose :: !(TVar Bool) - - , itrBodyToSend :: !(TVar Lazy.ByteString) - , itrBodyIsNull :: !(TVar Bool) - - , itrState :: !(TVar InteractionState) - - , itrWroteContinue :: !(TVar Bool) - , itrWroteHeader :: !(TVar Bool) - } - --- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期 --- 状態は ExaminingRequest。 -data InteractionState = ExaminingRequest - | GettingBody - | DecidingHeader - | DecidingBody - | Done - deriving (Show, Eq, Ord, Enum) - -type InteractionQueue = TVar (Seq Interaction) - - -newInteractionQueue :: IO InteractionQueue -newInteractionQueue = newTVarIO S.empty - - -defaultPageContentType :: Strict.ByteString -defaultPageContentType = C8.pack "application/xhtml+xml" - - -newInteraction :: Config -> PortNumber -> SockAddr -> Maybe X509 -> Maybe Request -> IO Interaction -newInteraction !conf !port !addr !cert !req - = do request <- newTVarIO req - responce <- newTVarIO Response { - resVersion = HttpVersion 1 1 - , resStatus = Ok - , resHeaders = toHeaders [(C8.pack "Content-Type", defaultPageContentType)] - } - - requestHasBody <- newTVarIO False - requestIsChunked <- newTVarIO False - expectedContinue <- newTVarIO False - - reqChunkLength <- newTVarIO Nothing -- 現在のチャンク長 - reqChunkRemaining <- newTVarIO Nothing -- 現在のチャンクの殘り - reqChunkIsOver <- newTVarIO False -- 最後のチャンクを讀み終へた - reqBodyWanted <- newTVarIO Nothing -- Resource が要求してゐるチャンク長 - reqBodyWasteAll <- newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求 - receivedBody <- newTVarIO L8.empty - - willReceiveBody <- newTVarIO False - willChunkBody <- newTVarIO False - willDiscardBody <- newTVarIO False - willClose <- newTVarIO False - - bodyToSend <- newTVarIO L8.empty - bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False - - state <- newTVarIO ExaminingRequest - - wroteContinue <- newTVarIO False - wroteHeader <- newTVarIO False - - return Interaction { - itrConfig = conf - , itrLocalPort = port - , itrRemoteAddr = addr - , itrRemoteCert = cert - , itrResourcePath = Nothing - , itrRequest = request - , itrResponse = responce - - , itrRequestHasBody = requestHasBody - , itrRequestIsChunked = requestIsChunked - , itrExpectedContinue = expectedContinue - - , itrReqChunkLength = reqChunkLength - , itrReqChunkRemaining = reqChunkRemaining - , itrReqChunkIsOver = reqChunkIsOver - , itrReqBodyWanted = reqBodyWanted - , itrReqBodyWasteAll = reqBodyWasteAll - , itrReceivedBody = receivedBody - - , itrWillReceiveBody = willReceiveBody - , itrWillChunkBody = willChunkBody - , itrWillDiscardBody = willDiscardBody - , itrWillClose = willClose - - , itrBodyToSend = bodyToSend - , itrBodyIsNull = bodyIsNull - - , itrState = state - - , itrWroteContinue = wroteContinue - , itrWroteHeader = wroteHeader - } - - -writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM () -writeItr !itr !accessor !value - = writeTVar (accessor itr) value + , SomeInteraction(..) + , SyntacticallyInvalidInteraction(..) + , mkSyntacticallyInvalidInteraction -readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b -readItr !itr !accessor !reader - = fmap reader $ readTVar (accessor itr) - - -readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b) -readItrF !itr !accessor !reader - = readItr itr accessor (fmap reader) -{-# SPECIALIZE readItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> b) -> STM (Maybe b) #-} + , SemanticallyInvalidInteraction(..) + , mkSemanticallyInvalidInteraction + , NormalInteraction(..) + , InteractionState(..) + , ReceiveBodyRequest(..) + , mkNormalInteraction -updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM () -updateItr !itr !accessor !updator - = do old <- readItr itr accessor id - writeItr itr accessor (updator old) + , InteractionQueue + , mkInteractionQueue + , setResponseStatus + , getCurrentDate + ) + where +import Blaze.ByteString.Builder (Builder) +import Control.Applicative +import Control.Concurrent.STM +import Data.Ascii (Ascii) +import qualified Data.ByteString as Strict +import Data.Monoid.Unicode +import Data.Sequence (Seq) +import Data.Time +import qualified Data.Time.HTTP as HTTP +import Data.Typeable +import Network.Socket +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.DefaultPage +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.Preprocess +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Response +import OpenSSL.X509 + +class Typeable i ⇒ Interaction i where + toInteraction ∷ i → SomeInteraction + toInteraction = SomeInteraction + + fromInteraction ∷ SomeInteraction → Maybe i + fromInteraction (SomeInteraction i) = cast i + +data SomeInteraction + = ∀i. Interaction i ⇒ SomeInteraction !i + deriving Typeable + +instance Interaction SomeInteraction where + toInteraction = id + fromInteraction = Just + +-- |'SyntacticallyInvalidInteraction' is an 'Interaction' without even +-- a syntactically valid 'Request'. The response code will always be +-- 'BadRequest'. +data SyntacticallyInvalidInteraction + = SYI { + syiResponse ∷ !Response + , syiBodyToSend ∷ !Builder + } + deriving Typeable +instance Interaction SyntacticallyInvalidInteraction + +mkSyntacticallyInvalidInteraction ∷ Config + → IO SyntacticallyInvalidInteraction +mkSyntacticallyInvalidInteraction config@(Config {..}) + = do date ← getCurrentDate + let res = setHeader "Server" cnfServerSoftware $ + setHeader "Date" date $ + setHeader "Content-Type" defaultPageContentType $ + emptyResponse BadRequest + body = getDefaultPage config Nothing res + return SYI { + syiResponse = res + , syiBodyToSend = body + } + +-- |'SemanticallyInvalidInteraction' is an 'Interaction' without a +-- semantically valid 'Request'. The response code will always satisfy +-- 'isError'. +data SemanticallyInvalidInteraction + = SEI { + seiRequest ∷ !Request + , seiExpectedContinue ∷ !Bool + , seiReqBodyLength ∷ !(Maybe RequestBodyLength) + + , seiResponse ∷ !Response + , seiWillChunkBody ∷ !Bool + , seiWillDiscardBody ∷ !Bool + , seiWillClose ∷ !Bool + , seiBodyToSend ∷ !Builder + } + deriving Typeable +instance Interaction SemanticallyInvalidInteraction + +mkSemanticallyInvalidInteraction ∷ Config + → AugmentedRequest + → IO SemanticallyInvalidInteraction +mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..}) + = do date ← getCurrentDate + let res = setHeader "Server" cnfServerSoftware $ + setHeader "Date" date $ + setHeader "Content-Type" defaultPageContentType $ + emptyResponse arInitialStatus + body = getDefaultPage config (Just arRequest) res + return SEI { + seiRequest = arRequest + , seiExpectedContinue = arExpectedContinue + , seiReqBodyLength = arReqBodyLength + + , seiResponse = res + , seiWillChunkBody = arWillChunkBody + , seiWillDiscardBody = arWillDiscardBody + , seiWillClose = arWillClose + , seiBodyToSend = body + } + +-- |'NormalInteraction' is an 'Interaction' with a semantically +-- correct 'Request'. +data NormalInteraction + = NI { + niConfig ∷ !Config + , niRemoteAddr ∷ !SockAddr + , niRemoteCert ∷ !(Maybe X509) + , niRequest ∷ !Request + , niResourcePath ∷ ![Strict.ByteString] + , niExpectedContinue ∷ !Bool + , niReqBodyLength ∷ !(Maybe RequestBodyLength) + + , niReceiveBodyReq ∷ !(TMVar ReceiveBodyRequest) + , niReceivedBody ∷ !(TMVar Strict.ByteString) + + , niResponse ∷ !(TVar Response) + , niSendContinue ∷ !(TMVar Bool) + , niWillChunkBody ∷ !Bool + , niWillDiscardBody ∷ !(TVar Bool) + , niWillClose ∷ !(TVar Bool) + , niResponseHasCType ∷ !(TVar Bool) + , niBodyToSend ∷ !(TMVar Builder) + + , niState ∷ !(TVar InteractionState) + } + deriving Typeable +instance Interaction NormalInteraction + +data ReceiveBodyRequest + = ReceiveBody !Int -- ^ Maximum number of octets to receive. + | WasteAll + deriving (Show, Eq) + +-- |The interaction state of Resource monad. 'ExaminingRequest' is the +-- initial state. +data InteractionState + = ExaminingRequest + | ReceivingBody + | DecidingHeader + | SendingBody + | Done + deriving (Show, Eq, Ord, Enum) + +mkNormalInteraction ∷ Config + → SockAddr + → Maybe X509 + → AugmentedRequest + → [Strict.ByteString] + → IO NormalInteraction +mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPath + = do receiveBodyReq ← newEmptyTMVarIO + receivedBody ← newEmptyTMVarIO + + response ← newTVarIO $ emptyResponse arInitialStatus + sendContinue ← newEmptyTMVarIO + willDiscardBody ← newTVarIO arWillDiscardBody + willClose ← newTVarIO arWillClose + responseHasCType ← newTVarIO False + bodyToSend ← newEmptyTMVarIO + + state ← newTVarIO ExaminingRequest + + return NI { + niConfig = config + , niRemoteAddr = remoteAddr + , niRemoteCert = remoteCert + , niRequest = arRequest + , niResourcePath = rsrcPath + , niExpectedContinue = arExpectedContinue + , niReqBodyLength = arReqBodyLength + + , niReceiveBodyReq = receiveBodyReq + , niReceivedBody = receivedBody + + , niResponse = response + , niSendContinue = sendContinue + , niWillChunkBody = arWillChunkBody + , niWillDiscardBody = willDiscardBody + , niWillClose = willClose + , niResponseHasCType = responseHasCType + , niBodyToSend = bodyToSend + + , niState = state + } + +type InteractionQueue = TVar (Seq SomeInteraction) + +mkInteractionQueue ∷ IO InteractionQueue +mkInteractionQueue = newTVarIO (∅) + +setResponseStatus ∷ NormalInteraction → StatusCode → STM () +setResponseStatus (NI {..}) sc + = do res ← readTVar niResponse + let res' = res { + resStatus = sc + } + writeTVar niResponse res' -updateItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM () -updateItrF !itr !accessor !updator - = updateItr itr accessor (fmap updator) -{-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-} \ No newline at end of file +getCurrentDate ∷ IO Ascii +getCurrentDate = HTTP.toAscii <$> getCurrentTime diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs index a3f3fc5..ab0e065 100644 --- a/Network/HTTP/Lucu/MIMEType.hs +++ b/Network/HTTP/Lucu/MIMEType.hs @@ -1,78 +1,84 @@ {-# LANGUAGE - UnboxedTuples + OverloadedStrings , UnicodeSyntax #-} -{-# OPTIONS_HADDOCK prune #-} --- |Manipulation of MIME Types. +-- |MIME Types module Network.HTTP.Lucu.MIMEType ( MIMEType(..) + , mkMIMEType + , parseMIMEType - , mimeTypeP - , mimeTypeListP + , printMIMEType + + , mimeType + , mimeTypeList ) where +import Control.Applicative +import Data.Ascii (Ascii, AsciiBuilder, CIAscii) +import qualified Data.Ascii as A +import Data.Attoparsec.Char8 as P +import Data.Map (Map) +import Data.Monoid.Unicode +import Data.Text (Text) +import Network.HTTP.Lucu.Parser.Http +import Network.HTTP.Lucu.RFC2231 +import Prelude hiding (min) +import Prelude.Unicode -import qualified Data.ByteString.Lazy as B -import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Parser.Http -import Network.HTTP.Lucu.Utils -import Prelude hiding (min) - --- |@'MIMEType' \"major\" \"minor\" [(\"name\", \"value\")]@ --- represents \"major\/minor; name=value\". +-- |@'MIMEType' \"major\" \"minor\" [(\"name\", \"value\"), ...]@ +-- represents \"major\/minor; name=value; ...\". data MIMEType = MIMEType { - mtMajor :: !String - , mtMinor :: !String - , mtParams :: ![ (String, String) ] + mtMajor ∷ !CIAscii + , mtMinor ∷ !CIAscii + , mtParams ∷ !(Map CIAscii Text) } deriving (Eq) - instance Show MIMEType where - show (MIMEType maj min params) - = maj ++ "/" ++ min ++ - if null params then - "" - else - "; " ++ joinWith "; " (map showPair params) - where - showPair :: (String, String) -> String - showPair (name, value) - = name ++ "=" ++ if any (not . isToken) value then - quoteStr value - else - value + show = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType +-- |@'mkMIMEType' major minor@ returns a 'MIMEType' with the given +-- @major@ and @minor@ types but without any parameters. +mkMIMEType ∷ CIAscii → CIAscii → MIMEType +{-# INLINE mkMIMEType #-} +mkMIMEType maj min + = MIMEType maj min (∅) -instance Read MIMEType where - readsPrec _ s = [(parseMIMEType s, "")] +-- |Convert a 'MIMEType' to an 'AsciiBuilder'. +printMIMEType ∷ MIMEType → AsciiBuilder +{-# INLINEABLE printMIMEType #-} +printMIMEType (MIMEType maj min params) + = A.toAsciiBuilder (A.fromCIAscii maj) ⊕ + A.toAsciiBuilder "/" ⊕ + A.toAsciiBuilder (A.fromCIAscii min) ⊕ + printMIMEParams params --- |Parse 'MIMEType' from a 'Prelude.String'. This function throws an +-- |Parse 'MIMEType' from an 'Ascii'. This function throws an -- exception for parse error. -parseMIMEType :: String -> MIMEType -parseMIMEType str = case parseStr mimeTypeP str of - (# Success t, r #) -> if B.null r - then t - else error ("unparsable MIME Type: " ++ str) - (# _ , _ #) -> error ("unparsable MIME Type: " ++ str) - - -mimeTypeP :: Parser MIMEType -mimeTypeP = allowEOF $! - do maj <- token - _ <- char '/' - min <- token - params <- many paramP - return $ MIMEType maj min params +parseMIMEType ∷ Ascii → MIMEType +{-# INLINEABLE parseMIMEType #-} +parseMIMEType str + = case parseOnly p $ A.toByteString str of + Right t → t + Left err → error ("unparsable MIME Type: " ⧺ A.toString str ⧺ ": " ⧺ err) where - paramP :: Parser (String, String) - paramP = do _ <- many lws - _ <- char ';' - _ <- many lws - name <- token - _ <- char '=' - value <- token <|> quotedStr - return (name, value) + p ∷ Parser MIMEType + {-# INLINE p #-} + p = do t ← mimeType + endOfInput + return t + +-- |'Parser' for an 'MIMEType'. +mimeType ∷ Parser MIMEType +{-# INLINEABLE mimeType #-} +mimeType = do maj ← A.toCIAscii <$> token + _ ← char '/' + min ← A.toCIAscii <$> token + params ← mimeParams + return $ MIMEType maj min params -mimeTypeListP :: Parser [MIMEType] -mimeTypeListP = allowEOF $! listOf mimeTypeP +-- |'Parser' for a list of 'MIMEType's. +mimeTypeList ∷ Parser [MIMEType] +{-# INLINE mimeTypeList #-} +mimeTypeList = listOf mimeType diff --git a/Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs b/Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs deleted file mode 100644 index d6add2b..0000000 --- a/Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs +++ /dev/null @@ -1,182 +0,0 @@ --- |This module is automatically generated from data\/mime.types. --- 'defaultExtensionMap' contains every possible pairs of an extension --- and a MIME Type. - -{- !!! WARNING !!! - This file is automatically generated. - DO NOT EDIT BY HAND OR YOU WILL REGRET -} - -module Network.HTTP.Lucu.MIMEType.DefaultExtensionMap - (defaultExtensionMap) where -import Network.HTTP.Lucu.MIMEType () -import Network.HTTP.Lucu.MIMEType.Guess -import qualified Data.Map as M - -defaultExtensionMap :: ExtMap -defaultExtensionMap - = M.fromList - [("3gp", read "application/x-3gp"), ("669", read "audio/x-mod"), - ("Z", read "application/x-compress"), - ("a", read "application/x-ar"), ("ac3", read "audio/x-ac3"), - ("ai", read "application/postscript"), - ("aif", read "audio/x-aiff"), ("aifc", read "audio/x-aiff"), - ("aiff", read "audio/x-aiff"), ("amf", read "audio/x-mod"), - ("anx", read "application/ogg"), ("ape", read "application/x-ape"), - ("asc", read "text/plain"), ("asf", read "video/x-ms-asf"), - ("atom", read "application/atom+xml"), ("au", read "audio/x-au"), - ("avi", read "video/x-msvideo"), - ("bcpio", read "application/x-bcpio"), - ("bin", read "application/octet-stream"), - ("bmp", read "image/bmp"), ("bz2", read "application/x-bzip"), - ("cabal", read "text/x-cabal"), - ("cdf", read "application/x-netcdf"), ("cgm", read "image/cgm"), - ("class", read "application/octet-stream"), - ("cpio", read "application/x-cpio"), - ("cpt", read "application/mac-compactpro"), - ("csh", read "application/x-csh"), ("css", read "text/css"), - ("dcr", read "application/x-director"), ("dif", read "video/x-dv"), - ("dir", read "application/x-director"), - ("djv", read "image/vnd.djvu"), ("djvu", read "image/vnd.djvu"), - ("dll", read "application/octet-stream"), - ("dmg", read "application/octet-stream"), - ("dms", read "application/octet-stream"), - ("doc", read "application/msword"), ("dsm", read "audio/x-mod"), - ("dtd", read "application/xml-dtd"), ("dv", read "video/x-dv"), - ("dvi", read "application/x-dvi"), - ("dxr", read "application/x-director"), - ("eps", read "application/postscript"), - ("etx", read "text/x-setext"), - ("exe", read "application/octet-stream"), - ("ez", read "application/andrew-inset"), - ("far", read "audio/x-mod"), ("flac", read "audio/x-flac"), - ("flc", read "video/x-fli"), ("fli", read "video/x-fli"), - ("flv", read "video/x-flv"), ("gdm", read "audio/x-mod"), - ("gif", read "image/gif"), ("gram", read "application/srgs"), - ("grxml", read "application/srgs+xml"), - ("gtar", read "application/x-gtar"), - ("gz", read "application/x-gzip"), - ("hdf", read "application/x-hdf"), - ("hi", read "application/octet-stream"), - ("hqx", read "application/mac-binhex40"), - ("hs", read "text/x-haskell"), ("htm", read "text/html"), - ("html", read "text/html"), - ("ice", read "x-conference/x-cooltalk"), - ("ico", read "image/x-icon"), ("ics", read "text/calendar"), - ("ief", read "image/ief"), ("ifb", read "text/calendar"), - ("iff", read "audio/x-svx"), ("iges", read "model/iges"), - ("igs", read "model/iges"), ("ilbc", read "audio/iLBC-sh"), - ("imf", read "audio/x-mod"), ("it", read "audio/x-mod"), - ("jng", read "image/x-jng"), - ("jnlp", read "application/x-java-jnlp-file"), - ("jp2", read "image/jp2"), ("jpe", read "image/jpeg"), - ("jpeg", read "image/jpeg"), ("jpg", read "image/jpeg"), - ("js", read "application/x-javascript"), - ("kar", read "audio/midi"), ("latex", read "application/x-latex"), - ("lha", read "application/octet-stream"), - ("lzh", read "application/octet-stream"), - ("m3u", read "audio/x-mpegurl"), ("m4a", read "audio/mp4a-latm"), - ("m4p", read "audio/mp4a-latm"), ("m4u", read "video/vnd.mpegurl"), - ("m4v", read "video/mpeg4"), ("mac", read "image/x-macpaint"), - ("man", read "application/x-troff-man"), - ("mathml", read "application/mathml+xml"), - ("me", read "application/x-troff-me"), ("med", read "audio/x-mod"), - ("mesh", read "model/mesh"), ("mid", read "audio/midi"), - ("midi", read "audio/midi"), ("mif", read "application/vnd.mif"), - ("mka", read "video/x-matroska"), ("mkv", read "video/x-matroska"), - ("mng", read "video/x-mng"), ("mod", read "audio/x-mod"), - ("mov", read "video/quicktime"), - ("movie", read "video/x-sgi-movie"), ("mp2", read "audio/mpeg"), - ("mp3", read "audio/mpeg"), ("mp4", read "video/mp4"), - ("mpc", read "audio/x-musepack"), ("mpe", read "video/mpeg"), - ("mpeg", read "video/mpeg"), ("mpg", read "video/mpeg"), - ("mpga", read "audio/mpeg"), ("ms", read "application/x-troff-ms"), - ("msh", read "model/mesh"), ("mtm", read "audio/x-mod"), - ("mve", read "video/x-mve"), ("mxu", read "video/vnd.mpegurl"), - ("nar", read "application/x-nar"), - ("nc", read "application/x-netcdf"), ("nist", read "audio/x-nist"), - ("nuv", read "video/x-nuv"), - ("o", read "application/octet-stream"), - ("oda", read "application/oda"), ("ogg", read "application/ogg"), - ("ogm", read "application/ogg"), ("okt", read "audio/x-mod"), - ("paf", read "audio/x-paris"), - ("pbm", read "image/x-portable-bitmap"), - ("pct", read "image/pict"), ("pdb", read "chemical/x-pdb"), - ("pdf", read "application/pdf"), - ("pgm", read "image/x-portable-graymap"), - ("pgn", read "application/x-chess-pgn"), - ("pic", read "image/pict"), ("pict", read "image/pict"), - ("png", read "image/png"), ("pnm", read "image/x-portable-anymap"), - ("pnt", read "image/x-macpaint"), - ("pntg", read "image/x-macpaint"), - ("ppm", read "image/x-portable-pixmap"), - ("ppt", read "application/vnd.ms-powerpoint"), - ("ps", read "application/postscript"), - ("qif", read "image/x-quicktime"), ("qt", read "video/quicktime"), - ("qti", read "image/x-quicktime"), - ("qtif", read "image/x-quicktime"), - ("ra", read "audio/x-pn-realaudio"), ("ram", read "text/uri-list"), - ("rar", read "application/x-rar"), - ("ras", read "image/x-sun-raster"), - ("rdf", read "application/rdf+xml"), ("rgb", read "image/x-rgb"), - ("rm", read "application/vnd.rn-realmedia"), - ("roff", read "application/x-troff"), ("rtf", read "text/rtf"), - ("rtx", read "text/richtext"), ("s3m", read "audio/x-mod"), - ("sam", read "audio/x-mod"), ("sds", read "audio/x-sds"), - ("sf", read "audio/x-ircam"), ("sgm", read "text/sgml"), - ("sgml", read "text/sgml"), ("sh", read "application/x-sh"), - ("shar", read "application/x-shar"), - ("shn", read "audio/x-shorten"), ("sid", read "audio/x-sid"), - ("silo", read "model/mesh"), ("sit", read "application/x-stuffit"), - ("skd", read "application/x-koan"), - ("skm", read "application/x-koan"), - ("skp", read "application/x-koan"), - ("skt", read "application/x-koan"), - ("smi", read "application/smil"), - ("smil", read "application/smil"), ("snd", read "audio/x-au"), - ("so", read "application/octet-stream"), - ("spc", read "application/x-spc"), - ("spl", read "application/x-futuresplash"), - ("src", read "application/x-wais-source"), - ("stm", read "audio/x-mod"), ("stx", read "audio/x-mod"), - ("sv4cpio", read "application/x-sv4cpio"), - ("sv4crc", read "application/x-sv4crc"), - ("svg", read "image/svg+xml"), ("svx", read "audio/x-svx"), - ("swf", read "application/x-shockwave-flash"), - ("swfl", read "application/x-shockwave-flash"), - ("t", read "application/x-troff"), - ("tar", read "application/x-tar"), - ("tbz", read "application/x-bzip"), - ("tcl", read "application/x-tcl"), - ("tex", read "application/x-tex"), - ("texi", read "application/x-texinfo"), - ("texinfo", read "application/x-texinfo"), - ("tgz", read "application/x-gzip"), ("tif", read "image/tiff"), - ("tiff", read "image/tiff"), ("tr", read "application/x-troff"), - ("ts", read "video/mpegts"), - ("tsv", read "text/tab-separated-values"), - ("tta", read "audio/x-ttafile"), ("txt", read "text/plain"), - ("ult", read "audio/x-mod"), ("ustar", read "application/x-ustar"), - ("vcd", read "application/x-cdlink"), ("voc", read "audio/x-voc"), - ("vrml", read "model/vrml"), - ("vxml", read "application/voicexml+xml"), - ("w64", read "audio/x-w64"), ("wav", read "audio/x-wav"), - ("wbmp", read "image/vnd.wap.wbmp"), - ("wbxml", read "application/vnd.wap.wbxml"), - ("wm", read "video/x-ms-asf"), ("wma", read "video/x-ms-asf"), - ("wml", read "text/vnd.wap.wml"), - ("wmlc", read "application/vnd.wap.wmlc"), - ("wmls", read "text/vnd.wap.wmlscript"), - ("wmlsc", read "application/vnd.wap.wmlscriptc"), - ("wmv", read "video/x-ms-asf"), ("wrl", read "model/vrml"), - ("wv", read "audio/x-wavpack"), - ("wvc", read "audio/x-wavpack-correction"), - ("wvp", read "audio/x-wavpack"), ("xbm", read "image/x-xbitmap"), - ("xcf", read "image/x-xcf"), ("xht", read "application/xhtml+xml"), - ("xhtml", read "application/xhtml+xml"), - ("xls", read "application/vnd.ms-excel"), - ("xm", read "audio/x-mod"), ("xml", read "application/xml"), - ("xpm", read "image/x-xpixmap"), ("xsl", read "application/xml"), - ("xslt", read "application/xslt+xml"), - ("xul", read "application/vnd.mozilla.xul+xml"), - ("xwd", read "image/x-xwindowdump"), - ("xyz", read "chemical/x-xyz"), ("zip", read "application/zip")] diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index 39de37e..d8bca8e 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -1,9 +1,8 @@ {-# LANGUAGE - UnboxedTuples - , 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. +-- |Guessing MIME Types by file extensions. It's not always accurate +-- but simple and fast. -- -- In general you don't have to use this module directly. module Network.HTTP.Lucu.MIMEType.Guess @@ -14,110 +13,144 @@ module Network.HTTP.Lucu.MIMEType.Guess , serializeExtMap ) where - +import Control.Applicative +import Control.Monad +import qualified Data.Ascii as A +import Data.Attoparsec.Char8 as P +import qualified Data.Attoparsec.Lazy as LP import qualified Data.ByteString.Lazy.Char8 as B import qualified Data.Map as M -import Data.Map (Map) -import Data.Maybe -import Language.Haskell.Pretty -import Language.Haskell.Syntax -import Network.HTTP.Lucu.MIMEType -import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Parser.Http -import Network.HTTP.Lucu.Utils +import Data.Map (Map) +import Data.Maybe +import Data.Monoid.Unicode +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding +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 --- |'Data.Map.Map' from extension to MIME Type. -type ExtMap = Map String MIMEType +-- |A 'Map' from file extensions to 'MIMEType's. +type ExtMap = Map Text MIMEType --- |Guess the MIME Type of file. -guessTypeByFileName :: ExtMap -> FilePath -> Maybe MIMEType +-- |Guess the MIME Type of a file. +guessTypeByFileName ∷ ExtMap → FilePath → Maybe MIMEType guessTypeByFileName extMap fpath - = extMap `seq` fpath `seq` - let ext = last $ splitBy (== '.') fpath - in - M.lookup ext extMap >>= return + = case takeExtension fpath of + [] → Nothing + (_:ext) → M.lookup (T.pack ext) extMap -- |Read an Apache mime.types and parse it. -parseExtMapFile :: FilePath -> IO ExtMap +parseExtMapFile ∷ FilePath → IO ExtMap parseExtMapFile fpath - = fpath `seq` - do file <- B.readFile fpath - case parse (allowEOF extMapP) file of - (# Success xs, _ #) - -> return $ compile xs - - (# _, input' #) - -> let near = B.unpack $ B.take 100 input' - in - fail ("Failed to parse: " ++ fpath ++ " (near: " ++ near ++ ")") - + = do file ← B.readFile fpath + case LP.parse extMapP file of + LP.Done _ xs + → case compile xs of + Right m → return m + Left e → fail (concat [ "Duplicate extension \"" + , show e + , "\" in: " + , fpath + ]) + LP.Fail _ _ e + → fail ("Failed to parse: " ⧺ fpath ⧺ ": " ⧺ e) -extMapP :: Parser [ (MIMEType, [String]) ] -extMapP = do xs <- many (comment <|> validLine <|> emptyLine) - eof +extMapP ∷ Parser [ (MIMEType, [Text]) ] +extMapP = do xs ← P.many (try comment <|> try validLine <|> emptyLine) + endOfInput return $ catMaybes xs where - spc = oneOf " \t" + isSpc ∷ Char → Bool + isSpc c = c ≡ '\x20' ∨ c ≡ '\x09' - comment = many spc >> - char '#' >> - ( many $ satisfy (/= '\n') ) >> - return Nothing + comment ∷ Parser (Maybe (MIMEType, [Text])) + comment = do skipWhile isSpc + void $ char '#' + skipWhile (≢ '\x0A') + return Nothing - validLine = do _ <- many spc - mime <- mimeTypeP - _ <- many spc - exts <- sepBy token (many spc) + validLine ∷ Parser (Maybe (MIMEType, [Text])) + validLine = do skipWhile isSpc + mime ← mimeType + skipWhile isSpc + exts ← sepBy extP (skipWhile isSpc) return $ Just (mime, exts) - emptyLine = oneOf " \t\n" >> return Nothing + extP ∷ Parser Text + extP = decodeUtf8 <$> takeWhile1 (\c → (¬) (isSpc c ∨ c ≡ '\x0A')) + emptyLine ∷ Parser (Maybe (MIMEType, [Text])) + emptyLine = do skipWhile isSpc + void $ char '\x0A' + return Nothing -compile :: [ (MIMEType, [String]) ] -> Map String MIMEType -compile = M.fromList . foldr (++) [] . map tr +compile ∷ Ord k ⇒ [(v, [k])] → Either (k, v, v) (Map k v) +compile = go (∅) ∘ concat ∘ map tr where - tr :: (MIMEType, [String]) -> [ (String, MIMEType) ] - tr (mime, exts) = [ (ext, mime) | ext <- exts ] + tr ∷ (v, [k]) → [(k, v)] + tr (v, ks) = [(k, v) | k ← ks] + + go ∷ Ord k ⇒ Map k v → [(k, v)] → Either (k, v, v) (Map k v) + go m [] = Right m + go m ((k, v):xs) + = case M.insertLookupWithKey' f k v m of + (Nothing, m') → go m' xs + (Just v0, _ ) → Left (k, v0, v) + + f ∷ k → v → v → v + f _ _ = id -- |@'serializeExtMap' extMap moduleName variableName@ generates a -- Haskell source code which contains the following things: -- -- * A definition of module named @moduleName@. -- --- * @variableName :: 'ExtMap'@ whose content is a serialization of --- @extMap@. +-- * @variableName :: 'ExtMap'@ whose content is the serialised +-- @extMap@. -- -- The module "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap" is -- surely generated using this function. -serializeExtMap :: ExtMap -> String -> String -> String +serializeExtMap ∷ ExtMap → String → String → String serializeExtMap extMap moduleName variableName - = let hsModule = HsModule undefined modName (Just exports) imports decls - modName = Module moduleName - exports = [HsEVar (UnQual (HsIdent variableName))] - imports = [ HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType") False Nothing (Just (False, [])) - , HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType.Guess") False Nothing Nothing - , HsImportDecl undefined (Module "Data.Map") True (Just (Module "M")) Nothing - ] - decls = [ HsTypeSig undefined [HsIdent variableName] - (HsQualType [] - (HsTyCon (UnQual (HsIdent "ExtMap")))) - , HsFunBind [HsMatch undefined (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 + , InlineSig (⊥) False AlwaysActive (UnQual (name variableName)) + ] + 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" + comment ⧺ prettyPrint hsModule ⧺ "\n" where - records :: [HsExp] + records ∷ [Exp] records = map record $ M.assocs extMap - record :: (String, MIMEType) -> HsExp + record ∷ (Text, MIMEType) → Exp record (ext, mime) - = HsTuple [HsLit (HsString ext), mimeToExp mime] - - mimeToExp :: MIMEType -> HsExp - mimeToExp mt - = HsApp (HsVar (UnQual (HsIdent "read"))) (HsLit (HsString $ show mt)) + = tuple [ strE (T.unpack ext) + , function "parseMIMEType" `app` strE (mimeToString mime) + ] + + mimeToString ∷ MIMEType → String + mimeToString = A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs index c463130..a04b4a0 100644 --- a/Network/HTTP/Lucu/MultipartForm.hs +++ b/Network/HTTP/Lucu/MultipartForm.hs @@ -1,156 +1,256 @@ {-# LANGUAGE - UnboxedTuples + DoAndIfThenElse + , FlexibleContexts + , OverloadedStrings + , RecordWildCards + , ScopedTypeVariables , UnicodeSyntax + , ViewPatterns #-} +-- |Parse \"multipart/form-data\" based on RFC 2388: +-- +-- +-- You usually don't have to use this module directly. module Network.HTTP.Lucu.MultipartForm ( FormData(..) - , multipartFormP + , parseMultipartFormData ) where +import Control.Applicative hiding (many) +import Control.Applicative.Unicode hiding ((∅)) +import Control.Monad.Error +import Control.Monad.Unicode +import Data.Ascii (Ascii, CIAscii) +import qualified Data.Ascii as A +import Data.Attoparsec +import qualified Data.Attoparsec.Lazy as LP +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LS +import Data.ByteString.Lazy.Search +import Data.Foldable +import Data.List +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import Data.Monoid.Unicode +import Data.Sequence (Seq) +import Data.Sequence.Unicode hiding ((∅)) +import Data.Text (Text) +import qualified Data.Text as T +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.MIMEType +import Network.HTTP.Lucu.Parser.Http +import Network.HTTP.Lucu.RFC2231 +import Prelude.Unicode -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Lazy.Char8 as L8 -import Data.Char -import Data.List -import Network.HTTP.Lucu.Abortion -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Parser.Http -import Network.HTTP.Lucu.Response -import Network.HTTP.Lucu.Utils - - -data Part = Part Headers L8.ByteString - --- |This data type represents a form value and possibly an uploaded --- file name. +-- |'FormData' represents a form value and possibly an uploaded file +-- name. data FormData = FormData { - fdFileName :: Maybe String - , fdContent :: L8.ByteString + -- | @'Nothing'@ for non-file values. + fdFileName ∷ !(Maybe Text) + -- | MIME Type of this value, defaulted to \"text/plain\". + , fdMIMEType ∷ !MIMEType + -- | The form value. + , fdContent ∷ !(LS.ByteString) + } + +data Part + = Part { + ptContDispo ∷ !ContDispo + , ptContType ∷ !MIMEType + , ptBody ∷ !LS.ByteString } -instance HasHeaders Part where - getHeaders (Part hs _) = hs - setHeaders (Part _ b) hs = Part hs b - - -data ContDispo = ContDispo String [(String, String)] - -instance Show ContDispo where - show (ContDispo dType dParams) - = dType ++ - if null dParams then - "" - else - "; " ++ joinWith "; " (map showPair dParams) - where - showPair :: (String, String) -> String - showPair (name, value) - = name ++ "=" ++ if any (not . isToken) value then - quoteStr value - else - value - - -multipartFormP :: String -> Parser [(String, FormData)] -multipartFormP boundary - = do parts <- many (partP boundary) - _ <- string "--" - _ <- string boundary - _ <- string "--" - _ <- crlf - eof - return $ map partToFormPair parts - - -partP :: String -> Parser Part -partP boundary - = do _ <- string "--" - _ <- string boundary - _ <- crlf -- バウンダリの末尾に -- が付いてゐたらここで fail する。 - hs <- headersP - body <- bodyP boundary - return $ Part hs body - - -bodyP :: String -> Parser L8.ByteString -bodyP boundary - = do body <- manyChar $ - do notFollowedBy $ ( crlf >> - string "--" >> - string boundary ) - anyChar - _ <- crlf - return body - - -partToFormPair :: Part -> (String, FormData) -partToFormPair part@(Part _ body) - = let name = partName part - fname = partFileName part - fd = FormData { - fdFileName = fname - , fdContent = body - } - in (name, fd) - -partName :: Part -> String -partName = getName' . getContDispoFormData +data ContDispo + = ContDispo { + dType ∷ !CIAscii + , dParams ∷ !(Map CIAscii Text) + } + +printContDispo ∷ ContDispo → Ascii +printContDispo d + = A.fromAsciiBuilder + ( A.toAsciiBuilder (A.fromCIAscii $ dType d) + ⊕ + printMIMEParams (dParams d) ) + +-- |Parse \"multipart/form-data\" and return either @'Left' err@ or +-- @'Right' result@. Note that there are currently the following +-- limitations: +-- +-- * Multiple files embedded as \"multipart/mixed\" within the +-- \"multipart/form-data\" won't be decomposed. +-- +-- * \"Content-Transfer-Encoding\" is always ignored. +-- +-- * RFC 2388 says that non-ASCII field names are encoded according +-- to the method in RFC 2047 +-- , but they won't be +-- decoded. +parseMultipartFormData ∷ Ascii -- ^boundary + → LS.ByteString -- ^input + → Either String [(Ascii, FormData)] +parseMultipartFormData boundary = (mapM partToFormPair =≪) ∘ go where - getName' :: ContDispo -> String - getName' dispo@(ContDispo _ dParams) - = case find ((== "name") . map toLower . fst) dParams of - Just (_, name) -> name - Nothing - -> abortPurely BadRequest [] - (Just $ "form-data without name: " ++ show dispo) + go ∷ (Functor m, MonadError String m) + ⇒ LS.ByteString + → m [Part] + {-# INLINEABLE go #-} + go src + = case LP.parse (prologue boundary) src of + LP.Done src' _ + → go' src' (∅) + LP.Fail _ eCtx e + → throwError $ "Unparsable multipart/form-data: " + ⧺ intercalate ", " eCtx + ⧺ ": " + ⧺ e + go' ∷ (Functor m, MonadError String m) + ⇒ LS.ByteString + → Seq Part + → m [Part] + {-# INLINEABLE go' #-} + go' src xs + = case LP.parse epilogue src of + LP.Done _ _ + → return $ toList xs + LP.Fail _ _ _ + → do (src', x) ← parsePart boundary src + go' src' $ xs ⊳ x + +prologue ∷ Ascii → Parser () +prologue boundary + = ( (string "--" "prefix") + *> + (string (A.toByteString boundary) "boundary") + *> + pure () + ) + + "prologue" +epilogue ∷ Parser () +epilogue = ( (string "--" "suffix") + *> + crlf + *> + endOfInput + ) + + "epilogue" -partFileName :: Part -> Maybe String -partFileName = getFileName' . getContDispoFormData +parsePart ∷ (Functor m, MonadError String m) + ⇒ Ascii + → LS.ByteString + → m (LS.ByteString, Part) +{-# INLINEABLE parsePart #-} +parsePart boundary src + = case LP.parse partHeader src of + LP.Done src' hdrs + → do dispo ← getContDispo hdrs + cType ← fromMaybe defaultCType <$> getContType hdrs + (body, src'') + ← getBody boundary src' + return (src'', Part dispo cType body) + LP.Fail _ eCtx e + → throwError $ "unparsable part: " + ⧺ intercalate ", " eCtx + ⧺ ": " + ⧺ e + where + defaultCType ∷ MIMEType + defaultCType = parseMIMEType "text/plain" + +partHeader ∷ Parser Headers +partHeader = crlf *> headers + +getContDispo ∷ MonadError String m ⇒ Headers → m ContDispo +{-# INLINEABLE getContDispo #-} +getContDispo hdrs + = case getHeader "Content-Disposition" hdrs of + Nothing + → throwError "Content-Disposition is missing" + Just str + → case parseOnly p $ A.toByteString str of + Right d → return d + Left err → throwError $ "malformed Content-Disposition: " + ⧺ A.toString str + ⧺ ": " + ⧺ err where - getFileName' :: ContDispo -> Maybe String - getFileName' (ContDispo _ dParams) - = do (_, fileName) <- find ((== "filename") . map toLower . fst) dParams - return fileName - -getContDispoFormData :: Part -> ContDispo -getContDispoFormData part - = let dispo@(ContDispo dType _) = getContDispo part - in - if map toLower dType == "form-data" then - dispo - else - abortPurely BadRequest [] - (Just $ "Content-Disposition type is not form-data: " ++ dType) - - -getContDispo :: Part -> ContDispo -getContDispo part - = case getHeader (C8.pack "Content-Disposition") part of - Nothing - -> abortPurely BadRequest [] - (Just "There is a part without Content-Disposition in the multipart/form-data.") - Just dispoStr - -> case parse contDispoP (L8.fromChunks [dispoStr]) of - (# Success dispo, _ #) - -> dispo - (# _, _ #) - -> abortPurely BadRequest [] - (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispoStr) - - -contDispoP :: Parser ContDispo -contDispoP = do dispoType <- token - params <- allowEOF $ many paramP - return $ ContDispo dispoType params + p = do dispo ← contentDisposition + endOfInput + return dispo + +contentDisposition ∷ Parser ContDispo +contentDisposition + = (ContDispo <$> (A.toCIAscii <$> token) ⊛ mimeParams) + + "contentDisposition" + +getContType ∷ MonadError String m ⇒ Headers → m (Maybe MIMEType) +{-# INLINEABLE getContType #-} +getContType hdrs + = case getHeader "Content-Type" hdrs of + Nothing + → return Nothing + Just str + → case parseOnly p $ A.toByteString str of + Right d → return $ Just d + Left err → throwError $ "malformed Content-Type: " + ⧺ A.toString str + ⧺ ": " + ⧺ err where - paramP :: Parser (String, String) - paramP = do _ <- many lws - _ <- char ';' - _ <- many lws - name <- token - _ <- char '=' - value <- token <|> quotedStr - return (name, value) + p = do t ← mimeType + endOfInput + return t + +getBody ∷ MonadError String m + ⇒ Ascii + → LS.ByteString + → m (LS.ByteString, LS.ByteString) +{-# INLINEABLE getBody #-} +getBody (("\r\n--" ⊕) ∘ A.toByteString → boundary) src + = case breakOn boundary src of + (before, after) + | LS.null after + → throwError "missing boundary" + | otherwise + → let len = fromIntegral $ BS.length boundary + after' = LS.drop len after + in + return (before, after') + +partToFormPair ∷ MonadError String m ⇒ Part → m (Ascii, FormData) +{-# INLINEABLE partToFormPair #-} +partToFormPair pt@(Part {..}) + | dType ptContDispo ≡ "form-data" + = do name ← partName pt + let fd = FormData { + fdFileName = partFileName pt + , fdMIMEType = ptContType + , fdContent = ptBody + } + return (name, fd) + | otherwise + = throwError $ "disposition type is not \"form-data\": " + ⧺ A.toString (A.fromCIAscii $ dType ptContDispo) + +partName ∷ MonadError String m ⇒ Part → m Ascii +{-# INLINEABLE partName #-} +partName (Part {..}) + = case M.lookup "name" $ dParams ptContDispo of + Just name + → case A.fromText name of + Just a → return a + Nothing → throwError $ "Non-ascii part name: " + ⧺ T.unpack name + Nothing + → throwError $ "form-data without name: " + ⧺ A.toString (printContDispo ptContDispo) + +partFileName ∷ Part → Maybe Text +partFileName (Part {..}) + = M.lookup "filename" $ dParams ptContDispo diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs index 7809f53..ce43718 100644 --- a/Network/HTTP/Lucu/Parser.hs +++ b/Network/HTTP/Lucu/Parser.hs @@ -1,339 +1,20 @@ {-# LANGUAGE - BangPatterns - , ScopedTypeVariables - , UnboxedTuples - , UnicodeSyntax + UnicodeSyntax #-} --- |Yet another parser combinator. This is mostly a subset of --- "Text.ParserCombinators.Parsec" but there are some differences: --- --- * This parser works on 'Data.ByteString.Base.LazyByteString' --- instead of 'Prelude.String'. --- --- * Backtracking is the only possible behavior so there is no \"try\" --- action. --- --- * On success, the remaining string is returned as well as the --- parser result. --- --- * You can choose whether to treat reaching EOF (trying to eat one --- more letter at the end of string) a fatal error or to treat it a --- normal failure. If a fatal error occurs, the entire parsing --- process immediately fails without trying any backtracks. The --- default behavior is to treat EOF fatal. --- --- In general, you don't have to use this module directly. +-- |This is an auxiliary parser utilities. You usually don't have to +-- use this module directly. module Network.HTTP.Lucu.Parser - ( Parser - , ParserResult(..) - - , failP - - , parse - , parseStr - - , anyChar - , eof - , allowEOF - , satisfy - , char - , string - , (<|>) - , choice - , oneOf - , digit - , hexDigit - , notFollowedBy - , many - , manyChar - , many1 - , count - , option - , sepBy - , sepBy1 - - , sp - , ht - , crlf + ( atMost ) where - -import Control.Monad.State.Strict hiding (state) -import qualified Data.ByteString.Lazy as Lazy (ByteString) -import qualified Data.ByteString.Lazy.Char8 as B hiding (ByteString) -import qualified Data.Foldable as Fold -import Data.Int -import qualified Data.Sequence as Seq -import Data.Sequence (Seq, (|>)) - --- |@'Parser' a@ is obviously a parser which parses and returns @a@. -newtype Parser a = Parser { - runParser :: State ParserState (ParserResult a) - } - - -data ParserState - = PST { - pstInput :: Lazy.ByteString - , pstIsEOFFatal :: !Bool - } - deriving (Eq, Show) - - -data ParserResult a = Success !a - | IllegalInput -- 受理出來ない入力があった - | ReachedEOF -- 限界を越えて讀まうとした - deriving (Eq, Show) - - --- (>>=) :: Parser a -> (a -> Parser b) -> Parser b -instance Monad Parser where - p >>= f = Parser $! do saved <- get -- 失敗した時の爲に状態を保存 - result <- runParser p - case result of - Success a -> runParser (f a) - IllegalInput -> do put saved -- 状態を復歸 - return IllegalInput - ReachedEOF -> do put saved -- 状態を復歸 - return ReachedEOF - return !x = Parser $! return $! Success x - fail _ = Parser $! return $! IllegalInput - -instance Functor Parser where - fmap f p = p >>= return . f - --- |@'failP'@ is just a synonym for @'Prelude.fail' --- 'Prelude.undefined'@. -failP :: Parser a -failP = fail undefined - --- |@'parse' p bstr@ parses @bstr@ with @p@ and returns @(# result, --- remaining #)@. -parse :: Parser a -> Lazy.ByteString -> (# ParserResult a, Lazy.ByteString #) -parse !p input -- input は lazy である必要有り。 - = let (!result, state') = runState (runParser p) (PST input True) - in - (# result, pstInput state' #) -- pstInput state' も lazy である必要有り。 - --- |@'parseStr' p str@ packs @str@ and parses it. -parseStr :: Parser a -> String -> (# ParserResult a, Lazy.ByteString #) -parseStr !p input -- input は lazy である必要有り。 - = parse p (B.pack input) - - -anyChar :: Parser Char -anyChar = Parser $! - do state@(PST input _) <- get - if B.null input then - return ReachedEOF - else - do put $! state { pstInput = B.tail input } - return (Success $! B.head input) - - -eof :: Parser () -eof = Parser $! - do PST input _ <- get - if B.null input then - return $! Success () - else - return IllegalInput - --- |@'allowEOF' p@ makes @p@ treat reaching EOF a normal failure. -allowEOF :: Parser a -> Parser a -allowEOF !f - = Parser $! do saved@(PST _ isEOFFatal) <- get - put $! saved { pstIsEOFFatal = False } - - result <- runParser f - - state <- get - put $! state { pstIsEOFFatal = isEOFFatal } - - return result - - -satisfy :: (Char -> Bool) -> Parser Char -satisfy !f - = do c <- anyChar - if f c then - return c - else - failP - - -char :: Char -> Parser Char -char !c = satisfy (== c) - - -string :: String -> Parser String -string !str - = let bs = B.pack str - len = B.length bs - in - Parser $! - do st <- get - let (bs', rest) = B.splitAt len $ pstInput st - st' = st { pstInput = rest } - if B.length bs' < len then - return ReachedEOF - else - if bs == bs' then - do put st' - return $ Success str - else - return IllegalInput - - -infixr 0 <|> - --- |This is the backtracking alternation. There is no non-backtracking --- equivalent. -(<|>) :: Parser a -> Parser a -> Parser a -(!f) <|> (!g) - = Parser $! do saved <- get -- 状態を保存 - result <- runParser f - case result of - Success a -> return $! Success a - IllegalInput -> do put saved -- 状態を復歸 - runParser g - ReachedEOF -> if pstIsEOFFatal saved then - do put saved - return ReachedEOF - else - do put saved - runParser g - - -choice :: [Parser a] -> Parser a -choice = foldl (<|>) failP - - -oneOf :: [Char] -> Parser Char -oneOf = foldl (<|>) failP . map char - - -notFollowedBy :: Parser a -> Parser () -notFollowedBy !p - = Parser $! do saved <- get -- 状態を保存 - result <- runParser p - case result of - Success _ -> do put saved -- 状態を復歸 - return IllegalInput - IllegalInput -> do put saved -- 状態を復歸 - return $! Success () - ReachedEOF -> do put saved -- 状態を復歸 - return $! Success () - - -digit :: Parser Char -digit = do c <- anyChar - if c >= '0' && c <= '9' then - return c - else - failP - - -hexDigit :: Parser Char -hexDigit = do c <- anyChar - if (c >= '0' && c <= '9') || - (c >= 'a' && c <= 'f') || - (c >= 'A' && c <= 'F') then - return c - else - failP - - -many :: forall a. Parser a -> Parser [a] -many !p = Parser $! - do state <- get - let (# result, state' #) = many' state Seq.empty - put state' - return result - where - many' :: ParserState -> Seq a -> (# ParserResult [a], ParserState #) - many' !st !soFar - = case runState (runParser p) st of - (Success a, st') -> many' st' (soFar |> a) - (IllegalInput, _) -> (# Success (Fold.toList soFar), st #) - (ReachedEOF , _) -> if pstIsEOFFatal st then - (# ReachedEOF, st #) - else - (# Success (Fold.toList soFar), st #) - -manyChar :: Parser Char -> Parser Lazy.ByteString -manyChar !p = Parser $! - do state <- get - case scan' state 0 of - Success len - -> do let (bs, rest) = B.splitAt len (pstInput state) - state' = state { pstInput = rest } - put state' - return $ Success bs - ReachedEOF - -> if pstIsEOFFatal state then - return ReachedEOF - else - error "internal error" - _ -> error "internal error" - where - scan' :: ParserState -> Int64 -> ParserResult Int64 - scan' !st !soFar - = case runState (runParser p) st of - (Success _ , st') -> scan' st' (soFar + 1) - (IllegalInput, _ ) -> Success soFar - (ReachedEOF , _ ) -> if pstIsEOFFatal st then - ReachedEOF - else - Success soFar - - -many1 :: Parser a -> Parser [a] -many1 !p = do x <- p - xs <- many p - return (x:xs) - - -count :: Int -> Parser a -> Parser [a] -count !n !p = Parser $! count' n p Seq.empty - --- This implementation is rather ugly but we need to make it --- tail-recursive to avoid stack overflow. -count' :: Int -> Parser a -> Seq a -> State ParserState (ParserResult [a]) -count' 0 _ !soFar = return $! Success $! Fold.toList soFar -count' !n !p !soFar = do saved <- get - result <- runParser p - case result of - Success a -> count' (n-1) p (soFar |> a) - IllegalInput -> do put saved - return IllegalInput - ReachedEOF -> do put saved - return ReachedEOF - - --- def may be a _|_ -option :: a -> Parser a -> Parser a -option def !p = p <|> return def - - -sepBy :: Parser a -> Parser sep -> Parser [a] -sepBy !p !sep = sepBy1 p sep <|> return [] - - -sepBy1 :: Parser a -> Parser sep -> Parser [a] -sepBy1 !p !sep - = do x <- p - xs <- many $! sep >> p - return (x:xs) - - -sp :: Parser Char -sp = char ' ' - - -ht :: Parser Char -ht = char '\t' - - -crlf :: Parser String -crlf = string "\x0d\x0a" +import Control.Applicative +import Control.Applicative.Unicode + +-- |@'atMost' n v@ is like @'P.many' v@ but accumulates @v@ at most +-- @n@ times. +atMost ∷ Alternative f ⇒ Int → f a → f [a] +{-# INLINE atMost #-} +atMost 0 _ = pure [] +atMost n v = ( (:) <$> v ⊛ atMost (n-1) v ) + <|> + pure [] diff --git a/Network/HTTP/Lucu/Parser/Http.hs b/Network/HTTP/Lucu/Parser/Http.hs index fe54bde..72d8ca1 100644 --- a/Network/HTTP/Lucu/Parser/Http.hs +++ b/Network/HTTP/Lucu/Parser/Http.hs @@ -1,5 +1,5 @@ {-# LANGUAGE - BangPatterns + OverloadedStrings , UnicodeSyntax #-} -- |This is an auxiliary parser utilities for parsing things related @@ -8,120 +8,158 @@ -- In general you don't have to use this module directly. module Network.HTTP.Lucu.Parser.Http ( isCtl + , isText , isSeparator , isChar , isToken + , isSPHT + , listOf - , token + + , crlf + , sp , lws - , text - , separator + + , token + , separators , quotedStr , qvalue ) where +import Control.Applicative +import Control.Monad +import Data.Ascii (Ascii) +import qualified Data.Ascii as A +import Data.Attoparsec.Char8 as P hiding (scan) +import qualified Data.Attoparsec.FastSet as FS +import qualified Data.ByteString.Char8 as BS +import Network.HTTP.Lucu.Parser +import Prelude.Unicode -import Network.HTTP.Lucu.Parser - --- |@'isCtl' c@ is 'Prelude.False' iff @0x20 <= @c@ < 0x7F@. -isCtl :: Char -> Bool +-- |@'isCtl' c@ returns 'False' iff @0x20 <= c < 0x7F@. +isCtl ∷ Char → Bool +{-# INLINE isCtl #-} isCtl c - | c < '\x1f' = True - | c >= '\x7f' = True - | otherwise = False + | c ≤ '\x1f' = True + | c > '\x7f' = True + | otherwise = False + +-- |@'isText'@ is equivalent to @'not' '.' 'isCtl'@ +isText ∷ Char → Bool +{-# INLINE isText #-} +isText = (¬) ∘ isCtl --- |@'isSeparator' c@ is 'Prelude.True' iff c is one of HTTP +-- |@'isSeparator' c@ returns 'True' iff c is one of the HTTP -- separators. -isSeparator :: Char -> Bool -isSeparator '(' = True -isSeparator ')' = True -isSeparator '<' = True -isSeparator '>' = True -isSeparator '@' = True -isSeparator ',' = True -isSeparator ';' = True -isSeparator ':' = True -isSeparator '\\' = True -isSeparator '"' = True -isSeparator '/' = True -isSeparator '[' = True -isSeparator ']' = True -isSeparator '?' = True -isSeparator '=' = True -isSeparator '{' = True -isSeparator '}' = True -isSeparator ' ' = True -isSeparator '\t' = True -isSeparator _ = False - --- |@'isChar' c@ is 'Prelude.True' iff @c <= 0x7f@. -isChar :: Char -> Bool -isChar c - | c <= '\x7f' = True - | otherwise = False - --- |@'isToken' c@ is equivalent to @not ('isCtl' c || 'isSeparator' +isSeparator ∷ Char → Bool +{-# INLINE isSeparator #-} +isSeparator = flip FS.memberChar set + where + {-# NOINLINE set #-} + set = FS.charClass "()<>@,;:\\\"/[]?={}\x20\x09" + +-- |@'isChar' c@ returns 'True' iff @c <= 0x7f@. +isChar ∷ Char → Bool +{-# INLINE isChar #-} +isChar = (≤ '\x7F') + +-- |@'isToken' c@ is equivalent to @not ('isCtl' c '||' 'isSeparator' -- c)@ -isToken :: Char -> Bool -isToken c = c `seq` - not (isCtl c || isSeparator c) - --- |@'listOf' p@ is similar to @'Network.HTTP.Lucu.Parser.sepBy' p --- ('Network.HTTP.Lucu.Parser.char' \',\')@ but it allows any --- occurrences of LWS before and after each tokens. -listOf :: Parser a -> Parser [a] -listOf !p = do _ <- many lws - sepBy p $! do _ <- many lws - _ <- char ',' - many lws - --- |'token' is equivalent to @'Network.HTTP.Lucu.Parser.many1' $ --- 'Network.HTTP.Lucu.Parser.satisfy' 'isToken'@ -token :: Parser String -token = many1 $! satisfy isToken - --- |'lws' is an HTTP LWS: @'Network.HTTP.Lucu.Parser.crlf'? --- ('Network.HTTP.Lucu.Parser.sp' | 'Network.HTTP.Lucu.Parser.ht')+@ -lws :: Parser String -lws = do s <- option "" crlf - xs <- many1 (sp <|> ht) - return (s ++ xs) - --- |'text' accepts one character which doesn't satisfy 'isCtl'. -text :: Parser Char -text = satisfy (not . isCtl) - --- |'separator' accepts one character which satisfies 'isSeparator'. -separator :: Parser Char -separator = satisfy isSeparator +isToken ∷ Char → Bool +{-# INLINE isToken #-} +isToken c = (¬) (isCtl c ∨ isSeparator c) + +-- |@'listOf' p@ is similar to @'sepBy' p ('char' \',\')@ but it +-- allows any occurrences of 'lws' before and after each tokens. +listOf ∷ Parser a → Parser [a] +{-# INLINEABLE listOf #-} +listOf p + = do skipMany lws + p `sepBy` do skipMany lws + void $ char ',' + skipMany lws + + "listOf" + +-- |'token' is almost the same as @'takeWhile1' 'isToken'@ +token ∷ Parser Ascii +{-# INLINE token #-} +token = (A.unsafeFromByteString <$> takeWhile1 isToken) + + "token" + +-- |The CRLF: 0x0D 0x0A. +crlf ∷ Parser () +{-# INLINE crlf #-} +crlf = (string "\x0D\x0A" *> return ()) + + "crlf" + +-- |The SP: 0x20. +sp ∷ Parser () +{-# INLINE sp #-} +sp = char '\x20' *> return () + +-- |HTTP LWS: crlf? (sp | ht)+ +lws ∷ Parser () +{-# INLINEABLE lws #-} +lws = (option () crlf *> void (takeWhile1 isSPHT)) + + "lws" + +-- |Returns 'True' for SP and HT. +isSPHT ∷ Char → Bool +{-# INLINE isSPHT #-} +isSPHT '\x20' = True +isSPHT '\x09' = True +isSPHT _ = False + +-- |@'separators'@ is almost the same as @'takeWhile1' 'isSeparator'@. +separators ∷ Parser Ascii +{-# INLINE separators #-} +separators = (A.unsafeFromByteString <$> takeWhile1 isSeparator) + + "separators" -- |'quotedStr' accepts a string surrounded by double quotation -- marks. Quotes can be escaped by backslashes. -quotedStr :: Parser String -quotedStr = do _ <- char '"' - xs <- many (qdtext <|> quotedPair) - _ <- char '"' - return $ foldr (++) "" xs +quotedStr ∷ Parser Ascii +{-# INLINEABLE quotedStr #-} +quotedStr = do void $ char '"' + xs ← P.many (qdtext <|> quotedPair) + void $ char '"' + return $ A.unsafeFromByteString $ BS.pack xs + + "quotedStr" where - qdtext = do c <- satisfy (/= '"') - return [c] + qdtext ∷ Parser Char + {-# INLINE qdtext #-} + qdtext = satisfy (\c → c ≢ '"' ∧ (¬) (isCtl c)) + + "qdtext" - quotedPair = do _ <- char '\\' - c <- satisfy isChar - return [c] + quotedPair ∷ Parser Char + {-# INLINE quotedPair #-} + quotedPair = (char '\\' *> satisfy isChar) + + "quotedPair" -- |'qvalue' accepts a so-called qvalue. -qvalue :: Parser Double -qvalue = do x <- char '0' - xs <- option "" - $ do y <- char '.' - ys <- many digit -- 本當は三文字までに制限 - return (y:ys) - return $ read (x:xs) - <|> - do x <- char '1' - xs <- option "" - $ do y <- char '.' - ys <- many (char '0') -- 本當は三文字までに制限 - return (y:ys) - return $ read (x:xs) +qvalue ∷ Parser Double +{-# INLINEABLE qvalue #-} +qvalue = ( do x ← char '0' + xs ← option "" $ + do y ← char '.' + ys ← atMost 3 digit + return (y:ys) + return $ read (x:xs) + <|> + do x ← char '1' + xs ← option "" $ + do y ← char '.' + ys ← atMost 3 (char '0') + return (y:ys) + return $ read (x:xs) + ) + + "qvalue" diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 806ed1c..6735652 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -1,180 +1,146 @@ {-# LANGUAGE - BangPatterns + DoAndIfThenElse + , OverloadedStrings + , RecordWildCards , UnicodeSyntax #-} module Network.HTTP.Lucu.Postprocess ( postprocess - , completeUnconditionalHeaders ) where - -import Control.Concurrent.STM -import Control.Monad -import qualified Data.ByteString as Strict (ByteString) -import qualified Data.ByteString.Char8 as C8 hiding (ByteString) -import Data.IORef -import Data.Maybe -import Data.Time -import qualified Data.Time.HTTP as HTTP -import GHC.Conc (unsafeIOToSTM) -import Network.HTTP.Lucu.Abortion -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.HttpVersion -import Network.HTTP.Lucu.Interaction -import Network.HTTP.Lucu.Request -import Network.HTTP.Lucu.Response -import System.IO.Unsafe - -{- - - * Response が未設定なら、200 OK にする。 - - * ステータスが 2xx, 3xx, 4xx, 5xx のいずれでもなければ 500 にする。 - - * 405 Method Not Allowed なのに Allow ヘッダが無ければ 500 にする。 - - * 304 Not Modified 以外の 3xx なのに Location ヘッダが無ければ 500 に - する。 - - * Content-Length があれば、それを削除する。Transfer-Encoding があって - も削除する。 - - * HTTP/1.1 であり、body を持つ事が出來る時、Transfer-Encoding を - chunked に設定する。 - - * body を持つ事が出來る時、Content-Type が無ければデフォルト値にする。 - 出來ない時、HEAD でなければContent-Type, Etag, Last-Modified を削除 - する。 - - * body を持つ事が出來ない時、body 破棄フラグを立てる。 - - * Connection: close が設定されてゐる時、切斷フラグを立てる。 - - * 切斷フラグが立ってゐる時、Connection: close を設定する。 - - * Server が無ければ設定。 - - * Date が無ければ設定。 - --} - -postprocess :: Interaction -> STM () -postprocess !itr - = do reqM <- readItr itr itrRequest id - res <- readItr itr itrResponse id - let sc = resStatus res - - unless (any (\ p -> p sc) [isSuccessful, isRedirection, isError]) - $ abortSTM InternalServerError [] - $ Just ("The status code is not good for a final status: " - ++ show sc) - - when (sc == MethodNotAllowed && getHeader (C8.pack "Allow") res == Nothing) - $ abortSTM InternalServerError [] - $ Just ("The status was " ++ show sc ++ " but no Allow header.") - - when (sc /= NotModified && isRedirection sc && getHeader (C8.pack "Location") res == Nothing) - $ abortSTM InternalServerError [] - $ Just ("The status code was " ++ show sc ++ " but no Location header.") - - when (reqM /= Nothing) relyOnRequest - - -- itrResponse の内容は relyOnRequest によって變へられてゐる可 - -- 能性が高い。 - do oldRes <- readItr itr itrResponse id - newRes <- unsafeIOToSTM - $ completeUnconditionalHeaders (itrConfig itr) oldRes - writeItr itr itrResponse newRes - where - relyOnRequest :: STM () - relyOnRequest - = do status <- readItr itr itrResponse resStatus - req <- readItr itr itrRequest fromJust - - let reqVer = reqVersion req - canHaveBody = if reqMethod req == HEAD then - False - else - not (isInformational status || - status == NoContent || - status == ResetContent || - status == NotModified ) - - updateRes $! deleteHeader (C8.pack "Content-Length") - updateRes $! deleteHeader (C8.pack "Transfer-Encoding") - - cType <- readHeader (C8.pack "Content-Type") - when (cType == Nothing) - $ updateRes $ setHeader (C8.pack "Content-Type") defaultPageContentType - - if canHaveBody then - when (reqVer == HttpVersion 1 1) - $ do updateRes $! setHeader (C8.pack "Transfer-Encoding") (C8.pack "chunked") - writeItr itr itrWillChunkBody True - else - -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す - when (reqMethod req /= HEAD) - $ do updateRes $! deleteHeader (C8.pack "Content-Type") - updateRes $! deleteHeader (C8.pack "Etag") - updateRes $! deleteHeader (C8.pack "Last-Modified") - - conn <- readHeader (C8.pack "Connection") - case conn of - Nothing -> return () - Just value -> when (value `noCaseEq` C8.pack "close") - $ writeItr itr itrWillClose True - - willClose <- readItr itr itrWillClose id - when willClose - $ updateRes $! setHeader (C8.pack "Connection") (C8.pack "close") - - when (reqMethod req == HEAD || not canHaveBody) - $ writeTVar (itrWillDiscardBody itr) True - - readHeader :: Strict.ByteString -> STM (Maybe Strict.ByteString) - readHeader !name - = readItr itr itrResponse $ getHeader name - - updateRes :: (Response -> Response) -> STM () - updateRes !updator - = updateItr itr itrResponse updator - - -completeUnconditionalHeaders :: Config -> Response -> IO Response -completeUnconditionalHeaders !conf !res - = compServer res >>= compDate - where - compServer res' - = case getHeader (C8.pack "Server") res' of - Nothing -> return $ setHeader (C8.pack "Server") (cnfServerSoftware conf) res' - Just _ -> return res' - - compDate res' - = case getHeader (C8.pack "Date") res' of - Nothing -> do date <- getCurrentDate - return $ setHeader (C8.pack "Date") date res' - Just _ -> return res' - - -cache :: IORef (UTCTime, Strict.ByteString) -cache = unsafePerformIO $ - newIORef (UTCTime (ModifiedJulianDay 0) 0, undefined) -{-# NOINLINE cache #-} - -getCurrentDate :: IO Strict.ByteString -getCurrentDate = do now <- getCurrentTime - (cachedTime, cachedStr) <- readIORef cache - - if now `mostlyEq` cachedTime then - return cachedStr - else - do let dateStr = C8.pack $ HTTP.format now - writeIORef cache (now, dateStr) - return dateStr +import Control.Applicative +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.Unicode +import Data.Ascii (Ascii, CIAscii, AsciiBuilder) +import qualified Data.Ascii as A +import Data.Maybe +import Data.Monoid.Unicode +import GHC.Conc (unsafeIOToSTM) +import Network.HTTP.Lucu.Abortion +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.DefaultPage +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Response +import Prelude.Unicode + +postprocess ∷ NormalInteraction → STM () +postprocess ni@(NI {..}) + = do void $ tryPutTMVar niSendContinue False + abortOnCertainConditions ni + postprocessWithRequest ni + completeUnconditionalHeaders ni + +abortOnCertainConditions ∷ NormalInteraction → STM () +abortOnCertainConditions (NI {..}) + = readTVar niResponse ≫= go where - mostlyEq :: UTCTime -> UTCTime -> Bool - mostlyEq a b - = (utctDay a == utctDay b) - && - (fromEnum (utctDayTime a) == fromEnum (utctDayTime b)) + go ∷ Response → STM () + go res@(Response {..}) + = do unless (any (\ p → p resStatus) [ isSuccessful + , isRedirection + , isError + ]) + $ abort' + $ A.toAsciiBuilder "Inappropriate status code for a response: " + ⊕ printStatusCode resStatus + + when ( resStatus ≡ MethodNotAllowed ∧ + hasHeader "Allow" res ) + $ abort' + $ A.toAsciiBuilder "The status was " + ⊕ printStatusCode resStatus + ⊕ A.toAsciiBuilder " but no \"Allow\" header." + + when ( resStatus ≢ NotModified ∧ + isRedirection resStatus ∧ + hasHeader "Location" res ) + $ abort' + $ A.toAsciiBuilder "The status code was " + ⊕ printStatusCode resStatus + ⊕ A.toAsciiBuilder " but no Location header." + + abort' ∷ AsciiBuilder → STM () + abort' = throwSTM + ∘ mkAbortion' InternalServerError + ∘ A.toText + ∘ A.fromAsciiBuilder + +postprocessWithRequest ∷ NormalInteraction → STM () +postprocessWithRequest ni@(NI {..}) + = do willDiscardBody ← readTVar niWillDiscardBody + canHaveBody ← if willDiscardBody then + return False + else + resCanHaveBody <$> readTVar niResponse + + updateRes ni + $ deleteHeader "Content-Length" + ∘ deleteHeader "Transfer-Encoding" + + if canHaveBody then + do when niWillChunkBody $ + writeHeader ni "Transfer-Encoding" (Just "chunked") + writeDefaultPageIfNeeded ni + else + do writeTVar niWillDiscardBody True + -- These headers make sense for HEAD requests even + -- when there won't be a response entity body. + when (reqMethod niRequest ≢ HEAD) + $ updateRes ni + $ deleteHeader "Content-Type" + ∘ deleteHeader "Etag" + ∘ deleteHeader "Last-Modified" + + hasConnClose ← (≡ Just "close") <$> readCIHeader ni "Connection" + willClose ← readTVar niWillClose + when (hasConnClose ∧ (¬) willClose) + $ writeTVar niWillClose True + when ((¬) hasConnClose ∧ willClose) + $ writeHeader ni "Connection" (Just "close") + +writeDefaultPageIfNeeded ∷ NormalInteraction → STM () +writeDefaultPageIfNeeded ni@(NI {..}) + = do resHasCType ← readTVar niResponseHasCType + unless resHasCType + $ do writeHeader ni "Content-Type" $ Just defaultPageContentType + writeHeader ni "Content-Encoding" Nothing + res ← readTVar niResponse + let body = getDefaultPage niConfig (Just niRequest) res + putTMVar niBodyToSend body + +completeUnconditionalHeaders ∷ NormalInteraction → STM () +completeUnconditionalHeaders ni@(NI {..}) + = do srv ← readHeader ni "Server" + when (isNothing srv) $ + writeHeader ni "Server" $ Just $ cnfServerSoftware niConfig + + date ← readHeader ni "Date" + when (isNothing date) $ + do date' ← unsafeIOToSTM getCurrentDate + writeHeader ni "Date" $ Just date' + +writeHeader ∷ NormalInteraction → CIAscii → Maybe Ascii → STM () +{-# INLINE writeHeader #-} +writeHeader ni k v + = case v of + Just v' → updateRes ni $ setHeader k v' + Nothing → updateRes ni $ deleteHeader k + +readHeader ∷ NormalInteraction → CIAscii → STM (Maybe Ascii) +{-# INLINE readHeader #-} +readHeader (NI {..}) k + = getHeader k <$> readTVar niResponse + +readCIHeader ∷ NormalInteraction → CIAscii → STM (Maybe CIAscii) +{-# INLINE readCIHeader #-} +readCIHeader (NI {..}) k + = getCIHeader k <$> readTVar niResponse + +updateRes ∷ NormalInteraction → (Response → Response) → STM () +{-# INLINE updateRes #-} +updateRes (NI {..}) f + = do old ← readTVar niResponse + writeTVar niResponse $ f old diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index 9f9fa0d..26fbd53 100644 --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -1,157 +1,205 @@ {-# LANGUAGE - BangPatterns + DoAndIfThenElse + , OverloadedStrings + , RecordWildCards + , UnicodeSyntax #-} module Network.HTTP.Lucu.Preprocess - ( preprocess + ( AugmentedRequest(..) + , RequestBodyLength(..) + , preprocess ) where - -import Control.Concurrent.STM -import Control.Monad -import qualified Data.ByteString as Strict (ByteString) -import qualified Data.ByteString.Char8 as C8 hiding (ByteString) -import Data.Char -import Data.Maybe -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.HttpVersion -import Network.HTTP.Lucu.Interaction -import Network.HTTP.Lucu.Request -import Network.HTTP.Lucu.Response -import Network.URI - -{- - - * URI にホスト名が存在しない時、 - [1] HTTP/1.0 ならば Config を使って補完 - [2] HTTP/1.1 ならば Host ヘッダで補完。Host が無ければ 400。 - - * Expect: に問題があった場合は 417 Expectation Failed に設定。 - 100-continue 以外のものは全部 417 に。 - - * Transfer-Encoding: に問題があったら 501 Not Implemented にする。具 - 体的には、identity でも chunked でもなければ 501 Not Implemented に - する。 - - * メソッドが GET, HEAD, POST, PUT, DELETE の何れでもない場合は 501 - Not Implemented にする。 - - * HTTP/1.0 でも HTTP/1.1 でもないリクエストに對しては 505 HTTP - Version Not Supported を返す。 - - * POST または PUT に Content-Length も Transfer-Encoding も無い時は、 - 411 Length Required にする。 - - * Content-Length の値が數値でなかったり負だったりしたら 400 Bad - Request にする。 - - * willDiscardBody その他の變數を設定する。 - --} - -preprocess :: Interaction -> STM () -preprocess !itr - = do req <- readItr itr itrRequest fromJust - - let reqVer = reqVersion req - - if reqVer /= HttpVersion 1 0 && - reqVer /= HttpVersion 1 1 then - - do setStatus HttpVersionNotSupported - writeItr itr itrWillClose True - - else - -- HTTP/1.0 では Keep-Alive できない - do when (reqVer == HttpVersion 1 0) - $ writeItr itr itrWillClose True - - -- ホスト部の補完 - completeAuthority req - - case reqMethod req of - GET -> return () - HEAD -> writeItr itr itrWillDiscardBody True - POST -> writeItr itr itrRequestHasBody True - PUT -> writeItr itr itrRequestHasBody True - DELETE -> return () - _ -> setStatus NotImplemented - - preprocessHeader req +import Control.Applicative +import Control.Monad +import Control.Monad.State.Strict +import Data.Ascii (Ascii) +import qualified Data.Ascii as A +import qualified Data.ByteString.Char8 as C8 +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.HttpVersion +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Response +import Network.Socket +import Network.URI +import Prelude.Unicode + +data AugmentedRequest + = AugmentedRequest { + arRequest ∷ !Request + , arInitialStatus ∷ !StatusCode + , arWillChunkBody ∷ !Bool + , arWillDiscardBody ∷ !Bool + , arWillClose ∷ !Bool + , arExpectedContinue ∷ !Bool + , arReqBodyLength ∷ !(Maybe RequestBodyLength) + } + +data RequestBodyLength + = Fixed !Int + | Chunked + deriving (Eq, Show) + +preprocess ∷ Text → PortNumber → Request → AugmentedRequest +preprocess localHost localPort req@(Request {..}) + = execState go initialAR where - setStatus :: StatusCode -> STM () - setStatus !status - = updateItr itr itrResponse - $! \ res -> res { - resStatus = status - } - - completeAuthority :: Request -> STM () - completeAuthority !req - = when (uriAuthority (reqURI req) == Nothing) - $ if reqVersion req == HttpVersion 1 0 then - -- HTTP/1.0 なので Config から補完 - do let conf = itrConfig itr - host = cnfServerHost conf - port = itrLocalPort itr - portStr - = case port of - 80 -> "" - n -> ':' : show n - updateAuthority host (C8.pack portStr) - else - case getHeader (C8.pack "Host") req of - Just str -> let (host, portStr) = parseHost str - in updateAuthority host portStr - Nothing -> setStatus BadRequest - - - parseHost :: Strict.ByteString -> (Strict.ByteString, Strict.ByteString) - parseHost = C8.break (== ':') - - - updateAuthority :: Strict.ByteString -> Strict.ByteString -> STM () - updateAuthority !host !portStr - = updateItr itr itrRequest - $! \ (Just req) -> Just req { - reqURI = let uri = reqURI req - in uri { - uriAuthority = Just URIAuth { - uriUserInfo = "" - , uriRegName = C8.unpack host - , uriPort = C8.unpack portStr - } - } - } - - - preprocessHeader :: Request -> STM () - preprocessHeader !req - = do case getHeader (C8.pack "Expect") req of - Nothing -> return () - Just value -> if value `noCaseEq` C8.pack "100-continue" then - writeItr itr itrExpectedContinue True - else - setStatus ExpectationFailed - - case getHeader (C8.pack "Transfer-Encoding") req of - Nothing -> return () - Just value -> unless (value `noCaseEq` C8.pack "identity") - $ if value `noCaseEq` C8.pack "chunked" then - writeItr itr itrRequestIsChunked True - else - setStatus NotImplemented - - case getHeader (C8.pack "Content-Length") req of - Nothing -> return () - Just value -> if C8.all isDigit value then - do let Just (len, _) = C8.readInt value - writeItr itr itrReqChunkLength $ Just len - writeItr itr itrReqChunkRemaining $ Just len - else - setStatus BadRequest - - case getHeader (C8.pack "Connection") req of - Nothing -> return () - Just value -> when (value `noCaseEq` C8.pack "close") - $ writeItr itr itrWillClose True + initialAR ∷ AugmentedRequest + initialAR = AugmentedRequest { + arRequest = req + , arInitialStatus = Ok + , arWillChunkBody = False + , arWillDiscardBody = False + , arWillClose = False + , arExpectedContinue = False + , arReqBodyLength = Nothing + } + go ∷ State AugmentedRequest () + go = do examineHttpVersion + examineMethod + examineAuthority localHost localPort + examineHeaders + examineBodyLength + +setRequest ∷ Request → State AugmentedRequest () +setRequest req + = modify $ \ar → ar { arRequest = req } + +setStatus ∷ StatusCode → State AugmentedRequest () +setStatus sc + = modify $ \ar → ar { arInitialStatus = sc } + +setWillClose ∷ Bool → State AugmentedRequest () +setWillClose b + = modify $ \ar → ar { arWillClose = b } + +setBodyLength ∷ Maybe RequestBodyLength → State AugmentedRequest () +setBodyLength len + = modify $ \ar → ar { arReqBodyLength = len } + +examineHttpVersion ∷ State AugmentedRequest () +examineHttpVersion + = do req ← gets arRequest + case reqVersion req of + -- HTTP/1.0 requests can't Keep-Alive. + HttpVersion 1 0 + → setWillClose True + HttpVersion 1 1 + → modify $ \ar → ar { arWillChunkBody = True } + _ → do setStatus HttpVersionNotSupported + setWillClose True + +examineMethod ∷ State AugmentedRequest () +examineMethod + = do req ← gets arRequest + case reqMethod req of + GET → return () + HEAD → modify $ \ar → ar { arWillDiscardBody = True } + POST → return () + PUT → return () + DELETE → return () + _ → setStatus NotImplemented + +examineAuthority ∷ Text → PortNumber → State AugmentedRequest () +examineAuthority localHost localPort + = do req ← gets arRequest + when (isNothing $ uriAuthority $ reqURI req) $ + case reqVersion req of + -- HTTP/1.0 requests have no Host header so complete it + -- with the configuration value. + HttpVersion 1 0 + → let host = localHost + port = case localPort of + 80 → "" + n → A.unsafeFromString $ ':':show n + req' = updateAuthority host port req + in + setRequest req' + -- HTTP/1.1 requests MUST have a Host header. + HttpVersion 1 1 + → case getHeader "Host" req of + Just str + → let (host, port) + = parseHost str + req' = updateAuthority host port req + in + setRequest req' + Nothing + → setStatus BadRequest + -- Should never reach here... + ver → fail ("internal error: unknown version: " ⧺ show ver) + +parseHost ∷ Ascii → (Text, Ascii) +parseHost hp + = let (h, p) = C8.break (≡ ':') $ A.toByteString hp + -- FIXME: should decode punycode here. + hText = T.decodeUtf8 h + pAscii = A.unsafeFromByteString p + in + (hText, pAscii) + +updateAuthority ∷ Text → Ascii → Request → Request +updateAuthority host port req + = let uri = reqURI req + uri' = uri { + uriAuthority = Just URIAuth { + uriUserInfo = "" + , uriRegName = T.unpack host + , uriPort = A.toString port + } + } + in + req { reqURI = uri' } + +examineHeaders ∷ State AugmentedRequest () +examineHeaders + = do req ← gets arRequest + + case getCIHeader "Expect" req of + Nothing → return () + Just v + | v ≡ "100-continue" + → modify $ \ar → ar { arExpectedContinue = True } + | otherwise + → setStatus ExpectationFailed + + case getCIHeader "Transfer-Encoding" req of + Nothing → return () + Just v + | v ≡ "identity" + → return () + | v ≡ "chunked" + → setBodyLength $ Just Chunked + | otherwise + → setStatus NotImplemented + + case A.toByteString <$> getHeader "Content-Length" req of + Nothing → return () + Just value → case C8.readInt value of + Just (len, garbage) + | C8.null garbage ∧ len ≥ 0 + → setBodyLength $ Just $ Fixed len + _ → setStatus BadRequest + + case getCIHeader "Connection" req of + Just v + | v ≡ "close" + → setWillClose True + _ → return () + +examineBodyLength ∷ State AugmentedRequest () +examineBodyLength + = do req ← gets arRequest + len ← gets arReqBodyLength + if reqMustHaveBody req then + -- POST and PUT requests must have an entity body. + when (isNothing len) + $ setStatus LengthRequired + else + -- Other requests must NOT have an entity body. + when (isJust len) + $ setStatus BadRequest diff --git a/Network/HTTP/Lucu/RFC2231.hs b/Network/HTTP/Lucu/RFC2231.hs new file mode 100644 index 0000000..1046c5d --- /dev/null +++ b/Network/HTTP/Lucu/RFC2231.hs @@ -0,0 +1,321 @@ +{-# LANGUAGE + DoAndIfThenElse + , OverloadedStrings + , RecordWildCards + , UnicodeSyntax + #-} +-- |Provide functionalities to encode/decode MIME parameter values in +-- character sets other than US-ASCII. See: +-- +-- +-- You usually don't have to use this module directly. +module Network.HTTP.Lucu.RFC2231 + ( printMIMEParams + , mimeParams + ) + where +import Control.Applicative +import Control.Monad hiding (mapM) +import Control.Monad.Unicode +import Data.Ascii (Ascii, CIAscii, AsciiBuilder) +import qualified Data.Ascii as A +import Data.Attoparsec.Char8 as P +import Data.Bits +import qualified Data.ByteString.Char8 as BS +import Data.Char +import Data.Foldable +import Data.Map (Map) +import qualified Data.Map as M +import Data.Monoid.Unicode +import Data.Sequence (Seq, ViewL(..)) +import qualified Data.Sequence as S +import Data.Sequence.Unicode hiding ((∅)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding +import Data.Text.Encoding.Error +import Data.Traversable +import Data.Word +import Network.HTTP.Lucu.Parser.Http +import Network.HTTP.Lucu.Utils +import Prelude hiding (concat, mapM, takeWhile) +import Prelude.Unicode + +-- |Convert MIME parameter values to an 'AsciiBuilder'. +printMIMEParams ∷ Map CIAscii Text → AsciiBuilder +{-# INLINEABLE printMIMEParams #-} +printMIMEParams m = M.foldlWithKey f (∅) m + -- THINKME: Use foldlWithKey' for newer Data.Map + where + f ∷ AsciiBuilder → CIAscii → Text → AsciiBuilder + {-# INLINE f #-} + f ab k v = ab ⊕ A.toAsciiBuilder "; " ⊕ printPair k v + +printPair ∷ CIAscii → Text → AsciiBuilder +{-# INLINEABLE printPair #-} +printPair name value + | T.any (> '\xFF') value + = printPairInUTF8 name value + | otherwise + = printPairInAscii name (A.unsafeFromByteString $ encodeUtf8 value) + +printPairInUTF8 ∷ CIAscii → Text → AsciiBuilder +{-# INLINEABLE printPairInUTF8 #-} +printPairInUTF8 name value + = A.toAsciiBuilder (A.fromCIAscii name) ⊕ + A.toAsciiBuilder "*=utf-8''" ⊕ + escapeUnsafeChars (encodeUtf8 value) (∅) + +printPairInAscii ∷ CIAscii → Ascii → AsciiBuilder +{-# INLINEABLE printPairInAscii #-} +printPairInAscii name value + = A.toAsciiBuilder (A.fromCIAscii name) ⊕ + A.toAsciiBuilder "=" ⊕ + if BS.any ((¬) ∘ isToken) (A.toByteString value) then + quoteStr value + else + A.toAsciiBuilder value + +escapeUnsafeChars ∷ BS.ByteString → AsciiBuilder → AsciiBuilder +{-# INLINEABLE escapeUnsafeChars #-} +escapeUnsafeChars bs b + = case BS.uncons bs of + Nothing → b + Just (c, bs') + | isToken c → escapeUnsafeChars bs' $ + b ⊕ A.toAsciiBuilder (A.unsafeFromString [c]) + | otherwise → escapeUnsafeChars bs' $ + b ⊕ toHex (fromIntegral $ fromEnum c) + +toHex ∷ Word8 → AsciiBuilder +{-# INLINEABLE toHex #-} +toHex o = A.toAsciiBuilder "%" ⊕ + A.toAsciiBuilder (A.unsafeFromString [ toHex' (o `shiftR` 8) + , toHex' (o .&. 0x0F) ]) + where + toHex' ∷ Word8 → Char + {-# INLINEABLE toHex' #-} + toHex' h + | h ≤ 0x09 = toEnum $ fromIntegral + $ fromEnum '0' + fromIntegral h + | otherwise = toEnum $ fromIntegral + $ fromEnum 'A' + fromIntegral (h - 0x0A) + +data ExtendedParam + = InitialEncodedParam { + epName ∷ !CIAscii + , epCharset ∷ !CIAscii + , epPayload ∷ !BS.ByteString + } + | ContinuedEncodedParam { + epName ∷ !CIAscii + , epSection ∷ !Integer + , epPayload ∷ !BS.ByteString + } + | AsciiParam { + epName ∷ !CIAscii + , epSection ∷ !Integer + , apPayload ∷ !Ascii + } + +section ∷ ExtendedParam → Integer +{-# INLINE section #-} +section (InitialEncodedParam {..}) = 0 +section ep = epSection ep + +-- |'Parser' for MIME parameter values. +mimeParams ∷ Parser (Map CIAscii Text) +{-# INLINEABLE mimeParams #-} +mimeParams = decodeParams =≪ P.many (try paramP) + +paramP ∷ Parser ExtendedParam +paramP = do skipMany lws + void $ char ';' + skipMany lws + epm ← nameP + void $ char '=' + case epm of + (name, 0, True) + → do (charset, payload) ← initialEncodedValue + return $ InitialEncodedParam name charset payload + (name, sect, True) + → do payload ← encodedPayload + return $ ContinuedEncodedParam name sect payload + (name, sect, False) + → do payload ← token <|> quotedStr + return $ AsciiParam name sect payload + +nameP ∷ Parser (CIAscii, Integer, Bool) +nameP = do name ← (A.toCIAscii ∘ A.unsafeFromByteString) <$> + takeWhile1 (\c → isToken c ∧ c ≢ '*') + sect ← option 0 $ try (char '*' *> decimal ) + isEncoded ← option False $ try (char '*' *> pure True) + return (name, sect, isEncoded) + +initialEncodedValue ∷ Parser (CIAscii, BS.ByteString) +initialEncodedValue + = do charset ← metadata + void $ char '\'' + void $ metadata -- Ignore the language tag + void $ char '\'' + payload ← encodedPayload + if charset ≡ "" then + -- NOTE: I'm not sure this is the right thing, but RFC + -- 2231 doesn't tell us what we should do when the + -- charset is omitted. + return ("US-ASCII", payload) + -- FIXME: Rethink about this behaviour. + else + return (charset, payload) + where + metadata ∷ Parser CIAscii + metadata = (A.toCIAscii ∘ A.unsafeFromByteString) <$> + takeWhile (\c → c ≢ '\'' ∧ isToken c) + +encodedPayload ∷ Parser BS.ByteString +{-# INLINE encodedPayload #-} +encodedPayload = BS.concat <$> P.many (hexChar <|> rawChars) + +hexChar ∷ Parser BS.ByteString +{-# INLINEABLE hexChar #-} +hexChar = do void $ char '%' + h ← satisfy isHexChar + l ← satisfy isHexChar + return $ BS.singleton $ hexToChar h l + +isHexChar ∷ Char → Bool +isHexChar = inClass "0-9a-fA-F" + +hexToChar ∷ Char → Char → Char +{-# INLINE hexToChar #-} +hexToChar h l + = chr $ (hexToInt h `shiftL` 8) .&. hexToInt l + +hexToInt ∷ Char → Int +{-# INLINEABLE hexToInt #-} +hexToInt c + | c ≤ '9' = ord c - ord '0' + | c ≤ 'F' = ord c - ord 'A' + 10 + | otherwise = ord c - ord 'a' + 10 + +rawChars ∷ Parser BS.ByteString +{-# INLINE rawChars #-} +rawChars = takeWhile1 (\c → isToken c ∧ c ≢ '%') + +decodeParams ∷ Monad m ⇒ [ExtendedParam] → m (Map CIAscii Text) +{-# INLINE decodeParams #-} +decodeParams = (mapM decodeSections =≪) ∘ sortBySection + +sortBySection ∷ Monad m + ⇒ [ExtendedParam] + → m (Map CIAscii (Map Integer ExtendedParam)) +sortBySection = flip go (∅) + where + go ∷ Monad m + ⇒ [ExtendedParam] + → Map CIAscii (Map Integer ExtendedParam) + → m (Map CIAscii (Map Integer ExtendedParam)) + go [] m = return m + go (x:xs) m + = case M.lookup (epName x) m of + Nothing + → let s = M.singleton (section x) x + m' = M.insert (epName x) s m + in + go xs m' + Just s + → case M.lookup (section x) s of + Nothing + → let s' = M.insert (section x) x s + m' = M.insert (epName x) s' m + in + go xs m' + Just _ + → fail (concat [ "Duplicate section " + , show $ section x + , " for parameter '" + , A.toString $ A.fromCIAscii $ epName x + , "'" + ]) + +decodeSections ∷ Monad m ⇒ Map Integer ExtendedParam → m Text +decodeSections = (decodeSeq =≪) ∘ flip (flip toSeq 0) (∅) + where + toSeq ∷ Monad m + ⇒ Map Integer ExtendedParam + → Integer + → Seq ExtendedParam + → m (Seq ExtendedParam) + toSeq m expectedSect sects + = case M.minViewWithKey m of + Nothing + → return sects + Just ((sect, p), m') + | sect ≡ expectedSect + → toSeq m' (expectedSect + 1) (sects ⊳ p) + | otherwise + → fail (concat [ "Missing section " + , show $ section p + , " for parameter '" + , A.toString $ A.fromCIAscii $ epName p + , "'" + ]) + + decodeSeq ∷ Monad m ⇒ Seq ExtendedParam → m Text + decodeSeq sects + = case S.viewl sects of + EmptyL + → fail "decodeSeq: internal error: empty seq" + InitialEncodedParam {..} :< xs + → do d ← getDecoder epCharset + t ← decodeStr d epPayload + decodeSeq' (Just d) xs $ S.singleton t + ContinuedEncodedParam {..} :< _ + → fail "decodeSeq: internal error: CEP at section 0" + AsciiParam {..} :< xs + → let t = A.toText apPayload + in + decodeSeq' Nothing xs $ S.singleton t + + decodeSeq' ∷ Monad m + ⇒ Maybe Decoder + → Seq ExtendedParam + → Seq Text + → m Text + decodeSeq' decoder sects chunks + = case S.viewl sects of + EmptyL + → return $ T.concat $ toList chunks + InitialEncodedParam {..} :< _ + → fail "decodeSeq': internal error: IEP at section > 0" + ContinuedEncodedParam {..} :< xs + → case decoder of + Just d + → do t ← decodeStr d epPayload + decodeSeq' decoder xs $ chunks ⊳ t + Nothing + → fail (concat [ "Section " + , show epSection + , " for parameter '" + , A.toString $ A.fromCIAscii epName + , "' is encoded but its first section is not" + ]) + AsciiParam {..} :< xs + → let t = A.toText apPayload + in + decodeSeq' decoder xs $ chunks ⊳ t + +type Decoder = BS.ByteString → Either UnicodeException Text + +decodeStr ∷ Monad m ⇒ Decoder → BS.ByteString → m Text +decodeStr decoder str + = case decoder str of + Right t → return t + Left e → fail $ show e + +getDecoder ∷ Monad m ⇒ CIAscii → m Decoder +getDecoder charset + | charset ≡ "UTF-8" = return decodeUtf8' + | charset ≡ "US-ASCII" = return decodeUtf8' + | otherwise = fail $ "No decoders found for charset: " + ⧺ A.toString (A.fromCIAscii charset) diff --git a/Network/HTTP/Lucu/Request.hs b/Network/HTTP/Lucu/Request.hs index 712a610..58286db 100644 --- a/Network/HTTP/Lucu/Request.hs +++ b/Network/HTTP/Lucu/Request.hs @@ -1,23 +1,31 @@ -{-# OPTIONS_HADDOCK prune #-} - +{-# LANGUAGE + OverloadedStrings + , UnicodeSyntax + , ViewPatterns + #-} -- |Definition of things related on HTTP request. -- -- In general you don't have to use this module directly. module Network.HTTP.Lucu.Request ( Method(..) , Request(..) - , requestP + , reqMustHaveBody + , request ) where - -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.HttpVersion -import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Parser.Http -import Network.URI +import Control.Applicative +import Control.Monad.Unicode +import Data.Ascii (Ascii) +import Data.Attoparsec.Char8 +import qualified Data.ByteString.Char8 as C8 +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.HttpVersion +import Network.HTTP.Lucu.Parser.Http +import Network.URI +import Prelude.Unicode -- |This is the definition of HTTP request methods, which shouldn't --- require any description. +-- require any descriptions. data Method = OPTIONS | GET | HEAD @@ -26,64 +34,70 @@ data Method = OPTIONS | DELETE | TRACE | CONNECT - | ExtensionMethod !String + | ExtensionMethod !Ascii deriving (Eq, Show) --- |This is the definition of HTTP reqest. +-- |This is the definition of an HTTP reqest. data Request = Request { - reqMethod :: !Method - , reqURI :: !URI - , reqVersion :: !HttpVersion - , reqHeaders :: !Headers + reqMethod ∷ !Method + , reqURI ∷ !URI + , reqVersion ∷ !HttpVersion + , reqHeaders ∷ !Headers } - deriving (Show, Eq) + deriving (Eq, Show) instance HasHeaders Request where + {-# INLINE getHeaders #-} getHeaders = reqHeaders + {-# INLINE setHeaders #-} setHeaders req hdr = req { reqHeaders = hdr } +-- |Returns 'True' iff the 'Request' must have an entity body. +reqMustHaveBody ∷ Request → Bool +{-# INLINEABLE reqMustHaveBody #-} +reqMustHaveBody (reqMethod → m) + | m ≡ POST = True + | m ≡ PUT = True + | otherwise = False -requestP :: Parser Request -requestP = do _ <- many crlf - (method, uri, version) <- requestLineP - headers <- headersP - return Request { - reqMethod = method - , reqURI = uri - , reqVersion = version - , reqHeaders = headers - } - - -requestLineP :: Parser (Method, URI, HttpVersion) -requestLineP = do method <- methodP - _ <- sp - uri <- uriP - _ <- sp - ver <- httpVersionP - _ <- crlf - return (method, uri, ver) - +-- |'Parser' for a 'Request'. +request ∷ Parser Request +request = do skipMany crlf + (meth, u, ver) ← requestLine + hdrs ← headers + return Request { + reqMethod = meth + , reqURI = u + , reqVersion = ver + , reqHeaders = hdrs + } -methodP :: Parser Method -methodP = ( let methods = [ ("OPTIONS", OPTIONS) - , ("GET" , GET ) - , ("HEAD" , HEAD ) - , ("POST" , POST ) - , ("PUT" , PUT ) - , ("DELETE" , DELETE ) - , ("TRACE" , TRACE ) - , ("CONNECT", CONNECT) - ] - in choice $ map (\ (str, mth) - -> string str >> return mth) methods ) - <|> - fmap ExtensionMethod token +requestLine ∷ Parser (Method, URI, HttpVersion) +requestLine = do meth ← method + sp + u ← uri + sp + ver ← httpVersion + crlf + return (meth, u, ver) +method ∷ Parser Method +method = choice + [ string "OPTIONS" ≫ return OPTIONS + , string "GET" ≫ return GET + , string "HEAD" ≫ return HEAD + , string "POST" ≫ return POST + , string "PUT" ≫ return PUT + , string "DELETE" ≫ return DELETE + , string "TRACE" ≫ return TRACE + , string "CONNECT" ≫ return CONNECT + , ExtensionMethod <$> token + ] -uriP :: Parser URI -uriP = do str <- many1 $ satisfy (\ c -> not (isCtl c || c == ' ')) - case parseURIReference str of - Nothing -> failP - Just uri -> return uri \ No newline at end of file +uri ∷ Parser URI +uri = do bs ← takeWhile1 (\c → (¬) (isCtl c ∨ c ≡ '\x20')) + let str = C8.unpack bs + case parseURIReference str of + Nothing → fail ("Unparsable URI: " ⧺ str) + Just u → return u diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index d3b8daa..7f48c9b 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -1,300 +1,377 @@ {-# LANGUAGE - BangPatterns - , UnboxedTuples + DoAndIfThenElse + , OverloadedStrings + , RecordWildCards + , ScopedTypeVariables , UnicodeSyntax #-} module Network.HTTP.Lucu.RequestReader ( requestReader ) where - -import Control.Concurrent.STM -import Control.Exception -import Control.Monad -import qualified Data.ByteString.Lazy.Char8 as B -import Data.ByteString.Lazy.Char8 (ByteString) -import Data.Maybe +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception hiding (block) +import Control.Monad +import qualified Data.Attoparsec.Lazy as LP +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Lazy as Lazy +import Data.List +import Data.Maybe +import Data.Monoid.Unicode import qualified Data.Sequence as S -import Data.Sequence ((<|)) -import GHC.Conc (unsafeIOToSTM) -import Network.Socket -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.Chunk -import Network.HTTP.Lucu.DefaultPage -import Network.HTTP.Lucu.HandleLike -import Network.HTTP.Lucu.Interaction -import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Postprocess -import Network.HTTP.Lucu.Preprocess -import Network.HTTP.Lucu.Request -import Network.HTTP.Lucu.Response -import Network.HTTP.Lucu.Resource.Tree -import Prelude hiding (catch) -import System.IO (stderr) +import Data.Sequence.Unicode hiding ((∅)) +import qualified Data.Text as T +import Network.HTTP.Lucu.Abortion +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.Chunk +import Network.HTTP.Lucu.HandleLike +import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.Preprocess +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Response +import Network.HTTP.Lucu.Resource.Internal +import Network.HTTP.Lucu.Resource.Tree +import Network.Socket +import Prelude.Unicode +import System.IO (hPutStrLn, stderr) + +data Context h + = Context { + cConfig ∷ !Config + , cResTree ∷ !ResTree + , cFallbacks ∷ ![FallbackHandler] + , cHandle ∷ !h + , cPort ∷ !PortNumber + , cAddr ∷ !SockAddr + , cQueue ∷ !InteractionQueue + } + +data ChunkReceivingState + = Initial + | InChunk !Int -- ^Number of remaining octets in the current + -- chunk. It's always positive. -requestReader :: HandleLike h => Config -> ResTree -> [FallbackHandler] -> h -> PortNumber -> SockAddr -> InteractionQueue -> IO () -requestReader !cnf !tree !fbs !h !port !addr !tQueue - = do input <- hGetLBS h - acceptRequest input +requestReader ∷ HandleLike h + ⇒ Config + → ResTree + → [FallbackHandler] + → h + → PortNumber + → SockAddr + → InteractionQueue + → IO () +requestReader cnf tree fbs h port addr tQueue + = do input ← hGetLBS h + acceptRequest (Context cnf tree fbs h port addr tQueue) input `catches` - [ Handler (( \ _ -> return () ) :: IOException -> IO ()) - , Handler ( \ ThreadKilled -> return () ) - , Handler ( \ BlockedIndefinitelyOnSTM -> hPutStrLn stderr "requestReader: blocked indefinitely" ) - , Handler (( \ e -> hPutStrLn stderr (show e) ) :: SomeException -> IO ()) + [ Handler handleAsyncE + , Handler handleBIOS + , Handler handleOthers ] where - acceptRequest :: ByteString -> IO () - acceptRequest input - -- キューに最大パイプライン深度以上のリクエストが溜まってゐる - -- 時は、それが限度以下になるまで待つ。 - = {-# SCC "acceptRequest" #-} - do atomically $ do queue <- readTVar tQueue - when (S.length queue >= cnfMaxPipelineDepth cnf) - retry + handleAsyncE ∷ AsyncException → IO () + handleAsyncE ThreadKilled = return () + handleAsyncE e = dump e + + handleBIOS ∷ BlockedIndefinitelyOnSTM → IO () + handleBIOS = dump + + handleOthers ∷ SomeException → IO () + handleOthers = dump - -- リクエストを讀む。パースできない場合は直ちに 400 Bad - -- Request 應答を設定し、それを出力してから切斷するやう - -- に ResponseWriter に通知する。 - case parse requestP input of - (# Success req , input' #) -> acceptParsableRequest req input' - (# IllegalInput, _ #) -> acceptNonparsableRequest BadRequest - (# ReachedEOF , _ #) -> acceptNonparsableRequest BadRequest + dump ∷ Exception e ⇒ e → IO () + dump e + = do hPutStrLn stderr "requestReader caught an exception:" + hPutStrLn stderr (show $ toException e) - acceptNonparsableRequest :: StatusCode -> IO () - acceptNonparsableRequest status - = {-# SCC "acceptNonparsableRequest" #-} - do itr <- newInteraction cnf port addr Nothing Nothing - atomically $ do updateItr itr itrResponse - $ \ res -> res { - resStatus = status - } - writeItr itr itrWillClose True - writeItr itr itrState Done - writeDefaultPage itr - postprocess itr - enqueue itr +acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO () +acceptRequest ctx@(Context {..}) input + -- キューに最大パイプライン深度以上のリクエストが溜まってゐる時は、 + -- それが限度以下になるまで待つ。 + = do atomically $ + do queue ← readTVar cQueue + when (S.length queue ≥ cnfMaxPipelineDepth cConfig) $ + retry + -- リクエストを讀む。パースできない場合は直ちに 400 Bad + -- Request 應答を設定し、それを出力してから切斷するやうに + -- ResponseWriter に通知する。 + case LP.parse request input of + LP.Done input' req → acceptParsableRequest ctx req input' + LP.Fail _ _ _ → acceptNonparsableRequest ctx - acceptParsableRequest :: Request -> ByteString -> IO () - acceptParsableRequest req input - = {-# SCC "acceptParsableRequest" #-} - do cert <- hGetPeerCert h - itr <- newInteraction cnf port addr cert (Just req) - action - <- atomically $ - do preprocess itr - isErr <- readItr itr itrResponse (isError . resStatus) - if isErr then - acceptSemanticallyInvalidRequest itr input - else - do rsrcM <- unsafeIOToSTM $ findResource tree fbs $ reqURI req - case rsrcM of - Nothing -- Resource が無かった - -> acceptRequestForNonexistentResource itr input +acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → IO () +acceptNonparsableRequest ctx@(Context {..}) + = do syi ← mkSyntacticallyInvalidInteraction cConfig + enqueue ctx syi - Just (rsrcPath, rsrcDef) -- あった - -> acceptRequestForExistentResource itr input rsrcPath rsrcDef - action +acceptParsableRequest ∷ HandleLike h + ⇒ Context h + → Request + → Lazy.ByteString + → IO () +acceptParsableRequest ctx@(Context {..}) req input + = do let ar = preprocess (cnfServerHost cConfig) cPort req + if isError $ arInitialStatus ar then + acceptSemanticallyInvalidRequest ctx ar input + else + do rsrc ← findResource cResTree cFallbacks $ reqURI $ arRequest ar + case rsrc of + Nothing + → do let ar' = ar { arInitialStatus = NotFound } + acceptSemanticallyInvalidRequest ctx ar' input + Just (path, def) + → acceptRequestForResource ctx ar input path def - acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ()) - acceptSemanticallyInvalidRequest itr input - = {-# SCC "acceptSemanticallyInvalidRequest" #-} - do writeItr itr itrState Done - writeDefaultPage itr - postprocess itr - enqueue itr - return $ acceptRequest input +acceptSemanticallyInvalidRequest ∷ HandleLike h + ⇒ Context h + → AugmentedRequest + → Lazy.ByteString + → IO () +acceptSemanticallyInvalidRequest ctx@(Context {..}) ar input + = do sei ← mkSemanticallyInvalidInteraction cConfig ar + enqueue ctx sei + acceptRequest ctx input - acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ()) - acceptRequestForNonexistentResource itr input - = {-# SCC "acceptRequestForNonexistentResource" #-} - do updateItr itr itrResponse - $ \res -> res { - resStatus = NotFound - } - writeItr itr itrState Done - writeDefaultPage itr - postprocess itr - enqueue itr - return $ acceptRequest input +acceptRequestForResource ∷ HandleLike h + ⇒ Context h + → AugmentedRequest + → Lazy.ByteString + → [Strict.ByteString] + → ResourceDef + → IO () +acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef + = do cert ← hGetPeerCert cHandle + ni ← mkNormalInteraction cConfig cAddr cert ar rsrcPath + tid ← spawnResource rsrcDef ni + enqueue ctx ni + if reqMustHaveBody arRequest then + waitForReceiveBodyReq ctx ni tid input + else + acceptRequest ctx input - acceptRequestForExistentResource :: Interaction -> ByteString -> [String] -> ResourceDef -> STM (IO ()) - acceptRequestForExistentResource oldItr input rsrcPath rsrcDef - = {-# SCC "acceptRequestForExistentResource" #-} - do let itr = oldItr { itrResourcePath = Just rsrcPath } - requestHasBody <- readItr itr itrRequestHasBody id - enqueue itr - return $ do _ <- runResource rsrcDef itr - if requestHasBody then - observeRequest itr input - else - acceptRequest input +waitForReceiveBodyReq ∷ HandleLike h + ⇒ Context h + → NormalInteraction + → ThreadId + → Lazy.ByteString + → IO () +waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input + = case fromJust niReqBodyLength of + Chunked + → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input + Fixed len + → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni input len - observeRequest :: Interaction -> ByteString -> IO () - observeRequest itr input - = {-# SCC "observeRequest" #-} - do isChunked <- atomically $ readItr itr itrRequestIsChunked id - if isChunked then - observeChunkedRequest itr input - else - observeNonChunkedRequest itr input +-- Toooooo long name for a function... +waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h + ⇒ Context h + → NormalInteraction + → ThreadId + → Lazy.ByteString + → IO () +waitForReceiveChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) rsrcTid input + = join $ + atomically $ + do req ← takeTMVar niReceiveBodyReq + case req of + ReceiveBody wanted + → do putTMVar niSendContinue niExpectedContinue + return $ readCurrentChunk ctx ni rsrcTid wanted input Initial + WasteAll + → do putTMVar niSendContinue False + return $ wasteAllChunks ctx rsrcTid input Initial - observeChunkedRequest :: Interaction -> ByteString -> IO () - observeChunkedRequest itr input - = {-# SCC "observeChunkedRequest" #-} - do action - <- atomically $ - do isOver <- readItr itr itrReqChunkIsOver id - if isOver then - return $ acceptRequest input - else - do wantedM <- readItr itr itrReqBodyWanted id - if wantedM == Nothing then - do wasteAll <- readItr itr itrReqBodyWasteAll id - if wasteAll then - -- 破棄要求が來た - do remainingM <- readItr itr itrReqChunkRemaining id - if fmap (> 0) remainingM == Just True then - -- 現在のチャンクをまだ - -- 讀み終へてゐない - do let (_, input') = B.splitAt (fromIntegral - $ fromJust remainingM) input - (# footerR, input'' #) = parse chunkFooterP input' +waitForReceiveChunkedBodyReq ∷ HandleLike h + ⇒ Context h + → NormalInteraction + → ThreadId + → Lazy.ByteString + → ChunkReceivingState + → IO () +waitForReceiveChunkedBodyReq ctx ni@(NI {..}) rsrcTid input st + = do req ← atomically $ takeTMVar niReceiveBodyReq + case req of + ReceiveBody wanted + → readCurrentChunk ctx ni rsrcTid wanted input st + WasteAll + → wasteAllChunks ctx rsrcTid input st - if footerR == Success () then - -- チャンクフッタを正常に讀めた - do writeItr itr itrReqChunkRemaining $ Just 0 - - return $ observeChunkedRequest itr input'' - else - return $ chunkWasMalformed itr - else - -- 次のチャンクを讀み始める - seekNextChunk itr input - else - -- 要求がまだ來ない - retry - else - -- 受信要求が來た - do remainingM <- readItr itr itrReqChunkRemaining id - if fmap (> 0) remainingM == Just True then - -- 現在のチャンクをまだ讀み - -- 終へてゐない - do let wanted = fromJust wantedM - remaining = fromJust remainingM - bytesToRead = fromIntegral $ min wanted remaining - (chunk, input') = B.splitAt bytesToRead input - actualReadBytes = fromIntegral $ B.length chunk - newWanted = case wanted - actualReadBytes of - 0 -> Nothing - n -> Just n - newRemaining = Just $ remaining - actualReadBytes - updateStates - = do writeItr itr itrReqChunkRemaining newRemaining - writeItr itr itrReqBodyWanted newWanted - updateItr itr itrReceivedBody $ flip B.append chunk +wasteAllChunks ∷ HandleLike h + ⇒ Context h + → ThreadId + → Lazy.ByteString + → ChunkReceivingState + → IO () +wasteAllChunks ctx rsrcTid = go + where + go ∷ Lazy.ByteString → ChunkReceivingState → IO () + go input Initial + = case LP.parse chunkHeader input of + LP.Done input' chunkLen + | chunkLen ≡ 0 → gotFinalChunk input' + | otherwise → gotChunk input' chunkLen + LP.Fail _ eCtx e + → chunkWasMalformed rsrcTid eCtx e + "wasteAllChunks: chunkHeader" + go input (InChunk chunkLen) + = gotChunk input chunkLen + + gotChunk ∷ Lazy.ByteString → Int → IO () + gotChunk input chunkLen + = let input' = Lazy.drop (fromIntegral chunkLen) input + in + case LP.parse chunkFooter input' of + LP.Done input'' _ + → go input'' Initial + LP.Fail _ eCtx e + → chunkWasMalformed rsrcTid eCtx e + "wasteAllChunks: chunkFooter" - if newRemaining == Just 0 then - -- チャンクフッタを讀む - case parse chunkFooterP input' of - (# Success _, input'' #) - -> do updateStates - return $ observeChunkedRequest itr input'' - (# _, _ #) - -> return $ chunkWasMalformed itr - else - -- まだチャンクの終はりに達してゐない - do updateStates - return $ observeChunkedRequest itr input' - else - -- 次のチャンクを讀み始める - seekNextChunk itr input - action + gotFinalChunk ∷ Lazy.ByteString → IO () + gotFinalChunk input + = case LP.parse chunkTrailer input of + LP.Done input' _ + → acceptRequest ctx input' + LP.Fail _ eCtx e + → chunkWasMalformed rsrcTid eCtx e + "wasteAllChunks: chunkTrailer" - seekNextChunk :: Interaction -> ByteString -> STM (IO ()) - seekNextChunk itr input - = {-# SCC "seekNextChunk" #-} - case parse chunkHeaderP input of - -- 最終チャンク (中身が空) - (# Success 0, input' #) - -> case parse chunkTrailerP input' of - (# Success _, input'' #) - -> do writeItr itr itrReqChunkLength $ Nothing - writeItr itr itrReqChunkRemaining $ Nothing - writeItr itr itrReqChunkIsOver True - - return $ acceptRequest input'' - (# _, _ #) - -> return $ chunkWasMalformed itr - -- 最終でないチャンク - (# Success len, input' #) - -> do writeItr itr itrReqChunkLength $ Just len - writeItr itr itrReqChunkRemaining $ Just len - - return $ observeChunkedRequest itr input' - -- チャンクヘッダがをかしい - (# _, _ #) - -> return $ chunkWasMalformed itr +readCurrentChunk ∷ HandleLike h + ⇒ Context h + → NormalInteraction + → ThreadId + → Int + → Lazy.ByteString + → ChunkReceivingState + → IO () +readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go + where + go ∷ Lazy.ByteString → ChunkReceivingState → IO () + go input Initial + = case LP.parse chunkHeader input of + LP.Done input' chunkLen + | chunkLen ≡ 0 + → gotFinalChunk input' + | otherwise + → gotChunk input' chunkLen + LP.Fail _ eCtx e + → chunkWasMalformed rsrcTid eCtx e + "readCurrentChunk: chunkHeader" + go input (InChunk chunkLen) + = gotChunk input chunkLen - chunkWasMalformed :: Interaction -> IO () - chunkWasMalformed itr - = {-# SCC "chunkWasMalformed" #-} - atomically $ do updateItr itr itrResponse - $ \ res -> res { - resStatus = BadRequest - } - writeItr itr itrWillClose True - writeItr itr itrState Done - writeDefaultPage itr - postprocess itr + gotChunk ∷ Lazy.ByteString → Int → IO () + gotChunk input chunkLen + = do let bytesToRead = min wanted chunkLen + (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input + block' = Strict.concat $ Lazy.toChunks block + actualReadBytes = Strict.length block' + chunkLen' = chunkLen - actualReadBytes + atomically $ putTMVar niReceivedBody block' + if chunkLen' ≡ 0 then + case LP.parse chunkFooter input' of + LP.Done input'' _ + → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial + LP.Fail _ eCtx e + → chunkWasMalformed rsrcTid eCtx e + "readCurrentChunk: chunkFooter" + else + waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen' - observeNonChunkedRequest :: Interaction -> ByteString -> IO () - observeNonChunkedRequest itr input - = {-# SCC "observeNonChunkedRequest" #-} - do action - <- atomically $ - do wantedM <- readItr itr itrReqBodyWanted id - if wantedM == Nothing then - do wasteAll <- readItr itr itrReqBodyWasteAll id - if wasteAll then - -- 破棄要求が來た - do remainingM <- readItr itr itrReqChunkRemaining id - - let (_, input') = if remainingM == Nothing then - (B.takeWhile (\ _ -> True) input, B.empty) - else - B.splitAt (fromIntegral $ fromJust remainingM) input + gotFinalChunk ∷ Lazy.ByteString → IO () + gotFinalChunk input + = do atomically $ putTMVar niReceivedBody (∅) + case LP.parse chunkTrailer input of + LP.Done input' _ + → acceptRequest ctx input' + LP.Fail _ eCtx e + → chunkWasMalformed rsrcTid eCtx e + "readCurrentChunk: chunkTrailer" - writeItr itr itrReqChunkRemaining $ Just 0 - writeItr itr itrReqChunkIsOver True +chunkWasMalformed ∷ ThreadId → [String] → String → String → IO () +chunkWasMalformed tid eCtx e msg + = let abo = mkAbortion BadRequest [("Connection", "close")] + $ Just + $ "chunkWasMalformed: " + ⊕ T.pack msg + ⊕ ": " + ⊕ T.pack (intercalate ", " eCtx) + ⊕ ": " + ⊕ T.pack e + in + throwTo tid abo - return $ acceptRequest input' - else - -- 要求がまだ来ない - retry - else - -- 受信要求が來た - do remainingM <- readItr itr itrReqChunkRemaining id +waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h + ⇒ Context h + → NormalInteraction + → Lazy.ByteString + → Int + → IO () +waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) input bodyLen + = join $ + atomically $ + do req ← takeTMVar niReceiveBodyReq + case req of + ReceiveBody wanted + → do putTMVar niSendContinue niExpectedContinue + return $ readNonChunkedRequestBody ctx ni input bodyLen wanted + WasteAll + → do putTMVar niSendContinue False + return $ wasteNonChunkedRequestBody ctx input bodyLen - let wanted = fromJust wantedM - bytesToRead = fromIntegral $ maybe wanted (min wanted) remainingM - (chunk, input') = B.splitAt bytesToRead input - newRemaining = fmap - (\ x -> x - (fromIntegral $ B.length chunk)) - remainingM - isOver = B.length chunk < bytesToRead || newRemaining == Just 0 +waitForReceiveNonChunkedBodyReq ∷ HandleLike h + ⇒ Context h + → NormalInteraction + → Lazy.ByteString + → Int + → IO () +waitForReceiveNonChunkedBodyReq ctx ni@(NI {..}) input bodyLen + = do req ← atomically $ takeTMVar niReceiveBodyReq + case req of + ReceiveBody wanted + → readNonChunkedRequestBody ctx ni input bodyLen wanted + WasteAll + → wasteNonChunkedRequestBody ctx input bodyLen - writeItr itr itrReqChunkRemaining newRemaining - writeItr itr itrReqChunkIsOver isOver - writeItr itr itrReqBodyWanted Nothing - writeItr itr itrReceivedBody chunk +wasteNonChunkedRequestBody ∷ HandleLike h + ⇒ Context h + → Lazy.ByteString + → Int + → IO () +wasteNonChunkedRequestBody ctx input bodyLen + = do let input' = Lazy.drop (fromIntegral bodyLen) input + acceptRequest ctx input' + +readNonChunkedRequestBody ∷ HandleLike h + ⇒ Context h + → NormalInteraction + → Lazy.ByteString + → Int + → Int + → IO () +readNonChunkedRequestBody ctx ni@(NI {..}) input bodyLen wanted + | bodyLen ≡ 0 = gotEndOfRequest + | otherwise = gotBody + where + gotBody ∷ IO () + gotBody + = do let bytesToRead = min wanted bodyLen + (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input + block' = Strict.concat $ Lazy.toChunks block + actualReadBytes = Strict.length block' + bodyLen' = bodyLen - actualReadBytes + atomically $ putTMVar niReceivedBody block' + waitForReceiveNonChunkedBodyReq ctx ni input' bodyLen' - if isOver then - return $ acceptRequest input' - else - return $ observeNonChunkedRequest itr input' - action + gotEndOfRequest ∷ IO () + gotEndOfRequest + = do atomically $ putTMVar niReceivedBody (∅) + acceptRequest ctx input - enqueue :: Interaction -> STM () - enqueue itr = {-# SCC "enqueue" #-} - do queue <- readTVar tQueue - writeTVar tQueue (itr <| queue) \ No newline at end of file +enqueue ∷ (HandleLike h, Interaction i) ⇒ Context h → i → IO () +{-# INLINEABLE enqueue #-} +enqueue (Context {..}) itr + = atomically $ + do queue ← readTVar cQueue + writeTVar cQueue (toInteraction itr ⊲ queue) diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index fa08fa5..aee29d5 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,13 +1,14 @@ {-# LANGUAGE - UnboxedTuples + BangPatterns + , GeneralizedNewtypeDeriving + , DoAndIfThenElse + , OverloadedStrings + , 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' --- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is --- also a state machine. +-- |This is the Resource Monad; monadic actions to define a behavior +-- of resource. The 'Resource' Monad is a kind of 'IO' Monad thus it +-- implements 'MonadIO' class, and it is a state machine as well. -- -- Request Processing Flow: -- @@ -16,9 +17,9 @@ -- 2. If the URI of it matches to any resource, the corresponding -- 'Resource' Monad starts running on a newly spawned thread. -- --- 3. The 'Resource' Monad looks at the request header, find (or not --- find) an entity, receive the request body (if any), decide the --- response header, and decide the response body. This process +-- 3. The 'Resource' Monad looks at request headers, find (or not +-- find) an entity, receive the request body (if any), send +-- response headers, and then send a response body. This process -- will be discussed later. -- -- 4. The 'Resource' Monad and its thread stops running. The client @@ -28,29 +29,33 @@ -- /Examining Request/ and the final state is /Done/. -- -- [/Examining Request/] In this state, a 'Resource' looks at the --- request header and thinks about an entity for it. If there is a --- suitable entity, the 'Resource' tells the system an entity tag --- and its last modification time ('foundEntity'). If it found no --- entity, it tells the system so ('foundNoEntity'). In case it is --- impossible to decide the existence of entity, which is a typical --- case for POST requests, 'Resource' does nothing in this state. +-- request header fields and thinks about the corresponding entity +-- for it. If there is a suitable entity, the 'Resource' tells the +-- system an entity tag and its last modification time +-- ('foundEntity'). If it found no entity, it tells the system so +-- ('foundNoEntity'). In case it is impossible to decide the +-- existence of entity, which is a typical case for POST requests, +-- 'Resource' does nothing in this state. -- --- [/Getting Body/] A 'Resource' asks the system to receive a --- request body from client. Before actually reading from the +-- [/Receiving Body/] A 'Resource' asks the system to receive a +-- request body from the client. Before actually reading from the -- socket, the system sends \"100 Continue\" to the client if need -- be. When a 'Resource' transits to the next state without --- receiving all or part of request body, the system still reads it --- and just throws it away. +-- receiving all or part of a request body, the system automatically +-- discards it. -- --- [/Deciding Header/] A 'Resource' makes a decision of status code --- and response header. When it transits to the next state, the --- system checks the validness of response header and then write --- them to the socket. +-- [/Deciding Header/] A 'Resource' makes a decision of response +-- status code and header fields. When it transits to the next +-- state, the system validates and completes the header fields and +-- then sends them to the client. -- --- [/Deciding Body/] In this state, a 'Resource' asks the system to +-- [/Sending Body/] In this state, a 'Resource' asks the system to -- write some response body to the socket. When it transits to the -- next state without writing any response body, the system --- completes it depending on the status code. +-- automatically completes it depending on the status code. (To be +-- exact, such completion only occurs when the 'Resource' transits +-- to this state without even declaring the \"Content-Type\" header +-- field. See: 'setContentType') -- -- [/Done/] Everything is over. A 'Resource' can do nothing for the -- HTTP interaction anymore. @@ -61,20 +66,17 @@ -- the entire request before starting 'Resource', nor we don't want to -- postpone writing the entire response till the end of 'Resource' -- computation. - module Network.HTTP.Lucu.Resource ( -- * Types Resource + , ResourceDef(..) + , emptyResource , FormData(..) - , runRes -- private - - -- * Actions - -- ** Getting request header - - -- |These actions can be computed regardless of the current state, - -- and they don't change the state. + -- * Getting request header + -- |These functions can be called regardless of the current state, + -- and they don't change the state of 'Resource'. , getConfig , getRemoteAddr , getRemoteAddr' @@ -94,899 +96,597 @@ module Network.HTTP.Lucu.Resource , getContentType , getAuthorization - -- ** Finding an entity - - -- |These actions can be computed only in the /Examining Request/ - -- state. After the computation, the 'Resource' transits to - -- /Getting Body/ state. + -- * Finding an entity + -- |These functions can be called only in the /Examining Request/ + -- state. They make the 'Resource' transit to the /Receiving Body/ + -- state. , foundEntity , foundETag , foundTimeStamp , foundNoEntity - - -- ** Getting a request body - - -- |Computation of these actions changes the state to /Getting - -- Body/. - , input - , inputChunk - , inputLBS - , inputChunkLBS - , inputForm - , defaultLimit - - -- ** Setting response headers - - -- |Computation of these actions changes the state to /Deciding - -- Header/. + , foundNoEntity' + + -- * Receiving a request body + -- |These functions make the 'Resource' transit to the /Receiving + -- Body/ state. + , getChunk + , getChunks + , getForm + + -- * Declaring response status and header fields + -- |These functions can be called at any time before transiting to + -- the /Sending Body/ state, but they themselves never causes any + -- state transitions. , setStatus - , setHeader , redirect , setContentType - , setLocation , setContentEncoding , setWWWAuthenticate - -- ** Writing a response body + -- ** Less frequently used functions + , setLocation + , setHeader + , deleteHeader - -- |Computation of these actions changes the state to /Deciding - -- Body/. - , output - , outputChunk - , outputLBS - , outputChunkLBS + -- * Sending a response body - , driftTo + -- |These functions make the 'Resource' transit to the + -- /Sending Body/ state. + , putChunk + , putChunks + , putBuilder ) where - -import Control.Concurrent.STM -import Control.Monad.Reader -import qualified Data.ByteString as Strict (ByteString) -import qualified Data.ByteString.Lazy as Lazy (ByteString) -import qualified Data.ByteString.Char8 as C8 hiding (ByteString) -import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString) -import Data.Char -import Data.List -import Data.Maybe -import Data.Time +import Blaze.ByteString.Builder (Builder) +import qualified Blaze.ByteString.Builder as BB +import qualified Blaze.ByteString.Builder.Internal as BB +import Control.Applicative +import Control.Arrow +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Unicode +import Data.Ascii (Ascii, CIAscii) +import qualified Data.Ascii as A +import qualified Data.Attoparsec.Char8 as P +import Data.ByteString (ByteString) +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Lazy as Lazy +import Data.List +import qualified Data.Map as M +import Data.Maybe +import Data.Monoid +import Data.Monoid.Unicode +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time import qualified Data.Time.HTTP as HTTP -import Network.HTTP.Lucu.Abortion -import Network.HTTP.Lucu.Authorization -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.ContentCoding -import Network.HTTP.Lucu.DefaultPage -import Network.HTTP.Lucu.ETag +import Network.HTTP.Lucu.Abortion +import Network.HTTP.Lucu.Authentication +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.ContentCoding +import Network.HTTP.Lucu.ETag import qualified Network.HTTP.Lucu.Headers as H -import Network.HTTP.Lucu.HttpVersion -import Network.HTTP.Lucu.Interaction -import Network.HTTP.Lucu.MultipartForm -import Network.HTTP.Lucu.Parser -import Network.HTTP.Lucu.Postprocess -import Network.HTTP.Lucu.Request -import Network.HTTP.Lucu.Response -import Network.HTTP.Lucu.MIMEType -import Network.HTTP.Lucu.Utils -import Network.Socket hiding (accept) -import Network.URI hiding (path) -import OpenSSL.X509 - --- |The 'Resource' monad. This monad implements --- 'Control.Monad.Trans.MonadIO' so it can do any 'Prelude.IO' --- actions. -newtype Resource a = Resource { unRes :: ReaderT Interaction IO a } - -instance Functor Resource where - fmap f c = Resource (fmap f (unRes c)) - -instance Monad Resource where - c >>= f = Resource (unRes c >>= unRes . f) - return = Resource . return - fail = Resource . fail - -instance MonadIO Resource where - liftIO = Resource . liftIO - - -runRes :: Resource a -> Interaction -> IO a -runRes r itr - = runReaderT (unRes r) itr - - -getInteraction :: Resource Interaction -getInteraction = Resource ask - - --- |Get the 'Network.HTTP.Lucu.Config.Config' value which is used for --- the httpd. -getConfig :: Resource Config -getConfig = do itr <- getInteraction - return $! itrConfig itr - - --- |Get the 'Network.Socket.SockAddr' of the remote host. If you want --- a string representation instead of 'Network.Socket.SockAddr', use --- 'getRemoteAddr''. -getRemoteAddr :: Resource SockAddr -getRemoteAddr = do itr <- getInteraction - return $! itrRemoteAddr itr - +import Network.HTTP.Lucu.HttpVersion +import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.MultipartForm +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Resource.Internal +import Network.HTTP.Lucu.Response +import Network.HTTP.Lucu.MIMEType +import Network.HTTP.Lucu.Utils +import Network.Socket hiding (accept) +import Network.URI hiding (path) +import Prelude.Unicode -- |Get the string representation of the address of remote host. If --- you want a 'Network.Socket.SockAddr' instead of 'Prelude.String', --- use 'getRemoteAddr'. -getRemoteAddr' :: Resource String -getRemoteAddr' = do addr <- getRemoteAddr - (Just str, _) <- liftIO $! getNameInfo [NI_NUMERICHOST] True False addr - return str +-- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'. +getRemoteAddr' ∷ Resource HostName +getRemoteAddr' = liftIO ∘ toNM =≪ getRemoteAddr + where + toNM ∷ SockAddr → IO HostName + toNM = (fromJust ∘ fst <$>) ∘ getNameInfo [NI_NUMERICHOST] True False -- |Resolve an address to the remote host. -getRemoteHost :: Resource String -getRemoteHost = do addr <- getRemoteAddr - (Just str, _) <- liftIO $! getNameInfo [] True False addr - return str +getRemoteHost ∷ Resource (Maybe HostName) +getRemoteHost = liftIO ∘ getHN =≪ getRemoteAddr + where + getHN ∷ SockAddr → IO (Maybe HostName) + getHN = (fst <$>) ∘ getNameInfo [] True False --- | Return the X.509 certificate of the client, or 'Nothing' if: --- --- * This request didn't came through an SSL stream. --- --- * The client didn't send us its certificate. --- --- * The 'OpenSSL.Session.VerificationMode' of --- 'OpenSSL.Session.SSLContext' in --- 'Network.HTTP.Lucu.Config.SSLConfig' has not been set to --- 'OpenSSL.Session.VerifyPeer'. -getRemoteCertificate :: Resource (Maybe X509) -getRemoteCertificate = do itr <- getInteraction - return $! itrRemoteCert itr - --- |Get the 'Network.HTTP.Lucu.Request.Request' value which represents --- the request header. In general you don't have to use this action. -getRequest :: Resource Request -getRequest = do itr <- getInteraction - req <- liftIO $! atomically $! readItr itr itrRequest fromJust - return req - --- |Get the 'Network.HTTP.Lucu.Request.Method' value of the request. -getMethod :: Resource Method -getMethod = do req <- getRequest - return $! reqMethod req +-- |Get the 'Method' value of the request. +getMethod ∷ Resource Method +getMethod = reqMethod <$> getRequest -- |Get the URI of the request. -getRequestURI :: Resource URI -getRequestURI = do req <- getRequest - return $! reqURI req +getRequestURI ∷ Resource URI +getRequestURI = reqURI <$> getRequest -- |Get the HTTP version of the request. -getRequestVersion :: Resource HttpVersion -getRequestVersion = do req <- getRequest - return $! reqVersion req - --- |Get the path of this 'Resource' (to be exact, --- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the --- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this --- action is the exact path in the tree even if the --- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy. --- --- Example: +getRequestVersion ∷ Resource HttpVersion +getRequestVersion = reqVersion <$> getRequest + +-- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns +-- @[]@ if the corresponding +-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See: +-- 'getResourcePath' -- --- > main = let tree = mkResTree [ (["foo"], resFoo) ] --- > in runHttpd defaultConfig tree --- > --- > resFoo = ResourceDef { --- > resIsGreedy = True --- > , resGet = Just $ do requestURI <- getRequestURI --- > resourcePath <- getResourcePath --- > pathInfo <- getPathInfo --- > -- uriPath requestURI == "/foo/bar/baz" --- > -- resourcePath == ["foo"] --- > -- pathInfo == ["bar", "baz"] --- > ... --- > , ... --- > } -getResourcePath :: Resource [String] -getResourcePath = do itr <- getInteraction - return $! fromJust $! itrResourcePath itr - - --- |This is an analogy of CGI PATH_INFO. The result is --- URI-unescaped. It is always @[]@ if the --- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See --- 'getResourcePath'. -getPathInfo :: Resource [String] -getPathInfo = do rsrcPath <- getResourcePath - uri <- getRequestURI - let reqPathStr = uriPath uri - reqPath = [unEscapeString x | x <- splitBy (== '/') reqPathStr, x /= ""] - -- rsrcPath と reqPath の共通する先頭部分を reqPath か - -- ら全部取り除くと、それは PATH_INFO のやうなものにな - -- る。rsrcPath は全部一致してゐるに決まってゐる（でな - -- ければこの Resource が撰ばれた筈が無い）ので、 - -- rsrcPath の長さの分だけ削除すれば良い。 - return $! drop (length rsrcPath) reqPath +-- Note that the returned path components are URI-decoded. +getPathInfo ∷ Resource [Strict.ByteString] +getPathInfo = do rsrcPath ← getResourcePath + reqPath ← splitPathInfo <$> getRequestURI + return $ drop (length rsrcPath) reqPath -- |Assume the query part of request URI as --- application\/x-www-form-urlencoded, and parse it to pairs of --- @(name, formData)@. This action doesn't parse the request body. See --- 'inputForm'. -getQueryForm :: Resource [(String, FormData)] -getQueryForm = liftM parse' getRequestURI +-- application\/x-www-form-urlencoded, and parse it into pairs of +-- @(name, formData)@. This function doesn't read the request +-- body. +getQueryForm ∷ Resource [(Strict.ByteString, FormData)] +getQueryForm = parse' <$> getRequestURI where - parse' = map toPairWithFormData . - parseWWWFormURLEncoded . - snd . - splitAt 1 . + parse' = map toPairWithFormData ∘ + parseWWWFormURLEncoded ∘ + fromJust ∘ + A.fromChars ∘ + drop 1 ∘ uriQuery -toPairWithFormData :: (String, String) -> (String, FormData) +toPairWithFormData ∷ (ByteString, ByteString) → (Strict.ByteString, FormData) toPairWithFormData (name, value) = let fd = FormData { fdFileName = Nothing - , fdContent = L8.pack value + , fdMIMEType = parseMIMEType "text/plain" + , fdContent = Lazy.fromChunks [value] } in (name, fd) --- |Get a value of given request header. Comparison of header name is --- case-insensitive. Note that this action is not intended to be used --- so frequently: there should be actions like 'getContentType' for --- every common headers. -getHeader :: Strict.ByteString -> Resource (Maybe Strict.ByteString) -getHeader name = name `seq` - do req <- getRequest - return $! H.getHeader name req - --- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on --- header \"Accept\". -getAccept :: Resource [MIMEType] -getAccept = do acceptM <- getHeader (C8.pack "Accept") - case acceptM of - Nothing - -> return [] - Just accept - -> case parse mimeTypeListP (L8.fromChunks [accept]) of - (# Success xs, _ #) -> return xs - (# _ , _ #) -> abort BadRequest [] - (Just $ "Unparsable Accept: " ++ C8.unpack accept) - --- |Get a list of @(contentCoding, qvalue)@ enumerated on header --- \"Accept-Encoding\". The list is sorted in descending order by --- qvalue. -getAcceptEncoding :: Resource [(String, Maybe Double)] +-- |@'getHeader' name@ returns the value of the request header field +-- @name@. Comparison of header name is case-insensitive. Note that +-- this function is not intended to be used so frequently: there +-- should be functions like 'getContentType' for every common headers. +getHeader ∷ CIAscii → Resource (Maybe Ascii) +getHeader name + = H.getHeader name <$> getRequest + +-- |Return the list of 'MIMEType' enumerated on the value of request +-- header \"Accept\", or @[]@ if absent. +getAccept ∷ Resource [MIMEType] +getAccept + = do acceptM ← getHeader "Accept" + case acceptM of + Nothing + → return [] + Just accept + → case P.parseOnly p (A.toByteString accept) of + Right xs → return xs + Left _ → abort $ mkAbortion' BadRequest + $ "Unparsable Accept: " ⊕ A.toText accept + where + p = do xs ← mimeTypeList + P.endOfInput + return xs + +-- |Return the list of @(contentCoding, qvalue)@ enumerated on the +-- value of request header \"Accept-Encoding\". The list is sorted in +-- descending order by qvalue. +getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)] getAcceptEncoding - = do accEncM <- getHeader (C8.pack "Accept-Encoding") + = do accEncM ← getHeader "Accept-Encoding" case accEncM of Nothing -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い -- ので安全の爲 identity が指定された事にする。HTTP/1.1 -- の場合は何でも受け入れて良い事になってゐるので "*" が -- 指定された事にする。 - -> do ver <- getRequestVersion - case ver of - HttpVersion 1 0 -> return [("identity", Nothing)] - HttpVersion 1 1 -> return [("*" , Nothing)] - _ -> undefined - Just value - -> if C8.null value then + → do ver ← getRequestVersion + case ver of + HttpVersion 1 0 → return [("identity", Nothing)] + HttpVersion 1 1 → return [("*" , Nothing)] + _ → abort $ mkAbortion' InternalServerError + "getAcceptEncoding: unknown HTTP version" + Just ae + → if ae ≡ "" then -- identity のみが許される。 return [("identity", Nothing)] - else - case parse acceptEncodingListP (L8.fromChunks [value]) of - (# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x - (# _ , _ #) -> abort BadRequest [] - (Just $ "Unparsable Accept-Encoding: " ++ C8.unpack value) - --- |Check whether a given content-coding is acceptable. -isEncodingAcceptable :: String -> Resource Bool -isEncodingAcceptable coding - = do accList <- getAcceptEncoding - return (flip any accList $ \ (c, q) -> - (c == "*" || C8.pack c `H.noCaseEq` C8.pack coding) && q /= Just 0) - - --- |Get the header \"Content-Type\" as --- 'Network.HTTP.Lucu.MIMEType.MIMEType'. -getContentType :: Resource (Maybe MIMEType) + else + case P.parseOnly p (A.toByteString ae) of + Right xs → return $ map toTuple $ reverse $ sort xs + Left _ → abort $ mkAbortion' BadRequest + $ "Unparsable Accept-Encoding: " ⊕ A.toText ae + where + p = do xs ← acceptEncodingList + P.endOfInput + return xs + + toTuple (AcceptEncoding {..}) + = (aeEncoding, aeQValue) + +-- |Return 'True' iff a given content-coding is acceptable by the +-- client. +isEncodingAcceptable ∷ CIAscii → Resource Bool +isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding + where + doesMatch ∷ (CIAscii, Maybe Double) → Bool + doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0 + +-- |Return the value of request header \"Content-Type\" as 'MIMEType'. +getContentType ∷ Resource (Maybe MIMEType) getContentType - = do cTypeM <- getHeader (C8.pack "Content-Type") + = do cTypeM ← getHeader "Content-Type" case cTypeM of Nothing - -> return Nothing + → return Nothing Just cType - -> case parse mimeTypeP (L8.fromChunks [cType]) of - (# Success t, _ #) -> return $ Just t - (# _ , _ #) -> abort BadRequest [] - (Just $ "Unparsable Content-Type: " ++ C8.unpack cType) - + → case P.parseOnly p (A.toByteString cType) of + Right t → return $ Just t + Left _ → abort $ mkAbortion' BadRequest + $ "Unparsable Content-Type: " ⊕ A.toText cType + where + p = do t ← mimeType + P.endOfInput + return t --- |Get the header \"Authorization\" as --- 'Network.HTTP.Lucu.Authorization.AuthCredential'. -getAuthorization :: Resource (Maybe AuthCredential) +-- |Return the value of request header \"Authorization\" as +-- 'AuthCredential'. +getAuthorization ∷ Resource (Maybe AuthCredential) getAuthorization - = do authM <- getHeader (C8.pack "Authorization") + = do authM ← getHeader "Authorization" case authM of Nothing - -> return Nothing + → return Nothing Just auth - -> case parse authCredentialP (L8.fromChunks [auth]) of - (# Success a, _ #) -> return $ Just a - (# _ , _ #) -> return Nothing - - -{- ExaminingRequest 時に使用するアクション群 -} + → case P.parseOnly p (A.toByteString auth) of + Right ac → return $ Just ac + Left _ → return Nothing + where + p = do ac ← authCredential + P.endOfInput + return ac -- |Tell the system that the 'Resource' found an entity for the -- request URI. If this is a GET or HEAD request, a found entity means -- a datum to be replied. If this is a PUT or DELETE request, it means --- a datum which was stored for the URI until now. It is an error to --- compute 'foundEntity' if this is a POST request. +-- a datum which was stored for the URI until now. For POST requests +-- it raises an error. -- --- Computation of 'foundEntity' performs \"If-Match\" test or --- \"If-None-Match\" test if possible. When those tests fail, the --- computation of 'Resource' immediately aborts with status \"412 --- Precondition Failed\" or \"304 Not Modified\" depending on the --- situation. +-- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test +-- whenever possible, and if those tests fail, it immediately aborts +-- with status \"412 Precondition Failed\" or \"304 Not Modified\" +-- depending on the situation. -- --- If this is a GET or HEAD request, 'foundEntity' automatically puts --- \"ETag\" and \"Last-Modified\" headers into the response. -foundEntity :: ETag -> UTCTime -> Resource () +-- If the request method is either GET or HEAD, 'foundEntity' +-- automatically puts \"ETag\" and \"Last-Modified\" headers into the +-- response. +foundEntity ∷ ETag → UTCTime → Resource () foundEntity tag timeStamp - = tag `seq` timeStamp `seq` - do driftTo ExaminingRequest - - method <- getMethod - when (method == GET || method == HEAD) - $ setHeader' (C8.pack "Last-Modified") (C8.pack $ HTTP.format timeStamp) - when (method == POST) - $ abort InternalServerError [] - (Just "Illegal computation of foundEntity for a POST request.") + = do driftTo ExaminingRequest + + method ← getMethod + when (method ≡ GET ∨ method ≡ HEAD) + $ setHeader "Last-Modified" (HTTP.toAscii timeStamp) + when (method ≡ POST) + $ abort + $ mkAbortion' InternalServerError + "foundEntity: this is a POST request." foundETag tag - driftTo GettingBody + driftTo ReceivingBody -- |Tell the system that the 'Resource' found an entity for the -- request URI. The only difference from 'foundEntity' is that --- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into +-- 'foundETag' doesn't (nor can't) put \"Last-Modified\" header into -- the response. -- --- This action is not preferred. You should use 'foundEntity' whenever --- possible. -foundETag :: ETag -> Resource () +-- Using this function is discouraged. You should use 'foundEntity' +-- whenever possible. +foundETag ∷ ETag → Resource () foundETag tag - = tag `seq` - do driftTo ExaminingRequest + = do driftTo ExaminingRequest - method <- getMethod - when (method == GET || method == HEAD) - $ setHeader' (C8.pack "ETag") (C8.pack $ show tag) - when (method == POST) - $ abort InternalServerError [] - (Just "Illegal computation of foundETag for POST request.") + method ← getMethod + when (method ≡ GET ∨ method ≡ HEAD) + $ setHeader "ETag" + $ A.fromAsciiBuilder + $ printETag tag + when (method ≡ POST) + $ abort + $ mkAbortion' InternalServerError + "Illegal computation of foundETag for POST request." -- If-Match があればそれを見る。 - ifMatch <- getHeader (C8.pack "If-Match") + ifMatch ← getHeader "If-Match" case ifMatch of - Nothing -> return () - Just value -> if value == C8.pack "*" then - return () - else - case parse eTagListP (L8.fromChunks [value]) of - (# Success tags, _ #) - -- tags の中に一致するものが無ければ - -- PreconditionFailed で終了。 - -> when (not $ any (== tag) tags) - $ abort PreconditionFailed [] - $! Just ("The entity tag doesn't match: " ++ C8.unpack value) - (# _, _ #) - -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ C8.unpack value) - - let statusForNoneMatch = if method == GET || method == HEAD then - NotModified - else - PreconditionFailed + Nothing → return () + Just value → if value ≡ "*" then + return () + else + case P.parseOnly p (A.toByteString value) of + Right tags + -- tags の中に一致するものが無ければ + -- PreconditionFailed で終了。 + → when ((¬) (any (≡ tag) tags)) + $ abort + $ mkAbortion' PreconditionFailed + $ "The entity tag doesn't match: " ⊕ A.toText value + Left _ + → abort $ mkAbortion' BadRequest + $ "Unparsable If-Match: " ⊕ A.toText value + + let statusForNoneMatch + = if method ≡ GET ∨ method ≡ HEAD then + NotModified + else + PreconditionFailed -- If-None-Match があればそれを見る。 - ifNoneMatch <- getHeader (C8.pack "If-None-Match") + ifNoneMatch ← getHeader "If-None-Match" case ifNoneMatch of - Nothing -> return () - Just value -> if value == C8.pack "*" then - abort statusForNoneMatch [] $! Just ("The entity tag matches: *") - else - case parse eTagListP (L8.fromChunks [value]) of - (# Success tags, _ #) - -> when (any (== tag) tags) - $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ C8.unpack value) - (# _, _ #) - -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ C8.unpack value) - - driftTo GettingBody + Nothing → return () + Just value → if value ≡ "*" then + abort $ mkAbortion' statusForNoneMatch + $ "The entity tag matches: *" + else + case P.parseOnly p (A.toByteString value) of + Right tags + → when (any (≡ tag) tags) + $ abort + $ mkAbortion' statusForNoneMatch + $ "The entity tag matches: " ⊕ A.toText value + Left _ + → abort $ mkAbortion' BadRequest + $ "Unparsable If-None-Match: " ⊕ A.toText value + + driftTo ReceivingBody + where + p = do xs ← eTagList + P.endOfInput + return xs -- |Tell the system that the 'Resource' found an entity for the -- request URI. The only difference from 'foundEntity' is that -- 'foundTimeStamp' performs \"If-Modified-Since\" test or -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or --- \"If-None-Match\" test. Be aware that any tests based on last +-- \"If-None-Match\" test. Be aware that any tests based on a last -- modification time are unsafe because it is possible to mess up such -- tests by modifying the entity twice in a second. -- --- This action is not preferred. You should use 'foundEntity' whenever --- possible. -foundTimeStamp :: UTCTime -> Resource () +-- Using this function is discouraged. You should use 'foundEntity' +-- whenever possible. +foundTimeStamp ∷ UTCTime → Resource () foundTimeStamp timeStamp - = timeStamp `seq` - do driftTo ExaminingRequest - - method <- getMethod - when (method == GET || method == HEAD) - $ setHeader' (C8.pack "Last-Modified") (C8.pack $ HTTP.format timeStamp) - when (method == POST) - $ abort InternalServerError [] - (Just "Illegal computation of foundTimeStamp for POST request.") - - let statusForIfModSince = if method == GET || method == HEAD then - NotModified - else - PreconditionFailed + = do driftTo ExaminingRequest + + method ← getMethod + when (method ≡ GET ∨ method ≡ HEAD) + $ setHeader "Last-Modified" (HTTP.toAscii timeStamp) + when (method ≡ POST) + $ abort + $ mkAbortion' InternalServerError + "Illegal computation of foundTimeStamp for POST request." + + let statusForIfModSince + = if method ≡ GET ∨ method ≡ HEAD then + NotModified + else + PreconditionFailed -- If-Modified-Since があればそれを見る。 - ifModSince <- getHeader (C8.pack "If-Modified-Since") + ifModSince ← getHeader "If-Modified-Since" case ifModSince of - Just str -> case HTTP.parse (C8.unpack str) of - Just lastTime - -> when (timeStamp <= lastTime) - $ abort statusForIfModSince [] - $! Just ("The entity has not been modified since " ++ C8.unpack str) - Nothing - -> return () -- 不正な時刻は無視 - Nothing -> return () + Just str → case HTTP.fromAscii str of + Right lastTime + → when (timeStamp ≤ lastTime) + $ abort + $ mkAbortion' statusForIfModSince + $ "The entity has not been modified since " ⊕ A.toText str + Left _ + → return () -- 不正な時刻は無視 + Nothing → return () -- If-Unmodified-Since があればそれを見る。 - ifUnmodSince <- getHeader (C8.pack "If-Unmodified-Since") + ifUnmodSince ← getHeader "If-Unmodified-Since" case ifUnmodSince of - Just str -> case HTTP.parse (C8.unpack str) of - Just lastTime - -> when (timeStamp > lastTime) - $ abort PreconditionFailed [] - $! Just ("The entity has not been modified since " ++ C8.unpack str) - Nothing - -> return () -- 不正な時刻は無視 - Nothing -> return () - - driftTo GettingBody - --- | Computation of @'foundNoEntity' mStr@ tells the system that the --- 'Resource' found no entity for the request URI. @mStr@ is an --- optional error message to be replied to the client. + Just str → case HTTP.fromAscii str of + Right lastTime + → when (timeStamp > lastTime) + $ abort + $ mkAbortion' PreconditionFailed + $ "The entity has not been modified since " ⊕ A.toText str + Left _ + → return () -- 不正な時刻は無視 + Nothing → return () + + driftTo ReceivingBody + +-- |@'foundNoEntity' mStr@ tells the system that the 'Resource' found +-- no entity for the request URI. @mStr@ is an optional error message +-- to be replied to the client. -- --- If this is a PUT request, 'foundNoEntity' performs \"If-Match\" --- test and aborts with status \"412 Precondition Failed\" when it --- failed. If this is a GET, HEAD, POST or DELETE request, +-- If the request method is PUT, 'foundNoEntity' performs \"If-Match\" +-- test and when that fails it aborts with status \"412 Precondition +-- Failed\". If the request method is GET, HEAD, POST or DELETE, -- 'foundNoEntity' always aborts with status \"404 Not Found\". -foundNoEntity :: Maybe String -> Resource () +foundNoEntity ∷ Maybe Text → Resource () foundNoEntity msgM - = msgM `seq` - do driftTo ExaminingRequest + = do driftTo ExaminingRequest - method <- getMethod - when (method /= PUT) - $ abort NotFound [] msgM + method ← getMethod + when (method ≢ PUT) + $ abort + $ mkAbortion NotFound [] msgM -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな -- If-Match: 條件も滿たさない。 - ifMatch <- getHeader (C8.pack "If-Match") - when (ifMatch /= Nothing) - $ abort PreconditionFailed [] msgM - - driftTo GettingBody - - -{- GettingBody 時に使用するアクション群 -} - --- | Computation of @'input' limit@ attempts to read the request body --- up to @limit@ bytes, and then make the 'Resource' transit to --- /Deciding Header/ state. When the actual size of body is larger --- than @limit@ bytes, computation of 'Resource' immediately aborts --- with status \"413 Request Entity Too Large\". When the request has --- no body, 'input' returns an empty string. + ifMatch ← getHeader "If-Match" + when (ifMatch ≢ Nothing) + $ abort + $ mkAbortion PreconditionFailed [] msgM + + driftTo ReceivingBody + +-- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@. +foundNoEntity' ∷ Resource () +{-# INLINE foundNoEntity' #-} +foundNoEntity' = foundNoEntity Nothing + +-- |@'getChunks' limit@ attemts to read the entire request body up to +-- @limit@ bytes, and then make the 'Resource' transit to the +-- /Deciding Header/ state. When the actual size of the body is larger +-- than @limit@ bytes, 'getChunks' immediately aborts with status +-- \"413 Request Entity Too Large\". When the request has no body, it +-- returns an empty string. -- --- @limit@ may be less than or equal to zero. In this case, the --- default limitation value --- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See --- 'defaultLimit'. +-- When the @limit@ is 'Nothing', 'getChunks' uses the default +-- limitation value ('cnfMaxEntityLength') instead. -- --- Note that 'inputLBS' is more efficient than 'input' so you should --- use it whenever possible. -input :: Int -> Resource String -input limit = limit `seq` - inputLBS limit >>= return . L8.unpack - - --- | This is mostly the same as 'input' but is more --- efficient. 'inputLBS' returns a 'Data.ByteString.Lazy.ByteString' --- but it's not really lazy: reading from the socket just happens at --- the computation of 'inputLBS', not at the evaluation of the --- 'Data.ByteString.Lazy.ByteString'. The same goes for --- 'inputChunkLBS'. -inputLBS :: Int -> Resource Lazy.ByteString -inputLBS limit - = limit `seq` - do driftTo GettingBody - itr <- getInteraction - hasBody <- liftIO $! atomically $! readItr itr itrRequestHasBody id - chunk <- if hasBody then - askForInput itr - else - do driftTo DecidingHeader - return L8.empty - return chunk +-- 'getChunks' returns a lazy 'Lazy.ByteString' but it's not really +-- lazy: reading from the socket just happens at the computation of +-- 'getChunks', not at the evaluation of the 'Lazy.ByteString'. +getChunks ∷ Maybe Int → Resource Lazy.ByteString +getChunks (Just n) + | n < 0 = fail ("getChunks: limit must not be negative: " ⧺ show n) + | n ≡ 0 = return (∅) + | otherwise = getChunks' n +getChunks Nothing + = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength + +getChunks' ∷ Int → Resource Lazy.ByteString +getChunks' limit = go limit (∅) where - askForInput :: Interaction -> Resource Lazy.ByteString - askForInput itr - = itr `seq` - do let confLimit = cnfMaxEntityLength $ itrConfig itr - actualLimit = if limit <= 0 then - confLimit - else - limit - when (actualLimit <= 0) - $ fail ("inputLBS: limit must be positive: " ++ show actualLimit) - -- Reader にリクエスト - liftIO $! atomically - $! do chunkLen <- readItr itr itrReqChunkLength id - writeItr itr itrWillReceiveBody True - if fmap (> actualLimit) chunkLen == Just True then - -- 受信前から多過ぎる事が分かってゐる - tooLarge actualLimit - else - writeItr itr itrReqBodyWanted $ Just actualLimit - -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 - chunk <- liftIO $! atomically - $! do chunk <- readItr itr itrReceivedBody id - chunkIsOver <- readItr itr itrReqChunkIsOver id - if L8.length chunk < fromIntegral actualLimit then - -- 要求された量に滿たなくて、まだ殘り - -- があるなら再試行。 - unless chunkIsOver - $ retry - else - -- 制限値一杯まで讀むやうに指示したの - -- にまだ殘ってゐるなら、それは多過ぎ - -- る。 - unless chunkIsOver - $ tooLarge actualLimit - -- 成功。itr 内にチャンクを置いたままにす - -- るとメモリの無駄になるので除去。 - writeItr itr itrReceivedBody L8.empty - return chunk - driftTo DecidingHeader - return chunk - - tooLarge :: Int -> STM () - tooLarge lim = lim `seq` - abortSTM RequestEntityTooLarge [] - $! Just ("Request body must be smaller than " - ++ show lim ++ " bytes.") - --- | Computation of @'inputChunk' limit@ attempts to read a part of --- request body up to @limit@ bytes. You can read any large request by --- repeating computation of this action. When you've read all the --- request body, 'inputChunk' returns an empty string and then make --- the 'Resource' transit to /Deciding Header/ state. --- --- @limit@ may be less than or equal to zero. In this case, the --- default limitation value --- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See --- 'defaultLimit'. --- --- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you --- should use it whenever possible. -inputChunk :: Int -> Resource String -inputChunk limit = limit `seq` - inputChunkLBS limit >>= return . L8.unpack - - --- | This is mostly the same as 'inputChunk' but is more --- efficient. See 'inputLBS'. -inputChunkLBS :: Int -> Resource Lazy.ByteString -inputChunkLBS limit - = limit `seq` - do driftTo GettingBody - itr <- getInteraction - hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id - chunk <- if hasBody then - askForInput itr + go ∷ Int → Builder → Resource Lazy.ByteString + go 0 _ = do chunk ← getChunk 1 + if Strict.null chunk then + return (∅) else - do driftTo DecidingHeader - return L8.empty - return chunk - where - askForInput :: Interaction -> Resource Lazy.ByteString - askForInput itr - = itr `seq` - do let confLimit = cnfMaxEntityLength $! itrConfig itr - actualLimit = if limit < 0 then - confLimit - else - limit - when (actualLimit <= 0) - $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit) - -- Reader にリクエスト - liftIO $! atomically - $! do writeItr itr itrReqBodyWanted $! Just actualLimit - writeItr itr itrWillReceiveBody True - -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 - chunk <- liftIO $! atomically - $ do chunk <- readItr itr itrReceivedBody id - -- 要求された量に滿たなくて、まだ殘りがあ - -- るなら再試行。 - when (L8.length chunk < fromIntegral actualLimit) - $ do chunkIsOver <- readItr itr itrReqChunkIsOver id - unless chunkIsOver - $ retry - -- 成功 - writeItr itr itrReceivedBody L8.empty - return chunk - when (L8.null chunk) - $ driftTo DecidingHeader - return chunk - --- | Computation of @'inputForm' limit@ attempts to read the request --- body with 'input' and parse it as --- application\/x-www-form-urlencoded or multipart\/form-data. If the --- request header \"Content-Type\" is neither of them, 'inputForm' --- makes 'Resource' abort with status \"415 Unsupported Media --- Type\". If the request has no \"Content-Type\", it aborts with --- \"400 Bad Request\". -inputForm :: Int -> Resource [(String, FormData)] -inputForm limit - = limit `seq` - do cTypeM <- getContentType + abort $ mkAbortion' RequestEntityTooLarge + $ "Request body must be smaller than " + ⊕ T.pack (show limit) + ⊕ " bytes." + go !n !b = do c ← getChunk $ min n BB.defaultBufferSize + if Strict.null c then + -- Got EOF + return $ BB.toLazyByteString b + else + do let n' = n - Strict.length c + xs' = b ⊕ BB.fromByteString c + go n' xs' + +-- |@'getForm' limit@ attempts to read the request body with +-- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or +-- @multipart\/form-data@. If the request header \"Content-Type\" is +-- neither of them, 'getForm' aborts with status \"415 Unsupported +-- Media Type\". If the request has no \"Content-Type\", it aborts +-- with \"400 Bad Request\". +-- +-- Note that there are currently a few limitations on parsing +-- @multipart/form-data@. See: 'parseMultipartFormData' +getForm ∷ Maybe Int → Resource [(Strict.ByteString, FormData)] +getForm limit + = do cTypeM ← getContentType case cTypeM of Nothing - -> abort BadRequest [] (Just "Missing Content-Type") + → abort $ mkAbortion' BadRequest "Missing Content-Type" Just (MIMEType "application" "x-www-form-urlencoded" _) - -> readWWWFormURLEncoded + → readWWWFormURLEncoded Just (MIMEType "multipart" "form-data" params) - -> readMultipartFormData params + → readMultipartFormData params Just cType - -> abort UnsupportedMediaType [] (Just $! "Unsupported media type: " - ++ show cType) + → abort $ mkAbortion' UnsupportedMediaType + $ A.toText + $ A.fromAsciiBuilder + $ A.toAsciiBuilder "Unsupported media type: " + ⊕ printMIMEType cType where readWWWFormURLEncoded - = liftM (map toPairWithFormData . parseWWWFormURLEncoded) (input limit) + = (map toPairWithFormData ∘ parseWWWFormURLEncoded) + <$> + (bsToAscii =≪ getChunks limit) + + bsToAscii bs + = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of + Just a → return a + Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded" readMultipartFormData params - = do case find ((== "boundary") . map toLower . fst) params of - Nothing - -> abort BadRequest [] (Just "Missing boundary of multipart/form-data") - Just (_, boundary) - -> do src <- inputLBS limit - case parse (multipartFormP boundary) src of - (# Success formList, _ #) - -> return formList - (# _, _ #) - -> abort BadRequest [] (Just "Unparsable multipart/form-data") - --- | This is just a constant @-1@. It's better to say @'input' --- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly --- the same. -defaultLimit :: Int -defaultLimit = (-1) - - - -{- DecidingHeader 時に使用するアクション群 -} - --- | Set the response status code. If you omit to compute this action, --- the status code will be defaulted to \"200 OK\". -setStatus :: StatusCode -> Resource () -setStatus code - = code `seq` - do driftTo DecidingHeader - itr <- getInteraction - liftIO $! atomically $! updateItr itr itrResponse - $! \ res -> res { - resStatus = code - } - --- | Set a value of given resource header. Comparison of header name --- is case-insensitive. Note that this action is not intended to be --- used so frequently: there should be actions like 'setContentType' --- for every common headers. --- --- Some important headers (especially \"Content-Length\" and --- \"Transfer-Encoding\") may be silently dropped or overwritten by --- the system not to corrupt the interaction with client at the --- viewpoint of HTTP protocol layer. For instance, if we are keeping --- the connection alive, without this process it causes a catastrophe --- to send a header \"Content-Length: 10\" and actually send a body of --- 20 bytes long. In this case the client shall only accept the first --- 10 bytes of response body and thinks that the residual 10 bytes is --- a part of header of the next response. -setHeader :: Strict.ByteString -> Strict.ByteString -> Resource () -setHeader name value - = name `seq` value `seq` - driftTo DecidingHeader >> setHeader' name value - - -setHeader' :: Strict.ByteString -> Strict.ByteString -> Resource () -setHeader' name value - = name `seq` value `seq` - do itr <- getInteraction - liftIO $ atomically - $ updateItr itr itrResponse - $ H.setHeader name value - --- | Computation of @'redirect' code uri@ sets the response status to --- @code@ and \"Location\" header to @uri@. The @code@ must satisfy --- 'Network.HTTP.Lucu.Response.isRedirection' or it causes an error. -redirect :: StatusCode -> URI -> Resource () + = case M.lookup "boundary" params of + Nothing + → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data" + Just boundary + → do src ← getChunks limit + b ← case A.fromText boundary of + Just b → return b + Nothing → abort $ mkAbortion' BadRequest + $ "Malformed boundary: " ⊕ boundary + case parseMultipartFormData b src of + Right xs → return $ map (first A.toByteString) xs + Left err → abort $ mkAbortion' BadRequest $ T.pack err + +-- |@'redirect' code uri@ declares the response status as @code@ and +-- \"Location\" header field as @uri@. The @code@ must satisfy +-- 'isRedirection' or it raises an error. +redirect ∷ StatusCode → URI → Resource () redirect code uri - = code `seq` uri `seq` - do when (code == NotModified || not (isRedirection code)) - $ abort InternalServerError [] - $! Just ("Attempted to redirect with status " ++ show code) + = do when (code ≡ NotModified ∨ not (isRedirection code)) + $ abort + $ mkAbortion' InternalServerError + $ A.toText + $ A.fromAsciiBuilder + $ A.toAsciiBuilder "Attempted to redirect with status " + ⊕ printStatusCode code setStatus code setLocation uri -{-# INLINE redirect #-} - --- | Computation of @'setContentType' mType@ sets the response header --- \"Content-Type\" to @mType@. -setContentType :: MIMEType -> Resource () -setContentType mType - = setHeader (C8.pack "Content-Type") (C8.pack $ show mType) +-- |@'setContentType' mType@ declares the response header +-- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is +-- mandatory for sending a response body. +setContentType ∷ MIMEType → Resource () +setContentType + = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType --- | Computation of @'setLocation' uri@ sets the response header --- \"Location\" to @uri@. -setLocation :: URI -> Resource () +-- |@'setLocation' uri@ declares the response header \"Location\" as +-- @uri@. You usually don't need to call this function directly. +setLocation ∷ URI → Resource () setLocation uri - = setHeader (C8.pack "Location") (C8.pack $ uriToString id uri $ "") + = case A.fromChars uriStr of + Just a → setHeader "Location" a + Nothing → abort $ mkAbortion' InternalServerError + $ "Malformed URI: " ⊕ T.pack uriStr + where + uriStr = uriToString id uri "" --- |Computation of @'setContentEncoding' codings@ sets the response --- header \"Content-Encoding\" to @codings@. -setContentEncoding :: [String] -> Resource () +-- |@'setContentEncoding' codings@ declares the response header +-- \"Content-Encoding\" as @codings@. +setContentEncoding ∷ [CIAscii] → Resource () setContentEncoding codings - = do ver <- getRequestVersion - let tr = case ver of - HttpVersion 1 0 -> unnormalizeCoding - HttpVersion 1 1 -> id - _ -> undefined - setHeader (C8.pack "Content-Encoding") (C8.pack $ joinWith ", " $ map tr codings) - --- |Computation of @'setWWWAuthenticate' challenge@ sets the response --- header \"WWW-Authenticate\" to @challenge@. -setWWWAuthenticate :: AuthChallenge -> Resource () -setWWWAuthenticate challenge - = setHeader (C8.pack "WWW-Authenticate") (C8.pack $ show challenge) - - -{- DecidingBody 時に使用するアクション群 -} - --- | Computation of @'output' str@ writes @str@ as a response body, --- and then make the 'Resource' transit to /Done/ state. It is safe to --- apply 'output' to an infinite string, such as a lazy stream of --- \/dev\/random. --- --- Note that 'outputLBS' is more efficient than 'output' so you should --- use it whenever possible. -output :: String -> Resource () -output str = outputLBS $! L8.pack str -{-# INLINE output #-} - --- | This is mostly the same as 'output' but is more efficient. -outputLBS :: Lazy.ByteString -> Resource () -outputLBS str = do outputChunkLBS str - driftTo Done -{-# INLINE outputLBS #-} - --- | Computation of @'outputChunk' str@ writes @str@ as a part of --- response body. You can compute this action multiple times to write --- a body little at a time. It is safe to apply 'outputChunk' to an --- infinite string. --- --- Note that 'outputChunkLBS' is more efficient than 'outputChunk' so --- you should use it whenever possible. -outputChunk :: String -> Resource () -outputChunk str = outputChunkLBS $! L8.pack str -{-# INLINE outputChunk #-} - --- | This is mostly the same as 'outputChunk' but is more efficient. -outputChunkLBS :: Lazy.ByteString -> Resource () -outputChunkLBS wholeChunk - = wholeChunk `seq` - do driftTo DecidingBody - itr <- getInteraction - - let limit = cnfMaxOutputChunkLength $ itrConfig itr - when (limit <= 0) - $ fail ("cnfMaxOutputChunkLength must be positive: " - ++ show limit) - - discardBody <- liftIO $ atomically $ - readItr itr itrWillDiscardBody id - - unless (discardBody) - $ sendChunks wholeChunk limit - - unless (L8.null wholeChunk) - $ liftIO $ atomically $ - writeItr itr itrBodyIsNull False - where - -- チャンクの大きさは Config で制限されてゐる。もし例へば - -- "/dev/zero" を L8.readFile して作った Lazy.ByteString をそのまま - -- ResponseWriter に渡したりすると大變な事が起こる。何故なら - -- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書 - -- く爲にチャンクの大きさを測る。 - sendChunks :: Lazy.ByteString -> Int -> Resource () - sendChunks str limit - | L8.null str = return () - | otherwise = do let (chunk, remaining) = L8.splitAt (fromIntegral limit) str - itr <- getInteraction - liftIO $ atomically $ - do buf <- readItr itr itrBodyToSend id - if L8.null buf then - -- バッファが消化された - writeItr itr itrBodyToSend chunk - else - -- 消化されるのを待つ - retry - -- 殘りのチャンクについて繰り返す - sendChunks remaining limit - -{- - - [GettingBody からそれ以降の状態に遷移する時] - - body を讀み終へてゐなければ、殘りの body を讀み捨てる。 - - - [DecidingHeader からそれ以降の状態に遷移する時] - - postprocess する。 - - - [Done に遷移する時] - - bodyIsNull が False ならば何もしない。True だった場合は出力補完す - る。 - --} - -driftTo :: InteractionState -> Resource () -driftTo newState - = newState `seq` - do itr <- getInteraction - liftIO $ atomically $ do oldState <- readItr itr itrState id - if newState < oldState then - throwStateError oldState newState - else - do let a = [oldState .. newState] - b = tail a - c = zip a b - mapM_ (uncurry $ drift itr) c - writeItr itr itrState newState + = do ver ← getRequestVersion + tr ← case ver of + HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding) + HttpVersion 1 1 → return toAB + _ → abort $ mkAbortion' InternalServerError + "setContentEncoding: Unknown HTTP version" + setHeader "Content-Encoding" + $ A.fromAsciiBuilder + $ mconcat + $ intersperse (A.toAsciiBuilder ", ") + $ map tr codings where - throwStateError :: Monad m => InteractionState -> InteractionState -> m a - - throwStateError Done DecidingBody - = fail "It makes no sense to output something after finishing to output." - - throwStateError old new - = fail ("state error: " ++ show old ++ " ==> " ++ show new) + toAB = A.toAsciiBuilder ∘ A.fromCIAscii +-- |@'setWWWAuthenticate' challenge@ declares the response header +-- \"WWW-Authenticate\" as @challenge@. +setWWWAuthenticate ∷ AuthChallenge → Resource () +setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge - drift :: Interaction -> InteractionState -> InteractionState -> STM () +-- |Write a chunk in 'Strict.ByteString' to the response body. You +-- must first declare the response header \"Content-Type\" before +-- applying this function. See: 'setContentType' +putChunk ∷ Strict.ByteString → Resource () +putChunk = putBuilder ∘ BB.fromByteString - drift itr GettingBody _ - = writeItr itr itrReqBodyWasteAll True - - drift itr DecidingHeader _ - = postprocess itr - - drift itr _ Done - = do bodyIsNull <- readItr itr itrBodyIsNull id - when bodyIsNull - $ writeDefaultPage itr - - drift _ _ _ - = return () +-- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It +-- can be safely applied to an infinitely long 'Lazy.ByteString'. +-- +-- Note that you must first declare the response header +-- \"Content-Type\" before applying this function. See: +-- 'setContentType' +putChunks ∷ Lazy.ByteString → Resource () +putChunks = putBuilder ∘ BB.fromLazyByteString diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs new file mode 100644 index 0000000..f43ec6c --- /dev/null +++ b/Network/HTTP/Lucu/Resource/Internal.hs @@ -0,0 +1,410 @@ +{-# LANGUAGE + DoAndIfThenElse + , GeneralizedNewtypeDeriving + , OverloadedStrings + , RecordWildCards + , UnicodeSyntax + #-} +module Network.HTTP.Lucu.Resource.Internal + ( Resource + , ResourceDef(..) + , emptyResource + , spawnResource + + , getConfig + , getRemoteAddr + , getRemoteCertificate + , getRequest + , getResourcePath + + , getChunk + + , setStatus + , setHeader + , deleteHeader + + , putBuilder + + , driftTo + ) + where +import Blaze.ByteString.Builder (Builder) +import Control.Applicative +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Monad.Unicode +import Data.Ascii (Ascii, CIAscii) +import qualified Data.Ascii as A +import qualified Data.ByteString as Strict +import Data.List +import Data.Maybe +import Data.Monoid +import Data.Monoid.Unicode +import qualified Data.Text as T +import Network.HTTP.Lucu.Abortion +import Network.HTTP.Lucu.Abortion.Internal +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.DefaultPage +import qualified Network.HTTP.Lucu.Headers as H +import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.Postprocess +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Response +import Network.Socket +import OpenSSL.X509 +import Prelude hiding (catch) +import Prelude.Unicode +import System.IO + +-- |The 'Resource' monad. This monad implements 'MonadIO' so it can do +-- any 'IO' actions. +newtype Resource a + = Resource { + unResource ∷ ReaderT NormalInteraction IO a + } + deriving (Applicative, Functor, Monad, MonadIO) + +runResource ∷ Resource a → NormalInteraction → IO a +runResource = runReaderT ∘ unResource + +-- |'ResourceDef' is basically a set of 'Resource' monads for each +-- HTTP methods. +data ResourceDef = ResourceDef { + -- |Whether to run a 'Resource' on a native thread (spawned by + -- 'forkOS') or to run it on a user thread (spanwed by + -- 'forkIO'). Generally you don't need to set this field to + -- 'True'. + resUsesNativeThread ∷ !Bool + -- | Whether to be greedy or not. + -- + -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a + -- greedy resource at \/aaa\/bbb, it is always chosen even if + -- there is another resource at \/aaa\/bbb\/ccc. If the resource + -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy + -- resources are like CGI scripts. + , resIsGreedy ∷ !Bool + -- |A 'Resource' to be run when a GET request comes for the + -- resource path. If 'resGet' is Nothing, the system responds + -- \"405 Method Not Allowed\" for GET requests. + -- + -- It also runs for HEAD request if the 'resHead' is 'Nothing'. In + -- that case 'putChunk' and such don't actually write a response + -- body. + , resGet ∷ !(Maybe (Resource ())) + -- |A 'Resource' to be run when a HEAD request comes for the + -- resource path. If 'resHead' is Nothing, the system runs + -- 'resGet' instead. If 'resGet' is also Nothing, the system + -- responds \"405 Method Not Allowed\" for HEAD requests. + , resHead ∷ !(Maybe (Resource ())) + -- |A 'Resource' to be run when a POST request comes for the + -- resource path. If 'resPost' is Nothing, the system responds + -- \"405 Method Not Allowed\" for POST requests. + , resPost ∷ !(Maybe (Resource ())) + -- |A 'Resource' to be run when a PUT request comes for the + -- resource path. If 'resPut' is Nothing, the system responds + -- \"405 Method Not Allowed\" for PUT requests. + , resPut ∷ !(Maybe (Resource ())) + -- |A 'Resource' to be run when a DELETE request comes for the + -- resource path. If 'resDelete' is Nothing, the system responds + -- \"405 Method Not Allowed\" for DELETE requests. + , resDelete ∷ !(Maybe (Resource ())) + } + +-- |'emptyResource' is a resource definition with no actual +-- handlers. You can construct a 'ResourceDef' by selectively +-- overriding 'emptyResource'. It is defined as follows: +-- +-- @ +-- emptyResource = ResourceDef { +-- resUsesNativeThread = False +-- , resIsGreedy = False +-- , resGet = Nothing +-- , resHead = Nothing +-- , resPost = Nothing +-- , resPut = Nothing +-- , resDelete = Nothing +-- } +-- @ +emptyResource ∷ ResourceDef +emptyResource = ResourceDef { + resUsesNativeThread = False + , resIsGreedy = False + , resGet = Nothing + , resHead = Nothing + , resPost = Nothing + , resPut = Nothing + , resDelete = Nothing + } + +spawnResource ∷ ResourceDef → NormalInteraction → IO ThreadId +spawnResource (ResourceDef {..}) ni@(NI {..}) + = fork $ run `catch` processException + where + fork ∷ IO () → IO ThreadId + fork | resUsesNativeThread = forkOS + | otherwise = forkIO + + run ∷ IO () + run = flip runResource ni $ + do req ← getRequest + fromMaybe notAllowed $ rsrc req + driftTo Done + + rsrc ∷ Request → Maybe (Resource ()) + rsrc req + = case reqMethod req of + GET → resGet + HEAD → case resHead of + Just r → Just r + Nothing → resGet + POST → resPost + PUT → resPut + DELETE → resDelete + _ → error $ "Unknown request method: " ⧺ show (reqMethod req) + + notAllowed ∷ Resource () + notAllowed = do setStatus MethodNotAllowed + setHeader "Allow" + $ A.fromAsciiBuilder + $ mconcat + $ intersperse (A.toAsciiBuilder ", ") + $ map A.toAsciiBuilder allowedMethods + + allowedMethods ∷ [Ascii] + allowedMethods = nub $ concat [ methods resGet ["GET"] + , methods resHead ["GET", "HEAD"] + , methods resPost ["POST"] + , methods resPut ["PUT"] + , methods resDelete ["DELETE"] + ] + + methods ∷ Maybe a → [Ascii] → [Ascii] + methods m xs + | isJust m = xs + | otherwise = [] + + toAbortion ∷ SomeException → Abortion + toAbortion e + = case fromException e of + Just abortion → abortion + Nothing → mkAbortion' InternalServerError $ T.pack $ show e + + processException ∷ SomeException → IO () + processException exc + = do let abo = toAbortion exc + state ← atomically $ readTVar niState + res ← atomically $ readTVar niResponse + if state ≤ DecidingHeader then + -- We still have a chance to reflect this abortion + -- in the response. Hooray! + flip runResource ni $ + do setStatus $ aboStatus abo + mapM_ (uncurry setHeader) $ H.fromHeaders $ aboHeaders abo + setHeader "Content-Type" defaultPageContentType + deleteHeader "Content-Encoding" + putBuilder $ abortPage niConfig (Just niRequest) res abo + else + when (cnfDumpTooLateAbortionToStderr niConfig) + $ dumpAbortion abo + runResource (driftTo Done) ni + +dumpAbortion ∷ Abortion → IO () +dumpAbortion abo + = hPutStr stderr + $ concat [ "Lucu: an exception occured after " + , "sending the response header to the client:\n" + , " ", show abo, "\n" + ] + +getInteraction ∷ Resource NormalInteraction +getInteraction = Resource ask + +-- |Get the 'Config' value for this httpd. +getConfig ∷ Resource Config +getConfig = niConfig <$> getInteraction + +-- |Get the 'SockAddr' of the remote host. +getRemoteAddr ∷ Resource SockAddr +getRemoteAddr = niRemoteAddr <$> getInteraction + +-- | Return the X.509 certificate of the client, or 'Nothing' if: +-- +-- * This request didn't came through an SSL stream. +-- +-- * The client didn't send us its certificate. +-- +-- * The 'OpenSSL.Session.VerificationMode' of +-- 'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to +-- 'OpenSSL.Session.VerifyPeer'. +getRemoteCertificate ∷ Resource (Maybe X509) +getRemoteCertificate = niRemoteCert <$> getInteraction + +-- |Return the 'Request' value representing the request header. You +-- usually don't need to call this function directly. +getRequest ∷ Resource Request +getRequest = niRequest <$> getInteraction + +-- |Get the path of this 'Resource' (to be exact, 'ResourceDef') in +-- the 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this +-- action is the exact path in the tree even when the 'ResourceDef' is +-- greedy. +-- +-- Example: +-- +-- > main = let tree = mkResTree [ (["foo"], resFoo) ] +-- > in runHttpd defaultConfig tree [] +-- > +-- > resFoo = emptyResource { +-- > resIsGreedy = True +-- > , resGet = Just $ do requestURI <- getRequestURI +-- > resourcePath <- getResourcePath +-- > pathInfo <- getPathInfo +-- > -- uriPath requestURI == "/foo/bar/baz" +-- > -- resourcePath == ["foo"] +-- > -- pathInfo == ["bar", "baz"] +-- > ... +-- > } +getResourcePath ∷ Resource [Strict.ByteString] +getResourcePath = niResourcePath <$> getInteraction + +-- |@'getChunk' n@ attempts to read a chunk of request body up to @n@ +-- bytes. You can incrementally read the request body by repeatedly +-- calling this function. If there is nothing to be read anymore, +-- 'getChunk' returns 'Strict.empty' and makes 'Resource' transit to +-- the /Deciding Header/ state. +getChunk ∷ Int → Resource Strict.ByteString +getChunk = (driftTo ReceivingBody *>) ∘ getChunk' + +getChunk' ∷ Int → Resource Strict.ByteString +getChunk' n + | n < 0 = fail ("getChunk: n must not be negative: " ⧺ show n) + | n ≡ 0 = return (∅) + | otherwise = do req ← getRequest + if reqMustHaveBody req then + askForInput =≪ getInteraction + else + driftTo DecidingHeader *> return (∅) + where + askForInput ∷ NormalInteraction → Resource Strict.ByteString + askForInput (NI {..}) + = do -- Ask the RequestReader to get a chunk. + liftIO $ atomically + $ putTMVar niReceiveBodyReq (ReceiveBody n) + -- Then wait for a reply. + chunk ← liftIO + $ atomically + $ takeTMVar niReceivedBody + -- Have we got an EOF? + when (Strict.null chunk) + $ driftTo DecidingHeader + return chunk + +-- |Declare the response status code. If you don't call this function, +-- the status code will be defaulted to \"200 OK\". +setStatus ∷ StatusCode → Resource () +setStatus sc + = do ni ← getInteraction + liftIO $ atomically + $ do state ← readTVar $ niState ni + when (state > DecidingHeader) + $ fail "Too late to declare the response status." + setResponseStatus ni sc + +-- |@'setHeader' name value@ declares the value of the response header +-- @name@ as @value@. Note that this function is not intended to be +-- used so frequently: there should be specialised functions like +-- 'setContentType' for every common headers. +-- +-- Some important headers (especially \"Content-Length\" and +-- \"Transfer-Encoding\") may be silently dropped or overwritten by +-- the system not to corrupt the interaction with client at the +-- viewpoint of HTTP protocol layer. For instance, if we are keeping +-- the connection alive, without this manipulation it will be a +-- catastrophe when we send a header \"Content-Length: 10\" and +-- actually send a body of 20 bytes long to the remote peer. In this +-- case the client shall only accept the first 10 bytes of response +-- body and thinks that the residual 10 bytes is a part of the header +-- of the next response. +setHeader ∷ CIAscii → Ascii → Resource () +setHeader name value = liftIO ∘ atomically ∘ go =≪ getInteraction + where + go ∷ NormalInteraction → STM () + go (NI {..}) + = do state ← readTVar niState + when (state > DecidingHeader) $ + fail "Too late to declare a response header field." + res ← readTVar niResponse + writeTVar niResponse $ H.setHeader name value res + when (name ≡ "Content-Type") $ + writeTVar niResponseHasCType True + +-- |@'deleteHeader' name@ deletes a response header @name@ if +-- any. This function is not intended to be used so frequently. +deleteHeader ∷ CIAscii → Resource () +deleteHeader name = liftIO ∘ atomically ∘ go =≪ getInteraction + where + go ∷ NormalInteraction → STM () + go (NI {..}) + = do state ← readTVar niState + when (state > DecidingHeader) $ + fail "Too late to delete a response header field." + res ← readTVar niResponse + writeTVar niResponse $ H.deleteHeader name res + when (name ≡ "Content-Type") $ + writeTVar niResponseHasCType False + +-- |Run a 'Builder' to construct a chunk, and write it to the response +-- body. It can be safely applied to a 'Builder' producing an +-- infinitely long stream of octets. +-- +-- Note that you must first declare the response header +-- \"Content-Type\" before applying this function. See: +-- 'setContentType' +putBuilder ∷ Builder → Resource () +putBuilder b = liftIO ∘ atomically ∘ go =≪ getInteraction + where + go ∷ NormalInteraction → STM () + go ni@(NI {..}) + = do driftTo' ni SendingBody + hasCType ← readTVar niResponseHasCType + unless hasCType + $ throwSTM + $ mkAbortion' InternalServerError + "putBuilder: Content-Type has not been set." + putTMVar niBodyToSend b + +driftTo ∷ InteractionState → Resource () +driftTo = (getInteraction ≫=) ∘ ((liftIO ∘ atomically) ∘) ∘ flip driftTo' + +driftTo' ∷ NormalInteraction → InteractionState → STM () +driftTo' ni@(NI {..}) newState + = do oldState ← readTVar niState + driftFrom oldState + where + driftFrom ∷ InteractionState → STM () + driftFrom oldState + | newState < oldState = throwStateError oldState newState + | newState ≡ oldState = return () + | otherwise + = do let a = [oldState .. newState] + b = tail a + c = zip a b + mapM_ (uncurry driftFromTo) c + writeTVar niState newState + + throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a + throwStateError Done SendingBody + = fail "It makes no sense to output something after finishing outputs." + throwStateError old new + = fail ("State error: " ⧺ show old ⧺ " ==> " ⧺ show new) + + driftFromTo ∷ InteractionState → InteractionState → STM () + driftFromTo ReceivingBody _ + = putTMVar niReceiveBodyReq WasteAll + driftFromTo DecidingHeader _ + = postprocess ni + driftFromTo _ _ + = return () diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index 4cb4932..f3fca16 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -1,136 +1,49 @@ -{-# OPTIONS_HADDOCK prune #-} +{-# LANGUAGE + DoAndIfThenElse + , OverloadedStrings + , RecordWildCards + , UnicodeSyntax + #-} -- | Repository of the resources in httpd. module Network.HTTP.Lucu.Resource.Tree - ( ResourceDef(..) - , emptyResource - - , ResTree + ( ResTree , FallbackHandler - , mkResTree -- [ ([String], ResourceDef) ] -> ResTree - - , findResource -- ResTree -> URI -> Maybe ([String], ResourceDef) - , runResource -- ResourceDef -> Interaction -> IO ThreadId + , mkResTree + , findResource ) where - -import Control.Arrow -import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception -import Control.Monad -import qualified Data.ByteString.Char8 as C8 -import Data.List +import Control.Arrow +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Control.Monad +import Data.Foldable +import Data.List import qualified Data.Map as M -import Data.Map (Map) -import Data.Maybe -import Network.HTTP.Lucu.Abortion -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.Headers (emptyHeaders, fromHeaders) -import Network.HTTP.Lucu.Request -import Network.HTTP.Lucu.Resource -import Network.HTTP.Lucu.Response -import Network.HTTP.Lucu.Interaction -import Network.HTTP.Lucu.Utils -import Network.URI hiding (path) -import System.IO -import Prelude hiding (catch) - +import Data.Map (Map) +import Data.Maybe +import Data.Monoid.Unicode +import Data.Sequence (Seq) +import Data.Sequence.Unicode hiding ((∅)) +import Network.HTTP.Lucu.Resource.Internal +import Network.HTTP.Lucu.Utils +import Network.URI hiding (path) +import System.IO +import Prelude hiding (catch) +import Prelude.Unicode -- |'FallbackHandler' is an extra resource handler for resources which --- can't be statically located somewhere in the resource tree. The --- Lucu httpd first search for a resource in the tree, and then call +-- can't be statically located anywhere in the resource tree. The Lucu +-- httpd first searches for a resource in the tree, and then calls -- fallback handlers to ask them for a resource. If all of the --- handlers returned 'Prelude.Nothing', the httpd responds with 404 --- Not Found. -type FallbackHandler = [String] -> IO (Maybe ResourceDef) - - --- "/aaa/bbb/ccc" にアクセスされた時、もし "/aaa/bbb" に貪欲なリソース --- があれば、假に "/aaa/bbb/ccc" に何らかのリソースがあったとしても必ず --- "/aaa/bbb" が撰ばれる。"/aaa/bbb" のリソースが貪欲でなければ、それは --- 無視される。 - --- | 'ResourceDef' is basically a set of --- 'Network.HTTP.Lucu.Resource.Resource' monads for each HTTP methods. -data ResourceDef = ResourceDef { - -- |Whether to run a 'Network.HTTP.Lucu.Resource.Resource' on a - -- native thread (spawned by 'Control.Concurrent.forkOS') or to - -- run it on a user thread (spanwed by - -- 'Control.Concurrent.forkIO'). Generally you don't need to set - -- this field to 'Prelude.True'. - resUsesNativeThread :: !Bool - -- | Whether to be greedy or not. - -- - -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a - -- greedy resource at \/aaa\/bbb, it is always chosen even if - -- there is another resource at \/aaa\/bbb\/ccc. If the resource - -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy - -- resources are like CGI scripts. - , resIsGreedy :: !Bool - -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a GET - -- request comes for the resource path. If 'resGet' is Nothing, - -- the system responds \"405 Method Not Allowed\" for GET - -- requests. - -- - -- It also runs for HEAD request if the 'resHead' is Nothing. In - -- this case 'Network.HTTP.Lucu.Resource.output' and such like - -- don't actually write a response body. - , resGet :: !(Maybe (Resource ())) - -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a HEAD - -- request comes for the resource path. If 'resHead' is Nothing, - -- the system runs 'resGet' instead. If 'resGet' is also Nothing, - -- the system responds \"405 Method Not Allowed\" for HEAD - -- requests. - , resHead :: !(Maybe (Resource ())) - -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a POST - -- request comes for the resource path. If 'resPost' is Nothing, - -- the system responds \"405 Method Not Allowed\" for POST - -- requests. - , resPost :: !(Maybe (Resource ())) - -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a PUT - -- request comes for the resource path. If 'resPut' is Nothing, - -- the system responds \"405 Method Not Allowed\" for PUT - -- requests. - , resPut :: !(Maybe (Resource ())) - -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a - -- DELETE request comes for the resource path. If 'resDelete' is - -- Nothing, the system responds \"405 Method Not Allowed\" for - -- DELETE requests. - , resDelete :: !(Maybe (Resource ())) - } - --- |'emptyResource' is a resource definition with no actual --- handlers. You can construct a 'ResourceDef' by selectively --- overriding 'emptyResource'. It is defined as follows: --- --- @ --- emptyResource = ResourceDef { --- resUsesNativeThread = False --- , resIsGreedy = False --- , resGet = Nothing --- , resHead = Nothing --- , resPost = Nothing --- , resPut = Nothing --- , resDelete = Nothing --- } --- @ -emptyResource :: ResourceDef -emptyResource = ResourceDef { - resUsesNativeThread = False - , resIsGreedy = False - , resGet = Nothing - , resHead = Nothing - , resPost = Nothing - , resPut = Nothing - , resDelete = Nothing - } +-- handlers returned 'Nothing', the httpd responds with 404 Not Found. +type FallbackHandler = [ByteString] → IO (Maybe ResourceDef) -- |'ResTree' is an opaque structure which is a map from resource path -- to 'ResourceDef'. newtype ResTree = ResTree ResNode -- root だから Map ではない -type ResSubtree = Map String ResNode +type ResSubtree = Map ByteString ResNode data ResNode = ResNode (Maybe ResourceDef) ResSubtree -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g. @@ -140,15 +53,21 @@ data ResNode = ResNode (Maybe ResourceDef) ResSubtree -- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd -- ] -- @ -mkResTree :: [ ([String], ResourceDef) ] -> ResTree -mkResTree = processRoot . map (first canonicalisePath) +-- +-- Note that path components are always represented as octet streams +-- in this system. Lucu automatically decodes percent-encoded URIs but +-- has no involvement in character encodings such as UTF-8, since RFC +-- 2616 (HTTP/1.1) says nothing about character encodings to be used +-- in \"http\" and \"https\" URI schemas. +mkResTree ∷ [ ([ByteString], ResourceDef) ] → ResTree +mkResTree = processRoot ∘ map (first canonicalisePath) where - canonicalisePath :: [String] -> [String] - canonicalisePath = filter (/= "") + canonicalisePath ∷ [ByteString] → [ByteString] + canonicalisePath = filter ((¬) ∘ BS.null) - processRoot :: [ ([String], ResourceDef) ] -> ResTree + processRoot ∷ [ ([ByteString], ResourceDef) ] → ResTree processRoot list - = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list + = let (roots, nonRoots) = partition (\(path, _) → null path) list children = processNonRoot nonRoots in if null roots then @@ -161,12 +80,12 @@ mkResTree = processRoot . map (first canonicalisePath) in ResTree (ResNode (Just def) children) - processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree + processNonRoot ∷ [ ([ByteString], ResourceDef) ] → ResSubtree processNonRoot list = let subtree = M.fromList [(name, node name) - | name <- childNames] - childNames = [name | (name:_, _) <- list] - node name = let defs = [def | (path, def) <- list, path == [name]] + | name ← childNames] + childNames = [name | (name:_, _) ← list] + node name = let defs = [def | (path, def) ← list, path ≡ [name]] in if null defs then -- No resources are defined @@ -177,123 +96,53 @@ mkResTree = processRoot . map (first canonicalisePath) -- There is a resource here. ResNode (Just $ last defs) children children = processNonRoot [(path, def) - | (_:path, def) <- list] + | (_:path, def) ← list] in subtree - -findResource :: ResTree -> [FallbackHandler] -> URI -> IO (Maybe ([String], ResourceDef)) +findResource ∷ ResTree + → [FallbackHandler] + → URI + → IO (Maybe ([ByteString], ResourceDef)) findResource (ResTree (ResNode rootDefM subtree)) fbs uri - = do let pathStr = uriPath uri - path = [unEscapeString x | x <- splitBy (== '/') pathStr, x /= ""] - haveGreedyRoot = case rootDefM of - Just def -> resIsGreedy def - Nothing -> False - foundInTree = if haveGreedyRoot || null path then - do def <- rootDefM + = do let path = splitPathInfo uri + hasGreedyRoot = maybe False resIsGreedy rootDefM + foundInTree = if hasGreedyRoot ∨ null path then + do def ← rootDefM return ([], def) else - walkTree subtree path [] + walkTree subtree path (∅) if isJust foundInTree then return foundInTree - else + else fallback path fbs where - walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef) + walkTree ∷ ResSubtree + → [ByteString] + → Seq ByteString + → Maybe ([ByteString], ResourceDef) walkTree _ [] _ = error "Internal error: should not reach here." walkTree tree (name:[]) soFar - = case M.lookup name tree of - Nothing -> Nothing - Just (ResNode defM _) -> do def <- defM - return (soFar ++ [name], def) + = do ResNode defM _ ← M.lookup name tree + def ← defM + return (toList $ soFar ⊳ name, def) walkTree tree (x:xs) soFar - = case M.lookup x tree of - Nothing -> Nothing - Just (ResNode defM children) -> case defM of - Just (ResourceDef { resIsGreedy = True }) - -> do def <- defM - return (soFar ++ [x], def) - _ -> walkTree children xs (soFar ++ [x]) - - fallback :: [String] -> [FallbackHandler] -> IO (Maybe ([String], ResourceDef)) + = do ResNode defM sub ← M.lookup x tree + case defM of + Just (ResourceDef { resIsGreedy = True }) + → do def ← defM + return (toList $ soFar ⊳ x, def) + _ → walkTree sub xs (soFar ⊳ x) + + fallback ∷ [ByteString] + → [FallbackHandler] + → IO (Maybe ([ByteString], ResourceDef)) fallback _ [] = return Nothing - fallback path (x:xs) = do m <- x path + fallback path (x:xs) = do m ← x path case m of - Just def -> return $! Just ([], def) - Nothing -> fallback path xs - - -runResource :: ResourceDef -> Interaction -> IO ThreadId -runResource def itr - = def `seq` itr `seq` - fork - $! catch ( runRes ( do req <- getRequest - fromMaybe notAllowed $ rsrc req - driftTo Done - ) itr - ) - processException - where - fork :: IO () -> IO ThreadId - fork = if resUsesNativeThread def - then forkOS - else forkIO - - rsrc :: Request -> Maybe (Resource ()) - rsrc req - = case reqMethod req of - GET -> resGet def - HEAD -> case resHead def of - Just r -> Just r - Nothing -> resGet def - POST -> resPost def - PUT -> resPut def - DELETE -> resDelete def - _ -> undefined - - notAllowed :: Resource () - notAllowed = do setStatus MethodNotAllowed - setHeader (C8.pack "Allow") (C8.pack $ joinWith ", " allowedMethods) - - allowedMethods :: [String] - allowedMethods = nub $ concat [ methods resGet ["GET"] - , methods resHead ["GET", "HEAD"] - , methods resPost ["POST"] - , methods resPut ["PUT"] - , methods resDelete ["DELETE"] - ] - - methods :: (ResourceDef -> Maybe a) -> [String] -> [String] - methods f xs = case f def of - Just _ -> xs - Nothing -> [] - - toAbortion :: SomeException -> Abortion - toAbortion e = case fromException e of - Just abortion -> abortion - Nothing -> Abortion InternalServerError emptyHeaders (Just (show e)) - - processException :: SomeException -> IO () - processException exc - = do let abo = toAbortion exc - conf = itrConfig itr - -- まだ DecidingHeader 以前の状態だったら、この途中終了 - -- を應答に反映させる餘地がある。さうでなければ stderr - -- にでも吐くしか無い。 - state <- atomically $ readItr itr itrState id - reqM <- atomically $ readItr itr itrRequest id - res <- atomically $ readItr itr itrResponse id - if state <= DecidingHeader then - flip runRes itr - $ do setStatus $ aboStatus abo - mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo - output $ abortPage conf reqM res abo - else - when (cnfDumpTooLateAbortionToStderr $ itrConfig itr) - $ hPutStrLn stderr $ show abo - - flip runRes itr $ driftTo Done + Just def → return $ Just ([], def) + Nothing → fallback path xs diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index adf8505..35c168f 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -1,36 +1,42 @@ {-# LANGUAGE DeriveDataTypeable + , OverloadedStrings + , RecordWildCards , UnboxedTuples , UnicodeSyntax + , ViewPatterns #-} -{-# OPTIONS_HADDOCK prune #-} -- |Definition of things related on HTTP response. module Network.HTTP.Lucu.Response ( StatusCode(..) + , printStatusCode + , Response(..) - , hPutResponse + , emptyResponse + , resCanHaveBody + , printResponse + , isInformational , isSuccessful , isRedirection , isError , isClientError , isServerError - , statusCode ) where - -import qualified Data.ByteString as Strict (ByteString) -import qualified Data.ByteString.Char8 as C8 hiding (ByteString) -import Data.Typeable -import Network.HTTP.Lucu.Format -import Network.HTTP.Lucu.HandleLike -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.HttpVersion +import Data.Ascii (Ascii, AsciiBuilder) +import qualified Data.Ascii as A +import Data.Monoid.Unicode +import Data.Typeable +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.HttpVersion +import Network.HTTP.Lucu.Utils +import Prelude.Unicode -- |This is the definition of HTTP status code. --- 'Network.HTTP.Lucu.Resource.setStatus' accepts these named statuses --- so you don't have to memorize, for instance, that \"Gateway +-- 'Network.HTTP.Lucu.Resource.setStatus' accepts these named status +-- codes so you don't have to memorize, for instance, that \"Gateway -- Timeout\" is 504. data StatusCode = Continue | SwitchingProtocols @@ -82,126 +88,144 @@ data StatusCode = Continue | GatewayTimeout | HttpVersionNotSupported | InsufficientStorage - deriving (Typeable, Eq) - -instance Show StatusCode where - show sc = case statusCode sc of - (# num, msg #) - -> (fmtDec 3 num) ++ " " ++ C8.unpack msg - - + deriving (Eq, Show, Typeable) + +-- |Convert a 'StatusCode' to an 'AsciiBuilder'. +printStatusCode ∷ StatusCode → AsciiBuilder +{-# INLINEABLE printStatusCode #-} +printStatusCode (statusCode → (# num, msg #)) + = ( show3 num ⊕ + A.toAsciiBuilder " " ⊕ + A.toAsciiBuilder msg + ) + +-- |This is the definition of an HTTP response. data Response = Response { - resVersion :: !HttpVersion - , resStatus :: !StatusCode - , resHeaders :: !Headers + resVersion ∷ !HttpVersion + , resStatus ∷ !StatusCode + , resHeaders ∷ !Headers } deriving (Show, Eq) - instance HasHeaders Response where - getHeaders = resHeaders + getHeaders = resHeaders setHeaders res hdr = res { resHeaders = hdr } - -hPutResponse :: HandleLike h => h -> Response -> IO () -hPutResponse h res - = h `seq` res `seq` - do hPutHttpVersion h (resVersion res) - hPutChar h ' ' - hPutStatus h (resStatus res) - hPutBS h (C8.pack "\r\n") - hPutHeaders h (resHeaders res) - -hPutStatus :: HandleLike h => h -> StatusCode -> IO () -hPutStatus h sc - = h `seq` sc `seq` - case statusCode sc of - (# num, msg #) - -> do hPutStr h (fmtDec 3 num) - hPutChar h ' ' - hPutBS h msg - - --- |@'isInformational' sc@ is 'Prelude.True' iff @sc < 200@. -isInformational :: StatusCode -> Bool -isInformational = doesMeet (< 200) - --- |@'isSuccessful' sc@ is 'Prelude.True' iff @200 <= sc < 300@. -isSuccessful :: StatusCode -> Bool -isSuccessful = doesMeet (\ n -> n >= 200 && n < 300) - --- |@'isRedirection' sc@ is 'Prelude.True' iff @300 <= sc < 400@. -isRedirection :: StatusCode -> Bool -isRedirection = doesMeet (\ n -> n >= 300 && n < 400) - --- |@'isError' sc@ is 'Prelude.True' iff @400 <= sc@ -isError :: StatusCode -> Bool -isError = doesMeet (>= 400) - --- |@'isClientError' sc@ is 'Prelude.True' iff @400 <= sc < 500@. -isClientError :: StatusCode -> Bool -isClientError = doesMeet (\ n -> n >= 400 && n < 500) - --- |@'isServerError' sc@ is 'Prelude.True' iff @500 <= sc@. -isServerError :: StatusCode -> Bool -isServerError = doesMeet (>= 500) - - -doesMeet :: (Int -> Bool) -> StatusCode -> Bool -doesMeet p sc = case statusCode sc of - (# num, _ #) -> p num - - --- |@'statusCode' sc@ returns an unboxed tuple of numeric and textual --- representation of @sc@. -statusCode :: StatusCode -> (# Int, Strict.ByteString #) - -statusCode Continue = (# 100, C8.pack "Continue" #) -statusCode SwitchingProtocols = (# 101, C8.pack "Switching Protocols" #) -statusCode Processing = (# 102, C8.pack "Processing" #) - -statusCode Ok = (# 200, C8.pack "OK" #) -statusCode Created = (# 201, C8.pack "Created" #) -statusCode Accepted = (# 202, C8.pack "Accepted" #) -statusCode NonAuthoritativeInformation = (# 203, C8.pack "Non Authoritative Information" #) -statusCode NoContent = (# 204, C8.pack "No Content" #) -statusCode ResetContent = (# 205, C8.pack "Reset Content" #) -statusCode PartialContent = (# 206, C8.pack "Partial Content" #) -statusCode MultiStatus = (# 207, C8.pack "Multi Status" #) - -statusCode MultipleChoices = (# 300, C8.pack "Multiple Choices" #) -statusCode MovedPermanently = (# 301, C8.pack "Moved Permanently" #) -statusCode Found = (# 302, C8.pack "Found" #) -statusCode SeeOther = (# 303, C8.pack "See Other" #) -statusCode NotModified = (# 304, C8.pack "Not Modified" #) -statusCode UseProxy = (# 305, C8.pack "Use Proxy" #) -statusCode TemporaryRedirect = (# 306, C8.pack "Temporary Redirect" #) - -statusCode BadRequest = (# 400, C8.pack "Bad Request" #) -statusCode Unauthorized = (# 401, C8.pack "Unauthorized" #) -statusCode PaymentRequired = (# 402, C8.pack "Payment Required" #) -statusCode Forbidden = (# 403, C8.pack "Forbidden" #) -statusCode NotFound = (# 404, C8.pack "Not Found" #) -statusCode MethodNotAllowed = (# 405, C8.pack "Method Not Allowed" #) -statusCode NotAcceptable = (# 406, C8.pack "Not Acceptable" #) -statusCode ProxyAuthenticationRequired = (# 407, C8.pack "Proxy Authentication Required" #) -statusCode RequestTimeout = (# 408, C8.pack "Request Timeout" #) -statusCode Conflict = (# 409, C8.pack "Conflict" #) -statusCode Gone = (# 410, C8.pack "Gone" #) -statusCode LengthRequired = (# 411, C8.pack "Length Required" #) -statusCode PreconditionFailed = (# 412, C8.pack "Precondition Failed" #) -statusCode RequestEntityTooLarge = (# 413, C8.pack "Request Entity Too Large" #) -statusCode RequestURITooLarge = (# 414, C8.pack "Request URI Too Large" #) -statusCode UnsupportedMediaType = (# 415, C8.pack "Unsupported Media Type" #) -statusCode RequestRangeNotSatisfiable = (# 416, C8.pack "Request Range Not Satisfiable" #) -statusCode ExpectationFailed = (# 417, C8.pack "Expectation Failed" #) -statusCode UnprocessableEntitiy = (# 422, C8.pack "Unprocessable Entity" #) -statusCode Locked = (# 423, C8.pack "Locked" #) -statusCode FailedDependency = (# 424, C8.pack "Failed Dependency" #) - -statusCode InternalServerError = (# 500, C8.pack "Internal Server Error" #) -statusCode NotImplemented = (# 501, C8.pack "Not Implemented" #) -statusCode BadGateway = (# 502, C8.pack "Bad Gateway" #) -statusCode ServiceUnavailable = (# 503, C8.pack "Service Unavailable" #) -statusCode GatewayTimeout = (# 504, C8.pack "Gateway Timeout" #) -statusCode HttpVersionNotSupported = (# 505, C8.pack "HTTP Version Not Supported" #) -statusCode InsufficientStorage = (# 507, C8.pack "Insufficient Storage" #) \ No newline at end of file +-- |Returns an HTTP\/1.1 'Response' with no header fields. +emptyResponse ∷ StatusCode → Response +emptyResponse sc + = Response { + resVersion = HttpVersion 1 1 + , resStatus = sc + , resHeaders = (∅) + } + +-- |Returns 'True' iff a given 'Response' allows the existence of +-- response entity body. +resCanHaveBody ∷ Response → Bool +{-# INLINEABLE resCanHaveBody #-} +resCanHaveBody (Response {..}) + | isInformational resStatus = False + | resStatus ≡ NoContent = False + | resStatus ≡ ResetContent = False + | resStatus ≡ NotModified = False + | otherwise = True + +-- |Convert a 'Response' to 'AsciiBuilder'. +printResponse ∷ Response → AsciiBuilder +{-# INLINEABLE printResponse #-} +printResponse (Response {..}) + = printHttpVersion resVersion ⊕ + A.toAsciiBuilder " " ⊕ + printStatusCode resStatus ⊕ + A.toAsciiBuilder "\x0D\x0A" ⊕ + printHeaders resHeaders + +-- |@'isInformational' sc@ returns 'True' iff @sc < 200@. +isInformational ∷ StatusCode → Bool +{-# INLINE isInformational #-} +isInformational = satisfy (< 200) + +-- |@'isSuccessful' sc@ returns 'True' iff @200 <= sc < 300@. +isSuccessful ∷ StatusCode → Bool +{-# INLINE isSuccessful #-} +isSuccessful = satisfy (\ n → n ≥ 200 ∧ n < 300) + +-- |@'isRedirection' sc@ returns 'True' iff @300 <= sc < 400@. +isRedirection ∷ StatusCode → Bool +{-# INLINE isRedirection #-} +isRedirection = satisfy (\ n → n ≥ 300 ∧ n < 400) + +-- |@'isError' sc@ returns 'True' iff @400 <= sc@ +isError ∷ StatusCode → Bool +{-# INLINE isError #-} +isError = satisfy (≥ 400) + +-- |@'isClientError' sc@ returns 'True' iff @400 <= sc < 500@. +isClientError ∷ StatusCode → Bool +{-# INLINE isClientError #-} +isClientError = satisfy (\ n → n ≥ 400 ∧ n < 500) + +-- |@'isServerError' sc@ returns 'True' iff @500 <= sc@. +isServerError ∷ StatusCode → Bool +{-# INLINE isServerError #-} +isServerError = satisfy (≥ 500) + +satisfy ∷ (Int → Bool) → StatusCode → Bool +{-# INLINE satisfy #-} +satisfy p (statusCode → (# num, _ #)) = p num + +statusCode ∷ StatusCode → (# Int, Ascii #) +{-# INLINEABLE statusCode #-} + +statusCode Continue = (# 100, "Continue" #) +statusCode SwitchingProtocols = (# 101, "Switching Protocols" #) +statusCode Processing = (# 102, "Processing" #) + +statusCode Ok = (# 200, "OK" #) +statusCode Created = (# 201, "Created" #) +statusCode Accepted = (# 202, "Accepted" #) +statusCode NonAuthoritativeInformation = (# 203, "Non Authoritative Information" #) +statusCode NoContent = (# 204, "No Content" #) +statusCode ResetContent = (# 205, "Reset Content" #) +statusCode PartialContent = (# 206, "Partial Content" #) +statusCode MultiStatus = (# 207, "Multi Status" #) + +statusCode MultipleChoices = (# 300, "Multiple Choices" #) +statusCode MovedPermanently = (# 301, "Moved Permanently" #) +statusCode Found = (# 302, "Found" #) +statusCode SeeOther = (# 303, "See Other" #) +statusCode NotModified = (# 304, "Not Modified" #) +statusCode UseProxy = (# 305, "Use Proxy" #) +statusCode TemporaryRedirect = (# 306, "Temporary Redirect" #) + +statusCode BadRequest = (# 400, "Bad Request" #) +statusCode Unauthorized = (# 401, "Unauthorized" #) +statusCode PaymentRequired = (# 402, "Payment Required" #) +statusCode Forbidden = (# 403, "Forbidden" #) +statusCode NotFound = (# 404, "Not Found" #) +statusCode MethodNotAllowed = (# 405, "Method Not Allowed" #) +statusCode NotAcceptable = (# 406, "Not Acceptable" #) +statusCode ProxyAuthenticationRequired = (# 407, "Proxy Authentication Required" #) +statusCode RequestTimeout = (# 408, "Request Timeout" #) +statusCode Conflict = (# 409, "Conflict" #) +statusCode Gone = (# 410, "Gone" #) +statusCode LengthRequired = (# 411, "Length Required" #) +statusCode PreconditionFailed = (# 412, "Precondition Failed" #) +statusCode RequestEntityTooLarge = (# 413, "Request Entity Too Large" #) +statusCode RequestURITooLarge = (# 414, "Request URI Too Large" #) +statusCode UnsupportedMediaType = (# 415, "Unsupported Media Type" #) +statusCode RequestRangeNotSatisfiable = (# 416, "Request Range Not Satisfiable" #) +statusCode ExpectationFailed = (# 417, "Expectation Failed" #) +statusCode UnprocessableEntitiy = (# 422, "Unprocessable Entity" #) +statusCode Locked = (# 423, "Locked" #) +statusCode FailedDependency = (# 424, "Failed Dependency" #) + +statusCode InternalServerError = (# 500, "Internal Server Error" #) +statusCode NotImplemented = (# 501, "Not Implemented" #) +statusCode BadGateway = (# 502, "Bad Gateway" #) +statusCode ServiceUnavailable = (# 503, "Service Unavailable" #) +statusCode GatewayTimeout = (# 504, "Gateway Timeout" #) +statusCode HttpVersionNotSupported = (# 505, "HTTP Version Not Supported" #) +statusCode InsufficientStorage = (# 507, "Insufficient Storage" #) +-- FIXME: Textual representations should also include numbers. +-- FIXME: StatusCode should be a type class rather than a type. diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 9751a76..d89ee9e 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -1,171 +1,269 @@ {-# LANGUAGE - BangPatterns + DoAndIfThenElse + , RecordWildCards + , ScopedTypeVariables , UnicodeSyntax #-} module Network.HTTP.Lucu.ResponseWriter ( responseWriter ) where - -import qualified Data.ByteString.Lazy.Char8 as C8 -import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception -import Control.Monad +import qualified Blaze.ByteString.Builder.HTTP as BB +import Control.Applicative +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(..)) -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.Format -import Network.HTTP.Lucu.HandleLike -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.HttpVersion -import Network.HTTP.Lucu.Interaction -import Network.HTTP.Lucu.Postprocess -import Network.HTTP.Lucu.Response -import Prelude hiding (catch) -import System.IO (stderr) - - -responseWriter :: HandleLike h => Config -> h -> InteractionQueue -> ThreadId -> IO () -responseWriter !cnf !h !tQueue !readerTID - = awaitSomethingToWrite +import Data.Sequence (ViewR(..)) +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.HandleLike +import Network.HTTP.Lucu.HttpVersion +import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.Response +import Prelude.Unicode +import System.IO (hPutStrLn, stderr) +import System.IO.Error + +data Context h + = Context { + cConfig ∷ !Config + , cHandle ∷ !h + , cQueue ∷ !InteractionQueue + , cReader ∷ !ThreadId + } + +responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO () +responseWriter cnf h tQueue readerTID + = awaitSomethingToWrite (Context cnf h tQueue readerTID) `catches` - [ Handler (( \ _ -> return () ) :: IOException -> IO ()) - , Handler ( \ ThreadKilled -> return () ) - , Handler ( \ BlockedIndefinitelyOnSTM -> hPutStrLn stderr "requestWriter: blocked indefinitely" ) - , Handler (( \ e -> hPutStrLn stderr (show e) ) :: SomeException -> IO ()) + [ Handler handleIOE + , Handler handleAsyncE + , Handler handleBIOS + , Handler handleOthers ] where - awaitSomethingToWrite :: IO () - awaitSomethingToWrite - = {-# SCC "awaitSomethingToWrite" #-} - join $! - atomically $! - -- キューが空でなくなるまで待つ - do queue <- readTVar tQueue - -- GettingBody 状態にあり、Continue が期待されてゐ - -- て、それがまだ送信前なのであれば、Continue を送 - -- 信する。 - case S.viewr queue of - EmptyR -> retry - _ :> itr -> do state <- readItr itr itrState id - - if state == GettingBody then - writeContinueIfNecessary itr - else - if state >= DecidingBody then - writeHeaderOrBodyIfNecessary itr - else - retry - - writeContinueIfNecessary :: Interaction -> STM (IO ()) - writeContinueIfNecessary !itr - = {-# SCC "writeContinueIfNecessary" #-} - do expectedContinue <- readItr itr itrExpectedContinue id - if expectedContinue then - do wroteContinue <- readItr itr itrWroteContinue id - if wroteContinue then - -- 既に Continue を書込み濟 - retry + handleIOE ∷ IOException → IO () + handleIOE e + | isIllegalOperation e + = return () -- EPIPE: should be ignored at all. + | otherwise + = terminate e + + handleAsyncE ∷ AsyncException → IO () + handleAsyncE ThreadKilled = terminate' + handleAsyncE e = terminate e + + handleBIOS ∷ BlockedIndefinitelyOnSTM → IO () + handleBIOS = terminate + + handleOthers ∷ SomeException → IO () + handleOthers = terminate + + terminate ∷ Exception e ⇒ e → IO () + terminate e + = do hPutStrLn stderr "requestWriter caught an exception:" + hPutStrLn stderr (show $ toException e) + terminate' + + terminate' ∷ IO () + terminate' = hClose h + +awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO () +awaitSomethingToWrite ctx@(Context {..}) + = join $ + atomically $ + do queue ← readTVar cQueue + case S.viewr queue of + EmptyR → retry + queue' :> itr → do writeTVar cQueue queue' + return $ writeSomething ctx itr + +writeSomething ∷ HandleLike h ⇒ Context h → SomeInteraction → IO () +writeSomething ctx itr + = let writer = writeResponseForNI ctx <$> fromInteraction itr <|> + writeResponseForSEI ctx <$> fromInteraction itr <|> + writeResponseForSYI ctx <$> fromInteraction itr + in + case writer of + Just f → f + Nothing → fail "Internal error: unknown interaction type" + +writeResponseForNI ∷ HandleLike h + ⇒ Context h + → NormalInteraction + → IO () +writeResponseForNI = writeContinueIfNeeded + +writeContinueIfNeeded ∷ HandleLike h + ⇒ Context h + → NormalInteraction + → IO () +writeContinueIfNeeded ctx@(Context {..}) ni@(NI {..}) + = do isNeeded ← atomically $ readTMVar niSendContinue + when isNeeded + $ do let cont = Response { + resVersion = HttpVersion 1 1 + , resStatus = Continue + , resHeaders = (∅) + } + hPutBuilder cHandle $ A.toBuilder $ printResponse cont + hFlush cHandle + writeHeader ctx ni + +writeHeader ∷ HandleLike h + ⇒ Context h + → NormalInteraction + → IO () +writeHeader ctx@(Context {..}) ni@(NI {..}) + = do res ← atomically $ + do state ← readTVar niState + if state ≥ SendingBody then + readTVar niResponse + else + retry -- Too early to write header fields. + hPutBuilder cHandle $ A.toBuilder $ printResponse res + hFlush cHandle + writeBodyIfNeeded ctx ni + +writeBodyIfNeeded ∷ HandleLike h + ⇒ Context h + → NormalInteraction + → IO () +writeBodyIfNeeded ctx ni@(NI {..}) + = join $ + atomically $ + do willDiscardBody ← readTVar niWillDiscardBody + if willDiscardBody then + return $ discardBody ctx ni + else + if niWillChunkBody then + return $ writeChunkedBody ctx ni + else + return $ writeNonChunkedBody ctx ni + +discardBody ∷ HandleLike h + ⇒ Context h + → NormalInteraction + → IO () +discardBody ctx ni@(NI {..}) + = join $ + atomically $ + do chunk ← tryTakeTMVar niBodyToSend + case chunk of + Just _ → return $ discardBody ctx ni + Nothing → do state ← readTVar niState + if state ≡ Done then + return $ finalize ctx ni else - do reqBodyWanted <- readItr itr itrReqBodyWanted id - if reqBodyWanted /= Nothing then - return $ writeContinue itr - else - retry - else - retry - - writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ()) - writeHeaderOrBodyIfNecessary !itr - -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ - -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が - -- 空でなければ、それを出力する。空である時は、もし状態が - -- Done であれば後処理をする。 - = {-# SCC "writeHeaderOrBodyIfNecessary" #-} - do wroteHeader <- readItr itr itrWroteHeader id - - if not wroteHeader then - return $! writeHeader itr - else - do bodyToSend <- readItr itr itrBodyToSend id - - if C8.null bodyToSend then - do state <- readItr itr itrState id - - if state == Done then - return $! finalize itr - else - retry + retry + +writeChunkedBody ∷ HandleLike h + ⇒ Context h + → NormalInteraction + → IO () +writeChunkedBody ctx@(Context {..}) ni@(NI {..}) + = join $ + atomically $ + do chunk ← tryTakeTMVar niBodyToSend + case chunk of + Just b → return $ + do hPutBuilder cHandle $ BB.chunkedTransferEncoding b + hFlush cHandle + writeChunkedBody ctx ni + Nothing → do state ← readTVar niState + if state ≡ Done then + return $ + do hPutBuilder cHandle BB.chunkedTransferTerminator + hFlush cHandle + finalize ctx ni else - return $! writeBodyChunk itr - - writeContinue :: Interaction -> IO () - writeContinue !itr - = {-# SCC "writeContinue" #-} - do let cont = Response { - resVersion = HttpVersion 1 1 - , resStatus = Continue - , resHeaders = emptyHeaders - } - cont' <- completeUnconditionalHeaders cnf cont - hPutResponse h cont' - hFlush h - atomically $! writeItr itr itrWroteContinue True - awaitSomethingToWrite - - writeHeader :: Interaction -> IO () - writeHeader !itr - = {-# SCC "writeHeader" #-} - do res <- atomically $! do writeItr itr itrWroteHeader True - readItr itr itrResponse id - hPutResponse h res - hFlush h - awaitSomethingToWrite - - writeBodyChunk :: Interaction -> IO () - writeBodyChunk !itr - = {-# SCC "writeBodyChunk" #-} - do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id - willChunkBody <- atomically $! readItr itr itrWillChunkBody id - chunk <- atomically $! do chunk <- readItr itr itrBodyToSend id - writeItr itr itrBodyToSend C8.empty - return chunk - unless willDiscardBody - $ do if willChunkBody then - do hPutStr h (fmtHex False 0 $! fromIntegral $! C8.length chunk) - hPutLBS h (C8.pack "\r\n") - hPutLBS h chunk - hPutLBS h (C8.pack "\r\n") - else - hPutLBS h chunk - hFlush h - awaitSomethingToWrite - - finishBodyChunk :: Interaction -> IO () - finishBodyChunk !itr - = {-# SCC "finishBodyChunk" #-} - do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id - willChunkBody <- atomically $! readItr itr itrWillChunkBody id - when (not willDiscardBody && willChunkBody) - $ hPutLBS h (C8.pack "0\r\n\r\n") >> hFlush h - - finalize :: Interaction -> IO () - finalize !itr - = {-# SCC "finalize" #-} - do finishBodyChunk itr - willClose <- atomically $! - do queue <- readTVar tQueue - - case S.viewr queue of - EmptyR -> return () -- this should never happen - remaining :> _ -> writeTVar tQueue remaining - - readItr itr itrWillClose id - if willClose then - -- reader は恐らく hWaitForInput してゐる最中なので、 - -- スレッドを豫め殺して置かないとをかしくなる。 - do killThread readerTID - hClose h - else - awaitSomethingToWrite + retry + +writeNonChunkedBody ∷ HandleLike h + ⇒ Context h + → NormalInteraction + → IO () +writeNonChunkedBody ctx@(Context {..}) ni@(NI {..}) + = join $ + atomically $ + do chunk ← tryTakeTMVar niBodyToSend + case chunk of + Just b → return $ + do hPutBuilder cHandle b + hFlush cHandle + writeNonChunkedBody ctx ni + Nothing → do state ← readTVar niState + if state ≡ Done then + return $ finalize ctx ni + else + retry + +finalize ∷ HandleLike h ⇒ Context h → NormalInteraction → IO () +finalize ctx@(Context {..}) (NI {..}) + = join $ + atomically $ + do willClose ← readTVar niWillClose + sentContinue ← takeTMVar niSendContinue + return $ + if needToClose willClose sentContinue then + -- The RequestReader is probably blocking on + -- hWaitForInput so we have to kill it before closing + -- the socket. THINKME: Couldn't that somehow be + -- avoided? + do killThread cReader + hClose cHandle + else + awaitSomethingToWrite ctx + where + needToClose ∷ Bool → Bool → Bool + needToClose willClose sentContinue + -- Explicitly instructed to close the connection. + | willClose = True + -- We've sent both "HTTP/1.1 100 Continue" and a final + -- response, so nothing prevents our connection from keeping + -- alive. + | sentContinue = False + -- We've got "Expect: 100-continue" but have sent a final + -- response without sending "HTTP/1.1 100 + -- Continue". According to the RFC 2616 (HTTP/1.1), it is + -- undecidable whether the client will send us its + -- (rejected) request body OR start a completely new request + -- in this situation. So the only possible thing to do is to + -- brutally shutdown the connection. + | niExpectedContinue = True + -- The client didn't expect 100-continue so we haven't sent + -- one. No need to do anything special. + | otherwise = False + +writeResponseForSEI ∷ HandleLike h + ⇒ Context h + → SemanticallyInvalidInteraction + → IO () +writeResponseForSEI ctx@(Context {..}) (SEI {..}) + = do hPutBuilder cHandle $ A.toBuilder $ printResponse seiResponse + unless seiWillDiscardBody $ + if seiWillChunkBody then + do hPutBuilder cHandle $ BB.chunkedTransferEncoding seiBodyToSend + hPutBuilder cHandle BB.chunkedTransferTerminator + else + hPutBuilder cHandle seiBodyToSend + hFlush cHandle + if seiWillClose ∨ seiExpectedContinue then + do killThread cReader + hClose cHandle + else + awaitSomethingToWrite ctx + +writeResponseForSYI ∷ HandleLike h + ⇒ Context h + → SyntacticallyInvalidInteraction + → IO () +writeResponseForSYI (Context {..}) (SYI {..}) + = do hPutBuilder cHandle $ A.toBuilder $ printResponse syiResponse + hPutBuilder cHandle syiBodyToSend + hFlush cHandle + killThread cReader + hClose cHandle diff --git a/Network/HTTP/Lucu/SocketLike.hs b/Network/HTTP/Lucu/SocketLike.hs index 915f323..dd9c34b 100644 --- a/Network/HTTP/Lucu/SocketLike.hs +++ b/Network/HTTP/Lucu/SocketLike.hs @@ -8,37 +8,34 @@ module Network.HTTP.Lucu.SocketLike ( SocketLike(..) ) where - import qualified Network.Socket as So -import Network.HTTP.Lucu.HandleLike +import Network.HTTP.Lucu.HandleLike import qualified OpenSSL.Session as SSL +import Prelude.Unicode import qualified System.IO as I - -class (HandleLike (Handle s)) => SocketLike s where - type Handle s :: * - accept :: s -> IO (Handle s, So.SockAddr) - socketPort :: s -> IO So.PortNumber - +class (HandleLike (Handle s)) ⇒ SocketLike s where + type Handle s ∷ ★ + accept ∷ s → IO (Handle s, So.SockAddr) + socketPort ∷ s → IO So.PortNumber instance SocketLike So.Socket where type Handle So.Socket = I.Handle accept soSelf - = do (soPeer, addr) <- So.accept soSelf - hPeer <- So.socketToHandle soPeer I.ReadWriteMode + = do (soPeer, addr) ← So.accept soSelf + hPeer ← So.socketToHandle soPeer I.ReadWriteMode return (hPeer, addr) socketPort = So.socketPort - instance SocketLike (SSL.SSLContext, So.Socket) where type Handle (SSL.SSLContext, So.Socket) = SSL.SSL accept (ctx, soSelf) - = do (soPeer, addr) <- So.accept soSelf - ssl <- SSL.connection ctx soPeer + = do (soPeer, addr) ← So.accept soSelf + ssl ← SSL.connection ctx soPeer SSL.accept ssl return (ssl, addr) - socketPort = So.socketPort . snd \ No newline at end of file + socketPort = So.socketPort ∘ snd diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index 9175ce9..4f66931 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -1,153 +1,139 @@ {-# LANGUAGE - BangPatterns + DoAndIfThenElse + , OverloadedStrings , UnicodeSyntax #-} -- | Handling static files on the filesystem. module Network.HTTP.Lucu.StaticFile ( staticFile - , handleStaticFile - , staticDir - , handleStaticDir , generateETagFromFile ) where +import qualified Blaze.ByteString.Builder.ByteString as BB +import qualified Blaze.Text.Int as BT +import Control.Monad +import Control.Monad.Unicode +import Control.Monad.Trans +import qualified Data.Ascii as A +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Monoid.Unicode +import Data.String +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time.Clock.POSIX +import Network.HTTP.Lucu.Abortion +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.ETag +import Network.HTTP.Lucu.MIMEType +import Network.HTTP.Lucu.MIMEType.Guess +import Network.HTTP.Lucu.Resource +import Network.HTTP.Lucu.Resource.Internal +import Network.HTTP.Lucu.Response +import Prelude.Unicode +import System.FilePath +import System.Posix.Files -import Control.Monad -import Control.Monad.Trans -import qualified Data.ByteString.Lazy.Char8 as B -import Data.Time.Clock.POSIX -import Network.HTTP.Lucu.Abortion -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.ETag -import Network.HTTP.Lucu.Format -import Network.HTTP.Lucu.MIMEType.Guess -import Network.HTTP.Lucu.Resource -import Network.HTTP.Lucu.Resource.Tree -import Network.HTTP.Lucu.Response -import Network.HTTP.Lucu.Utils -import System.FilePath.Posix -import System.Posix.Files - - --- | @'staticFile' fpath@ is a --- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' which serves the file --- at @fpath@ on the filesystem. -staticFile :: FilePath -> ResourceDef +-- | @'staticFile' fpath@ is a 'ResourceDef' which serves the file at +-- @fpath@ on the filesystem. +staticFile ∷ FilePath → ResourceDef staticFile path - = ResourceDef { - resUsesNativeThread = False - , resIsGreedy = False - , resGet = Just $! handleStaticFile path - , resHead = Nothing - , resPost = Nothing - , resPut = Nothing - , resDelete = Nothing + = emptyResource { + resGet = Just $ handleStaticFile True path + , resHead = Just $ handleStaticFile False path } --- | Computation of @'handleStaticFile' fpath@ serves the file at --- @fpath@ on the filesystem. The --- 'Network.HTTP.Lucu.Resource.Resource' must be in the /Examining --- Request/ state before the computation. It will be in the /Done/ --- state after the computation. --- --- If you just want to place a static file on the --- 'Network.HTTP.Lucu.Resource.Tree.ResTree', you had better use --- 'staticFile' instead of this. -handleStaticFile :: FilePath -> Resource () -handleStaticFile path - = path `seq` - do exists <- liftIO $ fileExist path - if exists then - -- 存在はした。讀めるかどうかは知らない。 - do stat <- liftIO $ getFileStatus path - if isRegularFile stat then - do readable <- liftIO $ fileAccess path True False False - unless readable - -- 讀めない - $ abort Forbidden [] Nothing - -- 讀める - tag <- liftIO $ generateETagFromFile path - let lastMod = posixSecondsToUTCTime $ fromRational $ toRational $ modificationTime stat - foundEntity tag lastMod +octetStream ∷ MIMEType +{-# NOINLINE octetStream #-} +octetStream = parseMIMEType "application/octet-stream" + +handleStaticFile ∷ Bool → FilePath → Resource () +handleStaticFile sendContent path + = do exists ← liftIO $ fileExist path + unless exists + foundNoEntity' + + readable ← liftIO $ fileAccess path True False False + unless readable + $ abort + $ mkAbortion Forbidden [] Nothing + + stat ← liftIO $ getFileStatus path + when (isDirectory stat) + $ abort + $ mkAbortion Forbidden [] Nothing - -- MIME Type を推定 - conf <- getConfig - case guessTypeByFileName (cnfExtToMIMEType conf) path of - Nothing -> return () - Just mime -> setContentType mime + tag ← liftIO $ generateETagFromFile path + let lastMod = posixSecondsToUTCTime + $ fromRational + $ toRational + $ modificationTime stat + foundEntity tag lastMod - -- 實際にファイルを讀んで送る - liftIO (B.readFile path) >>= outputLBS - else - abort Forbidden [] Nothing - else - foundNoEntity Nothing + conf ← getConfig + case guessTypeByFileName (cnfExtToMIMEType conf) path of + Nothing → setContentType octetStream + Just mime → setContentType mime + when sendContent + $ liftIO (LBS.readFile path) ≫= putChunks --- |Computation of @'generateETagFromFile' fpath@ generates a strong --- entity tag from a file. The file doesn't necessarily have to be a --- regular file; it may be a FIFO or a device file. The tag is made of --- inode ID, size and modification time. +-- |@'generateETagFromFile' fpath@ generates a strong entity tag from +-- a file. The file doesn't necessarily have to be a regular file; it +-- may be a FIFO or a device file. The tag is made of inode ID, size +-- and modification time. -- -- Note that the tag is not strictly strong because the file could be -- modified twice at a second without changing inode ID or size, but --- it's not really possible to generate a strict strong ETag from a --- file since we don't want to simply grab the entire file and use it --- as an ETag. It is indeed possible to hash it with SHA-1 or MD5 to +-- it's not really possible to generate a strictly strong ETag from a +-- file as we don't want to simply grab the entire file and use it as +-- an ETag. It is indeed possible to hash it with SHA-1 or MD5 to -- increase strictness, but it's too inefficient if the file is really -- large (say, 1 TiB). -generateETagFromFile :: FilePath -> IO ETag +generateETagFromFile ∷ FilePath → IO ETag generateETagFromFile path - = path `seq` - do stat <- getFileStatus path - let inode = fromEnum $! fileID stat - size = fromEnum $! fileSize stat - lastMod = fromEnum $! modificationTime stat - tag = fmtHex False 0 inode - ++ "-" ++ - fmtHex False 0 size - ++ "-" ++ - fmtHex False 0 lastMod - return $! strongETag tag + = do stat ← getFileStatus path + let inode = fileID stat + size = fileSize stat + lastMod = fromEnum $ modificationTime stat + tag = A.fromAsciiBuilder + $ A.unsafeFromBuilder + $ BT.integral inode + ⊕ BB.fromByteString "-" + ⊕ BT.integral size + ⊕ BB.fromByteString "-" + ⊕ BT.integral lastMod + return $ strongETag tag --- | @'staticDir' dir@ is a --- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' which maps all files --- in @dir@ and its subdirectories on the filesystem to the +-- | @'staticDir' dir@ is a 'ResourceDef' which maps all files in +-- @dir@ and its subdirectories on the filesystem to the -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. -staticDir :: FilePath -> ResourceDef +-- +-- Note that 'staticDir' currently doesn't have a directory-listing +-- capability. Requesting the content of a directory will end up being +-- replied with /403 Forbidden/. +staticDir ∷ FilePath → ResourceDef staticDir path - = ResourceDef { - resUsesNativeThread = False - , resIsGreedy = True - , resGet = Just $! handleStaticDir path - , resHead = Nothing - , resPost = Nothing - , resPut = Nothing - , resDelete = Nothing + = emptyResource { + resIsGreedy = True + , resGet = Just $ handleStaticDir True path + , resHead = Just $ handleStaticDir False path } --- | Computation of @'handleStaticDir' dir@ maps all files in @dir@ --- and its subdirectories on the filesystem to the --- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The --- 'Network.HTTP.Lucu.Resource.Resource' must be in the /Examining --- Request/ state before the computation. It will be in the /Done/ --- state after the computation. --- --- If you just want to place a static directory tree on the --- 'Network.HTTP.Lucu.Resource.Tree.ResTree', you had better use --- 'staticDir' instead of this. -handleStaticDir :: FilePath -> Resource () -handleStaticDir !basePath - = do extraPath <- getPathInfo +-- TODO: implement directory listing. +handleStaticDir ∷ Bool → FilePath → Resource () +handleStaticDir sendContent basePath + = do extraPath ← getPathInfo securityCheck extraPath - let path = basePath joinPath extraPath - - handleStaticFile path + let path = basePath joinPath (map dec8 extraPath) + handleStaticFile sendContent path where - securityCheck :: Monad m => [String] -> m () - securityCheck !pathElems - = when (any (== "..") pathElems) $ fail ("security error: " - ++ joinWith "/" pathElems) --- TODO: implement directory listing. + dec8 ∷ ByteString → String + dec8 = T.unpack ∘ T.decodeUtf8 + +securityCheck ∷ (Eq s, Show s, IsString s, Monad m) ⇒ [s] → m () +securityCheck pathElems + = when (any (≡ "..") pathElems) + $ fail ("security error: " ⧺ show pathElems) diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs index dbc65ac..3d38b8b 100644 --- a/Network/HTTP/Lucu/Utils.hs +++ b/Network/HTTP/Lucu/Utils.hs @@ -1,74 +1,68 @@ {-# LANGUAGE - BangPatterns + OverloadedStrings , UnicodeSyntax #-} -- |Utility functions used internally in the Lucu httpd. These -- functions may be useful too for something else. module Network.HTTP.Lucu.Utils ( splitBy - , joinWith - , trim - , isWhiteSpace , quoteStr , parseWWWFormURLEncoded + , splitPathInfo + , show3 ) where +import Blaze.ByteString.Builder.ByteString as B +import Blaze.Text.Int as BT import Control.Monad -import Data.List hiding (last) +import Data.Ascii (Ascii, AsciiBuilder) +import qualified Data.Ascii as A +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.List hiding (last) +import Data.Monoid.Unicode import Network.URI -import Prelude hiding (last) +import Prelude hiding (last) import Prelude.Unicode -- |> splitBy (== ':') "ab:c:def" -- > ==> ["ab", "c", "def"] -splitBy :: (a -> Bool) -> [a] -> [[a]] +splitBy ∷ (a → Bool) → [a] → [[a]] +{-# INLINEABLE splitBy #-} splitBy isSep src - = case break isSep src - of (last , [] ) -> [last] - (first, _sep:rest) -> first : splitBy isSep rest - --- |> joinWith ":" ["ab", "c", "def"] --- > ==> "ab:c:def" -joinWith :: [a] -> [[a]] -> [a] -joinWith = (join .) . intersperse - --- |> trim (== '_') "__ab_c__def___" --- > ==> "ab_c__def" -trim :: (a -> Bool) -> [a] -> [a] -trim !p = trimTail . trimHead - where - trimHead = dropWhile p - trimTail = reverse . trimHead . reverse - --- |@'isWhiteSpace' c@ is 'Prelude.True' iff c is one of SP, HT, CR --- and LF. -isWhiteSpace :: Char -> Bool -isWhiteSpace ' ' = True -isWhiteSpace '\t' = True -isWhiteSpace '\r' = True -isWhiteSpace '\n' = True -isWhiteSpace _ = False -{-# INLINE isWhiteSpace #-} + = case break isSep src of + (last , [] ) → [last] + (first, _sep:rest) → first : splitBy isSep rest -- |> quoteStr "abc" -- > ==> "\"abc\"" -- -- > quoteStr "ab\"c" -- > ==> "\"ab\\\"c\"" -quoteStr :: String -> String -quoteStr !str = concat (["\""] ++ map quote str ++ ["\""]) +quoteStr ∷ Ascii → AsciiBuilder +quoteStr str = A.toAsciiBuilder "\"" ⊕ + go (A.toByteString str) (∅) ⊕ + A.toAsciiBuilder "\"" where - quote :: Char -> String - quote '"' = "\\\"" - quote c = [c] + go ∷ BS.ByteString → AsciiBuilder → AsciiBuilder + go bs ab + = case BS.break (≡ '"') bs of + (x, y) + | BS.null y → ab ⊕ b2ab x + | otherwise → go (BS.tail y) (ab ⊕ b2ab x + ⊕ A.toAsciiBuilder "\\\"") + b2ab ∷ BS.ByteString → AsciiBuilder + b2ab = A.toAsciiBuilder ∘ A.unsafeFromByteString -- |> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd" -- > ==> [("aaa", "bbb"), ("ccc", "ddd")] -parseWWWFormURLEncoded ∷ String → [(String, String)] +parseWWWFormURLEncoded ∷ Ascii → [(ByteString, ByteString)] parseWWWFormURLEncoded src - | null src = [] - | otherwise = do pairStr ← splitBy (\ c → c ≡ ';' ∨ c ≡ '&') src + -- THINKME: We could gain some performance by using attoparsec + -- here. + | src ≡ "" = [] + | otherwise = do pairStr ← splitBy (\ c → c ≡ ';' ∨ c ≡ '&') (A.toString src) let (key, value) = break (≡ '=') pairStr return ( unescape key , unescape $ case value of @@ -76,9 +70,31 @@ parseWWWFormURLEncoded src val → val ) where - unescape ∷ String → String - unescape = unEscapeString ∘ map plusToSpace + unescape ∷ String → ByteString + unescape = BS.pack ∘ unEscapeString ∘ map plusToSpace plusToSpace ∷ Char → Char plusToSpace '+' = ' ' plusToSpace c = c + +-- |> splitPathInfo "http://example.com/foo/bar" +-- > ==> ["foo", "bar"] +splitPathInfo ∷ URI → [ByteString] +splitPathInfo uri + = let reqPathStr = uriPath uri + reqPath = [unEscapeString x | x ← splitBy (≡ '/') reqPathStr, (¬) (null x)] + in + map BS.pack reqPath + +-- |> show3 5 +-- > ==> "005" +show3 ∷ Integral n ⇒ n → AsciiBuilder +{-# INLINEABLE show3 #-} +show3 = A.unsafeFromBuilder ∘ go + where + go i | i ≥ 0 ∧ i < 10 = B.fromByteString "00" ⊕ BT.digit i + | i ≥ 0 ∧ i < 100 = B.fromByteString "0" ⊕ BT.integral i + | i ≥ 0 ∧ i < 1000 = BT.integral i + | otherwise = error ("show3: the integer i must satisfy 0 <= i < 1000: " ⧺ show i) +-- FIXME: Drop this function as soon as possible, to eliminate the +-- dependency on blaze-textual. diff --git a/bugs/issue-74e34d62deabaab386472d2949a46fea893f1ec1.yaml b/bugs/issue-74e34d62deabaab386472d2949a46fea893f1ec1.yaml index 717a930..d113d82 100644 --- a/bugs/issue-74e34d62deabaab386472d2949a46fea893f1ec1.yaml +++ b/bugs/issue-74e34d62deabaab386472d2949a46fea893f1ec1.yaml @@ -5,7 +5,7 @@ type: :task component: Lucu release: Lucu-1.0 reporter: PHO -status: :unstarted +status: :in_progress disposition: creation_time: 2011-07-29 16:01:14.666629 Z references: [] @@ -20,4 +20,8 @@ log_events: - PHO - assigned to release Lucu-1.0 from unassigned - "" -git_branch: +- - 2011-07-30 11:17:25.622897 Z + - PHO + - changed status from unstarted to in_progress + - "" +git_branch: attoparsec diff --git a/bugs/issue-8959dadc07db1bd363283dee401073f6e48dc7fa.yaml b/bugs/issue-8959dadc07db1bd363283dee401073f6e48dc7fa.yaml index 76f9120..3e454e7 100644 --- a/bugs/issue-8959dadc07db1bd363283dee401073f6e48dc7fa.yaml +++ b/bugs/issue-8959dadc07db1bd363283dee401073f6e48dc7fa.yaml @@ -5,7 +5,7 @@ type: :task component: Lucu release: Lucu-1.0 reporter: PHO -status: :unstarted +status: :in_progress disposition: creation_time: 2010-03-12 06:56:06.939283 Z references: [] @@ -20,4 +20,8 @@ log_events: - PHO - assigned to release Lucu-1.0 from unassigned - "" -git_branch: +- - 2011-07-30 11:17:19.173203 Z + - PHO + - changed status from unstarted to in_progress + - "" +git_branch: attoparsec diff --git a/bugs/issue-a5e6a89da31d2ca0a69d89ad1d579fee8d0c131f.yaml b/bugs/issue-a5e6a89da31d2ca0a69d89ad1d579fee8d0c131f.yaml new file mode 100644 index 0000000..43cf56d --- /dev/null +++ b/bugs/issue-a5e6a89da31d2ca0a69d89ad1d579fee8d0c131f.yaml @@ -0,0 +1,25 @@ +--- !ditz.rubyforge.org,2008-03-06/issue +title: "Add a configuration flag -fSSL to enable SSL support (default: off)" +desc: |- + Reason #1: SSL support isn't essential for Lucu. + Reason #2: We have toooo many dependencies now, want to drop at least HsOpenSSL. +type: :task +component: Lucu +release: Lucu-1.0 +reporter: PHO +status: :unstarted +disposition: +creation_time: 2011-10-26 23:04:33.719311 Z +references: [] + +id: a5e6a89da31d2ca0a69d89ad1d579fee8d0c131f +log_events: +- - 2011-10-26 23:04:35.031007 Z + - PHO + - created + - "" +- - 2011-10-27 17:33:31.904875 Z + - PHO + - edited title + - Should be defaulted to off! +git_branch: diff --git a/bugs/issue-b3e2a5ee9307d4ba9b7a0346e6ca0d91ca287997.yaml b/bugs/issue-b3e2a5ee9307d4ba9b7a0346e6ca0d91ca287997.yaml index 661d612..8469a0a 100644 --- a/bugs/issue-b3e2a5ee9307d4ba9b7a0346e6ca0d91ca287997.yaml +++ b/bugs/issue-b3e2a5ee9307d4ba9b7a0346e6ca0d91ca287997.yaml @@ -5,7 +5,7 @@ type: :task component: Lucu release: Lucu-1.0 reporter: PHO -status: :unstarted +status: :in_progress disposition: creation_time: 2011-07-30 04:39:53.073102 Z references: [] @@ -16,4 +16,8 @@ log_events: - PHO - created - "" -git_branch: +- - 2011-07-30 11:17:28.677836 Z + - PHO + - changed status from unstarted to in_progress + - "" +git_branch: attoparsec diff --git a/bugs/issue-ce2851ba49c154838b48e56ecf4c01840e4c1b7c.yaml b/bugs/issue-ce2851ba49c154838b48e56ecf4c01840e4c1b7c.yaml new file mode 100644 index 0000000..ea7b4e9 --- /dev/null +++ b/bugs/issue-ce2851ba49c154838b48e56ecf4c01840e4c1b7c.yaml @@ -0,0 +1,21 @@ +--- !ditz.rubyforge.org,2008-03-06/issue +title: "Consider adding a configuration flag -funix (default: on)" +desc: |- + Disabling it makes generateETagFromFile unavailable but drops + dependency to the unix package instead. +type: :task +component: Lucu +release: Lucu-1.0 +reporter: PHO +status: :unstarted +disposition: +creation_time: 2011-10-26 23:18:42.168974 Z +references: [] + +id: ce2851ba49c154838b48e56ecf4c01840e4c1b7c +log_events: +- - 2011-10-26 23:18:43.753104 Z + - PHO + - created + - "" +git_branch: diff --git a/bugs/issue-e0312227f40a0fa92d4c5d69a64dad473f54389a.yaml b/bugs/issue-e0312227f40a0fa92d4c5d69a64dad473f54389a.yaml new file mode 100644 index 0000000..1dfd5b4 --- /dev/null +++ b/bugs/issue-e0312227f40a0fa92d4c5d69a64dad473f54389a.yaml @@ -0,0 +1,27 @@ +--- !ditz.rubyforge.org,2008-03-06/issue +title: Introduce a type class 'Dispatcher' and make ResTree/FallbackHandler instances of it. +desc: And the dispatcher data type should form a Monoid. +type: :task +component: Lucu +release: Lucu-1.0 +reporter: PHO +status: :unstarted +disposition: +creation_time: 2011-10-17 02:46:21.854704 Z +references: [] + +id: e0312227f40a0fa92d4c5d69a64dad473f54389a +log_events: +- - 2011-10-17 02:46:22.826524 Z + - PHO + - created + - "" +- - 2011-10-17 02:48:13.741801 Z + - PHO + - commented + - We should implement name-based virtualhosts at the same time. +- - 2011-10-17 02:51:52.045280 Z + - PHO + - commented + - FallbackHandler should be either a non-pure function (MonadIO) or a pure function returning Maybe ResourceDef. +git_branch: diff --git a/cabal-package.mk b/cabal-package.mk index 2363b98..cc534f4 100644 --- a/cabal-package.mk +++ b/cabal-package.mk @@ -18,6 +18,7 @@ HPC ?= hpc DITZ ?= ditz CONFIGURE_ARGS ?= --disable-optimization +HLINT_OPTS ?= --cross --report=dist/report.html SETUP_FILE := $(wildcard Setup.*hs) CABAL_FILE := $(wildcard *.cabal) @@ -99,6 +100,13 @@ test: build ditz: $(DITZ) html dist/ditz +ChangeLog: + rm -f $@ + $(DITZ) releases | awk '{print $$1}' | sort --reverse | while read i; do \ + $(DITZ) changelog $$i >> $@; \ + done + head $@ + fixme: @$(FIND) . \ \( -name 'dist' -or -name '.git' -or -name '_darcs' \) -prune \ @@ -106,25 +114,33 @@ fixme: \( -name '*.c' -or -name '*.h' -or \ -name '*.hs' -or -name '*.lhs' -or \ -name '*.hsc' -or -name '*.cabal' \) \ - -exec egrep -i '(fixme|thinkme)' {} \+ \ + -exec egrep 'FIXME|THINKME|TODO' {} \+ \ || echo 'No FIXME or THINKME found.' lint: - $(HLINT) . --report + $(HLINT) . $(HLINT_OPTS) + +push: push-repo push-ditz push-doc -push: doc ditz +push-repo: if [ -d "_darcs" ]; then \ darcs push; \ elif [ -d ".git" ]; then \ git push --all && git push --tags; \ fi + +push-ditz: ditz + rsync -av --delete \ + dist/ditz/ \ + www@nem.cielonegro.org:static.cielonegro.org/htdocs/ditz/$(PKG_NAME) + +push-doc: doc if [ -d "dist/doc" ]; then \ rsync -av --delete \ dist/doc/html/$(PKG_NAME)/ \ www@nem.cielonegro.org:static.cielonegro.org/htdocs/doc/$(PKG_NAME); \ fi - rsync -av --delete \ - dist/ditz/ \ - www@nem.cielonegro.org:static.cielonegro.org/htdocs/ditz/$(PKG_NAME) -.PHONY: build build-hook setup-config setup-config-hook run clean clean-hook install doc sdist test lint push +.PHONY: build build-hook setup-config setup-config-hook run clean clean-hook \ + install doc sdist test lint push push-repo push-ditz push-doc \ + ChangeLog diff --git a/data/CompileMimeTypes.hs b/data/CompileMimeTypes.hs index 8118406..9ba5b1e 100755 --- a/data/CompileMimeTypes.hs +++ b/data/CompileMimeTypes.hs @@ -1,10 +1,13 @@ #!/usr/bin/env runghc - +{-# LANGUAGE + UnicodeSyntax + #-} import Network.HTTP.Lucu.MIMEType.Guess import System -main = do [inFile, outFile] <- getArgs - extMap <- parseExtMapFile inFile +main ∷ IO () +main = do [inFile, outFile] ← getArgs + extMap ← parseExtMapFile inFile let src = serializeExtMap extMap diff --git a/data/Makefile b/data/Makefile index 584c8d6..c73c1f3 100644 --- a/data/Makefile +++ b/data/Makefile @@ -1,5 +1,18 @@ -../Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs: mime.types CompileMimeTypes - ./CompileMimeTypes $< $@ +../Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs: dist/DefaultExtensionMap.hs + cp -f $< $@ -CompileMimeTypes: CompileMimeTypes.hs - ghc --make $@ +dist/DefaultExtensionMap.hs: mime.types compiler + ./CompileMimeTypes $< $@.tmp + if diff $@ $@.tmp >/dev/null; then \ + rm -f $@.tmp; \ + else \ + mv -f $@.tmp $@; \ + fi + +compiler: + ghc -Wall --make CompileMimeTypes -i.. -odir dist -hidir dist + +clean: + rm -rf dist DefaultExtensionMap.hs CompileMimeTypes + +.PHONY: clean compiler diff --git a/data/mime.types b/data/mime.types index f65dd32..7b7601b 100644 --- a/data/mime.types +++ b/data/mime.types @@ -75,7 +75,6 @@ audio/mp4a-latm m4a m4p audio/mpeg mpga mp2 mp3 audio/x-ac3 ac3 audio/x-aiff aif aiff aifc -audio/x-au au snd audio/x-ircam sf audio/x-flac flac audio/x-mod 669 amf dsm gdm far imf it med mod mtm okt sam s3m stm stx ult xm @@ -133,11 +132,13 @@ text/richtext rtx text/rtf rtf text/sgml sgml sgm text/tab-separated-values tsv -text/uri-list ram +text/uri-list uni unis uri uris text/vnd.wap.wml wml text/vnd.wap.wmlscript wmls +text/x-c c h +text/x-c++ cc cpp cxx hpp hxx text/x-cabal cabal -text/x-haskell hs +text/x-haskell hs hsc lhs text/x-setext etx video/mp4 mp4 video/mpeg mpeg mpg mpe diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs index dacd4c3..d7e0071 100644 --- a/examples/HelloWorld.hs +++ b/examples/HelloWorld.hs @@ -1,40 +1,39 @@ +{-# LANGUAGE + OverloadedStrings + , UnicodeSyntax + #-} +import Control.Applicative +import Control.Monad.Unicode +import qualified Data.ByteString.Lazy.Char8 as Lazy import Network.HTTP.Lucu -main :: IO () +main ∷ IO () main = let config = defaultConfig { cnfServerPort = "9999" } - resources = mkResTree [ ( [] - , helloWorld ) - - , ( ["urandom"] - , staticFile "/dev/urandom" ) - - , ( ["inc"] - , staticDir "/usr/include" ) - ] - fallbacks = [ \ path -> case path of - ["hello"] -> return $ Just helloWorld - _ -> return Nothing + resources = mkResTree + [ ([] , helloWorld ) + , (["urandom"], staticFile "/dev/urandom") + , (["inc" ], staticDir "/usr/include" ) + ] + fallbacks = [ \ path → case path of + ["hello"] → return $ Just helloWorld + _ → return Nothing ] in do putStrLn "Access http://localhost:9999/ with your browser." runHttpd config resources fallbacks - -helloWorld :: ResourceDef +helloWorld ∷ ResourceDef helloWorld = emptyResource { resGet - = Just $ do --time <- liftIO $ getClockTime - --foundEntity (strongETag "abcde") time - setContentType $ read "text/hello" - outputChunk "Hello, " - outputChunk "World!\n" - outputChunk =<< getRemoteAddr' - + = Just $ do setContentType $ parseMIMEType "text/hello" + putChunk "Hello, " + putChunk "World!\n" + putChunks =≪ Lazy.pack <$> getRemoteAddr' , resPost - = Just $ do str1 <- inputChunk 3 - str2 <- inputChunk 3 - str3 <- inputChunk 3 - setContentType $ read "text/hello" - output ("[" ++ str1 ++ " - " ++ str2 ++ "#" ++ str3 ++ "]") - } \ No newline at end of file + = Just $ do str1 ← getChunk 3 + str2 ← getChunk 3 + str3 ← getChunk 3 + setContentType $ parseMIMEType "text/hello" + putChunks $ Lazy.fromChunks ["[", str1, " - ", str2, "#", str3, "]"] + } diff --git a/examples/Implanted.hs b/examples/Implanted.hs index 6842308..82d98e7 100644 --- a/examples/Implanted.hs +++ b/examples/Implanted.hs @@ -1,10 +1,12 @@ +{-# LANGUAGE + UnicodeSyntax + #-} import MiseRafturai import Network.HTTP.Lucu -main :: IO () +main ∷ IO () main = let config = defaultConfig { cnfServerPort = "9999" } resources = mkResTree [ ([], miseRafturai) ] in do putStrLn "Access http://localhost:9999/ with your browser." runHttpd config resources [] - \ No newline at end of file diff --git a/examples/ImplantedSmall.hs b/examples/ImplantedSmall.hs index af35b63..a985cae 100644 --- a/examples/ImplantedSmall.hs +++ b/examples/ImplantedSmall.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE + UnicodeSyntax + #-} import Network.HTTP.Lucu import SmallFile -main :: IO () +main ∷ IO () main = let config = defaultConfig { cnfServerPort = "9999" } resources = mkResTree [ ([], smallFile) ] in diff --git a/examples/Makefile b/examples/Makefile index abd928e..0902512 100644 --- a/examples/Makefile +++ b/examples/Makefile @@ -1,29 +1,32 @@ TARGETS = \ HelloWorld \ - MiseRafturai \ Implanted \ ImplantedSmall \ Multipart \ SSL \ $(NULL) +IMPLANT ?= ../dist/build/lucu-implant-file/lucu-implant-file + build: $(TARGETS) %: %.hs - ghc --make $@ -threaded -O3 -fwarn-unused-imports + ghc -Wall --make $@ -threaded -O3 -idist -odir dist -hidir dist run: build ./HelloWorld clean: - rm -f $(TARGETS) *.hi *.o MiseRafturai.hs SmallFile.hs - -MiseRafturai.hs: mise-rafturai.html - lucu-implant-file -m MiseRafturai -o $@ $< + rm -rf $(TARGETS) dist -ImplantedSmall.hs: SmallFile.hs +Implanted.hs: dist/MiseRafturai.hs +dist/MiseRafturai.hs: mise-rafturai.html $(IMPLANT) + mkdir -p dist + $(IMPLANT) -m MiseRafturai -o $@ $< -SmallFile.hs: small-file.txt - lucu-implant-file -m SmallFile -o $@ $< +ImplantedSmall.hs: dist/SmallFile.hs +dist/SmallFile.hs: small-file.txt $(IMPLANT) + mkdir -p dist + $(IMPLANT) -m SmallFile -o $@ $< .PHONY: build run clean diff --git a/examples/Multipart.hs b/examples/Multipart.hs index 69c4125..8ddc618 100644 --- a/examples/Multipart.hs +++ b/examples/Multipart.hs @@ -1,8 +1,15 @@ -import qualified Data.ByteString.Lazy.Char8 as L8 +{-# LANGUAGE + OverloadedStrings + , UnicodeSyntax + #-} +import qualified Data.ByteString.Lazy.Char8 as Lazy +import Control.Applicative +import Control.Monad.Unicode import Data.Maybe +import Data.Monoid.Unicode import Network.HTTP.Lucu -main :: IO () +main ∷ IO () main = let config = defaultConfig { cnfServerPort = "9999" } resources = mkResTree [ ([], resMain) ] in @@ -10,30 +17,25 @@ main = let config = defaultConfig { cnfServerPort = "9999" } runHttpd config resources [] -resMain :: ResourceDef +resMain ∷ ResourceDef resMain - = ResourceDef { - resUsesNativeThread = False - , resIsGreedy = False - , resGet - = Just $ do setContentType $ read "text/html" - output ("Multipart Form Test" ++ - "
" ++ - " Upload some file:" ++ - " " ++ - " " ++ - " " ++ - "
") - , resHead = Nothing + = emptyResource { + resGet + = Just $ do setContentType $ parseMIMEType "text/html" + putChunks $ "Multipart Form Test\n" + ⊕ "
\n" + ⊕ " Upload some file:\n" + ⊕ " \n" + ⊕ " \n" + ⊕ " \n" + ⊕ "
\n" , resPost - = Just $ do form <- inputForm defaultLimit - let text = fromMaybe L8.empty $ fmap fdContent $ lookup "text" form - file = fromMaybe L8.empty $ fmap fdContent $ lookup "file" form - fileName = fdFileName =<< lookup "file" form - setContentType $ read "text/plain" - outputChunk ("You entered \"" ++ L8.unpack text ++ "\".\n") - outputChunk ("You uploaded a " ++ show (L8.length file) ++ " bytes long file.\n") - output ("The file name is " ++ show fileName ++ ".\n") - , resPut = Nothing - , resDelete = Nothing - } \ No newline at end of file + = Just $ do form ← getForm Nothing + let text = fromMaybe (∅) $ fdContent <$> lookup "text" form + file = fromMaybe (∅) $ fdContent <$> lookup "file" form + fileName = fdFileName =≪ lookup "file" form + setContentType $ parseMIMEType "text/plain" + putChunks $ "You entered \"" ⊕ text ⊕ "\".\n" + putChunks $ "You uploaded a " ⊕ Lazy.pack (show $ Lazy.length file) ⊕ " bytes long file.\n" + putChunks $ "The file name is " ⊕ Lazy.pack (show fileName) ⊕ ".\n" + } diff --git a/examples/SSL.hs b/examples/SSL.hs index 436749f..6df2ab7 100644 --- a/examples/SSL.hs +++ b/examples/SSL.hs @@ -1,20 +1,26 @@ -{-# LANGUAGE PackageImports #-} -import Control.Monad -import "mtl" Control.Monad.Trans -import Data.Time.Clock -import Network.HTTP.Lucu -import OpenSSL -import OpenSSL.EVP.PKey -import OpenSSL.RSA +{-# LANGUAGE + OverloadedStrings + , PackageImports + , UnicodeSyntax + #-} +import Control.Applicative +import "mtl" Control.Monad.Trans +import Control.Monad.Unicode +import qualified Data.ByteString.Lazy.Char8 as Lazy +import Data.Time.Clock +import Network.HTTP.Lucu +import OpenSSL +import OpenSSL.EVP.PKey +import OpenSSL.RSA import qualified OpenSSL.Session as SSL -import OpenSSL.X509 +import OpenSSL.X509 -main :: IO () +main ∷ IO () main = withOpenSSL $ - do ctx <- SSL.context + do ctx ← SSL.context - key <- generateRSAKey 1024 3 Nothing - cert <- genCert key + key ← generateRSAKey 1024 3 Nothing + cert ← genCert key SSL.contextSetPrivateKey ctx key SSL.contextSetCertificate ctx cert SSL.contextSetDefaultCiphers ctx @@ -26,42 +32,32 @@ main = withOpenSSL $ , sslContext = ctx } } - resources = mkResTree [ ( [] - , helloWorld ) - ] + resources = mkResTree [ ([], helloWorld) ] putStrLn "Access https://localhost:9001/ with your browser." runHttpd config resources [] - -helloWorld :: ResourceDef +helloWorld ∷ ResourceDef helloWorld - = ResourceDef { - resUsesNativeThread = False - , resIsGreedy = False - , resGet - = Just $ do setContentType $ read "text/plain" - outputChunk "getRemoteCertificate = " - cert <- do c <- getRemoteCertificate - case c of - Just c -> liftIO $ printX509 c - Nothing -> return "Nothing" - outputChunk cert - , resHead = Nothing - , resPost = Nothing - , resPut = Nothing - , resDelete = Nothing + = emptyResource { + resGet + = Just $ do setContentType $ parseMIMEType "text/plain" + putChunk "getRemoteCertificate = " + cert ← do cert ← getRemoteCertificate + case cert of + Just c → liftIO $ Lazy.pack <$> printX509 c + Nothing → return "Nothing" + putChunks cert } - -genCert :: KeyPair k => k -> IO X509 +genCert ∷ KeyPair k ⇒ k → IO X509 genCert pkey - = do cert <- newX509 + = do cert ← newX509 setVersion cert 2 setSerialNumber cert 1 setIssuerName cert [("CN", "localhost")] setSubjectName cert [("CN", "localhost")] - setNotBefore cert =<< liftM (addUTCTime (-1)) getCurrentTime - setNotAfter cert =<< liftM (addUTCTime (365 * 24 * 60 * 60)) getCurrentTime + setNotBefore cert =≪ addUTCTime (-1) <$> getCurrentTime + setNotAfter cert =≪ addUTCTime (365 * 24 * 60 * 60) <$> getCurrentTime setPublicKey cert pkey signX509 cert pkey Nothing return cert \ No newline at end of file