Network/HTTP/Lucu/Dispatcher/Internal.hs

   1 {-# LANGUAGE
   2     DoAndIfThenElse
   3   , ExistentialQuantification
   4   , FlexibleInstances
   5   , OverlappingInstances
   6   , MultiParamTypeClasses
   7   , RecordWildCards
   8   , ScopedTypeVariables
   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
  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: 'findHostMap'
  41 class SchemeMapper α where
  42     findHostMap ∷ Scheme → α → MaybeT IO HostMap
  43     schemeMap   ∷ α → SchemeMap
  44     {-# INLINE schemeMap #-}
  45     schemeMap   = SMap
  46
  47 -- |Container type for the 'SchemeMapper' type class.
  48 data SchemeMap = ∀α. SchemeMapper α ⇒ SMap α
  49
  50 -- |FIXME: docs
  51 --
  52 -- Minimal complete definition: 'findResourceMap'
  53 class HostMapper α where
  54     findResourceMap ∷ Host → α → MaybeT IO ResourceMap
  55     hostMap ∷ α → HostMap
  56     {-# INLINE hostMap #-}
  57     hostMap = HMap
  58
  59 -- |Container type for the 'HostMapper' type class.
  60 data HostMap = ∀α. HostMapper α ⇒ HMap α
  61
  62 -- |FIXME: docs
  63 --
  64 -- Minimal complete definition: 'findResource'
  65 class ResourceMapper α where
  66     findResource ∷ PathSegments → α → MaybeT IO (PathSegments, Resource)
  67     resourceMap  ∷ α → ResourceMap
  68     {-# INLINE resourceMap #-}
  69     resourceMap = RMap
  70
  71 -- |Container type for the 'ResourceMapper' type class.
  72 data ResourceMap = ∀α. ResourceMapper α ⇒ RMap α
  73
  74 -- FIXME: doc
  75 newtype ResourceTree = Root ResourceNode
  76
  77 -- FIXME: docs
  78 data ResourceNode
  79     = Greedy    !Resource
  80     | NonGreedy !Resource !SubTree
  81     | Branch              !SubTree
  82
  83 type SubTree
  84     = M.Map PathSegment ResourceNode
  85
  86 -- Instances of SchemeMapper --------------------------------------------------
  87 instance SchemeMapper SchemeMap where
  88     {-# INLINE findHostMap #-}
  89     findHostMap s (SMap α) = findHostMap s α
  90     {-# INLINE schemeMap #-}
  91     schemeMap = id
  92
  93 -- |'HostMap's are also 'SchemeMapper's too, which matches to any
  94 -- schemes.
  95 instance SchemeMapper HostMap where
  96     {-# INLINE findHostMap #-}
  97     findHostMap = const return
  98
  99 -- |'ResourceMap's are also 'SchemeMapper's too, which matches to any
 100 -- schemes and hosts.
 101 instance SchemeMapper ResourceMap where
 102     {-# INLINE findHostMap #-}
 103     findHostMap _ r = return $ hostMap f
 104         where
 105           f ∷ Host → Maybe ResourceMap
 106           {-# INLINE f #-}
 107           f = const $ Just r
 108
 109 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
 110 instance SchemeMapper α ⇒ Unfoldable SchemeMap α where
 111     {-# INLINE insert #-}
 112     insert a (SMap b) = schemeMap c
 113         where
 114           c ∷ Scheme → MaybeT IO HostMap
 115           {-# INLINEABLE c #-}
 116           c s = findHostMap s a <|> findHostMap s b
 117     {-# INLINE empty #-}
 118     empty = (∅)
 119     {-# INLINE singleton #-}
 120     singleton = schemeMap
 121
 122 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
 123 instance Monoid SchemeMap where
 124     {-# INLINE mempty #-}
 125     mempty = schemeMap e
 126         where
 127           e ∷ Scheme → MaybeT IO HostMap
 128           {-# INLINE e #-}
 129           e = const (fail (⊥))
 130     {-# INLINE mappend #-}
 131     mappend = insert
 132
 133 instance Map α Scheme HostMap ⇒ SchemeMapper α where
 134     {-# INLINE findHostMap #-}
 135     findHostMap = (maybe (fail (⊥)) return ∘) ∘ lookup
 136
 137 -- |An IO-based scheme mapper.
 138 instance SchemeMapper (Scheme → MaybeT IO HostMap) where
 139     {-# INLINE findHostMap #-}
 140     findHostMap = flip id
 141
 142 -- |A pure scheme mapper.
 143 instance SchemeMapper (Scheme → Maybe HostMap) where
 144     {-# INLINE findHostMap #-}
 145     findHostMap = (maybe (fail (⊥)) return ∘) ∘ flip id
 146
 147
 148 -- Instances of HostMapper ----------------------------------------------------
 149 instance HostMapper HostMap where
 150     {-# INLINE findResourceMap #-}
 151     findResourceMap h (HMap α) = findResourceMap h α
 152     {-# INLINE hostMap #-}
 153     hostMap = id
 154
 155 -- |'ResourceMap's are also 'HostMapper's too, which matches to any
 156 -- hosts.
 157 instance HostMapper ResourceMap where
 158     {-# INLINE findResourceMap #-}
 159     findResourceMap = const return
 160
 161 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
 162 instance HostMapper α ⇒ Unfoldable HostMap α where
 163     {-# INLINE insert #-}
 164     insert a (HMap b) = hostMap c
 165         where
 166           c ∷ Host → MaybeT IO ResourceMap
 167           {-# INLINEABLE c #-}
 168           c h = findResourceMap h a <|> findResourceMap h b
 169     {-# INLINE empty #-}
 170     empty = (∅)
 171     {-# INLINE singleton #-}
 172     singleton = hostMap
 173
 174 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
 175 instance Monoid HostMap where
 176     {-# INLINE mempty #-}
 177     mempty = hostMap e
 178         where
 179           e ∷ Host → MaybeT IO ResourceMap
 180           {-# INLINE e #-}
 181           e = const (fail (⊥))
 182     {-# INLINE mappend #-}
 183     mappend = insert
 184
 185 instance Map α Host ResourceMap ⇒ HostMapper α where
 186     {-# INLINE findResourceMap #-}
 187     findResourceMap = (maybe (fail (⊥)) return ∘) ∘ lookup
 188
 189 -- |An IO-based host mapper.
 190 instance HostMapper (Host → MaybeT IO ResourceMap) where
 191     {-# INLINE findResourceMap #-}
 192     findResourceMap = flip id
 193
 194 -- |A pure host mapper.
 195 instance HostMapper (Host → Maybe ResourceMap) where
 196     {-# INLINE findResourceMap #-}
 197     findResourceMap = (maybe (fail (⊥)) return ∘) ∘ flip id
 198
 199 -- Instances of ResourceMapper ------------------------------------------------
 200 instance ResourceMapper ResourceMap where
 201     {-# INLINE findResource #-}
 202     findResource s (RMap α) = findResource s α
 203     {-# INLINE resourceMap #-}
 204     resourceMap = id
 205
 206 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
 207 instance ResourceMapper α ⇒ Unfoldable ResourceMap α where
 208     {-# INLINE insert #-}
 209     insert a (RMap b) = resourceMap c
 210         where
 211           c ∷ PathSegments → MaybeT IO (PathSegments, Resource)
 212           {-# INLINEABLE c #-}
 213           c s = findResource s a <|> findResource s b
 214     {-# INLINE empty #-}
 215     empty = (∅)
 216     {-# INLINE singleton #-}
 217     singleton = resourceMap
 218
 219 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
 220 instance Monoid ResourceMap where
 221     {-# INLINE mempty #-}
 222     mempty = resourceMap e
 223         where
 224           e ∷ PathSegments → MaybeT IO (PathSegments, Resource)
 225           {-# INLINE e #-}
 226           e = const (fail (⊥))
 227     {-# INLINE mappend #-}
 228     mappend = insert
 229
 230 instance Map α PathSegments (PathSegments, Resource) ⇒ ResourceMapper α where
 231     {-# INLINE findResource #-}
 232     findResource = (maybe (fail (⊥)) return ∘) ∘ lookup
 233
 234 -- |An IO-based resource mapper.
 235 instance ResourceMapper (PathSegments → MaybeT IO (PathSegments, Resource)) where
 236     {-# INLINE findResource #-}
 237     findResource = flip id
 238
 239 -- |A pure resource mapper.
 240 instance ResourceMapper (PathSegments → Maybe (PathSegments, Resource)) where
 241     {-# INLINE findResource #-}
 242     findResource = (maybe (fail (⊥)) return ∘) ∘ flip id
 243
 244 -- Instances of ResourceTree --------------------------------------------------
 245 instance Unfoldable ResourceTree (PathSegments, ResourceNode) where
 246     {-# INLINE insert #-}
 247     insert e (Root root) = Root $ insert e root
 248     {-# INLINE empty #-}
 249     empty = (∅)
 250
 251 instance Monoid ResourceTree where
 252     {-# INLINE mempty #-}
 253     mempty = Root (∅)
 254     {-# INLINE mappend #-}
 255     mappend (Root a) (Root b)
 256         = Root (a ⊕ b)
 257
 258 -- Instances of ResourceNode --------------------------------------------------
 259 instance Unfoldable ResourceNode (PathSegments, ResourceNode) where
 260     {-# INLINEABLE insert #-}
 261     insert (p, n) = insertNodeAt (canonPath p) n
 262     {-# INLINE empty #-}
 263     empty = Branch (∅)
 264
 265 canonPath ∷ (Collection c f, Foldable f e) ⇒ c → c
 266 {-# INLINEABLE canonPath #-}
 267 canonPath = filter ((¬) ∘ null)
 268
 269 insertNodeAt ∷ PathSegments → ResourceNode → ResourceNode → ResourceNode
 270 {-# INLINEABLE insertNodeAt #-}
 271 insertNodeAt p a b
 272     = case front p of
 273         Nothing         → a ⊕ b
 274         Just (x, xs)
 275             | null xs   → Branch (singleton (x, a)) ⊕ b
 276             | otherwise → insertNodeAt xs a (∅) ⊕ b
 277
 278 instance Monoid ResourceNode where
 279     {-# INLINE mempty #-}
 280     mempty = Branch (∅)
 281     {-# INLINEABLE mappend #-}
 282     mappend _               (Greedy    r  ) = Greedy    r
 283     mappend (Greedy    _  ) (NonGreedy r n) = NonGreedy r      n
 284     mappend (NonGreedy _ m) (NonGreedy r n) = NonGreedy r (m ⊕ n)
 285     mappend (Branch      m) (NonGreedy r n) = NonGreedy r (m ⊕ n)
 286     mappend (Greedy    r  ) (Branch      _) = Greedy    r
 287     mappend (NonGreedy r m) (Branch      n) = NonGreedy r (m ⊕ n)
 288     mappend (Branch      m) (Branch      n) = Branch      (m ⊕ n)
 289
 290 -- dispatch -------------------------------------------------------------------
 291 dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, Resource)
 292 dispatch uri
 293     = (findResource (uriPathSegments uri) =≪)
 294       ∘ (findResourceMap (uriHost uri) =≪)
 295       ∘ findHostMap (uriCIScheme uri)
 296
 297 {-
 298 -- |'ResTree' is an opaque structure which is a map from resource path
 299 -- to 'Resource'.
 300 newtype ResTree = ResTree ResNode -- root だから Map ではない
 301 type ResSubtree = Map ByteString ResNode
 302 data ResNode    = ResNode (Maybe Resource) ResSubtree
 303
 304 -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
 305 --
 306 -- @
 307 --   mkResTree [ ([]        , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
 308 --             , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
 309 --             ]
 310 -- @
 311 --
 312 -- Note that path components are always represented as octet streams
 313 -- in this system. Lucu automatically decodes percent-encoded URIs but
 314 -- has no involvement in character encodings such as UTF-8, since RFC
 315 -- 2616 (HTTP/1.1) says nothing about character encodings to be used
 316 -- in \"http\" and \"https\" URI schemas.
 317 mkResTree ∷ [ ([ByteString], Resource) ] → ResTree
 318 mkResTree = processRoot ∘ map (first canonicalisePath)
 319     where
 320       canonicalisePath ∷ [ByteString] → [ByteString]
 321       canonicalisePath = filter ((¬) ∘ BS.null)
 322
 323       processRoot ∷ [ ([ByteString], Resource) ] → ResTree
 324       processRoot list
 325           = let (roots, nonRoots) = partition (\(path, _) → null path) list
 326                 children = processNonRoot nonRoots
 327             in
 328               if null roots then
 329                   -- The root has no resources. Maybe there's one at
 330                   -- somewhere like "/foo".
 331                   ResTree (ResNode Nothing children)
 332               else
 333                   -- There is a root resource.
 334                   let (_, def) = last roots
 335                   in
 336                     ResTree (ResNode (Just def) children)
 337
 338       processNonRoot ∷ [ ([ByteString], Resource) ] → ResSubtree
 339       processNonRoot list
 340           = let subtree    = M.fromList [(name, node name)
 341                                              | name ← childNames]
 342                 childNames = [name | (name:_, _) ← list]
 343                 node name  = let defs = [def | (path, def) ← list, path ≡ [name]]
 344                              in
 345                                if null defs then
 346                                    -- No resources are defined
 347                                    -- here. Maybe there's one at
 348                                    -- somewhere below this node.
 349                                    ResNode Nothing children
 350                                else
 351                                    -- There is a resource here.
 352                                    ResNode (Just $ last defs) children
 353                 children   = processNonRoot [(path, def)
 354                                                  | (_:path, def) ← list]
 355             in
 356               subtree
 357 -}