X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FDispatcher%2FInternal.hs;h=3699f700fd82c2413bd47b54e82d7b4ee2c8a072;hb=243b99439640480fc148d2e175247dacce04a222;hp=c889fc51dfae6683f2a6b10890ac7178f5860459;hpb=e30ad424d38d9406a8cede15b2fb730bc138ce64;p=Lucu.git diff --git a/Network/HTTP/Lucu/Dispatcher/Internal.hs b/Network/HTTP/Lucu/Dispatcher/Internal.hs index c889fc5..3699f70 100644 --- a/Network/HTTP/Lucu/Dispatcher/Internal.hs +++ b/Network/HTTP/Lucu/Dispatcher/Internal.hs @@ -10,9 +10,7 @@ , UnicodeSyntax #-} module Network.HTTP.Lucu.Dispatcher.Internal - ( SchemeMapper(..) - , SchemeMap - , HostMapper(..) + ( HostMapper(..) , HostMap , ResourceMapper(..) , ResourceMap @@ -28,132 +26,98 @@ import Control.Applicative hiding (empty) import Control.Monad.Trans.Maybe import Control.Monad.Unicode import Data.Collections +import qualified Data.Collections.Newtype.TH as C import qualified Data.Map as M import Data.Monoid import Data.Monoid.Unicode import Network.HTTP.Lucu.Resource.Internal import Network.HTTP.Lucu.Utils import Network.URI hiding (path) -import Prelude hiding (filter, lookup, null) +import Prelude hiding (filter, foldr, lookup, null) import Prelude.Unicode --- |FIXME: docs +-- |Class of maps from 'Host' to 'ResourceMap' to provide name-based +-- virtual hosts. -- --- Minimal complete definition: 'findHostMap' -class SchemeMapper α where - findHostMap ∷ Scheme → α → MaybeT IO HostMap - schemeMap ∷ α → SchemeMap - {-# INLINE schemeMap #-} - schemeMap = SMap - --- |Container type for the 'SchemeMapper' type class. -data SchemeMap = ∀α. SchemeMapper α ⇒ SMap α - --- |FIXME: docs +-- Note that Lucu currently does not implement neither RFC 2817 +-- connection upgrading () nor RFC +-- 3546 server name indication +-- () so you won't be +-- able to host more than one SSL virtual host on the same port +-- without using wildcard certificates +-- (). -- -- Minimal complete definition: 'findResourceMap' class HostMapper α where + -- |Find a repository of resources for the given host name if any. findResourceMap ∷ Host → α → MaybeT IO ResourceMap + -- |Wrap an instance of 'HostMapper' in a monoidal, homogeneous + -- container. hostMap ∷ α → HostMap {-# INLINE hostMap #-} hostMap = HMap -- |Container type for the 'HostMapper' type class. -data HostMap = ∀α. HostMapper α ⇒ HMap α +data HostMap = ∀α. HostMapper α ⇒ HMap !α --- |FIXME: docs +-- |Class of maps from resource 'Path' to 'Resource'. -- -- Minimal complete definition: 'findResource' class ResourceMapper α where - findResource ∷ PathSegments → α → MaybeT IO (PathSegments, Resource) + -- |Find a resource handler for the given resource path, along + -- with the path where the said handler was found. The found path + -- is usually the same as the queried path, but there are + -- situations where the found path is just a prefix of the queried + -- path. See 'greedy'. + findResource ∷ Path → α → MaybeT IO (Path, Resource) + -- |Wrap an instance of 'ResourceMapper' in a monoidal, + -- homogeneous container. resourceMap ∷ α → ResourceMap {-# INLINE resourceMap #-} resourceMap = RMap -- |Container type for the 'ResourceMapper' type class. -data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α +data ResourceMap = ∀α. ResourceMapper α ⇒ RMap !α --- |FIXME: doc -newtype ResourceTree = Tree (M.Map PathSegments ResourceNode) +-- |'ResourceTree' is an opaque structure which a map from resource +-- 'Path' to 'ResourceNode'. +-- +-- @ +-- 'fromList' [ ([] , 'nonGreedy' '$' 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/ +-- , ([\"unistd\"], 'nonGreedy' '$' 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd +-- ] +-- @ +-- +-- Note that path segments 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. +newtype ResourceTree = Tree (M.Map Path ResourceNode) deriving Monoid --- |FIXME: doc +-- |A node of 'Resource' located somewhere in a 'ResourceTree'. Such +-- nodes are either 'greedy' or 'nonGreedy'. data ResourceNode = Greedy { nResource ∷ !Resource } | NonGreedy { nResource ∷ !Resource } --- |FIXME: doc +-- |Make a greedy resource node. +-- +-- Say a client is trying to access \"\/aaa\/bbb\/ccc\' while there is +-- no resource node at the path. If there are greedy resource nodes at +-- \"\/aaa\/bbb\", \"\/aaa\" or \"/\" they will be chosen instead as a +-- fallback. Greedy resource nodes are searched in depth-first +-- order, just like CGI scripts. greedy ∷ Resource → ResourceNode {-# INLINE CONLIKE greedy #-} greedy = Greedy --- |FIXME: doc +-- |Make a normal, non-greedy resource node. nonGreedy ∷ Resource → ResourceNode {-# INLINE CONLIKE nonGreedy #-} nonGreedy = NonGreedy --- Instances of SchemeMapper -------------------------------------------------- -instance SchemeMapper SchemeMap where - {-# INLINE findHostMap #-} - findHostMap s (SMap α) = findHostMap s α - {-# INLINE schemeMap #-} - schemeMap = id - --- |'HostMap's are also 'SchemeMapper's too, which matches to any --- schemes. -instance SchemeMapper HostMap where - {-# INLINE findHostMap #-} - findHostMap = const return - --- |'ResourceMap's are also 'SchemeMapper's too, which matches to any --- schemes and hosts. -instance SchemeMapper ResourceMap where - {-# INLINE findHostMap #-} - findHostMap _ r = return $ hostMap f - where - f ∷ Host → Maybe ResourceMap - {-# INLINE f #-} - f = const $ Just r - --- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next. -instance SchemeMapper α ⇒ Unfoldable SchemeMap α where - {-# INLINE insert #-} - insert a (SMap b) = schemeMap c - where - c ∷ Scheme → MaybeT IO HostMap - {-# INLINEABLE c #-} - c s = findHostMap s a <|> findHostMap s b - {-# INLINE empty #-} - empty = (∅) - {-# INLINE singleton #-} - singleton = schemeMap - --- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next. -instance Monoid SchemeMap where - {-# INLINE mempty #-} - mempty = schemeMap e - where - e ∷ Scheme → MaybeT IO HostMap - {-# INLINE e #-} - e = const (fail (⊥)) - {-# INLINE mappend #-} - mappend = insert - --- |Any 'Map's from 'Scheme' to 'HostMap' are also 'SchemeMapper's. -instance Map α Scheme HostMap ⇒ SchemeMapper α where - {-# INLINE findHostMap #-} - findHostMap = (maybe (fail (⊥)) return ∘) ∘ lookup - --- |An IO-based scheme mapper. -instance SchemeMapper (Scheme → MaybeT IO HostMap) where - {-# INLINE findHostMap #-} - findHostMap = flip id - --- |A pure scheme mapper. -instance SchemeMapper (Scheme → Maybe HostMap) where - {-# INLINE findHostMap #-} - findHostMap = (maybe (fail (⊥)) return ∘) ∘ flip id - -- Instances of HostMapper ---------------------------------------------------- instance HostMapper HostMap where @@ -219,7 +183,7 @@ instance ResourceMapper α ⇒ Unfoldable ResourceMap α where {-# INLINE insert #-} insert a (RMap b) = resourceMap c where - c ∷ PathSegments → MaybeT IO (PathSegments, Resource) + c ∷ Path → MaybeT IO (Path, Resource) {-# INLINEABLE c #-} c s = findResource s a <|> findResource s b {-# INLINE empty #-} @@ -232,30 +196,30 @@ instance Monoid ResourceMap where {-# INLINE mempty #-} mempty = resourceMap e where - e ∷ PathSegments → MaybeT IO (PathSegments, Resource) + e ∷ Path → MaybeT IO (Path, Resource) {-# INLINE e #-} e = const (fail (⊥)) {-# INLINE mappend #-} mappend = insert --- |Any 'Map's from 'PathSegments' to @('PathSegments', 'Resource')@ --- are also 'ResourceMapper's. -instance Map α PathSegments (PathSegments, Resource) ⇒ ResourceMapper α where +-- |Any 'Map's from 'Path' to @('Path', 'Resource')@ are also +-- 'ResourceMapper's. +instance Map α Path (Path, Resource) ⇒ ResourceMapper α where {-# INLINE findResource #-} findResource = (maybe (fail (⊥)) return ∘) ∘ lookup -- |An IO-based resource mapper. -instance ResourceMapper (PathSegments → MaybeT IO (PathSegments, Resource)) where +instance ResourceMapper (Path → MaybeT IO (Path, Resource)) where {-# INLINE findResource #-} findResource = flip id -- |A pure resource mapper. -instance ResourceMapper (PathSegments → Maybe (PathSegments, Resource)) where +instance ResourceMapper (Path → Maybe (Path, Resource)) where {-# INLINE findResource #-} findResource = (maybe (fail (⊥)) return ∘) ∘ flip id -- Instances of ResourceTree -------------------------------------------------- -instance Unfoldable ResourceTree (PathSegments, ResourceNode) where +instance Unfoldable ResourceTree (Path, ResourceNode) where {-# INLINEABLE insert #-} insert (p, n) (Tree m) = Tree $ insert (canonPath p, n) m {-# INLINE empty #-} @@ -267,6 +231,13 @@ canonPath ∷ (Collection c f, Foldable f e) ⇒ c → c {-# INLINEABLE canonPath #-} canonPath = filter ((¬) ∘ null) +C.derive [d| instance Foldable ResourceTree (Path, ResourceNode) + |] + +instance Collection ResourceTree (Path, ResourceNode) where + {-# INLINE filter #-} + filter f (Tree m) = Tree $ filter f m + -- |'findResource' performs the longest prefix match on the tree, -- finding the most specific one. instance ResourceMapper ResourceTree where @@ -276,10 +247,10 @@ instance ResourceMapper ResourceTree where Just n → return (p, nResource n) Nothing → findGreedyResource p m -findGreedyResource ∷ (Monad m, Map α PathSegments ResourceNode) - ⇒ PathSegments +findGreedyResource ∷ (Monad m, Map α Path ResourceNode) + ⇒ Path → α - → MaybeT m (PathSegments, Resource) + → MaybeT m (Path, Resource) findGreedyResource p m = case back p of Nothing → fail (⊥) @@ -289,70 +260,7 @@ findGreedyResource p m _ → findGreedyResource p' m -- dispatch ------------------------------------------------------------------- -dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, Resource) +dispatch ∷ HostMapper α ⇒ URI → α → MaybeT IO (Path, Resource) dispatch uri = (findResource (uriPathSegments uri) =≪) - ∘ (findResourceMap (uriHost uri) =≪) - ∘ findHostMap (uriCIScheme uri) - -{- --- |'ResTree' is an opaque structure which is a map from resource path --- to 'Resource'. -newtype ResTree = ResTree ResNode -- root だから Map ではない -type ResSubtree = Map ByteString ResNode -data ResNode = ResNode (Maybe Resource) ResSubtree - --- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g. --- --- @ --- mkResTree [ ([] , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/ --- , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd --- ] --- @ --- --- 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 ∷ [ByteString] → [ByteString] - canonicalisePath = filter ((¬) ∘ BS.null) - - processRoot ∷ [ ([ByteString], Resource) ] → ResTree - processRoot list - = let (roots, nonRoots) = partition (\(path, _) → null path) list - children = processNonRoot nonRoots - in - if null roots then - -- The root has no resources. Maybe there's one at - -- somewhere like "/foo". - ResTree (ResNode Nothing children) - else - -- There is a root resource. - let (_, def) = last roots - in - ResTree (ResNode (Just def) children) - - processNonRoot ∷ [ ([ByteString], Resource) ] → ResSubtree - processNonRoot list - = let subtree = M.fromList [(name, node name) - | name ← childNames] - childNames = [name | (name:_, _) ← list] - node name = let defs = [def | (path, def) ← list, path ≡ [name]] - in - if null defs then - -- No resources are defined - -- here. Maybe there's one at - -- somewhere below this node. - ResNode Nothing children - else - -- There is a resource here. - ResNode (Just $ last defs) children - children = processNonRoot [(path, def) - | (_:path, def) ← list] - in - subtree --} \ No newline at end of file + ∘ findResourceMap (uriHost uri)