X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FInteraction.hs;h=35c9f06493d45c4cb92f65d9271c82280100d8fe;hb=3b448555e621530c3483f03b4b5156dc606b2035;hp=f1e7ab371734304bf18b00f57a70c608e3f4c16a;hpb=d70d885133173b9cf89cf6b3e34c8732cb65ab61;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index f1e7ab3..35c9f06 100644
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE
-    DeriveDataTypeable
+    CPP
+  , DeriveDataTypeable
   , ExistentialQuantification
   , OverloadedStrings
   , RecordWildCards
@@ -8,6 +9,7 @@
 module Network.HTTP.Lucu.Interaction
     ( Interaction(..)
     , SomeInteraction(..)
+    , EndOfInteraction(..)
 
     , SyntacticallyInvalidInteraction(..)
     , mkSyntacticallyInvalidInteraction
@@ -23,19 +25,21 @@ module Network.HTTP.Lucu.Interaction
     , InteractionQueue
     , mkInteractionQueue
 
-    , setResponseStatus
     , getCurrentDate
+    , formatUTCTime
     )
     where
 import Blaze.ByteString.Builder (Builder)
 import Control.Applicative
 import Control.Concurrent.STM
 import Data.Ascii (Ascii)
-import qualified Data.ByteString as Strict
+import Data.ByteString (ByteString)
+import Data.Convertible.Base
 import Data.Monoid.Unicode
 import Data.Sequence (Seq)
+import Data.Tagged
 import Data.Time
-import qualified Data.Time.HTTP as HTTP
+import Data.Time.Format.HTTP
 import Data.Typeable
 import Network.Socket
 import Network.HTTP.Lucu.Config
@@ -44,7 +48,12 @@ import Network.HTTP.Lucu.Headers
 import Network.HTTP.Lucu.Preprocess
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.Response.StatusCode
+import Network.HTTP.Lucu.Utils
+#if defined(HAVE_SSL)
 import OpenSSL.X509
+#endif
+import Prelude.Unicode
 
 class Typeable i ⇒ Interaction i where
     toInteraction ∷ i → SomeInteraction
@@ -61,6 +70,13 @@ instance Interaction SomeInteraction where
     toInteraction   = id
     fromInteraction = Just
 
+-- |'EndOfInteraction' is an 'Interaction' indicating the end of
+-- (possibly pipelined) requests. The connection has already been
+-- closed so no need to reply anything.
+data EndOfInteraction = EndOfInteraction
+    deriving Typeable
+instance Interaction EndOfInteraction
+
 -- |'SyntacticallyInvalidInteraction' is an 'Interaction' without even
 -- a syntactically valid 'Request'. The response code will always be
 -- 'BadRequest'.
@@ -74,13 +90,13 @@ instance Interaction SyntacticallyInvalidInteraction
 
 mkSyntacticallyInvalidInteraction ∷ Config
                                   → IO SyntacticallyInvalidInteraction
-mkSyntacticallyInvalidInteraction config@(Config {..})
+mkSyntacticallyInvalidInteraction conf@(Config {..})
     = do date ← getCurrentDate
          let res  = setHeader "Server"       cnfServerSoftware      $
                     setHeader "Date"         date                   $
                     setHeader "Content-Type" defaultPageContentType $
                     emptyResponse BadRequest
-             body = getDefaultPage config Nothing res
+             body = defaultPageForResponse conf Nothing res
          return SYI {
                   syiResponse   = res
                 , syiBodyToSend = body
@@ -97,7 +113,6 @@ data SemanticallyInvalidInteraction
 
       , seiResponse         ∷ !Response
       , seiWillChunkBody    ∷ !Bool
-      , seiWillDiscardBody  ∷ !Bool
       , seiWillClose        ∷ !Bool
       , seiBodyToSend       ∷ !Builder
       }
@@ -112,8 +127,16 @@ mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..})
          let res  = setHeader "Server"       cnfServerSoftware      $
                     setHeader "Date"         date                   $
                     setHeader "Content-Type" defaultPageContentType $
+                    ( if arWillChunkBody
+                      then setHeader "Transfer-Encoding" "chunked"
+                      else id
+                    ) $
+                    ( if arWillClose
+                      then setHeader "Connection" "close"
+                      else id
+                    ) $
                     emptyResponse arInitialStatus
