X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FInteraction.hs;h=fecb81543083babe065501dc03d4d52a529cee94;hp=6b5cdae11a708ddf3c36b26e81bfd581fa572064;hb=8cd9d79234344199a1644f661684bde3ed5e440b;hpb=73b5fba4907604681d778d3bd54cd65fd84b4454 diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 6b5cdae..fecb815 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -1,182 +1,233 @@ +{-# LANGUAGE + CPP + , DeriveDataTypeable + , ExistentialQuantification + , OverloadedStrings + , RecordWildCards + , UnicodeSyntax + #-} module Network.HTTP.Lucu.Interaction ( Interaction(..) + , SomeInteraction(..) + + , SyntacticallyInvalidInteraction(..) + , mkSyntacticallyInvalidInteraction + + , SemanticallyInvalidInteraction(..) + , mkSemanticallyInvalidInteraction + + , NormalInteraction(..) , InteractionState(..) + , ReceiveBodyRequest(..) + , mkNormalInteraction + , InteractionQueue - , newInteractionQueue - , newInteraction - , defaultPageContentType - - , writeItr - , readItr - , readItrF - , updateItr - , updateItrF + , mkInteractionQueue + + , getCurrentDate ) where - -import Control.Concurrent.STM -import qualified Data.ByteString as Strict (ByteString) -import qualified Data.ByteString.Lazy as Lazy (ByteString) -import Data.ByteString.Char8 as C8 hiding (ByteString) -import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString) -import qualified Data.Sequence as S -import Data.Sequence (Seq) -import Network.Socket -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.HttpVersion -import Network.HTTP.Lucu.Request -import Network.HTTP.Lucu.Response -import OpenSSL.X509 - -data Interaction = Interaction { - itrConfig :: !Config - , itrRemoteAddr :: !SockAddr - , itrRemoteCert :: !(Maybe X509) - , itrResourcePath :: !(Maybe [String]) - , itrRequest :: !(TVar (Maybe Request)) -- FIXME: TVar である必要無し - , itrResponse :: !(TVar Response) - - , itrRequestHasBody :: !(TVar Bool) -- FIXME: TVar である必要無し - , itrRequestIsChunked :: !(TVar Bool) -- FIXME: TVar である必要無し - , itrExpectedContinue :: !(TVar Bool) -- FIXME: TVar である必要無し - - , itrReqChunkLength :: !(TVar (Maybe Int)) - , itrReqChunkRemaining :: !(TVar (Maybe Int)) - , itrReqChunkIsOver :: !(TVar Bool) - , itrReqBodyWanted :: !(TVar (Maybe Int)) - , itrReqBodyWasteAll :: !(TVar Bool) - , itrReceivedBody :: !(TVar Lazy.ByteString) -- Resource が受領した部分は削除される - - , itrWillReceiveBody :: !(TVar Bool) - , itrWillChunkBody :: !(TVar Bool) - , itrWillDiscardBody :: !(TVar Bool) - , itrWillClose :: !(TVar Bool) - - , itrBodyToSend :: !(TVar Lazy.ByteString) - , itrBodyIsNull :: !(TVar Bool) - - , itrState :: !(TVar InteractionState) - - , itrWroteContinue :: !(TVar Bool) - , itrWroteHeader :: !(TVar Bool) - } - --- Resource の視點で見た時の状態。常に上から下へ行き、逆行しない。初期 --- 状態は ExaminingRequest。 -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 :: Strict.ByteString -defaultPageContentType = C8.pack "application/xhtml+xml" - - -newInteraction :: Config -> SockAddr -> Maybe X509 -> Maybe Request -> IO Interaction -newInteraction !conf !addr !cert !req - = do request <- newTVarIO $ req - responce <- newTVarIO $ Response { - resVersion = HttpVersion 1 1 - , resStatus = Ok - , resHeaders = toHeaders [(C8.pack "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 L8.empty - - willReceiveBody <- newTVarIO False - willChunkBody <- newTVarIO False - willDiscardBody <- newTVarIO False - willClose <- newTVarIO False - - bodyToSend <- newTVarIO L8.empty - bodyIsNull <- newTVarIO True -- 一度でも bodyToSend が空でなくなったら False - - state <- newTVarIO ExaminingRequest - - wroteContinue <- newTVarIO False - wroteHeader <- newTVarIO False - - return $ Interaction { - itrConfig = conf - , 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 () -writeItr itr accessor value - = itr `seq` accessor `seq` value `seq` - writeTVar (accessor itr) value - - -readItr :: Interaction -> (Interaction -> TVar a) -> (a -> b) -> STM b -readItr itr accessor reader - = itr `seq` accessor `seq` reader `seq` - readTVar (accessor itr) >>= return . reader - - -readItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> b) -> STM (f b) -readItrF itr accessor reader - = itr `seq` accessor `seq` reader `seq` - readItr itr accessor (fmap reader) -{-# SPECIALIZE readItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> b) -> STM (Maybe b) #-} - - -updateItr :: Interaction -> (Interaction -> TVar a) -> (a -> a) -> STM () -updateItr itr accessor updator - = itr `seq` accessor `seq` updator `seq` - do old <- readItr itr accessor id - writeItr itr accessor (updator old) - - -updateItrF :: Functor f => Interaction -> (Interaction -> TVar (f a)) -> (a -> a) -> STM () -updateItrF itr accessor updator - = itr `seq` accessor `seq` updator `seq` - updateItr itr accessor (fmap updator) -{-# SPECIALIZE updateItrF :: Interaction -> (Interaction -> TVar (Maybe a)) -> (a -> a) -> STM () #-} \ No newline at end of file +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 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 +#if defined(HAVE_SSL) +import OpenSSL.X509 +#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) + +-- |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 +#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