{-# LANGUAGE GeneralizedNewtypeDeriving, CPP #-}
{-|
Description: Beam actions for Spock

This builds on "TsWeb.Types.Db"'s read-only/read-write discrimination by
providing query functions to perform read-only operations, and an 'execute'
function to run updates, inserts, and deletes (and also selects as
appropriate). All of these are performed as 'TsWeb.Types.TsActionCtxT' actions
so as to nicely integrate with Spock. Finally, because I'm not a fan of
exceptions, all of these functions trap Postgres errors and convert them into
sum-type results.

I'm not yet providing shortcuts for the beam-postgres specific functions. I'm
not actually sure that I need to (IIRC they all build Pg actions), but I will
be adding them if necessary.
-}

module TsWeb.Db
  ( module Database.Beam
  , TxOpt(..)
  , QueryResult(..)
  , ExecResult(..)
  , runSelectReturningList
  , runSelectReturningOne
  , query
  , queryMaybe
  , queryList
  , execute
  ) where

import qualified TsWeb.Types.Db as Db

import TsWeb.Action (getExtra)
import TsWeb.Types (TsActionCtxT)
import TsWeb.Types.Db (ReadOnlyPool, ReadWritePool)

import qualified Database.Beam as Beam

import Control.Exception (catch, try)
import Data.HVect (ListContains)
import Database.Beam hiding (runSelectReturningList, runSelectReturningOne)
import Database.Beam.Postgres (Pg, Postgres)
import Database.PostgreSQL.Simple (SqlError(..))
import Database.PostgreSQL.Simple.Errors
  ( ConstraintViolation(..)
  , constraintViolationE
  )

#if MIN_VERSION_beam_core(0, 8, 0)
type Sel a = SqlSelect Postgres a
#else
import Database.Beam.Postgres (PgSelectSyntax)
type Sel a = SqlSelect PgSelectSyntax a
#endif

class ReadOnlyM m where
  runSelectReturningOne ::
       FromBackendRow Postgres a => Sel a -> m (Maybe a)
  runSelectReturningList ::
       FromBackendRow Postgres a => Sel a -> m [a]

instance ReadOnlyM Pg where
  runSelectReturningOne = Beam.runSelectReturningOne
  runSelectReturningList = Beam.runSelectReturningList

newtype RoPg a = RoPg
  { _fromRoPg :: Pg a
  } deriving (Functor, Applicative, Monad)

instance ReadOnlyM RoPg where
  runSelectReturningOne = RoPg . Beam.runSelectReturningOne
  runSelectReturningList = RoPg . Beam.runSelectReturningList

-- | Transaction option: provide WithTx to wrap operations in BEGIN/COMMIT, or
-- NoTx to skip that.
data TxOpt
  = NoTx
  | WithTx
  deriving (Eq, Ord, Enum, Bounded, Show)

-- | Result of a select operation. This will either succeed with a QSimply, or
-- fail with a QError (probably then an error in the db connection or table
-- definitions).
data QueryResult a
  = QSimply a
  | QError SqlError
  deriving (Eq, Show)

-- | Run one or many Beam 'Database.Beam.runSelectReturningList' or
-- 'Database.Beam.runSelectReturningOne' operation(s) against a view's
-- ReadOnlyPool.
query ::
     ListContains n ReadOnlyPool xs
  => TxOpt
  -> RoPg a
  -> TsActionCtxT lts xs sessdata (QueryResult a)
query opt (RoPg act) = do
  ropool :: ReadOnlyPool <- getExtra
  liftIO $ catch (QSimply <$> Db.withConnection ropool io) (pure . QError)
  where
    io conn =
      case opt of
        NoTx -> Db.readOnly conn act
        WithTx -> Db.withTransaction conn $ Db.readOnly conn act

-- | Run a single Beam 'select', returning a single (Maybe) value
queryMaybe ::
     (ListContains n ReadOnlyPool xs, FromBackendRow Postgres a)
  => Sel a
  -> TsActionCtxT lts xs sessdata (QueryResult (Maybe a))
queryMaybe = query NoTx . runSelectReturningOne

-- | Run a single Beam 'select', returning a list of values
queryList ::
     (ListContains n ReadOnlyPool xs, FromBackendRow Postgres a)
  => Sel a
  -> TsActionCtxT lts xs sessdata (QueryResult [a])
queryList = query NoTx . runSelectReturningList

-- | The result of a select, insert, update, or delete operation. This adds a
-- constraint error to the 'QueryResult', making it nicer to filter out
-- conflicts when handling errors.
data ExecResult a
  = ESimply a
  | EConstraint SqlError
                ConstraintViolation
  | EError SqlError
  deriving (Eq, Show)

-- | Run any arbitrary 'Database.Beam.Pg' monad in the context of a view,
-- returning an 'ExecResult'
execute ::
     ListContains n ReadWritePool xs
  => TxOpt
  -> Pg a
  -> TsActionCtxT lts xs sessdata (ExecResult a)
execute opt act = do
  rwpool <- getExtra
  liftIO $ handleError rwpool
  where
    handleError rwpool =
      try (Db.withConnection rwpool io) >>= \case
        Right a -> return $ ESimply a
        Left err ->
          case constraintViolationE err of
            Nothing -> return $ EError err
            Just (s, c) -> return $ EConstraint s c
    io conn =
      case opt of
        NoTx -> Db.readWrite conn act
        WithTx -> Db.withTransaction conn $ Db.readWrite conn act