From: PHO Date: Sat, 8 Oct 2011 09:59:29 +0000 (+0900) Subject: changed everything like a maniac X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=commitdiff_plain;h=ca338174155913a969808d7b20193973394e474e changed everything like a maniac --- diff --git a/Network/HTTP/Lucu/Chunk.hs b/Network/HTTP/Lucu/Chunk.hs index a419464..25d6907 100644 --- a/Network/HTTP/Lucu/Chunk.hs +++ b/Network/HTTP/Lucu/Chunk.hs @@ -2,9 +2,9 @@ UnicodeSyntax #-} module Network.HTTP.Lucu.Chunk - ( chunkHeaderP -- Num a => Parser a - , chunkFooterP -- Parser () - , chunkTrailerP -- Parser Headers + ( chunkHeaderP + , chunkFooterP + , chunkTrailerP ) where import Control.Applicative diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index 5c6846b..e1bdf1c 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -49,8 +49,7 @@ writeDefaultPage (Interaction {..}) -- 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 diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index b36927d..3308bbf 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -7,6 +7,8 @@ module Network.HTTP.Lucu.Headers ( Headers , HasHeaders(..) + , singleton + , toHeaders , fromHeaders @@ -63,6 +65,11 @@ instance HasHeaders Headers where getHeaders = id setHeaders _ = id +singleton ∷ CIAscii → Ascii → Headers +{-# INLINE singleton #-} +singleton key val + = Headers $ M.singleton key val + toHeaders ∷ [(CIAscii, Ascii)] → Headers {-# INLINE toHeaders #-} toHeaders = flip mkHeaders (∅) diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 8a64dc1..5821579 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -1,6 +1,6 @@ {-# LANGUAGE - BangPatterns - , OverloadedStrings + OverloadedStrings + , RecordWildCards , UnicodeSyntax #-} module Network.HTTP.Lucu.Interaction @@ -10,11 +10,8 @@ module Network.HTTP.Lucu.Interaction , newInteractionQueue , newInteraction , defaultPageContentType -{- - , writeItr - , readItr - , updateItr --} + + , setResponseStatus ) where import Blaze.ByteString.Builder (Builder) @@ -28,6 +25,7 @@ import Network.Socket 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 @@ -38,33 +36,25 @@ data Interaction = Interaction { , 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 @@ -84,39 +74,34 @@ newInteractionQueue = newTVarIO S.empty 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 @@ -124,57 +109,31 @@ newInteraction !conf !port !addr !cert !req , 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' diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs index 226e014..3e3df16 100644 --- a/Network/HTTP/Lucu/MIMEType/Guess.hs +++ b/Network/HTTP/Lucu/MIMEType/Guess.hs @@ -17,7 +17,7 @@ module Network.HTTP.Lucu.MIMEType.Guess 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) @@ -45,9 +45,9 @@ guessTypeByFileName !extMap !fpath 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) diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 4950a0b..732c47a 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -94,8 +94,7 @@ postprocess (Interaction {..}) ⊕ printStatusCode sc ⊕ A.toAsciiBuilder " but no Location header." - reqM ← readTVar itrRequest - case reqM of + case itrRequest of Just req → postprocessWithRequest sc req Nothing → return () diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index 9321b6b..f2212ab 100644 --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -5,158 +5,221 @@ , 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 diff --git a/Network/HTTP/Lucu/Request.hs b/Network/HTTP/Lucu/Request.hs index b690c3e..d23dc63 100644 --- a/Network/HTTP/Lucu/Request.hs +++ b/Network/HTTP/Lucu/Request.hs @@ -1,15 +1,15 @@ {-# 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 @@ -51,6 +51,11 @@ instance HasHeaders Request 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 diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 9307c8d..5818378 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -1,22 +1,22 @@ {-# 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 @@ -27,273 +27,256 @@ import Network.HTTP.Lucu.Preprocess import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.Resource.Tree -import Prelude hiding (catch) -import System.IO (stderr) +import 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) diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index b7f76f8..298b9b2 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -236,9 +236,7 @@ getRemoteCertificate = itrRemoteCert <$> getInteraction -- |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 @@ -608,8 +606,7 @@ input ∷ Int → Resource Lazy.ByteString 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 @@ -627,13 +624,7 @@ input limit $ 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 @@ -683,27 +674,25 @@ inputChunk ∷ Int → Resource Lazy.ByteString 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 @@ -793,15 +782,12 @@ defaultLimit = (-1) -- | 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 @@ -911,7 +897,7 @@ outputChunk wholeChunk 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 @@ -969,7 +955,7 @@ driftTo newState drift itr DecidingHeader _ = postprocess itr drift itr@(Interaction {..}) _ Done - = do bodyIsNull ← readTVar itrSentNoBody + = do bodyIsNull ← readTVar itrSentNoBodySoFar when bodyIsNull $ writeDefaultPage itr drift _ _ _ diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index 092ee06..6bf422f 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -146,14 +146,14 @@ data ResNode = ResNode (Maybe ResourceDef) ResSubtree -- ] -- @ 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 @@ -171,7 +171,7 @@ mkResTree = processRoot . map (first canonicalisePath) = 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 @@ -186,14 +186,11 @@ mkResTree = processRoot . map (first canonicalisePath) 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 @@ -209,41 +206,39 @@ findResource (ResTree (ResNode rootDefM subtree)) fbs uri = 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 @@ -275,9 +270,8 @@ runResource (ResourceDef {..}) itr@(Interaction {..}) methods ∷ Maybe a → [Ascii] → [Ascii] methods m xs - = case m of - Just _ → xs - Nothing → [] + | isJust m = xs + | otherwise = [] toAbortion ∷ SomeException → Abortion toAbortion e @@ -292,15 +286,13 @@ runResource (ResourceDef {..}) itr@(Interaction {..}) -- を應答に反映させる餘地がある。さうでなければ 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