Network/HTTP/Lucu/Dispatcher/Internal.hs

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