X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FInteraction.hs;h=3ecc9126f4292a63a239db5a0efb246f76909402;hb=895341e;hp=19faec28fe7a1fb506f42d5416123f17ec52a61d;hpb=e34910f85f459f049b9e6e6b79db9ef95dfccc13;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index 19faec2..3ecc912 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,60 +11,50 @@ module Network.HTTP.Lucu.Interaction
     , newInteraction
     , defaultPageContentType
 
-    , writeItr
-    , readItr
-    , readItrF
-    , updateItr
-    , updateItrF
+    , 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 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
@@ -84,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 (arWillDiscardBody ar)
+         willClose       ← newTVarIO (arWillClose       ar)
+         bodyToSend      ← newEmptyTMVarIO
+         sentNoBodySoFar ← newTVarIO True
+
+         state           ← newTVarIO ExaminingRequest
 
          return Interaction {
                       itrConfig       = conf
@@ -123,56 +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
                     }
 
-writeItr ∷ Interaction → (Interaction → TVar a) → a → STM ()
-{-# INLINE writeItr #-}
-writeItr itr accessor
-    = writeTVar (accessor itr)
-
-readItr ∷ Interaction → (Interaction → TVar a) → (a → b) → STM b
-{-# INLINE readItr #-}
-readItr itr accessor reader
-    = reader <$> readTVar (accessor itr)
-
-readItrF ∷ Functor f => Interaction → (Interaction → TVar (f a)) → (a → b) → STM (f b)
-{-# INLINE readItrF #-}
-readItrF itr accessor reader
-    = readItr itr accessor (fmap reader)
-
-updateItr ∷ Interaction → (Interaction → TVar a) → (a → a) → STM ()
-{-# INLINE updateItr #-}
-updateItr itr accessor updator
-    = do old ← readItr itr accessor id
-         writeItr itr accessor (updator old)
-
-updateItrF ∷ Functor f => Interaction → (Interaction → TVar (f a)) → (a → a) → STM ()
-{-# INLINE updateItrF #-}
-updateItrF itr accessor
-    = updateItr itr accessor ∘ fmap
+setResponseStatus ∷ Interaction → StatusCode → STM ()
+setResponseStatus (Interaction {..}) sc
+    = do res ← readTVar itrResponse
+         let res' = res {
+                      resStatus = sc
+                    }
+         writeTVar itrResponse res'