UnicodeSyntax
#-}
module Network.HTTP.Lucu.Chunk
- ( chunkHeaderP -- Num a => Parser a
- , chunkFooterP -- Parser ()
- , chunkTrailerP -- Parser Headers
+ ( chunkHeaderP
+ , chunkFooterP
+ , chunkTrailerP
)
where
import Control.Applicative
-- Content-Type が正しくなければ補完できない。
= do res ← readTVar itrResponse
when (getHeader "Content-Type" res ≡ Just defaultPageContentType)
- $ do reqM ← readTVar itrRequest
- let page = getDefaultPage itrConfig reqM res
+ $ do let page = getDefaultPage itrConfig itrRequest res
putTMVar itrBodyToSend (BB.fromLazyText page)
mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree
( Headers
, HasHeaders(..)
+ , singleton
+
, toHeaders
, fromHeaders
getHeaders = id
setHeaders _ = id
+singleton ∷ CIAscii → Ascii → Headers
+{-# INLINE singleton #-}
+singleton key val
+ = Headers $ M.singleton key val
+
toHeaders ∷ [(CIAscii, Ascii)] → Headers
{-# INLINE toHeaders #-}
toHeaders = flip mkHeaders (∅)
{-# LANGUAGE
- BangPatterns
- , OverloadedStrings
+ OverloadedStrings
+ , RecordWildCards
, UnicodeSyntax
#-}
module Network.HTTP.Lucu.Interaction
, newInteractionQueue
, newInteraction
, defaultPageContentType
-{-
- , writeItr
- , readItr
- , updateItr
--}
+
+ , setResponseStatus
)
where
import Blaze.ByteString.Builder (Builder)
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.HttpVersion
+import Network.HTTP.Lucu.Preprocess
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import OpenSSL.X509
, itrRemoteAddr ∷ !SockAddr
, itrRemoteCert ∷ !(Maybe X509)
, itrResourcePath ∷ !(Maybe [Text])
- , itrRequest ∷ !(TVar (Maybe Request))
- , itrResponse ∷ !(TVar Response)
+ , itrRequest ∷ !(Maybe Request)
- , itrRequestHasBody ∷ !(TVar Bool)
- , itrRequestIsChunked ∷ !(TVar Bool)
- , itrExpectedContinue ∷ !(TVar Bool)
+ , itrExpectedContinue ∷ !(Maybe Bool)
+ , itrReqBodyLength ∷ !(Maybe RequestBodyLength)
- , itrReqChunkLength ∷ !(TVar (Maybe Int))
- , itrReqChunkRemaining ∷ !(TVar (Maybe Int))
- , itrReqChunkIsOver ∷ !(TVar Bool)
, itrReqBodyWanted ∷ !(TVar (Maybe Int))
, itrReqBodyWasteAll ∷ !(TVar Bool)
+ , itrReqChunkIsOver ∷ !(TVar Bool)
, itrReceivedBody ∷ !(TVar (Seq BS.ByteString))
, itrReceivedBodyLen ∷ !(TVar Int)
- , itrWillReceiveBody ∷ !(TVar Bool)
+ , itrResponse ∷ !(TVar Response)
, itrWillChunkBody ∷ !(TVar Bool)
, itrWillDiscardBody ∷ !(TVar Bool)
, itrWillClose ∷ !(TVar Bool)
-
, itrBodyToSend ∷ !(TMVar Builder)
- , itrSentNoBody ∷ !(TVar Bool)
+ , itrSentNoBodySoFar ∷ !(TVar Bool)
, itrState ∷ !(TVar InteractionState)
-
- , itrWroteContinue ∷ !(TVar Bool)
- , itrWroteHeader ∷ !(TVar Bool)
}
-- |The interaction state of Resource monad. 'ExaminingRequest' is the
defaultPageContentType ∷ Ascii
defaultPageContentType = "application/xhtml+xml"
-newInteraction ∷ Config → PortNumber → SockAddr → Maybe X509 → Maybe Request → IO Interaction
-newInteraction !conf !port !addr !cert !req
- = do request ← newTVarIO req
- responce ← newTVarIO Response {
- resVersion = HttpVersion 1 1
- , resStatus = Ok
- , resHeaders = toHeaders [("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 S.empty
- receivedBodyLen ← newTVarIO 0
-
- willReceiveBody ← newTVarIO False
- willChunkBody ← newTVarIO False
- willDiscardBody ← newTVarIO False
- willClose ← newTVarIO False
-
- bodyToSend ← newEmptyTMVarIO
- sentNoBody ← newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
-
- state ← newTVarIO ExaminingRequest
-
- wroteContinue ← newTVarIO False
- wroteHeader ← newTVarIO False
+newInteraction ∷ Config
+ → PortNumber
+ → SockAddr
+ → Maybe X509
+ → Either StatusCode Request
+ → IO Interaction
+newInteraction conf@(Config {..}) port addr cert request
+ = do let ar = preprocess cnfServerHost port request
+ res = Response {
+ resVersion = HttpVersion 1 1
+ , resStatus = arInitialStatus ar
+ , resHeaders = singleton "Content-Type" defaultPageContentType
+ }
+
+ reqBodyWanted ← newTVarIO Nothing -- Resource が要求してゐるチャンク長
+ reqBodyWasteAll ← newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求
+ reqChunkIsOver ← newTVarIO False -- 最後のチャンクを讀み終へた
+ receivedBody ← newTVarIO S.empty
+ receivedBodyLen ← newTVarIO 0
+
+ response ← newTVarIO res
+ willChunkBody ← newTVarIO False
+ willDiscardBody ← newTVarIO False
+ willClose ← newTVarIO False
+ bodyToSend ← newEmptyTMVarIO
+ sentNoBodySoFar ← newTVarIO True
+
+ state ← newTVarIO ExaminingRequest
return Interaction {
itrConfig = conf
, itrRemoteAddr = addr
, itrRemoteCert = cert
, itrResourcePath = Nothing
- , itrRequest = request
- , itrResponse = responce
-
- , itrRequestHasBody = requestHasBody
- , itrRequestIsChunked = requestIsChunked
- , itrExpectedContinue = expectedContinue
-
- , itrReqChunkLength = reqChunkLength
- , itrReqChunkRemaining = reqChunkRemaining
- , itrReqChunkIsOver = reqChunkIsOver
- , itrReqBodyWanted = reqBodyWanted
- , itrReqBodyWasteAll = reqBodyWasteAll
- , itrReceivedBody = receivedBody
- , itrReceivedBodyLen = receivedBodyLen
-
- , itrWillReceiveBody = willReceiveBody
- , itrWillChunkBody = willChunkBody
- , itrWillDiscardBody = willDiscardBody
- , itrWillClose = willClose
-
- , itrBodyToSend = bodyToSend
- , itrSentNoBody = sentNoBody
+ , itrRequest = arRequest ar
+
+ , itrExpectedContinue = arExpectedContinue ar
+ , itrReqBodyLength = arReqBodyLength ar
+
+ , itrReqBodyWanted = reqBodyWanted
+ , itrReqBodyWasteAll = reqBodyWasteAll
+ , itrReqChunkIsOver = reqChunkIsOver
+ , itrReceivedBody = receivedBody
+ , itrReceivedBodyLen = receivedBodyLen
+
+ , itrResponse = response
+ , itrWillChunkBody = willChunkBody
+ , itrWillDiscardBody = willDiscardBody
+ , itrWillClose = willClose
+ , itrBodyToSend = bodyToSend
+ , itrSentNoBodySoFar = sentNoBodySoFar
- , itrState = state
-
- , itrWroteContinue = wroteContinue
- , itrWroteHeader = wroteHeader
+ , itrState = state
}
-{-
-chunksToLBS ∷ Seq BS.ByteString → LBS.ByteString
-{-# INLINE chunksToLBS #-}
-chunksToLBS = LBS.fromChunks ∘ toList
-
-chunksFromLBS ∷ LBS.ByteString → Seq BS.ByteString
-{-# INLINE chunksFromLBS #-}
-chunksFromLBS = S.fromList ∘ LBS.toChunks
--}
-
-writeItr ∷ (Interaction → TVar a) → a → Interaction → STM ()
-{-# INLINE writeItr #-}
-writeItr accessor a itr
- = writeTVar (accessor itr) a
-
-readItr ∷ (Interaction → TVar a) → Interaction → STM a
-{-# INLINE readItr #-}
-readItr accessor itr
- = readTVar (accessor itr)
-
-updateItr ∷ (Interaction → TVar a) → (a → a) → Interaction → STM ()
-{-# INLINE updateItr #-}
-updateItr accessor updator itr
- = do old ← readItr accessor itr
- writeItr accessor (updator old) itr
+setResponseStatus ∷ Interaction → StatusCode → STM ()
+setResponseStatus (Interaction {..}) sc
+ = do res ← readTVar itrResponse
+ let res' = res {
+ resStatus = sc
+ }
+ writeTVar itrResponse res'
import Control.Applicative
import qualified Data.Ascii as A
import Data.Attoparsec.Char8 as P
-import qualified Data.Attoparsec.Lazy as AL
+import qualified Data.Attoparsec.Lazy as LP
import qualified Data.ByteString.Lazy.Char8 as B
import qualified Data.Map as M
import Data.Map (Map)
parseExtMapFile ∷ FilePath → IO ExtMap
parseExtMapFile fpath
= do file ← B.readFile fpath
- case AL.parse extMapP file of
- AL.Done _ xs → return $ compile xs
- AL.Fail _ _ e → fail ("Failed to parse: " ⧺ fpath ⧺ ": " ⧺ e)
+ case LP.parse extMapP file of
+ LP.Done _ xs → return $ compile xs
+ LP.Fail _ _ e → fail ("Failed to parse: " ⧺ fpath ⧺ ": " ⧺ e)
extMapP ∷ Parser [ (MIMEType, [Text]) ]
extMapP = do xs ← P.many (comment <|> validLine <|> emptyLine)
⊕ printStatusCode sc
⊕ A.toAsciiBuilder " but no Location header."
- reqM ← readTVar itrRequest
- case reqM of
+ case itrRequest of
Just req → postprocessWithRequest sc req
Nothing → return ()
, UnicodeSyntax
#-}
module Network.HTTP.Lucu.Preprocess
- ( preprocess
+ ( AugmentedRequest(..)
+ , RequestBodyLength(..)
+ , preprocess
)
where
import Control.Applicative
-import Control.Concurrent.STM
import Control.Monad
+import Control.Monad.State
import Data.Ascii (Ascii)
import qualified Data.Ascii as A
-import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as C8
-import Data.Char
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
-import Network.HTTP.Lucu.Config
+import qualified Data.Text.Encoding as T
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.Socket
import Network.URI
import Prelude.Unicode
-{-
- TODO: Tanslate this memo into English. It doesn't make sense to
- non-Japanese speakers.
-
- * 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@(Interaction {..})
- = do req ← fromJust <$> readTVar itrRequest
-
- let reqVer = reqVersion req
-
- if reqVer ≢ HttpVersion 1 0 ∧
- reqVer ≢ HttpVersion 1 1 then
-
- do setStatus itr HttpVersionNotSupported
- writeTVar itrWillClose True
-
- else
- -- HTTP/1.0 では Keep-Alive できない
- do when (reqVer ≡ HttpVersion 1 0)
- $ writeTVar itrWillClose True
-
- -- ホスト部の補完
- completeAuthority itr req
-
- case reqMethod req of
- GET → return ()
- HEAD → writeTVar itrWillDiscardBody True
- POST → writeTVar itrRequestHasBody True
- PUT → writeTVar itrRequestHasBody True
- DELETE → return ()
- _ → setStatus itr NotImplemented
-
- preprocessHeader itr req
-
-setStatus ∷ Interaction → StatusCode → STM ()
-setStatus (Interaction {..}) sc
- = do res ← readTVar itrResponse
- let res' = res {
- resStatus = sc
- }
- writeTVar itrResponse res'
-
-completeAuthority ∷ Interaction → Request → STM ()
-completeAuthority itr@(Interaction {..}) req
- = when (isNothing $ uriAuthority $ reqURI req)
- $ if reqVersion req == HttpVersion 1 0 then
- -- HTTP/1.0 なので Config から補完
- do let host = cnfServerHost itrConfig
- portStr = case itrLocalPort of
- 80 → ""
- n → ':' : show n
- updateAuthority host $ A.unsafeFromString portStr
- else
- case getHeader "Host" req of
- Just str → let (host, portStr) = parseHost str
- in
- updateAuthority host portStr
- Nothing → setStatus itr BadRequest
+data AugmentedRequest
+ = AugmentedRequest {
+ arRequest ∷ !(Maybe Request)
+ , arInitialStatus ∷ !StatusCode
+ , arWillClose ∷ !Bool
+ , arWillDiscardBody ∷ !Bool
+ , arExpectedContinue ∷ !(Maybe Bool)
+ , arReqBodyLength ∷ !(Maybe RequestBodyLength)
+ }
+
+data RequestBodyLength
+ = Fixed !Int
+ | Chunked
+
+preprocess ∷ Text
+ → PortNumber
+ → Either StatusCode Request
+ → AugmentedRequest
+preprocess localHost localPort request
+ = case request of
+ Right req
+ → preprocess' localHost localPort req
+ Left sc
+ → unparsable sc
+
+unparsable ∷ StatusCode → AugmentedRequest
+unparsable sc
+ = AugmentedRequest {
+ arRequest = Nothing
+ , arInitialStatus = sc
+ , arWillClose = True
+ , arWillDiscardBody = False
+ , arExpectedContinue = Nothing
+ , arReqBodyLength = Nothing
+ }
+
+preprocess' ∷ Text → PortNumber → Request → AugmentedRequest
+preprocess' localHost localPort req@(Request {..})
+ = execState go initialAR
+ where
+ initialAR ∷ AugmentedRequest
+ initialAR = AugmentedRequest {
+ arRequest = Just req
+ , arInitialStatus = Ok
+ , arWillClose = False
+ , arWillDiscardBody = False
+ , arExpectedContinue = Just False
+ , arReqBodyLength = Nothing
+ }
+
+ go ∷ State AugmentedRequest ()
+ go = do examineHttpVersion
+ examineMethod
+ examineAuthority localHost localPort
+ examineHeaders
+ examineBodyLength
+
+setRequest ∷ Request → State AugmentedRequest ()
+setRequest req
+ = modify $ \ar → ar { arRequest = Just req }
+
+setStatus ∷ StatusCode → State AugmentedRequest ()
+setStatus sc
+ = modify $ \ar → ar { arInitialStatus = sc }
+
+setWillClose ∷ Bool → State AugmentedRequest ()
+setWillClose b
+ = modify $ \ar → ar { arWillClose = b }
+
+setBodyLength ∷ Maybe RequestBodyLength → State AugmentedRequest ()
+setBodyLength len
+ = modify $ \ar → ar { arReqBodyLength = len }
+
+examineHttpVersion ∷ State AugmentedRequest ()
+examineHttpVersion
+ = do req ← gets (fromJust ∘ arRequest)
+ case reqVersion req of
+ -- HTTP/1.0 requests can't Keep-Alive.
+ HttpVersion 1 0
+ → setWillClose True
+ HttpVersion 1 1
+ → return ()
+ _ → do setStatus HttpVersionNotSupported
+ setWillClose True
+
+examineMethod ∷ State AugmentedRequest ()
+examineMethod
+ = do req ← gets (fromJust ∘ arRequest)
+ case reqMethod req of
+ GET → return ()
+ HEAD → modify $ \ar → ar { arWillDiscardBody = True }
+ POST → return ()
+ PUT → return ()
+ DELETE → return ()
+ _ → setStatus NotImplemented
+
+examineAuthority ∷ Text → PortNumber → State AugmentedRequest ()
+examineAuthority localHost localPort
+ = do req ← gets (fromJust ∘ arRequest)
+ when (isNothing $ uriAuthority $ reqURI req) $
+ case reqVersion req of
+ -- HTTP/1.0 requests have no Host header so complete it
+ -- with the configuration value.
+ HttpVersion 1 0
+ → let host = localHost
+ port = case localPort of
+ 80 → ""
+ n → A.unsafeFromString $ ':':show n
+ req' = updateAuthority host port req
+ in
+ setRequest req'
+ -- HTTP/1.1 requests MUST have a Host header.
+ HttpVersion 1 1
+ → case getHeader "Host" req of
+ Just str
+ → let (host, port)
+ = parseHost str
+ req' = updateAuthority host port req
+ in
+ setRequest req'
+ Nothing
+ → setStatus BadRequest
+ -- Should never reach here...
+ ver → fail ("internal error: unknown version: " ⧺ show ver)
parseHost ∷ Ascii → (Text, Ascii)
-parseHost = C8.break (≡ ':')
-
-updateAuthority ∷ Text → Ascii → STM ()
-updateAuthority host portStr
- = do Just req ← readTVar itrRequest
- let uri = reqURI req
- uri' = uri {
- uriAuthority = Just URIAuth {
- uriUserInfo = ""
- , uriRegName = T.unpack host
- , uriPort = A.toString portStr
- }
- }
- req' = req { reqURI = uri' }
- writeTVar itrRequest $ Just req'
-
-preprocessHeader ∷ Interaction → Request → STM ()
-preprocessHeader (Interaction {..}) req
- = do case getCIHeader "Expect" req of
- Nothing → return ()
- Just value → if value ≡ "100-continue" then
- writeTVar itrExpectedContinue True
- else
- setStatus ExpectationFailed
+parseHost hp
+ = let (h, p) = C8.break (≡ ':') $ A.toByteString hp
+ -- FIXME: should decode punycode here.
+ hText = T.decodeUtf8 h
+ pAscii = A.unsafeFromByteString p
+ in
+ (hText, pAscii)
+
+updateAuthority ∷ Text → Ascii → Request → Request
+updateAuthority host port req
+ = let uri = reqURI req
+ uri' = uri {
+ uriAuthority = Just URIAuth {
+ uriUserInfo = ""
+ , uriRegName = T.unpack host
+ , uriPort = A.toString port
+ }
+ }
+ in
+ req { reqURI = uri' }
+
+examineHeaders ∷ State AugmentedRequest ()
+examineHeaders
+ = do req ← gets (fromJust ∘ arRequest)
+
+ case getCIHeader "Expect" req of
+ Nothing → return ()
+ Just v
+ | v ≡ "100-continue"
+ → modify $ \ar → ar { arExpectedContinue = Just True }
+ | otherwise
+ → setStatus ExpectationFailed
case getCIHeader "Transfer-Encoding" req of
+ Nothing → return ()
+ Just v
+ | v ≡ "identity"
+ → return ()
+ | v ≡ "chunked"
+ → setBodyLength $ Just Chunked
+ | otherwise
+ → setStatus NotImplemented
+
+ case A.toByteString <$> getHeader "Content-Length" req of
Nothing → return ()
- Just value → unless (value ≡ "identity")
- $ if value ≡ "chunked" then
- writeTVar itrRequestIsChunked True
- else
- setStatus NotImplemented
-
- case getHeader "Content-Length" req of
- Nothing → return ()
- Just value → if C8.all isDigit value then
- do let Just (len, _) = C8.readInt value
- writeTVar itrReqChunkLength $ Just len
- writeTVar itrReqChunkRemaining $ Just len
- else
- setStatus BadRequest
+ Just value → case C8.readInt value of
+ Just (len, garbage)
+ | C8.null garbage ∧ len ≥ 0
+ → setBodyLength $ Just $ Fixed len
+ _ → setStatus BadRequest
case getCIHeader "Connection" req of
- Nothing → return ()
- Just value → when (value ≡ "close")
- $ writeTVar itrWillClose True
+ Just v
+ | v ≡ "close"
+ → setWillClose True
+ _ → return ()
+
+examineBodyLength ∷ State AugmentedRequest ()
+examineBodyLength
+ = do req ← gets (fromJust ∘ arRequest)
+ len ← gets arReqBodyLength
+ if reqHasBody req then
+ -- POST and PUT requests must have an entity body.
+ when (isNothing len)
+ $ setStatus LengthRequired
+ else
+ -- Other requests must NOT have an entity body.
+ when (isJust len)
+ $ setStatus BadRequest
{-# LANGUAGE
OverloadedStrings
, UnicodeSyntax
+ , ViewPatterns
#-}
-{-# OPTIONS_HADDOCK 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(..)
+ , reqHasBody
, requestP
)
where
getHeaders = reqHeaders
setHeaders req hdr = req { reqHeaders = hdr }
+-- |Returns 'True' iff the 'Request' must have an entity body.
+reqHasBody ∷ Request → Bool
+reqHasBody (reqMethod → m)
+ = m ≡ POST ∨ m ≡ PUT
+
requestP ∷ Parser Request
requestP = do skipMany crlf
(method, uri, version) ← requestLineP
{-# LANGUAGE
- BangPatterns
- , UnboxedTuples
+ DoAndIfThenElse
+ , RecordWildCards
+ , ScopedTypeVariables
, UnicodeSyntax
#-}
module Network.HTTP.Lucu.RequestReader
( requestReader
)
where
+import Control.Applicative
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 qualified Data.Attoparsec.Lazy as LP
+import qualified Data.ByteString.Lazy as Lazy
import Data.Maybe
import qualified Data.Sequence as S
-import Data.Sequence ((<|))
-import GHC.Conc (unsafeIOToSTM)
-import Network.Socket
+import Data.Sequence.Unicode
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Chunk
import Network.HTTP.Lucu.DefaultPage
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.Resource.Tree
-import Prelude hiding (catch)
-import System.IO (stderr)
+import Network.Socket
+import Network.URI
+import Prelude.Unicode
+import System.IO (hPutStrLn, stderr)
-requestReader :: HandleLike h => Config -> ResTree -> [FallbackHandler] -> h -> PortNumber -> SockAddr -> InteractionQueue -> IO ()
-requestReader !cnf !tree !fbs !h !port !addr !tQueue
- = do input <- hGetLBS h
- acceptRequest input
+data Context h
+ = Context {
+ cConfig ∷ !Config
+ , cResTree ∷ !ResTree
+ , cFallbacks ∷ ![FallbackHandler]
+ , cHandle ∷ !h
+ , cPort ∷ !PortNumber
+ , cAddr ∷ !SockAddr
+ , cQueue ∷ !InteractionQueue
+ }
+
+requestReader ∷ HandleLike h
+ ⇒ Config
+ → ResTree
+ → [FallbackHandler]
+ → h
+ → PortNumber
+ → SockAddr
+ → InteractionQueue
+ → IO ()
+requestReader cnf tree fbs h port addr tQueue
+ = do input ← hGetLBS h
+ acceptRequest (Context cnf tree fbs h port addr tQueue) input
`catches`
- [ Handler (( \ _ -> return () ) :: IOException -> IO ())
- , Handler ( \ ThreadKilled -> return () )
- , Handler ( \ BlockedIndefinitelyOnSTM -> hPutStrLn stderr "requestReader: blocked indefinitely" )
- , Handler (( \ e -> hPutStrLn stderr (show e) ) :: SomeException -> IO ())
+ [ Handler $ \ (_ ∷ IOException) → return ()
+ , Handler $ \ e → case e of
+ ThreadKilled → return ()
+ _ → hPutStrLn stderr (show e)
+ , Handler $ \ BlockedIndefinitelyOnSTM → hPutStrLn stderr "requestReader: blocked indefinitely"
+ , Handler $ \ (e ∷ SomeException) → hPutStrLn stderr (show e)
]
- 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 port addr Nothing Nothing
- atomically $ do updateItr itr itrResponse
- $ \ res -> res {
- resStatus = status
- }
- writeItr itr itrWillClose True
- writeItr itr itrState Done
- writeDefaultPage itr
- postprocess itr
- enqueue itr
-
- acceptParsableRequest :: Request -> ByteString -> IO ()
- acceptParsableRequest req input
- = {-# SCC "acceptParsableRequest" #-}
- do cert <- hGetPeerCert h
- itr <- newInteraction cnf port addr cert (Just req)
- action
- <- atomically $
- do preprocess itr
- isErr <- readItr itr itrResponse (isError . resStatus)
- if isErr then
- acceptSemanticallyInvalidRequest itr input
- else
- do rsrcM <- unsafeIOToSTM $ findResource tree fbs $ reqURI req
- case rsrcM of
- Nothing -- Resource が無かった
- -> acceptRequestForNonexistentResource itr input
- Just (rsrcPath, rsrcDef) -- あった
- -> acceptRequestForExistentResource itr input rsrcPath rsrcDef
- action
+acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
+acceptRequest ctx@(Context {..}) input
+ -- キューに最大パイプライン深度以上のリクエストが溜まってゐる時は、
+ -- それが限度以下になるまで待つ。
+ = do atomically $
+ do queue ← readTVar cQueue
+ when (S.length queue ≥ cnfMaxPipelineDepth cConfig) $
+ retry
+ -- リクエストを讀む。パースできない場合は直ちに 400 Bad
+ -- Request 應答を設定し、それを出力してから切斷するやうに
+ -- ResponseWriter に通知する。
+ case LP.parse requestP input of
+ LP.Done input' req → acceptParsableRequest req input'
+ LP.Fail _ _ _ → acceptNonparsableRequest ctx BadRequest
- acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
- acceptSemanticallyInvalidRequest itr input
- = {-# SCC "acceptSemanticallyInvalidRequest" #-}
- do writeItr itr itrState Done
- writeDefaultPage itr
- postprocess itr
- enqueue itr
- return $ acceptRequest input
+acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → StatusCode → IO ()
+acceptNonparsableRequest (Context {..}) status
+ = do itr ← newInteraction cConfig cPort cAddr Nothing Nothing
+ atomically $
+ do setResponseStatus itr status
+ writeTVar (itrWillClose itr) True
+ writeTVar (itrState itr) Done
+ writeDefaultPage itr
+ postprocess itr
+ enqueue itr
- 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
+acceptParsableRequest ∷ HandleLike h
+ ⇒ Context h
+ → Request
+ → Lazy.ByteString
+ → IO ()
+acceptParsableRequest (Context {..}) req input
+ = do cert ← hGetPeerCert cHandle
+ itr ← newInteraction cConfig cPort cAddr cert (Right req)
+ join $ atomically
+ $ do preprocess itr
+ isErr ← (isError ∘ resStatus) <$> readTVar (itrResponse itr)
+ if isErr then
+ acceptSemanticallyInvalidRequest itr input
+ else
+ acceptSemanticallyValidRequest itr (reqURI req) 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
+acceptSemanticallyInvalidRequest ∷ Interaction → Lazy.ByteString → STM (IO ())
+acceptSemanticallyInvalidRequest itr input
+ = do writeTVar (itr itrState) Done
+ writeDefaultPage itr
+ postprocess itr
+ enqueue itr
+ return $ 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
+acceptSemanticallyValidRequest ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → URI
+ → Lazy.ByteString
+ → IO ()
+acceptSemanticallyValidRequest (Context {..}) itr uri input
+ = do rsrcM ← findResource cResTree cFallbacks uri
+ case rsrcM of
+ Nothing
+ → acceptRequestForNonexistentResource itr input
+ Just (rsrcPath, rsrcDef)
+ → acceptRequestForExistentResource itr input rsrcPath rsrcDef
- 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'
+acceptRequestForNonexistentResource ∷ Interaction → Lazy.ByteString → STM (IO ())
+acceptRequestForNonexistentResource itr input
+ = do setResponseStatus itr NotFound
+ writeTVar (itrState itr) Done
+ writeDefaultPage itr
+ postprocess itr
+ enqueue itr
+ return $ acceptRequest 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
- updateItr itrReceivedBodyLen (+ actualReadBytes) itr
+acceptRequestForExistentResource ∷ Interaction → Lazy.ByteString → [String] → ResourceDef → STM (IO ())
+acceptRequestForExistentResource oldItr input rsrcPath rsrcDef
+ = do let itr = oldItr { itrResourcePath = Just rsrcPath }
+ enqueue itr
+ return $ do _ ← runResource rsrcDef itr
+ if reqHasBody $ fromJust $ itrRequest itr then
+ observeRequest itr input
+ else
+ acceptRequest input
- 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
+observeRequest ∷ Interaction → Lazy.ByteString → IO ()
+observeRequest itr input
+ | itrReqBodyLength itr ≡ Just Chunked
+ = observeChunkedRequest itr input
+ | otherwise
+ = observeNonChunkedRequest itr input
- 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
+observeChunkedRequest ∷ Interaction → Lazy.ByteString → IO ()
+observeChunkedRequest itr input
+ = join $
+ atomically $
+ do isOver ← readTVar $ itrReqChunkIsOver itr
+ if isOver then
+ return $ acceptRequest input
+ else
+ do wantedM ← readTVar $ itrReqBodyWanted itr
+ if isNothing wantedM then
+ do wasteAll ← readTVar $ itrReqBodyWasteAll itr
+ if wasteAll then
+ wasteCurrentChunk input
+ else
+ retry
+ else
+ readCurrentChunk (fromJust wantedM)
- 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
+wasteCurrentChunk ∷ Interaction → Lazy.ByteString → Int → IO ()
+wasteCurrentChunk itr input len
+ | len > 0
+ = let input' = Lazy.drop (fromIntegral len) input
+ in
+ case LP.parse chunkFooterP input' of
+ LP.Done input'' _
+ → observeChunkedRequest itr input''
+ LP.Fail _ _ _
+ → chunkWasMalformed itr
+ | otherwise
+ = seekNextChunk itr input
- 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
+readCurrentChunk ∷ Interaction → Lazy.ByteString → Int → Int → IO ()
+readCurrentChunk itr input wanted remaining
+ | remaining > 0
+ = do let bytesToRead = fromIntegral $ min wanted remaining
+ (chunk, input') = Lazy.splitAt bytesToRead input
+ actualReadBytes = fromIntegral $ Lazy.length chunk
+ newWanted = case wanted - actualReadBytes of
+ 0 → Nothing
+ n → Just n
+ newRemaining = Just $ remaining - actualReadBytes
+ updateStates = do writeTVar (itrReqBodyWanted itr) newWanted
+ oldBody ← readTVar $ itrReceivedBody itr
+ oldBodyLen ← readTVar $ itrReceivedBodyLen itr
+ writeTVar (itrReceivedBody itr) $ oldBody ⊳ chunk
+ writeTVar (itrReceivedBodyLen itr) $ oldBodyLen + actualReadBytes
+ if newRemaining ≡ Just 0 then
+ case LP.parse chunkFooterP input' of
+ LP.Done input'' _
+ → do updateStates
+ observeChunkedRequest itr input''
+ LP.Fail _ _ _
+ → chunkWasMalformed itr
+ else
+ do updateStates
+ observeChunkedRequest itr input'
+ | otherwise
+ = seekNextChunk itr input
- writeItr itr itrReqChunkRemaining $ Just 0
- writeItr itr itrReqChunkIsOver True
+seekNextChunk ∷ Interaction → Lazy.ByteString → IO ()
+seekNextChunk itr input
+ = case LP.parse chunkHeaderP input of
+ LP.Done input' len
+ | len ≡ 0 -- Final chunk
+ → case LP.parse chunkTrailerP input' of
+ LP.Done input'' _
+ → do writeTVar (itrReqChunkIsOver itr) True
+ acceptRequest input''
+ LP.Fail _ _ _
+ → chunkWasMalformed itr
+ | otherwise -- Non-final chunk
+ → do observeChunkedRequest itr input'
+ LP.Fail _ _ _
+ → chunkWasMalformed itr
- return $ acceptRequest input'
- else
- -- 要求がまだ来ない
- retry
- else
- -- 受信要求が來た
- do remainingM <- readItr itr itrReqChunkRemaining id
+chunkWasMalformed ∷ Interaction → IO ()
+chunkWasMalformed itr
+ = atomically $
+ do setResponseStatus BadRequest
+ writeTVar (itrWillClose itr) True
+ writeTVar (itrState itr) Done
+ writeDefaultPage itr
+ postprocess itr
- let wanted = fromJust wantedM
- bytesToRead = fromIntegral $ maybe wanted (min wanted) remainingM
- (chunk, input') = B.splitAt bytesToRead input
- actualReadBytes = fromIntegral $ B.length chunk
- newRemaining = (- actualReadBytes) <$> remainingM
- isOver = actualReadBytes < bytesToRead ∨ newRemaining ≡ Just 0
+observeNonChunkedRequest ∷ Interaction → Lazy.ByteString → IO ()
+observeNonChunkedRequest itr input
+ = join $
+ atomically $
+ do wantedM ← readTVar $ itrReqBodyWanted itr
+ if isNothing wantedM then
+ do wasteAll ← readTVar itr itrReqBodyWasteAll id
+ if wasteAll then
+ wasteNonChunkedRequestBody itr input
+ else
+ retry
+ else
+ readNonChunkedRequestBody itr input
- writeItr itr itrReqChunkRemaining newRemaining
- writeItr itr itrReqChunkIsOver isOver
- writeItr itr itrReqBodyWanted Nothing
- writeItr itr itrReceivedBody chunk
- writeItr itrReceivedBody actualReadBytes
+wasteNonChunkedRequestBody ∷ Interaction → Lazy.ByteString → Maybe Int → IO ()
+wasteNonChunkedRequestBody itr input remaining
+ = do let input' = case remaining of
+ Just len → Lazy.drop len input
+ Nothing → (∅)
+ writeTVar (itrReqChunkIsOver itr) True
+ acceptRequest input'
- if isOver then
- return $ acceptRequest input'
- else
- return $ observeNonChunkedRequest itr input'
- action
+readNonChunkedRequestBody ∷ Interaction → Lazy.ByteString → Int → Maybe Int → IO ()
+readNonChunkedRequestBody itr input wanted remaining
+ = do let bytesToRead = fromIntegral $ maybe wanted (min wanted) remaining
+ (chunk, input') = Lazy.splitAt bytesToRead input
+ actualReadBytes = fromIntegral $ Lazy.length chunk
+ newRemaining = (- actualReadBytes) <$> remaining
+ isOver = actualReadBytes < bytesToRead ∨ newRemaining ≡ Just 0
+ writeTVar (itrReqChunkIsOver itr) isOver
+ writeTVar (itrReqBodyWanted itr) Nothing
+ writeTVar (itrReceivedBody itr) chunk
+ writeTVar (itrReceivedBodyLen itr) actualReadBytes
+ if isOver then
+ acceptRequest input'
+ else
+ observeNonChunkedRequest itr input'
- enqueue :: Interaction -> STM ()
- enqueue itr = {-# SCC "enqueue" #-}
- do queue <- readTVar tQueue
- writeTVar tQueue (itr <| queue)
\ No newline at end of file
+enqueue ∷ HandleLike h ⇒ Context h → Interaction → STM ()
+enqueue (Context {..}) itr
+ = do queue ← readTVar cQueue
+ writeTVar cQueue (itr ⊲ queue)
-- |Get the 'Request' value which represents the request header. In
-- general you don't have to use this action.
getRequest ∷ Resource Request
-getRequest
- = do itr ← getInteraction
- liftIO $ atomically $ fromJust <$> readTVar (itrRequest itr)
+getRequest = (fromJust ∘ itrRequest) <$> getInteraction
-- |Get the 'Method' value of the request.
getMethod ∷ Resource Method
input limit
= do driftTo GettingBody
itr ← getInteraction
- hasBody ← liftIO $ atomically $ readTVar $ itrRequestHasBody itr
- chunk ← if hasBody then
+ chunk ← if reqHasBody $ fromJust $ itrRequest itr then
askForInput itr
else
do driftTo DecidingHeader
$ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
-- Reader にリクエスト
liftIO $ atomically
- $ do chunkLen ← readTVar itrReqChunkLength
- writeTVar itrWillReceiveBody True
- if ((> actualLimit) <$> chunkLen) ≡ Just True then
- -- 受信前から多過ぎる事が分かってゐる
- tooLarge actualLimit
- else
- writeTVar itrReqBodyWanted (Just actualLimit)
+ $ writeTVar itrReqBodyWanted (Just actualLimit)
-- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
chunk ← liftIO $ atomically
$ do chunkLen ← readTVar itrReceivedBodyLen
inputChunk limit
= do driftTo GettingBody
itr ← getInteraction
- hasBody ← liftIO $ atomically $ readTVar $ itrRequestHasBody itr
- chunk ← if hasBody then
- askForInput itr
- else
- do driftTo DecidingHeader
- return (∅)
+ chunk ← if reqHasBody $ fromJust $ itrRequest itr then
+ askForInput itr
+ else
+ do driftTo DecidingHeader
+ return (∅)
return chunk
where
askForInput ∷ Interaction → Resource Lazy.ByteString
askForInput (Interaction {..})
= do let confLimit = cnfMaxEntityLength itrConfig
actualLimit = if limit < 0 then
- confLimit
- else
- limit
- when (actualLimit <= 0)
+ confLimit
+ else
+ limit
+ when (actualLimit ≤ 0)
$ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
-- Reader にリクエスト
liftIO $ atomically
- $ do writeTVar itrReqBodyWanted (Just actualLimit)
- writeTVar itrWillReceiveBody True
+ $ writeTVar itrReqBodyWanted (Just actualLimit)
-- 應答を待つ。トランザクションを分けなければ當然デッドロック。
chunk ← liftIO $ atomically
$ do chunkLen ← readTVar itrReceivedBodyLen
-- | 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
+setStatus sc
= do driftTo DecidingHeader
itr ← getInteraction
- liftIO $ atomically
- $ do res ← readTVar $ itrResponse itr
- let res' = res {
- resStatus = code
- }
- writeTVar (itrResponse itr) res'
+ liftIO
+ $ atomically
+ $ setResponseStatus itr sc
-- | Set a value of given resource header. Comparison of header name
-- is case-insensitive. Note that this action is not intended to be
unless (Lazy.null wholeChunk)
$ liftIO $ atomically $
- writeTVar (itrSentNoBody itr) False
+ writeTVar (itrSentNoBodySoFar itr) False
where
sendChunks ∷ Interaction → Lazy.ByteString → Int → Resource ()
sendChunks itr@(Interaction {..}) str limit
drift itr DecidingHeader _
= postprocess itr
drift itr@(Interaction {..}) _ Done
- = do bodyIsNull ← readTVar itrSentNoBody
+ = do bodyIsNull ← readTVar itrSentNoBodySoFar
when bodyIsNull
$ writeDefaultPage itr
drift _ _ _
-- ]
-- @
mkResTree ∷ [ ([Text], ResourceDef) ] → ResTree
-mkResTree = processRoot . map (first canonicalisePath)
+mkResTree = processRoot ∘ map (first canonicalisePath)
where
canonicalisePath ∷ [Text] → [Text]
canonicalisePath = filter (≢ "")
processRoot ∷ [ ([Text], ResourceDef) ] → ResTree
processRoot list
- = let (roots, nonRoots) = partition (\ (path, _) → path == []) list
+ = let (roots, nonRoots) = partition (\(path, _) → null path) list
children = processNonRoot nonRoots
in
if null roots then
= let subtree = M.fromList [(name, node name)
| name ← childNames]
childNames = [name | (name:_, _) ← list]
- node name = let defs = [def | (path, def) ← list, path == [name]]
+ node name = let defs = [def | (path, def) ← list, path ≡ [name]]
in
if null defs then
-- No resources are defined
in
subtree
-
findResource ∷ ResTree → [FallbackHandler] → URI → IO (Maybe ([Text], ResourceDef))
findResource (ResTree (ResNode rootDefM subtree)) fbs uri
- = do let path = splitPathInfo uri
- haveGreedyRoot = case rootDefM of
- Just def → resIsGreedy def
- Nothing → False
- foundInTree = if haveGreedyRoot ∨ null path then
+ = do let path = splitPathInfo uri
+ hasGreedyRoot = maybe False resIsGreedy rootDefM
+ foundInTree = if hasGreedyRoot ∨ null path then
do def ← rootDefM
return ([], def)
else
= error "Internal error: should not reach here."
walkTree tree (name:[]) soFar
- = case M.lookup name tree of
- Nothing → Nothing
- Just (ResNode defM _) → do def ← defM
- return (soFar ⧺ [name], def)
+ = do ResNode defM _ ← M.lookup name tree
+ def ← defM
+ return (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])
+ = do ResNode defM sub ← M.lookup x tree
+ case defM of
+ Just (ResourceDef { resIsGreedy = True })
+ → do def ← defM
+ return (soFar ⧺ [x], def)
+ _ → walkTree sub xs (soFar ⧺ [x])
fallback ∷ [Text] → [FallbackHandler] → IO (Maybe ([Text], ResourceDef))
fallback _ [] = return Nothing
fallback path (x:xs) = do m ← x path
case m of
- Just def → return $! Just ([], def)
+ Just def → return $ Just ([], def)
Nothing → fallback path xs
runResource ∷ ResourceDef → Interaction → IO ThreadId
runResource (ResourceDef {..}) itr@(Interaction {..})
- = fork $ ( runRes ( do req ← getRequest
- fromMaybe notAllowed $ rsrc req
- driftTo Done
- ) itr
- )
- `catch`
- processException
+ = fork $ run `catch` processException
where
fork ∷ IO () → IO ThreadId
fork | resUsesNativeThread = forkOS
| otherwise = forkIO
+
+ run ∷ IO ()
+ run = flip runRes itr $
+ do req ← getRequest
+ fromMaybe notAllowed $ rsrc req
+ driftTo Done
rsrc ∷ Request → Maybe (Resource ())
rsrc req
methods ∷ Maybe a → [Ascii] → [Ascii]
methods m xs
- = case m of
- Just _ → xs
- Nothing → []
+ | isJust m = xs
+ | otherwise = []
toAbortion ∷ SomeException → Abortion
toAbortion e
-- を應答に反映させる餘地がある。さうでなければ stderr
-- にでも吐くしか無い。
state ← atomically $ readTVar itrState
- reqM ← atomically $ readTVar itrRequest
res ← atomically $ readTVar itrResponse
if state ≤ DecidingHeader then
flip runRes itr $
do setStatus $ aboStatus abo
mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo
- output $ LT.encodeUtf8 $ abortPage itrConfig reqM res abo
- else
+ output $ LT.encodeUtf8 $ abortPage itrConfig itrRequest res abo
+ else
when (cnfDumpTooLateAbortionToStderr itrConfig)
- $ hPutStrLn stderr $ show abo
-
+ $ hPutStrLn stderr $ show abo
runRes (driftTo Done) itr
projects / Lucu.git / commitdiff