X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=6f3ecce8b851e8526e1f5eb48f6bf255656533ab;hp=aee29d56f95682c7550623176267f23e6230d23b;hb=67f9e87;hpb=9b2a30d14cbdb224d4c386a3bca45456dc336ce2 diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index aee29d5..6f3ecce 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,13 +1,15 @@ {-# LANGUAGE - BangPatterns + CPP + , BangPatterns , GeneralizedNewtypeDeriving , DoAndIfThenElse , OverloadedStrings + , QuasiQuotes , RecordWildCards , UnicodeSyntax #-} -- |This is the Resource Monad; monadic actions to define a behavior --- of resource. The 'Resource' Monad is a kind of 'IO' Monad thus it +-- of resource. The 'Rsrc' Monad is a kind of 'IO' Monad thus it -- implements 'MonadIO' class, and it is a state machine as well. -- -- Request Processing Flow: @@ -15,73 +17,73 @@ -- 1. A client issues an HTTP request. -- -- 2. If the URI of it matches to any resource, the corresponding --- 'Resource' Monad starts running on a newly spawned thread. +-- 'Rsrc' Monad starts running on a newly spawned thread. -- --- 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. +-- 3. The 'Rsrc' 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 --- may or may not be sending us the next request at this point. +-- 4. The 'Rsrc' Monad and its thread stops running. The client may +-- or may not be sending us the next request at this point. -- --- 'Resource' Monad takes the following states. The initial state is +-- 'Rsrc' Monad takes the following states. The initial state is -- /Examining Request/ and the final state is /Done/. -- --- [/Examining Request/] In this state, a 'Resource' looks at the +-- [/Examining Request/] In this state, a 'Rsrc' looks at the -- request header fields and thinks about the corresponding entity --- for it. If there is a suitable entity, the 'Resource' tells the +-- for it. If there is a suitable entity, the 'Rsrc' 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. +-- 'Rsrc' does nothing in this state. -- --- [/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 a request body, the system automatically --- discards it. +-- [/Receiving Body/] A 'Rsrc' 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 'Rsrc' transits to the next state without receiving all or part +-- of a request body, the system automatically discards it. -- --- [/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 Header/] A 'Rsrc' 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. -- --- [/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 --- 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') +-- [/Sending Body/] In this state, a 'Rsrc' 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 automatically +-- completes it depending on the status code. (To be exact, such +-- completion only occurs when the 'Rsrc' 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. +-- [/Done/] Everything is over. A 'Rsrc' can do nothing for the HTTP +-- interaction anymore. -- -- Note that the state transition is one-way: for instance, it is an -- error to try to read a request body after writing some -- response. This limitation is for efficiency. We don't want to read --- the entire request before starting 'Resource', nor we don't want to --- postpone writing the entire response till the end of 'Resource' +-- the entire request before starting 'Rsrc', nor we don't want to +-- postpone writing the entire response till the end of 'Rsrc' -- computation. module Network.HTTP.Lucu.Resource ( -- * Types - Resource - , ResourceDef(..) - , emptyResource + Resource(..) + , Rsrc , FormData(..) -- * Getting request header -- |These functions can be called regardless of the current state, - -- and they don't change the state of 'Resource'. + -- and they don't change the state of 'Rsrc'. , getConfig , getRemoteAddr , getRemoteAddr' , getRemoteHost +#if defined(HAVE_SSL) , getRemoteCertificate +#endif , getRequest , getMethod , getRequestURI @@ -98,7 +100,7 @@ module Network.HTTP.Lucu.Resource -- * Finding an entity -- |These functions can be called only in the /Examining Request/ - -- state. They make the 'Resource' transit to the /Receiving Body/ + -- state. They make the 'Rsrc' transit to the /Receiving Body/ -- state. , foundEntity , foundETag @@ -107,7 +109,7 @@ module Network.HTTP.Lucu.Resource , foundNoEntity' -- * Receiving a request body - -- |These functions make the 'Resource' transit to the /Receiving + -- |These functions make the 'Rsrc' transit to the /Receiving -- Body/ state. , getChunk , getChunks @@ -130,8 +132,8 @@ module Network.HTTP.Lucu.Resource -- * Sending a response body - -- |These functions make the 'Resource' transit to the - -- /Sending Body/ state. + -- |These functions make the 'Rsrc' transit to the /Sending Body/ + -- state. , putChunk , putChunks , putBuilder @@ -147,19 +149,23 @@ import Control.Monad.IO.Class import Control.Monad.Unicode import Data.Ascii (Ascii, CIAscii) import qualified Data.Ascii as A +import Data.Attempt import qualified Data.Attoparsec.Char8 as P import Data.ByteString (ByteString) import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy -import Data.List -import qualified Data.Map as M +import Data.Collections +import Data.Convertible.Base +import Data.List (intersperse, sort) import Data.Maybe import Data.Monoid import Data.Monoid.Unicode +import Data.Proxy +import Data.Tagged import Data.Text (Text) import qualified Data.Text as T import Data.Time -import qualified Data.Time.HTTP as HTTP +import Data.Time.Format.HTTP import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Authentication import Network.HTTP.Lucu.Config @@ -169,58 +175,61 @@ 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.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.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 Prelude hiding (any, drop, lookup, reverse) import Prelude.Unicode -- |Get the string representation of the address of remote host. If -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'. -getRemoteAddr' ∷ Resource HostName +getRemoteAddr' ∷ Rsrc HostName 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 ∷ Rsrc (Maybe HostName) 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 +getMethod ∷ Rsrc Method getMethod = reqMethod <$> getRequest -- |Get the URI of the request. -getRequestURI ∷ Resource URI +getRequestURI ∷ Rsrc URI getRequestURI = reqURI <$> getRequest -- |Get the HTTP version of the request. -getRequestVersion ∷ Resource HttpVersion +getRequestVersion ∷ Rsrc HttpVersion getRequestVersion = reqVersion <$> getRequest -- |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' +-- @[]@ if the corresponding 'Resource' is not greedy. See +-- 'getResourcePath'. -- -- Note that the returned path components are URI-decoded. -getPathInfo ∷ Resource [Strict.ByteString] +getPathInfo ∷ Rsrc [Strict.ByteString] getPathInfo = do rsrcPath ← getResourcePath - reqPath ← splitPathInfo <$> getRequestURI + reqPath ← uriPathSegments <$> getRequestURI return $ drop (length rsrcPath) reqPath -- |Assume the query part of request URI as -- 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 ∷ Rsrc [(Strict.ByteString, FormData)] getQueryForm = parse' <$> getRequestURI where parse' = map toPairWithFormData ∘ @@ -234,7 +243,7 @@ toPairWithFormData ∷ (ByteString, ByteString) → (Strict.ByteString, FormData toPairWithFormData (name, value) = let fd = FormData { fdFileName = Nothing - , fdMIMEType = parseMIMEType "text/plain" + , fdMIMEType = [mimeType| text/plain |] , fdContent = Lazy.fromChunks [value] } in (name, fd) @@ -243,32 +252,28 @@ toPairWithFormData (name, value) -- @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 ∷ CIAscii → Rsrc (Maybe Ascii) getHeader name = H.getHeader name <$> getRequest -- |Return the list of 'MIMEType' enumerated on the value of request -- header \"Accept\", or @[]@ if absent. -getAccept ∷ Resource [MIMEType] +getAccept ∷ Rsrc [MIMEType] getAccept = do acceptM ← getHeader "Accept" case acceptM of 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 $ mkAbortion' BadRequest $ "Unparsable Accept: " ⊕ A.toText accept - where - p = do xs ← mimeTypeList - P.endOfInput - return xs -- |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 ∷ Rsrc [(CIAscii, Maybe Double)] getAcceptEncoding = do accEncM ← getHeader "Accept-Encoding" case accEncM of @@ -288,65 +293,53 @@ getAcceptEncoding -- identity のみが許される。 return [("identity", Nothing)] else - case P.parseOnly p (A.toByteString ae) of + 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 ← acceptEncodingList - P.endOfInput - return xs - toTuple (AcceptEncoding {..}) = (aeEncoding, aeQValue) -- |Return 'True' iff a given content-coding is acceptable by the -- client. -isEncodingAcceptable ∷ CIAscii → Resource Bool +isEncodingAcceptable ∷ CIAscii → Rsrc Bool isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding where doesMatch ∷ (CIAscii, Maybe Double) → Bool doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0 -- |Return the value of request header \"Content-Type\" as 'MIMEType'. -getContentType ∷ Resource (Maybe MIMEType) +getContentType ∷ Rsrc (Maybe MIMEType) getContentType = do cTypeM ← getHeader "Content-Type" case cTypeM of 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 $ mkAbortion' BadRequest $ "Unparsable Content-Type: " ⊕ A.toText cType - where - p = do t ← mimeType - P.endOfInput - return t -- |Return the value of request header \"Authorization\" as -- 'AuthCredential'. -getAuthorization ∷ Resource (Maybe AuthCredential) +getAuthorization ∷ Rsrc (Maybe AuthCredential) getAuthorization = do authM ← getHeader "Authorization" case authM of 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 ← authCredential - P.endOfInput - return ac - --- |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. For POST requests --- it raises an error. + +-- |Tell the system that the 'Rsrc' 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. For POST requests it raises +-- an error. -- -- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test -- whenever possible, and if those tests fail, it immediately aborts @@ -356,13 +349,15 @@ getAuthorization -- 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 ∷ ETag → UTCTime → Rsrc () foundEntity tag timeStamp = do driftTo ExaminingRequest method ← getMethod when (method ≡ GET ∨ method ≡ HEAD) - $ setHeader "Last-Modified" (HTTP.toAscii timeStamp) + $ setHeader "Last-Modified" + $ flip proxy http + $ cs timeStamp when (method ≡ POST) $ abort $ mkAbortion' InternalServerError @@ -371,14 +366,13 @@ foundEntity tag timeStamp 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 (nor can't) put \"Last-Modified\" header into --- the response. +-- |Tell the system that the 'Rsrc' found an entity for the request +-- URI. The only difference from 'foundEntity' is that 'foundETag' +-- doesn't (nor can't) put \"Last-Modified\" header into the response. -- -- Using this function is discouraged. You should use 'foundEntity' -- whenever possible. -foundETag ∷ ETag → Resource () +foundETag ∷ ETag → Rsrc () foundETag tag = do driftTo ExaminingRequest @@ -386,7 +380,7 @@ foundETag tag when (method ≡ GET ∨ method ≡ HEAD) $ setHeader "ETag" $ A.fromAsciiBuilder - $ printETag tag + $ cs tag when (method ≡ POST) $ abort $ mkAbortion' InternalServerError @@ -395,53 +389,53 @@ foundETag tag -- 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 - $ mkAbortion' PreconditionFailed - $ "The entity tag doesn't match: " ⊕ A.toText value - Left _ - → abort $ mkAbortion' BadRequest - $ "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 - NotModified + fromStatusCode NotModified else - PreconditionFailed + fromStatusCode PreconditionFailed -- If-None-Match があればそれを見る。 ifNoneMatch ← getHeader "If-None-Match" case ifNoneMatch of - Nothing → return () - Just value → if value ≡ "*" then - abort $ mkAbortion' statusForNoneMatch - $ "The entity tag matches: *" - else - case P.parseOnly p (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 + 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 - where - p = do xs ← eTagList - P.endOfInput - return xs --- |Tell the system that the 'Resource' found an entity for the +-- |Tell the system that the 'Rsrc' 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 @@ -451,61 +445,63 @@ foundETag tag -- -- Using this function is discouraged. You should use 'foundEntity' -- whenever possible. -foundTimeStamp ∷ UTCTime → Resource () +foundTimeStamp ∷ UTCTime → Rsrc () foundTimeStamp timeStamp = do driftTo ExaminingRequest method ← getMethod when (method ≡ GET ∨ method ≡ HEAD) - $ setHeader "Last-Modified" (HTTP.toAscii timeStamp) + $ setHeader "Last-Modified" + $ flip proxy http + $ cs timeStamp when (method ≡ POST) $ abort $ mkAbortion' InternalServerError - "Illegal computation of foundTimeStamp for POST request." + "Illegal call of foundTimeStamp for POST request." let statusForIfModSince = if method ≡ GET ∨ method ≡ HEAD then - NotModified + fromStatusCode NotModified else - PreconditionFailed + fromStatusCode PreconditionFailed - -- If-Modified-Since があればそれを見る。 ifModSince ← getHeader "If-Modified-Since" case ifModSince of - Just str → case HTTP.fromAscii str of - Right lastTime + Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of + Just lastTime → when (timeStamp ≤ lastTime) $ abort $ mkAbortion' statusForIfModSince $ "The entity has not been modified since " ⊕ A.toText str - Left _ - → return () -- 不正な時刻は無視 + Nothing + → abort $ mkAbortion' BadRequest + $ "Malformed If-Modified-Since: " ⊕ A.toText str Nothing → return () - -- If-Unmodified-Since があればそれを見る。 ifUnmodSince ← getHeader "If-Unmodified-Since" case ifUnmodSince of - Just str → case HTTP.fromAscii str of - Right lastTime + Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of + Just lastTime → when (timeStamp > lastTime) $ abort $ mkAbortion' PreconditionFailed $ "The entity has not been modified since " ⊕ A.toText str - Left _ - → return () -- 不正な時刻は無視 + Nothing + → abort $ mkAbortion' BadRequest + $ "Malformed If-Unmodified-Since: " ⊕ A.toText str Nothing → return () driftTo ReceivingBody --- |@'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 'Rsrc' found no +-- entity for the request URI. @mStr@ is an optional error message to +-- be replied to the client. -- -- 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 ∷ Maybe Text → Rsrc () foundNoEntity msgM = do driftTo ExaminingRequest @@ -524,15 +520,15 @@ foundNoEntity msgM driftTo ReceivingBody -- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@. -foundNoEntity' ∷ Resource () +foundNoEntity' ∷ Rsrc () {-# 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 +-- @limit@ bytes, and then make the 'Rsrc' 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. -- -- When the @limit@ is 'Nothing', 'getChunks' uses the default @@ -541,7 +537,7 @@ foundNoEntity' = foundNoEntity Nothing -- '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 ∷ Maybe Int → Rsrc Lazy.ByteString getChunks (Just n) | n < 0 = fail ("getChunks: limit must not be negative: " ⧺ show n) | n ≡ 0 = return (∅) @@ -549,10 +545,10 @@ getChunks (Just n) getChunks Nothing = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength -getChunks' ∷ Int → Resource Lazy.ByteString +getChunks' ∷ Int → Rsrc Lazy.ByteString getChunks' limit = go limit (∅) where - go ∷ Int → Builder → Resource Lazy.ByteString + go ∷ Int → Builder → Rsrc Lazy.ByteString go 0 _ = do chunk ← getChunk 1 if Strict.null chunk then return (∅) @@ -579,7 +575,7 @@ getChunks' limit = go limit (∅) -- -- Note that there are currently a few limitations on parsing -- @multipart/form-data@. See: 'parseMultipartFormData' -getForm ∷ Maybe Int → Resource [(Strict.ByteString, FormData)] +getForm ∷ Maybe Int → Rsrc [(Strict.ByteString, FormData)] getForm limit = do cTypeM ← getContentType case cTypeM of @@ -594,7 +590,7 @@ getForm limit $ A.toText $ A.fromAsciiBuilder $ A.toAsciiBuilder "Unsupported media type: " - ⊕ printMIMEType cType + ⊕ MT.printMIMEType cType where readWWWFormURLEncoded = (map toPairWithFormData ∘ parseWWWFormURLEncoded) @@ -606,8 +602,8 @@ getForm limit Just a → return a Nothing → abort $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded" - readMultipartFormData params - = case M.lookup "boundary" params of + readMultipartFormData m + = case lookup "boundary" m of Nothing → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data" Just boundary @@ -623,28 +619,28 @@ getForm limit -- |@'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)) +redirect ∷ StatusCode sc ⇒ sc → URI → Rsrc () +redirect sc uri + = do when (sc ≈ NotModified ∨ (¬) (isRedirection sc)) $ abort $ mkAbortion' InternalServerError $ A.toText $ A.fromAsciiBuilder $ A.toAsciiBuilder "Attempted to redirect with status " - ⊕ printStatusCode code - setStatus code + ⊕ printStatusCode sc + setStatus sc setLocation uri -- |@'setContentType' mType@ declares the response header -- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is -- mandatory for sending a response body. -setContentType ∷ MIMEType → Resource () +setContentType ∷ MIMEType → Rsrc () setContentType - = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType + = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ MT.printMIMEType -- |@'setLocation' uri@ declares the response header \"Location\" as -- @uri@. You usually don't need to call this function directly. -setLocation ∷ URI → Resource () +setLocation ∷ URI → Rsrc () setLocation uri = case A.fromChars uriStr of Just a → setHeader "Location" a @@ -655,7 +651,7 @@ setLocation uri -- |@'setContentEncoding' codings@ declares the response header -- \"Content-Encoding\" as @codings@. -setContentEncoding ∷ [CIAscii] → Resource () +setContentEncoding ∷ [CIAscii] → Rsrc () setContentEncoding codings = do ver ← getRequestVersion tr ← case ver of @@ -673,20 +669,20 @@ setContentEncoding codings -- |@'setWWWAuthenticate' challenge@ declares the response header -- \"WWW-Authenticate\" as @challenge@. -setWWWAuthenticate ∷ AuthChallenge → Resource () -setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge +setWWWAuthenticate ∷ AuthChallenge → Rsrc () +setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ cs -- |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 () +-- applying this function. See 'setContentType'. +putChunk ∷ Strict.ByteString → Rsrc () putChunk = putBuilder ∘ BB.fromByteString -- |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 () +-- \"Content-Type\" before applying this function. See +-- 'setContentType'. +putChunks ∷ Lazy.ByteString → Rsrc () putChunks = putBuilder ∘ BB.fromLazyByteString