From e972d8bd6e283803ce4f5ef03cb35aa72de45d7f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 10:46:03 -0700 Subject: propellor spin --- config-joey.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) (limited to 'config-joey.hs') diff --git a/config-joey.hs b/config-joey.hs index 71b1a4ae..b3769db3 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -26,6 +26,7 @@ import qualified Propellor.Property.Gpg as Gpg import qualified Propellor.Property.Systemd as Systemd import qualified Propellor.Property.Journald as Journald import qualified Propellor.Property.Chroot as Chroot +import qualified Propellor.Property.DiskImage as DiskImage import qualified Propellor.Property.OS as OS import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost import qualified Propellor.Property.HostingProvider.Linode as Linode @@ -80,8 +81,15 @@ darkstar = host "darkstar.kitenet.net" & JoeySites.postfixClientRelay (Context "darkstar.kitenet.net") & JoeySites.dkimMilter - & partitioned YesReallyDeleteDiskContents "/home/joey/disk" - (PartTable MSDOS [ mkPartition EXT3 (MegaBytes 256), mkPartition LinuxSwap (MegaBytes 16)]) + & DiskImage.built "/tmp/img" c ps (DiskImage.grubBooted DiskImage.PC) + where + c d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d + & Apt.installed ["openssh-server"] + ps = DiskImage.fitChrootSize MSDOS + [ EXT2 `DiskImage.mountedPartition` "/boot" + , EXT4 `DiskImage.mountedPartition` "/" + , DiskImage.swapPartition (MegaBytes 256) + ] gnu :: Host gnu = host "gnu.kitenet.net" -- cgit v1.3-2-g0d8e From b08e5f6ebed4f8ae429876c4f01f31000562ab66 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 11:58:06 -0700 Subject: propellor spin --- config-joey.hs | 2 +- src/Propellor/Property/DiskImage.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'config-joey.hs') diff --git a/config-joey.hs b/config-joey.hs index b3769db3..276817f2 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -84,7 +84,7 @@ darkstar = host "darkstar.kitenet.net" & DiskImage.built "/tmp/img" c ps (DiskImage.grubBooted DiskImage.PC) where c d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d - & Apt.installed ["openssh-server"] + & Apt.installed ["linux-image-amd64"] ps = DiskImage.fitChrootSize MSDOS [ EXT2 `DiskImage.mountedPartition` "/boot" , EXT4 `DiskImage.mountedPartition` "/" diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 5cef449b..b31aef45 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -42,7 +42,7 @@ import System.Posix.Files -- > import Propellor.Property.Parted -- -- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d --- > & Apt.installed ["openssh-server"] +-- > & Apt.installed ["linux-image-amd64"] -- > & ... -- > partitions = DiskImage.fitChrootSize MSDOS -- > [ EXT2 `DiskImage.mountedPartition` "/boot" @@ -81,7 +81,7 @@ built' rebuild img mkchroot mkparttable final = <$> dirSizes chrootdir -- tie the knot! let (mnts, t) = mkparttable (map (getMountSz szm) mnts) - liftIO $ print (mnts, t, map (getMountSz szm) mnts, szm) + liftIO $ print (mnts, t, map (getMountSz szm) mnts) ensureProperty $ exists img (partTableSize t) `before` -- cgit v1.3-2-g0d8e From 1ac3495e9c3ac2a5e9118e143e2a9621746ee918 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 12:21:00 -0700 Subject: rename --- config-joey.hs | 4 ++-- src/Propellor/Property/DiskImage.hs | 10 +++++----- 2 files changed, 7 insertions(+), 7 deletions(-) (limited to 'config-joey.hs') diff --git a/config-joey.hs b/config-joey.hs index 276817f2..c66c682a 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -86,8 +86,8 @@ darkstar = host "darkstar.kitenet.net" c d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d & Apt.installed ["linux-image-amd64"] ps = DiskImage.fitChrootSize MSDOS - [ EXT2 `DiskImage.mountedPartition` "/boot" - , EXT4 `DiskImage.mountedPartition` "/" + [ mkPartition EXT2 `DiskImage.mountedAt` "/boot" + , mkPartition EXT4 `DiskImage.mountedAt` "/" , DiskImage.swapPartition (MegaBytes 256) ] diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 7820c4c3..fe24496f 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -6,7 +6,7 @@ module Propellor.Property.DiskImage ( exists, MountPoint, PartSpec, - mountedPartition, + mountedAt, swapPartition, MkPartTable, fitChrootSize, @@ -45,8 +45,8 @@ import System.Posix.Files -- > & Apt.installed ["linux-image-amd64"] -- > & ... -- > partitions = DiskImage.fitChrootSize MSDOS --- > [ EXT2 `DiskImage.mountedPartition` "/boot" --- > , EXT4 `DiskImage.mountedPartition` "/" +-- > [ mkPartition EXT2 `DiskImage.mountedAt` "/boot" +-- > , mkPartition EXT4 `DiskImage.mountedAt` "/" -- > , DiskImage.swapPartition (MegaBytes 256) -- > ] -- > in DiskImage.built "/srv/images/foo.img" chroot partitions (DiskImage.grubBooted DiskImage.PC) @@ -144,8 +144,8 @@ type MountPoint = Maybe FilePath type PartSpec = (MountPoint, PartSize -> Partition) -- | Specifies a mounted partition using a given filesystem. -mountedPartition :: Fs -> FilePath -> PartSpec -mountedPartition fs mntpoint = (Just mntpoint, mkPartition fs) +mountedAt :: (PartSize -> Partition) -> FilePath -> PartSpec +mountedAt mkp mntpoint = (Just mntpoint, mkp) -- | Specifies a swap partition of a given size. swapPartition :: PartSize -> PartSpec -- cgit v1.3-2-g0d8e From 8c37389e618058dca877bedcbe2b606d754d6c2f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 12:23:37 -0700 Subject: import unqualified --- config-joey.hs | 13 ++++++------ src/Propellor/Property/DiskImage.hs | 42 ++++++++++++++++++++----------------- 2 files changed, 29 insertions(+), 26 deletions(-) (limited to 'config-joey.hs') diff --git a/config-joey.hs b/config-joey.hs index c66c682a..35739f05 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -26,7 +26,6 @@ import qualified Propellor.Property.Gpg as Gpg import qualified Propellor.Property.Systemd as Systemd import qualified Propellor.Property.Journald as Journald import qualified Propellor.Property.Chroot as Chroot -import qualified Propellor.Property.DiskImage as DiskImage import qualified Propellor.Property.OS as OS import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost import qualified Propellor.Property.HostingProvider.Linode as Linode @@ -35,7 +34,7 @@ import qualified Propellor.Property.SiteSpecific.GitAnnexBuilder as GitAnnexBuil import qualified Propellor.Property.SiteSpecific.IABak as IABak import qualified Propellor.Property.SiteSpecific.Branchable as Branchable import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites -import Propellor.Property.Parted +import Propellor.Property.DiskImage main :: IO () -- _ ______`| ,-.__ main = defaultMain hosts -- / \___-=O`/|O`/__| (____.' @@ -81,14 +80,14 @@ darkstar = host "darkstar.kitenet.net" & JoeySites.postfixClientRelay (Context "darkstar.kitenet.net") & JoeySites.dkimMilter - & DiskImage.built "/tmp/img" c ps (DiskImage.grubBooted DiskImage.PC) + & imageBuilt "/tmp/img" c ps (grubBooted PC) where c d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d & Apt.installed ["linux-image-amd64"] - ps = DiskImage.fitChrootSize MSDOS - [ mkPartition EXT2 `DiskImage.mountedAt` "/boot" - , mkPartition EXT4 `DiskImage.mountedAt` "/" - , DiskImage.swapPartition (MegaBytes 256) + ps = fitChrootSize MSDOS + [ mkPartition EXT2 `mountedAt` "/boot" + , mkPartition EXT4 `mountedAt` "/" + , swapPartition (MegaBytes 256) ] gnu :: Host diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index fe24496f..ff9570dc 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -1,9 +1,13 @@ {-# LANGUAGE FlexibleContexts #-} +-- | Disk image generation. +-- +-- This module is designed to be imported unqualified. + module Propellor.Property.DiskImage ( - built, - rebuilt, - exists, + imageBuilt, + imageRebuilt, + imageExists, MountPoint, PartSpec, mountedAt, @@ -14,6 +18,7 @@ module Propellor.Property.DiskImage ( Finalization, grubBooted, Grub.BIOS(..), + module Propellor.Property.Parted ) where import Propellor @@ -38,29 +43,28 @@ import System.Posix.Files -- -- Example use: -- --- > import qualified Propellor.Property.DiskImage as DiskImage --- > import Propellor.Property.Parted +-- > import Propellor.Property.DiskImage -- -- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d -- > & Apt.installed ["linux-image-amd64"] -- > & ... --- > partitions = DiskImage.fitChrootSize MSDOS --- > [ mkPartition EXT2 `DiskImage.mountedAt` "/boot" --- > , mkPartition EXT4 `DiskImage.mountedAt` "/" --- > , DiskImage.swapPartition (MegaBytes 256) +-- > partitions = fitChrootSize MSDOS +-- > [ mkPartition EXT2 `mountedAt` "/boot" +-- > , mkPartition EXT4 `mountedAt` "/" +-- > , swapPartition (MegaBytes 256) -- > ] --- > in DiskImage.built "/srv/images/foo.img" chroot partitions (DiskImage.grubBooted DiskImage.PC) -built :: FilePath -> (FilePath -> Chroot) -> MkPartTable -> Finalization -> RevertableProperty -built = built' False +-- > in imageBuilt "/srv/images/foo.img" chroot partitions (grubBooted PC) +imageBuilt :: FilePath -> (FilePath -> Chroot) -> MkPartTable -> Finalization -> RevertableProperty +imageBuilt = imageBuilt' False -- | Like 'built', but the chroot is deleted and rebuilt from scratch each -- time. This is more expensive, but useful to ensure reproducible results -- when the properties of the chroot have been changed. -rebuilt :: FilePath -> (FilePath -> Chroot) -> MkPartTable -> Finalization -> RevertableProperty -rebuilt = built' True +imageRebuilt :: FilePath -> (FilePath -> Chroot) -> MkPartTable -> Finalization -> RevertableProperty +imageRebuilt = imageBuilt' True -built' :: Bool -> FilePath -> (FilePath -> Chroot) -> MkPartTable -> Finalization -> RevertableProperty -built' rebuild img mkchroot mkparttable final = +imageBuilt' :: Bool -> FilePath -> (FilePath -> Chroot) -> MkPartTable -> Finalization -> RevertableProperty +imageBuilt' rebuild img mkchroot mkparttable final = (mkimg unmkimg) -- TODO snd final -- TODO copy in @@ -85,7 +89,7 @@ built' rebuild img mkchroot mkparttable final = -- TODO if any size is < 1 MB, use 1 MB for sanity let (mnts, t) = mkparttable (map (getMountSz szm) mnts) ensureProperty $ - exists img (partTableSize t) + imageExists img (partTableSize t) `before` partitioned YesReallyDeleteDiskContents img t handlerebuild @@ -103,8 +107,8 @@ built' rebuild img mkchroot mkparttable final = -- If the file doesn't exist, or is too small, creates a new one, full of 0's. -- -- If the file is too large, truncates it down to the specified size. -exists :: FilePath -> ByteSize -> Property NoInfo -exists img sz = property ("disk image exists" ++ img) $ liftIO $ do +imageExists :: FilePath -> ByteSize -> Property NoInfo +imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do ms <- catchMaybeIO $ getFileStatus img case ms of Just s -- cgit v1.3-2-g0d8e From 851f7ebb8d598d9379a275df9b13303d3ac6d521 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 15:44:47 -0700 Subject: propellor spin --- config-joey.hs | 2 +- src/Propellor/Property/DiskImage.hs | 13 +++++++++++-- 2 files changed, 12 insertions(+), 3 deletions(-) (limited to 'config-joey.hs') diff --git a/config-joey.hs b/config-joey.hs index 35739f05..bfd14d7e 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -80,7 +80,7 @@ darkstar = host "darkstar.kitenet.net" & JoeySites.postfixClientRelay (Context "darkstar.kitenet.net") & JoeySites.dkimMilter - & imageBuilt "/tmp/img" c ps (grubBooted PC) + & imageBuilt "/tmp/img" c ps noFinalization -- (grubBooted PC) where c d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d & Apt.installed ["linux-image-amd64"] diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 384718ca..2c222cb2 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -23,6 +23,7 @@ module Propellor.Property.DiskImage ( Finalization, grubBooted, Grub.BIOS(..), + noFinalization, ) where import Propellor @@ -31,6 +32,7 @@ import Propellor.Property.Chroot.Util (removeChroot) 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 Propellor.Property.Parted import Propellor.Property.Mount import Utility.Path @@ -73,14 +75,18 @@ imageBuilt' rebuild img mkchroot mkparttable final = (mkimg unmkimg) -- TODO snd final -- TODO copy in - -- TODO chroot topevel directory perm fixup - `requires` Chroot.provisioned (mkchroot chrootdir & fst final) + `requires` Chroot.provisioned chroot `requires` (cleanrebuild doNothing) `describe` desc where desc = "built disk image " ++ img unmkimg = File.notPresent img chrootdir = img ++ ".chroot" + chroot = mkchroot chrootdir + -- Run first stage finalization. + & fst final + -- Avoid wasting disk image space on the apt cache + & Apt.cacheCleaned mkimg = property desc $ do -- unmount helper filesystems such as proc from the chroot -- before getting sizes @@ -223,3 +229,6 @@ type Finalization = (Property NoInfo, Property NoInfo) -- | Makes grub be the boot loader of the disk image. grubBooted :: Grub.BIOS -> Finalization grubBooted bios = (Grub.installed bios, undefined) + +noFinalization :: Finalization +noFinalization = (doNothing, doNothing) -- cgit v1.3-2-g0d8e From 55b925a6e0e5a27a964d9b80cd64d519cda7ae3d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 3 Sep 2015 07:21:49 -0700 Subject: partition setup dsl --- config-joey.hs | 11 ++-- src/Propellor/Property/DiskImage.hs | 128 ++++++++++++++++++------------------ src/Propellor/Property/Parted.hs | 6 +- 3 files changed, 75 insertions(+), 70 deletions(-) (limited to 'config-joey.hs') diff --git a/config-joey.hs b/config-joey.hs index bfd14d7e..75150184 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -80,15 +80,14 @@ darkstar = host "darkstar.kitenet.net" & JoeySites.postfixClientRelay (Context "darkstar.kitenet.net") & JoeySites.dkimMilter - & imageBuilt "/tmp/img" c ps noFinalization -- (grubBooted PC) + & imageBuilt "/tmp/img" c MSDOS + [ mkPartition EXT2 `setFlag` BootFlag `mountedAt` "/boot" + , mkPartition EXT4 `addFreeSpace` MegaBytes 100 `mountedAt` "/" + , swapPartition (MegaBytes 256) + ] noFinalization -- (grubBooted PC) where c d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d & Apt.installed ["linux-image-amd64"] - ps = fitChrootSize MSDOS - [ mkPartition EXT2 `mountedAt` "/boot" - , mkPartition EXT4 `mountedAt` "/" - , swapPartition (MegaBytes 256) - ] gnu :: Host gnu = host "gnu.kitenet.net" diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 8ee77376..4ef8d1a4 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} - -- | Disk image generation. -- -- This module is designed to be imported unqualified. @@ -11,27 +9,23 @@ module Propellor.Property.DiskImage ( imageRebuilt, imageBuiltFrom, imageExists, - -- * Partition specifiction - MountPoint, + -- * Partitioning + Partition, + MkPartition, + mkPartition, + PartSize(..), + Fs(..), PartSpec, + MountPoint, mountedAt, swapPartition, - TableType(..), - PartTable(..), - Partition(..), - mkPartition, - Fs(..), - PartSize(..), - ByteSize, - toPartSize, - fromPartSize, - reducePartSize, - PartType(..), + addFreeSpace, + setSize, PartFlag(..), - -- * Partition sizing - SizePartTable, - fitChrootSize, - freeSpace, + setFlag, + TableType(..), + extended, + adjustp, -- * Finalization Finalization, grubBooted, @@ -70,24 +64,23 @@ type DiskImage = FilePath -- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d -- > & Apt.installed ["linux-image-amd64"] -- > & ... --- > partitions = fitChrootSize MSDOS --- > [ mkPartition EXT2 `mountedAt` "/boot" --- > , mkPartition EXT4 `mountedAt` "/" +-- > in imageBuilt "/srv/images/foo.img" chroot MSDOS +-- > [ mkPartition EXT2 `setFlag` BootFlag `mountedAt` "/boot" +-- > , mkPartition EXT4 `addFreeSpace` MegaBytes 100 `mountedAt` "/" -- > , swapPartition (MegaBytes 256) --- > ] --- > in imageBuilt "/srv/images/foo.img" chroot partitions (grubBooted PC) -imageBuilt :: DiskImage -> (FilePath -> Chroot) -> SizePartTable -> Finalization -> RevertableProperty +-- > ] (grubBooted PC) +imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty imageBuilt = imageBuilt' False -- | Like 'built', but the chroot is deleted and rebuilt from scratch each -- time. This is more expensive, but useful to ensure reproducible results -- when the properties of the chroot have been changed. -imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> SizePartTable -> Finalization -> RevertableProperty +imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty imageRebuilt = imageBuilt' True -imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> SizePartTable -> Finalization -> RevertableProperty -imageBuilt' rebuild img mkchroot mkparttable final = - imageBuiltFrom img chrootdir mkparttable (snd final) +imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty +imageBuilt' rebuild img mkchroot tabletype partspec final = + imageBuiltFrom img chrootdir tabletype partspec (snd final) `requires` Chroot.provisioned chroot `requires` (cleanrebuild doNothing) `describe` desc @@ -111,8 +104,8 @@ imageBuilt' rebuild img mkchroot mkparttable final = -- -- TODO copy in -- TODO run final -imageBuiltFrom :: DiskImage -> FilePath -> SizePartTable -> Property NoInfo -> RevertableProperty -imageBuiltFrom img chrootdir mkparttable final = mkimg rmimg +imageBuiltFrom :: DiskImage -> FilePath -> TableType -> [PartSpec] -> Property NoInfo -> RevertableProperty +imageBuiltFrom img chrootdir tabletype partspec final = mkimg rmimg where mkimg = property (img ++ " built from " ++ chrootdir) $ do -- unmount helper filesystems such as proc from the chroot @@ -120,10 +113,9 @@ imageBuiltFrom img chrootdir mkparttable final = mkimg rmimg liftIO $ unmountBelow chrootdir szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize <$> liftIO (dirSizes chrootdir) - let calcsz = \mnts -> saneSz . fromMaybe defSz . getMountSz szm mnts + let calcsz = \mnts -> fromMaybe defSz . getMountSz szm mnts -- tie the knot! - let (mnts, t) = mkparttable (map (calcsz mnts) mnts) - liftIO $ print (mnts, t) + let (mnts, t) = fitChrootSize tabletype partspec (map (calcsz mnts) mnts) ensureProperty $ imageExists img (partTableSize t) `before` @@ -149,8 +141,9 @@ imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do return MadeChange -- | Generates a map of the sizes of the contents of --- every directory in a filesystem tree. (Hard links are counted multiple --- times for simplicity) +-- every directory in a filesystem tree. +-- +-- (Hard links are counted multiple times for simplicity) -- -- Should be same values as du -bl dirSizes :: FilePath -> IO (M.Map FilePath Integer) @@ -196,52 +189,61 @@ toSysDir chrootdir d = case makeRelative chrootdir d of -- | Where a partition is mounted. Use Nothing for eg, LinuxSwap. type MountPoint = Maybe FilePath +-- | A constructor for a Partition that has not yet been provided with a size. +-- +-- The size that is eventually provided is the amount of space needed to +-- hold the files that appear in the directory where the partition is to be +-- mounted. +-- +-- (Partitions that are not to be mounted (ie, LinuxSwap), or that have +-- no corresponding directory in the chroot will have 128 MegaBytes +-- provided as a default size.) +type MkPartition = PartSize -> Partition + +defSz :: PartSize +defSz = MegaBytes 128 + -- | Specifies a mount point and a constructor for a Partition --- that will later be privided with a size. -type PartSpec = (MountPoint, PartSize -> Partition) +-- that will later be provided with a size. +type PartSpec = (MountPoint, MkPartition) -- | Specifies a mounted partition using a given filesystem. -mountedAt :: (PartSize -> Partition) -> FilePath -> PartSpec +mountedAt :: MkPartition -> FilePath -> PartSpec mountedAt mkp mntpoint = (Just mntpoint, mkp) -- | Specifies a swap partition of a given size. swapPartition :: PartSize -> PartSpec swapPartition sz = (Nothing, const (mkPartition LinuxSwap sz)) --- | Avoid partitions smaller than 1 mb; parted gets confused. -saneSz :: PartSize -> PartSize -saneSz (MegaBytes n) | n < 1 = MegaBytes 1 -saneSz sz = sz +-- | Adds additional free space to the partition. +addFreeSpace :: MkPartition -> PartSize -> MkPartition +addFreeSpace mkp freesz = \sz -> mkp (sz <> freesz) -defSz :: PartSize -defSz = MegaBytes 128 +-- | Forced a partition to be a specific size, instead of scaling to the +-- size needed for the files in the chroot. +setSize :: MkPartition -> PartSize -> MkPartition +setSize mkp sz = const (mkp sz) --- | This is provided with a list of the sizes of directories in the chroot --- under each mount point. The input list corresponds to the list of mount --- points that the function returns! This trick is accomplished by --- exploiting laziness and tying the knot. --- --- (Partitions that are not to be mounted (ie, LinuxSwap), or that have --- no corresponding directory in the chroot will have 128 MegaBytes --- provided as a default size.) -type SizePartTable = [PartSize] -> ([MountPoint], PartTable) +-- | Sets a flag on the partition. +setFlag :: MkPartition -> PartFlag -> MkPartition +setFlag mkp f = adjustp mkp $ \p -> p { partFlags = (f, True):partFlags p } + +-- | Makes a MSDOS partition be Extended, rather than Primary. +extended :: MkPartition -> MkPartition +extended mkp = adjustp mkp $ \p -> p { partType = Extended } + +-- | Apply a Partition adjustment to a MkPartition. +adjustp :: MkPartition -> (Partition -> Partition) -> MkPartition +adjustp mkp f = f . mkp -- | The constructor for each Partition is passed the size of the files -- from the chroot that will be put in that partition. -fitChrootSize :: TableType -> [PartSpec] -> SizePartTable +fitChrootSize :: TableType -> [PartSpec] -> [PartSize] -> ([MountPoint], PartTable) fitChrootSize tt l basesizes = (mounts, parttable) where (mounts, sizers) = unzip l parttable = PartTable tt (map (uncurry id) (zip sizers basesizes)) --- | After populating the partitions with files from the chroot, --- they will have remaining free space equal to the sizes of the input --- partitions. -freeSpace :: TableType -> [(MountPoint, Partition)] -> SizePartTable -freeSpace tt = fitChrootSize tt . map (\(mnt, p) -> (mnt, adjustsz p)) - where - adjustsz p basesize = p { partSize = partSize p <> basesize } - -- | A pair of properties. The first property is satisfied within the -- chroot, and is typically used to download the boot loader. -- The second property is satisfied chrooted into the resulting diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs index 0b77fad1..a4f0f98e 100644 --- a/src/Propellor/Property/Parted.hs +++ b/src/Propellor/Property/Parted.hs @@ -93,7 +93,11 @@ newtype PartSize = MegaBytes Integer deriving (Show) instance PartedVal PartSize where - val (MegaBytes n) = show n ++ "MB" + val (MegaBytes n) + | n > 0 = show n ++ "MB" + -- parted can't make partitions smaller than 1MB; + -- avoid failure in edge cases + | otherwise = show "1MB" -- | Rounds up to the nearest MegaByte. toPartSize :: ByteSize -> PartSize -- cgit v1.3-2-g0d8e From 30a60f8b288b2007d10f08b94ce17bdb91e586bb Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 3 Sep 2015 08:38:07 -0700 Subject: improve types for PartSpec DSL --- config-joey.hs | 4 +-- src/Propellor/Property/DiskImage.hs | 61 +++++++++++++++++++------------------ 2 files changed, 33 insertions(+), 32 deletions(-) (limited to 'config-joey.hs') diff --git a/config-joey.hs b/config-joey.hs index 75150184..2bb2f1bd 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -81,8 +81,8 @@ darkstar = host "darkstar.kitenet.net" & JoeySites.dkimMilter & imageBuilt "/tmp/img" c MSDOS - [ mkPartition EXT2 `setFlag` BootFlag `mountedAt` "/boot" - , mkPartition EXT4 `addFreeSpace` MegaBytes 100 `mountedAt` "/" + [ partition EXT2 `mountedAt` "/boot" `setFlag` BootFlag + , partition EXT4 `mountedAt` "/" `addFreeSpace` MegaBytes 100 , swapPartition (MegaBytes 256) ] noFinalization -- (grubBooted PC) where diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 4ef8d1a4..7e5112fb 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -11,14 +11,13 @@ module Propellor.Property.DiskImage ( imageExists, -- * Partitioning Partition, - MkPartition, - mkPartition, PartSize(..), Fs(..), PartSpec, MountPoint, - mountedAt, swapPartition, + partition, + mountedAt, addFreeSpace, setSize, PartFlag(..), @@ -65,8 +64,8 @@ type DiskImage = FilePath -- > & Apt.installed ["linux-image-amd64"] -- > & ... -- > in imageBuilt "/srv/images/foo.img" chroot MSDOS --- > [ mkPartition EXT2 `setFlag` BootFlag `mountedAt` "/boot" --- > , mkPartition EXT4 `addFreeSpace` MegaBytes 100 `mountedAt` "/" +-- > [ partition EXT2 `mountedAt` "/boot" `setFlag` BootFlag +-- > , partition EXT4 `mountedAt` "/" `addFreeSpace` MegaBytes 100 -- > , swapPartition (MegaBytes 256) -- > ] (grubBooted PC) imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty @@ -189,8 +188,11 @@ toSysDir chrootdir d = case makeRelative chrootdir d of -- | Where a partition is mounted. Use Nothing for eg, LinuxSwap. type MountPoint = Maybe FilePath --- | A constructor for a Partition that has not yet been provided with a size. --- +defSz :: PartSize +defSz = MegaBytes 128 + +-- | Specifies a mount point and a constructor for a Partition. +-- -- The size that is eventually provided is the amount of space needed to -- hold the files that appear in the directory where the partition is to be -- mounted. @@ -198,43 +200,42 @@ type MountPoint = Maybe FilePath -- (Partitions that are not to be mounted (ie, LinuxSwap), or that have -- no corresponding directory in the chroot will have 128 MegaBytes -- provided as a default size.) -type MkPartition = PartSize -> Partition - -defSz :: PartSize -defSz = MegaBytes 128 - --- | Specifies a mount point and a constructor for a Partition --- that will later be provided with a size. -type PartSpec = (MountPoint, MkPartition) - --- | Specifies a mounted partition using a given filesystem. -mountedAt :: MkPartition -> FilePath -> PartSpec -mountedAt mkp mntpoint = (Just mntpoint, mkp) +type PartSpec = (MountPoint, PartSize -> Partition) -- | Specifies a swap partition of a given size. swapPartition :: PartSize -> PartSpec swapPartition sz = (Nothing, const (mkPartition LinuxSwap sz)) +-- | Specifies a partition with a given filesystem. +-- +-- The partition is not mounted anywhere by default; use the combinators +-- below to configure it. +partition :: Fs -> PartSpec +partition fs = (Nothing, mkPartition fs) + +-- | Specifies where to mount a partition. +mountedAt :: PartSpec -> FilePath -> PartSpec +mountedAt (_, p) mp = (Just mp, p) + -- | Adds additional free space to the partition. -addFreeSpace :: MkPartition -> PartSize -> MkPartition -addFreeSpace mkp freesz = \sz -> mkp (sz <> freesz) +addFreeSpace :: PartSpec -> PartSize -> PartSpec +addFreeSpace (mp, p) freesz = (mp, \sz -> p (sz <> freesz)) -- | Forced a partition to be a specific size, instead of scaling to the -- size needed for the files in the chroot. -setSize :: MkPartition -> PartSize -> MkPartition -setSize mkp sz = const (mkp sz) +setSize :: PartSpec -> PartSize -> PartSpec +setSize (mp, p) sz = (mp, const (p sz)) -- | Sets a flag on the partition. -setFlag :: MkPartition -> PartFlag -> MkPartition -setFlag mkp f = adjustp mkp $ \p -> p { partFlags = (f, True):partFlags p } +setFlag :: PartSpec -> PartFlag -> PartSpec +setFlag s f = adjustp s $ \p -> p { partFlags = (f, True):partFlags p } -- | Makes a MSDOS partition be Extended, rather than Primary. -extended :: MkPartition -> MkPartition -extended mkp = adjustp mkp $ \p -> p { partType = Extended } +extended :: PartSpec -> PartSpec +extended s = adjustp s $ \p -> p { partType = Extended } --- | Apply a Partition adjustment to a MkPartition. -adjustp :: MkPartition -> (Partition -> Partition) -> MkPartition -adjustp mkp f = f . mkp +adjustp :: PartSpec -> (Partition -> Partition) -> PartSpec +adjustp (mp, p) f = (mp, \sz -> f (p sz)) -- | The constructor for each Partition is passed the size of the files -- from the chroot that will be put in that partition. -- cgit v1.3-2-g0d8e