From 5462723243355c387746b10298db747d95e3e2c9 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 25 Aug 2015 15:53:00 -0700 Subject: working on parted --- src/Propellor/Property/DiskImage.hs | 50 ++++++++++++++ src/Propellor/Property/Parted.hs | 129 ++++++++++++++++++++++++++++++++++++ 2 files changed, 179 insertions(+) create mode 100644 src/Propellor/Property/DiskImage.hs create mode 100644 src/Propellor/Property/Parted.hs (limited to 'src') diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs new file mode 100644 index 00000000..15108249 --- /dev/null +++ b/src/Propellor/Property/DiskImage.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Propellor.Property.DiskImage ( + built, + DiskImageConfig(..), + DiskImageFinalization, + grubBooted, +) where + +import Propellor +import Propellor.Property.Chroot +import Utility.DataUnits +import Data.Monoid + +-- | Creates a bootable disk image. +-- +-- First the specified Chroot is set up, then a disk image is created, +-- large enough to fit the chroot, which is copied into it. Finally, the +-- DiskImageFinalization property is satisfied to make the disk image +-- bootable. +-- +-- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") Debootstrap.DefaultConfig d +-- > & Apt.installed ["openssh-server"] +-- > & Grub.installed Grub.PC +-- > & ... +-- > in DiskImage.built mempty chroot DiskImage.grubBooted +built :: DiskImageConfig -> (FilePath -> Chroot) -> DiskImageFinalization -> RevertableProperty +built c = undefined + +data DiskImageConfig = DiskImageConfig + { freeSpace :: ByteSize -- ^ A disk image is sized to fit the system installed in it. This adds some extra free space. + } + +instance Monoid DiskImageConfig where + -- | Default value is 256 mb freeSpace. + mempty = DiskImageConfig (1024 * 1024 * 256) + mappend a b = a + { freeSpace = freeSpace a + freeSpace b + } + +-- | This is a property that is run, chrooted into the disk image. It's +-- typically only used to set up the boot loader. +type DiskImageFinalization = Property NoInfo + +-- | Makes grub be the boot loader of the disk image. +-- +-- This does not cause grub to be installed. Use `Grub.installed` when +-- setting up the Chroot to do that. +grubBooted :: DiskImageFinalization +grubBooted = undefined diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs new file mode 100644 index 00000000..3a927354 --- /dev/null +++ b/src/Propellor/Property/Parted.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Propellor.Property.Parted ( + TableType(..), + PartTable(..), + PartType(..), + FsType, + PartFlag(..), + Eep(..), + partitioned, + parted, + installed, +) where + +import Propellor +import qualified Propellor.Property.Apt as Apt +import Utility.DataUnits +import Data.Char + +class PartedVal a where + val :: a -> String + +-- | Types of partition tables supported by parted. +data TableType = MSDOS | GPT | AIX | AMIGA | BSD | DVH | LOOP | MAC | PC98 | SUN + deriving (Show) + +instance PartedVal TableType where + val = map toLower . show + +-- | A disk's partition table. +data PartTable = PartTable TableType [Partition] + deriving (Show) + +instance Monoid PartTable where + -- | default TableType is MSDOS + mempty = PartTable MSDOS [] + -- | uses the TableType of the second parameter + mappend (PartTable _l1 ps1) (PartTable l2 ps2) = PartTable l2 (ps1 ++ ps2) + +-- | A partition on the disk. +data Partition = Partition + { partType :: PartType + , partFs :: FsType + , partSize :: ByteSize + , partFlags :: [(PartFlag, Bool)] -- ^ flags can be set or unset (parted may set some flags by default) + , partName :: Maybe String -- ^ optional name for partition (only works for GPT, PC98, MAC) + } + deriving (Show) + +-- | Type of a partition. +data PartType = Primary | Logical | Extended + deriving (Show) + +instance PartedVal PartType where + val Primary = "primary" + val Logical = "logical" + val Extended = "extended" + +-- | Eg, "ext4" or "fat16" or "ntfs" or "hfs+" or "linux-swap" +type FsType = String + +-- | Flags that can be set on a partition. +data PartFlag = BootFlag | RootFlag | SwapFlag | HiddenFlag | RaidFlag | LvmFlag | LbaFlag | LegacyBootFlag | IrstFlag | EspFlag | PaloFlag + deriving (Show) + +instance PartedVal PartFlag where + val BootFlag = "boot" + val RootFlag = "root" + val SwapFlag = "swap" + val HiddenFlag = "hidden" + val RaidFlag = "raid" + val LvmFlag = "lvm" + val LbaFlag = "lba" + val LegacyBootFlag = "legacy_boot" + val IrstFlag = "irst" + val EspFlag = "esp" + val PaloFlag = "palo" + +instance PartedVal Bool where + val True = "on" + val False = "off" + +data Eep = YesReallyDeleteDiskContents + +-- | Partitions a disk using parted. Does not mkfs filesystems. +-- +-- The FilePath can be a disk device (eg, /dev/sda), or a disk image file. +-- +-- This deletes any existing partitions in the disk! Use with EXTREME caution! +partitioned :: Eep -> FilePath -> PartTable -> Property NoInfo +partitioned eep disk (PartTable tabletype parts) = + parted eep disk (concat (setunits : mklabel : mkparts (1 :: Integer) 0 parts [])) + `describe` (disk ++ " partitioned") + where + mklabel = ["mklabel", val tabletype] + mkflag partnum (f, b) = + [ "set" + , show partnum + , val f + , val b + ] + setunits = ["unit", "B"] + mkpart partnum offset p = + [ "mkpart" + , show partnum + , val (partType p) + , partFs p + , show offset + , show (offset + partSize p) + ] ++ case partName p of + Just n -> ["name", show partnum, n] + Nothing -> [] + mkparts partnum offset (p:ps) c = + mkparts (partnum+1) (offset + partSize p) ps + (c ++ mkpart partnum offset p : map (mkflag partnum) (partFlags p)) + mkparts _ _ [] c = c + +-- | Runs parted on a disk with the specified parameters. +-- +-- Parted is run in script mode, so it will never prompt for input. +-- It is asked to use optimal alignment for the disk, for best performance. +parted :: Eep -> FilePath -> [String] -> Property NoInfo +parted YesReallyDeleteDiskContents disk ps = + cmdProperty "parted" ("--script":"--align":"optimal":disk:ps) + `requires` installed + +-- | Gets parted installed. +installed :: Property NoInfo +installed = Apt.installed ["parted"] -- cgit v1.2.3 From b3c3a7029020126b1ab5e2d5999b7b2707078150 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 25 Aug 2015 18:50:35 -0700 Subject: formatting for partitions set up by parted Including support for formatting partitions of a disk image file. --- debian/changelog | 1 + propellor.cabal | 1 + src/Propellor/Property/DiskImage.hs | 1 - src/Propellor/Property/Parted.hs | 61 +++++++++++++++++++++++++++++-------- src/Propellor/Property/Partition.hs | 54 ++++++++++++++++++++++++++++++++ 5 files changed, 104 insertions(+), 14 deletions(-) create mode 100644 src/Propellor/Property/Partition.hs (limited to 'src') diff --git a/debian/changelog b/debian/changelog index 45e80047..214038c3 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,6 +1,7 @@ propellor (2.7.3) UNRELEASED; urgency=medium * Added Propellor.Property.Parted, for disk partitioning. + * Added Propellor.Property.Partition, for partition formatting etc. * Added Propellor.Property.DiskImage, for bootable disk image creation. -- Joey Hess Tue, 25 Aug 2015 13:45:39 -0700 diff --git a/propellor.cabal b/propellor.cabal index d07684b1..329739be 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -96,6 +96,7 @@ Library Propellor.Property.OpenId Propellor.Property.OS Propellor.Property.Parted + Propellor.Property.Partition Propellor.Property.Postfix Propellor.Property.Prosody Propellor.Property.Reboot diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 15108249..de8bdd56 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -10,7 +10,6 @@ module Propellor.Property.DiskImage ( import Propellor import Propellor.Property.Chroot import Utility.DataUnits -import Data.Monoid -- | Creates a bootable disk image. -- diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs index 3a927354..2b741234 100644 --- a/src/Propellor/Property/Parted.hs +++ b/src/Propellor/Property/Parted.hs @@ -3,8 +3,11 @@ module Propellor.Property.Parted ( TableType(..), PartTable(..), + Partition(..), + mkPartition, + Partition.Fs(..), + Partition.MkfsOpts, PartType(..), - FsType, PartFlag(..), Eep(..), partitioned, @@ -14,8 +17,10 @@ module Propellor.Property.Parted ( import Propellor import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Partition as Partition import Utility.DataUnits import Data.Char +import System.Posix.Files class PartedVal a where val :: a -> String @@ -40,13 +45,25 @@ instance Monoid PartTable where -- | A partition on the disk. data Partition = Partition { partType :: PartType - , partFs :: FsType - , partSize :: ByteSize + , partSize :: ByteSize -- ^ size of the partition in bytes + , partFs :: Partition.Fs + , partMkFsOpts :: Partition.MkfsOpts , partFlags :: [(PartFlag, Bool)] -- ^ flags can be set or unset (parted may set some flags by default) , partName :: Maybe String -- ^ optional name for partition (only works for GPT, PC98, MAC) } deriving (Show) +-- | Makes a Partition with defaults for non-important values. +mkPartition :: Partition.Fs -> ByteSize -> Partition +mkPartition fs sz = Partition + { partType = Primary + , partSize = sz + , partFs = fs + , partMkFsOpts = [] + , partFlags = [] + , partName = Nothing + } + -- | Type of a partition. data PartType = Primary | Logical | Extended deriving (Show) @@ -56,9 +73,6 @@ instance PartedVal PartType where val Logical = "logical" val Extended = "extended" --- | Eg, "ext4" or "fat16" or "ntfs" or "hfs+" or "linux-swap" -type FsType = String - -- | Flags that can be set on a partition. data PartFlag = BootFlag | RootFlag | SwapFlag | HiddenFlag | RaidFlag | LvmFlag | LbaFlag | LegacyBootFlag | IrstFlag | EspFlag | PaloFlag deriving (Show) @@ -80,18 +94,39 @@ instance PartedVal Bool where val True = "on" val False = "off" +instance PartedVal Partition.Fs where + val Partition.EXT2 = "ext2" + val Partition.EXT3 = "ext3" + val Partition.EXT4 = "ext4" + val Partition.BTRFS = "btrfs" + val Partition.REISERFS = "reiserfs" + val Partition.XFS = "xfs" + val Partition.FAT = "fat" + val Partition.VFAT = "vfat" + val Partition.NTFS = "ntfs" + val Partition.LinuxSwap = "linux-swap" + data Eep = YesReallyDeleteDiskContents --- | Partitions a disk using parted. Does not mkfs filesystems. +-- | Partitions a disk using parted, and formats the partitions. -- --- The FilePath can be a disk device (eg, /dev/sda), or a disk image file. +-- The FilePath can be a block device (eg, /dev/sda), or a disk image file. -- -- This deletes any existing partitions in the disk! Use with EXTREME caution! partitioned :: Eep -> FilePath -> PartTable -> Property NoInfo -partitioned eep disk (PartTable tabletype parts) = - parted eep disk (concat (setunits : mklabel : mkparts (1 :: Integer) 0 parts [])) - `describe` (disk ++ " partitioned") +partitioned eep disk (PartTable tabletype parts) = property desc $ do + isdev <- liftIO $ isBlockDevice <$> getFileStatus disk + ensureProperty $ if isdev + then go (map (\n -> disk ++ show n) [1 :: Int ..]) + else Partition.kpartx disk go where + desc = disk ++ " partitioned" + go devs = combineProperties desc $ + parted eep disk partedparams : map format (zip parts devs) + partedparams = concat $ + setunits : mklabel : mkparts (1 :: Integer) 0 parts [] + format (p, dev) = Partition.formatted' (partMkFsOpts p) + Partition.YesReallyFormatPartition (partFs p) dev mklabel = ["mklabel", val tabletype] mkflag partnum (f, b) = [ "set" @@ -99,12 +134,12 @@ partitioned eep disk (PartTable tabletype parts) = , val f , val b ] - setunits = ["unit", "B"] + setunits = ["unit", "B"] -- tell parted we use bytes mkpart partnum offset p = [ "mkpart" , show partnum , val (partType p) - , partFs p + , val (partFs p) , show offset , show (offset + partSize p) ] ++ case partName p of diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs new file mode 100644 index 00000000..53d8a946 --- /dev/null +++ b/src/Propellor/Property/Partition.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Propellor.Property.Partition where + +import Propellor +import qualified Propellor.Property.Apt as Apt + +-- | Filesystems etc that can be used for a partition. +data Fs = EXT2 | EXT3 | EXT4 | BTRFS | REISERFS | XFS | FAT | VFAT | NTFS | LinuxSwap + deriving (Show) + +data Eep = YesReallyFormatPartition + +-- | Formats a partition. +formatted :: Eep -> Fs -> FilePath -> Property NoInfo +formatted = formatted' [] + +-- | Options passed to a mkfs.* command when making a filesystem. +-- +-- Eg, ["-m0"] +type MkfsOpts = [String] + +formatted' :: MkfsOpts -> Eep -> Fs -> FilePath -> Property NoInfo +formatted' opts YesReallyFormatPartition fs dev = + cmdProperty cmd opts' `requires` Apt.installed [pkg] + where + (cmd, opts', pkg) = case fs of + EXT2 -> ("mkfs.ext2", optsdev, "e2fsprogs") + EXT3 -> ("mkfs.ext3", optsdev, "e2fsprogs") + EXT4 -> ("mkfs.ext4", optsdev, "e2fsprogs") + BTRFS -> ("mkfs.btrfs", optsdev, "btrfs-tools") + REISERFS -> ("mkfs.reiserfs", optsdev, "reiserfsprogs") + XFS -> ("mkfs.xfs", optsdev, "xfsprogs") + FAT -> ("mkfs.fat", optsdev, "dosfstools") + VFAT -> ("mkfs.vfat", optsdev, "dosfstools") + NTFS -> ("mkfs.ntfs", optsdev, "ntfs-3g") + LinuxSwap -> ("mkswap", optsdev, "util-linux") + optsdev = opts++[dev] + +-- | Uses the kpartx utility to create device maps for partitions contained +-- within a disk image file. The resulting devices are passed to the +-- property, which can operate on them. Always cleans up after itself, +-- by removing the device maps after the property is run. +kpartx :: FilePath -> ([FilePath] -> Property NoInfo) -> Property NoInfo +kpartx diskimage mkprop = go `requires` Apt.installed ["kpartx"] + where + go = property (propertyDesc (mkprop [])) $ do + s <- liftIO $ readProcess "kpartx" ["-avs", diskimage] + r <- ensureProperty (mkprop (devlist s)) + void $ liftIO $ boolSystem "kpartx" [Param "-d", File diskimage] + return r + devlist = mapMaybe (finddev . words) . lines + finddev ("add":"map":s:_) = Just ("/dev/mapper/" ++ s) + finddev _ = Nothing -- cgit v1.2.3 From 516986cebd0030f0d599bec3b1a952344d9d9e9f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 25 Aug 2015 20:29:30 -0700 Subject: propellor spin --- config-joey.hs | 5 ++++- src/Propellor/Property/Mount.hs | 3 ++- src/Propellor/Property/Parted.hs | 3 ++- 3 files changed, 8 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/config-joey.hs b/config-joey.hs index acb20112..979e023b 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -34,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 main :: IO () -- _ ______`| ,-.__ main = defaultMain hosts -- / \___-=O`/|O`/__| (____.' @@ -80,6 +80,9 @@ darkstar = host "darkstar.kitenet.net" & JoeySites.postfixClientRelay (Context "darkstar.kitenet.net") & JoeySites.dkimMilter + & partitioned YesReallyDeleteDiskContents "/home/joey/disk" + (PartTable MSDOS [ mkPartition EXT3 268435456 ]) + gnu :: Host gnu = host "gnu.kitenet.net" & Apt.buildDep ["git-annex"] `period` Daily diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs index ff47f4d9..43ca0cc6 100644 --- a/src/Propellor/Property/Mount.hs +++ b/src/Propellor/Property/Mount.hs @@ -3,7 +3,8 @@ module Propellor.Property.Mount where import Propellor import Utility.Path -type FsType = String +type FsType = String -- ^ type of filesystem to mount ("auto" to autodetect) + type Source = String -- | Lists all mount points of the system. diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs index 2b741234..6d125b85 100644 --- a/src/Propellor/Property/Parted.hs +++ b/src/Propellor/Property/Parted.hs @@ -6,6 +6,7 @@ module Propellor.Property.Parted ( Partition(..), mkPartition, Partition.Fs(..), + ByteSize, Partition.MkfsOpts, PartType(..), PartFlag(..), @@ -110,7 +111,7 @@ data Eep = YesReallyDeleteDiskContents -- | Partitions a disk using parted, and formats the partitions. -- --- The FilePath can be a block device (eg, /dev/sda), or a disk image file. +-- The FilePath can be a block device (eg, \/dev\/sda), or a disk image file. -- -- This deletes any existing partitions in the disk! Use with EXTREME caution! partitioned :: Eep -> FilePath -> PartTable -> Property NoInfo -- cgit v1.2.3 From 77a5e58c4b04104be2883251e84bddf27362cfd4 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 25 Aug 2015 20:34:26 -0700 Subject: propellor spin --- config-joey.hs | 2 +- src/Propellor/Property/Parted.hs | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) (limited to 'src') diff --git a/config-joey.hs b/config-joey.hs index 979e023b..8682364a 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -81,7 +81,7 @@ darkstar = host "darkstar.kitenet.net" & JoeySites.dkimMilter & partitioned YesReallyDeleteDiskContents "/home/joey/disk" - (PartTable MSDOS [ mkPartition EXT3 268435456 ]) + (PartTable MSDOS [ mkPartition EXT3 268435456, mkPartition LinuxSwap 168435456 ]) gnu :: Host gnu = host "gnu.kitenet.net" diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs index 6d125b85..0b053422 100644 --- a/src/Propellor/Property/Parted.hs +++ b/src/Propellor/Property/Parted.hs @@ -138,7 +138,6 @@ partitioned eep disk (PartTable tabletype parts) = property desc $ do setunits = ["unit", "B"] -- tell parted we use bytes mkpart partnum offset p = [ "mkpart" - , show partnum , val (partType p) , val (partFs p) , show offset -- cgit v1.2.3 From 753963389c11cdf763f077eba9fed67413afb6c5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 25 Aug 2015 20:52:46 -0700 Subject: struggling with alignment --- src/Propellor/Property/Parted.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs index 0b053422..09753cd1 100644 --- a/src/Propellor/Property/Parted.hs +++ b/src/Propellor/Property/Parted.hs @@ -124,8 +124,7 @@ partitioned eep disk (PartTable tabletype parts) = property desc $ do desc = disk ++ " partitioned" go devs = combineProperties desc $ parted eep disk partedparams : map format (zip parts devs) - partedparams = concat $ - setunits : mklabel : mkparts (1 :: Integer) 0 parts [] + partedparams = concat $ mklabel : mkparts (1 :: Integer) 0 parts [] format (p, dev) = Partition.formatted' (partMkFsOpts p) Partition.YesReallyFormatPartition (partFs p) dev mklabel = ["mklabel", val tabletype] @@ -135,12 +134,14 @@ partitioned eep disk (PartTable tabletype parts) = property desc $ do , val f , val b ] - setunits = ["unit", "B"] -- tell parted we use bytes mkpart partnum offset p = [ "mkpart" , val (partType p) , val (partFs p) - , show offset + -- Using 0 rather than 0B is undocumented magic; + -- it makes parted automatically adjust the first partition + -- start to be beyond the start of the partition table. + , if offset == 0 then "0" else show offset ++ "B" , show (offset + partSize p) ] ++ case partName p of Just n -> ["name", show partnum, n] @@ -153,10 +154,10 @@ partitioned eep disk (PartTable tabletype parts) = property desc $ do -- | Runs parted on a disk with the specified parameters. -- -- Parted is run in script mode, so it will never prompt for input. --- It is asked to use optimal alignment for the disk, for best performance. +-- It is asked to use cylinder alignment for the disk. parted :: Eep -> FilePath -> [String] -> Property NoInfo parted YesReallyDeleteDiskContents disk ps = - cmdProperty "parted" ("--script":"--align":"optimal":disk:ps) + cmdProperty "parted" ("--script":"--align":"cylinder":disk:ps) `requires` installed -- | Gets parted installed. -- cgit v1.2.3 From 5b9303f50a9283aaeb85b7665392822e53f73423 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 25 Aug 2015 20:54:38 -0700 Subject: propellor spin --- src/Propellor/Property/Parted.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs index 09753cd1..8c71de5b 100644 --- a/src/Propellor/Property/Parted.hs +++ b/src/Propellor/Property/Parted.hs @@ -142,7 +142,7 @@ partitioned eep disk (PartTable tabletype parts) = property desc $ do -- it makes parted automatically adjust the first partition -- start to be beyond the start of the partition table. , if offset == 0 then "0" else show offset ++ "B" - , show (offset + partSize p) + , show (offset + partSize p) ++ "B" ] ++ case partName p of Just n -> ["name", show partnum, n] Nothing -> [] -- cgit v1.2.3 From d48e5ca96e371946befd234f384eeb673099d3b2 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 25 Aug 2015 21:44:59 -0700 Subject: propellor spin --- config-joey.hs | 2 +- src/Propellor/Property/Parted.hs | 34 +++++++++++++++++++++++++--------- 2 files changed, 26 insertions(+), 10 deletions(-) (limited to 'src') diff --git a/config-joey.hs b/config-joey.hs index 0873ddc9..71b1a4ae 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -81,7 +81,7 @@ darkstar = host "darkstar.kitenet.net" & JoeySites.dkimMilter & partitioned YesReallyDeleteDiskContents "/home/joey/disk" - (PartTable MSDOS [ mkPartition EXT3 268435456, mkPartition LinuxSwap 10240 ]) + (PartTable MSDOS [ mkPartition EXT3 (MegaBytes 256), mkPartition LinuxSwap (MegaBytes 16)]) gnu :: Host gnu = host "gnu.kitenet.net" diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs index 8c71de5b..f463164e 100644 --- a/src/Propellor/Property/Parted.hs +++ b/src/Propellor/Property/Parted.hs @@ -6,7 +6,9 @@ module Propellor.Property.Parted ( Partition(..), mkPartition, Partition.Fs(..), + MegaBytes(..), ByteSize, + toMegaBytes, Partition.MkfsOpts, PartType(..), PartFlag(..), @@ -46,7 +48,7 @@ instance Monoid PartTable where -- | A partition on the disk. data Partition = Partition { partType :: PartType - , partSize :: ByteSize -- ^ size of the partition in bytes + , partSize :: MegaBytes , partFs :: Partition.Fs , partMkFsOpts :: Partition.MkfsOpts , partFlags :: [(PartFlag, Bool)] -- ^ flags can be set or unset (parted may set some flags by default) @@ -55,7 +57,7 @@ data Partition = Partition deriving (Show) -- | Makes a Partition with defaults for non-important values. -mkPartition :: Partition.Fs -> ByteSize -> Partition +mkPartition :: Partition.Fs -> MegaBytes -> Partition mkPartition fs sz = Partition { partType = Primary , partSize = sz @@ -74,6 +76,23 @@ instance PartedVal PartType where val Logical = "logical" val Extended = "extended" +-- | All partition sizing is done in megabytes, so that parted can +-- automatically lay out the partitions. +-- +-- Note that these are SI megabytes, not mebibytes. +newtype MegaBytes = MegaBytes Integer + deriving (Show) + +instance PartedVal MegaBytes where + val (MegaBytes n) = show n ++ "MB" + +toMegaBytes :: ByteSize -> MegaBytes +toMegaBytes b = MegaBytes (b `div` 1000000) + +instance Monoid MegaBytes where + mempty = MegaBytes 0 + mappend (MegaBytes a) (MegaBytes b) = MegaBytes (a + b) + -- | Flags that can be set on a partition. data PartFlag = BootFlag | RootFlag | SwapFlag | HiddenFlag | RaidFlag | LvmFlag | LbaFlag | LegacyBootFlag | IrstFlag | EspFlag | PaloFlag deriving (Show) @@ -124,7 +143,7 @@ partitioned eep disk (PartTable tabletype parts) = property desc $ do desc = disk ++ " partitioned" go devs = combineProperties desc $ parted eep disk partedparams : map format (zip parts devs) - partedparams = concat $ mklabel : mkparts (1 :: Integer) 0 parts [] + partedparams = concat $ mklabel : mkparts (1 :: Integer) mempty parts [] format (p, dev) = Partition.formatted' (partMkFsOpts p) Partition.YesReallyFormatPartition (partFs p) dev mklabel = ["mklabel", val tabletype] @@ -138,16 +157,13 @@ partitioned eep disk (PartTable tabletype parts) = property desc $ do [ "mkpart" , val (partType p) , val (partFs p) - -- Using 0 rather than 0B is undocumented magic; - -- it makes parted automatically adjust the first partition - -- start to be beyond the start of the partition table. - , if offset == 0 then "0" else show offset ++ "B" - , show (offset + partSize p) ++ "B" + , val offset + , val (offset <> partSize p) ] ++ case partName p of Just n -> ["name", show partnum, n] Nothing -> [] mkparts partnum offset (p:ps) c = - mkparts (partnum+1) (offset + partSize p) ps + mkparts (partnum+1) (offset <> partSize p) ps (c ++ mkpart partnum offset p : map (mkflag partnum) (partFlags p)) mkparts _ _ [] c = c -- cgit v1.2.3 From 474119770bd54a905fcdda25a7bb12f2b1ea1307 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 25 Aug 2015 21:48:31 -0700 Subject: idempotency fix for kpartx noticed kpartx could get confused if a disk image it had mapped was deleted and a fresh one mapped --- src/Propellor/Property/Parted.hs | 2 +- src/Propellor/Property/Partition.hs | 4 +++- 2 files changed, 4 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs index f463164e..aa7bece4 100644 --- a/src/Propellor/Property/Parted.hs +++ b/src/Propellor/Property/Parted.hs @@ -77,7 +77,7 @@ instance PartedVal PartType where val Extended = "extended" -- | All partition sizing is done in megabytes, so that parted can --- automatically lay out the partitions. +-- automatically lay out the partitions. -- -- Note that these are SI megabytes, not mebibytes. newtype MegaBytes = MegaBytes Integer diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs index 53d8a946..41bdf795 100644 --- a/src/Propellor/Property/Partition.hs +++ b/src/Propellor/Property/Partition.hs @@ -45,10 +45,12 @@ kpartx :: FilePath -> ([FilePath] -> Property NoInfo) -> Property NoInfo kpartx diskimage mkprop = go `requires` Apt.installed ["kpartx"] where go = property (propertyDesc (mkprop [])) $ do + cleanup -- idempotency s <- liftIO $ readProcess "kpartx" ["-avs", diskimage] r <- ensureProperty (mkprop (devlist s)) - void $ liftIO $ boolSystem "kpartx" [Param "-d", File diskimage] + cleanup return r devlist = mapMaybe (finddev . words) . lines finddev ("add":"map":s:_) = Just ("/dev/mapper/" ++ s) finddev _ = Nothing + cleanup = void $ liftIO $ boolSystem "kpartx" [Param "-d", File diskimage] -- cgit v1.2.3 From 89dec139eef3d409c06877d5e8fd1dc1085465d1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 26 Aug 2015 11:21:29 -0700 Subject: wip --- src/Propellor/Property/DiskImage.hs | 31 ++++++++++++++++++++----------- 1 file changed, 20 insertions(+), 11 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index de8bdd56..cb373c94 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -2,6 +2,7 @@ module Propellor.Property.DiskImage ( built, + rebuilt, DiskImageConfig(..), DiskImageFinalization, grubBooted, @@ -9,32 +10,40 @@ module Propellor.Property.DiskImage ( import Propellor import Propellor.Property.Chroot -import Utility.DataUnits +import Propellor.Property.Parted -- | Creates a bootable disk image. -- --- First the specified Chroot is set up, then a disk image is created, --- large enough to fit the chroot, which is copied into it. Finally, the --- DiskImageFinalization property is satisfied to make the disk image --- bootable. +-- First the specified Chroot is set up, and its properties are satisfied. +-- Then a disk image is created, large enough to fit the chroot, which +-- is copied into it. Finally, the DiskImageFinalization property is +-- satisfied to make the disk image bootable. -- --- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") Debootstrap.DefaultConfig d +-- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d -- > & Apt.installed ["openssh-server"] -- > & Grub.installed Grub.PC -- > & ... -- > in DiskImage.built mempty chroot DiskImage.grubBooted built :: DiskImageConfig -> (FilePath -> Chroot) -> DiskImageFinalization -> RevertableProperty -built c = undefined +built = built' 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 :: DiskImageConfig -> (FilePath -> Chroot) -> DiskImageFinalization -> RevertableProperty +rebuilt = built' True + +built' :: Bool -> DiskImageConfig -> (FilePath -> Chroot) -> DiskImageFinalization -> RevertableProperty +built' rebuild c mkchroot final = undefined data DiskImageConfig = DiskImageConfig - { freeSpace :: ByteSize -- ^ A disk image is sized to fit the system installed in it. This adds some extra free space. + { freeSpace :: MegaBytes -- ^ A disk image is sized to fit the system installed in it. This adds some extra free space. (mempty default: 256 Megabytes) } instance Monoid DiskImageConfig where - -- | Default value is 256 mb freeSpace. - mempty = DiskImageConfig (1024 * 1024 * 256) + mempty = DiskImageConfig (MegaBytes 256) mappend a b = a - { freeSpace = freeSpace a + freeSpace b + { freeSpace = freeSpace a <> freeSpace b } -- | This is a property that is run, chrooted into the disk image. It's -- cgit v1.2.3