+{-# LANGUAGE
+ OverloadedStrings
+ , RecordWildCards
+ , UnicodeSyntax
+ #-}
module Network.HTTP.Lucu.Interaction
( Interaction(..)
, InteractionState(..)
, InteractionQueue
- , newInteractionQueue -- IO InteractionQueue
- , newInteraction -- HostName -> Maybe Request -> IO Interaction
+ , ReceiveBodyRequest(..)
+ , newInteractionQueue
+ , newInteraction
+
+ , setResponseStatus
)
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.Concurrent.STM
+import qualified Data.ByteString as Strict
+import Data.Monoid.Unicode
+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.HttpVersion
+import Network.HTTP.Lucu.Preprocess
+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 ∷ !(Maybe Request)
+
+ , itrExpectedContinue ∷ !(Maybe Bool)
+ , itrReqBodyLength ∷ !(Maybe RequestBodyLength)
+
+ , itrReceiveBodyReq ∷ !(TMVar ReceiveBodyRequest)
+ , itrReceivedBody ∷ !(TMVar Strict.ByteString)
+
+ , itrResponse ∷ !(TVar Response)
+ , itrWillChunkBody ∷ !(TVar Bool)
+ , itrWillDiscardBody ∷ !(TVar Bool)
+ , itrWillClose ∷ !(TVar Bool)
+ , itrResponseHasCType ∷ !(TVar Bool)
+ , itrBodyToSend ∷ !(TMVar Builder)
+
+ , itrState ∷ !(TVar InteractionState)
}
--- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
--- 状態は ExaminingHeader (リクエストボディが有る時) または
--- DecidingHeader (無い時)。終了状態は常に Done
-data InteractionState = ExaminingHeader
- | GettingBody
- | DecidingHeader
- | DecidingBody
- | Done
- deriving (Show, Eq, Ord)
+-- |The interaction state of Resource monad. 'ExaminingRequest' is the
+-- initial state.
+data InteractionState
+ = ExaminingRequest
+ | ReceivingBody
+ | DecidingHeader
+ | SendingBody
+ | Done
+ deriving (Show, Eq, Ord, Enum)
type InteractionQueue = TVar (Seq Interaction)
+data ReceiveBodyRequest
+ = ReceiveBody !Int -- ^ Maximum number of octets to receive.
+ | WasteAll
+ deriving (Show, Eq)
-newInteractionQueue :: IO InteractionQueue
+newInteractionQueue ∷ IO InteractionQueue
newInteractionQueue = newTVarIO S.empty
-
-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
- , itrReceivedBody = receivedBody
-
- , itrExpectedContinue = expectedContinue
-
+newInteraction ∷ Config
+ → PortNumber
+ → SockAddr
+ → Maybe X509
+ → Either StatusCode Request
+ → IO Interaction
+newInteraction conf@(Config {..}) port addr cert request
+ = do let ar = preprocess cnfServerHost port request
+ res = Response {
+ resVersion = HttpVersion 1 1
+ , resStatus = arInitialStatus ar
+ , resHeaders = (∅)
+ }
+
+ receiveBodyReq ← newEmptyTMVarIO
+ receivedBody ← newEmptyTMVarIO
+
+ response ← newTVarIO res
+ willChunkBody ← newTVarIO False
+ willDiscardBody ← newTVarIO (arWillDiscardBody ar)
+ willClose ← newTVarIO (arWillClose ar)
+ bodyToSend ← newEmptyTMVarIO
+ responseHasCType ← newTVarIO False
+
+ state ← newTVarIO ExaminingRequest
+
+ return Interaction {
+ itrConfig = conf
+ , itrLocalPort = port
+ , itrRemoteAddr = addr
+ , itrRemoteCert = cert
+ , itrResourcePath = Nothing
+ , itrRequest = arRequest ar
+
+ , itrExpectedContinue = arExpectedContinue ar
+ , itrReqBodyLength = arReqBodyLength ar
+
+ , itrReceiveBodyReq = receiveBodyReq
+ , itrReceivedBody = receivedBody
+
+ , itrResponse = response
, itrWillChunkBody = willChunkBody
, itrWillDiscardBody = willDiscardBody
, itrWillClose = willClose
+ , itrResponseHasCType = responseHasCType
, itrBodyToSend = bodyToSend
- , itrState = state
-
- , itrWroteContinue = wroteContinue
- , itrWroteHeader = wroteHeader
+ , itrState = state
+ }
+
+setResponseStatus ∷ Interaction → StatusCode → STM ()
+setResponseStatus (Interaction {..}) sc
+ = do res ← readTVar itrResponse
+ let res' = res {
+ resStatus = sc
}
+ writeTVar itrResponse res'
projects / Lucu.git / blobdiff