From: PHO Date: Thu, 20 Oct 2011 17:16:46 +0000 (+0900) Subject: Resource.hs compiles again. X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=7843dbf537dfefa583a8ee55b2a31a5e8a9c7c37;p=Lucu.git Resource.hs compiles again. Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa --- diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 4d153d1..f57a474 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -7,7 +7,7 @@ module Network.HTTP.Lucu.Interaction ( Interaction(..) , InteractionState(..) , InteractionQueue - , GetBodyRequest(..) + , ReceiveBodyRequest(..) , newInteractionQueue , newInteraction @@ -40,8 +40,8 @@ data Interaction = Interaction { , itrExpectedContinue ∷ !(Maybe Bool) , itrReqBodyLength ∷ !(Maybe RequestBodyLength) - , itrGetBodyRequest ∷ !(TMVar GetBodyRequest) - , itrGotBody ∷ !(TMVar Strict.ByteString) + , itrReceiveBodyReq ∷ !(TMVar ReceiveBodyRequest) + , itrReceivedBody ∷ !(TMVar Strict.ByteString) , itrResponse ∷ !(TVar Response) , itrWillChunkBody ∷ !(TVar Bool) @@ -57,16 +57,16 @@ data Interaction = Interaction { -- initial state. data InteractionState = ExaminingRequest - | GettingBody + | ReceivingBody | DecidingHeader - | DecidingBody + | SendingBody | Done deriving (Show, Eq, Ord, Enum) type InteractionQueue = TVar (Seq Interaction) -data GetBodyRequest - = GetBody !Int -- ^ Maximum number of bytes. +data ReceiveBodyRequest + = ReceiveBody !Int -- ^ Maximum number of octets to receive. | WasteAll deriving (Show, Eq) @@ -87,8 +87,8 @@ newInteraction conf@(Config {..}) port addr cert request , resHeaders = (∅) } - getBodyRequest ← newEmptyTMVarIO - gotBody ← newEmptyTMVarIO + receiveBodyReq ← newEmptyTMVarIO + receivedBody ← newEmptyTMVarIO response ← newTVarIO res willChunkBody ← newTVarIO False @@ -110,8 +110,8 @@ newInteraction conf@(Config {..}) port addr cert request , itrExpectedContinue = arExpectedContinue ar , itrReqBodyLength = arReqBodyLength ar - , itrGetBodyRequest = getBodyRequest - , itrGotBody = gotBody + , itrReceiveBodyReq = receiveBodyReq + , itrReceivedBody = receivedBody , itrResponse = response , itrWillChunkBody = willChunkBody diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 696abf1..eed224f 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -5,10 +5,9 @@ , RecordWildCards , UnicodeSyntax #-} --- |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 --- also a state machine. +-- |This is the Resource Monad; monadic actions to define a behavior +-- of resource. The 'Resource' Monad is a kind of 'IO' Monad thus it +-- implements 'MonadIO' class, and it is a state machine as well. -- -- Request Processing Flow: -- @@ -17,9 +16,9 @@ -- 2. If the URI of it matches to any resource, the corresponding -- 'Resource' Monad starts running on a newly spawned thread. -- --- 3. The 'Resource' Monad looks at the request header, find (or not --- find) an entity, receive the request body (if any), decide the --- response header, and decide the response body. This process +-- 3. The 'Resource' Monad looks at request headers, find (or not +-- find) an entity, receive the request body (if any), send +-- response headers, and then send a response body. This process -- will be discussed later. -- -- 4. The 'Resource' Monad and its thread stops running. The client @@ -29,29 +28,33 @@ -- /Examining Request/ and the final state is /Done/. -- -- [/Examining Request/] In this state, a 'Resource' looks at the --- request header and thinks about an entity for it. If there is a --- suitable entity, the 'Resource' tells the system an entity tag --- and its last modification time ('foundEntity'). If it found no --- entity, it tells the system so ('foundNoEntity'). In case it is --- impossible to decide the existence of entity, which is a typical --- case for POST requests, 'Resource' does nothing in this state. +-- request header fields and thinks about a corresponding entity for +-- it. If there is a suitable entity, the 'Resource' tells the +-- system an entity tag and its last modification time +-- ('foundEntity'). If it found no entity, it tells the system so +-- ('foundNoEntity'). In case it is impossible to decide the +-- existence of entity, which is a typical case for POST requests, +-- 'Resource' does nothing in this state. -- --- [/Getting Body/] A 'Resource' asks the system to receive a --- request body from client. Before actually reading from the +-- [/Receiving Body/] A 'Resource' asks the system to receive a +-- request body from the client. Before actually reading from the -- socket, the system sends \"100 Continue\" to the client if need -- be. When a 'Resource' transits to the next state without --- receiving all or part of request body, the system still reads it --- and just throws it away. +-- receiving all or part of a request body, the system automatically +-- receives and discards it. -- -- [/Deciding Header/] A 'Resource' makes a decision of status code --- and response header. When it transits to the next state, the --- system checks the validness of response header and then write --- them to the socket. +-- and response header fields. When it transits to the next state, +-- the system validates and completes the response header fields and +-- then sends them to the client. -- --- [/Deciding Body/] In this state, a 'Resource' asks the system to +-- [/Sending Body/] In this state, a 'Resource' asks the system to -- write some response body to the socket. When it transits to the -- next state without writing any response body, the system --- completes it depending on the status code. +-- automatically completes it depending on the status code. (To be +-- exact, such completion only occurs when the 'Resource' transits +-- to this state without even declaring the \"Content-Type\" header +-- field. See 'setContentType'.) -- -- [/Done/] Everything is over. A 'Resource' can do nothing for the -- HTTP interaction anymore. @@ -69,8 +72,8 @@ module Network.HTTP.Lucu.Resource , FormData(..) -- * Getting request header - -- |These actions can be computed regardless of the current state, - -- and they don't change the state. + -- |These functions can be called regardless of the current state, + -- and they don't change the state of 'Resource'. , getConfig , getRemoteAddr , getRemoteAddr' @@ -91,25 +94,25 @@ module Network.HTTP.Lucu.Resource , getAuthorization -- * Finding an entity - -- |These actions can be computed only in the /Examining Request/ - -- state. After the computation, the 'Resource' transits to - -- /Getting Body/ state. + -- |These functions can be called only in the /Examining Request/ + -- state. They make the 'Resource' transit to the /Receiving Body/ + -- state. , foundEntity , foundETag , foundTimeStamp , foundNoEntity - -- * Getting a request body - -- |Computation of these actions changes the state to /Getting - -- Body/. + -- * Receiving a request body + -- |These functions make the 'Resource' transit to the /Receiving + -- Body/ state. , getChunk , getChunks , getForm - , defaultLimit - -- * Setting response headers - -- |Computation of these actions changes the state to /Deciding - -- Header/. + -- * Declaring response status and header fields + -- |These functions can be called at any time before transiting to + -- the /Sending Body/ state, but they themselves never causes any + -- state transitions. , setStatus , redirect , setContentType @@ -121,18 +124,16 @@ module Network.HTTP.Lucu.Resource , setHeader , deleteHeader - -- * Writing a response body - -- |Computation of these actions changes the state to /Deciding - -- Body/. + -- * Sending a response body + -- |These functions make the 'Resource' transit to the /Sending + -- Body/ state. , putChunk , putChunks , putBuilder ) where -import Blaze.ByteString.Builder (Builder) import qualified Blaze.ByteString.Builder.ByteString as BB import Control.Applicative -import Control.Concurrent.STM import Control.Monad import Control.Monad.IO.Class import Control.Monad.Unicode @@ -143,12 +144,14 @@ import qualified Data.Attoparsec.Lazy as LP import Data.ByteString (ByteString) import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy +import qualified Data.ByteString.Lazy.Internal as Lazy import Data.Foldable (toList) import Data.List import qualified Data.Map as M import Data.Maybe import Data.Monoid.Unicode import Data.Sequence (Seq) +import Data.Sequence.Unicode hiding ((∅)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -163,7 +166,6 @@ import qualified Network.HTTP.Lucu.Headers as H import Network.HTTP.Lucu.HttpVersion 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 @@ -171,25 +173,14 @@ import Network.HTTP.Lucu.MIMEType import Network.HTTP.Lucu.Utils import Network.Socket hiding (accept) import Network.URI hiding (path) -import OpenSSL.X509 import Prelude.Unicode --- |Get the 'Config' value which is used for the httpd. -getConfig ∷ Resource Config -getConfig = itrConfig <$> getInteraction - --- |Get the 'SockAddr' of the remote host. If you want a string --- representation instead of 'SockAddr', use 'getRemoteAddr''. -getRemoteAddr ∷ Resource SockAddr -getRemoteAddr = itrRemoteAddr <$> getInteraction - -- |Get the string representation of the address of remote host. If --- you want a 'SockAddr' instead of 'String', use 'getRemoteAddr'. +-- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'. getRemoteAddr' ∷ Resource HostName getRemoteAddr' - = do sa ← getRemoteAddr - (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] True False sa - return a + = do sa ← getRemoteAddr + (fromJust ∘ fst) <$> (liftIO $ getNameInfo [NI_NUMERICHOST] True False sa) -- |Resolve an address to the remote host. getRemoteHost ∷ Resource (Maybe HostName) @@ -197,18 +188,6 @@ getRemoteHost = do sa ← getRemoteAddr fst <$> (liftIO $ getNameInfo [] True False sa) --- | Return the X.509 certificate of the client, or 'Nothing' if: --- --- * This request didn't came through an SSL stream. --- --- * The client didn't send us its certificate. --- --- * The 'OpenSSL.Session.VerificationMode' of --- 'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to --- 'OpenSSL.Session.VerifyPeer'. -getRemoteCertificate ∷ Resource (Maybe X509) -getRemoteCertificate = itrRemoteCert <$> getInteraction - -- |Get the 'Method' value of the request. getMethod ∷ Resource Method getMethod = reqMethod <$> getRequest @@ -221,33 +200,8 @@ getRequestURI = reqURI <$> getRequest getRequestVersion ∷ Resource HttpVersion getRequestVersion = reqVersion <$> getRequest --- |Get the path of this 'Resource' (to be exact, --- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the --- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this --- action is the exact path in the tree even when the --- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy. --- --- Example: --- --- > main = let tree = mkResTree [ (["foo"], resFoo) ] --- > in runHttpd defaultConfig tree --- > --- > resFoo = ResourceDef { --- > resIsGreedy = True --- > , resGet = Just $ do requestURI <- getRequestURI --- > resourcePath <- getResourcePath --- > pathInfo <- getPathInfo --- > -- uriPath requestURI == "/foo/bar/baz" --- > -- resourcePath == ["foo"] --- > -- pathInfo == ["bar", "baz"] --- > ... --- > , ... --- > } -getResourcePath ∷ Resource [Text] -getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction - --- |This is an analogy of CGI PATH_INFO. The result is --- URI-unescaped. It is always @[]@ if the +-- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns +-- @[]@ if the corresponding -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See -- 'getResourcePath'. -- @@ -263,9 +217,9 @@ getPathInfo = do rsrcPath ← getResourcePath return $ drop (length rsrcPath) reqPath -- |Assume the query part of request URI as --- application\/x-www-form-urlencoded, and parse it to pairs of --- @(name, formData)@. This action doesn't parse the request body. See --- 'inputForm'. Field names are decoded in UTF-8. +-- application\/x-www-form-urlencoded, and parse it into pairs of +-- @(name, formData)@. This function doesn't read the request +-- body. Field names are decoded in UTF-8. See 'getForm'. getQueryForm ∷ Resource [(Text, FormData)] getQueryForm = parse' <$> getRequestURI where @@ -284,15 +238,16 @@ toPairWithFormData (name, value) } in (T.decodeUtf8 name, fd) --- |Get a value of given request 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 'getContentType' for --- every common headers. +-- |@'getHeader' name@ returns the value of the request header field +-- @name@. Comparison of header name is case-insensitive. Note that +-- this function is not intended to be used so frequently: there +-- should be actions like 'getContentType' for every common headers. getHeader ∷ CIAscii → Resource (Maybe Ascii) getHeader name = H.getHeader name <$> getRequest --- |Get a list of 'MIMEType' enumerated on header \"Accept\". +-- |Return the list of 'MIMEType' enumerated on the value of request +-- header \"Accept\", or @[]@ if absent. getAccept ∷ Resource [MIMEType] getAccept = do acceptM ← getHeader "Accept" @@ -309,9 +264,9 @@ getAccept P.endOfInput return xs --- |Get a list of @(contentCoding, qvalue)@ enumerated on header --- \"Accept-Encoding\". The list is sorted in descending order by --- qvalue. +-- |Return the list of @(contentCoding, qvalue)@ enumerated on the +-- value of request header \"Accept-Encoding\". The list is sorted in +-- descending order by qvalue. getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)] getAcceptEncoding = do accEncM ← getHeader "Accept-Encoding" @@ -331,11 +286,11 @@ getAcceptEncoding → if ae ≡ "" then -- identity のみが許される。 return [("identity", Nothing)] - 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) + 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) where p = do xs ← acceptEncodingListP P.endOfInput @@ -344,14 +299,14 @@ getAcceptEncoding toTuple (AcceptEncoding {..}) = (aeEncoding, aeQValue) --- |Check whether a given content-coding is acceptable. +-- |Return 'True' iff a given content-coding is acceptable. isEncodingAcceptable ∷ CIAscii → Resource Bool -isEncodingAcceptable encoding = any f <$> getAcceptEncoding +isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding where - f (e, q) - = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0 + doesMatch ∷ (CIAscii, Maybe Double) → Bool + doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0 --- |Get the header \"Content-Type\" as 'MIMEType'. +-- |Return the value of request header \"Content-Type\" as 'MIMEType'. getContentType ∷ Resource (Maybe MIMEType) getContentType = do cTypeM ← getHeader "Content-Type" @@ -368,7 +323,8 @@ getContentType P.endOfInput return t --- |Get the header \"Authorization\" as 'AuthCredential'. +-- |Return the value of request header \"Authorization\" as +-- 'AuthCredential'. getAuthorization ∷ Resource (Maybe AuthCredential) getAuthorization = do authM ← getHeader "Authorization" @@ -384,56 +340,53 @@ getAuthorization P.endOfInput return ac - --- Finding an entity - -- |Tell the system that the 'Resource' found an entity for the -- request URI. If this is a GET or HEAD request, a found entity means -- a datum to be replied. If this is a PUT or DELETE request, it means --- a datum which was stored for the URI until now. It is an error to --- compute 'foundEntity' if this is a POST request. +-- a datum which was stored for the URI until now. For POST requests +-- it raises an error. -- --- Computation of 'foundEntity' performs \"If-Match\" test or --- \"If-None-Match\" test if possible. When those tests fail, the --- computation of 'Resource' immediately aborts with status \"412 --- Precondition Failed\" or \"304 Not Modified\" depending on the --- situation. +-- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test +-- whenever possible, and if those tests fail, it immediately aborts +-- with status \"412 Precondition Failed\" or \"304 Not Modified\" +-- depending on the situation. -- --- If this is a GET or HEAD request, 'foundEntity' automatically puts --- \"ETag\" and \"Last-Modified\" headers into the response. +-- If the request method is either GET or HEAD, 'foundEntity' +-- automatically puts \"ETag\" and \"Last-Modified\" headers into the +-- response. foundEntity ∷ ETag → UTCTime → Resource () foundEntity tag timeStamp = do driftTo ExaminingRequest method ← getMethod when (method ≡ GET ∨ method ≡ HEAD) - $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp) + $ setHeader "Last-Modified" (HTTP.toAscii timeStamp) when (method ≡ POST) $ abort InternalServerError [] - (Just "Illegal computation of foundEntity for a POST request.") + (Just "foundEntity: this is a POST request.") foundETag tag - driftTo GettingBody + driftTo ReceivingBody -- |Tell the system that the 'Resource' found an entity for the -- request URI. The only difference from 'foundEntity' is that --- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into +-- 'foundETag' doesn't (nor can't) put \"Last-Modified\" header into -- the response. -- --- This action is not preferred. You should use 'foundEntity' whenever --- possible. +-- Using this function is discouraged. You should use 'foundEntity' +-- whenever possible. foundETag ∷ ETag → Resource () foundETag tag = do driftTo ExaminingRequest method ← getMethod when (method ≡ GET ∨ method ≡ HEAD) - $ setHeader' "ETag" - $ A.fromAsciiBuilder - $ printETag tag + $ setHeader "ETag" + $ A.fromAsciiBuilder + $ printETag tag when (method ≡ POST) - $ abort InternalServerError [] - (Just "Illegal computation of foundETag for POST request.") + $ abort InternalServerError [] + $ Just "Illegal computation of foundETag for POST request." -- If-Match があればそれを見る。 ifMatch ← getHeader "If-Match" @@ -444,13 +397,16 @@ foundETag tag else case P.parseOnly p (A.toByteString value) of Right tags - -- tags の中に一致するものが無ければ - -- PreconditionFailed で終了。 - → when ((¬) (any (≡ tag) tags)) - $ abort PreconditionFailed [] - (Just $ "The entity tag doesn't match: " ⊕ A.toText value) + -- tags の中に一致するものが無ければ + -- PreconditionFailed で終了。 + → when ((¬) (any (≡ tag) tags)) + $ abort PreconditionFailed [] + $ Just + $ "The entity tag doesn't match: " ⊕ A.toText value Left _ - → abort BadRequest [] (Just $ "Unparsable If-Match: " ⊕ A.toText value) + → abort BadRequest [] + $ Just + $ "Unparsable If-Match: " ⊕ A.toText value let statusForNoneMatch = if method ≡ GET ∨ method ≡ HEAD then @@ -463,18 +419,20 @@ foundETag tag case ifNoneMatch of Nothing → return () Just value → if value ≡ "*" then - abort statusForNoneMatch [] (Just "The entity tag matches: *") - else - case P.parseOnly p (A.toByteString value) of - Right tags - → when (any (≡ tag) tags) - $ abort statusForNoneMatch [] - (Just $ "The entity tag matches: " ⊕ A.toText value) - Left _ - → abort BadRequest [] - (Just $ "Unparsable If-None-Match: " ⊕ A.toText value) - - driftTo GettingBody + abort statusForNoneMatch [] (Just "The entity tag matches: *") + else + case P.parseOnly p (A.toByteString value) of + Right tags + → when (any (≡ tag) tags) + $ abort statusForNoneMatch [] + $ Just + $ "The entity tag matches: " ⊕ A.toText value + Left _ + → abort BadRequest [] + $ Just + $ "Unparsable If-None-Match: " ⊕ A.toText value + + driftTo ReceivingBody where p = do xs ← eTagListP P.endOfInput @@ -484,19 +442,19 @@ foundETag tag -- request URI. The only difference from 'foundEntity' is that -- 'foundTimeStamp' performs \"If-Modified-Since\" test or -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or --- \"If-None-Match\" test. Be aware that any tests based on last +-- \"If-None-Match\" test. Be aware that any tests based on a last -- modification time are unsafe because it is possible to mess up such -- tests by modifying the entity twice in a second. -- --- This action is not preferred. You should use 'foundEntity' whenever --- possible. +-- Using this function is discouraged. You should use 'foundEntity' +-- whenever possible. foundTimeStamp ∷ UTCTime → Resource () foundTimeStamp timeStamp = do driftTo ExaminingRequest method ← getMethod when (method ≡ GET ∨ method ≡ HEAD) - $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp) + $ setHeader "Last-Modified" (HTTP.toAscii timeStamp) when (method ≡ POST) $ abort InternalServerError [] (Just "Illegal computation of foundTimeStamp for POST request.") @@ -531,15 +489,15 @@ foundTimeStamp timeStamp → return () -- 不正な時刻は無視 Nothing → return () - driftTo GettingBody + driftTo ReceivingBody --- | Computation of @'foundNoEntity' mStr@ tells the system that the --- 'Resource' found no entity for the request URI. @mStr@ is an --- optional error message to be replied to the client. +-- |@'foundNoEntity' mStr@ tells the system that the 'Resource' found +-- no entity for the request URI. @mStr@ is an optional error message +-- to be replied to the client. -- --- If this is a PUT request, 'foundNoEntity' performs \"If-Match\" --- test and aborts with status \"412 Precondition Failed\" when it --- failed. If this is a GET, HEAD, POST or DELETE request, +-- If the request method is PUT, 'foundNoEntity' performs \"If-Match\" +-- test and when that fails it aborts with status \"412 Precondition +-- Failed\". If the request method is GET, HEAD, POST or DELETE, -- 'foundNoEntity' always aborts with status \"404 Not Found\". foundNoEntity ∷ Maybe Text → Resource () foundNoEntity msgM @@ -555,149 +513,62 @@ foundNoEntity msgM when (ifMatch ≢ Nothing) $ abort PreconditionFailed [] msgM - driftTo GettingBody + driftTo ReceivingBody --- Getting a request body - --- | Computation of @'input' limit@ attempts to read the request body --- up to @limit@ bytes, and then make the 'Resource' transit to --- /Deciding Header/ state. When the actual size of body is larger --- than @limit@ bytes, computation of 'Resource' immediately aborts --- with status \"413 Request Entity Too Large\". When the request has --- no body, 'input' returns an empty string. +-- |@'getChunks' limit@ attemts to read the entire request body up to +-- @limit@ bytes, and then make the 'Resource' transit to the +-- /Deciding Header/ state. When the actual size of the body is larger +-- than @limit@ bytes, 'getChunks' immediately aborts with status +-- \"413 Request Entity Too Large\". When the request has no body, it +-- returns an empty string. -- --- @limit@ may be less than or equal to zero. In this case, the --- default limitation value ('cnfMaxEntityLength') is used. See --- 'defaultLimit'. +-- When the @limit@ is 'Nothing', 'getChunks' uses the default +-- limitation value ('cnfMaxEntityLength') instead. -- --- 'input' returns a 'Lazy.ByteString' but it's not really lazy: --- reading from the socket just happens at the computation of 'input', --- not at the evaluation of the 'Lazy.ByteString'. The same goes for --- 'inputChunk'. -input ∷ Int → Resource Lazy.ByteString -input limit - = do driftTo GettingBody - itr ← getInteraction - chunk ← if reqMustHaveBody $ fromJust $ itrRequest itr then - askForInput itr - else - do driftTo DecidingHeader - return (∅) - return chunk +-- 'getChunks' returns a 'Lazy.ByteString' but it's not really lazy: +-- reading from the socket just happens at the computation of +-- 'getChunks', not at the evaluation of the 'Lazy.ByteString'. +getChunks ∷ Maybe Int → Resource Lazy.ByteString +getChunks (Just n) + | n < 0 = fail ("getChunks: limit must not be negative: " ⧺ show n) + | n ≡ 0 = return (∅) + | otherwise = getChunks' n +getChunks Nothing + = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength + +getChunks' ∷ Int → Resource Lazy.ByteString +getChunks' limit = go limit (∅) where - askForInput ∷ Interaction → Resource Lazy.ByteString - askForInput (Interaction {..}) - = do let confLimit = cnfMaxEntityLength itrConfig - actualLimit = if limit ≤ 0 then - confLimit - else - limit - when (actualLimit ≤ 0) - $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit) - -- Reader にリクエスト - liftIO $ atomically - $ writeTVar itrReqBodyWanted actualLimit - -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。 - chunk ← liftIO $ atomically - $ do chunkLen ← readTVar itrReceivedBodyLen - chunkIsOver ← readTVar itrReqChunkIsOver - if chunkLen < actualLimit then - -- 要求された量に滿たなくて、まだ殘りが - -- あるなら再試行。 - unless chunkIsOver - $ retry - else - -- 制限値一杯まで讀むやうに指示したのに - -- まだ殘ってゐるなら、それは多過ぎる。 - unless chunkIsOver - $ tooLarge actualLimit - -- 成功。itr 内にチャンクを置いたままにする - -- とメモリの無駄になるので除去。 - chunk ← seqToLBS <$> readTVar itrReceivedBody - writeTVar itrReceivedBody (∅) - writeTVar itrReceivedBodyLen 0 - return chunk - - driftTo DecidingHeader - return chunk - - tooLarge ∷ Int → STM () - tooLarge lim = abortSTM RequestEntityTooLarge [] - (Just $ "Request body must be smaller than " - ⊕ T.pack (show lim) ⊕ " bytes.") - -seqToLBS ∷ Seq ByteString → Lazy.ByteString -{-# INLINE seqToLBS #-} -seqToLBS = Lazy.fromChunks ∘ toList - --- | Computation of @'inputChunk' limit@ attempts to read a part of --- request body up to @limit@ bytes. You can read any large request by --- repeating computation of this action. When you've read all the --- request body, 'inputChunk' returns an empty string and then make --- the 'Resource' transit to /Deciding Header/ state. --- --- @limit@ may be less than or equal to zero. In this case, the --- default limitation value ('cnfMaxEntityLength') is used. See --- 'defaultLimit'. --- --- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you --- should use it whenever possible. -inputChunk ∷ Int → Resource Lazy.ByteString -inputChunk limit - = do driftTo GettingBody - itr ← getInteraction - chunk ← if reqMustHaveBody $ fromJust $ itrRequest itr then - askForInput itr + 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 + chunk ← getChunk n' + if Strict.null chunk then + -- Got EOF + return $ Lazy.fromChunks $ toList xs else - do driftTo DecidingHeader - return (∅) - return chunk - where - askForInput ∷ Interaction → Resource Lazy.ByteString - askForInput (Interaction {..}) - = do let confLimit = cnfMaxEntityLength itrConfig - actualLimit = if limit < 0 then - confLimit - else - limit - when (actualLimit ≤ 0) - $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit) - -- Reader にリクエスト - liftIO $ atomically - $ writeTVar itrReqBodyWanted actualLimit - -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 - chunk ← liftIO $ atomically - $ do chunkLen ← readTVar itrReceivedBodyLen - -- 要求された量に滿たなくて、まだ殘りがある - -- なら再試行。 - when (chunkLen < actualLimit) - $ do chunkIsOver ← readTVar itrReqChunkIsOver - unless chunkIsOver - $ retry - -- 成功 - chunk ← seqToLBS <$> readTVar itrReceivedBody - writeTVar itrReceivedBody (∅) - writeTVar itrReceivedBodyLen 0 - return chunk - when (Lazy.null chunk) - $ driftTo DecidingHeader - return chunk - --- | Computation of @'inputForm' limit@ attempts to read the request --- body with 'input' and parse it as --- @application\/x-www-form-urlencoded@ or @multipart\/form-data@. If --- the request header \"Content-Type\" is neither of them, 'inputForm' --- makes 'Resource' abort with status \"415 Unsupported Media --- Type\". If the request has no \"Content-Type\", it aborts with --- \"400 Bad Request\". + do let n'' = n' - Strict.length chunk + xs' = xs ⊳ chunk + go n'' xs' + +-- |@'getForm' limit@ attempts to read the request body with +-- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or +-- @multipart\/form-data@. If the request header \"Content-Type\" is +-- neither of them, 'getForm' aborts with status \"415 Unsupported +-- Media Type\". If the request has no \"Content-Type\", it aborts +-- with \"400 Bad Request\". -- -- Field names in @multipart\/form-data@ will be precisely decoded in -- accordance with RFC 2231. On the other hand, -- @application\/x-www-form-urlencoded@ says nothing about the --- encoding of field names, so they'll always be decoded in UTF-8. -inputForm ∷ Int → Resource [(Text, FormData)] -inputForm limit +-- encoding of field names, so they'll always be decoded in +-- UTF-8. (This could be a bad design, but I can't think of any better +-- idea.) +getForm ∷ Maybe Int → Resource [(Text, FormData)] +getForm limit = do cTypeM ← getContentType case cTypeM of Nothing @@ -717,7 +588,7 @@ inputForm limit readWWWFormURLEncoded = (map toPairWithFormData ∘ parseWWWFormURLEncoded) <$> - (bsToAscii =≪ input limit) + (bsToAscii =≪ getChunks limit) bsToAscii bs = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of @@ -729,7 +600,7 @@ inputForm limit Nothing → abort BadRequest [] (Just "Missing boundary of multipart/form-data") Just boundary - → do src ← input limit + → do src ← getChunks limit b ← case A.fromText boundary of Just b → return b Nothing → abort BadRequest [] @@ -743,18 +614,9 @@ inputForm limit P.endOfInput return xs --- | This is just a constant @-1@. It's better to say @'input' --- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly --- the same. -defaultLimit ∷ Int -defaultLimit = (-1) - - --- Setting response headers - --- | 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. +-- |@'redirect' code uri@ declares the response status as @code@ and +-- \"Location\" header field as @uri@. The @code@ must satisfy +-- 'isRedirection' or it raises an error. redirect ∷ StatusCode → URI → Resource () redirect code uri = do when (code ≡ NotModified ∨ not (isRedirection code)) @@ -767,15 +629,15 @@ redirect code uri setStatus code setLocation uri --- | Computation of @'setContentType' mType@ sets the response header --- \"Content-Type\" to @mType@. +-- |@'setContentType' mType@ declares the response header +-- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is +-- mandatory for sending a response body. setContentType ∷ MIMEType → Resource () setContentType = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType --- | Computation of @'setLocation' uri@ sets the response header --- \"Location\" to @uri@. You usually don't need to call this function --- directly. +-- |@'setLocation' uri@ declares the response header \"Location\" as +-- @uri@. You usually don't need to call this function directly. setLocation ∷ URI → Resource () setLocation uri = case A.fromChars uriStr of @@ -785,8 +647,8 @@ setLocation uri where uriStr = uriToString id uri "" --- |Computation of @'setContentEncoding' codings@ sets the response --- header \"Content-Encoding\" to @codings@. +-- |@'setContentEncoding' codings@ declares the response header +-- \"Content-Encoding\" as @codings@. setContentEncoding ∷ [CIAscii] → Resource () setContentEncoding codings = do ver ← getRequestVersion @@ -800,20 +662,23 @@ setContentEncoding codings where toAB = A.toAsciiBuilder ∘ A.fromCIAscii --- |Computation of @'setWWWAuthenticate' challenge@ sets the response --- header \"WWW-Authenticate\" to @challenge@. +-- |@'setWWWAuthenticate' challenge@ declares the response header +-- \"WWW-Authenticate\" as @challenge@. setWWWAuthenticate ∷ AuthChallenge → Resource () -setWWWAuthenticate challenge - = setHeader "WWW-Authenticate" (printAuthChallenge challenge) - +setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge --- Writing a response body +-- |Write a chunk in 'Strict.ByteString' to the response body. You +-- must first declare the response header \"Content-Type\" before +-- applying this function. See 'setContentType'. +putChunk ∷ Strict.ByteString → Resource () +putChunk = putBuilder ∘ BB.fromByteString --- | Write a chunk in 'Lazy.ByteString' to the response body. It is +-- |Write a chunk in 'Lazy.ByteString' to the response body. It is -- safe to apply this function to an infinitely long -- 'Lazy.ByteString'. -- --- Note that you must first set the response header \"Content-Type\" --- before applying this function. See: 'setContentType' -putChunk ∷ Lazy.ByteString → Resource () -putChunk = putBuilder ∘ BB.fromLazyByteString +-- Note that you must first declare the response header +-- \"Content-Type\" before applying this function. See +-- 'setContentType'. +putChunks ∷ Lazy.ByteString → Resource () +putChunks = putBuilder ∘ BB.fromLazyByteString diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs index d68b334..418a330 100644 --- a/Network/HTTP/Lucu/Resource/Internal.hs +++ b/Network/HTTP/Lucu/Resource/Internal.hs @@ -11,12 +11,16 @@ module Network.HTTP.Lucu.Resource.Internal , emptyResource , spawnResource - , getInteraction + , getConfig + , getRemoteAddr + , getRemoteCertificate , getRequest + , getResourcePath + + , getChunk , setStatus , setHeader - , setHeader' , deleteHeader , putBuilder @@ -33,9 +37,11 @@ import Control.Monad.IO.Class import Control.Monad.Reader import Data.Ascii (Ascii, CIAscii) import qualified Data.Ascii as A +import qualified Data.ByteString as Strict import Data.List import Data.Maybe import Data.Monoid.Unicode +import Data.Text (Text) import qualified Data.Text as T import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Config @@ -46,6 +52,8 @@ import Network.HTTP.Lucu.Postprocess import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.Utils +import Network.Socket +import OpenSSL.X509 import Prelude hiding (catch) import Prelude.Unicode import System.IO @@ -61,7 +69,7 @@ newtype Resource a runResource ∷ Resource a → Interaction → IO a runResource = runReaderT ∘ unResource --- | 'ResourceDef' is basically a set of 'Resource' monads for each +-- |'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 @@ -77,7 +85,7 @@ data ResourceDef = ResourceDef { -- 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 + -- |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. -- @@ -85,20 +93,20 @@ data ResourceDef = ResourceDef { -- 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 + -- |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 + -- |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 + -- |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 + -- |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 ())) @@ -186,12 +194,11 @@ spawnResource (ResourceDef {..}) itr@(Interaction {..}) processException ∷ SomeException → IO () processException exc = do let abo = toAbortion exc - -- まだ DecidingHeader 以前の状態だったら、この途中終了 - -- を應答に反映させる餘地がある。さうでなければ stderr - -- にでも吐くしか無い。 state ← atomically $ readTVar itrState res ← atomically $ readTVar itrResponse if state ≤ DecidingHeader then + -- We still have a chance to reflect this abortion + -- in the response. Hooray! flip runResource itr $ do setStatus $ aboStatus abo setHeader "Content-Type" defaultPageContentType @@ -207,30 +214,108 @@ dumpAbortion ∷ Abortion → IO () dumpAbortion abo = hPutStr stderr $ concat [ "Lucu: an exception occured after " - , "sending response header to the client:\n" + , "sending the 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. +-- |Get the 'Config' value for this httpd. +getConfig ∷ Resource Config +getConfig = itrConfig <$> getInteraction + +-- |Get the 'SockAddr' of the remote host. +getRemoteAddr ∷ Resource SockAddr +getRemoteAddr = itrRemoteAddr <$> getInteraction + +-- | Return the X.509 certificate of the client, or 'Nothing' if: +-- +-- * This request didn't came through an SSL stream. +-- +-- * The client didn't send us its certificate. +-- +-- * The 'OpenSSL.Session.VerificationMode' of +-- 'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to +-- 'OpenSSL.Session.VerifyPeer'. +getRemoteCertificate ∷ Resource (Maybe X509) +getRemoteCertificate = itrRemoteCert <$> 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 --- | Set the response status code. If you don't call this function, +-- |Get the path of this 'Resource' (to be exact, 'ResourceDef') in +-- the 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this +-- action is the exact path in the tree even when the 'ResourceDef' is +-- greedy. +-- +-- Example: +-- +-- > main = let tree = mkResTree [ (["foo"], resFoo) ] +-- > in runHttpd defaultConfig tree [] +-- > +-- > resFoo = ResourceDef { +-- > resIsGreedy = True +-- > , resGet = Just $ do requestURI <- getRequestURI +-- > resourcePath <- getResourcePath +-- > pathInfo <- getPathInfo +-- > -- uriPath requestURI == "/foo/bar/baz" +-- > -- resourcePath == ["foo"] +-- > -- pathInfo == ["bar", "baz"] +-- > ... +-- > , ... +-- > } +getResourcePath ∷ Resource [Text] +getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction + +-- |@'getChunk' n@ attempts to read a chunk of request body up to @n@ +-- bytes. You can incrementally read the request body by repeatedly +-- calling this function. If there is nothing to be read anymore, +-- 'getChunk' returns 'Strict.empty' and makes 'Resource' transit to +-- the /Deciding Header/ state. +getChunk ∷ Int → Resource Strict.ByteString +getChunk = (driftTo ReceivingBody *>) ∘ getChunk' + +getChunk' ∷ Int → Resource Strict.ByteString +getChunk' n + | n < 0 = fail ("getChunk: n must not be negative: " ⧺ show n) + | n ≡ 0 = return (∅) + | otherwise = do req ← getRequest + if reqMustHaveBody req then + do itr ← getInteraction + askForInput itr + else + driftTo DecidingHeader *> return (∅) + where + askForInput ∷ Interaction → Resource Strict.ByteString + askForInput (Interaction {..}) + = do -- Ask the RequestReader to get a chunk. + liftIO $ atomically + $ putTMVar itrReceiveBodyReq (ReceiveBody n) + -- Then wait for a reply. + chunk ← liftIO + $ atomically + $ takeTMVar itrReceivedBody + -- Have we got an EOF? + when (Strict.null chunk) + $ driftTo DecidingHeader + return chunk + +-- |Declare 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 + = do itr ← getInteraction + liftIO $ atomically + $ do state ← readTVar $ itrState itr + when (state > DecidingHeader) + $ fail "Too late to declare the response status." + setResponseStatus itr sc + +-- |@'setHeader' name value@ declares the value of the response header +-- @name@ as @value@. Note that this function is not intended to be -- used so frequently: there should be specialised functions like -- 'setContentType' for every common headers. -- @@ -246,45 +331,44 @@ setStatus sc -- 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 + $ 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 --- | @'deleteHeader' name@ deletes a response header @name@ if +-- |@'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 + $ 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 --- | 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. +-- |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' +-- Note that you must first declare 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 + $ do driftTo' itr SendingBody hasCType ← readTVar $ itrResponseHasCType itr unless hasCType $ abortSTM InternalServerError [] @@ -299,25 +383,29 @@ driftTo 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 + driftFrom oldState where + driftFrom ∷ InteractionState → STM () + driftFrom oldState + | newState < oldState = throwStateError oldState newState + | newState ≡ oldState = return () + | otherwise + = do let a = [oldState .. newState] + b = tail a + c = zip a b + mapM_ (uncurry driftFromTo) c + writeTVar itrState newState + throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a - throwStateError Done DecidingBody + throwStateError Done SendingBody = fail "It makes no sense to output something after finishing outputs." throwStateError old new - = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new) + = fail ("State error: " ⧺ show old ⧺ " ==> " ⧺ show new) - drift ∷ InteractionState → InteractionState → STM () - drift GettingBody _ - = putTMVar itrGetBodyRequest WasteAll - drift DecidingHeader _ + driftFromTo ∷ InteractionState → InteractionState → STM () + driftFromTo ReceivingBody _ + = putTMVar itrReceiveBodyReq WasteAll + driftFromTo DecidingHeader _ = postprocess itr - drift _ _ + driftFromTo _ _ = return () diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 1106f14..d13dd84 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -98,10 +98,10 @@ awaitSomethingToWriteOn ctx itr phase = join $ atomically $ do state ← readTVar $ itrState itr - if state ≡ GettingBody then + if state ≡ ReceivingBody then writeContinueIfNeeded ctx itr phase else - if state ≥ DecidingBody then + if state ≥ SendingBody then writeHeaderOrBodyIfNeeded ctx itr phase else retry @@ -113,7 +113,7 @@ writeContinueIfNeeded ∷ HandleLike h → STM (IO ()) writeContinueIfNeeded ctx itr@(Interaction {..}) phase | phase ≡ Initial ∧ itrExpectedContinue ≡ Just True - = do isRequested ← isEmptyTMVar itrGetBodyRequest + = do isRequested ← isEmptyTMVar itrReceiveBodyReq if isRequested then return $ writeContinue ctx itr else