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 -- |Class of maps from 'Host' to 'ResourceMap' to provide name-based
  40 -- virtual hosts.
  41 --
  42 -- Note that Lucu currently does not implement neither RFC 2817
  43 -- connection upgrading (<http://tools.ietf.org/html/rfc2817>) nor RFC
  44 -- 3546 server name indication
  45 -- (<http://tools.ietf.org/html/rfc3546#section-3.1>) so you won't be
  46 -- able to host more than one SSL virtual host on the same port
  47 -- without using wildcard certificates
  48 -- (<http://tools.ietf.org/html/rfc2818#section-3.1>).
  49 --
  50 -- Minimal complete definition: 'findResourceMap'
  51 class HostMapper α where
  52     -- |Find a repository of resources for the given host name if any.
  53     findResourceMap ∷ Host → α → MaybeT IO ResourceMap
  54     -- |Wrap an instance of 'HostMapper' in a monoidal, homogeneous
  55     -- container.
  56     hostMap ∷ α → HostMap
  57     {-# INLINE hostMap #-}
  58     hostMap = HMap
  59
  60 -- |Container type for the 'HostMapper' type class.
  61 data HostMap = ∀α. HostMapper α ⇒ HMap α
  62
  63 -- |Class of maps from resource 'Path' to 'Resource'.
  64 --
  65 -- Minimal complete definition: 'findResource'
  66 class ResourceMapper α where
  67     -- |Find a resource handler for the given resource path, along
  68     -- with the path where the said handler was found. The found path
  69     -- is usually the same as the queried path, but there are
  70     -- situations where the found path is just a prefix of the queried
  71     -- path. See 'greedy'.
  72     findResource ∷ Path → α → MaybeT IO (Path, Resource)
  73     -- |Wrap an instance of 'ResourceMapper' in a monoidal,
  74     -- homogeneous container.
  75     resourceMap  ∷ α → ResourceMap
  76     {-# INLINE resourceMap #-}
  77     resourceMap = RMap
  78
  79 -- |Container type for the 'ResourceMapper' type class.
  80 data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α
  81
  82 -- |'ResourceTree' is an opaque structure which a map from resource
  83 -- 'Path' to 'ResourceNode'.
  84 --
  85 -- @
  86 --   'fromList' [ ([]        , 'nonGreedy' '$' 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
  87 --            , ([\"unistd\"], 'nonGreedy' '$' 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
  88 --            ]
  89 -- @
  90 --
  91 -- Note that path segments are always represented as octet streams in
  92 -- this system. Lucu automatically decodes percent-encoded URIs but
  93 -- has no involvement in character encodings such as UTF-8, since RFC
  94 -- 2616 (HTTP/1.1) says nothing about character encodings to be used
  95 -- in \"http\" and \"https\" URI schemas.
  96 newtype ResourceTree = Tree (M.Map Path ResourceNode)
  97     deriving Monoid
  98
  99 -- |A node of 'Resource' located somewhere in a 'ResourceTree'. Such
 100 -- nodes are either 'greedy' or 'nonGreedy'.
 101 data ResourceNode
 102     = Greedy    { nResource ∷ !Resource }
 103     | NonGreedy { nResource ∷ !Resource }
 104
 105 -- |Make a greedy resource node.
 106 --
 107 -- Say a client is trying to access \"\/aaa\/bbb\/ccc\' while there is
 108 -- no resource node at the path. If there are greedy resource nodes at
 109 -- \"\/aaa\/bbb\", \"\/aaa\" or \"/\" they will be chosen instead as a
 110 -- fallback. Greedy resource nodes are searched in depth-first
 111 -- order, just like CGI scripts.
 112 greedy ∷ Resource → ResourceNode
 113 {-# INLINE CONLIKE greedy #-}
 114 greedy = Greedy
 115
 116 -- |Make a normal, non-greedy resource node.
 117 nonGreedy ∷ Resource → ResourceNode
 118 {-# INLINE CONLIKE nonGreedy #-}
 119 nonGreedy = NonGreedy
 120
 121
 122 -- Instances of HostMapper ----------------------------------------------------
 123 instance HostMapper HostMap where
 124     {-# INLINE findResourceMap #-}
 125     findResourceMap h (HMap α) = findResourceMap h α
 126     {-# INLINE hostMap #-}
 127     hostMap = id
 128
 129 -- |'ResourceMap's are also 'HostMapper's too, which matches to any
 130 -- hosts.
 131 instance HostMapper ResourceMap where
 132     {-# INLINE findResourceMap #-}
 133     findResourceMap = const return
 134
 135 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
 136 instance HostMapper α ⇒ Unfoldable HostMap α where
 137     {-# INLINE insert #-}
 138     insert a (HMap b) = hostMap c
 139         where
 140           c ∷ Host → MaybeT IO ResourceMap
 141           {-# INLINEABLE c #-}
 142           c h = findResourceMap h a <|> findResourceMap h b
 143     {-# INLINE empty #-}
 144     empty = (∅)
 145     {-# INLINE singleton #-}
 146     singleton = hostMap
 147
 148 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
 149 instance Monoid HostMap where
 150     {-# INLINE mempty #-}
 151     mempty = hostMap e
 152         where
 153           e ∷ Host → MaybeT IO ResourceMap
 154           {-# INLINE e #-}
 155           e = const (fail (⊥))
 156     {-# INLINE mappend #-}
 157     mappend = insert
 158
 159 -- |Any 'Map's from 'Host' to 'ResourceMap' are also 'HostMapper's.
 160 instance Map α Host ResourceMap ⇒ HostMapper α where
 161     {-# INLINE findResourceMap #-}
 162     findResourceMap = (maybe (fail (⊥)) return ∘) ∘ lookup
 163
 164 -- |An IO-based host mapper.
 165 instance HostMapper (Host → MaybeT IO ResourceMap) where
 166     {-# INLINE findResourceMap #-}
 167     findResourceMap = flip id
 168
 169 -- |A pure host mapper.
 170 instance HostMapper (Host → Maybe ResourceMap) where
 171     {-# INLINE findResourceMap #-}
 172     findResourceMap = (maybe (fail (⊥)) return ∘) ∘ flip id
 173
 174 -- Instances of ResourceMapper ------------------------------------------------
 175 instance ResourceMapper ResourceMap where
 176     {-# INLINE findResource #-}
 177     findResource s (RMap α) = findResource s α
 178     {-# INLINE resourceMap #-}
 179     resourceMap = id
 180
 181 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
 182 instance ResourceMapper α ⇒ Unfoldable ResourceMap α where
 183     {-# INLINE insert #-}
 184     insert a (RMap b) = resourceMap c
 185         where
 186           c ∷ Path → MaybeT IO (Path, Resource)
 187           {-# INLINEABLE c #-}
 188           c s = findResource s a <|> findResource s b
 189     {-# INLINE empty #-}
 190     empty = (∅)
 191     {-# INLINE singleton #-}
 192     singleton = resourceMap
 193
 194 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
 195 instance Monoid ResourceMap where
 196     {-# INLINE mempty #-}
 197     mempty = resourceMap e
 198         where
 199           e ∷ Path → MaybeT IO (Path, Resource)
 200           {-# INLINE e #-}
 201           e = const (fail (⊥))
 202     {-# INLINE mappend #-}
 203     mappend = insert
 204
 205 -- |Any 'Map's from 'Path' to @('Path', 'Resource')@ are also
 206 -- 'ResourceMapper's.
 207 instance Map α Path (Path, Resource) ⇒ ResourceMapper α where
 208     {-# INLINE findResource #-}
 209     findResource = (maybe (fail (⊥)) return ∘) ∘ lookup
 210
 211 -- |An IO-based resource mapper.
 212 instance ResourceMapper (Path → MaybeT IO (Path, Resource)) where
 213     {-# INLINE findResource #-}
 214     findResource = flip id
 215
 216 -- |A pure resource mapper.
 217 instance ResourceMapper (Path → Maybe (Path, Resource)) where
 218     {-# INLINE findResource #-}
 219     findResource = (maybe (fail (⊥)) return ∘) ∘ flip id
 220
 221 -- Instances of ResourceTree --------------------------------------------------
 222 instance Unfoldable ResourceTree (Path, ResourceNode) where
 223     {-# INLINEABLE insert #-}
 224     insert (p, n) (Tree m) = Tree $ insert (canonPath p, n) m
 225     {-# INLINE empty #-}
 226     empty = Tree (∅)
 227     {-# INLINE singleton #-}
 228     singleton = Tree ∘ singleton
 229
 230 canonPath ∷ (Collection c f, Foldable f e) ⇒ c → c
 231 {-# INLINEABLE canonPath #-}
 232 canonPath = filter ((¬) ∘ null)
 233
 234 C.derive [d| instance Foldable ResourceTree (Path, ResourceNode)
 235            |]
 236
 237 instance Collection ResourceTree (Path, ResourceNode) where
 238     {-# INLINE filter #-}
 239     filter f (Tree m) = Tree $ filter f m
 240
 241 -- |'findResource' performs the longest prefix match on the tree,
 242 -- finding the most specific one.
 243 instance ResourceMapper ResourceTree where
 244     {-# INLINEABLE findResource #-}
 245     findResource p (Tree m)
 246         = case lookup p m of
 247             Just n  → return (p, nResource n)
 248             Nothing → findGreedyResource p m
 249
 250 findGreedyResource ∷ (Monad m, Map α Path ResourceNode)
 251                    ⇒ Path
 252                    → α
 253                    → MaybeT m (Path, Resource)
 254 findGreedyResource p m
 255     = case back p of
 256         Nothing      → fail (⊥)
 257         Just (p', _) → case lookup p' m of
 258                           Just (Greedy r)
 259                               → return (p', r)
 260                           _   → findGreedyResource p' m
 261
 262 -- dispatch -------------------------------------------------------------------
 263 dispatch ∷ HostMapper α ⇒ URI → α → MaybeT IO (Path, Resource)
 264 dispatch uri
 265     = (findResource (uriPathSegments uri) =≪)
 266       ∘ findResourceMap (uriHost uri)