X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=704feda9c79ca2e5ab4619b1550166bdd8023f4c;hp=298b9b2541edd0f4d3d8b170bccb6cc9965bfe4e;hb=b1fac0a2cb1cafa008c0efa8ae4e14afbee0927f;hpb=ca338174155913a969808d7b20193973394e474e diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 298b9b2..704feda 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,16 +1,15 @@ {-# LANGUAGE - GeneralizedNewtypeDeriving + BangPatterns + , GeneralizedNewtypeDeriving , DoAndIfThenElse , OverloadedStrings + , QuasiQuotes , 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 --- 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: -- @@ -19,9 +18,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 @@ -31,29 +30,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 the 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 +-- 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. +-- [/Deciding Header/] A 'Resource' makes a decision of response +-- status code and header fields. When it transits to the next +-- state, the system validates and completes the 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. @@ -64,20 +67,17 @@ -- 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 + , ResourceDef(..) + , emptyResource , FormData(..) - , runRes -- private - - -- * Actions - - -- ** Getting request header - -- |These actions can be computed regardless of the current state, - -- and they don't change the state. + -- * Getting request header + -- |These functions can be called regardless of the current state, + -- and they don't change the state of 'Resource'. , getConfig , getRemoteAddr , getRemoteAddr' @@ -97,146 +97,106 @@ module Network.HTTP.Lucu.Resource , getContentType , 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. + -- * Finding an entity + -- |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/. - , input - , inputChunk - , inputForm - , defaultLimit - - -- ** Setting response headers - - -- |Computation of these actions changes the state to /Deciding - -- Header/. + , foundNoEntity' + + -- * Receiving a request body + -- |These functions make the 'Resource' transit to the /Receiving + -- Body/ state. + , getChunk + , getChunks + , getForm + + -- * 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 - , setHeader , redirect , setContentType - , setLocation , setContentEncoding , setWWWAuthenticate - -- ** Writing a response body + -- ** Less frequently used functions + , setLocation + , setHeader + , deleteHeader - -- |Computation of these actions changes the state to /Deciding - -- Body/. - , output - , outputChunk + -- * Sending a response body - , driftTo -- private + -- |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 qualified Blaze.ByteString.Builder as BB +import qualified Blaze.ByteString.Builder.Internal as BB import Control.Applicative -import Control.Concurrent.STM -import Control.Monad.Reader +import Control.Arrow +import Control.Monad +import Control.Monad.IO.Class import Control.Monad.Unicode import Data.Ascii (Ascii, CIAscii) import qualified Data.Ascii as A import qualified Data.Attoparsec.Char8 as P -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 Data.Foldable (toList) import Data.List import qualified Data.Map as M import Data.Maybe import Data.Monoid import Data.Monoid.Unicode -import Data.Sequence (Seq) import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.Encoding as T import Data.Time import qualified Data.Time.HTTP as HTTP import Network.HTTP.Lucu.Abortion -import Network.HTTP.Lucu.Authorization +import Network.HTTP.Lucu.Authentication import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.ContentCoding -import Network.HTTP.Lucu.DefaultPage import Network.HTTP.Lucu.ETag 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.Parser 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.MIMEParams +import Network.HTTP.Lucu.MIMEType (MIMEType(..)) +import qualified Network.HTTP.Lucu.MIMEType as MT +import Network.HTTP.Lucu.MIMEType.TH import Network.HTTP.Lucu.Utils import Network.Socket hiding (accept) 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 - --- |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] False False sa - return a +getRemoteAddr' = liftIO ∘ toNM =≪ getRemoteAddr + where + toNM ∷ SockAddr → IO HostName + toNM = (fromJust ∘ fst <$>) ∘ getNameInfo [NI_NUMERICHOST] True False -- |Resolve an address to the remote host. getRemoteHost ∷ Resource (Maybe HostName) -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 'Request' value which represents the request header. In --- general you don't have to use this action. -getRequest ∷ Resource Request -getRequest = (fromJust ∘ itrRequest) <$> getInteraction +getRemoteHost = liftIO ∘ getHN =≪ getRemoteAddr + where + getHN ∷ SockAddr → IO (Maybe HostName) + getHN = (fst <$>) ∘ getNameInfo [] True False -- |Get the 'Method' value of the request. getMethod ∷ Resource Method @@ -250,52 +210,22 @@ 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 if the --- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy. +-- |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' -- --- 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 --- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See --- 'getResourcePath'. --- --- Note that the returned path is URI-decoded and then UTF-8 decoded. -getPathInfo ∷ Resource [Text] +-- Note that the returned path components are URI-decoded. +getPathInfo ∷ Resource [Strict.ByteString] getPathInfo = do rsrcPath ← getResourcePath reqPath ← splitPathInfo <$> getRequestURI - -- rsrcPath と reqPath の共通する先頭部分を reqPath か - -- ら全部取り除くと、それは PATH_INFO のやうなものにな - -- る。rsrcPath は全部一致してゐるに決まってゐる（でな - -- ければこの Resource が撰ばれた筈が無い）ので、 - -- rsrcPath の長さの分だけ削除すれば良い。 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. -getQueryForm ∷ Resource [(Text, FormData)] +-- application\/x-www-form-urlencoded, and parse it into pairs of +-- @(name, formData)@. This function doesn't read the request +-- body. +getQueryForm ∷ Resource [(Strict.ByteString, FormData)] getQueryForm = parse' <$> getRequestURI where parse' = map toPairWithFormData ∘ @@ -305,23 +235,25 @@ getQueryForm = parse' <$> getRequestURI drop 1 ∘ uriQuery -toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData) +toPairWithFormData ∷ (ByteString, ByteString) → (Strict.ByteString, FormData) toPairWithFormData (name, value) = let fd = FormData { fdFileName = Nothing + , fdMIMEType = [mimeType| text/plain |] , fdContent = Lazy.fromChunks [value] } - in (T.decodeUtf8 name, fd) + in (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 functions 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" @@ -329,18 +261,14 @@ getAccept Nothing → return [] Just accept - → case P.parseOnly p (A.toByteString accept) of + → case P.parseOnly (finishOff MT.mimeTypeList) (A.toByteString accept) of Right xs → return xs - Left _ → abort BadRequest [] - (Just $ "Unparsable Accept: " ⊕ A.toText accept) - where - p = do xs ← mimeTypeListP - P.endOfInput - return xs + Left _ → abort $ mkAbortion' BadRequest + $ "Unparsable Accept: " ⊕ A.toText accept --- |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" @@ -354,33 +282,30 @@ getAcceptEncoding case ver of HttpVersion 1 0 → return [("identity", Nothing)] HttpVersion 1 1 → return [("*" , Nothing)] - _ → abort InternalServerError [] - (Just "getAcceptEncoding: unknown HTTP version") + _ → abort $ mkAbortion' InternalServerError + "getAcceptEncoding: unknown HTTP version" Just ae → if ae ≡ "" then -- identity のみが許される。 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 (finishOff acceptEncodingList) (A.toByteString ae) of + Right xs → return $ map toTuple $ reverse $ sort xs + Left _ → abort $ mkAbortion' BadRequest + $ "Unparsable Accept-Encoding: " ⊕ A.toText ae where - p = do xs ← acceptEncodingListP - P.endOfInput - return xs - toTuple (AcceptEncoding {..}) = (aeEncoding, aeQValue) --- |Check whether a given content-coding is acceptable. +-- |Return 'True' iff a given content-coding is acceptable by the +-- client. 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" @@ -388,16 +313,13 @@ getContentType Nothing → return Nothing Just cType - → case P.parseOnly p (A.toByteString cType) of + → case P.parseOnly (finishOff MT.mimeType) (A.toByteString cType) of Right t → return $ Just t - Left _ → abort BadRequest [] - (Just $ "Unparsable Content-Type: " ⊕ A.toText cType) - where - p = do t ← mimeTypeP - P.endOfInput - return t + Left _ → abort $ mkAbortion' BadRequest + $ "Unparsable Content-Type: " ⊕ A.toText cType --- |Get the header \"Authorization\" as 'AuthCredential'. +-- |Return the value of request header \"Authorization\" as +-- 'AuthCredential'. getAuthorization ∷ Resource (Maybe AuthCredential) getAuthorization = do authM ← getHeader "Authorization" @@ -405,79 +327,80 @@ getAuthorization Nothing → return Nothing Just auth - → case P.parseOnly p (A.toByteString auth) of + → case P.parseOnly (finishOff authCredential) (A.toByteString auth) of Right ac → return $ Just ac Left _ → return Nothing - where - p = do ac ← authCredentialP - P.endOfInput - return ac - - -{- ExaminingRequest 時に使用するアクション群 -} -- |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.") + $ abort + $ mkAbortion' InternalServerError + "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" (printETag tag) + $ setHeader "ETag" + $ A.fromAsciiBuilder + $ printETag tag when (method ≡ POST) - $ abort InternalServerError [] - (Just "Illegal computation of foundETag for POST request.") + $ abort + $ mkAbortion' InternalServerError + "Illegal computation of foundETag for POST request." -- If-Match があればそれを見る。 ifMatch ← getHeader "If-Match" case ifMatch of - Nothing → return () - Just value → if value ≡ "*" then - return () - 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) - Left _ - → abort BadRequest [] (Just $ "Unparsable If-Match: " ⊕ A.toText value) + Nothing + → return () + Just value + → if value ≡ "*" then + return () + else + case P.parseOnly (finishOff eTagList) (A.toByteString value) of + Right tags + -- tags の中に一致するものが無ければ + -- PreconditionFailed で終了。 + → when ((¬) (any (≡ tag) tags)) + $ abort + $ mkAbortion' PreconditionFailed + $ "The entity tag doesn't match: " ⊕ A.toText value + Left _ + → abort $ mkAbortion' BadRequest + $ "Unparsable If-Match: " ⊕ A.toText value let statusForNoneMatch = if method ≡ GET ∨ method ≡ HEAD then @@ -488,45 +411,46 @@ foundETag tag -- If-None-Match があればそれを見る。 ifNoneMatch ← getHeader "If-None-Match" 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 - where - p = do xs ← eTagListP - P.endOfInput - return xs + Nothing + → return () + Just value + → if value ≡ "*" then + abort $ mkAbortion' statusForNoneMatch + $ "The entity tag matches: *" + else + case P.parseOnly (finishOff eTagList) (A.toByteString value) of + Right tags + → when (any (≡ tag) tags) + $ abort + $ mkAbortion' statusForNoneMatch + $ "The entity tag matches: " ⊕ A.toText value + Left _ + → abort $ mkAbortion' BadRequest + $ "Unparsable If-None-Match: " ⊕ A.toText value + + driftTo ReceivingBody -- |Tell the system that the 'Resource' found an entity for the -- 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.") + $ abort + $ mkAbortion' InternalServerError + "Illegal computation of foundTimeStamp for POST request." let statusForIfModSince = if method ≡ GET ∨ method ≡ HEAD then @@ -540,8 +464,9 @@ foundTimeStamp timeStamp Just str → case HTTP.fromAscii str of Right lastTime → when (timeStamp ≤ lastTime) - $ abort statusForIfModSince [] - (Just $ "The entity has not been modified since " ⊕ A.toText str) + $ abort + $ mkAbortion' statusForIfModSince + $ "The entity has not been modified since " ⊕ A.toText str Left _ → return () -- 不正な時刻は無視 Nothing → return () @@ -552,21 +477,22 @@ foundTimeStamp timeStamp Just str → case HTTP.fromAscii str of Right lastTime → when (timeStamp > lastTime) - $ abort PreconditionFailed [] - (Just $ "The entity has not been modified since " ⊕ A.toText str) + $ abort + $ mkAbortion' PreconditionFailed + $ "The entity has not been modified since " ⊕ A.toText str Left _ → return () -- 不正な時刻は無視 Nothing → return () - 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 @@ -574,255 +500,123 @@ foundNoEntity msgM method ← getMethod when (method ≢ PUT) - $ abort NotFound [] msgM + $ abort + $ mkAbortion NotFound [] msgM -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな -- If-Match: 條件も滿たさない。 ifMatch ← getHeader "If-Match" when (ifMatch ≢ Nothing) - $ abort PreconditionFailed [] msgM - - driftTo GettingBody - - -{- GettingBody 時に使用するアクション群 -} - --- | 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. + $ abort + $ mkAbortion PreconditionFailed [] msgM + + driftTo ReceivingBody + +-- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@. +foundNoEntity' ∷ Resource () +{-# INLINE foundNoEntity' #-} +foundNoEntity' = foundNoEntity Nothing + +-- |@'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 reqHasBody $ fromJust $ itrRequest itr then - askForInput itr - else - do driftTo DecidingHeader - return (∅) - return chunk +-- 'getChunks' returns a lazy '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 (Just 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'. + go ∷ Int → Builder → Resource Lazy.ByteString + go 0 _ = do chunk ← getChunk 1 + if Strict.null chunk then + return (∅) + else + abort $ mkAbortion' RequestEntityTooLarge + $ "Request body must be smaller than " + ⊕ T.pack (show limit) + ⊕ " bytes." + go !n !b = do c ← getChunk $ min n BB.defaultBufferSize + if Strict.null c then + -- Got EOF + return $ BB.toLazyByteString b + else + do let n' = n - Strict.length c + xs' = b ⊕ BB.fromByteString c + 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\". -- --- 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 reqHasBody $ fromJust $ itrRequest itr then - askForInput itr - 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 (Just 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\". --- --- 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 +-- Note that there are currently a few limitations on parsing +-- @multipart/form-data@. See: 'parseMultipartFormData' +getForm ∷ Maybe Int → Resource [(Strict.ByteString, FormData)] +getForm limit = do cTypeM ← getContentType case cTypeM of Nothing - → abort BadRequest [] (Just "Missing Content-Type") + → abort $ mkAbortion' BadRequest "Missing Content-Type" Just (MIMEType "application" "x-www-form-urlencoded" _) → readWWWFormURLEncoded Just (MIMEType "multipart" "form-data" params) → readMultipartFormData params Just cType - → abort UnsupportedMediaType [] - $ Just - $ A.toText - $ A.fromAsciiBuilder - $ A.toAsciiBuilder "Unsupported media type: " - ⊕ printMIMEType cType + → abort $ mkAbortion' UnsupportedMediaType + $ A.toText + $ A.fromAsciiBuilder + $ A.toAsciiBuilder "Unsupported media type: " + ⊕ MT.printMIMEType cType where readWWWFormURLEncoded = (map toPairWithFormData ∘ parseWWWFormURLEncoded) <$> - (bsToAscii =≪ input limit) + (bsToAscii =≪ getChunks limit) bsToAscii bs = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of Just a → return a - Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded") - - readMultipartFormData params - = do case M.lookup "boundary" params of - Nothing - → abort BadRequest [] (Just "Missing boundary of multipart/form-data") - Just boundary - → do src ← input limit - b ← case A.fromText boundary of - Just b → return b - Nothing → abort BadRequest [] - (Just $ "Malformed boundary: " ⊕ boundary) - case LP.parse (p b) src of - LP.Done _ formList - → return formList - _ → abort BadRequest [] (Just "Unparsable multipart/form-data") - where - p b = do xs ← multipartFormP b - 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) - - -{- DecidingHeader 時に使用するアクション群 -} - --- | 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' - --- | 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. + Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded" + + readMultipartFormData (MIMEParams m) + = case M.lookup "boundary" m of + Nothing + → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data" + Just boundary + → do src ← getChunks limit + b ← case A.fromText boundary of + Just b → return b + Nothing → abort $ mkAbortion' BadRequest + $ "Malformed boundary: " ⊕ boundary + case parseMultipartFormData b src of + Right xs → return $ map (first A.toByteString) xs + Left err → abort $ mkAbortion' BadRequest $ T.pack err + +-- |@'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)) - $ abort InternalServerError [] - $ Just + $ abort + $ mkAbortion' InternalServerError $ A.toText $ A.fromAsciiBuilder $ A.toAsciiBuilder "Attempted to redirect with status " @@ -830,133 +624,58 @@ 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 + = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ MT.printMIMEType --- | Computation of @'setLocation' uri@ sets the response header --- \"Location\" to @uri@. +-- |@'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 Just a → setHeader "Location" a - Nothing → abort InternalServerError [] - (Just $ "Malformed URI: " ⊕ T.pack uriStr) + Nothing → abort $ mkAbortion' InternalServerError + $ "Malformed URI: " ⊕ T.pack uriStr where uriStr = uriToString id uri "" --- |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 tr ← case ver of HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding) HttpVersion 1 1 → return toAB - _ → abort InternalServerError [] - (Just "setContentEncoding: Unknown HTTP version") + _ → abort $ mkAbortion' InternalServerError + "setContentEncoding: Unknown HTTP version" setHeader "Content-Encoding" - (A.fromAsciiBuilder $ joinWith ", " $ map tr codings) + $ A.fromAsciiBuilder + $ mconcat + $ intersperse (A.toAsciiBuilder ", ") + $ map tr 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) - - -{- DecidingBody 時に使用するアクション群 -} - --- | Write a 'Lazy.ByteString' to the response body, and then transit --- to the /Done/ state. It is safe to apply 'output' to an infinite --- string, such as the lazy stream of \/dev\/random. -output ∷ Lazy.ByteString → Resource () -{-# INLINE output #-} -output str = outputChunk str *> driftTo Done - --- | Write a 'Lazy.ByteString' to the response body. This action can --- be repeated as many times as you want. It is safe to apply --- 'outputChunk' to an infinite string. -outputChunk ∷ Lazy.ByteString → Resource () -outputChunk wholeChunk - = do driftTo DecidingBody - itr ← getInteraction - - let limit = cnfMaxOutputChunkLength $ itrConfig itr - when (limit ≤ 0) - $ abort InternalServerError [] - (Just $ "cnfMaxOutputChunkLength must be positive: " ⊕ T.pack (show limit)) - - discardBody ← liftIO $ atomically $ readTVar $ itrWillDiscardBody itr - unless (discardBody) - $ sendChunks itr wholeChunk limit - - unless (Lazy.null wholeChunk) - $ liftIO $ atomically $ - writeTVar (itrSentNoBodySoFar itr) False - where - sendChunks ∷ Interaction → Lazy.ByteString → Int → Resource () - sendChunks itr@(Interaction {..}) str limit - | Lazy.null str = return () - | otherwise = do let (chunk, remaining) = Lazy.splitAt (fromIntegral limit) str - liftIO $ atomically - $ putTMVar itrBodyToSend (chunkToBuilder chunk) - sendChunks itr remaining limit - - chunkToBuilder ∷ Lazy.ByteString → Builder - chunkToBuilder = mconcat ∘ map BB.fromByteString ∘ Lazy.toChunks - -{- - - [GettingBody からそれ以降の状態に遷移する時] - - body を讀み終へてゐなければ、殘りの body を讀み捨てる。 - +setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge - [DecidingHeader からそれ以降の状態に遷移する時] +-- |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 - postprocess する。 - - - [Done に遷移する時] - - bodyIsNull が False ならば何もしない。True だった場合は出力補完す - る。 - --} - -driftTo ∷ InteractionState → Resource () -driftTo newState - = do itr ← getInteraction - liftIO $ atomically - $ do oldState ← readTVar $ itrState itr - if newState < oldState then - throwStateError oldState newState - else - do let a = [oldState .. newState] - b = tail a - c = zip a b - mapM_ (uncurry $ drift itr) c - writeTVar (itrState itr) newState - where - throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a - throwStateError Done DecidingBody - = fail "It makes no sense to output something after finishing to output." - throwStateError old new - = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new) - - drift ∷ Interaction → InteractionState → InteractionState → STM () - drift (Interaction {..}) GettingBody _ - = writeTVar itrReqBodyWasteAll True - drift itr DecidingHeader _ - = postprocess itr - drift itr@(Interaction {..}) _ Done - = do bodyIsNull ← readTVar itrSentNoBodySoFar - when bodyIsNull - $ writeDefaultPage itr - drift _ _ _ - = return () +-- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It +-- can be safely applied to an infinitely long 'Lazy.ByteString'. +-- +-- 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