propellor 4.9.0 → 5.0.0

raw patch · 24 files changed

+881/−211 lines, 24 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG +23/−0
• debian/changelog +23/−0
• joeyconfig.hs +31/−32
• propellor.cabal +5/−1
• src/Propellor/Bootstrap.hs +4/−2
• src/Propellor/Property.hs +8/−0
• src/Propellor/Property/Chroot.hs +0/−22
• src/Propellor/Property/Debootstrap.hs +34/−3
• src/Propellor/Property/DiskImage.hs +77/−34
• src/Propellor/Property/DiskImage/PartSpec.hs +171/−18
• src/Propellor/Property/Fail2Ban.hs +35/−5
• src/Propellor/Property/FlashKernel.hs +63/−0
• src/Propellor/Property/Machine.hs +201/−0
• src/Propellor/Property/Mount.hs +12/−8
• src/Propellor/Property/Parted.hs +20/−3
• src/Propellor/Property/PropellorRepo.hs +3/−1
• src/Propellor/Property/Qemu.hs +49/−0
• src/Propellor/Property/Service.hs +33/−1
• src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +1/−1
• src/Propellor/Property/SiteSpecific/GitHome.hs +8/−1
• src/Propellor/Property/SiteSpecific/JoeySites.hs +29/−21
• src/Propellor/Property/Uboot.hs +36/−0
• src/Propellor/Types/Bootloader.hs +11/−2
• src/Propellor/Types/PartSpec.hs +4/−56

@@ -1,3 +1,26 @@+propellor (5.0.0) unstable; urgency=medium++  * Debootstrap.built now supports bootstrapping chroots for foreign+    OS's, using qemu-user-static.+  * Machine: New module collecting machine-specific properties for +    building bootable images for ARM boards.+    Tested working boards: Olimex Lime, CubieTruck, Banana Pi, SheevaPlug.+  * Diskimage.imageBuiltFor: New property to build a disk image for a Host,+    using partition table information configured via the new properties+    hasPartitionTableType, hasPartition and adjustPartition.+  * Chroot.noServices moved to Service.noServices and its type changed.+    (API change)+  * Service: Avoid starting services when noServices is used.+  * Add Typeable instance to OriginUrl, fixing build with old versions+    of ghc.+  * Added Propellor.Property.impossible+  * Fail2Ban: Added several additional properties.+    Thanks, Félix Sipma.+  * Fail2Ban: Renamed jail.d conf file to use .local.+    Thanks, Félix Sipma.++ -- Joey Hess <id@joeyh.name>  Sun, 19 Nov 2017 15:42:44 -0400+ propellor (4.9.0) unstable; urgency=medium    * When the ipv4 and ipv6 properties are used with a container, avoid

@@ -1,3 +1,26 @@+propellor (5.0.0) unstable; urgency=medium++  * Debootstrap.built now supports bootstrapping chroots for foreign+    OS's, using qemu-user-static.+  * Machine: New module collecting machine-specific properties for +    building bootable images for ARM boards.+    Tested working boards: Olimex Lime, CubieTruck, Banana Pi, SheevaPlug.+  * Diskimage.imageBuiltFor: New property to build a disk image for a Host,+    using partition table information configured via the new properties+    hasPartitionTableType, hasPartition and adjustPartition.+  * Chroot.noServices moved to Service.noServices and its type changed.+    (API change)+  * Service: Avoid starting services when noServices is used.+  * Add Typeable instance to OriginUrl, fixing build with old versions+    of ghc.+  * Added Propellor.Property.impossible+  * Fail2Ban: Added several additional properties.+    Thanks, Félix Sipma.+  * Fail2Ban: Renamed jail.d conf file to use .local.+    Thanks, Félix Sipma.++ -- Joey Hess <id@joeyh.name>  Sun, 19 Nov 2017 15:42:44 -0400+ propellor (4.9.0) unstable; urgency=medium    * When the ipv4 and ipv6 properties are used with a container, avoid

@@ -6,6 +6,8 @@ import Propellor.Property.Scheduled import Propellor.Property.DiskImage import Propellor.Property.Chroot+import Propellor.Property.Machine+import Propellor.Property.Bootstrap import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Network as Network@@ -23,6 +25,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.Locale as Locale import qualified Propellor.Property.Grub as Grub import qualified Propellor.Property.Borg as Borg import qualified Propellor.Property.Gpg as Gpg@@ -94,16 +97,9 @@ 	& 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 (VirtualBoxPointer "/srv/test.vmdk") mychroot MSDOS-		[ partition EXT2 `mountedAt` "/boot"-		, partition EXT4 `mountedAt` "/"-		, swapPartition (MegaBytes 256)-		]-  where-	mychroot d = debootstrapped mempty d $ props-		& osDebian Unstable X86_64-		& Apt.installed ["linux-image-amd64"]-		& Grub.installed PC+	& imageBuiltFor honeybee+		(RawDiskImage "/srv/honeybee.img")+		(Debootstrapped mempty)  gnu :: Host gnu = host "gnu.kitenet.net" $ props@@ -184,22 +180,30 @@ honeybee = host "honeybee.kitenet.net" $ props 	& standardSystem Testing ARMHF 		[ "Home router and arm git-annex build box." ]--	-- Hard to get console access, so no automatic upgrades,-	-- and try to be robust.-	& "/etc/default/rcS" `File.containsLine` "FSCKFIX=yes"--	-- Cubietruck-	& Apt.installed ["flash-kernel"]-	& "/etc/flash-kernel/machine" `File.hasContent` ["Cubietech Cubietruck"]-	& Apt.installed ["linux-image-armmp"]+	+	& cubietech_Cubietruck+	& hasPartition+		( partition EXT2+			`mountedAt` "/boot"+			`partLocation` Beginning+			`setSize` MegaBytes 200+		)+	& hasPartition+		( partition EXT4+			`mountedAt` "/"+			`addFreeSpace` MegaBytes 500+		)+	 	& Apt.installed ["firmware-brcm80211"] 		-- Workaround for https://bugs.debian.org/844056 		`requires` File.hasPrivContent "/lib/firmware/brcm/brcmfmac43362-sdio.txt" anyContext 		`requires` File.dirExists "/lib/firmware/brcm"--	-- No hardware clock-	& Apt.serviceInstalledRunning "ntp"+	& "/etc/default/rcS" `File.containsLine` "FSCKFIX=yes"+	& Apt.serviceInstalledRunning "ntp" -- no hardware clock+	& bootstrappedFrom GitRepoOutsideChroot+	& Ssh.hostKeys hostContext+		[ (SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIIS/hDYq1MAxfOBf49htym3BOYlx4Gk9SDpiHjv7u6IC")+		]  	& JoeySites.homePowerMonitor 		(User "joey")@@ -209,19 +213,13 @@ 	& Apt.installed ["mtr-tiny", "iftop", "screen"] 	& Postfix.satellite -	& Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer-		GitAnnexBuilder.armAutoBuilder-		Unstable ARMEL Nothing (Cron.Times "15 10 * * *") "10h")-	-- Disabled because it does not work, and the old systemd-	-- in the container uses a ton of CPU-	! Systemd.nspawned (GitAnnexBuilder.autoBuilderContainer-		GitAnnexBuilder.stackAutoBuilder-		(Stable "jessie") ARMEL (Just "ancient") weekdays "10h")+	& check (not <$> inChroot) (setupRevertableProperty autobuilder) 	-- In case compiler needs more than available ram 	& Apt.serviceInstalledRunning "swapspace"   where-	weekdays = Cron.Times "15 10 * * 2-5"-	-- weekends = Cron.Times "15 10 * * 6-7"+	autobuilder = Systemd.nspawned $ GitAnnexBuilder.autoBuilderContainer+		GitAnnexBuilder.armAutoBuilder+		Unstable ARMEL Nothing (Cron.Times "15 10 * * *") "10h"  -- This is not a complete description of kite, since it's a -- multiuser system with eg, user passwords that are not deployed@@ -565,6 +563,7 @@ 	& osDebian suite arch 	& Hostname.sane 	& Hostname.searchDomain+	& Locale.available "en_US.UTF-8" 	& File.hasContent "/etc/motd" ("":motd++[""]) 	& Apt.stdSourcesList `onChange` Apt.upgrade 	& Apt.cacheCleaned

