{-# LANGUAGE
- BangPatterns
+ CPP
+ , DeriveDataTypeable
+ , ExistentialQuantification
, OverloadedStrings
+ , RecordWildCards
, UnicodeSyntax
#-}
module Network.HTTP.Lucu.Interaction
( Interaction(..)
+ , SomeInteraction(..)
+ , EndOfInteraction(..)
+
+ , SyntacticallyInvalidInteraction(..)
+ , mkSyntacticallyInvalidInteraction
+
+ , SemanticallyInvalidInteraction(..)
+ , mkSemanticallyInvalidInteraction
+
+ , NormalInteraction(..)
, InteractionState(..)
+ , ReceiveBodyRequest(..)
+ , mkNormalInteraction
+
, InteractionQueue
- , newInteractionQueue
- , newInteraction
- , defaultPageContentType
-
- , writeItr
- , readItr
- , readItrF
- , updateItr
- , updateItrF
+ , mkInteractionQueue
+
+ , getCurrentDate
)
where
+import Blaze.ByteString.Builder (Builder)
import Control.Applicative
import Control.Concurrent.STM
import Data.Ascii (Ascii)
-import qualified Data.ByteString as BS
+import Data.ByteString (ByteString)
+import Data.Convertible.Base
+import Data.Monoid.Unicode
+import Data.Proxy
import Data.Sequence (Seq)
-import qualified Data.Sequence as S
+import Data.Time
+import Data.Time.Format.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.HttpVersion
+import Network.HTTP.Lucu.Preprocess
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.Utils
+#if defined(HAVE_SSL)
import OpenSSL.X509
+#endif
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)
- }
+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
+
+-- |'EndOfInteraction' is an 'Interaction' indicating the end of
+-- (possibly pipelined) requests. The connection has already been
+-- closed so no need to reply anything.
+data EndOfInteraction = EndOfInteraction
+ deriving Typeable
+instance Interaction EndOfInteraction
+
+-- |'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 conf@(Config {..})
+ = do date ← getCurrentDate
+ let res = setHeader "Server" cnfServerSoftware $
+ setHeader "Date" date $
+ setHeader "Content-Type" defaultPageContentType $
+ emptyResponse BadRequest
+ body = defaultPageForResponse conf 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
+ , 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 $
+ ( if arWillChunkBody
+ then setHeader "Transfer-Encoding" "chunked"
+ else id
+ ) $
+ ( if arWillClose
+ then setHeader "Connection" "close"
+ else id
+ ) $
+ emptyResponse arInitialStatus
+ body = defaultPageForResponse config (Just arRequest) res
+ return SEI {
+ seiRequest = arRequest
+ , seiExpectedContinue = arExpectedContinue
+ , seiReqBodyLength = arReqBodyLength
+
+ , seiResponse = res
+ , seiWillChunkBody = arWillChunkBody
+ , 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 ∷ !Path
+ , niExpectedContinue ∷ !Bool
+ , niReqBodyLength ∷ !(Maybe RequestBodyLength)
+
+ , niReceiveBodyReq ∷ !(TMVar ReceiveBodyRequest)
+ , niReceivedBody ∷ !(TMVar ByteString)
+
+ , niResponse ∷ !(TVar Response)
+ , niSendContinue ∷ !(TMVar Bool)
+ , niWillChunkBody ∷ !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)
-- |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
-
-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
-
- willReceiveBody ← newTVarIO False
- willChunkBody ← newTVarIO False
- willDiscardBody ← newTVarIO False
- willClose ← newTVarIO False
-
- bodyToSend ← newTVarIO S.empty
- 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
-
- , itrWillReceiveBody = willReceiveBody
- , itrWillChunkBody = willChunkBody
- , itrWillDiscardBody = willDiscardBody
- , itrWillClose = willClose
-
- , itrBodyToSend = bodyToSend
- , itrBodyIsNull = bodyIsNull
-
- , itrState = state
-
- , itrWroteContinue = wroteContinue
- , itrWroteHeader = wroteHeader
- }
-
-writeItr ∷ Interaction → (Interaction → TVar a) → a → STM ()
-{-# INLINE writeItr #-}
-writeItr itr accessor
- = writeTVar (accessor itr)
-
-readItr ∷ Interaction → (Interaction → TVar a) → (a → b) → STM b
-{-# INLINE readItr #-}
-readItr itr accessor reader
- = reader <$> readTVar (accessor itr)
-
-readItrF ∷ Functor f => Interaction → (Interaction → TVar (f a)) → (a → b) → STM (f b)
-{-# INLINE readItrF #-}
-readItrF itr accessor reader
- = readItr itr accessor (fmap reader)
-
-updateItr ∷ Interaction → (Interaction → TVar a) → (a → a) → STM ()
-{-# INLINE updateItr #-}
-updateItr itr accessor updator
- = do old ← readItr itr accessor id
- writeItr itr accessor (updator old)
-
-updateItrF ∷ Functor f => Interaction → (Interaction → TVar (f a)) → (a → a) → STM ()
-{-# INLINE updateItrF #-}
-updateItrF itr accessor
- = updateItr itr accessor ∘ fmap
+data InteractionState
+ = ExaminingRequest
+ | ReceivingBody
+ | DecidingHeader
+ | SendingBody
+ | Done
+ deriving (Show, Eq, Ord, Enum)
+
+mkNormalInteraction ∷ Config
+ → SockAddr
+#if defined(HAVE_SSL)
+ → Maybe X509
+#endif
+ → AugmentedRequest
+ → Path
+ → 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
+ 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
+ , niWillClose = willClose
+ , niResponseHasCType = responseHasCType
+ , niBodyToSend = bodyToSend
+
+ , niState = state
+ }
+
+type InteractionQueue = TVar (Seq SomeInteraction)
+
+mkInteractionQueue ∷ IO InteractionQueue
+{-# INLINE mkInteractionQueue #-}
+mkInteractionQueue = newTVarIO (∅)
+
+getCurrentDate ∷ IO Ascii
+{-# INLINE getCurrentDate #-}
+getCurrentDate = flip proxy http ∘ cs <$> getCurrentTime
projects / Lucu.git / blobdiff