X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource%2FTree.hs;h=9ab6f663254f9cf8c5e28e183ba2ccaddf7cdd25;hp=17827d12369d4eb950220ff48be0dd0cbde6d8ba;hb=1f0a19cbad7c4b64a773d7f1c1ae9180448624e6;hpb=1789cee5ee66d2f7f2b26280be2f13eac4df7980 diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs index 17827d1..9ab6f66 100644 --- a/Network/HTTP/Lucu/Resource/Tree.hs +++ b/Network/HTTP/Lucu/Resource/Tree.hs @@ -7,16 +7,11 @@ -- | Repository of the resources in httpd. module Network.HTTP.Lucu.Resource.Tree - ( ResourceDef(..) - , emptyResource - - , ResTree + ( ResTree , FallbackHandler , mkResTree - , findResource - , runResource ) where import Control.Arrow @@ -29,7 +24,6 @@ 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 qualified Data.Map as M import Data.Map (Map) @@ -49,7 +43,6 @@ 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 ではない @@ -227,84 +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 - setHeader "Content-Type" defaultPageContentType - mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo - putChunk $ LT.encodeUtf8 $ abortPage itrConfig itrRequest res abo - else - when (cnfDumpTooLateAbortionToStderr itrConfig) - $ dumpAbortion abo - runRes (driftTo Done) itr - -dumpAbortion ∷ Abortion → IO () -dumpAbortion abo - = hPutStr stderr - $ concat [ "Lucu: an exception occured after " - , "sending response header to the client:\n" - , " ", show abo, "\n" - ]