{-# LANGUAGE QuasiQuotes #-}

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

import Data.Aeson qualified as A
import Data.Text qualified as T
import Data.Time.Clock (UTCTime)
import Database.PG.Query qualified as Q
import Hasura.Backends.Postgres.Connection
import Hasura.Base.Error
import Hasura.Prelude
import Hasura.RQL.Types.Backend (Backend)
import Hasura.RQL.Types.Common (InputWebhook)
import Hasura.RQL.Types.EventTrigger
import Hasura.SQL.Backend
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 :: Q.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
Q.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
Q.withQE
        PGTxErr -> QErr
defaultTxErrorHandler
        [Q.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 :: m ()
from3To4 = TxE QErr () -> m ()
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) -> TxET PGTxErr IO () -> TxE QErr ()
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> TxET e m a -> TxET e' m a
Q.catchE PGTxErr -> QErr
defaultTxErrorHandler (TxET PGTxErr IO () -> TxE QErr ())
-> TxET PGTxErr IO () -> TxE QErr ()
forall a b. (a -> b) -> a -> b
$ do
    Query -> () -> Bool -> TxET PGTxErr IO ()
forall (m :: * -> *) r.
(MonadIO m, ToPrepArgs r) =>
Query -> r -> Bool -> TxT m ()
Q.unitQ
      [Q.sql|
      ALTER TABLE hdb_catalog.event_triggers
      ADD COLUMN configuration JSON |]
      ()
      Bool
False
    [EventTriggerConf ('Postgres 'Vanilla)]
eventTriggers <-
      ((TriggerName, AltJ (TriggerOpsDef ('Postgres 'Vanilla)),
  InputWebhook, Int, Int, AltJ (Maybe [HeaderConf]))
 -> EventTriggerConf ('Postgres 'Vanilla))
-> [(TriggerName, AltJ (TriggerOpsDef ('Postgres 'Vanilla)),
     InputWebhook, Int, Int, AltJ (Maybe [HeaderConf]))]
-> [EventTriggerConf ('Postgres 'Vanilla)]
forall a b. (a -> b) -> [a] -> [b]
map (TriggerName, AltJ (TriggerOpsDef ('Postgres 'Vanilla)),
 InputWebhook, Int, Int, AltJ (Maybe [HeaderConf]))
-> EventTriggerConf ('Postgres 'Vanilla)
uncurryEventTrigger
        ([(TriggerName, AltJ (TriggerOpsDef ('Postgres 'Vanilla)),
   InputWebhook, Int, Int, AltJ (Maybe [HeaderConf]))]
 -> [EventTriggerConf ('Postgres 'Vanilla)])
-> TxET
     PGTxErr
     IO
     [(TriggerName, AltJ (TriggerOpsDef ('Postgres 'Vanilla)),
       InputWebhook, Int, Int, AltJ (Maybe [HeaderConf]))]
-> TxET PGTxErr IO [EventTriggerConf ('Postgres 'Vanilla)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Query
-> ()
-> Bool
-> TxET
     PGTxErr
     IO
     [(TriggerName, AltJ (TriggerOpsDef ('Postgres 'Vanilla)),
       InputWebhook, Int, Int, AltJ (Maybe [HeaderConf]))]
forall (m :: * -> *) a r.
(MonadIO m, FromRow a, ToPrepArgs r) =>
Query -> r -> Bool -> TxT m [a]
Q.listQ
          [Q.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) -> TxET PGTxErr IO ())
-> TxET PGTxErr IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [EventTriggerConf ('Postgres 'Vanilla)]
eventTriggers EventTriggerConf ('Postgres 'Vanilla) -> TxET PGTxErr IO ()
forall (m :: * -> *) (b :: BackendType).
(MonadIO m, Backend b) =>
EventTriggerConf b -> TxT m ()
updateEventTrigger3To4
    Query -> () -> Bool -> TxET PGTxErr IO ()
forall (m :: * -> *) r.
(MonadIO m, ToPrepArgs r) =>
Query -> r -> Bool -> TxT m ()
Q.unitQ
      [Q.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,
        Q.AltJ (TriggerOpsDef ('Postgres 'Vanilla)),
        InputWebhook,
        Int,
        Int,
        Q.AltJ (Maybe [HeaderConf])
      ) ->
      EventTriggerConf ('Postgres 'Vanilla)
    uncurryEventTrigger :: (TriggerName, AltJ (TriggerOpsDef ('Postgres 'Vanilla)),
 InputWebhook, Int, Int, AltJ (Maybe [HeaderConf]))
-> EventTriggerConf ('Postgres 'Vanilla)
uncurryEventTrigger (TriggerName
trn, Q.AltJ TriggerOpsDef ('Postgres 'Vanilla)
tDef, InputWebhook
w, Int
nr, Int
rint, Q.AltJ Maybe [HeaderConf]
headers) =
      TriggerName
-> TriggerOpsDef ('Postgres 'Vanilla)
-> Maybe InputWebhook
-> Maybe Text
-> RetryConf
-> Maybe [HeaderConf]
-> Maybe RequestTransform
-> Maybe MetadataResponseTransform
-> EventTriggerConf ('Postgres 'Vanilla)
forall (b :: BackendType).
TriggerName
-> TriggerOpsDef b
-> Maybe InputWebhook
-> Maybe Text
-> RetryConf
-> Maybe [HeaderConf]
-> Maybe RequestTransform
-> Maybe MetadataResponseTransform
-> 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
    updateEventTrigger3To4 :: EventTriggerConf b -> TxT m ()
updateEventTrigger3To4 etc :: EventTriggerConf b
etc@(EventTriggerConf TriggerName
name TriggerOpsDef b
_ Maybe InputWebhook
_ Maybe Text
_ RetryConf
_ Maybe [HeaderConf]
_ Maybe RequestTransform
_ Maybe MetadataResponseTransform
_) =
      Query -> (AltJ Value, TriggerName) -> Bool -> TxT m ()
forall (m :: * -> *) r.
(MonadIO m, ToPrepArgs r) =>
Query -> r -> Bool -> TxT m ()
Q.unitQ
        [Q.sql|
                                            UPDATE hdb_catalog.event_triggers
                                            SET
                                            configuration = $1
                                            WHERE name = $2
                                            |]
        (Value -> AltJ Value
forall a. a -> AltJ a
Q.AltJ (Value -> AltJ Value) -> Value -> AltJ Value
forall a b. (a -> b) -> a -> b
$ EventTriggerConf b -> Value
forall a. ToJSON a => a -> Value
A.toJSON EventTriggerConf b
etc, TriggerName
name)
        Bool
True

setCatalogVersion :: MonadTx m => Text -> UTCTime -> m ()
setCatalogVersion :: Text -> UTCTime -> m ()
setCatalogVersion Text
ver UTCTime
time =
  TxE QErr () -> m ()
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 ()
Q.unitQE
      PGTxErr -> QErr
defaultTxErrorHandler
      [Q.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