1 -- |This is the Resource Monad; monadic actions to define the behavior
2 -- of each resources. The 'Resource' Monad is a kind of IO Monad thus
3 -- it implements MonadIO class. It is also a state machine.
5 -- Request Processing Flow:
7 -- 1. A client issues an HTTP request.
9 -- 2. If the URI of it matches to any resource, the corresponding
10 -- 'Resource' Monad starts running on a newly spawned thread.
12 -- 3. The 'Resource' Monad looks at the request header, find (or not
13 -- find) an entity, receive the request body (if any), decide the
14 -- response header, and decide the response body. This process
15 -- will be discussed later.
17 -- 4. The 'Resource' Monad and its thread stops running. The client
18 -- may or may not be sending us the next request at this point.
20 -- 'Resource' Monad takes the following states. The initial state is
21 -- /Examining Request/ and the final state is /Done/.
23 -- [/Examining Request/] In this state, a 'Resource' looks at the
24 -- request header and thinks about an entity for it. If there is a
25 -- suitable entity, the 'Resource' tells the system an entity tag
26 -- and its last modification time ('foundEntity'). If it found no
27 -- entity, it tells the system so ('foundNoEntity'). In case it is
28 -- impossible to decide the existence of entity, which is a typical
29 -- case for POST requests, 'Resource' does nothing in this state.
31 -- [/Getting Body/] A 'Resource' asks the system to receive a
32 -- request body from client. Before actually reading from the
33 -- socket, the system sends \"100 Continue\" to the client if need
34 -- be. When a 'Resource' transits to the next state without
35 -- receiving all or part of request body, the system still reads it
36 -- and just throws it away.
38 -- [/Deciding Header/] A 'Resource' makes a decision of status code
39 -- and response header. When it transits to the next state, the
40 -- system checks the validness of response header and then write
41 -- them to the socket.
43 -- [/Deciding Body/] In this state, a 'Resource' asks the system to
44 -- write some response body to the socket. When it transits to the
45 -- next state without writing any response body, the system
46 -- completes it depending on the status code.
48 -- [/Done/] Everything is over. A 'Resource' can do nothing for the
49 -- HTTP interaction anymore.
51 -- Note that the state transition is one-way: for instance, it is an
52 -- error to try to read a request body after writing some
53 -- response. This limitation is for efficiency. We don't want to read
54 -- the entire request before starting 'Resource', nor we don't want to
55 -- postpone writing the entire response till the end of 'Resource'
58 module Network.HTTP.Lucu.Resource
65 -- ** Getting request header
67 -- |These actions can be computed regardless of the current state,
68 -- and they don't change the state.
79 -- ** Finding an entity
81 -- |These actions can be computed only in the /Examining Request/
82 -- state. After the computation, the 'Resource' transits to
83 -- /Getting Body/ state.
89 -- ** Getting a request body
91 -- |Computation of these actions changes the state to /Getting
100 -- ** Setting response headers
102 -- |Computation of these actions changes the state to /Deciding
109 -- ** Writing a response body
111 -- |Computation of these actions changes the state to /Deciding
122 import Control.Concurrent.STM
123 import Control.Monad.Reader
124 import qualified Data.ByteString.Lazy.Char8 as B
125 import Data.ByteString.Lazy.Char8 (ByteString)
128 import GHC.Conc (unsafeIOToSTM)
129 import Network.HTTP.Lucu.Abortion
130 import Network.HTTP.Lucu.Config
131 import Network.HTTP.Lucu.DefaultPage
132 import Network.HTTP.Lucu.ETag
133 import qualified Network.HTTP.Lucu.Headers as H
134 import Network.HTTP.Lucu.HttpVersion
135 import Network.HTTP.Lucu.Interaction
136 import Network.HTTP.Lucu.Parser
137 import Network.HTTP.Lucu.Postprocess
138 import Network.HTTP.Lucu.RFC1123DateTime
139 import Network.HTTP.Lucu.Request
140 import Network.HTTP.Lucu.Response
141 import Network.HTTP.Lucu.MIMEType
142 import Network.HTTP.Lucu.Utils
146 -- |The 'Resource' monad. /Interaction/ is an internal state thus it
147 -- is not exposed to users. This monad implements 'MonadIO' so it can
148 -- do any IO actions.
149 type Resource a = ReaderT Interaction IO a
151 -- |Get the 'Network.HTTP.Lucu.Config.Config' value which is used for
153 getConfig :: Resource Config
154 getConfig = do itr <- ask
155 return $ itrConfig itr
157 -- |Get the 'Network.HTTP.Lucu.Request.Request' value which represents
158 -- the request header. In general you don't have to use this action.
159 getRequest :: Resource Request
160 getRequest = do itr <- ask
161 return $ fromJust $ itrRequest itr
163 -- |Get the 'Network.HTTP.Lucu.Request.Method' value of the request.
164 getMethod :: Resource Method
165 getMethod = do req <- getRequest
166 return $ reqMethod req
168 -- |Get the URI of the request.
169 getRequestURI :: Resource URI
170 getRequestURI = do req <- getRequest
173 -- |Get the path of this 'Resource' (to be exact,
174 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
175 -- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
176 -- action is the exact path in the tree even if the
177 -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
181 -- > main = let tree = mkResTree [ (["foo"], resFoo) ]
182 -- > in runHttpd defaultConfig tree
184 -- > resFoo = ResourceDef {
185 -- > resIsGreedy = True
186 -- > , resGet = Just $ do requestURI <- getRequestURI
187 -- > resourcePath <- getResourcePath
188 -- > pathInfo <- getPathInfo
189 -- > -- uriPath requestURI == "/foo/bar/baz"
190 -- > -- resourcePath == ["foo"]
191 -- > -- pathInfo == ["bar", "baz"]
195 getResourcePath :: Resource [String]
196 getResourcePath = do itr <- ask
197 return $ fromJust $ itrResourcePath itr
200 -- |This is an analogy of CGI PATH_INFO. Its result is always @[]@ if
201 -- the 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not
202 -- greedy. See 'getResourcePath'.
203 getPathInfo :: Resource [String]
204 getPathInfo = do rsrcPath <- getResourcePath
205 reqURI <- getRequestURI
206 let reqPathStr = uriPath reqURI
207 reqPath = [x | x <- splitBy (== '/') reqPathStr, x /= ""]
208 -- rsrcPath と reqPath の共通する先頭部分を reqPath か
209 -- ら全部取り除くと、それは PATH_INFO のやうなものにな
210 -- る。rsrcPath は全部一致してゐるに決まってゐる(でな
211 -- ければこの Resource が撰ばれた筈が無い)ので、
212 -- rsrcPath の長さの分だけ削除すれば良い。
213 return $ drop (length rsrcPath) reqPath
215 -- |Get a value of given request header. Comparison of header name is
216 -- case-insensitive. Note that this action is not intended to be used
217 -- so frequently: there should be an action like 'getContentType' for
218 -- every common headers.
219 getHeader :: String -> Resource (Maybe String)
220 getHeader name = do itr <- ask
221 return $ H.getHeader name $ fromJust $ itrRequest itr
223 -- |Get a list of 'Network.HTTP.Lucu.MIMEType.MIMEType' enumerated on
224 -- header \"Accept\".
225 getAccept :: Resource [MIMEType]
226 getAccept = do accept <- getHeader "Accept"
227 if accept == Nothing then
230 case parseStr mimeTypeListP $ fromJust accept of
231 (Success xs, _) -> return xs
234 -- |Get the header \"Content-Type\" as
235 -- 'Network.HTTP.Lucu.MIMEType.MIMEType'.
236 getContentType :: Resource (Maybe MIMEType)
237 getContentType = do cType <- getHeader "Content-Type"
238 if cType == Nothing then
241 case parseStr mimeTypeP $ fromJust cType of
242 (Success t, _) -> return $ Just t
247 {- ExaminingRequest 時に使用するアクション群 -}
249 -- |Tell the system that the 'Resource' found an entity for the
250 -- request URI. If this is a GET or HEAD request, a found entity means
251 -- a datum to be replied. If this is a PUT or DELETE request, it means
252 -- a datum which was stored for the URI up to now. It is an error to
253 -- compute 'foundEntity' if this is a POST request.
255 -- Computation of 'foundEntity' performs \"If-Match\" test or
256 -- \"If-None-Match\" test if possible. When those tests fail, the
257 -- computation of 'Resource' immediately aborts with status \"412
258 -- Precondition Failed\" or \"304 Not Modified\" depending on the
261 -- If this is a GET or HEAD request, 'foundEntity' automatically puts
262 -- \"ETag\" and \"Last-Modified\" headers into the response.
263 foundEntity :: ETag -> ClockTime -> Resource ()
264 foundEntity tag timeStamp
265 = do driftTo ExaminingRequest
268 when (method == GET || method == HEAD)
269 $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
270 when (method == POST)
271 $ abort InternalServerError []
272 (Just "Illegal computation of foundEntity for POST request.")
277 -- |Tell the system that the 'Resource' found an entity for the
278 -- request URI. The only difference from 'foundEntity' is that
279 -- 'foundETag' doesn't (and can't) put \"Last-Modified\" header into
282 -- This action is not preferred. You should use 'foundEntity' when
284 foundETag :: ETag -> Resource ()
286 = do driftTo ExaminingRequest
289 when (method == GET || method == HEAD)
290 $ setHeader' "ETag" $ show tag
291 when (method == POST)
292 $ abort InternalServerError []
293 (Just "Illegal computation of foundETag for POST request.")
295 -- If-Match があればそれを見る。
296 ifMatch <- getHeader "If-Match"
299 Just "*" -> return ()
300 Just list -> case parseStr eTagListP list of
302 -- tags の中に一致するものが無ければ
303 -- PreconditionFailed で終了。
304 -> when (not $ any (== tag) tags)
305 $ abort PreconditionFailed []
306 $ Just ("The entity tag doesn't match: " ++ list)
307 _ -> abort BadRequest [] $ Just ("Unparsable If-Match: " ++ fromJust ifMatch)
309 let statusForNoneMatch = if method == GET || method == HEAD then
314 -- If-None-Match があればそれを見る。
315 ifNoneMatch <- getHeader "If-None-Match"
318 Just "*" -> abort statusForNoneMatch [] $ Just ("The entity tag matches: *")
319 Just list -> case parseStr eTagListP list of
321 -> when (any (== tag) tags)
322 $ abort statusForNoneMatch [] $ Just ("The entity tag matches: " ++ list)
323 _ -> abort BadRequest [] $ Just ("Unparsable If-None-Match: " ++ list)
327 -- |Tell the system that the 'Resource' found an entity for the
328 -- request URI. The only difference from 'foundEntity' is that
329 -- 'foundTimeStamp' performs \"If-Modified-Since\" test or
330 -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
331 -- \"If-None-Match\" test. Be aware that any tests based on last
332 -- modification time are unsafe because it is possible to mess up such
333 -- tests by modifying the entity twice in a second.
335 -- This action is not preferred. You should use 'foundEntity' when
337 foundTimeStamp :: ClockTime -> Resource ()
338 foundTimeStamp timeStamp
339 = do driftTo ExaminingRequest
342 when (method == GET || method == HEAD)
343 $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
344 when (method == POST)
345 $ abort InternalServerError []
346 (Just "Illegal computation of foundTimeStamp for POST request.")
348 let statusForIfModSince = if method == GET || method == HEAD then
353 -- If-Modified-Since があればそれを見る。
354 ifModSince <- getHeader "If-Modified-Since"
356 Just str -> case parseHTTPDateTime str of
358 -> when (timeStamp <= lastTime)
359 $ abort statusForIfModSince []
360 $ Just ("The entity has not been modified since " ++ str)
362 -> return () -- 不正な時刻は無視
365 -- If-Unmodified-Since があればそれを見る。
366 ifUnmodSince <- getHeader "If-Unmodified-Since"
368 Just str -> case parseHTTPDateTime str of
370 -> when (timeStamp > lastTime)
371 $ abort PreconditionFailed []
372 $ Just ("The entity has not been modified since " ++ str)
374 -> return () -- 不正な時刻は無視
379 -- |Computation of @'foundNoEntity' mStr@ tell the system that the
380 -- 'Resource' found no entity for the request URI. @mStr@ is an
381 -- optional error message to be replied to the client.
383 -- If this is a PUT request, 'foundNoEntity' performs \"If-Match\"
384 -- test and aborts with status \"412 Precondition Failed\" when it
385 -- failed. If this is a GET, HEAD or DELETE request, 'foundNoEntity'
386 -- always aborts with status \"404 Not Found\". It is an error to
387 -- compute 'foundNoEntity' if this is a POST request.
388 foundNoEntity :: Maybe String -> Resource ()
390 = do driftTo ExaminingRequest
393 when (method == POST)
394 $ abort InternalServerError []
395 (Just "Illegal computation of foundNoEntity for POST request.")
397 $ abort NotFound [] msgM
399 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
400 -- If-Match: 條件も滿たさない。
401 ifMatch <- getHeader "If-Match"
402 when (ifMatch /= Nothing)
403 $ abort PreconditionFailed [] msgM
408 {- GettingBody 時に使用するアクション群 -}
410 input :: Int -> Resource String
411 input limit = inputBS limit >>= return . B.unpack
414 -- 多くとも limit バイトまでのリクエストボディ全體を受信する。limit が
415 -- 零以下なら Config で設定されたデフォルトのボディ長により制限される。
416 inputBS :: Int -> Resource ByteString
418 = do driftTo GettingBody
420 hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
421 chunk <- if hasBody then
424 do driftTo DecidingHeader
428 askForInput :: Interaction -> Resource ByteString
430 = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
431 actualLimit = if limit <= 0 then
435 when (actualLimit <= 0)
436 $ fail ("inputBS: limit must be positive: " ++ show actualLimit)
439 $ do chunkLen <- readItr itr itrReqChunkLength id
440 writeItr itr itrWillReceiveBody True
441 if fmap (> actualLimit) chunkLen == Just True then
445 writeItr itr itrReqBodyWanted $ Just actualLimit
446 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
447 chunk <- liftIO $ atomically
448 $ do chunk <- readItr itr itrReceivedBody id
449 chunkIsOver <- readItr itr itrReqChunkIsOver id
450 if B.length chunk < fromIntegral actualLimit then
460 $ tooLarge actualLimit
461 -- 成功。itr 内にチャンクを置いたままにす
463 writeItr itr itrReceivedBody B.empty
465 driftTo DecidingHeader
468 tooLarge :: Int -> STM ()
469 tooLarge lim = abortSTM RequestEntityTooLarge []
470 $ Just ("Request body must be smaller than "
471 ++ show lim ++ " bytes.")
474 inputChunk :: Int -> Resource String
475 inputChunk limit = inputChunkBS limit >>= return . B.unpack
478 -- 多くとも limit バイトまでのリクエストボディの一部を受信する。limit
479 -- が 0 以下なら Config で設定されたデフォルトのボディ長により制限され
480 -- る。これ以上ボディが殘ってゐなければ空文字列を返す。
481 inputChunkBS :: Int -> Resource ByteString
483 = do driftTo GettingBody
485 hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
486 chunk <- if hasBody then
489 do driftTo DecidingHeader
493 askForInput :: Interaction -> Resource ByteString
495 = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
496 actualLimit = if limit < 0 then
500 when (actualLimit <= 0)
501 $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit)
504 $ do writeItr itr itrReqBodyWanted $ Just actualLimit
505 writeItr itr itrWillReceiveBody True
506 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
507 chunk <- liftIO $ atomically
508 $ do chunk <- readItr itr itrReceivedBody id
509 -- 要求された量に滿たなくて、まだ殘りがあ
511 when (B.length chunk < fromIntegral actualLimit)
512 $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
516 writeItr itr itrReceivedBody B.empty
519 $ driftTo DecidingHeader
523 -- application/x-www-form-urlencoded または multipart/form-data をパー
524 -- スする。もし Content-Type が無かったら BadRequest で終了し、未對應の
525 -- タイプであったら UnsupportedMediaType で終了する。
526 inputForm :: Int -> Resource [(String, String)]
528 = do cTypeM <- getContentType
531 -> abort BadRequest [] (Just "Missing Content-Type")
532 Just (MIMEType "application" "x-www-form-urlencoded" _)
533 -> readWWWFormURLEncoded
534 Just (MIMEType "multipart" "form-data" _)
535 -> readMultipartFormData
537 -> abort UnsupportedMediaType [] (Just $ "Unsupported media type: "
540 readWWWFormURLEncoded
541 = do src <- input limit
542 return $ do pairStr <- splitBy (\ c -> c == ';' || c == '&') src
543 let pair = break (== '=') pairStr
544 return ( unEscapeString $ fst pair
545 , unEscapeString $ snd pair
547 readMultipartFormData -- FIXME: 未對應
548 = abort UnsupportedMediaType []
549 (Just $ "Sorry, inputForm does not currently support multipart/form-data.")
557 {- DecidingHeader 時に使用するアクション群 -}
559 setStatus :: StatusCode -> Resource ()
561 = do driftTo DecidingHeader
563 liftIO $ atomically $ updateItr itr itrResponse
568 -- | Set a value of given resource header. Comparison of header name
569 -- is case-insensitive. Note that this action is not intended to be
570 -- used so frequently: there should be an action like 'setContentType'
571 -- for every common headers.
573 -- Some important headers (especially \"Content-Length\" and
574 -- \"Transfer-Encoding\") may be silently deleted or overwritten by
575 -- the system not to corrupt the interaction with client at the
576 -- viewpoint of HTTP protocol. For instance, if we are keeping
577 -- connection alive, for an obvious reason it causes a catastrophe to
578 -- send header \"Content-Length: 10\" and actually sending body of 20
580 setHeader :: String -> String -> Resource ()
582 = driftTo DecidingHeader >> setHeader' name value
585 setHeader' :: String -> String -> Resource()
586 setHeader' name value
589 $ updateItr itr itrResponse
590 $ H.setHeader name value
593 redirect :: StatusCode -> URI -> Resource ()
595 = do when (code == NotModified || not (isRedirection code))
596 $ abort InternalServerError []
597 $ Just ("Attempted to redirect with status " ++ show code)
599 setHeader "Location" (uriToString id uri $ "")
602 setContentType :: MIMEType -> Resource ()
604 = setHeader "Content-Type" $ show mType
607 {- DecidingBody 時に使用するアクション群 -}
609 output :: String -> Resource ()
610 output = outputBS . B.pack
613 outputBS :: ByteString -> Resource ()
614 outputBS str = do outputChunkBS str
618 outputChunk :: String -> Resource ()
619 outputChunk = outputChunkBS . B.pack
622 {- チャンクの大きさは Config で制限されてゐる。もし例へば /dev/zero を
623 B.readFile して作った ByteString をそのまま ResponseWriter に渡した
624 りすると大變な事が起こる。何故なら ResponseWriter は
625 Transfer-Encoding: chunked の時、ヘッダを書く爲にチャンクの大きさを
626 測るから、その時に起こるであらう事は言ふまでも無い。 -}
628 outputChunkBS :: ByteString -> Resource ()
630 = do driftTo DecidingBody
633 let limit = cnfMaxOutputChunkLength $ itrConfig itr
635 $ fail ("cnfMaxOutputChunkLength must be positive: "
638 discardBody <- liftIO $ atomically $
639 readItr itr itrWillDiscardBody id
642 $ sendChunks str limit
645 $ liftIO $ atomically $
646 writeItr itr itrBodyIsNull False
648 sendChunks :: ByteString -> Int -> Resource ()
650 | B.null str = return ()
651 | otherwise = do let (chunk, remaining) = B.splitAt (fromIntegral limit) str
653 liftIO $ atomically $
654 do buf <- readItr itr itrBodyToSend id
657 writeItr itr itrBodyToSend chunk
662 sendChunks remaining limit
666 [GettingBody からそれ以降の状態に遷移する時]
668 body を讀み終へてゐなければ、殘りの body を讀み捨てる。
671 [DecidingHeader からそれ以降の状態に遷移する時]
678 bodyIsNull が False ならば何もしない。True だった場合は出力補完す
683 driftTo :: InteractionState -> Resource ()
686 liftIO $ atomically $ do oldState <- readItr itr itrState id
687 if newState < oldState then
688 throwStateError oldState newState
690 do let a = [oldState .. newState]
693 mapM_ (uncurry $ drift itr) c
694 writeItr itr itrState newState
696 throwStateError :: Monad m => InteractionState -> InteractionState -> m a
698 throwStateError Done DecidingBody
699 = fail "It makes no sense to output something after finishing to output."
701 throwStateError old new
702 = fail ("state error: " ++ show old ++ " ==> " ++ show new)
705 drift :: Interaction -> InteractionState -> InteractionState -> STM ()
707 drift itr GettingBody _
708 = writeItr itr itrReqBodyWasteAll True
710 drift itr DecidingHeader _
714 = do bodyIsNull <- readItr itr itrBodyIsNull id
716 $ writeDefaultPage itr