-data InteractionState = ExaminingRequest
- | GettingBody
- | DecidingHeader
- | DecidingBody
- | Done
- deriving (Show, Eq, Ord, Enum)
-
-type InteractionQueue = TVar (Seq Interaction)
-
-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
- bodyIsNull ← 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
-
- , itrReqChunkLength = reqChunkLength
- , itrReqChunkRemaining = reqChunkRemaining
- , itrReqChunkIsOver = reqChunkIsOver
- , itrReqBodyWanted = reqBodyWanted
- , itrReqBodyWasteAll = reqBodyWasteAll
- , itrReceivedBody = receivedBody
- , itrReceivedBodyLen = receivedBodyLen
-
- , itrWillReceiveBody = willReceiveBody
- , itrWillChunkBody = willChunkBody
- , itrWillDiscardBody = willDiscardBody
- , itrWillClose = willClose
-
- , itrBodyToSend = bodyToSend
- , itrBodyIsNull = bodyIsNull
-
- , 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
+data InteractionState
+ = ExaminingRequest
+ | ReceivingBody
+ | DecidingHeader
+ | SendingBody
+ | Done
+ deriving (Show, Eq, Ord, Enum)
+
+mkNormalInteraction ∷ Config
+ → SockAddr
+#if defined(HAVE_SSL)
+ → Maybe X509
+#endif
+ → AugmentedRequest
+ → [Strict.ByteString]
+ → IO NormalInteraction
+#if defined(HAVE_SSL)
+mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPath
+#else
+mkNormalInteraction config remoteAddr (AugmentedRequest {..}) rsrcPath
+#endif
+ = do receiveBodyReq ← newEmptyTMVarIO
+ receivedBody ← newEmptyTMVarIO
+
+ response ← newTVarIO $ emptyResponse arInitialStatus
+ sendContinue ← newEmptyTMVarIO
+ willDiscardBody ← newTVarIO arWillDiscardBody
+ willClose ← newTVarIO arWillClose
+ responseHasCType ← newTVarIO False
+ bodyToSend ← newEmptyTMVarIO
+
+ state ← newTVarIO ExaminingRequest
+
+ return NI {
+ niConfig = config
+ , niRemoteAddr = remoteAddr
+#if defined(HAVE_SSL)
+ , niRemoteCert = remoteCert
+#endif
+ , niRequest = arRequest
+ , niResourcePath = rsrcPath
+ , niExpectedContinue = arExpectedContinue
+ , niReqBodyLength = arReqBodyLength
+
+ , niReceiveBodyReq = receiveBodyReq
+ , niReceivedBody = receivedBody
+
+ , niResponse = response
+ , niSendContinue = sendContinue
+ , niWillChunkBody = arWillChunkBody
+ , niWillDiscardBody = willDiscardBody
+ , niWillClose = willClose
+ , niResponseHasCType = responseHasCType
+ , niBodyToSend = bodyToSend
+
+ , niState = state
+ }
+
+type InteractionQueue = TVar (Seq SomeInteraction)
+
+mkInteractionQueue ∷ IO InteractionQueue
+mkInteractionQueue = newTVarIO (∅)
+
+getCurrentDate ∷ IO Ascii
+getCurrentDate = HTTP.toAscii <$> getCurrentTime