From: PHO Date: Wed, 19 Oct 2011 14:28:25 +0000 (+0900) Subject: Many many changes X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=1f0a19cbad7c4b64a773d7f1c1ae9180448624e6;p=Lucu.git Many many changes Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa --- diff --git a/Lucu.cabal b/Lucu.cabal index 9373133..95d2095 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -67,8 +67,8 @@ Library text-icu == 0.6.*, time == 1.2.*, time-http == 0.2.*, - unix == 2.4.*, - zlib == 0.5.* + transformers == 0.2.*, + unix == 2.4.* Exposed-Modules: Network.HTTP.Lucu @@ -101,6 +101,7 @@ Library Network.HTTP.Lucu.Postprocess Network.HTTP.Lucu.Preprocess Network.HTTP.Lucu.RequestReader + Network.HTTP.Lucu.Resource.Internal Network.HTTP.Lucu.ResponseWriter Network.HTTP.Lucu.SocketLike @@ -116,7 +117,8 @@ Executable lucu-implant-file Main-Is: ImplantFile.hs Build-Depends: - SHA == 1.5.* + SHA == 1.5.*, + zlib == 0.5.* ghc-options: -Wall diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs index 0099576..6c2d14d 100644 --- a/Network/HTTP/Lucu/Abortion.hs +++ b/Network/HTTP/Lucu/Abortion.hs @@ -17,6 +17,8 @@ module Network.HTTP.Lucu.Abortion , 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 @@ -26,7 +28,6 @@ import Control.Monad.Trans import Data.Ascii (Ascii, CIAscii) import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.Lazy as Lazy import Data.Typeable import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.DefaultPage @@ -50,9 +51,8 @@ instance Exception Abortion -- 'Network.HTTP.Lucu.Resource.Resource' monad with given status, -- additional response headers, and optional message string. -- --- What this really does is to throw a special --- 'Control.Exception.Exception'. The exception will be caught by the --- Lucu system. +-- 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 @@ -61,11 +61,11 @@ instance Exception Abortion -- -- 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 --- 'Network.HTTP.Lucu.Config.cnfDumpTooLateAbortionToStderr'. +-- stderr. See 'cnfDumpTooLateAbortionToStderr'. -- --- Note that the status code doesn't have to be an error code so you --- can use this action for redirection as well as error reporting e.g. +-- 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/")] @@ -99,7 +99,7 @@ abortA = proc (status, (headers, msg)) → -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な -- ければならない。 -abortPage ∷ Config → Maybe Request → Response → Abortion → Lazy.Text +abortPage ∷ Config → Maybe Request → Response → Abortion → Builder abortPage conf reqM res abo = case aboMessage abo of Just msg @@ -108,7 +108,7 @@ abortPage conf reqM res abo writeDocumentToString [ withIndent True ] ) () in - Lazy.pack html + BB.fromString html Nothing → let res' = res { resStatus = aboStatus abo } res'' = foldl (∘) id [setHeader name value diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs index 4727980..cdeef3b 100644 --- a/Network/HTTP/Lucu/Config.hs +++ b/Network/HTTP/Lucu/Config.hs @@ -56,9 +56,9 @@ data Config = Config { , cnfMaxPipelineDepth ∷ !Int -- |The maximum length of request entity to accept in bytes. Note - -- that this is nothing but the default value which is used when - -- 'Network.HTTP.Lucu.Resource.input' and such like are applied to - -- 'Network.HTTP.Lucu.Resource.defaultLimit', so there is no + -- that this is nothing but a default value which is used when + -- 'Network.HTTP.Lucu.Resource.getForm' and such like are applied + -- to 'Network.HTTP.Lucu.Resource.defaultLimit', so there is no -- guarantee that this value always constrains all the requests. , cnfMaxEntityLength ∷ !Int diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index 70d4a6a..19a7293 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -8,6 +8,8 @@ module Network.HTTP.Lucu.DefaultPage , mkDefaultPage ) where +import Blaze.ByteString.Builder (Builder) +import qualified Blaze.ByteString.Builder.Char.Utf8 as BB import Control.Arrow import Control.Arrow.ArrowList import Control.Arrow.ListArrow @@ -16,7 +18,6 @@ import Data.Ascii (Ascii) import qualified Data.Ascii as A import Data.Maybe import qualified Data.Text as T -import qualified Data.Text.Lazy as Lazy import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.Request @@ -28,7 +29,7 @@ import Text.XML.HXT.Arrow.XmlArrow import Text.XML.HXT.Arrow.XmlState import Text.XML.HXT.DOM.TypeDefs -getDefaultPage ∷ Config → Maybe Request → Response → Lazy.Text +getDefaultPage ∷ Config → Maybe Request → Response → Builder {-# INLINEABLE getDefaultPage #-} getDefaultPage conf req res = let msgA = getMsg req res @@ -37,7 +38,7 @@ getDefaultPage conf req res writeDocumentToString [ withIndent True ] ) () in - Lazy.pack xmlStr + BB.fromString xmlStr defaultPageContentType ∷ Ascii {-# INLINE defaultPageContentType #-} diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 4ac7c09..4d153d1 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -7,6 +7,7 @@ module Network.HTTP.Lucu.Interaction ( Interaction(..) , InteractionState(..) , InteractionQueue + , GetBodyRequest(..) , newInteractionQueue , newInteraction @@ -15,7 +16,7 @@ module Network.HTTP.Lucu.Interaction where import Blaze.ByteString.Builder (Builder) import Control.Concurrent.STM -import qualified Data.ByteString as BS +import qualified Data.ByteString as Strict import Data.Monoid.Unicode import Data.Sequence (Seq) import qualified Data.Sequence as S @@ -39,11 +40,8 @@ data Interaction = Interaction { , itrExpectedContinue ∷ !(Maybe Bool) , itrReqBodyLength ∷ !(Maybe RequestBodyLength) - , itrReqBodyWanted ∷ !(TVar Int) - , itrReqBodyWasteAll ∷ !(TVar Bool) - , itrReqChunkIsOver ∷ !(TVar Bool) - , itrReceivedBody ∷ !(TVar (Seq BS.ByteString)) - , itrReceivedBodyLen ∷ !(TVar Int) + , itrGetBodyRequest ∷ !(TMVar GetBodyRequest) + , itrGotBody ∷ !(TMVar Strict.ByteString) , itrResponse ∷ !(TVar Response) , itrWillChunkBody ∷ !(TVar Bool) @@ -57,15 +55,21 @@ data Interaction = Interaction { -- |The interaction state of Resource monad. 'ExaminingRequest' is the -- initial state. -data InteractionState = ExaminingRequest - | GettingBody - | DecidingHeader - | DecidingBody - | Done - deriving (Show, Eq, Ord, Enum) +data InteractionState + = ExaminingRequest + | GettingBody + | DecidingHeader + | DecidingBody + | Done + deriving (Show, Eq, Ord, Enum) type InteractionQueue = TVar (Seq Interaction) +data GetBodyRequest + = GetBody !Int -- ^ Maximum number of bytes. + | WasteAll + deriving (Show, Eq) + newInteractionQueue ∷ IO InteractionQueue newInteractionQueue = newTVarIO S.empty @@ -83,11 +87,8 @@ newInteraction conf@(Config {..}) port addr cert request , resHeaders = (∅) } - reqBodyWanted ← newTVarIO 0 - reqBodyWasteAll ← newTVarIO False - reqChunkIsOver ← newTVarIO False - receivedBody ← newTVarIO S.empty - receivedBodyLen ← newTVarIO 0 + getBodyRequest ← newEmptyTMVarIO + gotBody ← newEmptyTMVarIO response ← newTVarIO res willChunkBody ← newTVarIO False @@ -99,21 +100,18 @@ newInteraction conf@(Config {..}) port addr cert request state ← newTVarIO ExaminingRequest return Interaction { - itrConfig = conf - , itrLocalPort = port - , itrRemoteAddr = addr - , itrRemoteCert = cert - , itrResourcePath = Nothing - , itrRequest = arRequest ar + itrConfig = conf + , itrLocalPort = port + , itrRemoteAddr = addr + , itrRemoteCert = cert + , itrResourcePath = Nothing + , itrRequest = arRequest ar , itrExpectedContinue = arExpectedContinue ar , itrReqBodyLength = arReqBodyLength ar - , itrReqBodyWanted = reqBodyWanted - , itrReqBodyWasteAll = reqBodyWasteAll - , itrReqChunkIsOver = reqChunkIsOver - , itrReceivedBody = receivedBody - , itrReceivedBodyLen = receivedBodyLen + , itrGetBodyRequest = getBodyRequest + , itrGotBody = gotBody , itrResponse = response , itrWillChunkBody = willChunkBody diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 39b6b4c..131cc8e 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -9,7 +9,6 @@ module Network.HTTP.Lucu.Postprocess , completeUnconditionalHeaders ) where -import qualified Blaze.ByteString.Builder.Char.Utf8 as BB import Control.Applicative import Control.Concurrent.STM import Control.Monad @@ -33,7 +32,6 @@ import Prelude.Unicode postprocess ∷ Interaction → STM () postprocess itr@(Interaction {..}) = do abortOnCertainConditions itr - writeDefaultPageIfNeeded itr case itrRequest of Just req → postprocessWithRequest itr req @@ -115,9 +113,10 @@ writeDefaultPageIfNeeded itr@(Interaction {..}) = do resHasCType ← readTVar itrResponseHasCType 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 (BB.fromLazyText page) + putTMVar itrBodyToSend page writeHeader ∷ Interaction → CIAscii → Maybe Ascii → STM () {-# INLINE writeHeader #-} diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index ddff647..696abf1 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -5,7 +5,6 @@ , RecordWildCards , UnicodeSyntax #-} -{-# OPTIONS_HADDOCK prune #-} -- |This is the Resource Monad; monadic actions to define the behavior -- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO' -- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is @@ -63,18 +62,13 @@ -- the entire request before starting 'Resource', nor we don't want to -- postpone writing the entire response till the end of 'Resource' -- computation. - module Network.HTTP.Lucu.Resource ( -- * Types Resource , FormData(..) - , runRes - - -- * Actions - - -- ** Getting request header + -- * Getting request header -- |These actions can be computed regardless of the current state, -- and they don't change the state. , getConfig @@ -96,8 +90,7 @@ module Network.HTTP.Lucu.Resource , getContentType , getAuthorization - -- ** Finding an entity - + -- * Finding an entity -- |These actions can be computed only in the /Examining Request/ -- state. After the computation, the 'Resource' transits to -- /Getting Body/ state. @@ -106,42 +99,42 @@ module Network.HTTP.Lucu.Resource , foundTimeStamp , foundNoEntity - -- ** Getting a request body - + -- * Getting a request body -- |Computation of these actions changes the state to /Getting -- Body/. - , input - , inputChunk - , inputForm + , getChunk + , getChunks + , getForm , defaultLimit - -- ** Setting response headers - + -- * Setting response headers -- |Computation of these actions changes the state to /Deciding -- Header/. , setStatus - , setHeader , redirect , setContentType - , setLocation , setContentEncoding , setWWWAuthenticate - -- ** Writing a response body + -- ** Less frequently used functions + , setLocation + , setHeader + , deleteHeader + -- * Writing a response body -- |Computation of these actions changes the state to /Deciding -- Body/. , putChunk + , putChunks , putBuilder - - , driftTo -- private ) where import Blaze.ByteString.Builder (Builder) import qualified Blaze.ByteString.Builder.ByteString as BB import Control.Applicative import Control.Concurrent.STM -import Control.Monad.Reader +import Control.Monad +import Control.Monad.IO.Class import Control.Monad.Unicode import Data.Ascii (Ascii, CIAscii) import qualified Data.Ascii as A @@ -172,6 +165,7 @@ import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.MultipartForm import Network.HTTP.Lucu.Postprocess import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Resource.Internal import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.MIMEType import Network.HTTP.Lucu.Utils @@ -180,21 +174,6 @@ import Network.URI hiding (path) import OpenSSL.X509 import Prelude.Unicode --- |The 'Resource' monad. This monad implements 'MonadIO' so it can do --- any 'IO' actions. -newtype Resource a - = Resource { - unRes ∷ ReaderT Interaction IO a - } - deriving (Applicative, Functor, Monad, MonadIO) - -runRes ∷ Resource a → Interaction → IO a -runRes r itr - = runReaderT (unRes r) itr - -getInteraction ∷ Resource Interaction -getInteraction = Resource ask - -- |Get the 'Config' value which is used for the httpd. getConfig ∷ Resource Config getConfig = itrConfig <$> getInteraction @@ -230,11 +209,6 @@ getRemoteHost getRemoteCertificate ∷ Resource (Maybe X509) getRemoteCertificate = itrRemoteCert <$> getInteraction --- |Get the 'Request' value which represents the request header. In --- general you don't have to use this action. -getRequest ∷ Resource Request -getRequest = (fromJust ∘ itrRequest) <$> getInteraction - -- |Get the 'Method' value of the request. getMethod ∷ Resource Method getMethod = reqMethod <$> getRequest @@ -778,44 +752,6 @@ defaultLimit = (-1) -- Setting response headers --- | Set the response status code. If you omit to compute this action, --- the status code will be defaulted to \"200 OK\". -setStatus ∷ StatusCode → Resource () -setStatus sc - = do driftTo DecidingHeader - itr ← getInteraction - liftIO - $ atomically - $ setResponseStatus itr sc - --- | Set a value of given resource header. Comparison of header name --- is case-insensitive. Note that this action is not intended to be --- used so frequently: there should be actions like 'setContentType' --- for every common headers. --- --- Some important headers (especially \"Content-Length\" and --- \"Transfer-Encoding\") may be silently dropped or overwritten by --- the system not to corrupt the interaction with client at the --- viewpoint of HTTP protocol layer. For instance, if we are keeping --- the connection alive, without this process it causes a catastrophe --- to send a header \"Content-Length: 10\" and actually send a body of --- 20 bytes long. In this case the client shall only accept the first --- 10 bytes of response body and thinks that the residual 10 bytes is --- a part of header of the next response. -setHeader ∷ CIAscii → Ascii → Resource () -setHeader name value - = driftTo DecidingHeader ≫ setHeader' name value - -setHeader' ∷ CIAscii → Ascii → Resource () -setHeader' name value - = do itr ← getInteraction - liftIO $ atomically - $ do res ← readTVar $ itrResponse itr - let res' = H.setHeader name value res - writeTVar (itrResponse itr) res' - when (name ≡ "Content-Type") - $ writeTVar (itrResponseHasCType itr) True - -- | Computation of @'redirect' code uri@ sets the response status to -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy -- 'isRedirection' or it causes an error. @@ -834,11 +770,12 @@ redirect code uri -- | Computation of @'setContentType' mType@ sets the response header -- \"Content-Type\" to @mType@. setContentType ∷ MIMEType → Resource () -{-# INLINE setContentType #-} -setContentType = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType +setContentType + = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType -- | Computation of @'setLocation' uri@ sets the response header --- \"Location\" to @uri@. +-- \"Location\" to @uri@. You usually don't need to call this function +-- directly. setLocation ∷ URI → Resource () setLocation uri = case A.fromChars uriStr of @@ -879,56 +816,4 @@ setWWWAuthenticate challenge -- Note that you must first set the response header \"Content-Type\" -- before applying this function. See: 'setContentType' putChunk ∷ Lazy.ByteString → Resource () -{-# INLINE putChunk #-} putChunk = putBuilder ∘ BB.fromLazyByteString - --- | 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 infinitely long stream of octets. --- --- Note that you must first set the response header \"Content-Type\" --- before applying this function. See: 'setContentType' -putBuilder ∷ Builder → Resource () -putBuilder b - = do itr ← getInteraction - liftIO $ atomically - $ do driftTo' itr DecidingBody - hasCType ← readTVar $ itrResponseHasCType itr - unless hasCType - $ abortSTM InternalServerError [] - $ Just "putBuilder: Content-Type has not been set." - putTMVar (itrBodyToSend itr) b - - --- Private - -driftTo ∷ InteractionState → Resource () -driftTo newState - = do itr ← getInteraction - liftIO $ atomically $ driftTo' itr newState - -driftTo' ∷ Interaction → InteractionState → STM () -driftTo' itr@(Interaction {..}) newState - = do oldState ← readTVar itrState - if newState < oldState then - throwStateError oldState newState - else - do let a = [oldState .. newState] - b = tail a - c = zip a b - mapM_ (uncurry drift) c - writeTVar itrState newState - where - throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a - throwStateError Done DecidingBody - = fail "It makes no sense to output something after finishing outputs." - throwStateError old new - = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new) - - drift ∷ InteractionState → InteractionState → STM () - drift GettingBody _ - = writeTVar itrReqBodyWasteAll True - drift DecidingHeader _ - = postprocess itr - drift _ _ - = return () diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs new file mode 100644 index 0000000..d68b334 --- /dev/null +++ b/Network/HTTP/Lucu/Resource/Internal.hs @@ -0,0 +1,323 @@ +{-# LANGUAGE + DoAndIfThenElse + , GeneralizedNewtypeDeriving + , OverloadedStrings + , RecordWildCards + , UnicodeSyntax + #-} +module Network.HTTP.Lucu.Resource.Internal + ( Resource + , ResourceDef(..) + , emptyResource + , spawnResource + + , getInteraction + , getRequest + + , setStatus + , setHeader + , setHeader' + , deleteHeader + + , putBuilder + + , driftTo + ) + where +import Blaze.ByteString.Builder (Builder) +import Control.Applicative +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception +import Control.Monad.IO.Class +import Control.Monad.Reader +import Data.Ascii (Ascii, CIAscii) +import qualified Data.Ascii as A +import Data.List +import Data.Maybe +import Data.Monoid.Unicode +import qualified Data.Text as T +import Network.HTTP.Lucu.Abortion +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.DefaultPage +import qualified Network.HTTP.Lucu.Headers as H +import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.Postprocess +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Response +import Network.HTTP.Lucu.Utils +import Prelude hiding (catch) +import Prelude.Unicode +import System.IO + +-- |The 'Resource' monad. This monad implements 'MonadIO' so it can do +-- any 'IO' actions. +newtype Resource a + = Resource { + unResource ∷ ReaderT Interaction IO a + } + deriving (Applicative, Functor, Monad, MonadIO) + +runResource ∷ Resource a → Interaction → IO a +runResource = runReaderT ∘ unResource + +-- | 'ResourceDef' is basically a set of 'Resource' monads for each +-- HTTP methods. +data ResourceDef = ResourceDef { + -- |Whether to run a 'Resource' on a native thread (spawned by + -- 'forkOS') or to run it on a user thread (spanwed by + -- 'forkIO'). Generally you don't need to set this field to + -- 'True'. + resUsesNativeThread ∷ !Bool + -- | Whether to be greedy or not. + -- + -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a + -- greedy resource at \/aaa\/bbb, it is always chosen even if + -- there is another resource at \/aaa\/bbb\/ccc. If the resource + -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy + -- resources are like CGI scripts. + , resIsGreedy ∷ !Bool + -- | A 'Resource' to be run when a GET request comes for the + -- resource path. If 'resGet' is Nothing, the system responds + -- \"405 Method Not Allowed\" for GET requests. + -- + -- It also runs for HEAD request if the 'resHead' is Nothing. In + -- this case 'output' and such like don't actually write a + -- response body. + , resGet ∷ !(Maybe (Resource ())) + -- | A 'Resource' to be run when a HEAD request comes for the + -- resource path. If 'resHead' is Nothing, the system runs + -- 'resGet' instead. If 'resGet' is also Nothing, the system + -- responds \"405 Method Not Allowed\" for HEAD requests. + , resHead ∷ !(Maybe (Resource ())) + -- | A 'Resource' to be run when a POST request comes for the + -- resource path. If 'resPost' is Nothing, the system responds + -- \"405 Method Not Allowed\" for POST requests. + , resPost ∷ !(Maybe (Resource ())) + -- | A 'Resource' to be run when a PUT request comes for the + -- resource path. If 'resPut' is Nothing, the system responds + -- \"405 Method Not Allowed\" for PUT requests. + , resPut ∷ !(Maybe (Resource ())) + -- | A 'Resource' to be run when a DELETE request comes for the + -- resource path. If 'resDelete' is Nothing, the system responds + -- \"405 Method Not Allowed\" for DELETE requests. + , resDelete ∷ !(Maybe (Resource ())) + } + +-- |'emptyResource' is a resource definition with no actual +-- handlers. You can construct a 'ResourceDef' by selectively +-- overriding 'emptyResource'. It is defined as follows: +-- +-- @ +-- emptyResource = ResourceDef { +-- resUsesNativeThread = False +-- , resIsGreedy = False +-- , resGet = Nothing +-- , resHead = Nothing +-- , resPost = Nothing +-- , resPut = Nothing +-- , resDelete = Nothing +-- } +-- @ +emptyResource ∷ ResourceDef +emptyResource = ResourceDef { + resUsesNativeThread = False + , resIsGreedy = False + , resGet = Nothing + , resHead = Nothing + , resPost = Nothing + , resPut = Nothing + , resDelete = Nothing + } + +spawnResource ∷ ResourceDef → Interaction → IO ThreadId +spawnResource (ResourceDef {..}) itr@(Interaction {..}) + = fork $ run `catch` processException + where + fork ∷ IO () → IO ThreadId + fork | resUsesNativeThread = forkOS + | otherwise = forkIO + + run ∷ IO () + run = flip runResource itr $ + do req ← getRequest + fromMaybe notAllowed $ rsrc req + driftTo Done + + rsrc ∷ Request → Maybe (Resource ()) + rsrc req + = case reqMethod req of + GET → resGet + HEAD → case resHead of + Just r → Just r + Nothing → resGet + POST → resPost + PUT → resPut + DELETE → resDelete + _ → error $ "Unknown request method: " ⧺ show (reqMethod req) + + notAllowed ∷ Resource () + notAllowed + = setStatus MethodNotAllowed + *> + (setHeader "Allow" $ A.fromAsciiBuilder + $ joinWith ", " + $ map A.toAsciiBuilder allowedMethods) + + allowedMethods ∷ [Ascii] + allowedMethods = nub $ concat [ methods resGet ["GET"] + , methods resHead ["GET", "HEAD"] + , methods resPost ["POST"] + , methods resPut ["PUT"] + , methods resDelete ["DELETE"] + ] + + methods ∷ Maybe a → [Ascii] → [Ascii] + methods m xs + | isJust m = xs + | otherwise = [] + + toAbortion ∷ SomeException → Abortion + toAbortion e + = case fromException e of + Just abortion → abortion + Nothing → Abortion InternalServerError (∅) (Just $ T.pack $ show e) + + processException ∷ SomeException → IO () + processException exc + = do let abo = toAbortion exc + -- まだ DecidingHeader 以前の状態だったら、この途中終了 + -- を應答に反映させる餘地がある。さうでなければ stderr + -- にでも吐くしか無い。 + state ← atomically $ readTVar itrState + res ← atomically $ readTVar itrResponse + if state ≤ DecidingHeader then + flip runResource itr $ + do setStatus $ aboStatus abo + setHeader "Content-Type" defaultPageContentType + deleteHeader "Content-Encoding" + mapM_ (uncurry setHeader) $ H.fromHeaders $ aboHeaders abo + putBuilder $ abortPage itrConfig itrRequest res abo + else + when (cnfDumpTooLateAbortionToStderr itrConfig) + $ dumpAbortion abo + runResource (driftTo Done) itr + +dumpAbortion ∷ Abortion → IO () +dumpAbortion abo + = hPutStr stderr + $ concat [ "Lucu: an exception occured after " + , "sending response header to the client:\n" + , " ", show abo, "\n" + ] + +getInteraction ∷ Resource Interaction +getInteraction = Resource ask + +-- |Get the 'Request' value which represents the request header. In +-- general you don't have to use this action. +getRequest ∷ Resource Request +getRequest = (fromJust ∘ itrRequest) <$> getInteraction + +-- | Set the response status code. If you don't call this function, +-- the status code will be defaulted to \"200 OK\". +setStatus ∷ StatusCode → Resource () +setStatus sc + = do driftTo DecidingHeader + itr ← getInteraction + liftIO + $ atomically + $ setResponseStatus itr sc + +-- | @'setHeader' name value@ sets the value of the response header +-- @name@ to @value@. Note that this function is not intended to be +-- used so frequently: there should be specialised functions like +-- 'setContentType' for every common headers. +-- +-- Some important headers (especially \"Content-Length\" and +-- \"Transfer-Encoding\") may be silently dropped or overwritten by +-- the system not to corrupt the interaction with client at the +-- viewpoint of HTTP protocol layer. For instance, if we are keeping +-- the connection alive, without this manipulation it will be a +-- catastrophe when we send a header \"Content-Length: 10\" and +-- actually send a body of 20 bytes long to the remote peer. In this +-- case the client shall only accept the first 10 bytes of response +-- body and thinks that the residual 10 bytes is a part of the header +-- of the next response. +setHeader ∷ CIAscii → Ascii → Resource () +setHeader name value + = driftTo DecidingHeader *> setHeader' name value + +setHeader' ∷ CIAscii → Ascii → Resource () +setHeader' name value + = do itr ← getInteraction + liftIO $ atomically + $ do res ← readTVar $ itrResponse itr + let res' = H.setHeader name value res + writeTVar (itrResponse itr) res' + when (name ≡ "Content-Type") + $ writeTVar (itrResponseHasCType itr) 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 + = driftTo DecidingHeader *> deleteHeader' name + +deleteHeader' ∷ CIAscii → Resource () +deleteHeader' name + = do itr ← getInteraction + liftIO $ atomically + $ do res ← readTVar $ itrResponse itr + let res' = H.deleteHeader name res + writeTVar (itrResponse itr) res' + when (name ≡ "Content-Type") + $ writeTVar (itrResponseHasCType itr) 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 infinitely long stream of octets. +-- +-- Note that you must first set the response header \"Content-Type\" +-- before applying this function. See: 'setContentType' +putBuilder ∷ Builder → Resource () +putBuilder b + = do itr ← getInteraction + liftIO $ atomically + $ do driftTo' itr DecidingBody + hasCType ← readTVar $ itrResponseHasCType itr + unless hasCType + $ abortSTM InternalServerError [] + $ Just "putBuilder: Content-Type has not been set." + putTMVar (itrBodyToSend itr) b + +driftTo ∷ InteractionState → Resource () +driftTo newState + = do itr ← getInteraction + liftIO $ atomically $ driftTo' itr newState + +driftTo' ∷ Interaction → InteractionState → STM () +driftTo' itr@(Interaction {..}) newState + = do oldState ← readTVar itrState + if newState < oldState then + throwStateError oldState newState + else + do let a = [oldState .. newState] + b = tail a + c = zip a b + mapM_ (uncurry drift) c + writeTVar itrState newState + where + throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a + throwStateError Done DecidingBody + = fail "It makes no sense to output something after finishing outputs." + throwStateError old new + = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new) + + drift ∷ InteractionState → InteractionState → STM () + drift GettingBody _ + = putTMVar itrGetBodyRequest WasteAll + drift DecidingHeader _ + = postprocess itr + drift _ _ + = return () diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index 17827d1..9ab6f66 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -7,16 +7,11 @@ -- | Repository of the resources in httpd. module Network.HTTP.Lucu.Resource.Tree - ( ResourceDef(..) - , emptyResource - - , ResTree + ( ResTree , FallbackHandler , mkResTree - , findResource - , runResource ) where import Control.Arrow @@ -29,7 +24,6 @@ import Control.Exception import Control.Monad import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.Lazy.Encoding as LT import Data.List import qualified Data.Map as M import Data.Map (Map) @@ -49,7 +43,6 @@ import System.IO import Prelude hiding (catch) import Prelude.Unicode - -- |'FallbackHandler' is an extra resource handler for resources which -- can't be statically located anywhere in the resource tree. The Lucu -- httpd first searches for a resource in the tree, and then calls @@ -57,81 +50,6 @@ import Prelude.Unicode -- handlers returned 'Nothing', the httpd responds with 404 Not Found. type FallbackHandler = [Text] → IO (Maybe ResourceDef) - --- "/aaa/bbb/ccc" にアクセスされた時、もし "/aaa/bbb" に貪欲なリソース --- があれば、假に "/aaa/bbb/ccc" に何らかのリソースがあったとしても必ず --- "/aaa/bbb" が撰ばれる。"/aaa/bbb" のリソースが貪欲でなければ、それは --- 無視される。 - --- | 'ResourceDef' is basically a set of 'Resource' monads for each --- HTTP methods. -data ResourceDef = ResourceDef { - -- |Whether to run a 'Resource' on a native thread (spawned by - -- 'forkOS') or to run it on a user thread (spanwed by - -- 'forkIO'). Generally you don't need to set this field to - -- 'True'. - resUsesNativeThread ∷ !Bool - -- | Whether to be greedy or not. - -- - -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a - -- greedy resource at \/aaa\/bbb, it is always chosen even if - -- there is another resource at \/aaa\/bbb\/ccc. If the resource - -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy - -- resources are like CGI scripts. - , resIsGreedy ∷ !Bool - -- | A 'Resource' to be run when a GET request comes for the - -- resource path. If 'resGet' is Nothing, the system responds - -- \"405 Method Not Allowed\" for GET requests. - -- - -- It also runs for HEAD request if the 'resHead' is Nothing. In - -- this case 'output' and such like don't actually write a - -- response body. - , resGet ∷ !(Maybe (Resource ())) - -- | A 'Resource' to be run when a HEAD request comes for the - -- resource path. If 'resHead' is Nothing, the system runs - -- 'resGet' instead. If 'resGet' is also Nothing, the system - -- responds \"405 Method Not Allowed\" for HEAD requests. - , resHead ∷ !(Maybe (Resource ())) - -- | A 'Resource' to be run when a POST request comes for the - -- resource path. If 'resPost' is Nothing, the system responds - -- \"405 Method Not Allowed\" for POST requests. - , resPost ∷ !(Maybe (Resource ())) - -- | A 'Resource' to be run when a PUT request comes for the - -- resource path. If 'resPut' is Nothing, the system responds - -- \"405 Method Not Allowed\" for PUT requests. - , resPut ∷ !(Maybe (Resource ())) - -- | A 'Resource' to be run when a DELETE request comes for the - -- resource path. If 'resDelete' is Nothing, the system responds - -- \"405 Method Not Allowed\" for DELETE requests. - , resDelete ∷ !(Maybe (Resource ())) - } - --- |'emptyResource' is a resource definition with no actual --- handlers. You can construct a 'ResourceDef' by selectively --- overriding 'emptyResource'. It is defined as follows: --- --- @ --- emptyResource = ResourceDef { --- resUsesNativeThread = False --- , resIsGreedy = False --- , resGet = Nothing --- , resHead = Nothing --- , resPost = Nothing --- , resPut = Nothing --- , resDelete = Nothing --- } --- @ -emptyResource ∷ ResourceDef -emptyResource = ResourceDef { - resUsesNativeThread = False - , resIsGreedy = False - , resGet = Nothing - , resHead = Nothing - , resPost = Nothing - , resPut = Nothing - , resDelete = Nothing - } - -- |'ResTree' is an opaque structure which is a map from resource path -- to 'ResourceDef'. newtype ResTree = ResTree ResNode -- root だから Map ではない @@ -227,84 +145,3 @@ findResource (ResTree (ResNode rootDefM subtree)) fbs uri case m of Just def → return $ Just ([], def) Nothing → fallback path xs - - -runResource ∷ ResourceDef → Interaction → IO ThreadId -runResource (ResourceDef {..}) itr@(Interaction {..}) - = fork $ run `catch` processException - where - fork ∷ IO () → IO ThreadId - fork | resUsesNativeThread = forkOS - | otherwise = forkIO - - run ∷ IO () - run = flip runRes itr $ - do req ← getRequest - fromMaybe notAllowed $ rsrc req - driftTo Done - - rsrc ∷ Request → Maybe (Resource ()) - rsrc req - = case reqMethod req of - GET → resGet - HEAD → case resHead of - Just r → Just r - Nothing → resGet - POST → resPost - PUT → resPut - DELETE → resDelete - _ → error $ "Unknown request method: " ⧺ show (reqMethod req) - - notAllowed ∷ Resource () - notAllowed - = setStatus MethodNotAllowed - *> - (setHeader "Allow" $ A.fromAsciiBuilder - $ joinWith ", " - $ map A.toAsciiBuilder allowedMethods) - - allowedMethods ∷ [Ascii] - allowedMethods = nub $ concat [ methods resGet ["GET"] - , methods resHead ["GET", "HEAD"] - , methods resPost ["POST"] - , methods resPut ["PUT"] - , methods resDelete ["DELETE"] - ] - - methods ∷ Maybe a → [Ascii] → [Ascii] - methods m xs - | isJust m = xs - | otherwise = [] - - toAbortion ∷ SomeException → Abortion - toAbortion e - = case fromException e of - Just abortion → abortion - Nothing → Abortion InternalServerError (∅) (Just $ T.pack $ show e) - - processException ∷ SomeException → IO () - processException exc - = do let abo = toAbortion exc - -- まだ DecidingHeader 以前の状態だったら、この途中終了 - -- を應答に反映させる餘地がある。さうでなければ stderr - -- にでも吐くしか無い。 - state ← atomically $ readTVar itrState - res ← atomically $ readTVar itrResponse - if state ≤ DecidingHeader then - flip runRes itr $ - do setStatus $ aboStatus abo - setHeader "Content-Type" defaultPageContentType - mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo - putChunk $ LT.encodeUtf8 $ abortPage itrConfig itrRequest res abo - else - when (cnfDumpTooLateAbortionToStderr itrConfig) - $ dumpAbortion abo - runRes (driftTo Done) itr - -dumpAbortion ∷ Abortion → IO () -dumpAbortion abo - = hPutStr stderr - $ concat [ "Lucu: an exception occured after " - , "sending response header to the client:\n" - , " ", show abo, "\n" - ] diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 587c01b..1106f14 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -113,8 +113,8 @@ writeContinueIfNeeded ∷ HandleLike h → STM (IO ()) writeContinueIfNeeded ctx itr@(Interaction {..}) phase | phase ≡ Initial ∧ itrExpectedContinue ≡ Just True - = do reqBodyWanted ← readTVar itrReqBodyWanted - if reqBodyWanted > 0 then + = do isRequested ← isEmptyTMVar itrGetBodyRequest + if isRequested then return $ writeContinue ctx itr else retry