1 module Network.HTTP.Lucu.Resource
4 , getConfig -- Resource Config
5 , getMethod -- Resource Method
6 , getHeader -- String -> Resource (Maybe String)
7 , getAccept -- Resource [MIMEType]
8 , getContentType -- Resource (Maybe MIMEType)
10 , foundEntity -- ETag -> ClockTime -> Resource ()
11 , foundETag -- ETag -> Resource ()
12 , foundTimeStamp -- ClockTime -> Resource ()
13 , foundNoEntity -- Maybe String -> Resource ()
15 , input -- Int -> Resource String
16 , inputChunk -- Int -> Resource String
17 , inputBS -- Int -> Resource ByteString
18 , inputChunkBS -- Int -> Resource ByteString
21 , setStatus -- StatusCode -> Resource ()
22 , setHeader -- String -> String -> Resource ()
23 , redirect -- StatusCode -> URI -> Resource ()
24 , setETag -- ETag -> Resource ()
25 , setLastModified -- ClockTime -> Resource ()
26 , setContentType -- MIMEType -> Resource ()
28 , output -- String -> Resource ()
29 , outputChunk -- String -> Resource ()
30 , outputBS -- ByteString -> Resource ()
31 , outputChunkBS -- ByteString -> Resource ()
33 , driftTo -- InteractionState -> Resource ()
37 import Control.Concurrent.STM
38 import Control.Monad.Reader
39 import qualified Data.ByteString.Lazy.Char8 as B
40 import Data.ByteString.Lazy.Char8 (ByteString)
43 import GHC.Conc (unsafeIOToSTM)
44 import Network.HTTP.Lucu.Abortion
45 import Network.HTTP.Lucu.Config
46 import Network.HTTP.Lucu.DefaultPage
47 import Network.HTTP.Lucu.ETag
48 import qualified Network.HTTP.Lucu.Headers as H
49 import Network.HTTP.Lucu.HttpVersion
50 import Network.HTTP.Lucu.Interaction
51 import Network.HTTP.Lucu.Parser
52 import Network.HTTP.Lucu.Postprocess
53 import Network.HTTP.Lucu.RFC1123DateTime
54 import Network.HTTP.Lucu.Request
55 import Network.HTTP.Lucu.Response
56 import Network.HTTP.Lucu.MIMEType
57 import Network.HTTP.Lucu.Utils
62 type Resource a = ReaderT Interaction IO a
65 getConfig :: Resource Config
66 getConfig = do itr <- ask
67 return $ itrConfig itr
70 getMethod :: Resource Method
71 getMethod = do itr <- ask
72 return $ reqMethod $ fromJust $ itrRequest itr
75 getHeader :: String -> Resource (Maybe String)
76 getHeader name = do itr <- ask
77 return $ H.getHeader name $ fromJust $ itrRequest itr
80 getAccept :: Resource [MIMEType]
81 getAccept = do accept <- getHeader "Accept"
82 if accept == Nothing then
85 case parseStr mimeTypeListP $ fromJust accept of
86 (Success xs, _) -> return xs
90 getContentType :: Resource (Maybe MIMEType)
91 getContentType = do cType <- getHeader "Content-Type"
92 if cType == Nothing then
95 case parseStr mimeTypeP $ fromJust cType of
96 (Success t, _) -> return $ Just t
101 {- ExaminingRequest 時に使用するアクション群 -}
103 foundEntity :: ETag -> ClockTime -> Resource ()
104 foundEntity tag timeStamp
105 = do driftTo ExaminingRequest
108 when (method == GET || method == HEAD)
109 $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
115 foundETag :: ETag -> Resource ()
117 = do driftTo ExaminingRequest
120 when (method == GET || method == HEAD)
121 $ setHeader' "ETag" $ show tag
123 -- If-Match があればそれを見る。
124 ifMatch <- getHeader "If-Match"
127 Just "*" -> return ()
128 Just list -> case parseStr eTagListP list of
130 -- tags の中に一致するものが無ければ
131 -- PreconditionFailed で終了。
132 -> when (not $ any (== tag) tags)
133 $ abort PreconditionFailed []
134 $ Just ("The entity tag doesn't match: " ++ list)
135 _ -> abort BadRequest [] $ Just ("Unparsable If-Match: " ++ fromJust ifMatch)
137 let statusForNoneMatch = if method == GET || method == HEAD then
142 -- If-None-Match があればそれを見る。
143 ifNoneMatch <- getHeader "If-None-Match"
146 Just "*" -> abort statusForNoneMatch [] $ Just ("The entity tag matches: *")
147 Just list -> case parseStr eTagListP list of
149 -> when (any (== tag) tags)
150 $ abort statusForNoneMatch [] $ Just ("The entity tag matches: " ++ list)
151 _ -> abort BadRequest [] $ Just ("Unparsable If-None-Match: " ++ list)
156 foundTimeStamp :: ClockTime -> Resource ()
157 foundTimeStamp timeStamp
158 = do driftTo ExaminingRequest
161 when (method == GET || method == HEAD)
162 $ setHeader' "Last-Modified" $ formatHTTPDateTime timeStamp
164 let statusForIfModSince = if method == GET || method == HEAD then
169 -- If-Modified-Since があればそれを見る。
170 ifModSince <- getHeader "If-Modified-Since"
172 Just str -> case parseHTTPDateTime str of
174 -> when (timeStamp <= lastTime)
175 $ abort statusForIfModSince []
176 $ Just ("The entity has not been modified since " ++ str)
178 -> return () -- 不正な時刻は無視
181 -- If-Unmodified-Since があればそれを見る。
182 ifUnmodSince <- getHeader "If-Unmodified-Since"
184 Just str -> case parseHTTPDateTime str of
186 -> when (timeStamp > lastTime)
187 $ abort PreconditionFailed []
188 $ Just ("The entity has not been modified since " ++ str)
190 -> return () -- 不正な時刻は無視
196 foundNoEntity :: Maybe String -> Resource ()
198 = do driftTo ExaminingRequest
202 $ abort NotFound [] msgM
204 -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
205 -- If-Match: 條件も滿たさない。
206 ifMatch <- getHeader "If-Match"
207 when (ifMatch /= Nothing)
208 $ abort PreconditionFailed [] msgM
213 {- GettingBody 時に使用するアクション群 -}
215 input :: Int -> Resource String
216 input limit = inputBS limit >>= return . B.unpack
219 -- 多くとも limit バイトまでのリクエストボディ全體を受信する。limit が
220 -- 零以下なら Config で設定されたデフォルトのボディ長により制限される。
221 inputBS :: Int -> Resource ByteString
223 = do driftTo GettingBody
225 hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
226 chunk <- if hasBody then
229 do driftTo DecidingHeader
233 askForInput :: Interaction -> Resource ByteString
235 = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
236 actualLimit = if limit <= 0 then
240 when (actualLimit <= 0)
241 $ fail ("inputBS: limit must be positive: " ++ show actualLimit)
244 $ do chunkLen <- readItr itr itrReqChunkLength id
245 writeItr itr itrWillReceiveBody True
246 if fmap (> actualLimit) chunkLen == Just True then
250 writeItr itr itrReqBodyWanted $ Just actualLimit
251 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
252 chunk <- liftIO $ atomically
253 $ do chunk <- readItr itr itrReceivedBody id
254 chunkIsOver <- readItr itr itrReqChunkIsOver id
255 if B.length chunk < fromIntegral actualLimit then
265 $ tooLarge actualLimit
266 -- 成功。itr 内にチャンクを置いたままにす
268 writeItr itr itrReceivedBody B.empty
270 driftTo DecidingHeader
273 tooLarge :: Int -> STM ()
274 tooLarge lim = abortSTM RequestEntityTooLarge []
275 $ Just ("Request body must be smaller than "
276 ++ show lim ++ " bytes.")
279 inputChunk :: Int -> Resource String
280 inputChunk limit = inputChunkBS limit >>= return . B.unpack
283 -- 多くとも limit バイトまでのリクエストボディの一部を受信する。limit
284 -- が 0 以下なら Config で設定されたデフォルトのボディ長により制限され
285 -- る。これ以上ボディが殘ってゐなければ空文字列を返す。
286 inputChunkBS :: Int -> Resource ByteString
288 = do driftTo GettingBody
290 hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
291 chunk <- if hasBody then
294 do driftTo DecidingHeader
298 askForInput :: Interaction -> Resource ByteString
300 = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
301 actualLimit = if limit < 0 then
305 when (actualLimit <= 0)
306 $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit)
309 $ do writeItr itr itrReqBodyWanted $ Just actualLimit
310 writeItr itr itrWillReceiveBody True
311 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
312 chunk <- liftIO $ atomically
313 $ do chunk <- readItr itr itrReceivedBody id
314 -- 要求された量に滿たなくて、まだ殘りがあ
316 when (B.length chunk < fromIntegral actualLimit)
317 $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
321 writeItr itr itrReceivedBody B.empty
324 $ driftTo DecidingHeader
333 {- DecidingHeader 時に使用するアクション群 -}
335 setStatus :: StatusCode -> Resource ()
337 = do driftTo DecidingHeader
339 liftIO $ atomically $ updateItr itr itrResponse
340 $ \ resM -> case resM of
341 Nothing -> Just $ Response {
342 resVersion = HttpVersion 1 1
346 Just res -> Just $ res {
351 setHeader :: String -> String -> Resource ()
353 = driftTo DecidingHeader >> setHeader' name value
356 setHeader' :: String -> String -> Resource()
357 setHeader' name value
359 liftIO $ atomically $ updateItr itr itrResponse
360 $ \ resM -> case resM of
361 Nothing -> Just $ Response {
362 resVersion = HttpVersion 1 1
364 , resHeaders = [ (name, value) ]
366 Just res -> Just $ H.setHeader name value res
369 redirect :: StatusCode -> URI -> Resource ()
371 = do when (code == NotModified || not (isRedirection code))
372 $ abort InternalServerError []
373 $ Just ("Attempted to redirect with status " ++ show code)
375 setHeader "Location" (uriToString id uri $ "")
378 setETag :: ETag -> Resource ()
380 = setHeader "ETag" $ show tag
383 setLastModified :: ClockTime -> Resource ()
384 setLastModified lastmod
385 = setHeader "Last-Modified" $ formatHTTPDateTime lastmod
388 setContentType :: MIMEType -> Resource ()
390 = setHeader "Content-Type" $ show mType
393 {- DecidingBody 時に使用するアクション群 -}
395 output :: String -> Resource ()
396 output = outputBS . B.pack
399 outputBS :: ByteString -> Resource ()
400 outputBS str = do outputChunkBS str
404 outputChunk :: String -> Resource ()
405 outputChunk = outputChunkBS . B.pack
408 {- チャンクの大きさは Config で制限されてゐる。もし例へば /dev/zero を
409 B.readFile して作った ByteString をそのまま ResponseWriter に渡した
410 りすると大變な事が起こる。何故なら ResponseWriter は
411 Transfer-Encoding: chunked の時、ヘッダを書く爲にチャンクの大きさを
412 測るから、その時に起こるであらう事は言ふまでも無い。 -}
414 outputChunkBS :: ByteString -> Resource ()
416 = do driftTo DecidingBody
420 let limit = cnfMaxOutputChunkLength $ itrConfig itr
422 $ fail ("cnfMaxOutputChunkLength must be positive: "
427 liftIO $ atomically $
428 writeItr itr itrBodyIsNull False
430 sendChunks :: ByteString -> Int -> Resource ()
432 | B.null str = return ()
433 | otherwise = do let (chunk, remaining) = B.splitAt (fromIntegral limit) str
435 liftIO $ atomically $
436 do buf <- readItr itr itrBodyToSend id
439 writeItr itr itrBodyToSend chunk
444 sendChunks remaining limit
448 [GettingBody からそれ以降の状態に遷移する時]
450 body を讀み終へてゐなければ、殘りの body を讀み捨てる。
453 [DecidingHeader からそれ以降の状態に遷移する時]
460 bodyIsNull が False ならば何もしない。True だった場合は出力補完す
461 る。Content-Type も變はる。但し(デフォルトのまま)Status が 200 OK
462 だった場合は、補完の代はりに 204 No Content に變へる。
466 driftTo :: InteractionState -> Resource ()
469 liftIO $ atomically $ do oldState <- readItr itr itrState id
470 if newState < oldState then
471 throwStateError oldState newState
473 do let a = [oldState .. newState]
476 mapM_ (uncurry $ drift itr) c
477 writeItr itr itrState newState
479 throwStateError :: Monad m => InteractionState -> InteractionState -> m a
481 throwStateError Done DecidingBody
482 = fail "It makes no sense to output something after finishing to output."
484 throwStateError old new
485 = fail ("state error: " ++ show old ++ " ==> " ++ show new)
488 drift :: Interaction -> InteractionState -> InteractionState -> STM ()
490 drift itr GettingBody _
491 = writeItr itr itrReqBodyWasteAll True
493 drift itr DecidingHeader _
497 = do bodyIsNull <- readItr itr itrBodyIsNull id
499 $ do status <- readStatus itr
501 do updateItrF itr itrResponse
502 $ \ res -> res { resStatus = NoContent }
503 updateItrF itr itrResponse
504 $ H.deleteHeader "Content-Type"
505 updateItrF itr itrResponse
506 $ H.deleteHeader "ETag"
507 updateItrF itr itrResponse
508 $ H.deleteHeader "Last-Modified"
517 readStatus :: Interaction -> STM StatusCode
518 readStatus itr = readItr itr itrResponse (resStatus . fromJust)