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
26 , setStatus -- StatusCode -> Resource ()
27 , setHeader -- String -> String -> Resource ()
28 , redirect -- StatusCode -> URI -> Resource ()
29 , setETag -- ETag -> Resource ()
30 , setLastModified -- ClockTime -> Resource ()
31 , setContentType -- MIMEType -> Resource ()
33 , output -- String -> Resource ()
34 , outputChunk -- String -> Resource ()
35 , outputBS -- ByteString -> Resource ()
36 , outputChunkBS -- ByteString -> Resource ()
38 , driftTo -- InteractionState -> Resource ()
42 import Control.Concurrent.STM
43 import Control.Monad.Reader
44 import qualified Data.ByteString.Lazy.Char8 as B
45 import Data.ByteString.Lazy.Char8 (ByteString)
48 import GHC.Conc (unsafeIOToSTM)
49 import Network.HTTP.Lucu.Abortion
50 import Network.HTTP.Lucu.Config
51 import Network.HTTP.Lucu.DefaultPage
52 import Network.HTTP.Lucu.ETag
53 import qualified Network.HTTP.Lucu.Headers as H
54 import Network.HTTP.Lucu.HttpVersion
55 import Network.HTTP.Lucu.Interaction
56 import Network.HTTP.Lucu.Parser
57 import Network.HTTP.Lucu.Postprocess
58 import Network.HTTP.Lucu.RFC1123DateTime
59 import Network.HTTP.Lucu.Request
60 import Network.HTTP.Lucu.Response
61 import Network.HTTP.Lucu.MIMEType
62 import Network.HTTP.Lucu.Utils
67 type Resource a = ReaderT Interaction IO a
70 getConfig :: Resource Config
71 getConfig = do itr <- ask
72 return $ itrConfig itr
75 getRequest :: Resource Request
76 getRequest = do itr <- ask
77 return $ fromJust $ itrRequest itr
80 getMethod :: Resource Method
81 getMethod = do req <- getRequest
82 return $ reqMethod req
85 getRequestURI :: Resource URI
86 getRequestURI = do req <- getRequest
90 getResourcePath :: Resource [String]
91 getResourcePath = do itr <- ask
92 return $ fromJust $ itrResourcePath itr
95 getPathInfo :: Resource [String]
96 getPathInfo = do rsrcPath <- getResourcePath
97 reqURI <- getRequestURI
98 let reqPathStr = uriPath reqURI
99 reqPath = [x | x <- splitBy (== '/') reqPathStr, x /= ""]
100 -- rsrcPath と reqPath の共通する先頭部分を reqPath か
101 -- ら全部取り除くと、それは PATH_INFO のやうなものにな
102 -- る。rsrcPath は全部一致してゐるに決まってゐる(でな
103 -- ければこの Resource が撰ばれた筈が無い)ので、
104 -- rsrcPath の長さの分だけ削除すれば良い。
105 return $ drop (length rsrcPath) reqPath
108 getHeader :: String -> Resource (Maybe String)
109 getHeader name = do itr <- ask
110 return $ H.getHeader name $ fromJust $ itrRequest itr
113 getAccept :: Resource [MIMEType]
114 getAccept = do accept <- getHeader "Accept"
115 if accept == Nothing then
118 case parseStr mimeTypeListP $ fromJust accept of
119 (Success xs, _) -> return xs
123 getContentType :: Resource (Maybe MIMEType)
124 getContentType = do cType <- getHeader "Content-Type"
125 if cType == Nothing then
128 case parseStr mimeTypeP $ fromJust cType of
129 (Success t, _) -> return $ Just t
134 {- ExaminingRequest 時に使用するアクション群 -}
136 foundEntity :: ETag -> ClockTime -> Resource ()
137 foundEntity tag timeStamp
138 = do driftTo ExaminingRequest
141 when (method == GET || method == HEAD)
142 $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
148 foundETag :: ETag -> Resource ()
150 = do driftTo ExaminingRequest
153 when (method == GET || method == HEAD)
154 $ setHeader' "ETag" $ show tag
156 -- If-Match があればそれを見る。
157 ifMatch <- getHeader "If-Match"
160 Just "*" -> return ()
161 Just list -> case parseStr eTagListP list of
163 -- tags の中に一致するものが無ければ
164 -- PreconditionFailed で終了。
165 -> when (not $ any (== tag) tags)
166 $ abort PreconditionFailed []
167 $ Just ("The entity tag doesn't match: " ++ list)
168 _ -> abort BadRequest [] $ Just ("Unparsable If-Match: " ++ fromJust ifMatch)
170 let statusForNoneMatch = if method == GET || method == HEAD then
175 -- If-None-Match があればそれを見る。
176 ifNoneMatch <- getHeader "If-None-Match"
179 Just "*" -> abort statusForNoneMatch [] $ Just ("The entity tag matches: *")
180 Just list -> case parseStr eTagListP list of
182 -> when (any (== tag) tags)
183 $ abort statusForNoneMatch [] $ Just ("The entity tag matches: " ++ list)
184 _ -> abort BadRequest [] $ Just ("Unparsable If-None-Match: " ++ list)
189 foundTimeStamp :: ClockTime -> Resource ()
190 foundTimeStamp timeStamp
191 = do driftTo ExaminingRequest
194 when (method == GET || method == HEAD)
195 $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
197 let statusForIfModSince = if method == GET || method == HEAD then
202 -- If-Modified-Since があればそれを見る。
203 ifModSince <- getHeader "If-Modified-Since"
205 Just str -> case parseHTTPDateTime str of
207 -> when (timeStamp <= lastTime)
208 $ abort statusForIfModSince []
209 $ Just ("The entity has not been modified since " ++ str)
211 -> return () -- 不正な時刻は無視
214 -- If-Unmodified-Since があればそれを見る。
215 ifUnmodSince <- getHeader "If-Unmodified-Since"
217 Just str -> case parseHTTPDateTime str of
219 -> when (timeStamp > lastTime)
220 $ abort PreconditionFailed []
221 $ Just ("The entity has not been modified since " ++ str)
223 -> return () -- 不正な時刻は無視
229 foundNoEntity :: Maybe String -> Resource ()
231 = do driftTo ExaminingRequest
235 $ abort NotFound [] msgM
237 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
238 -- If-Match: 條件も滿たさない。
239 ifMatch <- getHeader "If-Match"
240 when (ifMatch /= Nothing)
241 $ abort PreconditionFailed [] msgM
246 {- GettingBody 時に使用するアクション群 -}
248 input :: Int -> Resource String
249 input limit = inputBS limit >>= return . B.unpack
252 -- 多くとも limit バイトまでのリクエストボディ全體を受信する。limit が
253 -- 零以下なら Config で設定されたデフォルトのボディ長により制限される。
254 inputBS :: Int -> Resource ByteString
256 = do driftTo GettingBody
258 hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
259 chunk <- if hasBody then
262 do driftTo DecidingHeader
266 askForInput :: Interaction -> Resource ByteString
268 = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
269 actualLimit = if limit <= 0 then
273 when (actualLimit <= 0)
274 $ fail ("inputBS: limit must be positive: " ++ show actualLimit)
277 $ do chunkLen <- readItr itr itrReqChunkLength id
278 writeItr itr itrWillReceiveBody True
279 if fmap (> actualLimit) chunkLen == Just True then
283 writeItr itr itrReqBodyWanted $ Just actualLimit
284 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
285 chunk <- liftIO $ atomically
286 $ do chunk <- readItr itr itrReceivedBody id
287 chunkIsOver <- readItr itr itrReqChunkIsOver id
288 if B.length chunk < fromIntegral actualLimit then
298 $ tooLarge actualLimit
299 -- 成功。itr 内にチャンクを置いたままにす
301 writeItr itr itrReceivedBody B.empty
303 driftTo DecidingHeader
306 tooLarge :: Int -> STM ()
307 tooLarge lim = abortSTM RequestEntityTooLarge []
308 $ Just ("Request body must be smaller than "
309 ++ show lim ++ " bytes.")
312 inputChunk :: Int -> Resource String
313 inputChunk limit = inputChunkBS limit >>= return . B.unpack
316 -- 多くとも limit バイトまでのリクエストボディの一部を受信する。limit
317 -- が 0 以下なら Config で設定されたデフォルトのボディ長により制限され
318 -- る。これ以上ボディが殘ってゐなければ空文字列を返す。
319 inputChunkBS :: Int -> Resource ByteString
321 = do driftTo GettingBody
323 hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
324 chunk <- if hasBody then
327 do driftTo DecidingHeader
331 askForInput :: Interaction -> Resource ByteString
333 = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
334 actualLimit = if limit < 0 then
338 when (actualLimit <= 0)
339 $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit)
342 $ do writeItr itr itrReqBodyWanted $ Just actualLimit
343 writeItr itr itrWillReceiveBody True
344 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
345 chunk <- liftIO $ atomically
346 $ do chunk <- readItr itr itrReceivedBody id
347 -- 要求された量に滿たなくて、まだ殘りがあ
349 when (B.length chunk < fromIntegral actualLimit)
350 $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
354 writeItr itr itrReceivedBody B.empty
357 $ driftTo DecidingHeader
366 {- DecidingHeader 時に使用するアクション群 -}
368 setStatus :: StatusCode -> Resource ()
370 = do driftTo DecidingHeader
372 liftIO $ atomically $ updateItr itr itrResponse
373 $ \ resM -> case resM of
374 Nothing -> Just $ Response {
375 resVersion = HttpVersion 1 1
379 Just res -> Just $ res {
384 setHeader :: String -> String -> Resource ()
386 = driftTo DecidingHeader >> setHeader' name value
389 setHeader' :: String -> String -> Resource()
390 setHeader' name value
392 liftIO $ atomically $ updateItr itr itrResponse
393 $ \ resM -> case resM of
394 Nothing -> Just $ Response {
395 resVersion = HttpVersion 1 1
397 , resHeaders = [ (name, value) ]
399 Just res -> Just $ H.setHeader name value res
402 redirect :: StatusCode -> URI -> Resource ()
404 = do when (code == NotModified || not (isRedirection code))
405 $ abort InternalServerError []
406 $ Just ("Attempted to redirect with status " ++ show code)
408 setHeader "Location" (uriToString id uri $ "")
411 setETag :: ETag -> Resource ()
413 = setHeader "ETag" $ show tag
416 setLastModified :: ClockTime -> Resource ()
417 setLastModified lastmod
418 = setHeader "Last-Modified" $ formatHTTPDateTime lastmod
421 setContentType :: MIMEType -> Resource ()
423 = setHeader "Content-Type" $ show mType
426 {- DecidingBody 時に使用するアクション群 -}
428 output :: String -> Resource ()
429 output = outputBS . B.pack
432 outputBS :: ByteString -> Resource ()
433 outputBS str = do outputChunkBS str
437 outputChunk :: String -> Resource ()
438 outputChunk = outputChunkBS . B.pack
441 {- チャンクの大きさは Config で制限されてゐる。もし例へば /dev/zero を
442 B.readFile して作った ByteString をそのまま ResponseWriter に渡した
443 りすると大變な事が起こる。何故なら ResponseWriter は
444 Transfer-Encoding: chunked の時、ヘッダを書く爲にチャンクの大きさを
445 測るから、その時に起こるであらう事は言ふまでも無い。 -}
447 outputChunkBS :: ByteString -> Resource ()
449 = do driftTo DecidingBody
452 let limit = cnfMaxOutputChunkLength $ itrConfig itr
454 $ fail ("cnfMaxOutputChunkLength must be positive: "
457 discardBody <- liftIO $ atomically $
458 readItr itr itrWillDiscardBody id
461 $ sendChunks str limit
464 $ liftIO $ atomically $
465 writeItr itr itrBodyIsNull False
467 sendChunks :: ByteString -> Int -> Resource ()
469 | B.null str = return ()
470 | otherwise = do let (chunk, remaining) = B.splitAt (fromIntegral limit) str
472 liftIO $ atomically $
473 do buf <- readItr itr itrBodyToSend id
476 writeItr itr itrBodyToSend chunk
481 sendChunks remaining limit
485 [GettingBody からそれ以降の状態に遷移する時]
487 body を讀み終へてゐなければ、殘りの body を讀み捨てる。
490 [DecidingHeader からそれ以降の状態に遷移する時]
497 bodyIsNull が False ならば何もしない。True だった場合は出力補完す
498 る。Content-Type も變はる。但し(デフォルトのまま)Status が 200 OK
499 だった場合は、補完の代はりに 204 No Content に變へる。
503 driftTo :: InteractionState -> Resource ()
506 liftIO $ atomically $ do oldState <- readItr itr itrState id
507 if newState < oldState then
508 throwStateError oldState newState
510 do let a = [oldState .. newState]
513 mapM_ (uncurry $ drift itr) c
514 writeItr itr itrState newState
516 throwStateError :: Monad m => InteractionState -> InteractionState -> m a
518 throwStateError Done DecidingBody
519 = fail "It makes no sense to output something after finishing to output."
521 throwStateError old new
522 = fail ("state error: " ++ show old ++ " ==> " ++ show new)
525 drift :: Interaction -> InteractionState -> InteractionState -> STM ()
527 drift itr GettingBody _
528 = writeItr itr itrReqBodyWasteAll True
530 drift itr DecidingHeader _
534 = do bodyIsNull <- readItr itr itrBodyIsNull id
536 $ do status <- readStatus itr
538 do updateItrF itr itrResponse
539 $ \ res -> res { resStatus = NoContent }
540 updateItrF itr itrResponse
541 $ H.deleteHeader "Content-Type"
542 updateItrF itr itrResponse
543 $ H.deleteHeader "ETag"
544 updateItrF itr itrResponse
545 $ H.deleteHeader "Last-Modified"
554 readStatus :: Interaction -> STM StatusCode
555 readStatus itr = readItr itr itrResponse (resStatus . fromJust)