X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FDispatcher%2FInternal.hs;h=6e088df8061178f32ffd492187502d4206def0cf;hb=fffa09842d060c7d738084125dea07783d84aefe;hp=35f2f1ed403c81dfa36052d23b20b74995867628;hpb=b42b4ab2f78fa62dd023acd136085dae6dc9028a;p=Lucu.git diff --git a/Network/HTTP/Lucu/Dispatcher/Internal.hs b/Network/HTTP/Lucu/Dispatcher/Internal.hs index 35f2f1e..6e088df 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,32 +26,33 @@ 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 @@ -61,11 +60,18 @@ class HostMapper α where -- |Container type for the 'HostMapper' type class. 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 @@ -73,8 +79,8 @@ class ResourceMapper α where -- |Container type for the 'ResourceMapper' type class. data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α --- |'ResourceTree' is an opaque structure which is a map from resource --- path to 'Resource'. +-- |'ResourceTree' is an opaque structure which a map from resource +-- 'Path' to 'ResourceNode'. -- -- @ -- 'fromList' [ ([] , 'nonGreedy' '$' 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/ @@ -87,86 +93,31 @@ data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α -- 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 PathSegments ResourceNode) +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 @@ -232,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 #-} @@ -245,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 #-} @@ -280,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 @@ -289,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 (⊥) @@ -302,8 +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) + ∘ findResourceMap (uriHost uri)