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

{- |
Module      : Web.Routes.Nested.Types
Copyright   : (c) 2015, 2016, 2017, 2018 Athan Clark

License     : BSD-style
Maintainer  : athan.clark@gmail.com
Stability   : experimental
Portability : GHC
-}

module Web.Routes.Nested.Types
  ( -- * Internal Structure
    Tries (..)
  , -- * Builder
    RouterT (..)
  , execRouterT
  , ActionT
  , action
  , -- * Book Keeping
    ExtrudeSoundly
  ) where

import           Web.Routes.Nested.Match             (UrlChunks)
import           Network.Wai.Middleware.Verbs        (VerbListenerT, execVerbListenerT, getVerbFromRequest)
import           Network.Wai.Middleware.ContentType  (FileExtListenerT, fileExtsToMiddleware)
import           Network.Wai.Trans                   (MiddlewareT)
import           Network.Wai                         (strictRequestBody)
import           Data.Trie.Pred.Base                 (RootedPredTrie (..))
import           Data.Trie.Pred.Interface.Types      (Extrude (..), CatMaybes)

import           Data.Monoid                         ((<>))
import qualified Data.Text                           as T
import           Data.Function.Poly                  (ArityTypeListIso)
import           Data.Singleton.Class                (Extractable)
import qualified Data.HashMap.Lazy                   as HM
import           Control.Monad.Trans                 (MonadTrans)
import           Control.Monad.IO.Class              (MonadIO)
import qualified Control.Monad.State                 as S
import           Control.Monad.Trans.Control.Aligned (MonadBaseControl (liftBaseWith))



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


instance Semigroup (Tries x s) where
  (Tries RootedPredTrie Text x
x1 RootedPredTrie Text x
x2 RootedPredTrie Text s
x3) <> :: Tries x s -> Tries x s -> Tries x s
<> (Tries RootedPredTrie Text x
y1 RootedPredTrie Text x
y2 RootedPredTrie Text s
y3) =
    forall x s.
RootedPredTrie Text x
-> RootedPredTrie Text x -> RootedPredTrie Text s -> Tries x s
Tries (RootedPredTrie Text x
x1 forall a. Semigroup a => a -> a -> a
<> RootedPredTrie Text x
y1) (RootedPredTrie Text x
x2 forall a. Semigroup a => a -> a -> a
<> RootedPredTrie Text x
y2) (RootedPredTrie Text s
x3 forall a. Semigroup a => a -> a -> a
<> RootedPredTrie Text s
y3)

instance Monoid (Tries x s) where
  mempty :: Tries x s
mempty = forall x s.
RootedPredTrie Text x
-> RootedPredTrie Text x -> RootedPredTrie Text s -> Tries x s
Tries forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty

