From c95f05ef8874b21c9a4f9756b8af79e178d80232 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 26 Aug 2015 14:41:28 -0700 Subject: improve config types (cherry picked from commit 836133fd405212c31ac7e661cd3bbb6ed305cbc4) --- src/Propellor/Property/DiskImage.hs | 91 ++++++++++++++++++++++++++----------- 1 file changed, 64 insertions(+), 27 deletions(-) diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index cb373c94..a3d4073a 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -3,56 +3,93 @@ module Propellor.Property.DiskImage ( built, rebuilt, - DiskImageConfig(..), + MountPoint, + MkPartTable, + fitChrootSize, + freeSpace, DiskImageFinalization, grubBooted, + Grub.BIOS(..), ) where import Propellor import Propellor.Property.Chroot import Propellor.Property.Parted +import qualified Propellor.Property.Grub as Grub -- | Creates a bootable disk image. -- -- 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 +-- +-- Then, the disk image is set up, and the chroot is copied into the +-- appropriate partition(s) of it. +-- +-- Finally, the DiskImageFinalization property is -- satisfied to make the disk image bootable. -- -- > 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 +-- > & Apt.installed ["openssh-server"] +-- > & ... +-- > partitions = fitChrootSize MSDOS +-- > [ (Just "/boot", mkPartiton EXT2) +-- > , (Just "/", mkPartition EXT4) +-- > , (Nothing, const (mkPartition LinuxSwap (MegaBytes 256))) +-- > ] +-- > in built chroot partitions (grubBooted PC) +built :: (FilePath -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty 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 :: (FilePath -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty rebuilt = built' True -built' :: Bool -> DiskImageConfig -> (FilePath -> Chroot) -> DiskImageFinalization -> RevertableProperty -built' rebuild c mkchroot final = undefined +built' :: Bool -> (FilePath -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty +built' rebuild mkparttable mkchroot final = undefined + +-- | Where a partition is mounted. Use Nothing for eg, LinuxSwap. +type MountPoint = Maybe FilePath + +-- | 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 mounted (ie, LinuxSwap) will have 128 MegaBytes +-- provides as a default size.) +type MkPartTable = [MegaBytes] -> ([MountPoint], PartTable) + +-- TODO tie the knot +-- let f = fitChrootSize MSDOS [(Just "/", mkPartition EXT2)] +-- let (mnts, t) = f (map (MegaBytes . fromIntegral . length . show) mnts) -data DiskImageConfig = DiskImageConfig - { freeSpace :: MegaBytes -- ^ A disk image is sized to fit the system installed in it. This adds some extra free space. (mempty default: 256 Megabytes) - } +-- | The constructor for each Partition is passed the size of the files +-- from the chroot that will be put in that partition. +-- +-- Partitions that are not mounted (ie, LinuxSwap) will have their size +-- set to 128 MegaBytes, unless it's overridden. +fitChrootSize :: TableType -> [(MountPoint, MegaBytes -> Partition)] -> MkPartTable +fitChrootSize tt l basesizes = (mounts, parttable) + where + (mounts, sizers) = unzip l + parttable = PartTable tt (map (uncurry id) (zip sizers basesizes)) -instance Monoid DiskImageConfig where - mempty = DiskImageConfig (MegaBytes 256) - mappend a b = a - { freeSpace = freeSpace a <> freeSpace b - } +-- | 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)] -> MkPartTable +freeSpace tt = fitChrootSize tt . map (\(mnt, p) -> (mnt, adjustsz p)) + where + adjustsz p basesize = p { partSize = partSize p <> basesize } --- | 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 +-- | 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 +-- disk image, and will typically take care of installing the boot loader +-- to the disk image. +type DiskImageFinalization = (Property NoInfo, 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 +grubBooted :: Grub.BIOS -> DiskImageFinalization +grubBooted bios = (Grub.installed bios, undefined) -- cgit v1.3-2-g0d8e From 94d6f453e7441749a83f0ea69d0e7c12737565a1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 26 Aug 2015 17:29:01 -0700 Subject: propellor spin (cherry picked from commit 7087a94b21a086a98784d17b45dd2b7779e320e9) --- src/Propellor/Property/DiskImage.hs | 6 +++--- src/Propellor/Property/Parted.hs | 18 +++++++++--------- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index a3d4073a..691f79bc 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -57,8 +57,8 @@ type MountPoint = Maybe FilePath -- exploiting laziness and tying the knot. -- -- (Partitions that are not mounted (ie, LinuxSwap) will have 128 MegaBytes --- provides as a default size.) -type MkPartTable = [MegaBytes] -> ([MountPoint], PartTable) +-- provided as a default size.) +type MkPartTable = [PartSize] -> ([MountPoint], PartTable) -- TODO tie the knot -- let f = fitChrootSize MSDOS [(Just "/", mkPartition EXT2)] @@ -69,7 +69,7 @@ type MkPartTable = [MegaBytes] -> ([MountPoint], PartTable) -- -- Partitions that are not mounted (ie, LinuxSwap) will have their size -- set to 128 MegaBytes, unless it's overridden. -fitChrootSize :: TableType -> [(MountPoint, MegaBytes -> Partition)] -> MkPartTable +fitChrootSize :: TableType -> [(MountPoint, PartSize -> Partition)] -> MkPartTable fitChrootSize tt l basesizes = (mounts, parttable) where (mounts, sizers) = unzip l diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs index aa7bece4..29d94b4c 100644 --- a/src/Propellor/Property/Parted.hs +++ b/src/Propellor/Property/Parted.hs @@ -6,9 +6,9 @@ module Propellor.Property.Parted ( Partition(..), mkPartition, Partition.Fs(..), - MegaBytes(..), + PartSize(..), ByteSize, - toMegaBytes, + toPartSize, Partition.MkfsOpts, PartType(..), PartFlag(..), @@ -48,7 +48,7 @@ instance Monoid PartTable where -- | A partition on the disk. data Partition = Partition { partType :: PartType - , partSize :: MegaBytes + , partSize :: PartSize , partFs :: Partition.Fs , partMkFsOpts :: Partition.MkfsOpts , partFlags :: [(PartFlag, Bool)] -- ^ flags can be set or unset (parted may set some flags by default) @@ -57,7 +57,7 @@ data Partition = Partition deriving (Show) -- | Makes a Partition with defaults for non-important values. -mkPartition :: Partition.Fs -> MegaBytes -> Partition +mkPartition :: Partition.Fs -> PartSize -> Partition mkPartition fs sz = Partition { partType = Primary , partSize = sz @@ -80,16 +80,16 @@ instance PartedVal PartType where -- automatically lay out the partitions. -- -- Note that these are SI megabytes, not mebibytes. -newtype MegaBytes = MegaBytes Integer +newtype PartSize = MegaBytes Integer deriving (Show) -instance PartedVal MegaBytes where +instance PartedVal PartSize where val (MegaBytes n) = show n ++ "MB" -toMegaBytes :: ByteSize -> MegaBytes -toMegaBytes b = MegaBytes (b `div` 1000000) +toPartSize :: ByteSize -> PartSize +toPartSize b = MegaBytes (b `div` 1000000) -instance Monoid MegaBytes where +instance Monoid PartSize where mempty = MegaBytes 0 mappend (MegaBytes a) (MegaBytes b) = MegaBytes (a + b) -- cgit v1.3-2-g0d8e From 60950b159a2b800938929f8ae12823d5ec674667 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 27 Aug 2015 12:21:55 -0700 Subject: implement dirsizes Used Data.Map.Strict, so bumped versions. Don't want to support the ghc in debian oldstable.. (cherry picked from commit e413bed2c1cb15dcb8ce721a2801021e39f3ba86) --- debian/changelog | 1 + debian/control | 2 +- propellor.cabal | 6 +++--- src/Propellor/Property/DiskImage.hs | 31 +++++++++++++++++++++++++++---- 4 files changed, 32 insertions(+), 8 deletions(-) diff --git a/debian/changelog b/debian/changelog index d56ac606..2431969e 100644 --- a/debian/changelog +++ b/debian/changelog @@ -5,6 +5,7 @@ propellor (2.7.3) UNRELEASED; urgency=medium * Added Propellor.Property.DiskImage, for bootable disk image creation. (Not yet complete.) * Update for Debian systemd-container package split. + * Dropped support for ghc 7.4. -- Joey Hess Tue, 25 Aug 2015 13:45:39 -0700 diff --git a/debian/control b/debian/control index 25c3d474..05101be0 100644 --- a/debian/control +++ b/debian/control @@ -4,7 +4,7 @@ Priority: optional Build-Depends: debhelper (>= 9), git, - ghc (>= 7.4), + ghc (>= 7.6), cabal-install, libghc-async-dev, libghc-missingh-dev, diff --git a/propellor.cabal b/propellor.cabal index 329739be..e455d1a7 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -38,7 +38,7 @@ Executable propellor Hs-Source-Dirs: src Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, - containers, network, async, time, QuickCheck, mtl, transformers, + containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers, exceptions (>= 0.6) if (! os(windows)) @@ -50,7 +50,7 @@ Executable propellor-config Hs-Source-Dirs: src Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, - containers, network, async, time, QuickCheck, mtl, transformers, + containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers, exceptions if (! os(windows)) @@ -61,7 +61,7 @@ Library Hs-Source-Dirs: src Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, - containers, network, async, time, QuickCheck, mtl, transformers, + containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers, exceptions if (! os(windows)) diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 691f79bc..5bdd8f1a 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -17,6 +17,9 @@ import Propellor.Property.Chroot import Propellor.Property.Parted import qualified Propellor.Property.Grub as Grub +import qualified Data.Map.Strict as M +import System.Posix.Files + -- | Creates a bootable disk image. -- -- First the specified Chroot is set up, and its properties are satisfied. @@ -48,6 +51,30 @@ rebuilt = built' True built' :: Bool -> (FilePath -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty built' rebuild mkparttable mkchroot final = undefined +-- TODO tie the knot +-- let f = fitChrootSize MSDOS [(Just "/", mkPartition EXT2)] +-- let (mnts, t) = f (map (MegaBytes . fromIntegral . length . show) mnts) + +-- | Generates a map of the sizes of the contents of +-- every directory in a filesystem tree. +-- +-- Should be same values as du -b +dirSizes :: FilePath -> IO (M.Map FilePath Integer) +dirSizes top = go M.empty top [top] + where + go m _ [] = return m + go m dir (i:is) = do + s <- getSymbolicLinkStatus i + let sz = fromIntegral (fileSize s) + if isDirectory s + then do + subm <- go M.empty i =<< dirContents i + let sz' = M.foldr' (+) sz + (M.filterWithKey (const . subdirof i) subm) + go (M.insertWith (+) i sz' (M.union m subm)) dir is + else go (M.insertWith (+) dir sz m) dir is + subdirof parent i = not (i `equalFilePath` parent) && takeDirectory i `equalFilePath` parent + -- | Where a partition is mounted. Use Nothing for eg, LinuxSwap. type MountPoint = Maybe FilePath @@ -60,10 +87,6 @@ type MountPoint = Maybe FilePath -- provided as a default size.) type MkPartTable = [PartSize] -> ([MountPoint], PartTable) --- TODO tie the knot --- let f = fitChrootSize MSDOS [(Just "/", mkPartition EXT2)] --- let (mnts, t) = f (map (MegaBytes . fromIntegral . length . show) mnts) - -- | 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