-import Prelude.Unicode
-
-data Interaction = Interaction {
- itrConfig ∷ !Config
- , itrLocalPort ∷ !PortNumber
- , itrRemoteAddr ∷ !SockAddr
- , itrRemoteCert ∷ !(Maybe X509)
- , itrResourcePath ∷ !(Maybe [Ascii])
- , itrRequest ∷ !(TVar (Maybe Request))
- , itrResponse ∷ !(TVar Response)
-
- , itrRequestHasBody ∷ !(TVar Bool)
- , itrRequestIsChunked ∷ !(TVar Bool)
- , itrExpectedContinue ∷ !(TVar Bool)
-
- , itrReqChunkLength ∷ !(TVar (Maybe Int))
- , itrReqChunkRemaining ∷ !(TVar (Maybe Int))
- , itrReqChunkIsOver ∷ !(TVar Bool)
- , itrReqBodyWanted ∷ !(TVar (Maybe Int))
- , itrReqBodyWasteAll ∷ !(TVar Bool)
- , itrReceivedBody ∷ !(TVar (Seq BS.ByteString))
-
- , itrWillReceiveBody ∷ !(TVar Bool)
- , itrWillChunkBody ∷ !(TVar Bool)
- , itrWillDiscardBody ∷ !(TVar Bool)
- , itrWillClose ∷ !(TVar Bool)
-
- , itrBodyToSend ∷ !(TVar (Seq BS.ByteString))
- , itrBodyIsNull ∷ !(TVar Bool)
-
- , itrState ∷ !(TVar InteractionState)
-
- , itrWroteContinue ∷ !(TVar Bool)
- , itrWroteHeader ∷ !(TVar Bool)
- }
+#endif
+
+class Typeable i ⇒ Interaction i where
+ toInteraction ∷ i → SomeInteraction
+ toInteraction = SomeInteraction
+
+ fromInteraction ∷ SomeInteraction → Maybe i
+ fromInteraction (SomeInteraction i) = cast i
+
+data SomeInteraction
+ = ∀i. Interaction i ⇒ SomeInteraction !i
+ deriving Typeable
+
+instance Interaction SomeInteraction where
+ toInteraction = id
+ fromInteraction = Just
+
+-- |'SyntacticallyInvalidInteraction' is an 'Interaction' without even
+-- a syntactically valid 'Request'. The response code will always be
+-- 'BadRequest'.
+data SyntacticallyInvalidInteraction
+ = SYI {
+ syiResponse ∷ !Response
+ , syiBodyToSend ∷ !Builder
+ }
+ deriving Typeable
+instance Interaction SyntacticallyInvalidInteraction
+
+mkSyntacticallyInvalidInteraction ∷ Config
+ → IO SyntacticallyInvalidInteraction
+mkSyntacticallyInvalidInteraction config@(Config {..})
+ = do date ← getCurrentDate
+ let res = setHeader "Server" cnfServerSoftware $
+ setHeader "Date" date $
+ setHeader "Content-Type" defaultPageContentType $
+ emptyResponse BadRequest
+ body = getDefaultPage config Nothing res
+ return SYI {
+ syiResponse = res
+ , syiBodyToSend = body
+ }
+
+-- |'SemanticallyInvalidInteraction' is an 'Interaction' without a
+-- semantically valid 'Request'. The response code will always satisfy
+-- 'isError'.
+data SemanticallyInvalidInteraction
+ = SEI {
+ seiRequest ∷ !Request
+ , seiExpectedContinue ∷ !Bool
+ , seiReqBodyLength ∷ !(Maybe RequestBodyLength)
+
+ , seiResponse ∷ !Response
+ , seiWillChunkBody ∷ !Bool
+ , seiWillDiscardBody ∷ !Bool
+ , seiWillClose ∷ !Bool
+ , seiBodyToSend ∷ !Builder
+ }
+ deriving Typeable
+instance Interaction SemanticallyInvalidInteraction
+
+mkSemanticallyInvalidInteraction ∷ Config
+ → AugmentedRequest
+ → IO SemanticallyInvalidInteraction
+mkSemanticallyInvalidInteraction config@(Config {..}) (AugmentedRequest {..})
+ = do date ← getCurrentDate
+ let res = setHeader "Server" cnfServerSoftware $
+ setHeader "Date" date $
+ setHeader "Content-Type" defaultPageContentType $
+ emptyResponse arInitialStatus
+ body = getDefaultPage config (Just arRequest) res
+ return SEI {
+ seiRequest = arRequest
+ , seiExpectedContinue = arExpectedContinue
+ , seiReqBodyLength = arReqBodyLength
+
+ , seiResponse = res
+ , seiWillChunkBody = arWillChunkBody
+ , seiWillDiscardBody = arWillDiscardBody
+ , seiWillClose = arWillClose
+ , seiBodyToSend = body
+ }
+
+-- |'NormalInteraction' is an 'Interaction' with a semantically
+-- correct 'Request'.
+data NormalInteraction
+ = NI {
+ niConfig ∷ !Config
+ , niRemoteAddr ∷ !SockAddr
+#if defined(HAVE_SSL)
+ , niRemoteCert ∷ !(Maybe X509)
+#endif
+ , niRequest ∷ !Request
+ , niResourcePath ∷ ![Strict.ByteString]
+ , niExpectedContinue ∷ !Bool
+ , niReqBodyLength ∷ !(Maybe RequestBodyLength)
+
+ , niReceiveBodyReq ∷ !(TMVar ReceiveBodyRequest)
+ , niReceivedBody ∷ !(TMVar Strict.ByteString)
+
+ , niResponse ∷ !(TVar Response)
+ , niSendContinue ∷ !(TMVar Bool)
+ , niWillChunkBody ∷ !Bool
+ , niWillDiscardBody ∷ !(TVar Bool)
+ , niWillClose ∷ !(TVar Bool)
+ , niResponseHasCType ∷ !(TVar Bool)
+ -- FIXME: use TBChan Builder (in stm-chans package)
+ , niBodyToSend ∷ !(TMVar Builder)
+
+ , niState ∷ !(TVar InteractionState)
+ }
+ deriving Typeable
+instance Interaction NormalInteraction
+
+data ReceiveBodyRequest
+ = ReceiveBody !Int -- ^ Maximum number of octets to receive.
+ | WasteAll
+ deriving (Show, Eq)