Types.hs

{-# LANGUAGE
    DeriveFunctor
  , ConstraintKinds
  , TypeFamilies
  , FlexibleContexts
  , GeneralizedNewtypeDeriving
  #-}

module Web.Routes.Nested.Types where

import           Web.Routes.Nested.Match
import           Network.Wai.Middleware.Verbs
import           Network.Wai.Middleware.ContentType
import           Network.Wai.Trans
import           Data.Trie.Pred.Mutable
import           Data.Trie.Pred.Mutable.Morph
import           Data.Trie.Pred.Base                (RootedPredTrie (..))
import           Data.Trie.Pred.Interface.Types     (Extrude (..), CatMaybes)

import Data.Typeable
import           Data.Monoid
import qualified Data.Text as T
import           Data.Function.Poly
import           Control.Monad.Trans
import qualified Control.Monad.State                as S

import Control.Monad.ST


-- | The internal data structure built during route declaration.
data Tries x s = Tries
  { trieContent  :: !(RootedPredTrie T.Text x)
  , trieCatchAll :: !(RootedPredTrie T.Text x)
  , trieSecurity :: !(RootedPredTrie T.Text s)
  }

trieContentMutable :: ( Typeable x
                      , Typeable s
                      ) => Tries x s'
                        -> ST s (RootedHashTableTrie s T.Text x)
trieContentMutable (Tries x _ _) = toMutableRooted x

trieCatchAllMutable :: ( Typeable x
                       , Typeable s
                       ) => Tries x s'
                         -> ST s (RootedHashTableTrie s T.Text x)
trieCatchAllMutable (Tries _ x _) = toMutableRooted x

trieSecurityMutable :: ( Typeable s'
                       , Typeable s
                       ) => Tries x s'
                         -> ST s (RootedHashTableTrie s T.Text s')
trieSecurityMutable (Tries _ _ x) = toMutableRooted x

instance Monoid (Tries x s) where
  mempty = Tries mempty mempty mempty
  mappend (Tries x1 x2 x3) (Tries y1 y2 y3) =
    ((Tries $! x1 <> y1)
            $! x2 <> y2)
            $! x3 <> y3

-- | The return type of a route building expression like `match` -
--   it should have a shape of @HandlerT (MiddlewareT m) (SecurityToken s) m a@
--   when used with `route`.
newtype HandlerT x sec m a = HandlerT
  { runHandlerT :: S.StateT (Tries x sec) m a
  } deriving ( Functor, Applicative, Monad, MonadIO, MonadTrans
             , S.MonadState (Tries x sec))

-- | Run the monad, only getting the built state and throwing away @a@.
execHandlerT :: Monad m => HandlerT x sec m a -> m (Tries x sec)
execHandlerT hs = S.execStateT (runHandlerT hs) mempty

{-# INLINEABLE execHandlerT #-}

-- | Deductive proof that prepending a list of types to a function as arity
--   can be deconstructed.
type ExtrudeSoundly cleanxs xs c r =
  ( cleanxs ~ CatMaybes xs
  , ArityTypeListIso c cleanxs r
  , Extrude (UrlChunks xs)
      (RootedPredTrie T.Text c)
      (RootedPredTrie T.Text r)
  )

-- | The type of content builders.
type ActionT m a = VerbListenerT (FileExtListenerT m a) m a

-- | Run the content builder into a middleware that responds when the content
--   is satisfiable (i.e. @Accept@ headers are O.K., etc.)
action :: Monad m => ActionT m () -> MiddlewareT m
action xs app req respond = do
  vmap <- execVerbListenerT (mapVerbs fileExtsToMiddleware xs)
  case lookupVerb (getVerb req) vmap of
    Nothing  -> app req respond
    Just mid -> mid app req respond