From 2bb7a0baa35dadb5d36d3f9fa98bd242baabc6d1 Mon Sep 17 00:00:00 2001 From: PHO Date: Wed, 5 Oct 2011 16:26:22 +0900 Subject: [PATCH] Many changes... Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa --- Network/HTTP/Lucu/DefaultPage.hs | 25 ++- Network/HTTP/Lucu/Headers.hs | 15 +- Network/HTTP/Lucu/Interaction.hs | 3 +- Network/HTTP/Lucu/Postprocess.hs | 66 ++++---- Network/HTTP/Lucu/Preprocess.hs | 227 ++++++++++++++-------------- Network/HTTP/Lucu/Resource.hs | 133 ++++++++-------- Network/HTTP/Lucu/Resource/Tree.hs | 65 ++++---- Network/HTTP/Lucu/ResponseWriter.hs | 71 +++++---- 8 files changed, 303 insertions(+), 302 deletions(-) diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index 1e5a7a6..5c6846b 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -1,6 +1,6 @@ {-# LANGUAGE - BangPatterns - , OverloadedStrings + OverloadedStrings + , RecordWildCards , UnboxedTuples , UnicodeSyntax #-} @@ -35,7 +35,7 @@ import Text.XML.HXT.DOM.TypeDefs getDefaultPage ∷ Config → Maybe Request → Response → Lazy.Text {-# INLINEABLE getDefaultPage #-} -getDefaultPage !conf !req !res +getDefaultPage conf req res = let msgA = getMsg req res [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA ⋙ @@ -45,20 +45,17 @@ getDefaultPage !conf !req !res Lazy.pack xmlStr writeDefaultPage ∷ Interaction → STM () -writeDefaultPage !itr +writeDefaultPage (Interaction {..}) -- Content-Type が正しくなければ補完できない。 - = do res ← readItr itrResponse itr - when (getHeader "Content-Type" res == Just defaultPageContentType) - $ do reqM ← readItr itrRequest itr - - let conf = itrConfig itr - page = getDefaultPage conf reqM res - - putTMVar (itrBodyToSend itr) (BB.fromLazyText page) + = do res ← readTVar itrResponse + when (getHeader "Content-Type" res ≡ Just defaultPageContentType) + $ do reqM ← readTVar itrRequest + let page = getDefaultPage itrConfig reqM res + putTMVar itrBodyToSend (BB.fromLazyText page) mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree {-# INLINEABLE mkDefaultPage #-} -mkDefaultPage !conf !status !msgA +mkDefaultPage conf status msgA = let sStr = A.toString $ A.fromAsciiBuilder $ printStatusCode status sig = concat [ A.toString (cnfServerSoftware conf) , " at " @@ -81,7 +78,7 @@ mkDefaultPage !conf !status !msgA getMsg ∷ (ArrowXml a) ⇒ Maybe Request → Response → a b XmlTree {-# INLINEABLE getMsg #-} -getMsg !req !res +getMsg req res = case resStatus res of -- 1xx は body を持たない -- 2xx の body は補完しない diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index a5fdb02..b36927d 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -1,6 +1,5 @@ {-# LANGUAGE - BangPatterns - , GeneralizedNewtypeDeriving + GeneralizedNewtypeDeriving , OverloadedStrings , UnicodeSyntax #-} @@ -37,21 +36,25 @@ class HasHeaders a where setHeaders ∷ a → Headers → a getHeader ∷ CIAscii → a → Maybe Ascii - {-# INLINE getHeader #-} - getHeader !key !a + getHeader key a = case getHeaders a of Headers m → M.lookup key m + getCIHeader ∷ CIAscii → a → Maybe CIAscii + {-# INLINE getCIHeader #-} + getCIHeader key a + = A.toCIAscii <$> getHeader key a + deleteHeader ∷ CIAscii → a → a {-# INLINE deleteHeader #-} - deleteHeader !key !a + deleteHeader key a = case getHeaders a of Headers m → setHeaders a $ Headers $ M.delete key m setHeader ∷ CIAscii → Ascii → a → a {-# INLINE setHeader #-} - setHeader !key !val !a + setHeader key val a = case getHeaders a of Headers m → setHeaders a $ Headers $ M.insert key val m diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 1c2679c..8a64dc1 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -10,10 +10,11 @@ module Network.HTTP.Lucu.Interaction , newInteractionQueue , newInteraction , defaultPageContentType - +{- , writeItr , readItr , updateItr +-} ) where import Blaze.ByteString.Builder (Builder) diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 1a00b00..4950a0b 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DoAndIfThenElse , OverloadedStrings + , RecordWildCards , UnicodeSyntax #-} module Network.HTTP.Lucu.Postprocess @@ -14,7 +15,6 @@ import Control.Monad import Control.Monad.Unicode import Data.Ascii (Ascii, CIAscii) import qualified Data.Ascii as A -import Data.Maybe import Data.Monoid.Unicode import Data.Time import qualified Data.Time.HTTP as HTTP @@ -29,6 +29,8 @@ import Network.HTTP.Lucu.Response import Prelude.Unicode {- + TODO: Tanslate this memo into English. It doesn't make sense to + non-Japanese speakers. * Response が未設定なら、200 OK にする。 @@ -62,9 +64,8 @@ import Prelude.Unicode -} postprocess ∷ Interaction → STM () -postprocess itr - = do reqM ← readItr itrRequest itr - res ← readItr itrResponse itr +postprocess (Interaction {..}) + = do res ← readTVar itrResponse let sc = resStatus res unless (any (\ p → p sc) [isSuccessful, isRedirection, isError]) @@ -93,28 +94,27 @@ postprocess itr ⊕ printStatusCode sc ⊕ A.toAsciiBuilder " but no Location header." - when (reqM ≢ Nothing) relyOnRequest + reqM ← readTVar itrRequest + case reqM of + Just req → postprocessWithRequest sc req + Nothing → return () -- itrResponse の内容は relyOnRequest によって變へられてゐる可 -- 能性が高い。 - do oldRes ← readItr itrResponse itr + do oldRes ← readTVar itrResponse newRes ← unsafeIOToSTM - $ completeUnconditionalHeaders (itrConfig itr) oldRes - writeItr itrResponse newRes itr + $ completeUnconditionalHeaders itrConfig oldRes + writeTVar itrResponse newRes where - relyOnRequest ∷ STM () - relyOnRequest - = do status ← resStatus <$> readItr itrResponse itr - req ← fromJust <$> readItr itrRequest itr - - let reqVer = reqVersion req - canHaveBody = if reqMethod req ≡ HEAD then + postprocessWithRequest ∷ StatusCode → Request → STM () + postprocessWithRequest sc (Request {..}) + = do let canHaveBody = if reqMethod ≡ HEAD then False else - not (isInformational status ∨ - status ≡ NoContent ∨ - status ≡ ResetContent ∨ - status ≡ NotModified ) + (¬) (isInformational sc ∨ + sc ≡ NoContent ∨ + sc ≡ ResetContent ∨ + sc ≡ NotModified ) updateRes $ deleteHeader "Content-Length" updateRes $ deleteHeader "Transfer-Encoding" @@ -124,36 +124,42 @@ postprocess itr $ updateRes $ setHeader "Content-Type" defaultPageContentType if canHaveBody then - when (reqVer ≡ HttpVersion 1 1) + when (reqVersion ≡ HttpVersion 1 1) $ do updateRes $ setHeader "Transfer-Encoding" "chunked" - writeItr itrWillChunkBody True itr + writeTVar itrWillChunkBody True else -- body 関連のヘッダを削除。但し HEAD なら Content-* は殘す - when (reqMethod req ≢ HEAD) + when (reqMethod ≢ HEAD) $ do updateRes $ deleteHeader "Content-Type" updateRes $ deleteHeader "Etag" updateRes $ deleteHeader "Last-Modified" - conn ← readHeader "Connection" + conn ← readCIHeader "Connection" case conn of Nothing → return () - Just value → when (A.toCIAscii value ≡ "close") - $ writeItr itrWillClose True itr + Just value → when (value ≡ "close") + $ writeTVar itrWillClose True - willClose ← readItr itrWillClose itr + willClose ← readTVar itrWillClose when willClose $ updateRes $ setHeader "Connection" "close" - when (reqMethod req ≡ HEAD ∨ not canHaveBody) - $ writeTVar (itrWillDiscardBody itr) True + when (reqMethod ≡ HEAD ∨ not canHaveBody) + $ writeTVar itrWillDiscardBody True readHeader ∷ CIAscii → STM (Maybe Ascii) {-# INLINE readHeader #-} - readHeader k = getHeader k <$> readItr itrResponse itr + readHeader k = getHeader k <$> readTVar itrResponse + + readCIHeader ∷ CIAscii → STM (Maybe CIAscii) + {-# INLINE readCIHeader #-} + readCIHeader k = getCIHeader k <$> readTVar itrResponse updateRes ∷ (Response → Response) → STM () {-# INLINE updateRes #-} - updateRes f = updateItr itrResponse f itr + updateRes f + = do old ← readTVar itrResponse + writeTVar itrResponse (f old) completeUnconditionalHeaders ∷ Config → Response → IO Response completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index 9f9fa0d..9321b6b 100644 --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -1,26 +1,36 @@ {-# LANGUAGE - BangPatterns + DoAndIfThenElse + , OverloadedStrings + , RecordWildCards + , UnicodeSyntax #-} 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.URI +import Control.Applicative +import Control.Concurrent.STM +import Control.Monad +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 Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.HttpVersion +import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Response +import Network.URI +import Prelude.Unicode {- + TODO: Tanslate this memo into English. It doesn't make sense to + non-Japanese speakers. * URI にホスト名が存在しない時、 [1] HTTP/1.0 ならば Config を使って補完 @@ -46,112 +56,107 @@ import Network.URI Request にする。 * willDiscardBody その他の變數を設定する。 - -} -preprocess :: Interaction -> STM () -preprocess !itr - = do req <- readItr itr itrRequest fromJust +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 + if reqVer ≢ HttpVersion 1 0 ∧ + reqVer ≢ HttpVersion 1 1 then - do setStatus HttpVersionNotSupported - writeItr itr itrWillClose True + do setStatus itr HttpVersionNotSupported + writeTVar itrWillClose True - else + else -- HTTP/1.0 では Keep-Alive できない - do when (reqVer == HttpVersion 1 0) - $ writeItr itr itrWillClose True + do when (reqVer ≡ HttpVersion 1 0) + $ writeTVar itrWillClose True -- ホスト部の補完 - completeAuthority req + completeAuthority itr 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 + GET → return () + HEAD → writeTVar itrWillDiscardBody True + POST → writeTVar itrRequestHasBody True + PUT → writeTVar itrRequestHasBody True + DELETE → return () + _ → setStatus itr NotImplemented - preprocessHeader req - where - setStatus :: StatusCode -> STM () - setStatus !status - = updateItr itr itrResponse - $! \ res -> res { - resStatus = status - } - - completeAuthority :: Request -> STM () - completeAuthority !req - = when (uriAuthority (reqURI req) == Nothing) - $ if reqVersion req == HttpVersion 1 0 then - -- HTTP/1.0 なので Config から補完 - do let conf = itrConfig itr - host = cnfServerHost conf - port = itrLocalPort itr - portStr - = case port of - 80 -> "" - n -> ':' : show n - updateAuthority host (C8.pack portStr) - else - case getHeader (C8.pack "Host") req of - Just str -> let (host, portStr) = parseHost str - in updateAuthority host portStr - Nothing -> setStatus BadRequest - - - parseHost :: Strict.ByteString -> (Strict.ByteString, Strict.ByteString) - parseHost = C8.break (== ':') - - - updateAuthority :: Strict.ByteString -> Strict.ByteString -> STM () - updateAuthority !host !portStr - = updateItr itr itrRequest - $! \ (Just req) -> Just req { - reqURI = let uri = reqURI req - in uri { - uriAuthority = Just URIAuth { - uriUserInfo = "" - , uriRegName = C8.unpack host - , uriPort = C8.unpack portStr - } - } - } - - - preprocessHeader :: Request -> STM () - preprocessHeader !req - = do case getHeader (C8.pack "Expect") req of - Nothing -> return () - Just value -> if value `noCaseEq` C8.pack "100-continue" then - writeItr itr itrExpectedContinue True - else - setStatus ExpectationFailed - - case getHeader (C8.pack "Transfer-Encoding") req of - Nothing -> return () - Just value -> unless (value `noCaseEq` C8.pack "identity") - $ if value `noCaseEq` C8.pack "chunked" then - writeItr itr itrRequestIsChunked True - else - setStatus NotImplemented - - case getHeader (C8.pack "Content-Length") req of - Nothing -> return () - Just value -> if C8.all isDigit value then - do let Just (len, _) = C8.readInt value - writeItr itr itrReqChunkLength $ Just len - writeItr itr itrReqChunkRemaining $ Just len - else - setStatus BadRequest - - case getHeader (C8.pack "Connection") req of - Nothing -> return () - Just value -> when (value `noCaseEq` C8.pack "close") - $ writeItr itr itrWillClose True + 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 + +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 + + case getCIHeader "Transfer-Encoding" 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 + + case getCIHeader "Connection" req of + Nothing → return () + Just value → when (value ≡ "close") + $ writeTVar itrWillClose True diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 0dd73c9..b7f76f8 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,6 +1,5 @@ {-# LANGUAGE - BangPatterns - , GeneralizedNewtypeDeriving + GeneralizedNewtypeDeriving , DoAndIfThenElse , OverloadedStrings , RecordWildCards @@ -239,7 +238,7 @@ getRemoteCertificate = itrRemoteCert <$> getInteraction getRequest ∷ Resource Request getRequest = do itr ← getInteraction - liftIO $ atomically $ fromJust <$> readItr itrRequest itr + liftIO $ atomically $ fromJust <$> readTVar (itrRequest itr) -- |Get the 'Method' value of the request. getMethod ∷ Resource Method @@ -434,7 +433,7 @@ getAuthorization -- 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 +foundEntity tag timeStamp = do driftTo ExaminingRequest method ← getMethod @@ -455,7 +454,7 @@ foundEntity !tag !timeStamp -- This action is not preferred. You should use 'foundEntity' whenever -- possible. foundETag ∷ ETag → Resource () -foundETag !tag +foundETag tag = do driftTo ExaminingRequest method ← getMethod @@ -609,7 +608,7 @@ input ∷ Int → Resource Lazy.ByteString input limit = do driftTo GettingBody itr ← getInteraction - hasBody ← liftIO $ atomically $ readItr itrRequestHasBody itr + hasBody ← liftIO $ atomically $ readTVar $ itrRequestHasBody itr chunk ← if hasBody then askForInput itr else @@ -618,8 +617,8 @@ input limit return chunk where askForInput ∷ Interaction → Resource Lazy.ByteString - askForInput itr - = do let confLimit = cnfMaxEntityLength $ itrConfig itr + askForInput (Interaction {..}) + = do let confLimit = cnfMaxEntityLength itrConfig actualLimit = if limit ≤ 0 then confLimit else @@ -628,17 +627,17 @@ input limit $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit) -- Reader にリクエスト liftIO $ atomically - $ do chunkLen ← readItr itrReqChunkLength itr - writeItr itrWillReceiveBody True itr + $ do chunkLen ← readTVar itrReqChunkLength + writeTVar itrWillReceiveBody True if ((> actualLimit) <$> chunkLen) ≡ Just True then -- 受信前から多過ぎる事が分かってゐる tooLarge actualLimit else - writeItr itrReqBodyWanted (Just actualLimit) itr + writeTVar itrReqBodyWanted (Just actualLimit) -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。 chunk ← liftIO $ atomically - $ do chunkLen ← readItr itrReceivedBodyLen itr - chunkIsOver ← readItr itrReqChunkIsOver itr + $ do chunkLen ← readTVar itrReceivedBodyLen + chunkIsOver ← readTVar itrReqChunkIsOver if chunkLen < actualLimit then -- 要求された量に滿たなくて、まだ殘りが -- あるなら再試行。 @@ -651,9 +650,9 @@ input limit $ tooLarge actualLimit -- 成功。itr 内にチャンクを置いたままにする -- とメモリの無駄になるので除去。 - chunk ← seqToLBS <$> readItr itrReceivedBody itr - writeItr itrReceivedBody (∅) itr - writeItr itrReceivedBodyLen 0 itr + chunk ← seqToLBS <$> readTVar itrReceivedBody + writeTVar itrReceivedBody (∅) + writeTVar itrReceivedBodyLen 0 return chunk driftTo DecidingHeader @@ -684,7 +683,7 @@ inputChunk ∷ Int → Resource Lazy.ByteString inputChunk limit = do driftTo GettingBody itr ← getInteraction - hasBody ← liftIO $ atomically $ readItr itrRequestHasBody itr + hasBody ← liftIO $ atomically $ readTVar $ itrRequestHasBody itr chunk ← if hasBody then askForInput itr else @@ -693,8 +692,8 @@ inputChunk limit return chunk where askForInput ∷ Interaction → Resource Lazy.ByteString - askForInput itr - = do let confLimit = cnfMaxEntityLength $ itrConfig itr + askForInput (Interaction {..}) + = do let confLimit = cnfMaxEntityLength itrConfig actualLimit = if limit < 0 then confLimit else @@ -703,21 +702,21 @@ inputChunk limit $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit) -- Reader にリクエスト liftIO $ atomically - $ do writeItr itrReqBodyWanted (Just actualLimit) itr - writeItr itrWillReceiveBody True itr + $ do writeTVar itrReqBodyWanted (Just actualLimit) + writeTVar itrWillReceiveBody True -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 chunk ← liftIO $ atomically - $ do chunkLen ← readItr itrReceivedBodyLen itr + $ do chunkLen ← readTVar itrReceivedBodyLen -- 要求された量に滿たなくて、まだ殘りがある -- なら再試行。 when (chunkLen < actualLimit) - $ do chunkIsOver ← readItr itrReqChunkIsOver itr + $ do chunkIsOver ← readTVar itrReqChunkIsOver unless chunkIsOver $ retry -- 成功 - chunk ← seqToLBS <$> readItr itrReceivedBody itr - writeItr itrReceivedBody (∅) itr - writeItr itrReceivedBodyLen 0 itr + chunk ← seqToLBS <$> readTVar itrReceivedBody + writeTVar itrReceivedBody (∅) + writeTVar itrReceivedBodyLen 0 return chunk when (Lazy.null chunk) $ driftTo DecidingHeader @@ -797,11 +796,12 @@ setStatus ∷ StatusCode → Resource () setStatus code = do driftTo DecidingHeader itr ← getInteraction - liftIO $ atomically $ updateItr itrResponse f itr - where - f res = res { - resStatus = code - } + liftIO $ atomically + $ do res ← readTVar $ itrResponse itr + let res' = res { + resStatus = code + } + writeTVar (itrResponse itr) res' -- | Set a value of given resource header. Comparison of header name -- is case-insensitive. Note that this action is not intended to be @@ -825,7 +825,9 @@ setHeader' ∷ CIAscii → Ascii → Resource () setHeader' name value = do itr ← getInteraction liftIO $ atomically - $ updateItr itrResponse (H.setHeader name value) itr + $ do res ← readTVar $ itrResponse itr + let res' = H.setHeader name value res + writeTVar (itrResponse itr) res' -- | Computation of @'redirect' code uri@ sets the response status to -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy @@ -883,18 +885,16 @@ setWWWAuthenticate 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. +-- | Write a 'Lazy.ByteString' to the response body, and then transit +-- to the /Done/ state. It is safe to apply 'output' to an infinite +-- string, such as the lazy stream of \/dev\/random. output ∷ Lazy.ByteString → Resource () {-# INLINE output #-} output str = outputChunk str *> driftTo Done --- | 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. +-- | Write a 'Lazy.ByteString' to the response body. This action can +-- be repeated as many times as you want. It is safe to apply +-- 'outputChunk' to an infinite string. outputChunk ∷ Lazy.ByteString → Resource () outputChunk wholeChunk = do driftTo DecidingBody @@ -905,24 +905,21 @@ outputChunk wholeChunk $ abort InternalServerError [] (Just $ "cnfMaxOutputChunkLength must be positive: " ⊕ T.pack (show limit)) - discardBody ← liftIO $ atomically $ - readItr itrWillDiscardBody itr - + discardBody ← liftIO $ atomically $ readTVar $ itrWillDiscardBody itr unless (discardBody) - $ sendChunks wholeChunk limit + $ sendChunks itr wholeChunk limit unless (Lazy.null wholeChunk) $ liftIO $ atomically $ - writeItr itrSentNoBody False itr + writeTVar (itrSentNoBody itr) False where - sendChunks ∷ Lazy.ByteString → Int → Resource () - sendChunks str limit + sendChunks ∷ Interaction → Lazy.ByteString → Int → Resource () + sendChunks itr@(Interaction {..}) str limit | Lazy.null str = return () | otherwise = do let (chunk, remaining) = Lazy.splitAt (fromIntegral limit) str - itr ← getInteraction liftIO $ atomically - $ putTMVar (itrBodyToSend itr) (chunkToBuilder chunk) - sendChunks remaining limit + $ putTMVar itrBodyToSend (chunkToBuilder chunk) + sendChunks itr remaining limit chunkToBuilder ∷ Lazy.ByteString → Builder chunkToBuilder = mconcat ∘ map BB.fromByteString ∘ Lazy.toChunks @@ -949,37 +946,31 @@ outputChunk wholeChunk driftTo ∷ InteractionState → Resource () driftTo newState = do itr ← getInteraction - liftIO $ atomically $ do oldState ← readItr itrState itr - 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 itrState newState itr + liftIO $ atomically + $ do oldState ← readTVar $ itrState itr + 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 + writeTVar (itrState itr) newState where - throwStateError ∷ Monad m => InteractionState → InteractionState → m a - + 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 itrReqBodyWasteAll True itr - + drift (Interaction {..}) GettingBody _ + = writeTVar itrReqBodyWasteAll True drift itr DecidingHeader _ = postprocess itr - - drift itr _ Done - = do bodyIsNull ← readItr itrSentNoBody itr + drift itr@(Interaction {..}) _ Done + = do bodyIsNull ← readTVar itrSentNoBody when bodyIsNull $ writeDefaultPage itr - drift _ _ _ = return () diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index d386bce..092ee06 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DoAndIfThenElse , OverloadedStrings + , RecordWildCards , UnicodeSyntax #-} {-# OPTIONS_HADDOCK prune #-} @@ -231,32 +232,30 @@ findResource (ResTree (ResNode rootDefM subtree)) fbs uri runResource ∷ ResourceDef → Interaction → IO ThreadId -runResource def itr - = def `seq` itr `seq` - fork - $! catch ( runRes ( do req ← getRequest - fromMaybe notAllowed $ rsrc req - driftTo Done - ) itr - ) - processException +runResource (ResourceDef {..}) itr@(Interaction {..}) + = fork $ ( runRes ( do req ← getRequest + fromMaybe notAllowed $ rsrc req + driftTo Done + ) itr + ) + `catch` + processException where fork ∷ IO () → IO ThreadId - fork = if resUsesNativeThread def - then forkOS - else forkIO + fork | resUsesNativeThread = forkOS + | otherwise = forkIO rsrc ∷ Request → Maybe (Resource ()) rsrc req = case reqMethod req of - GET → resGet def - HEAD → case resHead def of + GET → resGet + HEAD → case resHead of Just r → Just r - Nothing → resGet def - POST → resPost def - PUT → resPut def - DELETE → resDelete def - _ → undefined + Nothing → resGet + POST → resPost + PUT → resPut + DELETE → resDelete + _ → error $ "Unknown request method: " ⧺ show (reqMethod req) notAllowed ∷ Resource () notAllowed @@ -274,10 +273,11 @@ runResource def itr , methods resDelete ["DELETE"] ] - methods ∷ (ResourceDef → Maybe a) → [Ascii] → [Ascii] - methods f xs = case f def of - Just _ → xs - Nothing → [] + methods ∷ Maybe a → [Ascii] → [Ascii] + methods m xs + = case m of + Just _ → xs + Nothing → [] toAbortion ∷ SomeException → Abortion toAbortion e @@ -288,20 +288,19 @@ runResource def itr processException ∷ SomeException → IO () processException exc = do let abo = toAbortion exc - conf = itrConfig itr -- まだ DecidingHeader 以前の状態だったら、この途中終了 -- を應答に反映させる餘地がある。さうでなければ stderr -- にでも吐くしか無い。 - state ← atomically $ readItr itrState itr - reqM ← atomically $ readItr itrRequest itr - res ← atomically $ readItr itrResponse itr + 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 conf reqM res abo + flip runRes itr $ + do setStatus $ aboStatus abo + mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo + output $ LT.encodeUtf8 $ abortPage itrConfig reqM res abo else - when (cnfDumpTooLateAbortionToStderr $ itrConfig itr) + when (cnfDumpTooLateAbortionToStderr itrConfig) $ hPutStrLn stderr $ show abo - flip runRes itr $ driftTo Done + runRes (driftTo Done) itr diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 7382071..034bd78 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -10,20 +10,19 @@ module Network.HTTP.Lucu.ResponseWriter where import qualified Blaze.ByteString.Builder.HTTP as BB import qualified Data.Ascii as A -import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception -import Control.Monad +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception +import Control.Monad import Data.Monoid.Unicode import qualified Data.Sequence as S -import Data.Sequence (ViewR(..)) -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.HandleLike -import Network.HTTP.Lucu.HttpVersion -import Network.HTTP.Lucu.Interaction -import Network.HTTP.Lucu.Postprocess -import Network.HTTP.Lucu.Response -import Prelude hiding (catch) +import Data.Sequence (ViewR(..)) +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.HandleLike +import Network.HTTP.Lucu.HttpVersion +import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.Postprocess +import Network.HTTP.Lucu.Response import Prelude.Unicode import System.IO (hPutStrLn, stderr) @@ -57,7 +56,7 @@ awaitSomethingToWrite ctx@(Context {..}) -- だ送信前なのであれば、Continue を送信する。 case S.viewr queue of EmptyR → retry - _ :> itr → do state ← readItr itrState itr + _ :> itr → do state ← readTVar $ itrState itr if state ≡ GettingBody then writeContinueIfNeeded ctx itr else @@ -67,15 +66,15 @@ awaitSomethingToWrite ctx@(Context {..}) retry writeContinueIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ()) -writeContinueIfNeeded ctx itr - = do expectedContinue ← readItr itrExpectedContinue itr +writeContinueIfNeeded ctx itr@(Interaction {..}) + = do expectedContinue ← readTVar itrExpectedContinue if expectedContinue then - do wroteContinue ← readItr itrWroteContinue itr + do wroteContinue ← readTVar itrWroteContinue if wroteContinue then -- 既に Continue を書込み濟 retry else - do reqBodyWanted ← readItr itrReqBodyWanted itr + do reqBodyWanted ← readTVar itrReqBodyWanted if reqBodyWanted ≢ Nothing then return $ writeContinue ctx itr else @@ -87,14 +86,14 @@ writeContinueIfNeeded ctx itr -- ダを出力する。ヘッダ出力後であり、bodyToSend が空でなければ、それを -- 出力する。空である時は、もし状態がDone であれば後処理をする。 writeHeaderOrBodyIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ()) -writeHeaderOrBodyIfNeeded ctx itr - = do wroteHeader ← readItr itrWroteHeader itr +writeHeaderOrBodyIfNeeded ctx itr@(Interaction {..}) + = do wroteHeader ← readTVar itrWroteHeader if not wroteHeader then return $ writeHeader ctx itr else - do noBodyToWrite ← isEmptyTMVar (itrBodyToSend itr) + do noBodyToWrite ← isEmptyTMVar itrBodyToSend if noBodyToWrite then - do state ← readItr itrState itr + do state ← readTVar itrState if state ≡ Done then return $ finalize ctx itr else @@ -103,7 +102,7 @@ writeHeaderOrBodyIfNeeded ctx itr return $ writeBodyChunk ctx itr writeContinue ∷ HandleLike h ⇒ Context h → Interaction → IO () -writeContinue ctx@(Context {..}) itr +writeContinue ctx@(Context {..}) (Interaction {..}) = do let cont = Response { resVersion = HttpVersion 1 1 , resStatus = Continue @@ -112,29 +111,29 @@ writeContinue ctx@(Context {..}) itr cont' ← completeUnconditionalHeaders cConfig cont hPutBuilder cHandle $ A.toBuilder $ printResponse cont' hFlush cHandle - atomically $ writeItr itrWroteContinue True itr + atomically $ writeTVar itrWroteContinue True awaitSomethingToWrite ctx writeHeader ∷ HandleLike h ⇒ Context h → Interaction → IO () -writeHeader ctx@(Context {..}) itr +writeHeader ctx@(Context {..}) (Interaction {..}) = do res ← atomically - $ do writeItr itrWroteHeader True itr - readItr itrResponse itr + $ do writeTVar itrWroteHeader True + readTVar itrResponse hPutBuilder cHandle $ A.toBuilder $ printResponse res hFlush cHandle awaitSomethingToWrite ctx writeBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO () -writeBodyChunk ctx@(Context {..}) itr +writeBodyChunk ctx@(Context {..}) (Interaction {..}) = join $ atomically $ - do willDiscardBody ← readItr itrWillDiscardBody itr + do willDiscardBody ← readTVar itrWillDiscardBody if willDiscardBody then - do _ ← tryTakeTMVar (itrBodyToSend itr) + do _ ← tryTakeTMVar itrBodyToSend return $ awaitSomethingToWrite ctx else - do willChunkBody ← readItr itrWillChunkBody itr - chunk ← takeTMVar (itrBodyToSend itr) + do willChunkBody ← readTVar itrWillChunkBody + chunk ← takeTMVar itrBodyToSend return $ do if willChunkBody then hPutBuilder cHandle $ BB.chunkedTransferEncoding chunk @@ -144,11 +143,11 @@ writeBodyChunk ctx@(Context {..}) itr awaitSomethingToWrite ctx finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO () -finishBodyChunk (Context {..}) itr +finishBodyChunk (Context {..}) (Interaction {..}) = join $ atomically $ - do willDiscardBody ← readItr itrWillDiscardBody itr - willChunkBody ← readItr itrWillChunkBody itr + do willDiscardBody ← readTVar itrWillDiscardBody + willChunkBody ← readTVar itrWillChunkBody if ((¬) willDiscardBody) ∧ willChunkBody then return $ do hPutBuilder cHandle BB.chunkedTransferTerminator @@ -157,14 +156,14 @@ finishBodyChunk (Context {..}) itr return $ return () finalize ∷ HandleLike h ⇒ Context h → Interaction → IO () -finalize ctx@(Context {..}) itr +finalize ctx@(Context {..}) itr@(Interaction {..}) = do finishBodyChunk ctx itr willClose ← atomically $ do queue ← readTVar cQueue case S.viewr queue of EmptyR → return () -- this should never happen remaining :> _ → writeTVar cQueue remaining - readItr itrWillClose itr + readTVar itrWillClose if willClose then -- reader は恐らく hWaitForInput してゐる最中なので、スレッ -- ドを豫め殺して置かないとをかしくなる。 -- 2.40.0