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