diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,12 @@ +propellor (4.0.3) unstable; urgency=medium + + * Added Fstab.listed, Fstab.swap, and Mount.swapOn properties. + Thanks, Daniel Brooks. + * Added Propellor.Property.Bootstrap, which can be used to make + disk images contain their own installation of propellor. + + -- Joey Hess Thu, 20 Apr 2017 00:54:32 -0400 + propellor (4.0.2) unstable; urgency=medium * Apt.mirror can be used to set the preferred apt mirror of a host, diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,12 @@ +propellor (4.0.3) unstable; urgency=medium + + * Added Fstab.listed, Fstab.swap, and Mount.swapOn properties. + Thanks, Daniel Brooks. + * Added Propellor.Property.Bootstrap, which can be used to make + disk images contain their own installation of propellor. + + -- Joey Hess Thu, 20 Apr 2017 00:54:32 -0400 + propellor (4.0.2) unstable; urgency=medium * Apt.mirror can be used to set the preferred apt mirror of a host, diff --git a/joeyconfig.hs b/joeyconfig.hs --- a/joeyconfig.hs +++ b/joeyconfig.hs @@ -38,6 +38,7 @@ import qualified Propellor.Property.SiteSpecific.Branchable as Branchable import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites import Propellor.Property.DiskImage +import Propellor.Property.Bootstrap main :: IO () -- _ ______`| ,-.__ main = defaultMain hosts -- / \___-=O`/|O`/__| (____.' @@ -81,6 +82,7 @@ darkstar :: Host darkstar = host "darkstar.kitenet.net" $ props + & osDebian Unstable X86_64 & ipv6 "2001:4830:1600:187::2" & Aiccu.hasConfig "T18376" "JHZ2-SIXXS" @@ -93,7 +95,7 @@ [ (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQC1YoyHxZwG5Eg0yiMTJLSWJ/+dMM6zZkZiR4JJ0iUfP+tT2bm/lxYompbSqBeiCq+PYcSC67mALxp1vfmdOV//LWlbXfotpxtyxbdTcQbHhdz4num9rJQz1tjsOsxTEheX5jKirFNC5OiKhqwIuNydKWDS9qHGqsKcZQ8p+n1g9Lr3nJVGY7eRRXzw/HopTpwmGmAmb9IXY6DC2k91KReRZAlOrk0287LaK3eCe1z0bu7LYzqqS+w99iXZ/Qs0m9OqAPnHZjWQQ0fN4xn5JQpZSJ7sqO38TBAimM+IHPmy2FTNVVn9zGM+vN1O2xr3l796QmaUG1+XLL0shfR/OZbb joey@darkstar") ] - ! imageBuilt "/tmp/img" c MSDOS (grubBooted PC) + & imageBuilt "/srv/propellor-disk.img" c MSDOS (grubBooted PC) [ partition EXT2 `mountedAt` "/boot" `setFlag` BootFlag , partition EXT4 `mountedAt` "/" @@ -106,6 +108,7 @@ & Hostname.setTo "demo" & Apt.installed ["linux-image-amd64"] & User "root" `User.hasInsecurePassword` "root" + & bootstrappedFrom GitRepoOutsideChroot gnu :: Host gnu = host "gnu.kitenet.net" $ props @@ -651,8 +654,8 @@ & ipv6 "2001:4830:1600:492::2" & ipv4 "67.223.19.96" , host "animx" $ props - & ipv4 "76.7.162.101" & ipv4 "76.7.162.186" + & ipv4 "76.7.162.187" ] diff --git a/propellor.cabal b/propellor.cabal --- a/propellor.cabal +++ b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 4.0.2 +Version: 4.0.3 Cabal-Version: >= 1.8 License: BSD2 Maintainer: Joey Hess @@ -87,6 +87,7 @@ Propellor.Property.Apt Propellor.Property.Apt.PPA Propellor.Property.Attic + Propellor.Property.Bootstrap Propellor.Property.Borg Propellor.Property.Ccache Propellor.Property.Cmd @@ -231,4 +232,4 @@ source-repository head type: git - location: git://git.joeyh.name/propellor.git + location: https://git.joeyh.name/git/propellor.git diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -144,7 +144,7 @@ -- assume a debian derived system when not specified Nothing -> use apt where - use cmds = "if ! git --version >/dev/null; then " ++ intercalate " && " cmds ++ "; fi" + use cmds = "if ! git --version >/dev/null 2>&1; then " ++ intercalate " && " cmds ++ "; fi" apt = [ "apt-get update" , "DEBIAN_FRONTEND=noninteractive apt-get -qq --no-install-recommends --no-upgrade -y install git" diff --git a/src/Propellor/Property/Bootstrap.hs b/src/Propellor/Property/Bootstrap.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Bootstrap.hs @@ -0,0 +1,111 @@ +module Propellor.Property.Bootstrap (RepoSource(..), bootstrappedFrom, clonedFrom) where + +import Propellor.Base +import Propellor.Bootstrap +import Propellor.Property.Chroot + +import Data.List +import qualified Data.ByteString as B + +-- | Where a propellor repository should be bootstrapped from. +data RepoSource + = GitRepoUrl String + | GitRepoOutsideChroot + -- ^ When used in a chroot, this copies the git repository from + -- outside the chroot, including its configuration. + +-- | Bootstraps a propellor installation into +-- /usr/local/propellor/ +-- +-- Normally, propellor is already bootstrapped when it runs, so this +-- property is not useful. However, this can be useful inside a +-- chroot used to build a disk image, to make the disk image +-- have propellor installed. +-- +-- The git repository is cloned (or pulled to update if it already exists). +-- +-- All build dependencies are installed, using distribution packages +-- or falling back to using cabal. +bootstrappedFrom :: RepoSource -> Property Linux +bootstrappedFrom reposource = go `requires` clonedFrom reposource + where + go :: Property Linux + go = property "Propellor bootstrapped" $ do + system <- getOS + assumeChange $ exposeTrueLocaldir $ const $ + runShellCommand $ buildShellCommand + [ "cd " ++ localdir + , bootstrapPropellorCommand system + ] + +-- | Clones the propellor repeository into /usr/local/propellor/ +-- +-- If the propellor repo has already been cloned, pulls to get it +-- up-to-date. +clonedFrom :: RepoSource -> Property Linux +clonedFrom reposource = case reposource of + GitRepoOutsideChroot -> go `onChange` copygitconfig + _ -> go + where + go :: Property Linux + go = property ("Propellor repo cloned from " ++ sourcedesc) $ + ifM needclone (makeclone, updateclone) + + makeclone = do + let tmpclone = localdir ++ ".tmpclone" + system <- getOS + assumeChange $ exposeTrueLocaldir $ \sysdir -> do + let originloc = case reposource of + GitRepoUrl s -> s + GitRepoOutsideChroot -> sysdir + runShellCommand $ buildShellCommand + [ installGitCommand system + , "rm -rf " ++ tmpclone + , "git clone " ++ shellEscape originloc ++ " " ++ tmpclone + , "mkdir -p " ++ localdir + -- This is done rather than deleting + -- the old localdir, because if it is bound + -- mounted from outside the chroot, deleting + -- it after unmounting in unshare will remove + -- the bind mount outside the unshare. + , "(cd " ++ tmpclone ++ " && tar c .) | (cd " ++ localdir ++ " && tar x)" + , "rm -rf " ++ tmpclone + ] + + updateclone = assumeChange $ exposeTrueLocaldir $ const $ + runShellCommand $ buildShellCommand + [ "cd " ++ localdir + , "git pull" + ] + + -- Copy the git config of the repo outside the chroot into the + -- chroot. This way it has the same remote urls, and other git + -- configuration. + copygitconfig :: Property Linux + copygitconfig = property ("Propellor repo git config copied from outside the chroot") $ do + let gitconfig = localdir <> ".git" <> "config" + cfg <- liftIO $ B.readFile gitconfig + exposeTrueLocaldir $ const $ + liftIO $ B.writeFile gitconfig cfg + return MadeChange + + needclone = (inChroot <&&> truelocaldirisempty) + <||> (liftIO (not <$> doesDirectoryExist localdir)) + + truelocaldirisempty = exposeTrueLocaldir $ const $ + runShellCommand ("test ! -d " ++ localdir ++ "/.git") + + sourcedesc = case reposource of + GitRepoUrl s -> s + GitRepoOutsideChroot -> localdir ++ " outside the chroot" + +assumeChange :: Propellor Bool -> Propellor Result +assumeChange a = do + ok <- a + return (cmdResult ok <> MadeChange) + +buildShellCommand :: [String] -> String +buildShellCommand = intercalate "&&" . map (\c -> "(" ++ c ++ ")") + +runShellCommand :: String -> Propellor Bool +runShellCommand s = liftIO $ boolSystem "sh" [ Param "-c", Param s] diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -11,6 +11,7 @@ ChrootTarball(..), noServices, inChroot, + exposeTrueLocaldir, -- * Internal use provisioned', propagateChrootInfo, @@ -294,6 +295,38 @@ newtype InChroot = InChroot Bool deriving (Typeable, Show) + +-- | Runs an action with the true localdir exposed, +-- not the one bind-mounted into a chroot. The action is passed the +-- path containing the contents of the localdir outside the chroot. +-- +-- In a chroot, this is accomplished by temporily bind mounting the localdir +-- to a temp directory, to preserve access to the original bind mount. Then +-- we unmount the localdir to expose the true localdir. Finally, to cleanup, +-- the temp directory is bind mounted back to the localdir. +exposeTrueLocaldir :: (FilePath -> Propellor a) -> Propellor a +exposeTrueLocaldir a = ifM inChroot + ( withTmpDirIn (takeDirectory localdir) "propellor.tmp" $ \tmpdir -> + bracket_ + (movebindmount localdir tmpdir) + (movebindmount tmpdir localdir) + (a tmpdir) + , a localdir + ) + where + movebindmount from to = liftIO $ do + run "mount" [Param "--bind", File from, File to] + -- Have to lazy unmount, because the propellor process + -- is running in the localdir that it's unmounting.. + run "umount" [Param "-l", File from] + -- We were in the old localdir; move to the new one after + -- flipping the bind mounts. Otherwise, commands that try + -- to access the cwd will fail because it got umounted out + -- from under. + changeWorkingDirectory "/" + changeWorkingDirectory localdir + run cmd ps = unlessM (boolSystem cmd ps) $ + error $ "exposeTrueLocaldir failed to run " ++ show (cmd, ps) -- | Generates a Chroot that has all the properties of a Host. -- diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs --- a/src/Propellor/Property/Cmd.hs +++ b/src/Propellor/Property/Cmd.hs @@ -33,6 +33,7 @@ Script, scriptProperty, userScriptProperty, + cmdResult, -- * Lower-level interface for running commands CommandParam(..), boolSystem, diff --git a/src/Propellor/Property/Fstab.hs b/src/Propellor/Property/Fstab.hs --- a/src/Propellor/Property/Fstab.hs +++ b/src/Propellor/Property/Fstab.hs @@ -24,19 +24,32 @@ -- Note that if anything else is already mounted at the `MountPoint`, it -- will be left as-is by this property. mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property Linux -mounted fs src mnt opts = tightenTargets $ - "/etc/fstab" `File.containsLine` l - `describe` (mnt ++ " mounted by fstab") +mounted fs src mnt opts = tightenTargets $ + listed fs src mnt opts `onChange` mountnow where - l = intercalate "\t" [src, mnt, fs, formatMountOpts opts, dump, passno] - dump = "0" - passno = "2" -- This use of mountPoints, which is linux-only, is why this -- property currently only supports linux. mountnow = check (notElem mnt <$> mountPoints) $ cmdProperty "mount" [mnt] +-- | Ensures that contains a line mounting the specified +-- `Source` on the specified `MountPoint`. Does not ensure that it's +-- currently `mounted`. +listed :: FsType -> Source -> MountPoint -> MountOpts -> Property UnixLike +listed fs src mnt opts = "/etc/fstab" `File.containsLine` l + `describe` (mnt ++ " mounted by fstab") + where + l = intercalate "\t" [src, mnt, fs, formatMountOpts opts, dump, passno] + dump = "0" + passno = "2" + +-- | Ensures that contains a line enabling the specified +-- `Source` to be used as swap space, and that it's enabled. +swap :: Source -> Property Linux +swap src = listed "swap" src "none" mempty + `onChange` swapOn src + newtype SwapPartition = SwapPartition FilePath -- | Replaces with a file that should cause the currently @@ -77,8 +90,8 @@ , pure "0" , pure (if mnt == "/" then "1" else "2") ] - getswapcfg (SwapPartition swap) = sequence - [ fromMaybe swap <$> getM (\a -> a swap) + getswapcfg (SwapPartition s) = sequence + [ fromMaybe s <$> getM (\a -> a s) [ uuidprefix getSourceUUID , sourceprefix getSourceLabel ] diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs --- a/src/Propellor/Property/Mount.hs +++ b/src/Propellor/Property/Mount.hs @@ -40,6 +40,9 @@ formatMountOpts (MountOpts l) = intercalate "," l -- | Mounts a device, without listing it in . +-- +-- Note that this property will fail if the device is already mounted +-- at the MountPoint. mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property UnixLike mounted fs src mnt opts = property (mnt ++ " mounted") $ toResult <$> liftIO (mount fs src mnt opts) @@ -51,6 +54,17 @@ cmdProperty "mount" ["--bind", src, dest] `assume` MadeChange `describe` ("bind mounted " ++ src ++ " to " ++ dest) + +-- | Enables swapping to a device, which must be formatted already as a swap +-- partition. +swapOn :: Source -> RevertableProperty Linux Linux +swapOn mnt = tightenTargets doswapon tightenTargets doswapoff + where + swaps = lines <$> readProcess "swapon" ["--show=NAME"] + doswapon = check (notElem mnt <$> swaps) $ + cmdProperty "swapon" [mnt] + doswapoff = check (elem mnt <$> swaps) $ + cmdProperty "swapoff" [mnt] mount :: FsType -> Source -> MountPoint -> MountOpts -> IO Bool mount fs src mnt opts = boolSystem "mount" $ diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs --- a/src/Propellor/Property/SiteSpecific/JoeySites.hs +++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -573,8 +573,8 @@ , "# Enable postgrey." , "smtpd_recipient_restrictions = permit_tls_clientcerts,permit_sasl_authenticated,,permit_mynetworks,reject_unauth_destination,check_policy_service inet:127.0.0.1:10023" - , "# Enable spamass-milter, amavis-milter, opendkim" - , "smtpd_milters = unix:/spamass/spamass.sock unix:amavis/amavis.sock inet:localhost:8891" + , "# Enable spamass-milter, amavis-milter (opendkim is not enabled because it causes mails forwarded from eg gmail to be rejected)" + , "smtpd_milters = unix:/spamass/spamass.sock unix:amavis/amavis.sock" , "# opendkim is used for outgoing mail" , "non_smtpd_milters = inet:localhost:8891" , "milter_connect_macros = j {daemon_name} v {if_name} _" diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -87,7 +87,7 @@ -- And now we can run it. unlessM (boolSystemNonConcurrent "ssh" (map Param $ cacheparams ++ ["-t", sshtarget, shellWrap runcmd])) $ - error "remote propellor failed" + giveup "remote propellor failed" where hn = fromMaybe target relay sys = case fromInfo (hostInfo hst) of