diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,14 @@ +propellor (3.0.4) unstable; urgency=medium + + * Run letsencrypt with --noninteractive. + * Fix build with ghc 8.0.1. + Thanks, davean. + * Module added for the Borg backup system. + Thanks, Félix Sipma. + * Fix build with directory-1.2.6.2. + + -- Joey Hess Sun, 22 May 2016 15:54:49 -0400 + propellor (3.0.3) unstable; urgency=medium * Remove Propellor.DotDir from the propellor library, as its use of diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,14 @@ +propellor (3.0.4) unstable; urgency=medium + + * Run letsencrypt with --noninteractive. + * Fix build with ghc 8.0.1. + Thanks, davean. + * Module added for the Borg backup system. + Thanks, Félix Sipma. + * Fix build with directory-1.2.6.2. + + -- Joey Hess Sun, 22 May 2016 15:54:49 -0400 + propellor (3.0.3) unstable; urgency=medium * Remove Propellor.DotDir from the propellor library, as its use of diff --git a/debian/control b/debian/control --- a/debian/control +++ b/debian/control @@ -20,7 +20,7 @@ libghc-text-dev, libghc-concurrent-output-dev, Maintainer: Joey Hess -Standards-Version: 3.9.6 +Standards-Version: 3.9.8 Vcs-Git: git://git.joeyh.name/propellor Homepage: http://propellor.branchable.com/ diff --git a/propellor.cabal b/propellor.cabal --- a/propellor.cabal +++ b/propellor.cabal @@ -1,7 +1,7 @@ Name: propellor -Version: 3.0.3 +Version: 3.0.4 Cabal-Version: >= 1.8 -License: BSD3 +License: BSD2 Maintainer: Joey Hess Author: Joey Hess Stability: Stable @@ -81,6 +81,7 @@ Propellor.Property.Apt Propellor.Property.Apt.PPA Propellor.Property.Attic + Propellor.Property.Borg Propellor.Property.Cmd Propellor.Property.Concurrent Propellor.Property.Conductor @@ -206,6 +207,7 @@ Utility.Process.NonConcurrent Utility.SafeCommand Utility.Scheduled + Utility.SystemDirectory Utility.Table Utility.ThreadScheduler Utility.Tmp diff --git a/src/Propellor/Base.hs b/src/Propellor/Base.hs --- a/src/Propellor/Base.hs +++ b/src/Propellor/Base.hs @@ -20,7 +20,7 @@ , 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.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 --- a/src/Propellor/PropAccum.hs +++ b/src/Propellor/PropAccum.hs @@ -78,9 +78,3 @@ -> 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 --- a/src/Propellor/Property/Attic.hs +++ b/src/Propellor/Property/Attic.hs @@ -1,4 +1,6 @@ -- | Maintainer: Félix Sipma +-- +-- Support for the Attic backup tool module Propellor.Property.Attic ( installed diff --git a/src/Propellor/Property/Borg.hs b/src/Propellor/Property/Borg.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Borg.hs @@ -0,0 +1,155 @@ +-- | Maintainer: Félix Sipma +-- +-- Support for the Borg backup tool + +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 --- 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 certificates +-- using CertBot module Propellor.Property.LetsEncrypt where @@ -7,6 +8,8 @@ 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 @@ , "--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 --- a/src/Propellor/Property/Obnam.hs +++ b/src/Propellor/Property/Obnam.hs @@ -1,3 +1,5 @@ +-- | Support for the Obnam backup tool + module Propellor.Property.Obnam where import Propellor.Base diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs --- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -135,6 +135,8 @@ & 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 --- 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 diff --git a/src/Utility/Directory.hs b/src/Utility/Directory.hs --- 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 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 --- a/src/Utility/Exception.hs +++ b/src/Utility/Exception.hs @@ -21,7 +21,8 @@ tryNonAsync, tryWhenExists, catchIOErrorType, - IOErrorType(..) + IOErrorType(..), + catchPermissionDenied, ) where import Control.Monad.Catch as X hiding (Handler) @@ -97,3 +98,6 @@ 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 --- a/src/Utility/FileMode.hs +++ b/src/Utility/FileMode.hs @@ -18,9 +18,10 @@ 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 --- a/src/Utility/FileSystemEncoding.hs +++ b/src/Utility/FileSystemEncoding.hs @@ -19,6 +19,7 @@ encodeW8NUL, decodeW8NUL, truncateFilePath, + setConsoleEncoding, ) where import qualified GHC.Foreign as GHC @@ -164,3 +165,10 @@ 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 --- 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 - @@ -21,6 +21,7 @@ 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, @@ -31,4 +32,11 @@ #ifdef mingw32_HOST_OS 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 --- /dev/null +++ b/src/Utility/SystemDirectory.hs @@ -0,0 +1,16 @@ +{- System.Directory without its conflicting isSymbolicLink + - + - Copyright 2016 Joey Hess + - + - 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 --- 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 --- a/src/Utility/UserInfo.hs +++ b/src/Utility/UserInfo.hs @@ -17,9 +17,7 @@ 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 @@ #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