Resource.hs compiles again.

Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index 4d153d14e579df2a5d8bc9e410b0e53054f8db0e..f57a474f4884f388ecfe38be3f51e5edbba5a9ca 100644 (file)
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -7,7 +7,7 @@ module Network.HTTP.Lucu.Interaction
     ( Interaction(..)
     , InteractionState(..)
     , InteractionQueue
     ( Interaction(..)
     , InteractionState(..)
     , InteractionQueue

-    , GetBodyRequest(..)
+    , ReceiveBodyRequest(..)

     , newInteractionQueue
     , newInteraction
 
     , newInteractionQueue
     , newInteraction
 


@@ -40,8 +40,8 @@ data Interaction = Interaction {
     , itrExpectedContinue  ∷ !(Maybe Bool)
     , itrReqBodyLength     ∷ !(Maybe RequestBodyLength)
 
     , itrExpectedContinue  ∷ !(Maybe Bool)
     , itrReqBodyLength     ∷ !(Maybe RequestBodyLength)
 

-    , itrGetBodyRequest    ∷ !(TMVar GetBodyRequest)
-    , itrGotBody           ∷ !(TMVar Strict.ByteString)
+    , itrReceiveBodyReq    ∷ !(TMVar ReceiveBodyRequest)
+    , itrReceivedBody      ∷ !(TMVar Strict.ByteString)

 
     , itrResponse          ∷ !(TVar Response)
     , itrWillChunkBody     ∷ !(TVar Bool)
 
     , itrResponse          ∷ !(TVar Response)
     , itrWillChunkBody     ∷ !(TVar Bool)


@@ -57,16 +57,16 @@ data Interaction = Interaction {
 -- initial state.
 data InteractionState
     = ExaminingRequest
 -- initial state.
 data InteractionState
     = ExaminingRequest

-    | GettingBody
+    | ReceivingBody

     | DecidingHeader
     | DecidingHeader

-    | DecidingBody
+    | SendingBody

     | Done
     deriving (Show, Eq, Ord, Enum)
 
 type InteractionQueue = TVar (Seq Interaction)
 
     | Done
     deriving (Show, Eq, Ord, Enum)
 
 type InteractionQueue = TVar (Seq Interaction)
 

-data GetBodyRequest
-    = GetBody !Int -- ^ Maximum number of bytes.
+data ReceiveBodyRequest
+    = ReceiveBody !Int -- ^ Maximum number of octets to receive.

     | WasteAll
     deriving (Show, Eq)
 
     | WasteAll
     deriving (Show, Eq)
 


@@ -87,8 +87,8 @@ newInteraction conf@(Config {..}) port addr cert request
                    , resHeaders = (∅)
                    }
 
                    , resHeaders = (∅)
                    }
 

-         getBodyRequest   ← newEmptyTMVarIO
-         gotBody          ← newEmptyTMVarIO
+         receiveBodyReq   ← newEmptyTMVarIO
+         receivedBody     ← newEmptyTMVarIO

 
          response         ← newTVarIO res
          willChunkBody    ← newTVarIO False
 
          response         ← newTVarIO res
          willChunkBody    ← newTVarIO False


@@ -110,8 +110,8 @@ newInteraction conf@(Config {..}) port addr cert request
                     , itrExpectedContinue = arExpectedContinue ar
                     , itrReqBodyLength    = arReqBodyLength    ar
 
                     , itrExpectedContinue = arExpectedContinue ar
                     , itrReqBodyLength    = arReqBodyLength    ar
 

-                    , itrGetBodyRequest   = getBodyRequest
-                    , itrGotBody          = gotBody
+                    , itrReceiveBodyReq   = receiveBodyReq
+                    , itrReceivedBody     = receivedBody

 
                     , itrResponse         = response
                     , itrWillChunkBody    = willChunkBody
 
                     , itrResponse         = response
                     , itrWillChunkBody    = willChunkBody

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 696abf1b1311e55c5f13f4eca54a45ea02ea0146..eed224f11bd797f68ed2517d56dd465b4183f64f 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -5,10 +5,9 @@
   , RecordWildCards
   , UnicodeSyntax
   #-}
   , RecordWildCards
   , UnicodeSyntax
   #-}

--- |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
--- also a state machine.
+-- |This is the Resource Monad; monadic actions to define a behavior
+-- of resource. The 'Resource' Monad is a kind of 'IO' Monad thus it
+-- implements 'MonadIO' class, and it is a state machine as well.

 -- 
 -- Request Processing Flow:
 --
 -- 
 -- Request Processing Flow:
 --


@@ -17,9 +16,9 @@
 --   2. If the URI of it matches to any resource, the corresponding
 --      'Resource' Monad starts running on a newly spawned thread.
 --
 --   2. If the URI of it matches to any resource, the corresponding
 --      'Resource' Monad starts running on a newly spawned thread.
 --

---   3. The 'Resource' Monad looks at the request header, find (or not
---      find) an entity, receive the request body (if any), decide the
---      response header, and decide the response body. This process
+--   3. The 'Resource' Monad looks at request headers, find (or not
+--      find) an entity, receive the request body (if any), send
+--      response headers, and then send a response body. This process

 --      will be discussed later.
 --
 --   4. The 'Resource' Monad and its thread stops running. The client
 --      will be discussed later.
 --
 --   4. The 'Resource' Monad and its thread stops running. The client


@@ -29,29 +28,33 @@
 -- /Examining Request/ and the final state is /Done/.
 --
 --   [/Examining Request/] In this state, a 'Resource' looks at the
 -- /Examining Request/ and the final state is /Done/.
 --
 --   [/Examining Request/] In this state, a 'Resource' looks at the

---   request header and thinks about an entity for it. If there is a
---   suitable entity, the 'Resource' tells the system an entity tag
---   and its last modification time ('foundEntity'). If it found no
---   entity, it tells the system so ('foundNoEntity'). In case it is
---   impossible to decide the existence of entity, which is a typical
---   case for POST requests, 'Resource' does nothing in this state.
+--   request header fields and thinks about a corresponding entity for
+--   it. If there is a suitable entity, the 'Resource' tells the
+--   system an entity tag and its last modification time
+--   ('foundEntity'). If it found no entity, it tells the system so
+--   ('foundNoEntity'). In case it is impossible to decide the
+--   existence of entity, which is a typical case for POST requests,
+--   'Resource' does nothing in this state.

 --
 --

---   [/Getting Body/] A 'Resource' asks the system to receive a
---   request body from client. Before actually reading from the
+--   [/Receiving Body/] A 'Resource' asks the system to receive a
+--   request body from the client. Before actually reading from the

 --   socket, the system sends \"100 Continue\" to the client if need
 --   be. When a 'Resource' transits to the next state without
 --   socket, the system sends \"100 Continue\" to the client if need
 --   be. When a 'Resource' transits to the next state without

---   receiving all or part of request body, the system still reads it
---   and just throws it away.
+--   receiving all or part of a request body, the system automatically
+--   receives and discards it.

 --
 --   [/Deciding Header/] A 'Resource' makes a decision of status code
 --
 --   [/Deciding Header/] A 'Resource' makes a decision of status code

---   and response header. When it transits to the next state, the
---   system checks the validness of response header and then write
---   them to the socket.
+--   and response header fields. When it transits to the next state,
+--   the system validates and completes the response header fields and
+--   then sends them to the client.

 --
 --

---   [/Deciding Body/] In this state, a 'Resource' asks the system to
+--   [/Sending Body/] In this state, a 'Resource' asks the system to

 --   write some response body to the socket. When it transits to the
 --   next state without writing any response body, the system
 --   write some response body to the socket. When it transits to the
 --   next state without writing any response body, the system

---   completes it depending on the status code.
+--   automatically completes it depending on the status code. (To be
+--   exact, such completion only occurs when the 'Resource' transits
+--   to this state without even declaring the \"Content-Type\" header
+--   field. See 'setContentType'.)

 --
 --   [/Done/] Everything is over. A 'Resource' can do nothing for the
 --   HTTP interaction anymore.
 --
 --   [/Done/] Everything is over. A 'Resource' can do nothing for the
 --   HTTP interaction anymore.


@@ -69,8 +72,8 @@ module Network.HTTP.Lucu.Resource
     , FormData(..)
 
     -- * Getting request header
     , FormData(..)
 
     -- * Getting request header

-    -- |These actions can be computed regardless of the current state,
-    -- and they don't change the state.
+    -- |These functions can be called regardless of the current state,
+    -- and they don't change the state of 'Resource'.

     , getConfig
     , getRemoteAddr
     , getRemoteAddr'
     , getConfig
     , getRemoteAddr
     , getRemoteAddr'


@@ -91,25 +94,25 @@ module Network.HTTP.Lucu.Resource
     , getAuthorization
 
     -- * Finding an entity
     , getAuthorization
 
     -- * Finding an entity

-    -- |These actions can be computed only in the /Examining Request/
-    -- state. After the computation, the 'Resource' transits to
-    -- /Getting Body/ state.
+    -- |These functions can be called only in the /Examining Request/
+    -- state. They make the 'Resource' transit to the /Receiving Body/
+    -- state.

     , foundEntity
     , foundETag
     , foundTimeStamp
     , foundNoEntity
 
     , foundEntity
     , foundETag
     , foundTimeStamp
     , foundNoEntity
 

-    -- * Getting a request body
-    -- |Computation of these actions changes the state to /Getting
-    -- Body/.
+    -- * Receiving a request body
+    -- |These functions make the 'Resource' transit to the /Receiving
+    -- Body/ state.

     , getChunk
     , getChunks
     , getForm
     , getChunk
     , getChunks
     , getForm

-    , defaultLimit

 
 

-    -- * Setting response headers
-    -- |Computation of these actions changes the state to /Deciding
-    -- Header/.
+    -- * Declaring response status and header fields
+    -- |These functions can be called at any time before transiting to
+    -- the /Sending Body/ state, but they themselves never causes any
+    -- state transitions.

     , setStatus
     , redirect
     , setContentType
     , setStatus
     , redirect
     , setContentType


@@ -121,18 +124,16 @@ module Network.HTTP.Lucu.Resource
     , setHeader
     , deleteHeader
 
     , setHeader
     , deleteHeader
 

-    -- * Writing a response body
-    -- |Computation of these actions changes the state to /Deciding
-    -- Body/.
+    -- * Sending a response body
+    -- |These functions make the 'Resource' transit to the /Sending
+    -- Body/ state.

     , putChunk
     , putChunks
     , putBuilder
     )
     where
     , putChunk
     , putChunks
     , putBuilder
     )
     where

