summaryrefslogtreecommitdiff
path: root/src/Propellor
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor')
-rw-r--r--src/Propellor/EnsureProperty.hs14
-rw-r--r--src/Propellor/Property.hs54
-rw-r--r--src/Propellor/Property/Apt.hs113
-rw-r--r--src/Propellor/Property/Service.hs10
-rw-r--r--src/Propellor/Types.hs23
-rw-r--r--src/Propellor/Types/ResultCheck.hs3
6 files changed, 119 insertions, 98 deletions
diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs
index 21f8acce..c4b5fde1 100644
--- a/src/Propellor/EnsureProperty.hs
+++ b/src/Propellor/EnsureProperty.hs
@@ -7,7 +7,7 @@
module Propellor.EnsureProperty
( ensureProperty
, property'
- , OuterMetaTypes
+ , OuterMetaTypes(..)
) where
import Propellor.Types
@@ -33,8 +33,8 @@ import Propellor.Exception
-- with the property to be lost.
ensureProperty
::
- ( (Targets inner `NotSuperset` Targets outer) ~ 'CanCombine
- , CannotUse_ensureProperty_WithInfo inner ~ 'True
+ ( Cannot_ensureProperty_WithInfo inner ~ 'True
+ , (Targets inner `NotSuperset` Targets outer) ~ 'CanCombine
)
=> OuterMetaTypes outer
-> Property (MetaTypes inner)
@@ -42,10 +42,10 @@ ensureProperty
ensureProperty _ = catchPropellor . getSatisfy
-- The name of this was chosen to make type errors a more understandable.
-type family CannotUse_ensureProperty_WithInfo (l :: [a]) :: Bool
-type instance CannotUse_ensureProperty_WithInfo '[] = 'True
-type instance CannotUse_ensureProperty_WithInfo (t ': ts) =
- Not (t `EqT` 'WithInfo) && CannotUse_ensureProperty_WithInfo ts
+type family Cannot_ensureProperty_WithInfo (l :: [a]) :: Bool
+type instance Cannot_ensureProperty_WithInfo '[] = 'True
+type instance Cannot_ensureProperty_WithInfo (t ': ts) =
+ Not (t `EqT` 'WithInfo) && Cannot_ensureProperty_WithInfo ts
-- | Constructs a property, like `property`, but provides its
-- `OuterMetaTypes`.
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index ba30209e..2ddec439 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -22,9 +22,9 @@ module Propellor.Property (
, Propellor
, property
, property'
+ , OuterMetaTypes
, ensureProperty
- , tightenTargets
- --, withOS
+ , withOS
, unsupportedOS
, makeChange
, noChange
@@ -243,26 +243,6 @@ isNewerThan x y = do
where
mtime f = catchMaybeIO $ modificationTimeHiRes <$> getFileStatus f
--- | Tightens the MetaType list of a Property, to contain fewer targets.
---
--- Anything else in the MetaType list is passed through unchanged.
---
--- For example, to make a property that uses apt-get, which is only
--- available on DebianLike systems:
---
--- > upgraded :: Property DebianLike
--- > upgraded = tightenTargets $ cmdProperty "apt-get" ["upgrade"]
-tightenTargets
- ::
- -- Note that this uses PolyKinds
- ( (Targets untightened `NotSuperset` Targets tightened) ~ 'CanCombine
- , (NonTargets tightened `NotSuperset` NonTargets untightened) ~ 'CanCombine
- , SingI tightened
- )
- => Property (MetaTypes untightened)
- -> Property (MetaTypes tightened)
-tightenTargets (Property _old d a i c) = Property sing d a i c
-
{-
-- | Picks one of the two input properties to use,
@@ -286,17 +266,29 @@ pickOS a@(Property ta ioa) b@(Property tb iob) = Property sing io
-}
--- | Makes a property that is satisfied differently depending on the host's
--- operating system.
+-- | Makes a property that is satisfied differently depending on specifics
+-- of the host's operating system.
--
--- Note that the operating system may not be declared for all hosts.
+-- > myproperty :: Property Debian
+-- > myproperty = withOS "foo installed" $ \o os -> case os of
+-- > (Just (System (Debian (Stable release)) arch)) -> ensureProperty o ...
+-- > (Just (System (Debian suite) arch)) -> ensureProperty o ...
+-- > _ -> unsupportedOS
--
--- > myproperty = withOS "foo installed" $ \o -> case o of
--- > (Just (System (Debian suite) arch)) -> ...
--- > (Just (System (Buntish release) arch)) -> ...
--- > Nothing -> unsupportedOS
---withOS :: Desc -> (Maybe System -> Propellor Result) -> Property NoInfo
---withOS desc a = property desc $ a =<< getOS
+-- Note that the operating system specifics may not be declared for all hosts,
+-- which is where Nothing comes in.
+withOS
+ :: (SingI metatypes)
+ => Desc
+ -> (OuterMetaTypes '[] -> Maybe System -> Propellor Result)
+ -> Property (MetaTypes metatypes)
+withOS desc a = property desc $ a dummyoutermetatypes =<< getOS
+ where
+ -- Using this dummy value allows ensureProperty to be used
+ -- even though the inner property probably doesn't target everything
+ -- that the outer withOS property targets.
+ dummyoutermetatypes :: OuterMetaTypes ('[])
+ dummyoutermetatypes = OuterMetaTypes sing
-- | Throws an error, for use in `withOS` when a property is lacking
-- support for an OS.
diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs
index 7301a6ae..3dd7277e 100644
--- a/src/Propellor/Property/Apt.hs
+++ b/src/Propellor/Property/Apt.hs
@@ -80,37 +80,36 @@ securityUpdates suite
--
-- Since the CDN is sometimes unreliable, also adds backup lines using
-- kernel.org.
-stdSourcesList :: Property NoInfo
-stdSourcesList = withOS "standard sources.list" $ \o ->
- case o of
- (Just (System (Debian suite) _)) ->
- ensureProperty $ stdSourcesListFor suite
- _ -> error "os is not declared to be Debian"
-
-stdSourcesListFor :: DebianSuite -> Property NoInfo
+stdSourcesList :: Property Debian
+stdSourcesList = withOS "standard sources.list" $ \o os -> case os of
+ (Just (System (Debian suite) _)) ->
+ ensureProperty o $ stdSourcesListFor suite
+ _ -> unsupportedOS
+
+stdSourcesListFor :: DebianSuite -> Property Debian
stdSourcesListFor suite = stdSourcesList' suite []
-- | Adds additional sources.list generators.
--
-- Note that if a Property needs to enable an apt source, it's better
-- to do so via a separate file in </etc/apt/sources.list.d/>
-stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property NoInfo
-stdSourcesList' suite more = setSourcesList
+stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property Debian
+stdSourcesList' suite more = tightenTargets $ setSourcesList
(concatMap (\gen -> gen suite) generators)
`describe` ("standard sources.list for " ++ show suite)
where
generators = [debCdn, kernelOrg, securityUpdates] ++ more
-setSourcesList :: [Line] -> Property NoInfo
+setSourcesList :: [Line] -> Property DebianLike
setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update
-setSourcesListD :: [Line] -> FilePath -> Property NoInfo
+setSourcesListD :: [Line] -> FilePath -> Property DebianLike
setSourcesListD ls basename = f `File.hasContent` ls `onChange` update
where
f = "/etc/apt/sources.list.d/" ++ basename ++ ".list"
-runApt :: [String] -> UncheckedProperty NoInfo
-runApt ps = cmdPropertyEnv "apt-get" ps noninteractiveEnv
+runApt :: [String] -> UncheckedProperty DebianLike
+runApt ps = tightenTargets $ cmdPropertyEnv "apt-get" ps noninteractiveEnv
noninteractiveEnv :: [(String, String)]
noninteractiveEnv =
@@ -118,51 +117,51 @@ noninteractiveEnv =
, ("APT_LISTCHANGES_FRONTEND", "none")
]
-update :: Property NoInfo
+update :: Property DebianLike
update = runApt ["update"]
`assume` MadeChange
`describe` "apt update"
-- | Have apt upgrade packages, adding new packages and removing old as
-- necessary.
-upgrade :: Property NoInfo
+upgrade :: Property DebianLike
upgrade = upgrade' "dist-upgrade"
-upgrade' :: String -> Property NoInfo
-upgrade' p = combineProperties ("apt " ++ p)
- [ pendingConfigured
- , runApt ["-y", p]
+upgrade' :: String -> Property DebianLike
+upgrade' p = combineProperties ("apt " ++ p) $ props
+ & pendingConfigured
+ & runApt ["-y", p]
`assume` MadeChange
- ]
-- | Have apt upgrade packages, but never add new packages or remove
-- old packages. Not suitable for upgrading acrocess major versions
-- of the distribution.
-safeUpgrade :: Property NoInfo
+safeUpgrade :: Property DebianLike
safeUpgrade = upgrade' "upgrade"
-- | Have dpkg try to configure any packages that are not fully configured.
-pendingConfigured :: Property NoInfo
-pendingConfigured = cmdPropertyEnv "dpkg" ["--configure", "--pending"] noninteractiveEnv
- `assume` MadeChange
- `describe` "dpkg configured pending"
+pendingConfigured :: Property DebianLike
+pendingConfigured = tightenTargets $
+ cmdPropertyEnv "dpkg" ["--configure", "--pending"] noninteractiveEnv
+ `assume` MadeChange
+ `describe` "dpkg configured pending"
type Package = String
-installed :: [Package] -> Property NoInfo
+installed :: [Package] -> Property DebianLike
installed = installed' ["-y"]
-installed' :: [String] -> [Package] -> Property NoInfo
+installed' :: [String] -> [Package] -> Property DebianLike
installed' params ps = robustly $ check (isInstallable ps) go
`describe` unwords ("apt installed":ps)
where
go = runApt (params ++ ["install"] ++ ps)
-installedBackport :: [Package] -> Property NoInfo
-installedBackport ps = withOS desc $ \o -> case o of
+installedBackport :: [Package] -> Property DebianLike
+installedBackport ps = withOS desc $ \o os -> case os of
(Just (System (Debian suite) _)) -> case backportSuite suite of
Nothing -> unsupportedOS
- Just bs -> ensureProperty $
+ Just bs -> ensureProperty o $
runApt (["install", "-t", bs, "-y"] ++ ps)
`changesFile` dpkgStatus
_ -> unsupportedOS
@@ -170,14 +169,14 @@ installedBackport ps = withOS desc $ \o -> case o of
desc = unwords ("apt installed backport":ps)
-- | Minimal install of package, without recommends.
-installedMin :: [Package] -> Property NoInfo
+installedMin :: [Package] -> Property DebianLike
installedMin = installed' ["--no-install-recommends", "-y"]
-removed :: [Package] -> Property NoInfo
+removed :: [Package] -> Property DebianLike
removed ps = check (or <$> isInstalled' ps) (runApt (["-y", "remove"] ++ ps))
`describe` unwords ("apt removed":ps)
-buildDep :: [Package] -> Property NoInfo
+buildDep :: [Package] -> Property DebianLike
buildDep ps = robustly $ go
`changesFile` dpkgStatus
`describe` unwords ("apt build-dep":ps)
@@ -187,7 +186,7 @@ buildDep ps = robustly $ go
-- | Installs the build deps for the source package unpacked
-- in the specifed directory, with a dummy package also
-- installed so that autoRemove won't remove them.
-buildDepIn :: FilePath -> Property NoInfo
+buildDepIn :: FilePath -> Property DebianLike
buildDepIn dir = cmdPropertyEnv "sh" ["-c", cmd] noninteractiveEnv
`changesFile` dpkgStatus
`requires` installedMin ["devscripts", "equivs"]
@@ -196,13 +195,13 @@ buildDepIn dir = cmdPropertyEnv "sh" ["-c", cmd] noninteractiveEnv
-- | Package installation may fail becuse the archive has changed.
-- Run an update in that case and retry.
-robustly :: (Combines (Property i) (Property NoInfo)) => Property i -> Property i
+robustly :: Property DebianLike -> Property DebianLike
robustly p = adjustPropertySatisfy p $ \satisfy -> do
r <- satisfy
if r == FailedChange
- -- Safe to use ignoreInfo because we're re-running
- -- the same property.
- then ensureProperty $ ignoreInfo $ p `requires` update
+ -- Safe to use getSatisfy because we're re-running
+ -- the same property as before.
+ then getSatisfy $ p `requires` update
else return r
isInstallable :: [Package] -> IO Bool
@@ -228,13 +227,13 @@ isInstalled' ps = (mapMaybe parse . lines) <$> policy
environ <- addEntry "LANG" "C" <$> getEnvironment
readProcessEnv "apt-cache" ("policy":ps) (Just environ)
-autoRemove :: Property NoInfo
+autoRemove :: Property DebianLike
autoRemove = runApt ["-y", "autoremove"]
`changesFile` dpkgStatus
`describe` "apt autoremove"
-- | Enables unattended upgrades. Revert to disable.
-unattendedUpgrades :: RevertableProperty NoInfo
+unattendedUpgrades :: RevertableProperty DebianLike DebianLike
unattendedUpgrades = enable <!> disable
where
enable = setup True
@@ -253,11 +252,12 @@ unattendedUpgrades = enable <!> disable
| enabled = "true"
| otherwise = "false"
- configure = withOS "unattended upgrades configured" $ \o ->
- case o of
+ configure :: Property DebianLike
+ configure = withOS "unattended upgrades configured" $ \o os ->
+ case os of
-- the package defaults to only upgrading stable
(Just (System (Debian suite) _))
- | not (isStable suite) -> ensureProperty $
+ | not (isStable suite) -> ensureProperty o $
"/etc/apt/apt.conf.d/50unattended-upgrades"
`File.containsLine`
("Unattended-Upgrade::Origins-Pattern { \"o=Debian,a="++showSuite suite++"\"; };")
@@ -269,10 +269,13 @@ type DebconfTemplateValue = String
-- | Preseeds debconf values and reconfigures the package so it takes
-- effect.
-reConfigure :: Package -> [(DebconfTemplate, DebconfTemplateType, DebconfTemplateValue)] -> Property NoInfo
-reConfigure package vals = reconfigure `requires` setselections
- `describe` ("reconfigure " ++ package)
+reConfigure :: Package -> [(DebconfTemplate, DebconfTemplateType, DebconfTemplateValue)] -> Property DebianLike
+reConfigure package vals = tightenTargets $
+ reconfigure
+ `requires` setselections
+ `describe` ("reconfigure " ++ package)
where
+ setselections :: Property DebianLike
setselections = property "preseed" $
if null vals
then noChange
@@ -289,7 +292,7 @@ reConfigure package vals = reconfigure `requires` setselections
--
-- Assumes that there is a 1:1 mapping between service names and apt
-- package names.
-serviceInstalledRunning :: Package -> Property NoInfo
+serviceInstalledRunning :: Package -> Property DebianLike
serviceInstalledRunning svc = Service.running svc `requires` installed [svc]
data AptKey = AptKey
@@ -297,10 +300,10 @@ data AptKey = AptKey
, pubkey :: String
}
-trustsKey :: AptKey -> RevertableProperty NoInfo
+trustsKey :: AptKey -> RevertableProperty DebianLike DebianLike
trustsKey k = trustsKey' k <!> untrustKey k
-trustsKey' :: AptKey -> Property NoInfo
+trustsKey' :: AptKey -> Property DebianLike
trustsKey' k = check (not <$> doesFileExist f) $ property desc $ makeChange $ do
withHandle StdinHandle createProcessSuccess
(proc "gpg" ["--no-default-keyring", "--keyring", f, "--import", "-"]) $ \h -> do
@@ -311,21 +314,21 @@ trustsKey' k = check (not <$> doesFileExist f) $ property desc $ makeChange $ do
desc = "apt trusts key " ++ keyname k
f = aptKeyFile k
-untrustKey :: AptKey -> Property NoInfo
-untrustKey = File.notPresent . aptKeyFile
+untrustKey :: AptKey -> Property DebianLike
+untrustKey = tightenTargets . File.notPresent . aptKeyFile
aptKeyFile :: AptKey -> FilePath
aptKeyFile k = "/etc/apt/trusted.gpg.d" </> keyname k ++ ".gpg"
-- | Cleans apt's cache of downloaded packages to avoid using up disk
-- space.
-cacheCleaned :: Property NoInfo
-cacheCleaned = cmdProperty "apt-get" ["clean"]
+cacheCleaned :: Property DebianLike
+cacheCleaned = tightenTargets $ cmdProperty "apt-get" ["clean"]
`assume` NoChange
`describe` "apt cache cleaned"
-- | Add a foreign architecture to dpkg and apt.
-hasForeignArch :: String -> Property NoInfo
+hasForeignArch :: String -> Property DebianLike
hasForeignArch arch = check notAdded (add `before` update)
`describe` ("dpkg has foreign architecture " ++ arch)
where
diff --git a/src/Propellor/Property/Service.hs b/src/Propellor/Property/Service.hs
index 0e96ed4c..46f9e8ef 100644
--- a/src/Propellor/Property/Service.hs
+++ b/src/Propellor/Property/Service.hs
@@ -11,17 +11,17 @@ type ServiceName = String
-- Note that due to the general poor state of init scripts, the best
-- we can do is try to start the service, and if it fails, assume
-- this means it's already running.
-running :: ServiceName -> Property NoInfo
+running :: ServiceName -> Property DebianLike
running = signaled "start" "running"
-restarted :: ServiceName -> Property NoInfo
+restarted :: ServiceName -> Property DebianLike
restarted = signaled "restart" "restarted"
-reloaded :: ServiceName -> Property NoInfo
+reloaded :: ServiceName -> Property DebianLike
reloaded = signaled "reload" "reloaded"
-signaled :: String -> Desc -> ServiceName -> Property NoInfo
-signaled cmd desc svc = p `describe` (desc ++ " " ++ svc)
+signaled :: String -> Desc -> ServiceName -> Property DebianLike
+signaled cmd desc svc = tightenTargets $ p `describe` (desc ++ " " ++ svc)
where
p = scriptProperty ["service " ++ shellEscape svc ++ " " ++ cmd ++ " >/dev/null 2>&1 || true"]
`assume` NoChange
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index db05e100..7098c83f 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -42,6 +42,7 @@ module Propellor.Types
, module Propellor.Types.Dns
, module Propellor.Types.Result
, module Propellor.Types.ZFS
+ , TightenTargets(..)
) where
import Data.Monoid
@@ -285,3 +286,25 @@ instance (CheckCombinable x y ~ 'CanCombine, SingI (Combine x y)) => Combines (R
combineWith sf tf (RevertableProperty x _) y = combineWith sf tf x y
instance (CheckCombinable x y ~ 'CanCombine, SingI (Combine x y)) => Combines (Property (MetaTypes x)) (RevertableProperty (MetaTypes y) (MetaTypes y')) where
combineWith sf tf x (RevertableProperty y _) = combineWith sf tf x y
+
+class TightenTargets p where
+ -- | Tightens the MetaType list of a Property (or similar),
+ -- to contain fewer targets.
+ --
+ -- For example, to make a property that uses apt-get, which is only
+ -- available on DebianLike systems:
+ --
+ -- > upgraded :: Property DebianLike
+ -- > upgraded = tightenTargets $ cmdProperty "apt-get" ["upgrade"]
+ tightenTargets
+ ::
+ -- Note that this uses PolyKinds
+ ( (Targets untightened `NotSuperset` Targets tightened) ~ 'CanCombine
+ , (NonTargets tightened `NotSuperset` NonTargets untightened) ~ 'CanCombine
+ , SingI tightened
+ )
+ => p (MetaTypes untightened)
+ -> p (MetaTypes tightened)
+
+instance TightenTargets Property where
+ tightenTargets (Property _ d a i c) = Property sing d a i c
diff --git a/src/Propellor/Types/ResultCheck.hs b/src/Propellor/Types/ResultCheck.hs
index 4c6524ee..f03c174f 100644
--- a/src/Propellor/Types/ResultCheck.hs
+++ b/src/Propellor/Types/ResultCheck.hs
@@ -22,6 +22,9 @@ import Data.Monoid
-- and `FailedChange` is still an error.
data UncheckedProperty i = UncheckedProperty (Property i)
+instance TightenTargets UncheckedProperty where
+ tightenTargets (UncheckedProperty p) = UncheckedProperty (tightenTargets p)
+
-- | Use to indicate that a Property is unchecked.
unchecked :: Property i -> UncheckedProperty i
unchecked = UncheckedProperty