X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=704feda9c79ca2e5ab4619b1550166bdd8023f4c;hp=d87e509b89d479ffcd39b97d58e0c01724bcb337;hb=b1fac0a2cb1cafa008c0efa8ae4e14afbee0927f;hpb=86ea98d8307ddc687696896a91bed9a05cbeb783 diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index d87e509..704feda 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,6 +1,15 @@ --- |This is the Resource Monad; monadic actions to define the behavior --- of each resources. The 'Resource' Monad is a kind of IO Monad thus --- it implements MonadIO class. It is also a state machine. +{-# LANGUAGE + 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 +-- implements 'MonadIO' class, and it is a state machine as well. -- -- Request Processing Flow: -- @@ -9,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 @@ -21,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. @@ -54,666 +67,615 @@ -- 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 ( - -- * Monad - Resource - - -- * Actions - - -- ** Getting request header - - -- |These actions can be computed regardless of the current state, - -- and they don't change the state. + -- * Types + Resource + , ResourceDef(..) + , emptyResource + , FormData(..) + + -- * 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' + , getRemoteHost + , getRemoteCertificate , getRequest , getMethod , getRequestURI + , getRequestVersion , getResourcePath , getPathInfo + , getQueryForm , getHeader , getAccept + , getAcceptEncoding + , isEncodingAcceptable , 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 - , inputBS - , inputChunkBS - , 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 + , 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 - , outputBS - , outputChunkBS + -- * Sending a response body - , driftTo + -- |These functions make the 'Resource' transit to the + -- /Sending Body/ state. + , putChunk + , putChunks + , putBuilder ) where - -import Control.Concurrent.STM -import Control.Monad.Reader -import qualified Data.ByteString.Lazy.Char8 as B -import Data.ByteString.Lazy.Char8 (ByteString) -import Data.List -import Data.Maybe -import GHC.Conc (unsafeIOToSTM) -import Network.HTTP.Lucu.Abortion -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.DefaultPage -import Network.HTTP.Lucu.ETag +import Blaze.ByteString.Builder (Builder) +import qualified Blaze.ByteString.Builder as BB +import qualified Blaze.ByteString.Builder.Internal as BB +import Control.Applicative +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 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.Maybe +import Data.Monoid +import Data.Monoid.Unicode +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time +import qualified Data.Time.HTTP as HTTP +import Network.HTTP.Lucu.Abortion +import Network.HTTP.Lucu.Authentication +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.ContentCoding +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.Parser -import Network.HTTP.Lucu.Postprocess -import Network.HTTP.Lucu.RFC1123DateTime -import Network.HTTP.Lucu.Request -import Network.HTTP.Lucu.Response -import Network.HTTP.Lucu.MIMEType -import Network.HTTP.Lucu.Utils -import Network.URI -import System.Time - --- |The 'Resource' monad. /Interaction/ is an internal state thus it --- is not exposed to users. This monad implements 'MonadIO' so it can --- do any IO actions. -type Resource a = ReaderT Interaction IO a - --- |Get the 'Network.HTTP.Lucu.Config.Config' value which is used for --- the httpd. -getConfig :: Resource Config -getConfig = do itr <- ask - return $ itrConfig itr - --- |Get the 'Network.HTTP.Lucu.Request.Request' value which represents --- the request header. In general you don't have to use this action. -getRequest :: Resource Request -getRequest = do itr <- ask - return $ fromJust $ itrRequest itr - --- |Get the 'Network.HTTP.Lucu.Request.Method' value of the request. -getMethod :: Resource Method -getMethod = do req <- getRequest - return $ reqMethod req +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.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 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' = 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 = 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 = reqMethod <$> getRequest -- |Get the URI of the request. -getRequestURI :: Resource URI -getRequestURI = do req <- getRequest - return $ reqURI req - --- |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. --- --- Example: +getRequestURI ∷ Resource URI +getRequestURI = reqURI <$> getRequest + +-- |Get the HTTP version of the request. +getRequestVersion ∷ Resource 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' -- --- > 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 [String] -getResourcePath = do itr <- ask - return $ fromJust $ itrResourcePath itr - - --- |This is an analogy of CGI PATH_INFO. Its result is always @[]@ if --- the 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not --- greedy. See 'getResourcePath'. -getPathInfo :: Resource [String] -getPathInfo = do rsrcPath <- getResourcePath - reqURI <- getRequestURI - let reqPathStr = uriPath reqURI - reqPath = [x | x <- splitBy (== '/') reqPathStr, x /= ""] - -- rsrcPath と reqPath の共通する先頭部分を reqPath か - -- ら全部取り除くと、それは PATH_INFO のやうなものにな - -- る。rsrcPath は全部一致してゐるに決まってゐる（でな - -- ければこの Resource が撰ばれた筈が無い）ので、 - -- rsrcPath の長さの分だけ削除すれば良い。 +-- Note that the returned path components are URI-decoded. +getPathInfo ∷ Resource [Strict.ByteString] +getPathInfo = do rsrcPath ← getResourcePath + reqPath ← splitPathInfo <$> getRequestURI return $ drop (length rsrcPath) reqPath --- |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 an action like 'getContentType' for --- every common headers. -getHeader :: String -> Resource (Maybe String) -getHeader name = do itr <- ask - return $ H.getHeader name $ fromJust $ itrRequest itr - --- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on --- header \"Accept\". -getAccept :: Resource [MIMEType] -getAccept = do accept <- getHeader "Accept" - if accept == Nothing then - return [] +-- |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 = parse' <$> getRequestURI + where + parse' = map toPairWithFormData ∘ + parseWWWFormURLEncoded ∘ + fromJust ∘ + A.fromChars ∘ + drop 1 ∘ + uriQuery + +toPairWithFormData ∷ (ByteString, ByteString) → (Strict.ByteString, FormData) +toPairWithFormData (name, value) + = let fd = FormData { + fdFileName = Nothing + , fdMIMEType = [mimeType| text/plain |] + , fdContent = Lazy.fromChunks [value] + } + in (name, fd) + +-- |@'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 + +-- |Return the list of 'MIMEType' enumerated on the value of request +-- header \"Accept\", or @[]@ if absent. +getAccept ∷ Resource [MIMEType] +getAccept + = do acceptM ← getHeader "Accept" + case acceptM of + Nothing + → return [] + Just accept + → case P.parseOnly (finishOff MT.mimeTypeList) (A.toByteString accept) of + Right xs → return xs + Left _ → abort $ mkAbortion' BadRequest + $ "Unparsable Accept: " ⊕ A.toText accept + +-- |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" + case accEncM of + Nothing + -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い + -- ので安全の爲 identity が指定された事にする。HTTP/1.1 + -- の場合は何でも受け入れて良い事になってゐるので "*" が + -- 指定された事にする。 + → do ver ← getRequestVersion + case ver of + HttpVersion 1 0 → return [("identity", Nothing)] + HttpVersion 1 1 → return [("*" , Nothing)] + _ → abort $ mkAbortion' InternalServerError + "getAcceptEncoding: unknown HTTP version" + Just ae + → if ae ≡ "" then + -- identity のみが許される。 + return [("identity", Nothing)] else - case parseStr mimeTypeListP $ fromJust accept of - (Success xs, _) -> return xs - _ -> return [] - --- |Get the header \"Content-Type\" as --- 'Network.HTTP.Lucu.MIMEType.MIMEType'. -getContentType :: Resource (Maybe MIMEType) -getContentType = do cType <- getHeader "Content-Type" - if cType == Nothing then - return Nothing - else - case parseStr mimeTypeP $ fromJust cType of - (Success t, _) -> return $ Just t - _ -> return Nothing - + 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 + toTuple (AcceptEncoding {..}) + = (aeEncoding, aeQValue) +-- |Return 'True' iff a given content-coding is acceptable by the +-- client. +isEncodingAcceptable ∷ CIAscii → Resource Bool +isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding + where + doesMatch ∷ (CIAscii, Maybe Double) → Bool + doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0 -{- ExaminingRequest 時に使用するアクション群 -} +-- |Return the value of request header \"Content-Type\" as 'MIMEType'. +getContentType ∷ Resource (Maybe MIMEType) +getContentType + = do cTypeM ← getHeader "Content-Type" + case cTypeM of + Nothing + → return Nothing + Just cType + → 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 + +-- |Return the value of request header \"Authorization\" as +-- 'AuthCredential'. +getAuthorization ∷ Resource (Maybe AuthCredential) +getAuthorization + = do authM ← getHeader "Authorization" + case authM of + Nothing + → return Nothing + Just auth + → case P.parseOnly (finishOff authCredential) (A.toByteString auth) of + Right ac → return $ Just ac + Left _ → return Nothing -- |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 up to 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. -foundEntity :: ETag -> ClockTime -> Resource () +-- 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" $ formatHTTPDateTime timeStamp - when (method == POST) - $ abort InternalServerError [] - (Just "Illegal computation of foundEntity for POST request.") + method ← getMethod + when (method ≡ GET ∨ method ≡ HEAD) + $ setHeader "Last-Modified" (HTTP.toAscii timeStamp) + when (method ≡ POST) + $ 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' when --- possible. -foundETag :: ETag -> Resource () +-- 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" $ show tag - when (method == POST) - $ abort InternalServerError [] - (Just "Illegal computation of foundETag for POST request.") + method ← getMethod + when (method ≡ GET ∨ method ≡ HEAD) + $ setHeader "ETag" + $ A.fromAsciiBuilder + $ printETag tag + when (method ≡ POST) + $ abort + $ mkAbortion' InternalServerError + "Illegal computation of foundETag for POST request." -- If-Match があればそれを見る。 - ifMatch <- getHeader "If-Match" + ifMatch ← getHeader "If-Match" case ifMatch of - Nothing -> return () - Just "*" -> return () - Just list -> case parseStr eTagListP list of - (Success tags, _) - -- tags の中に一致するものが無ければ - -- PreconditionFailed で終了。 - -> when (not $ any (== tag) tags) - $ abort PreconditionFailed [] - $ Just ("The entity tag doesn't match: " ++ list) - _ -> abort BadRequest [] $ Just ("Unparsable If-Match: " ++ fromJust ifMatch) - - let statusForNoneMatch = if method == GET || method == HEAD then - NotModified - else - PreconditionFailed + 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 + else + PreconditionFailed -- If-None-Match があればそれを見る。 - ifNoneMatch <- getHeader "If-None-Match" + ifNoneMatch ← getHeader "If-None-Match" case ifNoneMatch of - Nothing -> return () - Just "*" -> abort statusForNoneMatch [] $ Just ("The entity tag matches: *") - Just list -> case parseStr eTagListP list of - (Success tags, _) - -> when (any (== tag) tags) - $ abort statusForNoneMatch [] $ Just ("The entity tag matches: " ++ list) - _ -> abort BadRequest [] $ Just ("Unparsable If-None-Match: " ++ list) - - driftTo GettingBody + 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' when --- possible. -foundTimeStamp :: ClockTime -> Resource () +-- 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" $ formatHTTPDateTime timeStamp - when (method == POST) - $ abort InternalServerError [] - (Just "Illegal computation of foundTimeStamp for POST request.") + method ← getMethod + when (method ≡ GET ∨ method ≡ HEAD) + $ setHeader "Last-Modified" (HTTP.toAscii timeStamp) + when (method ≡ POST) + $ abort + $ mkAbortion' InternalServerError + "Illegal computation of foundTimeStamp for POST request." - let statusForIfModSince = if method == GET || method == HEAD then - NotModified - else - PreconditionFailed + let statusForIfModSince + = if method ≡ GET ∨ method ≡ HEAD then + NotModified + else + PreconditionFailed -- If-Modified-Since があればそれを見る。 - ifModSince <- getHeader "If-Modified-Since" + ifModSince ← getHeader "If-Modified-Since" case ifModSince of - Just str -> case parseHTTPDateTime str of - Just lastTime - -> when (timeStamp <= lastTime) - $ abort statusForIfModSince [] - $ Just ("The entity has not been modified since " ++ str) - Nothing - -> return () -- 不正な時刻は無視 - Nothing -> return () + Just str → case HTTP.fromAscii str of + Right lastTime + → when (timeStamp ≤ lastTime) + $ abort + $ mkAbortion' statusForIfModSince + $ "The entity has not been modified since " ⊕ A.toText str + Left _ + → return () -- 不正な時刻は無視 + Nothing → return () -- If-Unmodified-Since があればそれを見る。 - ifUnmodSince <- getHeader "If-Unmodified-Since" + ifUnmodSince ← getHeader "If-Unmodified-Since" case ifUnmodSince of - Just str -> case parseHTTPDateTime str of - Just lastTime - -> when (timeStamp > lastTime) - $ abort PreconditionFailed [] - $ Just ("The entity has not been modified since " ++ str) - Nothing - -> return () -- 不正な時刻は無視 - Nothing -> return () - - driftTo GettingBody - --- |Computation of @'foundNoEntity' mStr@ tell the system that the --- 'Resource' found no entity for the request URI. @mStr@ is an --- optional error message to be replied to the client. + Just str → case HTTP.fromAscii str of + Right lastTime + → when (timeStamp > lastTime) + $ abort + $ mkAbortion' PreconditionFailed + $ "The entity has not been modified since " ⊕ A.toText str + Left _ + → return () -- 不正な時刻は無視 + 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. -- --- 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 or DELETE request, 'foundNoEntity' --- always aborts with status \"404 Not Found\". It is an error to --- compute 'foundNoEntity' if this is a POST request. -foundNoEntity :: Maybe String -> Resource () +-- 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 = do driftTo ExaminingRequest - method <- getMethod - when (method == POST) - $ abort InternalServerError [] - (Just "Illegal computation of foundNoEntity for POST request.") - when (method /= PUT) - $ abort NotFound [] msgM + method ← getMethod + when (method ≢ PUT) + $ abort + $ mkAbortion NotFound [] msgM -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな -- If-Match: 條件も滿たさない。 - ifMatch <- getHeader "If-Match" - when (ifMatch /= Nothing) - $ abort PreconditionFailed [] msgM - - driftTo GettingBody - - -{- GettingBody 時に使用するアクション群 -} - -input :: Int -> Resource String -input limit = inputBS limit >>= return . B.unpack - - --- 多くとも limit バイトまでのリクエストボディ全體を受信する。limit が --- 零以下なら Config で設定されたデフォルトのボディ長により制限される。 -inputBS :: Int -> Resource ByteString -inputBS limit - = do driftTo GettingBody - itr <- ask - hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id - chunk <- if hasBody then - askForInput itr - else - do driftTo DecidingHeader - return B.empty - return chunk + ifMatch ← getHeader "If-Match" + when (ifMatch ≢ Nothing) + $ 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. +-- +-- When the @limit@ is 'Nothing', 'getChunks' uses the default +-- limitation value ('cnfMaxEntityLength') instead. +-- +-- '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 ByteString - askForInput itr - = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr - actualLimit = if limit <= 0 then - defaultLimit - else - limit - when (actualLimit <= 0) - $ fail ("inputBS: limit must be positive: " ++ show actualLimit) - -- Reader にリクエスト - liftIO $ atomically - $ do chunkLen <- readItr itr itrReqChunkLength id - writeItr itr itrWillReceiveBody True - if fmap (> actualLimit) chunkLen == Just True then - -- 受信前から多過ぎる事が分かってゐる - tooLarge actualLimit - else - writeItr itr itrReqBodyWanted $ Just actualLimit - -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 - chunk <- liftIO $ atomically - $ do chunk <- readItr itr itrReceivedBody id - chunkIsOver <- readItr itr itrReqChunkIsOver id - if B.length chunk < fromIntegral actualLimit then - -- 要求された量に滿たなくて、まだ殘り - -- があるなら再試行。 - unless chunkIsOver - $ retry - else - -- 制限値一杯まで讀むやうに指示したの - -- にまだ殘ってゐるなら、それは多過ぎ - -- る。 - unless chunkIsOver - $ tooLarge actualLimit - -- 成功。itr 内にチャンクを置いたままにす - -- るとメモリの無駄になるので除去。 - writeItr itr itrReceivedBody B.empty - return chunk - driftTo DecidingHeader - return chunk - - tooLarge :: Int -> STM () - tooLarge lim = abortSTM RequestEntityTooLarge [] - $ Just ("Request body must be smaller than " - ++ show lim ++ " bytes.") - - -inputChunk :: Int -> Resource String -inputChunk limit = inputChunkBS limit >>= return . B.unpack - - --- 多くとも limit バイトまでのリクエストボディの一部を受信する。limit --- が 0 以下なら Config で設定されたデフォルトのボディ長により制限され --- る。これ以上ボディが殘ってゐなければ空文字列を返す。 -inputChunkBS :: Int -> Resource ByteString -inputChunkBS limit - = do driftTo GettingBody - itr <- ask - hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id - chunk <- if hasBody then - askForInput itr + go ∷ Int → Builder → Resource Lazy.ByteString + go 0 _ = do chunk ← getChunk 1 + if Strict.null chunk then + return (∅) else - do driftTo DecidingHeader - return B.empty - return chunk - where - askForInput :: Interaction -> Resource ByteString - askForInput itr - = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr - actualLimit = if limit < 0 then - defaultLimit - else - limit - when (actualLimit <= 0) - $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit) - -- Reader にリクエスト - liftIO $ atomically - $ do writeItr itr itrReqBodyWanted $ Just actualLimit - writeItr itr itrWillReceiveBody True - -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 - chunk <- liftIO $ atomically - $ do chunk <- readItr itr itrReceivedBody id - -- 要求された量に滿たなくて、まだ殘りがあ - -- るなら再試行。 - when (B.length chunk < fromIntegral actualLimit) - $ do chunkIsOver <- readItr itr itrReqChunkIsOver id - unless chunkIsOver - $ retry - -- 成功 - writeItr itr itrReceivedBody B.empty - return chunk - when (B.null chunk) - $ driftTo DecidingHeader - return chunk - - --- application/x-www-form-urlencoded または multipart/form-data をパー --- スする。もし Content-Type が無かったら BadRequest で終了し、未對應の --- タイプであったら UnsupportedMediaType で終了する。 -inputForm :: Int -> Resource [(String, String)] -inputForm limit - = do cTypeM <- getContentType + 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 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" _) - -> readMultipartFormData + → readWWWFormURLEncoded + Just (MIMEType "multipart" "form-data" params) + → readMultipartFormData params Just cType - -> abort UnsupportedMediaType [] (Just $ "Unsupported media type: " - ++ show cType) + → abort $ mkAbortion' UnsupportedMediaType + $ A.toText + $ A.fromAsciiBuilder + $ A.toAsciiBuilder "Unsupported media type: " + ⊕ MT.printMIMEType cType where readWWWFormURLEncoded - = do src <- input limit - return $ do pairStr <- splitBy (\ c -> c == ';' || c == '&') src - let pair = break (== '=') pairStr - return ( unEscapeString $ fst pair - , unEscapeString $ snd pair - ) - readMultipartFormData -- FIXME: 未對應 - = abort UnsupportedMediaType [] - (Just $ "Sorry, inputForm does not currently support multipart/form-data.") - - -defaultLimit :: Int -defaultLimit = (-1) - - - -{- DecidingHeader 時に使用するアクション群 -} - -setStatus :: StatusCode -> Resource () -setStatus code - = do driftTo DecidingHeader - itr <- ask - liftIO $ atomically $ updateItr itr itrResponse - $ \ res -> res { - resStatus = code - } - --- | 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 an action like 'setContentType' --- for every common headers. --- --- Some important headers (especially \"Content-Length\" and --- \"Transfer-Encoding\") may be silently deleted or overwritten by --- the system not to corrupt the interaction with client at the --- viewpoint of HTTP protocol. For instance, if we are keeping --- connection alive, for an obvious reason it causes a catastrophe to --- send header \"Content-Length: 10\" and actually sending body of 20 --- bytes long. -setHeader :: String -> String -> Resource () -setHeader name value - = driftTo DecidingHeader >> setHeader' name value - - -setHeader' :: String -> String -> Resource() -setHeader' name value - = do itr <- ask - liftIO $ atomically - $ updateItr itr itrResponse - $ H.setHeader name value - - -redirect :: StatusCode -> URI -> Resource () + = (map toPairWithFormData ∘ parseWWWFormURLEncoded) + <$> + (bsToAscii =≪ getChunks limit) + + bsToAscii bs + = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of + Just a → return a + 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 ("Attempted to redirect with status " ++ show code) + = do when (code ≡ NotModified ∨ not (isRedirection code)) + $ abort + $ mkAbortion' InternalServerError + $ A.toText + $ A.fromAsciiBuilder + $ A.toAsciiBuilder "Attempted to redirect with status " + ⊕ printStatusCode code setStatus code - setHeader "Location" (uriToString id uri $ "") - - -setContentType :: MIMEType -> Resource () -setContentType mType - = setHeader "Content-Type" $ show mType - - -{- DecidingBody 時に使用するアクション群 -} - -output :: String -> Resource () -output = outputBS . B.pack - - -outputBS :: ByteString -> Resource () -outputBS str = do outputChunkBS str - driftTo Done - - -outputChunk :: String -> Resource () -outputChunk = outputChunkBS . B.pack - - -{- チャンクの大きさは Config で制限されてゐる。もし例へば /dev/zero を - B.readFile して作った ByteString をそのまま ResponseWriter に渡した - りすると大變な事が起こる。何故なら ResponseWriter は - Transfer-Encoding: chunked の時、ヘッダを書く爲にチャンクの大きさを - 測るから、その時に起こるであらう事は言ふまでも無い。 -} - -outputChunkBS :: ByteString -> Resource () -outputChunkBS str - = do driftTo DecidingBody - itr <- ask - - let limit = cnfMaxOutputChunkLength $ itrConfig itr - when (limit <= 0) - $ fail ("cnfMaxOutputChunkLength must be positive: " - ++ show limit) - - discardBody <- liftIO $ atomically $ - readItr itr itrWillDiscardBody id - - unless (discardBody) - $ sendChunks str limit - - unless (B.null str) - $ liftIO $ atomically $ - writeItr itr itrBodyIsNull False + 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 + = 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 + = case A.fromChars uriStr of + Just a → setHeader "Location" a + Nothing → abort $ mkAbortion' InternalServerError + $ "Malformed URI: " ⊕ T.pack uriStr where - sendChunks :: ByteString -> Int -> Resource () - sendChunks str limit - | B.null str = return () - | otherwise = do let (chunk, remaining) = B.splitAt (fromIntegral limit) str - itr <- ask - liftIO $ atomically $ - do buf <- readItr itr itrBodyToSend id - if B.null buf then - -- バッファが消化された - writeItr itr itrBodyToSend chunk - else - -- 消化されるのを待つ - retry - -- 殘りのチャンクについて繰り返す - sendChunks remaining limit - -{- - - [GettingBody からそれ以降の状態に遷移する時] - - body を讀み終へてゐなければ、殘りの body を讀み捨てる。 - - - [DecidingHeader からそれ以降の状態に遷移する時] - - postprocess する。 - - - [Done に遷移する時] - - bodyIsNull が False ならば何もしない。True だった場合は出力補完す - る。 - --} - -driftTo :: InteractionState -> Resource () -driftTo newState - = do itr <- ask - liftIO $ atomically $ do oldState <- readItr itr itrState id - 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 - writeItr itr itrState newState + uriStr = uriToString id uri "" + +-- |@'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 $ mkAbortion' InternalServerError + "setContentEncoding: Unknown HTTP version" + setHeader "Content-Encoding" + $ A.fromAsciiBuilder + $ mconcat + $ intersperse (A.toAsciiBuilder ", ") + $ map tr codings 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) + toAB = A.toAsciiBuilder ∘ A.fromCIAscii +-- |@'setWWWAuthenticate' challenge@ declares the response header +-- \"WWW-Authenticate\" as @challenge@. +setWWWAuthenticate ∷ AuthChallenge → Resource () +setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge - drift :: Interaction -> InteractionState -> InteractionState -> STM () +-- |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 - drift itr GettingBody _ - = writeItr itr itrReqBodyWasteAll True - - drift itr DecidingHeader _ - = postprocess itr - - drift itr _ Done - = do bodyIsNull <- readItr itr itrBodyIsNull id - 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