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