summaryrefslogtreecommitdiff
path: root/src/Propellor/Property
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Property')
-rw-r--r--src/Propellor/Property/DebianMirror.hs20
-rw-r--r--src/Propellor/Property/Dns.hs35
-rw-r--r--src/Propellor/Property/DnsSec.hs12
-rw-r--r--src/Propellor/Property/Fail2Ban.hs8
-rw-r--r--src/Propellor/Property/File.hs10
-rw-r--r--src/Propellor/Property/Firewall.hs4
-rw-r--r--src/Propellor/Property/FreeBSD/Pkg.hs17
-rw-r--r--src/Propellor/Property/Git.hs23
-rw-r--r--src/Propellor/Property/Grub.hs32
-rw-r--r--src/Propellor/Property/Network.hs1
-rw-r--r--src/Propellor/Property/Parted.hs17
-rw-r--r--src/Propellor/Property/Partition.hs11
-rw-r--r--src/Propellor/Property/Rsync.hs6
13 files changed, 101 insertions, 95 deletions
diff --git a/src/Propellor/Property/DebianMirror.hs b/src/Propellor/Property/DebianMirror.hs
index eea7b96f..b86d8e0b 100644
--- a/src/Propellor/Property/DebianMirror.hs
+++ b/src/Propellor/Property/DebianMirror.hs
@@ -119,19 +119,17 @@ debianMirrorKeyring k m = m { _debianMirrorKeyring = k }
debianMirrorRsyncExtra :: [RsyncExtra] -> DebianMirror -> DebianMirror
debianMirrorRsyncExtra r m = m { _debianMirrorRsyncExtra = r }
-mirror :: DebianMirror -> Property NoInfo
-mirror mirror' = propertyList
- ("Debian mirror " ++ dir)
- [ Apt.installed ["debmirror"]
- , User.accountFor (User "debmirror")
- , File.dirExists dir
- , File.ownerGroup dir (User "debmirror") (Group "debmirror")
- , check (not . and <$> mapM suitemirrored suites)
+mirror :: DebianMirror -> Property DebianLike
+mirror mirror' = propertyList ("Debian mirror " ++ dir) $ props
+ & Apt.installed ["debmirror"]
+ & User.accountFor (User "debmirror")
+ & File.dirExists dir
+ & File.ownerGroup dir (User "debmirror") (Group "debmirror")
+ & check (not . and <$> mapM suitemirrored suites)
(cmdProperty "debmirror" args)
`describe` "debmirror setup"
- , Cron.niceJob ("debmirror_" ++ dir) (_debianMirrorCronTimes mirror') (User "debmirror") "/" $
- unwords ("/usr/bin/debmirror" : args)
- ]
+ & Cron.niceJob ("debmirror_" ++ dir) (_debianMirrorCronTimes mirror') (User "debmirror") "/"
+ (unwords ("/usr/bin/debmirror" : args))
where
dir = _debianMirrorDir mirror'
suites = _debianMirrorSuites mirror'
diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
index adc12930..a660a016 100644
--- a/src/Propellor/Property/Dns.hs
+++ b/src/Propellor/Property/Dns.hs
@@ -60,7 +60,7 @@ import Data.List
--
-- In either case, the secondary dns server Host should have an ipv4 and/or
-- ipv6 property defined.
-primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty HasInfo
+primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty (HasInfo + DebianLike) DebianLike
primary hosts domain soa rs = setup <!> cleanup
where
setup = setupPrimary zonefile id hosts domain soa rs
@@ -70,7 +70,7 @@ primary hosts domain soa rs = setup <!> cleanup
zonefile = "/etc/bind/propellor/db." ++ domain
-setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property HasInfo
+setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property (HasInfo + DebianLike)
setupPrimary zonefile mknamedconffile hosts domain soa rs =
withwarnings baseprop
`requires` servingZones
@@ -80,9 +80,10 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs =
indomain = M.elems $ M.filterWithKey (\hn _ -> inDomain domain $ AbsDomain $ hn) hostmap
(partialzone, zonewarnings) = genZone indomain hostmap domain soa
- baseprop = infoProperty ("dns primary for " ++ domain) satisfy
- (mempty `addInfo` addNamedConf conf) []
- satisfy = do
+ baseprop = primaryprop
+ `addInfoProperty` (toInfo (addNamedConf conf))
+ primaryprop :: Property DebianLike
+ primaryprop = property ("dns primary for " ++ domain) $ do
sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap)
let zone = partialzone
{ zHosts = zHosts partialzone ++ rs ++ sshfps }
@@ -120,11 +121,13 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs =
in z /= oldzone || oldserial < sSerial (zSOA zone)
-cleanupPrimary :: FilePath -> Domain -> Property NoInfo
+cleanupPrimary :: FilePath -> Domain -> Property DebianLike
cleanupPrimary zonefile domain = check (doesFileExist zonefile) $
- property ("removed dns primary for " ++ domain)
- (makeChange $ removeZoneFile zonefile)
- `requires` namedConfWritten
+ go `requires` namedConfWritten
+ where
+ desc = "removed dns primary for " ++ domain
+ go :: Property DebianLike
+ go = property desc (makeChange $ removeZoneFile zonefile)
-- | Primary dns server for a domain, secured with DNSSEC.
--
@@ -152,7 +155,7 @@ cleanupPrimary zonefile domain = check (doesFileExist zonefile) $
-- This is different from the serial number used by 'primary', so if you
-- want to later disable DNSSEC you will need to adjust the serial number
-- passed to mkSOA to ensure it is larger.
-signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty HasInfo
+signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty (HasInfo + DebianLike) DebianLike
signedPrimary recurrance hosts domain soa rs = setup <!> cleanup
where
setup = combineProperties ("dns primary for " ++ domain ++ " (signed)")
@@ -184,12 +187,12 @@ signedPrimary recurrance hosts domain soa rs = setup <!> cleanup
--
-- Note that if a host is declared to be a primary and a secondary dns
-- server for the same domain, the primary server config always wins.
-secondary :: [Host] -> Domain -> RevertableProperty HasInfo
+secondary :: [Host] -> Domain -> RevertableProperty (HasInfo + DebianLike) DebianLike
secondary hosts domain = secondaryFor (otherServers Master hosts domain) hosts domain
-- | This variant is useful if the primary server does not have its DNS
-- configured via propellor.
-secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty HasInfo
+secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty (HasInfo + DebianLike) DebianLike
secondaryFor masters hosts domain = setup <!> cleanup
where
setup = pureInfoProperty desc (addNamedConf conf)
@@ -218,15 +221,15 @@ otherServers wantedtype hosts domain =
-- | Rewrites the whole named.conf.local file to serve the zones
-- configured by `primary` and `secondary`, and ensures that bind9 is
-- running.
-servingZones :: Property NoInfo
+servingZones :: Property DebianLike
servingZones = namedConfWritten
`onChange` Service.reloaded "bind9"
`requires` Apt.serviceInstalledRunning "bind9"
-namedConfWritten :: Property NoInfo
-namedConfWritten = property "named.conf configured" $ do
+namedConfWritten :: Property DebianLike
+namedConfWritten = property' "named.conf configured" $ \w -> do
zs <- getNamedConf
- ensureProperty $
+ ensureProperty w $
hasContent namedConfFile $
concatMap confStanza $ M.elems zs
diff --git a/src/Propellor/Property/DnsSec.hs b/src/Propellor/Property/DnsSec.hs
index 1ba459e6..aa58dc60 100644
--- a/src/Propellor/Property/DnsSec.hs
+++ b/src/Propellor/Property/DnsSec.hs
@@ -7,13 +7,13 @@ import qualified Propellor.Property.File as File
--
-- signedPrimary uses this, so this property does not normally need to be
-- used directly.
-keysInstalled :: Domain -> RevertableProperty HasInfo
+keysInstalled :: Domain -> RevertableProperty (HasInfo + UnixLike) UnixLike
keysInstalled domain = setup <!> cleanup
where
- setup = propertyList "DNSSEC keys installed" $
+ setup = propertyList "DNSSEC keys installed" $ toProps $
map installkey keys
- cleanup = propertyList "DNSSEC keys removed" $
+ cleanup = propertyList "DNSSEC keys removed" $ toProps $
map (File.notPresent . keyFn domain) keys
installkey k = writer (keysrc k) (keyFn domain k) (Context domain)
@@ -37,12 +37,14 @@ keysInstalled domain = setup <!> cleanup
--
-- signedPrimary uses this, so this property does not normally need to be
-- used directly.
-zoneSigned :: Domain -> FilePath -> RevertableProperty HasInfo
+zoneSigned :: Domain -> FilePath -> RevertableProperty (HasInfo + UnixLike) UnixLike
zoneSigned domain zonefile = setup <!> cleanup
where
+ setup :: Property (HasInfo + UnixLike)
setup = check needupdate (forceZoneSigned domain zonefile)
`requires` keysInstalled domain
+ cleanup :: Property UnixLike
cleanup = File.notPresent (signedZoneFile zonefile)
`before` File.notPresent dssetfile
`before` revert (keysInstalled domain)
@@ -63,7 +65,7 @@ zoneSigned domain zonefile = setup <!> cleanup
t2 <- getModificationTime f
return (t2 >= t1)
-forceZoneSigned :: Domain -> FilePath -> Property NoInfo
+forceZoneSigned :: Domain -> FilePath -> Property UnixLike
forceZoneSigned domain zonefile = property ("zone signed for " ++ domain) $ liftIO $ do
salt <- take 16 <$> saltSha1
let p = proc "dnssec-signzone"
diff --git a/src/Propellor/Property/Fail2Ban.hs b/src/Propellor/Property/Fail2Ban.hs
index 716d376f..9f147943 100644
--- a/src/Propellor/Property/Fail2Ban.hs
+++ b/src/Propellor/Property/Fail2Ban.hs
@@ -5,24 +5,24 @@ import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Service as Service
import Propellor.Property.ConfFile
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.serviceInstalledRunning "fail2ban"
-reloaded :: Property NoInfo
+reloaded :: Property DebianLike
reloaded = Service.reloaded "fail2ban"
type Jail = String
-- | By default, fail2ban only enables the ssh jail, but many others
-- are available to be enabled, for example "postfix-sasl"
-jailEnabled :: Jail -> Property NoInfo
+jailEnabled :: Jail -> Property DebianLike
jailEnabled name = jailConfigured name "enabled" "true"
`onChange` reloaded
-- | Configures a jail. For example:
--
-- > jailConfigured "sshd" "port" "2222"
-jailConfigured :: Jail -> IniKey -> String -> Property NoInfo
+jailConfigured :: Jail -> IniKey -> String -> Property UnixLike
jailConfigured name key value =
jailConfFile name `containsIniSetting` (name, key, value)
diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs
index 2a74b5ed..e072fcaa 100644
--- a/src/Propellor/Property/File.hs
+++ b/src/Propellor/Property/File.hs
@@ -25,25 +25,25 @@ f `hasContentProtected` newcontent = fileProperty' writeFileProtected
--
-- The file's permissions are preserved if the file already existed.
-- Otherwise, they're set to 600.
-hasPrivContent :: IsContext c => FilePath -> c -> Property HasInfo
+hasPrivContent :: IsContext c => FilePath -> c -> Property (HasInfo + UnixLike)
hasPrivContent f = hasPrivContentFrom (PrivDataSourceFile (PrivFile f) f) f
-- | Like hasPrivContent, but allows specifying a source
-- for PrivData, rather than using PrivDataSourceFile .
-hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property HasInfo
+hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property (HasInfo + UnixLike)
hasPrivContentFrom = hasPrivContent' writeFileProtected
-- | Leaves the file at its default or current mode,
-- allowing "private" data to be read.
--
-- Use with caution!
-hasPrivContentExposed :: IsContext c => FilePath -> c -> Property HasInfo
+hasPrivContentExposed :: IsContext c => FilePath -> c -> Property (HasInfo + UnixLike)
hasPrivContentExposed f = hasPrivContentExposedFrom (PrivDataSourceFile (PrivFile f) f) f
-hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property HasInfo
+hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property (HasInfo + UnixLike)
hasPrivContentExposedFrom = hasPrivContent' writeFile
-hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (FilePath -> String -> IO ()) -> s -> FilePath -> c -> Property HasInfo
+hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (FilePath -> String -> IO ()) -> s -> FilePath -> c -> Property (HasInfo + UnixLike)
hasPrivContent' writer source f context =
withPrivData source context $ \getcontent ->
property' desc $ \o -> getcontent $ \privcontent ->
diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs
index fa1f95d4..ce0befcd 100644
--- a/src/Propellor/Property/Firewall.hs
+++ b/src/Propellor/Property/Firewall.hs
@@ -26,10 +26,10 @@ import Propellor.Base
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Network as Network
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["iptables"]
-rule :: Chain -> Table -> Target -> Rules -> Property NoInfo
+rule :: Chain -> Table -> Target -> Rules -> Property Linux
rule c tb tg rs = property ("firewall rule: " <> show r) addIpTable
where
r = Rule c tb tg rs
diff --git a/src/Propellor/Property/FreeBSD/Pkg.hs b/src/Propellor/Property/FreeBSD/Pkg.hs
index 6bbd2570..6c775b94 100644
--- a/src/Propellor/Property/FreeBSD/Pkg.hs
+++ b/src/Propellor/Property/FreeBSD/Pkg.hs
@@ -22,8 +22,8 @@ runPkg cmd args =
in
lines <$> readProcess p a
-pkgCmdProperty :: String -> [String] -> UncheckedProperty NoInfo
-pkgCmdProperty cmd args =
+pkgCmdProperty :: String -> [String] -> UncheckedProperty FreeBSD
+pkgCmdProperty cmd args = tightenTargets $
let
(p, a) = pkgCommand cmd args
in
@@ -44,13 +44,14 @@ instance IsInfo PkgUpdate where
pkgUpdated :: PkgUpdate -> Bool
pkgUpdated (PkgUpdate _) = True
-update :: Property HasInfo
+update :: Property (HasInfo + FreeBSD)
update =
let
upd = pkgCmd "update" []
go = ifM (pkgUpdated <$> askInfo) ((noChange), (liftIO upd >> return MadeChange))
in
- infoProperty "pkg update has run" go (addInfo mempty (PkgUpdate "")) []
+ (property "pkg update has run" go :: Property FreeBSD)
+ `addInfoProperty` (toInfo (PkgUpdate ""))
newtype PkgUpgrade = PkgUpgrade String
deriving (Typeable, Monoid, Show)
@@ -60,17 +61,19 @@ instance IsInfo PkgUpgrade where
pkgUpgraded :: PkgUpgrade -> Bool
pkgUpgraded (PkgUpgrade _) = True
-upgrade :: Property HasInfo
+upgrade :: Property (HasInfo + FreeBSD)
upgrade =
let
upd = pkgCmd "upgrade" []
go = ifM (pkgUpgraded <$> askInfo) ((noChange), (liftIO upd >> return MadeChange))
in
- infoProperty "pkg upgrade has run" go (addInfo mempty (PkgUpgrade "")) [] `requires` update
+ (property "pkg upgrade has run" go :: Property FreeBSD)
+ `addInfoProperty` (toInfo (PkgUpdate ""))
+ `requires` update
type Package = String
-installed :: Package -> Property NoInfo
+installed :: Package -> Property FreeBSD
installed pkg = check (isInstallable pkg) $ pkgCmdProperty "install" [pkg]
isInstallable :: Package -> IO Bool
diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs
index a5ef5ab1..5d7c8b4d 100644
--- a/src/Propellor/Property/Git.hs
+++ b/src/Propellor/Property/Git.hs
@@ -11,7 +11,7 @@ import Data.List
-- using git-daemon, run from inetd.
--
-- Note that reverting this property does not remove or stop inetd.
-daemonRunning :: FilePath -> RevertableProperty NoInfo
+daemonRunning :: FilePath -> RevertableProperty DebianLike DebianLike
daemonRunning exportdir = setup <!> unsetup
where
setup = containsLine conf (mkl "tcp4")
@@ -47,7 +47,7 @@ daemonRunning exportdir = setup <!> unsetup
, exportdir
]
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["git"]
type RepoUrl = String
@@ -61,8 +61,8 @@ type Branch = String
-- it will be recursively deleted first.
--
-- A branch can be specified, to check out.
-cloned :: User -> RepoUrl -> FilePath -> Maybe Branch -> Property NoInfo
-cloned owner url dir mbranch = check originurl (property desc checkout)
+cloned :: User -> RepoUrl -> FilePath -> Maybe Branch -> Property DebianLike
+cloned owner url dir mbranch = check originurl go
`requires` installed
where
desc = "git cloned " ++ url ++ " to " ++ dir
@@ -74,12 +74,13 @@ cloned owner url dir mbranch = check originurl (property desc checkout)
return (v /= Just url)
, return True
)
- checkout = do
+ go :: Property DebianLike
+ go = property' desc $ \w -> do
liftIO $ do
whenM (doesDirectoryExist dir) $
removeDirectoryRecursive dir
createDirectoryIfMissing True (takeDirectory dir)
- ensureProperty $ userScriptProperty owner (catMaybes checkoutcmds)
+ ensureProperty w $ userScriptProperty owner (catMaybes checkoutcmds)
`assume` MadeChange
checkoutcmds =
-- The </dev/null fixes an intermittent
@@ -99,8 +100,8 @@ isGitDir dir = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--re
data GitShared = Shared Group | SharedAll | NotShared
-bareRepo :: FilePath -> User -> GitShared -> Property NoInfo
-bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " ++ repo) $
+bareRepo :: FilePath -> User -> GitShared -> Property UnixLike
+bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " ++ repo) $ toProps $
dirExists repo : case gitshared of
NotShared ->
[ ownerGroup repo user (userGroup user)
@@ -121,7 +122,7 @@ bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: "
isRepo repo' = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--resolve-git-dir", repo'])
-- | Set a key value pair in a git repo's configuration.
-repoConfigured :: FilePath -> (String, String) -> Property NoInfo
+repoConfigured :: FilePath -> (String, String) -> Property UnixLike
repo `repoConfigured` (key, value) = check (not <$> alreadyconfigured) $
userScriptProperty (User "root")
[ "cd " ++ repo
@@ -141,7 +142,7 @@ getRepoConfig repo key = catchDefaultIO [] $
lines <$> readProcess "git" ["-C", repo, "config", key]
-- | Whether a repo accepts non-fast-forward pushes.
-repoAcceptsNonFFs :: FilePath -> RevertableProperty NoInfo
+repoAcceptsNonFFs :: FilePath -> RevertableProperty UnixLike UnixLike
repoAcceptsNonFFs repo = accepts <!> refuses
where
accepts = repoConfigured repo ("receive.denyNonFastForwards", "false")
@@ -152,7 +153,7 @@ repoAcceptsNonFFs repo = accepts <!> refuses
-- | Sets a bare repository's default branch, which will be checked out
-- when cloning it.
-bareRepoDefaultBranch :: FilePath -> String -> Property NoInfo
+bareRepoDefaultBranch :: FilePath -> String -> Property UnixLike
bareRepoDefaultBranch repo branch =
userScriptProperty (User "root")
[ "cd " ++ repo
diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs
index 1b7f2a0a..09255587 100644
--- a/src/Propellor/Property/Grub.hs
+++ b/src/Propellor/Property/Grub.hs
@@ -19,17 +19,17 @@ data BIOS = PC | EFI64 | EFI32 | Coreboot | Xen
-- bootloader.
--
-- This includes running update-grub.
-installed :: BIOS -> Property NoInfo
+installed :: BIOS -> Property DebianLike
installed bios = installed' bios `onChange` mkConfig
-- Run update-grub, to generate the grub boot menu. It will be
-- automatically updated when kernel packages are installed.
-mkConfig :: Property NoInfo
-mkConfig = cmdProperty "update-grub" []
+mkConfig :: Property DebianLike
+mkConfig = tightenTargets $ cmdProperty "update-grub" []
`assume` MadeChange
-- | Installs grub; does not run update-grub.
-installed' :: BIOS -> Property NoInfo
+installed' :: BIOS -> Property DebianLike
installed' bios = Apt.installed [pkg] `describe` "grub package installed"
where
pkg = case bios of
@@ -48,8 +48,8 @@ installed' bios = Apt.installed [pkg] `describe` "grub package installed"
-- on the device; it always does the work to reinstall it. It's a good idea
-- to arrange for this property to only run once, by eg making it be run
-- onChange after OS.cleanInstallOnce.
-boots :: OSDevice -> Property NoInfo
-boots dev = cmdProperty "grub-install" [dev]
+boots :: OSDevice -> Property Linux
+boots dev = tightenTargets $ cmdProperty "grub-install" [dev]
`assume` MadeChange
`describe` ("grub boots " ++ dev)
@@ -61,10 +61,10 @@ boots dev = cmdProperty "grub-install" [dev]
--
-- The rootdev should be in the form "hd0", while the bootdev is in the form
-- "xen/xvda".
-chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property NoInfo
-chainPVGrub rootdev bootdev timeout = combineProperties desc
- [ File.dirExists "/boot/grub"
- , "/boot/grub/menu.lst" `File.hasContent`
+chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property DebianLike
+chainPVGrub rootdev bootdev timeout = combineProperties desc $ props
+ & File.dirExists "/boot/grub"
+ & "/boot/grub/menu.lst" `File.hasContent`
[ "default 1"
, "timeout " ++ show timeout
, ""
@@ -73,12 +73,12 @@ chainPVGrub rootdev bootdev timeout = combineProperties desc
, "kernel /boot/xen-shim"
, "boot"
]
- , "/boot/load.cf" `File.hasContent`
+ & "/boot/load.cf" `File.hasContent`
[ "configfile (" ++ bootdev ++ ")/boot/grub/grub.cfg" ]
- , installed Xen
- , flip flagFile "/boot/xen-shim" $ scriptProperty ["grub-mkimage --prefix '(" ++ bootdev ++ ")/boot/grub' -c /boot/load.cf -O x86_64-xen /usr/lib/grub/x86_64-xen/*.mod > /boot/xen-shim"]
- `assume` MadeChange
- `describe` "/boot-xen-shim"
- ]
+ & installed Xen
+ & flip flagFile "/boot/xen-shim" xenshim
where
desc = "chain PV-grub"
+ xenshim = scriptProperty ["grub-mkimage --prefix '(" ++ bootdev ++ ")/boot/grub' -c /boot/load.cf -O x86_64-xen /usr/lib/grub/x86_64-xen/*.mod > /boot/xen-shim"]
+ `assume` MadeChange
+ `describe` "/boot-xen-shim"
diff --git a/src/Propellor/Property/Network.hs b/src/Propellor/Property/Network.hs
index 46f5cef3..9ed9e591 100644
--- a/src/Propellor/Property/Network.hs
+++ b/src/Propellor/Property/Network.hs
@@ -2,7 +2,6 @@ module Propellor.Property.Network where
import Propellor.Base
import Propellor.Property.File
-import Propellor.Types.MetaTypes
import Data.Char
diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs
index 5d6afa9c..bc8a256d 100644
--- a/src/Propellor/Property/Parted.hs
+++ b/src/Propellor/Property/Parted.hs
@@ -153,18 +153,17 @@ data Eep = YesReallyDeleteDiskContents
-- 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
+partitioned :: Eep -> FilePath -> PartTable -> Property DebianLike
+partitioned eep disk (PartTable tabletype parts) = property' desc $ \w -> do
isdev <- liftIO $ isBlockDevice <$> getFileStatus disk
- ensureProperty $ combineProperties desc
- [ parted eep disk partedparams
- , if isdev
+ ensureProperty w $ combineProperties desc $ props
+ & parted eep disk partedparams
+ & if isdev
then formatl (map (\n -> disk ++ show n) [1 :: Int ..])
else Partition.kpartx disk (formatl . map Partition.partitionLoopDev)
- ]
where
desc = disk ++ " partitioned"
- formatl devs = combineProperties desc (map format (zip parts devs))
+ formatl devs = combineProperties desc (toProps $ 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
@@ -193,12 +192,12 @@ partitioned eep disk (PartTable tabletype parts) = property desc $ do
--
-- 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 :: Eep -> FilePath -> [String] -> Property DebianLike
parted YesReallyDeleteDiskContents disk ps = p `requires` installed
where
p = cmdProperty "parted" ("--script":"--align":"cylinder":disk:ps)
`assume` MadeChange
-- | Gets parted installed.
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["parted"]
diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs
index b2f50339..5aff4ba4 100644
--- a/src/Propellor/Property/Partition.hs
+++ b/src/Propellor/Property/Partition.hs
@@ -16,7 +16,7 @@ data Fs = EXT2 | EXT3 | EXT4 | BTRFS | REISERFS | XFS | FAT | VFAT | NTFS | Linu
data Eep = YesReallyFormatPartition
-- | Formats a partition.
-formatted :: Eep -> Fs -> FilePath -> Property NoInfo
+formatted :: Eep -> Fs -> FilePath -> Property DebianLike
formatted = formatted' []
-- | Options passed to a mkfs.* command when making a filesystem.
@@ -24,7 +24,7 @@ formatted = formatted' []
-- Eg, ["-m0"]
type MkfsOpts = [String]
-formatted' :: MkfsOpts -> Eep -> Fs -> FilePath -> Property NoInfo
+formatted' :: MkfsOpts -> Eep -> Fs -> FilePath -> Property DebianLike
formatted' opts YesReallyFormatPartition fs dev = cmdProperty cmd opts'
`assume` MadeChange
`requires` Apt.installed [pkg]
@@ -64,17 +64,18 @@ isLoopDev' f
-- within a disk image file. The resulting loop 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 -> ([LoopDev] -> Property NoInfo) -> Property NoInfo
+kpartx :: FilePath -> ([LoopDev] -> Property DebianLike) -> Property DebianLike
kpartx diskimage mkprop = go `requires` Apt.installed ["kpartx"]
where
- go = property (propertyDesc (mkprop [])) $ do
+ go :: Property DebianLike
+ go = property' (propertyDesc (mkprop [])) $ \w -> do
cleanup -- idempotency
loopdevs <- liftIO $ kpartxParse
<$> readProcess "kpartx" ["-avs", diskimage]
bad <- liftIO $ filterM (not <$$> isLoopDev) loopdevs
unless (null bad) $
error $ "kpartx output seems to include non-loop-devices (possible parse failure): " ++ show bad
- r <- ensureProperty (mkprop loopdevs)
+ r <- ensureProperty w (mkprop loopdevs)
cleanup
return r
cleanup = void $ liftIO $ boolSystem "kpartx" [Param "-d", File diskimage]
diff --git a/src/Propellor/Property/Rsync.hs b/src/Propellor/Property/Rsync.hs
index 0c77df58..b40396de 100644
--- a/src/Propellor/Property/Rsync.hs
+++ b/src/Propellor/Property/Rsync.hs
@@ -16,7 +16,7 @@ filesUnder d = Pattern (d ++ "/*")
-- | Ensures that the Dest directory exists and has identical contents as
-- the Src directory.
-syncDir :: Src -> Dest -> Property NoInfo
+syncDir :: Src -> Dest -> Property DebianLike
syncDir = syncDirFiltered []
data Filter
@@ -43,7 +43,7 @@ newtype Pattern = Pattern String
-- Rsync checks each name to be transferred against its list of Filter
-- rules, and the first matching one is acted on. If no matching rule
-- is found, the file is processed.
-syncDirFiltered :: [Filter] -> Src -> Dest -> Property NoInfo
+syncDirFiltered :: [Filter] -> Src -> Dest -> Property DebianLike
syncDirFiltered filters src dest = rsync $
[ "-av"
-- Add trailing '/' to get rsync to sync the Dest directory,
@@ -56,7 +56,7 @@ syncDirFiltered filters src dest = rsync $
, "--quiet"
] ++ map toRsync filters
-rsync :: [String] -> Property NoInfo
+rsync :: [String] -> Property DebianLike
rsync ps = cmdProperty "rsync" ps
`assume` MadeChange
`requires` Apt.installed ["rsync"]