X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FInteraction.hs;h=ac5c1d6285aa33d936d4ae23135cb09b4ef8e125;hb=ea2b7838f1b3d9d4923a220a601be2e04cc559d7;hp=52a5e2eea41e76b334015fedcee80089babad881;hpb=db4b61223e0d8b34079d3b190fb3e3644b0b4866;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index 52a5e2e..ac5c1d6 100644
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE
-    BangPatterns
-  , OverloadedStrings
+    OverloadedStrings
+  , RecordWildCards
   , UnicodeSyntax
   #-}
 module Network.HTTP.Lucu.Interaction
@@ -11,63 +11,50 @@ module Network.HTTP.Lucu.Interaction
     , newInteraction
     , defaultPageContentType
 
-    , chunksToLBS
-    , chunksFromLBS
-
-    , writeItr
-    , readItr
-    , updateItr
+    , setResponseStatus
     )
     where
-import Control.Applicative
+import Blaze.ByteString.Builder (Builder)
 import Control.Concurrent.STM
 import Data.Ascii (Ascii)
 import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as LBS
-import Data.Foldable
 import Data.Sequence (Seq)
 import qualified Data.Sequence as S
+import Data.Text (Text)
 import Network.Socket
 import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.Headers
 import Network.HTTP.Lucu.HttpVersion
+import Network.HTTP.Lucu.Preprocess
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 import OpenSSL.X509
-import Prelude.Unicode
 
 data Interaction = Interaction {
       itrConfig            ∷ !Config
     , itrLocalPort         ∷ !PortNumber
     , itrRemoteAddr        ∷ !SockAddr
     , itrRemoteCert        ∷ !(Maybe X509)
-    , itrResourcePath      ∷ !(Maybe [Ascii])
-    , itrRequest           ∷ !(TVar (Maybe Request))
-    , itrResponse          ∷ !(TVar Response)
+    , itrResourcePath      ∷ !(Maybe [Text])
+    , itrRequest           ∷ !(Maybe Request)
 
-    , itrRequestHasBody    ∷ !(TVar Bool)
-    , itrRequestIsChunked  ∷ !(TVar Bool)
-    , itrExpectedContinue  ∷ !(TVar Bool)
+    , itrExpectedContinue  ∷ !(Maybe Bool)
+    , itrReqBodyLength     ∷ !(Maybe RequestBodyLength)
 
-    , itrReqChunkLength    ∷ !(TVar (Maybe Int))
-    , itrReqChunkRemaining ∷ !(TVar (Maybe Int))
-    , itrReqChunkIsOver    ∷ !(TVar Bool)
-    , itrReqBodyWanted     ∷ !(TVar (Maybe Int))
+    , itrReqBodyWanted     ∷ !(TVar Int)
     , itrReqBodyWasteAll   ∷ !(TVar Bool)
+    , itrReqChunkIsOver    ∷ !(TVar Bool)
     , itrReceivedBody      ∷ !(TVar (Seq BS.ByteString))
+    , itrReceivedBodyLen   ∷ !(TVar Int)
 
-    , itrWillReceiveBody   ∷ !(TVar Bool)
+    , itrResponse          ∷ !(TVar Response)
     , itrWillChunkBody     ∷ !(TVar Bool)
     , itrWillDiscardBody   ∷ !(TVar Bool)
     , itrWillClose         ∷ !(TVar Bool)
-
-    , itrBodyToSend        ∷ !(TVar (Seq BS.ByteString))
-    , itrBodyIsNull        ∷ !(TVar Bool)
+    , itrBodyToSend        ∷ !(TMVar Builder)
+    , itrSentNoBodySoFar   ∷ !(TVar Bool)
 
     , itrState             ∷ !(TVar InteractionState)
-
-    , itrWroteContinue     ∷ !(TVar Bool)
-    , itrWroteHeader       ∷ !(TVar Bool)
     }
 
 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
@@ -87,38 +74,34 @@ newInteractionQueue = newTVarIO S.empty
 defaultPageContentType ∷ Ascii
 defaultPageContentType = "application/xhtml+xml"
 
