X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FDispatcher%2FInternal.hs;h=35f2f1ed403c81dfa36052d23b20b74995867628;hb=b42b4ab2f78fa62dd023acd136085dae6dc9028a;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..35f2f1e 100644 --- a/Network/HTTP/Lucu/Dispatcher/Internal.hs +++ b/Network/HTTP/Lucu/Dispatcher/Internal.hs @@ -1,17 +1,14 @@ {-# 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 @@ -21,6 +18,8 @@ module Network.HTTP.Lucu.Dispatcher.Internal , ResourceMap , ResourceTree , ResourceNode + , greedy + , nonGreedy , dispatch ) @@ -74,18 +73,37 @@ class ResourceMapper α where -- |Container type for the 'ResourceMapper' type class. data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α --- |FIXME: doc -newtype ResourceTree = Root ResourceNode - deriving (Monoid, Show) +-- |'ResourceTree' is an opaque structure which is a map from resource +-- path to 'Resource'. +-- +-- @ +-- '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 PathSegments ResourceNode) + deriving Monoid --- |FIXME: docs +-- |FIXME: doc data ResourceNode - = Greedy !Resource - | NonGreedy !Resource !SubTree - | Branch !SubTree + = Greedy { nResource ∷ !Resource } + | NonGreedy { nResource ∷ !Resource } + +-- |FIXME: doc +greedy ∷ Resource → ResourceNode +{-# INLINE CONLIKE greedy #-} +greedy = Greedy -type SubTree - = M.Map PathSegment ResourceNode +-- |FIXME: doc +nonGreedy ∷ Resource → ResourceNode +{-# INLINE CONLIKE nonGreedy #-} +nonGreedy = NonGreedy -- Instances of SchemeMapper -------------------------------------------------- instance SchemeMapper SchemeMap where @@ -252,54 +270,36 @@ instance ResourceMapper (PathSegments → Maybe (PathSegments, Resource)) where -- Instances of ResourceTree -------------------------------------------------- instance Unfoldable ResourceTree (PathSegments, 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) +-- |'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 α PathSegments ResourceNode) + ⇒ PathSegments + → α + → MaybeT m (PathSegments, 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) @@ -307,65 +307,3 @@ 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