X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource%2FTree.hs;h=9ab6f663254f9cf8c5e28e183ba2ccaddf7cdd25;hb=1f0a19cbad7c4b64a773d7f1c1ae9180448624e6;hp=6bf422f72fcf1ee14a567664c79341db03f7d138;hpb=ca338174155913a969808d7b20193973394e474e;p=Lucu.git diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index 6bf422f..9ab6f66 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -4,52 +4,45 @@ , 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.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 - -- |'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 @@ -57,81 +50,6 @@ import Prelude.Unicode -- 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 - } - -- |'ResTree' is an opaque structure which is a map from resource path -- to 'ResourceDef'. newtype ResTree = ResTree ResNode -- root だから Map ではない @@ -145,6 +63,9 @@ 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) where @@ -224,75 +145,3 @@ findResource (ResTree (ResNode rootDefM subtree)) fbs uri 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