summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Base.hs4
-rw-r--r--src/Propellor/PropAccum.hs6
-rw-r--r--src/Propellor/Property/Attic.hs2
-rw-r--r--src/Propellor/Property/Borg.hs155
-rw-r--r--src/Propellor/Property/LetsEncrypt.hs6
-rw-r--r--src/Propellor/Property/Obnam.hs2
-rw-r--r--src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs2
-rw-r--r--src/Propellor/Types/ZFS.hs1
-rw-r--r--src/Utility/Directory.hs6
-rw-r--r--src/Utility/Exception.hs6
-rw-r--r--src/Utility/FileMode.hs3
-rw-r--r--src/Utility/FileSystemEncoding.hs8
-rw-r--r--src/Utility/PosixFiles.hs10
-rw-r--r--src/Utility/SystemDirectory.hs16
-rw-r--r--src/Utility/Tmp.hs2
-rw-r--r--src/Utility/UserInfo.hs4
16 files changed, 214 insertions, 19 deletions
diff --git a/src/Propellor/Base.hs b/src/Propellor/Base.hs
index 2a0f5cbc..ae75589f 100644
--- a/src/Propellor/Base.hs
+++ b/src/Propellor/Base.hs
@@ -20,7 +20,7 @@ module Propellor.Base (
, module Propellor.Utilities
-- * System modules
- , module System.Directory
+ , module Utility.SystemDirectory
, module System.IO
, module System.FilePath
, module Data.Maybe
@@ -47,7 +47,7 @@ import Propellor.PropAccum
import Propellor.Location
import Propellor.Utilities
-import System.Directory
+import Utility.SystemDirectory
import System.IO
import System.FilePath
import Data.Maybe
diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs
index d9fa8ec7..fcac60bf 100644
--- a/src/Propellor/PropAccum.hs
+++ b/src/Propellor/PropAccum.hs
@@ -78,9 +78,3 @@ Props c &^ p = Props (toChildProperty p : c)
-> RevertableProperty (MetaTypes y) (MetaTypes z)
-> Props (MetaTypes (Combine x z))
Props c ! p = Props (c ++ [toChildProperty (revert p)])
-
--- addPropsHost :: Host -> [Prop] -> Host
--- addPropsHost (Host hn ps i) p = Host hn ps' i'
--- where
--- ps' = ps ++ [toChildProperty p]
--- i' = i <> getInfoRecursive p
diff --git a/src/Propellor/Property/Attic.hs b/src/Propellor/Property/Attic.hs
index 26f23500..4415f8c0 100644
--- a/src/Propellor/Property/Attic.hs
+++ b/src/Propellor/Property/Attic.hs
@@ -1,4 +1,6 @@
-- | Maintainer: Félix Sipma <felix+propellor@gueux.org>
+--
+-- Support for the Attic backup tool <https://attic-backup.org/>
module Propellor.Property.Attic
( installed
diff --git a/src/Propellor/Property/Borg.hs b/src/Propellor/Property/Borg.hs
new file mode 100644
index 00000000..f5842115
--- /dev/null
+++ b/src/Propellor/Property/Borg.hs
@@ -0,0 +1,155 @@
+-- | Maintainer: Félix Sipma <felix+propellor@gueux.org>
+--
+-- Support for the Borg backup tool <https://github.com/borgbackup>
+
+module Propellor.Property.Borg
+ ( 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)
+
+type BorgParam = String
+
+type BorgRepo = FilePath
+
+installed :: Property DebianLike
+installed = withOS desc $ \w o -> case o of
+ (Just (System (Debian (Stable "jessie")) _)) -> ensureProperty w $
+ Apt.installedBackport ["borgbackup"]
+ _ -> ensureProperty w $
+ Apt.installed ["borgbackup"]
+ where
+ desc = "installed borgbackup"
+
+repoExists :: BorgRepo -> IO Bool
+repoExists repo = boolSystem "borg" [Param "list", File repo]
+
+-- | Inits a new borg repository
+init :: BorgRepo -> Property DebianLike
+init backupdir = check (not <$> repoExists backupdir) (cmdProperty "borg" initargs)
+ `requires` installed
+ where
+ initargs =
+ [ "init"
+ , backupdir
+ ]
+
+-- | Restores a directory from an 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 dir backupdir = go `requires` installed
+ where
+ go :: Property DebianLike
+ go = property (dir ++ " restored by borg") $ ifM (liftIO needsRestore)
+ ( do
+ warningMessage $ dir ++ " is empty/missing; restoring from backup ..."
+ liftIO restore
+ , noChange
+ )
+
+ needsRestore = null <$> catchDefaultIO [] (dirContents dir)
+
+ restore = withTmpDirIn (takeDirectory dir) "borg-restore" $ \tmpdir -> do
+ ok <- boolSystem "borg" $
+ [ Param "extract"
+ , Param backupdir
+ , Param tmpdir
+ ]
+ let restoreddir = tmpdir ++ "/" ++ dir
+ ifM (pure ok <&&> doesDirectoryExist restoreddir)
+ ( do
+ void $ tryIO $ removeDirectory dir
+ renameDirectory restoreddir dir
+ return MadeChange
+ , return 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" "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 make borg encrypt the backup
+-- repository.
+--
+-- 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 dir backupdir crontimes extraargs kp = backup' dir backupdir crontimes extraargs kp
+ `requires` restored dir backupdir
+
+-- | Does a backup, but does not automatically restore.
+backup' :: FilePath -> BorgRepo -> Cron.Times -> [BorgParam] -> [KeepPolicy] -> Property DebianLike
+backup' dir backupdir crontimes extraargs kp = cronjob
+ `describe` desc
+ `requires` installed
+ where
+ desc = backupdir ++ " borg backup"
+ cronjob = Cron.niceJob ("borg_backup" ++ dir) crontimes (User "root") "/" $
+ "flock " ++ shellEscape lockfile ++ " sh -c " ++ backupcmd
+ lockfile = "/var/lock/propellor-borg.lock"
+ backupcmd = intercalate ";" $
+ createCommand
+ : if null kp then [] else [pruneCommand]
+ createCommand = unwords $
+ [ "borg"
+ , "create"
+ , "--stats"
+ ]
+ ++ map shellEscape extraargs ++
+ [ shellEscape backupdir ++ "::" ++ "$(date --iso-8601=ns --utc)"
+ , shellEscape dir
+ ]
+ pruneCommand = unwords $
+ [ "borg"
+ , "prune"
+ , shellEscape backupdir
+ ]
+ ++
+ map keepParam 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, they will run borg prune to clean out
+-- generations not specified here.
+keepParam :: KeepPolicy -> BorgParam
+keepParam (KeepHours n) = "--keep-hourly=" ++ show n
+keepParam (KeepDays n) = "--keep-daily=" ++ show n
+keepParam (KeepWeeks n) = "--keep-daily=" ++ show n
+keepParam (KeepMonths n) = "--keep-monthly=" ++ show n
+keepParam (KeepYears n) = "--keep-yearly=" ++ show 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
diff --git a/src/Propellor/Property/LetsEncrypt.hs b/src/Propellor/Property/LetsEncrypt.hs
index bf38046b..592a1e1d 100644
--- a/src/Propellor/Property/LetsEncrypt.hs
+++ b/src/Propellor/Property/LetsEncrypt.hs
@@ -1,4 +1,5 @@
--- | This module uses the letsencrypt reference client.
+-- | This module gets LetsEncrypt <https://letsencrypt.org/> certificates
+-- using CertBot <https://certbot.eff.org/>
module Propellor.Property.LetsEncrypt where
@@ -7,6 +8,8 @@ import qualified Propellor.Property.Apt as Apt
import System.Posix.Files
+-- Not using the certbot name yet, until it reaches jessie-backports and
+-- testing.
installed :: Property DebianLike
installed = Apt.installed ["letsencrypt"]
@@ -74,6 +77,7 @@ letsEncrypt' (AgreeTOS memail) domain domains webroot =
, "--webroot"
, "--webroot-path", webroot
, "--text"
+ , "--noninteractive"
, "--keep-until-expiring"
] ++ map (\d -> "--domain="++d) alldomains
diff --git a/src/Propellor/Property/Obnam.hs b/src/Propellor/Property/Obnam.hs
index 6d6f4a7f..5bf3ff06 100644
--- a/src/Propellor/Property/Obnam.hs
+++ b/src/Propellor/Property/Obnam.hs
@@ -1,3 +1,5 @@
+-- | Support for the Obnam backup tool <http://obnam.org/>
+
module Propellor.Property.Obnam where
import Propellor.Base
diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
index ce89b94a..b4812c7e 100644
--- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
+++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
@@ -135,6 +135,8 @@ stackAutoBuilder suite arch flavor =
& User.accountFor (User builduser)
& tree arch flavor
& stackInstalled
+ -- Workaround https://github.com/commercialhaskell/stack/issues/2093
+ & Apt.installed ["libtinfo-dev"]
stackInstalled :: Property Linux
stackInstalled = withOS "stack installed" $ \w o ->
diff --git a/src/Propellor/Types/ZFS.hs b/src/Propellor/Types/ZFS.hs
index 8784c641..3ce4b22c 100644
--- a/src/Propellor/Types/ZFS.hs
+++ b/src/Propellor/Types/ZFS.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ConstrainedClassMethods #-}
-- | Types for ZFS Properties.
--
-- Copyright 2016 Evan Cofsky <evan@theunixman.com>
diff --git a/src/Utility/Directory.hs b/src/Utility/Directory.hs
index 3b12b9fc..693e7713 100644
--- a/src/Utility/Directory.hs
+++ b/src/Utility/Directory.hs
@@ -6,15 +6,14 @@
-}
{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -fno-warn-tabs -w #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Directory (
module Utility.Directory,
- module System.Directory
+ module Utility.SystemDirectory
) where
import System.IO.Error
-import System.Directory hiding (isSymbolicLink)
import Control.Monad
import System.FilePath
import Control.Applicative
@@ -31,6 +30,7 @@ import Utility.SafeCommand
import Control.Monad.IfElse
#endif
+import Utility.SystemDirectory
import Utility.PosixFiles
import Utility.Tmp
import Utility.Exception
diff --git a/src/Utility/Exception.hs b/src/Utility/Exception.hs
index 8b110ae6..e691f13b 100644
--- a/src/Utility/Exception.hs
+++ b/src/Utility/Exception.hs
@@ -21,7 +21,8 @@ module Utility.Exception (
tryNonAsync,
tryWhenExists,
catchIOErrorType,
- IOErrorType(..)
+ IOErrorType(..),
+ catchPermissionDenied,
) where
import Control.Monad.Catch as X hiding (Handler)
@@ -97,3 +98,6 @@ catchIOErrorType errtype onmatchingerr a = catchIO a onlymatching
onlymatching e
| ioeGetErrorType e == errtype = onmatchingerr e
| otherwise = throwM e
+
+catchPermissionDenied :: MonadCatch m => (IOException -> m a) -> m a -> m a
+catchPermissionDenied = catchIOErrorType PermissionDenied
diff --git a/src/Utility/FileMode.hs b/src/Utility/FileMode.hs
index efef5fa2..bb3780c6 100644
--- a/src/Utility/FileMode.hs
+++ b/src/Utility/FileMode.hs
@@ -18,9 +18,10 @@ import System.PosixCompat.Types
import Utility.PosixFiles
#ifndef mingw32_HOST_OS
import System.Posix.Files
+import Control.Monad.IO.Class (liftIO)
#endif
+import Control.Monad.IO.Class (MonadIO)
import Foreign (complement)
-import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Monad.Catch
import Utility.Exception
diff --git a/src/Utility/FileSystemEncoding.hs b/src/Utility/FileSystemEncoding.hs
index 67341d37..eab98337 100644
--- a/src/Utility/FileSystemEncoding.hs
+++ b/src/Utility/FileSystemEncoding.hs
@@ -19,6 +19,7 @@ module Utility.FileSystemEncoding (
encodeW8NUL,
decodeW8NUL,
truncateFilePath,
+ setConsoleEncoding,
) where
import qualified GHC.Foreign as GHC
@@ -164,3 +165,10 @@ truncateFilePath n = reverse . go [] n . L8.fromString
else go (c:coll) (cnt - x') (L8.drop 1 bs)
_ -> coll
#endif
+
+{- This avoids ghc's output layer crashing on invalid encoded characters in
+ - filenames when printing them out. -}
+setConsoleEncoding :: IO ()
+setConsoleEncoding = do
+ fileEncoding stdout
+ fileEncoding stderr
diff --git a/src/Utility/PosixFiles.hs b/src/Utility/PosixFiles.hs
index 4550bebd..37253da2 100644
--- a/src/Utility/PosixFiles.hs
+++ b/src/Utility/PosixFiles.hs
@@ -1,6 +1,6 @@
{- POSIX files (and compatablity wrappers).
-
- - This is like System.PosixCompat.Files, except with a fixed rename.
+ - This is like System.PosixCompat.Files, but with a few fixes.
-
- Copyright 2014 Joey Hess <id@joeyh.name>
-
@@ -21,6 +21,7 @@ import System.PosixCompat.Files as X hiding (rename)
import System.Posix.Files (rename)
#else
import qualified System.Win32.File as Win32
+import qualified System.Win32.HardLink as Win32
#endif
{- System.PosixCompat.Files.rename on Windows calls renameFile,
@@ -32,3 +33,10 @@ import qualified System.Win32.File as Win32
rename :: FilePath -> FilePath -> IO ()
rename src dest = Win32.moveFileEx src dest Win32.mOVEFILE_REPLACE_EXISTING
#endif
+
+{- System.PosixCompat.Files.createLink throws an error, but windows
+ - does support hard links. -}
+#ifdef mingw32_HOST_OS
+createLink :: FilePath -> FilePath -> IO ()
+createLink = Win32.createHardLink
+#endif
diff --git a/src/Utility/SystemDirectory.hs b/src/Utility/SystemDirectory.hs
new file mode 100644
index 00000000..3dd44d19
--- /dev/null
+++ b/src/Utility/SystemDirectory.hs
@@ -0,0 +1,16 @@
+{- System.Directory without its conflicting isSymbolicLink
+ -
+ - Copyright 2016 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+-- Disable warnings because only some versions of System.Directory export
+-- isSymbolicLink.
+{-# OPTIONS_GHC -fno-warn-tabs -w #-}
+
+module Utility.SystemDirectory (
+ module System.Directory
+) where
+
+import System.Directory hiding (isSymbolicLink)
diff --git a/src/Utility/Tmp.hs b/src/Utility/Tmp.hs
index 7610f6cc..6a541cfe 100644
--- a/src/Utility/Tmp.hs
+++ b/src/Utility/Tmp.hs
@@ -11,9 +11,9 @@
module Utility.Tmp where
import System.IO
-import System.Directory
import Control.Monad.IfElse
import System.FilePath
+import System.Directory
import Control.Monad.IO.Class
#ifndef mingw32_HOST_OS
import System.Posix.Temp (mkdtemp)
diff --git a/src/Utility/UserInfo.hs b/src/Utility/UserInfo.hs
index 7e94cafa..c6010116 100644
--- a/src/Utility/UserInfo.hs
+++ b/src/Utility/UserInfo.hs
@@ -17,9 +17,7 @@ module Utility.UserInfo (
import Utility.Env
import System.PosixCompat
-#ifndef mingw32_HOST_OS
import Control.Applicative
-#endif
import Prelude
{- Current user's home directory.
@@ -58,6 +56,6 @@ myVal envvars extract = go envvars
#ifndef mingw32_HOST_OS
go [] = extract <$> (getUserEntryForID =<< getEffectiveUserID)
#else
- go [] = error $ "environment not set: " ++ show envvars
+ go [] = extract <$> error ("environment not set: " ++ show envvars)
#endif
go (v:vs) = maybe (go vs) return =<< getEnv v