]> gitweb @ CieloNegro.org - Lucu.git/commitdiff
Many many changes
authorPHO <pho@cielonegro.org>
Wed, 19 Oct 2011 14:28:25 +0000 (23:28 +0900)
committerPHO <pho@cielonegro.org>
Wed, 19 Oct 2011 14:28:25 +0000 (23:28 +0900)
Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa

Lucu.cabal
Network/HTTP/Lucu/Abortion.hs
Network/HTTP/Lucu/Config.hs
Network/HTTP/Lucu/DefaultPage.hs
Network/HTTP/Lucu/Interaction.hs
Network/HTTP/Lucu/Postprocess.hs
Network/HTTP/Lucu/Resource.hs
Network/HTTP/Lucu/Resource/Internal.hs [new file with mode: 0644]
Network/HTTP/Lucu/Resource/Tree.hs
Network/HTTP/Lucu/ResponseWriter.hs

index 93731338a7862b4de989ddd316c28462b22f49c2..95d20953bda37c38a4d4b85d49e46e77b9c46dd3 100644 (file)
@@ -67,8 +67,8 @@ Library
         text-icu                   == 0.6.*,
         time                       == 1.2.*,
         time-http                  == 0.2.*,
-        unix                       == 2.4.*,
-        zlib                       == 0.5.*
+        transformers               == 0.2.*,
+        unix                       == 2.4.*
 
     Exposed-Modules:
         Network.HTTP.Lucu
@@ -101,6 +101,7 @@ Library
         Network.HTTP.Lucu.Postprocess
         Network.HTTP.Lucu.Preprocess
         Network.HTTP.Lucu.RequestReader
+        Network.HTTP.Lucu.Resource.Internal
         Network.HTTP.Lucu.ResponseWriter
         Network.HTTP.Lucu.SocketLike
 
@@ -116,7 +117,8 @@ Executable lucu-implant-file
     Main-Is: ImplantFile.hs
 
     Build-Depends:
-        SHA == 1.5.*
+        SHA  == 1.5.*,
+        zlib == 0.5.*
 
     ghc-options:
         -Wall
index 0099576e62e04c631ae00a528ea0c55cb02eb6c5..6c2d14dd8c9e00cb09923df93b2097975d736ac7 100644 (file)
@@ -17,6 +17,8 @@ module Network.HTTP.Lucu.Abortion
     , abortPage
     )
     where
+import Blaze.ByteString.Builder (Builder)
+import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
 import Control.Arrow.ArrowIO
 import Control.Arrow.ListArrow
 import Control.Arrow.Unicode
@@ -26,7 +28,6 @@ import Control.Monad.Trans
 import Data.Ascii (Ascii, CIAscii)
 import Data.Text (Text)
 import qualified Data.Text as T
-import qualified Data.Text.Lazy as Lazy
 import Data.Typeable
 import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.DefaultPage
@@ -50,9 +51,8 @@ instance Exception Abortion
 -- 'Network.HTTP.Lucu.Resource.Resource' monad with given status,
 -- additional response headers, and optional message string.
 --
--- What this really does is to throw a special
--- 'Control.Exception.Exception'. The exception will be caught by the
--- Lucu system.
+-- What this really does is to throw an instance of 'Exception'. The
+-- exception will be caught by the Lucu system.
 --
 -- 1. If the 'Network.HTTP.Lucu.Resource.Resource' is in the /Deciding
 --    Header/ or any precedent states, it is possible to use the
@@ -61,11 +61,11 @@ instance Exception Abortion
 --
 -- 2. Otherwise the HTTP response can't be modified anymore so the
 --    only possible thing the system can do is to dump it to the
---    stderr. See
---    'Network.HTTP.Lucu.Config.cnfDumpTooLateAbortionToStderr'.
+--    stderr. See 'cnfDumpTooLateAbortionToStderr'.
 --
--- Note that the status code doesn't have to be an error code so you
--- can use this action for redirection as well as error reporting e.g.
+-- Note that the status code doesn't necessarily have to be an error
+-- code so you can use this action for redirection as well as error
+-- reporting e.g.
 --
 -- > abort MovedPermanently
 -- >       [("Location", "http://example.net/")]
@@ -99,7 +99,7 @@ abortA = proc (status, (headers, msg)) →
 -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
 -- ければならない。
