propellor 4.0.2 → 4.0.3

raw patch · 12 files changed

+210/−16 lines, 12 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG +9/−0
• debian/changelog +9/−0
• joeyconfig.hs +5/−2
• propellor.cabal +3/−2
• src/Propellor/Bootstrap.hs +1/−1
• src/Propellor/Property/Bootstrap.hs +111/−0
• src/Propellor/Property/Chroot.hs +33/−0
• src/Propellor/Property/Cmd.hs +1/−0
• src/Propellor/Property/Fstab.hs +21/−8
• src/Propellor/Property/Mount.hs +14/−0
• src/Propellor/Property/SiteSpecific/JoeySites.hs +2/−2
• src/Propellor/Spin.hs +1/−1

@@ -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 <id@joeyh.name>  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,

@@ -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 <id@joeyh.name>  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,

@@ -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" 	]  

@@ -1,5 +1,5 @@ Name: propellor-Version: 4.0.2+Version: 4.0.3 Cabal-Version: >= 1.8 License: BSD2 Maintainer: Joey Hess <id@joeyh.name>@@ -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

@@ -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"

@@ -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]

@@ -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. -- 

@@ -33,6 +33,7 @@ 	Script, 	scriptProperty, 	userScriptProperty,+	cmdResult, 	-- * Lower-level interface for running commands 	CommandParam(..), 	boolSystem,

@@ -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 </etc/fstab> 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 </etc/fstab> 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 </etc/fstab> 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 			]

@@ -40,6 +40,9 @@ formatMountOpts (MountOpts l) = intercalate "," l  -- | Mounts a device, without listing it in </etc/fstab>.+--+-- 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" $

@@ -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} _"

@@ -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