{-# 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 :: 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
..} <- (Context -> ConnInfo) -> m ConnInfo
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
Loc -> Text -> LogLevel -> Text -> m ()
Text -> Text
(Text -> m ()) -> (Text -> Text) -> 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 ()
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: FilePath -> Text
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
$logInfo (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Backing up database to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. Show a => a -> Text
tshow FilePath
path
  [(FilePath, FilePath)]
env <- IO [(FilePath, FilePath)] -> m [(FilePath, FilePath)]
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", Text -> [Element Text]
forall mono. MonoFoldable mono => mono -> [Element mono]
unpack Text
connDbName
          , FilePath
"-U", Text -> [Element Text]
forall mono. MonoFoldable mono => mono -> [Element mono]
unpack Text
connUser
          , FilePath
"-h", Text -> [Element Text]
forall mono. MonoFoldable mono => mono -> [Element mono]
unpack Text
connHost
          , FilePath
"-p", Word16 -> FilePath
forall a. Show a => a -> FilePath
show Word16
connPort
          ]
        ) { env :: Maybe [(FilePath, FilePath)]
Proc.env = [(FilePath, FilePath)] -> Maybe [(FilePath, FilePath)]
forall a. a -> Maybe a
Just ([(FilePath, FilePath)] -> Maybe [(FilePath, FilePath)])
-> [(FilePath, FilePath)] -> Maybe [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ (FilePath
"PGPASS", Text -> [Element Text]
forall mono. MonoFoldable mono => mono -> [Element mono]
unpack Text
connPassword) (FilePath, FilePath)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. a -> [a] -> [a]
: [(FilePath, FilePath)]
env }

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