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     ( SchemeMapper(..)
  14     , SchemeMap
  15     , HostMapper(..)
  16     , HostMap
  17     , ResourceMapper(..)
  18     , ResourceMap
  19     , ResourceTree
  20     , ResourceNode
  21     , greedy
  22     , nonGreedy
  23
  24     , dispatch
  25     )
  26     where
  27 import Control.Applicative hiding (empty)
  28 import Control.Monad.Trans.Maybe
  29 import Control.Monad.Unicode
  30 import Data.Collections
  31 import qualified Data.Map as M
  32 import Data.Monoid
  33 import Data.Monoid.Unicode
  34 import Network.HTTP.Lucu.Resource.Internal
  35 import Network.HTTP.Lucu.Utils
  36 import Network.URI hiding (path)
  37 import Prelude hiding (filter, lookup, null)
  38 import Prelude.Unicode
  39
  40 -- |FIXME: docs
  41 --
  42 -- Minimal complete definition: 'findHostMap'
  43 class SchemeMapper α where
  44     findHostMap ∷ Scheme → α → MaybeT IO HostMap
  45     schemeMap   ∷ α → SchemeMap
  46     {-# INLINE schemeMap #-}
  47     schemeMap   = SMap
  48
  49 -- |Container type for the 'SchemeMapper' type class.
  50 data SchemeMap = ∀α. SchemeMapper α ⇒ SMap α
  51
  52 -- |FIXME: docs
  53 --
  54 -- Minimal complete definition: 'findResourceMap'
  55 class HostMapper α where
  56     findResourceMap ∷ Host → α → MaybeT IO ResourceMap
  57     hostMap ∷ α → HostMap
  58     {-# INLINE hostMap #-}
  59     hostMap = HMap
  60
  61 -- |Container type for the 'HostMapper' type class.
  62 data HostMap = ∀α. HostMapper α ⇒ HMap α
  63
  64 -- |FIXME: docs
  65 --
  66 -- Minimal complete definition: 'findResource'
  67 class ResourceMapper α where
  68     findResource ∷ PathSegments → α → MaybeT IO (PathSegments, Resource)
  69     resourceMap  ∷ α → ResourceMap
  70     {-# INLINE resourceMap #-}
  71     resourceMap = RMap
  72
  73 -- |Container type for the 'ResourceMapper' type class.
  74 data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α
  75
  76 -- |'ResourceTree' is an opaque structure which is a map from resource
  77 -- path to 'Resource'.
  78 --
  79 -- @
  80 --   'fromList' [ ([]        , 'nonGreedy' '$' 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
  81 --            , ([\"unistd\"], 'nonGreedy' '$' 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
  82 --            ]
  83 -- @
  84 --
  85 -- Note that path segments are always represented as octet streams in
  86 -- this system. Lucu automatically decodes percent-encoded URIs but
  87 -- has no involvement in character encodings such as UTF-8, since RFC
  88 -- 2616 (HTTP/1.1) says nothing about character encodings to be used
  89 -- in \"http\" and \"https\" URI schemas.
  90 newtype ResourceTree = Tree (M.Map PathSegments ResourceNode)
  91     deriving Monoid
  92
  93 -- |FIXME: doc
  94 data ResourceNode
  95     = Greedy    { nResource ∷ !Resource }
  96     | NonGreedy { nResource ∷ !Resource }
  97
  98 -- |FIXME: doc
  99 greedy ∷ Resource → ResourceNode
 100 {-# INLINE CONLIKE greedy #-}
 101 greedy = Greedy
 102
 103 -- |FIXME: doc
 104 nonGreedy ∷ Resource → ResourceNode
 105 {-# INLINE CONLIKE nonGreedy #-}
 106 nonGreedy = NonGreedy
 107
 108 -- Instances of SchemeMapper --------------------------------------------------
 109 instance SchemeMapper SchemeMap where
 110     {-# INLINE findHostMap #-}
 111     findHostMap s (SMap α) = findHostMap s α
 112     {-# INLINE schemeMap #-}
 113     schemeMap = id
 114
 115 -- |'HostMap's are also 'SchemeMapper's too, which matches to any
 116 -- schemes.
 117 instance SchemeMapper HostMap where
 118     {-# INLINE findHostMap #-}
 119     findHostMap = const return
 120
 121 -- |'ResourceMap's are also 'SchemeMapper's too, which matches to any
 122 -- schemes and hosts.
 123 instance SchemeMapper ResourceMap where
 124     {-# INLINE findHostMap #-}
 125     findHostMap _ r = return $ hostMap f
 126         where
 127           f ∷ Host → Maybe ResourceMap
 128           {-# INLINE f #-}
 129           f = const $ Just r
 130
 131 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
 132 instance SchemeMapper α ⇒ Unfoldable SchemeMap α where
 133     {-# INLINE insert #-}
 134     insert a (SMap b) = schemeMap c
 135         where
 136           c ∷ Scheme → MaybeT IO HostMap
 137           {-# INLINEABLE c #-}
 138           c s = findHostMap s a <|> findHostMap s b
 139     {-# INLINE empty #-}
 140     empty = (∅)
 141     {-# INLINE singleton #-}
 142     singleton = schemeMap
 143
 144 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
 145 instance Monoid SchemeMap where
 146     {-# INLINE mempty #-}
 147     mempty = schemeMap e
 148         where
 149           e ∷ Scheme → MaybeT IO HostMap
 150           {-# INLINE e #-}
 151           e = const (fail (⊥))
 152     {-# INLINE mappend #-}
 153     mappend = insert
 154
 155 -- |Any 'Map's from 'Scheme' to 'HostMap' are also 'SchemeMapper's.
 156 instance Map α Scheme HostMap ⇒ SchemeMapper α where
 157     {-# INLINE findHostMap #-}
 158     findHostMap = (maybe (fail (⊥)) return ∘) ∘ lookup
 159
 160 -- |An IO-based scheme mapper.
 161 instance SchemeMapper (Scheme → MaybeT IO HostMap) where
 162     {-# INLINE findHostMap #-}
 163     findHostMap = flip id
 164
 165 -- |A pure scheme mapper.
 166 instance SchemeMapper (Scheme → Maybe HostMap) where
 167     {-# INLINE findHostMap #-}
 168     findHostMap = (maybe (fail (⊥)) return ∘) ∘ flip id
 169
 170
 171 -- Instances of HostMapper ----------------------------------------------------
 172 instance HostMapper HostMap where
 173     {-# INLINE findResourceMap #-}
 174     findResourceMap h (HMap α) = findResourceMap h α
 175     {-# INLINE hostMap #-}
 176     hostMap = id
 177
 178 -- |'ResourceMap's are also 'HostMapper's too, which matches to any
 179 -- hosts.
 180 instance HostMapper ResourceMap where
 181     {-# INLINE findResourceMap #-}
 182     findResourceMap = const return
 183
 184 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
 185 instance HostMapper α ⇒ Unfoldable HostMap α where
 186     {-# INLINE insert #-}
 187     insert a (HMap b) = hostMap c
 188         where
 189           c ∷ Host → MaybeT IO ResourceMap
 190           {-# INLINEABLE c #-}
 191           c h = findResourceMap h a <|> findResourceMap h b
 192     {-# INLINE empty #-}
 193     empty = (∅)
 194     {-# INLINE singleton #-}
 195     singleton = hostMap
 196
 197 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
 198 instance Monoid HostMap where
 199     {-# INLINE mempty #-}
 200     mempty = hostMap e
 201         where
 202           e ∷ Host → MaybeT IO ResourceMap
 203           {-# INLINE e #-}
 204           e = const (fail (⊥))
 205     {-# INLINE mappend #-}
 206     mappend = insert
 207
 208 -- |Any 'Map's from 'Host' to 'ResourceMap' are also 'HostMapper's.
 209 instance Map α Host ResourceMap ⇒ HostMapper α where
 210     {-# INLINE findResourceMap #-}
 211     findResourceMap = (maybe (fail (⊥)) return ∘) ∘ lookup
 212
 213 -- |An IO-based host mapper.
 214 instance HostMapper (Host → MaybeT IO ResourceMap) where
 215     {-# INLINE findResourceMap #-}
 216     findResourceMap = flip id
 217
 218 -- |A pure host mapper.
 219 instance HostMapper (Host → Maybe ResourceMap) where
 220     {-# INLINE findResourceMap #-}
 221     findResourceMap = (maybe (fail (⊥)) return ∘) ∘ flip id
 222
 223 -- Instances of ResourceMapper ------------------------------------------------
 224 instance ResourceMapper ResourceMap where
 225     {-# INLINE findResource #-}
 226     findResource s (RMap α) = findResource s α
 227     {-# INLINE resourceMap #-}
 228     resourceMap = id
 229
 230 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
 231 instance ResourceMapper α ⇒ Unfoldable ResourceMap α where
 232     {-# INLINE insert #-}
 233     insert a (RMap b) = resourceMap c
 234         where
 235           c ∷ PathSegments → MaybeT IO (PathSegments, Resource)
 236           {-# INLINEABLE c #-}
 237           c s = findResource s a <|> findResource s b
 238     {-# INLINE empty #-}
 239     empty = (∅)
 240     {-# INLINE singleton #-}
 241     singleton = resourceMap
 242
 243 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
 244 instance Monoid ResourceMap where
 245     {-# INLINE mempty #-}
 246     mempty = resourceMap e
 247         where
 248           e ∷ PathSegments → MaybeT IO (PathSegments, Resource)
 249           {-# INLINE e #-}
 250           e = const (fail (⊥))
 251     {-# INLINE mappend #-}
 252     mappend = insert
 253
 254 -- |Any 'Map's from 'PathSegments' to @('PathSegments', 'Resource')@
 255 -- are also 'ResourceMapper's.
 256 instance Map α PathSegments (PathSegments, Resource) ⇒ ResourceMapper α where
 257     {-# INLINE findResource #-}
 258     findResource = (maybe (fail (⊥)) return ∘) ∘ lookup
 259
 260 -- |An IO-based resource mapper.
 261 instance ResourceMapper (PathSegments → MaybeT IO (PathSegments, Resource)) where
 262     {-# INLINE findResource #-}
 263     findResource = flip id
 264
 265 -- |A pure resource mapper.
 266 instance ResourceMapper (PathSegments → Maybe (PathSegments, Resource)) where
 267     {-# INLINE findResource #-}
 268     findResource = (maybe (fail (⊥)) return ∘) ∘ flip id
 269
 270 -- Instances of ResourceTree --------------------------------------------------
 271 instance Unfoldable ResourceTree (PathSegments, ResourceNode) where
 272     {-# INLINEABLE insert #-}
 273     insert (p, n) (Tree m) = Tree $ insert (canonPath p, n) m
 274     {-# INLINE empty #-}
 275     empty = Tree (∅)
 276     {-# INLINE singleton #-}
 277     singleton = Tree ∘ singleton
 278
 279 canonPath ∷ (Collection c f, Foldable f e) ⇒ c → c
 280 {-# INLINEABLE canonPath #-}
 281 canonPath = filter ((¬) ∘ null)
 282
 283 -- |'findResource' performs the longest prefix match on the tree,
 284 -- finding the most specific one.
 285 instance ResourceMapper ResourceTree where
 286     {-# INLINEABLE findResource #-}
 287     findResource p (Tree m)
 288         = case lookup p m of
 289             Just n  → return (p, nResource n)
 290             Nothing → findGreedyResource p m
 291
 292 findGreedyResource ∷ (Monad m, Map α PathSegments ResourceNode)
 293                    ⇒ PathSegments
 294                    → α
 295                    → MaybeT m (PathSegments, Resource)
 296 findGreedyResource p m
 297     = case back p of
 298         Nothing      → fail (⊥)
 299         Just (p', _) → case lookup p' m of
 300                           Just (Greedy r)
 301                               → return (p', r)
 302                           _   → findGreedyResource p' m
 303
 304 -- dispatch -------------------------------------------------------------------
 305 dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, Resource)
 306 dispatch uri
 307     = (findResource (uriPathSegments uri) =≪)
 308       ∘ (findResourceMap (uriHost uri) =≪)
 309       ∘ findHostMap (uriCIScheme uri)