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=6bf422f72fcf1ee14a567664c79341db03f7d138;hb=1ead053df6a792edafa9d714c4c038a8a9c3ad16;hpb=ca338174155913a969808d7b20193973394e474e diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index 6bf422f..4a652a7 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -4,139 +4,46 @@ , 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. -- @@ -145,13 +52,19 @@ data ResNode = ResNode (Maybe ResourceDef) ResSubtree -- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd -- ] -- @ -mkResTree ∷ [ ([Text], ResourceDef) ] → ResTree +-- +-- 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, _) → null path) list children = processNonRoot nonRoots @@ -166,7 +79,7 @@ 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] @@ -186,7 +99,10 @@ 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 hasGreedyRoot = maybe False resIsGreedy rootDefM @@ -194,13 +110,16 @@ findResource (ResTree (ResNode rootDefM subtree)) fbs uri 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." @@ -208,91 +127,21 @@ findResource (ResTree (ResNode rootDefM subtree)) fbs uri walkTree tree (name:[]) soFar = do ResNode defM _ ← M.lookup name tree def ← defM - return (soFar ⧺ [name], def) + return (toList $ soFar ⊳ name, def) walkTree tree (x:xs) soFar = do ResNode defM sub ← M.lookup x tree case defM of - Just (ResourceDef { resIsGreedy = True }) + Just (Resource { resIsGreedy = True }) → do def ← defM - return (soFar ⧺ [x], def) - _ → walkTree sub xs (soFar ⧺ [x]) + return (toList $ soFar ⊳ x, def) + _ → walkTree sub xs (soFar ⊳ x) - fallback ∷ [Text] → [FallbackHandler] → IO (Maybe ([Text], ResourceDef)) + 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 - - -runResource ∷ ResourceDef → Interaction → IO ThreadId -runResource (ResourceDef {..}) itr@(Interaction {..}) - = 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 - = case reqMethod req of - GET → resGet - HEAD → case resHead of - Just r → Just r - Nothing → resGet - POST → resPost - PUT → resPut - DELETE → resDelete - _ → error $ "Unknown request method: " ⧺ show (reqMethod req) - - 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 ∷ Maybe a → [Ascii] → [Ascii] - methods m xs - | isJust m = xs - | otherwise = [] - - 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 - -- まだ DecidingHeader 以前の状態だったら、この途中終了 - -- を應答に反映させる餘地がある。さうでなければ stderr - -- にでも吐くしか無い。 - 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 itrConfig itrRequest res abo - else - when (cnfDumpTooLateAbortionToStderr itrConfig) - $ hPutStrLn stderr $ show abo - runRes (driftTo Done) itr