-- #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:
--
(
-- * Monad
Resource
+ , runRes -- private
-- * Actions
-- Body/.
, input
, inputChunk
- , inputBS
- , inputChunkBS
+ , inputLBS
+ , inputChunkLBS
, inputForm
, defaultLimit
-- Body/.
, output
, outputChunk
- , outputBS
- , outputChunkBS
+ , outputLBS
+ , outputChunkLBS
, driftTo
)
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
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
-- |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
-- > , ...
-- > }
getResourcePath :: Resource [String]
-getResourcePath = do itr <- ask
+getResourcePath = do itr <- getInteraction
return $! fromJust $! itrResourcePath itr
-- '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
-- 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
-- ('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
return B.empty
return chunk
where
- askForInput :: Interaction -> Resource ByteString
+ askForInput :: Interaction -> Resource LazyByteString
askForInput itr
= itr `seq`
do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
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
-- ('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
return B.empty
return chunk
where
- askForInput :: Interaction -> Resource ByteString
+ askForInput :: Interaction -> Resource LazyByteString
askForInput itr
= itr `seq`
do let defaultLimit = cnfMaxEntityLength $! itrConfig itr
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
= 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
setStatus code
= code `seq`
do driftTo DecidingHeader
- itr <- ask
+ itr <- getInteraction
liftIO $! atomically $! updateItr itr itrResponse
$! \ res -> res {
resStatus = code
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
-- 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)
$ 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
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
projects / Lucu.git / blobdiff