{-# OPTIONS_HADDOCK prune #-} -- |This is the Resource Monad; monadic actions to define the behavior -- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO' -- Monad thus it implements 'Control.Monad.Trans.MonadIO' class. It is -- also a state machine. -- -- 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 ( -- * Monad Resource , runRes -- private -- * Actions -- ** Getting request header -- |These actions can be computed regardless of the current state, -- and they don't change the state. , getConfig , getRemoteAddr , getRemoteAddr' , 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 , inputLBS , inputChunkLBS , 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 , outputLBS , outputChunkLBS , driftTo ) 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 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) import OpenSSL.X509 -- |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 -- |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 -- | 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 -- 'Network.HTTP.Lucu.Config.SSLConfig' has not been set to -- 'OpenSSL.Session.VerifyPeer'. getRemoteCertificate :: Resource (Maybe X509) getRemoteCertificate = do itr <- getInteraction return $! itrRemoteCert 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 <- 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 -- |Get the URI of the request. getRequestURI :: Resource URI getRequestURI = do req <- getRequest return $! reqURI req -- |Get the HTTP version of the request. getRequestVersion :: Resource HttpVersion getRequestVersion = do req <- getRequest return $! reqVersion 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: -- -- > 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 <- 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 /= ""] -- 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 -- |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) -- |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 = do accEncM <- getHeader (C8.pack "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 -- 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) -- |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) -- |Get the header \"Content-Type\" as -- 'Network.HTTP.Lucu.MIMEType.MIMEType'. getContentType :: Resource (Maybe MIMEType) getContentType = do cTypeM <- getHeader (C8.pack "Content-Type") case cTypeM of 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) -- |Get the header \"Authorization\" as -- 'Network.HTTP.Lucu.Authorization.AuthCredential'. getAuthorization :: Resource (Maybe AuthCredential) getAuthorization = do authM <- getHeader (C8.pack "Authorization") case authM of Nothing -> return Nothing Just auth -> case parse authCredentialP (L8.fromChunks [auth]) of (# Success a, _ #) -> return $ Just a (# _ , _ #) -> return Nothing {- ExaminingRequest 時に使用するアクション群 -} -- |Tell the system that the 'Resource' found an entity for the -- request URI. If this is a GET or HEAD request, a found entity means -- a datum to be replied. If this is a PUT or DELETE request, it means -- a datum which was stored for the URI up to 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 = 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.") foundETag tag driftTo GettingBody -- |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 = tag `seq` 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.") -- If-Match があればそれを見る。 ifMatch <- getHeader (C8.pack "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, _ #) -- 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 -- If-None-Match があればそれを見る。 ifNoneMatch <- getHeader (C8.pack "If-None-Match") case ifNoneMatch of Nothing -> return () Just value -> if value == C8.pack "*" 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) driftTo GettingBody -- |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 = 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 foundTimeStamp for POST request.") let statusForIfModSince = if method == GET || method == HEAD then NotModified else PreconditionFailed -- If-Modified-Since があればそれを見る。 ifModSince <- getHeader (C8.pack "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 () -- If-Unmodified-Since があればそれを見る。 ifUnmodSince <- getHeader (C8.pack "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 () driftTo GettingBody -- | 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 String -> Resource () foundNoEntity msgM = msgM `seq` do driftTo ExaminingRequest method <- getMethod when (method /= PUT) $ abort NotFound [] msgM -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな -- If-Match: 條件も滿たさない。 ifMatch <- getHeader (C8.pack "If-Match") when (ifMatch /= Nothing) $ abort PreconditionFailed [] msgM driftTo GettingBody {- GettingBody 時に使用するアクション群 -} -- | Computation of @'input' limit@ attempts to read the request body -- up to @limit@ bytes, and then make the 'Resource' transit to -- /Deciding Header/ state. When the actual size of body is larger -- than @limit@ bytes, computation of 'Resource' immediately aborts -- with status \"413 Request Entity Too Large\". When the request has -- no body, 'input' returns an empty string. -- -- @limit@ may be less than or equal to zero. In this case, the -- default limitation value -- ('Network.HTTP.Lucu.Config.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 return chunk where askForInput :: Interaction -> Resource Lazy.ByteString askForInput itr = itr `seq` do let confLimit = cnfMaxEntityLength $ itrConfig itr 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 L8.length chunk < fromIntegral actualLimit then -- 要求された量に滿たなくて、まだ殘り -- があるなら再試行。 unless chunkIsOver $ retry else -- 制限値一杯まで讀むやうに指示したの -- にまだ殘ってゐるなら、それは多過ぎ -- る。 unless chunkIsOver $ tooLarge actualLimit -- 成功。itr 内にチャンクを置いたままにす -- るとメモリの無駄になるので除去。 writeItr itr itrReceivedBody L8.empty 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.") -- | 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 -- ('Network.HTTP.Lucu.Config.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 return chunk where askForInput :: Interaction -> Resource Lazy.ByteString askForInput itr = itr `seq` do let confLimit = cnfMaxEntityLength $! itrConfig itr 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 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 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 return chunk -- | Computation of @'inputForm' limit@ attempts to read the request -- body with 'input' and parse it as -- application\/x-www-form-urlencoded or multipart\/form-data. If the -- request header \"Content-Type\" is neither of them, 'inputForm' -- makes 'Resource' abort with status \"415 Unsupported Media -- Type\". If the request has no \"Content-Type\", it aborts with -- \"400 Bad Request\". inputForm :: Int -> Resource [(String, String)] inputForm limit = limit `seq` 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 $! "Unsupported media type: " ++ show cType) where readWWWFormURLEncoded = do src <- input limit return $ parseWWWFormURLEncoded src readMultipartFormData params = do case find ((== "boundary") . map toLower . fst) 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") -- | This is just a constant @-1@. It's better to say @'input' -- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly -- the same. defaultLimit :: Int defaultLimit = (-1) {- DecidingHeader 時に使用するアクション群 -} -- | Set the response status code. If you omit to compute this action, -- the status code will be defaulted to \"200 OK\". setStatus :: StatusCode -> Resource () setStatus 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 -- | 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 () redirect code uri = code `seq` uri `seq` do when (code == NotModified || not (isRedirection code)) $ abort InternalServerError [] $! Just ("Attempted to redirect with status " ++ show 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) -- | Computation of @'setLocation' uri@ sets the response header -- \"Location\" to @uri@. setLocation :: URI -> Resource () setLocation uri = setHeader (C8.pack "Location") (C8.pack $ uriToString id uri $ "") -- |Computation of @'setContentEncoding' codings@ sets the response -- header \"Content-Encoding\" to @codings@. setContentEncoding :: [String] -> 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) -- |Computation of @'setWWWAuthenticate' challenge@ sets the response -- header \"WWW-Authenticate\" to @challenge@. setWWWAuthenticate :: AuthChallenge -> Resource () setWWWAuthenticate challenge = setHeader (C8.pack "WWW-Authenticate") (C8.pack $ show challenge) {- DecidingBody 時に使用するアクション群 -} -- | 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. -- -- 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 ()