propellor

propellor config for hosts.
git clone git://git.ricketyspace.net/propellor.git
Log | Files | Refs | LICENSE

commit bcdcdefa142e62ca96ccbfd824bf81f947129ebf
parent 8e09f7a041b066cbe859d2b8e154ea1ec291eef4
Author: rsiddharth <s@ricketyspace.net>
Date:   Thu,  9 Nov 2017 05:05:58 +0000

Merge remote-tracking branch 'upstream/master'

Diffstat:
debian/changelog | 70++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
debian/control | 5+----
joeyconfig.hs | 72++++++++++++++++++++++++++++++++++--------------------------------------
propellor.cabal | 3++-
src/Propellor/Bootstrap.hs | 2+-
src/Propellor/Engine.hs | 1+
src/Propellor/Info.hs | 28+++++++++++++++++++---------
src/Propellor/Property/Apt.hs | 4+++-
src/Propellor/Property/Attic.hs | 4++--
src/Propellor/Property/Borg.hs | 92+++++++++++++++++++++++++++++++++++++++++++++++++++++++++----------------------
src/Propellor/Property/Chroot.hs | 4++--
src/Propellor/Property/Chroot/Util.hs | 5-----
src/Propellor/Property/Debootstrap.hs | 2+-
src/Propellor/Property/DiskImage.hs | 104+++++++++++++++++++++++++++++++++++++++++++++++++++----------------------------
src/Propellor/Property/Dns.hs | 6+++---
src/Propellor/Property/Fstab.hs | 3++-
src/Propellor/Property/Lvm.hs | 171+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/Propellor/Property/Obnam.hs | 2+-
src/Propellor/Property/Partition.hs | 14++++++++++++++
src/Propellor/Property/PropellorRepo.hs | 30+++++++++++++++++++-----------
src/Propellor/Property/Restic.hs | 2+-
src/Propellor/Property/Sbuild.hs | 4++--
src/Propellor/Property/SiteSpecific/Branchable.hs | 30+++++++++++++++++++-----------
src/Propellor/Property/SiteSpecific/JoeySites.hs | 96+++++++++++++++++++++++++++----------------------------------------------------
src/Propellor/Spin.hs | 13+++++++++----
src/Propellor/Types/Dns.hs | 33+++++++++++++++++++++++++++------
src/Propellor/Types/Info.hs | 8+++-----
src/Utility/Directory.hs | 19+++++++++++++++++--
28 files changed, 591 insertions(+), 236 deletions(-)