@@ -1,5 +1,5 @@ Name: propellor-Version: 4.9.0+Version: 5.0.0 Cabal-Version: >= 1.20 License: BSD2 Maintainer: Joey Hess <id@joeyh.name>@@ -111,6 +111,7 @@     Propellor.Property.File     Propellor.Property.Firejail     Propellor.Property.Firewall+    Propellor.Property.FlashKernel     Propellor.Property.FreeBSD     Propellor.Property.FreeBSD.Pkg     Propellor.Property.FreeBSD.Poudriere@@ -128,6 +129,7 @@     Propellor.Property.Locale     Propellor.Property.Logcheck     Propellor.Property.Lvm+    Propellor.Property.Machine     Propellor.Property.Mount     Propellor.Property.Network     Propellor.Property.Nginx@@ -141,6 +143,7 @@     Propellor.Property.Postfix     Propellor.Property.PropellorRepo     Propellor.Property.Prosody+    Propellor.Property.Qemu     Propellor.Property.Reboot     Propellor.Property.Restic     Propellor.Property.Rsync@@ -154,6 +157,7 @@     Propellor.Property.Systemd.Core     Propellor.Property.Timezone     Propellor.Property.Tor+    Propellor.Property.Uboot     Propellor.Property.Unbound     Propellor.Property.User     Propellor.Property.Uwsgi

@@ -80,7 +80,7 @@   where 	go Cabal = 		[ "cabal configure"-		, "cabal build propellor-config"+		, "cabal build -j1 propellor-config" 		, "ln -sf dist/build/propellor-config/propellor-config propellor" 		] 	go Stack =@@ -280,7 +280,9 @@ 				boolSystem "sh" [Param "-c", Param (depsCommand (Robustly Cabal) (Just sys))] 					<&&> cabal ["configure"] 		)-	cabal_build = cabal ["build", "propellor-config"]+	-- The -j1 is to only run one job at a time -- in some situations,+	-- eg in qemu, ghc does not run reliably in parallel.+	cabal_build = cabal ["build", "-j1", "propellor-config"]  stackBuild :: Maybe System -> IO Bool stackBuild _msys = do

@@ -32,6 +32,7 @@ 	, makeChange 	, noChange 	, doNothing+	, impossible 	, endAction 	-- * Property result checking 	, UncheckedProperty@@ -62,6 +63,7 @@ import Propellor.Types.MetaTypes import Propellor.Types.Singletons import Propellor.Info+import Propellor.Message import Propellor.EnsureProperty import Utility.Exception import Utility.Monad@@ -363,6 +365,12 @@ -- This is the same as `mempty` from the `Monoid` instance. doNothing :: SingI t => Property (MetaTypes t) doNothing = mempty++-- | In situations where it's not possible to provide a property that+-- works, this can be used to make a property that always fails with an+-- error message you provide.+impossible :: SingI t => String -> Property (MetaTypes t)+impossible msg = property "impossible" $ errorMessage msg  -- | Registers an action that should be run at the very end, after -- propellor has checks all the properties of a host.

@@ -9,7 +9,6 @@ 	ChrootBootstrapper(..), 	Debootstrapped(..), 	ChrootTarball(..),-	noServices, 	inChroot, 	exposeTrueLocaldir, 	-- * Internal use@@ -32,7 +31,6 @@ import qualified Propellor.Property.File as File import qualified Propellor.Shim as Shim import Propellor.Property.Mount-import Utility.FileMode import Utility.Split  import qualified Data.Map as M@@ -256,26 +254,6 @@  chrootDesc :: Chroot -> String -> String chrootDesc (Chroot loc _ _ _) desc = "chroot " ++ loc ++ " " ++ desc---- | Adding this property to a chroot prevents daemons and other services--- from being started, which is often something you want to prevent when--- building a chroot.------ On Debian, this is accomplished by installing a </usr/sbin/policy-rc.d>--- script that does not let any daemons be started by packages that use--- invoke-rc.d. Reverting the property removes the script.------ This property has no effect on non-Debian systems.-noServices :: RevertableProperty UnixLike UnixLike-noServices = setup <!> teardown-  where-	f = "/usr/sbin/policy-rc.d"-	script = [ "#!/bin/sh", "exit 101" ]-	setup = combineProperties "no services started" $ toProps-		[ File.hasContent f script-		, File.mode f (combineModes (readModes ++ executeModes))-		]-	teardown = File.notPresent f  -- | Check if propellor is currently running within a chroot. --

