+{-# LANGUAGE
+ DeriveDataTypeable
+ , ExistentialQuantification
+ , OverloadedStrings
+ , RecordWildCards
+ , UnicodeSyntax
+ #-}
module Network.HTTP.Lucu.Interaction
( Interaction(..)
- , InteractionState(..)
- , InteractionQueue
- , newInteractionQueue -- IO InteractionQueue
- , newInteraction -- HostName -> Maybe Request -> IO Interaction
-
- , writeItr -- Interaction -> (Interaction -> TVar a) -> a -> STM ()
- , readItr -- Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
- , readItrF -- (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
- , updateItr -- Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
- , updateItrF -- (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
- )
- where
-
-import Control.Concurrent.STM
-import qualified Data.ByteString.Lazy.Char8 as B
-import Data.ByteString.Lazy.Char8 (ByteString)
-import qualified Data.Sequence as S
-import Data.Sequence (Seq)
-import Network
-import Network.HTTP.Lucu.Request
-import Network.HTTP.Lucu.Response
-
-data Interaction = Interaction {
- itrRemoteHost :: HostName
- , itrRequest :: Maybe Request
- , itrResponse :: TVar (Maybe Response)
-
- , itrRequestHasBody :: TVar Bool
- , itrRequestBodyLength :: TVar (Maybe Integer) -- chunked の場合は不明
- , itrRequestIsChunked :: TVar Bool
- , itrReceivedBody :: TVar ByteString -- Resource が受領した部分は削除される
-
- , itrExpectedContinue :: TVar Bool
-
- , itrWillChunkBody :: TVar Bool
- , itrWillDiscardBody :: TVar Bool
- , itrWillClose :: TVar Bool
- , itrBodyToSend :: TVar ByteString
-
- , itrState :: TVar InteractionState
-
- , itrWroteContinue :: TVar Bool
- , itrWroteHeader :: TVar Bool
- }
-
--- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期
--- 状態は ExaminingHeader (リクエストボディが有る時) または
--- DecidingHeader (無い時)。終了状態は常に Done
-data InteractionState = ExaminingHeader
- | GettingBody
- | DecidingHeader
- | DecidingBody
- | Done
- deriving (Show, Eq, Ord)
-
-type InteractionQueue = TVar (Seq Interaction)
-
-
-newInteractionQueue :: IO InteractionQueue
-newInteractionQueue = newTVarIO S.empty
-
-
-newInteraction :: HostName -> Maybe Request -> IO Interaction
-newInteraction host req
- = do responce <- newTVarIO Nothing
-
- requestHasBody <- newTVarIO False
- requestBodyLength <- newTVarIO Nothing
- requestIsChunked <- newTVarIO False
- receivedBody <- newTVarIO B.empty
-
- expectedContinue <- newTVarIO False
-
- willChunkBody <- newTVarIO False
- willDiscardBody <- newTVarIO False
- willClose <- newTVarIO False
- bodyToSend <- newTVarIO B.empty
-
- state <- newTVarIO undefined
-
- wroteContinue <- newTVarIO False
- wroteHeader <- newTVarIO False
-
- return $ Interaction {
- itrRemoteHost = host
- , itrRequest = req
- , itrResponse = responce
-
- , itrRequestHasBody = requestHasBody
- , itrRequestBodyLength = requestBodyLength
- , itrRequestIsChunked = requestIsChunked
- , itrReceivedBody = receivedBody
-
- , itrExpectedContinue = expectedContinue
-
- , itrWillChunkBody = willChunkBody
- , itrWillDiscardBody = willDiscardBody
- , itrWillClose = willClose
- , itrBodyToSend = bodyToSend
-
- , itrState = state
-
- , itrWroteContinue = wroteContinue
- , itrWroteHeader = wroteHeader
- }
-
-
-writeItr :: Interaction -> (Interaction -> TVar a) -> a -> STM ()
-writeItr itr accessor value
- = writeTVar (accessor itr) value
+ , SomeInteraction(..)
+ , SyntacticallyInvalidInteraction(..)
+ , mkSyntacticallyInvalidInteraction
-readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b
-readItr itr accessor reader
- = readTVar (accessor itr) >>= return . reader
-
-
-readItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b)
-readItrF itr accessor reader
- = readItr itr accessor (fmap reader)
+ , SemanticallyInvalidInteraction(..)
+ , mkSemanticallyInvalidInteraction
+ , NormalInteraction(..)
+ , InteractionState(..)
+ , ReceiveBodyRequest(..)
+ , mkNormalInteraction
-updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM ()
-updateItr itr accessor updator
- = do old <- readItr itr accessor id
- writeItr itr accessor (updator old)
+ , InteractionQueue
+ , mkInteractionQueue
+ , setResponseStatus
+ , getCurrentDate
+ )
+ where
+import Blaze.ByteString.Builder (Builder)
+import Control.Applicative
+import Control.Concurrent.STM
+import Data.Ascii (Ascii)
+import qualified Data.ByteString as Strict
+import Data.Monoid.Unicode
+import Data.Sequence (Seq)
+import qualified Data.Strict.Maybe as S
+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.DefaultPage
+import Network.HTTP.Lucu.Headers
+import Network.HTTP.Lucu.Preprocess
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Response
+import OpenSSL.X509
+
+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 ∷ !(S.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
+ -- FIXME: DRY
+ 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 ∷ !(S.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
+ | 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 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 ∷ NormalInteraction → StatusCode → STM ()
+setResponseStatus (NI {..}) sc
+ = do res ← readTVar niResponse
+ let res' = res {
+ resStatus = sc
+ }
+ writeTVar niResponse res'
-updateItrF :: (Functor f) => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM ()
-updateItrF itr accessor updator
- = updateItr itr accessor (fmap updator)
+getCurrentDate ∷ IO Ascii
+getCurrentDate = HTTP.toAscii <$> getCurrentTime