X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FInteraction.hs;h=5da428d4968ff225e31ac84fa003f013fbdf3d77;hb=f62b6f07bbf1eefcf552163d8f7daa6e0862ed5d;hp=0dd925916cc68d7fc083d9d6c31827e883525777;hpb=b340a77fa7bd051dd13a41d0a5b1ad30220bc6b6;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index 0dd9259..5da428d 100644
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -1,63 +1,65 @@
--- #hide
 module Network.HTTP.Lucu.Interaction
     ( Interaction(..)
     , InteractionState(..)
     , InteractionQueue
-    , newInteractionQueue -- IO InteractionQueue
-    , newInteraction      -- Config -> HostName -> Maybe Request -> IO Interaction
-
-    , writeItr   -- Interaction -> (Interaction -> TVar a) -> a -> STM ()
-    , readItr    -- Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
-    , readItrF   -- (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
-    , updateItr  -- Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
-    , updateItrF -- (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
+    , newInteractionQueue
+    , newInteraction
+    , defaultPageContentType
+
+    , writeItr
+    , readItr
+    , readItrF
+    , updateItr
+    , updateItrF
     )
     where
 
 import           Control.Concurrent.STM
-import qualified Data.ByteString.Lazy.Char8 as B
-import           Data.ByteString.Lazy.Char8 (ByteString)
+import qualified Data.ByteString as Strict (ByteString)
+import qualified Data.ByteString.Lazy as Lazy (ByteString)
+import           Data.ByteString.Char8 as C8 hiding (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as L8 hiding (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.Headers
+import           Network.HTTP.Lucu.HttpVersion
 import           Network.HTTP.Lucu.Request
 import           Network.HTTP.Lucu.Response
+import           OpenSSL.X509
 
 data Interaction = Interaction {
-      itrConfig       :: Config
-    , itrRemoteHost   :: HostName
-    , itrResourcePath :: Maybe [String]
-    , itrRequest      :: Maybe Request
-    , itrResponse     :: TVar (Maybe 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
+    , itrRemoteAddr   :: !SockAddr
+    , itrRemoteCert   :: !(Maybe X509)
+    , itrResourcePath :: !(Maybe [String])
+    , itrRequest      :: !(TVar (Maybe Request)) -- FIXME: TVar である必要無し
+    , itrResponse     :: !(TVar Response)
+
+    , itrRequestHasBody    :: !(TVar Bool) -- FIXME: TVar である必要無し
+    , itrRequestIsChunked  :: !(TVar Bool) -- FIXME: TVar である必要無し
+    , itrExpectedContinue  :: !(TVar Bool) -- FIXME: TVar である必要無し
+
+    , itrReqChunkLength    :: !(TVar (Maybe Int))
+    , itrReqChunkRemaining :: !(TVar (Maybe Int))
+    , itrReqChunkIsOver    :: !(TVar Bool)
+    , itrReqBodyWanted     :: !(TVar (Maybe Int))
+    , itrReqBodyWasteAll   :: !(TVar Bool)
+    , itrReceivedBody      :: !(TVar Lazy.ByteString) -- Resource が受領した部分は削除される
+
+    , itrWillReceiveBody   :: !(TVar Bool)
+    , itrWillChunkBody     :: !(TVar Bool)
+    , itrWillDiscardBody   :: !(TVar Bool)
+    , itrWillClose         :: !(TVar Bool)
+
+    , itrBodyToSend :: !(TVar Lazy.ByteString)
+    , itrBodyIsNull :: !(TVar Bool)
+
+    , itrState :: !(TVar InteractionState)
+
+    , itrWroteContinue :: !(TVar Bool)
+    , itrWroteHeader   :: !(TVar Bool)
     }
 
 -- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
@@ -76,9 +78,18 @@ newInteractionQueue :: IO InteractionQueue
 newInteractionQueue = newTVarIO S.empty
 
 
-newInteraction :: Config -> HostName -> Maybe Request -> IO Interaction
-newInteraction conf host req
-    = do responce <- newTVarIO Nothing
+defaultPageContentType :: Strict.ByteString
+defaultPageContentType = C8.pack "application/xhtml+xml"
+
+
+newInteraction :: Config -> SockAddr -> Maybe X509 -> Maybe Request -> IO Interaction
+newInteraction !conf !addr !cert !req
+    = do request  <- newTVarIO req
+         responce <- newTVarIO Response {
+                       resVersion = HttpVersion 1 1
+                     , resStatus  = Ok
+                     , resHeaders = toHeaders [(C8.pack "Content-Type", defaultPageContentType)]
+                     }
 
          requestHasBody     <- newTVarIO False
          requestIsChunked   <- newTVarIO False
@@ -89,14 +100,14 @@ newInteraction conf host req
          reqChunkIsOver     <- newTVarIO False   -- 最後のチャンクを讀み終へた
          reqBodyWanted      <- newTVarIO Nothing -- Resource が要求してゐるチャンク長
          reqBodyWasteAll    <- newTVarIO False   -- 殘りの body を讀み捨てよと云ふ要求
-         receivedBody       <- newTVarIO B.empty
+         receivedBody       <- newTVarIO L8.empty
 
          willReceiveBody   <- newTVarIO False
          willChunkBody     <- newTVarIO False
          willDiscardBody   <- newTVarIO False
          willClose         <- newTVarIO False
 
-         bodyToSend <- newTVarIO B.empty
+         bodyToSend <- newTVarIO L8.empty
          bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
 
          state <- newTVarIO ExaminingRequest
@@ -104,15 +115,16 @@ newInteraction conf host req
          wroteContinue <- newTVarIO False
          wroteHeader   <- newTVarIO False
 
-         return $ Interaction {
+         return Interaction {
                       itrConfig       = conf
-                    , itrRemoteHost   = host
+                    , itrRemoteAddr   = addr
+                    , itrRemoteCert   = cert
                     , itrResourcePath = Nothing
-                    , itrRequest      = req
+                    , itrRequest      = request
                     , itrResponse     = responce
 
-                    , itrRequestHasBody    = requestHasBody
-                    , itrRequestIsChunked  = requestIsChunked
+                    , itrRequestHasBody   = requestHasBody
+                    , itrRequestIsChunked = requestIsChunked
                     , itrExpectedContinue = expectedContinue
 
                     , itrReqChunkLength    = reqChunkLength
@@ -138,26 +150,28 @@ newInteraction conf host req
 
 
 writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
-writeItr itr accessor value
+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
+readItr !itr !accessor !reader
+    = fmap reader $ readTVar (accessor itr)
 
 
-readItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
-readItrF itr accessor reader
+readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
+readItrF !itr !accessor !reader
     = 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
+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
+updateItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
+updateItrF !itr !accessor !updator
     = updateItr itr accessor (fmap updator)
+{-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-}
\ No newline at end of file