X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=8e25904ac927d00da9d96fecdfff998328f7d6d7;hp=8942c762da36fa8104efe762288d1de33f0a6721;hb=0dc3d31312a12f2b085242841b29eb0d96e9c4ac;hpb=078fc2851ceae061fe368f2bc09fcd16d67ae00f

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 8942c76..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
 
 
@@ -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
@@ -424,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
@@ -509,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
@@ -534,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
@@ -543,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
@@ -592,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
@@ -614,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
@@ -623,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
@@ -677,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
@@ -693,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
@@ -722,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
@@ -771,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)
@@ -816,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
@@ -860,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