1 module Network.HTTP.Lucu.Resource
5 , mkResTree -- [ ([String], ResourceDef) ] -> ResTree
6 , findResource -- ResTree -> URI -> Maybe ResourceDef
7 , runResource -- ResourceDef -> Interaction -> IO ThreadId
9 , input -- Int -> Resource String
10 , inputChunk -- Int -> Resource String
11 , inputBS -- Int -> Resource ByteString
12 , inputChunkBS -- Int -> Resource ByteString
15 , setStatus -- StatusCode -> Resource ()
16 , setHeader -- String -> String -> Resource ()
18 , redirect -- StatusCode -> URI -> Resource ()
20 , output -- String -> Resource ()
21 , outputChunk -- String -> Resource ()
22 , outputBS -- ByteString -> Resource ()
23 , outputChunkBS -- ByteString -> Resource ()
27 import Control.Concurrent
28 import Control.Concurrent.STM
29 import Control.Exception
30 import Control.Monad.Reader
31 import qualified Data.ByteString.Lazy.Char8 as B
32 import Data.ByteString.Lazy.Char8 (ByteString)
35 import qualified Data.Map as M
38 import GHC.Conc (unsafeIOToSTM)
39 import Network.HTTP.Lucu.Abortion
40 import Network.HTTP.Lucu.Config
41 import Network.HTTP.Lucu.DefaultPage
42 import qualified Network.HTTP.Lucu.Headers as H
43 import Network.HTTP.Lucu.HttpVersion
44 import Network.HTTP.Lucu.Interaction
45 import Network.HTTP.Lucu.Postprocess
46 import Network.HTTP.Lucu.Request
47 import Network.HTTP.Lucu.Response
48 import Network.HTTP.Lucu.Utils
50 import Prelude hiding (catch)
52 import System.IO.Error hiding (catch)
55 type Resource a = ReaderT Interaction IO a
58 {- /aaa/bbb/ccc にアクセスされた時、もし /aaa/bbb に貪欲なリソースがあ
59 れば、假に /aaa/bbb/ccc に何らかのリソースがあったとしても必ず
60 /aaa/bbb が撰ばれる。/aaa/bbb のリソースが貪欲でなければ、それは無視
62 data ResourceDef = ResourceDef {
63 resUsesNativeThread :: Bool
65 , resGet :: Maybe (Resource ())
66 , resHead :: Maybe (Resource ())
67 , resPost :: Maybe (Resource ())
68 , resPut :: Maybe (Resource ())
69 , resDelete :: Maybe (Resource ())
71 type ResTree = ResNode -- root だから Map ではない
72 type ResSubtree = Map String ResNode
73 data ResNode = ResNode (Maybe ResourceDef) ResSubtree
76 mkResTree :: [ ([String], ResourceDef) ] -> ResTree
77 mkResTree list = processRoot list
79 processRoot :: [ ([String], ResourceDef) ] -> ResTree
81 = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list
82 children = processNonRoot nonRoots
85 -- / にリソースが定義されない。/foo とかにはあるかも。
86 ResNode Nothing children
89 let (_, def) = last roots
91 ResNode (Just def) children
93 processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree
95 = let subtree = M.fromList [(name, node name)
97 childNames = [name | (name:_, _) <- list]
98 node name = let defs = [def | (path, def) <- list, path == [name]]
103 ResNode Nothing children
106 ResNode (Just $ last defs) children
107 children = processNonRoot [(path, def)
108 | (_:path, def) <- list, not (null path)]
113 findResource :: ResTree -> URI -> Maybe ResourceDef
114 findResource (ResNode rootDefM subtree) uri
115 = let pathStr = uriPath uri
116 path = [x | x <- splitBy (== '/') pathStr, x /= ""]
121 walkTree subtree path
123 walkTree :: ResSubtree -> [String] -> Maybe ResourceDef
125 walkTree subtree (name:[])
126 = case M.lookup name subtree of
128 Just (ResNode defM _) -> defM
130 walkTree subtree (x:xs)
131 = case M.lookup x subtree of
133 Just (ResNode defM children) -> case defM of
134 Just (ResourceDef { resIsGreedy = True })
136 _ -> walkTree children xs
139 runResource :: ResourceDef -> Interaction -> IO ThreadId
142 $ catch ( runReaderT ( do fromMaybe notAllowed rsrc
146 $ \ exc -> processException (itrConfig itr) exc
148 fork :: IO () -> IO ThreadId
149 fork = if (resUsesNativeThread def)
153 rsrc :: Maybe (Resource ())
154 rsrc = case reqMethod $ fromJust $ itrRequest itr of
156 HEAD -> case resHead def of
158 Nothing -> resGet def
161 DELETE -> resDelete def
163 notAllowed :: Resource ()
164 notAllowed = do setStatus MethodNotAllowed
165 setHeader "Allow" $ joinWith ", " allowedMethods
167 allowedMethods :: [String]
168 allowedMethods = nub $ foldr (++) [] [ methods resGet ["GET"]
169 , methods resHead ["GET", "HEAD"]
170 , methods resPost ["POST"]
171 , methods resPut ["PUT"]
172 , methods resDelete ["DELETE"]
175 methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
176 methods f xs = case f def of
180 processException :: Config -> Exception -> IO ()
181 processException conf exc
182 = do let abo = case exc of
183 ErrorCall msg -> Abortion InternalServerError [] msg
184 IOException ioE -> Abortion InternalServerError [] $ formatIOE ioE
185 DynException dynE -> case fromDynamic dynE of
186 Just (abo :: Abortion) -> abo
188 -> Abortion InternalServerError []
190 _ -> Abortion InternalServerError [] $ show exc
191 -- まだ DecidingHeader 以前の状態だったら、この途中終了
192 -- を應答に反映させる餘地がある。さうでなければ stderr
194 state <- atomically $ readItr itr itrState id
195 if state <= DecidingHeader then
197 $ do setStatus $ aboStatus abo
198 -- FIXME: 同じ名前で複數の値があった時は、こ
200 mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo
201 setHeader "Content-Type" "application/xhtml+xml"
202 output $ aboPage conf abo
204 hPutStrLn stderr $ show abo
206 flip runReaderT itr $ driftTo Done
208 formatIOE :: IOError -> String
209 formatIOE ioE = if isUserError ioE then
210 ioeGetErrorString ioE
217 input :: Int -> Resource String
218 input limit = inputBS limit >>= return . B.unpack
221 -- 多くとも limit バイトまでのリクエストボディ全體を受信する。limit が
222 -- 零以下なら Config で設定されたデフォルトのボディ長により制限される。
223 inputBS :: Int -> Resource ByteString
225 = do driftTo GettingBody
227 let defaultLimit = cnfMaxEntityLength $ itrConfig itr
228 actualLimit = if limit <= 0 then
232 when (actualLimit <= 0)
233 $ fail ("inputBS: limit must be positive: " ++ show actualLimit)
236 $ do chunkLen <- readItr itr itrReqChunkLength id
237 writeItr itr itrWillReceiveBody True
238 if fmap (> actualLimit) chunkLen == Just True then
242 writeItr itr itrReqBodyWanted $ Just actualLimit
243 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
244 chunk <- liftIO $ atomically
245 $ do chunk <- readItr itr itrReceivedBody id
246 chunkIsOver <- readItr itr itrReqChunkIsOver id
247 if B.length chunk < fromIntegral actualLimit then
248 -- 要求された量に滿たなくて、まだ殘りがある
253 -- 制限値一杯まで讀むやうに指示したのにまだ殘っ
256 $ tooLarge actualLimit
257 -- 成功。itr 内にチャンクを置いたままにするとメ
259 writeItr itr itrReceivedBody B.empty
261 driftTo DecidingHeader
264 tooLarge :: Int -> STM ()
265 tooLarge lim = abortSTM RequestEntityTooLarge []
266 ("Request body must be smaller than "
267 ++ show lim ++ " bytes.")
270 inputChunk :: Int -> Resource String
271 inputChunk limit = inputChunkBS limit >>= return . B.unpack
274 -- 多くとも limit バイトまでのリクエストボディの一部を受信する。limit
275 -- が 0 以下なら Config で設定されたデフォルトのボディ長により制限され
276 -- る。これ以上ボディが殘ってゐなければ空文字列を返す。
277 inputChunkBS :: Int -> Resource ByteString
279 = do driftTo GettingBody
281 let defaultLimit = cnfMaxEntityLength $ itrConfig itr
282 actualLimit = if limit < 0 then
286 when (actualLimit <= 0)
287 $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit)
290 $ do writeItr itr itrReqBodyWanted $ Just actualLimit
291 writeItr itr itrWillReceiveBody True
292 -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
293 chunk <- liftIO $ atomically
294 $ do chunk <- readItr itr itrReceivedBody id
295 -- 要求された量に滿たなくて、まだ殘りがあるなら
297 when (B.length chunk < fromIntegral actualLimit)
298 $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
302 writeItr itr itrReceivedBody B.empty
305 $ driftTo DecidingHeader
313 setStatus :: StatusCode -> Resource ()
315 = do driftTo DecidingHeader
317 liftIO $ atomically $ updateItr itr itrResponse
318 $ \ resM -> case resM of
319 Nothing -> Just $ Response {
320 resVersion = HttpVersion 1 1
324 Just res -> Just $ res {
329 setHeader :: String -> String -> Resource ()
331 = do driftTo DecidingHeader
333 liftIO $ atomically $ updateItr itr itrResponse
334 $ \ resM -> case resM of
335 Nothing -> Just $ Response {
336 resVersion = HttpVersion 1 1
338 , resHeaders = [ (name, value) ]
340 Just res -> Just $ H.setHeader name value res
343 redirect :: StatusCode -> URI -> Resource ()
345 = do when (code == NotModified || not (isRedirection code))
346 $ abort InternalServerError []
347 $ "Attempted to redirect with status " ++ show code
349 setHeader "Location" (uriToString id uri $ "")
352 output :: String -> Resource ()
353 output = outputBS . B.pack
356 outputBS :: ByteString -> Resource ()
357 outputBS str = do outputChunkBS str
361 outputChunk :: String -> Resource ()
362 outputChunk = outputChunkBS . B.pack
365 outputChunkBS :: ByteString -> Resource ()
366 outputChunkBS str = do driftTo DecidingBody
368 liftIO $ atomically $
369 do updateItr itr itrBodyToSend (flip B.append str)
371 $ writeItr itr itrBodyIsNull False
376 [GettingBody からそれ以降の状態に遷移する時]
378 body を讀み終へてゐなければ、殘りの body を讀み捨てる。
381 [DecidingHeader からそれ以降の状態に遷移する時]
388 bodyIsNull が False ならば何もしない。True だった場合は出力補完す
389 る。Content-Type も變はる。但し(デフォルトのまま)Status が 200 OK
390 だった場合は、補完の代はりに 204 No Content に變へる。
394 driftTo :: InteractionState -> Resource ()
397 liftIO $ atomically $ do oldState <- readItr itr itrState id
398 if newState < oldState then
399 throwStateError oldState newState
401 do let a = [oldState .. newState]
404 mapM_ (uncurry $ drift itr) c
405 writeItr itr itrState newState
407 throwStateError :: Monad m => InteractionState -> InteractionState -> m a
409 throwStateError Done DecidingBody
410 = fail "It makes no sense to output something after finishing to output."
412 throwStateError old new
413 = fail ("state error: " ++ show old ++ " ==> " ++ show new)
416 drift :: Interaction -> InteractionState -> InteractionState -> STM ()
418 drift itr GettingBody _
419 = writeItr itr itrReqBodyWasteAll True
421 drift itr DecidingHeader _
425 = do bodyIsNull <- readItr itr itrBodyIsNull id
427 $ do status <- readStatus itr
429 do updateItrF itr itrResponse
430 $ \ res -> res { resStatus = NoContent }
431 updateItrF itr itrResponse
432 $ H.deleteHeader "Content-Type"
433 updateItrF itr itrResponse
434 $ H.deleteHeader "ETag"
435 updateItrF itr itrResponse
436 $ H.deleteHeader "Last-Modified"
445 readStatus :: Interaction -> STM StatusCode
446 readStatus itr = readItr itr itrResponse (resStatus . fromJust)