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 is composed of the following states. The initial
21 -- state is /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 headers. When it transits to the next state, ...
50 module Network.HTTP.Lucu.Resource
91 import Control.Concurrent.STM
92 import Control.Monad.Reader
93 import qualified Data.ByteString.Lazy.Char8 as B
94 import Data.ByteString.Lazy.Char8 (ByteString)
97 import GHC.Conc (unsafeIOToSTM)
98 import Network.HTTP.Lucu.Abortion
99 import Network.HTTP.Lucu.Config
100 import Network.HTTP.Lucu.DefaultPage
101 import Network.HTTP.Lucu.ETag
102 import qualified Network.HTTP.Lucu.Headers as H
103 import Network.HTTP.Lucu.HttpVersion
104 import Network.HTTP.Lucu.Interaction
105 import Network.HTTP.Lucu.Parser
106 import Network.HTTP.Lucu.Postprocess
107 import Network.HTTP.Lucu.RFC1123DateTime
108 import Network.HTTP.Lucu.Request
109 import Network.HTTP.Lucu.Response
110 import Network.HTTP.Lucu.MIMEType
111 import Network.HTTP.Lucu.Utils
116 type Resource a = ReaderT Interaction IO a
119 getConfig :: Resource Config
120 getConfig = do itr <- ask
121 return $ itrConfig itr
124 getRequest :: Resource Request
125 getRequest = do itr <- ask
126 return $ fromJust $ itrRequest itr
129 getMethod :: Resource Method
130 getMethod = do req <- getRequest
131 return $ reqMethod req
134 getRequestURI :: Resource URI
135 getRequestURI = do req <- getRequest
139 getResourcePath :: Resource [String]
140 getResourcePath = do itr <- ask
141 return $ fromJust $ itrResourcePath itr
144 getPathInfo :: Resource [String]
145 getPathInfo = do rsrcPath <- getResourcePath
146 reqURI <- getRequestURI
147 let reqPathStr = uriPath reqURI
148 reqPath = [x | x <- splitBy (== '/') reqPathStr, x /= ""]
149 -- rsrcPath と reqPath の共通する先頭部分を reqPath か
150 -- ら全部取り除くと、それは PATH_INFO のやうなものにな
151 -- る。rsrcPath は全部一致してゐるに決まってゐる(でな
152 -- ければこの Resource が撰ばれた筈が無い)ので、
153 -- rsrcPath の長さの分だけ削除すれば良い。
154 return $ drop (length rsrcPath) reqPath
157 getHeader :: String -> Resource (Maybe String)
158 getHeader name = do itr <- ask
159 return $ H.getHeader name $ fromJust $ itrRequest itr
162 getAccept :: Resource [MIMEType]
163 getAccept = do accept <- getHeader "Accept"
164 if accept == Nothing then
167 case parseStr mimeTypeListP $ fromJust accept of
168 (Success xs, _) -> return xs
172 getContentType :: Resource (Maybe MIMEType)
173 getContentType = do cType <- getHeader "Content-Type"
174 if cType == Nothing then
177 case parseStr mimeTypeP $ fromJust cType of
178 (Success t, _) -> return $ Just t
183 {- ExaminingRequest 時に使用するアクション群 -}
185 foundEntity :: ETag -> ClockTime -> Resource ()
186 foundEntity tag timeStamp
187 = do driftTo ExaminingRequest
190 when (method == GET || method == HEAD)
191 $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
197 foundETag :: ETag -> Resource ()
199 = do driftTo ExaminingRequest
202 when (method == GET || method == HEAD)
203 $ setHeader' "ETag" $ show tag
205 -- If-Match があればそれを見る。
206 ifMatch <- getHeader "If-Match"
209 Just "*" -> return ()
210 Just list -> case parseStr eTagListP list of
212 -- tags の中に一致するものが無ければ
213 -- PreconditionFailed で終了。
214 -> when (not $ any (== tag) tags)
215 $ abort PreconditionFailed []
216 $ Just ("The entity tag doesn't match: " ++ list)
217 _ -> abort BadRequest [] $ Just ("Unparsable If-Match: " ++ fromJust ifMatch)
219 let statusForNoneMatch = if method == GET || method == HEAD then
224 -- If-None-Match があればそれを見る。
225 ifNoneMatch <- getHeader "If-None-Match"
228 Just "*" -> abort statusForNoneMatch [] $ Just ("The entity tag matches: *")
229 Just list -> case parseStr eTagListP list of
231 -> when (any (== tag) tags)
232 $ abort statusForNoneMatch [] $ Just ("The entity tag matches: " ++ list)
233 _ -> abort BadRequest [] $ Just ("Unparsable If-None-Match: " ++ list)
238 foundTimeStamp :: ClockTime -> Resource ()
239 foundTimeStamp timeStamp
240 = do driftTo ExaminingRequest
243 when (method == GET || method == HEAD)
244 $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
246 let statusForIfModSince = if method == GET || method == HEAD then
251 -- If-Modified-Since があればそれを見る。
252 ifModSince <- getHeader "If-Modified-Since"
254 Just str -> case parseHTTPDateTime str of
256 -> when (timeStamp <= lastTime)
257 $ abort statusForIfModSince []
258 $ Just ("The entity has not been modified since " ++ str)
260 -> return () -- 不正な時刻は無視
263 -- If-Unmodified-Since があればそれを見る。
264 ifUnmodSince <- getHeader "If-Unmodified-Since"
266 Just str -> case parseHTTPDateTime str of
268 -> when (timeStamp > lastTime)
269 $ abort PreconditionFailed []
270 $ Just ("The entity has not been modified since " ++ str)
272 -> return () -- 不正な時刻は無視
278 foundNoEntity :: Maybe String -> Resource ()
280 = do driftTo ExaminingRequest
284 $ abort NotFound [] msgM
286 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
287 -- If-Match: 條件も滿たさない。
288 ifMatch <- getHeader "If-Match"
289 when (ifMatch /= Nothing)
290 $ abort PreconditionFailed [] msgM
295 {- GettingBody 時に使用するアクション群 -}
297 input :: Int -> Resource String
298 input limit = inputBS limit >>= return . B.unpack
301 -- 多くとも limit バイトまでのリクエストボディ全體を受信する。limit が
302 -- 零以下なら Config で設定されたデフォルトのボディ長により制限される。
303 inputBS :: Int -> Resource ByteString
305 = do driftTo GettingBody
307 hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
308 chunk <- if hasBody then
311 do driftTo DecidingHeader
315 askForInput :: Interaction -> Resource ByteString
317 = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
318 actualLimit = if limit <= 0 then
322 when (actualLimit <= 0)
323 $ fail ("inputBS: limit must be positive: " ++ show actualLimit)
326 $ do chunkLen <- readItr itr itrReqChunkLength id
327 writeItr itr itrWillReceiveBody True
328 if fmap (> actualLimit) chunkLen == Just True then
332 writeItr itr itrReqBodyWanted $ Just actualLimit
333 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
334 chunk <- liftIO $ atomically
335 $ do chunk <- readItr itr itrReceivedBody id
336 chunkIsOver <- readItr itr itrReqChunkIsOver id
337 if B.length chunk < fromIntegral actualLimit then
347 $ tooLarge actualLimit
348 -- 成功。itr 内にチャンクを置いたままにす
350 writeItr itr itrReceivedBody B.empty
352 driftTo DecidingHeader
355 tooLarge :: Int -> STM ()
356 tooLarge lim = abortSTM RequestEntityTooLarge []
357 $ Just ("Request body must be smaller than "
358 ++ show lim ++ " bytes.")
361 inputChunk :: Int -> Resource String
362 inputChunk limit = inputChunkBS limit >>= return . B.unpack
365 -- 多くとも limit バイトまでのリクエストボディの一部を受信する。limit
366 -- が 0 以下なら Config で設定されたデフォルトのボディ長により制限され
367 -- る。これ以上ボディが殘ってゐなければ空文字列を返す。
368 inputChunkBS :: Int -> Resource ByteString
370 = do driftTo GettingBody
372 hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
373 chunk <- if hasBody then
376 do driftTo DecidingHeader
380 askForInput :: Interaction -> Resource ByteString
382 = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
383 actualLimit = if limit < 0 then
387 when (actualLimit <= 0)
388 $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit)
391 $ do writeItr itr itrReqBodyWanted $ Just actualLimit
392 writeItr itr itrWillReceiveBody True
393 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
394 chunk <- liftIO $ atomically
395 $ do chunk <- readItr itr itrReceivedBody id
396 -- 要求された量に滿たなくて、まだ殘りがあ
398 when (B.length chunk < fromIntegral actualLimit)
399 $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
403 writeItr itr itrReceivedBody B.empty
406 $ driftTo DecidingHeader
410 -- application/x-www-form-urlencoded または multipart/form-data をパー
411 -- スする。もし Content-Type が無かったら BadRequest で終了し、未對應の
412 -- タイプであったら UnsupportedMediaType で終了する。
413 inputForm :: Int -> Resource [(String, String)]
415 = do cTypeM <- getContentType
418 -> abort BadRequest [] (Just "Missing Content-Type")
419 Just (MIMEType "application" "x-www-form-urlencoded" _)
420 -> readWWWFormURLEncoded
421 Just (MIMEType "multipart" "form-data" _)
422 -> readMultipartFormData
424 -> abort UnsupportedMediaType [] (Just $ "Unsupported media type: "
427 readWWWFormURLEncoded
428 = do src <- input limit
429 return $ do pairStr <- splitBy (\ c -> c == ';' || c == '&') src
430 let pair = break (== '=') pairStr
431 return ( unEscapeString $ fst pair
432 , unEscapeString $ snd pair
434 readMultipartFormData -- FIXME: 未對應
435 = abort UnsupportedMediaType []
436 (Just $ "Sorry, inputForm does not currently support multipart/form-data.")
444 {- DecidingHeader 時に使用するアクション群 -}
446 setStatus :: StatusCode -> Resource ()
448 = do driftTo DecidingHeader
450 liftIO $ atomically $ updateItr itr itrResponse
456 setHeader :: String -> String -> Resource ()
458 = driftTo DecidingHeader >> setHeader' name value
461 setHeader' :: String -> String -> Resource()
462 setHeader' name value
465 $ updateItr itr itrResponse
466 $ H.setHeader name value
469 redirect :: StatusCode -> URI -> Resource ()
471 = do when (code == NotModified || not (isRedirection code))
472 $ abort InternalServerError []
473 $ Just ("Attempted to redirect with status " ++ show code)
475 setHeader "Location" (uriToString id uri $ "")
478 setETag :: ETag -> Resource ()
480 = setHeader "ETag" $ show tag
483 setLastModified :: ClockTime -> Resource ()
484 setLastModified lastmod
485 = setHeader "Last-Modified" $ formatHTTPDateTime lastmod
488 setContentType :: MIMEType -> Resource ()
490 = setHeader "Content-Type" $ show mType
493 {- DecidingBody 時に使用するアクション群 -}
495 output :: String -> Resource ()
496 output = outputBS . B.pack
499 outputBS :: ByteString -> Resource ()
500 outputBS str = do outputChunkBS str
504 outputChunk :: String -> Resource ()
505 outputChunk = outputChunkBS . B.pack
508 {- チャンクの大きさは Config で制限されてゐる。もし例へば /dev/zero を
509 B.readFile して作った ByteString をそのまま ResponseWriter に渡した
510 りすると大變な事が起こる。何故なら ResponseWriter は
511 Transfer-Encoding: chunked の時、ヘッダを書く爲にチャンクの大きさを
512 測るから、その時に起こるであらう事は言ふまでも無い。 -}
514 outputChunkBS :: ByteString -> Resource ()
516 = do driftTo DecidingBody
519 let limit = cnfMaxOutputChunkLength $ itrConfig itr
521 $ fail ("cnfMaxOutputChunkLength must be positive: "
524 discardBody <- liftIO $ atomically $
525 readItr itr itrWillDiscardBody id
528 $ sendChunks str limit
531 $ liftIO $ atomically $
532 writeItr itr itrBodyIsNull False
534 sendChunks :: ByteString -> Int -> Resource ()
536 | B.null str = return ()
537 | otherwise = do let (chunk, remaining) = B.splitAt (fromIntegral limit) str
539 liftIO $ atomically $
540 do buf <- readItr itr itrBodyToSend id
543 writeItr itr itrBodyToSend chunk
548 sendChunks remaining limit
552 [GettingBody からそれ以降の状態に遷移する時]
554 body を讀み終へてゐなければ、殘りの body を讀み捨てる。
557 [DecidingHeader からそれ以降の状態に遷移する時]
564 bodyIsNull が False ならば何もしない。True だった場合は出力補完す
569 driftTo :: InteractionState -> Resource ()
572 liftIO $ atomically $ do oldState <- readItr itr itrState id
573 if newState < oldState then
574 throwStateError oldState newState
576 do let a = [oldState .. newState]
579 mapM_ (uncurry $ drift itr) c
580 writeItr itr itrState newState
582 throwStateError :: Monad m => InteractionState -> InteractionState -> m a
584 throwStateError Done DecidingBody
585 = fail "It makes no sense to output something after finishing to output."
587 throwStateError old new
588 = fail ("state error: " ++ show old ++ " ==> " ++ show new)
591 drift :: Interaction -> InteractionState -> InteractionState -> STM ()
593 drift itr GettingBody _
594 = writeItr itr itrReqBodyWasteAll True
596 drift itr DecidingHeader _
600 = do bodyIsNull <- readItr itr itrBodyIsNull id
602 $ writeDefaultPage itr