-import Blaze.ByteString.Builder (Builder)

 import qualified Blaze.ByteString.Builder.ByteString as BB
 import Control.Applicative
 import qualified Blaze.ByteString.Builder.ByteString as BB
 import Control.Applicative

-import Control.Concurrent.STM

 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Unicode
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Unicode


@@ -143,12 +144,14 @@ import qualified Data.Attoparsec.Lazy  as LP
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as Strict
 import qualified Data.ByteString.Lazy as Lazy
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as Strict
 import qualified Data.ByteString.Lazy as Lazy

+import qualified Data.ByteString.Lazy.Internal as Lazy

 import Data.Foldable (toList)
 import Data.List
 import qualified Data.Map as M
 import Data.Maybe
 import Data.Monoid.Unicode
 import Data.Sequence (Seq)
 import Data.Foldable (toList)
 import Data.List
 import qualified Data.Map as M
 import Data.Maybe
 import Data.Monoid.Unicode
 import Data.Sequence (Seq)

+import Data.Sequence.Unicode hiding ((∅))

 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T


@@ -163,7 +166,6 @@ import qualified Network.HTTP.Lucu.Headers as H
 import Network.HTTP.Lucu.HttpVersion
 import Network.HTTP.Lucu.Interaction
 import Network.HTTP.Lucu.MultipartForm
 import Network.HTTP.Lucu.HttpVersion
 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.Request
 import Network.HTTP.Lucu.Resource.Internal
 import Network.HTTP.Lucu.Response


@@ -171,25 +173,14 @@ import Network.HTTP.Lucu.MIMEType
 import Network.HTTP.Lucu.Utils
 import Network.Socket hiding (accept)
 import Network.URI hiding (path)
 import Network.HTTP.Lucu.Utils
 import Network.Socket hiding (accept)
 import Network.URI hiding (path)

-import OpenSSL.X509

 import Prelude.Unicode
 
 import Prelude.Unicode
 

--- |Get the 'Config' value which is used for the httpd.
-getConfig ∷ Resource Config
-getConfig = itrConfig <$> getInteraction
-
--- |Get the 'SockAddr' of the remote host. If you want a string
--- representation instead of 'SockAddr', use 'getRemoteAddr''.
-getRemoteAddr ∷ Resource SockAddr
-getRemoteAddr = itrRemoteAddr <$> getInteraction
-

 -- |Get the string representation of the address of remote host. If
 -- |Get the string representation of the address of remote host. If

--- you want a 'SockAddr' instead of 'String', use 'getRemoteAddr'.
+-- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'.

 getRemoteAddr' ∷ Resource HostName
 getRemoteAddr'
 getRemoteAddr' ∷ Resource HostName
 getRemoteAddr'

-    = do sa          ← getRemoteAddr
-         (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] True False sa
-         return a
+    = do sa ← getRemoteAddr
+         (fromJust ∘ fst) <$> (liftIO $ getNameInfo [NI_NUMERICHOST] True False sa)

 
 -- |Resolve an address to the remote host.
 getRemoteHost ∷ Resource (Maybe HostName)
 
 -- |Resolve an address to the remote host.
 getRemoteHost ∷ Resource (Maybe HostName)


@@ -197,18 +188,6 @@ getRemoteHost
     = do sa ← getRemoteAddr
          fst <$> (liftIO $ getNameInfo [] True False sa)
 
     = do sa ← getRemoteAddr
          fst <$> (liftIO $ getNameInfo [] True False sa)
 

--- | Return the X.509 certificate of the client, or 'Nothing' if:
---
---   * This request didn't came through an SSL stream.
---
---   * The client didn't send us its certificate.
---
---   * The 'OpenSSL.Session.VerificationMode' of
---   'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
---   'OpenSSL.Session.VerifyPeer'.
-getRemoteCertificate ∷ Resource (Maybe X509)
-getRemoteCertificate = itrRemoteCert <$> getInteraction
-

 -- |Get the 'Method' value of the request.
 getMethod ∷ Resource Method
 getMethod = reqMethod <$> getRequest
 -- |Get the 'Method' value of the request.
 getMethod ∷ Resource Method
 getMethod = reqMethod <$> getRequest


@@ -221,33 +200,8 @@ getRequestURI = reqURI <$> getRequest
 getRequestVersion ∷ Resource HttpVersion
 getRequestVersion = reqVersion <$> getRequest
 
 getRequestVersion ∷ Resource HttpVersion
 getRequestVersion = reqVersion <$> getRequest
 

