+{-# LANGUAGE
+ BangPatterns
+ , OverloadedStrings
+ , UnicodeSyntax
+ #-}
module Network.HTTP.Lucu.Interaction
( Interaction(..)
, InteractionState(..)
, InteractionQueue
- , newInteractionQueue -- IO InteractionQueue
- , newInteraction -- HostName -> Maybe Request -> IO Interaction
+ , newInteractionQueue
+ , newInteraction
+ , defaultPageContentType
+
+ , writeItr
+ , readItr
+ , updateItr
)
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.Applicative
+import Control.Concurrent.STM
+import Data.Ascii (Ascii)
+import qualified Data.ByteString as BS
+import Data.Sequence (Seq)
import qualified Data.Sequence as S
-import Data.Sequence (Seq)
-import Network
-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.Headers
+import Network.HTTP.Lucu.HttpVersion
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Response
+import OpenSSL.X509
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
+ , itrLocalPort ∷ !PortNumber
+ , itrRemoteAddr ∷ !SockAddr
+ , itrRemoteCert ∷ !(Maybe X509)
+ , itrResourcePath ∷ !(Maybe [Text])
+ , itrRequest ∷ !(TVar (Maybe Request))
+ , itrResponse ∷ !(TVar Response)
+
+ , 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 (Seq BS.ByteString))
+ , itrReceivedBodyLen ∷ !(TVar Int)
+
+ , itrWillReceiveBody ∷ !(TVar Bool)
+ , itrWillChunkBody ∷ !(TVar Bool)
+ , itrWillDiscardBody ∷ !(TVar Bool)
+ , itrWillClose ∷ !(TVar Bool)
+
+ , itrBodyToSend ∷ !(TMVar Builder)
+ , itrSentNoBody ∷ !(TVar Bool)
+
+ , itrState ∷ !(TVar InteractionState)
+
+ , itrWroteContinue ∷ !(TVar Bool)
+ , itrWroteHeader ∷ !(TVar Bool)
}
--- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
--- 状態は ExaminingHeader (リクエストボディが有る時) または
--- DecidingHeader (無い時)。終了状態は常に Done
-data InteractionState = ExaminingHeader
+-- |The interaction state of Resource monad. 'ExaminingRequest' is the
+-- initial state.
+data InteractionState = ExaminingRequest
| GettingBody
| DecidingHeader
| DecidingBody
| Done
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Enum)
type InteractionQueue = TVar (Seq Interaction)
-
-newInteractionQueue :: IO InteractionQueue
+newInteractionQueue ∷ IO InteractionQueue
newInteractionQueue = newTVarIO S.empty
+defaultPageContentType ∷ Ascii
+defaultPageContentType = "application/xhtml+xml"
+
+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 [("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 S.empty
+ receivedBodyLen ← newTVarIO 0
+
+ willReceiveBody ← newTVarIO False
+ willChunkBody ← newTVarIO False
+ willDiscardBody ← newTVarIO False
+ willClose ← newTVarIO False
+
+ bodyToSend ← newEmptyTMVarIO
+ sentNoBody ← newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
+
+ state ← newTVarIO ExaminingRequest
+
+ wroteContinue ← newTVarIO False
+ wroteHeader ← newTVarIO False
+
+ return Interaction {
+ itrConfig = conf
+ , itrLocalPort = port
+ , itrRemoteAddr = addr
+ , itrRemoteCert = cert
+ , itrResourcePath = Nothing
+ , itrRequest = request
+ , itrResponse = responce
+
+ , itrRequestHasBody = requestHasBody
+ , itrRequestIsChunked = requestIsChunked
+ , itrExpectedContinue = expectedContinue
-newInteraction :: HostName -> Maybe Request -> IO Interaction
-newInteraction host req
- = do responce <- newTVarIO Nothing
-
- requestHasBody <- newTVarIO False
- requestBodyLength <- newTVarIO Nothing
- requestIsChunked <- newTVarIO False
- receivedBody <- newTVarIO B.empty
-
- expectedContinue <- newTVarIO False
-
- willChunkBody <- newTVarIO False
- willDiscardBody <- newTVarIO False
- willClose <- newTVarIO False
- bodyToSend <- newTVarIO B.empty
-
- state <- newTVarIO undefined
-
- wroteContinue <- newTVarIO False
- wroteHeader <- newTVarIO False
-
- return $ Interaction {
- itrRemoteHost = host
- , itrRequest = req
- , itrResponse = responce
-
- , itrRequestHasBody = requestHasBody
- , itrRequestBodyLength = requestBodyLength
- , itrRequestIsChunked = requestIsChunked
+ , itrReqChunkLength = reqChunkLength
+ , itrReqChunkRemaining = reqChunkRemaining
+ , itrReqChunkIsOver = reqChunkIsOver
+ , itrReqBodyWanted = reqBodyWanted
+ , itrReqBodyWasteAll = reqBodyWasteAll
, itrReceivedBody = receivedBody
+ , itrReceivedBodyLen = receivedBodyLen
- , itrExpectedContinue = expectedContinue
+ , itrWillReceiveBody = willReceiveBody
+ , itrWillChunkBody = willChunkBody
+ , itrWillDiscardBody = willDiscardBody
+ , itrWillClose = willClose
- , itrWillChunkBody = willChunkBody
- , itrWillDiscardBody = willDiscardBody
- , itrWillClose = willClose
- , itrBodyToSend = bodyToSend
+ , itrBodyToSend = bodyToSend
+ , itrSentNoBody = sentNoBody
, itrState = state
, itrWroteContinue = wroteContinue
, itrWroteHeader = wroteHeader
}
+
+{-
+chunksToLBS ∷ Seq BS.ByteString → LBS.ByteString
+{-# INLINE chunksToLBS #-}
+chunksToLBS = LBS.fromChunks ∘ toList
+
+chunksFromLBS ∷ LBS.ByteString → Seq BS.ByteString
+{-# INLINE chunksFromLBS #-}
+chunksFromLBS = S.fromList ∘ LBS.toChunks
+-}
+
+writeItr ∷ (Interaction → TVar a) → a → Interaction → STM ()
+{-# INLINE writeItr #-}
+writeItr accessor a itr
+ = writeTVar (accessor itr) a
+
+readItr ∷ (Interaction → TVar a) → (a → b) → Interaction → STM b
+{-# INLINE readItr #-}
+readItr accessor reader itr
+ = reader <$> readTVar (accessor itr)
+
+updateItr ∷ (Interaction → TVar a) → (a → a) → Interaction → STM ()
+{-# INLINE updateItr #-}
+updateItr accessor updator itr
+ = do old ← readItr accessor id itr
+ writeItr accessor (updator old) itr
projects / Lucu.git / blobdiff