diff options
| -rw-r--r-- | config-joey.hs | 12 | ||||
| -rw-r--r-- | debian/changelog | 10 | ||||
| -rw-r--r-- | propellor.cabal | 2 | ||||
| -rw-r--r-- | src/Propellor/Info.hs | 5 | ||||
| -rw-r--r-- | src/Propellor/Property/Chroot/Util.hs | 10 | ||||
| -rw-r--r-- | src/Propellor/Property/Debootstrap.hs | 11 | ||||
| -rw-r--r-- | src/Propellor/Property/DiskImage.hs | 244 | ||||
| -rw-r--r-- | src/Propellor/Property/Mount.hs | 6 | ||||
| -rw-r--r-- | src/Propellor/Property/Parted.hs | 36 | ||||
| -rw-r--r-- | src/Propellor/Property/Partition.hs | 16 | ||||
| -rw-r--r-- | src/Propellor/Shim.hs | 15 |
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. |