-newInteraction ∷ Config → PortNumber → SockAddr → Maybe X509 → Maybe Request → IO Interaction
-newInteraction !conf !port !addr !cert !req
-    = do request  ← newTVarIO req
-         responce ← newTVarIO Response {
-                       resVersion = HttpVersion 1 1
-                     , resStatus  = Ok
-                     , resHeaders = toHeaders [("Content-Type", defaultPageContentType)]
-                     }
-
-         requestHasBody     ← newTVarIO False
-         requestIsChunked   ← newTVarIO False
-         expectedContinue   ← newTVarIO False
-         
-         reqChunkLength     ← newTVarIO Nothing -- 現在のチャンク長
-         reqChunkRemaining  ← newTVarIO Nothing -- 現在のチャンクの殘り
-         reqChunkIsOver     ← newTVarIO False   -- 最後のチャンクを讀み終へた
-         reqBodyWanted      ← newTVarIO Nothing -- Resource が要求してゐるチャンク長
-         reqBodyWasteAll    ← newTVarIO False   -- 殘りの body を讀み捨てよと云ふ要求
-         receivedBody       ← newTVarIO S.empty
-
-         willReceiveBody   ← newTVarIO False
-         willChunkBody     ← newTVarIO False
-         willDiscardBody   ← newTVarIO False
-         willClose         ← newTVarIO False
-
-         bodyToSend ← newTVarIO S.empty
-         bodyIsNull ← newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
-
-         state ← newTVarIO ExaminingRequest
-
-         wroteContinue ← newTVarIO False
-         wroteHeader   ← newTVarIO False
+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 = singleton "Content-Type" defaultPageContentType
+                   }
+
+         reqBodyWanted   ← newTVarIO 0
+         reqBodyWasteAll ← newTVarIO False
+         reqChunkIsOver  ← newTVarIO False
+         receivedBody    ← newTVarIO S.empty
+         receivedBodyLen ← newTVarIO 0
+
+         response        ← newTVarIO res
+         willChunkBody   ← newTVarIO False
+         willDiscardBody ← newTVarIO False
+         willClose       ← newTVarIO False
+         bodyToSend      ← newEmptyTMVarIO
+         sentNoBodySoFar ← newTVarIO True
+
+         state           ← newTVarIO ExaminingRequest
 
          return Interaction {
                       itrConfig       = conf
@@ -126,54 +109,31 @@ newInteraction !conf !port !addr !cert !req
                     , itrRemoteAddr   = addr
                     , itrRemoteCert   = cert
                     , itrResourcePath = Nothing
-                    , itrRequest      = request
-                    , itrResponse     = responce
-
-                    , itrRequestHasBody   = requestHasBody
-                    , itrRequestIsChunked = requestIsChunked
-                    , itrExpectedContinue = expectedContinue
-
-                    , itrReqChunkLength    = reqChunkLength
-                    , itrReqChunkRemaining = reqChunkRemaining
-                    , itrReqChunkIsOver    = reqChunkIsOver
-                    , itrReqBodyWanted     = reqBodyWanted
-                    , itrReqBodyWasteAll   = reqBodyWasteAll
-                    , itrReceivedBody      = receivedBody
-
-                    , itrWillReceiveBody   = willReceiveBody
-                    , itrWillChunkBody     = willChunkBody
-                    , itrWillDiscardBody   = willDiscardBody
-                    , itrWillClose         = willClose
-
-                    , itrBodyToSend = bodyToSend
-                    , itrBodyIsNull = bodyIsNull
+                    , itrRequest      = arRequest ar
+
+                    , itrExpectedContinue = arExpectedContinue ar
+                    , itrReqBodyLength    = arReqBodyLength    ar
+
+                    , itrReqBodyWanted    = reqBodyWanted
+                    , itrReqBodyWasteAll  = reqBodyWasteAll
+                    , itrReqChunkIsOver   = reqChunkIsOver
+                    , itrReceivedBody     = receivedBody
+                    , itrReceivedBodyLen  = receivedBodyLen
+
+                    , itrResponse         = response
+                    , itrWillChunkBody    = willChunkBody
+                    , itrWillDiscardBody  = willDiscardBody
+                    , itrWillClose        = willClose
+                    , itrBodyToSend       = bodyToSend
+                    , itrSentNoBodySoFar  = sentNoBodySoFar
                     
-                    , itrState = state
-                    
-                    , itrWroteContinue = wroteContinue
-                    , itrWroteHeader   = wroteHeader
+                    , itrState            = state
                     }
 
-chunksToLBS ∷ Seq BS.ByteString → LBS.ByteString
-{-# INLINE chunksToLBS #-}
-chunksToLBS = LBS.fromChunks ∘ toList
-
-chunksFromLBS ∷ LBS.ByteString → Seq BS.ByteString
-{-# INLINE chunksFromLBS #-}
-chunksFromLBS = S.fromList ∘ LBS.toChunks
-
-writeItr ∷ (Interaction → TVar a) → a → Interaction → STM ()
-{-# INLINE writeItr #-}
-writeItr accessor a itr
-    = writeTVar (accessor itr) a
-
-readItr ∷ (Interaction → TVar a) → (a → b) → Interaction → STM b
-{-# INLINE readItr #-}
-readItr accessor reader itr
-    = reader <$> readTVar (accessor itr)
-
-updateItr ∷ (Interaction → TVar a) → (a → a) → Interaction → STM ()
-{-# INLINE updateItr #-}
-updateItr accessor updator itr
-    = do old ← readItr accessor id itr
-         writeItr accessor (updator old) itr
+setResponseStatus ∷ Interaction → StatusCode → STM ()
+setResponseStatus (Interaction {..}) sc
+    = do res ← readTVar itrResponse
+         let res' = res {
+                      resStatus = sc
+                    }
+         writeTVar itrResponse res'