summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2015-09-03 08:53:40 -0700
committerJoey Hess2015-09-03 08:54:06 -0700
commit43a67e310740e58707d0a7908237641ef46f5ae6 (patch)
tree89df6bbb593bc85f8a443316c16dd4cd893f97d1
parentf158d1cf81c2fe4ece5320dd725496043e5b953d (diff)
parent776b4dc3b24f8d30fa0fe56254c16e613d8e0bbe (diff)
Merge branch 'joeyconfig'
-rw-r--r--config-joey.hs12
-rw-r--r--debian/changelog10
-rw-r--r--propellor.cabal2
-rw-r--r--src/Propellor/Info.hs5
-rw-r--r--src/Propellor/Property/Chroot/Util.hs10
-rw-r--r--src/Propellor/Property/Debootstrap.hs11
-rw-r--r--src/Propellor/Property/DiskImage.hs244
-rw-r--r--src/Propellor/Property/Mount.hs6
-rw-r--r--src/Propellor/Property/Parted.hs36
-rw-r--r--src/Propellor/Property/Partition.hs16
-rw-r--r--src/Propellor/Shim.hs15
11 files changed, 279 insertions, 88 deletions
diff --git a/config-joey.hs b/config-joey.hs
index 71b1a4ae..2bb2f1bd 100644
--- a/config-joey.hs
+++ b/config-joey.hs
@@ -34,7 +34,7 @@ import qualified Propellor.Property.SiteSpecific.GitAnnexBuilder as GitAnnexBuil
import qualified Propellor.Property.SiteSpecific.IABak as IABak
import qualified Propellor.Property.SiteSpecific.Branchable as Branchable
import qualified Propellor.Property.SiteSpecific.JoeySites as JoeySites
-import Propellor.Property.Parted
+import Propellor.Property.DiskImage
main :: IO () -- _ ______`| ,-.__
main = defaultMain hosts -- / \___-=O`/|O`/__| (____.'
@@ -80,8 +80,14 @@ 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)])
+ & imageBuilt "/tmp/img" c MSDOS
+ [ partition EXT2 `mountedAt` "/boot" `setFlag` BootFlag
+ , partition EXT4 `mountedAt` "/" `addFreeSpace` MegaBytes 100
+ , swapPartition (MegaBytes 256)
+ ] noFinalization -- (grubBooted PC)
+ where
+ c d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d
+ & Apt.installed ["linux-image-amd64"]
gnu :: Host
gnu = host "gnu.kitenet.net"
diff --git a/debian/changelog b/debian/changelog
index 33d44b02..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.)
- * Dropped support for ghc 7.4.
- * Update for Debian systemd-container package split.
+ (Experimental and not yet complete.)
* Dropped support for ghc 7.4.
- -- Joey Hess <id@joeyh.name> Tue, 25 Aug 2015 13:45:39 -0700
+ -- Joey Hess <id@joeyh.name> 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 <id@joeyh.name>
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
diff --git a/src/Propellor/Property/Chroot/Util.hs b/src/Propellor/Property/Chroot/Util.hs
index 382fbab7..ea0df780 100644
--- a/src/Propellor/Property/Chroot/Util.hs
+++ b/src/Propellor/Property/Chroot/Util.hs
@@ -1,7 +1,10 @@
module Propellor.Property.Chroot.Util where
+import Propellor.Property.Mount
+
import Utility.Env
import Control.Applicative
+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 +17,10 @@ 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
+ unmountBelow c
+ 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 5bdd8f1a..5a41edd0 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -1,25 +1,54 @@
-{-# LANGUAGE FlexibleContexts #-}
+-- | Disk image generation.
+--
+-- This module is designed to be imported unqualified.
module Propellor.Property.DiskImage (
- built,
- rebuilt,
+ -- * Properties
+ DiskImage,
+ imageBuilt,
+ imageRebuilt,
+ imageBuiltFrom,
+ imageExists,
+ -- * Partitioning
+ Partition,
+ PartSize(..),
+ Fs(..),
+ PartSpec,
MountPoint,
- MkPartTable,
- fitChrootSize,
- freeSpace,
- DiskImageFinalization,
+ swapPartition,
+ partition,
+ mountedAt,
+ addFreeSpace,
+ setSize,
+ PartFlag(..),
+ setFlag,
+ TableType(..),
+ extended,
+ adjustp,
+ -- * Finalization
+ Finalization,
grubBooted,
Grub.BIOS(..),
+ noFinalization,
) where
import Propellor
-import Propellor.Property.Chroot
-import Propellor.Property.Parted
+import Propellor.Property.Chroot (Chroot)
+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
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.
--
-- First the specified Chroot is set up, and its properties are satisfied.
@@ -27,43 +56,100 @@ 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.
---
+-- Example use:
+--
+-- > import Propellor.Property.DiskImage
+--
-- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d
--- > & Apt.installed ["openssh-server"]
+-- > & Apt.installed ["linux-image-amd64"]
-- > & ...
--- > partitions = fitChrootSize MSDOS
--- > [ (Just "/boot", mkPartiton EXT2)
--- > , (Just "/", mkPartition EXT4)
--- > , (Nothing, const (mkPartition LinuxSwap (MegaBytes 256)))
--- > ]
--- > in built chroot partitions (grubBooted PC)
-built :: (FilePath -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty
-built = built' False
+-- > in imageBuilt "/srv/images/foo.img" chroot MSDOS
+-- > [ 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
+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 -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty
-rebuilt = built' True
+imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty
+imageRebuilt = imageBuilt' True
-built' :: Bool -> (FilePath -> Chroot) -> MkPartTable -> DiskImageFinalization -> RevertableProperty
-built' rebuild mkparttable mkchroot final = undefined
+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
+ where
+ desc = "built disk image " ++ img
+ cleanrebuild
+ | rebuild = property desc $ do
+ liftIO $ removeChroot chrootdir
+ return MadeChange
+ | otherwise = doNothing
+ chrootdir = img ++ ".chroot"
+ chroot = mkchroot chrootdir
+ -- First stage finalization.
+ & fst final
+ -- Avoid wasting disk image space on the apt cache
+ & Apt.cacheCleaned
--- TODO tie the knot
--- let f = fitChrootSize MSDOS [(Just "/", mkPartition EXT2)]
--- let (mnts, t) = f (map (MegaBytes . fromIntegral . length . show) mnts)
+-- | 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 -> 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
+ -- before getting sizes
+ liftIO $ unmountBelow chrootdir
+ szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize
+ <$> liftIO (dirSizes chrootdir)
+ let calcsz = \mnts -> fromMaybe defSz . getMountSz szm mnts
+ -- tie the knot!
+ let (mnts, t) = fitChrootSize tabletype partspec (map (calcsz mnts) mnts)
+ ensureProperty $
+ imageExists img (partTableSize t)
+ `before`
+ partitioned YesReallyDeleteDiskContents img t
+ rmimg = File.notPresent img
+
+-- | 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
-- | 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
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
@@ -75,44 +161,100 @@ 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
+toSysDir chrootdir d = case makeRelative chrootdir d of
+ "." -> "/"
+ sysdir -> "/" ++ sysdir
+
-- | Where a partition is mounted. Use Nothing for eg, LinuxSwap.
type MountPoint = Maybe FilePath
--- | This is provided with a list of the sizes of directories in the chroot
--- under each mount point. The input list corresponds to the list of mount
--- points that the function returns! This trick is accomplished by
--- exploiting laziness and tying the knot.
+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.
--
--- (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)
+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 :: 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, \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.
---
--- 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 :: 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)] -> MkPartTable
-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
-- 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)
+
+noFinalization :: Finalization
+noFinalization = (doNothing, doNothing)
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]
diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs
index 29d94b4c..a4f0f98e 100644
--- a/src/Propellor/Property/Parted.hs
+++ b/src/Propellor/Property/Parted.hs
@@ -3,12 +3,15 @@
module Propellor.Property.Parted (
TableType(..),
PartTable(..),
+ partTableSize,
Partition(..),
mkPartition,
Partition.Fs(..),
PartSize(..),
ByteSize,
toPartSize,
+ fromPartSize,
+ reducePartSize,
Partition.MkfsOpts,
PartType(..),
PartFlag(..),
@@ -45,6 +48,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
@@ -84,15 +93,26 @@ 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
-toPartSize b = MegaBytes (b `div` 1000000)
+toPartSize b = MegaBytes $ ceiling (fromInteger b / 1000000 :: Double)
+
+fromPartSize :: PartSize -> ByteSize
+fromPartSize (MegaBytes b) = b * 1000000
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)
@@ -136,13 +156,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
diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs
index 41bdf795..c85ef8b9 100644
--- a/src/Propellor/Property/Partition.hs
+++ b/src/Propellor/Property/Partition.hs
@@ -25,17 +25,21 @@ 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", 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", optsdev, "reiserfsprogs")
- XFS -> ("mkfs.xfs", 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", 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
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.