-             body = getDefaultPage config (Just arRequest) res
+             body = defaultPageForResponse config (Just arRequest) res
          return SEI {
                   seiRequest          = arRequest
                 , seiExpectedContinue = arExpectedContinue
@@ -121,7 +144,6 @@ mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..})
 
                 , seiResponse         = res
                 , seiWillChunkBody    = arWillChunkBody
-                , seiWillDiscardBody  = arWillDiscardBody
                 , seiWillClose        = arWillClose
                 , seiBodyToSend       = body
                 }
@@ -132,21 +154,23 @@ data NormalInteraction
     = NI {
         niConfig           ∷ !Config
       , niRemoteAddr       ∷ !SockAddr
+#if defined(HAVE_SSL)
       , niRemoteCert       ∷ !(Maybe X509)
+#endif
       , niRequest          ∷ !Request
-      , niResourcePath     ∷ ![Strict.ByteString]
+      , niResourcePath     ∷ !Path
       , niExpectedContinue ∷ !Bool
       , niReqBodyLength    ∷ !(Maybe RequestBodyLength)
 
       , niReceiveBodyReq   ∷ !(TMVar ReceiveBodyRequest)
-      , niReceivedBody     ∷ !(TMVar Strict.ByteString)
+      , niReceivedBody     ∷ !(TMVar ByteString)
 
       , niResponse         ∷ !(TVar Response)
       , niSendContinue     ∷ !(TMVar Bool)
       , niWillChunkBody    ∷ !Bool
-      , niWillDiscardBody  ∷ !(TVar Bool)
       , niWillClose        ∷ !(TVar Bool)
       , niResponseHasCType ∷ !(TVar Bool)
+      -- FIXME: use TBChan Builder (in stm-chans package)
       , niBodyToSend       ∷ !(TMVar Builder)
 
       , niState            ∷ !(TVar InteractionState)
@@ -171,17 +195,22 @@ data InteractionState
 
 mkNormalInteraction ∷ Config
                     → SockAddr
+#if defined(HAVE_SSL)
                     → Maybe X509
+#endif
                     → AugmentedRequest
-                    → [Strict.ByteString]
+                    → Path
                     → IO NormalInteraction
+#if defined(HAVE_SSL)
 mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPath
+#else
+mkNormalInteraction config remoteAddr (AugmentedRequest {..}) rsrcPath
+#endif
     = do receiveBodyReq   ← newEmptyTMVarIO
          receivedBody     ← newEmptyTMVarIO
 
          response         ← newTVarIO $ emptyResponse arInitialStatus
          sendContinue     ← newEmptyTMVarIO
-         willDiscardBody  ← newTVarIO arWillDiscardBody
          willClose        ← newTVarIO arWillClose
          responseHasCType ← newTVarIO False
          bodyToSend       ← newEmptyTMVarIO
@@ -191,7 +220,9 @@ mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPat
          return NI {
                   niConfig           = config
                 , niRemoteAddr       = remoteAddr
+#if defined(HAVE_SSL)
                 , niRemoteCert       = remoteCert
+#endif
                 , niRequest          = arRequest
                 , niResourcePath     = rsrcPath
                 , niExpectedContinue = arExpectedContinue
@@ -203,7 +234,6 @@ mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPat
                 , niResponse         = response
                 , niSendContinue     = sendContinue
                 , niWillChunkBody    = arWillChunkBody
-                , niWillDiscardBody  = willDiscardBody
                 , niWillClose        = willClose
                 , niResponseHasCType = responseHasCType
                 , niBodyToSend       = bodyToSend
@@ -214,15 +244,16 @@ mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPat
 type InteractionQueue = TVar (Seq SomeInteraction)
 
 mkInteractionQueue ∷ IO InteractionQueue
+{-# INLINE mkInteractionQueue #-}
 mkInteractionQueue = newTVarIO (∅)
 
-setResponseStatus ∷ NormalInteraction → StatusCode → STM ()
-setResponseStatus (NI {..}) sc
-    = do res ← readTVar niResponse
-         let res' = res {
-                      resStatus = sc
-                    }
-         writeTVar niResponse res'
-
 getCurrentDate ∷ IO Ascii
-getCurrentDate = HTTP.toAscii <$> getCurrentTime
+{-# INLINE getCurrentDate #-}
+getCurrentDate = formatUTCTime <$> getCurrentTime
+
+formatUTCTime ∷ UTCTime → Ascii
+{-# INLINE formatUTCTime #-}
+formatUTCTime = cs' ∘ Tagged
+    where
+      cs' ∷ Tagged HTTP UTCTime → Ascii
+      cs' = cs