From f70e58b707a93f2977fbba6b98d89441e0ea3b31 Mon Sep 17 00:00:00 2001 From: Félix Sipma Date: Sat, 23 Apr 2016 20:43:17 +0200 Subject: Attic: do not run prune if no KeepPolicy is specified --- src/Propellor/Property/Attic.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/Attic.hs b/src/Propellor/Property/Attic.hs index 0fadc113..9fc79abd 100644 --- a/src/Propellor/Property/Attic.hs +++ b/src/Propellor/Property/Attic.hs @@ -52,10 +52,9 @@ backup dirs backupdir crontimes extraargs kp = propertyList (backupdir ++ " atti & Cron.niceJob ("attic_backup" ++ backupdir) crontimes (User "root") "/" backupcmd `requires` installed where - backupcmd = intercalate ";" - [ createCommand - , pruneCommand - ] + backupcmd = intercalate ";" $ + createCommand + : if null kp then [] else [pruneCommand] createCommand = unwords $ [ "attic" , "create" -- cgit v1.2.3 From 2e513dc98c51eca1cdfce3715b4a017be39734f7 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 28 Apr 2016 15:31:35 -0400 Subject: Fix build with directory-1.2.6.2. It's now exporting a conflicting isSymbolicLink https://github.com/haskell/directory/issues/52 Only a few places in propellor use isSymbolicLink, but to prevent future problems, made as much of it as possible import Utility.Directory, which re-exports System.Directory without the conflicting symbol. (Utility.Tmp and System.Console.Concurrent.Internal cannot import Utility.Directory due to cycles, and don't use isSymbolicLink anyway.) --- debian/changelog | 1 + src/Propellor/Debug.hs | 2 +- src/Propellor/DotDir.hs | 2 +- src/Propellor/Engine.hs | 2 +- src/Propellor/Git.hs | 2 +- src/Propellor/Gpg.hs | 2 +- src/Propellor/PrivData.hs | 2 +- src/Propellor/Property.hs | 2 +- src/Propellor/Property/Chroot/Util.hs | 1 - src/Utility/Directory.hs | 11 ++++++++--- src/Utility/LinuxMkLibs.hs | 1 - src/Utility/Path.hs | 22 ++++++++++++++-------- src/wrapper.hs | 2 +- 13 files changed, 31 insertions(+), 21 deletions(-) (limited to 'src') diff --git a/debian/changelog b/debian/changelog index ef68886a..c6b93e15 100644 --- a/debian/changelog +++ b/debian/changelog @@ -7,6 +7,7 @@ propellor (3.0.2) UNRELEASED; urgency=medium * 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 Tue, 05 Apr 2016 13:48:47 -0400 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/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 -- cgit v1.2.3 From ed52eec11b61d59b7a139b8f55c59961b0806d96 Mon Sep 17 00:00:00 2001 From: Félix Sipma Date: Thu, 28 Apr 2016 21:32:28 +0200 Subject: Attic: 'restored' and 'backup' only take one directory (API change) --- src/Propellor/Property/Attic.hs | 30 +++++++++++++++++++----------- 1 file changed, 19 insertions(+), 11 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/Attic.hs b/src/Propellor/Property/Attic.hs index 9fc79abd..504e3cfb 100644 --- a/src/Propellor/Property/Attic.hs +++ b/src/Propellor/Property/Attic.hs @@ -34,8 +34,9 @@ init backupdir = check (not <$> repoExists backupdir) (cmdProperty "attic" inita , backupdir ] -restored :: [FilePath] -> AtticRepo -> Property DebianLike -restored dirs backupdir = cmdProperty "attic" restoreargs +-- TODO: use restored from Obnam +restored :: FilePath -> AtticRepo -> Property DebianLike +restored dir backupdir = cmdProperty "attic" restoreargs `assume` MadeChange `describe` ("attic restore from " ++ backupdir) `requires` installed @@ -43,15 +44,22 @@ restored dirs backupdir = cmdProperty "attic" restoreargs restoreargs = [ "extract" , backupdir + , dir ] - ++ dirs -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 +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 + +backup' :: FilePath -> AtticRepo -> Cron.Times -> [AtticParam] -> [KeepPolicy] -> Property DebianLike +backup' dir backupdir crontimes extraargs kp = cronjob + `describe` desc `requires` installed where + 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] @@ -60,14 +68,14 @@ backup dirs backupdir crontimes extraargs kp = propertyList (backupdir ++ " atti , "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 -- cgit v1.2.3 From 67cb5eaecccddf65ecbd949aad6e82f6694ad4e5 Mon Sep 17 00:00:00 2001 From: Félix Sipma Date: Fri, 29 Apr 2016 11:21:02 +0200 Subject: Attic: use/adapt restored from Obnam --- src/Propellor/Property/Attic.hs | 35 +++++++++++++++++++++++++---------- 1 file changed, 25 insertions(+), 10 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/Attic.hs b/src/Propellor/Property/Attic.hs index 504e3cfb..ef74afbd 100644 --- a/src/Propellor/Property/Attic.hs +++ b/src/Propellor/Property/Attic.hs @@ -34,18 +34,33 @@ init backupdir = check (not <$> repoExists backupdir) (cmdProperty "attic" inita , backupdir ] --- TODO: use restored from Obnam restored :: FilePath -> AtticRepo -> Property DebianLike -restored dir backupdir = cmdProperty "attic" restoreargs - `assume` MadeChange - `describe` ("attic restore from " ++ backupdir) - `requires` installed +restored dir backupdir = go `requires` installed where - restoreargs = - [ "extract" - , backupdir - , dir - ] + 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) + + 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 + ) backup :: FilePath -> AtticRepo -> Cron.Times -> [AtticParam] -> [KeepPolicy] -> Property DebianLike backup dir backupdir crontimes extraargs kp = backup' dir backupdir crontimes extraargs kp -- cgit v1.2.3 From 9adfb7560fcd1186153bd743f885c12753abc9e5 Mon Sep 17 00:00:00 2001 From: Félix Sipma Date: Fri, 29 Apr 2016 11:33:23 +0200 Subject: Attic: add comments --- src/Propellor/Property/Attic.hs | 37 +++++++++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) (limited to 'src') diff --git a/src/Propellor/Property/Attic.hs b/src/Propellor/Property/Attic.hs index ef74afbd..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,6 +35,13 @@ init backupdir = check (not <$> repoExists backupdir) (cmdProperty "attic" inita , backupdir ] +-- | 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 @@ -62,10 +70,31 @@ restored dir backupdir = go `requires` installed , 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 @@ -95,6 +124,10 @@ backup' dir backupdir crontimes extraargs kp = cronjob ++ 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 @@ -102,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 -- cgit v1.2.3