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=062ffdca9217b5dd5462cf238fdb97e033b01ca7;hb=1ead053df6a792edafa9d714c4c038a8a9c3ad16;hpb=c6b11025d1f81c668e9995e856b7bb34175230d3 diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index 062ffdc..4a652a7 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -1,188 +1,147 @@ +{-# LANGUAGE + DoAndIfThenElse + , OverloadedStrings + , RecordWildCards + , UnicodeSyntax + #-} + +-- | Repository of the resources in httpd. module Network.HTTP.Lucu.Resource.Tree - ( ResourceDef(..) - , Resource - , ResTree - , mkResTree -- [ ([String], ResourceDef) ] -> ResTree + ( ResTree + , FallbackHandler - , findResource -- ResTree -> URI -> Maybe ResourceDef - , runResource -- ResourceDef -> Interaction -> IO ThreadId + , mkResTree + , findResource ) where - -import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception -import Control.Monad.Reader -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.Request -import Network.HTTP.Lucu.Resource -import Network.HTTP.Lucu.Response -import Network.HTTP.Lucu.Interaction -import Network.HTTP.Lucu.Utils -import Network.URI -import System.IO -import System.IO.Error hiding (catch) -import Prelude hiding (catch) - - -{- /aaa/bbb/ccc にアクセスされた時、もし /aaa/bbb に貪欲なリソースがあ - れば、假に /aaa/bbb/ccc に何らかのリソースがあったとしても必ず - /aaa/bbb が撰ばれる。/aaa/bbb のリソースが貪欲でなければ、それは無視 - される。 -} -data ResourceDef = ResourceDef { - resUsesNativeThread :: Bool - , resIsGreedy :: Bool - , resGet :: Maybe (Resource ()) - , resHead :: Maybe (Resource ()) - , resPost :: Maybe (Resource ()) - , resPut :: Maybe (Resource ()) - , resDelete :: Maybe (Resource ()) - } -type ResTree = ResNode -- root だから Map ではない -type ResSubtree = Map String ResNode -data ResNode = ResNode (Maybe ResourceDef) ResSubtree - - -mkResTree :: [ ([String], ResourceDef) ] -> ResTree -mkResTree list = processRoot list +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 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 '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 'Resource'. +newtype ResTree = ResTree ResNode -- root だから Map ではない +type ResSubtree = Map ByteString ResNode +data ResNode = ResNode (Maybe Resource) ResSubtree + +-- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g. +-- +-- @ +-- mkResTree [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/ +-- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd +-- ] +-- @ +-- +-- 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 とかにはあるかも。 - ResNode Nothing children + -- 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 - ResNode (Just def) children + 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 -> URI -> Maybe ResourceDef -findResource (ResNode rootDefM subtree) uri - = let pathStr = uriPath uri - path = [x | x <- splitBy (== '/') pathStr, x /= ""] - in - if null path then - rootDefM - else - walkTree subtree path - where - walkTree :: ResSubtree -> [String] -> Maybe ResourceDef - - walkTree subtree (name:[]) - = case M.lookup name subtree of - Nothing -> Nothing - Just (ResNode defM _) -> defM - - walkTree subtree (x:xs) - = case M.lookup x subtree of - Nothing -> Nothing - Just (ResNode defM children) -> case defM of - Just (ResourceDef { resIsGreedy = True }) - -> defM - _ -> walkTree children xs - - -runResource :: ResourceDef -> Interaction -> IO ThreadId -runResource def itr - = fork - $ catch ( runReaderT ( do fromMaybe notAllowed rsrc - driftTo Done - ) itr - ) - $ \ exc -> processException (itrConfig itr) exc +findResource ∷ ResTree + → [FallbackHandler] + → URI + → IO (Maybe ([ByteString], Resource)) +findResource (ResTree (ResNode rootDefM subtree)) fbs uri + = 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 + fallback path fbs where - fork :: IO () -> IO ThreadId - fork = if (resUsesNativeThread def) - then forkOS - else forkIO - - rsrc :: Maybe (Resource ()) - rsrc = case reqMethod $ fromJust $ itrRequest itr 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 - - notAllowed :: Resource () - notAllowed = do setStatus MethodNotAllowed - setHeader "Allow" $ 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 :: Config -> Exception -> IO () - processException conf exc - = do let abo = case exc of - ErrorCall msg -> Abortion InternalServerError [] msg - IOException ioE -> Abortion InternalServerError [] $ formatIOE ioE - DynException dynE -> case fromDynamic dynE of - Just (abo :: Abortion) -> abo - Nothing - -> Abortion InternalServerError [] - $ show exc - _ -> Abortion InternalServerError [] $ show exc - -- まだ DecidingHeader 以前の状態だったら、この途中終了 - -- を應答に反映させる餘地がある。さうでなければ stderr - -- にでも吐くしか無い。 - state <- atomically $ readItr itr itrState id - if state <= DecidingHeader then - flip runReaderT itr - $ do setStatus $ aboStatus abo - -- FIXME: 同じ名前で複數の値があった時は、こ - -- れではまずいと思ふ。 - mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo - setHeader "Content-Type" "application/xhtml+xml" - output $ aboPage conf abo - else - hPutStrLn stderr $ show abo - - flip runReaderT itr $ driftTo Done - - formatIOE :: IOError -> String - formatIOE ioE = if isUserError ioE then - ioeGetErrorString ioE - else - show ioE + walkTree ∷ ResSubtree + → [ByteString] + → Seq ByteString + → Maybe ([ByteString], Resource) + + walkTree _ [] _ + = error "Internal error: should not reach here." + + walkTree tree (name:[]) soFar + = do ResNode defM _ ← M.lookup name tree + def ← defM + return (toList $ soFar ⊳ name, def) + + walkTree tree (x:xs) soFar + = 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 + case m of + Just def → return $ Just ([], def) + Nothing → fallback path xs