X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FInteraction.hs;h=4d153d14e579df2a5d8bc9e410b0e53054f8db0e;hb=1f0a19c;hp=ac9c46f5a93b8e8a78c1bcb583f1d712b0c8a374;hpb=3fe5ca3bca04e0124a5f2440e893dc5375e0bb51;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index ac9c46f..4d153d1 100644
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -1,32 +1,30 @@
 {-# LANGUAGE
-    BangPatterns
-  , OverloadedStrings
+    OverloadedStrings
+  , RecordWildCards
   , UnicodeSyntax
   #-}
 module Network.HTTP.Lucu.Interaction
     ( Interaction(..)
     , InteractionState(..)
     , InteractionQueue
+    , GetBodyRequest(..)
     , newInteractionQueue
     , newInteraction
-    , defaultPageContentType
 
-    , writeItr
-    , readItr
-    , updateItr
+    , setResponseStatus
     )
     where
 import Blaze.ByteString.Builder (Builder)
-import Control.Applicative
 import Control.Concurrent.STM
-import Data.Ascii (Ascii)
-import qualified Data.ByteString as BS
+import qualified Data.ByteString as Strict
+import Data.Monoid.Unicode
 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
@@ -36,144 +34,99 @@ data Interaction = Interaction {
     , 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))
-    , itrReqBodyWasteAll   ∷ !(TVar Bool)
-    , itrReceivedBody      ∷ !(TVar (Seq BS.ByteString))
-    , itrReceivedBodyLen   ∷ !(TVar Int)
+    , itrGetBodyRequest    ∷ !(TMVar GetBodyRequest)
+    , itrGotBody           ∷ !(TMVar Strict.ByteString)
 
-    , itrWillReceiveBody   ∷ !(TVar Bool)
+    , itrResponse          ∷ !(TVar Response)
     , itrWillChunkBody     ∷ !(TVar Bool)
     , itrWillDiscardBody   ∷ !(TVar Bool)
     , itrWillClose         ∷ !(TVar Bool)
-
+    , itrResponseHasCType  ∷ !(TVar Bool)
     , itrBodyToSend        ∷ !(TMVar Builder)
-    , itrBodyIsNull        ∷ !(TVar Bool)
 
     , itrState             ∷ !(TVar InteractionState)
-
-    , itrWroteContinue     ∷ !(TVar Bool)
-    , itrWroteHeader       ∷ !(TVar Bool)
     }
 
 -- |The interaction state of Resource monad. 'ExaminingRequest' is the
 -- initial state.
-data InteractionState = ExaminingRequest
-                      | GettingBody
-                      | DecidingHeader
-                      | DecidingBody
-                      | Done
-                        deriving (Show, Eq, Ord, Enum)
+data InteractionState
+    = ExaminingRequest
+    | GettingBody
+    | DecidingHeader
+    | DecidingBody
+    | Done
+    deriving (Show, Eq, Ord, Enum)
 
 type InteractionQueue = TVar (Seq Interaction)
 
+data GetBodyRequest
+    = GetBody !Int -- ^ Maximum number of bytes.
+    | WasteAll
+    deriving (Show, Eq)
+
 newInteractionQueue ∷ IO InteractionQueue
 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
-         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 = (∅)
+                   }
+
+         getBodyRequest   ← newEmptyTMVarIO
+         gotBody          ← newEmptyTMVarIO
+
+         response         ← newTVarIO res
+         willChunkBody    ← newTVarIO False
+         willDiscardBody  ← newTVarIO (arWillDiscardBody ar)
+         willClose        ← newTVarIO (arWillClose       ar)
+         bodyToSend       ← newEmptyTMVarIO
+         responseHasCType ← newTVarIO False
+
+         state            ← newTVarIO ExaminingRequest
 
          return Interaction {
-                      itrConfig       = conf
-                    , itrLocalPort    = port
-                    , 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
-                    , itrBodyIsNull = bodyIsNull
-                    
-                    , itrState = state
+                      itrConfig           = conf
+                    , itrLocalPort        = port
+                    , itrRemoteAddr       = addr
+                    , itrRemoteCert       = cert
+                    , itrResourcePath     = Nothing
+                    , itrRequest          = arRequest ar
+
+                    , itrExpectedContinue = arExpectedContinue ar
+                    , itrReqBodyLength    = arReqBodyLength    ar
+
+                    , itrGetBodyRequest   = getBodyRequest
+                    , itrGotBody          = gotBody
+
+                    , itrResponse         = response
+                    , itrWillChunkBody    = willChunkBody
+                    , itrWillDiscardBody  = willDiscardBody
+                    , itrWillClose        = willClose
+                    , itrResponseHasCType = responseHasCType
+                    , itrBodyToSend       = bodyToSend
                     
-                    , 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'