X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FInteraction.hs;h=58215792fd968846532b6e7f27c065c4f874203e;hb=ca338174155913a969808d7b20193973394e474e;hp=8a64dc1b0715a1b3e703de12ed9c7da43c0076e6;hpb=2bb7a0baa35dadb5d36d3f9fa98bd242baabc6d1;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index 8a64dc1..5821579 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
@@ -10,11 +10,8 @@ module Network.HTTP.Lucu.Interaction
     , newInteractionQueue
     , newInteraction
     , defaultPageContentType
-{-
-    , writeItr
-    , readItr
-    , updateItr
--}
+
+    , setResponseStatus
     )
     where
 import Blaze.ByteString.Builder (Builder)
@@ -28,6 +25,7 @@ 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
@@ -38,33 +36,25 @@ data Interaction = Interaction {
     , itrRemoteAddr        ∷ !SockAddr
     , itrRemoteCert        ∷ !(Maybe X509)
     , itrResourcePath      ∷ !(Maybe [Text])
-    , itrRequest           ∷ !(TVar (Maybe Request))
-    , itrResponse          ∷ !(TVar Response)
+    , 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))
     , 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        ∷ !(TMVar Builder)
-    , itrSentNoBody        ∷ !(TVar Bool)
+    , itrSentNoBodySoFar   ∷ !(TVar Bool)
 
     , itrState             ∷ !(TVar InteractionState)
-
-    , itrWroteContinue     ∷ !(TVar Bool)
-    , itrWroteHeader       ∷ !(TVar Bool)
     }
 
 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
@@ -84,39 +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
-         receivedBodyLen    ← newTVarIO 0
-
-         willReceiveBody   ← newTVarIO False
-         willChunkBody     ← newTVarIO False
-         willDiscardBody   ← newTVarIO False
-         willClose         ← newTVarIO False
-
-         bodyToSend ← newEmptyTMVarIO
-         sentNoBody ← 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 Nothing -- Resource が要求してゐるチャンク長
+         reqBodyWasteAll ← newTVarIO False   -- 殘りの body を讀み捨てよと云ふ要求
+         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
@@ -124,57 +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
-                    , itrReceivedBodyLen   = receivedBodyLen
-
-                    , itrWillReceiveBody   = willReceiveBody
-                    , itrWillChunkBody     = willChunkBody
-                    , itrWillDiscardBody   = willDiscardBody
-                    , itrWillClose         = willClose
-
-                    , itrBodyToSend = bodyToSend
-                    , itrSentNoBody = sentNoBody
+                    , 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) → Interaction → STM a
-{-# INLINE readItr #-}
-readItr accessor itr
-    = readTVar (accessor itr)
-
-updateItr ∷ (Interaction → TVar a) → (a → a) → Interaction → STM ()
-{-# INLINE updateItr #-}
-updateItr accessor updator itr
-    = do old ← readItr accessor 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'