-- | API related to Postgres' pg dump
module Hasura.Server.API.PGDump
  ( PGDumpReqBody (..),
    execPGDump,
  )
where

import Control.Exception (IOException, try)
import Data.Aeson
import Data.ByteString.Lazy qualified as BL
import Data.Char (isSpace)
import Data.List qualified as L
import Data.Text qualified as T
import Data.Text.Conversions
import Database.PG.Query qualified as PG
import Hasura.Base.Error qualified as RTE
import Hasura.Prelude
import Hasura.RQL.Types.Common
import System.Exit
import System.Process
import Text.Regex.TDFA qualified as TDFA

data PGDumpReqBody = PGDumpReqBody
  { PGDumpReqBody -> SourceName
prbSource :: !SourceName,
    PGDumpReqBody -> [String]
prbOpts :: ![String],
    PGDumpReqBody -> Bool
prbCleanOutput :: !Bool
  }
  deriving (Int -> PGDumpReqBody -> ShowS
[PGDumpReqBody] -> ShowS
PGDumpReqBody -> String
(Int -> PGDumpReqBody -> ShowS)
-> (PGDumpReqBody -> String)
-> ([PGDumpReqBody] -> ShowS)
-> Show PGDumpReqBody
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PGDumpReqBody -> ShowS
showsPrec :: Int -> PGDumpReqBody -> ShowS
$cshow :: PGDumpReqBody -> String
show :: PGDumpReqBody -> String
$cshowList :: [PGDumpReqBody] -> ShowS
showList :: [PGDumpReqBody] -> ShowS
Show, PGDumpReqBody -> PGDumpReqBody -> Bool
(PGDumpReqBody -> PGDumpReqBody -> Bool)
-> (PGDumpReqBody -> PGDumpReqBody -> Bool) -> Eq PGDumpReqBody
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PGDumpReqBody -> PGDumpReqBody -> Bool
== :: PGDumpReqBody -> PGDumpReqBody -> Bool
$c/= :: PGDumpReqBody -> PGDumpReqBody -> Bool
/= :: PGDumpReqBody -> PGDumpReqBody -> Bool
Eq)

instance FromJSON PGDumpReqBody where
  parseJSON :: Value -> Parser PGDumpReqBody
parseJSON = String
-> (Object -> Parser PGDumpReqBody)
-> Value
-> Parser PGDumpReqBody
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Object" ((Object -> Parser PGDumpReqBody) -> Value -> Parser PGDumpReqBody)
-> (Object -> Parser PGDumpReqBody)
-> Value
-> Parser PGDumpReqBody
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    SourceName -> [String] -> Bool -> PGDumpReqBody
PGDumpReqBody
      (SourceName -> [String] -> Bool -> PGDumpReqBody)
-> Parser SourceName -> Parser ([String] -> Bool -> PGDumpReqBody)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o
      Object -> Key -> Parser (Maybe SourceName)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"source"
      Parser (Maybe SourceName) -> SourceName -> Parser SourceName
forall a. Parser (Maybe a) -> a -> Parser a
.!= SourceName
defaultSource
      Parser ([String] -> Bool -> PGDumpReqBody)
-> Parser [String] -> Parser (Bool -> PGDumpReqBody)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o
      Object -> Key -> Parser [String]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"opts"
      Parser (Bool -> PGDumpReqBody)
-> Parser Bool -> Parser PGDumpReqBody
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o
      Object -> Key -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"clean_output"
      Parser (Maybe Bool) -> Bool -> Parser Bool
forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
False

execPGDump ::
  (MonadError RTE.QErr m, MonadIO m) =>
  PGDumpReqBody ->
  PG.ConnInfo ->
  m BL.ByteString
execPGDump :: forall (m :: * -> *).
(MonadError QErr m, MonadIO m) =>
PGDumpReqBody -> ConnInfo -> m ByteString
execPGDump PGDumpReqBody
b ConnInfo
ci = do
  Either IOException (Either Text ByteString)
eOutput <- IO (Either IOException (Either Text ByteString))
-> m (Either IOException (Either Text ByteString))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException (Either Text ByteString))
 -> m (Either IOException (Either Text ByteString)))
-> IO (Either IOException (Either Text ByteString))
-> m (Either IOException (Either Text ByteString))
forall a b. (a -> b) -> a -> b
$ IO (Either Text ByteString)
-> IO (Either IOException (Either Text ByteString))
forall e a. Exception e => IO a -> IO (Either e a)
try IO (Either Text ByteString)
execProcess
  Either Text ByteString