-- | The (syntactic) monad for building a router with functions like
--   "Web.Routes.Nested.match".
--   it should have a shape of @RouterT (MiddlewareT m) (SecurityToken s) m a@
--   when used with "Web.Routes.Nested.route".
newtype RouterT x sec m a = RouterT
  { forall x sec (m :: * -> *) a.
RouterT x sec m a -> StateT (Tries x sec) m a
runRouterT :: S.StateT (Tries x sec) m a
  } deriving ( forall a b. a -> RouterT x sec m b -> RouterT x sec m a
forall a b. (a -> b) -> RouterT x sec m a -> RouterT x sec m b
forall x sec (m :: * -> *) a b.
Functor m =>
a -> RouterT x sec m b -> RouterT x sec m a
forall x sec (m :: * -> *) a b.
Functor m =>
(a -> b) -> RouterT x sec m a -> RouterT x sec m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> RouterT x sec m b -> RouterT x sec m a
$c<$ :: forall x sec (m :: * -> *) a b.
Functor m =>
a -> RouterT x sec m b -> RouterT x sec m a
fmap :: forall a b. (a -> b) -> RouterT x sec m a -> RouterT x sec m b
$cfmap :: forall x sec (m :: * -> *) a b.
Functor m =>
(a -> b) -> RouterT x sec m a -> RouterT x sec m b
Functor, forall a. a -> RouterT x sec m a
forall a b.
RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m a
forall a b.
RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m b
forall a b.
RouterT x sec m (a -> b) -> RouterT x sec m a -> RouterT x sec m b
forall a b c.
(a -> b -> c)
-> RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m c
forall {x} {sec} {m :: * -> *}.
Monad m =>
Functor (RouterT x sec m)
forall x sec (m :: * -> *) a. Monad m => a -> RouterT x sec m a
forall x sec (m :: * -> *) a b.
Monad m =>
RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m a
forall x sec (m :: * -> *) a b.
Monad m =>
RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m b
forall x sec (m :: * -> *) a b.
Monad m =>
RouterT x sec m (a -> b) -> RouterT x sec m a -> RouterT x sec m b
forall x sec (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b.
RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m a
$c<* :: forall x sec (m :: * -> *) a b.
Monad m =>
RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m a
*> :: forall a b.
RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m b
$c*> :: forall x sec (m :: * -> *) a b.
Monad m =>
RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m b
liftA2 :: forall a b c.
(a -> b -> c)
-> RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m c
$cliftA2 :: forall x sec (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m c
<*> :: forall a b.
RouterT x sec m (a -> b) -> RouterT x sec m a -> RouterT x sec m b
$c<*> :: forall x sec (m :: * -> *) a b.
Monad m =>
RouterT x sec m (a -> b) -> RouterT x sec m a -> RouterT x sec m b
pure :: forall a. a -> RouterT x sec m a
$cpure :: forall x sec (m :: * -> *) a. Monad m => a -> RouterT x sec m a
Applicative, forall a. a -> RouterT x sec m a
forall a b.
RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m b
forall a b.
RouterT x sec m a -> (a -> RouterT x sec m b) -> RouterT x sec m b
forall x sec (m :: * -> *).
Monad m =>
Applicative (RouterT x sec m)
forall x sec (m :: * -> *) a. Monad m => a -> RouterT x sec m a
forall x sec (m :: * -> *) a b.
Monad m =>
RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m b
forall x sec (m :: * -> *) a b.
Monad m =>
RouterT x sec m a -> (a -> RouterT x sec m b) -> RouterT x sec m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> RouterT x sec m a
$creturn :: forall x sec (m :: * -> *) a. Monad m => a -> RouterT x sec m a
>> :: forall a b.
RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m b
$c>> :: forall x sec (m :: * -> *) a b.
Monad m =>
RouterT x sec m a -> RouterT x sec m b -> RouterT x sec m b
>>= :: forall a b.
RouterT x sec m a -> (a -> RouterT x sec m b) -> RouterT x sec m b
$c>>= :: forall x sec (m :: * -> *) a b.
Monad m =>
RouterT x sec m a -> (a -> RouterT x sec m b) -> RouterT x sec m b
Monad, forall a. IO a -> RouterT x sec m a
forall {x} {sec} {m :: * -> *}.
MonadIO m =>
Monad (RouterT x sec m)
forall x sec (m :: * -> *) a.
MonadIO m =>
IO a -> RouterT x sec m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> RouterT x sec m a
$cliftIO :: forall x sec (m :: * -> *) a.
MonadIO m =>
IO a -> RouterT x sec m a
MonadIO, forall x sec (m :: * -> *) a. Monad m => m a -> RouterT x sec m a
forall (m :: * -> *) a. Monad m => m a -> RouterT x sec m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: forall (m :: * -> *) a. Monad m => m a -> RouterT x sec m a
$clift :: forall x sec (m :: * -> *) a. Monad m => m a -> RouterT x sec m a
MonadTrans
             , S.MonadState (Tries x sec))

-- | Run the monad, only getting the built state and throwing away @a@.
execRouterT :: Monad m => RouterT x sec m a -> m (Tries x sec)
execRouterT :: forall (m :: * -> *) x sec a.
Monad m =>
RouterT x sec m a -> m (Tries x sec)
execRouterT RouterT x sec m a
hs = forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
S.execStateT (forall x sec (m :: * -> *) a.
RouterT x sec m a -> StateT (Tries x sec) m a
runRouterT RouterT x sec m a
hs) forall a. Monoid a => a
mempty

{-# INLINEABLE execRouterT #-}

-- | Soundness constraint showing that a function's arity
--   can be represented as a type-level list.
type ExtrudeSoundly xs' xs c r =
  ( xs' ~ CatMaybes xs
  , ArityTypeListIso c xs' r
  , Extrude (UrlChunks xs)
      (RootedPredTrie T.Text c)
      (RootedPredTrie T.Text r)
  )


-- | The type of "content" builders; using the
--   <https://hackage.haskell.org/package/wai-middleware-verbs wai-middleware-verbs>
--   and <https://hackage.haskell.org/package/wai-middleware-content-type wai-middleware-content-type>
--   packages.
type ActionT urlbase m a = VerbListenerT (FileExtListenerT urlbase 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 :: MonadBaseControl IO m stM
       => Extractable stM
       => ActionT urlbase m ()
       -> MiddlewareT m
action :: forall (m :: * -> *) (stM :: * -> *) urlbase.
(MonadBaseControl IO m stM, Extractable stM) =>
ActionT urlbase m () -> MiddlewareT m
action ActionT urlbase m ()
xs ApplicationT m
app Request
req Response -> m ResponseReceived
respond = do
  VerbMap (FileExtListenerT urlbase m ())
vmap <- forall (m :: * -> *) r a.
Monad m =>
VerbListenerT r m a -> m (VerbMap r)
execVerbListenerT ActionT urlbase m ()
xs
  case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup (Request -> Verb
getVerbFromRequest Request
req) VerbMap (FileExtListenerT urlbase m ())
vmap of
    Maybe
  (Either
     (FileExtListenerT urlbase m ())
     (ByteString -> FileExtListenerT urlbase m ()))
Nothing -> ApplicationT m
app Request
req Response -> m ResponseReceived
respond
    Just Either
  (FileExtListenerT urlbase m ())
  (ByteString -> FileExtListenerT urlbase m ())
eR -> do
      FileExtListenerT urlbase m ()
c <- case Either
  (FileExtListenerT urlbase m ())
  (ByteString -> FileExtListenerT urlbase m ())
eR of
        Left FileExtListenerT urlbase m ()
c' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure FileExtListenerT urlbase m ()
c'
        Right ByteString -> FileExtListenerT urlbase m ()
f -> ByteString -> FileExtListenerT urlbase m ()
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (b :: * -> *) (m :: * -> *) (stM :: * -> *) a.
MonadBaseControl b m stM =>
(RunInBase m b stM -> b a) -> m a
liftBaseWith (\RunInBase m IO stM
_ -> Request -> IO ByteString
strictRequestBody Request
req)
      forall (m :: * -> *) (stM :: * -> *) urlbase a.
(MonadBaseControl IO m stM, Extractable stM) =>
FileExtListenerT urlbase m a -> MiddlewareT m
fileExtsToMiddleware FileExtListenerT urlbase m ()
c ApplicationT m
app Request
req Response -> m ResponseReceived
respond