X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource%2FTree.hs;h=660d8ff735bdc3f2fab18f7d42ab8a1f8951a091;hb=195fd2318fb0ad21c2fd60f61e7df72a8f25d12c;hp=cef168cb522322e80bdbb164a68f3e2db678f3a5;hpb=3d017dd65ddede9a11c5b7a34a91e04340e67bc4;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index cef168c..660d8ff 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 @@ -18,7 +20,6 @@ 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) @@ -33,7 +34,6 @@ import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Utils import Network.URI hiding (path) import System.IO -import System.IO.Error hiding (catch) import Prelude hiding (catch) @@ -100,11 +100,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 +140,25 @@ data ResNode = ResNode !(Maybe ResourceDef) !ResSubtree -- ] -- @ mkResTree :: [ ([String], ResourceDef) ] -> ResTree -mkResTree xs = xs `seq` processRoot xs +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" とかにはあるかも。 + -- 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 +171,31 @@ mkResTree xs = xs `seq` processRoot xs 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,6 +203,9 @@ findResource (ResTree (ResNode rootDefM subtree)) fbs uri where walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef) + walkTree _ [] _ + = error "Internal error: should not reach here." + walkTree tree (name:[]) soFar = case M.lookup name tree of Nothing -> Nothing @@ -198,10 +238,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 @@ -222,29 +262,26 @@ runResource def itr 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 (a :: Abortion) -> a - Nothing - -> Abortion InternalServerError emptyHeaders - $ Just $ show exc - _ -> Abortion InternalServerError emptyHeaders $ Just $ show exc + = do let abo = toAbortion exc conf = itrConfig itr -- まだ DecidingHeader 以前の状態だったら、この途中終了 -- を應答に反映させる餘地がある。さうでなければ stderr @@ -255,16 +292,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