Network/HTTP/Lucu/Dispatcher/Internal.hs

   1 {-# LANGUAGE
   2     ExistentialQuantification
   3   , FlexibleContexts
   4   , FlexibleInstances
   5   , GeneralizedNewtypeDeriving
   6   , OverlappingInstances
   7   , MultiParamTypeClasses
   8   , TemplateHaskell
   9   , UndecidableInstances
  10   , UnicodeSyntax
  11   #-}
  12 module Network.HTTP.Lucu.Dispatcher.Internal
  13     ( HostMapper(..)
  14     , HostMap
  15     , ResourceMapper(..)
  16     , ResourceMap
  17     , ResourceTree
  18     , ResourceNode
  19     , greedy
  20     , nonGreedy
  21
  22     , dispatch
  23     )
  24     where
  25 import Control.Applicative hiding (empty)
  26 import Control.Monad.Trans.Maybe
  27 import Control.Monad.Unicode
  28 import Data.Collections
  29 import qualified Data.Collections.Newtype.TH as C
  30 import qualified Data.Map as M
  31 import Data.Monoid
  32 import Data.Monoid.Unicode
  33 import Network.HTTP.Lucu.Resource.Internal
  34 import Network.HTTP.Lucu.Utils
  35 import Network.URI hiding (path)
  36 import Prelude hiding (filter, foldr, lookup, null)
  37 import Prelude.Unicode
  38
  39 -- |FIXME: docs
  40 --
  41 -- Minimal complete definition: 'findResourceMap'
  42 class HostMapper α where
  43     findResourceMap ∷ Host → α → MaybeT IO ResourceMap
  44     hostMap ∷ α → HostMap
  45     {-# INLINE hostMap #-}
  46     hostMap = HMap
  47
  48 -- |Container type for the 'HostMapper' type class.
  49 data HostMap = ∀α. HostMapper α ⇒ HMap α
  50
  51 -- |FIXME: docs
  52 --
  53 -- Minimal complete definition: 'findResource'
  54 class ResourceMapper α where
  55     findResource ∷ Path → α → MaybeT IO (Path, Resource)
  56     resourceMap  ∷ α → ResourceMap
  57     {-# INLINE resourceMap #-}
  58     resourceMap = RMap
  59
  60 -- |Container type for the 'ResourceMapper' type class.
  61 data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α
  62
  63 -- |'ResourceTree' is an opaque structure which is a map from resource
  64 -- path to 'Resource'.
  65 --
  66 -- @
  67 --   'fromList' [ ([]        , 'nonGreedy' '$' 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
  68 --            , ([\"unistd\"], 'nonGreedy' '$' 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
  69 --            ]
  70 -- @
  71 --
  72 -- Note that path segments are always represented as octet streams in
  73 -- this system. Lucu automatically decodes percent-encoded URIs but
  74 -- has no involvement in character encodings such as UTF-8, since RFC
  75 -- 2616 (HTTP/1.1) says nothing about character encodings to be used
  76 -- in \"http\" and \"https\" URI schemas.
  77 newtype ResourceTree = Tree (M.Map Path ResourceNode)
  78     deriving Monoid
  79
  80 -- |FIXME: doc
  81 data ResourceNode
  82     = Greedy    { nResource ∷ !Resource }
  83     | NonGreedy { nResource ∷ !Resource }
  84
  85 -- |Make a greedy resource node.
  86 --
  87 -- Say a client is trying to access \"\/aaa\/bbb\/ccc\' while there is
  88 -- no resource node at the path. If there are greedy resource nodes at
  89 -- \"\/aaa\/bbb\", \"\/aaa\" or \"/\" they will be chosen instead as a
  90 -- fallback. Greedy resource nodes are searched in depth-first order.
  91 greedy ∷ Resource → ResourceNode
  92 {-# INLINE CONLIKE greedy #-}
  93 greedy = Greedy
  94
  95 -- |FIXME: doc
  96 nonGreedy ∷ Resource → ResourceNode
  97 {-# INLINE CONLIKE nonGreedy #-}
  98 nonGreedy = NonGreedy
  99
 100
 101 -- Instances of HostMapper ----------------------------------------------------
 102 instance HostMapper HostMap where
 103     {-# INLINE findResourceMap #-}
 104     findResourceMap h (HMap α) = findResourceMap h α
 105     {-# INLINE hostMap #-}
 106     hostMap = id
 107
 108 -- |'ResourceMap's are also 'HostMapper's too, which matches to any
 109 -- hosts.
 110 instance HostMapper ResourceMap where
 111     {-# INLINE findResourceMap #-}
 112     findResourceMap = const return
 113
 114 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
 115 instance HostMapper α ⇒ Unfoldable HostMap α where
 116     {-# INLINE insert #-}
 117     insert a (HMap b) = hostMap c
 118         where
 119           c ∷ Host → MaybeT IO ResourceMap
 120           {-# INLINEABLE c #-}
 121           c h = findResourceMap h a <|> findResourceMap h b
 122     {-# INLINE empty #-}
 123     empty = (∅)
 124     {-# INLINE singleton #-}
 125     singleton = hostMap
 126
 127 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
 128 instance Monoid HostMap where
 129     {-# INLINE mempty #-}
 130     mempty = hostMap e
 131         where
 132           e ∷ Host → MaybeT IO ResourceMap
 133           {-# INLINE e #-}
 134           e = const (fail (⊥))
 135     {-# INLINE mappend #-}
 136     mappend = insert
 137
 138 -- |Any 'Map's from 'Host' to 'ResourceMap' are also 'HostMapper's.
 139 instance Map α Host ResourceMap ⇒ HostMapper α where
 140     {-# INLINE findResourceMap #-}
 141     findResourceMap = (maybe (fail (⊥)) return ∘) ∘ lookup
 142
 143 -- |An IO-based host mapper.
 144 instance HostMapper (Host → MaybeT IO ResourceMap) where
 145     {-# INLINE findResourceMap #-}
 146     findResourceMap = flip id
 147
 148 -- |A pure host mapper.
 149 instance HostMapper (Host → Maybe ResourceMap) where
 150     {-# INLINE findResourceMap #-}
 151     findResourceMap = (maybe (fail (⊥)) return ∘) ∘ flip id
 152
 153 -- Instances of ResourceMapper ------------------------------------------------
 154 instance ResourceMapper ResourceMap where
 155     {-# INLINE findResource #-}
 156     findResource s (RMap α) = findResource s α
 157     {-# INLINE resourceMap #-}
 158     resourceMap = id
 159
 160 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
 161 instance ResourceMapper α ⇒ Unfoldable ResourceMap α where
 162     {-# INLINE insert #-}
 163     insert a (RMap b) = resourceMap c
 164         where
 165           c ∷ Path → MaybeT IO (Path, Resource)
 166           {-# INLINEABLE c #-}
 167           c s = findResource s a <|> findResource s b
 168     {-# INLINE empty #-}
 169     empty = (∅)
 170     {-# INLINE singleton #-}
 171     singleton = resourceMap
 172
 173 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
 174 instance Monoid ResourceMap where
 175     {-# INLINE mempty #-}
 176     mempty = resourceMap e
 177         where
 178           e ∷ Path → MaybeT IO (Path, Resource)
 179           {-# INLINE e #-}
 180           e = const (fail (⊥))
 181     {-# INLINE mappend #-}
 182     mappend = insert
 183
 184 -- |Any 'Map's from 'Path' to @('Path', 'Resource')@ are also
 185 -- 'ResourceMapper's.
 186 instance Map α Path (Path, Resource) ⇒ ResourceMapper α where
 187     {-# INLINE findResource #-}
 188     findResource = (maybe (fail (⊥)) return ∘) ∘ lookup
 189
 190 -- |An IO-based resource mapper.
 191 instance ResourceMapper (Path → MaybeT IO (Path, Resource)) where
 192     {-# INLINE findResource #-}
 193     findResource = flip id
 194
 195 -- |A pure resource mapper.
 196 instance ResourceMapper (Path → Maybe (Path, Resource)) where
 197     {-# INLINE findResource #-}
 198     findResource = (maybe (fail (⊥)) return ∘) ∘ flip id
 199
 200 -- Instances of ResourceTree --------------------------------------------------
 201 instance Unfoldable ResourceTree (Path, ResourceNode) where
 202     {-# INLINEABLE insert #-}
 203     insert (p, n) (Tree m) = Tree $ insert (canonPath p, n) m
 204     {-# INLINE empty #-}
 205     empty = Tree (∅)
 206     {-# INLINE singleton #-}
 207     singleton = Tree ∘ singleton
 208
 209 canonPath ∷ (Collection c f, Foldable f e) ⇒ c → c
 210 {-# INLINEABLE canonPath #-}
 211 canonPath = filter ((¬) ∘ null)
 212
 213 C.derive [d| instance Foldable ResourceTree (Path, ResourceNode)
 214            |]
 215
 216 instance Collection ResourceTree (Path, ResourceNode) where
 217     {-# INLINE filter #-}
 218     filter f (Tree m) = Tree $ filter f m
 219
 220 -- |'findResource' performs the longest prefix match on the tree,
 221 -- finding the most specific one.
 222 instance ResourceMapper ResourceTree where
 223     {-# INLINEABLE findResource #-}
 224     findResource p (Tree m)
 225         = case lookup p m of
 226             Just n  → return (p, nResource n)
 227             Nothing → findGreedyResource p m
 228
 229 findGreedyResource ∷ (Monad m, Map α Path ResourceNode)
 230                    ⇒ Path
 231                    → α
 232                    → MaybeT m (Path, Resource)
 233 findGreedyResource p m
 234     = case back p of
 235         Nothing      → fail (⊥)
 236         Just (p', _) → case lookup p' m of
 237                           Just (Greedy r)
 238                               → return (p', r)
 239                           _   → findGreedyResource p' m
 240
 241 -- dispatch -------------------------------------------------------------------
 242 dispatch ∷ HostMapper α ⇒ URI → α → MaybeT IO (Path, Resource)
 243 dispatch uri
 244     = (findResource (uriPathSegments uri) =≪)
 245       ∘ findResourceMap (uriHost uri)