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