X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource%2FTree.hs;h=6bf422f72fcf1ee14a567664c79341db03f7d138;hb=ca338174155913a969808d7b20193973394e474e;hp=092ee06735b8da10b4802f2d9f2423143e998eef;hpb=2bb7a0baa35dadb5d36d3f9fa98bd242baabc6d1;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs
index 092ee06..6bf422f 100644
--- a/Network/HTTP/Lucu/Resource/Tree.hs
+++ b/Network/HTTP/Lucu/Resource/Tree.hs
@@ -146,14 +146,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
@@ -171,7 +171,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
@@ -186,14 +186,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
@@ -209,41 +206,39 @@ 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 (ResourceDef {..}) itr@(Interaction {..})
-    = fork $ ( runRes ( do req ← getRequest
-                           fromMaybe notAllowed $ rsrc req
-                           driftTo Done
-                      ) itr
-             )
-             `catch`
-             processException
+    = fork $ run `catch` processException
     where
       fork ∷ IO () → IO ThreadId
       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
@@ -275,9 +270,8 @@ runResource (ResourceDef {..}) itr@(Interaction {..})
 
       methods ∷ Maybe a → [Ascii] → [Ascii]
       methods m xs
-          = case m of
-              Just _  → xs
-              Nothing → []
+          | isJust m  = xs
+          | otherwise = []
 
       toAbortion ∷ SomeException → Abortion
       toAbortion e
@@ -292,15 +286,13 @@ runResource (ResourceDef {..}) itr@(Interaction {..})
                -- を應答に反映させる餘地がある。さうでなければ stderr
                -- にでも吐くしか無い。
                state ← atomically $ readTVar itrState
-               reqM  ← atomically $ readTVar itrRequest
                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 itrConfig reqM res abo
-                 else
+                          output $ LT.encodeUtf8 $ abortPage itrConfig itrRequest res abo
+               else
                    when (cnfDumpTooLateAbortionToStderr itrConfig)
-                            $ hPutStrLn stderr $ show abo
-
+                       $ hPutStrLn stderr $ show abo
                runRes (driftTo Done) itr