-- |This is the Resource Monad; monadic actions to define the behavior -- of each resources. The 'Resource' Monad is a kind of IO Monad thus -- it implements MonadIO class. It is also a state machine. -- -- 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 -- * Actions -- ** Getting request header -- |These actions can be computed regardless of the current state, -- and they don't change the state. , getConfig , getRequest , getMethod , getRequestURI , getResourcePath , getPathInfo , getHeader , getAccept , getContentType -- ** 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 , inputBS , inputChunkBS , inputForm , defaultLimit -- ** Setting response headers -- |Computation of these actions changes the state to /Deciding -- Header/. , setStatus , setHeader , redirect , setETag , setLastModified , setContentType -- ** Writing a response body -- |Computation of these actions changes the state to /Deciding -- Body/. , output , outputChunk , outputBS , outputChunkBS , driftTo ) where import Control.Concurrent.STM import Control.Monad.Reader import qualified Data.ByteString.Lazy.Char8 as B import Data.ByteString.Lazy.Char8 (ByteString) import Data.List import Data.Maybe import GHC.Conc (unsafeIOToSTM) import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.DefaultPage import Network.HTTP.Lucu.ETag import qualified Network.HTTP.Lucu.Headers as H import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Postprocess import Network.HTTP.Lucu.RFC1123DateTime import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.MIMEType import Network.HTTP.Lucu.Utils import Network.URI import System.Time -- |The 'Resource' monad. /Interaction/ is an internal state thus it -- is not exposed to users. This monad implements 'MonadIO' so it can -- do any IO actions. type Resource a = ReaderT Interaction IO a -- |Get the 'Network.HTTP.Lucu.Config.Config' value which is used for -- the httpd. getConfig :: Resource Config getConfig = do itr <- ask return $ itrConfig itr -- |Get the 'Network.HTTP.Lucu.Request.Request' value which represents -- the request header. In general you don't have to use this action. getRequest :: Resource Request getRequest = do itr <- ask return $ fromJust $ itrRequest itr -- |Get the 'Network.HTTP.Lucu.Request.Method' value of the request. getMethod :: Resource Method getMethod = do req <- getRequest return $ reqMethod req -- |Get the URI of the request. getRequestURI :: Resource URI getRequestURI = do req <- getRequest return $ reqURI req -- |Get the path of this 'Resource' (to be exact, -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this -- action is the exact path in the tree even if the -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy. -- -- Example: -- -- > main = let tree = mkResTree [ (["foo"], resFoo) ] -- > in runHttpd defaultConfig tree -- > -- > resFoo = ResourceDef { -- > resIsGreedy = True -- > , resGet = Just $ do requestURI <- getRequestURI -- > resourcePath <- getResourcePath -- > pathInfo <- getPathInfo -- > -- uriPath requestURI == "/foo/bar/baz" -- > -- resourcePath == ["foo"] -- > -- pathInfo == ["bar", "baz"] -- > ... -- > , ... -- > } getResourcePath :: Resource [String] getResourcePath = do itr <- ask return $ fromJust $ itrResourcePath itr -- |This is an analogy of CGI PATH_INFO. Its result is always @[]@ if -- the 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not -- greedy. See 'getResourcePath'. getPathInfo :: Resource [String] getPathInfo = do rsrcPath <- getResourcePath reqURI <- getRequestURI let reqPathStr = uriPath reqURI reqPath = [x | x <- splitBy (== '/') reqPathStr, x /= ""] -- rsrcPath と reqPath の共通する先頭部分を reqPath か -- ら全部取り除くと、それは PATH_INFO のやうなものにな -- る。rsrcPath は全部一致してゐるに決まってゐる（でな -- ければこの Resource が撰ばれた筈が無い）ので、 -- rsrcPath の長さの分だけ削除すれば良い。 return $ drop (length rsrcPath) reqPath -- |Get a value of given request header. Comparison of header name is -- case-insensitive. Note that this action is not intended to be used -- so frequently: there should be an action like 'getContentType' for -- every common headers. getHeader :: String -> Resource (Maybe String) getHeader name = do itr <- ask return $ H.getHeader name $ fromJust $ itrRequest itr -- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on -- header \"Accept\". getAccept :: Resource [MIMEType] getAccept = do accept <- getHeader "Accept" if accept == Nothing then return [] else case parseStr mimeTypeListP $ fromJust accept of (Success xs, _) -> return xs _ -> return [] -- |Get the header \"Content-Type\" as -- 'Network.HTTP.Lucu.MIMEType.MIMEType'. getContentType :: Resource (Maybe MIMEType) getContentType = do cType <- getHeader "Content-Type" if cType == Nothing then return Nothing else case parseStr mimeTypeP $ fromJust cType of (Success t, _) -> return $ Just t _ -> return Nothing {- ExaminingRequest 時に使用するアクション群 -} foundEntity :: ETag -> ClockTime -> Resource () foundEntity tag timeStamp = do driftTo ExaminingRequest method <- getMethod when (method == GET || method == HEAD) $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp foundETag tag driftTo GettingBody foundETag :: ETag -> Resource () foundETag tag = do driftTo ExaminingRequest method <- getMethod when (method == GET || method == HEAD) $ setHeader' "ETag" $ show tag -- If-Match があればそれを見る。 ifMatch <- getHeader "If-Match" case ifMatch of Nothing -> return () Just "*" -> return () Just list -> case parseStr eTagListP list of (Success tags, _) -- tags の中に一致するものが無ければ -- PreconditionFailed で終了。 -> when (not $ any (== tag) tags) $ abort PreconditionFailed [] $ Just ("The entity tag doesn't match: " ++ list) _ -> abort BadRequest [] $ Just ("Unparsable If-Match: " ++ fromJust ifMatch) let statusForNoneMatch = if method == GET || method == HEAD then NotModified else PreconditionFailed -- If-None-Match があればそれを見る。 ifNoneMatch <- getHeader "If-None-Match" case ifNoneMatch of Nothing -> return () Just "*" -> abort statusForNoneMatch [] $ Just ("The entity tag matches: *") Just list -> case parseStr eTagListP list of (Success tags, _) -> when (any (== tag) tags) $ abort statusForNoneMatch [] $ Just ("The entity tag matches: " ++ list) _ -> abort BadRequest [] $ Just ("Unparsable If-None-Match: " ++ list) driftTo GettingBody foundTimeStamp :: ClockTime -> Resource () foundTimeStamp timeStamp = do driftTo ExaminingRequest method <- getMethod when (method == GET || method == HEAD) $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp let statusForIfModSince = if method == GET || method == HEAD then NotModified else PreconditionFailed -- If-Modified-Since があればそれを見る。 ifModSince <- getHeader "If-Modified-Since" case ifModSince of Just str -> case parseHTTPDateTime str of Just lastTime -> when (timeStamp <= lastTime) $ abort statusForIfModSince [] $ Just ("The entity has not been modified since " ++ str) Nothing -> return () -- 不正な時刻は無視 Nothing -> return () -- If-Unmodified-Since があればそれを見る。 ifUnmodSince <- getHeader "If-Unmodified-Since" case ifUnmodSince of Just str -> case parseHTTPDateTime str of Just lastTime -> when (timeStamp > lastTime) $ abort PreconditionFailed [] $ Just ("The entity has not been modified since " ++ str) Nothing -> return () -- 不正な時刻は無視 Nothing -> return () driftTo GettingBody foundNoEntity :: Maybe String -> Resource () foundNoEntity msgM = do driftTo ExaminingRequest method <- getMethod when (method /= PUT) $ abort NotFound [] msgM -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな -- If-Match: 條件も滿たさない。 ifMatch <- getHeader "If-Match" when (ifMatch /= Nothing) $ abort PreconditionFailed [] msgM driftTo GettingBody {- GettingBody 時に使用するアクション群 -} input :: Int -> Resource String input limit = inputBS limit >>= return . B.unpack -- 多くとも limit バイトまでのリクエストボディ全體を受信する。limit が -- 零以下なら Config で設定されたデフォルトのボディ長により制限される。 inputBS :: Int -> Resource ByteString inputBS limit = do driftTo GettingBody itr <- ask hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id chunk <- if hasBody then askForInput itr else do driftTo DecidingHeader return B.empty return chunk where askForInput :: Interaction -> Resource ByteString askForInput itr = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr actualLimit = if limit <= 0 then defaultLimit else limit when (actualLimit <= 0) $ fail ("inputBS: limit must be positive: " ++ show actualLimit) -- Reader にリクエスト liftIO $ atomically $ do chunkLen <- readItr itr itrReqChunkLength id writeItr itr itrWillReceiveBody True if fmap (> actualLimit) chunkLen == Just True then -- 受信前から多過ぎる事が分かってゐる tooLarge actualLimit else writeItr itr itrReqBodyWanted $ Just actualLimit -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 chunk <- liftIO $ atomically $ do chunk <- readItr itr itrReceivedBody id chunkIsOver <- readItr itr itrReqChunkIsOver id if B.length chunk < fromIntegral actualLimit then -- 要求された量に滿たなくて、まだ殘り -- があるなら再試行。 unless chunkIsOver $ retry else -- 制限値一杯まで讀むやうに指示したの -- にまだ殘ってゐるなら、それは多過ぎ -- る。 unless chunkIsOver $ tooLarge actualLimit -- 成功。itr 内にチャンクを置いたままにす -- るとメモリの無駄になるので除去。 writeItr itr itrReceivedBody B.empty return chunk driftTo DecidingHeader return chunk tooLarge :: Int -> STM () tooLarge lim = abortSTM RequestEntityTooLarge [] $ Just ("Request body must be smaller than " ++ show lim ++ " bytes.") inputChunk :: Int -> Resource String inputChunk limit = inputChunkBS limit >>= return . B.unpack -- 多くとも limit バイトまでのリクエストボディの一部を受信する。limit -- が 0 以下なら Config で設定されたデフォルトのボディ長により制限され -- る。これ以上ボディが殘ってゐなければ空文字列を返す。 inputChunkBS :: Int -> Resource ByteString inputChunkBS limit = do driftTo GettingBody itr <- ask hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id chunk <- if hasBody then askForInput itr else do driftTo DecidingHeader return B.empty return chunk where askForInput :: Interaction -> Resource ByteString askForInput itr = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr actualLimit = if limit < 0 then defaultLimit else limit when (actualLimit <= 0) $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit) -- Reader にリクエスト liftIO $ atomically $ do writeItr itr itrReqBodyWanted $ Just actualLimit writeItr itr itrWillReceiveBody True -- 應答を待つ。トランザクションを分けなければ當然デッドロック。 chunk <- liftIO $ atomically $ do chunk <- readItr itr itrReceivedBody id -- 要求された量に滿たなくて、まだ殘りがあ -- るなら再試行。 when (B.length chunk < fromIntegral actualLimit) $ do chunkIsOver <- readItr itr itrReqChunkIsOver id unless chunkIsOver $ retry -- 成功 writeItr itr itrReceivedBody B.empty return chunk when (B.null chunk) $ driftTo DecidingHeader return chunk -- application/x-www-form-urlencoded または multipart/form-data をパー -- スする。もし Content-Type が無かったら BadRequest で終了し、未對應の -- タイプであったら UnsupportedMediaType で終了する。 inputForm :: Int -> Resource [(String, String)] inputForm limit = do cTypeM <- getContentType case cTypeM of Nothing -> abort BadRequest [] (Just "Missing Content-Type") Just (MIMEType "application" "x-www-form-urlencoded" _) -> readWWWFormURLEncoded Just (MIMEType "multipart" "form-data" _) -> readMultipartFormData Just cType -> abort UnsupportedMediaType [] (Just $ "Unsupported media type: " ++ show cType) where readWWWFormURLEncoded = do src <- input limit return $ do pairStr <- splitBy (\ c -> c == ';' || c == '&') src let pair = break (== '=') pairStr return ( unEscapeString $ fst pair , unEscapeString $ snd pair ) readMultipartFormData -- FIXME: 未對應 = abort UnsupportedMediaType [] (Just $ "Sorry, inputForm does not currently support multipart/form-data.") defaultLimit :: Int defaultLimit = (-1) {- DecidingHeader 時に使用するアクション群 -} setStatus :: StatusCode -> Resource () setStatus code = do driftTo DecidingHeader itr <- ask liftIO $ atomically $ updateItr itr itrResponse $ \ res -> res { resStatus = code } setHeader :: String -> String -> Resource () setHeader name value = driftTo DecidingHeader >> setHeader' name value setHeader' :: String -> String -> Resource() setHeader' name value = do itr <- ask liftIO $ atomically $ updateItr itr itrResponse $ H.setHeader name value redirect :: StatusCode -> URI -> Resource () redirect code uri = do when (code == NotModified || not (isRedirection code)) $ abort InternalServerError [] $ Just ("Attempted to redirect with status " ++ show code) setStatus code setHeader "Location" (uriToString id uri $ "") setETag :: ETag -> Resource () setETag tag = setHeader "ETag" $ show tag setLastModified :: ClockTime -> Resource () setLastModified lastmod = setHeader "Last-Modified" $ formatHTTPDateTime lastmod setContentType :: MIMEType -> Resource () setContentType mType = setHeader "Content-Type" $ show mType {- DecidingBody 時に使用するアクション群 -} output :: String -> Resource () output = outputBS . B.pack outputBS :: ByteString -> Resource () outputBS str = do outputChunkBS str driftTo Done outputChunk :: String -> Resource () outputChunk = outputChunkBS . B.pack {- チャンクの大きさは Config で制限されてゐる。もし例へば /dev/zero を B.readFile して作った ByteString をそのまま ResponseWriter に渡した りすると大變な事が起こる。何故なら ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書く爲にチャンクの大きさを 測るから、その時に起こるであらう事は言ふまでも無い。 -} outputChunkBS :: ByteString -> Resource () outputChunkBS str = do driftTo DecidingBody itr <- ask let limit = cnfMaxOutputChunkLength $ itrConfig itr when (limit <= 0) $ fail ("cnfMaxOutputChunkLength must be positive: " ++ show limit) discardBody <- liftIO $ atomically $ readItr itr itrWillDiscardBody id unless (discardBody) $ sendChunks str limit unless (B.null str) $ liftIO $ atomically $ writeItr itr itrBodyIsNull False where sendChunks :: ByteString -> Int -> Resource () sendChunks str limit | B.null str = return () | otherwise = do let (chunk, remaining) = B.splitAt (fromIntegral limit) str itr <- ask liftIO $ atomically $ do buf <- readItr itr itrBodyToSend id if B.null buf then -- バッファが消化された writeItr itr itrBodyToSend chunk else -- 消化されるのを待つ retry -- 殘りのチャンクについて繰り返す sendChunks remaining limit {- [GettingBody からそれ以降の状態に遷移する時] body を讀み終へてゐなければ、殘りの body を讀み捨てる。 [DecidingHeader からそれ以降の状態に遷移する時] postprocess する。 [Done に遷移する時] bodyIsNull が False ならば何もしない。True だった場合は出力補完す る。 -} driftTo :: InteractionState -> Resource () driftTo newState = do itr <- ask liftIO $ atomically $ do oldState <- readItr itr itrState id if newState < oldState then throwStateError oldState newState else do let a = [oldState .. newState] b = tail a c = zip a b mapM_ (uncurry $ drift itr) c writeItr itr itrState newState 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 ()