X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource%2FTree.hs;h=4a652a7b7aec8ac210f274a8393080ac0fa4ba66;hp=51c30b6908ac67e02bf178d02640f25b6489ad81;hb=1ead053df6a792edafa9d714c4c038a8a9c3ad16;hpb=5fc2e72c153ade03b16071c66a08a316295bb42a diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index 51c30b6..4a652a7 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -1,110 +1,49 @@ --- #prune +{-# LANGUAGE + DoAndIfThenElse + , OverloadedStrings + , RecordWildCards + , UnicodeSyntax + #-} -- | Repository of the resources in httpd. module Network.HTTP.Lucu.Resource.Tree - ( ResourceDef(..) - , ResTree + ( ResTree , FallbackHandler - , mkResTree -- [ ([String], ResourceDef) ] -> ResTree - - , findResource -- ResTree -> URI -> Maybe ([String], ResourceDef) - , runResource -- ResourceDef -> Interaction -> IO ThreadId + , mkResTree + , findResource ) where - -import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception -import Control.Monad -import qualified Data.ByteString.Char8 as C8 -import Data.Dynamic -import Data.List +import Control.Arrow +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Control.Monad +import Data.Foldable +import Data.List import qualified Data.Map as M -import Data.Map (Map) -import Data.Maybe -import Network.HTTP.Lucu.Abortion -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.Headers (emptyHeaders, 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 System.IO.Error hiding (catch) -import Prelude hiding (catch) - +import Data.Map (Map) +import Data.Maybe +import Data.Monoid.Unicode +import Data.Sequence (Seq) +import Network.HTTP.Lucu.Resource.Internal +import Network.HTTP.Lucu.Utils +import Network.URI hiding (path) +import System.IO +import Prelude hiding (catch) +import Prelude.Unicode -- |'FallbackHandler' is an extra resource handler for resources which --- can't be statically located somewhere in the resource tree. The --- Lucu httpd first search for a resource in the tree, and then call +-- can't be statically located anywhere in the resource tree. The Lucu +-- httpd first searches for a resource in the tree, and then calls -- fallback handlers to ask them for a resource. If all of the --- handlers returned 'Prelude.Nothing', the httpd responds with 404 --- Not Found. -type FallbackHandler = [String] -> IO (Maybe ResourceDef) - - --- "/aaa/bbb/ccc" にアクセスされた時、もし "/aaa/bbb" に貪欲なリソース --- があれば、假に "/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 { - -- |Whether to run a 'Network.HTTP.Lucu.Resource.Resource' on a - -- native thread (spawned by 'Control.Concurrent.forkOS') or to - -- run it on a user thread (spanwed by - -- 'Control.Concurrent.forkIO'). Generally you don't need to set - -- this field to 'Prelude.True'. - 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 - -- resources are like CGI scripts. - , 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 ())) - } +-- handlers returned 'Nothing', the httpd responds with 404 Not Found. +type FallbackHandler = [ByteString] → IO (Maybe Resource) -- |'ResTree' is an opaque structure which is a map from resource path --- to 'ResourceDef'. +-- to 'Resource'. newtype ResTree = ResTree ResNode -- root だから Map ではない -type ResSubtree = Map String ResNode -data ResNode = ResNode !(Maybe ResourceDef) !ResSubtree +type ResSubtree = Map ByteString ResNode +data ResNode = ResNode (Maybe Resource) ResSubtree -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g. -- @@ -113,159 +52,96 @@ data ResNode = ResNode !(Maybe ResourceDef) !ResSubtree -- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd -- ] -- @ -mkResTree :: [ ([String], ResourceDef) ] -> ResTree -mkResTree xs = xs `seq` processRoot xs +-- +-- Note that path components are always represented as octet streams +-- in this system. Lucu automatically decodes percent-encoded URIs but +-- has no involvement in character encodings such as UTF-8, since RFC +-- 2616 (HTTP/1.1) says nothing about character encodings to be used +-- in \"http\" and \"https\" URI schemas. +mkResTree ∷ [ ([ByteString], Resource) ] → ResTree +mkResTree = processRoot ∘ map (first canonicalisePath) where - processRoot :: [ ([String], ResourceDef) ] -> ResTree + canonicalisePath ∷ [ByteString] → [ByteString] + canonicalisePath = filter ((¬) ∘ BS.null) + + processRoot ∷ [ ([ByteString], Resource) ] → 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 - -- "/" にリソースが定義されない。"/foo" とかにはあるかも。 + -- The root has no resources. Maybe there's one at + -- somewhere like "/foo". ResTree (ResNode Nothing children) else - -- "/" がある。 + -- There is a root resource. let (_, def) = last roots in ResTree (ResNode (Just def) children) - processNonRoot :: [ ([String], ResourceDef) ] -> ResSubtree + processNonRoot ∷ [ ([ByteString], Resource) ] → ResSubtree processNonRoot list = let subtree = M.fromList [(name, node name) - | name <- childNames] - childNames = [name | (name:_, _) <- list] - node name = let defs = [def | (path, def) <- list, path == [name]] + | name ← childNames] + childNames = [name | (name:_, _) ← list] + node name = let defs = [def | (path, def) ← list, path ≡ [name]] in if null defs then - -- この位置にリソースが定義されない。 - -- もっと下にはあるかも。 + -- No resources are defined + -- here. Maybe there's one at + -- somewhere below this node. ResNode Nothing children else - -- この位置にリソースがある。 + -- There is a resource here. ResNode (Just $ last defs) children children = processNonRoot [(path, def) - | (_:path, def) <- list, not (null path)] + | (_:path, def) ← list] in subtree - -findResource :: ResTree -> [FallbackHandler] -> URI -> IO (Maybe ([String], ResourceDef)) +findResource ∷ ResTree + → [FallbackHandler] + → URI + → IO (Maybe ([ByteString], Resource)) findResource (ResTree (ResNode rootDefM subtree)) fbs uri - = do let pathStr = uriPath uri - path = [x | x <- splitBy (== '/') pathStr, x /= ""] - foundInTree = if null path then - do def <- rootDefM - return (path, def) - else - walkTree subtree path [] + = do let path = splitPathInfo uri + hasGreedyRoot = maybe False resIsGreedy rootDefM + foundInTree = if hasGreedyRoot ∨ null path then + do def ← rootDefM + return ([], def) + else + walkTree subtree path (∅) if isJust foundInTree then return foundInTree - else + else fallback path fbs where - walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef) + walkTree ∷ ResSubtree + → [ByteString] + → Seq ByteString + → Maybe ([ByteString], Resource) + + walkTree _ [] _ + = 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 (toList $ 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]) - - fallback :: [String] -> [FallbackHandler] -> IO (Maybe ([String], ResourceDef)) + = do ResNode defM sub ← M.lookup x tree + case defM of + Just (Resource { resIsGreedy = True }) + → do def ← defM + return (toList $ soFar ⊳ x, def) + _ → walkTree sub xs (soFar ⊳ x) + + fallback ∷ [ByteString] + → [FallbackHandler] + → IO (Maybe ([ByteString], Resource)) fallback _ [] = return Nothing - fallback path (x:xs) = do m <- x path + fallback path (x:xs) = do m ← x path case m of - 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 - ) - $ \ exc -> processException exc - where - fork :: IO () -> IO ThreadId - fork = if (resUsesNativeThread def) - then forkOS - else forkIO - - 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 - _ -> undefined - - notAllowed :: Resource () - notAllowed = do setStatus MethodNotAllowed - setHeader (C8.pack "Allow") (C8.pack $ joinWith ", " allowedMethods) - - allowedMethods :: [String] - allowedMethods = nub $ foldr (++) [] [ methods resGet ["GET"] - , methods resHead ["GET", "HEAD"] - , methods resPost ["POST"] - , methods resPut ["PUT"] - , methods resDelete ["DELETE"] - ] - - methods :: (ResourceDef -> Maybe a) -> [String] -> [String] - methods f xs = case f def of - Just _ -> xs - Nothing -> [] - - processException :: Exception -> IO () - processException exc - = do let abo = case exc of - ErrorCall msg -> Abortion InternalServerError emptyHeaders $ Just msg - IOException ioE -> Abortion InternalServerError emptyHeaders $ Just $ formatIOE ioE - DynException dynE -> case fromDynamic dynE of - Just a - -> a :: Abortion - Nothing - -> Abortion InternalServerError emptyHeaders - $ Just $ show exc - _ -> Abortion InternalServerError emptyHeaders $ Just $ show exc - conf = itrConfig itr - -- まだ DecidingHeader 以前の状態だったら、この途中終了 - -- を應答に反映させる餘地がある。さうでなければ stderr - -- にでも吐くしか無い。 - state <- atomically $ readItr itr itrState id - reqM <- atomically $ readItr itr itrRequest id - res <- atomically $ readItr itr itrResponse id - if state <= DecidingHeader then - flip runRes itr - $ do setStatus $ aboStatus abo - mapM_ (\ (name, value) -> setHeader name value) $ fromHeaders $ aboHeaders abo - output $ abortPage conf reqM res abo - else - when (cnfDumpTooLateAbortionToStderr $ itrConfig itr) - $ hPutStrLn stderr $ show abo - - flip runRes itr $ driftTo Done - - formatIOE :: IOError -> String - formatIOE ioE = if isUserError ioE then - ioeGetErrorString ioE - else - show ioE + Just def → return $ Just ([], def) + Nothing → fallback path xs