-- #prune -- |This is the Resource Monad; monadic actions to define the behavior -- of each resources. The 'Resource' Monad is a kind of IO Monad thus -- it implements MonadIO class. It is also a state machine. -- -- Request Processing Flow: -- -- 1. A client issues an HTTP request. -- -- 2. If the URI of it matches to any resource, the corresponding -- 'Resource' Monad starts running on a newly spawned thread. -- -- 3. The 'Resource' Monad looks at the request header, find (or not -- find) an entity, receive the request body (if any), decide the -- response header, and decide the response body. This process -- will be discussed later. -- -- 4. The 'Resource' Monad and its thread stops running. The client -- may or may not be sending us the next request at this point. -- -- 'Resource' Monad takes the following states. The initial state is -- /Examining Request/ and the final state is /Done/. -- -- [/Examining Request/] In this state, a 'Resource' looks at the -- request header and thinks about an entity for it. If there is a -- suitable entity, the 'Resource' tells the system an entity tag -- and its last modification time ('foundEntity'). If it found no -- entity, it tells the system so ('foundNoEntity'). In case it is -- impossible to decide the existence of entity, which is a typical -- case for POST requests, 'Resource' does nothing in this state. -- -- [/Getting Body/] A 'Resource' asks the system to receive a -- request body from client. Before actually reading from the -- socket, the system sends \"100 Continue\" to the client if need -- be. When a 'Resource' transits to the next state without -- receiving all or part of request body, the system still reads it -- and just throws it away. -- -- [/Deciding Header/] A 'Resource' makes a decision of status code -- and response header. When it transits to the next state, the -- system checks the validness of response header and then write -- them to the socket. -- -- [/Deciding Body/] In this state, a 'Resource' asks the system to -- write some response body to the socket. When it transits to the -- next state without writing any response body, the system -- completes it depending on the status code. -- -- [/Done/] Everything is over. A 'Resource' can do nothing for the -- HTTP interaction anymore. -- -- Note that the state transition is one-way: for instance, it is an -- error to try to read a request body after writing some -- response. This limitation is for efficiency. We don't want to read -- the entire request before starting 'Resource', nor we don't want to -- postpone writing the entire response till the end of 'Resource' -- computation. module Network.HTTP.Lucu.Resource ( -- * Monad Resource -- * Actions -- ** Getting request header -- |These actions can be computed regardless of the current state, -- and they don't change the state. , getConfig , getRemoteAddr , getRemoteAddr' , getRequest , getMethod , getRequestURI , getResourcePath , getPathInfo , getQueryForm , getHeader , getAccept , getContentType -- ** Finding an entity -- |These actions can be computed only in the /Examining Request/ -- state. After the computation, the 'Resource' transits to -- /Getting Body/ state. , foundEntity , foundETag , foundTimeStamp , foundNoEntity -- ** Getting a request body -- |Computation of these actions changes the state to /Getting -- Body/. , input , inputChunk , inputBS , inputChunkBS , inputForm , defaultLimit -- ** Setting response headers -- |Computation of these actions changes the state to /Deciding -- Header/. , setStatus , setHeader , redirect , setContentType , setLocation -- ** Writing a response body -- |Computation of these actions changes the state to /Deciding -- Body/. , output , outputChunk , outputBS , outputChunkBS , driftTo ) where import Control.Concurrent.STM import Control.Monad.Reader import Data.Bits import qualified Data.ByteString.Lazy.Char8 as B import Data.ByteString.Lazy.Char8 (ByteString) import Data.List import Data.Maybe import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.DefaultPage import Network.HTTP.Lucu.ETag import qualified Network.HTTP.Lucu.Headers as H import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Postprocess import Network.HTTP.Lucu.RFC1123DateTime import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.MIMEType import Network.HTTP.Lucu.Utils import Network.Socket import Network.URI import System.Time -- |The 'Resource' monad. /Interaction/ is an internal state thus it -- is not exposed to users. This monad implements 'MonadIO' so it can -- do any IO actions. type Resource a = ReaderT Interaction IO a -- |Get the 'Network.HTTP.Lucu.Config.Config' value which is used for -- the httpd. getConfig :: Resource Config getConfig = do itr <- ask return $! itrConfig itr -- |Get the SockAddr of the remote host. If you want a string -- representation instead of SockAddr, use 'getRemoteAddr''. getRemoteAddr :: Resource SockAddr getRemoteAddr = do itr <- ask return $! itrRemoteAddr itr -- |Get the string representation of the address of remote host. If -- you want a SockAddr instead of String, use 'getRemoteAddr'. getRemoteAddr' :: Resource String getRemoteAddr' = do addr <- getRemoteAddr case addr of -- Network.Socket は IPv6 を考慮してゐないやうだ… (SockAddrInet _ v4addr) -> let b1 = (v4addr `shiftR` 24) .&. 0xFF b2 = (v4addr `shiftR` 16) .&. 0xFF b3 = (v4addr `shiftR` 8) .&. 0xFF b4 = v4addr .&. 0xFF in return $ concat $ intersperse "." $ map show [b1, b2, b3, b4] (SockAddrUnix path) -> return path -- |Get the 'Network.HTTP.Lucu.Request.Request' value which represents -- the request header. In general you don't have to use this action. getRequest :: Resource Request getRequest = do itr <- ask req <- liftIO $! atomically $! readItr itr itrRequest fromJust return req -- |Get the 'Network.HTTP.Lucu.Request.Method' value of the request. getMethod :: Resource Method getMethod = do req <- getRequest return $! reqMethod req -- |Get the URI of the request. getRequestURI :: Resource URI getRequestURI = do req <- getRequest return $! reqURI req -- |Get the path of this 'Resource' (to be exact, -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this -- action is the exact path in the tree even if the -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy. -- -- Example: -- -- > main = let tree = mkResTree [ (["foo"], resFoo) ] -- > in runHttpd defaultConfig tree -- > -- > resFoo = ResourceDef { -- > resIsGreedy = True -- > , resGet = Just $ do requestURI <- getRequestURI -- > resourcePath <- getResourcePath -- > pathInfo <- getPathInfo -- > -- uriPath requestURI == "/foo/bar/baz" -- > -- resourcePath == ["foo"] -- > -- pathInfo == ["bar", "baz"] -- > ... -- > , ... -- > } getResourcePath :: Resource [String] getResourcePath = do itr <- ask return $! fromJust $! itrResourcePath itr -- |This is an analogy of CGI PATH_INFO. Its result is always @[]@ if -- the 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not -- greedy. See 'getResourcePath'. getPathInfo :: Resource [String] getPathInfo = do rsrcPath <- getResourcePath reqURI <- getRequestURI let reqPathStr = uriPath reqURI reqPath = [x | x <- splitBy (== '/') reqPathStr, x /= ""] -- rsrcPath と reqPath の共通する先頭部分を reqPath か -- ら全部取り除くと、それは PATH_INFO のやうなものにな -- る。rsrcPath は全部一致してゐるに決まってゐる（でな -- ければこの Resource が撰ばれた筈が無い）ので、 -- rsrcPath の長さの分だけ削除すれば良い。 return $! drop (length rsrcPath) reqPath -- | Assume the query part of request URI as -- application\/x-www-form-urlencoded, and parse it. This action -- doesn't parse the request body. See 'inputForm'. getQueryForm :: Resource [(String, String)] getQueryForm = do reqURI <- getRequestURI return $! parseWWWFormURLEncoded $ uriQuery reqURI -- |Get a value of given request header. Comparison of header name is -- case-insensitive. Note that this action is not intended to be used -- so frequently: there should be actions like 'getContentType' for -- every common headers. getHeader :: String -> Resource (Maybe String) getHeader name = name `seq` do req <- getRequest return $! H.getHeader name req -- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on -- header \"Accept\". getAccept :: Resource [MIMEType] getAccept = do accept <- getHeader "Accept" if accept == Nothing then return [] else case parseStr mimeTypeListP $ fromJust accept of (Success xs, _) -> return xs _ -> return [] -- |Get the header \"Content-Type\" as -- 'Network.HTTP.Lucu.MIMEType.MIMEType'. getContentType :: Resource (Maybe MIMEType) getContentType = do cType <- getHeader "Content-Type" if cType == Nothing then return Nothing else case parseStr mimeTypeP $ fromJust cType of (Success t, _) -> return $ Just t _ -> return Nothing {- ExaminingRequest 時に使用するアクション群 -} -- |Tell the system that the 'Resource' found an entity for the -- request URI. If this is a GET or HEAD request, a found entity means -- a datum to be replied. If this is a PUT or DELETE request, it means -- a datum which was stored for the URI up to now. It is an error to -- compute 'foundEntity' if this is a POST request. -- -- Computation of 'foundEntity' performs \"If-Match\" test or -- \"If-None-Match\" test if possible. When those tests fail, the -- computation of 'Resource' immediately aborts with status \"412 -- Precondition Failed\" or \"304 Not Modified\" depending on the -- situation. -- -- If this is a GET or HEAD request, 'foundEntity' automatically puts -- \"ETag\" and \"Last-Modified\" headers into the response. foundEntity :: ETag -> ClockTime -> Resource () foundEntity tag timeStamp = tag `seq` timeStamp `seq` do driftTo ExaminingRequest method <- getMethod when (method == GET || method == HEAD) $ setHeader' "Last-Modified" $! formatHTTPDateTime timeStamp when (method == POST) $ abort InternalServerError [] (Just "Illegal computation of foundEntity for POST request.") foundETag tag driftTo GettingBody -- |Tell the system that the 'Resource' found an entity for the -- request URI. The only difference from 'foundEntity' is that -- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into -- the response. -- -- This action is not preferred. You should use 'foundEntity' when -- possible. foundETag :: ETag -> Resource () foundETag tag = tag `seq` do driftTo ExaminingRequest method <- getMethod when (method == GET || method == HEAD) $ setHeader' "ETag" $! show tag when (method == POST) $ abort InternalServerError [] (Just "Illegal computation of foundETag for POST request.") -- If-Match があればそれを見る。 ifMatch <- getHeader "If-Match" case ifMatch of Nothing -> return () Just "*" -> return () Just list -> case parseStr eTagListP list of (Success tags, _) -- tags の中に一致するものが無ければ -- PreconditionFailed で終了。 -> when (not $ any (== tag) tags) $ abort PreconditionFailed [] $! Just ("The entity tag doesn't match: " ++ list) _ -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ fromJust ifMatch) let statusForNoneMatch = if method == GET || method == HEAD then NotModified else PreconditionFailed -- If-None-Match があればそれを見る。 ifNoneMatch <- getHeader "If-None-Match" case ifNoneMatch of Nothing -> return () Just "*" -> abort statusForNoneMatch [] $! Just ("The entity tag matches: *") Just list -> case parseStr eTagListP list of (Success tags, _) -> when (any (== tag) tags) $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ list) _ -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ list) driftTo GettingBody -- |Tell the system that the 'Resource' found an entity for the -- request URI. The only difference from 'foundEntity' is that -- 'foundTimeStamp' performs \"If-Modified-Since\" test or -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or -- \"If-None-Match\" test. Be aware that any tests based on last -- modification time are unsafe because it is possible to mess up such -- tests by modifying the entity twice in a second. -- -- This action is not preferred. You should use 'foundEntity' when -- possible. foundTimeStamp :: ClockTime -> Resource () foundTimeStamp timeStamp = timeStamp `seq` do driftTo ExaminingRequest method <- getMethod when (method == GET || method == HEAD) $ setHeader' "Last-Modified" $! formatHTTPDateTime timeStamp when (method == POST) $ abort InternalServerError [] (Just "Illegal computation of foundTimeStamp for POST request.") let statusForIfModSince = if method == GET || method == HEAD then NotModified else PreconditionFailed -- If-Modified-Since があればそれを見る。 ifModSince <- getHeader "If-Modified-Since" case ifModSince of Just str -> case parseHTTPDateTime str of Just lastTime -> when (timeStamp <= lastTime) $ abort statusForIfModSince [] $! Just ("The entity has not been modified since " ++ str) Nothing -> return () -- 不正な時刻は無視 Nothing -> return () -- If-Unmodified-Since があればそれを見る。 ifUnmodSince <- getHeader "If-Unmodified-Since" case ifUnmodSince of Just str -> case parseHTTPDateTime str of Just lastTime -> when (timeStamp > lastTime) $ abort PreconditionFailed [] $! Just ("The entity has not been modified since " ++ str) Nothing -> return () -- 不正な時刻は無視 Nothing -> return () driftTo GettingBody -- | Computation of @'foundNoEntity' mStr@ tells the system that the -- 'Resource' found no entity for the request URI. @mStr@ is an -- optional error message to be replied to the client. -- -- If this is a PUT request, 'foundNoEntity' performs \"If-Match\" -- test and aborts with status \"412 Precondition Failed\" when it -- failed. If this is a GET, HEAD, POST or DELETE request, -- 'foundNoEntity' always aborts with status \"404 Not Found\". foundNoEntity :: Maybe String -> Resource () foundNoEntity msgM = msgM `seq` do driftTo ExaminingRequest method <- getMethod when (method /= PUT) $ abort NotFound [] msgM -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな -- If-Match: 條件も滿たさない。 ifMatch <- getHeader "If-Match" when (ifMatch /= Nothing) $ abort PreconditionFailed [] msgM driftTo GettingBody {- GettingBody 時に使用するアクション群 -} -- | Computation of @'input' limit@ attempts to read the request body -- up to @limit@ bytes, and then make the 'Resource' transit to -- /Deciding Header/ state. When the actual size of body is larger -- than @limit@ bytes, computation of 'Resource' immediately aborts -- with status \"413 Request Entity Too Large\". When the request has -- no body, 'input' returns an empty string. -- -- @limit@ may be less than or equal to zero. In this case, the -- default limitation value -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See -- 'defaultLimit'. -- -- Note that 'inputBS' is more efficient than 'input' so you should -- use it whenever possible. input :: Int -> Resource String input limit = limit `seq` inputBS limit >>= return . B.unpack -- | This is mostly the same as 'input' but is more -- efficient. 'inputBS' returns a lazy ByteString but it's not really -- lazy: reading from the socket just happens at the computation of -- 'inputBS', not at the lazy evaluation of the ByteString. The same -- goes for 'inputChunkBS'. inputBS :: Int -> Resource ByteString inputBS limit = limit `seq` do driftTo GettingBody itr <- ask hasBody <- liftIO $! atomically $! readItr itr itrRequestHasBody id chunk <- if hasBody then askForInput itr else do driftTo DecidingHeader return B.empty return chunk where askForInput :: Interaction -> Resource ByteString askForInput itr = itr `seq` do let defaultLimit = cnfMaxEntityLength $ itrConfig itr actualLimit = if limit <= 0 then defaultLimit else limit when (actualLimit <= 0) $ fail ("inputBS: limit must be positive: " ++ show actualLimit) -- Reader にリクエスト liftIO $! atomically $! do chunkLen <- readItr itr itrReqChunkLength id writeItr itr itrWillReceiveBody True if fmap (> actualLimit) chunkLen == Just True then -- 受信前から多過ぎる事が分かってゐる tooLarge actualLimit else writeItr itr itrReqBodyWanted $ Just actualLimit -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 chunk <- liftIO $! atomically $! do chunk <- readItr itr itrReceivedBody id chunkIsOver <- readItr itr itrReqChunkIsOver id if B.length chunk < fromIntegral actualLimit then -- 要求された量に滿たなくて、まだ殘り -- があるなら再試行。 unless chunkIsOver $ retry else -- 制限値一杯まで讀むやうに指示したの -- にまだ殘ってゐるなら、それは多過ぎ -- る。 unless chunkIsOver $ tooLarge actualLimit -- 成功。itr 内にチャンクを置いたままにす -- るとメモリの無駄になるので除去。 writeItr itr itrReceivedBody B.empty return chunk driftTo DecidingHeader return chunk tooLarge :: Int -> STM () tooLarge lim = lim `seq` abortSTM RequestEntityTooLarge [] $! Just ("Request body must be smaller than " ++ show lim ++ " bytes.") -- | Computation of @'inputChunk' limit@ attempts to read a part of -- request body up to @limit@ bytes. You can read any large request by -- repeating computation of this action. When you've read all the -- request body, 'inputChunk' returns an empty string and then make -- the 'Resource' transit to /Deciding Header/ state. -- -- @limit@ may be less than or equal to zero. In this case, the -- default limitation value -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See -- 'defaultLimit'. -- -- Note that 'inputChunkBS' is more efficient than 'inputChunk' so you -- should use it whenever possible. inputChunk :: Int -> Resource String inputChunk limit = limit `seq` inputChunkBS limit >>= return . B.unpack -- | This is mostly the same as 'inputChunk' but is more -- efficient. See 'inputBS'. inputChunkBS :: Int -> Resource ByteString inputChunkBS limit = limit `seq` do driftTo GettingBody itr <- ask hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id chunk <- if hasBody then askForInput itr else do driftTo DecidingHeader return B.empty return chunk where askForInput :: Interaction -> Resource ByteString askForInput itr = itr `seq` do let defaultLimit = cnfMaxEntityLength $! itrConfig itr actualLimit = if limit < 0 then defaultLimit else limit when (actualLimit <= 0) $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit) -- Reader にリクエスト liftIO $! atomically $! do writeItr itr itrReqBodyWanted $! Just actualLimit writeItr itr itrWillReceiveBody True -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 chunk <- liftIO $! atomically $ do chunk <- readItr itr itrReceivedBody id -- 要求された量に滿たなくて、まだ殘りがあ -- るなら再試行。 when (B.length chunk < fromIntegral actualLimit) $ do chunkIsOver <- readItr itr itrReqChunkIsOver id unless chunkIsOver $ retry -- 成功 writeItr itr itrReceivedBody B.empty return chunk when (B.null chunk) $ driftTo DecidingHeader return chunk -- | Computation of @'inputForm' limit@ attempts to read the request -- body with 'input' and parse it as -- application\/x-www-form-urlencoded. If the request header -- \"Content-Type\" is not application\/x-www-form-urlencoded, -- 'inputForm' makes 'Resource' abort with status \"415 Unsupported -- Media Type\". If the request has no \"Content-Type\", it aborts -- with \"400 Bad Request\". -- -- This action should also support multipart\/form-data somehow, but -- it is not (yet) done. inputForm :: Int -> Resource [(String, String)] inputForm limit = limit `seq` do cTypeM <- getContentType case cTypeM of Nothing -> abort BadRequest [] (Just "Missing Content-Type") Just (MIMEType "application" "x-www-form-urlencoded" _) -> readWWWFormURLEncoded Just (MIMEType "multipart" "form-data" _) -> readMultipartFormData Just cType -> abort UnsupportedMediaType [] (Just $! "Unsupported media type: " ++ show cType) where readWWWFormURLEncoded = do src <- input limit return $ parseWWWFormURLEncoded src readMultipartFormData -- FIXME: 未對應 = abort UnsupportedMediaType [] (Just $! "Sorry, inputForm does not currently support multipart/form-data.") -- | This is just a constant -1. It's better to say @'input' -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly -- the same. defaultLimit :: Int defaultLimit = (-1) {- DecidingHeader 時に使用するアクション群 -} -- | Set the response status code. If you omit to compute this action, -- the status code will be defaulted to \"200 OK\". setStatus :: StatusCode -> Resource () setStatus code = code `seq` do driftTo DecidingHeader itr <- ask liftIO $! atomically $! updateItr itr itrResponse $! \ res -> res { resStatus = code } -- | Set a value of given resource header. Comparison of header name -- is case-insensitive. Note that this action is not intended to be -- used so frequently: there should be actions like 'setContentType' -- for every common headers. -- -- Some important headers (especially \"Content-Length\" and -- \"Transfer-Encoding\") may be silently dropped or overwritten by -- the system not to corrupt the interaction with client at the -- viewpoint of HTTP protocol layer. For instance, if we are keeping -- the connection alive, without this process it causes a catastrophe -- to send a header \"Content-Length: 10\" and actually send a body of -- 20 bytes long. In this case the client shall only accept the first -- 10 bytes of response body and thinks that the residual 10 bytes is -- a part of header of the next response. setHeader :: String -> String -> Resource () setHeader name value = name `seq` value `seq` driftTo DecidingHeader >> setHeader' name value setHeader' :: String -> String -> Resource () setHeader' name value = name `seq` value `seq` do itr <- ask liftIO $ atomically $ updateItr itr itrResponse $ H.setHeader name value -- | Computation of @'redirect' code uri@ sets the response status to -- @code@ and \"Location\" header to @uri@. @code@ must satisfy -- 'Network.HTTP.Lucu.Response.isRedirection' or it causes an error. redirect :: StatusCode -> URI -> Resource () redirect code uri = code `seq` uri `seq` do when (code == NotModified || not (isRedirection code)) $ abort InternalServerError [] $! Just ("Attempted to redirect with status " ++ show code) setStatus code setLocation uri {-# INLINE redirect #-} -- | Computation of @'setContentType' mType@ sets the response header -- \"Content-Type\" to @mType@. setContentType :: MIMEType -> Resource () setContentType mType = setHeader "Content-Type" $! show mType -- | Computation of @'setLocation' uri@ sets the response header -- \"Location\" to @uri@. setLocation :: URI -> Resource () setLocation uri = setHeader "Location" $ uriToString id uri $ "" {- DecidingBody 時に使用するアクション群 -} -- | Computation of @'output' str@ writes @str@ as a response body, -- and then make the 'Resource' transit to /Done/ state. It is safe to -- apply 'output' to an infinite string, such as a lazy stream of -- \/dev\/random. -- -- Note that 'outputBS' is more efficient than 'output' so you should -- use it whenever possible. output :: String -> Resource () output str = outputBS $! B.pack str {-# INLINE output #-} -- | This is mostly the same as 'output' but is more efficient. outputBS :: ByteString -> Resource () outputBS str = do outputChunkBS str driftTo Done {-# INLINE outputBS #-} -- | Computation of @'outputChunk' str@ writes @str@ as a part of -- response body. You can compute this action multiple times to write -- a body little at a time. It is safe to apply 'outputChunk' to an -- infinite string. -- -- Note that 'outputChunkBS' is more efficient than 'outputChunk' so -- you should use it whenever possible. outputChunk :: String -> Resource () outputChunk str = outputChunkBS $! B.pack str {-# INLINE outputChunk #-} -- | This is mostly the same as 'outputChunk' but is more efficient. outputChunkBS :: ByteString -> Resource () outputChunkBS str = str `seq` do driftTo DecidingBody itr <- ask let limit = cnfMaxOutputChunkLength $ itrConfig itr when (limit <= 0) $ fail ("cnfMaxOutputChunkLength must be positive: " ++ show limit) discardBody <- liftIO $ atomically $ readItr itr itrWillDiscardBody id unless (discardBody) $ sendChunks str limit unless (B.null str) $ liftIO $ atomically $ writeItr itr itrBodyIsNull False where {- チャンクの大きさは Config で制限されてゐる。もし例へば /dev/zero を B.readFile して作った ByteString をそのまま ResponseWriter に渡したりすると大變な事が起こる。何故なら ResponseWriter はTransfer-Encoding: chunked の時、ヘッダを書く 爲にチャンクの大きさを測るから、その時に起こるであらう事は言ふ までも無い。 -} sendChunks :: ByteString -> Int -> Resource () sendChunks str limit | B.null str = return () | otherwise = do let (chunk, remaining) = B.splitAt (fromIntegral limit) str itr <- ask liftIO $ atomically $ do buf <- readItr itr itrBodyToSend id if B.null buf then -- バッファが消化された writeItr itr itrBodyToSend chunk else -- 消化されるのを待つ retry -- 殘りのチャンクについて繰り返す sendChunks remaining limit {- [GettingBody からそれ以降の状態に遷移する時] body を讀み終へてゐなければ、殘りの body を讀み捨てる。 [DecidingHeader からそれ以降の状態に遷移する時] postprocess する。 [Done に遷移する時] bodyIsNull が False ならば何もしない。True だった場合は出力補完す る。 -} driftTo :: InteractionState -> Resource () driftTo newState = newState `seq` do itr <- ask liftIO $ atomically $ do oldState <- readItr itr itrState id if newState < oldState then throwStateError oldState newState else do let a = [oldState .. newState] b = tail a c = zip a b mapM_ (uncurry $ drift itr) c writeItr itr itrState newState where throwStateError :: Monad m => InteractionState -> InteractionState -> m a throwStateError Done DecidingBody = fail "It makes no sense to output something after finishing to output." throwStateError old new = fail ("state error: " ++ show old ++ " ==> " ++ show new) drift :: Interaction -> InteractionState -> InteractionState -> STM () drift itr GettingBody _ = writeItr itr itrReqBodyWasteAll True drift itr DecidingHeader _ = postprocess itr drift itr _ Done = do bodyIsNull <- readItr itr itrBodyIsNull id when bodyIsNull $ writeDefaultPage itr drift _ _ _ = return ()