-- #prune -- | Repository of the resources in httpd. module Network.HTTP.Lucu.Resource.Tree ( ResourceDef(..) , ResTree , mkResTree -- [ ([String], ResourceDef) ] -> ResTree , findResource -- ResTree -> URI -> Maybe ([String], ResourceDef) , runResource -- ResourceDef -> Interaction -> IO ThreadId ) where import Control.Concurrent import Control.Concurrent.STM import Control.Exception import Control.Monad.Reader import Data.Dynamic 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.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 System.IO import System.IO.Error hiding (catch) import Prelude hiding (catch) -- "/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 { -- | 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 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 -- resource is like a CGI script. , 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 ())) } -- | 'ResTree' is an opaque structure which is a map from resource -- path to 'ResourceDef'. type 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 = list `seq` processRoot list where 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 else -- "/" がある。 let (_, def) = last roots in ResNode (Just def) children processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree processNonRoot list = let subtree = M.fromList [(name, node name) | name <- childNames] childNames = [name | (name:_, _) <- list] node name = let defs = [def | (path, def) <- list, path == [name]] in if null defs then -- この位置にリソースが定義されない。 -- もっと下にはあるかも。 ResNode Nothing children else -- この位置にリソースがある。 ResNode (Just $ last defs) children children = processNonRoot [(path, def) | (_:path, def) <- list, not (null path)] 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 [] where walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef) walkTree subtree (name:[]) soFar = case M.lookup name subtree of Nothing -> Nothing Just (ResNode defM _) -> do def <- defM return (soFar ++ [name], def) walkTree subtree (x:xs) soFar = case M.lookup x subtree of Nothing -> Nothing Just (ResNode defM children) -> case defM of Just (ResourceDef { resIsGreedy = True }) -> do def <- defM return (soFar ++ [x], def) _ -> walkTree children xs (soFar ++ [x]) 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 ) $ \ exc -> processException exc where fork :: IO () -> IO ThreadId fork = if (resUsesNativeThread def) then forkOS else forkIO 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 notAllowed :: Resource () notAllowed = do setStatus MethodNotAllowed setHeader "Allow" $ joinWith ", " allowedMethods allowedMethods :: [String] allowedMethods = nub $ foldr (++) [] [ 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 () 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 conf = itrConfig itr -- まだ DecidingHeader 以前の状態だったら、この途中終了 -- を應答に反映させる餘地がある。さうでなければ stderr -- にでも吐くしか無い。 state <- atomically $ readItr itr itrState id reqM <- atomically $ readItr itr itrRequest id res <- atomically $ readItr itr itrResponse id if state <= DecidingHeader then flip runReaderT itr $ do setStatus $ aboStatus abo -- FIXME: 同じ名前で複數の値があった時は、こ -- れではまずいと思ふ。 mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo output $ abortPage conf reqM res abo else when (cnfDumpTooLateAbortionToStderr $ itrConfig itr) $ hPutStrLn stderr $ show abo flip runReaderT itr $ driftTo Done formatIOE :: IOError -> String formatIOE ioE = if isUserError ioE then ioeGetErrorString ioE else show ioE