{-# LANGUAGE QuasiQuotes #-}

module Hasura.Server.Migrate.Internal
  ( getCatalogVersion,
    from3To4,
    setCatalogVersion,
  )
where

import Data.Aeson qualified as J
import Data.Text qualified as T
import Data.Time.Clock (UTCTime)
import Database.PG.Query qualified as PG
import Hasura.Backends.Postgres.Connection
import Hasura.Base.Error
import Hasura.Prelude
import Hasura.RQL.Types.Backend (Backend)
import Hasura.RQL.Types.BackendType
import Hasura.RQL.Types.Common (InputWebhook, TriggerOnReplication (..))
import Hasura.RQL.Types.EventTrigger
import Hasura.Server.Migrate.Version

-- | The old 0.8 catalog version is non-integral, so the version has always been
-- stored as a string.
getCatalogVersion :: PG.TxE QErr MetadataCatalogVersion
getCatalogVersion :: TxE QErr MetadataCatalogVersion
getCatalogVersion = do
  Text
versionText <-
    Identity Text -> Text
forall a. Identity a -> a
runIdentity
      (Identity Text -> Text)
-> (SingleRow (Identity Text) -> Identity Text)
-> SingleRow (Identity Text)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingleRow (Identity Text) -> Identity Text
forall a. SingleRow a -> a
PG.getRow
      (SingleRow (Identity Text) -> Text)
-> TxET QErr IO (SingleRow (Identity Text)) -> TxET QErr IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PGTxErr -> QErr)
-> Query -> () -> Bool -> TxET QErr IO (SingleRow (Identity Text))
forall (m :: * -> *) a r e.
(MonadIO m, FromRes a, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m a
PG.withQE
        PGTxErr -> QErr
defaultTxErrorHandler
        [PG.sql| SELECT version FROM hdb_catalog.hdb_version |]
        ()
        Bool
False
  Either String MetadataCatalogVersion
-> (String -> TxE QErr MetadataCatalogVersion)
-> TxE QErr MetadataCatalogVersion
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
onLeft (String -> Either String MetadataCatalogVersion
forall a. Read a => String -> Either String a
readEither (String -> Either String MetadataCatalogVersion)
-> String -> Either String MetadataCatalogVersion
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
versionText)
    ((String -> TxE QErr MetadataCatalogVersion)
 -> TxE QErr MetadataCatalogVersion)
-> (String -> TxE QErr MetadataCatalogVersion)
-> TxE QErr MetadataCatalogVersion
forall a b. (a -> b) -> a -> b
$ \String
err -> Text -> TxE QErr MetadataCatalogVersion
forall (m :: * -> *) a. QErrM m => Text -> m a
throw500 (Text -> TxE QErr MetadataCatalogVersion)
-> Text -> TxE QErr MetadataCatalogVersion
forall a b. (a -> b) -> a -> b
$ Text
"Unexpected: couldn't convert read catalog version " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
versionText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", err:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. Show a => a -> Text
tshow String
err

from3To4 :: forall m. (Backend ('Postgres 'Vanilla), MonadTx m) => m ()
from3To4 :: forall (m :: * -> *).
(Backend ('Postgres 'Vanilla), MonadTx m) =>
m ()
from3To4 = TxE QErr () -> m ()
forall a. TxE QErr a -> m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx do
  (PGTxErr -> QErr) -> Query -> () -> Bool -> TxE QErr ()
forall (m :: * -> *) r e.
(MonadIO m, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m ()
PG.unitQE
    PGTxErr -> QErr
defaultTxErrorHandler
    [PG.sql|
      ALTER TABLE hdb_catalog.event_triggers
      ADD COLUMN configuration JSON |]
    ()
    Bool
False
  [EventTriggerConf ('Postgres 'Vanilla)]
eventTriggers <-
    ((TriggerName, ViaJSON (TriggerOpsDef ('Postgres 'Vanilla)),
  InputWebhook, Int, Int, ViaJSON (Maybe [HeaderConf]))
 -> EventTriggerConf ('Postgres 'Vanilla))
-> [(TriggerName, ViaJSON (TriggerOpsDef ('Postgres 'Vanilla)),
     InputWebhook, Int, Int, ViaJSON (Maybe [HeaderConf]))]
-> [EventTriggerConf ('Postgres 'Vanilla)]
forall a b. (a -> b) -> [a] -> [b]
map (TriggerName, ViaJSON (TriggerOpsDef ('Postgres 'Vanilla)),
 InputWebhook, Int, Int, ViaJSON (Maybe [HeaderConf]))
-> EventTriggerConf ('Postgres 'Vanilla)
uncurryEventTrigger
      ([(TriggerName, ViaJSON (TriggerOpsDef ('Postgres 'Vanilla)),
   InputWebhook, Int, Int, ViaJSON (Maybe [HeaderConf]))]
 -> [EventTriggerConf ('Postgres 'Vanilla)])
-> TxET
     QErr
     IO
     [(TriggerName, ViaJSON (TriggerOpsDef ('Postgres 'Vanilla)),
       InputWebhook, Int, Int, ViaJSON (Maybe [HeaderConf]))]
-> TxET QErr IO [EventTriggerConf ('Postgres 'Vanilla)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PGTxErr -> QErr)
-> Query
-> ()
-> Bool
-> TxET
     QErr
     IO
     [(TriggerName, ViaJSON (TriggerOpsDef ('Postgres 'Vanilla)),
       InputWebhook, Int, Int, ViaJSON (Maybe [HeaderConf]))]
forall (m :: * -> *) a r e.
(MonadIO m, FromRes a, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m a
PG.withQE
        PGTxErr -> QErr
defaultTxErrorHandler
        [PG.sql|
      SELECT e.name, e.definition::json, e.webhook, e.num_retries, e.retry_interval, e.headers::json
      FROM hdb_catalog.event_triggers e |]
        ()
        Bool
False
  [EventTriggerConf ('Postgres 'Vanilla)]
-> (EventTriggerConf ('Postgres 'Vanilla) -> TxE QErr ())
-> TxE QErr ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [EventTriggerConf ('Postgres 'Vanilla)]
eventTriggers EventTriggerConf ('Postgres 'Vanilla) -> TxE QErr ()
forall {m :: * -> *} {b :: BackendType}.
(MonadIO m, Backend b) =>
EventTriggerConf b -> TxET QErr m ()
updateEventTrigger3To4
  (PGTxErr -> QErr) -> Query -> () -> Bool -> TxE QErr ()
forall (m :: * -> *) r e.
(MonadIO m, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m ()
PG.unitQE
    PGTxErr -> QErr
defaultTxErrorHandler
    [PG.sql|
      ALTER TABLE hdb_catalog.event_triggers
      DROP COLUMN definition,
      DROP COLUMN query,
      DROP COLUMN webhook,
      DROP COLUMN num_retries,
      DROP COLUMN retry_interval,
      DROP COLUMN headers,
      DROP COLUMN metadataTransform|]
    ()
    Bool
False
  where
    uncurryEventTrigger ::
      ( TriggerName,
        PG.ViaJSON (TriggerOpsDef ('Postgres 'Vanilla)),
        InputWebhook,
        Int,
        Int,
        PG.ViaJSON (Maybe [HeaderConf])
      ) ->
      EventTriggerConf ('Postgres 'Vanilla)
    uncurryEventTrigger :: (TriggerName, ViaJSON (TriggerOpsDef ('Postgres 'Vanilla)),
 InputWebhook, Int, Int, ViaJSON (Maybe [HeaderConf]))
-> EventTriggerConf ('Postgres 'Vanilla)
uncurryEventTrigger (TriggerName
trn, PG.ViaJSON TriggerOpsDef ('Postgres 'Vanilla)
tDef, InputWebhook
w, Int
nr, Int
rint, PG.ViaJSON Maybe [HeaderConf]
headers) =
      TriggerName
-> TriggerOpsDef ('Postgres 'Vanilla)
-> Maybe InputWebhook
-> Maybe Text
-> RetryConf
-> Maybe [HeaderConf]
-> Maybe RequestTransform
-> Maybe MetadataResponseTransform
-> Maybe AutoTriggerLogCleanupConfig
-> TriggerOnReplication
-> EventTriggerConf ('Postgres 'Vanilla)
forall (b :: BackendType).
TriggerName
-> TriggerOpsDef b
-> Maybe InputWebhook
-> Maybe Text
-> RetryConf
-> Maybe [HeaderConf]
-> Maybe RequestTransform
-> Maybe MetadataResponseTransform
-> Maybe AutoTriggerLogCleanupConfig
-> TriggerOnReplication
-> EventTriggerConf b
EventTriggerConf TriggerName
trn TriggerOpsDef ('Postgres 'Vanilla)
tDef (InputWebhook -> Maybe InputWebhook
forall a. a -> Maybe a
Just InputWebhook
w) Maybe Text
forall a. Maybe a
Nothing (Int -> Int -> Maybe Int -> RetryConf
RetryConf Int
nr Int
rint Maybe Int
forall a. Maybe a
Nothing) Maybe [HeaderConf]
headers Maybe RequestTransform
forall a. Maybe a
Nothing Maybe MetadataResponseTransform
forall a. Maybe a
Nothing Maybe AutoTriggerLogCleanupConfig
forall a. Maybe a
Nothing TriggerOnReplication
TORDisableTrigger
    updateEventTrigger3To4 :: EventTriggerConf b -> TxET QErr m ()
updateEventTrigger3To4 etc :: EventTriggerConf b
etc@(EventTriggerConf TriggerName
name TriggerOpsDef b
_ Maybe InputWebhook
_ Maybe Text
_ RetryConf
_ Maybe [HeaderConf]
_ Maybe RequestTransform
_ Maybe MetadataResponseTransform
_ Maybe AutoTriggerLogCleanupConfig
_ TriggerOnReplication
_) =
      (PGTxErr -> QErr)
-> Query -> (ViaJSON Value, TriggerName) -> Bool -> TxET QErr m ()
forall (m :: * -> *) r e.
(MonadIO m, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m ()
PG.unitQE
        PGTxErr -> QErr
defaultTxErrorHandler
        [PG.sql|
                                            UPDATE hdb_catalog.event_triggers
                                            SET
                                            configuration = $1
                                            WHERE name = $2
                                            |]
        (Value -> ViaJSON Value
forall a. a -> ViaJSON a
PG.ViaJSON (Value -> ViaJSON Value) -> Value -> ViaJSON Value
forall a b. (a -> b) -> a -> b
$ EventTriggerConf b -> Value
forall a. ToJSON a => a -> Value
J.toJSON EventTriggerConf b
etc, TriggerName
name)
        Bool
True

setCatalogVersion :: (MonadTx m) => Text -> UTCTime -> m ()
setCatalogVersion :: forall (m :: * -> *). MonadTx m => Text -> UTCTime -> m ()
setCatalogVersion Text
ver UTCTime
time =
  TxE QErr () -> m ()
forall a. TxE QErr a -> m a
forall (m :: * -> *) a. MonadTx m => TxE QErr a -> m a
liftTx
    (TxE QErr () -> m ()) -> TxE QErr () -> m ()
forall a b. (a -> b) -> a -> b
$ (PGTxErr -> QErr)
-> Query -> (Text, UTCTime) -> Bool -> TxE QErr ()
forall (m :: * -> *) r e.
(MonadIO m, ToPrepArgs r) =>
(PGTxErr -> e) -> Query -> r -> Bool -> TxET e m ()
PG.unitQE
      PGTxErr -> QErr
defaultTxErrorHandler
      [PG.sql|
    INSERT INTO hdb_catalog.hdb_version (version, upgraded_on) VALUES ($1, $2)
    ON CONFLICT ((version IS NOT NULL))
    DO UPDATE SET version = $1, upgraded_on = $2
  |]
      (Text
ver, UTCTime
time)
      Bool
False