Dispatching.hs

module Network.Salvia.Handler.Dispatching (
    Dispatcher
  , ListDispatcher
  , hDispatch
  , hListDispatch
  ) where

import Data.Record.Label
import Network.Salvia.Httpd

{- |
The dispatcher type takes one value to dispatch on and two handlers. The first
handler will be used when the predicate on the dispatch value returned `True`,
the second (default) handler will be used when the predicate returs
`False`.
-}

type Dispatcher a b = a -> Handler b -> Handler b -> Handler b

{- |
A list dispatcher takes a mapping from dispatch values and handlers and one
default handler.
-}

type ListDispatcher a b = [(a, Handler b)] -> Handler b -> Handler b

{- |
Dispatch on an arbitrary part of the context using an arbitrary predicate. When
the predicate returns true on the value selected with the `Label` the first
handler will be invoked, otherwise the second handler will be used.
-}

hDispatch :: (Show a, Show c) => Label Context c -> (a -> c -> Bool) -> Dispatcher a b
hDispatch f match a handler _default = do
  ctx <- getM f
  if a `match` ctx
    then handler
    else _default

{- |
Turns a dispatcher function into a list dispatcher. This enables handler
routing based on arbitrary values from the context. When non of the predicates
in the `ListDispatcher` type hold the default handler will be invoked.
-}

hListDispatch :: Dispatcher a b -> ListDispatcher a b
hListDispatch disp = flip $ foldr $ uncurry disp