( 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 の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
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
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
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
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