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=d386bce8cd78486a5f89c039a5bf3b5c78ff57a3;hb=1ead053df6a792edafa9d714c4c038a8a9c3ad16;hpb=cc55fb9a095c9c583ed6fe2ded3eaf6401fb760f diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index d386bce..4a652a7 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -1,141 +1,49 @@ {-# LANGUAGE DoAndIfThenElse , OverloadedStrings + , RecordWildCards , UnicodeSyntax #-} -{-# OPTIONS_HADDOCK prune #-} -- | Repository of the resources in httpd. module Network.HTTP.Lucu.Resource.Tree - ( ResourceDef(..) - , emptyResource - - , ResTree + ( ResTree , FallbackHandler , mkResTree - , findResource - , runResource ) where -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 Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Lazy.Encoding as LT -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 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 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 = [Text] → IO (Maybe ResourceDef) - - --- "/aaa/bbb/ccc" にアクセスされた時、もし "/aaa/bbb" に貪欲なリソース --- があれば、假に "/aaa/bbb/ccc" に何らかのリソースがあったとしても必ず --- "/aaa/bbb" が撰ばれる。"/aaa/bbb" のリソースが貪欲でなければ、それは --- 無視される。 - --- | 'ResourceDef' is basically a set of 'Resource' monads for each --- HTTP methods. -data ResourceDef = ResourceDef { - -- |Whether to run a 'Resource' on a native thread (spawned by - -- 'forkOS') or to run it on a user thread (spanwed by - -- 'forkIO'). Generally you don't need to set this field to - -- '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 '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 'output' and such like don't actually write a - -- response body. - , resGet ∷ !(Maybe (Resource ())) - -- | A '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 '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 '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 '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 ())) - } - --- |'emptyResource' is a resource definition with no actual --- handlers. You can construct a 'ResourceDef' by selectively --- overriding 'emptyResource'. It is defined as follows: --- --- @ --- emptyResource = ResourceDef { --- resUsesNativeThread = False --- , resIsGreedy = False --- , resGet = Nothing --- , resHead = Nothing --- , resPost = Nothing --- , resPut = Nothing --- , resDelete = Nothing --- } --- @ -emptyResource ∷ ResourceDef -emptyResource = ResourceDef { - resUsesNativeThread = False - , resIsGreedy = False - , resGet = Nothing - , resHead = Nothing - , resPost = Nothing - , resPut = Nothing - , resDelete = Nothing - } +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 Text 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. -- @@ -144,15 +52,21 @@ data ResNode = ResNode (Maybe ResourceDef) ResSubtree -- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd -- ] -- @ -mkResTree ∷ [ ([Text], ResourceDef) ] → ResTree -mkResTree = processRoot . map (first canonicalisePath) +-- +-- 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 - canonicalisePath ∷ [Text] → [Text] - canonicalisePath = filter (≢ "") + canonicalisePath ∷ [ByteString] → [ByteString] + canonicalisePath = filter ((¬) ∘ BS.null) - processRoot ∷ [ ([Text], ResourceDef) ] → ResTree + 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 @@ -165,12 +79,12 @@ mkResTree = processRoot . map (first canonicalisePath) in ResTree (ResNode (Just def) children) - processNonRoot ∷ [ ([Text], 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]] + node name = let defs = [def | (path, def) ← list, path ≡ [name]] in if null defs then -- No resources are defined @@ -185,123 +99,49 @@ mkResTree = processRoot . map (first canonicalisePath) in subtree - -findResource ∷ ResTree → [FallbackHandler] → URI → IO (Maybe ([Text], ResourceDef)) +findResource ∷ ResTree + → [FallbackHandler] + → URI + → IO (Maybe ([ByteString], Resource)) 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 - walkTree subtree path [] + walkTree subtree path (∅) if isJust foundInTree then return foundInTree else fallback path fbs where - walkTree ∷ ResSubtree → [Text] → [Text] → Maybe ([Text], 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 ∷ [Text] → [FallbackHandler] → IO (Maybe ([Text], 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 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 - 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 - = setStatus MethodNotAllowed - *> - (setHeader "Allow" $ A.fromAsciiBuilder - $ joinWith ", " - $ map A.toAsciiBuilder allowedMethods) - - allowedMethods ∷ [Ascii] - allowedMethods = nub $ concat [ methods resGet ["GET"] - , methods resHead ["GET", "HEAD"] - , methods resPost ["POST"] - , methods resPut ["PUT"] - , methods resDelete ["DELETE"] - ] - - methods ∷ (ResourceDef → Maybe a) → [Ascii] → [Ascii] - methods f xs = case f def of - Just _ → xs - Nothing → [] - - toAbortion ∷ SomeException → Abortion - toAbortion e - = case fromException e of - Just abortion → abortion - Nothing → Abortion InternalServerError (∅) (Just $ T.pack $ show e) - - processException ∷ SomeException → IO () - processException exc - = do let abo = toAbortion exc - conf = itrConfig itr - -- まだ DecidingHeader 以前の状態だったら、この途中終了 - -- を應答に反映させる餘地がある。さうでなければ stderr - -- にでも吐くしか無い。 - state ← atomically $ readItr itrState itr - reqM ← atomically $ readItr itrRequest itr - res ← atomically $ readItr itrResponse itr - 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 $ driftTo Done