1 module Network.HTTP.Lucu.Resource
4 , getConfig -- Resource Config
5 , getRequest -- Resource Request
6 , getMethod -- Resource Method
7 , getRequestURI -- Resource URI
8 , getResourcePath -- Resource [String]
9 , getPathInfo -- Resource [String]
11 , getHeader -- String -> Resource (Maybe String)
12 , getAccept -- Resource [MIMEType]
13 , getContentType -- Resource (Maybe MIMEType)
15 , foundEntity -- ETag -> ClockTime -> Resource ()
16 , foundETag -- ETag -> Resource ()
17 , foundTimeStamp -- ClockTime -> Resource ()
18 , foundNoEntity -- Maybe String -> Resource ()
20 , input -- Int -> Resource String
21 , inputChunk -- Int -> Resource String
22 , inputBS -- Int -> Resource ByteString
23 , inputChunkBS -- Int -> Resource ByteString
24 , inputForm -- Int -> Resource [(String, String)]
27 , setStatus -- StatusCode -> Resource ()
28 , setHeader -- String -> String -> Resource ()
29 , redirect -- StatusCode -> URI -> Resource ()
30 , setETag -- ETag -> Resource ()
31 , setLastModified -- ClockTime -> Resource ()
32 , setContentType -- MIMEType -> Resource ()
34 , output -- String -> Resource ()
35 , outputChunk -- String -> Resource ()
36 , outputBS -- ByteString -> Resource ()
37 , outputChunkBS -- ByteString -> Resource ()
39 , driftTo -- InteractionState -> Resource ()
43 import Control.Concurrent.STM
44 import Control.Monad.Reader
45 import qualified Data.ByteString.Lazy.Char8 as B
46 import Data.ByteString.Lazy.Char8 (ByteString)
49 import GHC.Conc (unsafeIOToSTM)
50 import Network.HTTP.Lucu.Abortion
51 import Network.HTTP.Lucu.Config
52 import Network.HTTP.Lucu.DefaultPage
53 import Network.HTTP.Lucu.ETag
54 import qualified Network.HTTP.Lucu.Headers as H
55 import Network.HTTP.Lucu.HttpVersion
56 import Network.HTTP.Lucu.Interaction
57 import Network.HTTP.Lucu.Parser
58 import Network.HTTP.Lucu.Postprocess
59 import Network.HTTP.Lucu.RFC1123DateTime
60 import Network.HTTP.Lucu.Request
61 import Network.HTTP.Lucu.Response
62 import Network.HTTP.Lucu.MIMEType
63 import Network.HTTP.Lucu.Utils
68 type Resource a = ReaderT Interaction IO a
71 getConfig :: Resource Config
72 getConfig = do itr <- ask
73 return $ itrConfig itr
76 getRequest :: Resource Request
77 getRequest = do itr <- ask
78 return $ fromJust $ itrRequest itr
81 getMethod :: Resource Method
82 getMethod = do req <- getRequest
83 return $ reqMethod req
86 getRequestURI :: Resource URI
87 getRequestURI = do req <- getRequest
91 getResourcePath :: Resource [String]
92 getResourcePath = do itr <- ask
93 return $ fromJust $ itrResourcePath itr
96 getPathInfo :: Resource [String]
97 getPathInfo = do rsrcPath <- getResourcePath
98 reqURI <- getRequestURI
99 let reqPathStr = uriPath reqURI
100 reqPath = [x | x <- splitBy (== '/') reqPathStr, x /= ""]
101 -- rsrcPath と reqPath の共通する先頭部分を reqPath か
102 -- ら全部取り除くと、それは PATH_INFO のやうなものにな
103 -- る。rsrcPath は全部一致してゐるに決まってゐる(でな
104 -- ければこの Resource が撰ばれた筈が無い)ので、
105 -- rsrcPath の長さの分だけ削除すれば良い。
106 return $ drop (length rsrcPath) reqPath
109 getHeader :: String -> Resource (Maybe String)
110 getHeader name = do itr <- ask
111 return $ H.getHeader name $ fromJust $ itrRequest itr
114 getAccept :: Resource [MIMEType]
115 getAccept = do accept <- getHeader "Accept"
116 if accept == Nothing then
119 case parseStr mimeTypeListP $ fromJust accept of
120 (Success xs, _) -> return xs
124 getContentType :: Resource (Maybe MIMEType)
125 getContentType = do cType <- getHeader "Content-Type"
126 if cType == Nothing then
129 case parseStr mimeTypeP $ fromJust cType of
130 (Success t, _) -> return $ Just t
135 {- ExaminingRequest 時に使用するアクション群 -}
137 foundEntity :: ETag -> ClockTime -> Resource ()
138 foundEntity tag timeStamp
139 = do driftTo ExaminingRequest
142 when (method == GET || method == HEAD)
143 $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
149 foundETag :: ETag -> Resource ()
151 = do driftTo ExaminingRequest
154 when (method == GET || method == HEAD)
155 $ setHeader' "ETag" $ show tag
157 -- If-Match があればそれを見る。
158 ifMatch <- getHeader "If-Match"
161 Just "*" -> return ()
162 Just list -> case parseStr eTagListP list of
164 -- tags の中に一致するものが無ければ
165 -- PreconditionFailed で終了。
166 -> when (not $ any (== tag) tags)
167 $ abort PreconditionFailed []
168 $ Just ("The entity tag doesn't match: " ++ list)
169 _ -> abort BadRequest [] $ Just ("Unparsable If-Match: " ++ fromJust ifMatch)
171 let statusForNoneMatch = if method == GET || method == HEAD then
176 -- If-None-Match があればそれを見る。
177 ifNoneMatch <- getHeader "If-None-Match"
180 Just "*" -> abort statusForNoneMatch [] $ Just ("The entity tag matches: *")
181 Just list -> case parseStr eTagListP list of
183 -> when (any (== tag) tags)
184 $ abort statusForNoneMatch [] $ Just ("The entity tag matches: " ++ list)
185 _ -> abort BadRequest [] $ Just ("Unparsable If-None-Match: " ++ list)
190 foundTimeStamp :: ClockTime -> Resource ()
191 foundTimeStamp timeStamp
192 = do driftTo ExaminingRequest
195 when (method == GET || method == HEAD)
196 $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
198 let statusForIfModSince = if method == GET || method == HEAD then
203 -- If-Modified-Since があればそれを見る。
204 ifModSince <- getHeader "If-Modified-Since"
206 Just str -> case parseHTTPDateTime str of
208 -> when (timeStamp <= lastTime)
209 $ abort statusForIfModSince []
210 $ Just ("The entity has not been modified since " ++ str)
212 -> return () -- 不正な時刻は無視
215 -- If-Unmodified-Since があればそれを見る。
216 ifUnmodSince <- getHeader "If-Unmodified-Since"
218 Just str -> case parseHTTPDateTime str of
220 -> when (timeStamp > lastTime)
221 $ abort PreconditionFailed []
222 $ Just ("The entity has not been modified since " ++ str)
224 -> return () -- 不正な時刻は無視
230 foundNoEntity :: Maybe String -> Resource ()
232 = do driftTo ExaminingRequest
236 $ abort NotFound [] msgM
238 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
239 -- If-Match: 條件も滿たさない。
240 ifMatch <- getHeader "If-Match"
241 when (ifMatch /= Nothing)
242 $ abort PreconditionFailed [] msgM
247 {- GettingBody 時に使用するアクション群 -}
249 input :: Int -> Resource String
250 input limit = inputBS limit >>= return . B.unpack
253 -- 多くとも limit バイトまでのリクエストボディ全體を受信する。limit が
254 -- 零以下なら Config で設定されたデフォルトのボディ長により制限される。
255 inputBS :: Int -> Resource ByteString
257 = do driftTo GettingBody
259 hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
260 chunk <- if hasBody then
263 do driftTo DecidingHeader
267 askForInput :: Interaction -> Resource ByteString
269 = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
270 actualLimit = if limit <= 0 then
274 when (actualLimit <= 0)
275 $ fail ("inputBS: limit must be positive: " ++ show actualLimit)
278 $ do chunkLen <- readItr itr itrReqChunkLength id
279 writeItr itr itrWillReceiveBody True
280 if fmap (> actualLimit) chunkLen == Just True then
284 writeItr itr itrReqBodyWanted $ Just actualLimit
285 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
286 chunk <- liftIO $ atomically
287 $ do chunk <- readItr itr itrReceivedBody id
288 chunkIsOver <- readItr itr itrReqChunkIsOver id
289 if B.length chunk < fromIntegral actualLimit then
299 $ tooLarge actualLimit
300 -- 成功。itr 内にチャンクを置いたままにす
302 writeItr itr itrReceivedBody B.empty
304 driftTo DecidingHeader
307 tooLarge :: Int -> STM ()
308 tooLarge lim = abortSTM RequestEntityTooLarge []
309 $ Just ("Request body must be smaller than "
310 ++ show lim ++ " bytes.")
313 inputChunk :: Int -> Resource String
314 inputChunk limit = inputChunkBS limit >>= return . B.unpack
317 -- 多くとも limit バイトまでのリクエストボディの一部を受信する。limit
318 -- が 0 以下なら Config で設定されたデフォルトのボディ長により制限され
319 -- る。これ以上ボディが殘ってゐなければ空文字列を返す。
320 inputChunkBS :: Int -> Resource ByteString
322 = do driftTo GettingBody
324 hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
325 chunk <- if hasBody then
328 do driftTo DecidingHeader
332 askForInput :: Interaction -> Resource ByteString
334 = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
335 actualLimit = if limit < 0 then
339 when (actualLimit <= 0)
340 $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit)
343 $ do writeItr itr itrReqBodyWanted $ Just actualLimit
344 writeItr itr itrWillReceiveBody True
345 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
346 chunk <- liftIO $ atomically
347 $ do chunk <- readItr itr itrReceivedBody id
348 -- 要求された量に滿たなくて、まだ殘りがあ
350 when (B.length chunk < fromIntegral actualLimit)
351 $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
355 writeItr itr itrReceivedBody B.empty
358 $ driftTo DecidingHeader
362 -- application/x-www-form-urlencoded または multipart/form-data をパー
363 -- スする。もし Content-Type が無かったら BadRequest で終了し、未對應の
364 -- タイプであったら UnsupportedMediaType で終了する。
365 inputForm :: Int -> Resource [(String, String)]
367 = do cTypeM <- getContentType
370 -> abort BadRequest [] (Just "Missing Content-Type")
371 Just (MIMEType "application" "x-www-form-urlencoded" _)
372 -> readWWWFormURLEncoded
373 Just (MIMEType "multipart" "form-data" _)
374 -> readMultipartFormData
376 -> abort UnsupportedMediaType [] (Just $ "Unsupported media type: "
379 readWWWFormURLEncoded
380 = do src <- input limit
381 return $ do pairStr <- splitBy (\ c -> c == ';' || c == '&') src
382 let pair = break (== '=') pairStr
383 return ( unEscapeString $ fst pair
384 , unEscapeString $ snd pair
386 readMultipartFormData -- FIXME: 未對應
387 = abort UnsupportedMediaType []
388 (Just $ "Sorry, inputForm does not currently support multipart/form-data.")
396 {- DecidingHeader 時に使用するアクション群 -}
398 setStatus :: StatusCode -> Resource ()
400 = do driftTo DecidingHeader
402 liftIO $ atomically $ updateItr itr itrResponse
403 $ \ resM -> case resM of
404 Nothing -> Just $ Response {
405 resVersion = HttpVersion 1 1
409 Just res -> Just $ res {
414 setHeader :: String -> String -> Resource ()
416 = driftTo DecidingHeader >> setHeader' name value
419 setHeader' :: String -> String -> Resource()
420 setHeader' name value
422 liftIO $ atomically $ updateItr itr itrResponse
423 $ \ resM -> case resM of
424 Nothing -> Just $ Response {
425 resVersion = HttpVersion 1 1
427 , resHeaders = [ (name, value) ]
429 Just res -> Just $ H.setHeader name value res
432 redirect :: StatusCode -> URI -> Resource ()
434 = do when (code == NotModified || not (isRedirection code))
435 $ abort InternalServerError []
436 $ Just ("Attempted to redirect with status " ++ show code)
438 setHeader "Location" (uriToString id uri $ "")
441 setETag :: ETag -> Resource ()
443 = setHeader "ETag" $ show tag
446 setLastModified :: ClockTime -> Resource ()
447 setLastModified lastmod
448 = setHeader "Last-Modified" $ formatHTTPDateTime lastmod
451 setContentType :: MIMEType -> Resource ()
453 = setHeader "Content-Type" $ show mType
456 {- DecidingBody 時に使用するアクション群 -}
458 output :: String -> Resource ()
459 output = outputBS . B.pack
462 outputBS :: ByteString -> Resource ()
463 outputBS str = do outputChunkBS str
467 outputChunk :: String -> Resource ()
468 outputChunk = outputChunkBS . B.pack
471 {- チャンクの大きさは Config で制限されてゐる。もし例へば /dev/zero を
472 B.readFile して作った ByteString をそのまま ResponseWriter に渡した
473 りすると大變な事が起こる。何故なら ResponseWriter は
474 Transfer-Encoding: chunked の時、ヘッダを書く爲にチャンクの大きさを
475 測るから、その時に起こるであらう事は言ふまでも無い。 -}
477 outputChunkBS :: ByteString -> Resource ()
479 = do driftTo DecidingBody
482 let limit = cnfMaxOutputChunkLength $ itrConfig itr
484 $ fail ("cnfMaxOutputChunkLength must be positive: "
487 discardBody <- liftIO $ atomically $
488 readItr itr itrWillDiscardBody id
491 $ sendChunks str limit
494 $ liftIO $ atomically $
495 writeItr itr itrBodyIsNull False
497 sendChunks :: ByteString -> Int -> Resource ()
499 | B.null str = return ()
500 | otherwise = do let (chunk, remaining) = B.splitAt (fromIntegral limit) str
502 liftIO $ atomically $
503 do buf <- readItr itr itrBodyToSend id
506 writeItr itr itrBodyToSend chunk
511 sendChunks remaining limit
515 [GettingBody からそれ以降の状態に遷移する時]
517 body を讀み終へてゐなければ、殘りの body を讀み捨てる。
520 [DecidingHeader からそれ以降の状態に遷移する時]
527 bodyIsNull が False ならば何もしない。True だった場合は出力補完す
528 る。Content-Type も變はる。但し(デフォルトのまま)Status が 200 OK
529 だった場合は、補完の代はりに 204 No Content に變へる。
533 driftTo :: InteractionState -> Resource ()
536 liftIO $ atomically $ do oldState <- readItr itr itrState id
537 if newState < oldState then
538 throwStateError oldState newState
540 do let a = [oldState .. newState]
543 mapM_ (uncurry $ drift itr) c
544 writeItr itr itrState newState
546 throwStateError :: Monad m => InteractionState -> InteractionState -> m a
548 throwStateError Done DecidingBody
549 = fail "It makes no sense to output something after finishing to output."
551 throwStateError old new
552 = fail ("state error: " ++ show old ++ " ==> " ++ show new)
555 drift :: Interaction -> InteractionState -> InteractionState -> STM ()
557 drift itr GettingBody _
558 = writeItr itr itrReqBodyWasteAll True
560 drift itr DecidingHeader _
564 = do bodyIsNull <- readItr itr itrBodyIsNull id
566 $ do status <- readStatus itr
568 do updateItrF itr itrResponse
569 $ \ res -> res { resStatus = NoContent }
570 updateItrF itr itrResponse
571 $ H.deleteHeader "Content-Type"
572 updateItrF itr itrResponse
573 $ H.deleteHeader "ETag"
574 updateItrF itr itrResponse
575 $ H.deleteHeader "Last-Modified"
584 readStatus :: Interaction -> STM StatusCode
585 readStatus itr = readItr itr itrResponse (resStatus . fromJust)