From c9e408af6ddb296d60c6eeb6cdb3210262dd7cde Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 23 Oct 2015 14:33:10 -0400 Subject: refactor --- src/Propellor/Property/DiskImage.hs | 140 ++++++++------------------- src/Propellor/Property/DiskImage/PartSpec.hs | 65 +++++++++++++ 2 files changed, 104 insertions(+), 101 deletions(-) create mode 100644 src/Propellor/Property/DiskImage/PartSpec.hs (limited to 'src/Propellor') diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index c8b9ffa1..979a3e6a 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -5,28 +5,14 @@ -- TODO avoid starting services while populating chroot and running final module Propellor.Property.DiskImage ( + -- * Partition specification + module Propellor.Property.DiskImage.PartSpec, -- * Properties DiskImage, imageBuilt, imageRebuilt, imageBuiltFrom, imageExists, - -- * Partitioning - Partition, - PartSize(..), - Fs(..), - PartSpec, - MountPoint, - swapPartition, - partition, - mountedAt, - addFreeSpace, - setSize, - PartFlag(..), - setFlag, - TableType(..), - extended, - adjustp, -- * Finalization Finalization, grubBooted, @@ -35,6 +21,7 @@ module Propellor.Property.DiskImage ( ) where import Propellor.Base +import Propellor.Property.DiskImage.PartSpec import Propellor.Property.Chroot (Chroot) import Propellor.Property.Chroot.Util (removeChroot) import qualified Propellor.Property.Chroot as Chroot @@ -163,23 +150,13 @@ partitionsPopulated chrootdir mnts devs = property desc $ mconcat $ zipWith go m , Protect (Pattern "lost+found") ]) childmnts --- | 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. -imageExists :: FilePath -> ByteSize -> Property NoInfo -imageExists 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 +-- 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] -> [PartSize] -> ([Maybe MountPoint], PartTable) +fitChrootSize tt l basesizes = (mounts, parttable) + where + (mounts, sizers) = unzip l + parttable = PartTable tt (zipWith id sizers basesizes) -- | Generates a map of the sizes of the contents of -- every directory in a filesystem tree. @@ -210,22 +187,6 @@ getMountSz szm l (Just mntpt) = where childsz = mconcat $ mapMaybe (getMountSz szm l) (filter (isChild mntpt) l) -isChild :: FilePath -> Maybe MountPoint -> Bool -isChild mntpt (Just d) - | d `equalFilePath` mntpt = False - | otherwise = mntpt `dirContains` d -isChild _ Nothing = False - --- | 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 - -defSz :: PartSize -defSz = MegaBytes 128 - -- Add 2% for filesystem overhead. Rationalle for picking 2%: -- A filesystem with 1% overhead might just sneak by as acceptable. -- Double that just in case. Add an additional 3 mb to deal with @@ -234,60 +195,24 @@ defSz = MegaBytes 128 fudge :: PartSize -> PartSize fudge (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3 + 200) --- | 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. Plus a fudge factor, since filesystems have some space --- overhead. --- --- (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 PartSpec = (Maybe 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. +-- | 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. -- --- 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 :: 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 :: PartSpec -> PartSize -> PartSpec -setSize (mp, p) sz = (mp, const (p sz)) - --- | Sets a flag on the partition. -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 :: PartSpec -> PartSpec -extended s = adjustp s $ \p -> p { partType = Extended } - -adjustp :: PartSpec -> (Partition -> Partition) -> PartSpec -adjustp (mp, p) f = (mp, f . p) - --- | 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] -> [PartSize] -> ([Maybe MountPoint], PartTable) -fitChrootSize tt l basesizes = (mounts, parttable) - where - (mounts, sizers) = unzip l - parttable = PartTable tt (zipWith id sizers basesizes) +-- If the file is too large, truncates it down to the specified size. +imageExists :: FilePath -> ByteSize -> Property NoInfo +imageExists 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 -- | A pair of properties. The first property is satisfied within the -- chroot, and is typically used to download the boot loader. @@ -382,3 +307,16 @@ grubBooted bios = (Grub.installed' bios, boots) wholediskloopdev = case loopdevs of (l:_) -> wholeDiskLoopDev l [] -> error "No loop devs provided!" + +isChild :: FilePath -> Maybe MountPoint -> Bool +isChild mntpt (Just d) + | d `equalFilePath` mntpt = False + | otherwise = mntpt `dirContains` d +isChild _ Nothing = False + +-- | 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 diff --git a/src/Propellor/Property/DiskImage/PartSpec.hs b/src/Propellor/Property/DiskImage/PartSpec.hs new file mode 100644 index 00000000..1bd4fb01 --- /dev/null +++ b/src/Propellor/Property/DiskImage/PartSpec.hs @@ -0,0 +1,65 @@ +-- | Disk image partition specification and combinators. + +module Propellor.Property.DiskImage.PartSpec ( + module Propellor.Property.DiskImage.PartSpec, + Partition, + PartSize(..), + PartFlag(..), + TableType(..), + Fs(..), + MountPoint, +) where + +import Propellor.Base +import Propellor.Property.Parted +import Propellor.Property.Mount + +-- | 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. Plus a fudge factor, since filesystems have some space +-- overhead. +-- +-- (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 PartSpec = (Maybe MountPoint, PartSize -> Partition) + +defSz :: PartSize +defSz = MegaBytes 128 + +-- | 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 :: 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 :: PartSpec -> PartSize -> PartSpec +setSize (mp, p) sz = (mp, const (p sz)) + +-- | Sets a flag on the partition. +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 :: PartSpec -> PartSpec +extended s = adjustp s $ \p -> p { partType = Extended } + +adjustp :: PartSpec -> (Partition -> Partition) -> PartSpec +adjustp (mp, p) f = (mp, f . p) -- cgit v1.2.3