X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FInteraction.hs;h=638d1b05bafc472f364cfb7626930f6f00a86423;hb=70bf5bd248aa426ca4e410b3fb9a0529354aedaf;hp=4c0735a3f54e3da532101c27c5e2b28bf0a10811;hpb=83db536d11e8efb26848318ad4514b825f412460;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index 4c0735a..638d1b0 100644
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -1,3 +1,7 @@
+{-# LANGUAGE
+    BangPatterns
+  , UnicodeSyntax
+  #-}
 module Network.HTTP.Lucu.Interaction
     ( Interaction(..)
     , InteractionState(..)
@@ -15,9 +19,10 @@ module Network.HTTP.Lucu.Interaction
     where
 
 import           Control.Concurrent.STM
-import           Data.ByteString.Base (ByteString, LazyByteString)
-import           Data.ByteString.Char8 as C8
-import qualified Data.ByteString.Lazy.Char8 as L8
+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.Socket
@@ -26,31 +31,34 @@ 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
+    , itrLocalPort    :: !PortNumber
     , itrRemoteAddr   :: !SockAddr
+    , itrRemoteCert   :: !(Maybe X509)
     , itrResourcePath :: !(Maybe [String])
-    , itrRequest      :: !(TVar (Maybe Request))
+    , itrRequest      :: !(TVar (Maybe Request)) -- FIXME: TVar である必要無し
     , itrResponse     :: !(TVar Response)
 
-    , itrRequestHasBody    :: !(TVar Bool)
-    , itrRequestIsChunked  :: !(TVar Bool)
-    , itrExpectedContinue  :: !(TVar Bool)
+    , 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 LazyByteString) -- Resource が受領した部分は削除される
+    , itrReceivedBody      :: !(TVar Lazy.ByteString) -- Resource が受領した部分は削除される
 
     , itrWillReceiveBody   :: !(TVar Bool)
     , itrWillChunkBody     :: !(TVar Bool)
     , itrWillDiscardBody   :: !(TVar Bool)
     , itrWillClose         :: !(TVar Bool)
 
-    , itrBodyToSend :: !(TVar LazyByteString)
+    , itrBodyToSend :: !(TVar Lazy.ByteString)
     , itrBodyIsNull :: !(TVar Bool)
 
     , itrState :: !(TVar InteractionState)
@@ -75,15 +83,14 @@ newInteractionQueue :: IO InteractionQueue
 newInteractionQueue = newTVarIO S.empty
 
 
-defaultPageContentType :: ByteString
+defaultPageContentType :: Strict.ByteString
 defaultPageContentType = C8.pack "application/xhtml+xml"
 
 
-newInteraction :: Config -> SockAddr -> Maybe Request -> IO Interaction
-newInteraction conf addr req
-    = conf `seq` addr `seq` req `seq`
-      do request  <- newTVarIO $ req
-         responce <- newTVarIO $ Response {
+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 [(C8.pack "Content-Type", defaultPageContentType)]
@@ -113,9 +120,11 @@ newInteraction conf addr req
          wroteContinue <- newTVarIO False
          wroteHeader   <- newTVarIO False
 
-         return $ Interaction {
+         return Interaction {
                       itrConfig       = conf
+                    , itrLocalPort    = port
                     , itrRemoteAddr   = addr
+                    , itrRemoteCert   = cert
                     , itrResourcePath = Nothing
                     , itrRequest      = request
                     , itrResponse     = responce
@@ -147,33 +156,28 @@ newInteraction conf addr req
 
 
 writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
-writeItr itr accessor value
-    = itr `seq` accessor `seq` value `seq`
-      writeTVar (accessor itr) value
+writeItr !itr !accessor !value
+    = 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
+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
-    = itr `seq` accessor `seq` reader `seq`
-      readItr itr accessor (fmap reader)
+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
-    = itr `seq` accessor `seq` updator `seq`
-      do old <- readItr itr accessor id
+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
-    = itr `seq` accessor `seq` updator `seq`
-      updateItr itr accessor (fmap updator)
+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