output <- Either IOException (Either Text ByteString)
-> (IOException -> m (Either Text ByteString))
-> m (Either Text ByteString)
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
onLeft Either IOException (Either Text ByteString)
eOutput IOException -> m (Either Text ByteString)
forall (m :: * -> *) a. MonadError QErr m => IOException -> m a
throwException
  Either Text ByteString -> (Text -> m ByteString) -> m ByteString
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
onLeft Either Text ByteString
output ((Text -> m ByteString) -> m ByteString)
-> (Text -> m ByteString) -> m ByteString
forall a b. (a -> b) -> a -> b
$ \Text
err ->
    Text -> m ByteString
forall (m :: * -> *) a. QErrM m => Text -> m a
RTE.throw500 (Text -> m ByteString) -> Text -> m ByteString
forall a b. (a -> b) -> a -> b
$ Text
"error while executing pg_dump: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
  where
    throwException :: (MonadError RTE.QErr m) => IOException -> m a
    throwException :: forall (m :: * -> *) a. MonadError QErr m => IOException -> m a
throwException IOException
_ = Text -> m a
forall (m :: * -> *) a. QErrM m => Text -> m a
RTE.throw500 Text
"internal exception while executing pg_dump"

    execProcess :: IO (Either Text ByteString)
execProcess = do
      (ExitCode
exitCode, String
stdOut, String
stdErr) <- String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
"pg_dump" [String]
opts String
""
      Either Text ByteString -> IO (Either Text ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text ByteString -> IO (Either Text ByteString))
-> Either Text ByteString -> IO (Either Text ByteString)
forall a b. (a -> b) -> a -> b
$ case ExitCode
exitCode of
        ExitCode
ExitSuccess -> ByteString -> Either Text ByteString
forall a b. b -> Either a b
Right (ByteString -> Either Text ByteString)
-> ByteString -> Either Text ByteString
forall a b. (a -> b) -> a -> b
$ UTF8 ByteString -> ByteString
forall a. UTF8 a -> a
unUTF8 (UTF8 ByteString -> ByteString) -> UTF8 ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> UTF8 ByteString
forall a b. (ToText a, FromText b) => a -> b
convertText (ShowS
clean String
stdOut)
        ExitFailure Int
_ -> Text -> Either Text ByteString
forall a b. a -> Either a b
Left (Text -> Either Text ByteString) -> Text -> Either Text ByteString
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText String
stdErr

    connString :: String
connString = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
bsToTxt (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ConnDetails -> ByteString
PG.pgConnString (ConnDetails -> ByteString) -> ConnDetails -> ByteString
forall a b. (a -> b) -> a -> b
$ ConnInfo -> ConnDetails
PG.ciDetails ConnInfo
ci
    opts :: [String]
opts = String
connString String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"--encoding=utf8" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: PGDumpReqBody -> [String]
prbOpts PGDumpReqBody
b

    clean :: ShowS
clean String
str
      | PGDumpReqBody -> Bool
prbCleanOutput PGDumpReqBody
b =
          [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
shouldDropLine) (String -> [String]
lines String
str)
      | Bool
otherwise = String
str

    shouldDropLine :: String -> Bool
shouldDropLine String
line =
      -- delete empty lines
      (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
line
        -- delete comments
        Bool -> Bool -> Bool
|| (String
"--" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` String
line)
        -- delete front matter
        Bool -> Bool -> Bool
|| (String
line String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
preambleLines)
        -- delete notify triggers
        Bool -> Bool -> Bool
|| (Regex
eventTriggerRegex Regex -> String -> Bool
forall regex source target.
RegexContext regex source target =>
regex -> source -> target
`TDFA.match` String
line)

    preambleLines :: [String]
preambleLines =
      [ String
"SET statement_timeout = 0;",
        String
"SET lock_timeout = 0;",
        String
"SET idle_in_transaction_session_timeout = 0;",
        String
"SET client_encoding = 'UTF8';",
        String
"SET standard_conforming_strings = on;",
        String
"SELECT pg_catalog.set_config('search_path', '', false);",
        String
"SET xmloption = content;",
        String
"SET client_min_messages = warning;",
        String
"SET row_security = off;",
        String
"SET default_tablespace = '';",
        String
"SET default_with_oids = false;",
        String
"SET default_table_access_method = heap;",
        String
"CREATE SCHEMA public;",
        String
"COMMENT ON SCHEMA public IS 'standard public schema';"
      ]

    eventTriggerRegex :: Regex
eventTriggerRegex =
      let String
regexStr :: String =
            -- pg functions created by hasura for event triggers used "notify_hasura"
            -- These changes are also documented on the method pgIdenTrigger
            String
"^CREATE TRIGGER \"?notify_hasura_.+\"? AFTER [[:alnum:]]+ "
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"ON .+ FOR EACH ROW EXECUTE (FUNCTION|PROCEDURE) "
              String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\"?hdb_catalog\"?\\.\"?notify_hasura_.+\"?\\(\\);$"
       in String -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
source -> regex
TDFA.makeRegex String
regexStr :: TDFA.Regex