X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FInteraction.hs;h=df5e2302d21b16da302ce833bd849a2d1a068766;hp=4ac7c093607729fe8784acc3f8e914c96fed1b66;hb=51eda5b;hpb=72a3e24a952616e32845eeb4fc05048e841c91a2 diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 4ac7c09..df5e230 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -1,134 +1,228 @@ {-# LANGUAGE - OverloadedStrings + DeriveDataTypeable + , ExistentialQuantification + , OverloadedStrings , RecordWildCards , UnicodeSyntax #-} module Network.HTTP.Lucu.Interaction ( Interaction(..) + , SomeInteraction(..) + + , SyntacticallyInvalidInteraction(..) + , mkSyntacticallyInvalidInteraction + + , SemanticallyInvalidInteraction(..) + , mkSemanticallyInvalidInteraction + + , NormalInteraction(..) , InteractionState(..) + , ReceiveBodyRequest(..) + , mkNormalInteraction + , InteractionQueue - , newInteractionQueue - , newInteraction + , mkInteractionQueue , setResponseStatus + , getCurrentDate ) where import Blaze.ByteString.Builder (Builder) +import Control.Applicative import Control.Concurrent.STM -import qualified Data.ByteString as BS +import Data.Ascii (Ascii) +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 Data.Time +import qualified Data.Time.HTTP as HTTP +import Data.Typeable import Network.Socket import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.HttpVersion +import Network.HTTP.Lucu.DefaultPage +import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.Preprocess import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import OpenSSL.X509 -data Interaction = Interaction { - 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) - , itrResponseHasCType ∷ !(TVar Bool) - , itrBodyToSend ∷ !(TMVar Builder) - - , itrState ∷ !(TVar InteractionState) - } +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 + , niRemoteCert ∷ !(Maybe X509) + , 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) + , 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) -- |The interaction state of Resource monad. 'ExaminingRequest' is the -- initial state. -data InteractionState = ExaminingRequest - | GettingBody - | DecidingHeader - | DecidingBody - | Done - deriving (Show, Eq, Ord, Enum) - -type InteractionQueue = TVar (Seq Interaction) - -newInteractionQueue ∷ IO InteractionQueue -newInteractionQueue = newTVarIO S.empty - -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 = (∅) - } - - reqBodyWanted ← newTVarIO 0 - reqBodyWasteAll ← newTVarIO False - reqChunkIsOver ← newTVarIO False - receivedBody ← newTVarIO S.empty - receivedBodyLen ← newTVarIO 0 - - response ← newTVarIO res - willChunkBody ← newTVarIO False - willDiscardBody ← newTVarIO (arWillDiscardBody ar) - willClose ← newTVarIO (arWillClose ar) - bodyToSend ← newEmptyTMVarIO +data InteractionState + = ExaminingRequest + | ReceivingBody + | DecidingHeader + | SendingBody + | Done + deriving (Show, Eq, Ord, Enum) + +mkNormalInteraction ∷ Config + → SockAddr + → Maybe X509 + → AugmentedRequest + → [Strict.ByteString] + → IO NormalInteraction +mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPath + = 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 Interaction { - itrConfig = conf - , itrLocalPort = port - , itrRemoteAddr = addr - , itrRemoteCert = cert - , itrResourcePath = Nothing - , 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 - , itrResponseHasCType = responseHasCType - , itrBodyToSend = bodyToSend - - , itrState = state - } - -setResponseStatus ∷ Interaction → StatusCode → STM () -setResponseStatus (Interaction {..}) sc - = do res ← readTVar itrResponse + return NI { + niConfig = config + , niRemoteAddr = remoteAddr + , niRemoteCert = remoteCert + , 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 (∅) + +setResponseStatus ∷ StatusCode sc ⇒ NormalInteraction → sc → STM () +setResponseStatus (NI {..}) sc + = do res ← readTVar niResponse let res' = res { - resStatus = sc + resStatus = fromStatusCode sc } - writeTVar itrResponse res' + writeTVar niResponse res' + +getCurrentDate ∷ IO Ascii +getCurrentDate = HTTP.toAscii <$> getCurrentTime