X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=696abf1b1311e55c5f13f4eca54a45ea02ea0146;hb=1f0a19c;hp=d0454c4c630d047a419f335a37ecfeb1c64211cb;hpb=72a3e24a952616e32845eeb4fc05048e841c91a2;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index d0454c4..696abf1 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -5,7 +5,6 @@
   , RecordWildCards
   , UnicodeSyntax
   #-}
-{-# OPTIONS_HADDOCK prune #-}
 -- |This is the Resource Monad; monadic actions to define the behavior
 -- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO'
 -- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is
@@ -63,18 +62,13 @@
 -- 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
     (
     -- * Types
       Resource
     , FormData(..)
-    , runRes
-
-    -- * Actions
-
-    -- ** Getting request header
 
+    -- * Getting request header
     -- |These actions can be computed regardless of the current state,
     -- and they don't change the state.
     , getConfig
@@ -96,8 +90,7 @@ module Network.HTTP.Lucu.Resource
     , getContentType
     , getAuthorization
 
-    -- ** Finding an entity
-
+    -- * Finding an entity
     -- |These actions can be computed only in the /Examining Request/
     -- state. After the computation, the 'Resource' transits to
     -- /Getting Body/ state.
@@ -106,41 +99,42 @@ module Network.HTTP.Lucu.Resource
     , foundTimeStamp
     , foundNoEntity
 
-    -- ** Getting a request body
-
+    -- * Getting a request body
     -- |Computation of these actions changes the state to /Getting
     -- Body/.
-    , input
-    , inputChunk
-    , inputForm
+    , getChunk
+    , getChunks
+    , getForm
     , defaultLimit
 
-    -- ** Setting response headers
-    
+    -- * Setting response headers
     -- |Computation of these actions changes the state to /Deciding
     -- Header/.
     , setStatus
-    , setHeader
     , redirect
     , setContentType
-    , setLocation
     , setContentEncoding
     , setWWWAuthenticate
 
-    -- ** Writing a response body
+    -- ** Less frequently used functions
+    , setLocation
+    , setHeader
+    , deleteHeader
 
+    -- * Writing a response body
     -- |Computation of these actions changes the state to /Deciding
     -- Body/.
-    , output
-    , outputChunk
-
-    , driftTo -- private
+    , putChunk
+    , putChunks
+    , putBuilder
     )
     where
+import Blaze.ByteString.Builder (Builder)
 import qualified Blaze.ByteString.Builder.ByteString as BB
 import Control.Applicative
 import Control.Concurrent.STM
-import Control.Monad.Reader
+import Control.Monad
+import Control.Monad.IO.Class
 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii)
 import qualified Data.Ascii as A
@@ -171,6 +165,7 @@ import Network.HTTP.Lucu.Interaction
 import Network.HTTP.Lucu.MultipartForm
 import Network.HTTP.Lucu.Postprocess
 import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Resource.Internal
 import Network.HTTP.Lucu.Response
 import Network.HTTP.Lucu.MIMEType
 import Network.HTTP.Lucu.Utils
@@ -179,21 +174,6 @@ import Network.URI hiding (path)
 import OpenSSL.X509
 import Prelude.Unicode
 
--- |The 'Resource' monad. This monad implements 'MonadIO' so it can do
--- any 'IO' actions.
-newtype Resource a
-    = Resource {
-        unRes ∷ ReaderT Interaction IO a
-      }
-    deriving (Applicative, Functor, Monad, MonadIO)
-
-runRes ∷ Resource a → Interaction → IO a
-runRes r itr
-    = runReaderT (unRes r) itr
-
-getInteraction ∷ Resource Interaction
-getInteraction = Resource ask
-
 -- |Get the 'Config' value which is used for the httpd.
 getConfig ∷ Resource Config
 getConfig = itrConfig <$> getInteraction
@@ -229,11 +209,6 @@ getRemoteHost
 getRemoteCertificate ∷ Resource (Maybe X509)
 getRemoteCertificate = itrRemoteCert <$> getInteraction
 
--- |Get the 'Request' value which represents the request header. In
--- general you don't have to use this action.
-getRequest ∷ Resource Request
-getRequest = (fromJust ∘ itrRequest) <$> getInteraction
-
 -- |Get the 'Method' value of the request.
 getMethod ∷ Resource Method
 getMethod = reqMethod <$> getRequest
@@ -410,7 +385,7 @@ getAuthorization
              return ac
 
 
