X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource%2FTree.hs;h=8fbe2bf2d6b529aa1b00ad4fc4c6b17b943b64b8;hb=ea2b7838f1b3d9d4923a220a601be2e04cc559d7;hp=d386bce8cd78486a5f89c039a5bf3b5c78ff57a3;hpb=cc55fb9a095c9c583ed6fe2ded3eaf6401fb760f;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index d386bce..8fbe2bf 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -1,9 +1,9 @@ {-# LANGUAGE DoAndIfThenElse , OverloadedStrings + , RecordWildCards , UnicodeSyntax #-} -{-# OPTIONS_HADDOCK prune #-} -- | Repository of the resources in httpd. module Network.HTTP.Lucu.Resource.Tree @@ -145,14 +145,14 @@ data ResNode = ResNode (Maybe ResourceDef) ResSubtree -- ] -- @ mkResTree ∷ [ ([Text], ResourceDef) ] → ResTree -mkResTree = processRoot . map (first canonicalisePath) +mkResTree = processRoot ∘ map (first canonicalisePath) where canonicalisePath ∷ [Text] → [Text] canonicalisePath = filter (≢ "") processRoot ∷ [ ([Text], ResourceDef) ] → ResTree processRoot list - = let (roots, nonRoots) = partition (\ (path, _) → path == []) list + = let (roots, nonRoots) = partition (\(path, _) → null path) list children = processNonRoot nonRoots in if null roots then @@ -170,7 +170,7 @@ mkResTree = processRoot . map (first canonicalisePath) = let subtree = M.fromList [(name, node name) | name ← childNames] childNames = [name | (name:_, _) ← list] - node name = let defs = [def | (path, def) ← list, path == [name]] + node name = let defs = [def | (path, def) ← list, path ≡ [name]] in if null defs then -- No resources are defined @@ -185,14 +185,11 @@ mkResTree = processRoot . map (first canonicalisePath) in subtree - findResource ∷ ResTree → [FallbackHandler] → URI → IO (Maybe ([Text], ResourceDef)) findResource (ResTree (ResNode rootDefM subtree)) fbs uri - = do let path = splitPathInfo uri - haveGreedyRoot = case rootDefM of - Just def → resIsGreedy def - Nothing → False - foundInTree = if haveGreedyRoot ∨ null path then + = do let path = splitPathInfo uri + hasGreedyRoot = maybe False resIsGreedy rootDefM + foundInTree = if hasGreedyRoot ∨ null path then do def ← rootDefM return ([], def) else @@ -208,55 +205,51 @@ findResource (ResTree (ResNode rootDefM subtree)) fbs uri = 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) + = do ResNode defM _ ← M.lookup name tree + def ← defM + return (soFar ⧺ [name], def) walkTree tree (x:xs) soFar - = case M.lookup x tree 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]) + = do ResNode defM sub ← M.lookup x tree + case defM of + Just (ResourceDef { resIsGreedy = True }) + → do def ← defM + return (soFar ⧺ [x], def) + _ → walkTree sub xs (soFar ⧺ [x]) fallback ∷ [Text] → [FallbackHandler] → IO (Maybe ([Text], ResourceDef)) fallback _ [] = return Nothing fallback path (x:xs) = do m ← x path case m of - Just def → return $! Just ([], def) + Just def → return $ Just ([], def) Nothing → fallback path xs runResource ∷ ResourceDef → Interaction → IO ThreadId -runResource def itr - = def `seq` itr `seq` - fork - $! catch ( runRes ( do req ← getRequest - fromMaybe notAllowed $ rsrc req - driftTo Done - ) itr - ) - processException +runResource (ResourceDef {..}) itr@(Interaction {..}) + = fork $ run `catch` processException where fork ∷ IO () → IO ThreadId - fork = if resUsesNativeThread def - then forkOS - else forkIO + fork | resUsesNativeThread = forkOS + | otherwise = forkIO + + run ∷ IO () + run = flip runRes itr $ + do req ← getRequest + fromMaybe notAllowed $ rsrc req + driftTo Done rsrc ∷ Request → Maybe (Resource ()) rsrc req = case reqMethod req of - GET → resGet def - HEAD → case resHead def of + GET → resGet + HEAD → case resHead of Just r → Just r - Nothing → resGet def - POST → resPost def - PUT → resPut def - DELETE → resDelete def - _ → undefined + Nothing → resGet + POST → resPost + PUT → resPut + DELETE → resDelete + _ → error $ "Unknown request method: " ⧺ show (reqMethod req) notAllowed ∷ Resource () notAllowed @@ -274,10 +267,10 @@ runResource def itr , methods resDelete ["DELETE"] ] - methods ∷ (ResourceDef → Maybe a) → [Ascii] → [Ascii] - methods f xs = case f def of - Just _ → xs - Nothing → [] + methods ∷ Maybe a → [Ascii] → [Ascii] + methods m xs + | isJust m = xs + | otherwise = [] toAbortion ∷ SomeException → Abortion toAbortion e @@ -288,20 +281,17 @@ runResource def itr processException ∷ SomeException → IO () processException exc = do let abo = toAbortion exc - conf = itrConfig itr -- まだ DecidingHeader 以前の状態だったら、この途中終了 -- を應答に反映させる餘地がある。さうでなければ stderr -- にでも吐くしか無い。 - state ← atomically $ readItr itrState itr - reqM ← atomically $ readItr itrRequest itr - res ← atomically $ readItr itrResponse itr + state ← atomically $ readTVar itrState + res ← atomically $ readTVar itrResponse if state ≤ DecidingHeader then - flip runRes itr - $ do setStatus $ aboStatus abo - mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo - output $ LT.encodeUtf8 $ abortPage conf reqM res abo - else - when (cnfDumpTooLateAbortionToStderr $ itrConfig itr) - $ hPutStrLn stderr $ show abo - - flip runRes itr $ driftTo Done + flip runRes itr $ + do setStatus $ aboStatus abo + mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo + output $ LT.encodeUtf8 $ abortPage itrConfig itrRequest res abo + else + when (cnfDumpTooLateAbortionToStderr itrConfig) + $ hPutStrLn stderr $ show abo + runRes (driftTo Done) itr