X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FDispatcher%2FInternal.hs;h=3699f700fd82c2413bd47b54e82d7b4ee2c8a072;hb=243b99439640480fc148d2e175247dacce04a222;hp=88b1e16cd07056110e78a93c440d89debcc10226;hpb=01fe22bec14421e3b9430efbfc9daee05f181730;p=Lucu.git diff --git a/Network/HTTP/Lucu/Dispatcher/Internal.hs b/Network/HTTP/Lucu/Dispatcher/Internal.hs index 88b1e16..3699f70 100644 --- a/Network/HTTP/Lucu/Dispatcher/Internal.hs +++ b/Network/HTTP/Lucu/Dispatcher/Internal.hs @@ -1,26 +1,23 @@ {-# LANGUAGE - DoAndIfThenElse - , ExistentialQuantification + ExistentialQuantification + , FlexibleContexts , FlexibleInstances , GeneralizedNewtypeDeriving , OverlappingInstances , MultiParamTypeClasses - , RecordWildCards - , ScopedTypeVariables , TemplateHaskell , UndecidableInstances , UnicodeSyntax #-} -{-# OPTIONS_GHC -fno-warn-missing-methods #-} module Network.HTTP.Lucu.Dispatcher.Internal - ( SchemeMapper(..) - , SchemeMap - , HostMapper(..) + ( HostMapper(..) , HostMap , ResourceMapper(..) , ResourceMap , ResourceTree , ResourceNode + , greedy + , nonGreedy , dispatch ) @@ -29,125 +26,97 @@ 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 = Root ResourceNode - deriving (Monoid, Show) +-- |'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: docs +-- |A node of 'Resource' located somewhere in a 'ResourceTree'. Such +-- nodes are either 'greedy' or 'nonGreedy'. data ResourceNode - = Greedy !Resource - | NonGreedy !Resource !SubTree - | Branch !SubTree - -type SubTree - = M.Map PathSegment ResourceNode - --- 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 + = Greedy { nResource ∷ !Resource } + | NonGreedy { nResource ∷ !Resource } --- |@'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 +-- |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 --- |A pure scheme mapper. -instance SchemeMapper (Scheme → Maybe HostMap) where - {-# INLINE findHostMap #-} - findHostMap = (maybe (fail (⊥)) return ∘) ∘ flip id +-- |Make a normal, non-greedy resource node. +nonGreedy ∷ Resource → ResourceNode +{-# INLINE CONLIKE nonGreedy #-} +nonGreedy = NonGreedy -- Instances of HostMapper ---------------------------------------------------- @@ -214,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 #-} @@ -227,145 +196,71 @@ 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, a) (Root b) = Root $ insertNodeAt (canonPath p) a b + insert (p, n) (Tree m) = Tree $ insert (canonPath p, n) m {-# INLINE empty #-} - empty = Root $ Branch (∅) + empty = Tree (∅) + {-# INLINE singleton #-} + singleton = Tree ∘ singleton canonPath ∷ (Collection c f, Foldable f e) ⇒ c → c {-# INLINEABLE canonPath #-} canonPath = filter ((¬) ∘ null) -insertNodeAt ∷ PathSegments → ResourceNode → ResourceNode → ResourceNode -{-# INLINEABLE insertNodeAt #-} -insertNodeAt p a b - = case front p of - Nothing → a ⊕ b - Just (x, xs) - | null xs → Branch (singleton (x, a)) ⊕ b - | otherwise → insertNodeAt xs a (∅) ⊕ b - -instance Foldable ResourceTree (PathSegments, ResourceNode) where - foldMap f (Root n) = go (∅) n - where - go p (Greedy r ) = f (p, Greedy r) - go p (NonGreedy r m) = f (p, NonGreedy r (∅)) ⊕ go' p m - go p (Branch m) = go' p m - - go' p = foldMap $ \(s, n') → go (p `snoc` s) n' - - null (Root (Greedy _ )) = False - null (Root (NonGreedy _ _)) = False - null (Root (Branch m)) = null m - - --- Instances of ResourceNode -------------------------------------------------- -instance Show ResourceNode where - show (Greedy _ ) = "Greedy _" - show (NonGreedy _ m) = "NonGreedy _ " ⊕ show m - show (Branch m) = "Branch " ⊕ show m - -instance Monoid ResourceNode where - {-# INLINE mempty #-} - mempty = Branch (∅) - {-# INLINEABLE mappend #-} - mappend (Greedy r ) _ = Greedy r - mappend (NonGreedy r m) (Greedy _ ) = NonGreedy r m - mappend (NonGreedy r m) (NonGreedy _ n) = NonGreedy r (m ⊕ n) - mappend (NonGreedy r m) (Branch n) = NonGreedy r (m ⊕ n) - mappend (Branch _) (Greedy r ) = Greedy r - mappend (Branch m) (NonGreedy r n) = NonGreedy r (m ⊕ n) - mappend (Branch m) (Branch n) = Branch (m ⊕ n) +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 + {-# INLINEABLE findResource #-} + findResource p (Tree m) + = case lookup p m of + Just n → return (p, nResource n) + Nothing → findGreedyResource p m + +findGreedyResource ∷ (Monad m, Map α Path ResourceNode) + ⇒ Path + → α + → MaybeT m (Path, Resource) +findGreedyResource p m + = case back p of + Nothing → fail (⊥) + Just (p', _) → case lookup p' m of + Just (Greedy r) + → return (p', r) + _ → 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)