-{- ExaminingRequest 時に使用するアクション群 -}
+-- Finding an entity
 
 -- |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
@@ -583,7 +558,7 @@ foundNoEntity msgM
          driftTo GettingBody
 
 
-{- GettingBody 時に使用するアクション群 -}
+-- Getting a request body
 
 -- | Computation of @'input' limit@ attempts to read the request body
 -- up to @limit@ bytes, and then make the 'Resource' transit to
@@ -775,45 +750,7 @@ 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 sc
-    = do driftTo DecidingHeader
-         itr ← getInteraction
-         liftIO
-             $ atomically
-             $ setResponseStatus itr sc
-
--- | 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 ∷ CIAscii → Ascii → Resource ()
-setHeader name value
-    = driftTo DecidingHeader ≫ setHeader' name value
-
-setHeader' ∷ CIAscii → Ascii → Resource ()
-setHeader' name value
-    = do itr ← getInteraction
-         liftIO $ atomically
-                $ do res ← readTVar $ itrResponse itr
-                     let res' = H.setHeader name value res
-                     writeTVar (itrResponse itr) res'
-                     when (name ≡ "Content-Type")
-                         $ writeTVar (itrResponseHasCType itr) True
+-- Setting response headers
 
 -- | Computation of @'redirect' code uri@ sets the response status to
 -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
@@ -833,11 +770,12 @@ redirect code uri
 -- | Computation of @'setContentType' mType@ sets the response header
 -- \"Content-Type\" to @mType@.
 setContentType ∷ MIMEType → Resource ()
-{-# INLINE setContentType #-}
-setContentType = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
+setContentType
+    = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
 
 -- | Computation of @'setLocation' uri@ sets the response header
--- \"Location\" to @uri@.
+-- \"Location\" to @uri@. You usually don't need to call this function
+-- directly.
 setLocation ∷ URI → Resource ()
 setLocation uri
     = case A.fromChars uriStr of
@@ -869,59 +807,13 @@ setWWWAuthenticate challenge
     = setHeader "WWW-Authenticate" (printAuthChallenge challenge)
 
 
-{- DecidingBody 時に使用するアクション群 -}
+-- Writing a response body
 
--- | Write a 'Lazy.ByteString' to the response body, and then transit
--- to the /Done/ state. It is safe to apply 'output' to an infinite
--- string, such as the lazy stream of \/dev\/random.
+-- | Write a chunk in 'Lazy.ByteString' to the response body. It is
+-- safe to apply this function to an infinitely long
+-- 'Lazy.ByteString'.
 --
--- Note that you must first set the \"Content-Type\" response header
+-- Note that you must first set the response header \"Content-Type\"
 -- before applying this function. See: 'setContentType'
-output ∷ Lazy.ByteString → Resource ()
-{-# INLINE output #-}
-output str = outputChunk str *> driftTo Done
-
--- | Write a 'Lazy.ByteString' to the response body. This action can
--- be repeated as many times as you want. It is safe to apply
--- 'outputChunk' to an infinite string.
---
--- Note that you must first set the \"Content-Type\" response header
--- before applying this function. See: 'setContentType'
-outputChunk ∷ Lazy.ByteString → Resource ()
-outputChunk str
-    = do driftTo DecidingBody
-         itr ← getInteraction
-         liftIO $ atomically
-                $ do hasCType ← readTVar $ itrResponseHasCType itr
-                     unless hasCType
-                         $ abortSTM InternalServerError []
-                         $ Just "outputChunk: Content-Type has not been set."
-                     putTMVar (itrBodyToSend itr) (BB.fromLazyByteString str)
-
-driftTo ∷ InteractionState → Resource ()
-driftTo newState
-    = do itr ← getInteraction
-         liftIO $ atomically
-                $ do oldState ← readTVar $ itrState itr
-                     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
-                            writeTVar (itrState itr) newState
-    where
-      throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
-      throwStateError Done DecidingBody
-          = fail "It makes no sense to output something after finishing outputs."
-      throwStateError old new
-          = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new)
-
-      drift ∷ Interaction → InteractionState → InteractionState → STM ()
-      drift (Interaction {..}) GettingBody _
-          = writeTVar itrReqBodyWasteAll True
-      drift itr DecidingHeader _
-          = postprocess itr
-      drift _ _ _
-          = return ()
+putChunk ∷ Lazy.ByteString → Resource ()
+putChunk = putBuilder ∘ BB.fromLazyByteString