, UnicodeSyntax
#-}
module Network.HTTP.Lucu.Dispatcher.Internal
- ( SchemeMapper(..)
- , SchemeMap
- , HostMapper(..)
+ ( HostMapper(..)
, HostMap
, ResourceMapper(..)
, ResourceMap
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
-- 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
{-# 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
{-# 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
--- |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 #-}
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 (⊥)
_ → 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)
#-}
-- |Utility functions used internally in this package.
module Network.HTTP.Lucu.Utils
- ( Scheme
- , Host
+ ( Host
, PathSegment
- , PathSegments
+ , Path
, splitBy
, quoteStr
, parseWWWFormURLEncoded
- , uriCIScheme
, uriHost
, uriPathSegments
, trim
where
import Control.Applicative hiding (empty)
import Control.Monad hiding (mapM)
-import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
+import Data.Ascii (Ascii, AsciiBuilder)
import qualified Data.Ascii as A
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import System.Directory
import System.Time (ClockTime(..))
--- |'Scheme' represents an URI scheme.
-type Scheme = CIAscii
-
-- |'Host' represents an IP address or a host name in an URI
-- authority.
type Host = CI Text
-- percent-decoded.
type PathSegment = ByteString
--- |'PathSegments' is a list of URI path segments.
-type PathSegments = [PathSegment]
+-- |'Path' is a list of URI path segments.
+type Path = [PathSegment]
-- |>>> splitBy (== ':') "ab:c:def"
-- ["ab", "c", "def"]
plusToSpace '+' = ' '
plusToSpace c = c
--- |>>> uriCIScheme "http://example.com/foo/bar"
--- "http"
-uriCIScheme ∷ URI → Scheme
-{-# INLINE uriCIScheme #-}
-uriCIScheme = A.toCIAscii ∘ A.unsafeFromString ∘ uriScheme
-
-- |>>> uriHost "http://example.com/foo/bar"
-- "example.com"
uriHost ∷ URI → Host
-- |>>> uriPathSegments "http://example.com/foo/bar"
-- ["foo", "bar"]
-uriPathSegments ∷ URI → PathSegments
+uriPathSegments ∷ URI → Path
uriPathSegments uri
= let reqPathStr = uriPath uri
reqPath = [ unEscapeString x
projects / Lucu.git / commitdiff