diff --git a/debian/changelog b/debian/changelog @@ -1,3 +1,73 @@ +propellor (4.9.0-1) unstable; urgency=medium + + * Package new upstream release. + + -- Sean Whitton <spwhitton@spwhitton.name> Thu, 26 Oct 2017 12:55:35 -0700 + +propellor (4.9.0) unstable; urgency=medium + + * When the ipv4 and ipv6 properties are used with a container, avoid + propagating the address out to the host. + * DnsInfo has been replaced with DnsInfoPropagated and + DnsInfoUnpropagated. (API change) + * Code that used fromDnsInfo . fromInfo changes to use getDnsInfo. + * addDNS takes an additional Bool parameter to control whether + the DNS info should propagate out of containers. (API change) + * Made the PropellorRepo.hasOriginUrl property override the repository + url that --spin passes to a host. + * PropellorRepo.hasOriginUrl type changed to include HasInfo. (API change) + * Fstab.mounted: Create mount point if necessary, and mount it + if it's not already mounted. + Thanks, Nicolas Schodet + * Properties that check for an empty directory now treat a directory + containing only "lost+found" as effectively empty, to support + situations where the directory is a mount point of an EXT* filesystem. + Thanks, Nicolas Schodet + * Make addInfo accumulate Info in order properties appear, not + reverse order. + This fixes a bug involving reverting Systemd.resolvConfed or + Systemd.linkJournal. + + -- Joey Hess <id@joeyh.name> Wed, 25 Oct 2017 13:02:14 -0400 + +propellor (4.8.1-1) unstable; urgency=medium + + * Package new upstream release. + * Bump standards version to 4.1.0 (no changes required). + + -- Sean Whitton <spwhitton@spwhitton.name> Wed, 27 Sep 2017 16:25:39 -0700 + +propellor (4.8.1) unstable; urgency=medium + + * Borg: Fix propigation of exit status of borg backup. + * Borg: Fix handling of UseSshKey. + + -- Joey Hess <id@joeyh.name> Mon, 25 Sep 2017 17:19:49 -0400 + +propellor (4.8.0) unstable; urgency=medium + + * DiskImage: Made a DiskImage type class, so that different disk image + formats can be implemented. The properties in this module can generate + any type that is a member of DiskImage. (API change) + (To convert existing configs, convert the filename of the disk image + to RawDiskImage filename.) + * Removed DiskImage.vmdkBuiltFor property. (API change) + Instead, use VirtualBoxPointer in the property that creates the disk + image. + * Apt.isInstalled: Fix handling of packages that are not known at all + to apt. + * Borg: Converted BorgRepo from a String alias to a data type. + (API change) + * Borg: Allow specifying ssh private key to use when accessing a borg + repo by using the BorgRepoUsing constructor with UseSshKey. + * Borg: Fix broken shell escaping in borg cron job. + * Attic: Fix broken shell escaping in attic cron job. + * Make lock file descriptors close-on-exec. + * Lvm: New module for setting up LVM volumes. + Thanks, Nicolas Schodet + + -- Joey Hess <id@joeyh.name> Mon, 25 Sep 2017 14:37:52 -0400 + propellor (4.7.7-1) unstable; urgency=medium * Package new upstream release. diff --git a/debian/control b/debian/control @@ -12,8 +12,6 @@ Build-Depends: libghc-ansi-terminal-prof, libghc-async-dev, libghc-async-prof, - libghc-concurrent-output-dev, - libghc-concurrent-output-prof, libghc-exceptions-dev (>= 0.6), libghc-exceptions-prof (>= 0.6), libghc-hashable-dev, @@ -37,7 +35,7 @@ Build-Depends: libghc-unix-compat-dev, libghc-unix-compat-prof, Maintainer: Sean Whitton <spwhitton@spwhitton.name> -Standards-Version: 4.0.1 +Standards-Version: 4.1.0 Homepage: https://propellor.branchable.com/ Vcs-Git: https://git.spwhitton.name/propellor -b debian Vcs-Browser: https://git.spwhitton.name/propellor @@ -114,7 +112,6 @@ Depends: git (>= 1:2.9), libghc-ansi-terminal-dev, libghc-async-dev, - libghc-concurrent-output-dev, libghc-exceptions-dev (>= 0.6), libghc-hashable-dev, libghc-hslogger-dev, diff --git a/joeyconfig.hs b/joeyconfig.hs @@ -24,7 +24,7 @@ import qualified Propellor.Property.Postfix as Postfix import qualified Propellor.Property.Apache as Apache import qualified Propellor.Property.LetsEncrypt as LetsEncrypt import qualified Propellor.Property.Grub as Grub -import qualified Propellor.Property.Obnam as Obnam +import qualified Propellor.Property.Borg as Borg import qualified Propellor.Property.Gpg as Gpg import qualified Propellor.Property.Systemd as Systemd import qualified Propellor.Property.Journald as Journald @@ -94,12 +94,11 @@ darkstar = host "darkstar.kitenet.net" $ props & Ssh.userKeys (User "joey") hostContext [ (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQC1YoyHxZwG5Eg0yiMTJLSWJ/+dMM6zZkZiR4JJ0iUfP+tT2bm/lxYompbSqBeiCq+PYcSC67mALxp1vfmdOV//LWlbXfotpxtyxbdTcQbHhdz4num9rJQz1tjsOsxTEheX5jKirFNC5OiKhqwIuNydKWDS9qHGqsKcZQ8p+n1g9Lr3nJVGY7eRRXzw/HopTpwmGmAmb9IXY6DC2k91KReRZAlOrk0287LaK3eCe1z0bu7LYzqqS+w99iXZ/Qs0m9OqAPnHZjWQQ0fN4xn5JQpZSJ7sqO38TBAimM+IHPmy2FTNVVn9zGM+vN1O2xr3l796QmaUG1+XLL0shfR/OZbb joey@darkstar") ] - & imageBuilt "/srv/test.img" mychroot MSDOS + & imageBuilt (VirtualBoxPointer "/srv/test.vmdk") mychroot MSDOS [ partition EXT2 `mountedAt` "/boot" , partition EXT4 `mountedAt` "/" , swapPartition (MegaBytes 256) ] - `before` vmdkBuiltFor "/srv/test.img" where mychroot d = debootstrapped mempty d $ props & osDebian Unstable X86_64 @@ -131,6 +130,7 @@ clam = host "clam.kitenet.net" $ props & Apt.unattendedUpgrades & Systemd.persistentJournal & Journald.systemMaxUse "50MiB" + & Apt.serviceInstalledRunning "swapspace" & Tor.isRelay & Tor.named "kite1" @@ -230,7 +230,7 @@ kite :: Host kite = host "kite.kitenet.net" $ props & standardSystemUnhardened Testing X86_64 [ "Welcome to kite!" ] & ipv4 "66.228.36.95" - -- & ipv6 "2600:3c03::f03c:91ff:fe73:b0d2" + & ipv6 "2600:3c03::f03c:91ff:fe73:b0d2" & alias "kitenet.net" & alias "wren.kitenet.net" -- temporary & Ssh.hostKeys (Context "kitenet.net") @@ -254,30 +254,28 @@ kite = host "kite.kitenet.net" $ props & Ssh.setSshdConfig "GatewayPorts" "clientspecified" & Apt.serviceInstalledRunning "ntp" & "/etc/timezone" `File.hasContent` ["US/Eastern"] - - & Obnam.backupEncrypted "/" (Cron.Times "33 1 * * *") - [ "--repository=sftp://2318@usw-s002.rsync.net/~/kite-root.obnam" - , "--client-name=kitenet.net" - , "--exclude=/home" - , "--exclude=/var/cache" - , "--exclude=/var/tmp" + + & Borg.backup "/" (Borg.BorgRepo "joey@eubackup.kitenet.net:/home/joey/lib/backup/kite/kite.borg") Cron.Daily + [ "--exclude=/proc/*" + , "--exclude=/sys/*" + , "--exclude=/run/*" + , "--exclude=/tmp/*" + , "--exclude=/var/tmp/*" + , "--exclude=/var/cache/*" + , "--exclude=/home/joey/lib" + -- These directories are backed up and restored separately. , "--exclude=/srv/git" , "--exclude=/var/spool/oldusenet" - , "--exclude=.*/tmp/" - , "--one-file-system" - , Obnam.keepParam [Obnam.KeepDays 7, Obnam.KeepWeeks 4, Obnam.KeepMonths 6] - ] Obnam.OnlyClient (Gpg.GpgKeyId "98147487") - `requires` rootsshkey - `requires` Ssh.knownHost hosts "usw-s002.rsync.net" (User "root") - & Obnam.backupEncrypted "/home" (Cron.Times "33 3 * * *") - [ "--repository=sftp://2318@usw-s002.rsync.net/~/kite-home.obnam" - , "--client-name=kitenet.net" - , "--exclude=/home/joey/lib" - , "--one-file-system" - , Obnam.keepParam [Obnam.KeepDays 7, Obnam.KeepWeeks 4, Obnam.KeepMonths 6] - ] Obnam.OnlyClient (Gpg.GpgKeyId "98147487") - `requires` rootsshkey - `requires` Ssh.knownHost hosts "usw-s002.rsync.net" (User "root") + ] + [ Borg.KeepDays 7 + , Borg.KeepWeeks 4 + , Borg.KeepMonths 6 + ] + `requires` Ssh.knownHost hosts "eubackup.kitenet.net" (User "root") + `requires` Ssh.userKeys (User "root") + (Context "kite.kitenet.net") + [ (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQC5Gza2sNqSKfNtUN4dN/Z3rlqw18nijmXFx6df2GtBoZbkIak73uQfDuZLP+AXlyfHocwdkdHEf/zrxgXS4EokQMGLZhJ37Pr3edrEn/NEnqroiffw7kyd7EqaziA6UOezcLTjWGv+Zqg9JhitYs4WWTpNzrPH3yQf1V9FunZnkzb4gJGndts13wGmPEwSuf+QHbgQvjMOMCJwWSNcJGdhDR66hFlxfG26xx50uIczXYAbgLfHp5W6WuR/lcaS9J6i7HAPwcsPDA04XDinrcpl29QwsMW1HyGS/4FSCgrDqNZ2jzP49Bka78iCLRqfl1efyYas/Zo1jQ0x+pxq2RMr root@kite") + ] & alias "smtp.kitenet.net" & alias "imap.kitenet.net" @@ -334,7 +332,13 @@ kite = host "kite.kitenet.net" $ props & alias "ns4.branchable.com" & branchableSecondary & Dns.secondaryFor ["animx"] hosts "animx.eu.org" - + -- Use its own name server (amoung other things this avoids + -- spamassassin URIBL_BLOCKED. + & "/etc/resolv.conf" `File.hasContent` + [ "nameserver 127.0.0.1" + , "domain kitenet.net" + , "search kitenet.net" + ] & alias "debug-me.joeyh.name" -- debug-me installed manually until package is available & Systemd.enabled "debug-me" @@ -344,10 +348,6 @@ kite = host "kite.kitenet.net" $ props (LetsEncrypt.AgreeTOS (Just "id@joeyh.name")) & alias "letsencrypt.joeyh.name" where - rootsshkey = Ssh.userKeys (User "root") - (Context "kite.kitenet.net") - [ (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQC5Gza2sNqSKfNtUN4dN/Z3rlqw18nijmXFx6df2GtBoZbkIak73uQfDuZLP+AXlyfHocwdkdHEf/zrxgXS4EokQMGLZhJ37Pr3edrEn/NEnqroiffw7kyd7EqaziA6UOezcLTjWGv+Zqg9JhitYs4WWTpNzrPH3yQf1V9FunZnkzb4gJGndts13wGmPEwSuf+QHbgQvjMOMCJwWSNcJGdhDR66hFlxfG26xx50uIczXYAbgLfHp5W6WuR/lcaS9J6i7HAPwcsPDA04XDinrcpl29QwsMW1HyGS/4FSCgrDqNZ2jzP49Bka78iCLRqfl1efyYas/Zo1jQ0x+pxq2RMr root@kite") - ] elephant :: Host elephant = host "elephant.kitenet.net" $ props @@ -374,8 +374,7 @@ elephant = host "elephant.kitenet.net" $ props & Apt.serviceInstalledRunning "swapspace" & alias "eubackup.kitenet.net" - & Apt.installed ["obnam", "sshfs", "rsync"] - & JoeySites.obnamRepos ["pell", "kite"] + & Apt.installed ["sshfs", "rsync", "borgbackup"] & JoeySites.githubBackup & JoeySites.rsyncNetBackup hosts @@ -387,9 +386,6 @@ elephant = host "elephant.kitenet.net" $ props & alias "kgb.kitenet.net" & JoeySites.kgbServer - & alias "mumble.kitenet.net" - & JoeySites.mumbleServer hosts - & alias "ns3.kitenet.net" & myDnsSecondary @@ -453,8 +449,8 @@ pell = host "pell.branchable.com" $ props & alias "dist-bugs.kitenet.net" & alias "family.kitenet.net" - & osDebian (Stable "jessie") X86_64 - & Apt.installed ["linux-image-amd64"] + & osDebian (Stable "stretch") X86_64 + & Apt.installed ["linux-image-686-pae"] & Apt.unattendedUpgrades & Branchable.server hosts & Linode.serialGrub diff --git a/propellor.cabal b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 4.7.7 +Version: 4.9.0 Cabal-Version: >= 1.20 License: BSD2 Maintainer: Joey Hess <id@joeyh.name> @@ -127,6 +127,7 @@ Library Propellor.Property.LightDM Propellor.Property.Locale Propellor.Property.Logcheck + Propellor.Property.Lvm Propellor.Property.Mount Propellor.Property.Network Propellor.Property.Nginx diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs @@ -133,9 +133,9 @@ depsCommand bs msys = "( " ++ intercalate " ; " (go bs) ++ ") || true" pkginstall p = "ASSUME_ALWAYS_YES=yes pkg install " ++ p pacmaninstall p = "pacman -S --noconfirm --needed " ++ p - -- This is the same deps listed in debian/control. debdeps Cabal = [ "gnupg" + -- Below are the same deps listed in debian/control. , "ghc" , "cabal-install" , "libghc-async-dev" diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs @@ -97,6 +97,7 @@ onlyProcess lockfile a = bracket lock unlock (const a) lock = do createDirectoryIfMissing True (takeDirectory lockfile) l <- createFile lockfile stdFileMode + setFdOption l CloseOnExec True setLock l (WriteLock, AbsoluteSeek, 0, 0) `catchIO` const alreadyrunning return l diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs @@ -128,11 +128,11 @@ getOS = fromInfoVal <$> askInfo -- if the host's IP Property matches the DNS. If the DNS is missing or -- out of date, the host will instead be contacted directly by IP address. ipv4 :: String -> Property (HasInfo + UnixLike) -ipv4 = addDNS . Address . IPv4 +ipv4 = addDNS False . Address . IPv4 -- | Indicate that a host has an AAAA record in the DNS. ipv6 :: String -> Property (HasInfo + UnixLike) -ipv6 = addDNS . Address . IPv6 +ipv6 = addDNS False . Address . IPv6 -- | Indicates another name for the host in the DNS. -- @@ -145,19 +145,29 @@ alias d = pureInfoProperty' ("alias " ++ d) $ mempty `addInfo` toAliasesInfo [d] -- A CNAME is added here, but the DNS setup code converts it to an -- IP address when that makes sense. - `addInfo` (toDnsInfo $ S.singleton $ CNAME $ AbsDomain d) - -addDNS :: Record -> Property (HasInfo + UnixLike) -addDNS r = pureInfoProperty (rdesc r) (toDnsInfo (S.singleton r)) + `addInfo` (toDnsInfoPropagated $ S.singleton $ CNAME $ AbsDomain d) + +-- | Add a DNS Record. +addDNS + :: Bool + -- ^ When used in a container, the DNS info will only + -- propagate out the the Host when this is True. + -> Record + -> Property (HasInfo + UnixLike) +addDNS prop r + | prop = pureInfoProperty (rdesc r) (toDnsInfoPropagated s) + | otherwise = pureInfoProperty (rdesc r) (toDnsInfoUnpropagated s) where + s = S.singleton r + rdesc (CNAME d) = unwords ["alias", ddesc d] rdesc (Address (IPv4 addr)) = unwords ["ipv4", addr] rdesc (Address (IPv6 addr)) = unwords ["ipv6", addr] rdesc (MX n d) = unwords ["MX", show n, ddesc d] rdesc (NS d) = unwords ["NS", ddesc d] - rdesc (TXT s) = unwords ["TXT", s] + rdesc (TXT t) = unwords ["TXT", t] rdesc (SRV x y z d) = unwords ["SRV", show x, show y, show z, ddesc d] - rdesc (SSHFP x y s) = unwords ["SSHFP", show x, show y, s] + rdesc (SSHFP x y t) = unwords ["SSHFP", show x, show y, t] rdesc (INCLUDE f) = unwords ["$INCLUDE", f] rdesc (PTR x) = unwords ["PTR", x] @@ -182,7 +192,7 @@ findAlias :: [Host] -> HostName -> Maybe Host findAlias l hn = M.lookup hn (aliasMap l) getAddresses :: Info -> [IPAddr] -getAddresses = mapMaybe getIPAddr . S.toList . fromDnsInfo . fromInfo +getAddresses = mapMaybe getIPAddr . S.toList . getDnsInfo hostAddresses :: HostName -> [Host] -> [IPAddr] hostAddresses hn hosts = maybe [] (getAddresses . hostInfo) (findHost hosts hn) diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs @@ -331,7 +331,9 @@ isInstalled :: Package -> IO Bool isInstalled p = isInstalled' [p] isInstalled' :: [Package] -> IO Bool -isInstalled' ps = all (== IsInstalled) <$> getInstallStatus ps +isInstalled' ps = do + is <- getInstallStatus ps + return $ all (== IsInstalled) is && length is == length ps data InstallStatus = IsInstalled | NotInstalled deriving (Show, Eq) diff --git a/src/Propellor/Property/Attic.hs b/src/Propellor/Property/Attic.hs @@ -59,7 +59,7 @@ restored dir backupdir = go `requires` installed , noChange ) - needsRestore = null <$> catchDefaultIO [] (dirContents dir) + needsRestore = isUnpopulated dir restore = withTmpDirIn (takeDirectory dir) "attic-restore" $ \tmpdir -> do ok <- boolSystem "attic" $ @@ -108,7 +108,7 @@ backup' dir backupdir crontimes extraargs kp = cronjob where desc = backupdir ++ " attic backup" cronjob = Cron.niceJob ("attic_backup" ++ dir) crontimes (User "root") "/" $ - "flock " ++ shellEscape lockfile ++ " sh -c " ++ backupcmd + "flock " ++ shellEscape lockfile ++ " sh -c " ++ shellEscape backupcmd lockfile = "/var/lock/propellor-attic.lock" backupcmd = intercalate ";" $ createCommand diff --git a/src/Propellor/Property/Borg.hs b/src/Propellor/Property/Borg.hs @@ -3,7 +3,10 @@ -- Support for the Borg backup tool <https://github.com/borgbackup> module Propellor.Property.Borg - ( installed + ( BorgParam + , BorgRepo(..) + , BorgRepoOpt(..) + , installed , repoExists , init , restored @@ -17,9 +20,39 @@ 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 -type BorgRepo = FilePath +-- | 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 + +repoLoc :: BorgRepo -> String +repoLoc (BorgRepo s) = s +repoLoc (BorgRepoUsing _ s) = s + +runBorg :: BorgRepo -> [CommandParam] -> IO Bool +runBorg repo ps = case runBorgEnv repo of + [] -> boolSystem "borg" ps + environ -> do + environ' <- addEntries environ <$> getEnvironment + boolSystemEnv "borg" ps (Just environ') + +runBorgEnv :: BorgRepo -> [(String, String)] +runBorgEnv (BorgRepo _) = [] +runBorgEnv (BorgRepoUsing os _) = map go os + where + go (UseSshKey k) = ("BORG_RSH", "ssh -i " ++ k) installed :: Property DebianLike installed = withOS desc $ \w o -> case o of @@ -31,19 +64,20 @@ installed = withOS desc $ \w o -> case o of desc = "installed borgbackup" repoExists :: BorgRepo -> IO Bool -repoExists repo = boolSystem "borg" [Param "list", File repo] +repoExists repo = runBorg repo [Param "list", Param (repoLoc repo)] -- | Inits a new borg repository init :: BorgRepo -> Property DebianLike -init backupdir = check (not <$> repoExists backupdir) (cmdProperty "borg" initargs) - `requires` installed +init repo = check (not <$> repoExists repo) + (cmdPropertyEnv "borg" initargs (runBorgEnv repo)) + `requires` installed where initargs = [ "init" - , backupdir + , repoLoc repo ] --- | Restores a directory from an borg backup. +-- | Restores a directory from a borg backup. -- -- Only does anything if the directory does not exist, or exists, -- but is completely empty. @@ -51,7 +85,7 @@ init backupdir = check (not <$> repoExists backupdir) (cmdProperty "borg" initar -- 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 +restored dir repo = go `requires` installed where go :: Property DebianLike go = property (dir ++ " restored by borg") $ ifM (liftIO needsRestore) @@ -61,12 +95,12 @@ restored dir backupdir = go `requires` installed , noChange ) - needsRestore = null <$> catchDefaultIO [] (dirContents dir) + needsRestore = isUnpopulated dir restore = withTmpDirIn (takeDirectory dir) "borg-restore" $ \tmpdir -> do - ok <- boolSystem "borg" $ + ok <- runBorg repo $ [ Param "extract" - , Param backupdir + , Param (repoLoc repo) , Param tmpdir ] let restoreddir = tmpdir ++ "/" ++ dir @@ -88,53 +122,61 @@ restored dir backupdir = go `requires` installed -- 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 +-- > & 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 make borg encrypt the backup --- repository. +-- 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 dir backupdir crontimes extraargs kp = backup' dir backupdir crontimes extraargs kp - `requires` restored dir backupdir +backup dir repo crontimes extraargs kp = backup' dir repo crontimes extraargs kp + `requires` restored dir repo -- | Does a backup, but does not automatically restore. backup' :: FilePath -> BorgRepo -> Cron.Times -> [BorgParam] -> [KeepPolicy] -> Property DebianLike -backup' dir backupdir crontimes extraargs kp = cronjob +backup' dir repo crontimes extraargs kp = cronjob `describe` desc `requires` installed where - desc = backupdir ++ " borg backup" + desc = repoLoc repo ++ " borg backup" cronjob = Cron.niceJob ("borg_backup" ++ dir) crontimes (User "root") "/" $ - "flock " ++ shellEscape lockfile ++ " sh -c " ++ backupcmd + "flock " ++ shellEscape lockfile ++ " sh -c " ++ shellEscape backupcmd lockfile = "/var/lock/propellor-borg.lock" - backupcmd = intercalate ";" $ - createCommand - : if null kp then [] else [pruneCommand] + backupcmd = intercalate "&&" $ concat + [ concatMap exportenv (runBorgEnv repo) + , [createCommand] + , if null kp then [] else [pruneCommand] + ] + exportenv (k, v) = + [ k ++ "=" ++ shellEscape v + , "export " ++ k + ] createCommand = unwords $ [ "borg" , "create" , "--stats" ] ++ map shellEscape extraargs ++ - [ shellEscape backupdir ++ "::" ++ "$(date --iso-8601=ns --utc)" + [ shellEscape (repoLoc repo) ++ "::" ++ "$(date --iso-8601=ns --utc)" , shellEscape dir ] pruneCommand = unwords $ [ "borg" , "prune" - , shellEscape backupdir + , shellEscape (repoLoc repo) ] ++ 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 +-- passed to the `backup` property, it will run borg prune to clean out -- generations not specified here. keepParam :: KeepPolicy -> BorgParam keepParam (KeepHours n) = "--keep-hourly=" ++ val n diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs @@ -77,7 +77,7 @@ instance ChrootBootstrapper ChrootTarball where tightenTargets $ extractTarball loc tb extractTarball :: FilePath -> FilePath -> Property UnixLike -extractTarball target src = check (unpopulated target) $ +extractTarball target src = check (isUnpopulated target) $ cmdProperty "tar" params `assume` MadeChange `requires` File.dirExists target @@ -151,7 +151,7 @@ provisioned' c@(Chroot loc bootstrapper infopropigator _) systemdonly = cantbuild e = property (chrootDesc c "built") (error e) teardown :: Property Linux - teardown = check (not <$> unpopulated loc) $ + teardown = check (not <$> isUnpopulated loc) $ property ("removed " ++ loc) $ makeChange (removeChroot loc) diff --git a/src/Propellor/Property/Chroot/Util.hs b/src/Propellor/Property/Chroot/Util.hs @@ -2,7 +2,6 @@ module Propellor.Property.Chroot.Util where import Propellor.Property.Mount -import Utility.Exception import Utility.Env import Utility.Directory @@ -27,7 +26,3 @@ removeChroot :: FilePath -> IO () removeChroot c = do unmountBelow c removeDirectoryRecursive c - --- | Returns true if a chroot directory is empty. -unpopulated :: FilePath -> IO Bool -unpopulated d = null <$> catchDefaultIO [] (dirContents d) diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs @@ -54,7 +54,7 @@ built' :: Property Linux -> FilePath -> System -> DebootstrapConfig -> Property built' installprop target system@(System _ arch) config = go `before` oldpermfix where - go = check (unpopulated target <||> ispartial) setupprop + go = check (isUnpopulated target <||> ispartial) setupprop `requires` installprop setupprop :: Property Linux diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs @@ -8,12 +8,13 @@ module Propellor.Property.DiskImage ( -- * Partition specification module Propellor.Property.DiskImage.PartSpec, -- * Properties - DiskImage, + DiskImage(..), + RawDiskImage(..), + VirtualBoxPointer(..), imageBuilt, imageRebuilt, imageBuiltFrom, imageExists, - vmdkBuiltFor, Grub.BIOS(..), ) where @@ -42,7 +43,48 @@ import qualified Data.Map.Strict as M import qualified Data.ByteString.Lazy as L import System.Posix.Files -type DiskImage = FilePath +-- | Type class of disk image formats. +class DiskImage d where + -- | Get the location where the raw disk image should be stored. + rawDiskImage :: d -> RawDiskImage + -- | Describe the disk image (for display to the user) + describeDiskImage :: d -> String + -- | Convert the raw disk image file in the + -- `rawDiskImage` location into the desired disk image format. + -- For best efficiency, the raw disk imasge file should be left + -- unchanged on disk. + buildDiskImage :: d -> RevertableProperty DebianLike Linux + +-- | A raw disk image, that can be written directly out to a disk. +newtype RawDiskImage = RawDiskImage FilePath + +instance DiskImage RawDiskImage where + rawDiskImage = id + describeDiskImage (RawDiskImage f) = f + buildDiskImage (RawDiskImage _) = doNothing <!> doNothing + +-- | A virtualbox .vmdk file, which contains a pointer to the raw disk +-- image. This can be built very quickly. +newtype VirtualBoxPointer = VirtualBoxPointer FilePath + +instance DiskImage VirtualBoxPointer where + rawDiskImage (VirtualBoxPointer f) = RawDiskImage $ + dropExtension f ++ ".img" + describeDiskImage (VirtualBoxPointer f) = f + buildDiskImage (VirtualBoxPointer vmdkfile) = (setup <!> cleanup) + `describe` (vmdkfile ++ " built") + where + setup = cmdProperty "VBoxManage" + [ "internalcommands", "createrawvmdk" + , "-filename", vmdkfile + , "-rawdisk", diskimage + ] + `changesFile` vmdkfile + `onChange` File.mode vmdkfile (combineModes (ownerWriteMode : readModes)) + `requires` Apt.installed ["virtualbox"] + `requires` File.notPresent vmdkfile + cleanup = tightenTargets $ File.notPresent vmdkfile + RawDiskImage diskimage = rawDiskImage (VirtualBoxPointer vmdkfile) -- | Creates a bootable disk image. -- @@ -70,7 +112,7 @@ type DiskImage = FilePath -- > import Propellor.Property.Chroot -- > -- > foo = host "foo.example.com" $ props --- > & imageBuilt "/srv/diskimages/disk.img" mychroot +-- > & imageBuilt (RawDiskImage "/srv/diskimages/disk.img") mychroot -- > MSDOS -- > [ partition EXT2 `mountedAt` "/boot" -- > `setFlag` BootFlag @@ -95,7 +137,7 @@ type DiskImage = FilePath -- -- > foo :: Host -- > foo = host "foo.example.com" $ props --- > & imageBuilt "/srv/diskimages/bar-disk.img" +-- > & imageBuilt (RawDiskImage "/srv/diskimages/bar-disk.img") -- > (hostChroot bar (Debootstrapped mempty)) -- > MSDOS -- > [ partition EXT2 `mountedAt` "/boot" @@ -111,30 +153,31 @@ type DiskImage = FilePath -- > & Apt.installed ["linux-image-amd64"] -- > & Grub.installed PC -- > & hasPassword (User "root") -imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux +imageBuilt :: DiskImage d => d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux imageBuilt = imageBuilt' False -- | Like 'built', but the chroot is deleted and rebuilt from scratch each -- time. This is more expensive, but useful to ensure reproducible results -- when the properties of the chroot have been changed. -imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux +imageRebuilt :: DiskImage d => d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux imageRebuilt = imageBuilt' True -imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux +imageBuilt' :: DiskImage d => Bool -> d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux imageBuilt' rebuild img mkchroot tabletype partspec = imageBuiltFrom img chrootdir tabletype final partspec `requires` Chroot.provisioned chroot `requires` (cleanrebuild <!> (doNothing :: Property UnixLike)) `describe` desc where - desc = "built disk image " ++ img + desc = "built disk image " ++ describeDiskImage img + RawDiskImage imgfile = rawDiskImage img cleanrebuild :: Property Linux cleanrebuild | rebuild = property desc $ do liftIO $ removeChroot chrootdir return MadeChange | otherwise = doNothing - chrootdir = img ++ ".chroot" + chrootdir = imgfile ++ ".chroot" chroot = let c = propprivdataonly $ mkchroot chrootdir in setContainerProps c $ containerProps c @@ -161,10 +204,11 @@ cachesCleaned = "cache cleaned" ==> (Apt.cacheCleaned `pickOS` skipit) skipit = doNothing :: Property UnixLike -- | Builds a disk image from the contents of a chroot. -imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) UnixLike +imageBuiltFrom :: DiskImage d => d -> FilePath -> TableType -> Finalization -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg where - desc = img ++ " built from " ++ chrootdir + desc = describeDiskImage img ++ " built from " ++ chrootdir + dest@(RawDiskImage imgfile) = rawDiskImage img mkimg = property' desc $ \w -> do -- Unmount helper filesystems such as proc from the chroot -- first; don't want to include the contents of those. @@ -176,14 +220,17 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg let (mnts, mntopts, parttable) = fitChrootSize tabletype partspec $ map (calcsz mnts) mnts ensureProperty w $ - imageExists' img parttable + imageExists' dest parttable `before` - kpartx img (mkimg' mnts mntopts parttable) + kpartx imgfile (mkimg' mnts mntopts parttable) + `before` + buildDiskImage img mkimg' mnts mntopts parttable devs = partitionsPopulated chrootdir mnts mntopts devs `before` imageFinalized final mnts mntopts devs parttable - rmimg = undoRevertableProperty (imageExists' img dummyparttable) + rmimg = undoRevertableProperty (buildDiskImage img) + `before` undoRevertableProperty (imageExists' dest dummyparttable) dummyparttable = PartTable tabletype [] partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property DebianLike @@ -255,8 +302,8 @@ getMountSz szm l (Just mntpt) = -- If the file doesn't exist, or is too small, creates a new one, full of 0's. -- -- If the file is too large, truncates it down to the specified size. -imageExists :: FilePath -> ByteSize -> Property Linux -imageExists img isz = property ("disk image exists" ++ img) $ liftIO $ do +imageExists :: RawDiskImage -> ByteSize -> Property Linux +imageExists (RawDiskImage img) isz = property ("disk image exists" ++ img) $ liftIO $ do ms <- catchMaybeIO $ getFileStatus img case ms of Just s @@ -278,14 +325,14 @@ imageExists img isz = property ("disk image exists" ++ img) $ liftIO $ do -- -- Avoids repartitioning the disk image, when a file of the right size -- already exists, and it has the same PartTable. -imageExists' :: FilePath -> PartTable -> RevertableProperty DebianLike UnixLike -imageExists' img parttable = (setup <!> cleanup) `describe` desc +imageExists' :: RawDiskImage -> PartTable -> RevertableProperty DebianLike UnixLike +imageExists' dest@(RawDiskImage img) parttable = (setup <!> cleanup) `describe` desc where desc = "disk image exists " ++ img parttablefile = img ++ ".parttable" setup = property' desc $ \w -> do oldparttable <- liftIO $ catchDefaultIO "" $ readFileStrict parttablefile - res <- ensureProperty w $ imageExists img (partTableSize parttable) + res <- ensureProperty w $ imageExists dest (partTableSize parttable) if res == NoChange && oldparttable == show parttable then return NoChange else if res == FailedChange @@ -385,20 +432,3 @@ toSysDir :: FilePath -> FilePath -> FilePath toSysDir chrootdir d = case makeRelative chrootdir d of "." -> "/" sysdir -> "/" ++ sysdir - --- | Builds a VirtualBox .vmdk file for the specified disk image file. -vmdkBuiltFor :: FilePath -> RevertableProperty DebianLike UnixLike -vmdkBuiltFor diskimage = (setup <!> cleanup) - `describe` (vmdkfile ++ " built") - where - vmdkfile = diskimage ++ ".vmdk" - setup = cmdProperty "VBoxManage" - [ "internalcommands", "createrawvmdk" - , "-filename", vmdkfile - , "-rawdisk", diskimage - ] - `changesFile` vmdkfile - `onChange` File.mode vmdkfile (combineModes (ownerWriteMode : readModes)) - `requires` Apt.installed ["virtualbox"] - `requires` File.notPresent vmdkfile - cleanup = File.notPresent vmdkfile diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs @@ -468,7 +468,7 @@ genZone inzdomain hostmap zdomain soa = -- So we can just use the IPAddrs. addcnames :: Host -> [Either WarningMessage (BindDomain, Record)] addcnames h = concatMap gen $ filter (inDomain zdomain) $ - mapMaybe getCNAME $ S.toList $ fromDnsInfo $ fromInfo info + mapMaybe getCNAME $ S.toList $ getDnsInfo info where info = hostInfo h gen c = case getAddresses info of @@ -483,7 +483,7 @@ genZone inzdomain hostmap zdomain soa = where info = hostInfo h l = zip (repeat $ AbsDomain $ hostName h) - (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (fromDnsInfo $ fromInfo info)) + (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (getDnsInfo info)) -- Simplifies the list of hosts. Remove duplicate entries. -- Also, filter out any CHAMES where the same domain has an @@ -531,7 +531,7 @@ genSSHFP domain h = concatMap mk . concat <$> (gen =<< get) gen = liftIO . mapM genSSHFP' . M.elems . fromMaybe M.empty mk r = mapMaybe (\d -> if inDomain domain d then Just (d, r) else Nothing) (AbsDomain hostname : cnames) - cnames = mapMaybe getCNAME $ S.toList $ fromDnsInfo $ fromInfo info + cnames = mapMaybe getCNAME $ S.toList $ getDnsInfo info hostname = hostName h info = hostInfo h diff --git a/src/Propellor/Property/Fstab.hs b/src/Propellor/Property/Fstab.hs @@ -26,7 +26,8 @@ import Utility.Table mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property Linux mounted fs src mnt opts = tightenTargets $ listed fs src mnt opts - `onChange` mountnow + `before` mountnow + `requires` File.dirExists mnt where -- This use of mountPoints, which is linux-only, is why this -- property currently only supports linux. diff --git a/src/Propellor/Property/Lvm.hs b/src/Propellor/Property/Lvm.hs @@ -0,0 +1,171 @@ +-- | Maintainer: Nicolas Schodet <nico@ni.fr.eu.org> +-- +-- Support for LVM logical volumes. + +module Propellor.Property.Lvm ( + lvFormatted, + installed, + Eep(..), + VolumeGroup(..), + LogicalVolume(..), +) where + +import Propellor +import Propellor.Base +import Utility.DataUnits +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Mount as Mount +import qualified Propellor.Property.Partition as Partition + +data Eep = YesReallyFormatLogicalVolume + +type DataSize = String + +newtype VolumeGroup = VolumeGroup String +data LogicalVolume = LogicalVolume String VolumeGroup + +-- | Create or resize a logical volume, and make sure it is formatted. When +-- reverted, remove the logical volume. +-- +-- Example use: +-- +-- > import qualified Propellor.Property.Lvm as Lvm +-- > import qualified Propellor.Property.Partition as Partition +-- > Lvm.lvFormatted Lvm.YesReallyFormatLogicalVolume +-- > (Lvm.LogicalVolume "test" (Lvm.VolumeGroup "vg0")) "16m" +-- > Partition.EXT4 +-- +-- If size and filesystem match, nothing is done. +-- +-- Volume group must have been created already. +lvFormatted + :: Eep + -> LogicalVolume + -> DataSize + -> Partition.Fs + -> RevertableProperty DebianLike UnixLike +lvFormatted YesReallyFormatLogicalVolume lv sz fs = + setup <!> cleanup + where + setup :: Property DebianLike + setup = property' ("formatted logical volume " ++ (vglv lv)) $ \w -> do + es <- liftIO $ vgExtentSize vg + case es of + Nothing -> errorMessage $ + "can not get extent size, does volume group " + ++ vgname ++ " exist?" + Just extentSize -> do + case parseSize of + Nothing -> errorMessage + "can not parse volume group size" + Just size -> do + state <- liftIO $ lvState lv + let rsize = roundSize extentSize size + ensureProperty w $ + setupprop rsize state + + cleanup :: Property UnixLike + cleanup = property' ("removed logical volume " ++ (vglv lv)) $ \w -> do + exists <- liftIO $ lvExists lv + ensureProperty w $ if exists + then removedprop + else doNothing + + -- Parse size. + parseSize :: Maybe Integer + parseSize = readSize dataUnits sz + + -- Round size to next extent size multiple. + roundSize :: Integer -> Integer -> Integer + roundSize extentSize s = + (s + extentSize - 1) `div` extentSize * extentSize + + -- Dispatch to the right props. + setupprop :: Integer -> (Maybe LvState) -> Property DebianLike + setupprop size Nothing = createdprop size `before` formatprop + setupprop size (Just (LvState csize cfs)) + | size == csize && fsMatch fs cfs = doNothing + | size == csize = formatprop + | fsMatch fs cfs = tightenTargets $ resizedprop size True + | otherwise = resizedprop size False `before` formatprop + + createdprop :: Integer -> Property UnixLike + createdprop size = + cmdProperty "lvcreate" + (bytes size $ [ "-n", lvname, "--yes", vgname ]) + `assume` MadeChange + + resizedprop :: Integer -> Bool -> Property UnixLike + resizedprop size rfs = + cmdProperty "lvresize" + (resizeFs rfs $ bytes size $ [ vglv lv ]) + `assume` MadeChange + where + resizeFs True l = "-r" : l + resizeFs False l = l + + removedprop :: Property UnixLike + removedprop = cmdProperty "lvremove" [ "-f", vglv lv ] + `assume` MadeChange + + formatprop :: Property DebianLike + formatprop = Partition.formatted Partition.YesReallyFormatPartition + fs (path lv) + + fsMatch :: Partition.Fs -> Maybe Partition.Fs -> Bool + fsMatch a (Just b) = a == b + fsMatch _ _ = False + + bytes size l = "-L" : ((show size) ++ "b") : l + + (LogicalVolume lvname vg@(VolumeGroup vgname)) = lv + +-- | Make sure needed tools are installed. +installed :: RevertableProperty DebianLike DebianLike +installed = install <!> remove + where + install = Apt.installed ["lvm2"] + remove = Apt.removed ["lvm2"] + +data LvState = LvState Integer (Maybe Partition.Fs) + +-- Check for logical volume existance. +lvExists :: LogicalVolume -> IO Bool +lvExists lv = doesFileExist (path lv) + +-- Return Nothing if logical volume does not exists (or error), else return +-- its size and maybe file system. +lvState :: LogicalVolume -> IO (Maybe LvState) +lvState lv = do + exists <- lvExists lv + if not exists + then return Nothing + else do + s <- readLvSize + fs <- maybe Nothing Partition.parseFs <$> readFs + return $ do + size <- s + return $ LvState size fs + where + readLvSize = catchDefaultIO Nothing $ readish + <$> readProcess "lvs" [ "-o", "size", "--noheadings", + "--nosuffix", "--units", "b", vglv lv ] + readFs = Mount.blkidTag "TYPE" (path lv) + +-- Read extent size (or Nothing on error). +vgExtentSize :: VolumeGroup -> IO (Maybe Integer) +vgExtentSize (VolumeGroup vgname) = + catchDefaultIO Nothing $ readish + <$> readProcess "vgs" [ "-o", "vg_extent_size", + "--noheadings", "--nosuffix", "--units", "b", vgname ] + +-- Give "vgname/lvname" for a LogicalVolume. +vglv :: LogicalVolume -> String +vglv lv = + vgname </> lvname + where + (LogicalVolume lvname (VolumeGroup vgname)) = lv + +-- Give device path. +path :: LogicalVolume -> FilePath +path lv = "/dev" </> (vglv lv) diff --git a/src/Propellor/Property/Obnam.hs b/src/Propellor/Property/Obnam.hs @@ -113,7 +113,7 @@ restored dir params = go `requires` installed , noChange ) - needsRestore = null <$> catchDefaultIO [] (dirContents dir) + needsRestore = isUnpopulated dir restore = withTmpDirIn (takeDirectory dir) "obnam-restore" $ \tmpdir -> do ok <- boolSystem "obnam" $ diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs @@ -15,6 +15,20 @@ import Data.Char data Fs = EXT2 | EXT3 | EXT4 | BTRFS | REISERFS | XFS | FAT | VFAT | NTFS | LinuxSwap deriving (Show, Eq) +-- | Parse commonly used names of filesystems. +parseFs :: String -> Maybe Fs +parseFs "ext2" = Just EXT2 +parseFs "ext3" = Just EXT3 +parseFs "ext4" = Just EXT4 +parseFs "btrfs" = Just BTRFS +parseFs "reiserfs" = Just REISERFS +parseFs "xfs" = Just XFS +parseFs "fat" = Just FAT +parseFs "vfat" = Just VFAT +parseFs "ntfs" = Just NTFS +parseFs "swap" = Just LinuxSwap +parseFs _ = Nothing + data Eep = YesReallyFormatPartition -- | Formats a partition. diff --git a/src/Propellor/Property/PropellorRepo.hs b/src/Propellor/Property/PropellorRepo.hs @@ -2,18 +2,26 @@ module Propellor.Property.PropellorRepo where import Propellor.Base import Propellor.Git.Config +import Propellor.Types.Info -- | Sets the url to use as the origin of propellor's git repository. -- --- When propellor --spin is used to update a host, the url is taken from --- the repository that --spin is run in, and passed to the host. So, you --- don't need to specifiy this property then. +-- By default, the url is taken from the deploy or origin remote of +-- the repository that propellor --spin is run in. Setting this property +-- overrides that default behavior with a different url. -- --- This property is useful when hosts are being updated without using --- --spin, eg when using the `Propellor.Property.Cron.runPropellor` cron job. -hasOriginUrl :: String -> Property UnixLike -hasOriginUrl u = property ("propellor repo url " ++ u) $ do - curru <- liftIO getRepoUrl - if curru == Just u - then return NoChange - else makeChange $ setRepoUrl u +-- When hosts are being updated without using -- --spin, eg when using +-- the `Propellor.Property.Cron.runPropellor` cron job, this property can +-- be set to redirect them to a new git repository url. +hasOriginUrl :: String -> Property (HasInfo + UnixLike) +hasOriginUrl u = setInfoProperty p (toInfo (InfoVal (OriginUrl u))) + where + p :: Property UnixLike + p = property ("propellor repo url " ++ u) $ do + curru <- liftIO getRepoUrl + if curru == Just u + then return NoChange + else makeChange $ setRepoUrl u + +newtype OriginUrl = OriginUrl String + deriving (Show) diff --git a/src/Propellor/Property/Restic.hs b/src/Propellor/Property/Restic.hs @@ -97,7 +97,7 @@ restored dir repo = go , noChange ) - needsRestore = null <$> catchDefaultIO [] (dirContents dir) + needsRestore = isUnpopulated dir restore = withTmpDirIn (takeDirectory dir) "restic-restore" $ \tmpdir -> do ok <- boolSystem "restic" diff --git a/src/Propellor/Property/Sbuild.hs b/src/Propellor/Property/Sbuild.hs @@ -147,7 +147,7 @@ built s@(SbuildSchroot suite arch) mirror cc = <!> deleted where go :: Property DebianLike - go = check (unpopulated (schrootRoot s) <||> ispartial) $ + go = check (isUnpopulated (schrootRoot s) <||> ispartial) $ property' ("built sbuild schroot for " ++ val s) make make w = do de <- liftIO standardPathEnv @@ -166,7 +166,7 @@ built s@(SbuildSchroot suite arch) mirror cc = ) -- TODO we should kill any sessions still using the chroot -- before destroying it (as suggested by sbuild-destroychroot) - deleted = check (not <$> unpopulated (schrootRoot s)) $ + deleted = check (not <$> isUnpopulated (schrootRoot s)) $ property ("no sbuild schroot for " ++ val s) $ do liftIO $ removeChroot $ schrootRoot s liftIO $ nukeFile diff --git a/src/Propellor/Property/SiteSpecific/Branchable.hs b/src/Propellor/Property/SiteSpecific/Branchable.hs @@ -8,6 +8,8 @@ import qualified Propellor.Property.Ssh as Ssh import qualified Propellor.Property.Postfix as Postfix import qualified Propellor.Property.Gpg as Gpg import qualified Propellor.Property.Sudo as Sudo +import qualified Propellor.Property.Borg as Borg +import qualified Propellor.Property.Cron as Cron server :: [Host] -> Property (HasInfo + DebianLike) server hosts = propertyList "branchable server" $ props @@ -37,18 +39,24 @@ server hosts = propertyList "branchable server" $ props & Postfix.installed & Postfix.mainCf ("mailbox_command", "procmail -a \"$EXTENSION\"") - -- Obnam is run by a cron job in ikiwiki-hosting. - & "/etc/obnam.conf" `File.hasContent` - [ "[config]" - , "repository = sftp://joey@eubackup.kitenet.net/home/joey/lib/backup/pell.obnam" - , "log = /var/log/obnam.log" - , "encrypt-with = " ++ obnamkey - , "log-level = info" - , "log-max = 1048576" - , "keep = 7d,5w,12m" - , "upload-queue-size = 128" - , "lru-size = 128" + & Borg.backup "/" (Borg.BorgRepo "joey@eubackup.kitenet.net:/home/joey/lib/backup/branchable/pell.borg") Cron.Daily + [ "--exclude=/proc/*" + , "--exclude=/sys/*" + , "--exclude=/run/*" + , "--exclude=/tmp/*" + , "--exclude=/var/tmp/*" + , "--exclude=/var/backups/ikiwiki-hosting-web/*" + , "--exclude=/var/cache/*" + , "--exclude=/home/*/source/*" + , "--exclude=/home/*/public_html/*" + , "--exclude=/home/*/.git/*" ] + [ Borg.KeepDays 7 + , Borg.KeepWeeks 5 + , Borg.KeepMonths 12 + , Borg.KeepYears 1 + ] + -- gpg key that can be used to decrypt the borg backup key & Gpg.keyImported (Gpg.GpgKeyId obnamkey) (User "root") & Ssh.userKeys (User "root") (Context "branchable.com") [ (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQC2PqTSupwncqeffNwZQXacdEWp7L+TxllIxH7WjfRMb3U74mQxWI0lwqLVW6Fox430DvhSqF1y5rJBvTHh4i49Tc9lZ7mwAxA6jNOP6bmdfteaKKYmUw5qwtJW0vISBFu28qBO11Nq3uJ1D3Oj6N+b3mM/0D3Y3NoGgF8+2dLdi81u9+l6AQ5Jsnozi2Ni/Osx2oVGZa+IQDO6gX8VEP4OrcJFNJe8qdnvItcGwoivhjbIfzaqNNvswKgGzhYLOAS5KT8HsjvIpYHWkyQ5QUX7W/lqGSbjP+6B8C3tkvm8VLXbmaD+aSkyCaYbuoXC2BoJdS7Jh8phKMwPJmdYVepn") diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -15,7 +15,7 @@ import qualified Propellor.Property.Git as Git import qualified Propellor.Property.Cron as Cron import qualified Propellor.Property.Service as Service import qualified Propellor.Property.User as User -import qualified Propellor.Property.Obnam as Obnam +import qualified Propellor.Property.Borg as Borg import qualified Propellor.Property.Apache as Apache import qualified Propellor.Property.Postfix as Postfix import qualified Propellor.Property.Systemd as Systemd @@ -141,17 +141,17 @@ oldUseNetServer hosts = propertyList "olduse.net server" $ props ) oldUseNetBackup :: Property (HasInfo + DebianLike) - oldUseNetBackup = Obnam.backup datadir (Cron.Times "33 4 * * *") - [ "--repository=sftp://2318@usw-s002.rsync.net/~/olduse.net" - , "--client-name=spool" - , "--ssh-key=" ++ keyfile - , Obnam.keepParam [Obnam.KeepDays 30] - ] Obnam.OnlyClient + oldUseNetBackup = Borg.backup datadir borgrepo + (Cron.Times "33 4 * * *") + [] + [Borg.KeepDays 30] `requires` Ssh.userKeyAt (Just keyfile) (User "root") (Context "olduse.net") (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQD0F6L76SChMCIGmeyGhlFMUTgZ3BoTbATiOSs0A7KXQoI1LTE5ZtDzzUkrQRJVpJ640pfMR7cQZyBm8tv+kYIPp0238GrX43c1vgm0L78agDnBU7r2iNMyWIwhssK8O3ZAhp8Q4KCz1r8hP2nIiD0y1D1VWW8h4KWOS7I1XCEAjOTvFvEjTh6a9MyHrcIkv7teUUzTBRjNrsyijCFRk1+pEET54RueoOmEjQcWd/sK1tYRiMZjegRLBOus2wUWsUOvznJ2iniLONUTGAWRnEV+O7hLN6CD44osJ+wkZk8bPAumTS0zcSLckX1jpdHJicmAyeniWSd4FCqm1YE6/xDD") - `requires` Ssh.knownHost hosts "usw-s002.rsync.net" (User "root") + `requires` Ssh.knownHost hosts "eubackup.kitenet.net" (User "root") + borgrepo = Borg.BorgRepoUsing [Borg.UseSshKey keyfile] + "joey@eubackup.kitenet.net:/home/joey/lib/backup/olduse.net/olduse.net.borg" keyfile = "/root/.ssh/olduse.net.key" oldUseNetShellBox :: Property DebianLike @@ -162,13 +162,13 @@ oldUseNetShellBox = propertyList "olduse.net shellbox" $ props oldUseNetInstalled :: Apt.Package -> Property DebianLike oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $ propertyList ("olduse.net " ++ pkg) $ props - & Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-strptime-dev libghc-hamlet-dev libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev") + & Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev haskell-stack") `describe` "olduse.net build deps" & scriptProperty [ "rm -rf /root/tmp/oldusenet" -- idenpotency , "git clone git://olduse.net/ /root/tmp/oldusenet/source" , "cd /root/tmp/oldusenet/source/" - , "dpkg-buildpackage -us -uc" + , "HOME=/root dpkg-buildpackage -us -uc" , "dpkg -i ../" ++ pkg ++ "_*.deb || true" , "apt-get -fy install" -- dependencies , "rm -rf /root/tmp/oldusenet" @@ -193,42 +193,20 @@ kgbServer = propertyList desc $ props `onChange` Service.running "kgb-bot" _ -> error "kgb server needs Debian unstable (for kgb-bot 1.31+)" -mumbleServer :: [Host] -> Property (HasInfo + DebianLike) -mumbleServer hosts = combineProperties hn $ props - & Apt.serviceInstalledRunning "mumble-server" - & Obnam.backup "/var/lib/mumble-server" (Cron.Times "55 5 * * *") - [ "--repository=sftp://2318@usw-s002.rsync.net/~/" ++ hn ++ ".obnam" - , "--ssh-key=" ++ sshkey - , "--client-name=mumble" - , Obnam.keepParam [Obnam.KeepDays 30] - ] Obnam.OnlyClient - `requires` Ssh.userKeyAt (Just sshkey) - (User "root") - (Context hn) - (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQDSXXSM3mM8SNu+qel9R/LkDIkjpV3bfpUtRtYv2PTNqicHP+DdoThrr0ColFCtLH+k2vQJvR2n8uMzHn53Dq2IO3TtD27+7rJSsJwAZ8oftNzuTir8IjAwX5g6JYJs+L0Ny4RB0ausd+An0k/CPMRl79zKxpZd2MBMDNXt8hyqu0vS0v1ohq5VBEVhBBvRvmNQvWOCj7PdrKQXpUBHruZOeVVEdUUXZkVc1H0t7LVfJnE+nGKyWbw2jM+7r3Rn5Semc4R1DxsfaF8lKkZyE88/5uZQ/ddomv8ptz6YZ5b+Bg6wfooWPC3RWAALjxnHaC2yN1VONAvHmT0uNn1o6v0b") - `requires` Ssh.knownHost hosts "usw-s002.rsync.net" (User "root") - & cmdProperty "chown" ["-R", "mumble-server:mumble-server", "/var/lib/mumble-server"] - `assume` NoChange - where - hn = "mumble.debian.net" - sshkey = "/root/.ssh/mumble.debian.net.key" - -- git.kitenet.net and git.joeyh.name gitServer :: [Host] -> Property (HasInfo + DebianLike) gitServer hosts = propertyList "git.kitenet.net setup" $ props - & Obnam.backupEncrypted "/srv/git" (Cron.Times "33 3 * * *") - [ "--repository=sftp://2318@usw-s002.rsync.net/~/git.kitenet.net" - , "--ssh-key=" ++ sshkey - , "--client-name=wren" -- historical - , Obnam.keepParam [Obnam.KeepDays 30] - ] Obnam.OnlyClient (Gpg.GpgKeyId "1B169BE1") + & Borg.backup "/srv/git" borgrepo + (Cron.Times "33 3 * * *") + [] + [Borg.KeepDays 30] `requires` Ssh.userKeyAt (Just sshkey) (User "root") (Context "git.kitenet.net") - (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQD0F6L76SChMCIGmeyGhlFMUTgZ3BoTbATiOSs0A7KXQoI1LTE5ZtDzzUkrQRJVpJ640pfMR7cQZyBm8tv+kYIPp0238GrX43c1vgm0L78agDnBU7r2iNMyWIwhssK8O3ZAhp8Q4KCz1r8hP2nIiD0y1D1VWW8h4KWOS7I1XCEAjOTvFvEjTh6a9MyHrcIkv7teUUzTBRjNrsyijCFRk1+pEET54RueoOmEjQcWd/sK1tYRiMZjegRLBOus2wUWsUOvznJ2iniLONUTGAWRnEV+O7hLN6CD44osJ+wkZk8bPAumTS0zcSLckX1jpdHJicmAyeniWSd4FCqm1YE6/xDD") - `requires` Ssh.knownHost hosts "usw-s002.rsync.net" (User "root") - `requires` Ssh.authorizedKeys (User "family") (Context "git.kitenet.net") - `requires` User.accountFor (User "family") + (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQDLwUUkpkI9c2Wcnv/E4v9bJ7WcpiNkToltXfzRDd1F31AYrucfSMgzu3rtDpEL+wSnQLua/taJkWUWT/pyXOAh+90K6O/YeBZmY5CK01rYDz3kSTAtwHkMqednsRjdQS6NNJsuWc1reO8a4pKtsToJ3G9VAKufCkt2b8Nhqz0yLvLYwwU/mdI8DmfX6IgXhdy9njVEG/jsQnLFXY6QEfwKbIPs9O6qo4iFJg3defXX+zVMLsh3NE1P2i2VxMjxJEQdPdy9Z1sVpkiQM+mgJuylQQ5flPK8sxhO9r4uoK/JROkjPJNYoJMlsN+QlK04ABb7JV2JwhAL/Y8ypjQ13JdT") + `requires` Ssh.knownHost hosts "eubackup.kitenet.net" (User "root") + & Ssh.authorizedKeys (User "family") (Context "git.kitenet.net") + & User.accountFor (User "family") & Apt.installed ["git", "rsync", "cgit"] & Apt.installed ["git-annex"] & Apt.installed ["kgb-client"] @@ -257,6 +235,8 @@ gitServer hosts = propertyList "git.kitenet.net setup" $ props & Apache.modEnabled "cgi" where sshkey = "/root/.ssh/git.kitenet.net.key" + borgrepo = Borg.BorgRepoUsing [Borg.UseSshKey sshkey] + "joey@eubackup.kitenet.net:/home/joey/lib/backup/git.kitenet.net/git.kitenet.net.borg" website hn = Apache.httpsVirtualHost' hn "/srv/web/git.kitenet.net/" letos [ Apache.iconDir , " <Directory /srv/web/git.kitenet.net/>" @@ -440,16 +420,6 @@ backupsBackedupFrom hosts srchost destdir = Cron.niceJob desc desc = "backups copied from " ++ srchost ++ " on boot" cmd = "sleep 30m && rsync -az --bwlimit=300K --partial --delete " ++ srchost ++ ":lib/backup/ " ++ destdir </> srchost -obnamRepos :: [String] -> Property UnixLike -obnamRepos rs = propertyList ("obnam repos for " ++ unwords rs) $ - toProps (mkbase : map mkrepo rs) - where - mkbase = mkdir "/home/joey/lib/backup" - `requires` mkdir "/home/joey/lib" - mkrepo r = mkdir ("/home/joey/lib/backup/" ++ r ++ ".obnam") - mkdir d = File.dirExists d - `before` File.ownerGroup d (User "joey") (Group "joey") - podcatcher :: Property DebianLike podcatcher = Cron.niceJob "podcatcher run hourly" (Cron.Times "55 * * * *") (User "joey") "/home/joey/lib/sound/podcasts" @@ -520,6 +490,7 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props & "/etc/aliases" `File.hasPrivContentExposed` ctx `onChange` Postfix.newaliases + & hasPostfixCert ctx & "/etc/postfix/mydomain" `File.containsLines` [ "/.*\\.kitenet\\.net/\tOK" @@ -582,9 +553,9 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props , "milter_default_action = accept" , "# TLS setup -- server" - , "smtpd_tls_CAfile = /etc/letsencrypt/live/kitenet.net/fullchain.pem" - , "smtpd_tls_cert_file = /etc/letsencrypt/live/kitenet.net/cert.pem" - , "smtpd_tls_key_file = /etc/letsencrypt/live/kitenet.net/privkey.pem" + , "smtpd_tls_CAfile = /etc/ssl/certs/joeyca.pem" + , "smtpd_tls_cert_file = /etc/ssl/certs/postfix.pem" + , "smtpd_tls_key_file = /etc/ssl/private/postfix.pem" , "smtpd_tls_loglevel = 1" , "smtpd_tls_received_header = yes" , "smtpd_use_tls = yes" @@ -592,9 +563,9 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props , "smtpd_tls_session_cache_database = sdbm:/etc/postfix/smtpd_scache" , "# TLS setup -- client" - , "smtp_tls_CAfile = /etc/letsencrypt/live/kitenet.net/fullchain.pem" - , "smtp_tls_cert_file = /etc/letsencrypt/live/kitenet.net/cert.pem" - , "smtp_tls_key_file = /etc/letsencrypt/live/kitenet.net/privkey.pem" + , "smtp_tls_CAfile = /etc/ssl/certs/joeyca.pem" + , "smtp_tls_cert_file = /etc/ssl/certs/postfix.pem" + , "smtp_tls_key_file = /etc/ssl/private/postfix.pem" , "smtp_tls_loglevel = 1" , "smtp_use_tls = yes" , "smtp_tls_session_cache_database = sdbm:/etc/postfix/smtp_scache" @@ -613,12 +584,6 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props "!include auth-passwdfile.conf.ext" `onChange` Service.restarted "dovecot" `describe` "dovecot auth.conf" - & "/etc/dovecot/conf.d/10-ssl.conf" `File.containsLines` - [ "ssl_cert = </etc/letsencrypt/live/kitenet.net/fullchain.pem" - , "ssl_key = </etc/letsencrypt/live/kitenet.net/privkey.pem" - ] - `onChange` Service.restarted "dovecot" - `describe` "dovecot letsencrypt certs" & File.hasPrivContent dovecotusers ctx `onChange` (dovecotusers `File.mode` combineModes [ownerReadMode, groupReadMode]) @@ -719,6 +684,11 @@ postfixSaslPasswordClient = combineProperties "postfix uses SASL password to aut ] `onChange` Postfix.reloaded +hasPostfixCert :: Context -> Property (HasInfo + UnixLike) +hasPostfixCert ctx = combineProperties "postfix tls cert installed" $ props + & "/etc/ssl/certs/postfix.pem" `File.hasPrivContentExposed` ctx + & "/etc/ssl/private/postfix.pem" `File.hasPrivContent` ctx + -- Legacy static web sites and redirections from kitenet.net to newer -- sites. legacyWebSites :: Property (HasInfo + DebianLike) @@ -942,7 +912,7 @@ alarmClock oncalendar (User user) command = combineProperties "goodmorning timer homePowerMonitor :: IsContext c => User -> c -> (SshKeyType, Ssh.PubKeyText) -> Property (HasInfo + DebianLike) homePowerMonitor user ctx sshkey = propertyList "home power monitor" $ props & Apache.installed - & Apt.installed ["python2", "python-pymodbus"] + & Apt.installed ["python", "python-pymodbus"] & File.ownerGroup "/var/www/html" user (userGroup user) & Git.cloned user "git://git.kitenet.net/joey/homepower" d Nothing `onChange` buildpoller diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs @@ -29,6 +29,7 @@ import Propellor.Gpg import Propellor.Bootstrap import Propellor.Types.CmdLine import Propellor.Types.Info +import Propellor.Property.PropellorRepo (OriginUrl(..)) import qualified Propellor.Shim as Shim import Utility.FileMode import Utility.SafeCommand @@ -173,7 +174,7 @@ getSshTarget target hst return ip configips = map val $ mapMaybe getIPAddr $ - S.toList $ fromDnsInfo $ fromInfo $ hostInfo hst + S.toList $ getDnsInfo $ hostInfo hst -- Update the privdata, repo url, and git repo over the ssh -- connection, talking to the user's local propellor instance which is @@ -220,7 +221,7 @@ updateServer target relay hst connect haveprecompiled privdata = do v <- maybe Nothing readish <$> getMarked fromh statusMarker case v of (Just NeedRepoUrl) -> do - sendRepoUrl toh + sendRepoUrl hst toh loop (Just NeedPrivData) -> do sendPrivData hn toh privdata @@ -242,8 +243,12 @@ updateServer target relay hst connect haveprecompiled privdata = do done Nothing -> done -sendRepoUrl :: Handle -> IO () -sendRepoUrl toh = sendMarked toh repoUrlMarker =<< (fromMaybe "" <$> getRepoUrl) +sendRepoUrl :: Host -> Handle -> IO () +sendRepoUrl hst toh = sendMarked toh repoUrlMarker =<< geturl + where + geturl = case fromInfoVal (fromInfo (hostInfo hst)) of + Nothing -> fromMaybe "" <$> getRepoUrl + Just (OriginUrl u) -> return u sendPrivData :: HostName -> Handle -> PrivMap -> IO () sendPrivData hn toh privdata = void $ actionMessage msg $ do diff --git a/src/Propellor/Types/Dns.hs b/src/Propellor/Types/Dns.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} module Propellor.Types.Dns where @@ -36,17 +37,37 @@ toAliasesInfo l = AliasesInfo (S.fromList l) fromAliasesInfo :: AliasesInfo -> [HostName] fromAliasesInfo (AliasesInfo s) = S.toList s -newtype DnsInfo = DnsInfo { fromDnsInfo :: S.Set Record } +-- | Use this for DNS Info that should propagate from a container to a +-- host. For example, this can be used for CNAME to make aliases +-- of the containers in the host be reflected in the DNS. +newtype DnsInfoPropagated = DnsInfoPropagated + { fromDnsInfoPropagated :: S.Set Record } deriving (Show, Eq, Ord, Monoid, Typeable) -toDnsInfo :: S.Set Record -> DnsInfo -toDnsInfo = DnsInfo +toDnsInfoPropagated :: S.Set Record -> DnsInfoPropagated +toDnsInfoPropagated = DnsInfoPropagated --- | DNS Info is propagated, so that eg, aliases of a container --- are reflected in the dns for the host where it runs. -instance IsInfo DnsInfo where +instance IsInfo DnsInfoPropagated where propagateInfo _ = PropagateInfo True +-- | Use this for DNS Info that should not propagate from a container to a +-- host. For example, an IP address of a container should not influence +-- the host. +newtype DnsInfoUnpropagated = DnsInfoUnpropagated + { fromDnsInfoUnpropagated :: S.Set Record } + deriving (Show, Eq, Ord, Monoid, Typeable) + +toDnsInfoUnpropagated :: S.Set Record -> DnsInfoUnpropagated +toDnsInfoUnpropagated = DnsInfoUnpropagated + +-- | Get all DNS Info. +getDnsInfo :: Info -> S.Set Record +getDnsInfo i = fromDnsInfoUnpropagated (fromInfo i) + `S.union` fromDnsInfoPropagated (fromInfo i) + +instance IsInfo DnsInfoUnpropagated where + propagateInfo _ = PropagateInfo False + -- | Represents a bind 9 named.conf file. data NamedConf = NamedConf { confDomain :: Domain diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs @@ -44,8 +44,7 @@ extractInfoEntry (InfoEntry v) = T.cast v -- as info, especially type aliases which coud easily lead to bugs. -- We want a little bit of dynamic types here, but not too far.. class (Typeable v, Monoid v, Show v) => IsInfo v where - -- | Should info of this type be propagated out of a - -- container to its Host? + -- | Should this info be propagated out of a container to its Host? propagateInfo :: v -> PropagateInfo data PropagateInfo @@ -56,16 +55,15 @@ data PropagateInfo -- | Any value in the `IsInfo` type class can be added to an Info. addInfo :: IsInfo v => Info -> v -> Info -addInfo (Info l) v = Info (InfoEntry v:l) +addInfo (Info l) v = Info (l++[InfoEntry v]) -- | Converts any value in the `IsInfo` type class into an Info, -- which is otherwise empty. toInfo :: IsInfo v => v -> Info toInfo = addInfo mempty --- The list is reversed here because addInfo builds it up in reverse order. fromInfo :: IsInfo v => Info -> v -fromInfo (Info l) = mconcat (mapMaybe extractInfoEntry (reverse l)) +fromInfo (Info l) = mconcat (mapMaybe extractInfoEntry l) -- | Maps a function over all values stored in the Info that are of the -- appropriate type. diff --git a/src/Utility/Directory.hs b/src/Utility/Directory.hs @@ -42,6 +42,10 @@ dirCruft "." = True dirCruft ".." = True dirCruft _ = False +fsCruft :: FilePath -> Bool +fsCruft "lost+found" = True +fsCruft d = dirCruft d + {- Lists the contents of a directory. - Unlike getDirectoryContents, paths are not relative to the directory. -} dirContents :: FilePath -> IO [FilePath] @@ -236,12 +240,23 @@ readDirectory hdl@(DirectoryHandle _ h fdat mv) = do -- True only when directory exists and contains nothing. -- Throws exception if directory does not exist. isDirectoryEmpty :: FilePath -> IO Bool -isDirectoryEmpty d = bracket (openDirectory d) closeDirectory check +isDirectoryEmpty d = testDirectory d dirCruft + +-- | True if the directory does not exist or contains nothing. +-- Ignores "lost+found" which can exist in an empty filesystem. +isUnpopulated :: FilePath -> IO Bool +isUnpopulated d = catchDefaultIO True $ testDirectory d fsCruft + +-- | Run test on entries found in directory, return False as soon as the +-- test returns False, else return True. Throws exception if directory does +-- not exist. +testDirectory :: FilePath -> (FilePath -> Bool) -> IO Bool +testDirectory d test = bracket (openDirectory d) closeDirectory check where check h = do v <- readDirectory h case v of Nothing -> return True Just f - | not (dirCruft f) -> return False + | not (test f) -> return False | otherwise -> check h