@@ -1,3 +1,5 @@+{-# LANGUAGE TypeFamilies #-}+ module Propellor.Property.Debootstrap ( 	Url, 	DebootstrapConfig(..),@@ -6,12 +8,12 @@ 	extractSuite, 	installed, 	sourceInstall,-	programPath, ) where  import Propellor.Base import qualified Propellor.Property.Apt as Apt import Propellor.Property.Chroot.Util+import Propellor.Property.Qemu import Utility.Path import Utility.FileMode @@ -29,6 +31,7 @@ 	| MinBase 	| BuilddD 	| DebootstrapParam String+	| UseEmulation 	| DebootstrapConfig :+ DebootstrapConfig 	deriving (Show) @@ -41,15 +44,41 @@ toParams MinBase = [Param "--variant=minbase"] toParams BuilddD = [Param "--variant=buildd"] toParams (DebootstrapParam p) = [Param p]+toParams UseEmulation = [] toParams (c1 :+ c2) = toParams c1 <> toParams c2 +useEmulation :: DebootstrapConfig -> Bool+useEmulation UseEmulation = True+useEmulation (a :+ b) = useEmulation a || useEmulation b+useEmulation _ = False+ -- | Builds a chroot in the given directory using debootstrap. -- -- The System can be any OS and architecture that debootstrap -- and the kernel support.+--+-- When the System is architecture that the kernel does not support,+-- it can still be bootstrapped using emulation. This is determined+-- by checking `supportsArch`, or can be configured with `UseEmulation`.+--+-- When emulation is used, the chroot will have an additional binary +-- installed in it. To get a completelty clean chroot (eg for producing a+-- bootable disk image), use the `removeHostEmulationBinary` property. built :: FilePath -> System -> DebootstrapConfig -> Property Linux-built target system config = built' (setupRevertableProperty installed) target system config+built target system@(System _ targetarch) config =+	withOS ("debootstrapped " ++ target) go+  where+	go w (Just hostos)+		| supportsArch hostos targetarch && not (useEmulation config) =+			ensureProperty w $+				built' (setupRevertableProperty installed)+					target system config+	go w _ = ensureProperty w $ do+		let p = setupRevertableProperty foreignBinariesEmulated+			`before` setupRevertableProperty installed+		built' p target system (config :+ UseEmulation) +-- | Like `built`,  but uses the provided Property to install debootstrap. built' :: Property Linux -> FilePath -> System -> DebootstrapConfig -> Property Linux built' installprop target system@(System _ arch) config =  	go `before` oldpermfix@@ -68,7 +97,9 @@ 			, Param suite 			, Param target 			]-		cmd <- fromMaybe "debootstrap" <$> programPath+		cmd <- if useEmulation config+			then pure "qemu-debootstrap"+			else fromMaybe "debootstrap" <$> programPath 		de <- standardPathEnv 		ifM (boolSystemEnv cmd params (Just de)) 			( return MadeChange

@@ -13,6 +13,8 @@ 	VirtualBoxPointer(..), 	imageBuilt, 	imageRebuilt,+	imageBuiltFor,+	imageRebuiltFor, 	imageBuiltFrom, 	imageExists, 	Grub.BIOS(..),@@ -24,9 +26,12 @@ import Propellor.Property.Chroot.Util (removeChroot) import Propellor.Property.Mount import qualified Propellor.Property.Chroot as Chroot+import qualified Propellor.Property.Service as Service import qualified Propellor.Property.Grub as Grub import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt+import qualified Propellor.Property.Qemu as Qemu+import qualified Propellor.Property.FlashKernel as FlashKernel import Propellor.Property.Parted import Propellor.Property.Fstab (SwapPartition(..), genFstab) import Propellor.Property.Partition@@ -101,7 +106,7 @@ -- to avoid expensive IO to generate a new one. And, it's updated in-place, -- so its contents are undefined during the build process. ----- Note that the `Chroot.noServices` property is automatically added to the+-- Note that the `Service.noServices` property is automatically added to the -- chroot while the disk image is being built, which should prevent any -- daemons that are included from being started on the system that is -- building the disk image.@@ -131,37 +136,60 @@ -- > 		& User.hasPassword (User "demo") -- >		& User.hasDesktopGroups (User "demo") -- > 		& ...+imageBuilt :: DiskImage d => d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux+imageBuilt = imageBuilt' False++-- | Like 'imageBuilt', 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 d => d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux+imageRebuilt = imageBuilt' True++-- | Create a bootable disk image for a Host. ----- This can also be used with `Chroot.hostChroot` to build a disk image--- that has all the properties of a Host. For example:+-- This works just like 'imageBuilt', but partition table is+-- determined by looking at the Host's 'hasPartitionTableType',+-- `hasPartition', and 'adjustPartition' properties. --+-- For example:+-- -- > foo :: Host -- > foo = host "foo.example.com" $ props--- >	& imageBuilt (RawDiskImage "/srv/diskimages/bar-disk.img")--- >		(hostChroot bar (Debootstrapped mempty))--- >		MSDOS--- >		[ partition EXT2 `mountedAt` "/boot"--- >			`setFlag` BootFlag--- >		, partition EXT4 `mountedAt` "/"--- >			`addFreeSpace` MegaBytes 5000--- >		, swapPartition (MegaBytes 256)--- >		]+-- >	& imageBuiltFor bar+-- >		(RawDiskImage "/srv/diskimages/bar-disk.img")+-- >		(Debootstrapped mempty) -- > -- > bar :: Host -- > bar = host "bar.example.com" $ props+-- >	& hasPartiton+-- >		( partition EXT2+-- >		`mountedAt` "/boot"+-- >		`partLocation` Beginning+-- >		`addFreeSpace` MegaBytes 150+-- >		)+-- >	& hasPartiton+-- >		( partition EXT4+-- >		`mountedAt` "/"+-- >		`addFreeSpace` MegaBytes 500+-- >		) -- >	& osDebian Unstable X86_64 -- >	& Apt.installed ["linux-image-amd64"] -- >	& Grub.installed PC -- >	& hasPassword (User "root")-imageBuilt :: DiskImage d => d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux-imageBuilt = imageBuilt' False+imageBuiltFor :: (DiskImage d, Chroot.ChrootBootstrapper bootstrapper) => Host -> d -> bootstrapper -> RevertableProperty (HasInfo + DebianLike) Linux+imageBuiltFor = imageBuiltFor' 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 d => d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux-imageRebuilt = imageBuilt' True+-- | Like 'imageBuiltFor', but the chroot is deleted and rebuilt from+-- scratch each time.+imageRebuiltFor :: (DiskImage d, Chroot.ChrootBootstrapper bootstrapper) => Host -> d -> bootstrapper -> RevertableProperty (HasInfo + DebianLike) Linux+imageRebuiltFor = imageBuiltFor' False +imageBuiltFor' :: (DiskImage d, Chroot.ChrootBootstrapper bootstrapper) => Bool -> Host -> d -> bootstrapper -> RevertableProperty (HasInfo + DebianLike) Linux+imageBuiltFor' rebuild h d bs =+	imageBuilt' rebuild d (Chroot.hostChroot h bs) tt pil+  where+	PartTableSpec tt pil = toPartTableSpec (fromInfo (hostInfo h))+ 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@@ -183,7 +211,7 @@ 		in setContainerProps c $ containerProps c 			-- Before ensuring any other properties of the chroot, 			-- avoid starting services. Reverted by imageFinalized.-			&^ Chroot.noServices+			&^ Service.noServices 			& cachesCleaned 	-- Only propagate privdata Info from this chroot, nothing else. 	propprivdataonly (Chroot.Chroot d b ip h) =@@ -191,8 +219,14 @@ 	-- Pick boot loader finalization based on which bootloader is 	-- installed. 	final = case fromInfo (containerInfo chroot) of-		[GrubInstalled] -> grubBooted 		[] -> unbootable "no bootloader is installed"+		[GrubInstalled] -> grubFinalized+		[UbootInstalled p] -> ubootFinalized p+		[FlashKernelInstalled] -> flashKernelFinalized+		[UbootInstalled p, FlashKernelInstalled] -> +			ubootFlashKernelFinalized p+		[FlashKernelInstalled, UbootInstalled p] -> +			ubootFlashKernelFinalized p 		_ -> unbootable "multiple bootloaders are installed; don't know which to use"  -- | This property is automatically added to the chroot when building a@@ -215,7 +249,7 @@ 		liftIO $ unmountBelow chrootdir 		szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize 			<$> liftIO (dirSizes chrootdir)-		let calcsz mnts = maybe defSz fudge . getMountSz szm mnts+		let calcsz mnts = maybe defSz fudgeSz . getMountSz szm mnts 		-- tie the knot! 		let (mnts, mntopts, parttable) = fitChrootSize tabletype partspec $ 			map (calcsz mnts) mnts@@ -228,7 +262,7 @@ 	mkimg' mnts mntopts parttable devs = 		partitionsPopulated chrootdir mnts mntopts devs 			`before`-		imageFinalized final mnts mntopts devs parttable+		imageFinalized final dest mnts mntopts devs parttable 	rmimg = undoRevertableProperty (buildDiskImage img) 		`before` undoRevertableProperty (imageExists' dest dummyparttable) 	dummyparttable = PartTable tabletype []@@ -351,10 +385,10 @@ -- -- It's ok if the property leaves additional things mounted -- in the partition tree.-type Finalization = (FilePath -> [LoopDev] -> Property Linux)+type Finalization = (RawDiskImage -> FilePath -> [LoopDev] -> Property Linux) -imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux-imageFinalized final mnts mntopts devs (PartTable _ parts) =+imageFinalized :: Finalization -> RawDiskImage -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux+imageFinalized final img mnts mntopts devs (PartTable _ parts) = 	property' "disk image finalized" $ \w -> 		withTmpDir "mnt" $ \top -> 			go w top `finally` liftIO (unmountall top)@@ -363,7 +397,9 @@ 		liftIO $ mountall top 		liftIO $ writefstab top 		liftIO $ allowservices top-		ensureProperty w $ final top devs+		ensureProperty w $ +			final img top devs+				`before` Qemu.removeHostEmulationBinary top  	-- Ordered lexographically by mount point, so / comes before /usr 	-- comes before /usr/local@@ -399,18 +435,14 @@ 	allowservices top = nukeFile (top ++ "/usr/sbin/policy-rc.d")  unbootable :: String -> Finalization-unbootable msg = \_ _ -> property desc $ do+unbootable msg = \_ _ _ -> property desc $ do 	warningMessage (desc ++ ": " ++ msg) 	return FailedChange   where 	desc = "image is not bootable" --- | Makes grub be the boot loader of the disk image.------ This does not install the grub package. You will need to add--- the `Grub.installed` property to the chroot.-grubBooted :: Finalization-grubBooted mnt loopdevs = Grub.bootsMounted mnt wholediskloopdev+grubFinalized :: Finalization+grubFinalized _img mnt loopdevs = Grub.bootsMounted mnt wholediskloopdev 	`describe` "disk image boots using grub"   where 	-- It doesn't matter which loopdev we use; all@@ -419,6 +451,17 @@ 	wholediskloopdev = case loopdevs of 		(l:_) -> wholeDiskLoopDev l 		[] -> error "No loop devs provided!"++ubootFinalized :: (FilePath -> FilePath -> Property Linux) -> Finalization+ubootFinalized p (RawDiskImage img) mnt _loopdevs = p img mnt++flashKernelFinalized :: Finalization+flashKernelFinalized _img mnt _loopdevs = FlashKernel.flashKernelMounted mnt++ubootFlashKernelFinalized :: (FilePath -> FilePath -> Property Linux) -> Finalization+ubootFlashKernelFinalized p img mnt loopdevs = +	ubootFinalized p img mnt loopdevs+		`before` flashKernelFinalized img mnt loopdevs  isChild :: FilePath -> Maybe MountPoint -> Bool isChild mntpt (Just d)

@@ -1,33 +1,186 @@--- | Disk image partition specification and combinators.+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} --- Partitions in disk images default to being sized large enough to hold--- the files that appear in the directory where the partition is to be--- mounted. Plus a fudge factor, since filesystems have some space--- overhead.+-- | Disk image partition specification.  module Propellor.Property.DiskImage.PartSpec (-	module Propellor.Types.PartSpec,-	module Propellor.Property.DiskImage.PartSpec,-	module Propellor.Property.Parted.Types,-	module Propellor.Property.Partition,+	PartSpec,+	Fs(..),+	PartSize(..),+	partition,+	-- * PartSpec combinators+	swapPartition,+	mountedAt,+	addFreeSpace,+	setSize,+	mountOpt,+	errorReadonly,+	reservedSpacePercentage,+	setFlag,+	extended,+	-- * Partition properties+	--+	-- | These properties do not do any disk partitioning on their own, but+	-- the Info they set can be used when building a disk image for a+	-- host.+	hasPartition,+	adjustPartition,+	PartLocation(..),+	partLocation,+	hasPartitionTableType,+	TableType(..),+	PartInfo,+	toPartTableSpec,+	PartTableSpec(..) ) where  import Propellor.Base import Propellor.Property.Parted import Propellor.Types.PartSpec-import Propellor.Property.Parted.Types+import Propellor.Types.Info import Propellor.Property.Partition (Fs(..))+import Propellor.Property.Mount --- | Adds additional free space to the partition.+import Data.List (sortBy)+import Data.Ord++-- | Specifies a partition with a given filesystem.+--+-- The partition is not mounted anywhere by default; use the combinators+-- below to configure it.+partition :: Monoid t => Fs -> PartSpec t+partition fs = (Nothing, mempty, mkPartition fs, mempty)++-- | Specifies a swap partition of a given size.+swapPartition :: Monoid t => PartSize -> PartSpec t+swapPartition sz = (Nothing, mempty, const (mkPartition LinuxSwap sz), mempty)++-- | Specifies where to mount a partition.+mountedAt :: PartSpec t -> MountPoint -> PartSpec t+mountedAt (_, o, p, t) mp = (Just mp, o, p, t)++-- | Partitions in disk images default to being sized large enough to hold+-- the files that live in that partition.+--+-- This adds additional free space to a partition. addFreeSpace :: PartSpec t -> PartSize -> PartSpec t addFreeSpace (mp, o, p, t) freesz = (mp, o, p', t)   where 	p' = \sz -> p (sz <> freesz) --- | Add 2% for filesystem overhead. Rationalle for picking 2%:--- A filesystem with 1% overhead might just sneak by as acceptable.--- Double that just in case. Add an additional 3 mb to deal with--- non-scaling overhead of filesystems (eg, superblocks). --- Add an additional 200 mb for temp files, journals, etc.-fudge :: PartSize -> PartSize-fudge (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3 + 200)+-- | Specify a fixed size for a partition.+setSize :: PartSpec t -> PartSize -> PartSpec t+setSize (mp, o, p, t) sz = (mp, o, const (p sz), t)++-- | Specifies a mount option, such as "noexec"+mountOpt :: ToMountOpts o => PartSpec t -> o -> PartSpec t+mountOpt (mp, o, p, t) o' = (mp, o <> toMountOpts o', p, t)++-- | Mount option to make a partition be remounted readonly when there's an+-- error accessing it.+errorReadonly :: MountOpts+errorReadonly = toMountOpts "errors=remount-ro"++-- | Sets the percent of the filesystem blocks reserved for the super-user.+--+-- The default is 5% for ext2 and ext4. Some filesystems may not support+-- this.+reservedSpacePercentage :: PartSpec t -> Int -> PartSpec t+reservedSpacePercentage s percent = adjustp s $ \p -> +	p { partMkFsOpts = ("-m"):show percent:partMkFsOpts p }++-- | Sets a flag on the partition.+setFlag :: PartSpec t -> PartFlag -> PartSpec t+setFlag s f = adjustp s $ \p -> p { partFlags = (f, True):partFlags p }++-- | Makes a MSDOS partition be Extended, rather than Primary.+extended :: PartSpec t -> PartSpec t+extended s = adjustp s $ \p -> p { partType = Extended }++adjustp :: PartSpec t -> (Partition -> Partition) -> PartSpec t+adjustp (mp, o, p, t) f = (mp, o, f . p, t)++data PartInfoVal+	= TableTypeInfo TableType+	| PartSpecInfo (PartSpec PartLocation)+	| AdjustPartSpecInfo MountPoint (PartSpec PartLocation -> PartSpec PartLocation)++newtype PartInfo = PartInfo [PartInfoVal]+	deriving (Monoid, Typeable)++instance IsInfo PartInfo where+	propagateInfo _ = PropagateInfo False++instance Show PartInfo where+	show = show . toPartTableSpec++toPartTableSpec :: PartInfo -> PartTableSpec+toPartTableSpec (PartInfo l) = PartTableSpec tt pil+  where+	tt = fromMaybe MSDOS $ headMaybe $ reverse $ mapMaybe gettt l++	pil = map convert $ sortBy (comparing location) $ adjust collect+	collect = mapMaybe getspartspec l+	adjust ps = adjust' ps (mapMaybe getadjust l)+	adjust' ps [] = ps+	adjust' ps ((mp, f):rest) = adjust' (map (adjustone mp f) ps) rest+	adjustone mp f p@(mp', _, _, _)+		| Just mp == mp' = f p+		| otherwise = p+	location (_, _, _, loc) = loc+	convert (mp, o, p, _) = (mp, o, p, ())+	+	gettt (TableTypeInfo t) = Just t+	gettt _ = Nothing+	getspartspec (PartSpecInfo ps) = Just ps+	getspartspec _ = Nothing+	getadjust (AdjustPartSpecInfo mp f) = Just (mp, f)+	getadjust _ = Nothing++-- | Indicates the partition table type of a host.+--+-- When not specified, the default is MSDOS.+--+-- For example:+--+-- >	& hasPartitionTableType GPT+hasPartitionTableType :: TableType -> Property (HasInfo + UnixLike)+hasPartitionTableType tt = pureInfoProperty+	("partition table type " ++ show tt)+	(PartInfo [TableTypeInfo tt])++-- | Indicates that a host has a partition.+--+-- For example:+--+-- >	& hasPartiton (partition EXT2 `mountedAt` "/boot" `partLocation` Beginning)+-- >	& hasPartiton (partition EXT4 `mountedAt` "/")+-- >	& hasPartiton (partition EXT4 `mountedAt` "/home" `partLocation` End `reservedSpacePercentage` 0)+hasPartition :: PartSpec PartLocation -> Property (HasInfo + UnixLike)+hasPartition p@(mmp, _, _, _) = pureInfoProperty desc+	(PartInfo [PartSpecInfo p])+  where+	desc = case mmp of+		Just mp -> "has " ++ mp ++ " partition"+		Nothing -> "has unmounted partition"++-- | Adjusts the PartSpec for the partition mounted at the specified location.+--+-- For example:+--+-- > 	& adjustPartition "/boot" (`addFreeSpace` MegaBytes 150)+adjustPartition :: MountPoint -> (PartSpec PartLocation -> PartSpec PartLocation) -> Property (HasInfo + UnixLike)+adjustPartition mp f = pureInfoProperty+	("has " ++ mp ++ " adjusted")+	(PartInfo [AdjustPartSpecInfo mp f])++-- | Indicates partition layout in a disk. Default is somewhere in the+-- middle.+data PartLocation = Beginning | Middle | End+	deriving (Eq, Ord)++instance Monoid PartLocation where+	mempty = Middle+	mappend _ b = b++partLocation :: PartSpec PartLocation -> PartLocation -> PartSpec PartLocation+partLocation (mp, o, p, _) l = (mp, o, p, l)

@@ -2,6 +2,7 @@  import Propellor.Base import qualified Propellor.Property.Apt as Apt+import qualified Propellor.Property.File as File import qualified Propellor.Property.Service as Service import Propellor.Property.ConfFile @@ -13,18 +14,47 @@  type Jail = String +type Filter = String++type Action = String+ -- | By default, fail2ban only enables the ssh jail, but many others -- are available to be enabled, for example "postfix-sasl" jailEnabled :: Jail -> Property DebianLike-jailEnabled name = jailConfigured name "enabled" "true"+jailEnabled name = jailEnabled' name [] 	`onChange` reloaded +jailEnabled' :: Jail -> [(IniKey, String)] -> Property DebianLike+jailEnabled' name settings =+	jailConfigured' name (("enabled", "true") : settings)+	`onChange` reloaded+ -- | Configures a jail. For example: ----- > jailConfigured "sshd" "port" "2222"+-- > jailConfigured' "sshd" [("port", "2222")]+jailConfigured' :: Jail -> [(IniKey, String)] -> Property UnixLike+jailConfigured' name settings = propertyList ("jail \"" ++ name ++ "\" configuration") $ props+	-- removes .conf files added by old versions of Fail2Ban properties+	& File.notPresent (oldJailConfFile name)+	& jailConfFile name `iniFileContains` [(name, settings)]++-- | Adds a setting to a given jail. For example:+--+-- > jailConfigured "sshd" "port"  "2222" jailConfigured :: Jail -> IniKey -> String -> Property UnixLike-jailConfigured name key value = -	jailConfFile name `containsIniSetting` (name, key, value)+jailConfigured name key value = propertyList ("jail \"" ++ name ++ "\" configuration") $ props+	-- removes .conf files added by old versions of Fail2Ban properties+	& File.notPresent (oldJailConfFile name)+	& jailConfFile name `containsIniSetting` (name, key, value) +oldJailConfFile :: Jail -> FilePath+oldJailConfFile name = "/etc/fail2ban/jail.d/" ++ name ++ ".conf"+ jailConfFile :: Jail -> FilePath-jailConfFile name = "/etc/fail2ban/jail.d/" ++ name ++ ".conf"+jailConfFile name = "/etc/fail2ban/jail.d/" ++ name ++ ".local"++filterConfFile :: Filter -> FilePath+filterConfFile name = "/etc/fail2ban/filter.d/" ++ name ++ ".local"++actionConfFile :: Action -> FilePath+actionConfFile name = "/etc/fail2ban/action.d/" ++ name ++ ".local"

@@ -0,0 +1,63 @@+-- | Make ARM systems bootable using Debian's flash-kernel package.++module Propellor.Property.FlashKernel where++import Propellor.Base+import qualified Propellor.Property.File as File+import qualified Propellor.Property.Apt as Apt+import Propellor.Property.Mount+import Propellor.Types.Bootloader+import Propellor.Types.Info++-- | A machine name, such as "Cubietech Cubietruck" or "Olimex A10-OLinuXino-LIME"+--+-- flash-kernel supports many different machines,+-- see its file /usr/share/flash-kernel/db/all.db for a list.+type Machine = String++-- | Uses flash-kernel to make a machine bootable.+--+-- Before using this, an appropriate kernel needs to already be installed, +-- and on many machines, u-boot needs to be installed too.+installed :: Machine -> Property (HasInfo + DebianLike)+installed machine = setInfoProperty go (toInfo [FlashKernelInstalled])+  where+	go = "/etc/flash-kernel/machine" `File.hasContent` [machine]+		`onChange` (cmdProperty "flash-kernel" [] `assume` MadeChange)+		`requires` File.dirExists "/etc/flash-kernel"+		`requires` Apt.installed ["flash-kernel"]++-- | Runs flash-kernel in the system mounted at a particular directory.+flashKernelMounted :: FilePath -> Property Linux+flashKernelMounted mnt = combineProperties desc $ props+	-- remove mounts that are done below to make sure the right thing+	-- gets mounted+	& cleanupmounts+	& bindMount "/dev" (inmnt "/dev")+	& mounted "proc" "proc" (inmnt "/proc") mempty+	& mounted "sysfs" "sys" (inmnt "/sys") mempty+	-- update the initramfs so it gets the uuid of the root partition+	& inchroot "update-initramfs" ["-u"]+		`assume` MadeChange+	& inchroot "flash-kernel" []+		`assume` MadeChange+	& cleanupmounts+  where+	desc = "flash-kernel run"++	-- cannot use </> since the filepath is absolute+	inmnt f = mnt ++ f++	inchroot cmd ps = cmdProperty "chroot" ([mnt, cmd] ++ ps)++	cleanupmounts :: Property Linux+	cleanupmounts = property desc $ liftIO $ do+		cleanup "/sys"+		cleanup "/proc"+		cleanup "/dev"+		return NoChange+	  where+		cleanup m =+			let mp = inmnt m+			in whenM (isMounted mp) $+				umountLazy mp

@@ -0,0 +1,201 @@+-- | Machine-specific properties.+--+-- Many embedded computers have their own special configuration needed+-- to use them. Rather than needing to hunt down documentation about the+-- kernel, bootloader, etc for a given machine, if there's a property+-- in here for your machine, you can simply use it.+--+-- Not all machine properties have been tested yet. If one flagged as+-- untested and you find it works, please let us know.+--+-- You will need to configure the `Host` with the right `Architecture`+-- for the machine. These properties do test at runtime that a supported+-- Architecture was selected.+--+-- Sometimes non-free firmware is needed to use a board. If the board won't+-- be functional at all without it, its property will include the non-free+-- firmware, but if the non-free firmware is only needed for non-critical+-- functionality, it won't be included.+-- +-- Example: Building a disk image for a Marvell SheevaPlug +--+-- This defines a Host "sheeva" that is a Marvell SheevaPlug.+-- A bootable disk image for "sheeva" is built on another machine+-- "darkstar", which can be eg an Intel laptop running Debian.+--+-- > import Propellor.Property.Machine+-- > import Propellor.Property.DiskImage+-- > +-- > sheeva :: Host+-- > sheeva = host "sheeva.example.com" $ props+-- > 	& osDebian Unstable ARMEL+-- > 	& marvell_SheevaPlug Marvell_SheevaPlug_SDCard+-- >	& hasPartiton+-- >		( partition EXT4+-- > 		`mountedAt` "/"+-- >		`addFreeSpace` MegaBytes 2048+-- >		)+-- >+-- > darkstar :: Host+-- > darkstar = host "darkstar.example.com" $ props+-- >	& imageBuiltFor sheeva+-- >		(RawDiskImage "/srv/sheeva-disk.img")+-- >		(Debootstrapped mempty)++module Propellor.Property.Machine (+	-- * ARM boards+	Marvell_SheevaPlug_BootDevice(..),+	marvell_SheevaPlug,+	cubietech_Cubietruck,+	olimex_A10_OLinuXino_LIME,+	-- * ARM boards (untested)+	cubietech_Cubieboard,+	cubietech_Cubieboard2,+	lemaker_Banana_Pi,+	lemaker_Banana_Pro,+	olimex_A10s_OLinuXino_Micro,+	olimex_A20_OLinuXino_LIME,+	olimex_A20_OLinuXino_LIME2,+	olimex_A20_OLinuXino_Micro,+	olimex_A20_SOM_EVB,+	linkSprite_pcDuino3_Nano,+) where++import Propellor.Base+import Propellor.Types.Core+import qualified Propellor.Property.Apt as Apt+import qualified Propellor.Property.FlashKernel as FlashKernel+import qualified Propellor.Property.Uboot as Uboot+import Propellor.Property.DiskImage.PartSpec++data Marvell_SheevaPlug_BootDevice+	= Marvell_SheevaPlug_SDCard+	| Marvell_SheevaPlug_ESATA++-- | Marvell SheevaPlug+--+-- This includes a small EXT2 formatted /boot partition.+--+-- Note that u-boot may need to be upgraded manually, and will need to be+-- configured to boot from the SD card or eSATA. See+-- https://www.cyrius.com/debian/kirkwood/sheevaplug/install/+marvell_SheevaPlug :: Marvell_SheevaPlug_BootDevice -> Property (HasInfo + DebianLike)+marvell_SheevaPlug bd = fk+	`requires` marvell+	`requires` hasPartition bootpart+  where+	fk = case bd of+		Marvell_SheevaPlug_SDCard ->+			FlashKernel.installed "Marvell SheevaPlug Reference Board"+		Marvell_SheevaPlug_ESATA ->+			FlashKernel.installed "Marvell eSATA SheevaPlug Reference Board"+	-- The boot loader needs an EXT2 boot partition, which comes+	-- first. Add some free space to allow for additional kernel images+	-- and initrds.+	bootpart :: PartSpec PartLocation+	bootpart = partition EXT2+		`mountedAt` "/boot"+		`partLocation` Beginning+		`addFreeSpace` MegaBytes 150++-- | Cubietech Cubietruck+-- +-- Wifi needs non-free firmware-brcm80211, which is not installed by+-- this property. Also, see https://bugs.debian.org/844056+cubietech_Cubietruck :: Property (HasInfo + DebianLike)+cubietech_Cubietruck = FlashKernel.installed "Cubietech Cubietruck"+	`requires` sunixi "Cubietruck"+	`requires` lpae++-- | Cubietech Cubieboard (untested)+cubietech_Cubieboard :: Property (HasInfo + DebianLike)+cubietech_Cubieboard = FlashKernel.installed "Cubietech Cubieboard"+	`requires` sunixi "Cubieboard"+	`requires` armmp++-- | Cubietech Cubieboard2 (untested)+cubietech_Cubieboard2 :: Property (HasInfo + DebianLike)+cubietech_Cubieboard2 = FlashKernel.installed "Cubietech Cubieboard2"+	`requires` sunixi "Cubieboard2"+	`requires` lpae++-- | LeMaker Banana Pi+lemaker_Banana_Pi :: Property (HasInfo + DebianLike)+lemaker_Banana_Pi = FlashKernel.installed "LeMaker Banana Pi"+	`requires` sunixi "Bananapi"+	`requires` lpae++-- | LeMaker Banana Pro (untested)+lemaker_Banana_Pro :: Property (HasInfo + DebianLike)+lemaker_Banana_Pro = FlashKernel.installed "LeMaker Banana Pro"+	`requires` sunixi "Bananapro"+	`requires` lpae++-- | Olimex A10-OLinuXino-LIME+olimex_A10_OLinuXino_LIME :: Property (HasInfo + DebianLike)+olimex_A10_OLinuXino_LIME = FlashKernel.installed "Olimex A10-OLinuXino-LIME"+	`requires` sunixi "A10-OLinuXino-Lime"+	`requires` armmp++-- | Olimex A10s-Olinuxino Micro (untested)+olimex_A10s_OLinuXino_Micro :: Property (HasInfo + DebianLike)+olimex_A10s_OLinuXino_Micro = FlashKernel.installed "Olimex A10s-Olinuxino Micro"+	`requires` sunixi "A10s-OLinuXino-M"+	`requires` armmp++-- | Olimex A20-OlinuXino-LIME (untested)+olimex_A20_OLinuXino_LIME :: Property (HasInfo + DebianLike)+olimex_A20_OLinuXino_LIME = FlashKernel.installed "Olimex A20-OLinuXino-LIME"+	`requires` sunixi "A20-OLinuXino-Lime"+	`requires` lpae++-- | Olimex A20-OlinuXino-LIME2 (untested)+olimex_A20_OLinuXino_LIME2 :: Property (HasInfo + DebianLike)+olimex_A20_OLinuXino_LIME2 = FlashKernel.installed "Olimex A20-OLinuXino-LIME2"+	`requires` sunixi "A20-OLinuXino-Lime2"+	`requires` lpae++-- | Olimex A20-Olinuxino Micro (untested)+olimex_A20_OLinuXino_Micro :: Property (HasInfo + DebianLike)+olimex_A20_OLinuXino_Micro = FlashKernel.installed "Olimex A20-Olinuxino Micro"+	`requires` sunixi "A20-OLinuXino-MICRO"+	`requires` lpae++-- | Olimex A20-SOM-EVB (untested)+olimex_A20_SOM_EVB :: Property (HasInfo + DebianLike)+olimex_A20_SOM_EVB = FlashKernel.installed "Olimex A20-Olimex-SOM-EVB"+	`requires` sunixi "A20-Olimex-SOM-EVB"+	`requires` lpae++-- | LinkSprite pcDuino Nano (untested)+--+-- Needs non-free firmware, see+-- https://wiki.debian.org/InstallingDebianOn/Allwinner+linkSprite_pcDuino3_Nano :: Property (HasInfo + DebianLike)+linkSprite_pcDuino3_Nano = FlashKernel.installed "LinkSprite pcDuino3 Nano"+	`requires` sunixi "Linksprite_pcDuino3"+	`requires` lpae++sunixi :: Uboot.BoardName -> Property (HasInfo + DebianLike)+sunixi boardname = Uboot.sunxi boardname+	`requires` Apt.installed+		[ "firmware-linux-free"+		, "sunxi-tools"+		]++armmp :: Property DebianLike+armmp = checkArchitecture [ARMHF, ARMEL] $+	Apt.installed ["linux-image-armmp"]++lpae :: Property DebianLike+lpae = checkArchitecture [ARMHF, ARMEL] $ +	Apt.installed ["linux-image-armmp-lpae"]++marvell :: Property DebianLike+marvell = checkArchitecture [ARMEL] $+	Apt.installed ["linux-image-marvell"]++checkArchitecture :: [Architecture] -> Property DebianLike -> Property DebianLike+checkArchitecture as p = withOS (getDesc p) $ \w o -> case o of+	(Just (System _ arch)) | arch `elem` as -> ensureProperty w p+	_ -> error $ "Machine needs architecture to be one of: " ++ show as

@@ -90,18 +90,18 @@  -- | Filesystem type mounted at a given location. getFsType :: MountPoint -> IO (Maybe FsType)-getFsType = findmntField "fstype"+getFsType p = findmntField "fstype" [p]  -- | Mount options for the filesystem mounted at a given location. getFsMountOpts :: MountPoint -> IO MountOpts getFsMountOpts p = maybe mempty toMountOpts-	<$> findmntField "fs-options" p+	<$> findmntField "fs-options" [p]  type UUID = String  -- | UUID of filesystem mounted at a given location. getMountUUID :: MountPoint -> IO (Maybe UUID)-getMountUUID = findmntField "uuid"+getMountUUID p = findmntField "uuid" [p]  -- | UUID of a device getSourceUUID :: Source -> IO (Maybe UUID)@@ -111,7 +111,7 @@  -- | Label of filesystem mounted at a given location. getMountLabel :: MountPoint -> IO (Maybe Label)-getMountLabel = findmntField "label"+getMountLabel p = findmntField "label" [p]  -- | Label of a device getSourceLabel :: Source -> IO (Maybe UUID)@@ -119,12 +119,16 @@  -- | Device mounted at a given location. getMountSource :: MountPoint -> IO (Maybe Source)-getMountSource = findmntField "source"+getMountSource p = findmntField "source" [p] -findmntField :: String -> FilePath -> IO (Maybe String)-findmntField field mnt = catchDefaultIO Nothing $+-- | Device that a given path is located within.+getMountContaining :: FilePath -> IO (Maybe Source)+getMountContaining p = findmntField "source" ["-T", p]++findmntField :: String -> [String] -> IO (Maybe String)+findmntField field ps = catchDefaultIO Nothing $ 	headMaybe . filter (not . null) . lines-		<$> readProcess "findmnt" ["-n", mnt, "--output", field]+		<$> readProcess "findmnt" ("-n" : ps ++ ["--output", field])  blkidTag :: String -> Source -> IO (Maybe String) blkidTag tag dev = catchDefaultIO Nothing $

@@ -21,13 +21,14 @@ 	parted, 	Eep(..), 	installed,-	-- * PartSpec combinators+	-- * Partition table sizing 	calcPartTable, 	DiskSize(..), 	DiskPart,-	module Propellor.Types.PartSpec, 	DiskSpaceUse(..), 	useDiskSpace,+	defSz,+	fudgeSz, ) where  import Propellor.Base@@ -35,7 +36,7 @@ import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Pacman as Pacman import qualified Propellor.Property.Partition as Partition-import Propellor.Types.PartSpec+import Propellor.Types.PartSpec (PartSpec) import Utility.DataUnits  import System.Posix.Files@@ -160,3 +161,19 @@ -- (less all fixed size partitions), or the remaining space in the disk. useDiskSpace :: PartSpec DiskPart -> DiskSpaceUse -> PartSpec DiskPart useDiskSpace (mp, o, p, _) diskuse = (mp, o, p, DynamicDiskPart diskuse)++-- | Default partition size when not otherwize specified is 128 MegaBytes.+defSz :: PartSize+defSz = MegaBytes 128++-- | When a partition is sized to fit the files that live in it,+-- this fudge factor is added to the size of the files. This is necessary+-- since filesystems have some space overhead.+-- +-- Add 2% for filesystem overhead. Rationalle for picking 2%:+-- A filesystem with 1% overhead might just sneak by as acceptable.+-- Double that just in case. Add an additional 3 mb to deal with+-- non-scaling overhead of filesystems (eg, superblocks). +-- Add an additional 200 mb for temp files, journals, etc.+fudgeSz :: PartSize -> PartSize+fudgeSz (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3 + 200)

@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveDataTypeable #-}+ module Propellor.Property.PropellorRepo where  import Propellor.Base@@ -24,4 +26,4 @@ 			else makeChange $ setRepoUrl u  newtype OriginUrl = OriginUrl String-	deriving (Show)+	deriving (Show, Typeable)

@@ -0,0 +1,49 @@+module Propellor.Property.Qemu where++import Propellor.Base+import qualified Propellor.Property.Apt as Apt++-- | Installs qemu user mode emulation binaries, built statically,+-- which allow foreign binaries to run directly.+foreignBinariesEmulated :: RevertableProperty Linux Linux+foreignBinariesEmulated = (setup <!> cleanup)+	`describe` "foreign binary emulation"+  where+	setup = Apt.installed p `pickOS` unsupportedOS+	cleanup = Apt.removed p `pickOS` unsupportedOS+	p = ["qemu-user-static"]++-- | Removes qemu user mode emulation binary for the host CPU.+-- This binary is copied into a chroot by qemu-debootstrap, and is not+-- part of any package.+--+-- Note that removing the binary will prevent using the chroot on the host+-- system.+--+-- The FilePath is the path to the top of the chroot.+removeHostEmulationBinary :: FilePath -> Property Linux+removeHostEmulationBinary top = tightenTargets $ +	scriptProperty ["rm -f " ++ top ++ "/usr/bin/qemu-*-static"]+		`assume` MadeChange++-- | Check if the given System supports an Architecture.+--+-- For example, on Debian, X86_64 supports X86_32, and vice-versa.+supportsArch :: System -> Architecture -> Bool+supportsArch (System os a) b+	| a == b = True+	| otherwise = case os of+		Debian _ _ -> debianlike+		Buntish _ -> debianlike+		-- don't know about other OS's+		_ -> False+  where+	debianlike =+		let l = +			[ (X86_64, X86_32)+			, (ARMHF, ARMEL)+			, (PPC, PPC64)+			, (SPARC, SPARC64)+			, (S390, S390X)+			]+		in elem (a, b) l || elem (b, a) l

@@ -1,6 +1,11 @@+{-# LANGUAGE DeriveDataTypeable #-}+ module Propellor.Property.Service where  import Propellor.Base+import Propellor.Types.Info+import qualified Propellor.Property.File as File+import Utility.FileMode  type ServiceName = String @@ -21,7 +26,34 @@ reloaded = signaled "reload" "reloaded"  signaled :: String -> Desc -> ServiceName -> Property DebianLike-signaled cmd desc svc = tightenTargets $ p `describe` (desc ++ " " ++ svc)+signaled cmd desc svc = check (not <$> servicesDisabled) $+	tightenTargets $ p `describe` (desc ++ " " ++ svc)   where 	p = scriptProperty ["service " ++ shellEscape svc ++ " " ++ cmd ++ " >/dev/null 2>&1 || true"] 		`assume` NoChange++-- | This property prevents daemons and other services from being started,+-- which is often something you want to prevent when building a chroot.+--+-- When this is set, `running` and `restarted` will not start services.+--+-- On Debian this installs a </usr/sbin/policy-rc.d> script to further+-- prevent any packages that get installed from starting daemons.+-- Reverting the property removes the script.+noServices :: RevertableProperty (HasInfo + UnixLike) UnixLike+noServices = (setup `setInfoProperty` toInfo (InfoVal NoServices)) <!> teardown+  where+	f = "/usr/sbin/policy-rc.d"+	script = [ "#!/bin/sh", "exit 101" ]+	setup = combineProperties "no services started" $ toProps+		[ File.hasContent f script+		, File.mode f (combineModes (readModes ++ executeModes))+		]+	teardown = File.notPresent f++-- | Check if the noServices property is in effect.+servicesDisabled :: Propellor Bool+servicesDisabled = isJust . fromInfoVal+	<$> (askInfo :: Propellor (InfoVal NoServices))++data NoServices = NoServices deriving (Eq, Show, Typeable)

@@ -119,10 +119,10 @@ standardAutoBuilder suite arch flavor = 	propertyList "standard git-annex autobuilder" $ props 		& osDebian suite arch-		& buildDepsApt 		& Apt.stdSourcesList 		& Apt.unattendedUpgrades 		& Apt.cacheCleaned+		& buildDepsApt 		& User.accountFor (User builduser) 		& tree (architectureToDebianArchString arch) flavor 

@@ -20,7 +20,14 @@ 				moveout tmpdir home 			, property "rmdir" $ makeChange $ void $ 				catchMaybeIO $ removeDirectory tmpdir-			, userScriptProperty user ["rm -rf .aptitude/ .bashrc .profile; bin/mr checkout; bin/fixups"]+			, userScriptProperty user ["rm -rf .aptitude/ .bashrc .profile"]+				`assume` MadeChange+			-- Set HOSTNAME so that this sees the right+			-- hostname when run in a chroot with a different+			-- hostname than the current one.+			, userScriptProperty user ["HOSTNAME=$(cat /etc/hostname) bin/mr checkout"]+				`assume` MadeChange+			, userScriptProperty user ["bin/fixups"] 				`assume` MadeChange 			] 	moveout tmpdir home = do

@@ -912,16 +912,20 @@ homePowerMonitor :: IsContext c => User -> c -> (SshKeyType, Ssh.PubKeyText) -> Property (HasInfo + DebianLike) homePowerMonitor user ctx sshkey = propertyList "home power monitor" $ props 	& Apache.installed-	& Apt.installed ["python", "python-pymodbus"]+	& Apt.installed ["python", "python-pymodbus", "rrdtool"] 	& File.ownerGroup "/var/www/html" user (userGroup user) 	& Git.cloned user "git://git.kitenet.net/joey/homepower" d Nothing-		`onChange` buildpoller+	& buildpoller 	& Systemd.enabled servicename 		`requires` serviceinstalled 		`onChange` Systemd.started servicename+	& User.hasGroup user (Group "dialout") 	& Cron.niceJob "homepower upload" 		(Cron.Times "1 * * * *") user d rsynccommand 		`requires` Ssh.userKeyAt (Just sshkeyfile) user ctx sshkey+		`requires` File.ownerGroup (takeDirectory sshkeyfile)+			user (userGroup user)+		`requires` File.dirExists (takeDirectory sshkeyfile)   where 	d = "/var/www/html/homepower" 	sshkeyfile = d </> ".ssh/key"@@ -957,30 +961,34 @@ homeRouter = propertyList "home router" $ props 	& Network.static "wlan0" (IPv4 "10.1.1.1") Nothing 		`requires` Network.cleanInterfacesFile-	& Apt.serviceInstalledRunning "hostapd"-		`requires` File.hasContent "/etc/hostapd/hostapd.conf"+	& Apt.installed ["hostapd"]+	& File.hasContent "/etc/hostapd/hostapd.conf" 			[ "interface=wlan0" 			, "ssid=house" 			, "hw_mode=g" 			, "channel=8" 			]-		`requires` File.dirExists "/lib/hostapd"-	& Apt.serviceInstalledRunning "dnsmasq"-		`requires` File.hasContent "/etc/dnsmasq.conf"-			[ "domain-needed"-			, "bogus-priv"-			, "interface=wlan0"-			, "domain=kitenet.net"-			, "dhcp-range=10.1.1.100,10.1.1.150,24h"-			, "no-hosts"-			, "address=/honeybee.kitenet.net/10.1.1.1"-			]-		`requires` File.hasContent "/etc/resolv.conf"-			[ "domain kitenet.net"-			, "search kitenet.net"-			, "nameserver 8.8.8.8"-			, "nameserver 8.8.4.4"-			]+		`requires` File.dirExists "/etc/hostapd"+		`requires` File.hasContent "/etc/default/hostapd"+			[ "DAEMON_CONF=/etc/hostapd/hostapd.conf" ]+		`onChange` Service.running "hostapd"+	& File.hasContent "/etc/resolv.conf"+		[ "domain kitenet.net"+		, "search kitenet.net"+		, "nameserver 8.8.8.8"+		, "nameserver 8.8.4.4"+		]+	& Apt.installed ["dnsmasq"]+	& File.hasContent "/etc/dnsmasq.conf"+		[ "domain-needed"+		, "bogus-priv"+		, "interface=wlan0"+		, "domain=kitenet.net"+		, "dhcp-range=10.1.1.100,10.1.1.150,24h"+		, "no-hosts"+		, "address=/honeybee.kitenet.net/10.1.1.1"+		]+		`onChange` Service.restarted "dnsmasq" 	& ipmasq "wlan0" 	& Apt.serviceInstalledRunning "netplug" 	& Network.dhcp' "eth0"

@@ -0,0 +1,36 @@+module Propellor.Property.Uboot where++import Propellor.Base+import Propellor.Types.Info+import Propellor.Types.Bootloader+import Propellor.Property.Chroot+import Propellor.Property.Mount+import qualified Propellor.Property.Apt as Apt++-- | Name of a board.+type BoardName = String++-- | Installs u-boot for Allwinner/sunxi platforms.+--+-- This includes writing it to the boot sector.+sunxi :: BoardName -> Property (HasInfo + DebianLike)+sunxi boardname = setInfoProperty (check (not <$> inChroot) go) info+	`requires` Apt.installed ["u-boot", "u-boot-sunxi"]+  where+	go :: Property Linux+	go = property' "u-boot installed" $ \w -> do+		v <- liftIO $ getMountContaining "/boot"+		case v of+			Nothing -> error "unable to determine boot device"+			Just dev -> ensureProperty w (dd dev "/")+	dd :: FilePath -> FilePath -> Property Linux+	dd dev prefix = tightenTargets $ cmdProperty "dd"+		[ "conv=fsync,notrunc"+		, "if=" ++ prefix ++ "/usr/lib/u-boot/"+			++ boardname ++ "/u-boot-sunxi-with-spl.bin"+		, "of=" ++ dev+		, "bs=1024"+		, "seek=8"+		]+		`assume` NoChange+	info = toInfo [UbootInstalled dd]

@@ -2,11 +2,20 @@  module Propellor.Types.Bootloader where +import Propellor.Types import Propellor.Types.Info  -- | Boot loader installed on a host.-data BootloaderInstalled = GrubInstalled-	deriving (Typeable, Show)+data BootloaderInstalled+	= GrubInstalled+	| FlashKernelInstalled+	| UbootInstalled (FilePath -> FilePath -> Property Linux)+	deriving (Typeable)++instance Show BootloaderInstalled where+	show GrubInstalled = "GrubInstalled"+	show FlashKernelInstalled = "FlashKernelInstalled"+	show (UbootInstalled _) = "UbootInstalled"  instance IsInfo [BootloaderInstalled] where 	propagateInfo _ = PropagateInfo False

@@ -1,66 +1,14 @@--- | Partition specification combinators.- module Propellor.Types.PartSpec where -import Propellor.Base import Propellor.Property.Parted.Types import Propellor.Property.Mount-import Propellor.Property.Partition  -- | Specifies a mount point, mount options, and a constructor for a -- Partition that determines its size. type PartSpec t = (Maybe MountPoint, MountOpts, PartSize -> Partition, t) --- | Specifies a partition with a given filesystem.------ The partition is not mounted anywhere by default; use the combinators--- below to configure it.-partition :: Monoid t => Fs -> PartSpec t-partition fs = (Nothing, mempty, mkPartition fs, mempty)---- | Specifies a swap partition of a given size.-swapPartition :: Monoid t => PartSize -> PartSpec t-swapPartition sz = (Nothing, mempty, const (mkPartition LinuxSwap sz), mempty)---- | Specifies where to mount a partition.-mountedAt :: PartSpec t -> FilePath -> PartSpec t-mountedAt (_, o, p, t) mp = (Just mp, o, p, t)---- | Specify a fixed size for a partition.-setSize :: PartSpec t -> PartSize -> PartSpec t-setSize (mp, o, p, t) sz = (mp, o, const (p sz), t)---- | Specifies a mount option, such as "noexec"-mountOpt :: ToMountOpts o => PartSpec t -> o -> PartSpec t-mountOpt (mp, o, p, t) o' = (mp, o <> toMountOpts o', p, t)---- | Mount option to make a partition be remounted readonly when there's an--- error accessing it.-errorReadonly :: MountOpts-errorReadonly = toMountOpts "errors=remount-ro"---- | Sets the percent of the filesystem blocks reserved for the super-user.------ The default is 5% for ext2 and ext4. Some filesystems may not support--- this.-reservedSpacePercentage :: PartSpec t -> Int -> PartSpec t-reservedSpacePercentage s percent = adjustp s $ \p -> -	p { partMkFsOpts = ("-m"):show percent:partMkFsOpts p }---- | Sets a flag on the partition.-setFlag :: PartSpec t -> PartFlag -> PartSpec t-setFlag s f = adjustp s $ \p -> p { partFlags = (f, True):partFlags p }---- | Makes a MSDOS partition be Extended, rather than Primary.-extended :: PartSpec t -> PartSpec t-extended s = adjustp s $ \p -> p { partType = Extended }--adjustp :: PartSpec t -> (Partition -> Partition) -> PartSpec t-adjustp (mp, o, p, t) f = (mp, o, f . p, t)--adjustt :: PartSpec t -> (t -> t) -> PartSpec t-adjustt (mp, o, p, t) f = (mp, o, p, f t)+-- | Specifies a partition table.+data PartTableSpec = PartTableSpec TableType [PartSpec ()] --- | Default partition size when not otherwize specified is 128 MegaBytes.-defSz :: PartSize-defSz = MegaBytes 128+instance Show PartTableSpec where+	show (PartTableSpec tt _) = "PartTableSpec " ++ show tt