{-# LANGUAGE
- BangPatterns
- , OverloadedStrings
+ OverloadedStrings
+ , RecordWildCards
, UnicodeSyntax
#-}
module Network.HTTP.Lucu.Interaction
( Interaction(..)
, InteractionState(..)
, InteractionQueue
+ , ReceiveBodyRequest(..)
, newInteractionQueue
, newInteraction
- , defaultPageContentType
- , writeItr
- , readItr
- , updateItr
+ , setResponseStatus
)
where
import Blaze.ByteString.Builder (Builder)
-import Control.Applicative
import Control.Concurrent.STM
-import Data.Ascii (Ascii)
-import qualified Data.ByteString as BS
+import qualified Data.ByteString as Strict
+import Data.Monoid.Unicode
import Data.Sequence (Seq)
import qualified Data.Sequence as S
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.Preprocess
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import OpenSSL.X509
, itrRemoteAddr ∷ !SockAddr
, itrRemoteCert ∷ !(Maybe X509)
, itrResourcePath ∷ !(Maybe [Text])
- , itrRequest ∷ !(TVar (Maybe Request))
- , itrResponse ∷ !(TVar Response)
+ , itrRequest ∷ !(Maybe Request)
- , itrRequestHasBody ∷ !(TVar Bool)
- , itrRequestIsChunked ∷ !(TVar Bool)
- , itrExpectedContinue ∷ !(TVar Bool)
+ , itrExpectedContinue ∷ !(Maybe Bool)
+ , itrReqBodyLength ∷ !(Maybe RequestBodyLength)
- , 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)
+ , itrReceiveBodyReq ∷ !(TMVar ReceiveBodyRequest)
+ , itrReceivedBody ∷ !(TMVar Strict.ByteString)
- , itrWillReceiveBody ∷ !(TVar Bool)
+ , itrResponse ∷ !(TVar Response)
, itrWillChunkBody ∷ !(TVar Bool)
, itrWillDiscardBody ∷ !(TVar Bool)
, itrWillClose ∷ !(TVar Bool)
-
+ , itrResponseHasCType ∷ !(TVar Bool)
, itrBodyToSend ∷ !(TMVar Builder)
- , itrSentNoBody ∷ !(TVar Bool)
, itrState ∷ !(TVar InteractionState)
-
- , itrWroteContinue ∷ !(TVar Bool)
- , itrWroteHeader ∷ !(TVar Bool)
}
-- |The interaction state of Resource monad. 'ExaminingRequest' is the
-- initial state.
-data InteractionState = ExaminingRequest
- | GettingBody
- | DecidingHeader
- | DecidingBody
- | Done
- deriving (Show, Eq, Ord, Enum)
+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 = 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
+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 = request
- , itrResponse = responce
-
- , itrRequestHasBody = requestHasBody
- , itrRequestIsChunked = requestIsChunked
- , itrExpectedContinue = expectedContinue
-
- , itrReqChunkLength = reqChunkLength
- , itrReqChunkRemaining = reqChunkRemaining
- , itrReqChunkIsOver = reqChunkIsOver
- , itrReqBodyWanted = reqBodyWanted
- , itrReqBodyWasteAll = reqBodyWasteAll
- , itrReceivedBody = receivedBody
- , itrReceivedBodyLen = receivedBodyLen
-
- , itrWillReceiveBody = willReceiveBody
- , itrWillChunkBody = willChunkBody
- , itrWillDiscardBody = willDiscardBody
- , itrWillClose = willClose
-
- , itrBodyToSend = bodyToSend
- , itrSentNoBody = sentNoBody
-
- , itrState = state
+ 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
- , itrWroteContinue = wroteContinue
- , itrWroteHeader = wroteHeader
+ , itrState = state
}
-{-
-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
+setResponseStatus ∷ Interaction → StatusCode → STM ()
+setResponseStatus (Interaction {..}) sc
+ = do res ← readTVar itrResponse
+ let res' = res {
+ resStatus = sc
+ }
+ writeTVar itrResponse res'
projects / Lucu.git / blobdiff