From 540faf8215f8c38e1c6f8da4d82776986eea62a6 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 16 Nov 2017 15:51:21 -0400
Subject: flash-kernel support

Can be used to create disk images for arm boards using flash-kernel.

This commit was sponsored by Ewen McNeill.
---
 src/Propellor/Property/DiskImage.hs | 1 +
 1 file changed, 1 insertion(+)

(limited to 'src/Propellor/Property/DiskImage.hs')

diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 6c1a572c..7493dd21 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -192,6 +192,7 @@ imageBuilt' rebuild img mkchroot tabletype partspec =
 	-- installed.
 	final = case fromInfo (containerInfo chroot) of
 		[GrubInstalled] -> grubBooted
+		[FlashKernelInstalled] -> \_ _ -> doNothing
 		[] -> unbootable "no bootloader is installed"
 		_ -> unbootable "multiple bootloaders are installed; don't know which to use"
 
-- 
cgit v1.3-2-g0d8e


From cff178de9c0d229574ab884fcca08a41f434e119 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 16 Nov 2017 17:54:47 -0400
Subject: Uboot: New module.

Installing u-boot to the boot sector is not needed by some boards
(my CubieTruck boots without it), but may be by others.

Tricky part was making u-boot be written to a disk image when building one.

This commit was sponsored by Jake Vosloo on Patreon.
---
 debian/changelog                    |  1 +
 propellor.cabal                     |  1 +
 src/Propellor/Property/DiskImage.hs | 33 ++++++++++++++++++---------------
 src/Propellor/Property/Machine.hs   | 17 +++++++++--------
 src/Propellor/Property/Mount.hs     | 20 ++++++++++++--------
 src/Propellor/Property/Uboot.hs     | 36 ++++++++++++++++++++++++++++++++++++
 src/Propellor/Types/Bootloader.hs   |  9 ++++++++-
 7 files changed, 85 insertions(+), 32 deletions(-)
 create mode 100644 src/Propellor/Property/Uboot.hs

(limited to 'src/Propellor/Property/DiskImage.hs')

diff --git a/debian/changelog b/debian/changelog
index d6be2ca7..894c906f 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -12,6 +12,7 @@ propellor (4.9.1) UNRELEASED; urgency=medium
   * Qemu: New module.
   * FlashKernel: New module, can be used to create disk images for ARM
     boards using flash-kernel.
+  * Uboot: New module.
   * Machine: New module, machine-specific properties for ARM boards are
     being collected here.
 
diff --git a/propellor.cabal b/propellor.cabal
index 51640658..239a00e6 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -157,6 +157,7 @@ Library
     Propellor.Property.Systemd.Core
     Propellor.Property.Timezone
     Propellor.Property.Tor
+    Propellor.Property.Uboot
     Propellor.Property.Unbound
     Propellor.Property.User
     Propellor.Property.Uwsgi
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 7493dd21..fe2e60ac 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -191,10 +191,14 @@ imageBuilt' rebuild img mkchroot tabletype partspec =
 	-- Pick boot loader finalization based on which bootloader is
 	-- installed.
 	final = case fromInfo (containerInfo chroot) of
-		[GrubInstalled] -> grubBooted
-		[FlashKernelInstalled] -> \_ _ -> doNothing
 		[] -> unbootable "no bootloader is installed"
-		_ -> unbootable "multiple bootloaders are installed; don't know which to use"
+		l -> case filter ignorablefinal l of
+			[] -> \_ _ _ -> doNothing
+			[GrubInstalled] -> grubFinalized
+			[UbootInstalled p] -> ubootFinalized p
+			_ -> unbootable "multiple bootloaders are installed; don't know which to use"
+	ignorablefinal FlashKernelInstalled = True
+	ignorablefinal _ = False
 
 -- | This property is automatically added to the chroot when building a
 -- disk image. It cleans any caches of information that can be omitted;
@@ -229,7 +233,7 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
 	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 []
@@ -352,10 +356,10 @@ imageExists' dest@(RawDiskImage img) parttable = (setup <!> cleanup) `describe`
 --
 -- 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)
