X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource%2FTree.hs;h=4cb493274859cd7aa4fb56ca4664123dff0d5867;hb=f557285fa55e17ae2b3467b1cda6152c9ee1d004;hp=2cd498f7ade7c7f4e5435d2344e161a5717cf65e;hpb=50e8fe7af585a8d33d93b3721be8f8f01905b891;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index 2cd498f..4cb4932 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -1,8 +1,10 @@ --- #prune +{-# OPTIONS_HADDOCK prune #-} -- | Repository of the resources in httpd. module Network.HTTP.Lucu.Resource.Tree ( ResourceDef(..) + , emptyResource + , ResTree , FallbackHandler @@ -13,12 +15,12 @@ module Network.HTTP.Lucu.Resource.Tree ) where +import Control.Arrow import Control.Concurrent import Control.Concurrent.STM import Control.Exception import Control.Monad import qualified Data.ByteString.Char8 as C8 -import Data.Dynamic import Data.List import qualified Data.Map as M import Data.Map (Map) @@ -31,9 +33,8 @@ 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) @@ -100,11 +101,37 @@ data ResourceDef = ResourceDef { , resDelete :: !(Maybe (Resource ())) } +-- |'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 +data ResNode = ResNode (Maybe ResourceDef) ResSubtree -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g. -- @@ -114,18 +141,22 @@ data ResNode = ResNode !(Maybe ResourceDef) !ResSubtree -- ] -- @ mkResTree :: [ ([String], ResourceDef) ] -> ResTree -mkResTree list = list `seq` processRoot list +mkResTree = processRoot . map (first canonicalisePath) where + canonicalisePath :: [String] -> [String] + canonicalisePath = filter (/= "") + processRoot :: [ ([String], ResourceDef) ] -> ResTree processRoot list = let (roots, nonRoots) = partition (\ (path, _) -> path == []) list children = processNonRoot nonRoots in if null roots then - -- "/" にリソースが定義されない。"/foo" とかにはあるかも。 + -- 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 ResTree (ResNode (Just def) children) @@ -138,27 +169,31 @@ mkResTree list = list `seq` 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 -> [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 [] + = 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 @@ -166,14 +201,17 @@ findResource (ResTree (ResNode rootDefM subtree)) fbs uri 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 }) @@ -198,10 +236,10 @@ runResource def itr driftTo Done ) itr ) - $ \ exc -> processException exc + processException where fork :: IO () -> IO ThreadId - fork = if (resUsesNativeThread def) + fork = if resUsesNativeThread def then forkOS else forkIO @@ -215,35 +253,33 @@ runResource def itr POST -> resPost def PUT -> resPut def DELETE -> resDelete def + _ -> undefined notAllowed :: Resource () notAllowed = do setStatus MethodNotAllowed 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 emptyHeaders $ Just msg - IOException ioE -> Abortion InternalServerError emptyHeaders $ Just $ formatIOE ioE - DynException dynE -> case fromDynamic dynE of - Just (abo :: Abortion) -> abo - Nothing - -> Abortion InternalServerError emptyHeaders - $ Just $ show exc - _ -> Abortion InternalServerError emptyHeaders $ Just $ show exc + = do let abo = toAbortion exc conf = itrConfig itr -- まだ DecidingHeader 以前の状態だったら、この途中終了 -- を應答に反映させる餘地がある。さうでなければ stderr @@ -254,16 +290,10 @@ runResource def itr if state <= DecidingHeader then flip runRes itr $ do setStatus $ aboStatus abo - mapM_ (\ (name, value) -> setHeader name value) $ fromHeaders $ aboHeaders abo + mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo output $ abortPage conf reqM res abo else when (cnfDumpTooLateAbortionToStderr $ itrConfig itr) $ hPutStrLn stderr $ show abo flip runRes itr $ driftTo Done - - formatIOE :: IOError -> String - formatIOE ioE = if isUserError ioE then - ioeGetErrorString ioE - else - show ioE