dist
report.html
+Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs
+
+data/CompileMimeTypes
+
examples/HelloWorld
examples/Implanted
examples/ImplantedSmall
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
-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
| 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
{-
作られるファイルの例 (壓縮されない場合):
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..."
+ ]
------------------------------------------------------------------------------
-}
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 <pho at cielonegro dot org>
ImplantFile.hs
NEWS
data/CompileMimeTypes.hs
+ data/Makefile
data/mime.types
examples/HelloWorld.hs
examples/Implanted.hs
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
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
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)
Main-Is: ImplantFile.hs
+ Build-Depends:
+ SHA == 1.5.*,
+ zlib == 0.5.*
+
ghc-options:
-Wall
- -funbox-strict-fields
--Executable HelloWorld
-- Main-Is: HelloWorld.hs
--- | 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
{-# 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
--- /dev/null
+{-# 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''
--- /dev/null
+{-# 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"
+++ /dev/null
-{-# 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
+{-# 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
--- |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
- -- (<http://developer.gnome.org/doc/API/2.0/gnome-vfs-2.0/>)
- -- 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
}
+{-# 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
{-# 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
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
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
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
-- 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
-{-# 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:
+ -- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec13.html#sec13.3.3>
+ 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
+++ /dev/null
--- 本當にこんなものを自分で書く必要があったのだらうか。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
+{-# 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
+{-# 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 ]
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"
{-# 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)
| 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))
+{-# 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
-- >
-- > 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)
{-# 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
{-# 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
+++ /dev/null
--- |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")]
{-# 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
, 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
{-# LANGUAGE
- UnboxedTuples
+ DoAndIfThenElse
+ , FlexibleContexts
+ , OverloadedStrings
+ , RecordWildCards
+ , ScopedTypeVariables
, UnicodeSyntax
+ , ViewPatterns
#-}
+-- |Parse \"multipart/form-data\" based on RFC 2388:
+-- <http://www.faqs.org/rfcs/rfc2388.html>
+--
+-- 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
+-- <http://www.faqs.org/rfcs/rfc2047.html>, 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
{-# 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 []
{-# LANGUAGE
- BangPatterns
+ OverloadedStrings
, UnicodeSyntax
#-}
-- |This is an auxiliary parser utilities for parsing things related
-- 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"
{-# 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
{-# 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
--- /dev/null
+{-# LANGUAGE
+ DoAndIfThenElse
+ , OverloadedStrings
+ , RecordWildCards
+ , UnicodeSyntax
+ #-}
+-- |Provide functionalities to encode/decode MIME parameter values in
+-- character sets other than US-ASCII. See:
+-- <http://www.faqs.org/rfcs/rfc2231.html>
+--
+-- 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)
-{-# 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
| 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
{-# 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)
{-# 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:
--
-- 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
-- /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.
-- 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'
, 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
--- /dev/null
+{-# 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 ()
-{-# 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.
-- , ([\"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
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
-- 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
{-# 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
| 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.
{-# 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
( 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
{-# 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)
{-# 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
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.
component: Lucu
release: Lucu-1.0
reporter: PHO <pho@cielonegro.org>
-status: :unstarted
+status: :in_progress
disposition:
creation_time: 2011-07-29 16:01:14.666629 Z
references: []
- PHO <pho@cielonegro.org>
- assigned to release Lucu-1.0 from unassigned
- ""
-git_branch:
+- - 2011-07-30 11:17:25.622897 Z
+ - PHO <pho@cielonegro.org>
+ - changed status from unstarted to in_progress
+ - ""
+git_branch: attoparsec
component: Lucu
release: Lucu-1.0
reporter: PHO <pho@cielonegro.org>
-status: :unstarted
+status: :in_progress
disposition:
creation_time: 2010-03-12 06:56:06.939283 Z
references: []
- PHO <pho@cielonegro.org>
- assigned to release Lucu-1.0 from unassigned
- ""
-git_branch:
+- - 2011-07-30 11:17:19.173203 Z
+ - PHO <pho@cielonegro.org>
+ - changed status from unstarted to in_progress
+ - ""
+git_branch: attoparsec
--- /dev/null
+--- !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 <pho@cielonegro.org>
+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 <pho@cielonegro.org>
+ - created
+ - ""
+- - 2011-10-27 17:33:31.904875 Z
+ - PHO <pho@cielonegro.org>
+ - edited title
+ - Should be defaulted to off!
+git_branch:
component: Lucu
release: Lucu-1.0
reporter: PHO <pho@cielonegro.org>
-status: :unstarted
+status: :in_progress
disposition:
creation_time: 2011-07-30 04:39:53.073102 Z
references: []
- PHO <pho@cielonegro.org>
- created
- ""
-git_branch:
+- - 2011-07-30 11:17:28.677836 Z
+ - PHO <pho@cielonegro.org>
+ - changed status from unstarted to in_progress
+ - ""
+git_branch: attoparsec
--- /dev/null
+--- !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 <pho@cielonegro.org>
+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 <pho@cielonegro.org>
+ - created
+ - ""
+git_branch:
--- /dev/null
+--- !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 <pho@cielonegro.org>
+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 <pho@cielonegro.org>
+ - created
+ - ""
+- - 2011-10-17 02:48:13.741801 Z
+ - PHO <pho@cielonegro.org>
+ - commented
+ - We should implement name-based virtualhosts at the same time.
+- - 2011-10-17 02:51:52.045280 Z
+ - PHO <pho@cielonegro.org>
+ - commented
+ - FallbackHandler should be either a non-pure function (MonadIO) or a pure function returning Maybe ResourceDef.
+git_branch:
DITZ ?= ditz
CONFIGURE_ARGS ?= --disable-optimization
+HLINT_OPTS ?= --cross --report=dist/report.html
SETUP_FILE := $(wildcard Setup.*hs)
CABAL_FILE := $(wildcard *.cabal)
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 \
\( -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
#!/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
-../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
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
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
+{-# 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, "]"]
+ }
+{-# 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
+{-# LANGUAGE
+ UnicodeSyntax
+ #-}
import Network.HTTP.Lucu
import SmallFile
-main :: IO ()
+main ∷ IO ()
main = let config = defaultConfig { cnfServerPort = "9999" }
resources = mkResTree [ ([], smallFile) ]
in
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
-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
runHttpd config resources []
-resMain :: ResourceDef
+resMain ∷ ResourceDef
resMain
- = ResourceDef {
- resUsesNativeThread = False
- , resIsGreedy = False
- , resGet
- = Just $ do setContentType $ read "text/html"
- output ("<title>Multipart Form Test</title>" ++
- "<form action=\"/\" method=\"post\" enctype=\"multipart/form-data\">" ++
- " Upload some file:" ++
- " <input type=\"text\" name=\"text\">" ++
- " <input type=\"file\" name=\"file\">" ++
- " <input type=\"submit\" value=\"Submit\">" ++
- "</form>")
- , resHead = Nothing
+ = emptyResource {
+ resGet
+ = Just $ do setContentType $ parseMIMEType "text/html"
+ putChunks $ "<title>Multipart Form Test</title>\n"
+ ⊕ "<form action=\"/\" method=\"post\" enctype=\"multipart/form-data\">\n"
+ ⊕ " Upload some file:\n"
+ ⊕ " <input type=\"text\" name=\"text\">\n"
+ ⊕ " <input type=\"file\" name=\"file\">\n"
+ ⊕ " <input type=\"submit\" value=\"Submit\">\n"
+ ⊕ "</form>\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"
+ }
-{-# 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
, 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
projects / Lucu.git / commitdiff