--- |Get the path of this 'Resource' (to be exact,
--- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
--- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
--- action is the exact path in the tree even when the
--- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
---
--- Example:
---
--- > main = let tree = mkResTree [ (["foo"], resFoo) ]
--- >        in runHttpd defaultConfig tree
--- >
--- > resFoo = ResourceDef {
--- >     resIsGreedy = True
--- >   , resGet = Just $ do requestURI   <- getRequestURI
--- >                        resourcePath <- getResourcePath
--- >                        pathInfo     <- getPathInfo
--- >                        -- uriPath requestURI == "/foo/bar/baz"
--- >                        -- resourcePath       == ["foo"]
--- >                        -- pathInfo           == ["bar", "baz"]
--- >                        ...
--- >   , ...
--- >   }
-getResourcePath ∷ Resource [Text]
-getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction
-
--- |This is an analogy of CGI PATH_INFO. The result is
--- URI-unescaped. It is always @[]@ if the
+-- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns
+-- @[]@ if the corresponding

 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
 -- 'getResourcePath'.
 --
 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
 -- 'getResourcePath'.
 --


@@ -263,9 +217,9 @@ getPathInfo = do rsrcPath ← getResourcePath
                  return $ drop (length rsrcPath) reqPath
 
 -- |Assume the query part of request URI as
                  return $ drop (length rsrcPath) reqPath
 
 -- |Assume the query part of request URI as

--- application\/x-www-form-urlencoded, and parse it to pairs of
--- @(name, formData)@. This action doesn't parse the request body. See
--- 'inputForm'. Field names are decoded in UTF-8.
+-- application\/x-www-form-urlencoded, and parse it into pairs of
+-- @(name, formData)@. This function doesn't read the request
+-- body. Field names are decoded in UTF-8. See 'getForm'.

 getQueryForm ∷ Resource [(Text, FormData)]
 getQueryForm = parse' <$> getRequestURI
     where
 getQueryForm ∷ Resource [(Text, FormData)]
 getQueryForm = parse' <$> getRequestURI
     where


@@ -284,15 +238,16 @@ toPairWithFormData (name, value)
                }
       in (T.decodeUtf8 name, fd)
 
                }
       in (T.decodeUtf8 name, fd)
 

--- |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' name@ returns the value of the request header field
+-- @name@. Comparison of header name is case-insensitive. Note that
+-- this function is not intended to be used so frequently: there
+-- should be actions like 'getContentType' for every common headers.

 getHeader ∷ CIAscii → Resource (Maybe Ascii)
 getHeader name
     = H.getHeader name <$> getRequest
 
 getHeader ∷ CIAscii → Resource (Maybe Ascii)
 getHeader name
     = H.getHeader name <$> getRequest
 

--- |Get a list of 'MIMEType' enumerated on header \"Accept\".
+-- |Return the list of 'MIMEType' enumerated on the value of request
+-- header \"Accept\", or @[]@ if absent.

 getAccept ∷ Resource [MIMEType]
 getAccept
     = do acceptM ← getHeader "Accept"
 getAccept ∷ Resource [MIMEType]
 getAccept
     = do acceptM ← getHeader "Accept"


@@ -309,9 +264,9 @@ getAccept
              P.endOfInput
              return xs
 
              P.endOfInput
              return xs
 

--- |Get a list of @(contentCoding, qvalue)@ enumerated on header
--- \"Accept-Encoding\". The list is sorted in descending order by
--- qvalue.
+-- |Return the list of @(contentCoding, qvalue)@ enumerated on the
+-- value of request header \"Accept-Encoding\". The list is sorted in
+-- descending order by qvalue.

 getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
 getAcceptEncoding
     = do accEncM ← getHeader "Accept-Encoding"
 getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)]
 getAcceptEncoding
     = do accEncM ← getHeader "Accept-Encoding"


@@ -331,11 +286,11 @@ getAcceptEncoding
                → if ae ≡ "" then
                       -- identity のみが許される。
                       return [("identity", Nothing)]
                → if ae ≡ "" then
                       -- identity のみが許される。
                       return [("identity", Nothing)]

-                  else
-                      case P.parseOnly p (A.toByteString ae) of
-                        Right xs → return $ map toTuple $ reverse $ sort xs
-                        Left  _  → abort BadRequest []
-                                   (Just $ "Unparsable Accept-Encoding: " ⊕ A.toText ae)
+                 else
+                     case P.parseOnly p (A.toByteString ae) of
+                       Right xs → return $ map toTuple $ reverse $ sort xs
+                       Left  _  → abort BadRequest []
+                                  (Just $ "Unparsable Accept-Encoding: " ⊕ A.toText ae)

     where
       p = do xs ← acceptEncodingListP
              P.endOfInput
     where
       p = do xs ← acceptEncodingListP
              P.endOfInput


@@ -344,14 +299,14 @@ getAcceptEncoding
       toTuple (AcceptEncoding {..})
           = (aeEncoding, aeQValue)
 
       toTuple (AcceptEncoding {..})
           = (aeEncoding, aeQValue)
 

--- |Check whether a given content-coding is acceptable.
+-- |Return 'True' iff a given content-coding is acceptable.

 isEncodingAcceptable ∷ CIAscii → Resource Bool
 isEncodingAcceptable ∷ CIAscii → Resource Bool

-isEncodingAcceptable encoding = any f <$> getAcceptEncoding
+isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding

     where
     where

-      f (e, q)
-          = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
+      doesMatch ∷ (CIAscii, Maybe Double) → Bool
+      doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0

 
 

--- |Get the header \"Content-Type\" as 'MIMEType'.
+-- |Return the value of request header \"Content-Type\" as 'MIMEType'.

 getContentType ∷ Resource (Maybe MIMEType)
 getContentType
     = do cTypeM ← getHeader "Content-Type"
 getContentType ∷ Resource (Maybe MIMEType)
 getContentType
     = do cTypeM ← getHeader "Content-Type"


@@ -368,7 +323,8 @@ getContentType
              P.endOfInput
              return t
 
              P.endOfInput
              return t
 

--- |Get the header \"Authorization\" as 'AuthCredential'.
+-- |Return the value of request header \"Authorization\" as
+-- 'AuthCredential'.

 getAuthorization ∷ Resource (Maybe AuthCredential)
 getAuthorization
     = do authM ← getHeader "Authorization"
 getAuthorization ∷ Resource (Maybe AuthCredential)
 getAuthorization
     = do authM ← getHeader "Authorization"


@@ -384,56 +340,53 @@ getAuthorization
              P.endOfInput
              return ac
 
              P.endOfInput
              return ac
 

-
--- 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
 -- a datum to be replied. If this is a PUT or DELETE request, it means
 -- |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
 -- a datum to be replied. If this is a PUT or DELETE request, it means

--- a datum which was stored for the URI until now. It is an error to
--- compute 'foundEntity' if this is a POST request.
+-- a datum which was stored for the URI until now. For POST requests
+-- it raises an error.

 --
 --

--- Computation of 'foundEntity' performs \"If-Match\" test or
--- \"If-None-Match\" test if possible. When those tests fail, the
--- computation of 'Resource' immediately aborts with status \"412
--- Precondition Failed\" or \"304 Not Modified\" depending on the
--- situation.
+-- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test
+-- whenever possible, and if those tests fail, it immediately aborts
+-- with status \"412 Precondition Failed\" or \"304 Not Modified\"
+-- depending on the situation.

 --
 --

--- If this is a GET or HEAD request, 'foundEntity' automatically puts
--- \"ETag\" and \"Last-Modified\" headers into the response.
+-- If the request method is either GET or HEAD, 'foundEntity'
+-- automatically puts \"ETag\" and \"Last-Modified\" headers into the
+-- response.

 foundEntity ∷ ETag → UTCTime → Resource ()
 foundEntity tag timeStamp
     = do driftTo ExaminingRequest
 
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)
 foundEntity ∷ ETag → UTCTime → Resource ()
 foundEntity tag timeStamp
     = do driftTo ExaminingRequest
 
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)

-             $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
+             $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)

          when (method ≡ POST)
              $ abort InternalServerError []
          when (method ≡ POST)
              $ abort InternalServerError []

-               (Just "Illegal computation of foundEntity for a POST request.")
+               (Just "foundEntity: this is a POST request.")

          foundETag tag
 
          foundETag tag
 

-         driftTo GettingBody
+         driftTo ReceivingBody

 
 -- |Tell the system that the 'Resource' found an entity for the
 -- request URI. The only difference from 'foundEntity' is that
 
 -- |Tell the system that the 'Resource' found an entity for the
 -- request URI. The only difference from 'foundEntity' is that

--- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
+-- 'foundETag' doesn't (nor can't) put \"Last-Modified\" header into

 -- the response.
 --
 -- the response.
 --

