summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/DiskImage.hs
diff options
context:
space:
mode:
authorJoey Hess2015-10-23 14:33:10 -0400
committerJoey Hess2015-10-23 14:33:10 -0400
commitc9e408af6ddb296d60c6eeb6cdb3210262dd7cde (patch)
treeeeb21be3925ecfbab44220541ed6caca7050ee77 /src/Propellor/Property/DiskImage.hs
parentd8831c723a23da38a47a3d0deb3d56c7435b1097 (diff)
refactor
Diffstat (limited to 'src/Propellor/Property/DiskImage.hs')
-rw-r--r--src/Propellor/Property/DiskImage.hs140
1 files changed, 39 insertions, 101 deletions
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