X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource%2FTree.hs;h=9af5fd54ed809d19b1f65c168748a02b7878a641;hb=858129cb755aa09da2b7bd758efb8519f2c89103;hp=9cd8d0b49e585924cf04fdd87501ecd3c8527ace;hpb=175e14b3b144537644e65ca76f1fca5c56fd44e9;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index 9cd8d0b..9af5fd5 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -1,3 +1,6 @@ +-- #prune + +-- | Repository of the resources in httpd. module Network.HTTP.Lucu.Resource.Tree ( ResourceDef(..) , ResTree @@ -35,22 +38,69 @@ import Prelude hiding (catch) -- があれば、假に "/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 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 - - +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 list = list `seq` processRoot list where processRoot :: [ ([String], ResourceDef) ] -> ResTree processRoot list @@ -117,27 +167,30 @@ findResource (ResNode rootDefM subtree) uri 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 ( 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 :: 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 notAllowed :: Resource () notAllowed = do setStatus MethodNotAllowed @@ -168,22 +221,22 @@ runResource def itr $ Just $ show exc _ -> Abortion InternalServerError [] $ Just $ show 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 $ do setStatus $ aboStatus abo -- FIXME: 同じ名前で複數の値があった時は、こ -- れではまずいと思ふ。 mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo - setContentType ("application" "xhtml+xml") - output $ abortPage conf reqM resM abo + output $ abortPage conf reqM res abo else - hPutStrLn stderr $ show abo + when (cnfDumpTooLateAbortionToStderr $ itrConfig itr) + $ hPutStrLn stderr $ show abo flip runReaderT itr $ driftTo Done