--- This action is not preferred. You should use 'foundEntity' whenever
--- possible.
+-- Using this function is discouraged. You should use 'foundEntity'
+-- whenever possible.

 foundETag ∷ ETag → Resource ()
 foundETag tag
     = do driftTo ExaminingRequest
       
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)
 foundETag ∷ ETag → Resource ()
 foundETag tag
     = do driftTo ExaminingRequest
       
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)

-              $ setHeader' "ETag"
-              $ A.fromAsciiBuilder
-              $ printETag tag
+             $ setHeader "ETag"
+             $ A.fromAsciiBuilder
+             $ printETag tag

          when (method ≡ POST)
          when (method ≡ POST)

-              $ abort InternalServerError []
-                (Just "Illegal computation of foundETag for POST request.")
+             $ abort InternalServerError []
+             $ Just "Illegal computation of foundETag for POST request."

 
          -- If-Match があればそれを見る。
          ifMatch ← getHeader "If-Match"
 
          -- If-Match があればそれを見る。
          ifMatch ← getHeader "If-Match"


@@ -444,13 +397,16 @@ foundETag tag
                         else
                             case P.parseOnly p (A.toByteString value) of
                               Right tags
                         else
                             case P.parseOnly p (A.toByteString value) of
                               Right tags

-                                 -- tags の中に一致するものが無ければ
-                                 -- PreconditionFailed で終了。
-                                 → when ((¬) (any (≡ tag) tags))
-                                       $ abort PreconditionFailed []
-                                         (Just $ "The entity tag doesn't match: " ⊕ A.toText value)
+                                  -- tags の中に一致するものが無ければ
+                                  -- PreconditionFailed で終了。
+                                  → when ((¬) (any (≡ tag) tags))
+                                        $ abort PreconditionFailed []
+                                        $ Just
+                                        $ "The entity tag doesn't match: " ⊕ A.toText value

                               Left _
                               Left _

-                                   → abort BadRequest [] (Just $ "Unparsable If-Match: " ⊕ A.toText value)
+                                  → abort BadRequest []
+                                    $ Just
+                                    $ "Unparsable If-Match: " ⊕ A.toText value

 
          let statusForNoneMatch
                  = if method ≡ GET ∨ method ≡ HEAD then
 
          let statusForNoneMatch
                  = if method ≡ GET ∨ method ≡ HEAD then


@@ -463,18 +419,20 @@ foundETag tag
          case ifNoneMatch of
            Nothing    → return ()
            Just value → if value ≡ "*" then
          case ifNoneMatch of
            Nothing    → return ()
            Just value → if value ≡ "*" then

-                             abort statusForNoneMatch [] (Just "The entity tag matches: *")
-                         else
-                             case P.parseOnly p (A.toByteString value) of
-                               Right tags
-                                   → when (any (≡ tag) tags)
-                                         $ abort statusForNoneMatch []
-                                           (Just $ "The entity tag matches: " ⊕ A.toText value)
-                               Left _
-                                   → abort BadRequest []
-                                     (Just $ "Unparsable If-None-Match: " ⊕ A.toText value)
-
-         driftTo GettingBody
+                            abort statusForNoneMatch [] (Just "The entity tag matches: *")
+                        else
+                            case P.parseOnly p (A.toByteString value) of
+                              Right tags
+                                  → when (any (≡ tag) tags)
+                                        $ abort statusForNoneMatch []
+                                        $ Just
+                                        $ "The entity tag matches: " ⊕ A.toText value
+                              Left _
+                                  → abort BadRequest []
+                                    $ Just
+                                    $ "Unparsable If-None-Match: " ⊕ A.toText value
+
+         driftTo ReceivingBody

     where
       p = do xs ← eTagListP
              P.endOfInput
     where
       p = do xs ← eTagListP
              P.endOfInput


@@ -484,19 +442,19 @@ foundETag tag
 -- request URI. The only difference from 'foundEntity' is that
 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
 -- request URI. The only difference from 'foundEntity' is that
 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or

--- \"If-None-Match\" test. Be aware that any tests based on last
+-- \"If-None-Match\" test. Be aware that any tests based on a last

 -- modification time are unsafe because it is possible to mess up such
 -- tests by modifying the entity twice in a second.
 --
 -- 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' whenever
--- possible.
+-- Using this function is discouraged. You should use 'foundEntity'
+-- whenever possible.

 foundTimeStamp ∷ UTCTime → Resource ()
 foundTimeStamp timeStamp
     = do driftTo ExaminingRequest
 
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)
 foundTimeStamp ∷ UTCTime → Resource ()
 foundTimeStamp timeStamp
     = do driftTo ExaminingRequest
 
          method ← getMethod
          when (method ≡ GET ∨ method ≡ HEAD)

-             $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp)
+             $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)

          when (method ≡ POST)
              $ abort InternalServerError []
                (Just "Illegal computation of foundTimeStamp for POST request.")
          when (method ≡ POST)
              $ abort InternalServerError []
                (Just "Illegal computation of foundTimeStamp for POST request.")


@@ -531,15 +489,15 @@ foundTimeStamp timeStamp
                              → return () -- 不正な時刻は無視
            Nothing  → return ()
 
                              → return () -- 不正な時刻は無視
            Nothing  → return ()
 

-         driftTo GettingBody
+         driftTo ReceivingBody

 
 

--- | Computation of @'foundNoEntity' mStr@ tells the system that the
--- 'Resource' found no entity for the request URI. @mStr@ is an
--- optional error message to be replied to the client.
+-- |@'foundNoEntity' mStr@ tells the system that the 'Resource' found
+-- no entity for the request URI. @mStr@ is an optional error message
+-- to be replied to the client.

 --
 --

--- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
--- test and aborts with status \"412 Precondition Failed\" when it
--- failed. If this is a GET, HEAD, POST or DELETE request,
+-- If the request method is PUT, 'foundNoEntity' performs \"If-Match\"
+-- test and when that fails it aborts with status \"412 Precondition
+-- Failed\". If the request method is GET, HEAD, POST or DELETE,

 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
 foundNoEntity ∷ Maybe Text → Resource ()
 foundNoEntity msgM
 -- 'foundNoEntity' always aborts with status \"404 Not Found\".
 foundNoEntity ∷ Maybe Text → Resource ()
 foundNoEntity msgM


@@ -555,149 +513,62 @@ foundNoEntity msgM
          when (ifMatch ≢ Nothing)
              $ abort PreconditionFailed [] msgM
 
          when (ifMatch ≢ Nothing)
              $ abort PreconditionFailed [] msgM
 

-         driftTo GettingBody
+         driftTo ReceivingBody

 
 
 
 

--- 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
--- /Deciding Header/ state. When the actual size of body is larger
--- than @limit@ bytes, computation of 'Resource' immediately aborts
--- with status \"413 Request Entity Too Large\". When the request has
--- no body, 'input' returns an empty string.
+-- |@'getChunks' limit@ attemts to read the entire request body up to
+-- @limit@ bytes, and then make the 'Resource' transit to the
+-- /Deciding Header/ state. When the actual size of the body is larger
+-- than @limit@ bytes, 'getChunks' immediately aborts with status
+-- \"413 Request Entity Too Large\". When the request has no body, it
+-- returns an empty string.

 --
 --

--- @limit@ may be less than or equal to zero. In this case, the
--- default limitation value ('cnfMaxEntityLength') is used. See
--- 'defaultLimit'.
+-- When the @limit@ is 'Nothing', 'getChunks' uses the default
+-- limitation value ('cnfMaxEntityLength') instead.

 --
 --

