X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource%2FTree.hs;h=2cd498f7ade7c7f4e5435d2344e161a5717cf65e;hb=50e8fe7af585a8d33d93b3721be8f8f01905b891;hp=c2f6add5483b2e19a653ce1d25f51510407a65ad;hpb=8e78bc83bfe67a376293c346ae0b30f1a684c787;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index c2f6add..2cd498f 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -4,6 +4,8 @@ module Network.HTTP.Lucu.Resource.Tree ( ResourceDef(..) , ResTree + , FallbackHandler + , mkResTree -- [ ([String], ResourceDef) ] -> ResTree , findResource -- ResTree -> URI -> Maybe ([String], ResourceDef) @@ -14,7 +16,8 @@ module Network.HTTP.Lucu.Resource.Tree import Control.Concurrent import Control.Concurrent.STM import Control.Exception -import Control.Monad.Reader +import Control.Monad +import qualified Data.ByteString.Char8 as C8 import Data.Dynamic import Data.List import qualified Data.Map as M @@ -22,6 +25,7 @@ import Data.Map (Map) import Data.Maybe import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.Headers (emptyHeaders, fromHeaders) import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Resource import Network.HTTP.Lucu.Response @@ -33,6 +37,15 @@ import System.IO.Error hiding (catch) import Prelude hiding (catch) +-- |'FallbackHandler' is an extra resource handler for resources which +-- can't be statically located somewhere in the resource tree. The +-- Lucu httpd first search for a resource in the tree, and then call +-- fallback handlers to ask them for a resource. If all of the +-- handlers returned 'Prelude.Nothing', the httpd responds with 404 +-- Not Found. +type FallbackHandler = [String] -> IO (Maybe ResourceDef) + + -- "/aaa/bbb/ccc" にアクセスされた時、もし "/aaa/bbb" に貪欲なリソース -- があれば、假に "/aaa/bbb/ccc" に何らかのリソースがあったとしても必ず -- "/aaa/bbb" が撰ばれる。"/aaa/bbb" のリソースが貪欲でなければ、それは @@ -41,9 +54,11 @@ import Prelude hiding (catch) -- | 'ResourceDef' is basically a set of -- 'Network.HTTP.Lucu.Resource.Resource' monads for each HTTP methods. data ResourceDef = ResourceDef { - -- | Whether to run a 'Network.HTTP.Lucu.Resource.Resource' on a - -- native thread (spawned using @forkOS@) or to run it on a user - -- thread (spanwed using @forkIO@). Generally you don't + -- |Whether to run a 'Network.HTTP.Lucu.Resource.Resource' on a + -- native thread (spawned by 'Control.Concurrent.forkOS') or to + -- run it on a user thread (spanwed by + -- 'Control.Concurrent.forkIO'). Generally you don't need to set + -- this field to 'Prelude.True'. resUsesNativeThread :: !Bool -- | Whether to be greedy or not. -- @@ -51,7 +66,7 @@ data ResourceDef = ResourceDef { -- greedy resource at \/aaa\/bbb, it is always chosen even if -- there is another resource at \/aaa\/bbb\/ccc. If the resource -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy - -- resource is like a CGI script. + -- resources are like CGI scripts. , resIsGreedy :: !Bool -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a GET -- request comes for the resource path. If 'resGet' is Nothing, @@ -85,13 +100,13 @@ data ResourceDef = ResourceDef { , resDelete :: !(Maybe (Resource ())) } --- | 'ResTree' is an opaque structure which is a map from resource --- path to 'ResourceDef'. -type ResTree = ResNode -- root だから Map ではない +-- |'ResTree' is an opaque structure which is a map from resource path +-- to 'ResourceDef'. +newtype ResTree = ResTree ResNode -- root だから Map ではない type ResSubtree = Map String ResNode data ResNode = ResNode !(Maybe ResourceDef) !ResSubtree --- | 'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g. +-- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g. -- -- @ -- mkResTree [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/ @@ -108,12 +123,12 @@ mkResTree list = list `seq` processRoot list in if null roots then -- "/" にリソースが定義されない。"/foo" とかにはあるかも。 - ResNode Nothing children + ResTree (ResNode Nothing children) else -- "/" がある。 let (_, def) = last roots in - ResNode (Just def) children + ResTree (ResNode (Just def) children) processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree processNonRoot list @@ -135,16 +150,19 @@ mkResTree list = list `seq` processRoot list subtree -findResource :: ResTree -> URI -> Maybe ([String], ResourceDef) -findResource (ResNode rootDefM subtree) uri - = let pathStr = uriPath uri - path = [x | x <- splitBy (== '/') pathStr, x /= ""] - in - if null path then - do def <- rootDefM - return (path, def) - else - walkTree subtree path [] +findResource :: ResTree -> [FallbackHandler] -> URI -> IO (Maybe ([String], ResourceDef)) +findResource (ResTree (ResNode rootDefM subtree)) fbs uri + = do let pathStr = uriPath uri + path = [x | x <- splitBy (== '/') pathStr, x /= ""] + foundInTree = if null path then + do def <- rootDefM + return (path, def) + else + walkTree subtree path [] + if isJust foundInTree then + return foundInTree + else + fallback path fbs where walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef) @@ -163,15 +181,22 @@ findResource (ResNode rootDefM subtree) uri return (soFar ++ [x], def) _ -> walkTree children xs (soFar ++ [x]) + fallback :: [String] -> [FallbackHandler] -> IO (Maybe ([String], ResourceDef)) + fallback _ [] = return Nothing + fallback path (x:xs) = do m <- x path + case m of + Just def -> return $! Just ([], def) + Nothing -> fallback path xs + runResource :: ResourceDef -> Interaction -> IO ThreadId runResource def itr = def `seq` itr `seq` fork - $! catch ( runReaderT ( do req <- getRequest - fromMaybe notAllowed $ rsrc req - driftTo Done - ) itr + $! catch ( runRes ( do req <- getRequest + fromMaybe notAllowed $ rsrc req + driftTo Done + ) itr ) $ \ exc -> processException exc where @@ -193,7 +218,7 @@ runResource def itr notAllowed :: Resource () notAllowed = do setStatus MethodNotAllowed - setHeader "Allow" $ joinWith ", " allowedMethods + setHeader (C8.pack "Allow") (C8.pack $ joinWith ", " allowedMethods) allowedMethods :: [String] allowedMethods = nub $ foldr (++) [] [ methods resGet ["GET"] @@ -211,14 +236,14 @@ runResource def itr processException :: Exception -> IO () processException exc = do let abo = case exc of - ErrorCall msg -> Abortion InternalServerError [] $ Just msg - IOException ioE -> Abortion InternalServerError [] $ Just $ formatIOE ioE + ErrorCall msg -> Abortion InternalServerError emptyHeaders $ Just msg + IOException ioE -> Abortion InternalServerError emptyHeaders $ Just $ formatIOE ioE DynException dynE -> case fromDynamic dynE of Just (abo :: Abortion) -> abo Nothing - -> Abortion InternalServerError [] + -> Abortion InternalServerError emptyHeaders $ Just $ show exc - _ -> Abortion InternalServerError [] $ Just $ show exc + _ -> Abortion InternalServerError emptyHeaders $ Just $ show exc conf = itrConfig itr -- まだ DecidingHeader 以前の状態だったら、この途中終了 -- を應答に反映させる餘地がある。さうでなければ stderr @@ -227,17 +252,15 @@ runResource def itr reqM <- atomically $ readItr itr itrRequest id res <- atomically $ readItr itr itrResponse id if state <= DecidingHeader then - flip runReaderT itr + flip runRes itr $ do setStatus $ aboStatus abo - -- FIXME: 同じ名前で複數の値があった時は、こ - -- れではまずいと思ふ。 - mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo + mapM_ (\ (name, value) -> setHeader name value) $ fromHeaders $ aboHeaders abo output $ abortPage conf reqM res abo else when (cnfDumpTooLateAbortionToStderr $ itrConfig itr) $ hPutStrLn stderr $ show abo - flip runReaderT itr $ driftTo Done + flip runRes itr $ driftTo Done formatIOE :: IOError -> String formatIOE ioE = if isUserError ioE then