X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=696abf1b1311e55c5f13f4eca54a45ea02ea0146;hb=1f0a19cbad7c4b64a773d7f1c1ae9180448624e6;hp=f1186b7170635c4a4d7181cf84da509b2b24e08a;hpb=1196f43ecedbb123515065f0440844864af906fb;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index f1186b7..696abf1 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,5 +1,10 @@ -{-# OPTIONS_HADDOCK prune #-} - +{-# LANGUAGE + GeneralizedNewtypeDeriving + , DoAndIfThenElse + , OverloadedStrings + , RecordWildCards + , UnicodeSyntax + #-} -- |This is the Resource Monad; monadic actions to define the behavior -- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO' -- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is @@ -57,22 +62,20 @@ -- 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 - , runRes -- private - - -- * Actions - - -- ** Getting request header + -- * Types + Resource + , FormData(..) + -- * Getting request header -- |These actions can be computed regardless of the current state, -- and they don't change the state. , getConfig , getRemoteAddr , getRemoteAddr' + , getRemoteHost + , getRemoteCertificate , getRequest , getMethod , getRequestURI @@ -87,8 +90,7 @@ module Network.HTTP.Lucu.Resource , getContentType , getAuthorization - -- ** Finding an entity - + -- * Finding an entity -- |These actions can be computed only in the /Examining Request/ -- state. After the computation, the 'Resource' transits to -- /Getting Body/ state. @@ -97,160 +99,132 @@ module Network.HTTP.Lucu.Resource , foundTimeStamp , foundNoEntity - -- ** Getting a request body - + -- * Getting a request body -- |Computation of these actions changes the state to /Getting -- Body/. - , input - , inputChunk - , inputLBS - , inputChunkLBS - , inputForm + , getChunk + , getChunks + , getForm , defaultLimit - -- ** Setting response headers - + -- * Setting response headers -- |Computation of these actions changes the state to /Deciding -- Header/. , setStatus - , setHeader , redirect , setContentType - , setLocation , setContentEncoding , setWWWAuthenticate - -- ** Writing a response body + -- ** Less frequently used functions + , setLocation + , setHeader + , deleteHeader + -- * Writing a response body -- |Computation of these actions changes the state to /Deciding -- Body/. - , output - , outputChunk - , outputLBS - , outputChunkLBS - - , driftTo + , putChunk + , putChunks + , putBuilder ) where - -import Control.Concurrent.STM -import Control.Monad.Reader -import Data.Bits -import qualified Data.ByteString as Strict (ByteString) -import qualified Data.ByteString.Lazy as Lazy (ByteString) -import qualified Data.ByteString.Char8 as C8 hiding (ByteString) -import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString) -import Data.Char -import Data.List -import Data.Maybe -import Data.Time -import Network.HTTP.Lucu.Abortion -import Network.HTTP.Lucu.Authorization -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.ContentCoding -import Network.HTTP.Lucu.DefaultPage -import Network.HTTP.Lucu.ETag +import Blaze.ByteString.Builder (Builder) +import qualified Blaze.ByteString.Builder.ByteString as BB +import Control.Applicative +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Unicode +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.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.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.MultipartForm -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.Socket hiding (accept) -import Network.URI hiding (path) - --- |The 'Resource' monad. This monad implements --- 'Control.Monad.Trans.MonadIO' so it can do any 'Prelude.IO' --- actions. -newtype Resource a = Resource { unRes :: ReaderT Interaction IO a } - -instance Functor Resource where - fmap f c = Resource (fmap f (unRes c)) - -instance Monad Resource where - c >>= f = Resource (unRes c >>= unRes . f) - return = Resource . return - fail = Resource . fail - -instance MonadIO Resource where - liftIO = Resource . liftIO - - -runRes :: Resource a -> Interaction -> IO a -runRes r itr - = runReaderT (unRes r) itr - - -getInteraction :: Resource Interaction -getInteraction = Resource ask - - --- |Get the 'Network.HTTP.Lucu.Config.Config' value which is used for --- the httpd. -getConfig :: Resource Config -getConfig = do itr <- getInteraction - return $! itrConfig itr - - --- |Get the 'Network.Socket.SockAddr' of the remote host. If you want --- a string representation instead of 'Network.Socket.SockAddr', use --- 'getRemoteAddr''. -getRemoteAddr :: Resource SockAddr -getRemoteAddr = do itr <- getInteraction - return $! itrRemoteAddr itr - +import Network.HTTP.Lucu.HttpVersion +import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.MultipartForm +import Network.HTTP.Lucu.Postprocess +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Resource.Internal +import Network.HTTP.Lucu.Response +import Network.HTTP.Lucu.MIMEType +import Network.HTTP.Lucu.Utils +import Network.Socket hiding (accept) +import Network.URI hiding (path) +import OpenSSL.X509 +import Prelude.Unicode + +-- |Get the 'Config' value which is used for the httpd. +getConfig ∷ Resource Config +getConfig = itrConfig <$> getInteraction + +-- |Get the 'SockAddr' of the remote host. If you want a string +-- representation instead of 'SockAddr', use 'getRemoteAddr''. +getRemoteAddr ∷ Resource SockAddr +getRemoteAddr = itrRemoteAddr <$> getInteraction -- |Get the string representation of the address of remote host. If --- you want a 'Network.Socket.SockAddr' instead of 'Prelude.String', --- use 'getRemoteAddr'. -getRemoteAddr' :: Resource String -getRemoteAddr' = do addr <- getRemoteAddr - case addr of - -- Network.Socket は IPv6 を考慮してゐないやうだ… - SockAddrInet _ v4addr - -> let b1 = (v4addr `shiftR` 24) .&. 0xFF - b2 = (v4addr `shiftR` 16) .&. 0xFF - b3 = (v4addr `shiftR` 8) .&. 0xFF - b4 = v4addr .&. 0xFF - in - return $ concat $ intersperse "." $ map show [b1, b2, b3, b4] - SockAddrUnix path - -> return path - _ - -> undefined - - --- |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 <- getInteraction - req <- liftIO $! atomically $! readItr itr itrRequest fromJust - return req - --- |Get the 'Network.HTTP.Lucu.Request.Method' value of the request. -getMethod :: Resource Method -getMethod = do req <- getRequest - return $! reqMethod req +-- you want a 'SockAddr' instead of 'String', use 'getRemoteAddr'. +getRemoteAddr' ∷ Resource HostName +getRemoteAddr' + = do sa ← getRemoteAddr + (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] True False sa + return a + +-- |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 '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 +getRequestURI ∷ Resource URI +getRequestURI = reqURI <$> getRequest -- |Get the HTTP version of the request. -getRequestVersion :: Resource HttpVersion -getRequestVersion = do req <- getRequest - return $! reqVersion req +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 +-- action is the exact path in the tree even when the -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy. -- -- Example: @@ -269,125 +243,154 @@ getRequestVersion = do req <- getRequest -- > ... -- > , ... -- > } -getResourcePath :: Resource [String] -getResourcePath = do itr <- getInteraction - 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 - uri <- getRequestURI - let reqPathStr = uriPath uri - reqPath = [x | x <- splitBy (== '/') reqPathStr, x /= ""] +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] +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. This action --- doesn't parse the request body. See 'inputForm'. -getQueryForm :: Resource [(String, String)] -getQueryForm = do uri <- getRequestURI - return $! parseWWWFormURLEncoded $ snd $ splitAt 1 $ uriQuery uri + 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)] +getQueryForm = parse' <$> getRequestURI + where + parse' = map toPairWithFormData ∘ + parseWWWFormURLEncoded ∘ + fromJust ∘ + A.fromChars ∘ + drop 1 ∘ + uriQuery + +toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData) +toPairWithFormData (name, value) + = let fd = FormData { + fdFileName = Nothing + , fdContent = Lazy.fromChunks [value] + } + in (T.decodeUtf8 name, fd) -- |Get a value of given request header. Comparison of header name is -- case-insensitive. Note that this action is not intended to be used -- so frequently: there should be actions like 'getContentType' for -- every common headers. -getHeader :: Strict.ByteString -> Resource (Maybe Strict.ByteString) -getHeader name = name `seq` - do req <- getRequest - return $! H.getHeader name req - --- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on --- header \"Accept\". -getAccept :: Resource [MIMEType] -getAccept = do acceptM <- getHeader (C8.pack "Accept") - case acceptM of - Nothing - -> return [] - Just accept - -> case parse mimeTypeListP (L8.fromChunks [accept]) of - (# Success xs, _ #) -> return xs - (# _ , _ #) -> abort BadRequest [] - (Just $ "Unparsable Accept: " ++ C8.unpack accept) +getHeader ∷ CIAscii → Resource (Maybe Ascii) +getHeader name + = H.getHeader name <$> getRequest + +-- |Get a list of 'MIMEType' enumerated on header \"Accept\". +getAccept ∷ Resource [MIMEType] +getAccept + = do acceptM ← getHeader "Accept" + case acceptM of + Nothing + → return [] + Just accept + → case P.parseOnly p (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 -- |Get a list of @(contentCoding, qvalue)@ enumerated on header -- \"Accept-Encoding\". The list is sorted in descending order by -- qvalue. -getAcceptEncoding :: Resource [(String, Maybe Double)] +getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)] getAcceptEncoding - = do accEncM <- getHeader (C8.pack "Accept-Encoding") + = 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)] - _ -> undefined - Just value - -> if C8.null value then + → do ver ← getRequestVersion + case ver of + HttpVersion 1 0 → return [("identity", Nothing)] + HttpVersion 1 1 → return [("*" , Nothing)] + _ → abort InternalServerError [] + (Just "getAcceptEncoding: unknown HTTP version") + Just ae + → if ae ≡ "" then -- identity のみが許される。 return [("identity", Nothing)] else - case parse acceptEncodingListP (L8.fromChunks [value]) of - (# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x - (# _ , _ #) -> abort BadRequest [] - (Just $ "Unparsable Accept-Encoding: " ++ C8.unpack value) + case P.parseOnly p (A.toByteString ae) of + Right xs → return $ map toTuple $ reverse $ sort xs + Left _ → abort BadRequest [] + (Just $ "Unparsable Accept-Encoding: " ⊕ A.toText ae) + where + p = do xs ← acceptEncodingListP + P.endOfInput + return xs --- |Check whether a given content-coding is acceptable. -isEncodingAcceptable :: String -> Resource Bool -isEncodingAcceptable coding - = do accList <- getAcceptEncoding - return (flip any accList $ \ (c, q) -> - (c == "*" || C8.pack c `H.noCaseEq` C8.pack coding) && q /= Just 0) + toTuple (AcceptEncoding {..}) + = (aeEncoding, aeQValue) +-- |Check whether a given content-coding is acceptable. +isEncodingAcceptable ∷ CIAscii → Resource Bool +isEncodingAcceptable encoding = any f <$> getAcceptEncoding + where + f (e, q) + = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0 --- |Get the header \"Content-Type\" as --- 'Network.HTTP.Lucu.MIMEType.MIMEType'. -getContentType :: Resource (Maybe MIMEType) +-- |Get the header \"Content-Type\" as 'MIMEType'. +getContentType ∷ Resource (Maybe MIMEType) getContentType - = do cTypeM <- getHeader (C8.pack "Content-Type") + = do cTypeM ← getHeader "Content-Type" case cTypeM of Nothing - -> return Nothing + → return Nothing Just cType - -> case parse mimeTypeP (L8.fromChunks [cType]) of - (# Success t, _ #) -> return $ Just t - (# _ , _ #) -> abort BadRequest [] - (Just $ "Unparsable Content-Type: " ++ C8.unpack cType) - + → case P.parseOnly p (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 --- |Get the header \"Authorization\" as --- 'Network.HTTP.Lucu.Authorization.AuthCredential'. -getAuthorization :: Resource (Maybe AuthCredential) +-- |Get the header \"Authorization\" as 'AuthCredential'. +getAuthorization ∷ Resource (Maybe AuthCredential) getAuthorization - = do authM <- getHeader (C8.pack "Authorization") + = do authM ← getHeader "Authorization" case authM of Nothing - -> return Nothing + → return Nothing Just auth - -> case parse authCredentialP (L8.fromChunks [auth]) of - (# Success a, _ #) -> return $ Just a - (# _ , _ #) -> return Nothing + → case P.parseOnly p (A.toByteString auth) of + Right ac → return $ Just ac + Left _ → return Nothing + where + p = do ac ← authCredentialP + P.endOfInput + return ac -{- ExaminingRequest 時に使用するアクション群 -} +-- Finding an entity -- |Tell the system that the 'Resource' found an entity for the -- request URI. If this is a GET or HEAD request, a found entity means -- a datum to be replied. If this is a PUT or DELETE request, it means --- a datum which was stored for the URI up to now. It is an error to +-- a datum which was stored for the URI until now. It is an error to -- compute 'foundEntity' if this is a POST request. -- -- Computation of 'foundEntity' performs \"If-Match\" test or @@ -398,17 +401,16 @@ getAuthorization -- -- If this is a GET or HEAD request, 'foundEntity' automatically puts -- \"ETag\" and \"Last-Modified\" headers into the response. -foundEntity :: ETag -> UTCTime -> Resource () +foundEntity ∷ ETag → UTCTime → Resource () foundEntity tag timeStamp - = tag `seq` timeStamp `seq` - do driftTo ExaminingRequest - - method <- getMethod - when (method == GET || method == HEAD) - $ setHeader' (C8.pack "Last-Modified") (C8.pack $ formatHTTPDateTime timeStamp) - when (method == POST) - $ abort InternalServerError [] - (Just "Illegal computation of foundEntity for POST request.") + = do driftTo ExaminingRequest + + method ← getMethod + when (method ≡ GET ∨ method ≡ HEAD) + $ setHeader' "Last-Modified" (HTTP.toAscii timeStamp) + when (method ≡ POST) + $ abort InternalServerError [] + (Just "Illegal computation of foundEntity for a POST request.") foundETag tag driftTo GettingBody @@ -420,55 +422,63 @@ foundEntity tag timeStamp -- -- This action is not preferred. You should use 'foundEntity' whenever -- possible. -foundETag :: ETag -> Resource () +foundETag ∷ ETag → Resource () foundETag tag - = tag `seq` - do driftTo ExaminingRequest + = do driftTo ExaminingRequest - method <- getMethod - when (method == GET || method == HEAD) - $ setHeader' (C8.pack "ETag") (C8.pack $ 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 InternalServerError [] + (Just "Illegal computation of foundETag for POST request.") -- If-Match があればそれを見る。 - ifMatch <- getHeader (C8.pack "If-Match") + ifMatch ← getHeader "If-Match" case ifMatch of - Nothing -> return () - Just value -> if value == C8.pack "*" then - return () - else - case parse eTagListP (L8.fromChunks [value]) of - (# Success tags, _ #) + Nothing → return () + Just value → if value ≡ "*" then + return () + else + case P.parseOnly p (A.toByteString value) of + Right tags -- tags の中に一致するものが無ければ -- PreconditionFailed で終了。 - -> when (not $ any (== tag) tags) - $ abort PreconditionFailed [] - $! Just ("The entity tag doesn't match: " ++ C8.unpack value) - (# _, _ #) - -> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ C8.unpack value) - - let statusForNoneMatch = if method == GET || method == HEAD then - NotModified - else - 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) + + let statusForNoneMatch + = if method ≡ GET ∨ method ≡ HEAD then + NotModified + else + PreconditionFailed -- If-None-Match があればそれを見る。 - ifNoneMatch <- getHeader (C8.pack "If-None-Match") + ifNoneMatch ← getHeader "If-None-Match" case ifNoneMatch of - Nothing -> return () - Just value -> if value == C8.pack "*" then - abort statusForNoneMatch [] $! Just ("The entity tag matches: *") + Nothing → return () + Just value → if value ≡ "*" then + abort statusForNoneMatch [] (Just "The entity tag matches: *") else - case parse eTagListP (L8.fromChunks [value]) of - (# Success tags, _ #) - -> when (any (== tag) tags) - $ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ C8.unpack value) - (# _, _ #) - -> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ C8.unpack value) + 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 -- |Tell the system that the 'Resource' found an entity for the -- request URI. The only difference from 'foundEntity' is that @@ -480,46 +490,46 @@ foundETag tag -- -- This action is not preferred. You should use 'foundEntity' whenever -- possible. -foundTimeStamp :: UTCTime -> Resource () +foundTimeStamp ∷ UTCTime → Resource () foundTimeStamp timeStamp - = timeStamp `seq` - do driftTo ExaminingRequest + = do driftTo ExaminingRequest - method <- getMethod - when (method == GET || method == HEAD) - $ setHeader' (C8.pack "Last-Modified") (C8.pack $ 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 InternalServerError [] + (Just "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 (C8.pack "If-Modified-Since") + ifModSince ← getHeader "If-Modified-Since" case ifModSince of - Just str -> case parseHTTPDateTime (L8.fromChunks [str]) of - Just lastTime - -> when (timeStamp <= lastTime) - $ abort statusForIfModSince [] - $! Just ("The entity has not been modified since " ++ C8.unpack str) - Nothing - -> return () -- 不正な時刻は無視 - Nothing -> return () + 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) + Left _ + → return () -- 不正な時刻は無視 + Nothing → return () -- If-Unmodified-Since があればそれを見る。 - ifUnmodSince <- getHeader (C8.pack "If-Unmodified-Since") + ifUnmodSince ← getHeader "If-Unmodified-Since" case ifUnmodSince of - Just str -> case parseHTTPDateTime (L8.fromChunks [str]) of - Just lastTime - -> when (timeStamp > lastTime) - $ abort PreconditionFailed [] - $! Just ("The entity has not been modified since " ++ C8.unpack str) - Nothing - -> return () -- 不正な時刻は無視 - Nothing -> return () + 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) + Left _ + → return () -- 不正な時刻は無視 + Nothing → return () driftTo GettingBody @@ -531,25 +541,24 @@ foundTimeStamp timeStamp -- test and aborts with status \"412 Precondition Failed\" when it -- failed. If this is a GET, HEAD, POST or DELETE request, -- 'foundNoEntity' always aborts with status \"404 Not Found\". -foundNoEntity :: Maybe String -> Resource () +foundNoEntity ∷ Maybe Text → Resource () foundNoEntity msgM - = msgM `seq` - do driftTo ExaminingRequest + = do driftTo ExaminingRequest - method <- getMethod - when (method /= PUT) - $ abort NotFound [] msgM + method ← getMethod + when (method ≢ PUT) + $ abort NotFound [] msgM -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな -- If-Match: 條件も滿たさない。 - ifMatch <- getHeader (C8.pack "If-Match") - when (ifMatch /= Nothing) - $ abort PreconditionFailed [] msgM + ifMatch ← getHeader "If-Match" + when (ifMatch ≢ Nothing) + $ abort PreconditionFailed [] msgM driftTo GettingBody -{- GettingBody 時に使用するアクション群 -} +-- Getting a request body -- | Computation of @'input' limit@ attempts to read the request body -- up to @limit@ bytes, and then make the 'Resource' transit to @@ -559,82 +568,68 @@ foundNoEntity msgM -- no body, 'input' returns an empty string. -- -- @limit@ may be less than or equal to zero. In this case, the --- default limitation value --- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See +-- default limitation value ('cnfMaxEntityLength') is used. See -- 'defaultLimit'. -- --- Note that 'inputLBS' is more efficient than 'input' so you should --- use it whenever possible. -input :: Int -> Resource String -input limit = limit `seq` - inputLBS limit >>= return . L8.unpack - - --- | This is mostly the same as 'input' but is more --- efficient. 'inputLBS' returns a 'Data.ByteString.Lazy.ByteString' --- but it's not really lazy: reading from the socket just happens at --- the computation of 'inputLBS', not at the evaluation of the --- 'Data.ByteString.Lazy.ByteString'. The same goes for --- 'inputChunkLBS'. -inputLBS :: Int -> Resource Lazy.ByteString -inputLBS limit - = limit `seq` - do driftTo GettingBody - itr <- getInteraction - hasBody <- liftIO $! atomically $! readItr itr itrRequestHasBody id - chunk <- if hasBody then - askForInput itr - else - do driftTo DecidingHeader - return L8.empty +-- 'input' returns a 'Lazy.ByteString' but it's not really lazy: +-- reading from the socket just happens at the computation of 'input', +-- not at the evaluation of the 'Lazy.ByteString'. The same goes for +-- 'inputChunk'. +input ∷ Int → Resource Lazy.ByteString +input limit + = do driftTo GettingBody + itr ← getInteraction + chunk ← if reqMustHaveBody $ fromJust $ itrRequest itr then + askForInput itr + else + do driftTo DecidingHeader + return (∅) return chunk where - askForInput :: Interaction -> Resource Lazy.ByteString - askForInput itr - = itr `seq` - do let confLimit = cnfMaxEntityLength $ itrConfig itr - actualLimit = if limit <= 0 then + 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) + when (actualLimit ≤ 0) + $ fail ("inputLBS: 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 L8.length chunk < fromIntegral actualLimit then - -- 要求された量に滿たなくて、まだ殘り - -- があるなら再試行。 - unless chunkIsOver - $ retry - else - -- 制限値一杯まで讀むやうに指示したの - -- にまだ殘ってゐるなら、それは多過ぎ - -- る。 - unless chunkIsOver - $ tooLarge actualLimit - -- 成功。itr 内にチャンクを置いたままにす - -- るとメモリの無駄になるので除去。 - writeItr itr itrReceivedBody L8.empty - return chunk + liftIO $ atomically + $ writeTVar itrReqBodyWanted actualLimit + -- 應答を待つ。トランザクションを分けなければ當然デッドロックする。 + chunk ← liftIO $ atomically + $ do chunkLen ← readTVar itrReceivedBodyLen + chunkIsOver ← readTVar itrReqChunkIsOver + if chunkLen < actualLimit then + -- 要求された量に滿たなくて、まだ殘りが + -- あるなら再試行。 + unless chunkIsOver + $ retry + else + -- 制限値一杯まで讀むやうに指示したのに + -- まだ殘ってゐるなら、それは多過ぎる。 + unless chunkIsOver + $ tooLarge actualLimit + -- 成功。itr 内にチャンクを置いたままにする + -- とメモリの無駄になるので除去。 + chunk ← seqToLBS <$> readTVar itrReceivedBody + writeTVar itrReceivedBody (∅) + writeTVar itrReceivedBodyLen 0 + return chunk + driftTo DecidingHeader return chunk - tooLarge :: Int -> STM () - tooLarge lim = lim `seq` - abortSTM RequestEntityTooLarge [] - $! Just ("Request body must be smaller than " - ++ show lim ++ " bytes.") + 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 @@ -643,320 +638,182 @@ inputLBS limit -- the 'Resource' transit to /Deciding Header/ state. -- -- @limit@ may be less than or equal to zero. In this case, the --- default limitation value --- ('Network.HTTP.Lucu.Config.cnfMaxEntityLength') is used. See +-- default limitation value ('cnfMaxEntityLength') is used. See -- 'defaultLimit'. -- -- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you -- should use it whenever possible. -inputChunk :: Int -> Resource String -inputChunk limit = limit `seq` - inputChunkLBS limit >>= return . L8.unpack - - --- | This is mostly the same as 'inputChunk' but is more --- efficient. See 'inputLBS'. -inputChunkLBS :: Int -> Resource Lazy.ByteString -inputChunkLBS limit - = limit `seq` - do driftTo GettingBody - itr <- getInteraction - hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id - chunk <- if hasBody then - askForInput itr - else - do driftTo DecidingHeader - return L8.empty +inputChunk ∷ Int → Resource Lazy.ByteString +inputChunk limit + = do driftTo GettingBody + itr ← getInteraction + chunk ← if reqMustHaveBody $ fromJust $ itrRequest itr then + askForInput itr + else + do driftTo DecidingHeader + return (∅) return chunk where - askForInput :: Interaction -> Resource Lazy.ByteString - askForInput itr - = itr `seq` - do let confLimit = cnfMaxEntityLength $! itrConfig itr + askForInput ∷ Interaction → Resource Lazy.ByteString + askForInput (Interaction {..}) + = do let confLimit = cnfMaxEntityLength itrConfig actualLimit = if limit < 0 then - confLimit - else - limit - when (actualLimit <= 0) + confLimit + else + limit + when (actualLimit ≤ 0) $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit) -- Reader にリクエスト - liftIO $! atomically - $! do writeItr itr itrReqBodyWanted $! Just actualLimit - writeItr itr itrWillReceiveBody True + liftIO $ atomically + $ writeTVar itrReqBodyWanted actualLimit -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 - chunk <- liftIO $! atomically - $ do chunk <- readItr itr itrReceivedBody id - -- 要求された量に滿たなくて、まだ殘りがあ - -- るなら再試行。 - when (L8.length chunk < fromIntegral actualLimit) - $ do chunkIsOver <- readItr itr itrReqChunkIsOver id - unless chunkIsOver - $ retry - -- 成功 - writeItr itr itrReceivedBody L8.empty - return chunk - when (L8.null chunk) - $ driftTo DecidingHeader + 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' +-- @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\". -inputForm :: Int -> Resource [(String, String)] +-- +-- 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 - = limit `seq` - do cTypeM <- getContentType + = do cTypeM ← getContentType case cTypeM of Nothing - -> abort BadRequest [] (Just "Missing Content-Type") + → abort BadRequest [] (Just "Missing Content-Type") Just (MIMEType "application" "x-www-form-urlencoded" _) - -> readWWWFormURLEncoded + → readWWWFormURLEncoded Just (MIMEType "multipart" "form-data" params) - -> readMultipartFormData params + → readMultipartFormData params Just cType - -> abort UnsupportedMediaType [] (Just $! "Unsupported media type: " - ++ show cType) + → abort UnsupportedMediaType [] + $ Just + $ A.toText + $ A.fromAsciiBuilder + $ A.toAsciiBuilder "Unsupported media type: " + ⊕ printMIMEType cType where readWWWFormURLEncoded - = do src <- input limit - return $ parseWWWFormURLEncoded src + = (map toPairWithFormData ∘ parseWWWFormURLEncoded) + <$> + (bsToAscii =≪ input 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 find ((== "boundary") . map toLower . fst) params of + = do case M.lookup "boundary" params of Nothing - -> abort BadRequest [] (Just "Missing boundary of multipart/form-data") - Just (_, boundary) - -> do src <- inputLBS limit - case parse (multipartFormP boundary) src of - (# Success pairs, _ #) -> return pairs - (# _, _ #) - -> abort BadRequest [] (Just "Unparsable multipart/form-data") + → 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 ∷ 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 code - = code `seq` - do driftTo DecidingHeader - itr <- getInteraction - 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 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 :: Strict.ByteString -> Strict.ByteString -> Resource () -setHeader name value - = name `seq` value `seq` - driftTo DecidingHeader >> setHeader' name value - - -setHeader' :: Strict.ByteString -> Strict.ByteString -> Resource () -setHeader' name value - = name `seq` value `seq` - do itr <- getInteraction - liftIO $ atomically - $ updateItr itr itrResponse - $ H.setHeader name value +-- Setting response headers -- | Computation of @'redirect' code uri@ sets the response status to -- @code@ and \"Location\" header to @uri@. The @code@ must satisfy --- 'Network.HTTP.Lucu.Response.isRedirection' or it causes an error. -redirect :: StatusCode -> URI -> Resource () +-- 'isRedirection' or it causes an error. +redirect ∷ StatusCode → URI → Resource () redirect code uri - = code `seq` uri `seq` - 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 InternalServerError [] + $ Just + $ A.toText + $ A.fromAsciiBuilder + $ A.toAsciiBuilder "Attempted to redirect with status " + ⊕ printStatusCode code setStatus code setLocation uri -{-# INLINE redirect #-} - -- | Computation of @'setContentType' mType@ sets the response header -- \"Content-Type\" to @mType@. -setContentType :: MIMEType -> Resource () -setContentType mType - = setHeader (C8.pack "Content-Type") (C8.pack $ show mType) +setContentType ∷ MIMEType → Resource () +setContentType + = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType -- | Computation of @'setLocation' uri@ sets the response header --- \"Location\" to @uri@. -setLocation :: URI -> Resource () +-- \"Location\" to @uri@. You usually don't need to call this function +-- directly. +setLocation ∷ URI → Resource () setLocation uri - = setHeader (C8.pack "Location") (C8.pack $ uriToString id uri $ "") + = case A.fromChars uriStr of + Just a → setHeader "Location" a + Nothing → abort InternalServerError [] + (Just $ "Malformed URI: " ⊕ T.pack uriStr) + where + uriStr = uriToString id uri "" -- |Computation of @'setContentEncoding' codings@ sets the response -- header \"Content-Encoding\" to @codings@. -setContentEncoding :: [String] -> Resource () +setContentEncoding ∷ [CIAscii] → Resource () setContentEncoding codings - = do ver <- getRequestVersion - let tr = case ver of - HttpVersion 1 0 -> unnormalizeCoding - HttpVersion 1 1 -> id - _ -> undefined - setHeader (C8.pack "Content-Encoding") (C8.pack $ joinWith ", " $ map tr 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") + setHeader "Content-Encoding" + (A.fromAsciiBuilder $ joinWith ", " $ map tr codings) + where + toAB = A.toAsciiBuilder ∘ A.fromCIAscii -- |Computation of @'setWWWAuthenticate' challenge@ sets the response -- header \"WWW-Authenticate\" to @challenge@. -setWWWAuthenticate :: AuthChallenge -> Resource () +setWWWAuthenticate ∷ AuthChallenge → Resource () setWWWAuthenticate challenge - = setHeader (C8.pack "WWW-Authenticate") (C8.pack $ show challenge) + = setHeader "WWW-Authenticate" (printAuthChallenge challenge) -{- DecidingBody 時に使用するアクション群 -} +-- Writing a response body --- | Computation of @'output' str@ writes @str@ as a response body, --- and then make the 'Resource' transit to /Done/ state. It is safe to --- apply 'output' to an infinite string, such as a lazy stream of --- \/dev\/random. --- --- Note that 'outputLBS' is more efficient than 'output' so you should --- use it whenever possible. -output :: String -> Resource () -output str = outputLBS $! L8.pack str -{-# INLINE output #-} - --- | This is mostly the same as 'output' but is more efficient. -outputLBS :: Lazy.ByteString -> Resource () -outputLBS str = do outputChunkLBS str - driftTo Done -{-# INLINE outputLBS #-} - --- | Computation of @'outputChunk' str@ writes @str@ as a part of --- response body. You can compute this action multiple times to write --- a body little at a time. It is safe to apply 'outputChunk' to an --- infinite string. +-- | Write a chunk in 'Lazy.ByteString' to the response body. It is +-- safe to apply this function to an infinitely long +-- 'Lazy.ByteString'. -- --- Note that 'outputChunkLBS' is more efficient than 'outputChunk' so --- you should use it whenever possible. -outputChunk :: String -> Resource () -outputChunk str = outputChunkLBS $! L8.pack str -{-# INLINE outputChunk #-} - --- | This is mostly the same as 'outputChunk' but is more efficient. -outputChunkLBS :: Lazy.ByteString -> Resource () -outputChunkLBS wholeChunk - = wholeChunk `seq` - do driftTo DecidingBody - itr <- getInteraction - - 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 wholeChunk limit - - unless (L8.null wholeChunk) - $ liftIO $ atomically $ - writeItr itr itrBodyIsNull False - where - -- チャンクの大きさは Config で制限されてゐる。もし例へば - -- "/dev/zero" を L8.readFile して作った Lazy.ByteString をそのまま - -- ResponseWriter に渡したりすると大變な事が起こる。何故なら - -- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書 - -- く爲にチャンクの大きさを測る。 - sendChunks :: Lazy.ByteString -> Int -> Resource () - sendChunks str limit - | L8.null str = return () - | otherwise = do let (chunk, remaining) = L8.splitAt (fromIntegral limit) str - itr <- getInteraction - liftIO $ atomically $ - do buf <- readItr itr itrBodyToSend id - if L8.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 - = newState `seq` - do itr <- getInteraction - 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 - 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 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 () +-- Note that you must first set the response header \"Content-Type\" +-- before applying this function. See: 'setContentType' +putChunk ∷ Lazy.ByteString → Resource () +putChunk = putBuilder ∘ BB.fromLazyByteString