diff --git a/COPYING b/COPYING
new file mode 100644
--- /dev/null
+++ b/COPYING
@@ -0,0 +1,29 @@
+
+
+
+
+ Lucu
+
+
+ PHO
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/ImplantFile.hs b/ImplantFile.hs
new file mode 100644
--- /dev/null
+++ b/ImplantFile.hs
@@ -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..."))
+ ------------------------------------------------------------------------------
+ -}
diff --git a/Lucu.cabal b/Lucu.cabal
new file mode 100644
--- /dev/null
+++ b/Lucu.cabal
@@ -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
+Maintainer: PHO
+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
diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu.hs
@@ -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
diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/Abortion.hs
@@ -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''
diff --git a/Network/HTTP/Lucu/Authorization.hs b/Network/HTTP/Lucu/Authorization.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/Authorization.hs
@@ -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
diff --git a/Network/HTTP/Lucu/Chunk.hs b/Network/HTTP/Lucu/Chunk.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/Chunk.hs
@@ -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
diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/Config.hs
@@ -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
+ -- ()
+ -- 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
+ }
diff --git a/Network/HTTP/Lucu/ContentCoding.hs b/Network/HTTP/Lucu/ContentCoding.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/ContentCoding.hs
@@ -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
diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -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 #-}
diff --git a/Network/HTTP/Lucu/ETag.hs b/Network/HTTP/Lucu/ETag.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/ETag.hs
@@ -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
diff --git a/Network/HTTP/Lucu/Format.hs b/Network/HTTP/Lucu/Format.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/Format.hs
@@ -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
diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/Headers.hs
@@ -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 の先頭および末尾にある 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")
diff --git a/Network/HTTP/Lucu/HttpVersion.hs b/Network/HTTP/Lucu/HttpVersion.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/HttpVersion.hs
@@ -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)
diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/Httpd.hs
@@ -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)
diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -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 () #-}
diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/MIMEType.hs
@@ -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
diff --git a/Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs b/Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/MIMEType/DefaultExtensionMap.hs
@@ -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")]
diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/MIMEType/Guess.hs
@@ -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))
diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/MultipartForm.hs
@@ -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)
diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/Parser.hs
@@ -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"
diff --git a/Network/HTTP/Lucu/Parser/Http.hs b/Network/HTTP/Lucu/Parser/Http.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/Parser/Http.hs
@@ -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)
diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/Postprocess.hs
@@ -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
diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/Preprocess.hs
@@ -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 ()
diff --git a/Network/HTTP/Lucu/RFC1123DateTime.hs b/Network/HTTP/Lucu/RFC1123DateTime.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/RFC1123DateTime.hs
@@ -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
+
diff --git a/Network/HTTP/Lucu/Request.hs b/Network/HTTP/Lucu/Request.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/Request.hs
@@ -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
diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -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)
diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -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 ()
diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/Resource/Tree.hs
@@ -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
diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/Response.hs
@@ -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" #)
diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/ResponseWriter.hs
@@ -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
diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/StaticFile.hs
@@ -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)
diff --git a/Network/HTTP/Lucu/Utils.hs b/Network/HTTP/Lucu/Utils.hs
new file mode 100644
--- /dev/null
+++ b/Network/HTTP/Lucu/Utils.hs
@@ -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
+ )
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,4 @@
+#!/usr/bin/env runghc
+
+import Distribution.Simple
+main = defaultMain
diff --git a/data/CompileMimeTypes.hs b/data/CompileMimeTypes.hs
new file mode 100644
--- /dev/null
+++ b/data/CompileMimeTypes.hs
@@ -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
diff --git a/data/mime.types b/data/mime.types
new file mode 100644
--- /dev/null
+++ b/data/mime.types
@@ -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
diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs
new file mode 100644
--- /dev/null
+++ b/examples/HelloWorld.hs
@@ -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
+ }
diff --git a/examples/Makefile b/examples/Makefile
new file mode 100644
--- /dev/null
+++ b/examples/Makefile
@@ -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