{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Refurb.Run.Backup where

import ClassyPrelude
import Control.Monad.Base (liftBase)
import Control.Monad.Logger (logInfo, logError)
import Refurb.Run.Internal (MonadRefurb, contextDbConnInfo)
import Refurb.Types (ConnInfo(ConnInfo), connDbName, connUser, connHost, connPort, connPassword)
import System.Environment (getEnvironment)
import System.Exit (ExitCode(ExitSuccess, ExitFailure))
import qualified System.Process as Proc

-- |Handle the @backup@ command by calling @pg_dump@ to save a database backup.
backup :: MonadRefurb m => FilePath -> m ()
backup :: forall (m :: * -> *). MonadRefurb m => FilePath -> m ()
backup FilePath
path = do
  ConnInfo {Word16
Text
connDbName :: Text
connPassword :: Text
connUser :: Text
connPort :: Word16
connHost :: Text
connPassword :: ConnInfo -> Text
connPort :: ConnInfo -> Word16
connHost :: ConnInfo -> Text
connUser :: ConnInfo -> Text
connDbName :: ConnInfo -> Text
..} <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context -> ConnInfo
contextDbConnInfo
  $Int
FilePath
LogLevel
FilePath -> Text
FilePath -> FilePath -> FilePath -> CharPos -> CharPos -> Loc
Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: FilePath -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
logInfo forall a b. (a -> b) -> a -> b
$ Text
"Backing up database to " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow FilePath
path
  [(FilePath, FilePath)]
env <- forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase IO [(FilePath, FilePath)]
getEnvironment
  let createProcess :: CreateProcess
createProcess =
        ( FilePath -> [FilePath] -> CreateProcess
Proc.proc FilePath
"pg_dump"
          [ FilePath
"-Z", FilePath
"9"  -- max compression
          , FilePath
"-F", FilePath
"c"  -- "custom" format - custom to pg_dump / pg_restore
          , FilePath
"-f", FilePath
path
          , FilePath
"-d", forall mono. MonoFoldable mono => mono -> [Element mono]
unpack Text
connDbName
          , FilePath
"-U", forall mono. MonoFoldable mono => mono -> [Element mono]
unpack Text
connUser
          , FilePath
"-h", forall mono. MonoFoldable mono => mono -> [Element mono]
unpack Text
connHost
          , FilePath
"-p", forall a. Show a => a -> FilePath
show Word16
connPort
          ]
        ) { env :: Maybe [(FilePath, FilePath)]
Proc.env = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (FilePath
"PGPASS", forall mono. MonoFoldable mono => mono -> [Element mono]
unpack Text
connPassword) forall a. a -> [a] -> [a]
: [(FilePath, FilePath)]
env }

  (ExitCode
exitCode, FilePath
out, FilePath
err) <- forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase forall a b. (a -> b) -> a -> b
$ CreateProcess -> FilePath -> IO (ExitCode, FilePath, FilePath)
Proc.readCreateProcessWithExitCode CreateProcess
createProcess FilePath
""

  case ExitCode
exitCode of
    ExitCode
ExitSuccess ->
      $Int
FilePath
LogLevel
FilePath -> Text
FilePath -> FilePath -> FilePath -> CharPos -> CharPos -> Loc
Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: FilePath -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
logInfo Text
"Backup complete."
    ExitFailure Int
code -> do
      $Int
FilePath
LogLevel
FilePath -> Text
FilePath -> FilePath -> FilePath -> CharPos -> CharPos -> Loc
Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: FilePath -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
logError forall a b. (a -> b) -> a -> b
$ Text
"Backup failed with code " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Int
code
      $Int
FilePath
LogLevel
FilePath -> Text
FilePath -> FilePath -> FilePath -> CharPos -> CharPos -> Loc
Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: FilePath -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
logError forall a b. (a -> b) -> a -> b
$ Text
"pg_dump stdout:\n" forall a. Semigroup a => a -> a -> a
<> forall seq. IsSequence seq => [Element seq] -> seq
pack FilePath
out
      $Int
FilePath
LogLevel
FilePath -> Text
FilePath -> FilePath -> FilePath -> CharPos -> CharPos -> Loc
Text -> m ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: FilePath -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
id :: forall a. a -> a
logError forall a b. (a -> b) -> a -> b
$ Text
"pg_dump stderr:\n" forall a. Semigroup a => a -> a -> a
<> forall seq. IsSequence seq => [Element seq] -> seq
pack FilePath
err
      forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"pg_dump failed"