diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,15 @@ +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. + (Experimental and not yet complete.) + * Dropped support for ghc 7.4. + + -- Joey Hess Thu, 03 Sep 2015 08:52:51 -0700 + propellor (2.7.2) unstable; urgency=medium * Added Propellor.Property.ConfFile, with support for Windows-style .ini diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,7 +6,8 @@ Propellor is configured via a git repository, which typically lives in `~/.propellor/` on your development machine. Propellor clones the repository to each host it manages, in a -[secure](http://propellor.branchable.com/security/) way. See [[components]] +[secure](http://propellor.branchable.com/security/) way. See +[components](http://propellor.branchable.com/components/) for details. Properties are defined using Haskell. Edit `~/.propellor/config.hs` diff --git a/config-joey.hs b/config-joey.hs --- a/config-joey.hs +++ b/config-joey.hs @@ -34,7 +34,7 @@ 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.DiskImage main :: IO () -- _ ______`| ,-.__ main = defaultMain hosts -- / \___-=O`/|O`/__| (____.' @@ -79,6 +79,15 @@ & JoeySites.postfixClientRelay (Context "darkstar.kitenet.net") & JoeySites.dkimMilter + + & 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 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,15 @@ +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. + (Experimental and not yet complete.) + * Dropped support for ghc 7.4. + + -- Joey Hess Thu, 03 Sep 2015 08:52:51 -0700 + propellor (2.7.2) unstable; urgency=medium * Added Propellor.Property.ConfFile, with support for Windows-style .ini diff --git a/debian/control b/debian/control --- a/debian/control +++ b/debian/control @@ -4,7 +4,7 @@ Build-Depends: debhelper (>= 9), git, - ghc (>= 7.4), + ghc (>= 7.6), cabal-install, libghc-async-dev, libghc-missingh-dev, diff --git a/doc/README.mdwn b/doc/README.mdwn --- a/doc/README.mdwn +++ b/doc/README.mdwn @@ -6,7 +6,8 @@ Propellor is configured via a git repository, which typically lives in `~/.propellor/` on your development machine. Propellor clones the repository to each host it manages, in a -[secure](http://propellor.branchable.com/security/) way. See [[components]] +[secure](http://propellor.branchable.com/security/) way. See +[components](http://propellor.branchable.com/components/) for details. Properties are defined using Haskell. Edit `~/.propellor/config.hs` diff --git a/propellor.cabal b/propellor.cabal --- 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 @@ -38,7 +38,7 @@ Hs-Source-Dirs: src Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, - containers, network, async, time, QuickCheck, mtl, transformers, + containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers, exceptions (>= 0.6) if (! os(windows)) @@ -50,7 +50,7 @@ Hs-Source-Dirs: src Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, - containers, network, async, time, QuickCheck, mtl, transformers, + containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers, exceptions if (! os(windows)) @@ -61,7 +61,7 @@ Hs-Source-Dirs: src Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, - containers, network, async, time, QuickCheck, mtl, transformers, + containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers, exceptions if (! os(windows)) @@ -78,6 +78,7 @@ Propellor.Property.ConfFile Propellor.Property.Cron Propellor.Property.Debootstrap + Propellor.Property.DiskImage Propellor.Property.Dns Propellor.Property.DnsSec Propellor.Property.Docker @@ -94,6 +95,8 @@ Propellor.Property.Obnam Propellor.Property.OpenId Propellor.Property.OS + Propellor.Property.Parted + Propellor.Property.Partition Propellor.Property.Postfix Propellor.Property.Prosody Propellor.Property.Reboot diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs --- a/src/Propellor/Info.hs +++ b/src/Propellor/Info.hs @@ -18,10 +18,15 @@ 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 --- 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 @@ 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 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -13,7 +13,6 @@ 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 @@ 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,19 +95,13 @@ -- recover by deleting it and trying again. ispartial = ifM (doesDirectoryExist (target "debootstrap")) ( do - removetarget target + removeChroot target return True , return False ) 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 diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/DiskImage.hs @@ -0,0 +1,260 @@ +-- | Disk image generation. +-- +-- This module is designed to be imported unqualified. + +module Propellor.Property.DiskImage ( + -- * 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, + Grub.BIOS(..), + noFinalization, +) where + +import Propellor +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. +-- +-- Then, the disk image is set up, and the chroot is copied into the +-- appropriate partition(s) of it. +-- +-- Example use: +-- +-- > import Propellor.Property.DiskImage +-- +-- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d +-- > & Apt.installed ["linux-image-amd64"] +-- > & ... +-- > 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. +imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty +imageRebuilt = imageBuilt' True + +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 + +-- | 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. +-- +-- (Hard links are counted multiple times for simplicity) +-- +-- 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) = flip catchIO (\_ioerr -> go m dir is) $ do + s <- getSymbolicLinkStatus i + let sz = fromIntegral (fileSize s) + if isDirectory s + then do + subm <- go M.empty i =<< dirContents i + let sz' = M.foldr' (+) sz + (M.filterWithKey (const . subdirof i) subm) + go (M.insertWith (+) i sz' (M.union m subm)) dir is + 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 + +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 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 = (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. +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)) + +-- | 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 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) diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs --- a/src/Propellor/Property/Mount.hs +++ b/src/Propellor/Property/Mount.hs @@ -3,7 +3,8 @@ import Propellor import Utility.Path -type FsType = String +type FsType = String -- ^ type of filesystem to mount ("auto" to autodetect) + type Source = String -- | Lists all mount points of the system. @@ -27,6 +28,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 diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Parted.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Propellor.Property.Parted ( + TableType(..), + PartTable(..), + partTableSize, + Partition(..), + mkPartition, + Partition.Fs(..), + PartSize(..), + ByteSize, + toPartSize, + fromPartSize, + reducePartSize, + Partition.MkfsOpts, + PartType(..), + PartFlag(..), + Eep(..), + partitioned, + parted, + installed, +) where + +import Propellor +import qualified Propellor.Property.Apt as Apt +import qualified Propellor.Property.Partition as Partition +import Utility.DataUnits +import Data.Char +import System.Posix.Files + +class PartedVal a where + val :: a -> String + +-- | Types of partition tables supported by parted. +data TableType = MSDOS | GPT | AIX | AMIGA | BSD | DVH | LOOP | MAC | PC98 | SUN + deriving (Show) + +instance PartedVal TableType where + val = map toLower . show + +-- | A disk's partition table. +data PartTable = PartTable TableType [Partition] + deriving (Show) + +instance Monoid PartTable where + -- | default TableType is MSDOS + mempty = PartTable MSDOS [] + -- | 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 + , partSize :: PartSize + , partFs :: Partition.Fs + , partMkFsOpts :: Partition.MkfsOpts + , partFlags :: [(PartFlag, Bool)] -- ^ flags can be set or unset (parted may set some flags by default) + , partName :: Maybe String -- ^ optional name for partition (only works for GPT, PC98, MAC) + } + deriving (Show) + +-- | Makes a Partition with defaults for non-important values. +mkPartition :: Partition.Fs -> PartSize -> Partition +mkPartition fs sz = Partition + { partType = Primary + , partSize = sz + , partFs = fs + , partMkFsOpts = [] + , partFlags = [] + , partName = Nothing + } + +-- | Type of a partition. +data PartType = Primary | Logical | Extended + deriving (Show) + +instance PartedVal PartType where + val Primary = "primary" + val Logical = "logical" + val Extended = "extended" + +-- | All partition sizing is done in megabytes, so that parted can +-- automatically lay out the partitions. +-- +-- Note that these are SI megabytes, not mebibytes. +newtype PartSize = MegaBytes Integer + deriving (Show) + +instance PartedVal PartSize where + 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 $ 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) + +instance PartedVal PartFlag where + val BootFlag = "boot" + val RootFlag = "root" + val SwapFlag = "swap" + val HiddenFlag = "hidden" + val RaidFlag = "raid" + val LvmFlag = "lvm" + val LbaFlag = "lba" + val LegacyBootFlag = "legacy_boot" + val IrstFlag = "irst" + val EspFlag = "esp" + val PaloFlag = "palo" + +instance PartedVal Bool where + val True = "on" + val False = "off" + +instance PartedVal Partition.Fs where + val Partition.EXT2 = "ext2" + val Partition.EXT3 = "ext3" + val Partition.EXT4 = "ext4" + val Partition.BTRFS = "btrfs" + val Partition.REISERFS = "reiserfs" + val Partition.XFS = "xfs" + val Partition.FAT = "fat" + val Partition.VFAT = "vfat" + val Partition.NTFS = "ntfs" + val Partition.LinuxSwap = "linux-swap" + +data Eep = YesReallyDeleteDiskContents + +-- | Partitions a disk using parted, and formats the partitions. +-- +-- The FilePath can be a block device (eg, \/dev\/sda), or a disk image file. +-- +-- This deletes any existing partitions in the disk! Use with EXTREME caution! +partitioned :: Eep -> FilePath -> PartTable -> Property NoInfo +partitioned eep disk (PartTable tabletype parts) = property desc $ do + isdev <- liftIO $ isBlockDevice <$> getFileStatus disk + 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" + 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 + mklabel = ["mklabel", val tabletype] + mkflag partnum (f, b) = + [ "set" + , show partnum + , val f + , val b + ] + mkpart partnum offset p = + [ "mkpart" + , val (partType p) + , val (partFs p) + , val offset + , val (offset <> partSize p) + ] ++ case partName p of + Just n -> ["name", show partnum, n] + Nothing -> [] + mkparts partnum offset (p:ps) c = + mkparts (partnum+1) (offset <> partSize p) ps + (c ++ mkpart partnum offset p : map (mkflag partnum) (partFlags p)) + mkparts _ _ [] c = c + +-- | Runs parted on a disk with the specified parameters. +-- +-- Parted is run in script mode, so it will never prompt for input. +-- It is asked to use cylinder alignment for the disk. +parted :: Eep -> FilePath -> [String] -> Property NoInfo +parted YesReallyDeleteDiskContents disk ps = + cmdProperty "parted" ("--script":"--align":"cylinder":disk:ps) + `requires` installed + +-- | Gets parted installed. +installed :: Property NoInfo +installed = Apt.installed ["parted"] diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs new file mode 100644 --- /dev/null +++ b/src/Propellor/Property/Partition.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Propellor.Property.Partition where + +import Propellor +import qualified Propellor.Property.Apt as Apt + +-- | Filesystems etc that can be used for a partition. +data Fs = EXT2 | EXT3 | EXT4 | BTRFS | REISERFS | XFS | FAT | VFAT | NTFS | LinuxSwap + deriving (Show) + +data Eep = YesReallyFormatPartition + +-- | Formats a partition. +formatted :: Eep -> Fs -> FilePath -> Property NoInfo +formatted = formatted' [] + +-- | Options passed to a mkfs.* command when making a filesystem. +-- +-- Eg, ["-m0"] +type MkfsOpts = [String] + +formatted' :: MkfsOpts -> Eep -> Fs -> FilePath -> Property NoInfo +formatted' opts YesReallyFormatPartition fs dev = + cmdProperty cmd opts' `requires` Apt.installed [pkg] + where + (cmd, opts', pkg) = case fs of + 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", q $ "-ff":optsdev, "reiserfsprogs") + XFS -> ("mkfs.xfs", "-f":q optsdev, "xfsprogs") + FAT -> ("mkfs.fat", optsdev, "dosfstools") + VFAT -> ("mkfs.vfat", optsdev, "dosfstools") + 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 +-- property, which can operate on them. Always cleans up after itself, +-- by removing the device maps after the property is run. +kpartx :: FilePath -> ([FilePath] -> Property NoInfo) -> Property NoInfo +kpartx diskimage mkprop = go `requires` Apt.installed ["kpartx"] + where + go = property (propertyDesc (mkprop [])) $ do + cleanup -- idempotency + s <- liftIO $ readProcess "kpartx" ["-avs", diskimage] + r <- ensureProperty (mkprop (devlist s)) + cleanup + return r + devlist = mapMaybe (finddev . words) . lines + finddev ("add":"map":s:_) = Just ("/dev/mapper/" ++ s) + finddev _ = Nothing + cleanup = void $ liftIO $ boolSystem "kpartx" [Param "-d", File diskimage] diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs --- a/src/Propellor/Property/Systemd.hs +++ b/src/Propellor/Property/Systemd.hs @@ -20,7 +20,8 @@ -- * Journal persistentJournal, journaldConfigured, - -- * Containers + -- * Containers and machined + machined, MachineName, Container, container, @@ -160,6 +161,18 @@ configured "/etc/systemd/journald.conf" option value `onChange` restarted journald +-- | Ensures machined and machinectl are installed +machined :: Property NoInfo +machined = go `describe` "machined installed" + where + go = withOS ("standard sources.list") $ \o -> + case o of + -- Split into separate debian package since systemd 225. + (Just (System (Debian suite) _)) + | not (isStable suite) -> ensureProperty $ + Apt.installed ["systemd-container"] + _ -> noChange + -- | Defines a container with a given machine name. -- -- Properties can be added to configure the Container. @@ -250,7 +263,7 @@ `requires` daemonReloaded `requires` writeservicefile - setup = started service `requires` setupservicefile + setup = started service `requires` setupservicefile `requires` machined teardown = check (doesFileExist servicefile) $ disabled service `requires` stopped service diff --git a/src/Propellor/Shim.hs b/src/Propellor/Shim.hs --- a/src/Propellor/Shim.hs +++ b/src/Propellor/Shim.hs @@ -55,12 +55,15 @@ 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.