{-# LANGUAGE
- DoAndIfThenElse
- , ExistentialQuantification
+ ExistentialQuantification
+ , FlexibleContexts
, FlexibleInstances
+ , GeneralizedNewtypeDeriving
, OverlappingInstances
, MultiParamTypeClasses
- , RecordWildCards
- , ScopedTypeVariables
+ , TemplateHaskell
, UndecidableInstances
, UnicodeSyntax
#-}
module Network.HTTP.Lucu.Dispatcher.Internal
- ( SchemeMapper(..)
- , SchemeMap
- , HostMapper(..)
+ ( HostMapper(..)
, HostMap
, ResourceMapper(..)
, ResourceMap
, ResourceTree
, ResourceNode
+ , greedy
+ , nonGreedy
, dispatch
)
import Prelude hiding (filter, lookup, null)
import Prelude.Unicode
--- |FIXME: docs
---
--- 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
--
-- Minimal complete definition: 'findResourceMap'
--
-- Minimal complete definition: 'findResource'
class ResourceMapper α where
- findResource ∷ PathSegments → α → MaybeT IO (PathSegments, Resource)
+ findResource ∷ Path → α → MaybeT IO (Path, Resource)
resourceMap ∷ α → ResourceMap
{-# INLINE resourceMap #-}
resourceMap = RMap
-- |Container type for the 'ResourceMapper' type class.
data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α
--- FIXME: doc
-newtype ResourceTree = Root ResourceNode
+-- |'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 Path ResourceNode)
+ deriving Monoid
--- FIXME: docs
+-- |FIXME: doc
data ResourceNode
- = Greedy !Resource
- | NonGreedy !Resource !SubTree
- | Branch !SubTree
+ = Greedy { nResource ∷ !Resource }
+ | NonGreedy { nResource ∷ !Resource }
-type SubTree
- = M.Map PathSegment ResourceNode
+-- |FIXME: doc
+greedy ∷ Resource → ResourceNode
+{-# INLINE CONLIKE greedy #-}
+greedy = Greedy
--- 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
-
-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
+-- |FIXME: doc
+nonGreedy ∷ Resource → ResourceNode
+{-# INLINE CONLIKE nonGreedy #-}
+nonGreedy = NonGreedy
-- Instances of HostMapper ----------------------------------------------------
{-# INLINE mappend #-}
mappend = insert
+-- |Any 'Map's from 'Host' to 'ResourceMap' are also 'HostMapper's.
instance Map α Host ResourceMap ⇒ HostMapper α where
{-# INLINE findResourceMap #-}
findResourceMap = (maybe (fail (⊥)) return ∘) ∘ lookup
{-# 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 #-}
{-# 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
-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
- {-# INLINE insert #-}
- insert e (Root root) = Root $ insert e root
- {-# INLINE empty #-}
- empty = (∅)
-
-instance Monoid ResourceTree where
- {-# INLINE mempty #-}
- mempty = Root (∅)
- {-# INLINE mappend #-}
- mappend (Root a) (Root b)
- = Root (a ⊕ b)
-
--- Instances of ResourceNode --------------------------------------------------
-instance Unfoldable ResourceNode (PathSegments, ResourceNode) where
+instance Unfoldable ResourceTree (Path, ResourceNode) where
{-# INLINEABLE insert #-}
- insert (p, n) = insertNodeAt (canonPath p) n
+ insert (p, n) (Tree m) = Tree $ insert (canonPath p, n) m
{-# INLINE empty #-}
- empty = 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 Monoid ResourceNode where
- {-# INLINE mempty #-}
- mempty = Branch (∅)
- {-# INLINEABLE mappend #-}
- mappend _ (Greedy r ) = Greedy r
- mappend (Greedy _ ) (NonGreedy r n) = NonGreedy r n
- mappend (NonGreedy _ m) (NonGreedy r n) = NonGreedy r (m ⊕ n)
- mappend (Branch m) (NonGreedy r n) = NonGreedy r (m ⊕ n)
- mappend (Greedy r ) (Branch _) = Greedy r
- mappend (NonGreedy r m) (Branch 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 α 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)
projects / Lucu.git / blobdiff