summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2016-04-30 15:47:28 -0400
committerJoey Hess2016-04-30 15:47:28 -0400
commiteb0a945d43c909273ffd9472c091db917ed6c1e2 (patch)
tree0c9f95a3a543cf8fa85dfede4ab565fa00b43736
parent6e09ae96c03ebc589ae9bb647e30de19fbe2f2e7 (diff)
parent60b12654b0746f9c35a38002d34e9ac69f76c738 (diff)
Merge branch 'joeyconfig'
l---------config.hs2
-rw-r--r--debian/changelog7
-rw-r--r--privdata/relocate1
-rw-r--r--propellor.cabal2
-rw-r--r--src/Propellor/Debug.hs2
-rw-r--r--src/Propellor/DotDir.hs2
-rw-r--r--src/Propellor/Engine.hs2
-rw-r--r--src/Propellor/Git.hs2
-rw-r--r--src/Propellor/Gpg.hs2
-rw-r--r--src/Propellor/PrivData.hs2
-rw-r--r--src/Propellor/Property.hs2
-rw-r--r--src/Propellor/Property/Attic.hs103
-rw-r--r--src/Propellor/Property/Chroot/Util.hs1
-rw-r--r--src/Utility/Directory.hs11
-rw-r--r--src/Utility/LinuxMkLibs.hs1
-rw-r--r--src/Utility/Path.hs22
-rw-r--r--src/wrapper.hs2
17 files changed, 118 insertions, 48 deletions
diff --git a/config.hs b/config.hs
index ec313725..97d90636 120000
--- a/config.hs
+++ b/config.hs
@@ -1 +1 @@
-config-simple.hs \ No newline at end of file
+joeyconfig.hs \ No newline at end of file
diff --git a/debian/changelog b/debian/changelog
index ef68886a..58e32205 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,14 +1,15 @@
-propellor (3.0.2) UNRELEASED; urgency=medium
+propellor (3.0.2) unstable; urgency=medium
* Added Apt.periodicUpdates.
Thanks, Félix Sipma.
- * Apt.unattendedUpgrades: Enable mailing problems reports to root.
+ * Apt.unattendedUpgrades: Enable mailing problem reports to root.
Thanks, Félix Sipma.
* Added Propellor.Property.Fstab, and moved the fstabbed property to there.
* Attic module added for the backup system.
Thanks, Félix Sipma.
+ * Fix build with directory-1.2.6.2.
- -- Joey Hess <id@joeyh.name> Tue, 05 Apr 2016 13:48:47 -0400
+ -- Joey Hess <id@joeyh.name> Sat, 30 Apr 2016 15:46:50 -0400
propellor (3.0.1) unstable; urgency=medium
diff --git a/privdata/relocate b/privdata/relocate
new file mode 100644
index 00000000..271692d8
--- /dev/null
+++ b/privdata/relocate
@@ -0,0 +1 @@
+.joeyconfig
diff --git a/propellor.cabal b/propellor.cabal
index 215836ac..78a14c5e 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -1,5 +1,5 @@
Name: propellor
-Version: 3.0.1
+Version: 3.0.2
Cabal-Version: >= 1.8
License: BSD3
Maintainer: Joey Hess <id@joeyh.name>
diff --git a/src/Propellor/Debug.hs b/src/Propellor/Debug.hs
index 790a9a4b..5e729b23 100644
--- a/src/Propellor/Debug.hs
+++ b/src/Propellor/Debug.hs
@@ -2,7 +2,6 @@ module Propellor.Debug where
import Control.Monad.IfElse
import System.IO
-import System.Directory
import System.Log.Logger
import System.Log.Formatter
import System.Log.Handler (setFormatter)
@@ -14,6 +13,7 @@ import Utility.Monad
import Utility.Env
import Utility.Exception
import Utility.Process
+import Utility.Directory
debug :: [String] -> IO ()
debug = debugM "propellor" . unwords
diff --git a/src/Propellor/DotDir.hs b/src/Propellor/DotDir.hs
index 669ac303..f32b52a4 100644
--- a/src/Propellor/DotDir.hs
+++ b/src/Propellor/DotDir.hs
@@ -15,6 +15,7 @@ import Utility.Monad
import Utility.Process
import Utility.SafeCommand
import Utility.Exception
+import Utility.Directory
import Utility.Path
-- This module is autogenerated by the build system.
import qualified Paths_propellor as Package
@@ -24,7 +25,6 @@ import Data.List
import Data.Version
import Control.Monad
import Control.Monad.IfElse
-import System.Directory
import System.FilePath
import System.Posix.Directory
import System.IO
diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index f0035c40..8958da6b 100644
--- a/src/Propellor/Engine.hs
+++ b/src/Propellor/Engine.hs
@@ -17,7 +17,6 @@ import "mtl" Control.Monad.RWS.Strict
import System.PosixCompat
import System.Posix.IO
import System.FilePath
-import System.Directory
import Control.Applicative
import Prelude
@@ -28,6 +27,7 @@ import Propellor.Message
import Propellor.Exception
import Propellor.Info
import Utility.Exception
+import Utility.Directory
-- | Gets the Properties of a Host, and ensures them all,
-- with nice display of what's being done.
diff --git a/src/Propellor/Git.hs b/src/Propellor/Git.hs
index 949f430b..c3257b31 100644
--- a/src/Propellor/Git.hs
+++ b/src/Propellor/Git.hs
@@ -2,8 +2,8 @@ module Propellor.Git where
import Utility.Process
import Utility.Exception
+import Utility.Directory
-import System.Directory
import Control.Applicative
import Prelude
diff --git a/src/Propellor/Gpg.hs b/src/Propellor/Gpg.hs
index 4e6ceb79..b825d743 100644
--- a/src/Propellor/Gpg.hs
+++ b/src/Propellor/Gpg.hs
@@ -1,7 +1,6 @@
module Propellor.Gpg where
import System.IO
-import System.Directory
import Data.Maybe
import Data.List.Utils
import Control.Monad
@@ -19,6 +18,7 @@ import Utility.Misc
import Utility.Tmp
import Utility.FileSystemEncoding
import Utility.Env
+import Utility.Directory
type KeyId = String
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index d3bb3a6d..2e9cdbab 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -26,7 +26,6 @@ module Propellor.PrivData (
) where
import System.IO
-import System.Directory
import Data.Maybe
import Data.List
import Data.Typeable
@@ -59,6 +58,7 @@ import Utility.FileMode
import Utility.Env
import Utility.Table
import Utility.FileSystemEncoding
+import Utility.Directory
-- | Allows a Property to access the value of a specific PrivDataField,
-- for use in a specific Context or HostContext.
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 55c39ee2..af36ed58 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -44,7 +44,6 @@ module Propellor.Property (
, assume
) where
-import System.Directory
import System.FilePath
import Control.Monad
import Data.Monoid
@@ -66,6 +65,7 @@ import Propellor.EnsureProperty
import Utility.Exception
import Utility.Monad
import Utility.Misc
+import Utility.Directory
-- | Makes a perhaps non-idempotent Property be idempotent by using a flag
-- file to indicate whether it has run before.
diff --git a/src/Propellor/Property/Attic.hs b/src/Propellor/Property/Attic.hs
index 0fadc113..26f23500 100644
--- a/src/Propellor/Property/Attic.hs
+++ b/src/Propellor/Property/Attic.hs
@@ -25,6 +25,7 @@ installed = Apt.installed ["attic"]
repoExists :: AtticRepo -> IO Bool
repoExists repo = boolSystem "attic" [Param "list", File repo]
+-- | Inits a new attic repository
init :: AtticRepo -> Property DebianLike
init backupdir = check (not <$> repoExists backupdir) (cmdProperty "attic" initargs)
`requires` installed
@@ -34,45 +35,99 @@ init backupdir = check (not <$> repoExists backupdir) (cmdProperty "attic" inita
, backupdir
]
-restored :: [FilePath] -> AtticRepo -> Property DebianLike
-restored dirs backupdir = cmdProperty "attic" restoreargs
- `assume` MadeChange
- `describe` ("attic restore from " ++ backupdir)
- `requires` installed
+-- | Restores a directory from an attic 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 -> AtticRepo -> Property DebianLike
+restored dir backupdir = go `requires` installed
where
- restoreargs =
- [ "extract"
- , backupdir
- ]
- ++ dirs
+ go :: Property DebianLike
+ go = property (dir ++ " restored by attic") $ ifM (liftIO needsRestore)
+ ( do
+ warningMessage $ dir ++ " is empty/missing; restoring from backup ..."
+ liftIO restore
+ , noChange
+ )
+
+ needsRestore = null <$> catchDefaultIO [] (dirContents dir)
-backup :: [FilePath] -> AtticRepo -> Cron.Times -> [AtticParam] -> [KeepPolicy] -> Property DebianLike
-backup dirs backupdir crontimes extraargs kp = propertyList (backupdir ++ " attic backup") $ props
- & check (not <$> repoExists backupdir) (restored dirs backupdir)
- & Cron.niceJob ("attic_backup" ++ backupdir) crontimes (User "root") "/" backupcmd
+ restore = withTmpDirIn (takeDirectory dir) "attic-restore" $ \tmpdir -> do
+ ok <- boolSystem "attic" $
+ [ 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 attic 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:
+--
+-- > & Attic.backup "/srv/git" "root@myserver:/mnt/backup/git.attic" Cron.Daily
+-- > ["--exclude=/srv/git/tobeignored"]
+-- > [Attic.KeepDays 7, Attic.KeepWeeks 4, Attic.KeepMonths 6, Attic.KeepYears 1]
+--
+-- Note that this property does not make attic encrypt the backup
+-- repository.
+--
+-- Since attic uses a fair amount of system resources, only one attic
+-- backup job will be run at a time. Other jobs will wait their turns to
+-- run.
+backup :: FilePath -> AtticRepo -> Cron.Times -> [AtticParam] -> [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 -> AtticRepo -> Cron.Times -> [AtticParam] -> [KeepPolicy] -> Property DebianLike
+backup' dir backupdir crontimes extraargs kp = cronjob
+ `describe` desc
`requires` installed
where
- backupcmd = intercalate ";"
- [ createCommand
- , pruneCommand
- ]
+ desc = backupdir ++ " attic backup"
+ cronjob = Cron.niceJob ("attic_backup" ++ dir) crontimes (User "root") "/" $
+ "flock " ++ shellEscape lockfile ++ " sh -c " ++ backupcmd
+ lockfile = "/var/lock/propellor-attic.lock"
+ backupcmd = intercalate ";" $
+ createCommand
+ : if null kp then [] else [pruneCommand]
createCommand = unwords $
[ "attic"
, "create"
, "--stats"
]
- ++ extraargs ++
- [ backupdir ++ "::" ++ "$(date --iso-8601=ns --utc)"
- , unwords dirs
+ ++ map shellEscape extraargs ++
+ [ shellEscape backupdir ++ "::" ++ "$(date --iso-8601=ns --utc)"
+ , shellEscape dir
]
pruneCommand = unwords $
[ "attic"
, "prune"
- , backupdir
+ , shellEscape backupdir
]
++
map keepParam kp
+-- | Constructs an AtticParam 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 attic prune to clean out
+-- generations not specified here.
keepParam :: KeepPolicy -> AtticParam
keepParam (KeepHours n) = "--keep-hourly=" ++ show n
keepParam (KeepDays n) = "--keep-daily=" ++ show n
@@ -80,6 +135,10 @@ 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 attic's man page for details.
data KeepPolicy
= KeepHours Int
| KeepDays Int
diff --git a/src/Propellor/Property/Chroot/Util.hs b/src/Propellor/Property/Chroot/Util.hs
index ff227f52..ac703136 100644
--- a/src/Propellor/Property/Chroot/Util.hs
+++ b/src/Propellor/Property/Chroot/Util.hs
@@ -6,7 +6,6 @@ import Utility.Exception
import Utility.Env
import Utility.Directory
-import System.Directory
import Control.Applicative
import Prelude
diff --git a/src/Utility/Directory.hs b/src/Utility/Directory.hs
index fae33b5c..3b12b9fc 100644
--- a/src/Utility/Directory.hs
+++ b/src/Utility/Directory.hs
@@ -6,12 +6,15 @@
-}
{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
+{-# OPTIONS_GHC -fno-warn-tabs -w #-}
-module Utility.Directory where
+module Utility.Directory (
+ module Utility.Directory,
+ module System.Directory
+) where
import System.IO.Error
-import System.Directory
+import System.Directory hiding (isSymbolicLink)
import Control.Monad
import System.FilePath
import Control.Applicative
@@ -134,11 +137,13 @@ moveFile src dest = tryIO (rename src dest) >>= onrename
_ <- tryIO $ removeFile tmp
throwM e'
+#ifndef mingw32_HOST_OS
isdir f = do
r <- tryIO $ getFileStatus f
case r of
(Left _) -> return False
(Right s) -> return $ isDirectory s
+#endif
{- Removes a file, which may or may not exist, and does not have to
- be a regular file.
diff --git a/src/Utility/LinuxMkLibs.hs b/src/Utility/LinuxMkLibs.hs
index fdeb7795..122f3964 100644
--- a/src/Utility/LinuxMkLibs.hs
+++ b/src/Utility/LinuxMkLibs.hs
@@ -14,7 +14,6 @@ import Utility.Monad
import Utility.Path
import Data.Maybe
-import System.Directory
import System.FilePath
import Data.List.Utils
import System.Posix.Files
diff --git a/src/Utility/Path.hs b/src/Utility/Path.hs
index f3290d8d..3ee5ff39 100644
--- a/src/Utility/Path.hs
+++ b/src/Utility/Path.hs
@@ -12,7 +12,6 @@ module Utility.Path where
import Data.String.Utils
import System.FilePath
-import System.Directory
import Data.List
import Data.Maybe
import Data.Char
@@ -29,6 +28,7 @@ import Utility.Exception
import qualified "MissingH" System.Path as MissingH
import Utility.Monad
import Utility.UserInfo
+import Utility.Directory
{- Simplifies a path, removing any "." component, collapsing "dir/..",
- and removing the trailing path separator.
@@ -60,7 +60,7 @@ simplifyPath path = dropTrailingPathSeparator $
{- Makes a path absolute.
-
- The first parameter is a base directory (ie, the cwd) to use if the path
- - is not already absolute.
+ - is not already absolute, and should itsef be absolute.
-
- Does not attempt to deal with edge cases or ensure security with
- untrusted inputs.
@@ -252,15 +252,21 @@ dotfile file
where
f = takeFileName file
-{- Converts a DOS style path to a Cygwin style path. Only on Windows.
- - Any trailing '\' is preserved as a trailing '/' -}
-toCygPath :: FilePath -> FilePath
+{- Converts a DOS style path to a msys2 style path. Only on Windows.
+ - Any trailing '\' is preserved as a trailing '/'
+ -
+ - Taken from: http://sourceforge.net/p/msys2/wiki/MSYS2%20introduction/i
+ -
+ - The virtual filesystem contains:
+ - /c, /d, ... mount points for Windows drives
+ -}
+toMSYS2Path :: FilePath -> FilePath
#ifndef mingw32_HOST_OS
-toCygPath = id
+toMSYS2Path = id
#else
-toCygPath p
+toMSYS2Path p
| null drive = recombine parts
- | otherwise = recombine $ "/cygdrive" : driveletter drive : parts
+ | otherwise = recombine $ "/" : driveletter drive : parts
where
(drive, p') = splitDrive p
parts = splitDirectories p'
diff --git a/src/wrapper.hs b/src/wrapper.hs
index 90f14379..dab77358 100644
--- a/src/wrapper.hs
+++ b/src/wrapper.hs
@@ -13,10 +13,10 @@ import Propellor.DotDir
import Propellor.Message
import Propellor.Bootstrap
import Utility.Monad
+import Utility.Directory
import Utility.Process
import Utility.Process.NonConcurrent
-import System.Directory
import System.Environment (getArgs)
import System.Exit
import System.Posix.Directory