+{-# LANGUAGE
+ DoAndIfThenElse
+ , ExistentialQuantification
+ , FlexibleInstances
+ , OverlappingInstances
+ , MultiParamTypeClasses
+ , RecordWildCards
+ , ScopedTypeVariables
+ , UndecidableInstances
+ , UnicodeSyntax
+ #-}
+module Network.HTTP.Lucu.Dispatcher.Internal
+ ( SchemeMapper(..)
+ , SchemeMap
+ , HostMapper(..)
+ , HostMap
+ , ResourceMapper(..)
+ , ResourceMap
+ , ResourceTree
+ , ResourceNode
+
+ , dispatch
+ )
+ where
+import Control.Applicative hiding (empty)
+import Control.Monad.Trans.Maybe
+import Control.Monad.Unicode
+import Data.Collections
+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.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'
+class HostMapper α where
+ findResourceMap ∷ Host → α → MaybeT IO ResourceMap
+ hostMap ∷ α → HostMap
+ {-# INLINE hostMap #-}
+ hostMap = HMap
+
+-- |Container type for the 'HostMapper' type class.
+data HostMap = ∀α. HostMapper α ⇒ HMap α
+
+-- |FIXME: docs
+--
+-- Minimal complete definition: 'findResource'
+class ResourceMapper α where
+ findResource ∷ PathSegments → α → MaybeT IO (PathSegments, Resource)
+ resourceMap ∷ α → ResourceMap
+ {-# INLINE resourceMap #-}
+ resourceMap = RMap
+
+-- |Container type for the 'ResourceMapper' type class.
+data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α
+
+-- FIXME: doc
+newtype ResourceTree = Root ResourceNode
+
+-- FIXME: docs
+data ResourceNode
+ = Greedy !Resource
+ | NonGreedy !Resource !ResourceTree
+ | Branch !ResourceTree
+
+-- 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
+
+-- |@a `'mappend'` 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
+
+
+-- Instances of HostMapper ----------------------------------------------------
+instance HostMapper HostMap where
+ {-# INLINE findResourceMap #-}
+ findResourceMap h (HMap α) = findResourceMap h α
+ {-# INLINE hostMap #-}
+ hostMap = id
+
+-- |'ResourceMap's are also 'HostMapper's too, which matches to any
+-- hosts.
+instance HostMapper ResourceMap where
+ {-# INLINE findResourceMap #-}
+ findResourceMap = const return
+
+-- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
+instance HostMapper α ⇒ Unfoldable HostMap α where
+ {-# INLINE insert #-}
+ insert a (HMap b) = hostMap c
+ where
+ c ∷ Host → MaybeT IO ResourceMap
+ {-# INLINEABLE c #-}
+ c h = findResourceMap h a <|> findResourceMap h b
+ {-# INLINE empty #-}
+ empty = (∅)
+ {-# INLINE singleton #-}
+ singleton = hostMap
+
+-- |@a `'mappend'` b@ first tries @a@, and if it fails, tries @b@ next.
+instance Monoid HostMap where
+ {-# INLINE mempty #-}
+ mempty = hostMap e
+ where
+ e ∷ Host → MaybeT IO ResourceMap
+ {-# INLINE e #-}
+ e = const (fail (⊥))
+ {-# INLINE mappend #-}
+ mappend = insert
+
+instance Map α Host ResourceMap ⇒ HostMapper α where
+ {-# INLINE findResourceMap #-}
+ findResourceMap = (maybe (fail (⊥)) return ∘) ∘ lookup
+
+-- |An IO-based host mapper.
+instance HostMapper (Host → MaybeT IO ResourceMap) where
+ {-# INLINE findResourceMap #-}
+ findResourceMap = flip id
+
+-- |A pure host mapper.
+instance HostMapper (Host → Maybe ResourceMap) where
+ {-# INLINE findResourceMap #-}
+ findResourceMap = (maybe (fail (⊥)) return ∘) ∘ flip id
+
+-- Instances of ResourceMapper ------------------------------------------------
+instance ResourceMapper ResourceMap where
+ {-# INLINE findResource #-}
+ findResource s (RMap α) = findResource s α
+ {-# INLINE resourceMap #-}
+ resourceMap = id
+
+-- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
+instance ResourceMapper α ⇒ Unfoldable ResourceMap α where
+ {-# INLINE insert #-}
+ insert a (RMap b) = resourceMap c
+ where
+ c ∷ PathSegments → MaybeT IO (PathSegments, Resource)
+ {-# INLINEABLE c #-}
+ c s = findResource s a <|> findResource s b
+ {-# INLINE empty #-}
+ empty = (∅)
+ {-# INLINE singleton #-}
+ singleton = resourceMap
+
+-- |@a `'mappend'` b@ first tries @a@, and if it fails, tries @b@ next.
+instance Monoid ResourceMap where
+ {-# INLINE mempty #-}
+ mempty = resourceMap e
+ where
+ e ∷ PathSegments → MaybeT IO (PathSegments, Resource)
+ {-# INLINE e #-}
+ e = const (fail (⊥))
+ {-# INLINE mappend #-}
+ mappend = insert
+
+instance Map α PathSegments (PathSegments, Resource) ⇒ ResourceMapper α where
+ {-# INLINE findResource #-}
+ findResource = (maybe (fail (⊥)) return ∘) ∘ lookup
+
+-- |An IO-based resource mapper.
+instance ResourceMapper (PathSegments → MaybeT IO (PathSegments, Resource)) where
+ {-# INLINE findResource #-}
+ findResource = flip id
+
+-- |A pure resource mapper.
+instance ResourceMapper (PathSegments → Maybe (PathSegments, Resource)) where
+ {-# INLINE findResource #-}
+ findResource = (maybe (fail (⊥)) return ∘) ∘ flip id
+
+-- Instances of ResourceTree --------------------------------------------------
+{-
+instance (Functor m, MonadIO m)
+ ⇒ Unfoldable (ResourceTree m) ([PathSegment], ResourceNode m) where
+ {-# INLINE insert #-}
+ insert e (Root root) = Root $ insert e root
+ {-# INLINE empty #-}
+ empty = (∅)
+
+instance (Functor m, MonadIO m) ⇒ Monoid (ResourceTree m) where
+ {-# INLINE mempty #-}
+ mempty = Root (∅)
+ {-# INLINE mappend #-}
+ mappend (Root a) (Root b)
+ = Root (a ⊕ b)
+-}
+
+-- Instances of ResourceNode --------------------------------------------------
+{-
+instance (Functor m, MonadIO m)
+ ⇒ Unfoldable (ResourceNode m) ([PathSegment], ResourceNode m) where
+ {-# INLINEABLE insert #-}
+ insert (p, a) b = insertNodeAt (canonPath p) a b
+ {-# INLINE empty #-}
+ empty = Branch (∅)
+
+canonPath ∷ (Collection c f, Foldable f e) ⇒ c → c
+{-# INLINEABLE canonPath #-}
+canonPath = filter ((¬) ∘ null)
+
+insertNodeAt ∷ (Functor m, MonadIO m)
+ ⇒ [PathSegment]
+ → ResourceNode m
+ → ResourceNode m
+ → ResourceNode m
+{-# INLINEABLE insertNodeAt #-}
+insertNodeAt [] a b = a ⊕ b
+insertNodeAt (x:[]) a b = Branch (singleton (x, a)) ⊕ b
+insertNodeAt (x:xs) a b = insertNodeAt xs a (∅) ⊕ b
+
+instance (Functor m, MonadIO m) ⇒ Monoid (ResourceNode m) 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)
+-}
+
+-- dispatch -------------------------------------------------------------------
+dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, 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
projects / Lucu.git / commitdiff