X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FInteraction.hs;h=91979c9d5449e7a1b2ee7811a0c8294a9d381fc7;hb=d05d8c883eaca12ee621975a2b95c5ebdc2357d2;hp=44f4243b6ebe2abb5b02cb0891d783bd60f60655;hpb=3c7a58ab749a55a30466a033b170536bcdf18b98;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index 44f4243..91979c9 100644
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -2,8 +2,15 @@ module Network.HTTP.Lucu.Interaction
     ( Interaction(..)
     , InteractionState(..)
     , InteractionQueue
-    , newInteractionQueue -- IO InteractionQueue
-    , newInteraction      -- HostName -> Maybe Request -> IO Interaction
+    , newInteractionQueue
+    , newInteraction
+    , defaultPageContentType
+
+    , writeItr
+    , readItr
+    , readItrF
+    , updateItr
+    , updateItrF
     )
     where
 
@@ -12,42 +19,54 @@ import qualified Data.ByteString.Lazy.Char8 as B
 import           Data.ByteString.Lazy.Char8 (ByteString)
 import qualified Data.Sequence as S
 import           Data.Sequence (Seq)
-import           Network
+import           Network.Socket
+import           Network.HTTP.Lucu.Config
+import           Network.HTTP.Lucu.HttpVersion
 import           Network.HTTP.Lucu.Request
 import           Network.HTTP.Lucu.Response
 
 data Interaction = Interaction {
-      itrRemoteHost  :: HostName
-    , itrRequest     :: Maybe Request
-    , itrResponse    :: TVar (Maybe Response)
-
-    , itrRequestHasBody    :: TVar Bool
-    , itrRequestBodyLength :: TVar (Maybe Integer) -- chunked の場合は不明
-    , itrRequestIsChunked  :: TVar Bool
-    , itrReceivedBody      :: TVar ByteString -- Resource が受領した部分は削除される
-    
-    , itrExpectedContinue  :: TVar Bool
-
-    , itrWillChunkBody    :: TVar Bool
-    , itrWillDiscardBody  :: TVar Bool
-    , itrWillClose        :: TVar Bool
-    , itrBodyToSend       :: TVar ByteString
-
-    , itrState :: TVar InteractionState
-
-    , itrWroteContinue :: TVar Bool
-    , itrWroteHeader   :: TVar Bool
+      itrConfig       :: !Config
+    , itrRemoteAddr   :: !SockAddr
+    , itrResourcePath :: !(Maybe [String])
+    , itrRequest      :: !(TVar (Maybe Request))
+    , itrResponse     :: !(TVar Response)
+
+    -- FIXME: この三つは本來 TVar であるべきでないので、唯の Bool にす
+    -- るに越した事は無いが、それは重要でない。
+    , 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)
     }
 
 -- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
--- 状態は ExaminingHeader (リクエストボディが有る時) または
--- DecidingHeader (無い時)。終了状態は常に Done
-data InteractionState = ExaminingHeader
+-- 状態は ExaminingRequest。
+data InteractionState = ExaminingRequest
                       | GettingBody
                       | DecidingHeader
                       | DecidingBody
                       | Done
-                        deriving (Show, Eq, Ord)
+                        deriving (Show, Eq, Ord, Enum)
 
 type InteractionQueue = TVar (Seq Interaction)
 
@@ -56,46 +75,105 @@ newInteractionQueue :: IO InteractionQueue
 newInteractionQueue = newTVarIO S.empty
 
 
-newInteraction :: HostName -> Maybe Request -> IO Interaction
-newInteraction host req
-    = do responce <- newTVarIO Nothing
+defaultPageContentType :: String
+defaultPageContentType = "application/xhtml+xml"
 
-         requestHasBody    <- newTVarIO False
-         requestBodyLength <- newTVarIO Nothing
-         requestIsChunked  <- newTVarIO False
-         receivedBody      <- newTVarIO B.empty
 
-         expectedContinue <- newTVarIO False
+newInteraction :: Config -> SockAddr -> Maybe Request -> IO Interaction
+newInteraction conf addr req
+    = conf `seq` addr `seq` req `seq`
+      do request  <- newTVarIO $ req
+         responce <- newTVarIO $ Response {
+                       resVersion = HttpVersion 1 1
+                     , resStatus  = Ok
+                     , resHeaders = [("Content-Type", defaultPageContentType)]
+                     }
 
-         willChunkBody   <- newTVarIO False
-         willDiscardBody <- newTVarIO False
-         willClose       <- newTVarIO False
-         bodyToSend      <- newTVarIO B.empty
+         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
 
-         state <- newTVarIO undefined
+         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 {
-                      itrRemoteHost = host
-                    , itrRequest    = req
-                    , itrResponse   = responce
+                      itrConfig       = conf
+                    , itrRemoteAddr   = addr
+                    , itrResourcePath = Nothing
+                    , itrRequest      = request
+                    , itrResponse     = responce
 
                     , itrRequestHasBody    = requestHasBody
-                    , itrRequestBodyLength = requestBodyLength
                     , itrRequestIsChunked  = requestIsChunked
+                    , itrExpectedContinue = expectedContinue
+
+                    , itrReqChunkLength    = reqChunkLength
+                    , itrReqChunkRemaining = reqChunkRemaining
+                    , itrReqChunkIsOver    = reqChunkIsOver
+                    , itrReqBodyWanted     = reqBodyWanted
+                    , itrReqBodyWasteAll   = reqBodyWasteAll
                     , itrReceivedBody      = receivedBody
 
-                    , itrExpectedContinue = expectedContinue
+                    , itrWillReceiveBody   = willReceiveBody
+                    , itrWillChunkBody     = willChunkBody
+                    , itrWillDiscardBody   = willDiscardBody
+                    , itrWillClose         = willClose
 
-                    , itrWillChunkBody    = willChunkBody
-                    , itrWillDiscardBody  = willDiscardBody
-                    , itrWillClose        = willClose
-                    , itrBodyToSend       = bodyToSend
+                    , itrBodyToSend = bodyToSend
+                    , itrBodyIsNull = bodyIsNull
                     
                     , itrState = state
                     
                     , itrWroteContinue = wroteContinue
                     , itrWroteHeader   = wroteHeader
                     }
+
+
+writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
+writeItr itr accessor value
+    = itr `seq` accessor `seq` value `seq`
+      writeTVar (accessor itr) value
+
+
+readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
+readItr itr accessor reader
+    = itr `seq` accessor `seq` reader `seq`
+      readTVar (accessor itr) >>= return . reader
+
+
+readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
+readItrF itr accessor reader
+    = itr `seq` accessor `seq` reader `seq`
+      readItr itr accessor (fmap reader)
+{-# SPECIALIZE readItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> b) -> STM (Maybe b) #-}
+
+
+updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
+updateItr itr accessor updator
+    = itr `seq` accessor `seq` updator `seq`
+      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
+    = itr `seq` accessor `seq` updator `seq`
+      updateItr itr accessor (fmap updator)
+{-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-}
\ No newline at end of file