X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=8e25904ac927d00da9d96fecdfff998328f7d6d7;hb=0dc3d31312a12f2b085242841b29eb0d96e9c4ac;hp=7b64629bf832245669effa0acd8d55c5cc045a9c;hpb=11c3854540c46bfcd9e88c2164ed554f3b6550a5;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 7b64629..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 @@ -100,8 +102,8 @@ module Network.HTTP.Lucu.Resource -- Body/. , input , inputChunk - , inputBS - , inputChunkBS + , inputLBS + , inputChunkLBS , inputForm , defaultLimit @@ -122,8 +124,8 @@ module Network.HTTP.Lucu.Resource -- Body/. , output , outputChunk - , outputBS - , outputChunkBS + , outputLBS + , outputChunkLBS , driftTo ) @@ -132,8 +134,8 @@ 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 Network.HTTP.Lucu.Abortion @@ -155,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 +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 +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 @@ -194,7 +219,7 @@ 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 +getRequest = do itr <- getInteraction req <- liftIO $! atomically $! readItr itr itrRequest fromJust return req @@ -236,7 +261,7 @@ getRequestVersion = do req <- getRequest -- > , ... -- > } getResourcePath :: Resource [String] -getResourcePath = do itr <- ask +getResourcePath = do itr <- getInteraction return $! fromJust $! itrResourcePath itr @@ -280,9 +305,9 @@ getAccept = do acceptM <- getHeader "Accept" -> return [] Just accept -> case parseStr mimeTypeListP accept of - (Success xs, _) -> return xs - _ -> abort BadRequest [] - (Just $ "Unparsable Accept: " ++ accept) + (# 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 @@ -305,9 +330,9 @@ getAcceptEncoding -> return [("identity", Nothing)] Just accEnc -> case parseStr acceptEncodingListP accEnc of - (Success x, _) -> return $ reverse $ sortBy orderAcceptEncodings x - _ -> abort BadRequest [] - (Just $ "Unparsable Accept-Encoding: " ++ accEnc) + (# 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 @@ -327,9 +352,9 @@ getContentType -> return Nothing Just cType -> case parseStr mimeTypeP cType of - (Success t, _) -> return $ Just t - _ -> abort BadRequest [] - (Just $ "Unparsable Content-Type: " ++ cType) + (# Success t, _ #) -> return $ Just t + (# _ , _ #) -> abort BadRequest [] + (Just $ "Unparsable Content-Type: " ++ cType) {- ExaminingRequest 時に使用するアクション群 -} @@ -368,7 +393,7 @@ 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 @@ -388,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) + (# _, _ #) + -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ fromJust ifMatch) let statusForNoneMatch = if method == GET || method == HEAD then NotModified @@ -407,10 +433,11 @@ foundETag tag Nothing -> return () 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 BadRequest [] $! Just ("Unparsable If-None-Match: " ++ list) driftTo GettingBody @@ -422,7 +449,7 @@ 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 @@ -507,23 +534,25 @@ 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 = limit `seq` - inputBS limit >>= return . B.unpack + 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 +-- 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 <- ask + itr <- getInteraction hasBody <- liftIO $! atomically $! readItr itr itrRequestHasBody id chunk <- if hasBody then askForInput itr @@ -532,7 +561,7 @@ inputBS limit return B.empty return chunk where - askForInput :: Interaction -> Resource ByteString + askForInput :: Interaction -> Resource LazyByteString askForInput itr = itr `seq` do let defaultLimit = cnfMaxEntityLength $ itrConfig itr @@ -541,7 +570,7 @@ inputBS limit 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 @@ -590,20 +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 = limit `seq` - inputChunkBS limit >>= return . B.unpack + inputChunkLBS limit >>= return . B.unpack -- | This is mostly the same as 'inputChunk' but is more --- efficient. See 'inputBS'. -inputChunkBS :: Int -> Resource ByteString -inputChunkBS limit +-- efficient. See 'inputLBS'. +inputChunkLBS :: Int -> Resource LazyByteString +inputChunkLBS limit = limit `seq` do driftTo GettingBody - itr <- ask + itr <- getInteraction hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id chunk <- if hasBody then askForInput itr @@ -612,7 +641,7 @@ inputChunkBS limit return B.empty return chunk where - askForInput :: Interaction -> Resource ByteString + askForInput :: Interaction -> Resource LazyByteString askForInput itr = itr `seq` do let defaultLimit = cnfMaxEntityLength $! itrConfig itr @@ -621,7 +650,7 @@ inputChunkBS limit 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 @@ -675,7 +704,7 @@ inputForm limit = abort UnsupportedMediaType [] (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 @@ -691,7 +720,7 @@ setStatus :: StatusCode -> Resource () setStatus code = code `seq` do driftTo DecidingHeader - itr <- ask + itr <- getInteraction liftIO $! atomically $! updateItr itr itrResponse $! \ res -> res { resStatus = code @@ -720,13 +749,13 @@ setHeader name value setHeader' :: String -> String -> Resource () setHeader' name value = name `seq` value `seq` - do itr <- ask + 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 @@ -769,35 +798,35 @@ setContentEncoding codings -- 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 str = outputBS $! B.pack str +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 -{-# INLINE outputBS #-} +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 str = outputChunkBS $! B.pack str +outputChunk str = outputChunkLBS $! B.pack str {-# INLINE outputChunk #-} -- | This is mostly the same as 'outputChunk' but is more efficient. -outputChunkBS :: ByteString -> Resource () -outputChunkBS str +outputChunkLBS :: LazyByteString -> Resource () +outputChunkLBS str = str `seq` do driftTo DecidingBody - itr <- ask + itr <- getInteraction let limit = cnfMaxOutputChunkLength $ itrConfig itr when (limit <= 0) @@ -814,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 @@ -858,7 +886,7 @@ outputChunkBS str driftTo :: InteractionState -> Resource () driftTo newState = newState `seq` - do itr <- ask + do itr <- getInteraction liftIO $ atomically $ do oldState <- readItr itr itrState id if newState < oldState then throwStateError oldState newState