Lucu (empty) → 0.1
raw patch · 38 files changed
+5755/−0 lines, 38 filesdep +HsOpenSSLdep +basedep +bytestringsetup-changed
Dependencies added: HsOpenSSL, base, bytestring, containers, dataenc, directory, haskell-src, hxt, mtl, network, stm, time, unix, zlib
Files
- COPYING +29/−0
- ImplantFile.hs +531/−0
- Lucu.cabal +91/−0
- Network/HTTP/Lucu.hs +86/−0
- Network/HTTP/Lucu/Abortion.hs +114/−0
- Network/HTTP/Lucu/Authorization.hs +67/−0
- Network/HTTP/Lucu/Chunk.hs +36/−0
- Network/HTTP/Lucu/Config.hs +72/−0
- Network/HTTP/Lucu/ContentCoding.hs +46/−0
- Network/HTTP/Lucu/DefaultPage.hs +168/−0
- Network/HTTP/Lucu/ETag.hs +58/−0
- Network/HTTP/Lucu/Format.hs +127/−0
- Network/HTTP/Lucu/Headers.hs +219/−0
- Network/HTTP/Lucu/HttpVersion.hs +50/−0
- Network/HTTP/Lucu/Httpd.hs +73/−0
- Network/HTTP/Lucu/Interaction.hs +180/−0
- Network/HTTP/Lucu/MIMEType.hs +74/−0
- Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs +183/−0
- Network/HTTP/Lucu/MIMEType/Guess.hs +120/−0
- Network/HTTP/Lucu/MultipartForm.hs +114/−0
- Network/HTTP/Lucu/Parser.hs +268/−0
- Network/HTTP/Lucu/Parser/Http.hs +125/−0
- Network/HTTP/Lucu/Postprocess.hs +183/−0
- Network/HTTP/Lucu/Preprocess.hs +173/−0
- Network/HTTP/Lucu/RFC1123DateTime.hs +109/−0
- Network/HTTP/Lucu/Request.hs +89/−0
- Network/HTTP/Lucu/RequestReader.hs +294/−0
- Network/HTTP/Lucu/Resource.hs +962/−0
- Network/HTTP/Lucu/Resource/Tree.hs +271/−0
- Network/HTTP/Lucu/Response.hs +202/−0
- Network/HTTP/Lucu/ResponseWriter.hs +174/−0
- Network/HTTP/Lucu/StaticFile.hs +149/−0
- Network/HTTP/Lucu/Utils.hs +75/−0
- Setup.hs +4/−0
- data/CompileMimeTypes.hs +18/−0
- data/mime.types +158/−0
- examples/HelloWorld.hs +44/−0
- examples/Makefile +19/−0
+ COPYING view
@@ -0,0 +1,29 @@+<!-- -*- xml -*-++Lucu はパブリックドメインに在ります。+Lucu is in the public domain.++See http://creativecommons.org/licenses/publicdomain/++-->++<rdf:RDF xmlns="http://web.resource.org/cc/"+ xmlns:dc="http://purl.org/dc/elements/1.1/"+ xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#">+ <Work rdf:about="http://cielonegro.org/Lucu.html">+ <dc:title>Lucu</dc:title>+ <dc:rights>+ <Agent>+ <dc:title>PHO</dc:title>+ </Agent>+ </dc:rights>+ <license rdf:resource="http://web.resource.org/cc/PublicDomain" />+ </Work>+ + <License rdf:about="http://web.resource.org/cc/PublicDomain">+ <permits rdf:resource="http://web.resource.org/cc/Reproduction" />+ <permits rdf:resource="http://web.resource.org/cc/Distribution" />+ <permits rdf:resource="http://web.resource.org/cc/DerivativeWorks" />+ </License>++</rdf:RDF>
+ ImplantFile.hs view
@@ -0,0 +1,531 @@+import Codec.Binary.Base64+import Codec.Compression.GZip+import Control.Monad+import Data.Bits+import qualified Data.ByteString.Lazy as Lazy (ByteString)+import qualified Data.ByteString.Lazy as L 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++data CmdOpt+ = OptOutput FilePath+ | OptModName String+ | OptSymName String+ | OptMIMEType String+ | OptETag String+ | OptHelp+ deriving (Eq, Show)+++options :: [OptDescr CmdOpt]+options = [ Option ['o'] ["output"]+ (ReqArg OptOutput "FILE")+ "Output to the FILE."++ , Option ['m'] ["module"]+ (ReqArg OptModName "MODULE")+ "Specify the resulting module name. (required)"++ , Option ['s'] ["symbol"]+ (ReqArg OptSymName "SYMBOL")+ "Specify the resulting symbol name."++ , Option ['t'] ["mime-type"]+ (ReqArg OptMIMEType "TYPE")+ "Specify the MIME Type of the file."++ , Option ['e'] ["etag"]+ (ReqArg OptETag "TAG")+ "Specify the ETag of the file."++ , 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 ""+ putStr $ usageInfo "Options:" options+ putStrLn ""+++main :: IO ()+main = withOpenSSL $+ do (opts, sources, errors) <- return . getOpt Permute options =<< getArgs++ when (not $ null errors)+ $ do mapM_ putStr errors+ exitWith $ ExitFailure 1++ when (any (\ x -> x == OptHelp) opts)+ $ do printUsage+ exitWith ExitSuccess++ when (null sources)+ $ do printUsage+ exitWith $ ExitFailure 1++ when (length sources >= 2)+ $ error "too many input files."++ generateHaskellSource opts (head sources)+++generateHaskellSource :: [CmdOpt] -> FilePath -> IO ()+generateHaskellSource opts srcFile+ = do modName <- getModuleName opts+ symName <- getSymbolName opts modName+ mimeType <- getMIMEType opts srcFile+ lastMod <- getLastModified srcFile+ input <- openInput srcFile+ output <- openOutput opts+ eTag <- getETag opts input++ let gzippedData = compressWith BestCompression input+ originalLen = L.length input+ gzippedLen = L.length gzippedData+ useGZip = originalLen > gzippedLen+ rawB64 = encode $ L.unpack input+ gzippedB64 = encode $ L.unpack 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 "Codec.Binary.Base64")+ False Nothing Nothing+ , HsImportDecl undefined (Module "Data.ByteString.Lazy")+ True (Just (Module "L")) Nothing+ , HsImportDecl undefined (Module "Data.Maybe")+ False Nothing 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 "L") (HsIdent "ByteString"))))+ , HsFunBind [HsMatch undefined (HsIdent "gzippedData")+ [] (HsUnGuardedRhs defGZippedData) []]+ ]++ defGZippedData :: HsExp+ defGZippedData + = HsApp (HsVar (Qual (Module "L") (HsIdent "pack")))+ (HsParen+ (HsApp (HsVar (UnQual (HsIdent "fromJust")))+ (HsParen+ (HsApp (HsVar (UnQual (HsIdent "decode")))+ (HsLit (HsString gzippedB64))))))++ declRawData :: [HsDecl]+ declRawData + = [ HsTypeSig undefined [HsIdent "rawData"]+ (HsQualType []+ (HsTyCon (Qual (Module "L") (HsIdent "ByteString"))))+ , HsFunBind [HsMatch undefined (HsIdent "rawData")+ [] (HsUnGuardedRhs defRawData) []]+ ]++ defRawData :: HsExp+ defRawData+ = HsApp (HsVar (Qual (Module "L") (HsIdent "pack")))+ (HsParen+ (HsApp (HsVar (UnQual (HsIdent "fromJust")))+ (HsParen+ (HsApp (HsVar (UnQual (HsIdent "decode")))+ (HsLit (HsString 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+ in+ case mimeTypeOpts of+ [] -> return defaultType+ (OptMIMEType mimeType):[] -> return $ read mimeType+ _ -> error "too many --mime-type options."+++getLastModified :: FilePath -> IO UTCTime+getLastModified "-" = getCurrentTime+getLastModified fpath = getFileStatus fpath+ >>= return . posixSecondsToUTCTime . fromRational . toRational . modificationTime+++getETag :: [CmdOpt] -> Lazy.ByteString -> IO String+getETag opts input+ = let eTagOpts = filter (\ x -> case x of+ OptETag _ -> True+ _ -> False) opts+ in+ case eTagOpts of+ [] -> getDigestByName "SHA1" >>= return . mkETagFromInput . fromJust+ (OptETag str):[] -> return str+ _ -> error "too many --etag options."+ where+ mkETagFromInput :: Digest -> String+ mkETagFromInput sha1 = "SHA-1:" ++ (toHex $ digestLBS sha1 input)++ toHex :: [Char] -> String+ toHex [] = ""+ toHex (x:xs) = hexByte (fromEnum x) ++ toHex xs++ hexByte :: Int -> String+ hexByte n+ = hex4bit ((n `shiftR` 4) .&. 0x0F) : hex4bit (n .&. 0x0F) : []++ hex4bit :: Int -> Char+ hex4bit n+ | n < 10 = (chr $ ord '0' + n )+ | n < 16 = (chr $ ord 'a' + n - 10)+ | otherwise = undefined+++openInput :: FilePath -> IO Lazy.ByteString+openInput "-" = L.getContents+openInput fpath = L.readFile fpath+++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."+++{-+ 作られるファイルの例 (壓縮されない場合):+ ------------------------------------------------------------------------------+ {- DO NOT EDIT THIS FILE.+ This file is automatically generated by the lucu-implant-file program.+ + Source: baz.png+ Original Length: 302 bytes+ Compressed Length: 453 bytes -- これは Compression: disabled の時には無い+ Compression: disabled+ MIME Type: image/png+ ETag: d41d8cd98f00b204e9800998ecf8427e+ Last Modified: 2007-11-05 13:53:42.231882 JST+ -}+ module Foo.Bar.Baz (baz) where+ import Codec.Binary.Base64+ import qualified Data.ByteString.Lazy as L+ import Data.Maybe+ import Data.Time+ import Network.HTTP.Lucu++ baz :: ResourceDef+ baz = ResourceDef {+ resUsesNativeThread = False+ , resIsGreedy = False+ , resGet+ = Just (do foundEntity entityTag lastModified+ setContentType contentType+ outputLBS rawData)+ , resHead = Nothing+ , resPost = Nothing+ , resPut = Nothing+ , resDelete = Nothing+ }++ entityTag :: ETag+ entityTag = strongETag "d41d8cd98f00b204e9800998ecf8427e"++ lastModified :: UTCTime+ lastModified = read "2007-11-05 04:47:56.008366 UTC"++ contentType :: MIMEType+ contentType = read "image/png"++ rawData :: L.ByteString+ rawData = L.pack (fromJust (decode "IyEvdXNyL2Jpbi9lbnYgcnVuZ2hjCgppbXBvcnQgRGlzdHJ..."))+ ------------------------------------------------------------------------------++ 壓縮される場合は次のやうに變はる:+ ------------------------------------------------------------------------------+ -- import に追加+ import Control.Monad+ import Codec.Compression.GZip++ -- 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+ , resPost = Nothing+ , resPut = Nothing+ , resDelete = Nothing+ }+ + -- rawData の代はりに gzippedData+ gzippedData :: L.ByteString+ gzippedData = L.pack (fromJust (decode "Otb/+DniOlRgAAAAYAAAAGAAAAB/6QOmToAEIGAAAAB..."))+ ------------------------------------------------------------------------------+ -}
+ Lucu.cabal view
@@ -0,0 +1,91 @@+Name: Lucu+Synopsis: HTTP Daemonic Library+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. It is intended to be+ used to create an efficient web-based 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 and so on.+Version: 0.1+License: PublicDomain+License-File: COPYING+Author: PHO <pho at cielonegro dot org>+Maintainer: PHO <pho at cielonegro dot org>+Stability: experimental+Homepage: http://cielonegro.org/Lucu.html+Category: Network+Tested-With: GHC == 6.8.1+Cabal-Version: >= 1.2+Build-Type: Simple++Extra-Source-Files:+ ImplantFile.hs+ data/CompileMimeTypes.hs+ data/mime.types+ examples/HelloWorld.hs+ examples/Makefile++Flag build-lucu-implant-file+ Description: Build the lucu-implant-file program.+ Default: True++Library+ Build-Depends:+ HsOpenSSL, base, bytestring, containers, dataenc, directory,+ haskell-src, hxt, mtl, network, stm, time, unix, zlib+ Exposed-Modules:+ Network.HTTP.Lucu+ Network.HTTP.Lucu.Abortion+ Network.HTTP.Lucu.Authorization+ Network.HTTP.Lucu.Config+ Network.HTTP.Lucu.ETag+ Network.HTTP.Lucu.HttpVersion+ Network.HTTP.Lucu.Httpd+ Network.HTTP.Lucu.MIMEType+ Network.HTTP.Lucu.MIMEType.DefaultExtensionMap+ Network.HTTP.Lucu.MIMEType.Guess+ Network.HTTP.Lucu.Parser+ Network.HTTP.Lucu.Parser.Http+ Network.HTTP.Lucu.RFC1123DateTime+ Network.HTTP.Lucu.Request+ Network.HTTP.Lucu.Resource+ Network.HTTP.Lucu.Resource.Tree+ Network.HTTP.Lucu.Response+ Network.HTTP.Lucu.StaticFile+ Network.HTTP.Lucu.Utils+ Other-Modules:+ Network.HTTP.Lucu.Chunk+ Network.HTTP.Lucu.ContentCoding+ Network.HTTP.Lucu.DefaultPage+ Network.HTTP.Lucu.Format+ 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.ResponseWriter+ Extensions:+ DeriveDataTypeable, UnboxedTuples+ ghc-options:+ -Wall+ -funbox-strict-fields++Executable lucu-implant-file+ if flag(build-lucu-implant-file)+ Buildable: True+ else+ Buildable: False+ Main-Is: ImplantFile.hs+ Extensions:+ UnboxedTuples+ ghc-options:+ -Wall+ -funbox-strict-fields++--Executable HelloWorld+-- Main-Is: HelloWorld.hs+-- Hs-Source-Dirs: ., examples+-- ghc-options: -fglasgow-exts -Wall -funbox-strict-fields -O3 -prof -auto-all
+ Network/HTTP/Lucu.hs view
@@ -0,0 +1,86 @@+-- | Lucu is an HTTP daemonic library. It can be embedded in any+-- Haskell program and runs in an independent thread.+--+-- Features:+--+-- [/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.+--+-- Lucu is not a replacement for Apache. It is intended to be used to+-- create an efficient web-based 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:+--+-- [/Logging/] Lucu doesn't log any requests from any clients.+--+-- [/Client Filtering/] Lucu always accepts any clients. No IP+-- filter is implemented.+--+-- [/SSL Support/] Lucu can handle only HTTP.+--+-- [/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+-- buffer-overflow but can possibly DoS it.+--+++module Network.HTTP.Lucu+ ( -- * Entry Point+ runHttpd++ -- * Configuration+ , module Network.HTTP.Lucu.Config++ -- * Resource Tree+ , ResourceDef(..)+ , ResTree+ , mkResTree++ -- * Resource Monad+ , module Network.HTTP.Lucu.Resource++ -- ** Things to be used in the Resource monad++ -- *** Status Code+ , StatusCode(..)++ -- *** Abortion+ , abort+ , abortPurely+ , abortA++ -- *** ETag+ , ETag(..)+ , strongETag+ , weakETag++ -- *** MIME Type+ , MIMEType(..)++ -- *** Authorization+ , AuthChallenge(..)+ , AuthCredential(..)+ + -- * Utility++ -- ** Static file handling+ , module Network.HTTP.Lucu.StaticFile+ )+ where++import Network.HTTP.Lucu.Abortion+import Network.HTTP.Lucu.Authorization+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.Tree+import Network.HTTP.Lucu.Response+import Network.HTTP.Lucu.StaticFile
+ Network/HTTP/Lucu/Abortion.hs view
@@ -0,0 +1,114 @@+-- #prune++-- |Aborting the computation of 'Network.HTTP.Lucu.Resource.Resource'+-- in any 'Prelude.IO' monads or arrows.+module Network.HTTP.Lucu.Abortion+ ( Abortion(..)+ , 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.Dynamic+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.XmlIOStateArrow+import Text.XML.HXT.DOM.XmlKeywords+++data Abortion = Abortion {+ aboStatus :: !StatusCode+ , aboHeaders :: !Headers+ , aboMessage :: !(Maybe String)+ } deriving (Show, Typeable)++-- |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 just throw a special+-- 'Control.Exception.DynException'. The exception will be caught by+-- the Lucu.+--+-- 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+ exc = DynException (toDyn abo)+ in+ liftIO $ throwIO exc+ 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 [(a_indent, v_1)]+ )+ 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''
+ Network/HTTP/Lucu/Authorization.hs view
@@ -0,0 +1,67 @@+-- #prune++-- |Manipulation of WWW authorization.+module Network.HTTP.Lucu.Authorization+ ( AuthChallenge(..)+ , AuthCredential(..)+ , Realm+ , UserID+ , Password++ , authCredentialP -- private+ )+ where++import qualified Codec.Binary.Base64 as B64+import Data.Maybe+import Network.HTTP.Lucu.Parser+import Network.HTTP.Lucu.Parser.Http+import Network.HTTP.Lucu.Utils++-- |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 == '=')+ let decoded = map (toEnum . fromEnum) (fromJust $ B64.decode b64)+ case break (== ':') decoded of+ (uid, ':' : password)+ -> return (BasicAuthCredential uid password)+ _ -> failP
+ Network/HTTP/Lucu/Chunk.hs view
@@ -0,0 +1,36 @@+module Network.HTTP.Lucu.Chunk+ ( chunkHeaderP -- Num a => Parser a+ , chunkFooterP -- Parser ()+ , chunkTrailerP -- Parser Headers+ )+ 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+ where+ extension :: Parser ()+ extension = do many $ do char ';'+ token+ char '='+ token <|> quotedStr+ return ()+{-# SPECIALIZE chunkHeaderP :: Parser Int #-}+++chunkFooterP :: Parser ()+chunkFooterP = crlf >> return ()+++chunkTrailerP :: Parser Headers+chunkTrailerP = headersP
+ Network/HTTP/Lucu/Config.hs view
@@ -0,0 +1,72 @@+-- |Configurations for the Lucu httpd like a port to listen.+module Network.HTTP.Lucu.Config+ ( Config(..)+ , 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 System.IO.Unsafe++-- |Configuration record for the Lucu httpd. You need to use+-- 'defaultConfig' or setup your own configuration to run the httpd.+data Config = Config {+ -- |A string which will be sent to clients as \"Server\" field.+ cnfServerSoftware :: !Strict.ByteString+ -- |The host name of the server. This value will be used in+ -- built-in pages like \"404 Not Found\".+ , cnfServerHost :: !Strict.ByteString+ -- |A port ID to listen to HTTP clients.+ , cnfServerPort :: !PortID+ -- |The maximum number of requests to accept in one connection+ -- simultaneously. 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+ -- |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 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+ -- 'Network.HTTP.Lucu.Abortion.abort'.+ , 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. + -- + -- 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+ }++-- |The default configuration. Generally you can use this value as-is,+-- or possibly you just want to replace the 'cnfServerSoftware' and+-- 'cnfServerPort'.+defaultConfig :: Config+defaultConfig = Config {+ cnfServerSoftware = C8.pack "Lucu/1.0"+ , cnfServerHost = C8.pack (unsafePerformIO getHostName)+ , cnfServerPort = Service "http"+ , cnfMaxPipelineDepth = 100+ , cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB+ , cnfMaxOutputChunkLength = 5 * 1024 * 1024 -- 5 MiB+ , cnfDumpTooLateAbortionToStderr = True+ , cnfExtToMIMEType = defaultExtensionMap+ }
+ Network/HTTP/Lucu/ContentCoding.hs view
@@ -0,0 +1,46 @@+module Network.HTTP.Lucu.ContentCoding+ ( acceptEncodingListP+ , normalizeCoding+ , unnormalizeCoding+ , orderAcceptEncodings+ )+ where++import Data.Char+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+normalizeCoding coding+ = case map toLower coding of+ "x-gzip" -> "gzip"+ "x-compress" -> "compress"+ other -> other+++unnormalizeCoding :: String -> String+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)+ = fromMaybe 0 q1 `compare` fromMaybe 0 q2
+ Network/HTTP/Lucu/DefaultPage.hs view
@@ -0,0 +1,168 @@+module Network.HTTP.Lucu.DefaultPage+ ( getDefaultPage+ , writeDefaultPage+ , 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+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.XmlIOStateArrow+import Text.XML.HXT.DOM.TypeDefs+import Text.XML.HXT.DOM.XmlKeywords+++getDefaultPage :: Config -> Maybe Request -> Response -> String+getDefaultPage conf req res+ = conf `seq` req `seq` res `seq`+ let msgA = getMsg req res+ in+ unsafePerformIO $+ do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA+ >>>+ writeDocumentToString [ (a_indent, v_1) ]+ )+ return xmlStr+++writeDefaultPage :: Interaction -> STM ()+writeDefaultPage itr+ = itr `seq`+ -- 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+ = conf `seq` status `seq` msgA `seq`+ let (# sCode, sMsg #) = statusCode status+ sig = C8.unpack (cnfServerSoftware conf)+ ++ " at "+ ++ C8.unpack (cnfServerHost conf)+ ++ ( case cnfServerPort conf of+ Service serv -> ", service " ++ serv+ PortNumber num -> ", port " ++ show num+ UnixSocket path -> ", unix socket " ++ show path+ )+ in ( eelem "/"+ += ( eelem "html"+ += sattr "xmlns" "http://www.w3.org/1999/xhtml"+ += ( eelem "head"+ += ( eelem "title"+ += txt (fmtDec 3 sCode ++ " " ++ C8.unpack sMsg)+ ))+ += ( eelem "body"+ += ( eelem "h1"+ += txt (C8.unpack sMsg)+ )+ += ( 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+ = req `seq` res `seq`+ case resStatus res of+ -- 1xx は body を持たない+ -- 2xx の body は補完しない++ -- 3xx+ MovedPermanently+ -> 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 ")+ <+>+ eelem "a" += sattr "href" loc+ += txt loc+ <+>+ txt ". This is not a permanent relocation."++ SeeOther+ -> 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 ")+ <+>+ eelem "a" += sattr "href" loc+ += txt loc+ <+>+ txt "."++ -- 4xx+ BadRequest+ -> txt "The server could not understand the request you sent."++ Unauthorized+ -> txt ("You need a valid authentication to access " ++ path)++ Forbidden+ -> txt ("You don't have permission to access " ++ path)++ NotFound+ -> 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.")++ RequestEntityTooLarge+ -> txt ("The request entity you sent for " ++ path ++ " was too big to accept.")++ RequestURITooLarge+ -> txt "The request URI you sent was too big to accept."++ -- 5xx+ InternalServerError+ -> txt ("An internal server error has occured during the process of your request to " ++ path)++ ServiceUnavailable+ -> txt "The service is temporarily unavailable. Try later."++ _ -> none++ + where+ 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 #-}
+ Network/HTTP/Lucu/ETag.hs view
@@ -0,0 +1,58 @@+-- #prune++-- |Manipulation of entity tags.+module Network.HTTP.Lucu.ETag+ ( ETag(..)+ , strongETag+ , weakETag+ , eTagP+ , eTagListP+ )+ where++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.+data ETag = ETag {+ -- |The weakness flag. Weak tags looks like W\/\"blahblah\" and+ -- strong tags are like \"blahblah\".+ 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+-- 'Network.HTTP.Lucu.StaticFile.generateETagFromFile'.+strongETag :: String -> ETag+strongETag = ETag False++-- |This is equivalent to @'ETag' 'Prelude.True'@.+weakETag :: String -> ETag+weakETag = ETag True+++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
+ Network/HTTP/Lucu/Format.hs view
@@ -0,0 +1,127 @@+-- 本當にこんなものを自分で書く必要があったのだらうか。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
+ Network/HTTP/Lucu/Headers.hs view
@@ -0,0 +1,219 @@+module Network.HTTP.Lucu.Headers+ ( Headers+ , HasHeaders(..)++ , noCaseCmp+ , noCaseEq++ , emptyHeaders+ , toHeaders+ , fromHeaders++ , headersP+ , hPutHeaders+ )+ 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 qualified Data.Map as M+import Data.Word+import Foreign.ForeignPtr+import Foreign.Ptr+import Foreign.Storable+import Network.HTTP.Lucu.Parser+import Network.HTTP.Lucu.Parser.Http+import Network.HTTP.Lucu.Utils+import System.IO++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 toLower (w2c c1) `compare` toLower (w2c 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+++class HasHeaders a where+ getHeaders :: a -> Headers+ setHeaders :: a -> Headers -> a++ getHeader :: Strict.ByteString -> a -> Maybe Strict.ByteString+ getHeader key a+ = key `seq` a `seq`+ M.lookup (toNCBS key) (getHeaders a)++ deleteHeader :: Strict.ByteString -> a -> a+ deleteHeader key a+ = key `seq` a `seq`+ setHeaders a $ M.delete (toNCBS key) (getHeaders a)++ setHeader :: Strict.ByteString -> Strict.ByteString -> a -> a+ 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+ where+ merge :: Strict.ByteString -> Strict.ByteString -> Strict.ByteString+ -- カンマ區切りである事を假定する。RFC ではカンマ區切りに出來ない+ -- ヘッダは複數個あってはならない事になってゐる。+ 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]+++fromHeaders :: Headers -> [(Strict.ByteString, Strict.ByteString)]+fromHeaders hs = [(fromNCBS a, b) | (a, b) <- M.toList hs]+++{-+ message-header = field-name ":" [ field-value ]+ field-name = token+ field-value = *( field-content | LWS )+ field-content = <field-value を構成し、*TEXT あるいは+ token, separators, quoted-string を連結+ したものから成る OCTET>++ field-value の先頭および末尾にある LWS は全て削除され、それ以外の+ LWS は單一の SP に變換される。+-}+headersP :: Parser Headers+headersP = do xs <- 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 = foldr (++) []+ . map (\ s -> if head s == ' ' then+ " "+ else+ s)+ . group+ . map (\ c -> if isWhiteSpace c+ then ' '+ else c)+++hPutHeaders :: Handle -> Headers -> IO ()+hPutHeaders h hds+ = h `seq` hds `seq`+ mapM_ putH (M.toList hds) >> C8.hPut h (C8.pack "\r\n")+ where+ putH :: (NCBS, Strict.ByteString) -> IO ()+ putH (name, value)+ = name `seq` value `seq`+ do C8.hPut h (fromNCBS name)+ C8.hPut h (C8.pack ": ")+ C8.hPut h value+ C8.hPut h (C8.pack "\r\n")
+ Network/HTTP/Lucu/HttpVersion.hs view
@@ -0,0 +1,50 @@+-- #prune++-- |Manipulation of HTTP version string.+module Network.HTTP.Lucu.HttpVersion+ ( HttpVersion(..)+ , httpVersionP+ , hPutHttpVersion+ )+ where++import qualified Data.ByteString.Char8 as C8+import Network.HTTP.Lucu.Parser+import Prelude hiding (min)+import System.IO++-- |@'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++instance Ord HttpVersion where+ (HttpVersion majA minA) `compare` (HttpVersion majB minB)+ | majA > majB = GT+ | majA < majB = LT+ | minA > minB = GT+ | minA < minB = LT+ | otherwise = EQ+++httpVersionP :: Parser HttpVersion+httpVersionP = do string "HTTP/"+ major <- many1 digit+ char '.'+ minor <- many1 digit+ return $ HttpVersion (read' major) (read' minor)+ where+ read' "1" = 1 -- この二つが+ read' "0" = 0 -- 壓倒的に頻出する+ read' s = read s+++hPutHttpVersion :: Handle -> HttpVersion -> IO ()+hPutHttpVersion h (HttpVersion maj min)+ = h `seq`+ do C8.hPut h (C8.pack "HTTP/")+ hPutStr h (show maj)+ hPutChar h '.'+ hPutStr h (show min)
+ Network/HTTP/Lucu/Httpd.hs view
@@ -0,0 +1,73 @@+-- |The entry point of Lucu httpd.+module Network.HTTP.Lucu.Httpd+ ( FallbackHandler+ , runHttpd+ )+ where++import Control.Concurrent+import Network+import qualified Network.Socket as So+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 System.IO+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.+--+-- 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.+--+-- Example:+--+-- > module Main where+-- > import Network.HTTP.Lucu+-- > +-- > main :: IO ()+-- > main = let config = defaultConfig+-- > resources = mkResTree [ ([], helloWorld) ]+-- > in+-- > 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+-- > }+runHttpd :: Config -> ResTree -> [FallbackHandler] -> IO ()+runHttpd cnf tree fbs+ = withSocketsDo $+ do installHandler sigPIPE Ignore Nothing+ so <- listenOn (cnfServerPort cnf)+ loop so+ where+ loop :: Socket -> IO ()+ loop so+ -- 本當は Network.accept を使ひたいが、このアクションは勝手に+ -- リモートのIPを逆引きするので、使へない。+ = do (h, addr) <- accept' so+ tQueue <- newInteractionQueue+ readerTID <- forkIO $ requestReader cnf tree fbs h addr tQueue+ _writerTID <- forkIO $ responseWriter cnf h tQueue readerTID+ loop so++ accept' :: Socket -> IO (Handle, So.SockAddr)+ accept' soSelf+ = do (soPeer, addr) <- So.accept soSelf+ hPeer <- So.socketToHandle soPeer ReadWriteMode+ return (hPeer, addr)
+ Network/HTTP/Lucu/Interaction.hs view
@@ -0,0 +1,180 @@+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++data Interaction = Interaction {+ itrConfig :: !Config+ , itrRemoteAddr :: !SockAddr+ , 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 -> SockAddr -> Maybe Request -> IO Interaction+newInteraction conf addr req+ = conf `seq` addr `seq` req `seq`+ 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+ , itrRemoteAddr = addr+ , 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+ = itr `seq` accessor `seq` value `seq`+ writeTVar (accessor itr) value+++readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b+readItr itr accessor reader+ = itr `seq` accessor `seq` reader `seq`+ readTVar (accessor itr) >>= return . reader+++readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)+readItrF itr accessor reader+ = itr `seq` accessor `seq` reader `seq`+ readItr itr accessor (fmap reader)+{-# SPECIALIZE readItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> b) -> STM (Maybe b) #-}+++updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()+updateItr itr accessor updator+ = itr `seq` accessor `seq` updator `seq`+ do old <- readItr itr accessor id+ writeItr itr accessor (updator old)+++updateItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()+updateItrF itr accessor updator+ = itr `seq` accessor `seq` updator `seq`+ updateItr itr accessor (fmap updator)+{-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-}
+ Network/HTTP/Lucu/MIMEType.hs view
@@ -0,0 +1,74 @@+-- #prune++-- |Manipulation of MIME Types.+module Network.HTTP.Lucu.MIMEType+ ( MIMEType(..)+ , parseMIMEType+ , mimeTypeP+ , mimeTypeListP+ )+ where++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\".+data MIMEType = MIMEType {+ mtMajor :: !String+ , mtMinor :: !String+ , mtParams :: ![ (String, String) ]+ } 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+++instance Read MIMEType where+ readsPrec _ s = [(parseMIMEType s, "")]++-- |Parse 'MIMEType' from a 'Prelude.String'. 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+ where+ paramP :: Parser (String, String)+ paramP = do many lws+ char ';'+ many lws+ name <- token+ char '='+ value <- token <|> quotedStr+ return (name, value)++mimeTypeListP :: Parser [MIMEType]+mimeTypeListP = allowEOF $! listOf mimeTypeP
+ Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs view
@@ -0,0 +1,183 @@+-- |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 "application/x-wavpack"),+ ("wvc", read "application/x-wavpack-correction"),+ ("wvp", read "application/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")]
+ Network/HTTP/Lucu/MIMEType/Guess.hs view
@@ -0,0 +1,120 @@+-- |MIME Type guessing by a file extension. This is a poor man's way+-- of guessing MIME Types. It is simple and fast.+--+-- In general you don't have to use this module directly.+module Network.HTTP.Lucu.MIMEType.Guess+ ( ExtMap+ , guessTypeByFileName++ , parseExtMapFile+ , serializeExtMap+ )+ where++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 System.IO++-- |'Data.Map.Map' from extension to MIME Type.+type ExtMap = Map String MIMEType++-- |Guess the MIME Type of file.+guessTypeByFileName :: ExtMap -> FilePath -> Maybe MIMEType+guessTypeByFileName extMap fpath+ = extMap `seq` fpath `seq`+ let ext = last $ splitBy (== '.') fpath+ in+ M.lookup ext extMap >>= return++-- |Read an Apache mime.types and parse it.+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 ++ ")")+++extMapP :: Parser [ (MIMEType, [String]) ]+extMapP = do xs <- many (comment <|> validLine <|> emptyLine)+ eof+ return $ catMaybes xs+ where+ spc = oneOf " \t"++ comment = do many spc+ char '#'+ many $ satisfy (/= '\n')+ return Nothing++ validLine = do many spc+ mime <- mimeTypeP+ many spc+ exts <- sepBy token (many spc)+ return $ Just (mime, exts)++ emptyLine = oneOf " \t\n" >> return Nothing+++compile :: [ (MIMEType, [String]) ] -> Map String MIMEType+compile = M.fromList . foldr (++) [] . map tr+ where+ tr :: (MIMEType, [String]) -> [ (String, MIMEType) ]+ tr (mime, exts) = [ (ext, mime) | ext <- exts ]++-- |@'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@.+--+-- The module "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap" is+-- surely generated using this function.+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"+ in+ comment ++ prettyPrint hsModule ++ "\n"+ where+ records :: [HsExp]+ records = map record $ M.assocs extMap++ record :: (String, MIMEType) -> HsExp+ record (ext, mime)+ = HsTuple [HsLit (HsString ext), mimeToExp mime]+ + mimeToExp :: MIMEType -> HsExp+ mimeToExp mt+ = HsApp (HsVar (UnQual (HsIdent "read"))) (HsLit (HsString $ show mt))
+ Network/HTTP/Lucu/MultipartForm.hs view
@@ -0,0 +1,114 @@+module Network.HTTP.Lucu.MultipartForm+ ( multipartFormP+ )+ where++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 String++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, String)]+multipartFormP boundary+ = do parts <- many (partP boundary)+ string "--"+ string boundary+ string "--"+ crlf+ eof+ return $ map partToPair 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 String+bodyP boundary+ = do body <- many $+ do notFollowedBy $ do crlf+ string "--"+ string boundary+ anyChar+ crlf+ return body+++partToPair :: Part -> (String, String)+partToPair part@(Part _ body)+ = 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, _ #)+ -> (getName dispo, body)+ (# _, _ #)+ -> abortPurely BadRequest []+ (Just $ "Unparsable Content-Disposition: " ++ C8.unpack dispoStr)+ where+ getName :: ContDispo -> String+ getName dispo@(ContDispo dType dParams)+ | map toLower dType == "form-data"+ = case find ((== "name") . map toLower . fst) dParams of+ Just (_, name) -> name+ Nothing + -> abortPurely BadRequest []+ (Just $ "form-data without name: " ++ show dispo)+ | otherwise+ = abortPurely BadRequest []+ (Just $ "Content-Disposition type is not form-data: " ++ dType)+++contDispoP :: Parser ContDispo+contDispoP = do dispoType <- token+ params <- allowEOF $ many paramP+ return $ ContDispo dispoType params+ where+ paramP :: Parser (String, String)+ paramP = do many lws+ char ';'+ many lws+ name <- token+ char '='+ value <- token <|> quotedStr+ return (name, value)
+ Network/HTTP/Lucu/Parser.hs view
@@ -0,0 +1,268 @@+-- |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.+module Network.HTTP.Lucu.Parser+ ( Parser+ , ParserResult(..)++ , failP++ , parse+ , parseStr++ , anyChar+ , eof+ , allowEOF+ , satisfy+ , char+ , string+ , (<|>)+ , oneOf+ , digit+ , hexDigit+ , notFollowedBy+ , many+ , many1+ , count+ , option+ , sepBy+ , sepBy1++ , sp+ , ht+ , crlf+ )+ where++import Control.Monad.State.Strict+import qualified Data.ByteString.Lazy as Lazy (ByteString)+import qualified Data.ByteString.Lazy.Char8 as B hiding (ByteString)++-- |@'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 = x `seq` Parser $! return $! Success x+ fail _ = Parser $! return $! IllegalInput++-- |@'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 である必要有り。+ = p `seq`+ let (result, state') = runState (runParser p) (PST input True)+ in+ result `seq` (# 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+ = p `seq` -- 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 = f `seq`+ 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 = f `seq`+ do c <- anyChar+ if f $! c then+ return c+ else+ failP+++char :: Char -> Parser Char+char c = c `seq` satisfy (== c)+++string :: String -> Parser String+string str = str `seq`+ do mapM_ char str+ return str+++infixr 0 <|>++-- |This is the backtracking alternation. There is no non-backtracking+-- equivalent.+(<|>) :: Parser a -> Parser a -> Parser a+f <|> g+ = f `seq` g `seq`+ 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+ return ReachedEOF+ else+ do put saved+ runParser g+++oneOf :: [Char] -> Parser Char+oneOf = foldl (<|>) failP . map char+++notFollowedBy :: Parser a -> Parser ()+notFollowedBy p+ = p `seq`+ 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 :: Parser a -> Parser [a]+many p = p `seq`+ do x <- p+ xs <- many p+ return (x:xs)+ <|>+ return []+++many1 :: Parser a -> Parser [a]+many1 p = p `seq`+ do x <- p+ xs <- many p+ return (x:xs)+++count :: Int -> Parser a -> Parser [a]+count 0 _ = return []+count n p = n `seq` p `seq`+ do x <- p+ xs <- count (n-1) p+ return (x:xs)++-- def may be a _|_+option :: a -> Parser a -> Parser a+option def p = p `seq`+ p <|> return def+++sepBy :: Parser a -> Parser sep -> Parser [a]+sepBy p sep = p `seq` sep `seq`+ sepBy1 p sep <|> return []+++sepBy1 :: Parser a -> Parser sep -> Parser [a]+sepBy1 p sep = p `seq` sep `seq`+ 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"
+ Network/HTTP/Lucu/Parser/Http.hs view
@@ -0,0 +1,125 @@+-- |This is an auxiliary parser utilities for parsing things related+-- on HTTP protocol.+--+-- In general you don't have to use this module directly.+module Network.HTTP.Lucu.Parser.Http+ ( isCtl+ , isSeparator+ , isChar+ , isToken+ , listOf+ , token+ , lws+ , text+ , separator+ , quotedStr+ , qvalue+ )+ where++import Data.List+import Network.HTTP.Lucu.Parser++-- |@'isCtl' c@ is 'Prelude.False' iff @0x20 <= @c@ < 0x7F@.+isCtl :: Char -> Bool+isCtl c+ | c < '\x1f' = True+ | c >= '\x7f' = True+ | otherwise = False++-- |@'isSeparator' c@ is 'Prelude.True' iff c is one of 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'+-- 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 = p `seq`+ 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 (\ c -> not (isCtl c))++-- |'separator' accepts one character which satisfies 'isSeparator'.+separator :: Parser Char+separator = satisfy isSeparator++-- |'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+ where+ qdtext = do c <- satisfy (/= '"')+ return [c]++ quotedPair = do char '\\'+ c <- satisfy isChar+ return [c]++-- |'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)
+ Network/HTTP/Lucu/Postprocess.hs view
@@ -0,0 +1,183 @@+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 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.RFC1123DateTime+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+ = itr `seq`+ do reqM <- readItr itr itrRequest id+ res <- readItr itr itrResponse id+ let sc = resStatus res++ when (not $ 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 -> if value `noCaseEq` C8.pack "close" then+ writeItr itr itrWillClose True+ else+ return ()++ 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+ = name `seq`+ readItr itr itrResponse $ getHeader name++ updateRes :: (Response -> Response) -> STM ()+ updateRes updator + = updator `seq`+ updateItr itr itrResponse updator+++completeUnconditionalHeaders :: Config -> Response -> IO Response+completeUnconditionalHeaders conf res+ = conf `seq` res `seq`+ return res >>= compServer >>= compDate >>= return+ 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 $ formatHTTPDateTime now+ writeIORef cache (now, dateStr)+ return dateStr+ where+ mostlyEq :: UTCTime -> UTCTime -> Bool+ mostlyEq a b+ = if utctDay a == utctDay b then+ fromEnum (utctDayTime a) == fromEnum (utctDayTime b)+ else+ False
+ Network/HTTP/Lucu/Preprocess.hs view
@@ -0,0 +1,173 @@+module Network.HTTP.Lucu.Preprocess+ ( 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+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+ = itr `seq`+ 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+ where+ setStatus :: StatusCode -> STM ()+ setStatus status+ = status `seq`+ updateItr itr itrResponse+ $! \ res -> res {+ resStatus = status+ }++ completeAuthority :: Request -> STM ()+ completeAuthority req+ = req `seq`+ 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 = case cnfServerPort conf of+ PortNumber n -> Just (fromIntegral n :: Int)+ _ -> Nothing+ portStr+ = case port of+ Just 80 -> Just ""+ Just n -> Just $ ":" ++ show n+ Nothing -> Nothing+ case portStr of+ Just str -> updateAuthority host (C8.pack str)+ -- FIXME: このエラーの原因は、listen してゐるソ+ -- ケットが INET でない故にポート番號が分からな+ -- い事だが、その事をどうにかして通知した方が良+ -- いと思ふ。stderr？+ Nothing -> setStatus InternalServerError+ else+ do 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+ = host `seq` portStr `seq`+ 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+ = req `seq`+ 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 -> if value `noCaseEq` C8.pack "identity" then+ return ()+ else+ 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 -> if value `noCaseEq` C8.pack "close" then+ writeItr itr itrWillClose True+ else+ return ()
+ Network/HTTP/Lucu/RFC1123DateTime.hs view
@@ -0,0 +1,109 @@+-- |This module parses and prints RFC 1123 Date and Time string.+-- +-- In general you don't have to use this module directly.+module Network.HTTP.Lucu.RFC1123DateTime+ ( formatRFC1123DateTime+ , formatHTTPDateTime+ , parseHTTPDateTime+ )+ where++import Control.Monad+import Data.Time+import Data.Time.Calendar.WeekDate+import qualified Data.ByteString.Lazy as Lazy (ByteString)+import Network.HTTP.Lucu.Format+import Network.HTTP.Lucu.Parser+import Prelude hiding (min)+++monthStr :: [String]+monthStr = ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"]++weekStr :: [String]+weekStr = ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"]++-- |Format a 'System.Time.CalendarTime' to RFC 1123 Date and Time+-- string.+formatRFC1123DateTime :: ZonedTime -> String+formatRFC1123DateTime zonedTime+ = let localTime = zonedTimeToLocalTime zonedTime+ timeZone = zonedTimeZone zonedTime+ (year, month, day) = toGregorian (localDay localTime)+ (_, _, week) = toWeekDate (localDay localTime)+ timeOfDay = localTimeOfDay localTime+ in+ id (weekStr !! (week - 1))+ ++ ", " +++ fmtDec 2 day+ ++ " " +++ id (monthStr !! (month - 1))+ ++ " " +++ fmtDec 4 (fromInteger year)+ ++ " " +++ fmtDec 2 (todHour timeOfDay)+ ++ ":" +++ fmtDec 2 (todMin timeOfDay)+ ++ ":" +++ fmtDec 2 (floor (todSec timeOfDay))+ ++ " " +++ id (timeZoneName timeZone)+ ++-- |Format a 'System.Time.ClockTime' to HTTP Date and Time. Time zone+-- will be always UTC but prints as GMT.+formatHTTPDateTime :: UTCTime -> String+formatHTTPDateTime utcTime+ = let timeZone = TimeZone 0 False "GMT"+ zonedTime = utcToZonedTime timeZone utcTime+ in+ formatRFC1123DateTime zonedTime+++-- |Parse an HTTP Date and Time.+--+-- Limitation: RFC 2616 (HTTP\/1.1) says we must accept these three+-- formats:+--+-- * @Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123@+--+-- * @Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036@+--+-- * @Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() format@+--+-- ...but currently this function only supports the RFC 1123+-- format. This is a violation of RFC 2616 so this should be fixed+-- later. What a bother!+parseHTTPDateTime :: Lazy.ByteString -> Maybe UTCTime+parseHTTPDateTime src+ = case parse httpDateTime src of+ (# Success ct, _ #) -> Just ct+ (# _ , _ #) -> Nothing+++httpDateTime :: Parser UTCTime+httpDateTime = do foldl (<|>) failP (map string weekStr)+ char ','+ char ' '+ day <- liftM read (count 2 digit)+ char ' '+ mon <- foldl (<|>) failP (map tryEqToFst (zip monthStr [1..]))+ char ' '+ year <- liftM read (count 4 digit)+ char ' '+ hour <- liftM read (count 2 digit)+ char ':'+ min <- liftM read (count 2 digit)+ char ':'+ sec <- liftM read (count 2 digit) :: Parser Int+ char ' '+ string "GMT"+ eof+ let julianDay = fromGregorian year mon day+ timeOfDay = TimeOfDay hour min (fromIntegral sec)+ utcTime = UTCTime julianDay (timeOfDayToTime timeOfDay)+ return utcTime+ where+ tryEqToFst :: (String, a) -> Parser a+ tryEqToFst (str, a) = string str >> return a+
+ Network/HTTP/Lucu/Request.hs view
@@ -0,0 +1,89 @@+-- #prune++-- |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+ )+ 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++-- |This is the definition of HTTP request methods, which shouldn't+-- require any description.+data Method = OPTIONS+ | GET+ | HEAD+ | POST+ | PUT+ | DELETE+ | TRACE+ | CONNECT+ | ExtensionMethod !String+ deriving (Eq, Show)++-- |This is the definition of HTTP reqest.+data Request+ = Request {+ reqMethod :: !Method+ , reqURI :: !URI+ , reqVersion :: !HttpVersion+ , reqHeaders :: !Headers+ }+ deriving (Show, Eq)++instance HasHeaders Request where+ getHeaders = reqHeaders+ setHeaders req hdr = req { reqHeaders = hdr }+++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)+++methodP :: Parser Method+methodP = (let methods = [ ("OPTIONS", OPTIONS)+ , ("GET" , GET )+ , ("HEAD" , HEAD )+ , ("POST" , POST )+ , ("PUT" , PUT )+ , ("DELETE" , DELETE )+ , ("TRACE" , TRACE )+ , ("CONNECT", CONNECT)+ ]+ in foldl (<|>) failP $ map (\ (str, mth)+ -> string str >> return mth) methods)+ <|>+ token >>= return . ExtensionMethod+++uriP :: Parser URI+uriP = do str <- many1 $ satisfy (\ c -> not (isCtl c || c == ' '))+ case parseURIReference str of+ Nothing -> failP+ Just uri -> return uri
+ Network/HTTP/Lucu/RequestReader.hs view
@@ -0,0 +1,294 @@+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 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.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+++requestReader :: Config -> ResTree -> [FallbackHandler] -> Handle -> SockAddr -> InteractionQueue -> IO ()+requestReader cnf tree fbs h addr tQueue+ = cnf `seq` tree `seq` fbs `seq` h `seq` addr `seq` tQueue `seq`+ do catch (do input <- B.hGetContents h+ acceptRequest input) $ \ exc ->+ case exc of+ IOException _ -> return ()+ AsyncException ThreadKilled -> return ()+ BlockedIndefinitely -> putStrLn "requestReader: blocked indefinitely"+ _ -> print exc+ where+ acceptRequest :: ByteString -> IO ()+ acceptRequest input+ -- キューに最大パイプライン深度以上のリクエストが溜まってゐる+ -- 時は、それが限度以下になるまで待つ。+ = {-# SCC "acceptRequest" #-}+ do atomically $ do queue <- readTVar tQueue+ when (S.length queue >= cnfMaxPipelineDepth cnf)+ retry++ -- リクエストを讀む。パースできない場合は直ちに 400 Bad+ -- Request 應答を設定し、それを出力してから切斷するやう+ -- に ResponseWriter に通知する。+ case parse requestP input of+ (# Success req , input' #) -> acceptParsableRequest req input'+ (# IllegalInput, _ #) -> acceptNonparsableRequest BadRequest+ (# ReachedEOF , _ #) -> acceptNonparsableRequest BadRequest++ acceptNonparsableRequest :: StatusCode -> IO ()+ acceptNonparsableRequest status+ = {-# SCC "acceptNonparsableRequest" #-}+ do itr <- newInteraction cnf addr Nothing+ atomically $ do updateItr itr itrResponse+ $ \ res -> res {+ resStatus = status+ }+ writeItr itr itrWillClose True+ writeItr itr itrState Done+ writeDefaultPage itr+ postprocess itr+ enqueue itr++ acceptParsableRequest :: Request -> ByteString -> IO ()+ acceptParsableRequest req input+ = {-# SCC "acceptParsableRequest" #-}+ do itr <- newInteraction cnf addr (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++ Just (rsrcPath, rsrcDef) -- あった+ -> acceptRequestForExistentResource itr input rsrcPath rsrcDef+ action++ acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())+ acceptSemanticallyInvalidRequest itr input+ = {-# SCC "acceptSemanticallyInvalidRequest" #-}+ do writeItr itr itrState Done+ writeDefaultPage itr+ postprocess itr+ enqueue itr+ return $ acceptRequest 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++ 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++ 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++ 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'++ 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++ 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++ 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++ 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++ 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++ writeItr itr itrReqChunkRemaining $ Just 0+ writeItr itr itrReqChunkIsOver True++ return $ acceptRequest input'+ else+ -- 要求がまだ来ない+ retry+ else+ -- 受信要求が來た+ do remainingM <- readItr itr itrReqChunkRemaining id++ 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++ writeItr itr itrReqChunkRemaining newRemaining+ writeItr itr itrReqChunkIsOver isOver+ writeItr itr itrReqBodyWanted Nothing+ writeItr itr itrReceivedBody chunk++ if isOver then+ return $ acceptRequest input'+ else+ return $ observeNonChunkedRequest itr input'+ action++ enqueue :: Interaction -> STM ()+ enqueue itr = {-# SCC "enqueue" #-}+ do queue <- readTVar tQueue+ writeTVar tQueue (itr <| queue)
+ Network/HTTP/Lucu/Resource.hs view
@@ -0,0 +1,962 @@+-- #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.+-- +-- Request Processing Flow:+--+-- 1. A client issues an HTTP request.+--+-- 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+-- will be discussed later.+--+-- 4. The 'Resource' Monad and its thread stops running. The client+-- may or may not be sending us the next request at this point.+--+-- 'Resource' Monad takes the following states. The initial state is+-- /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.+--+-- [/Getting Body/] A 'Resource' asks the system to receive a+-- request body from 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.+--+-- [/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 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.+--+-- [/Done/] Everything is over. A 'Resource' can do nothing for the+-- HTTP interaction anymore.+--+-- Note that the state transition is one-way: for instance, it is an+-- error to try to read a request body after writing some+-- response. This limitation is for efficiency. We don't want to read+-- 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+ (+ -- * Monad+ Resource+ , runRes -- private++ -- * Actions++ -- ** Getting request header++ -- |These actions can be computed regardless of the current state,+ -- and they don't change the state.+ , getConfig+ , getRemoteAddr+ , getRemoteAddr'+ , getRequest+ , getMethod+ , getRequestURI+ , getRequestVersion+ , getResourcePath+ , getPathInfo+ , getQueryForm+ , getHeader+ , getAccept+ , getAcceptEncoding+ , isEncodingAcceptable+ , 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.+ , 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/.+ , setStatus+ , setHeader+ , redirect+ , setContentType+ , setLocation+ , setContentEncoding+ , setWWWAuthenticate++ -- ** Writing a response body++ -- |Computation of these actions changes the state to /Deciding+ -- Body/.+ , output+ , outputChunk+ , outputLBS+ , outputChunkLBS++ , driftTo+ )+ where++import Control.Concurrent.STM+import Control.Monad.Reader+import Data.Bits+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 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 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.RFC1123DateTime+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)++-- |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+++-- |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+ case addr of+ -- Network.Socket は IPv6 を考慮してゐないやうだ…+ SockAddrInet _ v4addr+ -> let b1 = (v4addr `shiftR` 24) .&. 0xFF+ b2 = (v4addr `shiftR` 16) .&. 0xFF+ b3 = (v4addr `shiftR` 8) .&. 0xFF+ b4 = v4addr .&. 0xFF+ in+ return $ concat $ intersperse "." $ map show [b1, b2, b3, b4]+ SockAddrUnix path+ -> return path+ _+ -> undefined+++-- |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 URI of the request.+getRequestURI :: Resource URI+getRequestURI = do req <- getRequest+ return $! reqURI req++-- |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:+--+-- > 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. Its result 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 = [x | x <- splitBy (== '/') reqPathStr, x /= ""]+ -- rsrcPath と reqPath の共通する先頭部分を reqPath か+ -- ら全部取り除くと、それは PATH_INFO のやうなものにな+ -- る。rsrcPath は全部一致してゐるに決まってゐる（でな+ -- ければこの Resource が撰ばれた筈が無い）ので、+ -- rsrcPath の長さの分だけ削除すれば良い。+ return $! drop (length rsrcPath) reqPath++-- | Assume the query part of request URI as+-- application\/x-www-form-urlencoded, and parse it. This action+-- doesn't parse the request body. See 'inputForm'.+getQueryForm :: Resource [(String, String)]+getQueryForm = do uri <- getRequestURI+ return $! parseWWWFormURLEncoded $ snd $ splitAt 1 $ uriQuery uri++-- |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)]+getAcceptEncoding+ = do accEncM <- getHeader (C8.pack "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+ -- 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)+getContentType+ = do cTypeM <- getHeader (C8.pack "Content-Type")+ case cTypeM of+ 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)+++-- |Get the header \"Authorization\" as+-- 'Network.HTTP.Lucu.Authorization.AuthCredential'.+getAuthorization :: Resource (Maybe AuthCredential)+getAuthorization+ = do authM <- getHeader (C8.pack "Authorization")+ case authM of+ Nothing+ -> return Nothing+ Just auth+ -> case parse authCredentialP (L8.fromChunks [auth]) of+ (# Success a, _ #) -> return $ Just a+ (# _ , _ #) -> return Nothing+++{- ExaminingRequest 時に使用するアクション群 -}++-- |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 up to now. It is an error to+-- compute 'foundEntity' if this is a POST request.+--+-- 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.+--+-- If this is a GET or HEAD request, '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 $ formatHTTPDateTime timeStamp)+ when (method == POST)+ $ abort InternalServerError []+ (Just "Illegal computation of foundEntity for POST request.")+ foundETag tag++ driftTo GettingBody++-- |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+-- the response.+--+-- This action is not preferred. You should use 'foundEntity' whenever+-- possible.+foundETag :: ETag -> Resource ()+foundETag tag+ = tag `seq`+ 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.")++ -- If-Match があればそれを見る。+ ifMatch <- getHeader (C8.pack "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++ -- If-None-Match があればそれを見る。+ ifNoneMatch <- getHeader (C8.pack "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++-- |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+-- 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 ()+foundTimeStamp timeStamp+ = timeStamp `seq`+ do driftTo ExaminingRequest++ method <- getMethod+ when (method == GET || method == HEAD)+ $ setHeader' (C8.pack "Last-Modified") (C8.pack $ formatHTTPDateTime 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++ -- If-Modified-Since があればそれを見る。+ ifModSince <- getHeader (C8.pack "If-Modified-Since")+ case ifModSince of+ Just str -> case parseHTTPDateTime (L8.fromChunks [str]) of+ Just lastTime+ -> when (timeStamp <= lastTime)+ $ abort statusForIfModSince []+ $! Just ("The entity has not been modified since " ++ C8.unpack str)+ Nothing+ -> return () -- 不正な時刻は無視+ Nothing -> return ()++ -- If-Unmodified-Since があればそれを見る。+ ifUnmodSince <- getHeader (C8.pack "If-Unmodified-Since")+ case ifUnmodSince of+ Just str -> case parseHTTPDateTime (L8.fromChunks [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.+--+-- 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,+-- 'foundNoEntity' always aborts with status \"404 Not Found\".+foundNoEntity :: Maybe String -> Resource ()+foundNoEntity msgM+ = msgM `seq`+ do driftTo ExaminingRequest++ method <- getMethod+ when (method /= PUT)+ $ abort 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.+--+-- @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 '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+ 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+ 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, String)]+inputForm limit+ = limit `seq` + do cTypeM <- getContentType+ case cTypeM of+ Nothing+ -> abort BadRequest [] (Just "Missing Content-Type")+ Just (MIMEType "application" "x-www-form-urlencoded" _)+ -> readWWWFormURLEncoded+ Just (MIMEType "multipart" "form-data" params)+ -> readMultipartFormData params+ Just cType+ -> abort UnsupportedMediaType [] (Just $! "Unsupported media type: "+ ++ show cType)+ where+ readWWWFormURLEncoded+ = do src <- input limit+ return $ parseWWWFormURLEncoded src++ 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 pairs, _ #) -> return pairs+ (# _, _ #)+ -> 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 ()+redirect code uri+ = code `seq` uri `seq`+ do when (code == NotModified || not (isRedirection code))+ $ abort InternalServerError []+ $! Just ("Attempted to redirect with status " ++ show 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)++-- | Computation of @'setLocation' uri@ sets the response header+-- \"Location\" to @uri@.+setLocation :: URI -> Resource ()+setLocation uri+ = setHeader (C8.pack "Location") (C8.pack $ uriToString id uri $ "")++-- |Computation of @'setContentEncoding' codings@ sets the response+-- header \"Content-Encoding\" to @codings@.+setContentEncoding :: [String] -> 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+ 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)+++ drift :: Interaction -> InteractionState -> InteractionState -> STM ()++ 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 ()
+ Network/HTTP/Lucu/Resource/Tree.hs view
@@ -0,0 +1,271 @@+-- #prune++-- | Repository of the resources in httpd.+module Network.HTTP.Lucu.Resource.Tree+ ( ResourceDef(..)+ , ResTree+ , FallbackHandler++ , mkResTree -- [ ([String], ResourceDef) ] -> ResTree++ , findResource -- ResTree -> URI -> Maybe ([String], ResourceDef)+ , runResource -- ResourceDef -> Interaction -> IO ThreadId+ )+ where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception+import Control.Monad+import qualified Data.ByteString.Char8 as C8+import Data.Dynamic+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 System.IO.Error hiding (catch)+import Prelude hiding (catch)+++-- |'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+-- 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 ()))+ }++-- |'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+data ResNode = ResNode !(Maybe ResourceDef) !ResSubtree++-- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.+--+-- @+-- mkResTree [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/+-- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd+-- ]+-- @+mkResTree :: [ ([String], ResourceDef) ] -> ResTree+mkResTree xs = xs `seq` processRoot xs+ where+ processRoot :: [ ([String], ResourceDef) ] -> ResTree+ processRoot list+ = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list+ children = processNonRoot nonRoots+ in+ if null roots then+ -- "/" にリソースが定義されない。"/foo" とかにはあるかも。+ ResTree (ResNode Nothing children)+ else+ -- "/" がある。+ let (_, def) = last roots+ in + ResTree (ResNode (Just def) children)++ processNonRoot :: [ ([String], 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]]+ in+ if null defs then+ -- この位置にリソースが定義されない。+ -- もっと下にはあるかも。+ ResNode Nothing children+ else+ -- この位置にリソースがある。+ ResNode (Just $ last defs) children+ children = processNonRoot [(path, def)+ | (_:path, def) <- list, not (null path)]+ in+ subtree+++findResource :: ResTree -> [FallbackHandler] -> URI -> IO (Maybe ([String], ResourceDef))+findResource (ResTree (ResNode rootDefM subtree)) fbs uri+ = do let pathStr = uriPath uri+ path = [x | x <- splitBy (== '/') pathStr, x /= ""]+ foundInTree = if null path then+ do def <- rootDefM+ return (path, def)+ else+ walkTree subtree path []+ if isJust foundInTree then+ return foundInTree+ else+ fallback path fbs+ where+ walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef)++ walkTree tree (name:[]) soFar+ = case M.lookup name tree of+ Nothing -> Nothing+ Just (ResNode defM _) -> do def <- defM+ return (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))+ fallback _ [] = return Nothing+ 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+ )+ $ \ exc -> processException exc+ 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 $ foldr (++) [] [ 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 -> []++ processException :: Exception -> IO ()+ processException exc+ = do let abo = case exc of+ ErrorCall msg -> Abortion InternalServerError emptyHeaders $ Just msg+ IOException ioE -> Abortion InternalServerError emptyHeaders $ Just $ formatIOE ioE+ DynException dynE -> case fromDynamic dynE of+ Just a+ -> a :: Abortion+ Nothing+ -> Abortion InternalServerError emptyHeaders+ $ Just $ show exc+ _ -> Abortion InternalServerError emptyHeaders $ Just $ show 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_ (\ (name, value) -> setHeader name value) $ fromHeaders $ aboHeaders abo+ output $ abortPage conf reqM res abo+ else+ when (cnfDumpTooLateAbortionToStderr $ itrConfig itr)+ $ hPutStrLn stderr $ show abo++ flip runRes itr $ driftTo Done++ formatIOE :: IOError -> String+ formatIOE ioE = if isUserError ioE then+ ioeGetErrorString ioE+ else+ show ioE
+ Network/HTTP/Lucu/Response.hs view
@@ -0,0 +1,202 @@+-- #prune++-- |Definition of things related on HTTP response.+module Network.HTTP.Lucu.Response+ ( StatusCode(..)+ , Response(..)+ , hPutResponse+ , 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.Dynamic+import Network.HTTP.Lucu.Format+import Network.HTTP.Lucu.Headers+import Network.HTTP.Lucu.HttpVersion+import System.IO++-- |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+-- Timeout\" is 504.+data StatusCode = Continue+ | SwitchingProtocols+ | Processing+ -- + | Ok+ | Created+ | Accepted+ | NonAuthoritativeInformation+ | NoContent+ | ResetContent+ | PartialContent+ | MultiStatus+ --+ | MultipleChoices+ | MovedPermanently+ | Found+ | SeeOther+ | NotModified+ | UseProxy+ | TemporaryRedirect+ --+ | BadRequest+ | Unauthorized+ | PaymentRequired+ | Forbidden+ | NotFound+ | MethodNotAllowed+ | NotAcceptable+ | ProxyAuthenticationRequired+ | RequestTimeout+ | Conflict+ | Gone+ | LengthRequired+ | PreconditionFailed+ | RequestEntityTooLarge+ | RequestURITooLarge+ | UnsupportedMediaType+ | RequestRangeNotSatisfiable+ | ExpectationFailed+ | UnprocessableEntitiy+ | Locked+ | FailedDependency+ --+ | InternalServerError+ | NotImplemented+ | BadGateway+ | ServiceUnavailable+ | GatewayTimeout+ | HttpVersionNotSupported+ | InsufficientStorage+ deriving (Typeable, Eq)++instance Show StatusCode where+ show sc = case statusCode sc of+ (# num, msg #)+ -> (fmtDec 3 num) ++ " " ++ C8.unpack msg+++data Response = Response {+ resVersion :: !HttpVersion+ , resStatus :: !StatusCode+ , resHeaders :: !Headers+ } deriving (Show, Eq)+++instance HasHeaders Response where+ getHeaders = resHeaders+ setHeaders res hdr = res { resHeaders = hdr }+++hPutResponse :: Handle -> Response -> IO ()+hPutResponse h res+ = h `seq` res `seq`+ do hPutHttpVersion h (resVersion res)+ hPutChar h ' '+ hPutStatus h (resStatus res)+ C8.hPut h (C8.pack "\r\n")+ hPutHeaders h (resHeaders res)++hPutStatus :: Handle -> StatusCode -> IO ()+hPutStatus h sc+ = h `seq` sc `seq`+ case statusCode sc of+ (# num, msg #)+ -> do hPutStr h (fmtDec 3 num)+ hPutChar h ' '+ C8.hPut 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" #)
+ Network/HTTP/Lucu/ResponseWriter.hs view
@@ -0,0 +1,174 @@+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 Data.Sequence as S+import Data.Sequence (ViewR(..))+import Network.HTTP.Lucu.Config+import Network.HTTP.Lucu.Format+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+++responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO ()+responseWriter cnf h tQueue readerTID+ = cnf `seq` h `seq` tQueue `seq` readerTID `seq`+ catch awaitSomethingToWrite $ \ exc ->+ case exc of+ IOException _ -> return ()+ AsyncException ThreadKilled -> return ()+ BlockedIndefinitely -> putStrLn "requestWriter: blocked indefinitely"+ _ -> print exc+ where+ awaitSomethingToWrite :: IO ()+ awaitSomethingToWrite + = {-# SCC "awaitSomethingToWrite" #-}+ do action+ <- 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+ action++ writeContinueIfNecessary :: Interaction -> STM (IO ())+ writeContinueIfNecessary itr+ = {-# SCC "writeContinueIfNecessary" #-}+ itr `seq`+ do expectedContinue <- readItr itr itrExpectedContinue id+ if expectedContinue then+ do wroteContinue <- readItr itr itrWroteContinue id+ if wroteContinue then+ -- 既に Continue を書込み濟+ retry+ 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" #-}+ itr `seq`+ 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+ else+ return $! writeBodyChunk itr++ writeContinue :: Interaction -> IO ()+ writeContinue itr+ = {-# SCC "writeContinue" #-}+ itr `seq`+ 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" #-}+ itr `seq`+ 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" #-}+ itr `seq`+ 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)+ C8.hPut h (C8.pack "\r\n")+ C8.hPut h chunk+ C8.hPut h (C8.pack "\r\n")+ else+ C8.hPut h chunk+ hFlush h+ awaitSomethingToWrite++ finishBodyChunk :: Interaction -> IO ()+ finishBodyChunk itr+ = {-# SCC "finishBodyChunk" #-}+ itr `seq`+ do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id+ willChunkBody <- atomically $! readItr itr itrWillChunkBody id+ when (not willDiscardBody && willChunkBody)+ $ C8.hPut h (C8.pack "0\r\n\r\n") >> hFlush h++ finalize :: Interaction -> IO ()+ finalize itr+ = {-# SCC "finalize" #-}+ itr `seq`+ 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
+ Network/HTTP/Lucu/StaticFile.hs view
@@ -0,0 +1,149 @@+-- | Handling static files on the filesystem.+module Network.HTTP.Lucu.StaticFile+ ( staticFile+ , handleStaticFile++ , staticDir+ , handleStaticDir++ , generateETagFromFile+ )+ where++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.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 path+ = ResourceDef {+ resUsesNativeThread = False+ , resIsGreedy = False+ , resGet = Just $! handleStaticFile path+ , resHead = Nothing+ , resPost = Nothing+ , resPut = Nothing+ , resDelete = Nothing+ }++-- | 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+ lastMod <- return $ posixSecondsToUTCTime $ fromRational $ toRational $ modificationTime stat+ foundEntity tag lastMod++ -- MIME Type を推定+ conf <- getConfig+ case guessTypeByFileName (cnfExtToMIMEType conf) path of+ Nothing -> return ()+ Just mime -> setContentType mime++ -- 實際にファイルを讀んで送る+ (liftIO $ B.readFile path) >>= outputLBS+ else+ abort Forbidden [] Nothing+ else+ foundNoEntity Nothing+++-- |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.+--+-- 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+-- increase strictness, but it's too inefficient if the file is really+-- large (say, 1 TiB).+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++-- | @'staticDir' dir@ is a+-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' which maps all files+-- in @dir@ and its subdirectories on the filesystem to the+-- 'Network.HTTP.Lucu.Resource.Tree.ResTree'.+staticDir :: FilePath -> ResourceDef+staticDir path+ = ResourceDef {+ resUsesNativeThread = False+ , resIsGreedy = True+ , resGet = Just $! handleStaticDir path+ , resHead = Nothing+ , resPost = Nothing+ , resPut = Nothing+ , resDelete = Nothing+ }++-- | 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+ = basePath `seq`+ do extraPath <- getPathInfo+ securityCheck extraPath+ let path = basePath ++ "/" ++ joinWith "/" extraPath++ handleStaticFile path+ where+ securityCheck :: Monad m => [String] -> m ()+ securityCheck pathElems+ = pathElems `seq`+ when (any (== "..") pathElems) $ fail ("security error: "+ ++ joinWith "/" pathElems)
+ Network/HTTP/Lucu/Utils.hs view
@@ -0,0 +1,75 @@+-- |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+ )+ where++import Data.List hiding (last)+import Network.URI+import Prelude hiding (last)++-- |> splitBy (== ':') "ab:c:def"+-- > ==> ["ab", "c", "def"]+splitBy :: (a -> Bool) -> [a] -> [[a]]+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 separator xs+ = separator `seq` xs `seq`+ foldr (++) [] $! intersperse separator xs++-- |> trim (== '_') "__ab_c__def___"+-- > ==> "ab_c__def"+trim :: (a -> Bool) -> [a] -> [a]+trim p = p `seq` 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 #-}++-- |> quoteStr "abc"+-- > ==> "\"abc\""+--+-- > quoteStr "ab\"c"+-- > ==> "\"ab\\\"c\""+quoteStr :: String -> String+quoteStr str = str `seq`+ foldr (++) "" (["\""] ++ map quote str ++ ["\""])+ where+ quote :: Char -> String+ quote '"' = "\\\""+ quote c = [c]+++-- |> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd"+-- > ==> [("aaa", "bbb"), ("ccc", "ddd")]+parseWWWFormURLEncoded :: String -> [(String, String)]+parseWWWFormURLEncoded src+ | src == "" = []+ | otherwise = do pairStr <- splitBy (\ c -> c == ';' || c == '&') src+ let (key, value) = break (== '=') pairStr+ return ( unEscapeString key+ , unEscapeString $ case value of+ ('=':val) -> val+ val -> val+ )
+ Setup.hs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runghc++import Distribution.Simple+main = defaultMain
+ data/CompileMimeTypes.hs view
@@ -0,0 +1,18 @@+#!/usr/bin/env runghc++import Network.HTTP.Lucu.MIMEType.Guess+import System++main = do [inFile, outFile] <- getArgs+ extMap <- parseExtMapFile inFile++ let src = serializeExtMap+ extMap+ "Network.HTTP.Lucu.MIMEType.DefaultExtensionMap"+ "defaultExtensionMap"+ doc = "-- |This module is automatically generated from data\\/mime.types.\n" +++ "-- 'defaultExtensionMap' contains every possible pairs of an extension\n" +++ "-- and a MIME Type.\n" +++ "\n"++ writeFile outFile $ doc ++ src
+ data/mime.types view
@@ -0,0 +1,158 @@+# MIME type Extensions+application/andrew-inset ez+application/atom+xml atom+application/mac-binhex40 hqx+application/mac-compactpro cpt+application/mathml+xml mathml+application/msword doc+application/octet-stream bin dms lha lzh exe class so dll dmg hi o+application/oda oda+application/ogg anx ogg ogm+application/pdf pdf+application/postscript ai eps ps+application/rdf+xml rdf+application/smil smi smil+application/srgs gram+application/srgs+xml grxml+application/vnd.mif mif+application/vnd.mozilla.xul+xml xul+application/vnd.ms-excel xls+application/vnd.ms-powerpoint ppt+application/vnd.rn-realmedia rm+application/vnd.wap.wbxml wbxml+application/vnd.wap.wmlc wmlc+application/vnd.wap.wmlscriptc wmlsc+application/voicexml+xml vxml+application/x-3gp 3gp+application/x-ape ape+application/x-ar a+application/x-bcpio bcpio+application/x-bzip bz2 tbz+application/x-cdlink vcd+application/x-chess-pgn pgn+application/x-compress Z+application/x-cpio cpio+application/x-csh csh+application/x-director dcr dir dxr+application/x-dvi dvi+application/x-futuresplash spl+application/x-gtar gtar+application/x-gzip gz tgz+application/x-hdf hdf+application/x-javascript js+application/x-java-jnlp-file jnlp+application/x-koan skp skd skt skm+application/x-latex latex+application/x-nar nar+application/x-netcdf nc cdf+application/x-rar rar+application/x-sh sh+application/x-shar shar+application/x-shockwave-flash swf swfl+application/x-spc spc+application/x-stuffit sit+application/x-sv4cpio sv4cpio+application/x-sv4crc sv4crc+application/x-tar tar+application/x-tcl tcl+application/x-tex tex+application/x-texinfo texinfo texi+application/x-troff t tr roff+application/x-troff-man man+application/x-troff-me me+application/x-troff-ms ms+application/x-ustar ustar+application/x-wavpack wv wvp+application/x-wavpack-correction wvc+application/x-wais-source src+application/xhtml+xml xhtml xht+application/xslt+xml xslt+application/xml xml xsl+application/xml-dtd dtd+application/zip zip+audio/basic au snd+audio/iLBC-sh ilbc+audio/midi mid midi kar+audio/mp4a-latm m4a m4p+audio/mpeg mpga mp2 mp3+audio/x-ac3 ac3+audio/x-aiff aif aiff aifc+audio/x-au au snd+audio/x-ircam sf+audio/x-flac flac+audio/x-mod 669 amf dsm gdm far imf it med mod mtm okt sam s3m stm stx ult xm+audio/x-mpegurl m3u+audio/x-musepack mpc+audio/x-nist nist+audio/x-paris paf+audio/x-pn-realaudio ram ra+audio/x-sds sds+audio/x-shorten shn+audio/x-sid sid+audio/x-svx iff svx+audio/x-ttafile tta+audio/x-voc voc+audio/x-w64 w64+audio/x-wav wav+chemical/x-pdb pdb+chemical/x-xyz xyz+image/bmp bmp+image/cgm cgm+image/gif gif+image/ief ief+image/jpeg jpeg jpg jpe+image/jp2 jp2+image/pict pict pic pct+image/png png+image/svg+xml svg+image/tiff tiff tif+image/vnd.djvu djvu djv+image/vnd.wap.wbmp wbmp+image/x-sun-raster ras+image/x-macpaint pntg pnt mac+image/x-icon ico+image/x-jng jng+image/x-portable-anymap pnm+image/x-portable-bitmap pbm+image/x-portable-graymap pgm+image/x-portable-pixmap ppm+image/x-quicktime qtif qti qif+image/x-rgb rgb+image/x-xbitmap xbm+image/x-xcf xcf+image/x-xpixmap xpm+image/x-xwindowdump xwd+model/iges igs iges+model/mesh msh mesh silo+model/vrml wrl vrml+text/calendar ics ifb+text/css css+text/html html htm+text/plain asc txt+text/richtext rtx+text/rtf rtf+text/sgml sgml sgm+text/tab-separated-values tsv+text/uri-list ram+text/vnd.wap.wml wml+text/vnd.wap.wmlscript wmls+text/x-cabal cabal+text/x-haskell hs+text/x-setext etx+video/mp4 mp4+video/mpeg mpeg mpg mpe+video/mpeg4 m4v+video/mpegts ts+video/quicktime qt mov+video/vnd.mpegurl mxu m4u+video/x-dv dv dif+video/x-fli flc fli+video/x-flv flv+video/x-matroska mkv mka+video/x-ms-asf asf wm wma wmv+video/x-msvideo avi+video/x-mng mng+video/x-mve mve+video/x-nuv nuv+video/x-sgi-movie movie+x-conference/x-cooltalk ice
+ examples/HelloWorld.hs view
@@ -0,0 +1,44 @@+import Network+import Network.HTTP.Lucu++main :: IO ()+main = let config = defaultConfig { cnfServerPort = PortNumber 9999 }+ 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 {+ resUsesNativeThread = False+ , resIsGreedy = False+ , resGet+ = Just $ do --time <- liftIO $ getClockTime+ --foundEntity (strongETag "abcde") time+ setContentType $ read "text/hello"+ outputChunk "Hello, "+ outputChunk "World!\n"+ , resHead = Nothing+ , resPost+ = Just $ do str1 <- inputChunk 3+ str2 <- inputChunk 3+ str3 <- inputChunk 3+ setContentType $ read "text/hello"+ output ("[" ++ str1 ++ " - " ++ str2 ++ "#" ++ str3 ++ "]")+ , resPut = Nothing+ , resDelete = Nothing+ }
+ examples/Makefile view
@@ -0,0 +1,19 @@+build: MiseRafturai.hs SmallFile.hs+ ghc --make HelloWorld -threaded -O3 -fwarn-unused-imports+ ghc --make Implanted -threaded -O3 -fwarn-unused-imports+ ghc --make ImplantedSmall -threaded -O3 -fwarn-unused-imports+ ghc --make Multipart -threaded -O3 -fwarn-unused-imports++run: build+ ./HelloWorld++clean:+ rm -f HelloWorld Implanted MiseRafturai.hs ImplantedSmall SmallFile.hs Multipart *.hi *.o++MiseRafturai.hs: mise-rafturai.html+ lucu-implant-file -m MiseRafturai -o $@ $<++SmallFile.hs: small-file.txt+ lucu-implant-file -m SmallFile -o $@ $<++.PHONY: build run clean