X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource%2FTree.hs;h=7f816e8feabb667139db9c1d903eacaa53e4a152;hb=72a3e24a952616e32845eeb4fc05048e841c91a2;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..7f816e8 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -4,7 +4,6 @@ , RecordWildCards , UnicodeSyntax #-} -{-# OPTIONS_HADDOCK prune #-} -- | Repository of the resources in httpd. module Network.HTTP.Lucu.Resource.Tree @@ -20,33 +19,34 @@ module Network.HTTP.Lucu.Resource.Tree , runResource ) where -import Control.Arrow +import Control.Arrow import Control.Applicative import Data.Ascii (Ascii) import qualified Data.Ascii as A -import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception -import Control.Monad +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception +import Control.Monad import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy.Encoding as LT -import Data.List +import Data.List import qualified Data.Map as M -import Data.Map (Map) -import Data.Maybe +import Data.Map (Map) +import Data.Maybe import Data.Monoid.Unicode -import Network.HTTP.Lucu.Abortion -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.Headers (fromHeaders) -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 hiding (path) -import System.IO -import Prelude hiding (catch) +import Network.HTTP.Lucu.Abortion +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.DefaultPage +import Network.HTTP.Lucu.Headers (fromHeaders) +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 hiding (path) +import System.IO +import Prelude hiding (catch) import Prelude.Unicode @@ -145,15 +145,18 @@ data ResNode = ResNode (Maybe ResourceDef) ResSubtree -- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd -- ] -- @ +-- +-- Note that the request path in an incoming HTTP request is always +-- treated as an URI-encoded UTF-8 string. 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 +174,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 +189,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 +209,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 +273,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 +289,14 @@ 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 + setHeader "Content-Type" defaultPageContentType 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