-- | 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.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)
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
-- 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 ではない
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"
- ]
projects / Lucu.git / blobdiff