-- | Maintainer: Félix Sipma <felix+propellor@gueux.org>
--
-- Support for the Borg backup tool <https://github.com/borgbackup>

module Propellor.Property.Borg
	( BorgParam
	, BorgRepo(..)
	, BorgRepoOpt(..)
	, installed
	, repoExists
	, init
	, restored
	, backup
	, KeepPolicy (..)
	) where

import Propellor.Base hiding (init)
import Prelude hiding (init)
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Cron as Cron
import Data.List (intercalate)

-- | Parameter to pass to a borg command.
type BorgParam = String

-- | A borg repository.
data BorgRepo
	-- | Location of the repository, eg
	-- `BorgRepo "root@myserver:/mnt/backup/git.borg"`
	= BorgRepo String
	-- | Location of the repository, and additional options to use
	-- when accessing the repository.
	| BorgRepoUsing [BorgRepoOpt] String

data BorgRepoOpt 
	-- | Use to specify a ssh private key to use when accessing a
	-- BorgRepo.
	= UseSshKey FilePath
	-- | Use to specify an environment variable to set when running
	-- borg on a BorgRepo.
	| UsesEnvVar (String, String)

repoLoc :: BorgRepo -> String
repoLoc :: BorgRepo -> String
repoLoc (BorgRepo s :: String
s) = String
s
repoLoc (BorgRepoUsing _ s :: String
s) = String
s

runBorg :: BorgRepo -> [CommandParam] -> IO Bool
runBorg :: BorgRepo -> [CommandParam] -> IO Bool
runBorg repo :: BorgRepo
repo ps :: [CommandParam]
ps = case BorgRepo -> [(String, String)]
runBorgEnv BorgRepo
repo of
	[] -> String -> [CommandParam] -> IO Bool
boolSystem "borg" [CommandParam]
ps
	environ :: [(String, String)]
environ -> do
		[(String, String)]
