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 module Network.HTTP.Lucu.Dispatcher.Internal
  15     ( SchemeMapper(..)
  16     , SchemeMap
  17     , HostMapper(..)
  18     , HostMap
  19     , ResourceMapper(..)
  20     , ResourceMap
  21     , ResourceTree
  22
  23     , dispatch
  24     )
  25     where
  26 import Control.Applicative hiding (empty)
  27 import Control.Monad.Trans.Maybe
  28 import Control.Monad.Unicode
  29 import Data.Collections
  30 import qualified Data.Collections.Newtype.TH as C
  31 import Data.Monoid
  32 import Data.Monoid.Unicode
  33 import Network.HTTP.Lucu.Dispatcher.Node
  34 import Network.HTTP.Lucu.Resource.Internal
  35 import Network.HTTP.Lucu.Utils
  36 import Network.URI hiding (path)
  37 import Prelude hiding (lookup)
  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 = Root ResourceNode
  78     deriving (Monoid, Show)
  79
  80 -- Instances of SchemeMapper --------------------------------------------------
  81 instance SchemeMapper SchemeMap where
  82     {-# INLINE findHostMap #-}
  83     findHostMap s (SMap α) = findHostMap s α
  84     {-# INLINE schemeMap #-}
  85     schemeMap = id
  86
  87 -- |'HostMap's are also 'SchemeMapper's too, which matches to any
  88 -- schemes.
  89 instance SchemeMapper HostMap where
  90     {-# INLINE findHostMap #-}
  91     findHostMap = const return
  92
  93 -- |'ResourceMap's are also 'SchemeMapper's too, which matches to any
  94 -- schemes and hosts.
  95 instance SchemeMapper ResourceMap where
  96     {-# INLINE findHostMap #-}
  97     findHostMap _ r = return $ hostMap f
  98         where
  99           f ∷ Host → Maybe ResourceMap
 100           {-# INLINE f #-}
 101           f = const $ Just r
 102
 103 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
 104 instance SchemeMapper α ⇒ Unfoldable SchemeMap α where
 105     {-# INLINE insert #-}
 106     insert a (SMap b) = schemeMap c
 107         where
 108           c ∷ Scheme → MaybeT IO HostMap
 109           {-# INLINEABLE c #-}
 110           c s = findHostMap s a <|> findHostMap s b
 111     {-# INLINE empty #-}
 112     empty = (∅)
 113     {-# INLINE singleton #-}
 114     singleton = schemeMap
 115
 116 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
 117 instance Monoid SchemeMap where
 118     {-# INLINE mempty #-}
 119     mempty = schemeMap e
 120         where
 121           e ∷ Scheme → MaybeT IO HostMap
 122           {-# INLINE e #-}
 123           e = const (fail (⊥))
 124     {-# INLINE mappend #-}
 125     mappend = insert
 126
 127 instance Map α Scheme HostMap ⇒ SchemeMapper α where
 128     {-# INLINE findHostMap #-}
 129     findHostMap = (maybe (fail (⊥)) return ∘) ∘ lookup
 130
 131 -- |An IO-based scheme mapper.
 132 instance SchemeMapper (Scheme → MaybeT IO HostMap) where
 133     {-# INLINE findHostMap #-}
 134     findHostMap = flip id
 135
 136 -- |A pure scheme mapper.
 137 instance SchemeMapper (Scheme → Maybe HostMap) where
 138     {-# INLINE findHostMap #-}
 139     findHostMap = (maybe (fail (⊥)) return ∘) ∘ flip id
 140
 141
 142 -- Instances of HostMapper ----------------------------------------------------
 143 instance HostMapper HostMap where
 144     {-# INLINE findResourceMap #-}
 145     findResourceMap h (HMap α) = findResourceMap h α
 146     {-# INLINE hostMap #-}
 147     hostMap = id
 148
 149 -- |'ResourceMap's are also 'HostMapper's too, which matches to any
 150 -- hosts.
 151 instance HostMapper ResourceMap where
 152     {-# INLINE findResourceMap #-}
 153     findResourceMap = const return
 154
 155 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
 156 instance HostMapper α ⇒ Unfoldable HostMap α where
 157     {-# INLINE insert #-}
 158     insert a (HMap b) = hostMap c
 159         where
 160           c ∷ Host → MaybeT IO ResourceMap
 161           {-# INLINEABLE c #-}
 162           c h = findResourceMap h a <|> findResourceMap h b
 163     {-# INLINE empty #-}
 164     empty = (∅)
 165     {-# INLINE singleton #-}
 166     singleton = hostMap
 167
 168 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
 169 instance Monoid HostMap where
 170     {-# INLINE mempty #-}
 171     mempty = hostMap e
 172         where
 173           e ∷ Host → MaybeT IO ResourceMap
 174           {-# INLINE e #-}
 175           e = const (fail (⊥))
 176     {-# INLINE mappend #-}
 177     mappend = insert
 178
 179 instance Map α Host ResourceMap ⇒ HostMapper α where
 180     {-# INLINE findResourceMap #-}
 181     findResourceMap = (maybe (fail (⊥)) return ∘) ∘ lookup
 182
 183 -- |An IO-based host mapper.
 184 instance HostMapper (Host → MaybeT IO ResourceMap) where
 185     {-# INLINE findResourceMap #-}
 186     findResourceMap = flip id
 187
 188 -- |A pure host mapper.
 189 instance HostMapper (Host → Maybe ResourceMap) where
 190     {-# INLINE findResourceMap #-}
 191     findResourceMap = (maybe (fail (⊥)) return ∘) ∘ flip id
 192
 193 -- Instances of ResourceMapper ------------------------------------------------
 194 instance ResourceMapper ResourceMap where
 195     {-# INLINE findResource #-}
 196     findResource s (RMap α) = findResource s α
 197     {-# INLINE resourceMap #-}
 198     resourceMap = id
 199
 200 -- |@'insert' a b@ first tries @a@, and if it fails, tries @b@ next.
 201 instance ResourceMapper α ⇒ Unfoldable ResourceMap α where
 202     {-# INLINE insert #-}
 203     insert a (RMap b) = resourceMap c
 204         where
 205           c ∷ PathSegments → MaybeT IO (PathSegments, Resource)
 206           {-# INLINEABLE c #-}
 207           c s = findResource s a <|> findResource s b
 208     {-# INLINE empty #-}
 209     empty = (∅)
 210     {-# INLINE singleton #-}
 211     singleton = resourceMap
 212
 213 -- |@'mappend' a b@ first tries @a@, and if it fails, tries @b@ next.
 214 instance Monoid ResourceMap where
 215     {-# INLINE mempty #-}
 216     mempty = resourceMap e
 217         where
 218           e ∷ PathSegments → MaybeT IO (PathSegments, Resource)
 219           {-# INLINE e #-}
 220           e = const (fail (⊥))
 221     {-# INLINE mappend #-}
 222     mappend = insert
 223
 224 instance Map α PathSegments (PathSegments, Resource) ⇒ ResourceMapper α where
 225     {-# INLINE findResource #-}
 226     findResource = (maybe (fail (⊥)) return ∘) ∘ lookup
 227
 228 -- |An IO-based resource mapper.
 229 instance ResourceMapper (PathSegments → MaybeT IO (PathSegments, Resource)) where
 230     {-# INLINE findResource #-}
 231     findResource = flip id
 232
 233 -- |A pure resource mapper.
 234 instance ResourceMapper (PathSegments → Maybe (PathSegments, Resource)) where
 235     {-# INLINE findResource #-}
 236     findResource = (maybe (fail (⊥)) return ∘) ∘ flip id
 237
 238 -- Instances of ResourceTree --------------------------------------------------
 239 C.derive [d| instance Foldable ResourceTree (PathSegments, ResourceNode)
 240            |]
 241
 242 -- dispatch -------------------------------------------------------------------
 243 dispatch ∷ SchemeMapper α ⇒ URI → α → MaybeT IO (PathSegments, Resource)
 244 dispatch uri
 245     = (findResource (uriPathSegments uri) =≪)
 246       ∘ (findResourceMap (uriHost uri) =≪)
 247       ∘ findHostMap (uriCIScheme uri)
 248
 249 {-
 250 -- |'ResTree' is an opaque structure which is a map from resource path
 251 -- to 'Resource'.
 252 newtype ResTree = ResTree ResNode -- root だから Map ではない
 253 type ResSubtree = Map ByteString ResNode
 254 data ResNode    = ResNode (Maybe Resource) ResSubtree
 255
 256 -- |'mkResTree' converts a list of @(path, def)@ to a 'ResTree' e.g.
 257 --
 258 -- @
 259 --   mkResTree [ ([]        , 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/stdio.h\" ) -- \/
 260 --             , ([\"unistd\"], 'Network.HTTP.Lucu.StaticFile.staticFile' \"\/usr\/include\/unistd.h\") -- \/unistd
 261 --             ]
 262 -- @
 263 --
 264 -- Note that path components are always represented as octet streams
 265 -- in this system. Lucu automatically decodes percent-encoded URIs but
 266 -- has no involvement in character encodings such as UTF-8, since RFC
 267 -- 2616 (HTTP/1.1) says nothing about character encodings to be used
 268 -- in \"http\" and \"https\" URI schemas.
 269 mkResTree ∷ [ ([ByteString], Resource) ] → ResTree
 270 mkResTree = processRoot ∘ map (first canonicalisePath)
 271     where
 272       canonicalisePath ∷ [ByteString] → [ByteString]
 273       canonicalisePath = filter ((¬) ∘ BS.null)
 274
 275       processRoot ∷ [ ([ByteString], Resource) ] → ResTree
 276       processRoot list
 277           = let (roots, nonRoots) = partition (\(path, _) → null path) list
 278                 children = processNonRoot nonRoots
 279             in
 280               if null roots then
 281                   -- The root has no resources. Maybe there's one at
 282                   -- somewhere like "/foo".
 283                   ResTree (ResNode Nothing children)
 284               else
 285                   -- There is a root resource.
 286                   let (_, def) = last roots
 287                   in
 288                     ResTree (ResNode (Just def) children)
 289
 290       processNonRoot ∷ [ ([ByteString], Resource) ] → ResSubtree
 291       processNonRoot list
 292           = let subtree    = M.fromList [(name, node name)
 293                                              | name ← childNames]
 294                 childNames = [name | (name:_, _) ← list]
 295                 node name  = let defs = [def | (path, def) ← list, path ≡ [name]]
 296                              in
 297                                if null defs then
 298                                    -- No resources are defined
 299                                    -- here. Maybe there's one at
 300                                    -- somewhere below this node.
 301                                    ResNode Nothing children
 302                                else
 303                                    -- There is a resource here.
 304                                    ResNode (Just $ last defs) children
 305                 children   = processNonRoot [(path, def)
 306                                                  | (_:path, def) ← list]
 307             in
 308               subtree
 309 -}