{-# LANGUAGE
- BangPatterns
- , OverloadedStrings
+ OverloadedStrings
+ , RecordWildCards
, UnicodeSyntax
#-}
module Network.HTTP.Lucu.Interaction
, newInteractionQueue
, newInteraction
, defaultPageContentType
-{-
- , writeItr
- , readItr
- , updateItr
--}
+
+ , setResponseStatus
)
where
import Blaze.ByteString.Builder (Builder)
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)
+ , itrReqChunkIsOver ∷ !(TVar Bool)
, itrReceivedBody ∷ !(TVar (Seq BS.ByteString))
, itrReceivedBodyLen ∷ !(TVar Int)
- , itrWillReceiveBody ∷ !(TVar Bool)
+ , itrResponse ∷ !(TVar Response)
, itrWillChunkBody ∷ !(TVar Bool)
, itrWillDiscardBody ∷ !(TVar Bool)
, itrWillClose ∷ !(TVar Bool)
-
, itrBodyToSend ∷ !(TMVar Builder)
- , itrSentNoBody ∷ !(TVar Bool)
+ , itrSentNoBodySoFar ∷ !(TVar Bool)
, itrState ∷ !(TVar InteractionState)
-
- , itrWroteContinue ∷ !(TVar Bool)
- , itrWroteHeader ∷ !(TVar Bool)
}
-- |The interaction state of Resource monad. 'ExaminingRequest' is the
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 = singleton "Content-Type" defaultPageContentType
+ }
+
+ reqBodyWanted ← newTVarIO Nothing -- Resource が要求してゐるチャンク長
+ reqBodyWasteAll ← newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求
+ reqChunkIsOver ← newTVarIO False -- 最後のチャンクを讀み終へた
+ receivedBody ← newTVarIO S.empty
+ receivedBodyLen ← newTVarIO 0
+
+ response ← newTVarIO res
+ willChunkBody ← newTVarIO False
+ willDiscardBody ← newTVarIO False
+ willClose ← newTVarIO False
+ bodyToSend ← newEmptyTMVarIO
+ sentNoBodySoFar ← newTVarIO True
+
+ state ← newTVarIO ExaminingRequest
return Interaction {
itrConfig = conf
, 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
+ , itrRequest = arRequest ar
+
+ , itrExpectedContinue = arExpectedContinue ar
+ , itrReqBodyLength = arReqBodyLength ar
+
+ , itrReqBodyWanted = reqBodyWanted
+ , itrReqBodyWasteAll = reqBodyWasteAll
+ , itrReqChunkIsOver = reqChunkIsOver
+ , itrReceivedBody = receivedBody
+ , itrReceivedBodyLen = receivedBodyLen
+
+ , itrResponse = response
+ , itrWillChunkBody = willChunkBody
+ , itrWillDiscardBody = willDiscardBody
+ , itrWillClose = willClose
+ , itrBodyToSend = bodyToSend
+ , itrSentNoBodySoFar = sentNoBodySoFar
- , itrState = state
-
- , 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) → Interaction → STM a
-{-# INLINE readItr #-}
-readItr accessor itr
- = readTVar (accessor itr)
-
-updateItr ∷ (Interaction → TVar a) → (a → a) → Interaction → STM ()
-{-# INLINE updateItr #-}
-updateItr accessor updator itr
- = do old ← readItr accessor 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