{-# LANGUAGE ExplicitNamespaces #-}

{-|
Description: Tagged routes for Spock

This module builds on Spock's "reroute" library by associating a
"GHC.OverloadedLabels" label to each route, which views can then use to
reverse routes in a type-safe manner. It also uses some rediculous function
chaining to almost create an indexed monad, but not quite because I can't
figure out quite how to make that work. A fairly function example follows:

First, we'll define a couple of views:

@
  index :: Has "users" lts (Path '[] 'Open) => TsActionCtxT lts xs sess a
  index = 'TsWeb.Actions.showPath' #users >>= 'Spock.text

  users :: Has "root" lts (Path '[] 'Open) => TsActionCtxT lts xs sess a
  users = do
    root <- 'TsWeb.Actions.showPath' #root
    text $ "GET users, root is, " \<\> root

  usersPost :: TsActionCtxT lts xs sess a
  usersPost = text "POST to users!"
@

Then, routing to those views looks like this:

@
  'runroute' ropool rwpool $
    'path' #root 'Web.Spock.root' ('getpost' index) .
    'path' #users "users" (do get users
                              post usersPost)
@

Notice the (.) after the @getpost index@. We're chaining functions together
and then passing that chained function to 'runroute' in order to generate an
actual Spock 'Web.Spock.Routing.RouteM'.
-}
module TsWeb.Routing
  ( RoutingM
  , runroute
  , path
  , dbwrite
  , getpost
  , get
  , post
  ) where

import TsWeb.Types (Context(..), TsActionCtxT, TsSpockCtxT)
import TsWeb.Types.Db (ReadOnlyPool, ReadWritePool)

import qualified SuperRecord as SR
import qualified Web.Spock as Spock
import qualified Web.Spock.Routing

import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (ReaderT(..), ask, mapReaderT)
import Data.HVect (HVect(..), HVectElim, HasRep)
import GHC.TypeLits (type (-), KnownNat, KnownSymbol)
import SuperRecord ((:=)(..), FldProxy, Rec, Record, Sort, (&), rnil)
import Web.Routing.Combinators (PathState(Open))
import Web.Spock (Path)
import Web.Spock.Routing (withPrehook)

-- | Reader monad to pass one 'Web.Spock.Path' to potentially multiple
-- different 'get'/'post'/etc calls.
type RoutingM as lts xs sess
   = ReaderT (Path as 'Open, ReadWritePool) (TsSpockCtxT lts xs sess)

-- | Convert a chain of 'path' calls into a 'Web.Spock.Routing.RouteM'
-- instance. This takes a 'TsWeb.Types.Db.ReadOnlyPool' and a
-- 'TsWeb.Types.Db.ReadWritePool' in order to operate the
-- 'TsWeb.Routing.Auth.auth' and 'dbwrite' calls.
runroute ::
     (Applicative f, MonadIO m, Web.Spock.Routing.RouteM t)
  => ReadOnlyPool  -- ^Read-only postgres connection pool
  -> ReadWritePool -- ^Read-write postgres connection pool
  -> ((ReadWritePool, Rec '[], f ()) -> ( ReadWritePool
                                        , Rec lts
                                        , t (Context lts '[ ReadOnlyPool]) m ()))
  -- ^Chain of functions built up using 'path' calls
  -> t ctx m ()
runroute ropool rwpool fn =
  let (_p, r, m) = fn (rwpool, rnil, pure ())
   in Spock.prehook (pure $ Context r (ropool :&: HNil)) m

-- | Describe a path for routing. This both builds up the
-- 'Web.Spock.Routing.RouteM' monad and associates the given label with the
-- URL so that views can look up the URL using 'TsWeb.Action.showPath' &c.
path ::
     ( KnownNat ((SR.RecSize (Sort (l := (Path as 'Open) : lts)) - SR.RecTyIdxH 0 l (Sort (l := (Path as 'Open) : lts))) - 1)
     , SR.RecCopy lts lts (Sort (l := (Path as 'Open) : lts))
     , KnownNat (SR.RecSize lts)
     , SR.KeyDoesNotExist l lts
     , KnownSymbol l
     )
  => FldProxy l                 -- ^Label for this URL path
  -> (Path as 'Open)            -- ^'Web.Spock.Path' for views
  -> RoutingM as lts0 xs sess a
  -- ^Routing monad built from 'get' \/ 'post' \/ &c
  -> (ReadWritePool, Rec lts, (TsSpockCtxT lts0 xs sess) a)
  -- ^Result of previous 'path' call, or initial data from 'runroute'
  -> ( ReadWritePool
     , Record (l := (Path as 'Open) : lts)
     , (TsSpockCtxT lts0 xs sess) a)
path l t m (pool, r, m0) = (pool, l := t & r, m0 >> runReaderT m (t, pool))

-- | Raise up a 'RoutingM' to have 'TsWeb.Types.Db.ReadWritePool' in its
-- extras record.
dbwrite ::
     RoutingM as lts (ReadWritePool ': xs) sess () -> RoutingM as lts xs sess ()
dbwrite action = do
  (_path, pool) <- ask
  xform pool action
  where
    xform ::
         nn -> RoutingM as lts (nn ': xs) sess () -> RoutingM as lts xs sess ()
    xform nn = mapReaderT (xform' nn)
    xform' ::
         nn -> TsSpockCtxT lts (nn ': xs) sess () -> TsSpockCtxT lts xs sess ()
    xform' nn = withPrehook (xform'' nn)
    xform'' :: nn -> TsActionCtxT lts xs sess (Context lts (nn ': xs))
    xform'' nn = do
      ctx <- Spock.getContext
      pure $ ctx {ctxExtras = nn :&: ctxExtras ctx}

-- | Run this view whether the client did a GET or a POST request
getpost ::
     Data.HVect.HasRep as
  => Data.HVect.HVectElim as (TsActionCtxT lts xs sess ())
  -> RoutingM as lts xs sess ()
getpost action = do
  (p, _) <- ask
  lift $ Spock.getpost p action

-- | Run this view only on GET requests
get ::
     Data.HVect.HasRep as
  => Data.HVect.HVectElim as (TsActionCtxT lts xs sess ())
  -> RoutingM as lts xs sess ()
get action = do
  (p, _) <- ask
  lift $ Spock.get p action

-- | Run this view only on POST requests
post ::
     Data.HVect.HasRep as
  => Data.HVect.HVectElim as (TsActionCtxT lts xs sess ())
  -> RoutingM as lts xs sess ()
post action = do
  (p, _) <- ask
  lift $ Spock.post p action