From: PHO Date: Mon, 24 Oct 2011 13:08:42 +0000 (+0900) Subject: Yet Another Huge Changes X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=f402841;p=Lucu.git Yet Another Huge Changes Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa --- diff --git a/Lucu.cabal b/Lucu.cabal index c041872..28b9741 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -1,15 +1,13 @@ Name: Lucu -Synopsis: HTTP Daemonic Library +Synopsis: Embedded HTTP Server Description: - Lucu is an HTTP daemonic library. It can be embedded in any - Haskell program and runs in an independent thread. + Lucu is an embedded HTTP server library. - Lucu is not a replacement for Apache nor lighttpd. It is - intended to be used to build an efficient web-based RESTful - application. It is also intended to be run behind a - reverse-proxy so it doesn't have some facilities like logging, - client filtering or such like. + It's not a replacement for Apache nor lighttpd. It is intended + to be used to build an efficient web-based RESTful application + which runs behind a reverse-proxy so it doesn't have some + functionalities like logging, client filtering or such like. Version: 1.0 License: PublicDomain @@ -66,6 +64,7 @@ Library mtl == 2.0.*, network == 2.3.*, stm == 2.2.*, + strict == 0.3.*, text == 0.11.*, text-icu == 0.6.*, time == 1.2.*, @@ -94,6 +93,7 @@ Library Network.HTTP.Lucu.Utils Other-Modules: + Network.HTTP.Lucu.Abortion.Internal Network.HTTP.Lucu.Chunk Network.HTTP.Lucu.ContentCoding Network.HTTP.Lucu.DefaultPage diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs index efae41a..e5d9276 100644 --- a/Network/HTTP/Lucu.hs +++ b/Network/HTTP/Lucu.hs @@ -1,24 +1,20 @@ --- | Lucu is an HTTP daemonic library. It can be embedded in any --- Haskell program and runs in an independent thread. +-- | Lucu is an embedded HTTP server library. -- -- Features: -- --- [/Full support of HTTP\/1.1/] Lucu supports request pipelining, --- chunked I\/O, ETag comparison and \"100 Continue\". --- --- [/Performance/] Lucu is carefully designed to gain a good --- performance. --- -- [/Affinity for RESTafarians/] Lucu is specifically designed to be -- suitable for RESTful applications. -- --- [/SSL connections/] Lucu can handle HTTP connections over SSL --- layer. +-- [/Full support of HTTP\/1.1/] Lucu supports request pipelining, +-- chunked I\/O, ETag comparison and \"100 Continue\". +-- +-- [/SSL connections/] Lucu can handle HTTP connections over Secure +-- Socket Layer. -- -- Lucu is not a replacement for Apache or lighttpd. It is intended to -- be used to build an efficient web-based RESTful application. It is -- also intended to be run behind a reverse-proxy so it doesn't have --- the following (otherwise essential) facilities: +-- the following (otherwise essential) functionalities: -- -- [/Logging/] Lucu doesn't write logs of any requests from any -- clients. @@ -51,9 +47,10 @@ module Network.HTTP.Lucu , StatusCode(..) -- *** Abortion + , Abortion + , mkAbortion + , mkAbortion' , abort - , abortPurely - , abortA -- *** ETag , ETag(..) diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs index 62677e8..40a8cb5 100644 --- a/Network/HTTP/Lucu/Abortion.hs +++ b/Network/HTTP/Lucu/Abortion.hs @@ -1,116 +1,50 @@ {-# LANGUAGE - Arrows - , DeriveDataTypeable - , TypeOperators - , UnicodeSyntax + UnicodeSyntax #-} -- |Aborting the computation of 'Network.HTTP.Lucu.Resource.Resource' -- in any 'Prelude.IO' monads or arrows. module Network.HTTP.Lucu.Abortion - ( Abortion(..) + ( Abortion + , mkAbortion + , mkAbortion' , abort - , abortPurely - , abortSTM - , abortA - , abortPage ) where -import Blaze.ByteString.Builder (Builder) -import qualified Blaze.ByteString.Builder.Char.Utf8 as BB -import Control.Arrow.ArrowIO -import Control.Arrow.ListArrow -import Control.Arrow.Unicode -import Control.Concurrent.STM import Control.Exception import Control.Monad.Trans import Data.Ascii (Ascii, CIAscii) +import Data.Monoid.Unicode import Data.Text (Text) -import qualified Data.Text as T -import Data.Typeable -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.DefaultPage +import Network.HTTP.Lucu.Abortion.Internal import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import Prelude.Unicode -import Text.XML.HXT.Arrow.WriteDocument -import Text.XML.HXT.Arrow.XmlArrow -import Text.XML.HXT.Arrow.XmlState -data Abortion = Abortion { - aboStatus ∷ !StatusCode - , aboHeaders ∷ !Headers - , aboMessage ∷ !(Maybe Text) - } deriving (Eq, Show, Typeable) - -instance Exception Abortion - --- |Computation of @'abort' status headers msg@ aborts the --- 'Network.HTTP.Lucu.Resource.Resource' monad with given status, --- additional response headers, and optional message string. --- --- What this really does is to throw an instance of 'Exception'. The --- exception will be caught by the Lucu system. --- --- 1. If the 'Network.HTTP.Lucu.Resource.Resource' is in the /Deciding --- Header/ or any precedent states, it is possible to use the --- @status@ and such like as a HTTP response to be sent to the --- client. --- --- 2. Otherwise the HTTP response can't be modified anymore so the --- only possible thing the system can do is to dump it to the --- stderr. See 'cnfDumpTooLateAbortionToStderr'. --- --- Note that the status code doesn't necessarily have to be an error --- code so you can use this action for redirection as well as error --- reporting e.g. --- --- > abort MovedPermanently --- > [("Location", "http://example.net/")] --- > (Just "It has been moved to example.net") -abort ∷ MonadIO m ⇒ StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → m a +-- |Construct an 'Abortion' with additional headers and an optional +-- message text. +mkAbortion ∷ StatusCode → [(CIAscii, Ascii)] → Maybe Text → Abortion +{-# INLINE mkAbortion #-} +mkAbortion sc hdr msg + = Abortion { + aboStatus = sc + , aboHeaders = toHeaders hdr + , aboMessage = msg + } + +-- |Construct an 'Abortion' without any additional headers but with a +-- message text. +mkAbortion' ∷ StatusCode → Text → Abortion +{-# INLINE mkAbortion' #-} +mkAbortion' sc msg + = Abortion { + aboStatus = sc + , aboHeaders = (∅) + , aboMessage = Just msg + } + +-- |Throw an 'Abortion' in a 'MonadIO', including the very +-- 'Network.HTTP.Lucu.Resource.Resource' monad. +abort ∷ MonadIO m ⇒ Abortion → m a {-# INLINE abort #-} -abort status headers - = liftIO ∘ throwIO ∘ Abortion status (toHeaders headers) - --- |This is similar to 'abort' but computes it with --- 'System.IO.Unsafe.unsafePerformIO'. -abortPurely ∷ StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → a -{-# INLINE abortPurely #-} -abortPurely status headers - = throw ∘ Abortion status (toHeaders headers) - --- |Computation of @'abortSTM' status headers msg@ just computes --- 'abort' in a 'Control.Monad.STM.STM' monad. -abortSTM ∷ StatusCode → [ (CIAscii, Ascii) ] → Maybe Text → STM a -{-# INLINE abortSTM #-} -abortSTM status headers - = throwSTM ∘ Abortion status (toHeaders headers) - --- | Computation of @'abortA' -< (status, (headers, msg))@ just --- computes 'abort' in an 'Control.Arrow.ArrowIO.ArrowIO'. -abortA ∷ ArrowIO (⇝) ⇒ (StatusCode, ([ (CIAscii, Ascii) ], Maybe Text)) ⇝ c -{-# INLINE abortA #-} -abortA = proc (status, (headers, msg)) → - arrIO throwIO ⤙ Abortion status (toHeaders headers) msg - --- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、 --- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な --- ければならない。 -abortPage ∷ Config → Maybe Request → Response → Abortion → Builder -abortPage conf reqM res abo - = case aboMessage abo of - Just msg - → let [html] = runLA ( mkDefaultPage conf (aboStatus abo) (txt $ T.unpack msg) - ⋙ - writeDocumentToString [ withIndent True ] - ) () - in - BB.fromString html - Nothing - → let res' = res { resStatus = aboStatus abo } - res'' = foldl (∘) id [setHeader name value - | (name, value) ← fromHeaders $ aboHeaders abo] res' - in - getDefaultPage conf reqM res'' +abort = liftIO ∘ throwIO diff --git a/Network/HTTP/Lucu/Abortion/Internal.hs b/Network/HTTP/Lucu/Abortion/Internal.hs new file mode 100644 index 0000000..f71e045 --- /dev/null +++ b/Network/HTTP/Lucu/Abortion/Internal.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE + DeriveDataTypeable + , UnicodeSyntax + #-} +module Network.HTTP.Lucu.Abortion.Internal + ( Abortion(..) + , abortPage + ) + where +import Blaze.ByteString.Builder (Builder) +import qualified Blaze.ByteString.Builder.Char.Utf8 as BB +import Control.Arrow.ListArrow +import Control.Arrow.Unicode +import Control.Exception +import Data.Text (Text) +import qualified Data.Text as T +import Data.Typeable +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.DefaultPage +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Response +import Prelude.Unicode +import Text.XML.HXT.Arrow.WriteDocument +import Text.XML.HXT.Arrow.XmlArrow +import Text.XML.HXT.Arrow.XmlState + +-- |'Abortion' is an 'Exception' that aborts the execution of +-- 'Network.HTTP.Lucu.Resource.Resource' monad with a 'StatusCode', +-- additional response headers, and an optional message text. +-- +-- 1. If the 'Network.HTTP.Lucu.Resource.Resource' is in the /Deciding +-- Header/ or any precedent states, throwing an 'Abortion' affects +-- the HTTP response to be sent to the client. +-- +-- 2. Otherwise it's too late to overwrite the HTTP response so the +-- only possible thing the system can do is to dump the exception +-- to the stderr. See 'cnfDumpTooLateAbortionToStderr'. +-- +-- Note that the status code doesn't necessarily have to satisfy +-- 'isError' so you can abuse this exception for redirections as well +-- as error reporting e.g. +-- +-- > abort $ mkAbortion MovedPermanently +-- > [("Location", "http://example.net/")] +-- > "It has been moved to example.net" +data Abortion = Abortion { + aboStatus ∷ !StatusCode + , aboHeaders ∷ !Headers + , aboMessage ∷ !(Maybe Text) + } deriving (Eq, Show, Typeable) + +instance Exception Abortion + +instance HasHeaders Abortion where + getHeaders = aboHeaders + setHeaders abo hdr = abo { aboHeaders = hdr } + +abortPage ∷ Config → Maybe Request → Response → Abortion → Builder +abortPage conf reqM res abo + = case aboMessage abo of + Just msg + → let [html] = runLA ( mkDefaultPage conf (aboStatus abo) (txt $ T.unpack msg) + ⋙ + writeDocumentToString [ withIndent True ] + ) () + in + BB.fromString html + Nothing + → let res' = res { resStatus = aboStatus abo } + res'' = foldl (∘) id [setHeader name value + | (name, value) ← fromHeaders $ aboHeaders abo] res' + in + getDefaultPage conf reqM res'' diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs index 2dca512..595403a 100644 --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -45,7 +45,7 @@ import System.Posix.Signals -- > helloWorld :: ResourceDef -- > helloWorld = emptyResource { -- > resGet --- > = Just $ do setContentType $ mkMIMEType "text" "plain" +-- > = Just $ do setContentType $ parseMIMEType "text/plain" -- > putChunk "Hello, world!" -- > } runHttpd ∷ Config → ResTree → [FallbackHandler] → IO () @@ -105,7 +105,7 @@ runHttpd cnf tree fbs httpLoop ∷ SocketLike s ⇒ PortNumber → s → IO () httpLoop port so = do (h, addr) ← SL.accept so - tQueue ← newInteractionQueue + tQueue ← mkInteractionQueue readerTID ← forkIO $ requestReader cnf tree fbs h port addr tQueue _writerTID ← forkIO $ responseWriter cnf h tQueue readerTID httpLoop port so diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 20b4bc2..e486e1a 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -1,57 +1,164 @@ {-# LANGUAGE - OverloadedStrings + DeriveDataTypeable + , ExistentialQuantification + , OverloadedStrings , RecordWildCards , UnicodeSyntax #-} module Network.HTTP.Lucu.Interaction ( Interaction(..) + , SomeInteraction(..) + + , SyntacticallyInvalidInteraction(..) + , mkSyntacticallyInvalidInteraction + + , SemanticallyInvalidInteraction(..) + , mkSemanticallyInvalidInteraction + + , NormalInteraction(..) , InteractionState(..) - , InteractionQueue , ReceiveBodyRequest(..) - , newInteractionQueue - , newInteraction + , mkNormalInteraction + + , 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.Sequence as S +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.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 [Strict.ByteString]) - , itrRequest ∷ !(Maybe Request) +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 + 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 - , itrExpectedContinue ∷ !(Maybe Bool) - , itrReqBodyLength ∷ !(Maybe RequestBodyLength) - - , itrReceiveBodyReq ∷ !(TMVar ReceiveBodyRequest) - , itrReceivedBody ∷ !(TMVar Strict.ByteString) - - , itrSendContinue ∷ !(TMVar Bool) - , itrResponse ∷ !(TVar Response) - , itrWillChunkBody ∷ !(TVar Bool) - , itrWillDiscardBody ∷ !(TVar Bool) - , itrWillClose ∷ !(TVar Bool) - , itrResponseHasCType ∷ !(TVar Bool) - , itrBodyToSend ∷ !(TMVar Builder) - - , itrState ∷ !(TVar InteractionState) - } +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. @@ -63,72 +170,60 @@ data InteractionState | Done deriving (Show, Eq, Ord, Enum) -type InteractionQueue = TVar (Seq Interaction) - -data ReceiveBodyRequest - = ReceiveBody !Int -- ^ Maximum number of octets to receive. - | WasteAll - deriving (Show, Eq) - -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 = (∅) - } - - receiveBodyReq ← newEmptyTMVarIO +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 - response ← newTVarIO res - willChunkBody ← newTVarIO False - willDiscardBody ← newTVarIO (arWillDiscardBody ar) - willClose ← newTVarIO (arWillClose ar) - bodyToSend ← 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 - - , itrReceiveBodyReq = receiveBodyReq - , itrReceivedBody = receivedBody - - , itrSendContinue = sendContinue - , 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 ∷ NormalInteraction → StatusCode → STM () +setResponseStatus (NI {..}) sc + = do res ← readTVar niResponse let res' = res { resStatus = sc } - writeTVar itrResponse res' + writeTVar niResponse res' + +getCurrentDate ∷ IO Ascii +getCurrentDate = HTTP.toAscii <$> getCurrentTime diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index bc9363d..6735652 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -6,7 +6,6 @@ #-} module Network.HTTP.Lucu.Postprocess ( postprocess - , completeUnconditionalHeaders ) where import Control.Applicative @@ -15,33 +14,28 @@ import Control.Monad import Control.Monad.Unicode import Data.Ascii (Ascii, CIAscii, AsciiBuilder) import qualified Data.Ascii as A +import Data.Maybe import Data.Monoid.Unicode -import Data.Time -import qualified Data.Time.HTTP as HTTP import GHC.Conc (unsafeIOToSTM) import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.DefaultPage import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import Prelude.Unicode -postprocess ∷ Interaction → STM () -postprocess itr@(Interaction {..}) - = do abortOnCertainConditions itr +postprocess ∷ NormalInteraction → STM () +postprocess ni@(NI {..}) + = do void $ tryPutTMVar niSendContinue False + abortOnCertainConditions ni + postprocessWithRequest ni + completeUnconditionalHeaders ni - case itrRequest of - Just req → postprocessWithRequest itr req - Nothing → return () - - updateResIO itr $ completeUnconditionalHeaders itrConfig - -abortOnCertainConditions ∷ Interaction → STM () -abortOnCertainConditions (Interaction {..}) - = readTVar itrResponse ≫= go +abortOnCertainConditions ∷ NormalInteraction → STM () +abortOnCertainConditions (NI {..}) + = readTVar niResponse ≫= go where go ∷ Response → STM () go res@(Response {..}) @@ -69,94 +63,84 @@ abortOnCertainConditions (Interaction {..}) ⊕ A.toAsciiBuilder " but no Location header." abort' ∷ AsciiBuilder → STM () - abort' = abortSTM InternalServerError [] - ∘ Just + abort' = throwSTM + ∘ mkAbortion' InternalServerError ∘ A.toText ∘ A.fromAsciiBuilder -postprocessWithRequest ∷ Interaction → Request → STM () -postprocessWithRequest itr@(Interaction {..}) (Request {..}) - = do willDiscardBody ← readTVar itrWillDiscardBody +postprocessWithRequest ∷ NormalInteraction → STM () +postprocessWithRequest ni@(NI {..}) + = do willDiscardBody ← readTVar niWillDiscardBody canHaveBody ← if willDiscardBody then return False else - resCanHaveBody <$> readTVar itrResponse + resCanHaveBody <$> readTVar niResponse - updateRes itr + updateRes ni $ deleteHeader "Content-Length" ∘ deleteHeader "Transfer-Encoding" if canHaveBody then - do when (reqVersion ≡ HttpVersion 1 1) - $ do writeHeader itr "Transfer-Encoding" (Just "chunked") - writeTVar itrWillChunkBody True - writeDefaultPageIfNeeded itr + do when niWillChunkBody $ + writeHeader ni "Transfer-Encoding" (Just "chunked") + writeDefaultPageIfNeeded ni else - do writeTVar itrWillDiscardBody True + do writeTVar niWillDiscardBody True -- These headers make sense for HEAD requests even -- when there won't be a response entity body. - when (reqMethod ≢ HEAD) - $ updateRes itr + when (reqMethod niRequest ≢ HEAD) + $ updateRes ni $ deleteHeader "Content-Type" ∘ deleteHeader "Etag" ∘ deleteHeader "Last-Modified" - hasConnClose ← (≡ Just "close") <$> readCIHeader itr "Connection" - willClose ← readTVar itrWillClose + hasConnClose ← (≡ Just "close") <$> readCIHeader ni "Connection" + willClose ← readTVar niWillClose when (hasConnClose ∧ (¬) willClose) - $ writeTVar itrWillClose True + $ writeTVar niWillClose True when ((¬) hasConnClose ∧ willClose) - $ writeHeader itr "Connection" (Just "close") + $ writeHeader ni "Connection" (Just "close") -writeDefaultPageIfNeeded ∷ Interaction → STM () -writeDefaultPageIfNeeded itr@(Interaction {..}) - = do resHasCType ← readTVar itrResponseHasCType +writeDefaultPageIfNeeded ∷ NormalInteraction → STM () +writeDefaultPageIfNeeded ni@(NI {..}) + = do resHasCType ← readTVar niResponseHasCType unless resHasCType - $ do writeHeader itr "Content-Type" (Just defaultPageContentType) - writeHeader itr "Content-Encoding" Nothing - res ← readTVar itrResponse - let page = getDefaultPage itrConfig itrRequest res - putTMVar itrBodyToSend page - -writeHeader ∷ Interaction → CIAscii → Maybe Ascii → STM () + $ do writeHeader ni "Content-Type" $ Just defaultPageContentType + writeHeader ni "Content-Encoding" Nothing + res ← readTVar niResponse + let body = getDefaultPage niConfig (Just niRequest) res + putTMVar niBodyToSend body + +completeUnconditionalHeaders ∷ NormalInteraction → STM () +completeUnconditionalHeaders ni@(NI {..}) + = do srv ← readHeader ni "Server" + when (isNothing srv) $ + writeHeader ni "Server" $ Just $ cnfServerSoftware niConfig + + date ← readHeader ni "Date" + when (isNothing date) $ + do date' ← unsafeIOToSTM getCurrentDate + writeHeader ni "Date" $ Just date' + +writeHeader ∷ NormalInteraction → CIAscii → Maybe Ascii → STM () {-# INLINE writeHeader #-} -writeHeader itr k v +writeHeader ni k v = case v of - Just v' → updateRes itr $ setHeader k v' - Nothing → updateRes itr $ deleteHeader k + Just v' → updateRes ni $ setHeader k v' + Nothing → updateRes ni $ deleteHeader k + +readHeader ∷ NormalInteraction → CIAscii → STM (Maybe Ascii) +{-# INLINE readHeader #-} +readHeader (NI {..}) k + = getHeader k <$> readTVar niResponse -readCIHeader ∷ Interaction → CIAscii → STM (Maybe CIAscii) +readCIHeader ∷ NormalInteraction → CIAscii → STM (Maybe CIAscii) {-# INLINE readCIHeader #-} -readCIHeader (Interaction {..}) k - = getCIHeader k <$> readTVar itrResponse +readCIHeader (NI {..}) k + = getCIHeader k <$> readTVar niResponse -updateRes ∷ Interaction → (Response → Response) → STM () +updateRes ∷ NormalInteraction → (Response → Response) → STM () {-# INLINE updateRes #-} -updateRes (Interaction {..}) f - = do old ← readTVar itrResponse - writeTVar itrResponse (f old) - -updateResIO ∷ Interaction → (Response → IO Response) → STM () -{-# INLINE updateResIO #-} -updateResIO (Interaction {..}) f - = do old ← readTVar itrResponse - new ← unsafeIOToSTM $ f old - writeTVar itrResponse new - --- FIXME: Narrow the use of IO monad! -completeUnconditionalHeaders ∷ Config → Response → IO Response -completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer - where - compServer res' - = case getHeader "Server" res' of - Nothing → return $ setHeader "Server" (cnfServerSoftware conf) res' - Just _ → return res' - - compDate res' - = case getHeader "Date" res' of - Nothing → do date ← getCurrentDate - return $ setHeader "Date" date res' - Just _ → return res' - -getCurrentDate ∷ IO Ascii -getCurrentDate = HTTP.toAscii <$> getCurrentTime +updateRes (NI {..}) f + = do old ← readTVar niResponse + writeTVar niResponse $ f old diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index 739dec8..8e3087e 100644 --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -12,11 +12,12 @@ module Network.HTTP.Lucu.Preprocess where import Control.Applicative import Control.Monad -import Control.Monad.State +import Control.Monad.State.Strict import Data.Ascii (Ascii) import qualified Data.Ascii as A import qualified Data.ByteString.Char8 as C8 import Data.Maybe +import qualified Data.Strict.Maybe as S import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -30,12 +31,13 @@ import Prelude.Unicode data AugmentedRequest = AugmentedRequest { - arRequest ∷ !(Maybe Request) + arRequest ∷ !Request , arInitialStatus ∷ !StatusCode - , arWillClose ∷ !Bool + , arWillChunkBody ∷ !Bool , arWillDiscardBody ∷ !Bool - , arExpectedContinue ∷ !(Maybe Bool) - , arReqBodyLength ∷ !(Maybe RequestBodyLength) + , arWillClose ∷ !Bool + , arExpectedContinue ∷ !Bool + , arReqBodyLength ∷ !(S.Maybe RequestBodyLength) } data RequestBodyLength @@ -43,42 +45,20 @@ data RequestBodyLength | Chunked deriving (Eq, Show) -preprocess ∷ Text - → PortNumber - → Either StatusCode Request - → AugmentedRequest -preprocess localHost localPort request - = case request of - Right req - → preprocess' localHost localPort req - Left sc - → unparsable sc - -unparsable ∷ StatusCode → AugmentedRequest -unparsable sc - = AugmentedRequest { - arRequest = Nothing - , arInitialStatus = sc - , arWillClose = True - , arWillDiscardBody = False - , arExpectedContinue = Nothing - , arReqBodyLength = Nothing - } - -preprocess' ∷ Text → PortNumber → Request → AugmentedRequest -preprocess' localHost localPort req@(Request {..}) +preprocess ∷ Text → PortNumber → Request → AugmentedRequest +preprocess localHost localPort req@(Request {..}) = execState go initialAR where initialAR ∷ AugmentedRequest initialAR = AugmentedRequest { - arRequest = Just req + arRequest = req , arInitialStatus = Ok - , arWillClose = False + , arWillChunkBody = False , arWillDiscardBody = False - , arExpectedContinue = Just False - , arReqBodyLength = Nothing + , arWillClose = False + , arExpectedContinue = False + , arReqBodyLength = S.Nothing } - go ∷ State AugmentedRequest () go = do examineHttpVersion examineMethod @@ -88,7 +68,7 @@ preprocess' localHost localPort req@(Request {..}) setRequest ∷ Request → State AugmentedRequest () setRequest req - = modify $ \ar → ar { arRequest = Just req } + = modify $ \ar → ar { arRequest = req } setStatus ∷ StatusCode → State AugmentedRequest () setStatus sc @@ -98,25 +78,25 @@ setWillClose ∷ Bool → State AugmentedRequest () setWillClose b = modify $ \ar → ar { arWillClose = b } -setBodyLength ∷ Maybe RequestBodyLength → State AugmentedRequest () +setBodyLength ∷ S.Maybe RequestBodyLength → State AugmentedRequest () setBodyLength len = modify $ \ar → ar { arReqBodyLength = len } examineHttpVersion ∷ State AugmentedRequest () examineHttpVersion - = do req ← gets (fromJust ∘ arRequest) + = do req ← gets arRequest case reqVersion req of -- HTTP/1.0 requests can't Keep-Alive. HttpVersion 1 0 → setWillClose True HttpVersion 1 1 - → return () + → modify $ \ar → ar { arWillChunkBody = True } _ → do setStatus HttpVersionNotSupported setWillClose True examineMethod ∷ State AugmentedRequest () examineMethod - = do req ← gets (fromJust ∘ arRequest) + = do req ← gets arRequest case reqMethod req of GET → return () HEAD → modify $ \ar → ar { arWillDiscardBody = True } @@ -127,7 +107,7 @@ examineMethod examineAuthority ∷ Text → PortNumber → State AugmentedRequest () examineAuthority localHost localPort - = do req ← gets (fromJust ∘ arRequest) + = do req ← gets arRequest when (isNothing $ uriAuthority $ reqURI req) $ case reqVersion req of -- HTTP/1.0 requests have no Host header so complete it @@ -178,13 +158,13 @@ updateAuthority host port req examineHeaders ∷ State AugmentedRequest () examineHeaders - = do req ← gets (fromJust ∘ arRequest) + = do req ← gets arRequest case getCIHeader "Expect" req of Nothing → return () Just v | v ≡ "100-continue" - → modify $ \ar → ar { arExpectedContinue = Just True } + → modify $ \ar → ar { arExpectedContinue = True } | otherwise → setStatus ExpectationFailed @@ -194,7 +174,7 @@ examineHeaders | v ≡ "identity" → return () | v ≡ "chunked" - → setBodyLength $ Just Chunked + → setBodyLength $ S.Just Chunked | otherwise → setStatus NotImplemented @@ -203,7 +183,7 @@ examineHeaders Just value → case C8.readInt value of Just (len, garbage) | C8.null garbage ∧ len ≥ 0 - → setBodyLength $ Just $ Fixed len + → setBodyLength $ S.Just $ Fixed len _ → setStatus BadRequest case getCIHeader "Connection" req of @@ -214,13 +194,13 @@ examineHeaders examineBodyLength ∷ State AugmentedRequest () examineBodyLength - = do req ← gets (fromJust ∘ arRequest) + = do req ← gets arRequest len ← gets arReqBodyLength if reqMustHaveBody req then -- POST and PUT requests must have an entity body. - when (isNothing len) + when (S.isNothing len) $ setStatus LengthRequired else -- Other requests must NOT have an entity body. - when (isJust len) + when (S.isJust len) $ setStatus BadRequest diff --git a/Network/HTTP/Lucu/RFC2231.hs b/Network/HTTP/Lucu/RFC2231.hs index 9856f47..1302e59 100644 --- a/Network/HTTP/Lucu/RFC2231.hs +++ b/Network/HTTP/Lucu/RFC2231.hs @@ -5,7 +5,7 @@ , ScopedTypeVariables , UnicodeSyntax #-} --- |Provide facilities to encode/decode MIME parameter values in +-- |Provide functionalities to encode/decode MIME parameter values in -- character sets other than US-ASCII. See: -- http://www.faqs.org/rfcs/rfc2231.html module Network.HTTP.Lucu.RFC2231 diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 05b3042..b0af8d1 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DoAndIfThenElse + , OverloadedStrings , RecordWildCards , ScopedTypeVariables , UnicodeSyntax @@ -8,29 +9,29 @@ module Network.HTTP.Lucu.RequestReader ( requestReader ) where -import Control.Applicative +import Control.Concurrent import Control.Concurrent.STM import Control.Exception hiding (block) import Control.Monad import qualified Data.Attoparsec.Lazy as LP import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy -import Data.Maybe +import qualified Data.Strict.Maybe as S import Data.Monoid.Unicode import qualified Data.Sequence as S import Data.Sequence.Unicode hiding ((∅)) +import qualified Data.Text as T +import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.Chunk import Network.HTTP.Lucu.HandleLike import Network.HTTP.Lucu.Interaction -import Network.HTTP.Lucu.Postprocess import Network.HTTP.Lucu.Preprocess import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.Resource.Internal import Network.HTTP.Lucu.Resource.Tree import Network.Socket -import Network.URI import Prelude.Unicode import System.IO (hPutStrLn, stderr) @@ -96,15 +97,12 @@ acceptRequest ctx@(Context {..}) input -- ResponseWriter に通知する。 case LP.parse requestP input of LP.Done input' req → acceptParsableRequest ctx req input' - LP.Fail _ _ _ → acceptNonparsableRequest ctx BadRequest + LP.Fail _ _ _ → acceptNonparsableRequest ctx -acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → StatusCode → IO () -acceptNonparsableRequest ctx@(Context {..}) sc - = do itr ← newInteraction cConfig cPort cAddr Nothing (Left sc) - atomically $ - do writeTVar (itrState itr) Done - postprocess itr - enqueue ctx itr +acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → IO () +acceptNonparsableRequest ctx@(Context {..}) + = do syi ← mkSyntacticallyInvalidInteraction cConfig + enqueue ctx syi acceptParsableRequest ∷ HandleLike h ⇒ Context h @@ -112,120 +110,98 @@ acceptParsableRequest ∷ HandleLike h → Lazy.ByteString → IO () acceptParsableRequest ctx@(Context {..}) req input - = do cert ← hGetPeerCert cHandle - itr ← newInteraction cConfig cPort cAddr cert (Right req) - join $ atomically - $ do isErr ← (isError ∘ resStatus) <$> readTVar (itrResponse itr) - if isErr then - acceptSemanticallyInvalidRequest ctx itr input - else - return $ acceptSemanticallyValidRequest ctx itr (reqURI req) input + = do let ar = preprocess (cnfServerHost cConfig) cPort req + if isError $ arInitialStatus ar then + acceptSemanticallyInvalidRequest ctx ar input + else + do rsrc ← findResource cResTree cFallbacks $ reqURI $ arRequest ar + case rsrc of + Nothing + → do let ar' = ar { arInitialStatus = NotFound } + acceptSemanticallyInvalidRequest ctx ar' input + Just (path, def) + → acceptRequestForResource ctx ar input path def acceptSemanticallyInvalidRequest ∷ HandleLike h ⇒ Context h - → Interaction + → AugmentedRequest → Lazy.ByteString - → STM (IO ()) -acceptSemanticallyInvalidRequest ctx itr input - = do writeTVar (itrState itr) Done - postprocess itr - enqueue ctx itr - return $ acceptRequest ctx input - -acceptSemanticallyValidRequest ∷ HandleLike h - ⇒ Context h - → Interaction - → URI - → Lazy.ByteString - → IO () -acceptSemanticallyValidRequest ctx@(Context {..}) itr uri input - = do rsrcM ← findResource cResTree cFallbacks uri - case rsrcM of - Nothing - → acceptRequestForNonexistentResource ctx itr input - Just (rsrcPath, rsrcDef) - → acceptRequestForExistentResource ctx itr input rsrcPath rsrcDef - -acceptRequestForNonexistentResource ∷ HandleLike h - ⇒ Context h - → Interaction - → Lazy.ByteString - → IO () -acceptRequestForNonexistentResource ctx itr input - = do atomically $ - do setResponseStatus itr NotFound - writeTVar (itrState itr) Done - postprocess itr - enqueue ctx itr + → IO () +acceptSemanticallyInvalidRequest ctx@(Context {..}) ar input + = do sei ← mkSemanticallyInvalidInteraction cConfig ar + enqueue ctx sei acceptRequest ctx input -acceptRequestForExistentResource ∷ HandleLike h - ⇒ Context h - → Interaction - → Lazy.ByteString - → [Strict.ByteString] - → ResourceDef - → IO () -acceptRequestForExistentResource ctx oldItr input rsrcPath rsrcDef - = do let itr = oldItr { itrResourcePath = Just rsrcPath } - atomically $ enqueue ctx itr - do _ ← spawnResource rsrcDef itr - if reqMustHaveBody $ fromJust $ itrRequest itr then - waitForReceiveBodyReq ctx itr input - else - acceptRequest ctx input +acceptRequestForResource ∷ HandleLike h + ⇒ Context h + → AugmentedRequest + → Lazy.ByteString + → [Strict.ByteString] + → ResourceDef + → IO () +acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef + = do cert ← hGetPeerCert cHandle + ni ← mkNormalInteraction cConfig cAddr cert ar rsrcPath + tid ← spawnResource rsrcDef ni + if reqMustHaveBody arRequest then + waitForReceiveBodyReq ctx ni tid input + else + acceptRequest ctx input waitForReceiveBodyReq ∷ HandleLike h ⇒ Context h - → Interaction + → NormalInteraction + → ThreadId → Lazy.ByteString → IO () -waitForReceiveBodyReq ctx itr input - = case fromJust $ itrReqBodyLength itr of +waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input + = case S.fromJust niReqBodyLength of Chunked - → waitForReceiveChunkedBodyReqForTheFirstTime ctx itr input + → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input Fixed len - → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx itr input len + → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni input len -- Toooooo long name for a function... waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h ⇒ Context h - → Interaction + → NormalInteraction + → ThreadId → Lazy.ByteString → IO () -waitForReceiveChunkedBodyReqForTheFirstTime ctx itr@(Interaction {..}) input +waitForReceiveChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) rsrcTid input = join $ atomically $ - do req ← takeTMVar itrReceiveBodyReq + do req ← takeTMVar niReceiveBodyReq case req of ReceiveBody wanted - → do putTMVar itrSendContinue $ fromJust itrExpectedContinue - return $ readCurrentChunk ctx itr input Initial wanted + → do putTMVar niSendContinue niExpectedContinue + return $ readCurrentChunk ctx ni rsrcTid wanted input Initial WasteAll - → do putTMVar itrSendContinue False - return $ wasteAllChunks ctx itr input Initial + → do putTMVar niSendContinue False + return $ wasteAllChunks ctx rsrcTid input Initial waitForReceiveChunkedBodyReq ∷ HandleLike h ⇒ Context h - → Interaction + → NormalInteraction + → ThreadId → Lazy.ByteString → ChunkReceivingState → IO () -waitForReceiveChunkedBodyReq ctx itr@(Interaction {..}) input st - = do req ← atomically $ takeTMVar itrReceiveBodyReq +waitForReceiveChunkedBodyReq ctx ni@(NI {..}) rsrcTid input st + = do req ← atomically $ takeTMVar niReceiveBodyReq case req of ReceiveBody wanted - → readCurrentChunk ctx itr input st wanted + → readCurrentChunk ctx ni rsrcTid wanted input st WasteAll - → wasteAllChunks ctx itr input st + → wasteAllChunks ctx rsrcTid input st wasteAllChunks ∷ HandleLike h ⇒ Context h - → Interaction + → ThreadId → Lazy.ByteString → ChunkReceivingState → IO () -wasteAllChunks ctx itr = go +wasteAllChunks ctx rsrcTid = go where go ∷ Lazy.ByteString → ChunkReceivingState → IO () go input Initial @@ -233,8 +209,9 @@ wasteAllChunks ctx itr = go LP.Done input' chunkLen | chunkLen ≡ 0 → gotFinalChunk input' | otherwise → gotChunk input' chunkLen - LP.Fail _ _ _ - → chunkWasMalformed itr + LP.Fail _ _ msg + → chunkWasMalformed rsrcTid + $ "wasteAllChunks: chunkHeaderP: " ⧺ msg go input (InChunk chunkLen) = gotChunk input chunkLen @@ -245,30 +222,28 @@ wasteAllChunks ctx itr = go case LP.parse chunkFooterP input' of LP.Done input'' _ → go input'' Initial - LP.Fail _ _ _ - → chunkWasMalformed itr + LP.Fail _ _ msg + → chunkWasMalformed rsrcTid + $ "wasteAllChunks: chunkFooterP: " ⧺ msg gotFinalChunk ∷ Lazy.ByteString → IO () gotFinalChunk input - = case LP.parse chunkFooterP input of + = case LP.parse chunkTrailerP input of LP.Done input' _ - → case LP.parse chunkTrailerP input' of - LP.Done input'' _ - → acceptRequest ctx input'' - LP.Fail _ _ _ - → chunkWasMalformed itr - LP.Fail _ _ _ - → chunkWasMalformed itr + → acceptRequest ctx input' + LP.Fail _ _ msg + → chunkWasMalformed rsrcTid + $ "wasteAllChunks: chunkTrailerP: " ⧺ msg readCurrentChunk ∷ HandleLike h ⇒ Context h - → Interaction + → NormalInteraction + → ThreadId + → Int → Lazy.ByteString → ChunkReceivingState - → Int → IO () -readCurrentChunk ctx itr@(Interaction {..}) input0 st0 wanted - = go input0 st0 +readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go where go ∷ Lazy.ByteString → ChunkReceivingState → IO () go input Initial @@ -278,8 +253,9 @@ readCurrentChunk ctx itr@(Interaction {..}) input0 st0 wanted → gotFinalChunk input' | otherwise → gotChunk input' chunkLen - LP.Fail _ _ _ - → chunkWasMalformed itr + LP.Fail _ _ msg + → chunkWasMalformed rsrcTid + $ "readCurrentChunk: chunkHeaderP: " ⧺ msg go input (InChunk chunkLen) = gotChunk input chunkLen @@ -290,67 +266,64 @@ readCurrentChunk ctx itr@(Interaction {..}) input0 st0 wanted block' = Strict.concat $ Lazy.toChunks block actualReadBytes = Strict.length block' chunkLen' = chunkLen - actualReadBytes - atomically $ putTMVar itrReceivedBody block' + atomically $ putTMVar niReceivedBody block' if chunkLen' ≡ 0 then case LP.parse chunkFooterP input' of LP.Done input'' _ - → waitForReceiveChunkedBodyReq ctx itr input'' Initial - LP.Fail _ _ _ - → chunkWasMalformed itr + → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial + LP.Fail _ _ msg + → chunkWasMalformed rsrcTid + $ "readCurrentChunk: chunkFooterP: " ⧺ msg else - waitForReceiveChunkedBodyReq ctx itr input' $ InChunk chunkLen' + waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen' gotFinalChunk ∷ Lazy.ByteString → IO () gotFinalChunk input - = do atomically $ putTMVar itrReceivedBody (∅) - case LP.parse chunkFooterP input of + = do atomically $ putTMVar niReceivedBody (∅) + case LP.parse chunkTrailerP input of LP.Done input' _ - → case LP.parse chunkTrailerP input' of - LP.Done input'' _ - → acceptRequest ctx input'' - LP.Fail _ _ _ - → chunkWasMalformed itr - LP.Fail _ _ _ - → chunkWasMalformed itr + → acceptRequest ctx input' + LP.Fail _ _ msg + → chunkWasMalformed rsrcTid + $ "readCurrentChunk: chunkTrailerP: " ⧺ msg -chunkWasMalformed ∷ Interaction → IO () -chunkWasMalformed itr - -- FIXME: This is a totally wrong way to abort! - = atomically $ - do setResponseStatus itr BadRequest - writeTVar (itrWillClose itr) True - writeTVar (itrState itr) Done - postprocess itr +chunkWasMalformed ∷ ThreadId → String → IO () +chunkWasMalformed tid msg + = let abo = mkAbortion BadRequest [("Connection", "close")] + $ Just + $ "chunkWasMalformed: " ⊕ T.pack msg + in + throwTo tid abo waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h ⇒ Context h - → Interaction + → NormalInteraction → Lazy.ByteString → Int → IO () -waitForReceiveNonChunkedBodyReqForTheFirstTime ctx itr@(Interaction {..}) input bodyLen +waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) input bodyLen = join $ atomically $ - do req ← takeTMVar itrReceiveBodyReq + do req ← takeTMVar niReceiveBodyReq case req of ReceiveBody wanted - → do putTMVar itrSendContinue $ fromJust itrExpectedContinue - return $ readNonChunkedRequestBody ctx itr input bodyLen wanted + → do putTMVar niSendContinue niExpectedContinue + return $ readNonChunkedRequestBody ctx ni input bodyLen wanted WasteAll - → do putTMVar itrSendContinue False + → do putTMVar niSendContinue False return $ wasteNonChunkedRequestBody ctx input bodyLen waitForReceiveNonChunkedBodyReq ∷ HandleLike h ⇒ Context h - → Interaction + → NormalInteraction → Lazy.ByteString → Int → IO () -waitForReceiveNonChunkedBodyReq ctx itr@(Interaction {..}) input bodyLen - = do req ← atomically $ takeTMVar itrReceiveBodyReq +waitForReceiveNonChunkedBodyReq ctx ni@(NI {..}) input bodyLen + = do req ← atomically $ takeTMVar niReceiveBodyReq case req of ReceiveBody wanted - → readNonChunkedRequestBody ctx itr input bodyLen wanted + → readNonChunkedRequestBody ctx ni input bodyLen wanted WasteAll → wasteNonChunkedRequestBody ctx input bodyLen @@ -365,12 +338,12 @@ wasteNonChunkedRequestBody ctx input bodyLen readNonChunkedRequestBody ∷ HandleLike h ⇒ Context h - → Interaction + → NormalInteraction → Lazy.ByteString → Int → Int → IO () -readNonChunkedRequestBody ctx itr@(Interaction {..}) input bodyLen wanted +readNonChunkedRequestBody ctx ni@(NI {..}) input bodyLen wanted | bodyLen ≡ 0 = gotEndOfRequest | otherwise = gotBody where @@ -381,15 +354,17 @@ readNonChunkedRequestBody ctx itr@(Interaction {..}) input bodyLen wanted block' = Strict.concat $ Lazy.toChunks block actualReadBytes = Strict.length block' bodyLen' = bodyLen - actualReadBytes - atomically $ putTMVar itrReceivedBody block' - waitForReceiveNonChunkedBodyReq ctx itr input' bodyLen' + atomically $ putTMVar niReceivedBody block' + waitForReceiveNonChunkedBodyReq ctx ni input' bodyLen' gotEndOfRequest ∷ IO () gotEndOfRequest - = do atomically $ putTMVar itrReceivedBody (∅) + = do atomically $ putTMVar niReceivedBody (∅) acceptRequest ctx input -enqueue ∷ HandleLike h ⇒ Context h → Interaction → STM () +enqueue ∷ (HandleLike h, Interaction i) ⇒ Context h → i → IO () +{-# INLINEABLE enqueue #-} enqueue (Context {..}) itr - = do queue ← readTVar cQueue - writeTVar cQueue (itr ⊲ queue) + = atomically $ + do queue ← readTVar cQueue + writeTVar cQueue (toInteraction itr ⊲ queue) diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 085b677..314e1f5 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -255,8 +255,8 @@ getAccept Just accept → case P.parseOnly p (A.toByteString accept) of Right xs → return xs - Left _ → abort BadRequest [] - (Just $ "Unparsable Accept: " ⊕ A.toText accept) + Left _ → abort $ mkAbortion' BadRequest + $ "Unparsable Accept: " ⊕ A.toText accept where p = do xs ← mimeTypeListP P.endOfInput @@ -278,8 +278,8 @@ getAcceptEncoding case ver of HttpVersion 1 0 → return [("identity", Nothing)] HttpVersion 1 1 → return [("*" , Nothing)] - _ → abort InternalServerError [] - (Just "getAcceptEncoding: unknown HTTP version") + _ → abort $ mkAbortion' InternalServerError + "getAcceptEncoding: unknown HTTP version" Just ae → if ae ≡ "" then -- identity のみが許される。 @@ -287,8 +287,8 @@ getAcceptEncoding else case P.parseOnly p (A.toByteString ae) of Right xs → return $ map toTuple $ reverse $ sort xs - Left _ → abort BadRequest [] - (Just $ "Unparsable Accept-Encoding: " ⊕ A.toText ae) + Left _ → abort $ mkAbortion' BadRequest + $ "Unparsable Accept-Encoding: " ⊕ A.toText ae where p = do xs ← acceptEncodingListP P.endOfInput @@ -314,8 +314,8 @@ getContentType Just cType → case P.parseOnly p (A.toByteString cType) of Right t → return $ Just t - Left _ → abort BadRequest [] - (Just $ "Unparsable Content-Type: " ⊕ A.toText cType) + Left _ → abort $ mkAbortion' BadRequest + $ "Unparsable Content-Type: " ⊕ A.toText cType where p = do t ← mimeTypeP P.endOfInput @@ -360,8 +360,9 @@ foundEntity tag timeStamp when (method ≡ GET ∨ method ≡ HEAD) $ setHeader "Last-Modified" (HTTP.toAscii timeStamp) when (method ≡ POST) - $ abort InternalServerError [] - (Just "foundEntity: this is a POST request.") + $ abort + $ mkAbortion' InternalServerError + "foundEntity: this is a POST request." foundETag tag driftTo ReceivingBody @@ -383,8 +384,9 @@ foundETag tag $ A.fromAsciiBuilder $ printETag tag when (method ≡ POST) - $ abort InternalServerError [] - $ Just "Illegal computation of foundETag for POST request." + $ abort + $ mkAbortion' InternalServerError + "Illegal computation of foundETag for POST request." -- If-Match があればそれを見る。 ifMatch ← getHeader "If-Match" @@ -398,13 +400,12 @@ foundETag tag -- tags の中に一致するものが無ければ -- PreconditionFailed で終了。 → when ((¬) (any (≡ tag) tags)) - $ abort PreconditionFailed [] - $ Just + $ abort + $ mkAbortion' PreconditionFailed $ "The entity tag doesn't match: " ⊕ A.toText value Left _ - → abort BadRequest [] - $ Just - $ "Unparsable If-Match: " ⊕ A.toText value + → abort $ mkAbortion' BadRequest + $ "Unparsable If-Match: " ⊕ A.toText value let statusForNoneMatch = if method ≡ GET ∨ method ≡ HEAD then @@ -417,18 +418,18 @@ foundETag tag case ifNoneMatch of Nothing → return () Just value → if value ≡ "*" then - abort statusForNoneMatch [] (Just "The entity tag matches: *") + abort $ mkAbortion' statusForNoneMatch + $ "The entity tag matches: *" else case P.parseOnly p (A.toByteString value) of Right tags → when (any (≡ tag) tags) - $ abort statusForNoneMatch [] - $ Just + $ abort + $ mkAbortion' statusForNoneMatch $ "The entity tag matches: " ⊕ A.toText value Left _ - → abort BadRequest [] - $ Just - $ "Unparsable If-None-Match: " ⊕ A.toText value + → abort $ mkAbortion' BadRequest + $ "Unparsable If-None-Match: " ⊕ A.toText value driftTo ReceivingBody where @@ -454,8 +455,9 @@ foundTimeStamp timeStamp when (method ≡ GET ∨ method ≡ HEAD) $ setHeader "Last-Modified" (HTTP.toAscii timeStamp) when (method ≡ POST) - $ abort InternalServerError [] - (Just "Illegal computation of foundTimeStamp for POST request.") + $ abort + $ mkAbortion' InternalServerError + "Illegal computation of foundTimeStamp for POST request." let statusForIfModSince = if method ≡ GET ∨ method ≡ HEAD then @@ -469,8 +471,9 @@ foundTimeStamp timeStamp Just str → case HTTP.fromAscii str of Right lastTime → when (timeStamp ≤ lastTime) - $ abort statusForIfModSince [] - (Just $ "The entity has not been modified since " ⊕ A.toText str) + $ abort + $ mkAbortion' statusForIfModSince + $ "The entity has not been modified since " ⊕ A.toText str Left _ → return () -- 不正な時刻は無視 Nothing → return () @@ -481,8 +484,9 @@ foundTimeStamp timeStamp Just str → case HTTP.fromAscii str of Right lastTime → when (timeStamp > lastTime) - $ abort PreconditionFailed [] - (Just $ "The entity has not been modified since " ⊕ A.toText str) + $ abort + $ mkAbortion' PreconditionFailed + $ "The entity has not been modified since " ⊕ A.toText str Left _ → return () -- 不正な時刻は無視 Nothing → return () @@ -503,13 +507,15 @@ foundNoEntity msgM method ← getMethod when (method ≢ PUT) - $ abort NotFound [] msgM + $ abort + $ mkAbortion NotFound [] msgM -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな -- If-Match: 條件も滿たさない。 ifMatch ← getHeader "If-Match" when (ifMatch ≢ Nothing) - $ abort PreconditionFailed [] msgM + $ abort + $ mkAbortion PreconditionFailed [] msgM driftTo ReceivingBody @@ -539,10 +545,15 @@ getChunks' ∷ Int → Resource Lazy.ByteString getChunks' limit = go limit (∅) where go ∷ Int → Seq Strict.ByteString → Resource Lazy.ByteString - go 0 _ = abort RequestEntityTooLarge [] - (Just $ "Request body must be smaller than " - ⊕ T.pack (show limit) ⊕ " bytes.") - go n xs = do let n' = min n Lazy.defaultChunkSize + go 0 _ = do chunk ← getChunk 1 + if Strict.null chunk then + return (∅) + else + abort $ mkAbortion' RequestEntityTooLarge + $ "Request body must be smaller than " + ⊕ T.pack (show limit) + ⊕ " bytes." + go n xs = do let n' = min n Lazy.defaultChunkSize chunk ← getChunk n' if Strict.null chunk then -- Got EOF @@ -570,18 +581,17 @@ getForm limit = do cTypeM ← getContentType case cTypeM of Nothing - → abort BadRequest [] (Just "Missing Content-Type") + → abort $ mkAbortion' BadRequest "Missing Content-Type" Just (MIMEType "application" "x-www-form-urlencoded" _) → readWWWFormURLEncoded Just (MIMEType "multipart" "form-data" params) → readMultipartFormData params Just cType - → abort UnsupportedMediaType [] - $ Just - $ A.toText - $ A.fromAsciiBuilder - $ A.toAsciiBuilder "Unsupported media type: " - ⊕ printMIMEType cType + → abort $ mkAbortion' UnsupportedMediaType + $ A.toText + $ A.fromAsciiBuilder + $ A.toAsciiBuilder "Unsupported media type: " + ⊕ printMIMEType cType where readWWWFormURLEncoded = (map toPairWithFormData ∘ parseWWWFormURLEncoded) @@ -591,22 +601,22 @@ getForm limit bsToAscii bs = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of Just a → return a - Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded") + Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded" readMultipartFormData params - = do case M.lookup "boundary" params of - Nothing - → abort BadRequest [] (Just "Missing boundary of multipart/form-data") - Just boundary - → do src ← getChunks limit - b ← case A.fromText boundary of - Just b → return b - Nothing → abort BadRequest [] - (Just $ "Malformed boundary: " ⊕ boundary) - case LP.parse (p b) src of - LP.Done _ formList - → return formList - _ → abort BadRequest [] (Just "Unparsable multipart/form-data") + = case M.lookup "boundary" params of + Nothing + → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data" + Just boundary + → do src ← getChunks limit + b ← case A.fromText boundary of + Just b → return b + Nothing → abort $ mkAbortion' BadRequest + $ "Malformed boundary: " ⊕ boundary + case LP.parse (p b) src of + LP.Done _ formList + → return formList + _ → abort $ mkAbortion' BadRequest "Unparsable multipart/form-data" where p b = do xs ← multipartFormP b P.endOfInput @@ -618,8 +628,8 @@ getForm limit redirect ∷ StatusCode → URI → Resource () redirect code uri = do when (code ≡ NotModified ∨ not (isRedirection code)) - $ abort InternalServerError [] - $ Just + $ abort + $ mkAbortion' InternalServerError $ A.toText $ A.fromAsciiBuilder $ A.toAsciiBuilder "Attempted to redirect with status " @@ -640,8 +650,8 @@ setLocation ∷ URI → Resource () setLocation uri = case A.fromChars uriStr of Just a → setHeader "Location" a - Nothing → abort InternalServerError [] - (Just $ "Malformed URI: " ⊕ T.pack uriStr) + Nothing → abort $ mkAbortion' InternalServerError + $ "Malformed URI: " ⊕ T.pack uriStr where uriStr = uriToString id uri "" @@ -653,8 +663,8 @@ setContentEncoding codings tr ← case ver of HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding) HttpVersion 1 1 → return toAB - _ → abort InternalServerError [] - (Just "setContentEncoding: Unknown HTTP version") + _ → abort $ mkAbortion' InternalServerError + "setContentEncoding: Unknown HTTP version" setHeader "Content-Encoding" (A.fromAsciiBuilder $ joinWith ", " $ map tr codings) where diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs index 1d01a82..a1ad956 100644 --- a/Network/HTTP/Lucu/Resource/Internal.hs +++ b/Network/HTTP/Lucu/Resource/Internal.hs @@ -35,6 +35,7 @@ import Control.Concurrent.STM import Control.Exception import Control.Monad.IO.Class import Control.Monad.Reader +import Control.Monad.Unicode import Data.Ascii (Ascii, CIAscii) import qualified Data.Ascii as A import qualified Data.ByteString as Strict @@ -43,6 +44,7 @@ import Data.Maybe import Data.Monoid.Unicode import qualified Data.Text as T import Network.HTTP.Lucu.Abortion +import Network.HTTP.Lucu.Abortion.Internal import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.DefaultPage import qualified Network.HTTP.Lucu.Headers as H @@ -61,11 +63,11 @@ import System.IO -- any 'IO' actions. newtype Resource a = Resource { - unResource ∷ ReaderT Interaction IO a + unResource ∷ ReaderT NormalInteraction IO a } deriving (Applicative, Functor, Monad, MonadIO) -runResource ∷ Resource a → Interaction → IO a +runResource ∷ Resource a → NormalInteraction → IO a runResource = runReaderT ∘ unResource -- |'ResourceDef' is basically a set of 'Resource' monads for each @@ -137,8 +139,8 @@ emptyResource = ResourceDef { , resDelete = Nothing } -spawnResource ∷ ResourceDef → Interaction → IO ThreadId -spawnResource (ResourceDef {..}) itr@(Interaction {..}) +spawnResource ∷ ResourceDef → NormalInteraction → IO ThreadId +spawnResource (ResourceDef {..}) ni@(NI {..}) = fork $ run `catch` processException where fork ∷ IO () → IO ThreadId @@ -146,7 +148,7 @@ spawnResource (ResourceDef {..}) itr@(Interaction {..}) | otherwise = forkIO run ∷ IO () - run = flip runResource itr $ + run = flip runResource ni $ do req ← getRequest fromMaybe notAllowed $ rsrc req driftTo Done @@ -188,26 +190,26 @@ spawnResource (ResourceDef {..}) itr@(Interaction {..}) toAbortion e = case fromException e of Just abortion → abortion - Nothing → Abortion InternalServerError (∅) (Just $ T.pack $ show e) + Nothing → mkAbortion' InternalServerError $ T.pack $ show e processException ∷ SomeException → IO () processException exc = do let abo = toAbortion exc - state ← atomically $ readTVar itrState - res ← atomically $ readTVar itrResponse + state ← atomically $ readTVar niState + res ← atomically $ readTVar niResponse if state ≤ DecidingHeader then -- We still have a chance to reflect this abortion -- in the response. Hooray! - flip runResource itr $ + flip runResource ni $ do setStatus $ aboStatus abo + mapM_ (uncurry setHeader) $ H.fromHeaders $ aboHeaders abo setHeader "Content-Type" defaultPageContentType deleteHeader "Content-Encoding" - mapM_ (uncurry setHeader) $ H.fromHeaders $ aboHeaders abo - putBuilder $ abortPage itrConfig itrRequest res abo + putBuilder $ abortPage niConfig (Just niRequest) res abo else - when (cnfDumpTooLateAbortionToStderr itrConfig) + when (cnfDumpTooLateAbortionToStderr niConfig) $ dumpAbortion abo - runResource (driftTo Done) itr + runResource (driftTo Done) ni dumpAbortion ∷ Abortion → IO () dumpAbortion abo @@ -217,16 +219,16 @@ dumpAbortion abo , " ", show abo, "\n" ] -getInteraction ∷ Resource Interaction +getInteraction ∷ Resource NormalInteraction getInteraction = Resource ask -- |Get the 'Config' value for this httpd. getConfig ∷ Resource Config -getConfig = itrConfig <$> getInteraction +getConfig = niConfig <$> getInteraction -- |Get the 'SockAddr' of the remote host. getRemoteAddr ∷ Resource SockAddr -getRemoteAddr = itrRemoteAddr <$> getInteraction +getRemoteAddr = niRemoteAddr <$> getInteraction -- | Return the X.509 certificate of the client, or 'Nothing' if: -- @@ -238,12 +240,12 @@ getRemoteAddr = itrRemoteAddr <$> getInteraction -- 'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to -- 'OpenSSL.Session.VerifyPeer'. getRemoteCertificate ∷ Resource (Maybe X509) -getRemoteCertificate = itrRemoteCert <$> getInteraction +getRemoteCertificate = niRemoteCert <$> getInteraction -- |Return the 'Request' value representing the request header. You -- usually don't need to call this function directly. getRequest ∷ Resource Request -getRequest = (fromJust ∘ itrRequest) <$> getInteraction +getRequest = niRequest <$> getInteraction -- |Get the path of this 'Resource' (to be exact, 'ResourceDef') in -- the 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this @@ -267,7 +269,7 @@ getRequest = (fromJust ∘ itrRequest) <$> getInteraction -- > , ... -- > } getResourcePath ∷ Resource [Strict.ByteString] -getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction +getResourcePath = niResourcePath <$> getInteraction -- |@'getChunk' n@ attempts to read a chunk of request body up to @n@ -- bytes. You can incrementally read the request body by repeatedly @@ -283,20 +285,19 @@ getChunk' n | n ≡ 0 = return (∅) | otherwise = do req ← getRequest if reqMustHaveBody req then - do itr ← getInteraction - askForInput itr + askForInput =≪ getInteraction else driftTo DecidingHeader *> return (∅) where - askForInput ∷ Interaction → Resource Strict.ByteString - askForInput (Interaction {..}) + askForInput ∷ NormalInteraction → Resource Strict.ByteString + askForInput (NI {..}) = do -- Ask the RequestReader to get a chunk. liftIO $ atomically - $ putTMVar itrReceiveBodyReq (ReceiveBody n) + $ putTMVar niReceiveBodyReq (ReceiveBody n) -- Then wait for a reply. chunk ← liftIO $ atomically - $ takeTMVar itrReceivedBody + $ takeTMVar niReceivedBody -- Have we got an EOF? when (Strict.null chunk) $ driftTo DecidingHeader @@ -306,12 +307,12 @@ getChunk' n -- the status code will be defaulted to \"200 OK\". setStatus ∷ StatusCode → Resource () setStatus sc - = do itr ← getInteraction + = do ni ← getInteraction liftIO $ atomically - $ do state ← readTVar $ itrState itr + $ do state ← readTVar $ niState ni when (state > DecidingHeader) $ fail "Too late to declare the response status." - setResponseStatus itr sc + setResponseStatus ni sc -- |@'setHeader' name value@ declares the value of the response header -- @name@ as @value@. Note that this function is not intended to be @@ -330,31 +331,35 @@ setStatus sc -- of the next response. setHeader ∷ CIAscii → Ascii → Resource () setHeader name value - = do itr ← getInteraction - liftIO $ atomically - $ do state ← readTVar $ itrState itr - when (state > DecidingHeader) - $ fail "Too late to declare a response header field." - res ← readTVar $ itrResponse itr - let res' = H.setHeader name value res - writeTVar (itrResponse itr) res' - when (name ≡ "Content-Type") - $ writeTVar (itrResponseHasCType itr) True + = do ni ← getInteraction + liftIO $ atomically $ go ni + where + go ∷ NormalInteraction → STM () + go (NI {..}) + = do state ← readTVar niState + when (state > DecidingHeader) $ + fail "Too late to declare a response header field." + res ← readTVar niResponse + writeTVar niResponse $ H.setHeader name value res + when (name ≡ "Content-Type") $ + writeTVar niResponseHasCType True -- |@'deleteHeader' name@ deletes a response header @name@ if -- any. This function is not intended to be used so frequently. deleteHeader ∷ CIAscii → Resource () deleteHeader name - = do itr ← getInteraction - liftIO $ atomically - $ do state ← readTVar $ itrState itr - when (state > DecidingHeader) - $ fail "Too late to delete a response header field." - res ← readTVar $ itrResponse itr - let res' = H.deleteHeader name res - writeTVar (itrResponse itr) res' - when (name ≡ "Content-Type") - $ writeTVar (itrResponseHasCType itr) False + = do ni ← getInteraction + liftIO $ atomically $ go ni + where + go ∷ NormalInteraction → STM () + go (NI {..}) + = do state ← readTVar niState + when (state > DecidingHeader) $ + fail "Too late to delete a response header field." + res ← readTVar niResponse + writeTVar niResponse $ H.deleteHeader name res + when (name ≡ "Content-Type") $ + writeTVar niResponseHasCType False -- |Run a 'Builder' to construct a chunk, and write it to the response -- body. It is safe to apply this function to a 'Builder' producing an @@ -365,23 +370,27 @@ deleteHeader name -- 'setContentType'. putBuilder ∷ Builder → Resource () putBuilder b - = do itr ← getInteraction - liftIO $ atomically - $ do driftTo' itr SendingBody - hasCType ← readTVar $ itrResponseHasCType itr - unless hasCType - $ abortSTM InternalServerError [] - $ Just "putBuilder: Content-Type has not been set." - putTMVar (itrBodyToSend itr) b + = do ni ← getInteraction + liftIO $ atomically $ go ni + where + go ∷ NormalInteraction → STM () + go ni@(NI {..}) + = do driftTo' ni SendingBody + hasCType ← readTVar niResponseHasCType + unless hasCType + $ throwSTM + $ mkAbortion' InternalServerError + "putBuilder: Content-Type has not been set." + putTMVar niBodyToSend b driftTo ∷ InteractionState → Resource () driftTo newState - = do itr ← getInteraction - liftIO $ atomically $ driftTo' itr newState + = do ni ← getInteraction + liftIO $ atomically $ driftTo' ni newState -driftTo' ∷ Interaction → InteractionState → STM () -driftTo' itr@(Interaction {..}) newState - = do oldState ← readTVar itrState +driftTo' ∷ NormalInteraction → InteractionState → STM () +driftTo' ni@(NI {..}) newState + = do oldState ← readTVar niState driftFrom oldState where driftFrom ∷ InteractionState → STM () @@ -393,7 +402,7 @@ driftTo' itr@(Interaction {..}) newState b = tail a c = zip a b mapM_ (uncurry driftFromTo) c - writeTVar itrState newState + writeTVar niState newState throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a throwStateError Done SendingBody @@ -403,8 +412,8 @@ driftTo' itr@(Interaction {..}) newState driftFromTo ∷ InteractionState → InteractionState → STM () driftFromTo ReceivingBody _ - = putTMVar itrReceiveBodyReq WasteAll + = putTMVar niReceiveBodyReq WasteAll driftFromTo DecidingHeader _ - = postprocess itr + = postprocess ni driftFromTo _ _ = return () diff --git a/Network/HTTP/Lucu/Response.hs b/Network/HTTP/Lucu/Response.hs index 547947b..e2b76fa 100644 --- a/Network/HTTP/Lucu/Response.hs +++ b/Network/HTTP/Lucu/Response.hs @@ -13,6 +13,7 @@ module Network.HTTP.Lucu.Response , printStatusCode , Response(..) + , emptyResponse , resCanHaveBody , printResponse @@ -107,11 +108,18 @@ data Response = Response { } deriving (Show, Eq) instance HasHeaders Response where - {-# INLINE getHeaders #-} - getHeaders = resHeaders - {-# INLINE setHeaders #-} + getHeaders = resHeaders setHeaders res hdr = res { resHeaders = hdr } +-- |Returns an HTTP\/1.1 'Response' with no header fields. +emptyResponse ∷ StatusCode → Response +emptyResponse sc + = Response { + resVersion = HttpVersion 1 1 + , resStatus = sc + , resHeaders = (∅) + } + -- |Returns 'True' iff a given 'Response' allows the existence of -- response entity body. resCanHaveBody ∷ Response → Bool diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 02e3938..d89ee9e 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -9,6 +9,7 @@ module Network.HTTP.Lucu.ResponseWriter ) where import qualified Blaze.ByteString.Builder.HTTP as BB +import Control.Applicative import Control.Concurrent import Control.Concurrent.STM import Control.Exception @@ -21,7 +22,6 @@ import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.HandleLike import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction -import Network.HTTP.Lucu.Postprocess import Network.HTTP.Lucu.Response import Prelude.Unicode import System.IO (hPutStrLn, stderr) @@ -79,141 +79,149 @@ awaitSomethingToWrite ctx@(Context {..}) case S.viewr queue of EmptyR → retry queue' :> itr → do writeTVar cQueue queue' - return $ writeContinueIfNeeded ctx itr + return $ writeSomething ctx itr + +writeSomething ∷ HandleLike h ⇒ Context h → SomeInteraction → IO () +writeSomething ctx itr + = let writer = writeResponseForNI ctx <$> fromInteraction itr <|> + writeResponseForSEI ctx <$> fromInteraction itr <|> + writeResponseForSYI ctx <$> fromInteraction itr + in + case writer of + Just f → f + Nothing → fail "Internal error: unknown interaction type" + +writeResponseForNI ∷ HandleLike h + ⇒ Context h + → NormalInteraction + → IO () +writeResponseForNI = writeContinueIfNeeded writeContinueIfNeeded ∷ HandleLike h ⇒ Context h - → Interaction + → NormalInteraction → IO () -writeContinueIfNeeded ctx@(Context {..}) itr@(Interaction {..}) - = do isNeeded ← atomically $ readTMVar itrSendContinue +writeContinueIfNeeded ctx@(Context {..}) ni@(NI {..}) + = do isNeeded ← atomically $ readTMVar niSendContinue when isNeeded $ do let cont = Response { resVersion = HttpVersion 1 1 , resStatus = Continue , resHeaders = (∅) } - cont' ← completeUnconditionalHeaders cConfig cont - hPutBuilder cHandle $ A.toBuilder $ printResponse cont' + hPutBuilder cHandle $ A.toBuilder $ printResponse cont hFlush cHandle - writeHeader ctx itr + writeHeader ctx ni writeHeader ∷ HandleLike h ⇒ Context h - → Interaction + → NormalInteraction → IO () -writeHeader ctx@(Context {..}) itr@(Interaction {..}) +writeHeader ctx@(Context {..}) ni@(NI {..}) = do res ← atomically $ - do state ← readTVar itrState + do state ← readTVar niState if state ≥ SendingBody then - readTVar itrResponse + readTVar niResponse else retry -- Too early to write header fields. hPutBuilder cHandle $ A.toBuilder $ printResponse res hFlush cHandle - writeBodyIfNeeded ctx itr + writeBodyIfNeeded ctx ni writeBodyIfNeeded ∷ HandleLike h ⇒ Context h - → Interaction + → NormalInteraction → IO () -writeBodyIfNeeded ctx itr@(Interaction {..}) +writeBodyIfNeeded ctx ni@(NI {..}) = join $ atomically $ - do willDiscardBody ← readTVar itrWillDiscardBody + do willDiscardBody ← readTVar niWillDiscardBody if willDiscardBody then - return $ discardBody ctx itr + return $ discardBody ctx ni else - do willChunkBody ← readTVar itrWillChunkBody - if willChunkBody then - return $ writeChunkedBody ctx itr - else - return $ writeNonChunkedBody ctx itr + if niWillChunkBody then + return $ writeChunkedBody ctx ni + else + return $ writeNonChunkedBody ctx ni discardBody ∷ HandleLike h ⇒ Context h - → Interaction + → NormalInteraction → IO () -discardBody ctx itr@(Interaction {..}) +discardBody ctx ni@(NI {..}) = join $ atomically $ - do chunk ← tryTakeTMVar itrBodyToSend + do chunk ← tryTakeTMVar niBodyToSend case chunk of - Just _ → return $ discardBody ctx itr - Nothing → do state ← readTVar itrState + Just _ → return $ discardBody ctx ni + Nothing → do state ← readTVar niState if state ≡ Done then - return $ finalize ctx itr + return $ finalize ctx ni else retry writeChunkedBody ∷ HandleLike h ⇒ Context h - → Interaction + → NormalInteraction → IO () -writeChunkedBody ctx@(Context {..}) itr@(Interaction {..}) +writeChunkedBody ctx@(Context {..}) ni@(NI {..}) = join $ atomically $ - do chunk ← tryTakeTMVar itrBodyToSend + do chunk ← tryTakeTMVar niBodyToSend case chunk of Just b → return $ do hPutBuilder cHandle $ BB.chunkedTransferEncoding b hFlush cHandle - writeChunkedBody ctx itr - Nothing → do state ← readTVar itrState + writeChunkedBody ctx ni + Nothing → do state ← readTVar niState if state ≡ Done then - return $ finalize ctx itr + return $ + do hPutBuilder cHandle BB.chunkedTransferTerminator + hFlush cHandle + finalize ctx ni else retry writeNonChunkedBody ∷ HandleLike h ⇒ Context h - → Interaction + → NormalInteraction → IO () -writeNonChunkedBody ctx@(Context {..}) itr@(Interaction {..}) +writeNonChunkedBody ctx@(Context {..}) ni@(NI {..}) = join $ atomically $ - do chunk ← tryTakeTMVar itrBodyToSend + do chunk ← tryTakeTMVar niBodyToSend case chunk of Just b → return $ do hPutBuilder cHandle b hFlush cHandle - writeNonChunkedBody ctx itr - Nothing → do state ← readTVar itrState + writeNonChunkedBody ctx ni + Nothing → do state ← readTVar niState if state ≡ Done then - return $ finalize ctx itr + return $ finalize ctx ni else retry -finalize ∷ HandleLike h ⇒ Context h → Interaction → IO () -finalize ctx@(Context {..}) (Interaction {..}) +finalize ∷ HandleLike h ⇒ Context h → NormalInteraction → IO () +finalize ctx@(Context {..}) (NI {..}) = join $ atomically $ - do sentContinue ← takeTMVar itrSendContinue - willDiscardBody ← readTVar itrWillDiscardBody - willChunkBody ← readTVar itrWillChunkBody - willClose ← readTVar itrWillClose - queue ← readTVar cQueue - case S.viewr queue of - queue' :> _ - → writeTVar cQueue queue' - EmptyR - → fail "finalize: cQueue is empty, which should never happen." + do willClose ← readTVar niWillClose + sentContinue ← takeTMVar niSendContinue return $ - do when (((¬) willDiscardBody) ∧ willChunkBody) - $ do hPutBuilder cHandle BB.chunkedTransferTerminator - hFlush cHandle - if willClose ∨ needToClose sentContinue then - -- The RequestReader is probably blocking on - -- hWaitForInput so we have to kill it before - -- closing the socket. - -- THINKME: Couldn't that somehow be avoided? - do killThread cReader - hClose cHandle - else - awaitSomethingToWrite ctx + if needToClose willClose sentContinue then + -- The RequestReader is probably blocking on + -- hWaitForInput so we have to kill it before closing + -- the socket. THINKME: Couldn't that somehow be + -- avoided? + do killThread cReader + hClose cHandle + else + awaitSomethingToWrite ctx where - needToClose ∷ Bool → Bool - needToClose sentContinue + needToClose ∷ Bool → Bool → Bool + needToClose willClose sentContinue + -- Explicitly instructed to close the connection. + | willClose = True -- We've sent both "HTTP/1.1 100 Continue" and a final -- response, so nothing prevents our connection from keeping -- alive. @@ -225,7 +233,37 @@ finalize ctx@(Context {..}) (Interaction {..}) -- (rejected) request body OR start a completely new request -- in this situation. So the only possible thing to do is to -- brutally shutdown the connection. - | itrExpectedContinue ≡ Just True = True + | niExpectedContinue = True -- The client didn't expect 100-continue so we haven't sent -- one. No need to do anything special. | otherwise = False + +writeResponseForSEI ∷ HandleLike h + ⇒ Context h + → SemanticallyInvalidInteraction + → IO () +writeResponseForSEI ctx@(Context {..}) (SEI {..}) + = do hPutBuilder cHandle $ A.toBuilder $ printResponse seiResponse + unless seiWillDiscardBody $ + if seiWillChunkBody then + do hPutBuilder cHandle $ BB.chunkedTransferEncoding seiBodyToSend + hPutBuilder cHandle BB.chunkedTransferTerminator + else + hPutBuilder cHandle seiBodyToSend + hFlush cHandle + if seiWillClose ∨ seiExpectedContinue then + do killThread cReader + hClose cHandle + else + awaitSomethingToWrite ctx + +writeResponseForSYI ∷ HandleLike h + ⇒ Context h + → SyntacticallyInvalidInteraction + → IO () +writeResponseForSYI (Context {..}) (SYI {..}) + = do hPutBuilder cHandle $ A.toBuilder $ printResponse syiResponse + hPutBuilder cHandle syiBodyToSend + hFlush cHandle + killThread cReader + hClose cHandle diff --git a/Network/HTTP/Lucu/StaticFile.hs b/Network/HTTP/Lucu/StaticFile.hs index 82bc59b..d79fc4f 100644 --- a/Network/HTTP/Lucu/StaticFile.hs +++ b/Network/HTTP/Lucu/StaticFile.hs @@ -56,11 +56,13 @@ handleStaticFile sendContent path readable ← liftIO $ fileAccess path True False False unless readable - $ abort Forbidden [] Nothing + $ abort + $ mkAbortion Forbidden [] Nothing stat ← liftIO $ getFileStatus path when (isDirectory stat) - $ abort Forbidden [] Nothing + $ abort + $ mkAbortion Forbidden [] Nothing tag ← liftIO $ generateETagFromFile path let lastMod = posixSecondsToUTCTime diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs index 3b17bf8..d7e0071 100644 --- a/examples/HelloWorld.hs +++ b/examples/HelloWorld.hs @@ -5,7 +5,6 @@ import Control.Applicative import Control.Monad.Unicode import qualified Data.ByteString.Lazy.Char8 as Lazy -import Data.Monoid.Unicode import Network.HTTP.Lucu main ∷ IO () @@ -23,19 +22,18 @@ main = let config = defaultConfig { cnfServerPort = "9999" } do putStrLn "Access http://localhost:9999/ with your browser." runHttpd config resources fallbacks - helloWorld ∷ ResourceDef helloWorld = emptyResource { resGet = Just $ do setContentType $ parseMIMEType "text/hello" - outputChunk "Hello, " - outputChunk "World!\n" - outputChunk =≪ Lazy.pack <$> getRemoteAddr' + putChunk "Hello, " + putChunk "World!\n" + putChunks =≪ Lazy.pack <$> getRemoteAddr' , resPost - = Just $ do str1 ← inputChunk 3 - str2 ← inputChunk 3 - str3 ← inputChunk 3 + = Just $ do str1 ← getChunk 3 + str2 ← getChunk 3 + str3 ← getChunk 3 setContentType $ parseMIMEType "text/hello" - output ("[" ⊕ str1 ⊕ " - " ⊕ str2 ⊕ "#" ⊕ str3 ⊕ "]") + putChunks $ Lazy.fromChunks ["[", str1, " - ", str2, "#", str3, "]"] }