summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Propellor/Container.hs18
-rw-r--r--src/Propellor/PropAccum.hs12
-rw-r--r--src/Propellor/Property.hs2
-rw-r--r--src/Propellor/Property/Chroot.hs11
-rw-r--r--src/Propellor/Property/Conductor.hs7
-rw-r--r--src/Propellor/Property/DiskImage.hs81
-rw-r--r--src/Propellor/Property/Grub.hs11
-rw-r--r--src/Propellor/Property/Ssh.hs2
-rw-r--r--src/Propellor/Types/MetaTypes.hs2
9 files changed, 87 insertions, 59 deletions
diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs
index 832faf9c..4cd46ae5 100644
--- a/src/Propellor/Container.hs
+++ b/src/Propellor/Container.hs
@@ -6,14 +6,28 @@ import Propellor.Types
import Propellor.Types.MetaTypes
import Propellor.Types.Info
import Propellor.PrivData
+import Propellor.PropAccum
class IsContainer c where
containerProperties :: c -> [ChildProperty]
containerInfo :: c -> Info
+ setContainerProperties :: c -> [ChildProperty] -> c
instance IsContainer Host where
- containerProperties = hostProperties
- containerInfo = hostInfo
+ containerProperties = hostProperties
+ containerInfo = hostInfo
+ setContainerProperties h ps = host (hostName h) (Props ps)
+
+-- | Note that the metatype of a container's properties is not retained,
+-- so this defaults to UnixLike. So, using this with setContainerProps can
+-- add properties to a container that conflict with properties already in it.
+-- Use caution when using this; only add properties that do not have
+-- restricted targets.
+containerProps :: IsContainer c => c -> Props UnixLike
+containerProps = Props . containerProperties
+
+setContainerProps :: IsContainer c => c -> Props metatypes -> c
+setContainerProps c (Props ps) = setContainerProperties c ps
-- | Adjust the provided Property, adding to its
-- propertyChidren the properties of the provided container.
diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs
index 1212ef7a..856f2e8e 100644
--- a/src/Propellor/PropAccum.hs
+++ b/src/Propellor/PropAccum.hs
@@ -12,8 +12,6 @@ module Propellor.PropAccum
, (&)
, (&^)
, (!)
- , hostProps
- , modifyHostProps
) where
import Propellor.Types
@@ -32,16 +30,6 @@ import Prelude
host :: HostName -> Props metatypes -> Host
host hn (Props ps) = Host hn ps (mconcat (map getInfoRecursive ps))
--- | Note that the metatype of a Host's properties is not retained,
--- so this defaults to UnixLike. So, using this with modifyHostProps can
--- add properties to a Host that conflict with properties already in it.
--- Use caution when using this.
-hostProps :: Host -> Props UnixLike
-hostProps = Props . hostProperties
-
-modifyHostProps :: Host -> Props metatypes -> Host
-modifyHostProps h ps = host (hostName h) ps
-
-- | Props is a combination of a list of properties, with their combined
-- metatypes.
data Props metatypes = Props [ChildProperty]
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 9fa29888..70583edc 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -308,7 +308,7 @@ makeChange a = liftIO a >> return MadeChange
noChange :: Propellor Result
noChange = return NoChange
-doNothing :: Property UnixLike
+doNothing :: SingI t => Property (MetaTypes t)
doNothing = property "noop property" noChange
-- | Registers an action that should be run at the very end, after
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index ddadc763..b29da7f9 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -44,6 +44,7 @@ data Chroot where
instance IsContainer Chroot where
containerProperties (Chroot _ _ h) = containerProperties h
containerInfo (Chroot _ _ h) = containerInfo h
+ setContainerProperties (Chroot loc b h) ps = Chroot loc b (setContainerProperties h ps)
chrootSystem :: Chroot -> Maybe System
chrootSystem = fromInfoVal . fromInfo . containerInfo
@@ -256,11 +257,13 @@ chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc
-- from being started, which is often something you want to prevent when
-- building a chroot.
--
--- This is accomplished by installing a </usr/sbin/policy-rc.d> script
--- that does not let any daemons be started by packages that use
+-- 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.
-noServices :: RevertableProperty DebianLike DebianLike
-noServices = tightenTargets setup <!> tightenTargets teardown
+--
+-- 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" ]
diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs
index 005fc804..ab747acc 100644
--- a/src/Propellor/Property/Conductor.hs
+++ b/src/Propellor/Property/Conductor.hs
@@ -74,6 +74,7 @@ module Propellor.Property.Conductor (
) where
import Propellor.Base
+import Propellor.Container
import Propellor.Spin (spin')
import Propellor.PrivData.Paths
import Propellor.Types.Info
@@ -219,7 +220,7 @@ orchestrate hs = map go hs
os = extractOrchestras hs
removeold h = foldl removeold' h (oldconductorsof h)
- removeold' h oldconductor = modifyHostProps h $ hostProps h
+ removeold' h oldconductor = setContainerProps h $ containerProps h
! conductedBy oldconductor
oldconductors = zip hs (map (fromInfo . hostInfo) hs)
@@ -234,7 +235,7 @@ orchestrate' h (Conducted _) = h
orchestrate' h (Conductor c l)
| sameHost h c = cont $ addConductorPrivData h (concatMap allHosts l)
| any (sameHost h) (map topHost l) = cont $
- modifyHostProps h $ hostProps h
+ setContainerProps h $ containerProps h
& conductedBy c
| otherwise = cont h
where
@@ -268,7 +269,7 @@ conductorFor h = go
-- Reverts conductorFor.
notConductorFor :: Host -> Property (HasInfo + UnixLike)
-notConductorFor h = doNothing
+notConductorFor h = (doNothing :: Property UnixLike)
`addInfoProperty` (toInfo (NotConductorFor [h]))
`describe` desc
`requires` undoRevertableProperty (conductorKnownHost h)
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 48df7fab..8c027b05 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -2,6 +2,8 @@
--
-- This module is designed to be imported unqualified.
+{-# LANGUAGE TypeFamilies #-}
+
module Propellor.Property.DiskImage (
-- * Partition specification
module Propellor.Property.DiskImage.PartSpec,
@@ -30,6 +32,7 @@ import Propellor.Property.Parted
import Propellor.Property.Mount
import Propellor.Property.Partition
import Propellor.Property.Rsync
+import Propellor.Container
import Utility.Path
import Data.List (isPrefixOf, isInfixOf, sortBy)
@@ -51,7 +54,8 @@ type DiskImage = FilePath
--
-- > import Propellor.Property.DiskImage
--
--- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d
+-- > let chroot d = Chroot.debootstrapped mempty d
+-- > & osDebian Unstable "amd64"
-- > & Apt.installed ["linux-image-amd64"]
-- > & User.hasPassword (User "root")
-- > & User.accountFor (User "demo")
@@ -89,31 +93,44 @@ imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finaliz
imageBuilt' rebuild img mkchroot tabletype final partspec =
imageBuiltFrom img chrootdir tabletype final partspec
`requires` Chroot.provisioned chroot
- `requires` (cleanrebuild <!> doNothing)
+ `requires` (cleanrebuild <!> (doNothing :: Property UnixLike))
`describe` desc
where
desc = "built disk image " ++ img
+ cleanrebuild :: Property Linux
cleanrebuild
| rebuild = property desc $ do
liftIO $ removeChroot chrootdir
return MadeChange
| otherwise = doNothing
chrootdir = img ++ ".chroot"
- chroot = mkchroot chrootdir
- -- Before ensuring any other properties of the chroot, avoid
- -- starting services. Reverted by imageFinalized.
- &^ Chroot.noServices
- -- First stage finalization.
- & fst final
- -- Avoid wasting disk image space on the apt cache
- & Apt.cacheCleaned
+ chroot =
+ let c = mkchroot chrootdir
+ in setContainerProps c $ containerProps c
+ -- Before ensuring any other properties of the chroot,
+ -- avoid starting services. Reverted by imageFinalized.
+ &^ Chroot.noServices
+ -- First stage finalization.
+ & fst final
+ & cachesCleaned
+
+-- | This property is automatically added to the chroot when building a
+-- disk image. It cleans any caches of information that can be omitted;
+-- eg the apt cache on Debian.
+cachesCleaned :: Property UnixLike
+cachesCleaned = withOS "cache cleaned" $ \w o ->
+ let aptclean = ensureProperty w Apt.cacheCleaned
+ in case o of
+ (Just (System (Debian _) _)) -> aptclean
+ (Just (System (Buntish _) _)) -> aptclean
+ _ -> noChange
-- | Builds a disk image from the contents of a chroot.
-imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty Linux Linux
+imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) UnixLike
imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
where
desc = img ++ " built from " ++ chrootdir
- mkimg = property desc $ do
+ mkimg = property' desc $ \w -> do
-- unmount helper filesystems such as proc from the chroot
-- before getting sizes
liftIO $ unmountBelow chrootdir
@@ -123,7 +140,7 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
-- tie the knot!
let (mnts, mntopts, parttable) = fitChrootSize tabletype partspec $
map (calcsz mnts) mnts
- ensureProperty $
+ ensureProperty w $
imageExists img (partTableSize parttable)
`before`
partitioned YesReallyDeleteDiskContents img parttable
@@ -136,16 +153,17 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
rmimg = File.notPresent img
partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property Linux
-partitionsPopulated chrootdir mnts mntopts devs = property desc $ mconcat $ zipWith3 go mnts mntopts devs
+partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w ->
+ mconcat $ zipWith3 (go w) mnts mntopts devs
where
desc = "partitions populated from " ++ chrootdir
- go Nothing _ _ = noChange
- go (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket
+ go _ Nothing _ _ = noChange
+ go w (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket
(liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir mntopt)
(const $ liftIO $ umountLazy tmpdir)
$ \ismounted -> if ismounted
- then ensureProperty $
+ then ensureProperty w $
syncDirFiltered (filtersfor mnt) (chrootdir ++ mnt) tmpdir
else return FailedChange
@@ -230,15 +248,15 @@ type Finalization = (Property Linux, (FilePath -> [LoopDev] -> Property Linux))
imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux
imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) =
- property "disk image finalized" $
+ property' "disk image finalized" $ \w ->
withTmpDir "mnt" $ \top ->
- go top `finally` liftIO (unmountall top)
+ go w top `finally` liftIO (unmountall top)
where
- go top = do
+ go w top = do
liftIO $ mountall top
liftIO $ writefstab top
liftIO $ allowservices top
- ensureProperty $ final top devs
+ ensureProperty w $ final top devs
-- Ordered lexographically by mount point, so / comes before /usr
-- comes before /usr/local
@@ -280,27 +298,26 @@ noFinalization = (doNothing, \_ _ -> doNothing)
grubBooted :: Grub.BIOS -> Finalization
grubBooted bios = (Grub.installed' bios, boots)
where
- boots mnt loopdevs = combineProperties "disk image boots using grub"
+ boots mnt loopdevs = combineProperties "disk image boots using grub" $ props
-- bind mount host /dev so grub can access the loop devices
- [ bindMount "/dev" (inmnt "/dev")
- , mounted "proc" "proc" (inmnt "/proc") mempty
- , mounted "sysfs" "sys" (inmnt "/sys") mempty
+ & 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"]
+ & inchroot "update-initramfs" ["-u"]
`assume` MadeChange
-- work around for http://bugs.debian.org/802717
- , check haveosprober $ inchroot "chmod" ["-x", osprober]
- , inchroot "update-grub" []
+ & check haveosprober (inchroot "chmod" ["-x", osprober])
+ & inchroot "update-grub" []
`assume` MadeChange
- , check haveosprober $ inchroot "chmod" ["+x", osprober]
- , inchroot "grub-install" [wholediskloopdev]
+ & check haveosprober (inchroot "chmod" ["+x", osprober])
+ & inchroot "grub-install" [wholediskloopdev]
`assume` MadeChange
-- sync all buffered changes out to the disk image
-- may not be necessary, but seemed needed sometimes
-- when using the disk image right away.
- , cmdProperty "sync" []
+ & cmdProperty "sync" []
`assume` NoChange
- ]
where
-- cannot use </> since the filepath is absolute
inmnt f = mnt ++ f
diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs
index 09255587..b8dc5f9e 100644
--- a/src/Propellor/Property/Grub.hs
+++ b/src/Propellor/Property/Grub.hs
@@ -29,10 +29,15 @@ mkConfig = tightenTargets $ cmdProperty "update-grub" []
`assume` MadeChange
-- | Installs grub; does not run update-grub.
-installed' :: BIOS -> Property DebianLike
-installed' bios = Apt.installed [pkg] `describe` "grub package installed"
+installed' :: BIOS -> Property Linux
+installed' bios = withOS "grub package installed" $ \w o ->
+ let apt = ensureProperty w (Apt.installed [debpkg])
+ in case o of
+ (Just (System (Debian _) _)) -> apt
+ (Just (System (Buntish _) _)) -> apt
+ _ -> unsupportedOS
where
- pkg = case bios of
+ debpkg = case bios of
PC -> "grub-pc"
EFI64 -> "grub-efi-amd64"
EFI32 -> "grub-efi-ia32"
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index 05409593..7048de3b 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -173,7 +173,7 @@ hostKeys ctx l = go `before` cleanup
removestale b = map (tightenTargets . File.notPresent . flip keyFile b) staletypes
cleanup :: Property DebianLike
cleanup
- | null staletypes || null l = tightenTargets doNothing
+ | null staletypes || null l = doNothing
| otherwise =
combineProperties ("any other ssh host keys removed " ++ typelist staletypes)
(toProps $ removestale True ++ removestale False)
diff --git a/src/Propellor/Types/MetaTypes.hs b/src/Propellor/Types/MetaTypes.hs
index ce2b1411..3e89e28d 100644
--- a/src/Propellor/Types/MetaTypes.hs
+++ b/src/Propellor/Types/MetaTypes.hs
@@ -36,7 +36,7 @@ type UnixLike = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish, 'Targe
-- | Any linux system
type Linux = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish ]
-- | Debian and derivatives.
-type DebianLike = Debian + Buntish
+type DebianLike = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish ]
type Debian = MetaTypes '[ 'Targeting 'OSDebian ]
type Buntish = MetaTypes '[ 'Targeting 'OSBuntish ]
type FreeBSD = MetaTypes '[ 'Targeting 'OSFreeBSD ]
generated by cgit v1.3-2-g0d8e (git 2.53.0) at 2026-06-13 22:45:35 +0000