From e85a15d160005929a9d5ea5cb21c25751856c5ae Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 1 Sep 2015 11:09:50 -0700 Subject: keystone for disk image creation Untested, and grub booting not done. --- src/Propellor/Property/DiskImage.hs | 65 +++++++++++++++++++++++++++++-------- src/Propellor/Property/Parted.hs | 11 +++++++ 2 files changed, 63 insertions(+), 13 deletions(-) diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 5bdd8f1a..f649b7bb 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -3,6 +3,7 @@ module Propellor.Property.DiskImage ( built, rebuilt, + exists, MountPoint, MkPartTable, fitChrootSize, @@ -13,14 +14,17 @@ module Propellor.Property.DiskImage ( ) where import Propellor -import Propellor.Property.Chroot +import Propellor.Property.Chroot (Chroot) +import qualified Propellor.Property.Chroot as Chroot import Propellor.Property.Parted import qualified Propellor.Property.Grub as Grub +import qualified Propellor.Property.File as File import qualified Data.Map.Strict as M +import qualified Data.ByteString.Lazy as L import System.Posix.Files --- | Creates a bootable disk image. +-- | Creates a bootable disk image in the specified file. -- -- First the specified Chroot is set up, and its properties are satisfied. -- @@ -39,21 +43,51 @@ import System.Posix.Files -- > , (Nothing, const (mkPartition LinuxSwap (MegaBytes 256))) -- > ] -- > in built chroot partitions (grubBooted PC) -built :: (FilePath -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty +built :: FilePath -> (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 :: (FilePath -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty +rebuilt :: FilePath -> (FilePath -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty rebuilt = built' True -built' :: Bool -> (FilePath -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty -built' rebuild mkparttable mkchroot final = undefined +built' :: Bool -> FilePath -> (FilePath -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty +built' rebuild img mkchroot mkparttable final = + (mkimg unmkimg) + `requires` Chroot.provisioned (mkchroot chrootdir) + `describe` desc + where + desc = "built disk image " ++ img + unmkimg = File.notPresent img + chrootdir = img ++ ".chroot" + mkimg = property desc $ do + szm <- liftIO $ M.map toPartSize <$> dirSizes chrootdir + -- tie the knot! + let (mnts, t) = mkparttable (map (getMountSz szm) mnts) + let disksz = partTableSize t + ensureProperty $ + exists img disksz + `before` + partitioned YesReallyDeleteDiskContents img t --- TODO tie the knot --- let f = fitChrootSize MSDOS [(Just "/", mkPartition EXT2)] --- let (mnts, t) = f (map (MegaBytes . fromIntegral . length . show) mnts) +-- | Ensures that a disk image file of the specified size exists. +-- +-- 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 + ms <- catchMaybeIO $ getFileStatus img + case ms of + Just s + | toInteger (fileSize s) == toInteger sz -> return NoChange + | toInteger (fileSize s) > toInteger sz -> do + setFileSize img (fromInteger sz) + return MadeChange + _ -> do + L.writeFile img (L.replicate (fromIntegral sz) 0) + return MadeChange -- | Generates a map of the sizes of the contents of -- every directory in a filesystem tree. @@ -78,20 +112,25 @@ dirSizes top = go M.empty top [top] -- | Where a partition is mounted. Use Nothing for eg, LinuxSwap. type MountPoint = Maybe FilePath +getMountSz :: (M.Map FilePath PartSize) -> MountPoint -> PartSize +getMountSz _ Nothing = defSz +getMountSz szm (Just mntpt) = M.findWithDefault defSz mntpt szm + +defSz :: PartSize +defSz = MegaBytes 128 + -- | 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 +-- (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 MkPartTable = [PartSize] -> ([MountPoint], PartTable) -- | 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, PartSize -> Partition)] -> MkPartTable fitChrootSize tt l basesizes = (mounts, parttable) where diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs index 29d94b4c..4e2efe24 100644 --- a/src/Propellor/Property/Parted.hs +++ b/src/Propellor/Property/Parted.hs @@ -3,12 +3,14 @@ module Propellor.Property.Parted ( TableType(..), PartTable(..), + partTableSize, Partition(..), mkPartition, Partition.Fs(..), PartSize(..), ByteSize, toPartSize, + fromPartSize, Partition.MkfsOpts, PartType(..), PartFlag(..), @@ -45,6 +47,12 @@ instance Monoid PartTable where -- | uses the TableType of the second parameter mappend (PartTable _l1 ps1) (PartTable l2 ps2) = PartTable l2 (ps1 ++ ps2) +-- | Gets the total size of the disk specified by the partition table. +partTableSize :: PartTable -> ByteSize +partTableSize (PartTable _ ps) = fromPartSize $ + -- add 1 megabyte to hold the partition table itself + mconcat (MegaBytes 1 : map partSize ps) + -- | A partition on the disk. data Partition = Partition { partType :: PartType @@ -89,6 +97,9 @@ instance PartedVal PartSize where toPartSize :: ByteSize -> PartSize toPartSize b = MegaBytes (b `div` 1000000) +fromPartSize :: PartSize -> ByteSize +fromPartSize (MegaBytes b) = b * 1000000 + instance Monoid PartSize where mempty = MegaBytes 0 mappend (MegaBytes a) (MegaBytes b) = MegaBytes (a + b) -- cgit v1.2.3 From 804622719b8a348bfdd32f427502e0529d50a8ed Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 1 Sep 2015 11:24:02 -0700 Subject: removal of chroot on disk image rebuild --- src/Propellor/Property/Chroot/Util.hs | 12 ++++++++++++ src/Propellor/Property/Debootstrap.hs | 11 ++--------- src/Propellor/Property/DiskImage.hs | 7 +++++++ 3 files changed, 21 insertions(+), 9 deletions(-) diff --git a/src/Propellor/Property/Chroot/Util.hs b/src/Propellor/Property/Chroot/Util.hs index 382fbab7..73cf094a 100644 --- a/src/Propellor/Property/Chroot/Util.hs +++ b/src/Propellor/Property/Chroot/Util.hs @@ -1,7 +1,11 @@ module Propellor.Property.Chroot.Util where +import Propellor.Property.Mount + import Utility.Env import Control.Applicative +import Control.Monad +import System.Directory -- When chrooting, it's useful to ensure that PATH has all the standard -- directories in it. This adds those directories to whatever PATH is @@ -14,3 +18,11 @@ standardPathEnv = do stdPATH :: String stdPATH = "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin" + +-- Removes the contents of a chroot. First, unmounts any filesystems +-- mounted within it. +removeChroot :: FilePath -> IO () +removeChroot c = do + submnts <- mountPointsBelow c + forM_ submnts umountLazy + removeDirectoryRecursive c diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index 8d974eba..a46451ef 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -13,7 +13,6 @@ module Propellor.Property.Debootstrap ( import Propellor import qualified Propellor.Property.Apt as Apt import Propellor.Property.Chroot.Util -import Propellor.Property.Mount import Utility.Path import Utility.FileMode @@ -61,7 +60,7 @@ built target system config = built' (toProp installed) target system config teardown = check (not <$> unpopulated target) teardownprop teardownprop = property ("removed debootstrapped " ++ target) $ - makeChange (removetarget target) + makeChange (removeChroot target) built' :: (Combines (Property NoInfo) (Property i)) => Property i -> FilePath -> System -> DebootstrapConfig -> Property (CInfo NoInfo i) built' installprop target system@(System _ arch) config = @@ -96,7 +95,7 @@ built' installprop target system@(System _ arch) config = -- recover by deleting it and trying again. ispartial = ifM (doesDirectoryExist (target "debootstrap")) ( do - removetarget target + removeChroot target return True , return False ) @@ -104,12 +103,6 @@ built' installprop target system@(System _ arch) config = unpopulated :: FilePath -> IO Bool unpopulated d = null <$> catchDefaultIO [] (dirContents d) -removetarget :: FilePath -> IO () -removetarget target = do - submnts <- mountPointsBelow target - forM_ submnts umountLazy - removeDirectoryRecursive target - extractSuite :: System -> Maybe String extractSuite (System (Debian s) _) = Just $ Apt.showSuite s extractSuite (System (Ubuntu r) _) = Just r diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index f649b7bb..54fa8945 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -15,6 +15,7 @@ module Propellor.Property.DiskImage ( import Propellor import Propellor.Property.Chroot (Chroot) +import Propellor.Property.Chroot.Util (removeChroot) import qualified Propellor.Property.Chroot as Chroot import Propellor.Property.Parted import qualified Propellor.Property.Grub as Grub @@ -56,6 +57,7 @@ built' :: Bool -> FilePath -> (FilePath -> Chroot) -> MkPartTable -> DiskImageFi built' rebuild img mkchroot mkparttable final = (mkimg unmkimg) `requires` Chroot.provisioned (mkchroot chrootdir) + `requires` (handlerebuild doNothing) `describe` desc where desc = "built disk image " ++ img @@ -70,6 +72,11 @@ built' rebuild img mkchroot mkparttable final = exists img disksz `before` partitioned YesReallyDeleteDiskContents img t + handlerebuild + | rebuild = property desc $ do + liftIO $ removeChroot chrootdir + return MadeChange + | otherwise = doNothing -- | Ensures that a disk image file of the specified size exists. -- -- cgit v1.2.3 From cafd349d60b902705ebe12e8f8bc31c285e32ffe Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 1 Sep 2015 11:48:48 -0700 Subject: cleanup --- src/Propellor/Property/DiskImage.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 54fa8945..76adac09 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -67,9 +67,8 @@ built' rebuild img mkchroot mkparttable final = szm <- liftIO $ M.map toPartSize <$> dirSizes chrootdir -- tie the knot! let (mnts, t) = mkparttable (map (getMountSz szm) mnts) - let disksz = partTableSize t ensureProperty $ - exists img disksz + exists img (partTableSize t) `before` partitioned YesReallyDeleteDiskContents img t handlerebuild -- cgit v1.2.3 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 ++++++++-- src/Propellor/Property/DiskImage.hs | 44 ++++++++++++++++++++++++------------- 2 files changed, 39 insertions(+), 17 deletions(-) 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" diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 76adac09..45f5ca40 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -5,10 +5,13 @@ module Propellor.Property.DiskImage ( rebuilt, exists, MountPoint, + PartSpec, + mountedPartition, + swapPartition, MkPartTable, fitChrootSize, freeSpace, - DiskImageFinalization, + Finalization, grubBooted, Grub.BIOS(..), ) where @@ -32,30 +35,30 @@ import System.Posix.Files -- 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"] -- > & ... --- > partitions = fitChrootSize MSDOS --- > [ (Just "/boot", mkPartiton EXT2) --- > , (Just "/", mkPartition EXT4) --- > , (Nothing, const (mkPartition LinuxSwap (MegaBytes 256))) +-- > partitions = DiskImage.fitChrootSize MSDOS +-- > [ EXT2 `DiskImage.mountedPartition` "/boot" +-- > , EXT4 `DiskImage.mountedPartition` "/" +-- > , DiskImage.swapPartition (MegaBytes 256) -- > ] --- > in built chroot partitions (grubBooted PC) -built :: FilePath -> (FilePath -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty +-- > in DiskImage.built "/srv/images/foo.img" chroot partitions (DiskImage.grubBooted DiskImage.PC) +built :: FilePath -> (FilePath -> Chroot) -> MkPartTable -> Finalization -> 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 :: FilePath -> (FilePath -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty +rebuilt :: FilePath -> (FilePath -> Chroot) -> MkPartTable -> Finalization -> RevertableProperty rebuilt = built' True -built' :: Bool -> FilePath -> (FilePath -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty +built' :: Bool -> FilePath -> (FilePath -> Chroot) -> MkPartTable -> Finalization -> RevertableProperty built' rebuild img mkchroot mkparttable final = (mkimg unmkimg) + -- TODO snd final + -- TODO copy in + -- TODO fst final `requires` Chroot.provisioned (mkchroot chrootdir) `requires` (handlerebuild doNothing) `describe` desc @@ -118,6 +121,17 @@ dirSizes top = go M.empty top [top] -- | Where a partition is mounted. Use Nothing for eg, LinuxSwap. type MountPoint = Maybe FilePath +-- | Specifies a mount point and a constructor for a Partition. +type PartSpec = (MountPoint, PartSize -> Partition) + +-- | Specifies a mounted partition using a given filesystem. +mountedPartition :: Fs -> FilePath -> PartSpec +mountedPartition fs mntpoint = (Just mntpoint, mkPartition fs) + +-- | Specifies a swap partition of a given size. +swapPartition :: PartSize -> PartSpec +swapPartition sz = (Nothing, const (mkPartition LinuxSwap sz)) + getMountSz :: (M.Map FilePath PartSize) -> MountPoint -> PartSize getMountSz _ Nothing = defSz getMountSz szm (Just mntpt) = M.findWithDefault defSz mntpt szm @@ -137,7 +151,7 @@ type MkPartTable = [PartSize] -> ([MountPoint], PartTable) -- | The constructor for each Partition is passed the size of the files -- from the chroot that will be put in that partition. -fitChrootSize :: TableType -> [(MountPoint, PartSize -> Partition)] -> MkPartTable +fitChrootSize :: TableType -> [PartSpec] -> MkPartTable fitChrootSize tt l basesizes = (mounts, parttable) where (mounts, sizers) = unzip l @@ -156,8 +170,8 @@ freeSpace tt = fitChrootSize tt . map (\(mnt, p) -> (mnt, adjustsz p)) -- 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) +type Finalization = (Property NoInfo, Property NoInfo) -- | Makes grub be the boot loader of the disk image. -grubBooted :: Grub.BIOS -> DiskImageFinalization +grubBooted :: Grub.BIOS -> Finalization grubBooted bios = (Grub.installed bios, undefined) -- cgit v1.2.3 From bce9d314a94a1378ee35a4575aa7ecadf5967e62 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 11:06:20 -0700 Subject: Fix bug that caused provisioning new chroots to fail. --- debian/changelog | 1 + src/Propellor/Property/DiskImage.hs | 9 ++++++++- src/Propellor/Shim.hs | 15 +++++++++------ 3 files changed, 18 insertions(+), 7 deletions(-) diff --git a/debian/changelog b/debian/changelog index 2431969e..61ed235b 100644 --- a/debian/changelog +++ b/debian/changelog @@ -6,6 +6,7 @@ propellor (2.7.3) UNRELEASED; urgency=medium (Not yet complete.) * Update for Debian systemd-container package split. * Dropped support for ghc 7.4. + * Fix bug that caused provisioning new chroots to fail. -- Joey Hess Tue, 25 Aug 2015 13:45:39 -0700 diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 45f5ca40..6f2af863 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -35,6 +35,11 @@ import System.Posix.Files -- Then, the disk image is set up, and the chroot is copied into the -- appropriate partition(s) of it. -- +-- Example use: +-- +-- > import qualified Propellor.Property.DiskImage as DiskImage +-- > import Propellor.Property.Parted +-- -- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d -- > & Apt.installed ["openssh-server"] -- > & ... @@ -59,6 +64,7 @@ built' rebuild img mkchroot mkparttable final = -- TODO snd final -- TODO copy in -- TODO fst final + -- TODO chroot topevel directory perm fixup `requires` Chroot.provisioned (mkchroot chrootdir) `requires` (handlerebuild doNothing) `describe` desc @@ -121,7 +127,8 @@ dirSizes top = go M.empty top [top] -- | Where a partition is mounted. Use Nothing for eg, LinuxSwap. type MountPoint = Maybe FilePath --- | Specifies a mount point and a constructor for a Partition. +-- | Specifies a mount point and a constructor for a Partition +-- that will later be privided with a size. type PartSpec = (MountPoint, PartSize -> Partition) -- | Specifies a mounted partition using a given filesystem. diff --git a/src/Propellor/Shim.hs b/src/Propellor/Shim.hs index 7cdecefd..a3c8e701 100644 --- a/src/Propellor/Shim.hs +++ b/src/Propellor/Shim.hs @@ -55,12 +55,15 @@ shebang :: String shebang = "#!/bin/sh" checkAlreadyShimmed :: FilePath -> IO FilePath -> IO FilePath -checkAlreadyShimmed f nope = withFile f ReadMode $ \h -> do - fileEncoding h - s <- hGetLine h - if s == shebang - then return f - else nope +checkAlreadyShimmed f nope = ifM (doesFileExist f) + ( withFile f ReadMode $ \h -> do + fileEncoding h + s <- hGetLine h + if s == shebang + then return f + else nope + , nope + ) -- Called when the shimmed propellor is running, so that commands it runs -- don't see it. -- cgit v1.2.3 From d2393d8141ac302eff5dc29d32d68014b630d166 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 11:13:36 -0700 Subject: propellor spin --- src/Propellor/Property/Chroot/Util.hs | 4 +--- src/Propellor/Property/DiskImage.hs | 8 ++++++-- src/Propellor/Property/Mount.hs | 6 ++++++ 3 files changed, 13 insertions(+), 5 deletions(-) diff --git a/src/Propellor/Property/Chroot/Util.hs b/src/Propellor/Property/Chroot/Util.hs index 73cf094a..ea0df780 100644 --- a/src/Propellor/Property/Chroot/Util.hs +++ b/src/Propellor/Property/Chroot/Util.hs @@ -4,7 +4,6 @@ import Propellor.Property.Mount import Utility.Env import Control.Applicative -import Control.Monad import System.Directory -- When chrooting, it's useful to ensure that PATH has all the standard @@ -23,6 +22,5 @@ stdPATH = "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin" -- mounted within it. removeChroot :: FilePath -> IO () removeChroot c = do - submnts <- mountPointsBelow c - forM_ submnts umountLazy + unmountBelow c removeDirectoryRecursive c diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 6f2af863..00bb465f 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -20,9 +20,10 @@ import Propellor import Propellor.Property.Chroot (Chroot) import Propellor.Property.Chroot.Util (removeChroot) import qualified Propellor.Property.Chroot as Chroot -import Propellor.Property.Parted import qualified Propellor.Property.Grub as Grub import qualified Propellor.Property.File as File +import Propellor.Property.Parted +import Propellor.Property.Mount import qualified Data.Map.Strict as M import qualified Data.ByteString.Lazy as L @@ -73,6 +74,9 @@ built' rebuild img mkchroot mkparttable final = unmkimg = File.notPresent img chrootdir = img ++ ".chroot" mkimg = property desc $ do + -- unmount helper filesystems such as proc from the chroot + -- before getting sizes + liftIO $ unmountBelow chrootdir szm <- liftIO $ M.map toPartSize <$> dirSizes chrootdir -- tie the knot! let (mnts, t) = mkparttable (map (getMountSz szm) mnts) @@ -112,7 +116,7 @@ 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 + go m dir (i:is) = flip catchIO (\_ioerr -> go m dir is) $ do s <- getSymbolicLinkStatus i let sz = fromIntegral (fileSize s) if isDirectory s diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs index 43ca0cc6..4070ebcb 100644 --- a/src/Propellor/Property/Mount.hs +++ b/src/Propellor/Property/Mount.hs @@ -29,6 +29,12 @@ umountLazy mnt = unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $ errorMessage $ "failed unmounting " ++ mnt +-- | Unmounts anything mounted inside the specified directory. +unmountBelow :: FilePath -> IO () +unmountBelow d = do + submnts <- mountPointsBelow d + forM_ submnts umountLazy + -- | Mounts a device. mount :: FsType -> Source -> FilePath -> IO Bool mount fs src mnt = boolSystem "mount" [Param "-t", Param fs, Param src, Param mnt] -- cgit v1.2.3 From 9dad69313101a3f45f63ce2e2d2a2c11c27f058d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 11:17:53 -0700 Subject: propellor spin --- src/Propellor/Property/DiskImage.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 00bb465f..bd7178cc 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -80,6 +80,7 @@ built' rebuild img mkchroot mkparttable final = szm <- liftIO $ M.map toPartSize <$> dirSizes chrootdir -- tie the knot! let (mnts, t) = mkparttable (map (getMountSz szm) mnts) + liftIO $ print (mnts, t) ensureProperty $ exists img (partTableSize t) `before` -- cgit v1.2.3 -- cgit v1.2.3 From e63158e270129b39b19a58b9952b9235570a393d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 11:27:25 -0700 Subject: run parted before kpartex --- src/Propellor/Property/Parted.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs index 4e2efe24..fcff089a 100644 --- a/src/Propellor/Property/Parted.hs +++ b/src/Propellor/Property/Parted.hs @@ -147,13 +147,15 @@ data Eep = YesReallyDeleteDiskContents partitioned :: Eep -> FilePath -> PartTable -> Property NoInfo 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 + ensureProperty $ combineProperties desc + [ parted eep disk partedparams + , if isdev + then formatl (map (\n -> disk ++ show n) [1 :: Int ..]) + else Partition.kpartx disk formatl + ] where desc = disk ++ " partitioned" - go devs = combineProperties desc $ - parted eep disk partedparams : map format (zip parts devs) + formatl devs = combineProperties desc (map format (zip parts devs)) partedparams = concat $ mklabel : mkparts (1 :: Integer) mempty parts [] format (p, dev) = Partition.formatted' (partMkFsOpts p) Partition.YesReallyFormatPartition (partFs p) dev -- cgit v1.2.3 -- cgit v1.2.3 From 7846ad9db602d50adbef4bd62edba3fcb158d0c9 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 11:30:46 -0700 Subject: propellor spin --- src/Propellor/Property/DiskImage.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index bd7178cc..82b243fd 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -80,7 +80,7 @@ built' rebuild img mkchroot mkparttable final = szm <- liftIO $ M.map toPartSize <$> dirSizes chrootdir -- tie the knot! let (mnts, t) = mkparttable (map (getMountSz szm) mnts) - liftIO $ print (mnts, t) + liftIO $ print (mnts, t, map (getMountSz szm) mnts) ensureProperty $ exists img (partTableSize t) `before` -- cgit v1.2.3 From e6933eac69ca575bb7e19d083c6bea2cfb76a201 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 11:40:46 -0700 Subject: force partition formatting to happen for non-block devs and when already formatted --- src/Propellor/Property/Partition.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs index 41bdf795..e4b067a5 100644 --- a/src/Propellor/Property/Partition.hs +++ b/src/Propellor/Property/Partition.hs @@ -25,17 +25,19 @@ 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") + EXT2 -> ("mkfs.ext2", eff optsdev, "e2fsprogs") + EXT3 -> ("mkfs.ext3", eff optsdev, "e2fsprogs") + EXT4 -> ("mkfs.ext4", eff optsdev, "e2fsprogs") BTRFS -> ("mkfs.btrfs", optsdev, "btrfs-tools") - REISERFS -> ("mkfs.reiserfs", optsdev, "reiserfsprogs") - XFS -> ("mkfs.xfs", optsdev, "xfsprogs") + REISERFS -> ("mkfs.reiserfs", "-ff":optsdev, "reiserfsprogs") + XFS -> ("mkfs.xfs", "-f":optsdev, "xfsprogs") FAT -> ("mkfs.fat", optsdev, "dosfstools") VFAT -> ("mkfs.vfat", optsdev, "dosfstools") - NTFS -> ("mkfs.ntfs", optsdev, "ntfs-3g") + NTFS -> ("mkfs.ntfs", eff optsdev, "ntfs-3g") LinuxSwap -> ("mkswap", optsdev, "util-linux") optsdev = opts++[dev] + -- -F forces creating a filesystem even if the device already has one + eff l = "-F":l -- | Uses the kpartx utility to create device maps for partitions contained -- within a disk image file. The resulting devices are passed to the -- cgit v1.2.3 -- cgit v1.2.3 From 5dce06cbb83d69f7c1c85f1cbc6ccf1382c774d4 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 11:44:01 -0700 Subject: propellor spin --- src/Propellor/Property/DiskImage.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 82b243fd..99c9b14b 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -80,7 +80,7 @@ built' rebuild img mkchroot mkparttable final = szm <- liftIO $ M.map toPartSize <$> dirSizes chrootdir -- tie the knot! let (mnts, t) = mkparttable (map (getMountSz szm) mnts) - liftIO $ print (mnts, t, map (getMountSz szm) mnts) + liftIO $ print (mnts, t, map (getMountSz szm) mnts, szm) ensureProperty $ exists img (partTableSize t) `before` -- cgit v1.2.3 From ed42227b115ed1adf2e88b57bad8a7744d9cb240 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 11:52:39 -0700 Subject: propellor spin --- src/Propellor/Property/DiskImage.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 99c9b14b..5cef449b 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -77,7 +77,8 @@ built' rebuild img mkchroot mkparttable final = -- unmount helper filesystems such as proc from the chroot -- before getting sizes liftIO $ unmountBelow chrootdir - szm <- liftIO $ M.map toPartSize <$> dirSizes chrootdir + szm <- liftIO $ M.mapKeys tosysdir . M.map toPartSize + <$> dirSizes chrootdir -- tie the knot! let (mnts, t) = mkparttable (map (getMountSz szm) mnts) liftIO $ print (mnts, t, map (getMountSz szm) mnts, szm) @@ -91,6 +92,10 @@ built' rebuild img mkchroot mkparttable final = return MadeChange | otherwise = doNothing + tosysdir d = case makeRelative chrootdir d of + "." -> "/" + sysdir -> "/" ++ sysdir + -- | Ensures that a disk image file of the specified size exists. -- -- If the file doesn't exist, or is too small, creates a new one, full of 0's. -- cgit v1.2.3 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(-) 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.2.3 From b01d6fab5e8aa2120485884062ff3e03709ef626 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 12:17:44 -0700 Subject: todos --- src/Propellor/Property/DiskImage.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index b31aef45..7820c4c3 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -80,8 +80,10 @@ built' rebuild img mkchroot mkparttable final = szm <- liftIO $ M.mapKeys tosysdir . M.map toPartSize <$> dirSizes chrootdir -- tie the knot! + -- TODO when /boot is in part table, size of / + -- should be reduced by sie of /boot + -- TODO if any size is < 1 MB, use 1 MB for sanity let (mnts, t) = mkparttable (map (getMountSz szm) mnts) - liftIO $ print (mnts, t, map (getMountSz szm) mnts) ensureProperty $ exists img (partTableSize t) `before` -- cgit v1.2.3 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(-) 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.2.3 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(-) 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.2.3 From 2a645cc290faa82e3f763f3ced0ebaa68226351e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 12:26:32 -0700 Subject: haddock --- src/Propellor/Property/DiskImage.hs | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index ff9570dc..a74f3ac8 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -5,20 +5,24 @@ -- This module is designed to be imported unqualified. module Propellor.Property.DiskImage ( + -- * Properties imageBuilt, imageRebuilt, imageExists, + -- * Partition specifiction + module Propellor.Property.Parted, MountPoint, PartSpec, mountedAt, swapPartition, - MkPartTable, + -- * Partition sizing + SizePartTable, fitChrootSize, freeSpace, + -- * Finalization Finalization, grubBooted, Grub.BIOS(..), - module Propellor.Property.Parted ) where import Propellor @@ -54,16 +58,16 @@ import System.Posix.Files -- > , swapPartition (MegaBytes 256) -- > ] -- > in imageBuilt "/srv/images/foo.img" chroot partitions (grubBooted PC) -imageBuilt :: FilePath -> (FilePath -> Chroot) -> MkPartTable -> Finalization -> RevertableProperty +imageBuilt :: FilePath -> (FilePath -> Chroot) -> SizePartTable -> 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 :: FilePath -> (FilePath -> Chroot) -> MkPartTable -> Finalization -> RevertableProperty +imageRebuilt :: FilePath -> (FilePath -> Chroot) -> SizePartTable -> Finalization -> RevertableProperty imageRebuilt = imageBuilt' True -imageBuilt' :: Bool -> FilePath -> (FilePath -> Chroot) -> MkPartTable -> Finalization -> RevertableProperty +imageBuilt' :: Bool -> FilePath -> (FilePath -> Chroot) -> SizePartTable -> Finalization -> RevertableProperty imageBuilt' rebuild img mkchroot mkparttable final = (mkimg unmkimg) -- TODO snd final @@ -170,11 +174,11 @@ defSz = MegaBytes 128 -- (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 MkPartTable = [PartSize] -> ([MountPoint], PartTable) +type SizePartTable = [PartSize] -> ([MountPoint], PartTable) -- | 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] -> MkPartTable +fitChrootSize :: TableType -> [PartSpec] -> SizePartTable fitChrootSize tt l basesizes = (mounts, parttable) where (mounts, sizers) = unzip l @@ -183,7 +187,7 @@ fitChrootSize tt l basesizes = (mounts, parttable) -- | 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 :: TableType -> [(MountPoint, Partition)] -> SizePartTable freeSpace tt = fitChrootSize tt . map (\(mnt, p) -> (mnt, adjustsz p)) where adjustsz p basesize = p { partSize = partSize p <> basesize } -- cgit v1.2.3 From ef0fe77e7123949ed5a1ebe922bde93044bd9e38 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 14:03:11 -0700 Subject: docs --- src/Propellor/Info.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs index f1f23b96..0eea0816 100644 --- a/src/Propellor/Info.hs +++ b/src/Propellor/Info.hs @@ -18,10 +18,15 @@ pureInfoProperty desc i = infoProperty ("has " ++ desc) (return NoChange) i memp askInfo :: (Info -> Val a) -> Propellor (Maybe a) askInfo f = asks (fromVal . f . hostInfo) +-- | Specifies the operating system of a host. +-- +-- This only provides info for other Properties, so they can act +-- conditional on the os. os :: System -> Property HasInfo os system = pureInfoProperty ("Operating " ++ show system) $ mempty { _os = Val system } +-- Gets the operating system of a host, if it has been specified. getOS :: Propellor (Maybe System) getOS = askInfo _os -- cgit v1.2.3 From f49dd3692708ea8e0adbaa701f562de264f40153 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 14:09:44 -0700 Subject: cleanup --- src/Propellor/Property/DiskImage.hs | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index a74f3ac8..59baa8d1 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -75,7 +75,7 @@ imageBuilt' rebuild img mkchroot mkparttable final = -- TODO fst final -- TODO chroot topevel directory perm fixup `requires` Chroot.provisioned (mkchroot chrootdir) - `requires` (handlerebuild doNothing) + `requires` (cleanrebuild doNothing) `describe` desc where desc = "built disk image " ++ img @@ -85,7 +85,7 @@ imageBuilt' rebuild img mkchroot mkparttable final = -- unmount helper filesystems such as proc from the chroot -- before getting sizes liftIO $ unmountBelow chrootdir - szm <- liftIO $ M.mapKeys tosysdir . M.map toPartSize + szm <- liftIO $ M.mapKeys (toSysDir chrootdir) . M.map toPartSize <$> dirSizes chrootdir -- tie the knot! -- TODO when /boot is in part table, size of / @@ -96,16 +96,12 @@ imageBuilt' rebuild img mkchroot mkparttable final = imageExists img (partTableSize t) `before` partitioned YesReallyDeleteDiskContents img t - handlerebuild + cleanrebuild | rebuild = property desc $ do liftIO $ removeChroot chrootdir return MadeChange | otherwise = doNothing - tosysdir d = case makeRelative chrootdir d of - "." -> "/" - sysdir -> "/" ++ sysdir - -- | Ensures that a disk image file of the specified size exists. -- -- If the file doesn't exist, or is too small, creates a new one, full of 0's. @@ -144,6 +140,13 @@ dirSizes top = go M.empty top [top] else go (M.insertWith (+) dir sz m) dir is subdirof parent i = not (i `equalFilePath` parent) && takeDirectory i `equalFilePath` parent +-- | From a location in a chroot (eg, /tmp/chroot/usr) to +-- the corresponding location inside (eg, /usr). +toSysDir :: FilePath -> FilePath -> FilePath +toSysDir chrootdir d = case makeRelative chrootdir d of + "." -> "/" + sysdir -> "/" ++ sysdir + -- | Where a partition is mounted. Use Nothing for eg, LinuxSwap. type MountPoint = Maybe FilePath -- cgit v1.2.3 From 418e6a5b4ee36360911cdff14f70357c5c2bfc80 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 15:09:47 -0700 Subject: propellor spin --- src/Propellor/Property/DiskImage.hs | 36 +++++++++++++++++++++++++++--------- src/Propellor/Property/Parted.hs | 4 ++++ 2 files changed, 31 insertions(+), 9 deletions(-) diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 59baa8d1..86be3a9b 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -33,6 +33,7 @@ import qualified Propellor.Property.Grub as Grub import qualified Propellor.Property.File as File import Propellor.Property.Parted import Propellor.Property.Mount +import Utility.Path import qualified Data.Map.Strict as M import qualified Data.ByteString.Lazy as L @@ -85,13 +86,12 @@ imageBuilt' rebuild img mkchroot mkparttable final = -- unmount helper filesystems such as proc from the chroot -- before getting sizes liftIO $ unmountBelow chrootdir - szm <- liftIO $ M.mapKeys (toSysDir chrootdir) . M.map toPartSize - <$> dirSizes chrootdir + szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize + <$> liftIO (dirSizes chrootdir) -- tie the knot! - -- TODO when /boot is in part table, size of / - -- should be reduced by sie of /boot -- TODO if any size is < 1 MB, use 1 MB for sanity - let (mnts, t) = mkparttable (map (getMountSz szm) mnts) + let (mnts, t) = mkparttable (map (saneSz . fromMaybe defSz . getMountSz szm mnts) mnts) + liftIO $ print (mnts, t) ensureProperty $ imageExists img (partTableSize t) `before` @@ -140,6 +140,23 @@ dirSizes top = go M.empty top [top] else go (M.insertWith (+) dir sz m) dir is subdirof parent i = not (i `equalFilePath` parent) && takeDirectory i `equalFilePath` parent +-- | Gets the size to allocate for a particular mount point, given the +-- map of sizes. +-- +-- A list of all mount points is provided, so that when eg calculating +-- the size for /, if /boot is a mount point, its size can be subtracted. +getMountSz :: (M.Map FilePath PartSize) -> [MountPoint] -> MountPoint -> Maybe PartSize +getMountSz _ _ Nothing = Nothing +getMountSz szm l (Just mntpt) = + fmap (`reducePartSize` childsz) (M.lookup mntpt szm) + where + childsz = mconcat $ catMaybes $ + map (getMountSz szm l) (filter childmntpt l) + childmntpt Nothing = False + childmntpt (Just d) + | d `equalFilePath` mntpt = False + | otherwise = mntpt `dirContains` d + -- | From a location in a chroot (eg, /tmp/chroot/usr) to -- the corresponding location inside (eg, /usr). toSysDir :: FilePath -> FilePath -> FilePath @@ -162,10 +179,11 @@ mountedAt mkp mntpoint = (Just mntpoint, mkp) swapPartition :: PartSize -> PartSpec swapPartition sz = (Nothing, const (mkPartition LinuxSwap sz)) -getMountSz :: (M.Map FilePath PartSize) -> MountPoint -> PartSize -getMountSz _ Nothing = defSz -getMountSz szm (Just mntpt) = M.findWithDefault defSz mntpt szm - +-- | Avoid partitions smaller than 1 mb; parted gets confused. +saneSz :: PartSize -> PartSize +saneSz (MegaBytes n) | n < 1 = MegaBytes 1 +saneSz sz = sz + defSz :: PartSize defSz = MegaBytes 128 diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs index fcff089a..1ff8677a 100644 --- a/src/Propellor/Property/Parted.hs +++ b/src/Propellor/Property/Parted.hs @@ -11,6 +11,7 @@ module Propellor.Property.Parted ( ByteSize, toPartSize, fromPartSize, + reducePartSize, Partition.MkfsOpts, PartType(..), PartFlag(..), @@ -104,6 +105,9 @@ instance Monoid PartSize where mempty = MegaBytes 0 mappend (MegaBytes a) (MegaBytes b) = MegaBytes (a + b) +reducePartSize :: PartSize -> PartSize -> PartSize +reducePartSize (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) -- cgit v1.2.3 From fe59ea1a62ff8dd15e30646802b9ca045df3008b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 15:23:47 -0700 Subject: propellor spin --- src/Propellor/Property/DiskImage.hs | 4 ++-- src/Propellor/Property/Parted.hs | 3 ++- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 86be3a9b..1d087cc0 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -88,9 +88,9 @@ imageBuilt' rebuild img mkchroot mkparttable final = liftIO $ unmountBelow chrootdir szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize <$> liftIO (dirSizes chrootdir) + let calcsz = \mnts -> saneSz . fromMaybe defSz . getMountSz szm mnts -- tie the knot! - -- TODO if any size is < 1 MB, use 1 MB for sanity - let (mnts, t) = mkparttable (map (saneSz . fromMaybe defSz . getMountSz szm mnts) mnts) + let (mnts, t) = mkparttable (map (calcsz mnts) mnts) liftIO $ print (mnts, t) ensureProperty $ imageExists img (partTableSize t) diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs index 1ff8677a..0b77fad1 100644 --- a/src/Propellor/Property/Parted.hs +++ b/src/Propellor/Property/Parted.hs @@ -95,8 +95,9 @@ newtype PartSize = MegaBytes Integer instance PartedVal PartSize where val (MegaBytes n) = show n ++ "MB" +-- | Rounds up to the nearest MegaByte. toPartSize :: ByteSize -> PartSize -toPartSize b = MegaBytes (b `div` 1000000) +toPartSize b = MegaBytes $ ceiling (fromInteger b / 1000000 :: Double) fromPartSize :: PartSize -> ByteSize fromPartSize (MegaBytes b) = b * 1000000 -- cgit v1.2.3 From 6dfc583d27cb0aeecf48f6dae01b98625902372b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 15:36:24 -0700 Subject: propellor spin --- src/Propellor/Property/DiskImage.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 1d087cc0..384718ca 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -73,9 +73,8 @@ imageBuilt' rebuild img mkchroot mkparttable final = (mkimg unmkimg) -- TODO snd final -- TODO copy in - -- TODO fst final -- TODO chroot topevel directory perm fixup - `requires` Chroot.provisioned (mkchroot chrootdir) + `requires` Chroot.provisioned (mkchroot chrootdir & fst final) `requires` (cleanrebuild doNothing) `describe` desc where @@ -121,9 +120,10 @@ 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. +-- every directory in a filesystem tree. (Hard links are counted multiple +-- times for simplicity) -- --- Should be same values as du -b +-- Should be same values as du -bl dirSizes :: FilePath -> IO (M.Map FilePath Integer) dirSizes top = go M.empty top [top] where -- cgit v1.2.3 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(-) 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.2.3 From 63b44fc8a59b5c2a49fde3f0bcb5fa4c69e8abce Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 15:49:06 -0700 Subject: mkfs quietly --- src/Propellor/Property/Partition.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs index e4b067a5..c85ef8b9 100644 --- a/src/Propellor/Property/Partition.hs +++ b/src/Propellor/Property/Partition.hs @@ -25,19 +25,21 @@ formatted' opts YesReallyFormatPartition fs dev = cmdProperty cmd opts' `requires` Apt.installed [pkg] where (cmd, opts', pkg) = case fs of - EXT2 -> ("mkfs.ext2", eff optsdev, "e2fsprogs") - EXT3 -> ("mkfs.ext3", eff optsdev, "e2fsprogs") - EXT4 -> ("mkfs.ext4", eff optsdev, "e2fsprogs") + EXT2 -> ("mkfs.ext2", q $ eff optsdev, "e2fsprogs") + EXT3 -> ("mkfs.ext3", q $ eff optsdev, "e2fsprogs") + EXT4 -> ("mkfs.ext4", q $ eff optsdev, "e2fsprogs") BTRFS -> ("mkfs.btrfs", optsdev, "btrfs-tools") - REISERFS -> ("mkfs.reiserfs", "-ff":optsdev, "reiserfsprogs") - XFS -> ("mkfs.xfs", "-f":optsdev, "xfsprogs") + REISERFS -> ("mkfs.reiserfs", q $ "-ff":optsdev, "reiserfsprogs") + XFS -> ("mkfs.xfs", "-f":q optsdev, "xfsprogs") FAT -> ("mkfs.fat", optsdev, "dosfstools") VFAT -> ("mkfs.vfat", optsdev, "dosfstools") - NTFS -> ("mkfs.ntfs", eff optsdev, "ntfs-3g") + NTFS -> ("mkfs.ntfs", q $ eff optsdev, "ntfs-3g") LinuxSwap -> ("mkswap", optsdev, "util-linux") optsdev = opts++[dev] -- -F forces creating a filesystem even if the device already has one eff l = "-F":l + -- Be quiet. + q l = "-q":l -- | Uses the kpartx utility to create device maps for partitions contained -- within a disk image file. The resulting devices are passed to the -- cgit v1.2.3 -- cgit v1.2.3 From 72c0c1b6608bfa318437bb9219f777c255b9831a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 16:46:02 -0700 Subject: refactor --- src/Propellor/Property/DiskImage.hs | 40 ++++++++++++++++++++++++------------- 1 file changed, 26 insertions(+), 14 deletions(-) diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 2c222cb2..a406428a 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -5,9 +5,11 @@ -- This module is designed to be imported unqualified. module Propellor.Property.DiskImage ( + DiskImage, -- * Properties imageBuilt, imageRebuilt, + imageBuiltFrom, imageExists, -- * Partition specifiction module Propellor.Property.Parted, @@ -41,6 +43,8 @@ import qualified Data.Map.Strict as M import qualified Data.ByteString.Lazy as L import System.Posix.Files +type DiskImage = FilePath + -- | Creates a bootable disk image in the specified file. -- -- First the specified Chroot is set up, and its properties are satisfied. @@ -61,33 +65,45 @@ import System.Posix.Files -- > , swapPartition (MegaBytes 256) -- > ] -- > in imageBuilt "/srv/images/foo.img" chroot partitions (grubBooted PC) -imageBuilt :: FilePath -> (FilePath -> Chroot) -> SizePartTable -> Finalization -> RevertableProperty +imageBuilt :: DiskImage -> (FilePath -> Chroot) -> SizePartTable -> 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 :: FilePath -> (FilePath -> Chroot) -> SizePartTable -> Finalization -> RevertableProperty +imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> SizePartTable -> Finalization -> RevertableProperty imageRebuilt = imageBuilt' True -imageBuilt' :: Bool -> FilePath -> (FilePath -> Chroot) -> SizePartTable -> Finalization -> RevertableProperty +imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> SizePartTable -> Finalization -> RevertableProperty imageBuilt' rebuild img mkchroot mkparttable final = - (mkimg unmkimg) - -- TODO snd final - -- TODO copy in + imageBuiltFrom img chrootdir mkparttable (snd final) `requires` Chroot.provisioned chroot `requires` (cleanrebuild doNothing) `describe` desc where desc = "built disk image " ++ img - unmkimg = File.notPresent img + cleanrebuild + | rebuild = property desc $ do + liftIO $ removeChroot chrootdir + return MadeChange + | otherwise = doNothing chrootdir = img ++ ".chroot" chroot = mkchroot chrootdir - -- Run first stage finalization. + -- First stage finalization. & fst final -- Avoid wasting disk image space on the apt cache & Apt.cacheCleaned - mkimg = property desc $ do + +-- | Builds a disk image from the contents of a chroot. +-- +-- The passed property is run inside the mounted disk image. +-- +-- TODO copy in +-- TODO run final +imageBuiltFrom :: DiskImage -> FilePath -> SizePartTable -> Property NoInfo -> RevertableProperty +imageBuiltFrom img chrootdir mkparttable final = mkimg rmimg + where + mkimg = property (img ++ " built from " ++ chrootdir) $ do -- unmount helper filesystems such as proc from the chroot -- before getting sizes liftIO $ unmountBelow chrootdir @@ -101,11 +117,7 @@ imageBuilt' rebuild img mkchroot mkparttable final = imageExists img (partTableSize t) `before` partitioned YesReallyDeleteDiskContents img t - cleanrebuild - | rebuild = property desc $ do - liftIO $ removeChroot chrootdir - return MadeChange - | otherwise = doNothing + rmimg = File.notPresent img -- | Ensures that a disk image file of the specified size exists. -- -- cgit v1.2.3 From 00ce4591aacfc2c16d8a3204ebd5dd0fc52d5825 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 2 Sep 2015 19:33:54 -0700 Subject: improve exports --- src/Propellor/Property/DiskImage.hs | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index a406428a..8ee77376 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -12,11 +12,22 @@ module Propellor.Property.DiskImage ( imageBuiltFrom, imageExists, -- * Partition specifiction - module Propellor.Property.Parted, MountPoint, PartSpec, mountedAt, swapPartition, + TableType(..), + PartTable(..), + Partition(..), + mkPartition, + Fs(..), + PartSize(..), + ByteSize, + toPartSize, + fromPartSize, + reducePartSize, + PartType(..), + PartFlag(..), -- * Partition sizing SizePartTable, fitChrootSize, @@ -45,7 +56,7 @@ import System.Posix.Files type DiskImage = FilePath --- | Creates a bootable disk image in the specified file. +-- | Creates a bootable disk image. -- -- First the specified Chroot is set up, and its properties are satisfied. -- -- cgit v1.2.3 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(-) 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.2.3 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(-) 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.2.3 From 99aa052ecfab5fd0c3721f0c84edaf67b12217fc Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 3 Sep 2015 08:50:39 -0700 Subject: reorder --- src/Propellor/Property/DiskImage.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 7e5112fb..5a41edd0 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -3,8 +3,8 @@ -- This module is designed to be imported unqualified. module Propellor.Property.DiskImage ( - DiskImage, -- * Properties + DiskImage, imageBuilt, imageRebuilt, imageBuiltFrom, -- cgit v1.2.3 From 776b4dc3b24f8d30fa0fe56254c16e613d8e0bbe Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 3 Sep 2015 08:53:04 -0700 Subject: prep release --- debian/changelog | 10 +++++----- propellor.cabal | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/debian/changelog b/debian/changelog index 61ed235b..1fa8c1f1 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,14 +1,14 @@ -propellor (2.7.3) UNRELEASED; urgency=medium +propellor (2.7.3) unstable; urgency=medium + * Fix bug that caused provisioning new chroots to fail. + * Update for Debian systemd-container package split. * Added Propellor.Property.Parted, for disk partitioning. * Added Propellor.Property.Partition, for partition formatting etc. * Added Propellor.Property.DiskImage, for bootable disk image creation. - (Not yet complete.) - * Update for Debian systemd-container package split. + (Experimental and not yet complete.) * Dropped support for ghc 7.4. - * Fix bug that caused provisioning new chroots to fail. - -- Joey Hess Tue, 25 Aug 2015 13:45:39 -0700 + -- Joey Hess Thu, 03 Sep 2015 08:52:51 -0700 propellor (2.7.2) unstable; urgency=medium diff --git a/propellor.cabal b/propellor.cabal index e455d1a7..eab5ccfb 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 2.7.2 +Version: 2.7.3 Cabal-Version: >= 1.8 License: BSD3 Maintainer: Joey Hess -- cgit v1.2.3