+{-# LANGUAGE
+ OverloadedStrings
+ , RecordWildCards
+ , UnicodeSyntax
+ #-}
module Network.HTTP.Lucu.Interaction
( Interaction(..)
, InteractionState(..)
, newInteraction
, defaultPageContentType
- , writeItr
- , readItr
- , readItrF
- , updateItr
- , updateItrF
+ , setResponseStatus
)
where
-
-import Control.Concurrent.STM
-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 Blaze.ByteString.Builder (Builder)
+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.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
+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
data Interaction = Interaction {
- 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)
+ itrConfig ∷ !Config
+ , itrLocalPort ∷ !PortNumber
+ , itrRemoteAddr ∷ !SockAddr
+ , itrRemoteCert ∷ !(Maybe X509)
+ , itrResourcePath ∷ !(Maybe [Text])
+ , itrRequest ∷ !(Maybe Request)
+
+ , itrExpectedContinue ∷ !(Maybe Bool)
+ , itrReqBodyLength ∷ !(Maybe RequestBodyLength)
+
+ , itrReqBodyWanted ∷ !(TVar Int)
+ , itrReqBodyWasteAll ∷ !(TVar Bool)
+ , itrReqChunkIsOver ∷ !(TVar Bool)
+ , itrReceivedBody ∷ !(TVar (Seq BS.ByteString))
+ , itrReceivedBodyLen ∷ !(TVar Int)
+
+ , itrResponse ∷ !(TVar Response)
+ , itrWillChunkBody ∷ !(TVar Bool)
+ , itrWillDiscardBody ∷ !(TVar Bool)
+ , itrWillClose ∷ !(TVar Bool)
+ , itrBodyToSend ∷ !(TMVar Builder)
+ , itrSentNoBodySoFar ∷ !(TVar Bool)
+
+ , itrState ∷ !(TVar InteractionState)
}
--- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
--- 状態は ExaminingRequest。
+-- |The interaction state of Resource monad. 'ExaminingRequest' is the
+-- initial state.
data InteractionState = ExaminingRequest
| GettingBody
| DecidingHeader
type InteractionQueue = TVar (Seq Interaction)
-
-newInteractionQueue :: IO InteractionQueue
+newInteractionQueue ∷ IO InteractionQueue
newInteractionQueue = newTVarIO S.empty
-
-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
- expectedContinue <- newTVarIO False
-
- reqChunkLength <- newTVarIO Nothing -- 現在のチャンク長
- reqChunkRemaining <- newTVarIO Nothing -- 現在のチャンクの殘り
- reqChunkIsOver <- newTVarIO False -- 最後のチャンクを讀み終へた
- reqBodyWanted <- newTVarIO Nothing -- Resource が要求してゐるチャンク長
- reqBodyWasteAll <- newTVarIO False -- 殘りの body を讀み捨てよと云ふ要求
- receivedBody <- newTVarIO L8.empty
-
- willReceiveBody <- newTVarIO False
- willChunkBody <- newTVarIO False
- willDiscardBody <- newTVarIO False
- willClose <- newTVarIO False
-
- bodyToSend <- newTVarIO L8.empty
- bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False
-
- state <- newTVarIO ExaminingRequest
-
- wroteContinue <- newTVarIO False
- wroteHeader <- newTVarIO False
-
- return $ Interaction {
+defaultPageContentType ∷ Ascii
+defaultPageContentType = "application/xhtml+xml"
+
+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 0
+ reqBodyWasteAll ← newTVarIO False
+ 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
+ , 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
-
- , itrWillReceiveBody = willReceiveBody
- , itrWillChunkBody = willChunkBody
- , itrWillDiscardBody = willDiscardBody
- , itrWillClose = willClose
-
- , itrBodyToSend = bodyToSend
- , itrBodyIsNull = bodyIsNull
+ , 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
}
-
-writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
-writeItr itr accessor value
- = itr `seq` accessor `seq` value `seq`
- writeTVar (accessor itr) value
-
-
-readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
-readItr itr accessor reader
- = itr `seq` accessor `seq` reader `seq`
- readTVar (accessor itr) >>= return . reader
-
-
-readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
-readItrF itr accessor reader
- = itr `seq` accessor `seq` reader `seq`
- 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
- = itr `seq` accessor `seq` updator `seq`
- 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
- = itr `seq` accessor `seq` updator `seq`
- updateItr itr accessor (fmap updator)
-{-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-}
\ No newline at end of file
+setResponseStatus ∷ Interaction → StatusCode → STM ()
+setResponseStatus (Interaction {..}) sc
+ = do res ← readTVar itrResponse
+ let res' = res {
+ resStatus = sc
+ }
+ writeTVar itrResponse res'
projects / Lucu.git / blobdiff