X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource%2FTree.hs;h=17827d12369d4eb950220ff48be0dd0cbde6d8ba;hb=1789cee5ee66d2f7f2b26280be2f13eac4df7980;hp=b45707249062c143d39270da8a45d9aaaa1814b6;hpb=0ff03469c29b791f2c609a659bbf59be97e306f2;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index b457072..17827d1 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 @@ -19,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 @@ -144,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 @@ -170,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 @@ -185,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 @@ -208,55 +209,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 +271,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 +285,26 @@ runResource def itr processException ∷ SomeException → IO () processException exc = do let abo = toAbortion exc - conf = itrConfig itr -- まだ DecidingHeader 以前の状態だったら、この途中終了 -- を應答に反映させる餘地がある。さうでなければ stderr -- にでも吐くしか無い。 - state ← atomically $ readItr itrState id itr - reqM ← atomically $ readItr itrRequest id itr - res ← atomically $ readItr itrResponse id 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 $ + do setStatus $ aboStatus abo + setHeader "Content-Type" defaultPageContentType + mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo + putChunk $ LT.encodeUtf8 $ abortPage itrConfig itrRequest res abo + else + when (cnfDumpTooLateAbortionToStderr itrConfig) + $ dumpAbortion abo + runRes (driftTo Done) itr - flip runRes itr $ driftTo Done +dumpAbortion ∷ Abortion → IO () +dumpAbortion abo + = hPutStr stderr + $ concat [ "Lucu: an exception occured after " + , "sending response header to the client:\n" + , " ", show abo, "\n" + ]