-- | 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 Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
import Control.Monad
-import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.Lazy.Encoding as LT
+import Data.Foldable
import Data.List
import qualified Data.Map as M
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.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 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.
--
-- ]
-- @
--
--- Note that the request path in an incoming HTTP request is always
--- treated as an URI-encoded UTF-8 string.
-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
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]
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
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
= 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)
- _ â\86\92 walkTree sub xs (soFar ⧺ [x])
+ return (toList $ soFar ⊳ x, def)
+ _ â\86\92 walkTree sub xs (soFar â\8a³ 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
- setHeader "Content-Type" defaultPageContentType
- 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
projects / Lucu.git / blobdiff