--- 'input' returns a 'Lazy.ByteString' but it's not really lazy:
--- reading from the socket just happens at the computation of 'input',
--- not at the evaluation of the 'Lazy.ByteString'. The same goes for
--- 'inputChunk'.
-input ∷ Int → Resource Lazy.ByteString
-input limit
-    = do driftTo GettingBody
-         itr     ← getInteraction
-         chunk   ← if reqMustHaveBody $ fromJust $ itrRequest itr then
-                       askForInput itr
-                   else
-                       do driftTo DecidingHeader
-                          return (∅)
-         return chunk
+-- 'getChunks' returns a 'Lazy.ByteString' but it's not really lazy:
+-- reading from the socket just happens at the computation of
+-- 'getChunks', not at the evaluation of the 'Lazy.ByteString'.
+getChunks ∷ Maybe Int → Resource Lazy.ByteString
+getChunks (Just n)
+    | n < 0     = fail ("getChunks: limit must not be negative: " ⧺ show n)
+    | n ≡ 0     = return (∅)
+    | otherwise = getChunks' n
+getChunks Nothing
+    = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength
+
+getChunks' ∷ Int → Resource Lazy.ByteString
+getChunks' limit = go limit (∅)

     where
     where

-      askForInput ∷ Interaction → Resource Lazy.ByteString
-      askForInput (Interaction {..})
-          = do let confLimit   = cnfMaxEntityLength itrConfig
-                   actualLimit = if limit ≤ 0 then
-                                     confLimit
-                                 else
-                                     limit
-               when (actualLimit ≤ 0)
-                        $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
-               -- Reader にリクエスト
-               liftIO $ atomically
-                      $ writeTVar itrReqBodyWanted actualLimit
-               -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
-               chunk ← liftIO $ atomically
-                       $ do chunkLen    ← readTVar itrReceivedBodyLen
-                            chunkIsOver ← readTVar itrReqChunkIsOver
-                            if chunkLen < actualLimit then
-                                -- 要求された量に滿たなくて、まだ殘りが
-                                -- あるなら再試行。
-                                unless chunkIsOver
-                                    $ retry
-                            else
-                                -- 制限値一杯まで讀むやうに指示したのに
-                                -- まだ殘ってゐるなら、それは多過ぎる。
-                                unless chunkIsOver
-                                    $ tooLarge actualLimit
-                            -- 成功。itr 内にチャンクを置いたままにする
-                            -- とメモリの無駄になるので除去。
-                            chunk ← seqToLBS <$> readTVar itrReceivedBody
-                            writeTVar itrReceivedBody    (∅)
-                            writeTVar itrReceivedBodyLen 0
-                            return chunk
-
-               driftTo DecidingHeader
-               return chunk
-
-      tooLarge ∷ Int → STM ()
-      tooLarge lim = abortSTM RequestEntityTooLarge []
-                     (Just $ "Request body must be smaller than "
-                             ⊕ T.pack (show lim) ⊕ " bytes.")
-
-seqToLBS ∷ Seq ByteString → Lazy.ByteString
-{-# INLINE seqToLBS #-}
-seqToLBS = Lazy.fromChunks ∘ toList
-         
--- | Computation of @'inputChunk' limit@ attempts to read a part of
--- request body up to @limit@ bytes. You can read any large request by
--- repeating computation of this action. When you've read all the
--- request body, 'inputChunk' returns an empty string and then make
--- the 'Resource' transit to /Deciding Header/ state.
---
--- @limit@ may be less than or equal to zero. In this case, the
--- default limitation value ('cnfMaxEntityLength') is used. See
--- 'defaultLimit'.
---
--- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you
--- should use it whenever possible.
-inputChunk ∷ Int → Resource Lazy.ByteString
-inputChunk limit
-    = do driftTo GettingBody
-         itr     ← getInteraction
-         chunk   ← if reqMustHaveBody $ fromJust $ itrRequest itr then
-                       askForInput itr
+      go ∷ Int → Seq Strict.ByteString → Resource Lazy.ByteString
+      go 0 _  = abort RequestEntityTooLarge []
+                (Just $ "Request body must be smaller than "
+                        ⊕ T.pack (show limit) ⊕ " bytes.")
+      go n xs = do let n'  = min n Lazy.defaultChunkSize
+                   chunk ← getChunk n'
+                   if Strict.null chunk then
+                       -- Got EOF
+                       return $ Lazy.fromChunks $ toList xs

                    else
                    else

-                       do driftTo DecidingHeader
-                          return (∅)
-         return chunk
-    where
-      askForInput ∷ Interaction → Resource Lazy.ByteString
-      askForInput (Interaction {..})
-          = do let confLimit   = cnfMaxEntityLength itrConfig
-                   actualLimit = if limit < 0 then
-                                     confLimit
-                                 else
-                                     limit
-               when (actualLimit ≤ 0)
-                        $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
-               -- Reader にリクエスト
-               liftIO $ atomically
-                      $ writeTVar itrReqBodyWanted actualLimit
-               -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
-               chunk ← liftIO $ atomically
-                       $ do chunkLen ← readTVar itrReceivedBodyLen
-                            -- 要求された量に滿たなくて、まだ殘りがある
-                            -- なら再試行。
-                            when (chunkLen < actualLimit)
-                                $ do chunkIsOver ← readTVar itrReqChunkIsOver
-                                     unless chunkIsOver
-                                         $ retry
-                            -- 成功
-                            chunk ← seqToLBS <$> readTVar itrReceivedBody
-                            writeTVar itrReceivedBody    (∅)
-                            writeTVar itrReceivedBodyLen 0
-                            return chunk
-               when (Lazy.null chunk)
-                   $ driftTo DecidingHeader
-               return chunk
-
--- | Computation of @'inputForm' limit@ attempts to read the request
--- body with 'input' and parse it as
--- @application\/x-www-form-urlencoded@ or @multipart\/form-data@. If
--- the request header \"Content-Type\" is neither of them, 'inputForm'
--- makes 'Resource' abort with status \"415 Unsupported Media
--- Type\". If the request has no \"Content-Type\", it aborts with
--- \"400 Bad Request\".
+                       do let n'' = n' - Strict.length chunk
+                              xs' = xs ⊳ chunk
+                          go n'' xs'
+
+-- |@'getForm' limit@ attempts to read the request body with
+-- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
+-- @multipart\/form-data@. If the request header \"Content-Type\" is
+-- neither of them, 'getForm' aborts with status \"415 Unsupported
+-- Media Type\". If the request has no \"Content-Type\", it aborts
+-- with \"400 Bad Request\".

 --
 -- Field names in @multipart\/form-data@ will be precisely decoded in
 -- accordance with RFC 2231. On the other hand,
 -- @application\/x-www-form-urlencoded@ says nothing about the
 --
 -- Field names in @multipart\/form-data@ will be precisely decoded in
 -- accordance with RFC 2231. On the other hand,
 -- @application\/x-www-form-urlencoded@ says nothing about the

--- encoding of field names, so they'll always be decoded in UTF-8.
-inputForm ∷ Int → Resource [(Text, FormData)]
-inputForm limit
+-- encoding of field names, so they'll always be decoded in
+-- UTF-8. (This could be a bad design, but I can't think of any better
+-- idea.)
+getForm ∷ Maybe Int → Resource [(Text, FormData)]
+getForm limit

     = do cTypeM ← getContentType
          case cTypeM of
            Nothing
     = do cTypeM ← getContentType
          case cTypeM of
            Nothing


@@ -717,7 +588,7 @@ inputForm limit
       readWWWFormURLEncoded
           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
             <$>
       readWWWFormURLEncoded
           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
             <$>

-            (bsToAscii =≪ input limit)
+            (bsToAscii =≪ getChunks limit)

 
       bsToAscii bs
           = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
 
       bsToAscii bs
           = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of


@@ -729,7 +600,7 @@ inputForm limit
                  Nothing
                      → abort BadRequest [] (Just "Missing boundary of multipart/form-data")
                  Just boundary
                  Nothing
                      → abort BadRequest [] (Just "Missing boundary of multipart/form-data")
                  Just boundary

-                     → do src ← input limit
+                     → do src ← getChunks limit

                           b   ← case A.fromText boundary of
                                    Just b  → return b
                                    Nothing → abort BadRequest []
                           b   ← case A.fromText boundary of
                                    Just b  → return b
                                    Nothing → abort BadRequest []


@@ -743,18 +614,9 @@ inputForm limit
                      P.endOfInput
                      return xs
 
                      P.endOfInput
                      return xs
 

--- | 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
-defaultLimit = (-1)
-
-
--- Setting response headers
-
--- | Computation of @'redirect' code uri@ sets the response status to
--- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
--- 'isRedirection' or it causes an error.
+-- |@'redirect' code uri@ declares the response status as @code@ and
+-- \"Location\" header field as @uri@. The @code@ must satisfy
+-- 'isRedirection' or it raises an error.

 redirect ∷ StatusCode → URI → Resource ()
 redirect code uri
     = do when (code ≡ NotModified ∨ not (isRedirection code))
 redirect ∷ StatusCode → URI → Resource ()
 redirect code uri
     = do when (code ≡ NotModified ∨ not (isRedirection code))


@@ -767,15 +629,15 @@ redirect code uri
          setStatus code
          setLocation uri
 
          setStatus code
          setLocation uri
 

--- | Computation of @'setContentType' mType@ sets the response header
--- \"Content-Type\" to @mType@.
+-- |@'setContentType' mType@ declares the response header
+-- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
+-- mandatory for sending a response body.

 setContentType ∷ MIMEType → Resource ()
 setContentType
     = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
 
 setContentType ∷ MIMEType → Resource ()
 setContentType
     = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
 

--- | Computation of @'setLocation' uri@ sets the response header
--- \"Location\" to @uri@. You usually don't need to call this function
--- directly.
+-- |@'setLocation' uri@ declares the response header \"Location\" as
+-- @uri@. You usually don't need to call this function directly.

 setLocation ∷ URI → Resource ()
 setLocation uri
     = case A.fromChars uriStr of
 setLocation ∷ URI → Resource ()
 setLocation uri
     = case A.fromChars uriStr of


@@ -785,8 +647,8 @@ setLocation uri
     where
       uriStr = uriToString id uri ""
 
     where
       uriStr = uriToString id uri ""
 

--- |Computation of @'setContentEncoding' codings@ sets the response
--- header \"Content-Encoding\" to @codings@.
+-- |@'setContentEncoding' codings@ declares the response header
+-- \"Content-Encoding\" as @codings@.

 setContentEncoding ∷ [CIAscii] → Resource ()
 setContentEncoding codings
     = do ver ← getRequestVersion
 setContentEncoding ∷ [CIAscii] → Resource ()
 setContentEncoding codings
     = do ver ← getRequestVersion


@@ -800,20 +662,23 @@ setContentEncoding codings
     where
       toAB = A.toAsciiBuilder ∘ A.fromCIAscii
 
     where
       toAB = A.toAsciiBuilder ∘ A.fromCIAscii
 

--- |Computation of @'setWWWAuthenticate' challenge@ sets the response
--- header \"WWW-Authenticate\" to @challenge@.
+-- |@'setWWWAuthenticate' challenge@ declares the response header
+-- \"WWW-Authenticate\" as @challenge@.

 setWWWAuthenticate ∷ AuthChallenge → Resource ()
 setWWWAuthenticate ∷ AuthChallenge → Resource ()

-setWWWAuthenticate challenge
-    = setHeader "WWW-Authenticate" (printAuthChallenge challenge)
-
+setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge

 
 

--- Writing a response body
+-- |Write a chunk in 'Strict.ByteString' to the response body. You
+-- must first declare the response header \"Content-Type\" before
+-- applying this function. See 'setContentType'.
+putChunk ∷ Strict.ByteString → Resource ()
+putChunk = putBuilder ∘ BB.fromByteString

 
 

--- | Write a chunk in 'Lazy.ByteString' to the response body. It is
+-- |Write a chunk in 'Lazy.ByteString' to the response body. It is

 -- safe to apply this function to an infinitely long
 -- 'Lazy.ByteString'.
 --
 -- safe to apply this function to an infinitely long
 -- 'Lazy.ByteString'.
 --

--- Note that you must first set the response header \"Content-Type\"
--- before applying this function. See: 'setContentType'
-putChunk ∷ Lazy.ByteString → Resource ()
-putChunk = putBuilder ∘ BB.fromLazyByteString
+-- Note that you must first declare the response header
+-- \"Content-Type\" before applying this function. See
+-- 'setContentType'.
+putChunks ∷ Lazy.ByteString → Resource ()
+putChunks = putBuilder ∘ BB.fromLazyByteString

diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs
index d68b334ed7f706d4c7234bfb9b6799d2505ae3a6..418a330f5c7bca2d6bb05a2cc9a9d2cbaa8645a7 100644 (file)
--- a/Network/HTTP/Lucu/Resource/Internal.hs
+++ b/Network/HTTP/Lucu/Resource/Internal.hs
@@ -11,12 +11,16 @@ module Network.HTTP.Lucu.Resource.Internal
     , emptyResource
     , spawnResource
 
     , emptyResource
     , spawnResource
 

-    , getInteraction
+    , getConfig
+    , getRemoteAddr
+    , getRemoteCertificate

     , getRequest
     , getRequest

+    , getResourcePath
+
+    , getChunk

 
     , setStatus
     , setHeader
 
     , setStatus
     , setHeader

-    , setHeader'

     , deleteHeader
 
     , putBuilder
     , deleteHeader
 
     , putBuilder


@@ -33,9 +37,11 @@ import Control.Monad.IO.Class
 import Control.Monad.Reader
 import Data.Ascii (Ascii, CIAscii)
 import qualified Data.Ascii as A
 import Control.Monad.Reader
 import Data.Ascii (Ascii, CIAscii)
 import qualified Data.Ascii as A

+import qualified Data.ByteString as Strict

 import Data.List
 import Data.Maybe
 import Data.Monoid.Unicode
 import Data.List
 import Data.Maybe
 import Data.Monoid.Unicode

+import Data.Text (Text)

 import qualified Data.Text as T
 import Network.HTTP.Lucu.Abortion
 import Network.HTTP.Lucu.Config
 import qualified Data.Text as T
 import Network.HTTP.Lucu.Abortion
 import Network.HTTP.Lucu.Config


@@ -46,6 +52,8 @@ import Network.HTTP.Lucu.Postprocess
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 import Network.HTTP.Lucu.Utils
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 import Network.HTTP.Lucu.Utils

+import Network.Socket
+import OpenSSL.X509

 import Prelude hiding (catch)
 import Prelude.Unicode
 import System.IO
 import Prelude hiding (catch)
 import Prelude.Unicode
 import System.IO


@@ -61,7 +69,7 @@ newtype Resource a
 runResource ∷ Resource a → Interaction → IO a
 runResource = runReaderT ∘ unResource
 
 runResource ∷ Resource a → Interaction → IO a
 runResource = runReaderT ∘ unResource
 

--- | 'ResourceDef' is basically a set of 'Resource' monads for each
+-- |'ResourceDef' is basically a set of 'Resource' monads for each

 -- HTTP methods.
 data ResourceDef = ResourceDef {
     -- |Whether to run a 'Resource' on a native thread (spawned by
 -- HTTP methods.
 data ResourceDef = ResourceDef {
     -- |Whether to run a 'Resource' on a native thread (spawned by


@@ -77,7 +85,7 @@ data ResourceDef = ResourceDef {
     -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
     -- resources are like CGI scripts.
     , resIsGreedy         ∷ !Bool
     -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
     -- resources are like CGI scripts.
     , resIsGreedy         ∷ !Bool

-    -- | A 'Resource' to be run when a GET request comes for the
+    -- |A 'Resource' to be run when a GET request comes for the

     -- resource path. If 'resGet' is Nothing, the system responds
     -- \"405 Method Not Allowed\" for GET requests.
     --
     -- resource path. If 'resGet' is Nothing, the system responds
     -- \"405 Method Not Allowed\" for GET requests.
     --


@@ -85,20 +93,20 @@ data ResourceDef = ResourceDef {
     -- this case 'output' and such like don't actually write a
     -- response body.
     , resGet              ∷ !(Maybe (Resource ()))
     -- this case 'output' and such like don't actually write a
     -- response body.
     , resGet              ∷ !(Maybe (Resource ()))

-    -- | A 'Resource' to be run when a HEAD request comes for the
+    -- |A 'Resource' to be run when a HEAD request comes for the

     -- resource path. If 'resHead' is Nothing, the system runs
     -- 'resGet' instead. If 'resGet' is also Nothing, the system
     -- responds \"405 Method Not Allowed\" for HEAD requests.
     , resHead             ∷ !(Maybe (Resource ()))
     -- resource path. If 'resHead' is Nothing, the system runs
     -- 'resGet' instead. If 'resGet' is also Nothing, the system
     -- responds \"405 Method Not Allowed\" for HEAD requests.
     , resHead             ∷ !(Maybe (Resource ()))

-    -- | A 'Resource' to be run when a POST request comes for the
+    -- |A 'Resource' to be run when a POST request comes for the

     -- resource path. If 'resPost' is Nothing, the system responds
     -- \"405 Method Not Allowed\" for POST requests.
     , resPost             ∷ !(Maybe (Resource ()))
     -- resource path. If 'resPost' is Nothing, the system responds
     -- \"405 Method Not Allowed\" for POST requests.
     , resPost             ∷ !(Maybe (Resource ()))

-    -- | A 'Resource' to be run when a PUT request comes for the
+    -- |A 'Resource' to be run when a PUT request comes for the

     -- resource path. If 'resPut' is Nothing, the system responds
     -- \"405 Method Not Allowed\" for PUT requests.
     , resPut              ∷ !(Maybe (Resource ()))
     -- resource path. If 'resPut' is Nothing, the system responds
     -- \"405 Method Not Allowed\" for PUT requests.
     , resPut              ∷ !(Maybe (Resource ()))

-    -- | A 'Resource' to be run when a DELETE request comes for the
+    -- |A 'Resource' to be run when a DELETE request comes for the

     -- resource path. If 'resDelete' is Nothing, the system responds
     -- \"405 Method Not Allowed\" for DELETE requests.
     , resDelete           ∷ !(Maybe (Resource ()))
     -- resource path. If 'resDelete' is Nothing, the system responds
     -- \"405 Method Not Allowed\" for DELETE requests.
     , resDelete           ∷ !(Maybe (Resource ()))


@@ -186,12 +194,11 @@ spawnResource (ResourceDef {..}) itr@(Interaction {..})
       processException ∷ SomeException → IO ()
       processException exc
           = do let abo = toAbortion exc
       processException ∷ SomeException → IO ()
       processException exc
           = do let abo = toAbortion exc

-               -- まだ DecidingHeader 以前の状態だったら、この途中終了
-               -- を應答に反映させる餘地がある。さうでなければ stderr
-               -- にでも吐くしか無い。

                state ← atomically $ readTVar itrState
                res   ← atomically $ readTVar itrResponse
                if state ≤ DecidingHeader then
                state ← atomically $ readTVar itrState
                res   ← atomically $ readTVar itrResponse
                if state ≤ DecidingHeader then

+                   -- We still have a chance to reflect this abortion
+                   -- in the response. Hooray!

                    flip runResource itr $
                        do setStatus $ aboStatus abo
                           setHeader "Content-Type" defaultPageContentType
                    flip runResource itr $
                        do setStatus $ aboStatus abo
                           setHeader "Content-Type" defaultPageContentType


@@ -207,30 +214,108 @@ dumpAbortion ∷ Abortion → IO ()
 dumpAbortion abo
     = hPutStr stderr
       $ concat [ "Lucu: an exception occured after "
 dumpAbortion abo
     = hPutStr stderr
       $ concat [ "Lucu: an exception occured after "

-               , "sending response header to the client:\n"
+               , "sending the response header to the client:\n"

                , "  ", show abo, "\n"
                ]
 
 getInteraction ∷ Resource Interaction
 getInteraction = Resource ask
 
                , "  ", show abo, "\n"
                ]
 
 getInteraction ∷ Resource Interaction
 getInteraction = Resource ask
 

--- |Get the 'Request' value which represents the request header. In
--- general you don't have to use this action.
+-- |Get the 'Config' value for this httpd.
+getConfig ∷ Resource Config
+getConfig = itrConfig <$> getInteraction
+
+-- |Get the 'SockAddr' of the remote host.
+getRemoteAddr ∷ Resource SockAddr
+getRemoteAddr = itrRemoteAddr <$> getInteraction
+
+-- | Return the X.509 certificate of the client, or 'Nothing' if:
+--
+--   * This request didn't came through an SSL stream.
+--
+--   * The client didn't send us its certificate.
+--
+--   * The 'OpenSSL.Session.VerificationMode' of
+--   'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
+--   'OpenSSL.Session.VerifyPeer'.
+getRemoteCertificate ∷ Resource (Maybe X509)
+getRemoteCertificate = itrRemoteCert <$> getInteraction
+
+-- |Return the 'Request' value representing the request header. You
+-- usually don't need to call this function directly.

 getRequest ∷ Resource Request
 getRequest = (fromJust ∘ itrRequest) <$> getInteraction
 
 getRequest ∷ Resource Request
 getRequest = (fromJust ∘ itrRequest) <$> getInteraction
 

--- | Set the response status code. If you don't call this function,
+-- |Get the path of this 'Resource' (to be exact, 'ResourceDef') in
+-- the 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
+-- action is the exact path in the tree even when the 'ResourceDef' is
+-- greedy.
+--
+-- Example:
+--
+-- > main = let tree = mkResTree [ (["foo"], resFoo) ]
+-- >        in runHttpd defaultConfig tree []
+-- >
+-- > resFoo = ResourceDef {
+-- >     resIsGreedy = True
+-- >   , resGet = Just $ do requestURI   <- getRequestURI
+-- >                        resourcePath <- getResourcePath
+-- >                        pathInfo     <- getPathInfo
+-- >                        -- uriPath requestURI == "/foo/bar/baz"
+-- >                        -- resourcePath       == ["foo"]
+-- >                        -- pathInfo           == ["bar", "baz"]
+-- >                        ...
+-- >   , ...
+-- >   }
+getResourcePath ∷ Resource [Text]
+getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction
+
+-- |@'getChunk' n@ attempts to read a chunk of request body up to @n@
+-- bytes. You can incrementally read the request body by repeatedly
+-- calling this function. If there is nothing to be read anymore,
+-- 'getChunk' returns 'Strict.empty' and makes 'Resource' transit to
+-- the /Deciding Header/ state.
+getChunk ∷ Int → Resource Strict.ByteString
+getChunk = (driftTo ReceivingBody *>) ∘ getChunk'
+
+getChunk' ∷ Int → Resource Strict.ByteString
+getChunk' n
+    | n < 0     = fail ("getChunk: n must not be negative: " ⧺ show n)
+    | n ≡ 0     = return (∅)
+    | otherwise = do req ← getRequest
+                     if reqMustHaveBody req then
+                         do itr ← getInteraction
+                            askForInput itr
+                     else
+                         driftTo DecidingHeader *> return (∅)
+    where
+      askForInput ∷ Interaction → Resource Strict.ByteString
+      askForInput (Interaction {..})
+          = do -- Ask the RequestReader to get a chunk.
+               liftIO $ atomically
+                      $ putTMVar itrReceiveBodyReq (ReceiveBody n)
+               -- Then wait for a reply.
+               chunk ← liftIO
+                       $ atomically
+                       $ takeTMVar itrReceivedBody
+               -- Have we got an EOF?
+               when (Strict.null chunk)
+                   $ driftTo DecidingHeader
+               return chunk
+
+-- |Declare the response status code. If you don't call this function,

 -- the status code will be defaulted to \"200 OK\".
 setStatus ∷ StatusCode → Resource ()
 setStatus sc
 -- the status code will be defaulted to \"200 OK\".
 setStatus ∷ StatusCode → Resource ()
 setStatus sc

-    = do driftTo DecidingHeader
-         itr ← getInteraction
-         liftIO
-             $ atomically
-             $ setResponseStatus itr sc
-
--- | @'setHeader' name value@ sets the value of the response header
--- @name@ to @value@. Note that this function is not intended to be
+    = do itr ← getInteraction
+         liftIO $ atomically
+                $ do state ← readTVar $ itrState itr
+                     when (state > DecidingHeader)
+                         $ fail "Too late to declare the response status."
+                     setResponseStatus itr sc
+
+-- |@'setHeader' name value@ declares the value of the response header
+-- @name@ as @value@. Note that this function is not intended to be

 -- used so frequently: there should be specialised functions like
 -- 'setContentType' for every common headers.
 --
 -- used so frequently: there should be specialised functions like
 -- 'setContentType' for every common headers.
 --


@@ -246,45 +331,44 @@ setStatus sc
 -- of the next response.
 setHeader ∷ CIAscii → Ascii → Resource ()
 setHeader name value
 -- 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 itr ← getInteraction
          liftIO $ atomically

-                $ do res ← readTVar $ itrResponse itr
+                $ do state ← readTVar $ itrState itr
+                     when (state > DecidingHeader)
+                         $ fail "Too late to declare a response header field."
+                     res ← readTVar $ itrResponse itr

                      let res' = H.setHeader name value res
                      writeTVar (itrResponse itr) res'
                      when (name ≡ "Content-Type")
                          $ writeTVar (itrResponseHasCType itr) True
 
                      let res' = H.setHeader name value res
                      writeTVar (itrResponse itr) res'
                      when (name ≡ "Content-Type")
                          $ writeTVar (itrResponseHasCType itr) True
 

--- | @'deleteHeader' name@ deletes a response header @name@ if
+-- |@'deleteHeader' name@ deletes a response header @name@ if

 -- any. This function is not intended to be used so frequently.
 deleteHeader ∷ CIAscii → Resource ()
 deleteHeader name
 -- any. This function is not intended to be used so frequently.
 deleteHeader ∷ CIAscii → Resource ()
 deleteHeader name

-    = driftTo DecidingHeader *> deleteHeader' name
-
-deleteHeader' ∷ CIAscii → Resource ()
-deleteHeader' name

     = do itr ← getInteraction
          liftIO $ atomically
     = do itr ← getInteraction
          liftIO $ atomically

-                $ do res ← readTVar $ itrResponse itr
+                $ do state ← readTVar $ itrState itr
+                     when (state > DecidingHeader)
+                         $ fail "Too late to delete a response header field."
+                     res ← readTVar $ itrResponse itr

                      let res' = H.deleteHeader name res
                      writeTVar (itrResponse itr) res'
                      when (name ≡ "Content-Type")
                          $ writeTVar (itrResponseHasCType itr) False
 
                      let res' = H.deleteHeader name res
                      writeTVar (itrResponse itr) res'
                      when (name ≡ "Content-Type")
                          $ writeTVar (itrResponseHasCType itr) False
 

--- | Run a 'Builder' to construct a chunk, and write it to the
--- response body. It is safe to apply this function to a 'Builder'
--- producing an infinitely long stream of octets.
+-- |Run a 'Builder' to construct a chunk, and write it to the response
+-- body. It is safe to apply this function to a 'Builder' producing an
+-- infinitely long stream of octets.

 --
 --

--- Note that you must first set the response header \"Content-Type\"
--- before applying this function. See: 'setContentType'
+-- Note that you must first declare the response header
+-- \"Content-Type\" before applying this function. See
+-- 'setContentType'.

 putBuilder ∷ Builder → Resource ()
 putBuilder b
     = do itr ← getInteraction
          liftIO $ atomically
 putBuilder ∷ Builder → Resource ()
 putBuilder b
     = do itr ← getInteraction
          liftIO $ atomically

-                $ do driftTo' itr DecidingBody
+                $ do driftTo' itr SendingBody

                      hasCType ← readTVar $ itrResponseHasCType itr
                      unless hasCType
                          $ abortSTM InternalServerError []
                      hasCType ← readTVar $ itrResponseHasCType itr
                      unless hasCType
                          $ abortSTM InternalServerError []


@@ -299,25 +383,29 @@ driftTo newState
 driftTo' ∷ Interaction → InteractionState → STM ()
 driftTo' itr@(Interaction {..}) newState
     = do oldState ← readTVar itrState
 driftTo' ∷ Interaction → InteractionState → STM ()
 driftTo' itr@(Interaction {..}) newState
     = do oldState ← readTVar itrState

-         if newState < oldState then
-             throwStateError oldState newState
-         else
-             do let a = [oldState .. newState]
-                    b = tail a
-                    c = zip a b
-                mapM_ (uncurry drift) c
-                writeTVar itrState newState
+         driftFrom oldState

     where
     where

+      driftFrom ∷ InteractionState → STM ()
+      driftFrom oldState
+          | newState < oldState = throwStateError oldState newState
+          | newState ≡ oldState = return ()
+          | otherwise
+              = do let a = [oldState .. newState]
+                       b = tail a
+                       c = zip a b
+                   mapM_ (uncurry driftFromTo) c
+                   writeTVar itrState newState
+

       throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
       throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a

-      throwStateError Done DecidingBody
+      throwStateError Done SendingBody

           = fail "It makes no sense to output something after finishing outputs."
       throwStateError old new
           = fail "It makes no sense to output something after finishing outputs."
       throwStateError old new

-          = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new)
+          = fail ("State error: " ⧺ show old ⧺ " ==> " ⧺ show new)

 
 

-      drift ∷ InteractionState → InteractionState → STM ()
-      drift GettingBody _
-          = putTMVar itrGetBodyRequest WasteAll
-      drift DecidingHeader _
+      driftFromTo ∷ InteractionState → InteractionState → STM ()
+      driftFromTo ReceivingBody _
+          = putTMVar itrReceiveBodyReq WasteAll
+      driftFromTo DecidingHeader _

           = postprocess itr
           = postprocess itr

-      drift _ _
+      driftFromTo _ _

           = return ()
           = return ()

diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
index 1106f14e14dcf06111e8abb872b2bfe5905083db..d13dd84e02d9a12b2f3ab3a8196cf29ec6dcf4e0 100644 (file)
--- a/Network/HTTP/Lucu/ResponseWriter.hs
+++ b/Network/HTTP/Lucu/ResponseWriter.hs
@@ -98,10 +98,10 @@ awaitSomethingToWriteOn ctx itr phase
     = join $
       atomically $
       do state ← readTVar $ itrState itr
     = join $
       atomically $
       do state ← readTVar $ itrState itr

-         if state ≡ GettingBody then
+         if state ≡ ReceivingBody then

              writeContinueIfNeeded ctx itr phase
          else
              writeContinueIfNeeded ctx itr phase
          else

-             if state ≥ DecidingBody then
+             if state ≥ SendingBody then

                  writeHeaderOrBodyIfNeeded ctx itr phase
              else
                  retry
                  writeHeaderOrBodyIfNeeded ctx itr phase
              else
                  retry


@@ -113,7 +113,7 @@ writeContinueIfNeeded ∷ HandleLike h
                       → STM (IO ())
 writeContinueIfNeeded ctx itr@(Interaction {..}) phase
     | phase ≡ Initial ∧ itrExpectedContinue ≡ Just True
                       → STM (IO ())
 writeContinueIfNeeded ctx itr@(Interaction {..}) phase
     | phase ≡ Initial ∧ itrExpectedContinue ≡ Just True

-        = do isRequested ← isEmptyTMVar itrGetBodyRequest
+        = do isRequested ← isEmptyTMVar itrReceiveBodyReq

              if isRequested then
                  return $ writeContinue ctx itr
              else
              if isRequested then
                  return $ writeContinue ctx itr
              else