summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2015-08-26 11:23:42 -0700
committerJoey Hess2015-08-26 11:23:42 -0700
commita4ac16ab9432a9f6e180e9e416e95de8433ed016 (patch)
tree8e5dc34c025109ff544c76e43a987c773fe2ac89 /src
parent01d1cbb8361d1fada638bd4c554f3ea9fe7b8c76 (diff)
parent89dec139eef3d409c06877d5e8fd1dc1085465d1 (diff)
Merge branch 'joeyconfig'
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Property/DiskImage.hs58
-rw-r--r--src/Propellor/Property/Mount.hs3
-rw-r--r--src/Propellor/Property/Parted.hs181
-rw-r--r--src/Propellor/Property/Partition.hs56
4 files changed, 297 insertions, 1 deletions
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
new file mode 100644
index 00000000..cb373c94
--- /dev/null
+++ b/src/Propellor/Property/DiskImage.hs
@@ -0,0 +1,58 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module Propellor.Property.DiskImage (
+ built,
+ rebuilt,
+ DiskImageConfig(..),
+ DiskImageFinalization,
+ grubBooted,
+) where
+
+import Propellor
+import Propellor.Property.Chroot
+import Propellor.Property.Parted
+
+-- | Creates a bootable disk image.
+--
+-- First the specified Chroot is set up, and its properties are satisfied.
+-- Then a disk image is created, large enough to fit the chroot, which
+-- is copied into it. Finally, the DiskImageFinalization property is
+-- satisfied to make the disk image bootable.
+--
+-- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d
+-- > & Apt.installed ["openssh-server"]
+-- > & Grub.installed Grub.PC
+-- > & ...
+-- > in DiskImage.built mempty chroot DiskImage.grubBooted
+built :: DiskImageConfig -> (FilePath -> Chroot) -> DiskImageFinalization -> RevertableProperty
+built = built' 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 :: DiskImageConfig -> (FilePath -> Chroot) -> DiskImageFinalization -> RevertableProperty
+rebuilt = built' True
+
+built' :: Bool -> DiskImageConfig -> (FilePath -> Chroot) -> DiskImageFinalization -> RevertableProperty
+built' rebuild c mkchroot final = undefined
+
+data DiskImageConfig = DiskImageConfig
+ { freeSpace :: MegaBytes -- ^ A disk image is sized to fit the system installed in it. This adds some extra free space. (mempty default: 256 Megabytes)
+ }
+
+instance Monoid DiskImageConfig where
+ mempty = DiskImageConfig (MegaBytes 256)
+ mappend a b = a
+ { freeSpace = freeSpace a <> freeSpace b
+ }
+
+-- | This is a property that is run, chrooted into the disk image. It's
+-- typically only used to set up the boot loader.
+type DiskImageFinalization = Property NoInfo
+
+-- | Makes grub be the boot loader of the disk image.
+--
+-- This does not cause grub to be installed. Use `Grub.installed` when
+-- setting up the Chroot to do that.
+grubBooted :: DiskImageFinalization
+grubBooted = undefined
diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs
index ff47f4d9..43ca0cc6 100644
--- a/src/Propellor/Property/Mount.hs
+++ b/src/Propellor/Property/Mount.hs
@@ -3,7 +3,8 @@ module Propellor.Property.Mount where
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.
diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs
new file mode 100644
index 00000000..aa7bece4
--- /dev/null
+++ b/src/Propellor/Property/Parted.hs
@@ -0,0 +1,181 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module Propellor.Property.Parted (
+ TableType(..),
+ PartTable(..),
+ Partition(..),
+ mkPartition,
+ Partition.Fs(..),
+ MegaBytes(..),
+ ByteSize,
+ toMegaBytes,
+ 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)
+
+-- | A partition on the disk.
+data Partition = Partition
+ { partType :: PartType
+ , partSize :: MegaBytes
+ , 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 -> MegaBytes -> 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 MegaBytes = MegaBytes Integer
+ deriving (Show)
+
+instance PartedVal MegaBytes where
+ val (MegaBytes n) = show n ++ "MB"
+
+toMegaBytes :: ByteSize -> MegaBytes
+toMegaBytes b = MegaBytes (b `div` 1000000)
+
+instance Monoid MegaBytes where
+ mempty = MegaBytes 0
+ mappend (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 $ if isdev
+ then go (map (\n -> disk ++ show n) [1 :: Int ..])
+ else Partition.kpartx disk go
+ where
+ desc = disk ++ " partitioned"
+ go devs = combineProperties desc $
+ parted eep disk partedparams : 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
index 00000000..41bdf795
--- /dev/null
+++ b/src/Propellor/Property/Partition.hs
@@ -0,0 +1,56 @@
+{-# 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", optsdev, "e2fsprogs")
+ EXT3 -> ("mkfs.ext3", optsdev, "e2fsprogs")
+ EXT4 -> ("mkfs.ext4", optsdev, "e2fsprogs")
+ BTRFS -> ("mkfs.btrfs", optsdev, "btrfs-tools")
+ REISERFS -> ("mkfs.reiserfs", optsdev, "reiserfsprogs")
+ XFS -> ("mkfs.xfs", optsdev, "xfsprogs")
+ FAT -> ("mkfs.fat", optsdev, "dosfstools")
+ VFAT -> ("mkfs.vfat", optsdev, "dosfstools")
+ NTFS -> ("mkfs.ntfs", optsdev, "ntfs-3g")
+ LinuxSwap -> ("mkswap", optsdev, "util-linux")
+ optsdev = opts++[dev]
+
+-- | 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]