@@ -364,7 +368,7 @@ imageFinalized final mnts mntopts devs (PartTable _ parts) =
 		liftIO $ mountall top
 		liftIO $ writefstab top
 		liftIO $ allowservices top
-		ensureProperty w $ final top devs
+		ensureProperty w $ final img top devs
 
 	-- Ordered lexographically by mount point, so / comes before /usr
 	-- comes before /usr/local
@@ -400,18 +404,14 @@ imageFinalized final mnts mntopts devs (PartTable _ parts) =
 	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
@@ -421,6 +421,9 @@ grubBooted mnt loopdevs = Grub.bootsMounted mnt wholediskloopdev
 		(l:_) -> wholeDiskLoopDev l
 		[] -> error "No loop devs provided!"
 
+ubootFinalized :: (FilePath -> FilePath -> Property Linux) -> Finalization
+ubootFinalized p (RawDiskImage img) mnt _loopdevs = p img mnt
+
 isChild :: FilePath -> Maybe MountPoint -> Bool
 isChild mntpt (Just d)
 	| d `equalFilePath` mntpt = False
diff --git a/src/Propellor/Property/Machine.hs b/src/Propellor/Property/Machine.hs
index 2f356bdd..5f5024df 100644
--- a/src/Propellor/Property/Machine.hs
+++ b/src/Propellor/Property/Machine.hs
@@ -14,6 +14,7 @@ module Propellor.Property.Machine (
 import Propellor.Base
 import qualified Propellor.Property.Apt as Apt
 import qualified Propellor.Property.FlashKernel as FlashKernel
+import qualified Propellor.Property.Uboot as Uboot
 
 -- | Cubietech Cubietruck
 -- 
@@ -21,21 +22,21 @@ import qualified Propellor.Property.FlashKernel as FlashKernel
 -- this property. Also, see https://bugs.debian.org/844056
 cubietech_Cubietruck :: Property (HasInfo + DebianLike)
 cubietech_Cubietruck = FlashKernel.installed "Cubietech Cubietruck"
-	`requires` sunixi
+	`requires` sunixi "Cubietruck"
 	`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
+	`requires` sunixi "A10-OLinuXino-Lime"
 	`requires` armmp
 
-sunixi :: Property DebianLike
-sunixi = Apt.installed
-	[ "firmware-linux-free"
-	, "u-boot"
-	, "sunxi-tools"
-	]
+sunixi :: Uboot.BoardName -> Property (HasInfo + DebianLike)
+sunixi boardname = Uboot.sunxi boardname
+	`requires` Apt.installed
+		[ "firmware-linux-free"
+		, "sunxi-tools"
+		]
 
 armmp :: Property DebianLike
 armmp = Apt.installed ["linux-image-armmp"]
diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs
index 2c4d9620..c047161d 100644
--- a/src/Propellor/Property/Mount.hs
+++ b/src/Propellor/Property/Mount.hs
@@ -90,18 +90,18 @@ mountPointsBelow target = filter (\p -> simplifyPath p /= simplifyPath target)
 
 -- | 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 @@ type Label = String
 
 -- | 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 @@ getSourceLabel = blkidTag "LABEL"
 
 -- | 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 $
diff --git a/src/Propellor/Property/Uboot.hs b/src/Propellor/Property/Uboot.hs
new file mode 100644
index 00000000..70b4dd68
--- /dev/null
+++ b/src/Propellor/Property/Uboot.hs
@@ -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]
diff --git a/src/Propellor/Types/Bootloader.hs b/src/Propellor/Types/Bootloader.hs
index 9822d520..fd929d7e 100644
--- a/src/Propellor/Types/Bootloader.hs
+++ b/src/Propellor/Types/Bootloader.hs
@@ -2,13 +2,20 @@
 
 module Propellor.Types.Bootloader where
 
+import Propellor.Types
 import Propellor.Types.Info
 
 -- | Boot loader installed on a host.
 data BootloaderInstalled
 	= GrubInstalled
 	| FlashKernelInstalled
-	deriving (Typeable, Show)
+	| 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
-- 
cgit v1.3-2-g0d8e


From fc208477a6c76fcd39ca35f2e183bbf386b50379 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 16 Nov 2017 18:00:20 -0400
Subject: propellor spin

---
 src/Propellor/Property/DiskImage.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

(limited to 'src/Propellor/Property/DiskImage.hs')

diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index fe2e60ac..acfe58f5 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -192,11 +192,11 @@ imageBuilt' rebuild img mkchroot tabletype partspec =
 	-- installed.
 	final = case fromInfo (containerInfo chroot) of
 		[] -> unbootable "no bootloader is installed"
-		l -> case filter ignorablefinal l of
+		l -> case filter (not . ignorablefinal) l of
 			[] -> \_ _ _ -> doNothing
 			[GrubInstalled] -> grubFinalized
 			[UbootInstalled p] -> ubootFinalized p
-			_ -> unbootable "multiple bootloaders are installed; don't know which to use"
+			l -> unbootable $ "multiple bootloaders are installed; don't know which to use: " ++ show l
 	ignorablefinal FlashKernelInstalled = True
 	ignorablefinal _ = False
 
-- 
cgit v1.3-2-g0d8e


From c9e51c0f7ee2e9c64484369b358d3b918227ddc5 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 16 Nov 2017 18:00:37 -0400
Subject: propellor spin

---
 src/Propellor/Property/DiskImage.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'src/Propellor/Property/DiskImage.hs')

diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index acfe58f5..e9c9d0d4 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -196,7 +196,7 @@ imageBuilt' rebuild img mkchroot tabletype partspec =
 			[] -> \_ _ _ -> doNothing
 			[GrubInstalled] -> grubFinalized
 			[UbootInstalled p] -> ubootFinalized p
-			l -> unbootable $ "multiple bootloaders are installed; don't know which to use: " ++ show l
+			_ -> unbootable $ "multiple bootloaders are installed; don't know which to use: " ++ show l
 	ignorablefinal FlashKernelInstalled = True
 	ignorablefinal _ = False
 
-- 
cgit v1.3-2-g0d8e


From a8dacb76dec5cfa9514d7638987ca52b675c9251 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 17 Nov 2017 13:55:49 -0400
Subject: clean up qemu emulation binary when finalizing disk image

This commit was sponsored by Denis Dzyubenko on Patreon.
---
 src/Propellor/Property/DiskImage.hs | 5 ++++-
 src/Propellor/Property/Qemu.hs      | 8 +++++---
 2 files changed, 9 insertions(+), 4 deletions(-)

(limited to 'src/Propellor/Property/DiskImage.hs')

diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index e9c9d0d4..69a4b188 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -27,6 +27,7 @@ import qualified Propellor.Property.Chroot as Chroot
 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 Propellor.Property.Parted
 import Propellor.Property.Fstab (SwapPartition(..), genFstab)
 import Propellor.Property.Partition
@@ -368,7 +369,9 @@ imageFinalized final img mnts mntopts devs (PartTable _ parts) =
 		liftIO $ mountall top
 		liftIO $ writefstab top
 		liftIO $ allowservices top
-		ensureProperty w $ final img top devs
+		ensureProperty w $ 
+			Qemu.removeHostEmulationBinary top
+				`before` final img top devs
 
 	-- Ordered lexographically by mount point, so / comes before /usr
 	-- comes before /usr/local
diff --git a/src/Propellor/Property/Qemu.hs b/src/Propellor/Property/Qemu.hs
index 4d9e8b1f..f204a0e1 100644
--- a/src/Propellor/Property/Qemu.hs
+++ b/src/Propellor/Property/Qemu.hs
@@ -19,9 +19,11 @@ foreignBinariesEmulated = (setup <!> cleanup)
 --
 -- Note that removing the binary will prevent using the chroot on the host
 -- system.
-removeHostEmulationBinary :: Property DebianLike
-removeHostEmulationBinary = tightenTargets $ 
-	scriptProperty ["rm -f /usr/bin/qemu-*-static"]
+--
+-- 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.
-- 
cgit v1.3-2-g0d8e


From 1a837867b8ae264fee2b9bacc8fd2a86d0f78ec8 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 17 Nov 2017 15:14:02 -0400
Subject: update initramfs and flash-kernel during disk image finalization

flashKernelMounted is slightly cargo culted from Grub.bootsMounted,
could be refactored.

This commit was sponsored by Thom May on Patreon.
---
 joeyconfig.hs                         |  8 ++++----
 src/Propellor/Property/DiskImage.hs   | 24 ++++++++++++++++-------
 src/Propellor/Property/FlashKernel.hs | 36 +++++++++++++++++++++++++++++++++++
 3 files changed, 57 insertions(+), 11 deletions(-)

(limited to 'src/Propellor/Property/DiskImage.hs')

diff --git a/joeyconfig.hs b/joeyconfig.hs
index 0a018826..48eff2ec 100644
--- a/joeyconfig.hs
+++ b/joeyconfig.hs
@@ -6,6 +6,7 @@ import Propellor
 import Propellor.Property.Scheduled
 import Propellor.Property.DiskImage
 import Propellor.Property.Chroot
+import Propellor.Property.Machine
 import qualified Propellor.Property.File as File
 import qualified Propellor.Property.Apt as Apt
 import qualified Propellor.Property.Network as Network
@@ -24,7 +25,6 @@ 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.Machine as Machine
 import qualified Propellor.Property.Borg as Borg
 import qualified Propellor.Property.Gpg as Gpg
 import qualified Propellor.Property.Systemd as Systemd
@@ -109,12 +109,12 @@ darkstar = host "darkstar.kitenet.net" $ props
 sheevaplug :: Host
 sheevaplug = host "sheevaplug.kitenet.net" $ props
 	& osDebian Unstable ARMEL
-	& Machine.marvell_SheevaPlug Machine.Marvell_SheevaPlug_SDCard
+	& marvell_SheevaPlug Marvell_SheevaPlug_SDCard
 
 lime :: Host
 lime = host "lime.kitenet.net" $ props
 	& osDebian Unstable ARMHF
-	& Machine.olimex_A10_OLinuXino_LIME
+	& olimex_A10_OLinuXino_LIME
 
 gnu :: Host
 gnu = host "gnu.kitenet.net" $ props
@@ -200,7 +200,7 @@ honeybee = host "honeybee.kitenet.net" $ props
 	-- and try to be robust.
 	& "/etc/default/rcS" `File.containsLine` "FSCKFIX=yes"
 
-	& Machine.cubietech_Cubietruck
+	& cubietech_Cubietruck
 	& Apt.installed ["firmware-brcm80211"]
 		-- Workaround for https://bugs.debian.org/844056
 		`requires` File.hasPrivContent "/lib/firmware/brcm/brcmfmac43362-sdio.txt" anyContext
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 69a4b188..08306106 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -28,6 +28,7 @@ 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
@@ -193,13 +194,14 @@ imageBuilt' rebuild img mkchroot tabletype partspec =
 	-- installed.
 	final = case fromInfo (containerInfo chroot) of
 		[] -> unbootable "no bootloader is installed"
-		l -> case filter (not . ignorablefinal) l of
-			[] -> \_ _ _ -> doNothing
-			[GrubInstalled] -> grubFinalized
-			[UbootInstalled p] -> ubootFinalized p
-			_ -> unbootable $ "multiple bootloaders are installed; don't know which to use: " ++ show l
-	ignorablefinal FlashKernelInstalled = True
-	ignorablefinal _ = False
+		[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
 -- disk image. It cleans any caches of information that can be omitted;
@@ -427,6 +429,14 @@ grubFinalized _img mnt loopdevs = Grub.bootsMounted mnt wholediskloopdev
 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)
 	| d `equalFilePath` mntpt = False
diff --git a/src/Propellor/Property/FlashKernel.hs b/src/Propellor/Property/FlashKernel.hs
index 7aa8420b..3f65f872 100644
--- a/src/Propellor/Property/FlashKernel.hs
+++ b/src/Propellor/Property/FlashKernel.hs
@@ -5,6 +5,7 @@ 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
 
@@ -25,3 +26,38 @@ installed machine = setInfoProperty go (toInfo [FlashKernelInstalled])
 		`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
-- 
cgit v1.3-2-g0d8e


From e7ffe778fe41ad87e3d02251d9cbf0b87d972909 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 17 Nov 2017 15:21:58 -0400
Subject: propellor spin

---
 src/Propellor/Property/DiskImage.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

(limited to 'src/Propellor/Property/DiskImage.hs')

diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 08306106..68b34412 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -372,8 +372,8 @@ imageFinalized final img mnts mntopts devs (PartTable _ parts) =
 		liftIO $ writefstab top
 		liftIO $ allowservices top
 		ensureProperty w $ 
-			Qemu.removeHostEmulationBinary top
-				`before` final img top devs
+			final img top devs
+				`before` Qemu.removeHostEmulationBinary top
 
 	-- Ordered lexographically by mount point, so / comes before /usr
 	-- comes before /usr/local
-- 
cgit v1.3-2-g0d8e


From 6dae019be9ebed76f282ec3cb258df7bf5891320 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 17 Nov 2017 21:58:39 -0400
Subject: Service: Avoid starting services when noServices is used.

Reconsidered making services never run inside chroots, that seemed too
potentially limiting.

Using Info rather than checking policy-rc.d because it will also work
outside of debian, but more because policy-rc.d has an extremely
complicated interface and I didn't want to deal with it.

This commit was sponsored by Jochen Bartl on Patreon.
---
 debian/changelog                    |  8 ++++----
 propellor.cabal                     |  2 +-
 src/Propellor/Property/Chroot.hs    | 22 ----------------------
 src/Propellor/Property/DiskImage.hs |  5 +++--
 src/Propellor/Property/Service.hs   | 33 ++++++++++++++++++++++++++++++++-
 5 files changed, 40 insertions(+), 30 deletions(-)

(limited to 'src/Propellor/Property/DiskImage.hs')

diff --git a/debian/changelog b/debian/changelog
index 78115eb3..f7bc48c3 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,13 +1,13 @@
-propellor (4.9.1) UNRELEASED; urgency=medium
+propellor (5.0.0) UNRELEASED; 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.
-  * Service: Changed to use invoke-rc.d rather than the service command for
-    starting services. This notably means that in chroots, services will
-    not be started.
+  * 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
diff --git a/propellor.cabal b/propellor.cabal
index 239a00e6..9bafd2fb 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -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>
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index ea8b1407..0dd1f05a 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -9,7 +9,6 @@ module Propellor.Property.Chroot (
 	ChrootBootstrapper(..),
 	Debootstrapped(..),
 	ChrootTarball(..),
-	noServices,
 	inChroot,
 	exposeTrueLocaldir,
 	-- * Internal use
@@ -32,7 +31,6 @@ import qualified Propellor.Property.Systemd.Core as Systemd
 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
@@ -257,26 +255,6 @@ mungeloc = replace "/" "_"
 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.
 --
 -- This allows properties to check and avoid performing actions that
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 68b34412..f0e1602e 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -24,6 +24,7 @@ import Propellor.Property.Chroot (Chroot)
 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
@@ -103,7 +104,7 @@ instance DiskImage VirtualBoxPointer where
 -- 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.
@@ -185,7 +186,7 @@ imageBuilt' rebuild img mkchroot tabletype partspec =
 		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) =
diff --git a/src/Propellor/Property/Service.hs b/src/Propellor/Property/Service.hs
index e6a69eb5..0bcfdb93 100644
--- a/src/Propellor/Property/Service.hs
+++ b/src/Propellor/Property/Service.hs
@@ -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
 
@@ -23,5 +28,31 @@ reloaded = signaled "reload" "reloaded"
 signaled :: String -> Desc -> ServiceName -> Property DebianLike
 signaled cmd desc svc = tightenTargets $ p `describe` (desc ++ " " ++ svc)
   where
-	p = scriptProperty ["invoke-rc.d " ++ shellEscape svc ++ " " ++ cmd ++ " >/dev/null 2>&1 || true"]
+	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.
+checkNoServices :: Propellor Bool
+checkNoServices = isJust . fromInfoVal
+	<$> (askInfo :: Propellor (InfoVal NoServices))
+
+data NoServices = NoServices deriving (Eq, Show, Typeable)
-- 
cgit v1.3-2-g0d8e


From 492c52bfabb4d1772034eb15b263f5e257d2548b Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Sat, 18 Nov 2017 05:02:24 -0400
Subject: reorganized

---
 src/Propellor/Property/DiskImage.hs              |  2 +-
 src/Propellor/Property/DiskImage/PartSpec.hs     | 67 +++++++++++++++++++-----
 src/Propellor/Property/Parted.hs                 | 23 ++++++--
 src/Propellor/Property/SiteSpecific/JoeySites.hs |  2 +-
 src/Propellor/Types/PartSpec.hs                  | 58 --------------------
 5 files changed, 76 insertions(+), 76 deletions(-)

(limited to 'src/Propellor/Property/DiskImage.hs')

diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index f0e1602e..2c35b532 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -224,7 +224,7 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
 		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
diff --git a/src/Propellor/Property/DiskImage/PartSpec.hs b/src/Propellor/Property/DiskImage/PartSpec.hs
index 55249889..f7492589 100644
--- a/src/Propellor/Property/DiskImage/PartSpec.hs
+++ b/src/Propellor/Property/DiskImage/PartSpec.hs
@@ -1,10 +1,5 @@
 -- | Disk image partition specification and combinators.
 
--- 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.
-
 module Propellor.Property.DiskImage.PartSpec (
 	module Propellor.Types.PartSpec,
 	module Propellor.Property.DiskImage.PartSpec,
@@ -17,17 +12,63 @@ import Propellor.Property.Parted
 import Propellor.Types.PartSpec
 import Propellor.Property.Parted.Types
 import Propellor.Property.Partition (Fs(..))
+import Propellor.Property.Mount
+
+-- | 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)
 
--- | Adds additional free space to the partition.
+-- | Specifies where to mount a partition.
+mountedAt :: PartSpec t -> FilePath -> 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)
+
+adjustt :: PartSpec t -> (t -> t) -> PartSpec t
+adjustt (mp, o, p, t) f = (mp, o, p, f t)
diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs
index 43744142..d60d4a60 100644
--- a/src/Propellor/Property/Parted.hs
+++ b/src/Propellor/Property/Parted.hs
@@ -21,13 +21,14 @@ module Propellor.Property.Parted (
 	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 Propellor.Property.Parted.Types
 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 @@ instance Monoid DiskPart
 -- (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)
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index 1a4e211c..097171a3 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -971,7 +971,7 @@ homeRouter = propertyList "home router" $ props
 		`requires` File.dirExists "/etc/hostapd"
 		`requires` File.hasContent "/etc/default/hostapd"
 			[ "DAEMON_CONF=/etc/hostapd/hostapd.conf" ]
-		`onChange` Service.started "hostapd"
+		`onChange` Service.running "hostapd"
 	& File.hasContent "/etc/resolv.conf"
 		[ "domain kitenet.net"
 		, "search kitenet.net"
diff --git a/src/Propellor/Types/PartSpec.hs b/src/Propellor/Types/PartSpec.hs
index 2b0a8787..860b38f6 100644
--- a/src/Propellor/Types/PartSpec.hs
+++ b/src/Propellor/Types/PartSpec.hs
@@ -1,66 +1,8 @@
--- | 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)
-
--- | Default partition size when not otherwize specified is 128 MegaBytes.
-defSz :: PartSize
-defSz = MegaBytes 128
-- 
cgit v1.3-2-g0d8e