X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource%2FTree.hs;h=660d8ff735bdc3f2fab18f7d42ab8a1f8951a091;hb=195fd2318fb0ad21c2fd60f61e7df72a8f25d12c;hp=e4fa662688ad24ccdf642283f0790350779ad659;hpb=40c0d61e88920807a91b8f3c4419b08032988d76;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index e4fa662..660d8ff 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -1,6 +1,13 @@ +{-# OPTIONS_HADDOCK prune #-} + +-- | Repository of the resources in httpd. module Network.HTTP.Lucu.Resource.Tree ( ResourceDef(..) + , emptyResource + , ResTree + , FallbackHandler + , mkResTree -- [ ([String], ResourceDef) ] -> ResTree , findResource -- ResTree -> URI -> Maybe ([String], ResourceDef) @@ -11,60 +18,150 @@ module Network.HTTP.Lucu.Resource.Tree import Control.Concurrent import Control.Concurrent.STM import Control.Exception -import Control.Monad.Reader -import Data.Dynamic +import Control.Monad +import qualified Data.ByteString.Char8 as C8 import Data.List import qualified Data.Map as M import Data.Map (Map) import Data.Maybe import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.MIMEType +import Network.HTTP.Lucu.Headers (emptyHeaders, fromHeaders) import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Resource import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Utils -import Network.URI +import Network.URI hiding (path) import System.IO -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" のリソースが貪欲でなければ、それは -- 無視される。 + +-- | 'ResourceDef' is basically a set of +-- 'Network.HTTP.Lucu.Resource.Resource' monads for each HTTP methods. data ResourceDef = ResourceDef { - resUsesNativeThread :: Bool - , resIsGreedy :: Bool - , resGet :: Maybe (Resource ()) - , resHead :: Maybe (Resource ()) - , resPost :: Maybe (Resource ()) - , resPut :: Maybe (Resource ()) - , resDelete :: Maybe (Resource ()) + -- |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. + -- + -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a + -- 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 + -- 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, + -- the system responds \"405 Method Not Allowed\" for GET + -- requests. + -- + -- It also runs for HEAD request if the 'resHead' is Nothing. In + -- this case 'Network.HTTP.Lucu.Resource.output' and such like + -- don't actually write a response body. + , resGet :: !(Maybe (Resource ())) + -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a HEAD + -- request comes for the resource path. If 'resHead' is Nothing, + -- the system runs 'resGet' instead. If 'resGet' is also Nothing, + -- the system responds \"405 Method Not Allowed\" for HEAD + -- requests. + , resHead :: !(Maybe (Resource ())) + -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a POST + -- request comes for the resource path. If 'resPost' is Nothing, + -- the system responds \"405 Method Not Allowed\" for POST + -- requests. + , resPost :: !(Maybe (Resource ())) + -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a PUT + -- request comes for the resource path. If 'resPut' is Nothing, + -- the system responds \"405 Method Not Allowed\" for PUT + -- requests. + , resPut :: !(Maybe (Resource ())) + -- | A 'Network.HTTP.Lucu.Resource.Resource' to be run when a + -- DELETE request comes for the resource path. If 'resDelete' is + -- Nothing, the system responds \"405 Method Not Allowed\" for + -- DELETE requests. + , resDelete :: !(Maybe (Resource ())) } -type ResTree = ResNode -- root だから Map ではない + +-- |'emptyResource' is a resource definition with no actual +-- handlers. You can construct a 'ResourceDef' by selectively +-- overriding 'emptyResource'. It is defined as follows: +-- +-- @ +-- emptyResource = ResourceDef { +-- resUsesNativeThread = False +-- , resIsGreedy = False +-- , resGet = Nothing +-- , resHead = Nothing +-- , resPost = Nothing +-- , resPut = Nothing +-- , resDelete = Nothing +-- } +-- @ +emptyResource :: ResourceDef +emptyResource = ResourceDef { + resUsesNativeThread = False + , resIsGreedy = False + , resGet = Nothing + , resHead = Nothing + , resPost = Nothing + , resPut = Nothing + , resDelete = Nothing + } + +-- |'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 [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/ +-- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd +-- ] +-- @ mkResTree :: [ ([String], ResourceDef) ] -> ResTree -mkResTree list = processRoot list +mkResTree = processRoot . mapFirst canonicalisePath where + mapFirst :: (a -> a') -> [(a, b)] -> [(a', b)] + mapFirst f = map (\ (a, b) -> (f a, b)) + + canonicalisePath :: [String] -> [String] + canonicalisePath = filter (\ x -> x /= "") + processRoot :: [ ([String], ResourceDef) ] -> ResTree processRoot list = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list children = processNonRoot nonRoots in if null roots then - -- "/" にリソースが定義されない。"/foo" とかにはあるかも。 - ResNode Nothing children + -- The root has no resources. Maybe there's one at + -- somewhere like "/foo". + ResTree (ResNode Nothing children) else - -- "/" がある。 + -- There is a root resource. let (_, def) = last roots in - ResNode (Just def) children + ResTree (ResNode (Just def) children) processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree processNonRoot list @@ -74,39 +171,49 @@ mkResTree list = processRoot list node name = let defs = [def | (path, def) <- list, path == [name]] in if null defs then - -- この位置にリソースが定義されない。 - -- もっと下にはあるかも。 + -- No resources are defined + -- here. Maybe there's one at + -- somewhere below this node. ResNode Nothing children else - -- この位置にリソースがある。 + -- There is a resource here. ResNode (Just $ last defs) children children = processNonRoot [(path, def) - | (_:path, def) <- list, not (null path)] + | (_:path, def) <- list] in 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 = [unEscapeString x | x <- splitBy (== '/') pathStr, x /= ""] + haveGreedyRoot = case rootDefM of + Just def -> resIsGreedy def + Nothing -> False + foundInTree = if haveGreedyRoot || null path then + do def <- rootDefM + return ([], def) + else + walkTree subtree path [] + if isJust foundInTree then + return foundInTree + else + fallback path fbs where walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef) - walkTree subtree (name:[]) soFar - = case M.lookup name subtree of + walkTree _ [] _ + = error "Internal error: should not reach here." + + walkTree tree (name:[]) soFar + = case M.lookup name tree of Nothing -> Nothing Just (ResNode defM _) -> do def <- defM return (soFar ++ [name], def) - walkTree subtree (x:xs) soFar - = case M.lookup x subtree of + walkTree tree (x:xs) soFar + = case M.lookup x tree of Nothing -> Nothing Just (ResNode defM children) -> case defM of Just (ResourceDef { resIsGreedy = True }) @@ -114,81 +221,81 @@ 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 - = fork - $ catch ( runReaderT ( do fromMaybe notAllowed rsrc - driftTo Done - ) itr - ) - $ \ exc -> processException exc + = def `seq` itr `seq` + fork + $! catch ( runRes ( do req <- getRequest + fromMaybe notAllowed $ rsrc req + driftTo Done + ) itr + ) + processException where fork :: IO () -> IO ThreadId - fork = if (resUsesNativeThread def) + fork = if resUsesNativeThread def then forkOS else forkIO - rsrc :: Maybe (Resource ()) - rsrc = case reqMethod $ fromJust $ itrRequest itr of - GET -> resGet def - HEAD -> case resHead def of - Just r -> Just r - Nothing -> resGet def - POST -> resPost def - PUT -> resPut def - DELETE -> resDelete def + rsrc :: Request -> Maybe (Resource ()) + rsrc req + = case reqMethod req of + GET -> resGet def + HEAD -> case resHead def of + Just r -> Just r + Nothing -> resGet def + POST -> resPost def + PUT -> resPut def + DELETE -> resDelete def + _ -> undefined 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"] - , methods resHead ["GET", "HEAD"] - , methods resPost ["POST"] - , methods resPut ["PUT"] - , methods resDelete ["DELETE"] - ] + allowedMethods = nub $ concat [ methods resGet ["GET"] + , methods resHead ["GET", "HEAD"] + , methods resPost ["POST"] + , methods resPut ["PUT"] + , methods resDelete ["DELETE"] + ] methods :: (ResourceDef -> Maybe a) -> [String] -> [String] methods f xs = case f def of Just _ -> xs Nothing -> [] - processException :: Exception -> IO () + toAbortion :: SomeException -> Abortion + toAbortion e = case fromException e of + Just abortion -> abortion + Nothing -> Abortion InternalServerError emptyHeaders (Just (show e)) + + processException :: SomeException -> IO () processException exc - = do let abo = case exc of - ErrorCall msg -> Abortion InternalServerError [] $ Just msg - IOException ioE -> Abortion InternalServerError [] $ Just $ formatIOE ioE - DynException dynE -> case fromDynamic dynE of - Just (abo :: Abortion) -> abo - Nothing - -> Abortion InternalServerError [] - $ Just $ show exc - _ -> Abortion InternalServerError [] $ Just $ show exc + = do let abo = toAbortion exc conf = itrConfig itr - reqM = itrRequest itr -- まだ DecidingHeader 以前の状態だったら、この途中終了 -- を應答に反映させる餘地がある。さうでなければ stderr -- にでも吐くしか無い。 state <- atomically $ readItr itr itrState id - resM <- atomically $ readItr itr itrResponse id + 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 - setContentType ("application" +/+ "xhtml+xml") - output $ abortPage conf reqM resM abo + mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo + output $ abortPage conf reqM res abo else - hPutStrLn stderr $ show abo - - flip runReaderT itr $ driftTo Done + when (cnfDumpTooLateAbortionToStderr $ itrConfig itr) + $ hPutStrLn stderr $ show abo - formatIOE :: IOError -> String - formatIOE ioE = if isUserError ioE then - ioeGetErrorString ioE - else - show ioE + flip runRes itr $ driftTo Done