X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource.hs;h=01b61813971e9e1ce4ba80e18ed374e400a5ce5a;hb=ea2b7838f1b3d9d4923a220a601be2e04cc559d7;hp=883cc149188a404f2007425cf88d6bcfc8a2b1d8;hpb=1000bdc46cfe7b3ae550ff24ccea9f440f11b42a;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 883cc14..01b6181 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,551 +1,913 @@ +{-# 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 +-- also a state machine. +-- +-- Request Processing Flow: +-- +-- 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. +-- +-- 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 +-- 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. +-- +-- 'Resource' 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 +-- 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. +-- +-- [/Getting Body/] A 'Resource' asks the system to receive a +-- request body from 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. +-- +-- [/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 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. +-- +-- [/Done/] Everything is over. A 'Resource' 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' +-- computation. + module Network.HTTP.Lucu.Resource - ( ResourceDef(..) - , Resource - , ResTree - , mkResTree -- [ ([String], ResourceDef) ] -> ResTree - , findResource -- ResTree -> URI -> Maybe ResourceDef - , runResource -- ResourceDef -> Interaction -> IO ThreadId - - , getMethod -- Resource Method - , getHeader -- String -> Resource (Maybe String) - - , foundEntity -- Bool -> String -> ClockTime -> Resource () - , foundETag -- Bool -> String -> Resource () - , foundTimeStamp -- ClockTime -> Resource () - , foundNoEntity -- Maybe String -> Resource () - - , input -- Int -> Resource String - , inputChunk -- Int -> Resource String - , inputBS -- Int -> Resource ByteString - , inputChunkBS -- Int -> Resource ByteString - , defaultLimit -- Int - - , setStatus -- StatusCode -> Resource () - , setHeader -- String -> String -> Resource () - , redirect -- StatusCode -> URI -> Resource () - , setETag -- Bool -> String -> Resource () - , setLastModified -- ClockTime -> Resource () - - , output -- String -> Resource () - , outputChunk -- String -> Resource () - , outputBS -- ByteString -> Resource () - , outputChunkBS -- ByteString -> Resource () + ( + -- * Types + Resource + , FormData(..) + , runRes + + -- * Actions + + -- ** 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 + , 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. + , foundEntity + , foundETag + , foundTimeStamp + , foundNoEntity + + -- ** Getting a request body + + -- |Computation of these actions changes the state to /Getting + -- Body/. + , input + , inputChunk + , inputForm + , defaultLimit + + -- ** Setting response headers + + -- |Computation of these actions changes the state to /Deciding + -- Header/. + , setStatus + , setHeader + , redirect + , setContentType + , setLocation + , setContentEncoding + , setWWWAuthenticate + + -- ** Writing a response body + + -- |Computation of these actions changes the state to /Deciding + -- Body/. + , output + , outputChunk + + , driftTo -- private ) where - -import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception -import Control.Monad.Reader -import qualified Data.ByteString.Lazy.Char8 as B -import Data.ByteString.Lazy.Char8 (ByteString) -import Data.Dynamic -import Data.List +import Blaze.ByteString.Builder (Builder) +import qualified Blaze.ByteString.Builder.ByteString as BB +import Control.Applicative +import Control.Concurrent.STM +import Control.Monad.Reader +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.Map (Map) -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 Data.Maybe +import Data.Monoid +import Data.Monoid.Unicode +import Data.Sequence (Seq) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time +import qualified Data.Time.HTTP as HTTP +import Network.HTTP.Lucu.Abortion +import Network.HTTP.Lucu.Authorization +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.ContentCoding +import Network.HTTP.Lucu.DefaultPage +import Network.HTTP.Lucu.ETag import qualified Network.HTTP.Lucu.Headers as H -import Network.HTTP.Lucu.HttpVersion -import Network.HTTP.Lucu.Interaction -import Network.HTTP.Lucu.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.Utils -import Network.URI -import Prelude hiding (catch) -import System.IO -import System.IO.Error hiding (catch) -import System.Time - - -type Resource a = ReaderT Interaction IO a - - -{- /aaa/bbb/ccc にアクセスされた時、もし /aaa/bbb に貪欲なリソースがあ - れば、假に /aaa/bbb/ccc に何らかのリソースがあったとしても必ず - /aaa/bbb が撰ばれる。/aaa/bbb のリソースが貪欲でなければ、それは無視 - される。 -} -data ResourceDef = ResourceDef { - resUsesNativeThread :: Bool - , resIsGreedy :: Bool - , resGet :: Maybe (Resource ()) - , resHead :: Maybe (Resource ()) - , resPost :: Maybe (Resource ()) - , resPut :: Maybe (Resource ()) - , resDelete :: Maybe (Resource ()) - } -type ResTree = ResNode -- root だから Map ではない -type ResSubtree = Map String ResNode -data ResNode = ResNode (Maybe ResourceDef) ResSubtree - - -mkResTree :: [ ([String], ResourceDef) ] -> ResTree -mkResTree list = processRoot list +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.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 + +-- |The 'Resource' monad. This monad implements 'MonadIO' so it can do +-- any 'IO' actions. +newtype Resource a + = Resource { + unRes ∷ ReaderT Interaction IO a + } + deriving (Applicative, Functor, Monad, MonadIO) + +runRes ∷ Resource a → Interaction → IO a +runRes r itr + = runReaderT (unRes r) itr + +getInteraction ∷ Resource Interaction +getInteraction = Resource ask + +-- |Get the 'Config' value which is used for the httpd. +getConfig ∷ Resource Config +getConfig = itrConfig <$> getInteraction + +-- |Get the 'SockAddr' of the remote host. If you want a string +-- representation instead of 'SockAddr', use 'getRemoteAddr''. +getRemoteAddr ∷ Resource SockAddr +getRemoteAddr = itrRemoteAddr <$> getInteraction + +-- |Get the string representation of the address of remote host. If +-- you want a 'SockAddr' instead of 'String', use 'getRemoteAddr'. +getRemoteAddr' ∷ Resource HostName +getRemoteAddr' + = do sa ← getRemoteAddr + (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] False 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 'Request' value which represents the request header. In +-- general you don't have to use this action. +getRequest ∷ Resource Request +getRequest = (fromJust ∘ itrRequest) <$> getInteraction + +-- |Get the 'Method' value of the request. +getMethod ∷ Resource Method +getMethod = reqMethod <$> getRequest + +-- |Get the URI of the request. +getRequestURI ∷ Resource URI +getRequestURI = reqURI <$> getRequest + +-- |Get the HTTP version of the request. +getRequestVersion ∷ Resource HttpVersion +getRequestVersion = reqVersion <$> getRequest + +-- |Get the path of this 'Resource' (to be exact, +-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the +-- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this +-- action is the exact path in the tree even if the +-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy. +-- +-- Example: +-- +-- > main = let tree = mkResTree [ (["foo"], resFoo) ] +-- > in runHttpd defaultConfig tree +-- > +-- > resFoo = ResourceDef { +-- > resIsGreedy = True +-- > , resGet = Just $ do requestURI ← getRequestURI +-- > resourcePath ← getResourcePath +-- > pathInfo ← getPathInfo +-- > -- uriPath requestURI == "/foo/bar/baz" +-- > -- resourcePath == ["foo"] +-- > -- pathInfo == ["bar", "baz"] +-- > ... +-- > , ... +-- > } +getResourcePath ∷ Resource [Text] +getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction + +-- |This is an analogy of CGI PATH_INFO. The result is +-- URI-unescaped. It is always @[]@ if the +-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See +-- 'getResourcePath'. +-- +-- Note that the returned path is URI-decoded and then UTF-8 decoded. +getPathInfo ∷ Resource [Text] +getPathInfo = do rsrcPath ← getResourcePath + reqPath ← splitPathInfo <$> getRequestURI + -- rsrcPath と reqPath の共通する先頭部分を reqPath か + -- ら全部取り除くと、それは PATH_INFO のやうなものにな + -- る。rsrcPath は全部一致してゐるに決まってゐる（でな + -- ければこの Resource が撰ばれた筈が無い）ので、 + -- rsrcPath の長さの分だけ削除すれば良い。 + return $ drop (length rsrcPath) reqPath + +-- |Assume the query part of request URI as +-- application\/x-www-form-urlencoded, and parse it to pairs of +-- @(name, formData)@. This action doesn't parse the request body. See +-- 'inputForm'. Field names are decoded in UTF-8. +getQueryForm ∷ Resource [(Text, FormData)] +getQueryForm = parse' <$> getRequestURI where - processRoot :: [ ([String], ResourceDef) ] -> ResTree - processRoot list - = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list - children = processNonRoot nonRoots - in - if null roots then - -- / にリソースが定義されない。/foo とかにはあるかも。 - ResNode Nothing children - else - -- / がある。 - let (_, def) = last roots - in - ResNode (Just def) children - - processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree - processNonRoot list - = let subtree = M.fromList [(name, node name) - | name <- childNames] - childNames = [name | (name:_, _) <- list] - node name = let defs = [def | (path, def) <- list, path == [name]] - in - if null defs then - -- この位置にリソースが定義されない。 - -- もっと下にはあるかも。 - ResNode Nothing children - else - -- この位置にリソースがある。 - ResNode (Just $ last defs) children - children = processNonRoot [(path, def) - | (_:path, def) <- list, not (null path)] - in - subtree - - -findResource :: ResTree -> URI -> Maybe ResourceDef -findResource (ResNode rootDefM subtree) uri - = let pathStr = uriPath uri - path = [x | x <- splitBy (== '/') pathStr, x /= ""] - in - if null path then - rootDefM - else - walkTree subtree path + 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 ∷ 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 - walkTree :: ResSubtree -> [String] -> Maybe ResourceDef - - walkTree subtree (name:[]) - = case M.lookup name subtree of - Nothing -> Nothing - Just (ResNode defM _) -> defM - - walkTree subtree (x:xs) - = case M.lookup x subtree of - Nothing -> Nothing - Just (ResNode defM children) -> case defM of - Just (ResourceDef { resIsGreedy = True }) - -> defM - _ -> walkTree children xs - - -runResource :: ResourceDef -> Interaction -> IO ThreadId -runResource def itr - = fork - $ catch ( runReaderT ( do fromMaybe notAllowed rsrc - driftTo Done - ) itr - ) - $ \ exc -> processException (itrConfig itr) exc + 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 [(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 InternalServerError [] + (Just "getAcceptEncoding: unknown HTTP version") + Just ae + → if ae ≡ "" then + -- identity のみが許される。 + return [("identity", Nothing)] + else + case P.parseOnly p (A.toByteString ae) of + Right xs → return $ map toTuple $ reverse $ sort xs + Left _ → abort BadRequest [] + (Just $ "Unparsable Accept-Encoding: " ⊕ A.toText ae) where - fork :: IO () -> IO ThreadId - fork = if (resUsesNativeThread def) - then forkOS - else forkIO - - rsrc :: Maybe (Resource ()) - rsrc = case reqMethod $ fromJust $ itrRequest itr of - GET -> resGet def - HEAD -> case resHead def of - Just r -> Just r - Nothing -> resGet def - POST -> resPost def - PUT -> resPut def - DELETE -> resDelete def - - notAllowed :: Resource () - notAllowed = do setStatus MethodNotAllowed - setHeader "Allow" $ joinWith ", " allowedMethods - - allowedMethods :: [String] - allowedMethods = nub $ foldr (++) [] [ methods resGet ["GET"] - , methods resHead ["GET", "HEAD"] - , methods resPost ["POST"] - , methods resPut ["PUT"] - , methods resDelete ["DELETE"] - ] - - methods :: (ResourceDef -> Maybe a) -> [String] -> [String] - methods f xs = case f def of - Just _ -> xs - Nothing -> [] - - processException :: Config -> Exception -> IO () - processException conf exc - = do let abo = case exc of - ErrorCall msg -> Abortion InternalServerError [] msg - IOException ioE -> Abortion InternalServerError [] $ formatIOE ioE - DynException dynE -> case fromDynamic dynE of - Just (abo :: Abortion) -> abo - Nothing - -> Abortion InternalServerError [] - $ show exc - _ -> Abortion InternalServerError [] $ show exc - -- まだ DecidingHeader 以前の状態だったら、この途中終了 - -- を應答に反映させる餘地がある。さうでなければ stderr - -- にでも吐くしか無い。 - state <- atomically $ readItr itr itrState id - if state <= DecidingHeader then - flip runReaderT itr - $ do setStatus $ aboStatus abo - -- FIXME: 同じ名前で複數の値があった時は、こ - -- れではまずいと思ふ。 - mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo - setHeader "Content-Type" "application/xhtml+xml" - output $ aboPage conf abo - else - hPutStrLn stderr $ show abo - - flip runReaderT itr $ driftTo Done - - formatIOE :: IOError -> String - formatIOE ioE = if isUserError ioE then - ioeGetErrorString ioE - else - show ioE - - -getMethod :: Resource Method -getMethod = do itr <- ask - return $ reqMethod $ fromJust $ itrRequest itr - - -getHeader :: String -> Resource (Maybe String) -getHeader name = do itr <- ask - return $ H.getHeader name $ fromJust $ itrRequest itr + p = do xs ← acceptEncodingListP + P.endOfInput + return xs + + 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 'MIMEType'. +getContentType ∷ Resource (Maybe MIMEType) +getContentType + = do cTypeM ← getHeader "Content-Type" + case cTypeM of + Nothing + → return Nothing + Just 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 'AuthCredential'. +getAuthorization ∷ Resource (Maybe AuthCredential) +getAuthorization + = do authM ← getHeader "Authorization" + case authM of + Nothing + → return Nothing + Just auth + → 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 時に使用するアクション群 -} -foundEntity :: Bool -> String -> ClockTime -> Resource () -foundEntity isWeak token timeStamp +-- |Tell the system that the 'Resource' found an entity for the +-- request URI. If this is a GET or HEAD request, a found entity means +-- a datum to be replied. If this is a PUT or DELETE request, it means +-- a datum which was stored for the URI until now. It is an error to +-- compute 'foundEntity' if this is a POST request. +-- +-- 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. +-- +-- If this is a GET or HEAD request, '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 - foundETag isWeak token + 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 - -foundETag :: Bool -> String -> Resource () -foundETag isWeak token +-- |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 +-- the response. +-- +-- This action is not preferred. You should use 'foundEntity' whenever +-- possible. +foundETag ∷ ETag → Resource () +foundETag tag = do driftTo ExaminingRequest - - let tag = mkETag isWeak token - method <- getMethod - when (method == GET || method == HEAD) - $ setHeader' "ETag" $ show tag + method ← getMethod + when (method ≡ GET ∨ method ≡ HEAD) + $ setHeader' "ETag" (printETag tag) + when (method ≡ POST) + $ abort InternalServerError [] + (Just "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 [] ("The entity tag doesn't match: " ++ list) - _ -> abort BadRequest [] ("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 p (A.toByteString value) of + Right tags + -- tags の中に一致するものが無ければ + -- PreconditionFailed で終了。 + → when ((¬) (any (≡ tag) tags)) + $ abort PreconditionFailed [] + (Just $ "The entity tag doesn't match: " ⊕ A.toText value) + Left _ + → abort BadRequest [] (Just $ "Unparsable If-Match: " ⊕ A.toText value) + + 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 [] ("The entity tag matches: *") - Just list -> case parseStr eTagListP list of - (Success tags, _) - -> when (any (== tag) tags) - $ abort statusForNoneMatch [] ("The entity tag matches: " ++ list) - _ -> abort BadRequest [] ("Unparsable If-None-Match: " ++ list) + Nothing → return () + Just value → if value ≡ "*" then + abort statusForNoneMatch [] (Just "The entity tag matches: *") + else + case P.parseOnly p (A.toByteString value) of + Right tags + → when (any (≡ tag) tags) + $ abort statusForNoneMatch [] + (Just $ "The entity tag matches: " ⊕ A.toText value) + Left _ + → abort BadRequest [] + (Just $ "Unparsable If-None-Match: " ⊕ A.toText value) driftTo GettingBody - - -foundTimeStamp :: ClockTime -> Resource () + 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 +-- '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 +-- modification time are unsafe because it is possible to mess up such +-- tests by modifying the entity twice in a second. +-- +-- This action is not preferred. You should use 'foundEntity' whenever +-- possible. +foundTimeStamp ∷ UTCTime → Resource () foundTimeStamp timeStamp = do driftTo ExaminingRequest - method <- getMethod - when (method == GET || method == HEAD) - $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp + 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 "If-Modified-Since" + ifModSince ← getHeader "If-Modified-Since" case ifModSince of - Just str -> case parseHTTPDateTime str of - Just lastTime - -> when (timeStamp <= lastTime) - $ abort statusForIfModSince [] ("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 statusForIfModSince [] + (Just $ "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 [] ("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 PreconditionFailed [] + (Just $ "The entity has not been modified since " ⊕ A.toText str) + Left _ + → return () -- 不正な時刻は無視 + Nothing → return () driftTo GettingBody - -foundNoEntity :: Maybe String -> Resource () +-- | Computation of @'foundNoEntity' mStr@ tells the system that the +-- 'Resource' found no entity for the request URI. @mStr@ is an +-- optional error message to be replied to the client. +-- +-- If this is a PUT request, 'foundNoEntity' performs \"If-Match\" +-- test and aborts with status \"412 Precondition Failed\" when it +-- failed. If this is a GET, HEAD, POST or DELETE request, +-- 'foundNoEntity' always aborts with status \"404 Not Found\". +foundNoEntity ∷ Maybe Text → Resource () foundNoEntity msgM = do driftTo ExaminingRequest - let msg = fromMaybe "The requested entity was not found in this server." msgM - - method <- getMethod - when (method /= PUT) - $ abort NotFound [] msg + method ← getMethod + when (method ≢ PUT) + $ abort NotFound [] msgM -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな -- If-Match: 條件も滿たさない。 - ifMatch <- getHeader "If-Match" - when (ifMatch /= Nothing) - $ abort PreconditionFailed [] msg + 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 +-- | Computation of @'input' limit@ attempts to read the request body +-- up to @limit@ bytes, and then make the 'Resource' transit to +-- /Deciding Header/ state. When the actual size of body is larger +-- than @limit@ bytes, computation of 'Resource' immediately aborts +-- with status \"413 Request Entity Too Large\". When the request has +-- no body, 'input' returns an empty string. +-- +-- @limit@ may be less than or equal to zero. In this case, the +-- default limitation value ('cnfMaxEntityLength') is used. See +-- 'defaultLimit'. +-- +-- '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 <- ask - hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id - chunk <- if hasBody then - askForInput itr - else - do driftTo DecidingHeader - return B.empty + itr ← getInteraction + chunk ← if reqHasBody $ fromJust $ itrRequest itr then + askForInput itr + else + do driftTo DecidingHeader + return (∅) 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 ("inputBS: limit must be positive: " ++ show actualLimit) + askForInput ∷ Interaction → Resource Lazy.ByteString + askForInput (Interaction {..}) + = do let confLimit = cnfMaxEntityLength itrConfig + actualLimit = if limit ≤ 0 then + confLimit + else + limit + when (actualLimit ≤ 0) + $ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit) -- Reader にリクエスト liftIO $ atomically - $ 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 + $ 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 ∷ Int → STM () tooLarge lim = abortSTM RequestEntityTooLarge [] - ("Request body must be smaller than " - ++ show lim ++ " bytes.") - - -inputChunk :: Int -> Resource String -inputChunk limit = inputChunkBS limit >>= return . B.unpack + (Just $ "Request body must be smaller than " + ⊕ T.pack (show lim) ⊕ " bytes.") - --- 多くとも limit バイトまでのリクエストボディの一部を受信する。limit --- が 0 以下なら Config で設定されたデフォルトのボディ長により制限され --- る。これ以上ボディが殘ってゐなければ空文字列を返す。 -inputChunkBS :: Int -> Resource ByteString -inputChunkBS limit +seqToLBS ∷ Seq ByteString → Lazy.ByteString +{-# INLINE seqToLBS #-} +seqToLBS = Lazy.fromChunks ∘ toList + +-- | Computation of @'inputChunk' limit@ attempts to read a part of +-- request body up to @limit@ bytes. You can read any large request by +-- repeating computation of this action. When you've read all the +-- request body, 'inputChunk' returns an empty string and then make +-- the 'Resource' transit to /Deciding Header/ state. +-- +-- @limit@ may be less than or equal to zero. In this case, the +-- default limitation value ('cnfMaxEntityLength') is used. See +-- 'defaultLimit'. +-- +-- Note that 'inputChunkLBS' is more efficient than 'inputChunk' so you +-- should use it whenever possible. +inputChunk ∷ Int → Resource Lazy.ByteString +inputChunk limit = do driftTo GettingBody - itr <- ask - hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id - chunk <- if hasBody then - askForInput itr - else - do driftTo DecidingHeader - return B.empty + itr ← getInteraction + chunk ← if reqHasBody $ fromJust $ itrRequest itr then + askForInput itr + else + do driftTo DecidingHeader + return (∅) 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) + askForInput ∷ Interaction → Resource Lazy.ByteString + askForInput (Interaction {..}) + = do let confLimit = cnfMaxEntityLength itrConfig + actualLimit = if limit < 0 then + confLimit + else + limit + when (actualLimit ≤ 0) + $ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit) -- Reader にリクエスト liftIO $ atomically - $ do writeItr itr itrReqBodyWanted $ Just actualLimit - writeItr itr itrWillReceiveBody True + $ writeTVar itrReqBodyWanted actualLimit -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 - 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 + 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 - -defaultLimit :: Int +-- | Computation of @'inputForm' limit@ attempts to read the request +-- body with 'input' and parse it as +-- @application\/x-www-form-urlencoded@ or @multipart\/form-data@. If +-- the request header \"Content-Type\" is neither of them, 'inputForm' +-- makes 'Resource' abort with status \"415 Unsupported Media +-- Type\". If the request has no \"Content-Type\", it aborts with +-- \"400 Bad Request\". +-- +-- Field names in @multipart\/form-data@ will be precisely decoded in +-- accordance with RFC 2231. On the other hand, +-- @application\/x-www-form-urlencoded@ says nothing about the +-- encoding of field names, so they'll always be decoded in UTF-8. +inputForm ∷ Int → Resource [(Text, FormData)] +inputForm limit + = do cTypeM ← getContentType + case cTypeM of + Nothing + → abort BadRequest [] (Just "Missing Content-Type") + Just (MIMEType "application" "x-www-form-urlencoded" _) + → readWWWFormURLEncoded + Just (MIMEType "multipart" "form-data" params) + → readMultipartFormData params + Just cType + → abort UnsupportedMediaType [] + $ Just + $ A.toText + $ A.fromAsciiBuilder + $ A.toAsciiBuilder "Unsupported media type: " + ⊕ printMIMEType cType + where + readWWWFormURLEncoded + = (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 M.lookup "boundary" params of + Nothing + → abort BadRequest [] (Just "Missing boundary of multipart/form-data") + Just boundary + → do src ← input limit + b ← case A.fromText boundary of + Just b → return b + Nothing → abort BadRequest [] + (Just $ "Malformed boundary: " ⊕ boundary) + case LP.parse (p b) src of + LP.Done _ formList + → return formList + _ → abort BadRequest [] (Just "Unparsable multipart/form-data") + where + p b = do xs ← multipartFormP b + P.endOfInput + return xs + +-- | This is just a constant @-1@. It's better to say @'input' +-- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly +-- the same. +defaultLimit ∷ Int defaultLimit = (-1) - {- DecidingHeader 時に使用するアクション群 -} -setStatus :: StatusCode -> Resource () -setStatus code +-- | Set the response status code. If you omit to compute this action, +-- the status code will be defaulted to \"200 OK\". +setStatus ∷ StatusCode → Resource () +setStatus sc = do driftTo DecidingHeader - itr <- ask - liftIO $ atomically $ updateItr itr itrResponse - $ \ resM -> case resM of - Nothing -> Just $ Response { - resVersion = HttpVersion 1 1 - , resStatus = code - , resHeaders = [] - } - Just res -> Just $ res { - resStatus = code - } - - -setHeader :: String -> String -> Resource () + itr ← getInteraction + liftIO + $ atomically + $ setResponseStatus itr sc + +-- | Set a value of given resource header. Comparison of header name +-- is case-insensitive. Note that this action is not intended to be +-- used so frequently: there should be actions like 'setContentType' +-- for every common headers. +-- +-- Some important headers (especially \"Content-Length\" and +-- \"Transfer-Encoding\") may be silently dropped or overwritten by +-- the system not to corrupt the interaction with client at the +-- viewpoint of HTTP protocol layer. For instance, if we are keeping +-- the connection alive, without this process it causes a catastrophe +-- to send a header \"Content-Length: 10\" and actually send a body of +-- 20 bytes long. In this case the client shall only accept the first +-- 10 bytes of response body and thinks that the residual 10 bytes is +-- a part of header of the next response. +setHeader ∷ CIAscii → Ascii → Resource () setHeader name value - = driftTo DecidingHeader >> setHeader' name value - + = driftTo DecidingHeader ≫ setHeader' name value -setHeader' :: String -> String -> Resource() +setHeader' ∷ CIAscii → Ascii → Resource () setHeader' name value - = do itr <- ask - liftIO $ atomically $ updateItr itr itrResponse - $ \ resM -> case resM of - Nothing -> Just $ Response { - resVersion = HttpVersion 1 1 - , resStatus = Ok - , resHeaders = [ (name, value) ] - } - Just res -> Just $ H.setHeader name value res - - -redirect :: StatusCode -> URI -> Resource () + = do itr ← getInteraction + liftIO $ atomically + $ do res ← readTVar $ itrResponse itr + let res' = H.setHeader name value res + writeTVar (itrResponse itr) res' + +-- | Computation of @'redirect' code uri@ sets the response status to +-- @code@ and \"Location\" header to @uri@. The @code@ must satisfy +-- 'isRedirection' or it causes an error. +redirect ∷ StatusCode → URI → Resource () redirect code uri - = do when (code == NotModified || not (isRedirection code)) - $ abort InternalServerError [] - $ "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 - setHeader "Location" (uriToString id uri $ "") - - -setETag :: Bool -> String -> Resource () -setETag isWeak token - = setHeader "ETag" $ show $ mkETag isWeak token - + setLocation uri + +-- | Computation of @'setContentType' mType@ sets the response header +-- \"Content-Type\" to @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 () +setLocation 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 ∷ [CIAscii] → Resource () +setContentEncoding codings + = do ver ← getRequestVersion + tr ← case ver of + HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding) + HttpVersion 1 1 → return toAB + _ → abort InternalServerError [] + (Just "setContentEncoding: Unknown HTTP version") + setHeader "Content-Encoding" + (A.fromAsciiBuilder $ joinWith ", " $ map tr codings) + where + toAB = A.toAsciiBuilder ∘ A.fromCIAscii -setLastModified :: ClockTime -> Resource () -setLastModified lastmod - = setHeader "Last-Modified" $ formatHTTPDateTime lastmod +-- |Computation of @'setWWWAuthenticate' challenge@ sets the response +-- header \"WWW-Authenticate\" to @challenge@. +setWWWAuthenticate ∷ AuthChallenge → Resource () +setWWWAuthenticate challenge + = setHeader "WWW-Authenticate" (printAuthChallenge challenge) {- 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 - - -outputChunkBS :: ByteString -> Resource () -outputChunkBS str = do driftTo DecidingBody - itr <- ask - liftIO $ atomically $ - do updateItr itr itrBodyToSend (flip B.append str) - unless (B.null str) - $ writeItr itr itrBodyIsNull False +-- | Write a 'Lazy.ByteString' to the response body, and then transit +-- to the /Done/ state. It is safe to apply 'output' to an infinite +-- string, such as the lazy stream of \/dev\/random. +output ∷ Lazy.ByteString → Resource () +{-# INLINE output #-} +output str = outputChunk str *> driftTo Done + +-- | Write a 'Lazy.ByteString' to the response body. This action can +-- be repeated as many times as you want. It is safe to apply +-- 'outputChunk' to an infinite string. +outputChunk ∷ Lazy.ByteString → Resource () +outputChunk wholeChunk + = do driftTo DecidingBody + itr ← getInteraction + + let limit = cnfMaxOutputChunkLength $ itrConfig itr + when (limit ≤ 0) + $ abort InternalServerError [] + (Just $ "cnfMaxOutputChunkLength must be positive: " ⊕ T.pack (show limit)) + + discardBody ← liftIO $ atomically $ readTVar $ itrWillDiscardBody itr + unless (discardBody) + $ sendChunks itr wholeChunk limit + + unless (Lazy.null wholeChunk) + $ liftIO $ atomically $ + writeTVar (itrSentNoBodySoFar itr) False + where + sendChunks ∷ Interaction → Lazy.ByteString → Int → Resource () + sendChunks itr@(Interaction {..}) str limit + | Lazy.null str = return () + | otherwise = do let (chunk, remaining) = Lazy.splitAt (fromIntegral limit) str + liftIO $ atomically + $ putTMVar itrBodyToSend (chunkToBuilder chunk) + sendChunks itr remaining limit + chunkToBuilder ∷ Lazy.ByteString → Builder + chunkToBuilder = mconcat ∘ map BB.fromByteString ∘ Lazy.toChunks {- @@ -562,61 +924,38 @@ outputChunkBS str = do driftTo DecidingBody [Done に遷移する時] bodyIsNull が False ならば何もしない。True だった場合は出力補完す - る。Content-Type も變はる。但し（デフォルトのまま）Status が 200 OK - だった場合は、補完の代はりに 204 No Content に變へる。 + る。 -} -driftTo :: InteractionState -> Resource () +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 + = do itr ← getInteraction + liftIO $ atomically + $ do oldState ← readTVar $ itrState itr + if newState < oldState then + throwStateError oldState newState + else + do let a = [oldState .. newState] + b = tail a + c = zip a b + mapM_ (uncurry $ drift itr) c + writeTVar (itrState itr) newState where - throwStateError :: Monad m => InteractionState -> InteractionState -> m a - + throwStateError ∷ 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 + = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new) + drift ∷ Interaction → InteractionState → InteractionState → STM () + drift (Interaction {..}) GettingBody _ + = writeTVar itrReqBodyWasteAll True drift itr DecidingHeader _ = postprocess itr - - drift itr _ Done - = do bodyIsNull <- readItr itr itrBodyIsNull id + drift itr@(Interaction {..}) _ Done + = do bodyIsNull ← readTVar itrSentNoBodySoFar when bodyIsNull - $ do status <- readStatus itr - if status == Ok then - do updateItrF itr itrResponse - $ \ res -> res { resStatus = NoContent } - updateItrF itr itrResponse - $ H.deleteHeader "Content-Type" - updateItrF itr itrResponse - $ H.deleteHeader "ETag" - updateItrF itr itrResponse - $ H.deleteHeader "Last-Modified" - else - writeDefaultPage itr - - + $ writeDefaultPage itr drift _ _ _ = return () - - - readStatus :: Interaction -> STM StatusCode - readStatus itr = readItr itr itrResponse (resStatus . fromJust) \ No newline at end of file