1
0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-12-20 22:11:45 +03:00
graphql-engine/server/src-lib/Hasura/Server/API/PGDump.hs
Tom Harding e0c0043e76 Upgrade Ormolu to 0.7.0.0
PR-URL: https://github.com/hasura/graphql-engine-mono/pull/9284
GitOrigin-RevId: 2f2cf2ad01900a54e4bdb970205ac0ef313c7e00
2023-05-24 13:53:53 +00:00

105 lines
3.3 KiB
Haskell

-- | 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
{ prbSource :: !SourceName,
prbOpts :: ![String],
prbCleanOutput :: !Bool
}
deriving (Show, Eq)
instance FromJSON PGDumpReqBody where
parseJSON = withObject "Object" $ \o ->
PGDumpReqBody
<$> o
.:? "source"
.!= defaultSource
<*> o
.: "opts"
<*> o
.:? "clean_output"
.!= False
execPGDump ::
(MonadError RTE.QErr m, MonadIO m) =>
PGDumpReqBody ->
PG.ConnInfo ->
m BL.ByteString
execPGDump b ci = do
eOutput <- liftIO $ try execProcess
output <- onLeft eOutput throwException
onLeft output $ \err ->
RTE.throw500 $ "error while executing pg_dump: " <> err
where
throwException :: (MonadError RTE.QErr m) => IOException -> m a
throwException _ = RTE.throw500 "internal exception while executing pg_dump"
execProcess = do
(exitCode, stdOut, stdErr) <- readProcessWithExitCode "pg_dump" opts ""
return $ case exitCode of
ExitSuccess -> Right $ unUTF8 $ convertText (clean stdOut)
ExitFailure _ -> Left $ toText stdErr
connString = T.unpack $ bsToTxt $ PG.pgConnString $ PG.ciDetails ci
opts = connString : "--encoding=utf8" : prbOpts b
clean str
| prbCleanOutput b =
unlines $ filter (not . shouldDropLine) (lines str)
| otherwise = str
shouldDropLine line =
-- delete empty lines
all isSpace line
-- delete comments
|| ("--" `L.isPrefixOf` line)
-- delete front matter
|| (line `elem` preambleLines)
-- delete notify triggers
|| (eventTriggerRegex `TDFA.match` line)
preambleLines =
[ "SET statement_timeout = 0;",
"SET lock_timeout = 0;",
"SET idle_in_transaction_session_timeout = 0;",
"SET client_encoding = 'UTF8';",
"SET standard_conforming_strings = on;",
"SELECT pg_catalog.set_config('search_path', '', false);",
"SET xmloption = content;",
"SET client_min_messages = warning;",
"SET row_security = off;",
"SET default_tablespace = '';",
"SET default_with_oids = false;",
"SET default_table_access_method = heap;",
"CREATE SCHEMA public;",
"COMMENT ON SCHEMA public IS 'standard public schema';"
]
eventTriggerRegex =
let regexStr :: String =
-- pg functions created by hasura for event triggers used "notify_hasura"
-- These changes are also documented on the method pgIdenTrigger
"^CREATE TRIGGER \"?notify_hasura_.+\"? AFTER [[:alnum:]]+ "
<> "ON .+ FOR EACH ROW EXECUTE (FUNCTION|PROCEDURE) "
<> "\"?hdb_catalog\"?\\.\"?notify_hasura_.+\"?\\(\\);$"
in TDFA.makeRegex regexStr :: TDFA.Regex