Yet Another Huge Changes

Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa

diff --git a/Lucu.cabal b/Lucu.cabal
index c0418729ee7080e307f885f6f09ecb67a9e49425..28b9741fa4ae4f8a474f9418009e218740999214 100644 (file)
--- a/Lucu.cabal
+++ b/Lucu.cabal
@@ -1,15 +1,13 @@
 Name: Lucu
 Name: Lucu

-Synopsis: HTTP Daemonic Library
+Synopsis: Embedded HTTP Server

 Description:
 
 Description:
 

-        Lucu is an HTTP daemonic library. It can be embedded in any
-        Haskell program and runs in an independent thread.
+        Lucu is an embedded HTTP server library.

 
 

-        Lucu is not a replacement for Apache nor lighttpd. It is
-        intended to be used to build an efficient web-based RESTful
-        application. It is also intended to be run behind a
-        reverse-proxy so it doesn't have some facilities like logging,
-        client filtering or such like.
+        It's not a replacement for Apache nor lighttpd. It is intended
+        to be used to build an efficient web-based RESTful application
+        which runs behind a reverse-proxy so it doesn't have some
+        functionalities like logging, client filtering or such like.

 
 Version: 1.0
 License: PublicDomain
 
 Version: 1.0
 License: PublicDomain


@@ -66,6 +64,7 @@ Library
         mtl                        == 2.0.*,
         network                    == 2.3.*,
         stm                        == 2.2.*,
         mtl                        == 2.0.*,
         network                    == 2.3.*,
         stm                        == 2.2.*,

+        strict                     == 0.3.*,

         text                       == 0.11.*,
         text-icu                   == 0.6.*,
         time                       == 1.2.*,
         text                       == 0.11.*,
         text-icu                   == 0.6.*,
         time                       == 1.2.*,


@@ -94,6 +93,7 @@ Library
         Network.HTTP.Lucu.Utils
 
     Other-Modules:
         Network.HTTP.Lucu.Utils
 
     Other-Modules:

+        Network.HTTP.Lucu.Abortion.Internal

         Network.HTTP.Lucu.Chunk
         Network.HTTP.Lucu.ContentCoding
         Network.HTTP.Lucu.DefaultPage
         Network.HTTP.Lucu.Chunk
         Network.HTTP.Lucu.ContentCoding
         Network.HTTP.Lucu.DefaultPage

diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs
index efae41a90e499156cc2e62d8ad42b4a6db63f773..e5d92765af57bcfdf6bf91390c3990258d05b13b 100644 (file)
--- a/Network/HTTP/Lucu.hs
+++ b/Network/HTTP/Lucu.hs
@@ -1,24 +1,20 @@
--- | Lucu is an HTTP daemonic library. It can be embedded in any
--- Haskell program and runs in an independent thread.
+-- | Lucu is an embedded HTTP server library.

 --
 -- Features:
 --
 --
 -- Features:
 --

---   [/Full support of HTTP\/1.1/] Lucu supports request pipelining,
---   chunked I\/O, ETag comparison and \"100 Continue\".
---
---   [/Performance/] Lucu is carefully designed to gain a good
---   performance.
---

 --   [/Affinity for RESTafarians/] Lucu is specifically designed to be
 --   suitable for RESTful applications.
 --
 --   [/Affinity for RESTafarians/] Lucu is specifically designed to be
 --   suitable for RESTful applications.
 --

---   [/SSL connections/] Lucu can handle HTTP connections over SSL
---   layer.
+--   [/Full support of HTTP\/1.1/] Lucu supports request pipelining,
+--   chunked I\/O, ETag comparison and \"100 Continue\".
+--
+--   [/SSL connections/] Lucu can handle HTTP connections over Secure
+--   Socket Layer.

 --
 -- Lucu is not a replacement for Apache or lighttpd. It is intended to
 -- be used to build an efficient web-based RESTful application. It is
 -- also intended to be run behind a reverse-proxy so it doesn't have
 --
 -- Lucu is not a replacement for Apache or lighttpd. It is intended to
 -- be used to build an efficient web-based RESTful application. It is
 -- also intended to be run behind a reverse-proxy so it doesn't have

--- the following (otherwise essential) facilities:
+-- the following (otherwise essential) functionalities:

 --
 --   [/Logging/] Lucu doesn't write logs of any requests from any
 --   clients.
 --
 --   [/Logging/] Lucu doesn't write logs of any requests from any
 --   clients.


@@ -51,9 +47,10 @@ module Network.HTTP.Lucu
     , StatusCode(..)
 
       -- *** Abortion
     , StatusCode(..)
 
       -- *** Abortion

+    , Abortion
+    , mkAbortion
+    , mkAbortion'

     , abort
     , abort

-    , abortPurely
-    , abortA

 
       -- *** ETag
     , ETag(..)
 
       -- *** ETag
     , ETag(..)

diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs
index 62677e82baea3117f808dc541925611e6c6be2a6..40a8cb5ab0b276103a5cf9e8f4231be7d0e2e20c 100644 (file)
--- a/Network/HTTP/Lucu/Abortion.hs
+++ b/Network/HTTP/Lucu/Abortion.hs
@@ -1,116 +1,50 @@
 {-# LANGUAGE
 {-# LANGUAGE

-    Arrows
-  , DeriveDataTypeable
-  , TypeOperators
-  , UnicodeSyntax
+    UnicodeSyntax

   #-}
 -- |Aborting the computation of 'Network.HTTP.Lucu.Resource.Resource'
 -- in any 'Prelude.IO' monads or arrows.
 module Network.HTTP.Lucu.Abortion
   #-}
 -- |Aborting the computation of 'Network.HTTP.Lucu.Resource.Resource'
 -- in any 'Prelude.IO' monads or arrows.
 module Network.HTTP.Lucu.Abortion

-    ( Abortion(..)
+    ( Abortion
+    , mkAbortion
+    , mkAbortion'

 
     , abort
 
     , abort

-    , abortPurely
-    , abortSTM
-    , abortA
-    , abortPage

     )
     where
     )
     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
-import Control.Concurrent.STM

 import Control.Exception
 import Control.Monad.Trans
 import Data.Ascii (Ascii, CIAscii)
 import Control.Exception
 import Control.Monad.Trans
 import Data.Ascii (Ascii, CIAscii)

+import Data.Monoid.Unicode

 import Data.Text (Text)
 import Data.Text (Text)

-import qualified Data.Text as T
-import Data.Typeable
-import Network.HTTP.Lucu.Config
-import Network.HTTP.Lucu.DefaultPage
+import Network.HTTP.Lucu.Abortion.Internal

 import Network.HTTP.Lucu.Headers
 import Network.HTTP.Lucu.Headers

-import Network.HTTP.Lucu.Request

 import Network.HTTP.Lucu.Response
 import Prelude.Unicode
 import Network.HTTP.Lucu.Response
 import Prelude.Unicode

-import Text.XML.HXT.Arrow.WriteDocument
-import Text.XML.HXT.Arrow.XmlArrow
-import Text.XML.HXT.Arrow.XmlState

 
 

-data Abortion = Abortion {
-      aboStatus  ∷ !StatusCode
-    , aboHeaders ∷ !Headers
-    , aboMessage ∷ !(Maybe Text)
-    } deriving (Eq, Show, Typeable)
-
-instance Exception Abortion
-
--- |Computation of @'abort' status headers msg@ aborts the
--- 'Network.HTTP.Lucu.Resource.Resource' monad with given status,
--- additional response headers, and optional message string.
---
--- 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
---    @status@ and such like as a HTTP response to be sent to the
---    client.
---
--- 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 'cnfDumpTooLateAbortionToStderr'.
---
--- 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/")]
--- >       (Just "It has been moved to example.net")
-abort ∷ MonadIO m ⇒ StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → m a
+-- |Construct an 'Abortion' with additional headers and an optional
+-- message text.
+mkAbortion ∷ StatusCode → [(CIAscii, Ascii)] → Maybe Text → Abortion
+{-# INLINE mkAbortion #-}
+mkAbortion sc hdr msg
+    = Abortion {
+        aboStatus  = sc
+      , aboHeaders = toHeaders hdr
+      , aboMessage = msg
+      }
+
+-- |Construct an 'Abortion' without any additional headers but with a
+-- message text.
+mkAbortion' ∷ StatusCode → Text → Abortion
+{-# INLINE mkAbortion' #-}
+mkAbortion' sc msg
+    = Abortion {
+        aboStatus  = sc
+      , aboHeaders = (∅)
+      , aboMessage = Just msg
+      }
+
+-- |Throw an 'Abortion' in a 'MonadIO', including the very
+-- 'Network.HTTP.Lucu.Resource.Resource' monad.
+abort ∷ MonadIO m ⇒ Abortion → m a

 {-# INLINE abort #-}
 {-# INLINE abort #-}

-abort status headers
-    = liftIO ∘ throwIO ∘ Abortion status (toHeaders headers)
-
--- |This is similar to 'abort' but computes it with
--- 'System.IO.Unsafe.unsafePerformIO'.
-abortPurely ∷ StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → a
-{-# INLINE abortPurely #-}
-abortPurely status headers
-    = throw ∘ Abortion status (toHeaders headers)
-
--- |Computation of @'abortSTM' status headers msg@ just computes
--- 'abort' in a 'Control.Monad.STM.STM' monad.
-abortSTM ∷ StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → STM a
-{-# INLINE abortSTM #-}
-abortSTM status headers
-    = throwSTM ∘ Abortion status (toHeaders headers)
-
--- | Computation of @'abortA' -< (status, (headers, msg))@ just
--- computes 'abort' in an 'Control.Arrow.ArrowIO.ArrowIO'.
-abortA ∷ ArrowIO (⇝) ⇒ (StatusCode, ([ (CIAscii, Ascii) ], Maybe Text)) ⇝ c
-{-# INLINE abortA #-}
-abortA = proc (status, (headers, msg)) →
-         arrIO throwIO ⤙ Abortion status (toHeaders headers) msg
-
--- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
--- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
--- ければならない。
-abortPage ∷ Config → Maybe Request → Response → Abortion → Builder
-abortPage conf reqM res abo
-    = case aboMessage abo of
-        Just msg
-            → let [html] = runLA ( mkDefaultPage conf (aboStatus abo) (txt $ T.unpack msg)
-                                   ⋙
-                                   writeDocumentToString [ withIndent True ]
-                                 ) ()
-              in
-                BB.fromString html
-        Nothing
-            → let res'  = res { resStatus = aboStatus abo }
-                  res'' = foldl (∘) id [setHeader name value
-                                            | (name, value) ← fromHeaders $ aboHeaders abo] res'
-               in
-                 getDefaultPage conf reqM res''
+abort = liftIO ∘ throwIO

diff --git a/Network/HTTP/Lucu/Abortion/Internal.hs b/Network/HTTP/Lucu/Abortion/Internal.hs
new file mode 100644 (file)
index 0000000..f71e045
--- /dev/null
+++ b/Network/HTTP/Lucu/Abortion/Internal.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE
+    DeriveDataTypeable
+  , UnicodeSyntax
+  #-}
+module Network.HTTP.Lucu.Abortion.Internal
+    ( Abortion(..)
+    , abortPage
+    )
+    where
+import Blaze.ByteString.Builder (Builder)
+import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
+import Control.Arrow.ListArrow
+import Control.Arrow.Unicode
+import Control.Exception
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Typeable
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.DefaultPage
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Response
+import Prelude.Unicode
+import Text.XML.HXT.Arrow.WriteDocument
+import Text.XML.HXT.Arrow.XmlArrow
+import Text.XML.HXT.Arrow.XmlState
+
+-- |'Abortion' is an 'Exception' that aborts the execution of
+-- 'Network.HTTP.Lucu.Resource.Resource' monad with a 'StatusCode',
+-- additional response headers, and an optional message text.
+--
+-- 1. If the 'Network.HTTP.Lucu.Resource.Resource' is in the /Deciding
+--    Header/ or any precedent states, throwing an 'Abortion' affects
+--    the HTTP response to be sent to the client.
+--
+-- 2. Otherwise it's too late to overwrite the HTTP response so the
+--    only possible thing the system can do is to dump the exception
+--    to the stderr. See 'cnfDumpTooLateAbortionToStderr'.
+--
+-- Note that the status code doesn't necessarily have to satisfy
+-- 'isError' so you can abuse this exception for redirections as well
+-- as error reporting e.g.
+--
+-- > abort $ mkAbortion MovedPermanently
+-- >         [("Location", "http://example.net/")]
+-- >         "It has been moved to example.net"
+data Abortion = Abortion {
+      aboStatus  ∷ !StatusCode
+    , aboHeaders ∷ !Headers
+    , aboMessage ∷ !(Maybe Text)
+    } deriving (Eq, Show, Typeable)
+
+instance Exception Abortion
+
+instance HasHeaders Abortion where
+    getHeaders         = aboHeaders
+    setHeaders abo hdr = abo { aboHeaders = hdr }
+
+abortPage ∷ Config → Maybe Request → Response → Abortion → Builder
+abortPage conf reqM res abo
+    = case aboMessage abo of
+        Just msg
+            → let [html] = runLA ( mkDefaultPage conf (aboStatus abo) (txt $ T.unpack msg)
+                                   ⋙
+                                   writeDocumentToString [ withIndent True ]
+                                 ) ()
+              in
+                BB.fromString html
+        Nothing
+            → let res'  = res { resStatus = aboStatus abo }
+                  res'' = foldl (∘) id [setHeader name value
+                                            | (name, value) ← fromHeaders $ aboHeaders abo] res'
+               in
+                 getDefaultPage conf reqM res''

diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs
index 2dca5120d8c6e0e21f40b88a03959d4017c848d4..595403abd0364f1a2e70c79088d9138d38eeaf90 100644 (file)
--- a/Network/HTTP/Lucu/Httpd.hs
+++ b/Network/HTTP/Lucu/Httpd.hs
@@ -45,7 +45,7 @@ import System.Posix.Signals
 -- > helloWorld :: ResourceDef
 -- > helloWorld = emptyResource {
 -- >                resGet
 -- > helloWorld :: ResourceDef
 -- > helloWorld = emptyResource {
 -- >                resGet

--- >                  = Just $ do setContentType $ mkMIMEType "text" "plain"
+-- >                  = Just $ do setContentType $ parseMIMEType "text/plain"

 -- >                              putChunk "Hello, world!"
 -- >              }
 runHttpd ∷ Config → ResTree → [FallbackHandler] → IO ()
 -- >                              putChunk "Hello, world!"
 -- >              }
 runHttpd ∷ Config → ResTree → [FallbackHandler] → IO ()


@@ -105,7 +105,7 @@ runHttpd cnf tree fbs
       httpLoop ∷ SocketLike s ⇒ PortNumber → s → IO ()
       httpLoop port so
           = do (h, addr)  ← SL.accept so
       httpLoop ∷ SocketLike s ⇒ PortNumber → s → IO ()
       httpLoop port so
           = do (h, addr)  ← SL.accept so

-               tQueue     ← newInteractionQueue
+               tQueue     ← mkInteractionQueue

                readerTID  ← forkIO $ requestReader cnf tree fbs h port addr tQueue
                _writerTID ← forkIO $ responseWriter cnf h tQueue readerTID
                httpLoop port so
                readerTID  ← forkIO $ requestReader cnf tree fbs h port addr tQueue
                _writerTID ← forkIO $ responseWriter cnf h tQueue readerTID
                httpLoop port so

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index 20b4bc27ec956fffb6b959be6dae9c6359182694..e486e1a32d2895faaa1165727fc01fd9c15f255d 100644 (file)
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -1,57 +1,164 @@
 {-# LANGUAGE
 {-# LANGUAGE

-    OverloadedStrings
+    DeriveDataTypeable
+  , ExistentialQuantification
+  , OverloadedStrings

   , RecordWildCards
   , UnicodeSyntax
   #-}
 module Network.HTTP.Lucu.Interaction
     ( Interaction(..)
   , RecordWildCards
   , UnicodeSyntax
   #-}
 module Network.HTTP.Lucu.Interaction
     ( Interaction(..)

+    , SomeInteraction(..)
+
+    , SyntacticallyInvalidInteraction(..)
+    , mkSyntacticallyInvalidInteraction
+
+    , SemanticallyInvalidInteraction(..)
+    , mkSemanticallyInvalidInteraction
+
+    , NormalInteraction(..)

     , InteractionState(..)
     , InteractionState(..)

-    , InteractionQueue

     , ReceiveBodyRequest(..)
     , ReceiveBodyRequest(..)

-    , newInteractionQueue
-    , newInteraction
+    , mkNormalInteraction
+
+    , InteractionQueue
+    , mkInteractionQueue

 
     , setResponseStatus
 
     , setResponseStatus

+    , getCurrentDate

     )
     where
 import Blaze.ByteString.Builder (Builder)
     )
     where
 import Blaze.ByteString.Builder (Builder)

+import Control.Applicative

 import Control.Concurrent.STM
 import Control.Concurrent.STM

+import Data.Ascii (Ascii)

 import qualified Data.ByteString as Strict
 import Data.Monoid.Unicode
 import Data.Sequence (Seq)
 import qualified Data.ByteString as Strict
 import Data.Monoid.Unicode
 import Data.Sequence (Seq)

-import qualified Data.Sequence as S
+import qualified Data.Strict.Maybe as S
+import Data.Time
+import qualified Data.Time.HTTP as HTTP
+import Data.Typeable

 import Network.Socket
 import Network.HTTP.Lucu.Config
 import Network.Socket
 import Network.HTTP.Lucu.Config

-import Network.HTTP.Lucu.HttpVersion
+import Network.HTTP.Lucu.DefaultPage
+import Network.HTTP.Lucu.Headers

 import Network.HTTP.Lucu.Preprocess
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 import OpenSSL.X509
 
 import Network.HTTP.Lucu.Preprocess
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 import OpenSSL.X509
 

-data Interaction = Interaction {
-      itrConfig            ∷ !Config
-    , itrLocalPort         ∷ !PortNumber
-    , itrRemoteAddr        ∷ !SockAddr
-    , itrRemoteCert        ∷ !(Maybe X509)
-    , itrResourcePath      ∷ !(Maybe [Strict.ByteString])
-    , itrRequest           ∷ !(Maybe Request)
+class Typeable i ⇒ Interaction i where
+    toInteraction ∷ i → SomeInteraction
+    toInteraction = SomeInteraction
+
+    fromInteraction ∷ SomeInteraction → Maybe i
+    fromInteraction (SomeInteraction i) = cast i
+
+data SomeInteraction
+    = ∀i. Interaction i ⇒ SomeInteraction !i
+    deriving Typeable
+
+instance Interaction SomeInteraction where
+    toInteraction   = id
+    fromInteraction = Just
+
+-- |'SyntacticallyInvalidInteraction' is an 'Interaction' without even
+-- a syntactically valid 'Request'. The response code will always be
+-- 'BadRequest'.
+data SyntacticallyInvalidInteraction
+    = SYI {
+        syiResponse   ∷ !Response
+      , syiBodyToSend ∷ !Builder
+      }
+    deriving Typeable
+instance Interaction SyntacticallyInvalidInteraction
+
+mkSyntacticallyInvalidInteraction ∷ Config
+                                  → IO SyntacticallyInvalidInteraction
+mkSyntacticallyInvalidInteraction config@(Config {..})
+    = do date ← getCurrentDate
+         let res  = setHeader "Server"       cnfServerSoftware      $
+                    setHeader "Date"         date                   $
+                    setHeader "Content-Type" defaultPageContentType $
+                    emptyResponse BadRequest
+             body = getDefaultPage config Nothing res
+         return SYI {
+                  syiResponse   = res
+                , syiBodyToSend = body
+                }
+
+-- |'SemanticallyInvalidInteraction' is an 'Interaction' without a
+-- semantically valid 'Request'. The response code will always satisfy
+-- 'isError'.
+data SemanticallyInvalidInteraction
+    = SEI {
+        seiRequest          ∷ !Request
+      , seiExpectedContinue ∷ !Bool
+      , seiReqBodyLength    ∷ !(S.Maybe RequestBodyLength)
+
+      , seiResponse         ∷ !Response
+      , seiWillChunkBody    ∷ !Bool
+      , seiWillDiscardBody  ∷ !Bool
+      , seiWillClose        ∷ !Bool
+      , seiBodyToSend       ∷ !Builder
+      }
+    deriving Typeable
+instance Interaction SemanticallyInvalidInteraction
+
+mkSemanticallyInvalidInteraction ∷ Config
+                                 → AugmentedRequest
+                                 → IO SemanticallyInvalidInteraction
+mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..})
+    = do date ← getCurrentDate
+         let res  = setHeader "Server"       cnfServerSoftware      $
+                    setHeader "Date"         date                   $
+                    setHeader "Content-Type" defaultPageContentType $
+                    emptyResponse arInitialStatus
+             body = getDefaultPage config (Just arRequest) res
+         return SEI {
+                  seiRequest          = arRequest
+                , seiExpectedContinue = arExpectedContinue
+                , seiReqBodyLength    = arReqBodyLength
+
+                , seiResponse         = res
+                , seiWillChunkBody    = arWillChunkBody
+                , seiWillDiscardBody  = arWillDiscardBody
+                , seiWillClose        = arWillClose
+                , seiBodyToSend       = body
+                }
+
+-- |'NormalInteraction' is an 'Interaction' with a semantically
+-- correct 'Request'.
+data NormalInteraction
+    = NI {
+        niConfig           ∷ !Config
+      , niRemoteAddr       ∷ !SockAddr
+      , niRemoteCert       ∷ !(Maybe X509)
+      , niRequest          ∷ !Request
+      , niResourcePath     ∷ ![Strict.ByteString]
+      , niExpectedContinue ∷ !Bool
+      , niReqBodyLength    ∷ !(S.Maybe RequestBodyLength)
+
+      , niReceiveBodyReq   ∷ !(TMVar ReceiveBodyRequest)
+      , niReceivedBody     ∷ !(TMVar Strict.ByteString)
+
+      , niResponse         ∷ !(TVar Response)
+      , niSendContinue     ∷ !(TMVar Bool)
+      , niWillChunkBody    ∷ !Bool
+      , niWillDiscardBody  ∷ !(TVar Bool)
+      , niWillClose        ∷ !(TVar Bool)
+      , niResponseHasCType ∷ !(TVar Bool)
+      , niBodyToSend       ∷ !(TMVar Builder)
+
+      , niState            ∷ !(TVar InteractionState)
+      }
+    deriving Typeable
+instance Interaction NormalInteraction

 
 

-    , itrExpectedContinue  ∷ !(Maybe Bool)
-    , itrReqBodyLength     ∷ !(Maybe RequestBodyLength)
-
-    , itrReceiveBodyReq    ∷ !(TMVar ReceiveBodyRequest)
-    , itrReceivedBody      ∷ !(TMVar Strict.ByteString)
-
-    , itrSendContinue      ∷ !(TMVar Bool)
-    , itrResponse          ∷ !(TVar Response)
-    , itrWillChunkBody     ∷ !(TVar Bool)
-    , itrWillDiscardBody   ∷ !(TVar Bool)
-    , itrWillClose         ∷ !(TVar Bool)
-    , itrResponseHasCType  ∷ !(TVar Bool)
-    , itrBodyToSend        ∷ !(TMVar Builder)
-
-    , itrState             ∷ !(TVar InteractionState)
-    }
+data ReceiveBodyRequest
+    = ReceiveBody !Int -- ^ Maximum number of octets to receive.
+    | WasteAll
+    deriving (Show, Eq)

 
 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
 -- initial state.
 
 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
 -- initial state.


@@ -63,72 +170,60 @@ data InteractionState
     | Done
     deriving (Show, Eq, Ord, Enum)
 
     | Done
     deriving (Show, Eq, Ord, Enum)
 

-type InteractionQueue = TVar (Seq Interaction)
-
-data ReceiveBodyRequest
-    = ReceiveBody !Int -- ^ Maximum number of octets to receive.
-    | WasteAll
-    deriving (Show, Eq)
-
-newInteractionQueue ∷ IO InteractionQueue
-newInteractionQueue = newTVarIO S.empty
-
-newInteraction ∷ Config
-               → PortNumber
-               → SockAddr
-               → Maybe X509
-               → Either StatusCode Request
-               → IO Interaction
-newInteraction conf@(Config {..}) port addr cert request
-    = do let ar  = preprocess cnfServerHost port request
-             res = Response {
-                     resVersion = HttpVersion 1 1
-                   , resStatus  = arInitialStatus ar
-                   , resHeaders = (∅)
-                   }
-
-         receiveBodyReq   ← newEmptyTMVarIO
+mkNormalInteraction ∷ Config
+                    → SockAddr
+                    → Maybe X509
+                    → AugmentedRequest
+                    → [Strict.ByteString]
+                    → IO NormalInteraction
+mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPath
+    = do receiveBodyReq   ← newEmptyTMVarIO

          receivedBody     ← newEmptyTMVarIO
 
          receivedBody     ← newEmptyTMVarIO
 

+         response         ← newTVarIO $ emptyResponse arInitialStatus

          sendContinue     ← newEmptyTMVarIO
          sendContinue     ← newEmptyTMVarIO

-         response         ← newTVarIO res
-         willChunkBody    ← newTVarIO False
-         willDiscardBody  ← newTVarIO (arWillDiscardBody ar)
-         willClose        ← newTVarIO (arWillClose       ar)
-         bodyToSend       ← newEmptyTMVarIO
+         willDiscardBody  ← newTVarIO arWillDiscardBody
+         willClose        ← newTVarIO arWillClose

          responseHasCType ← newTVarIO False
          responseHasCType ← newTVarIO False

+         bodyToSend       ← newEmptyTMVarIO

 
          state            ← newTVarIO ExaminingRequest
 
 
          state            ← newTVarIO ExaminingRequest
 

-         return Interaction {
-                      itrConfig           = conf
-                    , itrLocalPort        = port
-                    , itrRemoteAddr       = addr
-                    , itrRemoteCert       = cert
-                    , itrResourcePath     = Nothing
-                    , itrRequest          = arRequest ar
-
-                    , itrExpectedContinue = arExpectedContinue ar
-                    , itrReqBodyLength    = arReqBodyLength    ar
-
-                    , itrReceiveBodyReq   = receiveBodyReq
-                    , itrReceivedBody     = receivedBody
-
-                    , itrSendContinue     = sendContinue
-                    , itrResponse         = response
-                    , itrWillChunkBody    = willChunkBody
-                    , itrWillDiscardBody  = willDiscardBody
-                    , itrWillClose        = willClose
-                    , itrResponseHasCType = responseHasCType
-                    , itrBodyToSend       = bodyToSend
-                    
-                    , itrState            = state
-                    }
-
-setResponseStatus ∷ Interaction → StatusCode → STM ()
-setResponseStatus (Interaction {..}) sc
-    = do res ← readTVar itrResponse
+         return NI {
+                  niConfig           = config
+                , niRemoteAddr       = remoteAddr
+                , niRemoteCert       = remoteCert
+                , niRequest          = arRequest
+                , niResourcePath     = rsrcPath
+                , niExpectedContinue = arExpectedContinue
+                , niReqBodyLength    = arReqBodyLength
+
+                , niReceiveBodyReq   = receiveBodyReq
+                , niReceivedBody     = receivedBody
+
+                , niResponse         = response
+                , niSendContinue     = sendContinue
+                , niWillChunkBody    = arWillChunkBody
+                , niWillDiscardBody  = willDiscardBody
+                , niWillClose        = willClose
+                , niResponseHasCType = responseHasCType
+                , niBodyToSend       = bodyToSend
+
+                , niState            = state
+                }
+
+type InteractionQueue = TVar (Seq SomeInteraction)
+
+mkInteractionQueue ∷ IO InteractionQueue
+mkInteractionQueue = newTVarIO (∅)
+
+setResponseStatus ∷ NormalInteraction → StatusCode → STM ()
+setResponseStatus (NI {..}) sc
+    = do res ← readTVar niResponse

          let res' = res {
                       resStatus = sc
                     }
          let res' = res {
                       resStatus = sc
                     }

-         writeTVar itrResponse res'
+         writeTVar niResponse res'
+
+getCurrentDate ∷ IO Ascii
+getCurrentDate = HTTP.toAscii <$> getCurrentTime

diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
index bc9363d1115de6740032c1d858ac9baab4e65ea3..6735652d6a5656410c6cc5ebfcdc922c11184761 100644 (file)
--- a/Network/HTTP/Lucu/Postprocess.hs
+++ b/Network/HTTP/Lucu/Postprocess.hs
@@ -6,7 +6,6 @@
   #-}
 module Network.HTTP.Lucu.Postprocess
     ( postprocess
   #-}
 module Network.HTTP.Lucu.Postprocess
     ( postprocess

-    , completeUnconditionalHeaders

     )
     where
 import Control.Applicative
     )
     where
 import Control.Applicative


@@ -15,33 +14,28 @@ import Control.Monad
 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
 import qualified Data.Ascii as A
 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
 import qualified Data.Ascii as A

+import Data.Maybe

 import Data.Monoid.Unicode
 import Data.Monoid.Unicode

-import Data.Time
-import qualified Data.Time.HTTP as HTTP

 import GHC.Conc (unsafeIOToSTM)
 import Network.HTTP.Lucu.Abortion
 import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.DefaultPage
 import Network.HTTP.Lucu.Headers
 import GHC.Conc (unsafeIOToSTM)
 import Network.HTTP.Lucu.Abortion
 import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.DefaultPage
 import Network.HTTP.Lucu.Headers

-import Network.HTTP.Lucu.HttpVersion

 import Network.HTTP.Lucu.Interaction
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 import Prelude.Unicode
 
 import Network.HTTP.Lucu.Interaction
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 import Prelude.Unicode
 

-postprocess ∷ Interaction → STM ()
-postprocess itr@(Interaction {..})
-    = do abortOnCertainConditions itr
+postprocess ∷ NormalInteraction → STM ()
+postprocess ni@(NI {..})
+    = do void $ tryPutTMVar niSendContinue False
+         abortOnCertainConditions ni
+         postprocessWithRequest ni
+         completeUnconditionalHeaders ni

 
 

-         case itrRequest of
-           Just req → postprocessWithRequest itr req
-           Nothing  → return ()
-
-         updateResIO itr $ completeUnconditionalHeaders itrConfig
-
-abortOnCertainConditions ∷ Interaction → STM ()
-abortOnCertainConditions (Interaction {..})
-    = readTVar itrResponse ≫= go
+abortOnCertainConditions ∷ NormalInteraction → STM ()
+abortOnCertainConditions (NI {..})
+    = readTVar niResponse ≫= go

     where
       go ∷ Response → STM ()
       go res@(Response {..})
     where
       go ∷ Response → STM ()
       go res@(Response {..})


@@ -69,94 +63,84 @@ abortOnCertainConditions (Interaction {..})
                    ⊕ A.toAsciiBuilder " but no Location header."
 
       abort' ∷ AsciiBuilder → STM ()
                    ⊕ A.toAsciiBuilder " but no Location header."
 
       abort' ∷ AsciiBuilder → STM ()

-      abort' = abortSTM InternalServerError []
-               ∘ Just
+      abort' = throwSTM
+               ∘ mkAbortion' InternalServerError

                ∘ A.toText
                ∘ A.fromAsciiBuilder
 
                ∘ A.toText
                ∘ A.fromAsciiBuilder
 

-postprocessWithRequest ∷ Interaction → Request → STM ()
-postprocessWithRequest itr@(Interaction {..}) (Request {..})
-    = do willDiscardBody ← readTVar itrWillDiscardBody
+postprocessWithRequest ∷ NormalInteraction → STM ()
+postprocessWithRequest ni@(NI {..})
+    = do willDiscardBody ← readTVar niWillDiscardBody

          canHaveBody     ← if willDiscardBody then
                                return False
                            else
          canHaveBody     ← if willDiscardBody then
                                return False
                            else

-                               resCanHaveBody <$> readTVar itrResponse
+                               resCanHaveBody <$> readTVar niResponse

 
 

-         updateRes itr
+         updateRes ni

              $ deleteHeader "Content-Length"
              ∘ deleteHeader "Transfer-Encoding"
 
          if canHaveBody then
              $ deleteHeader "Content-Length"
              ∘ deleteHeader "Transfer-Encoding"
 
          if canHaveBody then

-             do when (reqVersion ≡ HttpVersion 1 1)
-                    $ do writeHeader itr "Transfer-Encoding" (Just "chunked")
-                         writeTVar itrWillChunkBody True
-                writeDefaultPageIfNeeded itr
+             do when niWillChunkBody $
+                    writeHeader ni "Transfer-Encoding" (Just "chunked")
+                writeDefaultPageIfNeeded ni

          else
          else

-             do writeTVar itrWillDiscardBody True
+             do writeTVar niWillDiscardBody True

                 -- These headers make sense for HEAD requests even
                 -- when there won't be a response entity body.
                 -- These headers make sense for HEAD requests even
                 -- when there won't be a response entity body.

-                when (reqMethod ≢ HEAD)
-                    $ updateRes itr
+                when (reqMethod niRequest ≢ HEAD)
+                    $ updateRes ni

                     $ deleteHeader "Content-Type"
                     ∘ deleteHeader "Etag"
                     ∘ deleteHeader "Last-Modified"
 
                     $ deleteHeader "Content-Type"
                     ∘ deleteHeader "Etag"
                     ∘ deleteHeader "Last-Modified"
 

-         hasConnClose ← (≡ Just "close") <$> readCIHeader itr "Connection"
-         willClose    ← readTVar itrWillClose
+         hasConnClose ← (≡ Just "close") <$> readCIHeader ni "Connection"
+         willClose    ← readTVar niWillClose

          when (hasConnClose ∧ (¬) willClose)
          when (hasConnClose ∧ (¬) willClose)

-             $ writeTVar itrWillClose True
+             $ writeTVar niWillClose True

          when ((¬) hasConnClose ∧ willClose)
          when ((¬) hasConnClose ∧ willClose)

-             $ writeHeader itr "Connection" (Just "close")
+             $ writeHeader ni "Connection" (Just "close")

 
 

-writeDefaultPageIfNeeded ∷ Interaction → STM ()
-writeDefaultPageIfNeeded itr@(Interaction {..})
-    = do resHasCType ← readTVar itrResponseHasCType
+writeDefaultPageIfNeeded ∷ NormalInteraction → STM ()
+writeDefaultPageIfNeeded ni@(NI {..})
+    = do resHasCType ← readTVar niResponseHasCType

          unless resHasCType
          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 page
-
-writeHeader ∷ Interaction → CIAscii → Maybe Ascii → STM ()
+             $ do writeHeader ni "Content-Type" $ Just defaultPageContentType
+                  writeHeader ni "Content-Encoding" Nothing
+                  res ← readTVar niResponse
+                  let body = getDefaultPage niConfig (Just niRequest) res
+                  putTMVar niBodyToSend body
+
+completeUnconditionalHeaders ∷ NormalInteraction → STM ()
+completeUnconditionalHeaders ni@(NI {..})
+    = do srv ← readHeader ni "Server"
+         when (isNothing srv) $
+             writeHeader ni "Server" $ Just $ cnfServerSoftware niConfig
+
+         date ← readHeader ni "Date"
+         when (isNothing date) $
+             do date' ← unsafeIOToSTM getCurrentDate
+                writeHeader ni "Date" $ Just date'
+
+writeHeader ∷ NormalInteraction → CIAscii → Maybe Ascii → STM ()

 {-# INLINE writeHeader #-}
 {-# INLINE writeHeader #-}

-writeHeader itr k v
+writeHeader ni k v

     = case v of
     = case v of

-        Just v' → updateRes itr $ setHeader    k v'
-        Nothing → updateRes itr $ deleteHeader k
+        Just v' → updateRes ni $ setHeader    k v'
+        Nothing → updateRes ni $ deleteHeader k
+
+readHeader ∷ NormalInteraction → CIAscii → STM (Maybe Ascii)
+{-# INLINE readHeader #-}
+readHeader (NI {..}) k
+    = getHeader k <$> readTVar niResponse

 
 

-readCIHeader ∷ Interaction → CIAscii → STM (Maybe CIAscii)
+readCIHeader ∷ NormalInteraction → CIAscii → STM (Maybe CIAscii)

 {-# INLINE readCIHeader #-}
 {-# INLINE readCIHeader #-}

-readCIHeader (Interaction {..}) k
-    = getCIHeader k <$> readTVar itrResponse
+readCIHeader (NI {..}) k
+    = getCIHeader k <$> readTVar niResponse

 
 

-updateRes ∷ Interaction → (Response → Response) → STM ()
+updateRes ∷ NormalInteraction → (Response → Response) → STM ()

 {-# INLINE updateRes #-}
 {-# INLINE updateRes #-}

-updateRes (Interaction {..}) f
-    = do old ← readTVar itrResponse
-         writeTVar itrResponse (f old)
-
-updateResIO ∷ Interaction → (Response → IO Response) → STM ()
-{-# INLINE updateResIO #-}
-updateResIO (Interaction {..}) f
-    = do old ← readTVar itrResponse
-         new ← unsafeIOToSTM $ f old
-         writeTVar itrResponse new
-
--- FIXME: Narrow the use of IO monad!
-completeUnconditionalHeaders ∷ Config → Response → IO Response
-completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer
-      where
-        compServer res'
-            = case getHeader "Server" res' of
-                Nothing → return $ setHeader "Server" (cnfServerSoftware conf) res'
-                Just _  → return res'
-
-        compDate res'
-            = case getHeader "Date" res' of
-                Nothing → do date ← getCurrentDate
-                             return $ setHeader "Date" date res'
-                Just _  → return res'
-
-getCurrentDate ∷ IO Ascii
-getCurrentDate = HTTP.toAscii <$> getCurrentTime
+updateRes (NI {..}) f
+    = do old ← readTVar niResponse
+         writeTVar niResponse $ f old

diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs
index 739dec89f6d6058486a00cf404e7d6a12b7280c9..8e3087ebae70654ae0b4a8f74b5e1f0a4102c466 100644 (file)
--- a/Network/HTTP/Lucu/Preprocess.hs
+++ b/Network/HTTP/Lucu/Preprocess.hs
@@ -12,11 +12,12 @@ module Network.HTTP.Lucu.Preprocess
     where
 import Control.Applicative
 import Control.Monad
     where
 import Control.Applicative
 import Control.Monad

-import Control.Monad.State
+import Control.Monad.State.Strict

 import Data.Ascii (Ascii)
 import qualified Data.Ascii as A
 import qualified Data.ByteString.Char8 as C8
 import Data.Maybe
 import Data.Ascii (Ascii)
 import qualified Data.Ascii as A
 import qualified Data.ByteString.Char8 as C8
 import Data.Maybe

+import qualified Data.Strict.Maybe as S

 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


@@ -30,12 +31,13 @@ import Prelude.Unicode
 
 data AugmentedRequest
     = AugmentedRequest {
 
 data AugmentedRequest
     = AugmentedRequest {

-        arRequest          ∷ !(Maybe Request)
+        arRequest          ∷ !Request

       , arInitialStatus    ∷ !StatusCode
       , arInitialStatus    ∷ !StatusCode

-      , arWillClose        ∷ !Bool
+      , arWillChunkBody    ∷ !Bool

       , arWillDiscardBody  ∷ !Bool
       , arWillDiscardBody  ∷ !Bool

-      , arExpectedContinue ∷ !(Maybe Bool)
-      , arReqBodyLength    ∷ !(Maybe RequestBodyLength)
+      , arWillClose        ∷ !Bool
+      , arExpectedContinue ∷ !Bool
+      , arReqBodyLength    ∷ !(S.Maybe RequestBodyLength)

       }
 
 data RequestBodyLength
       }
 
 data RequestBodyLength


@@ -43,42 +45,20 @@ data RequestBodyLength
     | Chunked
     deriving (Eq, Show)
 
     | Chunked
     deriving (Eq, Show)
 

-preprocess ∷ Text
-           → PortNumber
-           → Either StatusCode Request
-           → AugmentedRequest
-preprocess localHost localPort request
-    = case request of
-        Right req
-            → preprocess' localHost localPort req
-        Left sc
-            → unparsable sc
-
-unparsable ∷ StatusCode → AugmentedRequest
-unparsable sc
-    = AugmentedRequest {
-        arRequest          = Nothing
-      , arInitialStatus    = sc
-      , arWillClose        = True
-      , arWillDiscardBody  = False
-      , arExpectedContinue = Nothing
-      , arReqBodyLength    = Nothing
-      }
-
-preprocess' ∷ Text → PortNumber → Request → AugmentedRequest
-preprocess' localHost localPort req@(Request {..})
+preprocess ∷ Text → PortNumber → Request → AugmentedRequest
+preprocess localHost localPort req@(Request {..})

     = execState go initialAR
     where
       initialAR ∷ AugmentedRequest
       initialAR = AugmentedRequest {
     = execState go initialAR
     where
       initialAR ∷ AugmentedRequest
       initialAR = AugmentedRequest {

-                    arRequest          = Just req
+                    arRequest          = req

                   , arInitialStatus    = Ok
                   , arInitialStatus    = Ok

-                  , arWillClose        = False
+                  , arWillChunkBody    = False

                   , arWillDiscardBody  = False
                   , arWillDiscardBody  = False

-                  , arExpectedContinue = Just False
-                  , arReqBodyLength    = Nothing
+                  , arWillClose        = False
+                  , arExpectedContinue = False
+                  , arReqBodyLength    = S.Nothing

                   }
                   }

-

       go ∷ State AugmentedRequest ()
       go = do examineHttpVersion
               examineMethod
       go ∷ State AugmentedRequest ()
       go = do examineHttpVersion
               examineMethod


@@ -88,7 +68,7 @@ preprocess' localHost localPort req@(Request {..})
 
 setRequest ∷ Request → State AugmentedRequest ()
 setRequest req
 
 setRequest ∷ Request → State AugmentedRequest ()
 setRequest req

-    = modify $ \ar → ar { arRequest = Just req }
+    = modify $ \ar → ar { arRequest = req }

 
 setStatus ∷ StatusCode → State AugmentedRequest ()
 setStatus sc
 
 setStatus ∷ StatusCode → State AugmentedRequest ()
 setStatus sc


@@ -98,25 +78,25 @@ setWillClose ∷ Bool → State AugmentedRequest ()
 setWillClose b
     = modify $ \ar → ar { arWillClose = b }
 
 setWillClose b
     = modify $ \ar → ar { arWillClose = b }
 

-setBodyLength ∷ Maybe RequestBodyLength → State AugmentedRequest ()
+setBodyLength ∷ S.Maybe RequestBodyLength → State AugmentedRequest ()

 setBodyLength len
     = modify $ \ar → ar { arReqBodyLength = len }
 
 examineHttpVersion ∷ State AugmentedRequest ()
 examineHttpVersion
 setBodyLength len
     = modify $ \ar → ar { arReqBodyLength = len }
 
 examineHttpVersion ∷ State AugmentedRequest ()
 examineHttpVersion

-    = do req ← gets (fromJust ∘ arRequest)
+    = do req ← gets arRequest

          case reqVersion req of
            -- HTTP/1.0 requests can't Keep-Alive.
            HttpVersion 1 0
                → setWillClose True
            HttpVersion 1 1
          case reqVersion req of
            -- HTTP/1.0 requests can't Keep-Alive.
            HttpVersion 1 0
                → setWillClose True
            HttpVersion 1 1

-               → return ()
+               → modify $ \ar → ar { arWillChunkBody = True }

            _   → do setStatus    HttpVersionNotSupported
                     setWillClose True
 
 examineMethod ∷ State AugmentedRequest ()
 examineMethod
            _   → do setStatus    HttpVersionNotSupported
                     setWillClose True
 
 examineMethod ∷ State AugmentedRequest ()
 examineMethod

-    = do req ← gets (fromJust ∘ arRequest)
+    = do req ← gets arRequest

          case reqMethod req of
            GET    → return ()
            HEAD   → modify $ \ar → ar { arWillDiscardBody = True }
          case reqMethod req of
            GET    → return ()
            HEAD   → modify $ \ar → ar { arWillDiscardBody = True }


@@ -127,7 +107,7 @@ examineMethod
 
 examineAuthority ∷ Text → PortNumber → State AugmentedRequest ()
 examineAuthority localHost localPort
 
 examineAuthority ∷ Text → PortNumber → State AugmentedRequest ()
 examineAuthority localHost localPort

-    = do req ← gets (fromJust ∘ arRequest)
+    = do req ← gets arRequest

          when (isNothing $ uriAuthority $ reqURI req) $
              case reqVersion req of
                -- HTTP/1.0 requests have no Host header so complete it
          when (isNothing $ uriAuthority $ reqURI req) $
              case reqVersion req of
                -- HTTP/1.0 requests have no Host header so complete it


@@ -178,13 +158,13 @@ updateAuthority host port req
 
 examineHeaders ∷ State AugmentedRequest ()
 examineHeaders
 
 examineHeaders ∷ State AugmentedRequest ()
 examineHeaders

-    = do req ← gets (fromJust ∘ arRequest)
+    = do req ← gets arRequest

 
          case getCIHeader "Expect" req of
            Nothing → return ()
            Just v
                | v ≡ "100-continue"
 
          case getCIHeader "Expect" req of
            Nothing → return ()
            Just v
                | v ≡ "100-continue"

-                   → modify $ \ar → ar { arExpectedContinue = Just True }
+                   → modify $ \ar → ar { arExpectedContinue = True }

                | otherwise
                    → setStatus ExpectationFailed
 
                | otherwise
                    → setStatus ExpectationFailed
 


@@ -194,7 +174,7 @@ examineHeaders
                | v ≡ "identity"
                    → return ()
                | v ≡ "chunked"
                | v ≡ "identity"
                    → return ()
                | v ≡ "chunked"

-                   → setBodyLength $ Just Chunked
+                   → setBodyLength $ S.Just Chunked

                | otherwise
                    → setStatus NotImplemented
 
                | otherwise
                    → setStatus NotImplemented
 


@@ -203,7 +183,7 @@ examineHeaders
            Just value → case C8.readInt value of
                            Just (len, garbage)
                                | C8.null garbage ∧ len ≥ 0
            Just value → case C8.readInt value of
                            Just (len, garbage)
                                | C8.null garbage ∧ len ≥ 0

-                                   → setBodyLength $ Just $ Fixed len
+                                   → setBodyLength $ S.Just $ Fixed len

                            _       → setStatus BadRequest
 
          case getCIHeader "Connection" req of
                            _       → setStatus BadRequest
 
          case getCIHeader "Connection" req of


@@ -214,13 +194,13 @@ examineHeaders
 
 examineBodyLength ∷ State AugmentedRequest ()
 examineBodyLength
 
 examineBodyLength ∷ State AugmentedRequest ()
 examineBodyLength

-    = do req ← gets (fromJust ∘ arRequest)
+    = do req ← gets arRequest

          len ← gets arReqBodyLength
          if reqMustHaveBody req then
              -- POST and PUT requests must have an entity body.
          len ← gets arReqBodyLength
          if reqMustHaveBody req then
              -- POST and PUT requests must have an entity body.

-             when (isNothing len)
+             when (S.isNothing len)

                  $ setStatus LengthRequired
          else
              -- Other requests must NOT have an entity body.
                  $ setStatus LengthRequired
          else
              -- Other requests must NOT have an entity body.

-             when (isJust len)
+             when (S.isJust len)

                  $ setStatus BadRequest
                  $ setStatus BadRequest

diff --git a/Network/HTTP/Lucu/RFC2231.hs b/Network/HTTP/Lucu/RFC2231.hs
index 9856f474eb94281b8280fc9110780fe43643a278..1302e596a8418985a8c5e429c6947de504ab6502 100644 (file)
--- a/Network/HTTP/Lucu/RFC2231.hs
+++ b/Network/HTTP/Lucu/RFC2231.hs
@@ -5,7 +5,7 @@
   , ScopedTypeVariables
   , UnicodeSyntax
   #-}
   , ScopedTypeVariables
   , UnicodeSyntax
   #-}

--- |Provide facilities to encode/decode MIME parameter values in
+-- |Provide functionalities to encode/decode MIME parameter values in

 -- character sets other than US-ASCII. See:
 -- http://www.faqs.org/rfcs/rfc2231.html
 module Network.HTTP.Lucu.RFC2231
 -- character sets other than US-ASCII. See:
 -- http://www.faqs.org/rfcs/rfc2231.html
 module Network.HTTP.Lucu.RFC2231

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 05b30420a95040bf9284b94d19bfb913fde51ae4..b0af8d1f38d773571c8374ce4c5cff2101992b75 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE
     DoAndIfThenElse
 {-# LANGUAGE
     DoAndIfThenElse

+  , OverloadedStrings

   , RecordWildCards
   , ScopedTypeVariables
   , UnicodeSyntax
   , RecordWildCards
   , ScopedTypeVariables
   , UnicodeSyntax


@@ -8,29 +9,29 @@ module Network.HTTP.Lucu.RequestReader
     ( requestReader
     )
     where
     ( requestReader
     )
     where

-import Control.Applicative
+import Control.Concurrent

 import Control.Concurrent.STM
 import Control.Exception hiding (block)
 import Control.Monad
 import qualified Data.Attoparsec.Lazy as LP
 import qualified Data.ByteString as Strict
 import qualified Data.ByteString.Lazy as Lazy
 import Control.Concurrent.STM
 import Control.Exception hiding (block)
 import Control.Monad
 import qualified Data.Attoparsec.Lazy as LP
 import qualified Data.ByteString as Strict
 import qualified Data.ByteString.Lazy as Lazy

-import Data.Maybe
+import qualified Data.Strict.Maybe as S

 import Data.Monoid.Unicode
 import qualified Data.Sequence as S
 import Data.Sequence.Unicode hiding ((∅))
 import Data.Monoid.Unicode
 import qualified Data.Sequence as S
 import Data.Sequence.Unicode hiding ((∅))

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

 import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.Chunk
 import Network.HTTP.Lucu.HandleLike
 import Network.HTTP.Lucu.Interaction
 import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.Chunk
 import Network.HTTP.Lucu.HandleLike
 import Network.HTTP.Lucu.Interaction

-import Network.HTTP.Lucu.Postprocess

 import Network.HTTP.Lucu.Preprocess
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 import Network.HTTP.Lucu.Resource.Internal
 import Network.HTTP.Lucu.Resource.Tree
 import Network.Socket
 import Network.HTTP.Lucu.Preprocess
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 import Network.HTTP.Lucu.Resource.Internal
 import Network.HTTP.Lucu.Resource.Tree
 import Network.Socket

-import Network.URI

 import Prelude.Unicode
 import System.IO (hPutStrLn, stderr)
 
 import Prelude.Unicode
 import System.IO (hPutStrLn, stderr)
 


@@ -96,15 +97,12 @@ acceptRequest ctx@(Context {..}) input
          -- ResponseWriter に通知する。
          case LP.parse requestP input of
            LP.Done input' req → acceptParsableRequest ctx req input'
          -- ResponseWriter に通知する。
          case LP.parse requestP input of
            LP.Done input' req → acceptParsableRequest ctx req input'

-           LP.Fail _ _ _      → acceptNonparsableRequest ctx BadRequest
+           LP.Fail _ _ _      → acceptNonparsableRequest ctx

 
 

-acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → StatusCode → IO ()
-acceptNonparsableRequest ctx@(Context {..}) sc
-    = do itr ← newInteraction cConfig cPort cAddr Nothing (Left sc)
-         atomically $
-             do writeTVar (itrState itr) Done
-                postprocess itr
-                enqueue ctx itr
+acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → IO ()
+acceptNonparsableRequest ctx@(Context {..})
+    = do syi ← mkSyntacticallyInvalidInteraction cConfig
+         enqueue ctx syi

 
 acceptParsableRequest ∷ HandleLike h
                       ⇒ Context h
 
 acceptParsableRequest ∷ HandleLike h
                       ⇒ Context h


@@ -112,120 +110,98 @@ acceptParsableRequest ∷ HandleLike h
                       → Lazy.ByteString
                       → IO ()
 acceptParsableRequest ctx@(Context {..}) req input
                       → Lazy.ByteString
                       → IO ()
 acceptParsableRequest ctx@(Context {..}) req input

-    = do cert ← hGetPeerCert cHandle
-         itr  ← newInteraction cConfig cPort cAddr cert (Right req)
-         join $ atomically
-              $ do isErr ← (isError ∘ resStatus) <$> readTVar (itrResponse itr)
-                   if isErr then
-                       acceptSemanticallyInvalidRequest ctx itr input
-                   else
-                       return $ acceptSemanticallyValidRequest ctx itr (reqURI req) input
+    = do let ar = preprocess (cnfServerHost cConfig) cPort req
+         if isError $ arInitialStatus ar then
+             acceptSemanticallyInvalidRequest ctx ar input
+         else
+             do rsrc ← findResource cResTree cFallbacks $ reqURI $ arRequest ar
+                case rsrc of
+                  Nothing
+                      → do let ar' = ar { arInitialStatus = NotFound }
+                           acceptSemanticallyInvalidRequest ctx ar' input
+                  Just (path, def)
+                      → acceptRequestForResource ctx ar input path def

 
 acceptSemanticallyInvalidRequest ∷ HandleLike h
                                  ⇒ Context h
 
 acceptSemanticallyInvalidRequest ∷ HandleLike h
                                  ⇒ Context h

-                                 → Interaction
+                                 → AugmentedRequest

                                  → Lazy.ByteString
                                  → Lazy.ByteString

-                                 → STM (IO ())
-acceptSemanticallyInvalidRequest ctx itr input
-    = do writeTVar (itrState itr) Done
-         postprocess itr
-         enqueue ctx itr
-         return $ acceptRequest ctx input
-
-acceptSemanticallyValidRequest ∷ HandleLike h
-                               ⇒ Context h
-                               → Interaction
-                               → URI
-                               → Lazy.ByteString
-                               → IO ()
-acceptSemanticallyValidRequest ctx@(Context {..}) itr uri input
-    = do rsrcM ← findResource cResTree cFallbacks uri
-         case rsrcM of
-           Nothing
-               → acceptRequestForNonexistentResource ctx itr input
-           Just (rsrcPath, rsrcDef)
-               → acceptRequestForExistentResource ctx itr input rsrcPath rsrcDef
-
-acceptRequestForNonexistentResource ∷ HandleLike h
-                                    ⇒ Context h
-                                    → Interaction
-                                    → Lazy.ByteString
-                                    → IO ()
-acceptRequestForNonexistentResource ctx itr input
-    = do atomically $
-             do setResponseStatus itr NotFound
-                writeTVar (itrState itr) Done
-                postprocess itr
-                enqueue ctx itr
+                                 → IO ()
+acceptSemanticallyInvalidRequest ctx@(Context {..}) ar input
+    = do sei ← mkSemanticallyInvalidInteraction cConfig ar
+         enqueue ctx sei

          acceptRequest ctx input
 
          acceptRequest ctx input
 

-acceptRequestForExistentResource ∷ HandleLike h
-                                 ⇒ Context h
-                                 → Interaction
-                                 → Lazy.ByteString
-                                 → [Strict.ByteString]
-                                 → ResourceDef
-                                 → IO ()
-acceptRequestForExistentResource ctx oldItr input rsrcPath rsrcDef
-    = do let itr = oldItr { itrResourcePath = Just rsrcPath }
-         atomically $ enqueue ctx itr
-         do _ ← spawnResource rsrcDef itr
-            if reqMustHaveBody $ fromJust $ itrRequest itr then
-                waitForReceiveBodyReq ctx itr input
-            else
-                acceptRequest ctx input
+acceptRequestForResource ∷ HandleLike h
+                         ⇒ Context h
+                         → AugmentedRequest
+                         → Lazy.ByteString
+                         → [Strict.ByteString]
+                         → ResourceDef
+                         → IO ()
+acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef
+    = do cert ← hGetPeerCert cHandle
+         ni   ← mkNormalInteraction cConfig cAddr cert ar rsrcPath
+         tid  ← spawnResource rsrcDef ni
+         if reqMustHaveBody arRequest then
+             waitForReceiveBodyReq ctx ni tid input
+         else
+             acceptRequest ctx input

 
 waitForReceiveBodyReq ∷ HandleLike h
                       ⇒ Context h
 
 waitForReceiveBodyReq ∷ HandleLike h
                       ⇒ Context h

-                      → Interaction
+                      → NormalInteraction
+                      → ThreadId

                       → Lazy.ByteString
                       → IO ()
                       → Lazy.ByteString
                       → IO ()

-waitForReceiveBodyReq ctx itr input
-    = case fromJust $ itrReqBodyLength itr of
+waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input
+    = case S.fromJust niReqBodyLength of

         Chunked
         Chunked

-            → waitForReceiveChunkedBodyReqForTheFirstTime ctx itr input
+            → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input

         Fixed len
         Fixed len

-            → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx itr input len
+            → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni input len

 
 -- Toooooo long name for a function...
 waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h
                                             ⇒ Context h
 
 -- Toooooo long name for a function...
 waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h
                                             ⇒ Context h

-                                            → Interaction
+                                            → NormalInteraction
+                                            → ThreadId

                                             → Lazy.ByteString
                                             → IO ()
                                             → Lazy.ByteString
                                             → IO ()

-waitForReceiveChunkedBodyReqForTheFirstTime ctx itr@(Interaction {..}) input
+waitForReceiveChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) rsrcTid input

     = join $
       atomically $
     = join $
       atomically $

-      do req ← takeTMVar itrReceiveBodyReq
+      do req ← takeTMVar niReceiveBodyReq

          case req of
            ReceiveBody wanted
          case req of
            ReceiveBody wanted

-               → do putTMVar itrSendContinue $ fromJust itrExpectedContinue
-                    return $ readCurrentChunk ctx itr input Initial wanted
+               → do putTMVar niSendContinue niExpectedContinue
+                    return $ readCurrentChunk ctx ni rsrcTid wanted input Initial

            WasteAll
            WasteAll

-               → do putTMVar itrSendContinue False
-                    return $ wasteAllChunks ctx itr input Initial
+               → do putTMVar niSendContinue False
+                    return $ wasteAllChunks ctx rsrcTid input Initial

 
 waitForReceiveChunkedBodyReq ∷ HandleLike h
                              ⇒ Context h
 
 waitForReceiveChunkedBodyReq ∷ HandleLike h
                              ⇒ Context h

-                             → Interaction
+                             → NormalInteraction
+                             → ThreadId

                              → Lazy.ByteString
                              → ChunkReceivingState
                              → IO ()
                              → Lazy.ByteString
                              → ChunkReceivingState
                              → IO ()

-waitForReceiveChunkedBodyReq ctx itr@(Interaction {..}) input st
-    = do req ← atomically $ takeTMVar itrReceiveBodyReq
+waitForReceiveChunkedBodyReq ctx ni@(NI {..}) rsrcTid input st
+    = do req ← atomically $ takeTMVar niReceiveBodyReq

          case req of
            ReceiveBody wanted
          case req of
            ReceiveBody wanted

-               → readCurrentChunk ctx itr input st wanted
+               → readCurrentChunk ctx ni rsrcTid wanted input st

            WasteAll
            WasteAll

-               → wasteAllChunks ctx itr input st
+               → wasteAllChunks ctx rsrcTid input st

 
 wasteAllChunks ∷ HandleLike h
                ⇒ Context h
 
 wasteAllChunks ∷ HandleLike h
                ⇒ Context h

-               → Interaction
+               → ThreadId

                → Lazy.ByteString
                → ChunkReceivingState
                → IO ()
                → Lazy.ByteString
                → ChunkReceivingState
                → IO ()

-wasteAllChunks ctx itr = go
+wasteAllChunks ctx rsrcTid = go

     where
       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
       go input Initial
     where
       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
       go input Initial


@@ -233,8 +209,9 @@ wasteAllChunks ctx itr = go
               LP.Done input' chunkLen
                   | chunkLen ≡ 0 → gotFinalChunk input'
                   | otherwise    → gotChunk input' chunkLen
               LP.Done input' chunkLen
                   | chunkLen ≡ 0 → gotFinalChunk input'
                   | otherwise    → gotChunk input' chunkLen

-              LP.Fail _ _ _
-                  → chunkWasMalformed itr
+              LP.Fail _ _ msg
+                  → chunkWasMalformed rsrcTid
+                        $ "wasteAllChunks: chunkHeaderP: " ⧺ msg

       go input (InChunk chunkLen)
           = gotChunk input chunkLen
 
       go input (InChunk chunkLen)
           = gotChunk input chunkLen
 


@@ -245,30 +222,28 @@ wasteAllChunks ctx itr = go
               case LP.parse chunkFooterP input' of
                 LP.Done input'' _
                     → go input'' Initial
               case LP.parse chunkFooterP input' of
                 LP.Done input'' _
                     → go input'' Initial

-                LP.Fail _ _ _
-                    → chunkWasMalformed itr
+                LP.Fail _ _ msg
+                    → chunkWasMalformed rsrcTid
+                          $ "wasteAllChunks: chunkFooterP: " ⧺ msg

 
       gotFinalChunk ∷ Lazy.ByteString → IO ()
       gotFinalChunk input
 
       gotFinalChunk ∷ Lazy.ByteString → IO ()
       gotFinalChunk input

-          = case LP.parse chunkFooterP input of
+          = case LP.parse chunkTrailerP input of

               LP.Done input' _
               LP.Done input' _

-                  → case LP.parse chunkTrailerP input' of
-                       LP.Done input'' _
-                           → acceptRequest ctx input''
-                       LP.Fail _ _ _
-                           → chunkWasMalformed itr
-              LP.Fail _ _ _
-                  → chunkWasMalformed itr
+                  → acceptRequest ctx input'
+              LP.Fail _ _ msg
+                  → chunkWasMalformed rsrcTid
+                        $ "wasteAllChunks: chunkTrailerP: " ⧺ msg

 
 readCurrentChunk ∷ HandleLike h
                  ⇒ Context h
 
 readCurrentChunk ∷ HandleLike h
                  ⇒ Context h

-                 → Interaction
+                 → NormalInteraction
+                 → ThreadId
+                 → Int

                  → Lazy.ByteString
                  → ChunkReceivingState
                  → Lazy.ByteString
                  → ChunkReceivingState

-                 → Int

                  → IO ()
                  → IO ()

-readCurrentChunk ctx itr@(Interaction {..}) input0 st0 wanted
-    = go input0 st0
+readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go

     where
       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
       go input Initial
     where
       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
       go input Initial


@@ -278,8 +253,9 @@ readCurrentChunk ctx itr@(Interaction {..}) input0 st0 wanted
                       → gotFinalChunk input'
                   | otherwise
                       → gotChunk input' chunkLen
                       → gotFinalChunk input'
                   | otherwise
                       → gotChunk input' chunkLen

-              LP.Fail _ _ _
-                  → chunkWasMalformed itr
+              LP.Fail _ _ msg
+                  → chunkWasMalformed rsrcTid
+                        $ "readCurrentChunk: chunkHeaderP: " ⧺ msg

       go input (InChunk chunkLen)
           = gotChunk input chunkLen
 
       go input (InChunk chunkLen)
           = gotChunk input chunkLen
 


@@ -290,67 +266,64 @@ readCurrentChunk ctx itr@(Interaction {..}) input0 st0 wanted
                    block'          = Strict.concat $ Lazy.toChunks block
                    actualReadBytes = Strict.length block'
                    chunkLen'       = chunkLen - actualReadBytes
                    block'          = Strict.concat $ Lazy.toChunks block
                    actualReadBytes = Strict.length block'
                    chunkLen'       = chunkLen - actualReadBytes

-               atomically $ putTMVar itrReceivedBody block'
+               atomically $ putTMVar niReceivedBody block'

                if chunkLen' ≡ 0 then
                    case LP.parse chunkFooterP input' of
                      LP.Done input'' _
                if chunkLen' ≡ 0 then
                    case LP.parse chunkFooterP input' of
                      LP.Done input'' _

-                         → waitForReceiveChunkedBodyReq ctx itr input'' Initial
-                     LP.Fail _ _ _
-                         → chunkWasMalformed itr
+                         → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial
+                     LP.Fail _ _ msg
+                         → chunkWasMalformed rsrcTid
+                               $ "readCurrentChunk: chunkFooterP: " ⧺ msg

                else
                else

-                   waitForReceiveChunkedBodyReq ctx itr input' $ InChunk chunkLen'
+                   waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen'

 
       gotFinalChunk ∷ Lazy.ByteString → IO ()
       gotFinalChunk input
 
       gotFinalChunk ∷ Lazy.ByteString → IO ()
       gotFinalChunk input

-          = do atomically $ putTMVar itrReceivedBody (∅)
-               case LP.parse chunkFooterP input of
+          = do atomically $ putTMVar niReceivedBody (∅)
+               case LP.parse chunkTrailerP input of

                  LP.Done input' _
                  LP.Done input' _

-                     → case LP.parse chunkTrailerP input' of
-                          LP.Done input'' _
-                              → acceptRequest ctx input''
-                          LP.Fail _ _ _
-                              → chunkWasMalformed itr
-                 LP.Fail _ _ _
-                     → chunkWasMalformed itr
+                     → acceptRequest ctx input'
+                 LP.Fail _ _ msg
+                     → chunkWasMalformed rsrcTid
+                           $ "readCurrentChunk: chunkTrailerP: " ⧺ msg

 
 

-chunkWasMalformed ∷ Interaction → IO ()
-chunkWasMalformed itr
-    -- FIXME: This is a totally wrong way to abort!
-    = atomically $
-      do setResponseStatus itr BadRequest
-         writeTVar (itrWillClose itr) True
-         writeTVar (itrState     itr) Done
-         postprocess itr
+chunkWasMalformed ∷ ThreadId → String → IO ()
+chunkWasMalformed tid msg
+    = let abo = mkAbortion BadRequest [("Connection", "close")]
+                $ Just
+                $ "chunkWasMalformed: " ⊕ T.pack msg
+      in
+        throwTo tid abo

 
 waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h
                                                ⇒ Context h
 
 waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h
                                                ⇒ Context h

-                                               → Interaction
+                                               → NormalInteraction

                                                → Lazy.ByteString
                                                → Int
                                                → IO ()
                                                → Lazy.ByteString
                                                → Int
                                                → IO ()

-waitForReceiveNonChunkedBodyReqForTheFirstTime ctx itr@(Interaction {..}) input bodyLen
+waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) input bodyLen

     = join $
       atomically $
     = join $
       atomically $

-      do req ← takeTMVar itrReceiveBodyReq
+      do req ← takeTMVar niReceiveBodyReq

          case req of
            ReceiveBody wanted
          case req of
            ReceiveBody wanted

-               → do putTMVar itrSendContinue $ fromJust itrExpectedContinue
-                    return $ readNonChunkedRequestBody ctx itr input bodyLen wanted
+               → do putTMVar niSendContinue niExpectedContinue
+                    return $ readNonChunkedRequestBody ctx ni input bodyLen wanted

            WasteAll
            WasteAll

-               → do putTMVar itrSendContinue False
+               → do putTMVar niSendContinue False

                     return $ wasteNonChunkedRequestBody ctx input bodyLen
 
 waitForReceiveNonChunkedBodyReq ∷ HandleLike h
                                 ⇒ Context h
                     return $ wasteNonChunkedRequestBody ctx input bodyLen
 
 waitForReceiveNonChunkedBodyReq ∷ HandleLike h
                                 ⇒ Context h

-                                → Interaction
+                                → NormalInteraction

                                 → Lazy.ByteString
                                 → Int
                                 → IO ()
                                 → Lazy.ByteString
                                 → Int
                                 → IO ()

-waitForReceiveNonChunkedBodyReq ctx itr@(Interaction {..}) input bodyLen
-    = do req ← atomically $ takeTMVar itrReceiveBodyReq
+waitForReceiveNonChunkedBodyReq ctx ni@(NI {..}) input bodyLen
+    = do req ← atomically $ takeTMVar niReceiveBodyReq

          case req of
            ReceiveBody wanted
          case req of
            ReceiveBody wanted

-               → readNonChunkedRequestBody ctx itr input bodyLen wanted
+               → readNonChunkedRequestBody ctx ni input bodyLen wanted

            WasteAll
                → wasteNonChunkedRequestBody ctx input bodyLen
 
            WasteAll
                → wasteNonChunkedRequestBody ctx input bodyLen
 


@@ -365,12 +338,12 @@ wasteNonChunkedRequestBody ctx input bodyLen
 
 readNonChunkedRequestBody ∷ HandleLike h
                           ⇒ Context h
 
 readNonChunkedRequestBody ∷ HandleLike h
                           ⇒ Context h

-                          → Interaction
+                          → NormalInteraction

                           → Lazy.ByteString
                           → Int
                           → Int
                           → IO ()
                           → Lazy.ByteString
                           → Int
                           → Int
                           → IO ()

-readNonChunkedRequestBody ctx itr@(Interaction {..}) input bodyLen wanted
+readNonChunkedRequestBody ctx ni@(NI {..}) input bodyLen wanted

     | bodyLen ≡ 0 = gotEndOfRequest
     | otherwise   = gotBody
     where
     | bodyLen ≡ 0 = gotEndOfRequest
     | otherwise   = gotBody
     where


@@ -381,15 +354,17 @@ readNonChunkedRequestBody ctx itr@(Interaction {..}) input bodyLen wanted
                    block'          = Strict.concat $ Lazy.toChunks block
                    actualReadBytes = Strict.length block'
                    bodyLen'        = bodyLen - actualReadBytes
                    block'          = Strict.concat $ Lazy.toChunks block
                    actualReadBytes = Strict.length block'
                    bodyLen'        = bodyLen - actualReadBytes

-               atomically $ putTMVar itrReceivedBody block'
-               waitForReceiveNonChunkedBodyReq ctx itr input' bodyLen'
+               atomically $ putTMVar niReceivedBody block'
+               waitForReceiveNonChunkedBodyReq ctx ni input' bodyLen'

 
       gotEndOfRequest ∷ IO ()
       gotEndOfRequest
 
       gotEndOfRequest ∷ IO ()
       gotEndOfRequest

-          = do atomically $ putTMVar itrReceivedBody (∅)
+          = do atomically $ putTMVar niReceivedBody (∅)

                acceptRequest ctx input
 
                acceptRequest ctx input
 

-enqueue ∷ HandleLike h ⇒ Context h → Interaction → STM ()
+enqueue ∷ (HandleLike h, Interaction i) ⇒ Context h → i → IO ()
+{-# INLINEABLE enqueue #-}

 enqueue (Context {..}) itr
 enqueue (Context {..}) itr

-    = do queue ← readTVar cQueue
-         writeTVar cQueue (itr ⊲ queue)
+    = atomically $
+      do queue ← readTVar cQueue
+         writeTVar cQueue (toInteraction itr ⊲ queue)

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 085b677b3f37685694ddd3ebec8d464f457d72d1..314e1f55972c1ac40d26deaadeb64602fbb1df12 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -255,8 +255,8 @@ getAccept
            Just accept
                → case P.parseOnly p (A.toByteString accept) of
                     Right xs → return xs
            Just accept
                → case P.parseOnly p (A.toByteString accept) of
                     Right xs → return xs

-                    Left  _  → abort BadRequest []
-                               (Just $ "Unparsable Accept: " ⊕ A.toText accept)
+                    Left  _  → abort $ mkAbortion' BadRequest
+                                     $ "Unparsable Accept: " ⊕ A.toText accept

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


@@ -278,8 +278,8 @@ getAcceptEncoding
                     case ver of
                       HttpVersion 1 0 → return [("identity", Nothing)]
                       HttpVersion 1 1 → return [("*"       , Nothing)]
                     case ver of
                       HttpVersion 1 0 → return [("identity", Nothing)]
                       HttpVersion 1 1 → return [("*"       , Nothing)]

-                      _               → abort InternalServerError []
-                                        (Just "getAcceptEncoding: unknown HTTP version")
+                      _               → abort $ mkAbortion' InternalServerError
+                                                "getAcceptEncoding: unknown HTTP version"

            Just ae
                → if ae ≡ "" then
                       -- identity のみが許される。
            Just ae
                → if ae ≡ "" then
                       -- identity のみが許される。


@@ -287,8 +287,8 @@ getAcceptEncoding
                  else
                      case P.parseOnly p (A.toByteString ae) of
                        Right xs → return $ map toTuple $ reverse $ sort xs
                  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)
+                       Left  _  → abort $ mkAbortion' BadRequest
+                                        $ "Unparsable Accept-Encoding: " ⊕ A.toText ae

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


@@ -314,8 +314,8 @@ getContentType
            Just cType
                → case P.parseOnly p (A.toByteString cType) of
                     Right t → return $ Just t
            Just cType
                → case P.parseOnly p (A.toByteString cType) of
                     Right t → return $ Just t

-                    Left  _ → abort BadRequest []
-                              (Just $ "Unparsable Content-Type: " ⊕ A.toText cType)
+                    Left  _ → abort $ mkAbortion' BadRequest
+                                    $ "Unparsable Content-Type: " ⊕ A.toText cType

     where
       p = do t ← mimeTypeP
              P.endOfInput
     where
       p = do t ← mimeTypeP
              P.endOfInput


@@ -360,8 +360,9 @@ foundEntity tag timeStamp
          when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
          when (method ≡ POST)
          when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
          when (method ≡ POST)

-             $ abort InternalServerError []
-               (Just "foundEntity: this is a POST request.")
+             $ abort
+             $ mkAbortion' InternalServerError
+               "foundEntity: this is a POST request."

          foundETag tag
 
          driftTo ReceivingBody
          foundETag tag
 
          driftTo ReceivingBody


@@ -383,8 +384,9 @@ foundETag tag
              $ A.fromAsciiBuilder
              $ printETag tag
          when (method ≡ POST)
              $ A.fromAsciiBuilder
              $ printETag tag
          when (method ≡ POST)

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

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


@@ -398,13 +400,12 @@ foundETag tag
                                   -- tags の中に一致するものが無ければ
                                   -- PreconditionFailed で終了。
                                   → when ((¬) (any (≡ tag) tags))
                                   -- tags の中に一致するものが無ければ
                                   -- PreconditionFailed で終了。
                                   → when ((¬) (any (≡ tag) tags))

-                                        $ abort PreconditionFailed []
-                                        $ Just
+                                        $ abort
+                                        $ mkAbortion' PreconditionFailed

                                         $ "The entity tag doesn't match: " ⊕ A.toText value
                               Left _
                                         $ "The entity tag doesn't match: " ⊕ A.toText value
                               Left _

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

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


@@ -417,18 +418,18 @@ 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: *")
+                            abort $ mkAbortion' statusForNoneMatch
+                                  $ "The entity tag matches: *"

                         else
                             case P.parseOnly p (A.toByteString value) of
                               Right tags
                                   → when (any (≡ tag) tags)
                         else
                             case P.parseOnly p (A.toByteString value) of
                               Right tags
                                   → when (any (≡ tag) tags)

-                                        $ abort statusForNoneMatch []
-                                        $ Just
+                                        $ abort
+                                        $ mkAbortion' statusForNoneMatch

                                         $ "The entity tag matches: " ⊕ A.toText value
                               Left _
                                         $ "The entity tag matches: " ⊕ A.toText value
                               Left _

-                                  → abort BadRequest []
-                                    $ Just
-                                    $ "Unparsable If-None-Match: " ⊕ A.toText value
+                                  → abort $ mkAbortion' BadRequest
+                                          $ "Unparsable If-None-Match: " ⊕ A.toText value

 
          driftTo ReceivingBody
     where
 
          driftTo ReceivingBody
     where


@@ -454,8 +455,9 @@ foundTimeStamp timeStamp
          when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
          when (method ≡ POST)
          when (method ≡ GET ∨ method ≡ HEAD)
              $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
          when (method ≡ POST)

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

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


@@ -469,8 +471,9 @@ foundTimeStamp timeStamp
            Just str → case HTTP.fromAscii str of
                          Right lastTime
                              → when (timeStamp ≤ lastTime)
            Just str → case HTTP.fromAscii str of
                          Right lastTime
                              → when (timeStamp ≤ lastTime)

-                               $ abort statusForIfModSince []
-                                 (Just $ "The entity has not been modified since " ⊕ A.toText str)
+                               $ abort
+                               $ mkAbortion' statusForIfModSince
+                               $ "The entity has not been modified since " ⊕ A.toText str

                          Left _
                              → return () -- 不正な時刻は無視
            Nothing  → return ()
                          Left _
                              → return () -- 不正な時刻は無視
            Nothing  → return ()


@@ -481,8 +484,9 @@ foundTimeStamp timeStamp
            Just str → case HTTP.fromAscii str of
                          Right lastTime
                              → when (timeStamp > lastTime)
            Just str → case HTTP.fromAscii str of
                          Right lastTime
                              → when (timeStamp > lastTime)

-                               $ abort PreconditionFailed []
-                                 (Just $ "The entity has not been modified since " ⊕ A.toText str)
+                               $ abort
+                               $ mkAbortion' PreconditionFailed
+                               $ "The entity has not been modified since " ⊕ A.toText str

                          Left _
                              → return () -- 不正な時刻は無視
            Nothing  → return ()
                          Left _
                              → return () -- 不正な時刻は無視
            Nothing  → return ()


@@ -503,13 +507,15 @@ foundNoEntity msgM
 
          method ← getMethod
          when (method ≢ PUT)
 
          method ← getMethod
          when (method ≢ PUT)

-             $ abort NotFound [] msgM
+             $ abort
+             $ mkAbortion NotFound [] msgM

 
          -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
          -- If-Match: 條件も滿たさない。
          ifMatch ← getHeader "If-Match"
          when (ifMatch ≢ Nothing)
 
          -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
          -- If-Match: 條件も滿たさない。
          ifMatch ← getHeader "If-Match"
          when (ifMatch ≢ Nothing)

-             $ abort PreconditionFailed [] msgM
+             $ abort
+             $ mkAbortion PreconditionFailed [] msgM

 
          driftTo ReceivingBody
 
 
          driftTo ReceivingBody
 


@@ -539,10 +545,15 @@ getChunks' ∷ Int → Resource Lazy.ByteString
 getChunks' limit = go limit (∅)
     where
       go ∷ Int → Seq Strict.ByteString → Resource Lazy.ByteString
 getChunks' limit = go limit (∅)
     where
       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
+      go 0 _  = do chunk ← getChunk 1
+                   if Strict.null chunk then
+                       return (∅)
+                   else
+                       abort $ mkAbortion' RequestEntityTooLarge
+                             $ "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
                    chunk ← getChunk n'
                    if Strict.null chunk then
                        -- Got EOF


@@ -570,18 +581,17 @@ getForm limit
     = do cTypeM ← getContentType
          case cTypeM of
            Nothing
     = do cTypeM ← getContentType
          case cTypeM of
            Nothing

-               → abort BadRequest [] (Just "Missing Content-Type")
+               → abort $ mkAbortion' BadRequest "Missing Content-Type"

            Just (MIMEType "application" "x-www-form-urlencoded" _)
                → readWWWFormURLEncoded
            Just (MIMEType "multipart" "form-data" params)
                → readMultipartFormData params
            Just cType
            Just (MIMEType "application" "x-www-form-urlencoded" _)
                → readWWWFormURLEncoded
            Just (MIMEType "multipart" "form-data" params)
                → readMultipartFormData params
            Just cType

-               → abort UnsupportedMediaType []
-                 $ Just
-                 $ A.toText
-                 $ A.fromAsciiBuilder
-                 $ A.toAsciiBuilder "Unsupported media type: "
-                 ⊕ printMIMEType cType
+               → abort $ mkAbortion' UnsupportedMediaType
+                       $ A.toText
+                       $ A.fromAsciiBuilder
+                       $ A.toAsciiBuilder "Unsupported media type: "
+                       ⊕ printMIMEType cType

     where
       readWWWFormURLEncoded
           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
     where
       readWWWFormURLEncoded
           = (map toPairWithFormData ∘ parseWWWFormURLEncoded)


@@ -591,22 +601,22 @@ getForm limit
       bsToAscii bs
           = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
               Just a  → return a
       bsToAscii bs
           = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
               Just a  → return a

-              Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded")
+              Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"

 
       readMultipartFormData params
 
       readMultipartFormData params

-          = do case M.lookup "boundary" params of
-                 Nothing
-                     → abort BadRequest [] (Just "Missing boundary of multipart/form-data")
-                 Just boundary
-                     → do src ← getChunks limit
-                          b   ← case A.fromText boundary of
-                                   Just b  → return b
-                                   Nothing → abort BadRequest []
-                                             (Just $ "Malformed boundary: " ⊕ boundary)
-                          case LP.parse (p b) src of
-                            LP.Done _ formList
-                                → return formList
-                            _   → abort BadRequest [] (Just "Unparsable multipart/form-data")
+          = case M.lookup "boundary" params of
+              Nothing
+                  → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
+              Just boundary
+                  → do src ← getChunks limit
+                       b   ← case A.fromText boundary of
+                                Just b  → return b
+                                Nothing → abort $ mkAbortion' BadRequest
+                                                $ "Malformed boundary: " ⊕ boundary
+                       case LP.parse (p b) src of
+                         LP.Done _ formList
+                             → return formList
+                         _   → abort $ mkAbortion' BadRequest "Unparsable multipart/form-data"

           where
             p b = do xs ← multipartFormP b
                      P.endOfInput
           where
             p b = do xs ← multipartFormP b
                      P.endOfInput


@@ -618,8 +628,8 @@ getForm limit
 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))

-             $ abort InternalServerError []
-             $ Just
+             $ abort
+             $ mkAbortion' InternalServerError

              $ A.toText
              $ A.fromAsciiBuilder
              $ A.toAsciiBuilder "Attempted to redirect with status "
              $ A.toText
              $ A.fromAsciiBuilder
              $ A.toAsciiBuilder "Attempted to redirect with status "


@@ -640,8 +650,8 @@ setLocation ∷ URI → Resource ()
 setLocation uri
     = case A.fromChars uriStr of
         Just a  → setHeader "Location" a
 setLocation uri
     = case A.fromChars uriStr of
         Just a  → setHeader "Location" a

-        Nothing → abort InternalServerError []
-                  (Just $ "Malformed URI: " ⊕ T.pack uriStr)
+        Nothing → abort $ mkAbortion' InternalServerError
+                        $ "Malformed URI: " ⊕ T.pack uriStr

     where
       uriStr = uriToString id uri ""
 
     where
       uriStr = uriToString id uri ""
 


@@ -653,8 +663,8 @@ setContentEncoding codings
          tr  ← case ver of
                   HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
                   HttpVersion 1 1 → return toAB
          tr  ← case ver of
                   HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
                   HttpVersion 1 1 → return toAB

-                  _               → abort InternalServerError []
-                                    (Just "setContentEncoding: Unknown HTTP version")
+                  _               → abort $ mkAbortion' InternalServerError
+                                            "setContentEncoding: Unknown HTTP version"

          setHeader "Content-Encoding"
                    (A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
     where
          setHeader "Content-Encoding"
                    (A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
     where

diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs
index 1d01a8258751af7a73a4a17ee26a0dd41fd17153..a1ad95674aefc46e360dd86d221c061439137f4a 100644 (file)
--- a/Network/HTTP/Lucu/Resource/Internal.hs
+++ b/Network/HTTP/Lucu/Resource/Internal.hs
@@ -35,6 +35,7 @@ import Control.Concurrent.STM
 import Control.Exception
 import Control.Monad.IO.Class
 import Control.Monad.Reader
 import Control.Exception
 import Control.Monad.IO.Class
 import Control.Monad.Reader

+import Control.Monad.Unicode

 import Data.Ascii (Ascii, CIAscii)
 import qualified Data.Ascii as A
 import qualified Data.ByteString as Strict
 import Data.Ascii (Ascii, CIAscii)
 import qualified Data.Ascii as A
 import qualified Data.ByteString as Strict


@@ -43,6 +44,7 @@ import Data.Maybe
 import Data.Monoid.Unicode
 import qualified Data.Text as T
 import Network.HTTP.Lucu.Abortion
 import Data.Monoid.Unicode
 import qualified Data.Text as T
 import Network.HTTP.Lucu.Abortion

+import Network.HTTP.Lucu.Abortion.Internal

 import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.DefaultPage
 import qualified Network.HTTP.Lucu.Headers as H
 import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.DefaultPage
 import qualified Network.HTTP.Lucu.Headers as H


@@ -61,11 +63,11 @@ import System.IO
 -- any 'IO' actions.
 newtype Resource a
     = Resource {
 -- any 'IO' actions.
 newtype Resource a
     = Resource {

-        unResource ∷ ReaderT Interaction IO a
+        unResource ∷ ReaderT NormalInteraction IO a

       }
     deriving (Applicative, Functor, Monad, MonadIO)
 
       }
     deriving (Applicative, Functor, Monad, MonadIO)
 

-runResource ∷ Resource a → Interaction → IO a
+runResource ∷ Resource a → NormalInteraction → IO a

 runResource = runReaderT ∘ unResource
 
 -- |'ResourceDef' is basically a set of 'Resource' monads for each
 runResource = runReaderT ∘ unResource
 
 -- |'ResourceDef' is basically a set of 'Resource' monads for each


@@ -137,8 +139,8 @@ emptyResource = ResourceDef {
                 , resDelete           = Nothing
                 }
 
                 , resDelete           = Nothing
                 }
 

-spawnResource ∷ ResourceDef → Interaction → IO ThreadId
-spawnResource (ResourceDef {..}) itr@(Interaction {..})
+spawnResource ∷ ResourceDef → NormalInteraction → IO ThreadId
+spawnResource (ResourceDef {..}) ni@(NI {..})

     = fork $ run `catch` processException
     where
       fork ∷ IO () → IO ThreadId
     = fork $ run `catch` processException
     where
       fork ∷ IO () → IO ThreadId


@@ -146,7 +148,7 @@ spawnResource (ResourceDef {..}) itr@(Interaction {..})
            | otherwise           = forkIO
 
       run ∷ IO ()
            | otherwise           = forkIO
 
       run ∷ IO ()

-      run = flip runResource itr $
+      run = flip runResource ni $

             do req ← getRequest
                fromMaybe notAllowed $ rsrc req
                driftTo Done
             do req ← getRequest
                fromMaybe notAllowed $ rsrc req
                driftTo Done


@@ -188,26 +190,26 @@ spawnResource (ResourceDef {..}) itr@(Interaction {..})
       toAbortion e
           = case fromException e of
               Just abortion → abortion
       toAbortion e
           = case fromException e of
               Just abortion → abortion

-              Nothing       → Abortion InternalServerError (∅) (Just $ T.pack $ show e)
+              Nothing       → mkAbortion' InternalServerError $ T.pack $ show e

 
       processException ∷ SomeException → IO ()
       processException exc
           = do let abo = toAbortion exc
 
       processException ∷ SomeException → IO ()
       processException exc
           = do let abo = toAbortion exc

-               state ← atomically $ readTVar itrState
-               res   ← atomically $ readTVar itrResponse
+               state ← atomically $ readTVar niState
+               res   ← atomically $ readTVar niResponse

                if state ≤ DecidingHeader then
                    -- We still have a chance to reflect this abortion
                    -- in the response. Hooray!
                if state ≤ DecidingHeader then
                    -- We still have a chance to reflect this abortion
                    -- in the response. Hooray!

-                   flip runResource itr $
+                   flip runResource ni $

                        do setStatus $ aboStatus abo
                        do setStatus $ aboStatus abo

+                          mapM_ (uncurry setHeader) $ H.fromHeaders $ aboHeaders abo

                           setHeader "Content-Type" defaultPageContentType
                           deleteHeader "Content-Encoding"
                           setHeader "Content-Type" defaultPageContentType
                           deleteHeader "Content-Encoding"

-                          mapM_ (uncurry setHeader) $ H.fromHeaders $ aboHeaders abo
-                          putBuilder $ abortPage itrConfig itrRequest res abo
+                          putBuilder $ abortPage niConfig (Just niRequest) res abo

                else
                else

-                   when (cnfDumpTooLateAbortionToStderr itrConfig)
+                   when (cnfDumpTooLateAbortionToStderr niConfig)

                        $ dumpAbortion abo
                        $ dumpAbortion abo

-               runResource (driftTo Done) itr
+               runResource (driftTo Done) ni

 
 dumpAbortion ∷ Abortion → IO ()
 dumpAbortion abo
 
 dumpAbortion ∷ Abortion → IO ()
 dumpAbortion abo


@@ -217,16 +219,16 @@ dumpAbortion abo
                , "  ", show abo, "\n"
                ]
 
                , "  ", show abo, "\n"
                ]
 

-getInteraction ∷ Resource Interaction
+getInteraction ∷ Resource NormalInteraction

 getInteraction = Resource ask
 
 -- |Get the 'Config' value for this httpd.
 getConfig ∷ Resource Config
 getInteraction = Resource ask
 
 -- |Get the 'Config' value for this httpd.
 getConfig ∷ Resource Config

-getConfig = itrConfig <$> getInteraction
+getConfig = niConfig <$> getInteraction

 
 -- |Get the 'SockAddr' of the remote host.
 getRemoteAddr ∷ Resource SockAddr
 
 -- |Get the 'SockAddr' of the remote host.
 getRemoteAddr ∷ Resource SockAddr

-getRemoteAddr = itrRemoteAddr <$> getInteraction
+getRemoteAddr = niRemoteAddr <$> getInteraction

 
 -- | Return the X.509 certificate of the client, or 'Nothing' if:
 --
 
 -- | Return the X.509 certificate of the client, or 'Nothing' if:
 --


@@ -238,12 +240,12 @@ getRemoteAddr = itrRemoteAddr <$> getInteraction
 --   'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
 --   'OpenSSL.Session.VerifyPeer'.
 getRemoteCertificate ∷ Resource (Maybe X509)
 --   'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
 --   'OpenSSL.Session.VerifyPeer'.
 getRemoteCertificate ∷ Resource (Maybe X509)

-getRemoteCertificate = itrRemoteCert <$> getInteraction
+getRemoteCertificate = niRemoteCert <$> getInteraction

 
 -- |Return the 'Request' value representing the request header. You
 -- usually don't need to call this function directly.
 getRequest ∷ Resource Request
 
 -- |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 = niRequest <$> getInteraction

 
 -- |Get the path of this 'Resource' (to be exact, 'ResourceDef') in
 -- the 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
 
 -- |Get the path of this 'Resource' (to be exact, 'ResourceDef') in
 -- the 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this


@@ -267,7 +269,7 @@ getRequest = (fromJust ∘ itrRequest) <$> getInteraction
 -- >   , ...
 -- >   }
 getResourcePath ∷ Resource [Strict.ByteString]
 -- >   , ...
 -- >   }
 getResourcePath ∷ Resource [Strict.ByteString]

-getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction
+getResourcePath = niResourcePath <$> getInteraction

 
 -- |@'getChunk' n@ attempts to read a chunk of request body up to @n@
 -- bytes. You can incrementally read the request body by repeatedly
 
 -- |@'getChunk' n@ attempts to read a chunk of request body up to @n@
 -- bytes. You can incrementally read the request body by repeatedly


@@ -283,20 +285,19 @@ getChunk' n
     | n ≡ 0     = return (∅)
     | otherwise = do req ← getRequest
                      if reqMustHaveBody req then
     | n ≡ 0     = return (∅)
     | otherwise = do req ← getRequest
                      if reqMustHaveBody req then

-                         do itr ← getInteraction
-                            askForInput itr
+                         askForInput =≪ getInteraction

                      else
                          driftTo DecidingHeader *> return (∅)
     where
                      else
                          driftTo DecidingHeader *> return (∅)
     where

-      askForInput ∷ Interaction → Resource Strict.ByteString
-      askForInput (Interaction {..})
+      askForInput ∷ NormalInteraction → Resource Strict.ByteString
+      askForInput (NI {..})

           = do -- Ask the RequestReader to get a chunk.
                liftIO $ atomically
           = do -- Ask the RequestReader to get a chunk.
                liftIO $ atomically

-                      $ putTMVar itrReceiveBodyReq (ReceiveBody n)
+                      $ putTMVar niReceiveBodyReq (ReceiveBody n)

                -- Then wait for a reply.
                chunk ← liftIO
                        $ atomically
                -- Then wait for a reply.
                chunk ← liftIO
                        $ atomically

-                       $ takeTMVar itrReceivedBody
+                       $ takeTMVar niReceivedBody

                -- Have we got an EOF?
                when (Strict.null chunk)
                    $ driftTo DecidingHeader
                -- Have we got an EOF?
                when (Strict.null chunk)
                    $ driftTo DecidingHeader


@@ -306,12 +307,12 @@ getChunk' n
 -- 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 itr ← getInteraction
+    = do ni ← getInteraction

          liftIO $ atomically
          liftIO $ atomically

-                $ do state ← readTVar $ itrState itr
+                $ do state ← readTVar $ niState ni

                      when (state > DecidingHeader)
                          $ fail "Too late to declare the response status."
                      when (state > DecidingHeader)
                          $ fail "Too late to declare the response status."

-                     setResponseStatus itr sc
+                     setResponseStatus ni sc

 
 -- |@'setHeader' name value@ declares the value of the response header
 -- @name@ as @value@. Note that this function is not intended to be
 
 -- |@'setHeader' name value@ declares the value of the response header
 -- @name@ as @value@. Note that this function is not intended to be


@@ -330,31 +331,35 @@ setStatus sc
 -- of the next response.
 setHeader ∷ CIAscii → Ascii → Resource ()
 setHeader name value
 -- of the next response.
 setHeader ∷ CIAscii → Ascii → Resource ()
 setHeader name value

-    = do itr ← getInteraction
-         liftIO $ atomically
-                $ 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
+    = do ni ← getInteraction
+         liftIO $ atomically $ go ni
+    where
+      go ∷ NormalInteraction → STM ()
+      go (NI {..})
+          = do state ← readTVar niState
+               when (state > DecidingHeader) $
+                   fail "Too late to declare a response header field."
+               res ← readTVar niResponse
+               writeTVar niResponse $ H.setHeader name value res
+               when (name ≡ "Content-Type") $
+                   writeTVar niResponseHasCType 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
 
 -- |@'deleteHeader' name@ deletes a response header @name@ if
 -- any. This function is not intended to be used so frequently.
 deleteHeader ∷ CIAscii → Resource ()
 deleteHeader name

-    = do itr ← getInteraction
-         liftIO $ atomically
-                $ 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
+    = do ni ← getInteraction
+         liftIO $ atomically $ go ni
+    where
+      go ∷ NormalInteraction → STM ()
+      go (NI {..})
+          = do state ← readTVar niState
+               when (state > DecidingHeader) $
+                   fail "Too late to delete a response header field."
+               res ← readTVar niResponse
+               writeTVar niResponse $ H.deleteHeader name res
+               when (name ≡ "Content-Type") $
+                   writeTVar niResponseHasCType 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
 
 -- |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


@@ -365,23 +370,27 @@ deleteHeader name
 -- 'setContentType'.
 putBuilder ∷ Builder → Resource ()
 putBuilder b
 -- 'setContentType'.
 putBuilder ∷ Builder → Resource ()
 putBuilder b

-    = do itr ← getInteraction
-         liftIO $ atomically
-                $ do driftTo' itr SendingBody
-                     hasCType ← readTVar $ itrResponseHasCType itr
-                     unless hasCType
-                         $ abortSTM InternalServerError []
-                         $ Just "putBuilder: Content-Type has not been set."
-                     putTMVar (itrBodyToSend itr) b
+    = do ni ← getInteraction
+         liftIO $ atomically $ go ni
+    where
+      go ∷ NormalInteraction → STM ()
+      go ni@(NI {..})
+          = do driftTo' ni SendingBody
+               hasCType ← readTVar niResponseHasCType
+               unless hasCType
+                   $ throwSTM
+                   $ mkAbortion' InternalServerError
+                     "putBuilder: Content-Type has not been set."
+               putTMVar niBodyToSend b

 
 driftTo ∷ InteractionState → Resource ()
 driftTo newState
 
 driftTo ∷ InteractionState → Resource ()
 driftTo newState

-    = do itr ← getInteraction
-         liftIO $ atomically $ driftTo' itr newState
+    = do ni ← getInteraction
+         liftIO $ atomically $ driftTo' ni newState

 
 

-driftTo' ∷ Interaction → InteractionState → STM ()
-driftTo' itr@(Interaction {..}) newState
-    = do oldState ← readTVar itrState
+driftTo' ∷ NormalInteraction → InteractionState → STM ()
+driftTo' ni@(NI {..}) newState
+    = do oldState ← readTVar niState

          driftFrom oldState
     where
       driftFrom ∷ InteractionState → STM ()
          driftFrom oldState
     where
       driftFrom ∷ InteractionState → STM ()


@@ -393,7 +402,7 @@ driftTo' itr@(Interaction {..}) newState
                        b = tail a
                        c = zip a b
                    mapM_ (uncurry driftFromTo) c
                        b = tail a
                        c = zip a b
                    mapM_ (uncurry driftFromTo) c

-                   writeTVar itrState newState
+                   writeTVar niState newState

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


@@ -403,8 +412,8 @@ driftTo' itr@(Interaction {..}) newState
 
       driftFromTo ∷ InteractionState → InteractionState → STM ()
       driftFromTo ReceivingBody _
 
       driftFromTo ∷ InteractionState → InteractionState → STM ()
       driftFromTo ReceivingBody _

-          = putTMVar itrReceiveBodyReq WasteAll
+          = putTMVar niReceiveBodyReq WasteAll

       driftFromTo DecidingHeader _
       driftFromTo DecidingHeader _

-          = postprocess itr
+          = postprocess ni

       driftFromTo _ _
           = return ()
       driftFromTo _ _
           = return ()

diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs
index 547947b4726b94240f1e909bc0180f7f2e5e5f68..e2b76fa94617ebe0560394cb011d7eab24f85e6b 100644 (file)
--- a/Network/HTTP/Lucu/Response.hs
+++ b/Network/HTTP/Lucu/Response.hs
@@ -13,6 +13,7 @@ module Network.HTTP.Lucu.Response
     , printStatusCode
 
     , Response(..)
     , printStatusCode
 
     , Response(..)

+    , emptyResponse

     , resCanHaveBody
     , printResponse
 
     , resCanHaveBody
     , printResponse
 


@@ -107,11 +108,18 @@ data Response = Response {
     } deriving (Show, Eq)
 
 instance HasHeaders Response where
     } deriving (Show, Eq)
 
 instance HasHeaders Response where

-    {-# INLINE getHeaders #-}
-    getHeaders = resHeaders
-    {-# INLINE setHeaders #-}
+    getHeaders         = resHeaders

     setHeaders res hdr = res { resHeaders = hdr }
 
     setHeaders res hdr = res { resHeaders = hdr }
 

+-- |Returns an HTTP\/1.1 'Response' with no header fields.
+emptyResponse ∷ StatusCode → Response
+emptyResponse sc
+    = Response {
+        resVersion = HttpVersion 1 1
+      , resStatus  = sc
+      , resHeaders = (∅)
+      }
+

 -- |Returns 'True' iff a given 'Response' allows the existence of
 -- response entity body.
 resCanHaveBody ∷ Response → Bool
 -- |Returns 'True' iff a given 'Response' allows the existence of
 -- response entity body.
 resCanHaveBody ∷ Response → Bool

diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
index 02e3938644b2122269d9c98e708c58352b68535d..d89ee9e885aa114429489cdef1fb7c59466fb65b 100644 (file)
--- a/Network/HTTP/Lucu/ResponseWriter.hs
+++ b/Network/HTTP/Lucu/ResponseWriter.hs
@@ -9,6 +9,7 @@ module Network.HTTP.Lucu.ResponseWriter
     )
     where
 import qualified Blaze.ByteString.Builder.HTTP as BB
     )
     where
 import qualified Blaze.ByteString.Builder.HTTP as BB

+import Control.Applicative

 import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Exception
 import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Exception


@@ -21,7 +22,6 @@ import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.HandleLike
 import Network.HTTP.Lucu.HttpVersion
 import Network.HTTP.Lucu.Interaction
 import Network.HTTP.Lucu.HandleLike
 import Network.HTTP.Lucu.HttpVersion
 import Network.HTTP.Lucu.Interaction

-import Network.HTTP.Lucu.Postprocess

 import Network.HTTP.Lucu.Response
 import Prelude.Unicode
 import System.IO (hPutStrLn, stderr)
 import Network.HTTP.Lucu.Response
 import Prelude.Unicode
 import System.IO (hPutStrLn, stderr)


@@ -79,141 +79,149 @@ awaitSomethingToWrite ctx@(Context {..})
          case S.viewr queue of
            EmptyR        → retry
            queue' :> itr → do writeTVar cQueue queue'
          case S.viewr queue of
            EmptyR        → retry
            queue' :> itr → do writeTVar cQueue queue'

-                              return $ writeContinueIfNeeded ctx itr
+                              return $ writeSomething ctx itr
+
+writeSomething ∷ HandleLike h ⇒ Context h → SomeInteraction → IO ()
+writeSomething ctx itr
+    = let writer = writeResponseForNI  ctx <$> fromInteraction itr <|>
+                   writeResponseForSEI ctx <$> fromInteraction itr <|>
+                   writeResponseForSYI ctx <$> fromInteraction itr
+      in
+        case writer of
+          Just f  → f
+          Nothing → fail "Internal error: unknown interaction type"
+
+writeResponseForNI ∷ HandleLike h
+                   ⇒ Context h
+                   → NormalInteraction
+                   → IO ()
+writeResponseForNI = writeContinueIfNeeded

 
 writeContinueIfNeeded ∷ HandleLike h
                       ⇒ Context h
 
 writeContinueIfNeeded ∷ HandleLike h
                       ⇒ Context h

-                      → Interaction
+                      → NormalInteraction

                       → IO ()
                       → IO ()

-writeContinueIfNeeded ctx@(Context {..}) itr@(Interaction {..})
-    = do isNeeded ← atomically $ readTMVar itrSendContinue
+writeContinueIfNeeded ctx@(Context {..}) ni@(NI {..})
+    = do isNeeded ← atomically $ readTMVar niSendContinue

          when isNeeded
              $ do let cont = Response {
                                resVersion = HttpVersion 1 1
                              , resStatus  = Continue
                              , resHeaders = (∅)
                              }
          when isNeeded
              $ do let cont = Response {
                                resVersion = HttpVersion 1 1
                              , resStatus  = Continue
                              , resHeaders = (∅)
                              }

-                  cont' ← completeUnconditionalHeaders cConfig cont
-                  hPutBuilder cHandle $ A.toBuilder $ printResponse cont'
+                  hPutBuilder cHandle $ A.toBuilder $ printResponse cont

                   hFlush cHandle
                   hFlush cHandle

-         writeHeader ctx itr
+         writeHeader ctx ni

 
 writeHeader ∷ HandleLike h
             ⇒ Context h
 
 writeHeader ∷ HandleLike h
             ⇒ Context h

-            → Interaction
+            → NormalInteraction

             → IO ()
             → IO ()

-writeHeader ctx@(Context {..}) itr@(Interaction {..})
+writeHeader ctx@(Context {..}) ni@(NI {..})

     = do res ← atomically $
     = do res ← atomically $

-               do state ← readTVar itrState
+               do state ← readTVar niState

                   if state ≥ SendingBody then
                   if state ≥ SendingBody then

-                      readTVar itrResponse
+                      readTVar niResponse

                   else
                       retry -- Too early to write header fields.
          hPutBuilder cHandle $ A.toBuilder $ printResponse res
          hFlush cHandle
                   else
                       retry -- Too early to write header fields.
          hPutBuilder cHandle $ A.toBuilder $ printResponse res
          hFlush cHandle

-         writeBodyIfNeeded ctx itr
+         writeBodyIfNeeded ctx ni

 
 writeBodyIfNeeded ∷ HandleLike h
                   ⇒ Context h
 
 writeBodyIfNeeded ∷ HandleLike h
                   ⇒ Context h

-                  → Interaction
+                  → NormalInteraction

                   → IO ()
                   → IO ()

-writeBodyIfNeeded ctx itr@(Interaction {..})
+writeBodyIfNeeded ctx ni@(NI {..})

     = join $
       atomically $
     = join $
       atomically $

-      do willDiscardBody ← readTVar itrWillDiscardBody
+      do willDiscardBody ← readTVar niWillDiscardBody

          if willDiscardBody then
          if willDiscardBody then

-             return $ discardBody ctx itr
+             return $ discardBody ctx ni

          else
          else

-             do willChunkBody ← readTVar itrWillChunkBody
-                if willChunkBody then
-                    return $ writeChunkedBody ctx itr
-                else
-                    return $ writeNonChunkedBody ctx itr
+             if niWillChunkBody then
+                 return $ writeChunkedBody    ctx ni
+             else
+                 return $ writeNonChunkedBody ctx ni

 
 discardBody ∷ HandleLike h
             ⇒ Context h
 
 discardBody ∷ HandleLike h
             ⇒ Context h

-            → Interaction
+            → NormalInteraction

             → IO ()
             → IO ()

-discardBody ctx itr@(Interaction {..})
+discardBody ctx ni@(NI {..})

     = join $
       atomically $
     = join $
       atomically $

-      do chunk ← tryTakeTMVar itrBodyToSend
+      do chunk ← tryTakeTMVar niBodyToSend

          case chunk of
          case chunk of

-           Just _  → return $ discardBody ctx itr
-           Nothing → do state ← readTVar itrState
+           Just _  → return $ discardBody ctx ni
+           Nothing → do state ← readTVar niState

                         if state ≡ Done then
                         if state ≡ Done then

-                            return $ finalize ctx itr
+                            return $ finalize ctx ni

                         else
                             retry
 
 writeChunkedBody ∷ HandleLike h
                  ⇒ Context h
                         else
                             retry
 
 writeChunkedBody ∷ HandleLike h
                  ⇒ Context h

-                 → Interaction
+                 → NormalInteraction

                  → IO ()
                  → IO ()

-writeChunkedBody ctx@(Context {..}) itr@(Interaction {..})
+writeChunkedBody ctx@(Context {..}) ni@(NI {..})

     = join $
       atomically $
     = join $
       atomically $

-      do chunk ← tryTakeTMVar itrBodyToSend
+      do chunk ← tryTakeTMVar niBodyToSend

          case chunk of
            Just b  → return $
                      do hPutBuilder cHandle $ BB.chunkedTransferEncoding b
                         hFlush cHandle
          case chunk of
            Just b  → return $
                      do hPutBuilder cHandle $ BB.chunkedTransferEncoding b
                         hFlush cHandle

-                        writeChunkedBody ctx itr
-           Nothing → do state ← readTVar itrState
+                        writeChunkedBody ctx ni
+           Nothing → do state ← readTVar niState

                         if state ≡ Done then
                         if state ≡ Done then

-                            return $ finalize ctx itr
+                            return $
+                            do hPutBuilder cHandle BB.chunkedTransferTerminator
+                               hFlush cHandle
+                               finalize ctx ni

                         else
                             retry
 
 writeNonChunkedBody ∷ HandleLike h
                     ⇒ Context h
                         else
                             retry
 
 writeNonChunkedBody ∷ HandleLike h
                     ⇒ Context h

-                    → Interaction
+                    → NormalInteraction

                     → IO ()
                     → IO ()

-writeNonChunkedBody ctx@(Context {..}) itr@(Interaction {..})
+writeNonChunkedBody ctx@(Context {..}) ni@(NI {..})

     = join $
       atomically $
     = join $
       atomically $

-      do chunk ← tryTakeTMVar itrBodyToSend
+      do chunk ← tryTakeTMVar niBodyToSend

          case chunk of
            Just b  → return $
                      do hPutBuilder cHandle b
                         hFlush cHandle
          case chunk of
            Just b  → return $
                      do hPutBuilder cHandle b
                         hFlush cHandle

-                        writeNonChunkedBody ctx itr
-           Nothing → do state ← readTVar itrState
+                        writeNonChunkedBody ctx ni
+           Nothing → do state ← readTVar niState

                         if state ≡ Done then
                         if state ≡ Done then

-                            return $ finalize ctx itr
+                            return $ finalize ctx ni

                         else
                             retry
 
                         else
                             retry
 

-finalize ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-finalize ctx@(Context {..}) (Interaction {..})
+finalize ∷ HandleLike h ⇒ Context h → NormalInteraction → IO ()
+finalize ctx@(Context {..}) (NI {..})

     = join $
       atomically $
     = join $
       atomically $

-      do sentContinue    ← takeTMVar itrSendContinue
-         willDiscardBody ← readTVar  itrWillDiscardBody
-         willChunkBody   ← readTVar  itrWillChunkBody
-         willClose       ← readTVar  itrWillClose
-         queue           ← readTVar  cQueue
-         case S.viewr queue of
-           queue' :> _
-               → writeTVar cQueue queue'
-           EmptyR
-               → fail "finalize: cQueue is empty, which should never happen."
+      do willClose    ← readTVar  niWillClose
+         sentContinue ← takeTMVar niSendContinue

          return $
          return $

-             do when (((¬) willDiscardBody) ∧ willChunkBody)
-                    $ do hPutBuilder cHandle BB.chunkedTransferTerminator
-                         hFlush cHandle
-                if willClose ∨ needToClose sentContinue then
-                    -- The RequestReader is probably blocking on
-                    -- hWaitForInput so we have to kill it before
-                    -- closing the socket.
-                    -- THINKME: Couldn't that somehow be avoided?
-                    do killThread cReader
-                       hClose cHandle
-                else
-                    awaitSomethingToWrite ctx
+             if needToClose willClose sentContinue then
+                 -- The RequestReader is probably blocking on
+                 -- hWaitForInput so we have to kill it before closing
+                 -- the socket.  THINKME: Couldn't that somehow be
+                 -- avoided?
+                 do killThread cReader
+                    hClose cHandle
+             else
+                 awaitSomethingToWrite ctx

     where
     where

-      needToClose ∷ Bool → Bool
-      needToClose sentContinue
+      needToClose ∷ Bool → Bool → Bool
+      needToClose willClose sentContinue
+          -- Explicitly instructed to close the connection.
+          | willClose = True

           -- We've sent both "HTTP/1.1 100 Continue" and a final
           -- response, so nothing prevents our connection from keeping
           -- alive.
           -- We've sent both "HTTP/1.1 100 Continue" and a final
           -- response, so nothing prevents our connection from keeping
           -- alive.


@@ -225,7 +233,37 @@ finalize ctx@(Context {..}) (Interaction {..})
           -- (rejected) request body OR start a completely new request
           -- in this situation. So the only possible thing to do is to
           -- brutally shutdown the connection.
           -- (rejected) request body OR start a completely new request
           -- in this situation. So the only possible thing to do is to
           -- brutally shutdown the connection.

-          | itrExpectedContinue ≡ Just True = True
+          | niExpectedContinue = True

           -- The client didn't expect 100-continue so we haven't sent
           -- one. No need to do anything special.
           | otherwise = False
           -- The client didn't expect 100-continue so we haven't sent
           -- one. No need to do anything special.
           | otherwise = False

+
+writeResponseForSEI ∷ HandleLike h
+                    ⇒ Context h
+                    → SemanticallyInvalidInteraction
+                    → IO ()
+writeResponseForSEI ctx@(Context {..}) (SEI {..})
+    = do hPutBuilder cHandle $ A.toBuilder $ printResponse seiResponse
+         unless seiWillDiscardBody $
+             if seiWillChunkBody then
+                 do hPutBuilder cHandle $ BB.chunkedTransferEncoding seiBodyToSend
+                    hPutBuilder cHandle BB.chunkedTransferTerminator
+             else
+                 hPutBuilder cHandle seiBodyToSend
+         hFlush cHandle
+         if seiWillClose ∨ seiExpectedContinue then
+             do killThread cReader
+                hClose cHandle
+         else
+             awaitSomethingToWrite ctx
+
+writeResponseForSYI ∷ HandleLike h
+                    ⇒ Context h
+                    → SyntacticallyInvalidInteraction
+                    → IO ()
+writeResponseForSYI (Context {..}) (SYI {..})
+    = do hPutBuilder cHandle $ A.toBuilder $ printResponse syiResponse
+         hPutBuilder cHandle syiBodyToSend
+         hFlush cHandle
+         killThread cReader
+         hClose cHandle

diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs
index 82bc59b84db9706a688e1b69ab215a7bdfee1d51..d79fc4fff4f6b6ff70959e7df497087a37289014 100644 (file)
--- a/Network/HTTP/Lucu/StaticFile.hs
+++ b/Network/HTTP/Lucu/StaticFile.hs
@@ -56,11 +56,13 @@ handleStaticFile sendContent path
 
          readable ← liftIO $ fileAccess path True False False
          unless readable
 
          readable ← liftIO $ fileAccess path True False False
          unless readable

-             $ abort Forbidden [] Nothing
+             $ abort
+             $ mkAbortion Forbidden [] Nothing

 
          stat ← liftIO $ getFileStatus path
          when (isDirectory stat)
 
          stat ← liftIO $ getFileStatus path
          when (isDirectory stat)

-             $ abort Forbidden [] Nothing
+             $ abort
+             $ mkAbortion Forbidden [] Nothing

 
          tag  ← liftIO $ generateETagFromFile path
          let lastMod = posixSecondsToUTCTime
 
          tag  ← liftIO $ generateETagFromFile path
          let lastMod = posixSecondsToUTCTime

diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs
index 3b17bf8bd08a08976fd79577628678bea1ada6eb..d7e0071c8767f72caf9e9bc72c0ef08e748c3b66 100644 (file)
--- a/examples/HelloWorld.hs
+++ b/examples/HelloWorld.hs
@@ -5,7 +5,6 @@
 import Control.Applicative
 import Control.Monad.Unicode
 import qualified Data.ByteString.Lazy.Char8 as Lazy
 import Control.Applicative
 import Control.Monad.Unicode
 import qualified Data.ByteString.Lazy.Char8 as Lazy

-import Data.Monoid.Unicode

 import Network.HTTP.Lucu
 
 main ∷ IO ()
 import Network.HTTP.Lucu
 
 main ∷ IO ()


@@ -23,19 +22,18 @@ main = let config    = defaultConfig { cnfServerPort = "9999" }
          do putStrLn "Access http://localhost:9999/ with your browser."
             runHttpd config resources fallbacks
 
          do putStrLn "Access http://localhost:9999/ with your browser."
             runHttpd config resources fallbacks
 

-

 helloWorld ∷ ResourceDef
 helloWorld
     = emptyResource {
         resGet
           = Just $ do setContentType $ parseMIMEType "text/hello"
 helloWorld ∷ ResourceDef
 helloWorld
     = emptyResource {
         resGet
           = Just $ do setContentType $ parseMIMEType "text/hello"

-                      outputChunk "Hello, "
-                      outputChunk "World!\n"
-                      outputChunk =≪ Lazy.pack <$> getRemoteAddr'
+                      putChunk "Hello, "
+                      putChunk "World!\n"
+                      putChunks =≪ Lazy.pack <$> getRemoteAddr'

       , resPost
       , resPost

-          = Just $ do str1 ← inputChunk 3
-                      str2 ← inputChunk 3
-                      str3 ← inputChunk 3
+          = Just $ do str1 ← getChunk 3
+                      str2 ← getChunk 3
+                      str3 ← getChunk 3

                       setContentType $ parseMIMEType "text/hello"
                       setContentType $ parseMIMEType "text/hello"

-                      output ("[" ⊕ str1 ⊕ " - " ⊕ str2 ⊕ "#" ⊕ str3 ⊕ "]")
+                      putChunks $ Lazy.fromChunks ["[", str1, " - ", str2, "#", str3, "]"]

       }
       }