environ' <- [(String, String)] -> [(String, String)] -> [(String, String)]
forall k v. Eq k => [(k, v)] -> [(k, v)] -> [(k, v)]
addEntries [(String, String)]
environ ([(String, String)] -> [(String, String)])
-> IO [(String, String)] -> IO [(String, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(String, String)]
getEnvironment
		String -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
boolSystemEnv "borg" [CommandParam]
ps ([(String, String)] -> Maybe [(String, String)]
forall a. a -> Maybe a
Just [(String, String)]
environ')

runBorgEnv :: BorgRepo -> [(String, String)]
runBorgEnv :: BorgRepo -> [(String, String)]
runBorgEnv (BorgRepo _) = []
runBorgEnv (BorgRepoUsing os :: [BorgRepoOpt]
os _) = (BorgRepoOpt -> (String, String))
-> [BorgRepoOpt] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map BorgRepoOpt -> (String, String)
go [BorgRepoOpt]
os
  where
	go :: BorgRepoOpt -> (String, String)
go (UseSshKey k :: String
k) = ("BORG_RSH", "ssh -i " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
k)
	go (UsesEnvVar (k :: String
k, v :: String
v)) = (String
k, String
v)

installed :: Property DebianLike
installed :: Property DebianLike
installed = Property (MetaTypes '[ 'Targeting 'OSDebian])
-> Property DebianLike -> Property DebianLike
forall k ka kb (c :: k) (a :: ka) (b :: kb).
(HasCallStack, SingKind 'KProxy, SingKind 'KProxy,
 DemoteRep 'KProxy ~ [MetaType], DemoteRep 'KProxy ~ [MetaType],
 SingI c) =>
Property (MetaTypes a)
-> Property (MetaTypes b) -> Property (MetaTypes c)
pickOS Property (MetaTypes '[ 'Targeting 'OSDebian])
installdebian Property DebianLike
aptinstall
  where
	installdebian :: Property Debian
	installdebian :: Property (MetaTypes '[ 'Targeting 'OSDebian])
installdebian = String
-> (OuterMetaTypesWitness '[ 'Targeting 'OSDebian]
    -> Maybe System -> Propellor Result)
-> Property (MetaTypes '[ 'Targeting 'OSDebian])
forall k (metatypes :: k).
SingI metatypes =>
String
-> (OuterMetaTypesWitness metatypes
    -> Maybe System -> Propellor Result)
-> Property (MetaTypes metatypes)
withOS String
desc ((OuterMetaTypesWitness '[ 'Targeting 'OSDebian]
  -> Maybe System -> Propellor Result)
 -> Property (MetaTypes '[ 'Targeting 'OSDebian]))
-> (OuterMetaTypesWitness '[ 'Targeting 'OSDebian]
    -> Maybe System -> Propellor Result)
-> Property (MetaTypes '[ 'Targeting 'OSDebian])
forall a b. (a -> b) -> a -> b
$ \w :: OuterMetaTypesWitness '[ 'Targeting 'OSDebian]
w o :: Maybe System
o -> case Maybe System
o of
		(Just (System (Debian _ (Stable "jessie")) _)) -> OuterMetaTypesWitness '[ 'Targeting 'OSDebian]
-> Property (MetaTypes '[ 'Targeting 'OSDebian])
-> Propellor Result
forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness '[ 'Targeting 'OSDebian]
w (Property (MetaTypes '[ 'Targeting 'OSDebian]) -> Propellor Result)
-> Property (MetaTypes '[ 'Targeting 'OSDebian])
-> Propellor Result
forall a b. (a -> b) -> a -> b
$
			[String] -> Property (MetaTypes '[ 'Targeting 'OSDebian])
Apt.backportInstalled ["borgbackup", "python3-msgpack"]
		_ -> OuterMetaTypesWitness '[ 'Targeting 'OSDebian]
-> Property DebianLike -> Propellor Result
forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness '[ 'Targeting 'OSDebian]
w (Property DebianLike -> Propellor Result)
-> Property DebianLike -> Propellor Result
forall a b. (a -> b) -> a -> b
$
			[String] -> Property DebianLike
Apt.installed ["borgbackup"]
	aptinstall :: Property DebianLike
aptinstall = [String] -> Property DebianLike
Apt.installed ["borgbackup"] Property DebianLike -> String -> Property DebianLike
forall p. IsProp p => p -> String -> p
`describe` String
desc
        desc :: String
desc = "installed borgbackup"

repoExists :: BorgRepo -> IO Bool
repoExists :: BorgRepo -> IO Bool
repoExists repo :: BorgRepo
repo = BorgRepo -> [CommandParam] -> IO Bool
runBorg BorgRepo
repo [String -> CommandParam
Param "list", String -> CommandParam
Param (BorgRepo -> String
repoLoc BorgRepo
repo)]

-- | Inits a new borg repository
init :: BorgRepo -> Property DebianLike
init :: BorgRepo -> Property DebianLike
init repo :: BorgRepo
repo = IO Bool -> UncheckedProperty UnixLike -> Property UnixLike
forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check (Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BorgRepo -> IO Bool
repoExists BorgRepo
repo)
	(String
-> [String] -> [(String, String)] -> UncheckedProperty UnixLike
cmdPropertyEnv "borg" [String]
initargs (BorgRepo -> [(String, String)]
runBorgEnv BorgRepo
repo))
		Property UnixLike
-> Property DebianLike
-> CombinedType (Property UnixLike) (Property DebianLike)
forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Property DebianLike
installed
  where
	initargs :: [String]
initargs =
		[ "init"
		, BorgRepo -> String
repoLoc BorgRepo
repo
		]

-- | Restores a directory from a borg backup.
--
-- Only does anything if the directory does not exist, or exists,
-- but is completely empty.
--
-- The restore is performed atomically; restoring to a temp directory
-- and then moving it to the directory.
restored :: FilePath -> BorgRepo -> Property DebianLike
restored :: String -> BorgRepo -> Property DebianLike
restored dir :: String
dir repo :: BorgRepo
repo = Property DebianLike
go Property DebianLike
-> Property DebianLike
-> CombinedType (Property DebianLike) (Property DebianLike)
forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Property DebianLike
installed
  where
	go :: Property DebianLike
	go :: Property DebianLike
go = String -> Propellor Result -> Property DebianLike
forall k (metatypes :: k).
SingI metatypes =>
String -> Propellor Result -> Property (MetaTypes metatypes)
property (String
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ " restored by borg") (Propellor Result -> Property DebianLike)
-> Propellor Result -> Property DebianLike
forall a b. (a -> b) -> a -> b
$ Propellor Bool
-> (Propellor Result, Propellor Result) -> Propellor Result
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (IO Bool -> Propellor Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Bool
needsRestore)
		( do
			String -> Propellor ()
forall (m :: * -> *). MonadIO m => String -> m ()
warningMessage (String -> Propellor ()) -> String -> Propellor ()
forall a b. (a -> b) -> a -> b
$ String
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ " is empty/missing; restoring from backup ..."
			IO Result -> Propellor Result
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Result
restore
		, Propellor Result
noChange
		)

	needsRestore :: IO Bool
needsRestore = String -> IO Bool
isUnpopulated String
dir

	restore :: IO Result
restore = String -> String -> (String -> IO Result) -> IO Result
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
String -> String -> (String -> m a) -> m a
withTmpDirIn (String -> String
takeDirectory String
dir) "borg-restore" ((String -> IO Result) -> IO Result)
-> (String -> IO Result) -> IO Result
forall a b. (a -> b) -> a -> b
$ \tmpdir :: String
tmpdir -> do
		Bool
ok <- BorgRepo -> [CommandParam] -> IO Bool
runBorg BorgRepo
repo ([CommandParam] -> IO Bool) -> [CommandParam] -> IO Bool
forall a b. (a -> b) -> a -> b
$
			[ String -> CommandParam
Param "extract"
			, String -> CommandParam
Param (BorgRepo -> String
repoLoc BorgRepo
repo)
			, String -> CommandParam
Param String
tmpdir
			]
		let restoreddir :: String
restoreddir = String
tmpdir String -> String -> String
forall a. [a] -> [a] -> [a]
++ "/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dir
		IO Bool -> (IO Result, IO Result) -> IO Result
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
ok IO Bool -> IO Bool -> IO Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
<&&> String -> IO Bool
doesDirectoryExist String
restoreddir)
			( do
				IO (Either IOException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either IOException ()) -> IO ())
-> IO (Either IOException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Either IOException ())
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeDirectory String
dir
				String -> String -> IO ()
renameDirectory String
restoreddir String
dir
				Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
MadeChange
			, Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
			)

-- | Installs a cron job that causes a given directory to be backed
-- up, by running borg with some parameters.
--
-- If the directory does not exist, or exists but is completely empty,
-- this Property will immediately restore it from an existing backup.
--
-- So, this property can be used to deploy a directory of content
-- to a host, while also ensuring any changes made to it get backed up.
-- For example:
--
-- >	& Borg.backup "/srv/git"
-- >		(BorgRepo "root@myserver:/mnt/backup/git.borg") 
-- >		Cron.Daily
-- >		["--exclude=/srv/git/tobeignored"]
-- >		[Borg.KeepDays 7, Borg.KeepWeeks 4, Borg.KeepMonths 6, Borg.KeepYears 1]
--
-- Note that this property does not initialize the backup repository,
-- so that will need to be done once, before-hand.
--
-- Since borg uses a fair amount of system resources, only one borg
-- backup job will be run at a time. Other jobs will wait their turns to
-- run.
backup :: FilePath -> BorgRepo -> Cron.Times -> [BorgParam] -> [KeepPolicy] -> Property DebianLike
backup :: String
-> BorgRepo
-> Times
-> [String]
-> [KeepPolicy]
-> Property DebianLike
backup dir :: String
dir repo :: BorgRepo
repo crontimes :: Times
crontimes extraargs :: [String]
extraargs kp :: [KeepPolicy]
kp = String
-> BorgRepo
-> Times
-> [String]
-> [KeepPolicy]
-> Property DebianLike
backup' String
dir BorgRepo
repo Times
crontimes [String]
extraargs [KeepPolicy]
kp
	Property DebianLike
-> Property DebianLike
-> CombinedType (Property DebianLike) (Property DebianLike)
forall x y. Combines x y => x -> y -> CombinedType x y
`requires` String -> BorgRepo -> Property DebianLike
restored String
dir BorgRepo
repo

-- | Does a backup, but does not automatically restore.
backup' :: FilePath -> BorgRepo -> Cron.Times -> [BorgParam] -> [KeepPolicy] -> Property DebianLike
backup' :: String
-> BorgRepo
-> Times
-> [String]
-> [KeepPolicy]
-> Property DebianLike
backup' dir :: String
dir repo :: BorgRepo
repo crontimes :: Times
crontimes extraargs :: [String]
extraargs kp :: [KeepPolicy]
kp = Property DebianLike
cronjob
	Property DebianLike -> String -> Property DebianLike
forall p. IsProp p => p -> String -> p
`describe` String
desc
	Property DebianLike
-> Property DebianLike
-> CombinedType (Property DebianLike) (Property DebianLike)
forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Property DebianLike
installed
  where
	desc :: String
desc = BorgRepo -> String
repoLoc BorgRepo
repo String -> String -> String
forall a. [a] -> [a] -> [a]
++ " borg backup"
	cronjob :: Property DebianLike
cronjob = String -> Times -> User -> String -> String -> Property DebianLike
Cron.niceJob ("borg_backup" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dir) Times
crontimes (String -> User
User "root") "/" (String -> Property DebianLike) -> String -> Property DebianLike
forall a b. (a -> b) -> a -> b
$
		"flock " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
shellEscape String
lockfile String -> String -> String
forall a. [a] -> [a] -> [a]
++ " sh -c " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
shellEscape String
backupcmd
	lockfile :: String
lockfile = "/var/lock/propellor-borg.lock"
	backupcmd :: String
backupcmd = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "&&" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
		[ ((String, String) -> [String]) -> [(String, String)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String, String) -> [String]
exportenv (BorgRepo -> [(String, String)]
runBorgEnv BorgRepo
repo)
		, [String
createCommand]
		, if [KeepPolicy] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [KeepPolicy]
kp then [] else [String
pruneCommand]
		]
	exportenv :: (String, String) -> [String]
exportenv (k :: String
k, v :: String
v) = 
		[ String
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ "=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
shellEscape String
v
		, "export " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
k
		]
	createCommand :: String
createCommand = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
		[ "borg"
		, "create"
		, "--stats"
		]
		[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
shellEscape [String]
extraargs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
		[ String -> String
shellEscape (BorgRepo -> String
repoLoc BorgRepo
repo) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "::" String -> String -> String
forall a. [a] -> [a] -> [a]
++ "$(date --iso-8601=ns --utc)"
		, String -> String
shellEscape String
dir
		]
	pruneCommand :: String
pruneCommand = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
		[ "borg"
		, "prune"
		, String -> String
shellEscape (BorgRepo -> String
repoLoc BorgRepo
repo)
		]
		[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
		(KeepPolicy -> String) -> [KeepPolicy] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map KeepPolicy -> String
keepParam [KeepPolicy]
kp

-- | Constructs an BorgParam that specifies which old backup generations to
-- keep. By default, all generations are kept. However, when this parameter is
-- passed to the `backup` property, it will run borg prune to clean out
-- generations not specified here.
keepParam :: KeepPolicy -> BorgParam
keepParam :: KeepPolicy -> String
keepParam (KeepHours n :: Int
n) = "--keep-hourly=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall t. ConfigurableValue t => t -> String
val Int
n
keepParam (KeepDays n :: Int
n) = "--keep-daily=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall t. ConfigurableValue t => t -> String
val Int
n
keepParam (KeepWeeks n :: Int
n) = "--keep-daily=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall t. ConfigurableValue t => t -> String
val Int
n
keepParam (KeepMonths n :: Int
n) = "--keep-monthly=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall t. ConfigurableValue t => t -> String
val Int
n
keepParam (KeepYears n :: Int
n) = "--keep-yearly=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall t. ConfigurableValue t => t -> String
val Int
n

-- | Policy for backup generations to keep. For example, KeepDays 30 will
-- keep the latest backup for each day when a backup was made, and keep the
-- last 30 such backups. When multiple KeepPolicies are combined together,
-- backups meeting any policy are kept. See borg's man page for details.
data KeepPolicy
	= KeepHours Int
	| KeepDays Int
	| KeepWeeks Int
	| KeepMonths Int
	| KeepYears Int