X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FInteraction.hs;h=f57a474f4884f388ecfe38be3f51e5edbba5a9ca;hb=7843dbf537dfefa583a8ee55b2a31a5e8a9c7c37;hp=29c944e573bf8c41c1fbb2ca2cb00ba500181eab;hpb=5b255535f2c7d2a6d4622ad164b31e63746b906e;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index 29c944e..f57a474 100644
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -1,174 +1,132 @@
--- #hide
+{-# LANGUAGE
+    OverloadedStrings
+  , RecordWildCards
+  , UnicodeSyntax
+  #-}
 module Network.HTTP.Lucu.Interaction
     ( Interaction(..)
     , InteractionState(..)
     , InteractionQueue
+    , ReceiveBodyRequest(..)
     , newInteractionQueue
     , newInteraction
-    , defaultPageContentType
 
-    , writeItr
-    , readItr
-    , readItrF
-    , updateItr
-    , updateItrF
+    , setResponseStatus
     )
     where
-
-import           Control.Concurrent.STM
-import qualified Data.ByteString.Lazy.Char8 as B
-import           Data.ByteString.Lazy.Char8 (ByteString)
+import Blaze.ByteString.Builder (Builder)
+import Control.Concurrent.STM
+import qualified Data.ByteString as Strict
+import Data.Monoid.Unicode
+import Data.Sequence (Seq)
 import qualified Data.Sequence as S
-import           Data.Sequence (Seq)
-import           Network.Socket
-import           Network.HTTP.Lucu.Config
-import           Network.HTTP.Lucu.HttpVersion
-import           Network.HTTP.Lucu.Request
-import           Network.HTTP.Lucu.Response
+import Data.Text (Text)
+import Network.Socket
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.HttpVersion
+import Network.HTTP.Lucu.Preprocess
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Response
+import OpenSSL.X509
 
 data Interaction = Interaction {
-      itrConfig       :: Config
-    , itrRemoteAddr   :: SockAddr
-    , itrResourcePath :: Maybe [String]
-    , itrRequest      :: TVar (Maybe Request)
-    , itrResponse     :: TVar Response
-
-    -- FIXME: この三つは本來 TVar であるべきでないので、唯の Bool にす
-    -- るに越した事は無いが、それは重要でない。そんな golf で自分の貴重
-    -- な時間を /dev/null に突っ込むのは、他にしたい事が何も無くなって
-    -- からにすべき。
-    , itrRequestHasBody    :: TVar Bool
-    , itrRequestIsChunked  :: TVar Bool
-    , itrExpectedContinue  :: TVar Bool
-
-    , itrReqChunkLength    :: TVar (Maybe Int)
-    , itrReqChunkRemaining :: TVar (Maybe Int)
-    , itrReqChunkIsOver    :: TVar Bool
-    , itrReqBodyWanted     :: TVar (Maybe Int)
-    , itrReqBodyWasteAll   :: TVar Bool
-    , itrReceivedBody      :: TVar ByteString -- Resource が受領した部分は削除される
-
-    , itrWillReceiveBody   :: TVar Bool
-    , itrWillChunkBody     :: TVar Bool
-    , itrWillDiscardBody   :: TVar Bool
-    , itrWillClose         :: TVar Bool
-
-    , itrBodyToSend :: TVar ByteString
-    , itrBodyIsNull :: TVar Bool
-
-    , itrState :: TVar InteractionState
-
-    , itrWroteContinue :: TVar Bool
-    , itrWroteHeader   :: TVar Bool
+      itrConfig            ∷ !Config
+    , itrLocalPort         ∷ !PortNumber
+    , itrRemoteAddr        ∷ !SockAddr
+    , itrRemoteCert        ∷ !(Maybe X509)
+    , itrResourcePath      ∷ !(Maybe [Text])
+    , itrRequest           ∷ !(Maybe Request)
+
+    , itrExpectedContinue  ∷ !(Maybe Bool)
+    , itrReqBodyLength     ∷ !(Maybe RequestBodyLength)
+
+    , itrReceiveBodyReq    ∷ !(TMVar ReceiveBodyRequest)
+    , itrReceivedBody      ∷ !(TMVar Strict.ByteString)
+
+    , itrResponse          ∷ !(TVar Response)
+    , itrWillChunkBody     ∷ !(TVar Bool)
+    , itrWillDiscardBody   ∷ !(TVar Bool)
+    , itrWillClose         ∷ !(TVar Bool)
+    , itrResponseHasCType  ∷ !(TVar Bool)
+    , itrBodyToSend        ∷ !(TMVar Builder)
+
+    , itrState             ∷ !(TVar InteractionState)
     }
 
--- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
--- 状態は ExaminingRequest。
-data InteractionState = ExaminingRequest
-                      | GettingBody
-                      | DecidingHeader
-                      | DecidingBody
-                      | Done
-                        deriving (Show, Eq, Ord, Enum)
+-- |The interaction state of Resource monad. 'ExaminingRequest' is the
+-- initial state.
+data InteractionState
+    = ExaminingRequest
+    | ReceivingBody
+    | DecidingHeader
+    | SendingBody
+    | Done
+    deriving (Show, Eq, Ord, Enum)
 
 type InteractionQueue = TVar (Seq Interaction)
 
+data ReceiveBodyRequest
+    = ReceiveBody !Int -- ^ Maximum number of octets to receive.
+    | WasteAll
+    deriving (Show, Eq)
 
-newInteractionQueue :: IO InteractionQueue
+newInteractionQueue ∷ IO InteractionQueue
 newInteractionQueue = newTVarIO S.empty
 
-
-defaultPageContentType :: String
-defaultPageContentType = "application/xhtml+xml"
-
-
-newInteraction :: Config -> SockAddr -> Maybe Request -> IO Interaction
-newInteraction conf addr req
-    = do request  <- newTVarIO $ req
-         responce <- newTVarIO $ Response {
-                       resVersion = HttpVersion 1 1
-                     , resStatus  = Ok
-                     , resHeaders = [("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 B.empty
-
-         willReceiveBody   <- newTVarIO False
-         willChunkBody     <- newTVarIO False
-         willDiscardBody   <- newTVarIO False
-         willClose         <- newTVarIO False
-
-         bodyToSend <- newTVarIO B.empty
-         bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
-
-         state <- newTVarIO ExaminingRequest
-
-         wroteContinue <- newTVarIO False
-         wroteHeader   <- newTVarIO False
-
-         return $ Interaction {
-                      itrConfig       = conf
-                    , itrRemoteAddr   = addr
-                    , 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
+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 = (∅)
+                   }
+
+         receiveBodyReq   ← newEmptyTMVarIO
+         receivedBody     ← 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          = arRequest ar
+
+                    , itrExpectedContinue = arExpectedContinue ar
+                    , itrReqBodyLength    = arReqBodyLength    ar
+
+                    , itrReceiveBodyReq   = receiveBodyReq
+                    , itrReceivedBody     = receivedBody
+
+                    , itrResponse         = response
+                    , itrWillChunkBody    = willChunkBody
+                    , itrWillDiscardBody  = willDiscardBody
+                    , itrWillClose        = willClose
+                    , itrResponseHasCType = responseHasCType
+                    , itrBodyToSend       = bodyToSend
                     
-                    , itrState = state
-                    
-                    , itrWroteContinue = wroteContinue
-                    , itrWroteHeader   = wroteHeader
+                    , itrState            = state
                     }
 
-
-writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
-writeItr itr accessor value
-    = writeTVar (accessor itr) value
-
-
-readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
-readItr itr accessor reader
-    = readTVar (accessor itr) >>= return . reader
-
-
-readItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
-readItrF itr accessor reader
-    = readItr itr accessor (fmap reader)
-
-
-updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
-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 ()
-updateItrF itr accessor updator
-    = updateItr itr accessor (fmap updator)
+setResponseStatus ∷ Interaction → StatusCode → STM ()
+setResponseStatus (Interaction {..}) sc
+    = do res ← readTVar itrResponse
+         let res' = res {
+                      resStatus = sc
+                    }
+         writeTVar itrResponse res'