X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=8e25904ac927d00da9d96fecdfff998328f7d6d7;hb=0dc3d31312a12f2b085242841b29eb0d96e9c4ac;hp=af8c16917e154dd12e0661b671659a5c462b7b71;hpb=5b255535f2c7d2a6d4622ad164b31e63746b906e;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index af8c169..8e25904 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,8 +1,9 @@ -- #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. +-- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO' +-- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is +-- also a state machine. -- -- Request Processing Flow: -- @@ -61,6 +62,7 @@ module Network.HTTP.Lucu.Resource ( -- * Monad Resource + , runRes -- private -- * Actions @@ -74,11 +76,14 @@ module Network.HTTP.Lucu.Resource , getRequest , getMethod , getRequestURI + , getRequestVersion , getResourcePath , getPathInfo , getQueryForm , getHeader , getAccept + , getAcceptEncoding + , isEncodingAcceptable , getContentType -- ** Finding an entity @@ -97,8 +102,8 @@ module Network.HTTP.Lucu.Resource -- Body/. , input , inputChunk - , inputBS - , inputChunkBS + , inputLBS + , inputChunkLBS , inputForm , defaultLimit @@ -111,6 +116,7 @@ module Network.HTTP.Lucu.Resource , redirect , setContentType , setLocation + , setContentEncoding -- ** Writing a response body @@ -118,8 +124,8 @@ module Network.HTTP.Lucu.Resource -- Body/. , output , outputChunk - , outputBS - , outputChunkBS + , outputLBS + , outputChunkLBS , driftTo ) @@ -128,13 +134,13 @@ module Network.HTTP.Lucu.Resource import Control.Concurrent.STM import Control.Monad.Reader import Data.Bits +import Data.ByteString.Base (LazyByteString) import qualified Data.ByteString.Lazy.Char8 as B -import Data.ByteString.Lazy.Char8 (ByteString) import Data.List import Data.Maybe -import GHC.Conc (unsafeIOToSTM) import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.ContentCoding import Network.HTTP.Lucu.DefaultPage import Network.HTTP.Lucu.ETag import qualified Network.HTTP.Lucu.Headers as H @@ -151,27 +157,50 @@ 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 +-- |The 'Resource' monad. This monad implements +-- 'Control.Monad.Trans.MonadIO' so it can do any 'Prelude.IO' +-- actions. +newtype Resource a = Resource { unRes :: ReaderT Interaction IO a } + +instance Functor Resource where + fmap f c = Resource (fmap f (unRes c)) + +instance Monad Resource where + c >>= f = Resource (unRes c >>= unRes . f) + return = Resource . return + fail = Resource . fail + +instance MonadIO Resource where + liftIO = Resource . liftIO + + +runRes :: Resource a -> Interaction -> IO a +runRes r itr + = runReaderT (unRes r) itr + + +getInteraction :: Resource Interaction +getInteraction = Resource ask + -- |Get the 'Network.HTTP.Lucu.Config.Config' value which is used for -- the httpd. getConfig :: Resource Config -getConfig = do itr <- ask - return $ itrConfig itr +getConfig = do itr <- getInteraction + return $! itrConfig itr --- |Get the SockAddr of the remote host. If you want a string --- representation instead of SockAddr, use 'getRemoteAddr''. +-- |Get the 'Network.Socket.SockAddr' of the remote host. If you want +-- a string representation instead of 'Network.Socket.SockAddr', use +-- 'getRemoteAddr''. getRemoteAddr :: Resource SockAddr -getRemoteAddr = do itr <- ask - return $ itrRemoteAddr itr +getRemoteAddr = do itr <- getInteraction + return $! itrRemoteAddr itr -- |Get the string representation of the address of remote host. If --- you want a SockAddr instead of String, use 'getRemoteAddr'. +-- you want a 'Network.Socket.SockAddr' instead of String, use +-- 'getRemoteAddr'. getRemoteAddr' :: Resource String getRemoteAddr' = do addr <- getRemoteAddr case addr of @@ -190,19 +219,24 @@ getRemoteAddr' = do addr <- getRemoteAddr -- |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 +getRequest = do itr <- getInteraction + req <- liftIO $! atomically $! readItr itr itrRequest fromJust return req -- |Get the 'Network.HTTP.Lucu.Request.Method' value of the request. getMethod :: Resource Method getMethod = do req <- getRequest - return $ reqMethod req + return $! reqMethod req -- |Get the URI of the request. getRequestURI :: Resource URI getRequestURI = do req <- getRequest - return $ reqURI req + return $! reqURI req + +-- |Get the HTTP version of the request. +getRequestVersion :: Resource HttpVersion +getRequestVersion = do req <- getRequest + return $! reqVersion req -- |Get the path of this 'Resource' (to be exact, -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the @@ -227,8 +261,8 @@ getRequestURI = do req <- getRequest -- > , ... -- > } getResourcePath :: Resource [String] -getResourcePath = do itr <- ask - return $ fromJust $ itrResourcePath itr +getResourcePath = do itr <- getInteraction + return $! fromJust $! itrResourcePath itr -- |This is an analogy of CGI PATH_INFO. Its result is always @[]@ if @@ -244,45 +278,83 @@ getPathInfo = do rsrcPath <- getResourcePath -- る。rsrcPath は全部一致してゐるに決まってゐる（でな -- ければこの Resource が撰ばれた筈が無い）ので、 -- rsrcPath の長さの分だけ削除すれば良い。 - return $ drop (length rsrcPath) reqPath + 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 + 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 = do req <- getRequest - return $ H.getHeader name req +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 [] +getAccept = do acceptM <- getHeader "Accept" + case acceptM of + Nothing + -> return [] + Just accept + -> case parseStr mimeTypeListP accept of + (# Success xs, _ #) -> return xs + (# _ , _ #) -> abort BadRequest [] + (Just $ "Unparsable Accept: " ++ accept) + +-- |Get a list of @(contentCoding, qvalue)@ enumerated on header +-- \"Accept-Encoding\". The list is sorted in descending order by +-- qvalue. +getAcceptEncoding :: Resource [(String, Maybe Double)] +getAcceptEncoding + = do accEncM <- getHeader "Accept-Encoding" + case accEncM of + Nothing + -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い + -- ので安全の爲 identity が指定された事にする。HTTP/1.1 + -- の場合は何でも受け入れて良い事になってゐるので "*" が + -- 指定された事にする。 + -> do ver <- getRequestVersion + case ver of + HttpVersion 1 0 -> return [("identity", Nothing)] + HttpVersion 1 1 -> return [("*" , Nothing)] + Just "" + -- identity のみが許される。 + -> return [("identity", Nothing)] + Just accEnc + -> case parseStr acceptEncodingListP accEnc of + (# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x + (# _ , _ #) -> abort BadRequest [] + (Just $ "Unparsable Accept-Encoding: " ++ accEnc) + +-- |Check whether a given content-coding is acceptable. +isEncodingAcceptable :: String -> Resource Bool +isEncodingAcceptable coding + = do accList <- getAcceptEncoding + return (flip any accList $ \ (c, q) -> + (c == "*" || c `noCaseEq` coding) && q /= Just 0) + -- |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 - +getContentType + = do cTypeM <- getHeader "Content-Type" + case cTypeM of + Nothing + -> return Nothing + Just cType + -> case parseStr mimeTypeP cType of + (# Success t, _ #) -> return $ Just t + (# _ , _ #) -> abort BadRequest [] + (Just $ "Unparsable Content-Type: " ++ cType) {- ExaminingRequest 時に使用するアクション群 -} @@ -303,11 +375,12 @@ getContentType = do cType <- getHeader "Content-Type" -- \"ETag\" and \"Last-Modified\" headers into the response. foundEntity :: ETag -> ClockTime -> Resource () foundEntity tag timeStamp - = do driftTo ExaminingRequest + = tag `seq` timeStamp `seq` + do driftTo ExaminingRequest method <- getMethod when (method == GET || method == HEAD) - $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp + $ setHeader' "Last-Modified" $! formatHTTPDateTime timeStamp when (method == POST) $ abort InternalServerError [] (Just "Illegal computation of foundEntity for POST request.") @@ -320,15 +393,16 @@ foundEntity tag timeStamp -- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into -- the response. -- --- This action is not preferred. You should use 'foundEntity' when +-- This action is not preferred. You should use 'foundEntity' whenever -- possible. foundETag :: ETag -> Resource () foundETag tag - = do driftTo ExaminingRequest + = tag `seq` + do driftTo ExaminingRequest method <- getMethod when (method == GET || method == HEAD) - $ setHeader' "ETag" $ show tag + $ setHeader' "ETag" $! show tag when (method == POST) $ abort InternalServerError [] (Just "Illegal computation of foundETag for POST request.") @@ -339,13 +413,14 @@ foundETag tag Nothing -> return () Just "*" -> return () Just list -> case parseStr eTagListP list of - (Success tags, _) + (# 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) + $! 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 @@ -356,12 +431,13 @@ foundETag tag ifNoneMatch <- getHeader "If-None-Match" case ifNoneMatch of Nothing -> return () - Just "*" -> abort statusForNoneMatch [] $ Just ("The entity tag matches: *") + Just "*" -> abort statusForNoneMatch [] $! Just ("The entity tag matches: *") Just list -> case parseStr eTagListP list of - (Success tags, _) + (# Success tags, _ #) -> when (any (== tag) tags) - $ abort statusForNoneMatch [] $ Just ("The entity tag matches: " ++ list) - _ -> abort BadRequest [] $ Just ("Unparsable If-None-Match: " ++ list) + $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ list) + (# _, _ #) + -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ list) driftTo GettingBody @@ -373,15 +449,16 @@ foundETag tag -- 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 +-- This action is not preferred. You should use 'foundEntity' whenever -- possible. foundTimeStamp :: ClockTime -> Resource () foundTimeStamp timeStamp - = do driftTo ExaminingRequest + = timeStamp `seq` + do driftTo ExaminingRequest method <- getMethod when (method == GET || method == HEAD) - $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp + $ setHeader' "Last-Modified" $! formatHTTPDateTime timeStamp when (method == POST) $ abort InternalServerError [] (Just "Illegal computation of foundTimeStamp for POST request.") @@ -398,7 +475,7 @@ foundTimeStamp timeStamp Just lastTime -> when (timeStamp <= lastTime) $ abort statusForIfModSince [] - $ Just ("The entity has not been modified since " ++ str) + $! Just ("The entity has not been modified since " ++ str) Nothing -> return () -- 不正な時刻は無視 Nothing -> return () @@ -410,7 +487,7 @@ foundTimeStamp timeStamp Just lastTime -> when (timeStamp > lastTime) $ abort PreconditionFailed [] - $ Just ("The entity has not been modified since " ++ str) + $! Just ("The entity has not been modified since " ++ str) Nothing -> return () -- 不正な時刻は無視 Nothing -> return () @@ -427,7 +504,8 @@ foundTimeStamp timeStamp -- 'foundNoEntity' always aborts with status \"404 Not Found\". foundNoEntity :: Maybe String -> Resource () foundNoEntity msgM - = do driftTo ExaminingRequest + = msgM `seq` + do driftTo ExaminingRequest method <- getMethod when (method /= PUT) @@ -456,22 +534,26 @@ foundNoEntity msgM -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See -- 'defaultLimit'. -- --- Note that 'inputBS' is more efficient than 'input' so you should +-- Note that 'inputLBS' is more efficient than 'input' so you should -- use it whenever possible. input :: Int -> Resource String -input limit = inputBS limit >>= return . B.unpack +input limit = limit `seq` + inputLBS 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 - = do driftTo GettingBody - itr <- ask - hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id +-- efficient. 'inputLBS' returns a +-- 'Data.ByteString.Base.LazyByteString' but it's not really lazy: +-- reading from the socket just happens at the computation of +-- 'inputLBS', not at the evaluation of the +-- 'Data.ByteString.Base.LazyByteString'. The same goes for +-- 'inputChunkLBS'. +inputLBS :: Int -> Resource LazyByteString +inputLBS limit + = limit `seq` + do driftTo GettingBody + itr <- getInteraction + hasBody <- liftIO $! atomically $! readItr itr itrRequestHasBody id chunk <- if hasBody then askForInput itr else @@ -479,50 +561,52 @@ inputBS limit return B.empty return chunk where - askForInput :: Interaction -> Resource ByteString + askForInput :: Interaction -> Resource LazyByteString askForInput itr - = do let defaultLimit = cnfMaxEntityLength $ itrConfig 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) + $ fail ("inputLBS: limit must be positive: " ++ show actualLimit) -- Reader にリクエスト - liftIO $ atomically - $ do chunkLen <- readItr itr itrReqChunkLength id - writeItr itr itrWillReceiveBody True - if fmap (> actualLimit) chunkLen == Just True then - -- 受信前から多過ぎる事が分かってゐる - tooLarge actualLimit - else - writeItr itr itrReqBodyWanted $ Just actualLimit + 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 + 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 = abortSTM RequestEntityTooLarge [] - $ Just ("Request body must be smaller than " - ++ show lim ++ " bytes.") + 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 @@ -535,18 +619,20 @@ inputBS limit -- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See -- 'defaultLimit'. -- --- Note that 'inputChunkBS' is more efficient than 'inputChunk' so you +-- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you -- should use it whenever possible. inputChunk :: Int -> Resource String -inputChunk limit = inputChunkBS limit >>= return . B.unpack +inputChunk limit = limit `seq` + inputChunkLBS limit >>= return . B.unpack -- | This is mostly the same as 'inputChunk' but is more --- efficient. See 'inputBS'. -inputChunkBS :: Int -> Resource ByteString -inputChunkBS limit - = do driftTo GettingBody - itr <- ask +-- efficient. See 'inputLBS'. +inputChunkLBS :: Int -> Resource LazyByteString +inputChunkLBS limit + = limit `seq` + do driftTo GettingBody + itr <- getInteraction hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id chunk <- if hasBody then askForInput itr @@ -555,21 +641,22 @@ inputChunkBS limit return B.empty return chunk where - askForInput :: Interaction -> Resource ByteString + askForInput :: Interaction -> Resource LazyByteString askForInput itr - = do let defaultLimit = cnfMaxEntityLength $ itrConfig 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) + $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit) -- Reader にリクエスト - liftIO $ atomically - $ do writeItr itr itrReqBodyWanted $ Just actualLimit - writeItr itr itrWillReceiveBody True + liftIO $! atomically + $! do writeItr itr itrReqBodyWanted $! Just actualLimit + writeItr itr itrWillReceiveBody True -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 - chunk <- liftIO $ atomically + chunk <- liftIO $! atomically $ do chunk <- readItr itr itrReceivedBody id -- 要求された量に滿たなくて、まだ殘りがあ -- るなら再試行。 @@ -596,7 +683,8 @@ inputChunkBS limit -- it is not (yet) done. inputForm :: Int -> Resource [(String, String)] inputForm limit - = do cTypeM <- getContentType + = limit `seq` + do cTypeM <- getContentType case cTypeM of Nothing -> abort BadRequest [] (Just "Missing Content-Type") @@ -605,7 +693,7 @@ inputForm limit Just (MIMEType "multipart" "form-data" _) -> readMultipartFormData Just cType - -> abort UnsupportedMediaType [] (Just $ "Unsupported media type: " + -> abort UnsupportedMediaType [] (Just $! "Unsupported media type: " ++ show cType) where readWWWFormURLEncoded @@ -614,9 +702,9 @@ inputForm limit readMultipartFormData -- FIXME: 未對應 = abort UnsupportedMediaType [] - (Just $ "Sorry, inputForm does not currently support multipart/form-data.") + (Just $! "Sorry, inputForm does not currently support multipart/form-data.") --- | This is just a constant -1. It's better to say @'input' +-- | 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 @@ -630,12 +718,13 @@ defaultLimit = (-1) -- the status code will be defaulted to \"200 OK\". setStatus :: StatusCode -> Resource () setStatus code - = do driftTo DecidingHeader - itr <- ask - liftIO $ atomically $ updateItr itr itrResponse - $ \ res -> res { - resStatus = code - } + = code `seq` + do driftTo DecidingHeader + itr <- getInteraction + liftIO $! atomically $! updateItr itr itrResponse + $! \ res -> res { + resStatus = code + } -- | Set a value of given resource header. Comparison of header name -- is case-insensitive. Note that this action is not intended to be @@ -653,32 +742,37 @@ setStatus code -- a part of header of the next response. setHeader :: String -> String -> Resource () setHeader name value - = driftTo DecidingHeader >> setHeader' name value + = name `seq` value `seq` + driftTo DecidingHeader >> setHeader' name value -setHeader' :: String -> String -> Resource() +setHeader' :: String -> String -> Resource () setHeader' name value - = do itr <- ask + = name `seq` value `seq` + do itr <- getInteraction liftIO $ atomically $ updateItr itr itrResponse $ H.setHeader name value -- | Computation of @'redirect' code uri@ sets the response status to --- @code@ and \"Location\" header to @uri@. @code@ must satisfy +-- @code@ and \"Location\" header to @uri@. The @code@ must satisfy -- 'Network.HTTP.Lucu.Response.isRedirection' or it causes an error. redirect :: StatusCode -> URI -> Resource () redirect code uri - = do when (code == NotModified || not (isRedirection code)) + = code `seq` uri `seq` + do when (code == NotModified || not (isRedirection code)) $ abort InternalServerError [] - $ Just ("Attempted to redirect with status " ++ show code) + $! 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 + = setHeader "Content-Type" $! show mType -- | Computation of @'setLocation' uri@ sets the response header -- \"Location\" to @uri@. @@ -686,6 +780,16 @@ setLocation :: URI -> Resource () setLocation uri = setHeader "Location" $ uriToString id uri $ "" +-- |Computation of @'setContentEncoding' codings@ sets the response +-- header \"Content-Encoding\" to @codings@. +setContentEncoding :: [String] -> Resource () +setContentEncoding codings + = do ver <- getRequestVersion + let tr = case ver of + HttpVersion 1 0 -> unnormalizeCoding + HttpVersion 1 1 -> id + setHeader "Content-Encoding" $ joinWith ", " $ map tr codings + {- DecidingBody 時に使用するアクション群 -} @@ -694,31 +798,35 @@ setLocation uri -- 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 +-- Note that 'outputLBS' is more efficient than 'output' so you should -- use it whenever possible. output :: String -> Resource () -output = outputBS . B.pack +output str = outputLBS $! 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 +outputLBS :: LazyByteString -> Resource () +outputLBS str = do outputChunkLBS str + driftTo Done +{-# INLINE outputLBS #-} -- | Computation of @'outputChunk' str@ writes @str@ as a part of -- response body. You can compute this action multiple times to write -- a body little at a time. It is safe to apply 'outputChunk' to an -- infinite string. -- --- Note that 'outputChunkBS' is more efficient than 'outputChunk' so +-- Note that 'outputChunkLBS' is more efficient than 'outputChunk' so -- you should use it whenever possible. outputChunk :: String -> Resource () -outputChunk = outputChunkBS . B.pack +outputChunk str = outputChunkLBS $! B.pack str +{-# INLINE outputChunk #-} -- | This is mostly the same as 'outputChunk' but is more efficient. -outputChunkBS :: ByteString -> Resource () -outputChunkBS str - = do driftTo DecidingBody - itr <- ask +outputChunkLBS :: LazyByteString -> Resource () +outputChunkLBS str + = str `seq` + do driftTo DecidingBody + itr <- getInteraction let limit = cnfMaxOutputChunkLength $ itrConfig itr when (limit <= 0) @@ -735,17 +843,16 @@ outputChunkBS str $ liftIO $ atomically $ writeItr itr itrBodyIsNull False where - {- チャンクの大きさは Config で制限されてゐる。もし例へば - /dev/zero を B.readFile して作った ByteString をそのまま - ResponseWriter に渡したりすると大變な事が起こる。何故なら - ResponseWriter はTransfer-Encoding: chunked の時、ヘッダを書く - 爲にチャンクの大きさを測るから、その時に起こるであらう事は言ふ - までも無い。 -} - sendChunks :: ByteString -> Int -> Resource () + -- チャンクの大きさは Config で制限されてゐる。もし例へば + -- "/dev/zero" を B.readFile して作った LazyByteString をそのまま + -- ResponseWriter に渡したりすると大變な事が起こる。何故なら + -- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書 + -- く爲にチャンクの大きさを測る。 + sendChunks :: LazyByteString -> Int -> Resource () sendChunks str limit | B.null str = return () | otherwise = do let (chunk, remaining) = B.splitAt (fromIntegral limit) str - itr <- ask + itr <- getInteraction liftIO $ atomically $ do buf <- readItr itr itrBodyToSend id if B.null buf then @@ -778,7 +885,8 @@ outputChunkBS str driftTo :: InteractionState -> Resource () driftTo newState - = do itr <- ask + = newState `seq` + do itr <- getInteraction liftIO $ atomically $ do oldState <- readItr itr itrState id if newState < oldState then throwStateError oldState newState