summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorSean Whitton2017-11-19 12:04:26 -0700
committerSean Whitton2017-11-19 12:04:26 -0700
commit05e5308ee7cef99b24b4f9d9755e5488f8d92a39 (patch)
tree256b8f20bddf0f0701a3247228f9c2dd77be6e64 /src
parent38d039310e4db6ffaf5c8ca51c339421e6865eff (diff)
parent12beba0367d14f9c52adf72dd36e9cf5a8e35761 (diff)
Merge branch 'master' of https://git.joeyh.name/git/propellor into sbuild-overhaul
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Bootstrap.hs6
-rw-r--r--src/Propellor/Property/Chroot.hs22
-rw-r--r--src/Propellor/Property/Debootstrap.hs37
-rw-r--r--src/Propellor/Property/DiskImage.hs50
-rw-r--r--src/Propellor/Property/DiskImage/PartSpec.hs67
-rw-r--r--src/Propellor/Property/Fail2Ban.hs40
-rw-r--r--src/Propellor/Property/FlashKernel.hs63
-rw-r--r--src/Propellor/Property/Machine.hs164
-rw-r--r--src/Propellor/Property/Mount.hs20
-rw-r--r--src/Propellor/Property/Parted.hs23
-rw-r--r--src/Propellor/Property/Qemu.hs49
-rw-r--r--src/Propellor/Property/Service.hs34
-rw-r--r--src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs2
-rw-r--r--src/Propellor/Property/SiteSpecific/GitHome.hs9
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs50
-rw-r--r--src/Propellor/Property/Uboot.hs36
-rw-r--r--src/Propellor/Types/Bootloader.hs13
-rw-r--r--src/Propellor/Types/PartSpec.hs58
18 files changed, 587 insertions, 156 deletions
diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs
index 170c85d6..04f23f85 100644
--- a/src/Propellor/Bootstrap.hs
+++ b/src/Propellor/Bootstrap.hs
@@ -80,7 +80,7 @@ buildCommand bs = intercalate " && " (go (getBuilder bs))
where
go Cabal =
[ "cabal configure"
- , "cabal build propellor-config"
+ , "cabal build -j1 propellor-config"
, "ln -sf dist/build/propellor-config/propellor-config propellor"
]
go Stack =
@@ -280,7 +280,9 @@ cabalBuild msys = do
boolSystem "sh" [Param "-c", Param (depsCommand (Robustly Cabal) (Just sys))]
<&&> cabal ["configure"]
)
- cabal_build = cabal ["build", "propellor-config"]
+ -- The -j1 is to only run one job at a time -- in some situations,
+ -- eg in qemu, ghc does not run reliably in parallel.
+ cabal_build = cabal ["build", "-j1", "propellor-config"]
stackBuild :: Maybe System -> IO Bool
stackBuild _msys = do
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index ea8b1407..0dd1f05a 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -9,7 +9,6 @@ module Propellor.Property.Chroot (
ChrootBootstrapper(..),
Debootstrapped(..),
ChrootTarball(..),
- noServices,
inChroot,
exposeTrueLocaldir,
-- * Internal use
@@ -32,7 +31,6 @@ import qualified Propellor.Property.Systemd.Core as Systemd
import qualified Propellor.Property.File as File
import qualified Propellor.Shim as Shim
import Propellor.Property.Mount
-import Utility.FileMode
import Utility.Split
import qualified Data.Map as M
@@ -257,26 +255,6 @@ mungeloc = replace "/" "_"
chrootDesc :: Chroot -> String -> String
chrootDesc (Chroot loc _ _ _) desc = "chroot " ++ loc ++ " " ++ desc
--- | Adding this property to a chroot prevents daemons and other services
--- from being started, which is often something you want to prevent when
--- building a chroot.
---
--- On Debian, this is accomplished by installing a </usr/sbin/policy-rc.d>
--- script that does not let any daemons be started by packages that use
--- invoke-rc.d. Reverting the property removes the script.
---
--- This property has no effect on non-Debian systems.
-noServices :: RevertableProperty UnixLike UnixLike
-noServices = setup <!> teardown
- where
- f = "/usr/sbin/policy-rc.d"
- script = [ "#!/bin/sh", "exit 101" ]
- setup = combineProperties "no services started" $ toProps
- [ File.hasContent f script
- , File.mode f (combineModes (readModes ++ executeModes))
- ]
- teardown = File.notPresent f
-
-- | Check if propellor is currently running within a chroot.
--
-- This allows properties to check and avoid performing actions that
diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs
index a9412b95..7c8e9618 100644
--- a/src/Propellor/Property/Debootstrap.hs
+++ b/src/Propellor/Property/Debootstrap.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE TypeFamilies #-}
+
module Propellor.Property.Debootstrap (
Url,
DebootstrapConfig(..),
@@ -6,12 +8,12 @@ module Propellor.Property.Debootstrap (
extractSuite,
installed,
sourceInstall,
- programPath,
) where
import Propellor.Base
import qualified Propellor.Property.Apt as Apt
import Propellor.Property.Chroot.Util
+import Propellor.Property.Qemu
import Utility.Path
import Utility.FileMode
@@ -29,6 +31,7 @@ data DebootstrapConfig
| MinBase
| BuilddD
| DebootstrapParam String
+ | UseEmulation
| DebootstrapConfig :+ DebootstrapConfig
deriving (Show)
@@ -41,15 +44,41 @@ toParams DefaultConfig = []
toParams MinBase = [Param "--variant=minbase"]
toParams BuilddD = [Param "--variant=buildd"]
toParams (DebootstrapParam p) = [Param p]
+toParams UseEmulation = []
toParams (c1 :+ c2) = toParams c1 <> toParams c2
+useEmulation :: DebootstrapConfig -> Bool
+useEmulation UseEmulation = True
+useEmulation (a :+ b) = useEmulation a || useEmulation b
+useEmulation _ = False
+
-- | Builds a chroot in the given directory using debootstrap.
--
-- The System can be any OS and architecture that debootstrap
-- and the kernel support.
+--
+-- When the System is architecture that the kernel does not support,
+-- it can still be bootstrapped using emulation. This is determined
+-- by checking `supportsArch`, or can be configured with `UseEmulation`.
+--
+-- When emulation is used, the chroot will have an additional binary
+-- installed in it. To get a completelty clean chroot (eg for producing a
+-- bootable disk image), use the `removeHostEmulationBinary` property.
built :: FilePath -> System -> DebootstrapConfig -> Property Linux
-built target system config = built' (setupRevertableProperty installed) target system config
+built target system@(System _ targetarch) config =
+ withOS ("debootstrapped " ++ target) go
+ where
+ go w (Just hostos)
+ | supportsArch hostos targetarch && not (useEmulation config) =
+ ensureProperty w $
+ built' (setupRevertableProperty installed)
+ target system config
+ go w _ = ensureProperty w $ do
+ let p = setupRevertableProperty foreignBinariesEmulated
+ `before` setupRevertableProperty installed
+ built' p target system (config :+ UseEmulation)
+-- | Like `built`, but uses the provided Property to install debootstrap.
built' :: Property Linux -> FilePath -> System -> DebootstrapConfig -> Property Linux
built' installprop target system@(System _ arch) config =
go `before` oldpermfix
@@ -68,7 +97,9 @@ built' installprop target system@(System _ arch) config =
, Param suite
, Param target
]
- cmd <- fromMaybe "debootstrap" <$> programPath
+ cmd <- if useEmulation config
+ then pure "qemu-debootstrap"
+ else fromMaybe "debootstrap" <$> programPath
de <- standardPathEnv
ifM (boolSystemEnv cmd params (Just de))
( return MadeChange
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 6c1a572c..2c35b532 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -24,9 +24,12 @@ import Propellor.Property.Chroot (Chroot)
import Propellor.Property.Chroot.Util (removeChroot)
import Propellor.Property.Mount
import qualified Propellor.Property.Chroot as Chroot
+import qualified Propellor.Property.Service as Service
import qualified Propellor.Property.Grub as Grub
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.Qemu as Qemu
+import qualified Propellor.Property.FlashKernel as FlashKernel
import Propellor.Property.Parted
import Propellor.Property.Fstab (SwapPartition(..), genFstab)
import Propellor.Property.Partition
@@ -101,7 +104,7 @@ instance DiskImage VirtualBoxPointer where
-- to avoid expensive IO to generate a new one. And, it's updated in-place,
-- so its contents are undefined during the build process.
--
--- Note that the `Chroot.noServices` property is automatically added to the
+-- Note that the `Service.noServices` property is automatically added to the
-- chroot while the disk image is being built, which should prevent any
-- daemons that are included from being started on the system that is
-- building the disk image.
@@ -183,7 +186,7 @@ imageBuilt' rebuild img mkchroot tabletype partspec =
in setContainerProps c $ containerProps c
-- Before ensuring any other properties of the chroot,
-- avoid starting services. Reverted by imageFinalized.
- &^ Chroot.noServices
+ &^ Service.noServices
& cachesCleaned
-- Only propagate privdata Info from this chroot, nothing else.
propprivdataonly (Chroot.Chroot d b ip h) =
@@ -191,8 +194,14 @@ imageBuilt' rebuild img mkchroot tabletype partspec =
-- Pick boot loader finalization based on which bootloader is
-- installed.
final = case fromInfo (containerInfo chroot) of
- [GrubInstalled] -> grubBooted
[] -> unbootable "no bootloader is installed"
+ [GrubInstalled] -> grubFinalized
+ [UbootInstalled p] -> ubootFinalized p
+ [FlashKernelInstalled] -> flashKernelFinalized
+ [UbootInstalled p, FlashKernelInstalled] ->
+ ubootFlashKernelFinalized p
+ [FlashKernelInstalled, UbootInstalled p] ->
+ ubootFlashKernelFinalized p
_ -> unbootable "multiple bootloaders are installed; don't know which to use"
-- | This property is automatically added to the chroot when building a
@@ -215,7 +224,7 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
liftIO $ unmountBelow chrootdir
szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize
<$> liftIO (dirSizes chrootdir)
- let calcsz mnts = maybe defSz fudge . getMountSz szm mnts
+ let calcsz mnts = maybe defSz fudgeSz . getMountSz szm mnts
-- tie the knot!
let (mnts, mntopts, parttable) = fitChrootSize tabletype partspec $
map (calcsz mnts) mnts
@@ -228,7 +237,7 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
mkimg' mnts mntopts parttable devs =
partitionsPopulated chrootdir mnts mntopts devs
`before`
- imageFinalized final mnts mntopts devs parttable
+ imageFinalized final dest mnts mntopts devs parttable
rmimg = undoRevertableProperty (buildDiskImage img)
`before` undoRevertableProperty (imageExists' dest dummyparttable)
dummyparttable = PartTable tabletype []
@@ -351,10 +360,10 @@ imageExists' dest@(RawDiskImage img) parttable = (setup <!> cleanup) `describe`
--
-- It's ok if the property leaves additional things mounted
-- in the partition tree.
-type Finalization = (FilePath -> [LoopDev] -> Property Linux)
+type Finalization = (RawDiskImage -> FilePath -> [LoopDev] -> Property Linux)
-imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux
-imageFinalized final mnts mntopts devs (PartTable _ parts) =
+imageFinalized :: Finalization -> RawDiskImage -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux
+imageFinalized final img mnts mntopts devs (PartTable _ parts) =
property' "disk image finalized" $ \w ->
withTmpDir "mnt" $ \top ->
go w top `finally` liftIO (unmountall top)
@@ -363,7 +372,9 @@ imageFinalized final mnts mntopts devs (PartTable _ parts) =
liftIO $ mountall top
liftIO $ writefstab top
liftIO $ allowservices top
- ensureProperty w $ final top devs
+ ensureProperty w $
+ final img top devs
+ `before` Qemu.removeHostEmulationBinary top
-- Ordered lexographically by mount point, so / comes before /usr
-- comes before /usr/local
@@ -399,18 +410,14 @@ imageFinalized final mnts mntopts devs (PartTable _ parts) =
allowservices top = nukeFile (top ++ "/usr/sbin/policy-rc.d")
unbootable :: String -> Finalization
-unbootable msg = \_ _ -> property desc $ do
+unbootable msg = \_ _ _ -> property desc $ do
warningMessage (desc ++ ": " ++ msg)
return FailedChange
where
desc = "image is not bootable"
--- | Makes grub be the boot loader of the disk image.
---
--- This does not install the grub package. You will need to add
--- the `Grub.installed` property to the chroot.
-grubBooted :: Finalization
-grubBooted mnt loopdevs = Grub.bootsMounted mnt wholediskloopdev
+grubFinalized :: Finalization
+grubFinalized _img mnt loopdevs = Grub.bootsMounted mnt wholediskloopdev
`describe` "disk image boots using grub"
where
-- It doesn't matter which loopdev we use; all
@@ -420,6 +427,17 @@ grubBooted mnt loopdevs = Grub.bootsMounted mnt wholediskloopdev
(l:_) -> wholeDiskLoopDev l
[] -> error "No loop devs provided!"
+ubootFinalized :: (FilePath -> FilePath -> Property Linux) -> Finalization
+ubootFinalized p (RawDiskImage img) mnt _loopdevs = p img mnt
+
+flashKernelFinalized :: Finalization
+flashKernelFinalized _img mnt _loopdevs = FlashKernel.flashKernelMounted mnt
+
+ubootFlashKernelFinalized :: (FilePath -> FilePath -> Property Linux) -> Finalization
+ubootFlashKernelFinalized p img mnt loopdevs =
+ ubootFinalized p img mnt loopdevs
+ `before` flashKernelFinalized img mnt loopdevs
+
isChild :: FilePath -> Maybe MountPoint -> Bool
isChild mntpt (Just d)
| d `equalFilePath` mntpt = False
diff --git a/src/Propellor/Property/DiskImage/PartSpec.hs b/src/Propellor/Property/DiskImage/PartSpec.hs
index 55249889..f7492589 100644
--- a/src/Propellor/Property/DiskImage/PartSpec.hs
+++ b/src/Propellor/Property/DiskImage/PartSpec.hs
@@ -1,10 +1,5 @@
-- | Disk image partition specification and combinators.
--- Partitions in disk images default to being sized large enough 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.
-
module Propellor.Property.DiskImage.PartSpec (
module Propellor.Types.PartSpec,
module Propellor.Property.DiskImage.PartSpec,
@@ -17,17 +12,63 @@ import Propellor.Property.Parted
import Propellor.Types.PartSpec
import Propellor.Property.Parted.Types
import Propellor.Property.Partition (Fs(..))
+import Propellor.Property.Mount
+
+-- | Specifies a partition with a given filesystem.
+--
+-- The partition is not mounted anywhere by default; use the combinators
+-- below to configure it.
+partition :: Monoid t => Fs -> PartSpec t
+partition fs = (Nothing, mempty, mkPartition fs, mempty)
+
+-- | Specifies a swap partition of a given size.
+swapPartition :: Monoid t => PartSize -> PartSpec t
+swapPartition sz = (Nothing, mempty, const (mkPartition LinuxSwap sz), mempty)
--- | Adds additional free space to the partition.
+-- | Specifies where to mount a partition.
+mountedAt :: PartSpec t -> FilePath -> PartSpec t
+mountedAt (_, o, p, t) mp = (Just mp, o, p, t)
+
+-- | Partitions in disk images default to being sized large enough to hold
+-- the files that live in that partition.
+--
+-- This adds additional free space to a partition.
addFreeSpace :: PartSpec t -> PartSize -> PartSpec t
addFreeSpace (mp, o, p, t) freesz = (mp, o, p', t)
where
p' = \sz -> p (sz <> freesz)
--- | 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
--- non-scaling overhead of filesystems (eg, superblocks).
--- Add an additional 200 mb for temp files, journals, etc.
-fudge :: PartSize -> PartSize
-fudge (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3 + 200)
+-- | Specify a fixed size for a partition.
+setSize :: PartSpec t -> PartSize -> PartSpec t
+setSize (mp, o, p, t) sz = (mp, o, const (p sz), t)
+
+-- | Specifies a mount option, such as "noexec"
+mountOpt :: ToMountOpts o => PartSpec t -> o -> PartSpec t
+mountOpt (mp, o, p, t) o' = (mp, o <> toMountOpts o', p, t)
+
+-- | Mount option to make a partition be remounted readonly when there's an
+-- error accessing it.
+errorReadonly :: MountOpts
+errorReadonly = toMountOpts "errors=remount-ro"
+
+-- | Sets the percent of the filesystem blocks reserved for the super-user.
+--
+-- The default is 5% for ext2 and ext4. Some filesystems may not support
+-- this.
+reservedSpacePercentage :: PartSpec t -> Int -> PartSpec t
+reservedSpacePercentage s percent = adjustp s $ \p ->
+ p { partMkFsOpts = ("-m"):show percent:partMkFsOpts p }
+
+-- | Sets a flag on the partition.
+setFlag :: PartSpec t -> PartFlag -> PartSpec t
+setFlag s f = adjustp s $ \p -> p { partFlags = (f, True):partFlags p }
+
+-- | Makes a MSDOS partition be Extended, rather than Primary.
+extended :: PartSpec t -> PartSpec t
+extended s = adjustp s $ \p -> p { partType = Extended }
+
+adjustp :: PartSpec t -> (Partition -> Partition) -> PartSpec t
+adjustp (mp, o, p, t) f = (mp, o, f . p, t)
+
+adjustt :: PartSpec t -> (t -> t) -> PartSpec t
+adjustt (mp, o, p, t) f = (mp, o, p, f t)
diff --git a/src/Propellor/Property/Fail2Ban.hs b/src/Propellor/Property/Fail2Ban.hs
index 9f147943..342e2acb 100644
--- a/src/Propellor/Property/Fail2Ban.hs
+++ b/src/Propellor/Property/Fail2Ban.hs
@@ -2,6 +2,7 @@ module Propellor.Property.Fail2Ban where
import Propellor.Base
import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.File as File
import qualified Propellor.Property.Service as Service
import Propellor.Property.ConfFile
@@ -13,18 +14,47 @@ reloaded = Service.reloaded "fail2ban"
type Jail = String
+type Filter = String
+
+type Action = String
+
-- | By default, fail2ban only enables the ssh jail, but many others
-- are available to be enabled, for example "postfix-sasl"
jailEnabled :: Jail -> Property DebianLike
-jailEnabled name = jailConfigured name "enabled" "true"
+jailEnabled name = jailEnabled' name []
+ `onChange` reloaded
+
+jailEnabled' :: Jail -> [(IniKey, String)] -> Property DebianLike
+jailEnabled' name settings =
+ jailConfigured' name (("enabled", "true") : settings)
`onChange` reloaded
-- | Configures a jail. For example:
--
--- > jailConfigured "sshd" "port" "2222"
+-- > jailConfigured' "sshd" [("port", "2222")]
+jailConfigured' :: Jail -> [(IniKey, String)] -> Property UnixLike
+jailConfigured' name settings = propertyList ("jail \"" ++ name ++ "\" configuration") $ props
+ -- removes .conf files added by old versions of Fail2Ban properties
+ & File.notPresent (oldJailConfFile name)
+ & jailConfFile name `iniFileContains` [(name, settings)]
+
+-- | Adds a setting to a given jail. For example:
+--
+-- > jailConfigured "sshd" "port" "2222"
jailConfigured :: Jail -> IniKey -> String -> Property UnixLike
-jailConfigured name key value =
- jailConfFile name `containsIniSetting` (name, key, value)
+jailConfigured name key value = propertyList ("jail \"" ++ name ++ "\" configuration") $ props
+ -- removes .conf files added by old versions of Fail2Ban properties
+ & File.notPresent (oldJailConfFile name)
+ & jailConfFile name `containsIniSetting` (name, key, value)
+
+oldJailConfFile :: Jail -> FilePath
+oldJailConfFile name = "/etc/fail2ban/jail.d/" ++ name ++ ".conf"
jailConfFile :: Jail -> FilePath
-jailConfFile name = "/etc/fail2ban/jail.d/" ++ name ++ ".conf"
+jailConfFile name = "/etc/fail2ban/jail.d/" ++ name ++ ".local"
+
+filterConfFile :: Filter -> FilePath
+filterConfFile name = "/etc/fail2ban/filter.d/" ++ name ++ ".local"
+
+actionConfFile :: Action -> FilePath
+actionConfFile name = "/etc/fail2ban/action.d/" ++ name ++ ".local"
diff --git a/src/Propellor/Property/FlashKernel.hs b/src/Propellor/Property/FlashKernel.hs
new file mode 100644
index 00000000..3f65f872
--- /dev/null
+++ b/src/Propellor/Property/FlashKernel.hs
@@ -0,0 +1,63 @@
+-- | Make ARM systems bootable using Debian's flash-kernel package.
+
+module Propellor.Property.FlashKernel where
+
+import Propellor.Base
+import qualified Propellor.Property.File as File
+import qualified Propellor.Property.Apt as Apt
+import Propellor.Property.Mount
+import Propellor.Types.Bootloader
+import Propellor.Types.Info
+
+-- | A machine name, such as "Cubietech Cubietruck" or "Olimex A10-OLinuXino-LIME"
+--
+-- flash-kernel supports many different machines,
+-- see its file /usr/share/flash-kernel/db/all.db for a list.
+type Machine = String
+
+-- | Uses flash-kernel to make a machine bootable.
+--
+-- Before using this, an appropriate kernel needs to already be installed,
+-- and on many machines, u-boot needs to be installed too.
+installed :: Machine -> Property (HasInfo + DebianLike)
+installed machine = setInfoProperty go (toInfo [FlashKernelInstalled])
+ where
+ go = "/etc/flash-kernel/machine" `File.hasContent` [machine]
+ `onChange` (cmdProperty "flash-kernel" [] `assume` MadeChange)
+ `requires` File.dirExists "/etc/flash-kernel"
+ `requires` Apt.installed ["flash-kernel"]
+
+-- | Runs flash-kernel in the system mounted at a particular directory.
+flashKernelMounted :: FilePath -> Property Linux
+flashKernelMounted mnt = combineProperties desc $ props
+ -- remove mounts that are done below to make sure the right thing
+ -- gets mounted
+ & cleanupmounts
+ & bindMount "/dev" (inmnt "/dev")
+ & mounted "proc" "proc" (inmnt "/proc") mempty
+ & mounted "sysfs" "sys" (inmnt "/sys") mempty
+ -- update the initramfs so it gets the uuid of the root partition
+ & inchroot "update-initramfs" ["-u"]
+ `assume` MadeChange
+ & inchroot "flash-kernel" []
+ `assume` MadeChange
+ & cleanupmounts
+ where
+ desc = "flash-kernel run"
+
+ -- cannot use </> since the filepath is absolute
+ inmnt f = mnt ++ f
+
+ inchroot cmd ps = cmdProperty "chroot" ([mnt, cmd] ++ ps)
+
+ cleanupmounts :: Property Linux
+ cleanupmounts = property desc $ liftIO $ do
+ cleanup "/sys"
+ cleanup "/proc"
+ cleanup "/dev"
+ return NoChange
+ where
+ cleanup m =
+ let mp = inmnt m
+ in whenM (isMounted mp) $
+ umountLazy mp
diff --git a/src/Propellor/Property/Machine.hs b/src/Propellor/Property/Machine.hs
new file mode 100644
index 00000000..b4ffc008
--- /dev/null
+++ b/src/Propellor/Property/Machine.hs
@@ -0,0 +1,164 @@
+-- | Machine-specific properties.
+--
+-- Many embedded computers have their own special configuration needed
+-- to use them. Rather than needing to hunt down documentation about the
+-- kernel, bootloader, etc for a given machine, if there's a property
+-- in here for your machine, you can simply use it.
+--
+-- Not all machine properties have been tested yet. If one flagged as
+-- untested and you find it works, please let us know.
+--
+-- You will need to configure the `Host` with the right `Architecture`
+-- for the machine. These properties do test at runtime that a supported
+-- Architecture was selected.
+--
+-- Sometimes non-free firmware is needed to use a board. If the board won't
+-- be functional at all without it, its property will include the non-free
+-- firmware, but if the non-free firmware is only needed for non-critical
+-- functionality, it won't be included.
+
+module Propellor.Property.Machine (
+ -- * ARM boards
+ Marvell_SheevaPlug_BootDevice(..),
+ marvell_SheevaPlug,
+ cubietech_Cubietruck,
+ olimex_A10_OLinuXino_LIME,
+ -- * ARM boards (untested)
+ cubietech_Cubieboard,
+ cubietech_Cubieboard2,
+ lemaker_Banana_Pi,
+ lemaker_Banana_Pro,
+ olimex_A10s_OLinuXino_Micro,
+ olimex_A20_OLinuXino_LIME,
+ olimex_A20_OLinuXino_LIME2,
+ olimex_A20_OLinuXino_Micro,
+ olimex_A20_SOM_EVB,
+ linkSprite_pcDuino3_Nano,
+) where
+
+import Propellor.Base
+import Propellor.Types.Core
+import qualified Propellor.Property.Apt as Apt
+import qualified Propellor.Property.FlashKernel as FlashKernel
+import qualified Propellor.Property.Uboot as Uboot
+
+data Marvell_SheevaPlug_BootDevice
+ = Marvell_SheevaPlug_SDCard
+ | Marvell_SheevaPlug_ESATA
+
+-- | Marvel SheevaPlug
+--
+-- Needs a small /boot partition formatted EXT2
+--
+-- Note that u-boot may need to be upgraded manually, and will need to be
+-- configured to boot from the SD card or eSATA. See
+-- https://www.cyrius.com/debian/kirkwood/sheevaplug/install/
+marvell_SheevaPlug :: Marvell_SheevaPlug_BootDevice -> Property (HasInfo + DebianLike)
+marvell_SheevaPlug Marvell_SheevaPlug_SDCard =
+ FlashKernel.installed "Marvell SheevaPlug Reference Board"
+ `requires` marvell
+marvell_SheevaPlug Marvell_SheevaPlug_ESATA =
+ FlashKernel.installed "Marvell eSATA SheevaPlug Reference Board"
+ `requires` marvell
+
+-- | Cubietech Cubietruck
+--
+-- Wifi needs non-free firmware-brcm80211, which is not installed by
+-- this property. Also, see https://bugs.debian.org/844056
+cubietech_Cubietruck :: Property (HasInfo + DebianLike)
+cubietech_Cubietruck = FlashKernel.installed "Cubietech Cubietruck"
+ `requires` sunixi "Cubietruck"
+ `requires` lpae
+
+-- | Cubietech Cubieboard (untested)
+cubietech_Cubieboard :: Property (HasInfo + DebianLike)
+cubietech_Cubieboard = FlashKernel.installed "Cubietech Cubieboard"
+ `requires` sunixi "Cubieboard"
+ `requires` armmp
+
+-- | Cubietech Cubieboard2 (untested)
+cubietech_Cubieboard2 :: Property (HasInfo + DebianLike)
+cubietech_Cubieboard2 = FlashKernel.installed "Cubietech Cubieboard2"
+ `requires` sunixi "Cubieboard2"
+ `requires` lpae
+
+-- | LeMaker Banana Pi
+lemaker_Banana_Pi :: Property (HasInfo + DebianLike)
+lemaker_Banana_Pi = FlashKernel.installed "LeMaker Banana Pi"
+ `requires` sunixi "Bananapi"
+ `requires` lpae
+
+-- | LeMaker Banana Pro (untested)
+lemaker_Banana_Pro :: Property (HasInfo + DebianLike)
+lemaker_Banana_Pro = FlashKernel.installed "LeMaker Banana Pro"
+ `requires` sunixi "Bananapro"
+ `requires` lpae
+
+-- | Olimex A10-OLinuXino-LIME
+olimex_A10_OLinuXino_LIME :: Property (HasInfo + DebianLike)
+olimex_A10_OLinuXino_LIME = FlashKernel.installed "Olimex A10-OLinuXino-LIME"
+ `requires` sunixi "A10-OLinuXino-Lime"
+ `requires` armmp
+
+-- | Olimex A10s-Olinuxino Micro (untested)
+olimex_A10s_OLinuXino_Micro :: Property (HasInfo + DebianLike)
+olimex_A10s_OLinuXino_Micro = FlashKernel.installed "Olimex A10s-Olinuxino Micro"
+ `requires` sunixi "A10s-OLinuXino-M"
+ `requires` armmp
+
+-- | Olimex A20-OlinuXino-LIME (untested)
+olimex_A20_OLinuXino_LIME :: Property (HasInfo + DebianLike)
+olimex_A20_OLinuXino_LIME = FlashKernel.installed "Olimex A20-OLinuXino-LIME"
+ `requires` sunixi "A20-OLinuXino-Lime"
+ `requires` lpae
+
+-- | Olimex A20-OlinuXino-LIME2 (untested)
+olimex_A20_OLinuXino_LIME2 :: Property (HasInfo + DebianLike)
+olimex_A20_OLinuXino_LIME2 = FlashKernel.installed "Olimex A20-OLinuXino-LIME2"
+ `requires` sunixi "A20-OLinuXino-Lime2"
+ `requires` lpae
+
+-- | Olimex A20-Olinuxino Micro (untested)
+olimex_A20_OLinuXino_Micro :: Property (HasInfo + DebianLike)
+olimex_A20_OLinuXino_Micro = FlashKernel.installed "Olimex A20-Olinuxino Micro"
+ `requires` sunixi "A20-OLinuXino-MICRO"
+ `requires` lpae
+
+-- | Olimex A20-SOM-EVB (untested)
+olimex_A20_SOM_EVB :: Property (HasInfo + DebianLike)
+olimex_A20_SOM_EVB = FlashKernel.installed "Olimex A20-Olimex-SOM-EVB"
+ `requires` sunixi "A20-Olimex-SOM-EVB"
+ `requires` lpae
+
+-- | LinkSprite pcDuino Nano (untested)
+--
+-- Needs non-free firmware, see
+-- https://wiki.debian.org/InstallingDebianOn/Allwinner
+linkSprite_pcDuino3_Nano :: Property (HasInfo + DebianLike)
+linkSprite_pcDuino3_Nano = FlashKernel.installed "LinkSprite pcDuino3 Nano"
+ `requires` sunixi "Linksprite_pcDuino3"
+ `requires` lpae
+
+sunixi :: Uboot.BoardName -> Property (HasInfo + DebianLike)
+sunixi boardname = Uboot.sunxi boardname
+ `requires` Apt.installed
+ [ "firmware-linux-free"
+ , "sunxi-tools"
+ ]
+
+armmp :: Property DebianLike
+armmp = checkArchitecture [ARMHF, ARMEL] $
+ Apt.installed ["linux-image-armmp"]
+
+lpae :: Property DebianLike
+lpae = checkArchitecture [ARMHF, ARMEL] $
+ Apt.installed ["linux-image-armmp-lpae"]
+
+marvell :: Property DebianLike
+marvell = checkArchitecture [ARMEL] $
+ Apt.installed ["linux-image-marvell"]
+
+checkArchitecture :: [Architecture] -> Property DebianLike -> Property DebianLike
+checkArchitecture as p = withOS (getDesc p) $ \w o -> case o of
+ (Just (System _ arch)) | arch `elem` as -> ensureProperty w p
+ _ -> error $ "Machine needs architecture to be one of: " ++ show as
diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs
index 2c4d9620..c047161d 100644
--- a/src/Propellor/Property/Mount.hs
+++ b/src/Propellor/Property/Mount.hs
@@ -90,18 +90,18 @@ mountPointsBelow target = filter (\p -> simplifyPath p /= simplifyPath target)
-- | Filesystem type mounted at a given location.
getFsType :: MountPoint -> IO (Maybe FsType)
-getFsType = findmntField "fstype"
+getFsType p = findmntField "fstype" [p]
-- | Mount options for the filesystem mounted at a given location.
getFsMountOpts :: MountPoint -> IO MountOpts
getFsMountOpts p = maybe mempty toMountOpts
- <$> findmntField "fs-options" p
+ <$> findmntField "fs-options" [p]
type UUID = String
-- | UUID of filesystem mounted at a given location.
getMountUUID :: MountPoint -> IO (Maybe UUID)
-getMountUUID = findmntField "uuid"
+getMountUUID p = findmntField "uuid" [p]
-- | UUID of a device
getSourceUUID :: Source -> IO (Maybe UUID)
@@ -111,7 +111,7 @@ type Label = String
-- | Label of filesystem mounted at a given location.
getMountLabel :: MountPoint -> IO (Maybe Label)
-getMountLabel = findmntField "label"
+getMountLabel p = findmntField "label" [p]
-- | Label of a device
getSourceLabel :: Source -> IO (Maybe UUID)
@@ -119,12 +119,16 @@ getSourceLabel = blkidTag "LABEL"
-- | Device mounted at a given location.
getMountSource :: MountPoint -> IO (Maybe Source)
-getMountSource = findmntField "source"
+getMountSource p = findmntField "source" [p]
-findmntField :: String -> FilePath -> IO (Maybe String)
-findmntField field mnt = catchDefaultIO Nothing $
+-- | Device that a given path is located within.
+getMountContaining :: FilePath -> IO (Maybe Source)
+getMountContaining p = findmntField "source" ["-T", p]
+
+findmntField :: String -> [String] -> IO (Maybe String)
+findmntField field ps = catchDefaultIO Nothing $
headMaybe . filter (not . null) . lines
- <$> readProcess "findmnt" ["-n", mnt, "--output", field]
+ <$> readProcess "findmnt" ("-n" : ps ++ ["--output", field])
blkidTag :: String -> Source -> IO (Maybe String)
blkidTag tag dev = catchDefaultIO Nothing $
diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs
index 43744142..d60d4a60 100644
--- a/src/Propellor/Property/Parted.hs
+++ b/src/Propellor/Property/Parted.hs
@@ -21,13 +21,14 @@ module Propellor.Property.Parted (
parted,
Eep(..),
installed,
- -- * PartSpec combinators
+ -- * Partition table sizing
calcPartTable,
DiskSize(..),
DiskPart,
- module Propellor.Types.PartSpec,
DiskSpaceUse(..),
useDiskSpace,
+ defSz,
+ fudgeSz,
) where
import Propellor.Base
@@ -35,7 +36,7 @@ import Propellor.Property.Parted.Types
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Pacman as Pacman
import qualified Propellor.Property.Partition as Partition
-import Propellor.Types.PartSpec
+import Propellor.Types.PartSpec (PartSpec)
import Utility.DataUnits
import System.Posix.Files
@@ -160,3 +161,19 @@ instance Monoid DiskPart
-- (less all fixed size partitions), or the remaining space in the disk.
useDiskSpace :: PartSpec DiskPart -> DiskSpaceUse -> PartSpec DiskPart
useDiskSpace (mp, o, p, _) diskuse = (mp, o, p, DynamicDiskPart diskuse)
+
+-- | Default partition size when not otherwize specified is 128 MegaBytes.
+defSz :: PartSize
+defSz = MegaBytes 128
+
+-- | When a partition is sized to fit the files that live in it,
+-- this fudge factor is added to the size of the files. This is necessary
+-- since filesystems have some space overhead.
+--
+-- 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
+-- non-scaling overhead of filesystems (eg, superblocks).
+-- Add an additional 200 mb for temp files, journals, etc.
+fudgeSz :: PartSize -> PartSize
+fudgeSz (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3 + 200)
diff --git a/src/Propellor/Property/Qemu.hs b/src/Propellor/Property/Qemu.hs
new file mode 100644
index 00000000..f204a0e1
--- /dev/null
+++ b/src/Propellor/Property/Qemu.hs
@@ -0,0 +1,49 @@
+module Propellor.Property.Qemu where
+
+import Propellor.Base
+import qualified Propellor.Property.Apt as Apt
+
+-- | Installs qemu user mode emulation binaries, built statically,
+-- which allow foreign binaries to run directly.
+foreignBinariesEmulated :: RevertableProperty Linux Linux
+foreignBinariesEmulated = (setup <!> cleanup)
+ `describe` "foreign binary emulation"
+ where
+ setup = Apt.installed p `pickOS` unsupportedOS
+ cleanup = Apt.removed p `pickOS` unsupportedOS
+ p = ["qemu-user-static"]
+
+-- | Removes qemu user mode emulation binary for the host CPU.
+-- This binary is copied into a chroot by qemu-debootstrap, and is not
+-- part of any package.
+--
+-- Note that removing the binary will prevent using the chroot on the host
+-- system.
+--
+-- The FilePath is the path to the top of the chroot.
+removeHostEmulationBinary :: FilePath -> Property Linux
+removeHostEmulationBinary top = tightenTargets $
+ scriptProperty ["rm -f " ++ top ++ "/usr/bin/qemu-*-static"]
+ `assume` MadeChange
+
+-- | Check if the given System supports an Architecture.
+--
+-- For example, on Debian, X86_64 supports X86_32, and vice-versa.
+supportsArch :: System -> Architecture -> Bool
+supportsArch (System os a) b
+ | a == b = True
+ | otherwise = case os of
+ Debian _ _ -> debianlike
+ Buntish _ -> debianlike
+ -- don't know about other OS's
+ _ -> False
+ where
+ debianlike =
+ let l =
+ [ (X86_64, X86_32)
+ , (ARMHF, ARMEL)
+ , (PPC, PPC64)
+ , (SPARC, SPARC64)
+ , (S390, S390X)
+ ]
+ in elem (a, b) l || elem (b, a) l
diff --git a/src/Propellor/Property/Service.hs b/src/Propellor/Property/Service.hs
index 46f9e8ef..1c230ce0 100644
--- a/src/Propellor/Property/Service.hs
+++ b/src/Propellor/Property/Service.hs
@@ -1,6 +1,11 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
module Propellor.Property.Service where
import Propellor.Base
+import Propellor.Types.Info
+import qualified Propellor.Property.File as File
+import Utility.FileMode
type ServiceName = String
@@ -21,7 +26,34 @@ reloaded :: ServiceName -> Property DebianLike
reloaded = signaled "reload" "reloaded"
signaled :: String -> Desc -> ServiceName -> Property DebianLike
-signaled cmd desc svc = tightenTargets $ p `describe` (desc ++ " " ++ svc)
+signaled cmd desc svc = check (not <$> servicesDisabled) $
+ tightenTargets $ p `describe` (desc ++ " " ++ svc)
where
p = scriptProperty ["service " ++ shellEscape svc ++ " " ++ cmd ++ " >/dev/null 2>&1 || true"]
`assume` NoChange
+
+-- | This property prevents daemons and other services from being started,
+-- which is often something you want to prevent when building a chroot.
+--
+-- When this is set, `running` and `restarted` will not start services.
+--
+-- On Debian this installs a </usr/sbin/policy-rc.d> script to further
+-- prevent any packages that get installed from starting daemons.
+-- Reverting the property removes the script.
+noServices :: RevertableProperty (HasInfo + UnixLike) UnixLike
+noServices = (setup `setInfoProperty` toInfo (InfoVal NoServices)) <!> teardown
+ where
+ f = "/usr/sbin/policy-rc.d"
+ script = [ "#!/bin/sh", "exit 101" ]
+ setup = combineProperties "no services started" $ toProps
+ [ File.hasContent f script
+ , File.mode f (combineModes (readModes ++ executeModes))
+ ]
+ teardown = File.notPresent f
+
+-- | Check if the noServices property is in effect.
+servicesDisabled :: Propellor Bool
+servicesDisabled = isJust . fromInfoVal
+ <$> (askInfo :: Propellor (InfoVal NoServices))
+
+data NoServices = NoServices deriving (Eq, Show, Typeable)
diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
index bd4d0928..dd1085d7 100644
--- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
+++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
@@ -119,10 +119,10 @@ standardAutoBuilder :: DebianSuite -> Architecture -> Flavor -> Property (HasInf
standardAutoBuilder suite arch flavor =
propertyList "standard git-annex autobuilder" $ props
& osDebian suite arch
- & buildDepsApt
& Apt.stdSourcesList
& Apt.unattendedUpgrades
& Apt.cacheCleaned
+ & buildDepsApt
& User.accountFor (User builduser)
& tree (architectureToDebianArchString arch) flavor
diff --git a/src/Propellor/Property/SiteSpecific/GitHome.hs b/src/Propellor/Property/SiteSpecific/GitHome.hs
index f14b5f12..2a66d1e2 100644
--- a/src/Propellor/Property/SiteSpecific/GitHome.hs
+++ b/src/Propellor/Property/SiteSpecific/GitHome.hs
@@ -20,7 +20,14 @@ installedFor user@(User u) = check (not <$> hasGitDir user) $
moveout tmpdir home
, property "rmdir" $ makeChange $ void $
catchMaybeIO $ removeDirectory tmpdir
- , userScriptProperty user ["rm -rf .aptitude/ .bashrc .profile; bin/mr checkout; bin/fixups"]
+ , userScriptProperty user ["rm -rf .aptitude/ .bashrc .profile"]
+ `assume` MadeChange
+ -- Set HOSTNAME so that this sees the right
+ -- hostname when run in a chroot with a different
+ -- hostname than the current one.
+ , userScriptProperty user ["HOSTNAME=$(cat /etc/hostname) bin/mr checkout"]
+ `assume` MadeChange
+ , userScriptProperty user ["bin/fixups"]
`assume` MadeChange
]
moveout tmpdir home = do
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index 7812c855..097171a3 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -912,16 +912,20 @@ alarmClock oncalendar (User user) command = combineProperties "goodmorning timer
homePowerMonitor :: IsContext c => User -> c -> (SshKeyType, Ssh.PubKeyText) -> Property (HasInfo + DebianLike)
homePowerMonitor user ctx sshkey = propertyList "home power monitor" $ props
& Apache.installed
- & Apt.installed ["python", "python-pymodbus"]
+ & Apt.installed ["python", "python-pymodbus", "rrdtool"]
& File.ownerGroup "/var/www/html" user (userGroup user)
& Git.cloned user "git://git.kitenet.net/joey/homepower" d Nothing
- `onChange` buildpoller
+ & buildpoller
& Systemd.enabled servicename
`requires` serviceinstalled
`onChange` Systemd.started servicename
+ & User.hasGroup user (Group "dialout")
& Cron.niceJob "homepower upload"
(Cron.Times "1 * * * *") user d rsynccommand
`requires` Ssh.userKeyAt (Just sshkeyfile) user ctx sshkey
+ `requires` File.ownerGroup (takeDirectory sshkeyfile)
+ user (userGroup user)
+ `requires` File.dirExists (takeDirectory sshkeyfile)
where
d = "/var/www/html/homepower"
sshkeyfile = d </> ".ssh/key"
@@ -957,30 +961,34 @@ homeRouter :: Property (HasInfo + DebianLike)
homeRouter = propertyList "home router" $ props
& Network.static "wlan0" (IPv4 "10.1.1.1") Nothing
`requires` Network.cleanInterfacesFile
- & Apt.serviceInstalledRunning "hostapd"
- `requires` File.hasContent "/etc/hostapd/hostapd.conf"
+ & Apt.installed ["hostapd"]
+ & File.hasContent "/etc/hostapd/hostapd.conf"
[ "interface=wlan0"
, "ssid=house"
, "hw_mode=g"
, "channel=8"
]
- `requires` File.dirExists "/lib/hostapd"
- & Apt.serviceInstalledRunning "dnsmasq"
- `requires` File.hasContent "/etc/dnsmasq.conf"
- [ "domain-needed"
- , "bogus-priv"
- , "interface=wlan0"
- , "domain=kitenet.net"
- , "dhcp-range=10.1.1.100,10.1.1.150,24h"
- , "no-hosts"
- , "address=/honeybee.kitenet.net/10.1.1.1"
- ]
- `requires` File.hasContent "/etc/resolv.conf"
- [ "domain kitenet.net"
- , "search kitenet.net"
- , "nameserver 8.8.8.8"
- , "nameserver 8.8.4.4"
- ]
+ `requires` File.dirExists "/etc/hostapd"
+ `requires` File.hasContent "/etc/default/hostapd"
+ [ "DAEMON_CONF=/etc/hostapd/hostapd.conf" ]
+ `onChange` Service.running "hostapd"
+ & File.hasContent "/etc/resolv.conf"
+ [ "domain kitenet.net"
+ , "search kitenet.net"
+ , "nameserver 8.8.8.8"
+ , "nameserver 8.8.4.4"
+ ]
+ & Apt.installed ["dnsmasq"]
+ & File.hasContent "/etc/dnsmasq.conf"
+ [ "domain-needed"
+ , "bogus-priv"
+ , "interface=wlan0"
+ , "domain=kitenet.net"
+ , "dhcp-range=10.1.1.100,10.1.1.150,24h"
+ , "no-hosts"
+ , "address=/honeybee.kitenet.net/10.1.1.1"
+ ]
+ `onChange` Service.restarted "dnsmasq"
& ipmasq "wlan0"
& Apt.serviceInstalledRunning "netplug"
& Network.dhcp' "eth0"
diff --git a/src/Propellor/Property/Uboot.hs b/src/Propellor/Property/Uboot.hs
new file mode 100644
index 00000000..562d2441
--- /dev/null
+++ b/src/Propellor/Property/Uboot.hs
@@ -0,0 +1,36 @@
+module Propellor.Property.Uboot where
+
+import Propellor.Base
+import Propellor.Types.Info
+import Propellor.Types.Bootloader
+import Propellor.Property.Chroot
+import Propellor.Property.Mount
+import qualified Propellor.Property.Apt as Apt
+
+-- | Name of a board.
+type BoardName = String
+
+-- | Installs u-boot for Allwinner/sunxi platforms.
+--
+-- This includes writing it to the boot sector.
+sunxi :: BoardName -> Property (HasInfo + DebianLike)
+sunxi boardname = setInfoProperty (check (not <$> inChroot) go) info
+ `requires` Apt.installed ["u-boot", "u-boot-sunxi"]
+ where
+ go :: Property Linux
+ go = property' "u-boot installed" $ \w -> do
+ v <- liftIO $ getMountContaining "/boot"
+ case v of
+ Nothing -> error "unable to determine boot device"
+ Just dev -> ensureProperty w (dd dev "/")
+ dd :: FilePath -> FilePath -> Property Linux
+ dd dev prefix = tightenTargets $ cmdProperty "dd"
+ [ "conv=fsync,notrunc"
+ , "if=" ++ prefix ++ "/usr/lib/u-boot/"
+ ++ boardname ++ "/u-boot-sunxi-with-spl.bin"
+ , "of=" ++ dev
+ , "bs=1024"
+ , "seek=8"
+ ]
+ `assume` NoChange
+ info = toInfo [UbootInstalled dd]
diff --git a/src/Propellor/Types/Bootloader.hs b/src/Propellor/Types/Bootloader.hs
index 4a75503a..fd929d7e 100644
--- a/src/Propellor/Types/Bootloader.hs
+++ b/src/Propellor/Types/Bootloader.hs
@@ -2,11 +2,20 @@
module Propellor.Types.Bootloader where
+import Propellor.Types
import Propellor.Types.Info
-- | Boot loader installed on a host.
-data BootloaderInstalled = GrubInstalled
- deriving (Typeable, Show)
+data BootloaderInstalled
+ = GrubInstalled
+ | FlashKernelInstalled
+ | UbootInstalled (FilePath -> FilePath -> Property Linux)
+ deriving (Typeable)
+
+instance Show BootloaderInstalled where
+ show GrubInstalled = "GrubInstalled"
+ show FlashKernelInstalled = "FlashKernelInstalled"
+ show (UbootInstalled _) = "UbootInstalled"
instance IsInfo [BootloaderInstalled] where
propagateInfo _ = PropagateInfo False
diff --git a/src/Propellor/Types/PartSpec.hs b/src/Propellor/Types/PartSpec.hs
index 2b0a8787..860b38f6 100644
--- a/src/Propellor/Types/PartSpec.hs
+++ b/src/Propellor/Types/PartSpec.hs
@@ -1,66 +1,8 @@
--- | Partition specification combinators.
-
module Propellor.Types.PartSpec where
-import Propellor.Base
import Propellor.Property.Parted.Types
import Propellor.Property.Mount
-import Propellor.Property.Partition
-- | Specifies a mount point, mount options, and a constructor for a
-- Partition that determines its size.
type PartSpec t = (Maybe MountPoint, MountOpts, PartSize -> Partition, t)
-
--- | Specifies a partition with a given filesystem.
---
--- The partition is not mounted anywhere by default; use the combinators
--- below to configure it.
-partition :: Monoid t => Fs -> PartSpec t
-partition fs = (Nothing, mempty, mkPartition fs, mempty)
-
--- | Specifies a swap partition of a given size.
-swapPartition :: Monoid t => PartSize -> PartSpec t
-swapPartition sz = (Nothing, mempty, const (mkPartition LinuxSwap sz), mempty)
-
--- | Specifies where to mount a partition.
-mountedAt :: PartSpec t -> FilePath -> PartSpec t
-mountedAt (_, o, p, t) mp = (Just mp, o, p, t)
-
--- | Specify a fixed size for a partition.
-setSize :: PartSpec t -> PartSize -> PartSpec t
-setSize (mp, o, p, t) sz = (mp, o, const (p sz), t)
-
--- | Specifies a mount option, such as "noexec"
-mountOpt :: ToMountOpts o => PartSpec t -> o -> PartSpec t
-mountOpt (mp, o, p, t) o' = (mp, o <> toMountOpts o', p, t)
-
--- | Mount option to make a partition be remounted readonly when there's an
--- error accessing it.
-errorReadonly :: MountOpts
-errorReadonly = toMountOpts "errors=remount-ro"
-
--- | Sets the percent of the filesystem blocks reserved for the super-user.
---
--- The default is 5% for ext2 and ext4. Some filesystems may not support
--- this.
-reservedSpacePercentage :: PartSpec t -> Int -> PartSpec t
-reservedSpacePercentage s percent = adjustp s $ \p ->
- p { partMkFsOpts = ("-m"):show percent:partMkFsOpts p }
-
--- | Sets a flag on the partition.
-setFlag :: PartSpec t -> PartFlag -> PartSpec t
-setFlag s f = adjustp s $ \p -> p { partFlags = (f, True):partFlags p }
-
--- | Makes a MSDOS partition be Extended, rather than Primary.
-extended :: PartSpec t -> PartSpec t
-extended s = adjustp s $ \p -> p { partType = Extended }
-
-adjustp :: PartSpec t -> (Partition -> Partition) -> PartSpec t
-adjustp (mp, o, p, t) f = (mp, o, f . p, t)
-
-adjustt :: PartSpec t -> (t -> t) -> PartSpec t
-adjustt (mp, o, p, t) f = (mp, o, p, f t)
-
--- | Default partition size when not otherwize specified is 128 MegaBytes.
-defSz :: PartSize
-defSz = MegaBytes 128