X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=eed224f11bd797f68ed2517d56dd465b4183f64f;hp=696abf1b1311e55c5f13f4eca54a45ea02ea0146;hb=7843dbf537dfefa583a8ee55b2a31a5e8a9c7c37;hpb=1f0a19cbad7c4b64a773d7f1c1ae9180448624e6 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