-abortPage ∷ Config → Maybe Request → Response → Abortion → Lazy.Text
+abortPage ∷ Config → Maybe Request → Response → Abortion → Builder
 abortPage conf reqM res abo
     = case aboMessage abo of
         Just msg
@@ -108,7 +108,7 @@ abortPage conf reqM res abo
                                    writeDocumentToString [ withIndent True ]
                                  ) ()
               in
-                Lazy.pack html
+                BB.fromString html
         Nothing
             → let res'  = res { resStatus = aboStatus abo }
                   res'' = foldl (∘) id [setHeader name value
index 47279806117e7b72ef3b095925eb195e4ce66dc4..cdeef3b435305ae8e76a5630f07d5fb8f884c162 100644 (file)
@@ -56,9 +56,9 @@ data Config = Config {
     , cnfMaxPipelineDepth ∷ !Int
 
     -- |The maximum length of request entity to accept in bytes. Note
-    -- that this is nothing but the default value which is used when
-    -- 'Network.HTTP.Lucu.Resource.input' and such like are applied to
-    -- 'Network.HTTP.Lucu.Resource.defaultLimit', so there is no
+    -- that this is nothing but a default value which is used when
+    -- 'Network.HTTP.Lucu.Resource.getForm' and such like are applied
+    -- to 'Network.HTTP.Lucu.Resource.defaultLimit', so there is no
     -- guarantee that this value always constrains all the requests.
     , cnfMaxEntityLength ∷ !Int
 
index 70d4a6a278b29c6aa6f3e70ba31b3d2920565e1f..19a72936e2718608034e22c15885fb9ea2fbe747 100644 (file)
@@ -8,6 +8,8 @@ module Network.HTTP.Lucu.DefaultPage
     , mkDefaultPage
     )
     where
+import Blaze.ByteString.Builder (Builder)
+import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
 import Control.Arrow
 import Control.Arrow.ArrowList
 import Control.Arrow.ListArrow
@@ -16,7 +18,6 @@ import Data.Ascii (Ascii)
 import qualified Data.Ascii as A
 import Data.Maybe
 import qualified Data.Text as T
-import qualified Data.Text.Lazy as Lazy
 import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.Headers
 import Network.HTTP.Lucu.Request
@@ -28,7 +29,7 @@ import Text.XML.HXT.Arrow.XmlArrow
 import Text.XML.HXT.Arrow.XmlState
 import Text.XML.HXT.DOM.TypeDefs
 
-getDefaultPage ∷ Config → Maybe Request → Response → Lazy.Text
+getDefaultPage ∷ Config → Maybe Request → Response → Builder
 {-# INLINEABLE getDefaultPage #-}
 getDefaultPage conf req res
     = let msgA     = getMsg req res
@@ -37,7 +38,7 @@ getDefaultPage conf req res
                              writeDocumentToString [ withIndent True ]
                            ) ()
       in
-        Lazy.pack xmlStr
+        BB.fromString xmlStr
 
 defaultPageContentType ∷ Ascii
 {-# INLINE defaultPageContentType #-}
index 4ac7c093607729fe8784acc3f8e914c96fed1b66..4d153d14e579df2a5d8bc9e410b0e53054f8db0e 100644 (file)
@@ -7,6 +7,7 @@ module Network.HTTP.Lucu.Interaction
     ( Interaction(..)
     , InteractionState(..)
     , InteractionQueue
+    , GetBodyRequest(..)
     , newInteractionQueue
     , newInteraction
 
@@ -15,7 +16,7 @@ module Network.HTTP.Lucu.Interaction
     where
 import Blaze.ByteString.Builder (Builder)
 import Control.Concurrent.STM
-import qualified Data.ByteString as BS
+import qualified Data.ByteString as Strict
 import Data.Monoid.Unicode
 import Data.Sequence (Seq)
 import qualified Data.Sequence as S
@@ -39,11 +40,8 @@ data Interaction = Interaction {
     , itrExpectedContinue  ∷ !(Maybe Bool)
     , itrReqBodyLength     ∷ !(Maybe RequestBodyLength)
 
-    , itrReqBodyWanted     ∷ !(TVar Int)
-    , itrReqBodyWasteAll   ∷ !(TVar Bool)
-    , itrReqChunkIsOver    ∷ !(TVar Bool)
-    , itrReceivedBody      ∷ !(TVar (Seq BS.ByteString))
-    , itrReceivedBodyLen   ∷ !(TVar Int)
+    , itrGetBodyRequest    ∷ !(TMVar GetBodyRequest)
+    , itrGotBody           ∷ !(TMVar Strict.ByteString)
 
     , itrResponse          ∷ !(TVar Response)
     , itrWillChunkBody     ∷ !(TVar Bool)
@@ -57,15 +55,21 @@ data Interaction = Interaction {
 
 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
 -- initial state.
-data InteractionState = ExaminingRequest
-                      | GettingBody
-                      | DecidingHeader
-                      | DecidingBody
-                      | Done
-                        deriving (Show, Eq, Ord, Enum)
+data InteractionState
+    = ExaminingRequest
+    | GettingBody
+    | DecidingHeader
+    | DecidingBody
+    | Done
+    deriving (Show, Eq, Ord, Enum)
 
 type InteractionQueue = TVar (Seq Interaction)
 
+data GetBodyRequest
+    = GetBody !Int -- ^ Maximum number of bytes.
+    | WasteAll
+    deriving (Show, Eq)
+
 newInteractionQueue ∷ IO InteractionQueue
 newInteractionQueue = newTVarIO S.empty
 
@@ -83,11 +87,8 @@ newInteraction conf@(Config {..}) port addr cert request
                    , resHeaders = (∅)
                    }
 
-         reqBodyWanted   ← newTVarIO 0
-         reqBodyWasteAll ← newTVarIO False
-         reqChunkIsOver  ← newTVarIO False
-         receivedBody    ← newTVarIO S.empty
-         receivedBodyLen ← newTVarIO 0
+         getBodyRequest   ← newEmptyTMVarIO
+         gotBody          ← newEmptyTMVarIO
 
          response         ← newTVarIO res
          willChunkBody    ← newTVarIO False
@@ -99,21 +100,18 @@ newInteraction conf@(Config {..}) port addr cert request
          state            ← newTVarIO ExaminingRequest
 
          return Interaction {
-                      itrConfig       = conf
-                    , itrLocalPort    = port
-                    , itrRemoteAddr   = addr
-                    , itrRemoteCert   = cert
-                    , itrResourcePath = Nothing
-                    , itrRequest      = arRequest ar
+                      itrConfig           = conf
+                    , itrLocalPort        = port
+                    , itrRemoteAddr       = addr
+                    , itrRemoteCert       = cert
+                    , itrResourcePath     = Nothing
+                    , itrRequest          = arRequest ar
 
                     , itrExpectedContinue = arExpectedContinue ar
                     , itrReqBodyLength    = arReqBodyLength    ar
 
-                    , itrReqBodyWanted    = reqBodyWanted
-                    , itrReqBodyWasteAll  = reqBodyWasteAll
-                    , itrReqChunkIsOver   = reqChunkIsOver
-                    , itrReceivedBody     = receivedBody
-                    , itrReceivedBodyLen  = receivedBodyLen
+                    , itrGetBodyRequest   = getBodyRequest
+                    , itrGotBody          = gotBody
 
                     , itrResponse         = response
                     , itrWillChunkBody    = willChunkBody
index 39b6b4c16f24ff608c12f1c59780225682915b91..131cc8ebb3e65f7426a3bf245cc14185a1502795 100644 (file)
@@ -9,7 +9,6 @@ module Network.HTTP.Lucu.Postprocess
     , completeUnconditionalHeaders
     )
     where
-import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
 import Control.Applicative
 import Control.Concurrent.STM
 import Control.Monad
@@ -33,7 +32,6 @@ import Prelude.Unicode
 postprocess ∷ Interaction → STM ()
 postprocess itr@(Interaction {..})
     = do abortOnCertainConditions itr
-         writeDefaultPageIfNeeded itr
 
          case itrRequest of
            Just req → postprocessWithRequest itr req
@@ -115,9 +113,10 @@ writeDefaultPageIfNeeded itr@(Interaction {..})
     = do resHasCType ← readTVar itrResponseHasCType
          unless resHasCType
              $ do writeHeader itr "Content-Type" (Just defaultPageContentType)
+                  writeHeader itr "Content-Encoding" Nothing
                   res ← readTVar itrResponse
                   let page = getDefaultPage itrConfig itrRequest res
-                  putTMVar itrBodyToSend (BB.fromLazyText page)
+                  putTMVar itrBodyToSend page
 
 writeHeader ∷ Interaction → CIAscii → Maybe Ascii → STM ()
 {-# INLINE writeHeader #-}
index ddff647364a4295361379926b5affcff571a7081..696abf1b1311e55c5f13f4eca54a45ea02ea0146 100644 (file)
@@ -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
 -- 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,42 +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/.
     , putChunk
+    , putChunks
     , putBuilder
-
-    , driftTo -- private
     )
     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
@@ -172,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
@@ -180,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
@@ -230,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
@@ -778,44 +752,6 @@ defaultLimit = (-1)
 
 -- Setting response headers
 
--- | 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
-
 -- | 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.
@@ -834,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
@@ -879,56 +816,4 @@ setWWWAuthenticate challenge
 -- Note that you must first set the response header \"Content-Type\"
 -- before applying this function. See: 'setContentType'
 putChunk ∷ Lazy.ByteString → Resource ()
-{-# INLINE putChunk #-}
 putChunk = putBuilder ∘ BB.fromLazyByteString
-
--- | 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'
-putBuilder ∷ Builder → Resource ()
-putBuilder b
-    = do itr ← getInteraction
-         liftIO $ atomically
-                $ do driftTo' itr DecidingBody
-                     hasCType ← readTVar $ itrResponseHasCType itr
-                     unless hasCType
-                         $ abortSTM InternalServerError []
-                         $ Just "putBuilder: Content-Type has not been set."
-                     putTMVar (itrBodyToSend itr) b
-
-
--- Private
-
-driftTo ∷ InteractionState → Resource ()
-driftTo newState
-    = do itr ← getInteraction
-         liftIO $ atomically $ driftTo' itr newState
-
-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
-    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 ∷ InteractionState → InteractionState → STM ()
-      drift GettingBody _
-          = writeTVar itrReqBodyWasteAll True
-      drift DecidingHeader _
-          = postprocess itr
-      drift _ _
-          = return ()
diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs
new file mode 100644 (file)
index 0000000..d68b334
--- /dev/null
@@ -0,0 +1,323 @@
+{-# LANGUAGE
+    DoAndIfThenElse
+  , GeneralizedNewtypeDeriving
+  , OverloadedStrings
+  , RecordWildCards
+  , UnicodeSyntax
+  #-}
+module Network.HTTP.Lucu.Resource.Internal
+    ( Resource
+    , ResourceDef(..)
+    , emptyResource
+    , spawnResource
+
+    , getInteraction
+    , getRequest
+
+    , setStatus
+    , setHeader
+    , setHeader'
+    , deleteHeader
+
+    , putBuilder
+
+    , driftTo
+    )
+    where
+import Blaze.ByteString.Builder (Builder)
+import Control.Applicative
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad.IO.Class
+import Control.Monad.Reader
+import Data.Ascii (Ascii, CIAscii)
+import qualified Data.Ascii as A
+import Data.List
+import Data.Maybe
+import Data.Monoid.Unicode
+import qualified Data.Text as T
+import Network.HTTP.Lucu.Abortion
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.DefaultPage
+import qualified Network.HTTP.Lucu.Headers as H
+import Network.HTTP.Lucu.Interaction
+import Network.HTTP.Lucu.Postprocess
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.Utils
+import Prelude hiding (catch)
+import Prelude.Unicode
+import System.IO
+
+-- |The 'Resource' monad. This monad implements 'MonadIO' so it can do
+-- any 'IO' actions.
+newtype Resource a
+    = Resource {
+        unResource ∷ ReaderT Interaction IO a
+      }
+    deriving (Applicative, Functor, Monad, MonadIO)
+
+runResource ∷ Resource a → Interaction → IO a
+runResource = runReaderT ∘ unResource
+
+-- | '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
+    -- 'forkOS') or to run it on a user thread (spanwed by
+    -- 'forkIO'). Generally you don't need to set this field to
+    -- 'True'.
+      resUsesNativeThread ∷ !Bool
+    -- | Whether to be greedy or not.
+    --
+    -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
+    -- greedy resource at \/aaa\/bbb, it is always chosen even if
+    -- there is another resource at \/aaa\/bbb\/ccc. If the resource
+    -- 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
+    -- resource path. If 'resGet' is Nothing, the system responds
+    -- \"405 Method Not Allowed\" for GET requests.
+    --
+    -- It also runs for HEAD request if the 'resHead' is Nothing. In
+    -- 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
+    -- 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
+    -- 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
+    -- 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
+    -- resource path. If 'resDelete' is Nothing, the system responds
+    -- \"405 Method Not Allowed\" for DELETE requests.
+    , resDelete           ∷ !(Maybe (Resource ()))
+    }
+
+-- |'emptyResource' is a resource definition with no actual
+-- handlers. You can construct a 'ResourceDef' by selectively
+-- overriding 'emptyResource'. It is defined as follows:
+--
+-- @
+--   emptyResource = ResourceDef {
+--                     resUsesNativeThread = False
+--                   , resIsGreedy         = False
+--                   , resGet              = Nothing
+--                   , resHead             = Nothing
+--                   , resPost             = Nothing
+--                   , resPut              = Nothing
+--                   , resDelete           = Nothing
+--                   }
+-- @
+emptyResource ∷ ResourceDef
+emptyResource = ResourceDef {
+                  resUsesNativeThread = False
+                , resIsGreedy         = False
+                , resGet              = Nothing
+                , resHead             = Nothing
+                , resPost             = Nothing
+                , resPut              = Nothing
+                , resDelete           = Nothing
+                }
+
+spawnResource ∷ ResourceDef → Interaction → IO ThreadId
+spawnResource (ResourceDef {..}) itr@(Interaction {..})
+    = fork $ run `catch` processException
+    where
+      fork ∷ IO () → IO ThreadId
+      fork | resUsesNativeThread = forkOS
+           | otherwise           = forkIO
+
+      run ∷ IO ()
+      run = flip runResource itr $
+            do req ← getRequest
+               fromMaybe notAllowed $ rsrc req
+               driftTo Done
+
+      rsrc ∷ Request → Maybe (Resource ())
+      rsrc req
+          = case reqMethod req of
+              GET    → resGet
+              HEAD   → case resHead of
+                          Just r  → Just r
+                          Nothing → resGet
+              POST   → resPost
+              PUT    → resPut
+              DELETE → resDelete
+              _      → error $ "Unknown request method: " ⧺ show (reqMethod req)
+
+      notAllowed ∷ Resource ()
+      notAllowed
+          = setStatus MethodNotAllowed
+            *>
+            (setHeader "Allow" $ A.fromAsciiBuilder
+                               $ joinWith ", "
+                               $ map A.toAsciiBuilder allowedMethods)
+
+      allowedMethods ∷ [Ascii]
+      allowedMethods = nub $ concat [ methods resGet    ["GET"]
+                                    , methods resHead   ["GET", "HEAD"]
+                                    , methods resPost   ["POST"]
+                                    , methods resPut    ["PUT"]
+                                    , methods resDelete ["DELETE"]
+                                    ]
+
+      methods ∷ Maybe a → [Ascii] → [Ascii]
+      methods m xs
+          | isJust m  = xs
+          | otherwise = []
+
+      toAbortion ∷ SomeException → Abortion
+      toAbortion e
+          = case fromException e of
+              Just abortion → abortion
+              Nothing       → Abortion InternalServerError (∅) (Just $ T.pack $ show e)
+
+      processException ∷ SomeException → IO ()
+      processException exc
+          = do let abo = toAbortion exc
+               -- まだ DecidingHeader 以前の状態だったら、この途中終了
+               -- を應答に反映させる餘地がある。さうでなければ stderr
+               -- にでも吐くしか無い。
+               state ← atomically $ readTVar itrState
+               res   ← atomically $ readTVar itrResponse
+               if state ≤ DecidingHeader then
+                   flip runResource itr $
+                       do setStatus $ aboStatus abo
+                          setHeader "Content-Type" defaultPageContentType
+                          deleteHeader "Content-Encoding"
+                          mapM_ (uncurry setHeader) $ H.fromHeaders $ aboHeaders abo
+                          putBuilder $ abortPage itrConfig itrRequest res abo
+               else
+                   when (cnfDumpTooLateAbortionToStderr itrConfig)
+                       $ dumpAbortion abo
+               runResource (driftTo Done) itr
+
+dumpAbortion ∷ Abortion → IO ()
+dumpAbortion abo
+    = hPutStr stderr
+      $ concat [ "Lucu: an exception occured after "
+               , "sending response header to the client:\n"
+               , "  ", 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.
+getRequest ∷ Resource Request
+getRequest = (fromJust ∘ itrRequest) <$> getInteraction
+
+-- | Set 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
+    = 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
+-- used so frequently: there should be specialised functions 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 manipulation it will be a
+-- catastrophe when we send a header \"Content-Length: 10\" and
+-- actually send a body of 20 bytes long to the remote peer. 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 the 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
+
+-- | @'deleteHeader' name@ deletes a response header @name@ if
+-- 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 res ← readTVar $ itrResponse itr
+                     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.
+--
+-- Note that you must first set the response header \"Content-Type\"
+-- before applying this function. See: 'setContentType'
+putBuilder ∷ Builder → Resource ()
+putBuilder b
+    = do itr ← getInteraction
+         liftIO $ atomically
+                $ do driftTo' itr DecidingBody
+                     hasCType ← readTVar $ itrResponseHasCType itr
+                     unless hasCType
+                         $ abortSTM InternalServerError []
+                         $ Just "putBuilder: Content-Type has not been set."
+                     putTMVar (itrBodyToSend itr) b
+
+driftTo ∷ InteractionState → Resource ()
+driftTo newState
+    = do itr ← getInteraction
+         liftIO $ atomically $ driftTo' itr newState
+
+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
+    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 ∷ InteractionState → InteractionState → STM ()
+      drift GettingBody _
+          = putTMVar itrGetBodyRequest WasteAll
+      drift DecidingHeader _
+          = postprocess itr
+      drift _ _
+          = return ()
index 17827d12369d4eb950220ff48be0dd0cbde6d8ba..9ab6f663254f9cf8c5e28e183ba2ccaddf7cdd25 100644 (file)
@@ -7,16 +7,11 @@
 
 -- | Repository of the resources in httpd.
 module Network.HTTP.Lucu.Resource.Tree
-    ( ResourceDef(..)
-    , emptyResource
-
-    , ResTree
+    ( ResTree
     , FallbackHandler
 
     , mkResTree
-
     , findResource
-    , runResource
     )
     where
 import Control.Arrow
@@ -29,7 +24,6 @@ import Control.Exception
 import Control.Monad
 import Data.Text (Text)
 import qualified Data.Text as T
-import qualified Data.Text.Lazy.Encoding as LT
 import Data.List
 import qualified Data.Map as M
 import Data.Map (Map)
@@ -49,7 +43,6 @@ import System.IO
 import Prelude hiding (catch)
 import Prelude.Unicode
 
-
 -- |'FallbackHandler' is an extra resource handler for resources which
 -- can't be statically located anywhere in the resource tree. The Lucu
 -- httpd first searches for a resource in the tree, and then calls
@@ -57,81 +50,6 @@ import Prelude.Unicode
 -- handlers returned 'Nothing', the httpd responds with 404 Not Found.
 type FallbackHandler = [Text] → IO (Maybe ResourceDef)
 
-
--- "/aaa/bbb/ccc" にアクセスされた時、もし "/aaa/bbb" に貪欲なリソース
--- があれば、假に "/aaa/bbb/ccc" に何らかのリソースがあったとしても必ず
--- "/aaa/bbb" が撰ばれる。"/aaa/bbb" のリソースが貪欲でなければ、それは
--- 無視される。
-
--- | '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
-    -- 'forkOS') or to run it on a user thread (spanwed by
-    -- 'forkIO'). Generally you don't need to set this field to
-    -- 'True'.
-      resUsesNativeThread ∷ !Bool
-    -- | Whether to be greedy or not.
-    -- 
-    -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
-    -- greedy resource at \/aaa\/bbb, it is always chosen even if
-    -- there is another resource at \/aaa\/bbb\/ccc. If the resource
-    -- 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
-    -- resource path. If 'resGet' is Nothing, the system responds
-    -- \"405 Method Not Allowed\" for GET requests.
-    -- 
-    -- It also runs for HEAD request if the 'resHead' is Nothing. In
-    -- 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
-    -- 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
-    -- 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
-    -- 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
-    -- resource path. If 'resDelete' is Nothing, the system responds
-    -- \"405 Method Not Allowed\" for DELETE requests.
-    , resDelete           ∷ !(Maybe (Resource ()))
-    }
-
--- |'emptyResource' is a resource definition with no actual
--- handlers. You can construct a 'ResourceDef' by selectively
--- overriding 'emptyResource'. It is defined as follows:
---
--- @
---   emptyResource = ResourceDef {
---                     resUsesNativeThread = False
---                   , resIsGreedy         = False
---                   , resGet              = Nothing
---                   , resHead             = Nothing
---                   , resPost             = Nothing
---                   , resPut              = Nothing
---                   , resDelete           = Nothing
---                   }
--- @
-emptyResource ∷ ResourceDef
-emptyResource = ResourceDef {
-                  resUsesNativeThread = False
-                , resIsGreedy         = False
-                , resGet              = Nothing
-                , resHead             = Nothing
-                , resPost             = Nothing
-                , resPut              = Nothing
-                , resDelete           = Nothing
-                }
-
 -- |'ResTree' is an opaque structure which is a map from resource path
 -- to 'ResourceDef'.
 newtype ResTree = ResTree ResNode -- root だから Map ではない
@@ -227,84 +145,3 @@ findResource (ResTree (ResNode rootDefM subtree)) fbs uri
                                 case m of
                                   Just def → return $ Just ([], def)
                                   Nothing  → fallback path xs
-
-
-runResource ∷ ResourceDef → Interaction → IO ThreadId
-runResource (ResourceDef {..}) itr@(Interaction {..})
-    = fork $ run `catch` processException
-    where
-      fork ∷ IO () → IO ThreadId
-      fork | resUsesNativeThread = forkOS
-           | otherwise           = forkIO
-
-      run ∷ IO ()
-      run = flip runRes itr $
-            do req ← getRequest
-               fromMaybe notAllowed $ rsrc req
-               driftTo Done
-      
-      rsrc ∷ Request → Maybe (Resource ())
-      rsrc req
-          = case reqMethod req of
-              GET    → resGet
-              HEAD   → case resHead of
-                          Just r  → Just r
-                          Nothing → resGet
-              POST   → resPost
-              PUT    → resPut
-              DELETE → resDelete
-              _      → error $ "Unknown request method: " ⧺ show (reqMethod req)
-
-      notAllowed ∷ Resource ()
-      notAllowed
-          = setStatus MethodNotAllowed
-            *>
-            (setHeader "Allow" $ A.fromAsciiBuilder
-                               $ joinWith ", "
-                               $ map A.toAsciiBuilder allowedMethods)
-
-      allowedMethods ∷ [Ascii]
-      allowedMethods = nub $ concat [ methods resGet    ["GET"]
-                                    , methods resHead   ["GET", "HEAD"]
-                                    , methods resPost   ["POST"]
-                                    , methods resPut    ["PUT"]
-                                    , methods resDelete ["DELETE"]
-                                    ]
-
-      methods ∷ Maybe a → [Ascii] → [Ascii]
-      methods m xs
-          | isJust m  = xs
-          | otherwise = []
-
-      toAbortion ∷ SomeException → Abortion
-      toAbortion e
-          = case fromException e of
-              Just abortion → abortion
-              Nothing       → Abortion InternalServerError (∅) (Just $ T.pack $ show e)
-
-      processException ∷ SomeException → IO ()
-      processException exc
-          = do let abo = toAbortion exc
-               -- まだ DecidingHeader 以前の状態だったら、この途中終了
-               -- を應答に反映させる餘地がある。さうでなければ stderr
-               -- にでも吐くしか無い。
-               state ← atomically $ readTVar itrState
-               res   ← atomically $ readTVar itrResponse
-               if state ≤ DecidingHeader then
-                   flip runRes itr $
-                       do setStatus $ aboStatus abo
-                          setHeader "Content-Type" defaultPageContentType
-                          mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo
-                          putChunk $ LT.encodeUtf8 $ abortPage itrConfig itrRequest res abo
-               else
-                   when (cnfDumpTooLateAbortionToStderr itrConfig)
-                       $ dumpAbortion abo
-               runRes (driftTo Done) itr
-
-dumpAbortion ∷ Abortion → IO ()
-dumpAbortion abo
-    = hPutStr stderr
-      $ concat [ "Lucu: an exception occured after "
-               , "sending response header to the client:\n"
-               , "  ", show abo, "\n"
-               ]
index 587c01b695b1de62111a14ce9a70772cf467aa50..1106f14e14dcf06111e8abb872b2bfe5905083db 100644 (file)
@@ -113,8 +113,8 @@ writeContinueIfNeeded ∷ HandleLike h
                       → STM (IO ())
 writeContinueIfNeeded ctx itr@(Interaction {..}) phase
     | phase ≡ Initial ∧ itrExpectedContinue ≡ Just True
-        = do reqBodyWanted ← readTVar itrReqBodyWanted
-             if reqBodyWanted > 0 then
+        = do isRequested ← isEmptyTMVar itrGetBodyRequest
+             if isRequested then
                  return $ writeContinue ctx itr
              else
                  retry