summaryrefslogtreecommitdiff
path: root/src/Propellor
diff options
context:
space:
mode:
authorJoey Hess2016-03-26 19:31:23 -0400
committerJoey Hess2016-03-26 19:31:23 -0400
commit36e97137e538de401bd0340b469e10dca5f4b475 (patch)
tree1c735c4a0c39b2b23862e57069eb32a832d52fd7 /src/Propellor
parent42da8445470a6e4950873fc5d6bea88646ec2b63 (diff)
ported propagateContainer
Renamed several utility functions along the way.
Diffstat (limited to 'src/Propellor')
-rw-r--r--src/Propellor/Container.hs46
-rw-r--r--src/Propellor/Info.hs6
-rw-r--r--src/Propellor/PrivData.hs4
-rw-r--r--src/Propellor/PropAccum.hs33
-rw-r--r--src/Propellor/Property/Chroot.hs43
-rw-r--r--src/Propellor/Property/Concurrent.hs2
-rw-r--r--src/Propellor/Property/Conductor.hs8
-rw-r--r--src/Propellor/Property/Dns.hs10
-rw-r--r--src/Propellor/Property/Docker.hs10
-rw-r--r--src/Propellor/Property/List.hs4
-rw-r--r--src/Propellor/Property/Partition.hs2
-rw-r--r--src/Propellor/Property/Postfix.hs2
-rw-r--r--src/Propellor/Property/Scheduled.hs6
-rw-r--r--src/Propellor/Property/Systemd.hs18
-rw-r--r--src/Propellor/Spin.hs4
-rw-r--r--src/Propellor/Types.hs48
-rw-r--r--src/Propellor/Types/Info.hs6
17 files changed, 125 insertions, 127 deletions
diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs
new file mode 100644
index 00000000..6e974efd
--- /dev/null
+++ b/src/Propellor/Container.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE DataKinds, TypeFamilies #-}
+
+module Propellor.Container where
+
+import Propellor.Types
+import Propellor.Types.MetaTypes
+import Propellor.Types.Info
+import Propellor.PrivData
+
+class Container c where
+ containerProperties :: c -> [ChildProperty]
+ containerInfo :: c -> Info
+
+instance Container Host where
+ containerProperties = hostProperties
+ containerInfo = hostInfo
+
+-- | Adjust the provided Property, adding to its
+-- propertyChidren the properties of the provided container.
+--
+-- The Info of the propertyChildren is adjusted to only include
+-- info that should be propagated out to the Property.
+--
+-- Any PrivInfo that uses HostContext is adjusted to use the name
+-- of the container as its context.
+propagateContainer
+ ::
+ -- Since the children being added probably have info,
+ -- require the Property's metatypes to have info.
+ ( IncludesInfo metatypes ~ 'True
+ , Container c
+ )
+ => String
+ -> c
+ -> Property metatypes
+ -> Property metatypes
+propagateContainer containername c prop = prop
+ `addChildren` map convert (containerProperties c)
+ where
+ convert p =
+ let n = property (getDesc p) (getSatisfy p) :: Property UnixLike
+ n' = n
+ `addInfoProperty` mapInfo (forceHostContext containername)
+ (propagatableInfo (getInfo p))
+ `addChildren` map convert (getChildren p)
+ in toChildProperty n'
diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs
index 725a02ad..ff0b3b5e 100644
--- a/src/Propellor/Info.hs
+++ b/src/Propellor/Info.hs
@@ -42,7 +42,7 @@ pureInfoProperty' desc i = addInfoProperty p i
-- | Gets a value from the host's Info.
askInfo :: (IsInfo v) => Propellor v
-askInfo = asks (getInfo . hostInfo)
+askInfo = asks (fromInfo . hostInfo)
-- | Specifies that a host's operating system is Debian,
-- and further indicates the suite and architecture.
@@ -129,7 +129,7 @@ hostMap l = M.fromList $ zip (map hostName l) l
aliasMap :: [Host] -> M.Map HostName Host
aliasMap = M.fromList . concat .
- map (\h -> map (\aka -> (aka, h)) $ fromAliasesInfo $ getInfo $ hostInfo h)
+ map (\h -> map (\aka -> (aka, h)) $ fromAliasesInfo $ fromInfo $ hostInfo h)
findHost :: [Host] -> HostName -> Maybe Host
findHost l hn = (findHostNoAlias l hn) <|> (findAlias l hn)
@@ -141,7 +141,7 @@ findAlias :: [Host] -> HostName -> Maybe Host
findAlias l hn = M.lookup hn (aliasMap l)
getAddresses :: Info -> [IPAddr]
-getAddresses = mapMaybe getIPAddr . S.toList . fromDnsInfo . getInfo
+getAddresses = mapMaybe getIPAddr . S.toList . fromDnsInfo . fromInfo
hostAddresses :: HostName -> [Host] -> [IPAddr]
hostAddresses hn hosts = maybe [] (getAddresses . hostInfo) (findHost hosts hn)
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index 77c7133f..0bc0c100 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -161,7 +161,7 @@ filterPrivData :: Host -> PrivMap -> PrivMap
filterPrivData host = M.filterWithKey (\k _v -> S.member k used)
where
used = S.map (\(f, _, c) -> (f, mkHostContext c (hostName host))) $
- fromPrivInfo $ getInfo $ hostInfo host
+ fromPrivInfo $ fromInfo $ hostInfo host
getPrivData :: PrivDataField -> Context -> PrivMap -> Maybe PrivData
getPrivData field context m = do
@@ -245,7 +245,7 @@ mkUsedByMap = M.unionsWith (++) . map (\h -> mkPrivDataMap h $ const [hostName h
mkPrivDataMap :: Host -> (Maybe PrivDataSourceDesc -> a) -> M.Map (PrivDataField, Context) a
mkPrivDataMap host mkv = M.fromList $
map (\(f, d, c) -> ((f, mkHostContext c (hostName host)), mkv d))
- (S.toList $ fromPrivInfo $ getInfo $ hostInfo host)
+ (S.toList $ fromPrivInfo $ fromInfo $ hostInfo host)
setPrivDataTo :: PrivDataField -> Context -> PrivData -> IO ()
setPrivDataTo field context (PrivData value) = do
diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs
index 8281b9a1..af362ca7 100644
--- a/src/Propellor/PropAccum.hs
+++ b/src/Propellor/PropAccum.hs
@@ -12,7 +12,6 @@ module Propellor.PropAccum
, (&)
, (&^)
, (!)
- --, propagateContainer
) where
import Propellor.Types
@@ -82,35 +81,3 @@ Props c &^ p = Props (toChildProperty p : c)
-> RevertableProperty (MetaTypes y) (MetaTypes z)
-> Props (MetaTypes (Combine x z))
Props c ! p = Props (c ++ [toChildProperty (revert p)])
-
-{-
-
--- | Adjust the provided Property, adding to its
--- propertyChidren the properties of the provided container.
---
--- The Info of the propertyChildren is adjusted to only include
--- info that should be propagated out to the Property.
---
--- Any PrivInfo that uses HostContext is adjusted to use the name
--- of the container as its context.
-propagateContainer
- :: (PropAccum container)
- => String
- -> container
- -> Property metatypes
- -> Property metatypes
-propagateContainer containername c prop = Property
- undefined
- (propertyDesc prop)
- (getSatisfy prop)
- (propertyInfo prop)
- (propertyChildren prop ++ hostprops)
- where
- hostprops = map go $ getProperties c
- go p =
- let i = mapInfo (forceHostContext containername)
- (propagatableInfo (propertyInfo p))
- cs = map go (propertyChildren p)
- in infoProperty (propertyDesc p) (getSatisfy p) i cs
-
--}
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 4480f98d..547e5c94 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -41,23 +41,18 @@ data Chroot where
Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot
chrootSystem :: Chroot -> Maybe System
-chrootSystem (Chroot _ _ h) = fromInfoVal (getInfo (hostInfo h))
+chrootSystem (Chroot _ _ h) = fromInfoVal (fromInfo (hostInfo h))
instance Show Chroot where
show c@(Chroot loc _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c)
-instance PropAccum Chroot where
- (Chroot l c h) `addProp` p = Chroot l c (h & p)
- (Chroot l c h) `addPropFront` p = Chroot l c (h `addPropFront` p)
- getProperties (Chroot _ _ h) = hostProperties h
-
-- | Class of things that can do initial bootstrapping of an operating
-- System in a chroot.
class ChrootBootstrapper b where
-- | Do initial bootstrapping of an operating system in a chroot.
-- If the operating System is not supported, return
-- Left error message.
- buildchroot :: b -> Maybe System -> FilePath -> Either String (Property HasInfo)
+ buildchroot :: b -> Maybe System -> FilePath -> Either String (Property (HasInfo + UnixLike))
-- | Use this to bootstrap a chroot by extracting a tarball.
--
@@ -70,12 +65,11 @@ data ChrootTarball = ChrootTarball FilePath
instance ChrootBootstrapper ChrootTarball where
buildchroot (ChrootTarball tb) _ loc = Right $ extractTarball loc tb
-extractTarball :: FilePath -> FilePath -> Property HasInfo
-extractTarball target src = toProp .
- check (unpopulated target) $
- cmdProperty "tar" params
- `assume` MadeChange
- `requires` File.dirExists target
+extractTarball :: FilePath -> FilePath -> Property UnixLike
+extractTarball target src = check (unpopulated target) $
+ cmdProperty "tar" params
+ `assume` MadeChange
+ `requires` File.dirExists target
where
params =
[ "-C"
@@ -92,14 +86,15 @@ instance ChrootBootstrapper Debootstrapped where
(Just s@(System (Debian _) _)) -> Right $ debootstrap s
(Just s@(System (Buntish _) _)) -> Right $ debootstrap s
(Just (System (FreeBSD _) _)) -> Left "FreeBSD not supported by debootstrap."
- Nothing -> Left "Cannot debootstrap; `os` property not specified"
+ Nothing -> Left "Cannot debootstrap; OS not specified"
where
debootstrap s = Debootstrap.built loc s cf
-- | Defines a Chroot at the given location, built with debootstrap.
--
-- Properties can be added to configure the Chroot. At a minimum,
--- add the `os` property to specify the operating system to bootstrap.
+-- add a property such as `osDebian` to specify the operating system
+-- to bootstrap.
--
-- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev"
-- > & osDebian Unstable "amd64"
@@ -131,25 +126,25 @@ provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly =
(propertyList (chrootDesc c "removed") [teardown])
where
setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly
- `requires` toProp built
+ `requires` built
built = case buildchroot bootstrapper (chrootSystem c) loc of
Right p -> p
Left e -> cantbuild e
- cantbuild e = infoProperty (chrootDesc c "built") (error e) mempty []
+ cantbuild e = property (chrootDesc c "built") (error e)
teardown = check (not <$> unpopulated loc) $
property ("removed " ++ loc) $
makeChange (removeChroot loc)
-propagateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property HasInfo
+propagateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property (HasInfo + UnixLike)
propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c p'
where
p' = infoProperty
- (propertyDesc p)
+ (getDesc p)
(getSatisfy p)
- (propertyInfo p <> chrootInfo c)
+ (getInfo p <> chrootInfo c)
(propertyChildren p)
chrootInfo :: Chroot -> Info
@@ -157,7 +152,7 @@ chrootInfo (Chroot loc _ h) = mempty `addInfo`
mempty { _chroots = M.singleton loc h }
-- | Propellor is run inside the chroot to provision it.
-propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property NoInfo
+propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property UnixLike
propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do
let d = localdir </> shimdir c
let me = localdir </> "propellor"
@@ -205,7 +200,7 @@ chain :: [Host] -> CmdLine -> IO ()
chain hostlist (ChrootChain hn loc systemdonly onconsole) =
case findHostNoAlias hostlist hn of
Nothing -> errorMessage ("cannot find host " ++ hn)
- Just parenthost -> case M.lookup loc (_chroots $ getInfo $ hostInfo parenthost) of
+ Just parenthost -> case M.lookup loc (_chroots $ fromInfo $ hostInfo parenthost) of
Nothing -> errorMessage ("cannot find chroot " ++ loc ++ " on host " ++ hn)
Just h -> go h
where
@@ -215,7 +210,7 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) =
onlyProcess (provisioningLock loc) $ do
r <- runPropellor (setInChroot h) $ ensureChildProperties $
if systemdonly
- then [toProp Systemd.installed]
+ then [toChildProperty Systemd.installed]
else hostProperties h
flushConcurrentOutput
putStrLn $ "\n" ++ show r
@@ -257,7 +252,7 @@ chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc
-- 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 NoInfo
+noServices :: RevertableProperty DebianLike DebianLike
noServices = setup <!> teardown
where
f = "/usr/sbin/policy-rc.d"
diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs
index a86c839f..ace85a3c 100644
--- a/src/Propellor/Property/Concurrent.hs
+++ b/src/Propellor/Property/Concurrent.hs
@@ -78,7 +78,7 @@ concurrently p1 p2 = (combineWith go go p1 p2)
-- The above example will run foo and bar concurrently, and once either of
-- those 2 properties finishes, will start running baz.
concurrentList :: SingI metatypes => IO Int -> Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
-concurrentList getn d (Props ps) = property d go `modifyChildren` (++ ps)
+concurrentList getn d (Props ps) = property d go `addChildren` ps
where
go = do
n <- liftIO getn
diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs
index ec15281b..8fe607bc 100644
--- a/src/Propellor/Property/Conductor.hs
+++ b/src/Propellor/Property/Conductor.hs
@@ -126,7 +126,7 @@ mkOrchestra = fromJust . go S.empty
where
go seen h
| S.member (hostName h) seen = Nothing -- break loop
- | otherwise = Just $ case getInfo (hostInfo h) of
+ | otherwise = Just $ case fromInfo (hostInfo h) of
ConductorFor [] -> Conducted h
ConductorFor l ->
let seen' = S.insert (hostName h) seen
@@ -214,7 +214,7 @@ orchestrate :: [Host] -> [Host]
orchestrate hs = map go hs
where
go h
- | isOrchestrated (getInfo (hostInfo h)) = h
+ | isOrchestrated (fromInfo (hostInfo h)) = h
| otherwise = foldl orchestrate' (removeold h) (map (deloop h) os)
os = extractOrchestras hs
@@ -222,7 +222,7 @@ orchestrate hs = map go hs
removeold' h oldconductor = addPropHost h $
undoRevertableProperty $ conductedBy oldconductor
- oldconductors = zip hs (map (getInfo . hostInfo) hs)
+ oldconductors = zip hs (map (fromInfo . hostInfo) hs)
oldconductorsof h = flip mapMaybe oldconductors $
\(oldconductor, NotConductorFor l) ->
if any (sameHost h) l
@@ -299,7 +299,7 @@ addConductorPrivData h hs = h { hostInfo = hostInfo h <> i }
i = mempty
`addInfo` mconcat (map privinfo hs)
`addInfo` Orchestrated (Any True)
- privinfo h' = forceHostContext (hostName h') $ getInfo (hostInfo h')
+ privinfo h' = forceHostContext (hostName h') $ fromInfo (hostInfo h')
-- Use this property to let the specified conductor ssh in and run propellor.
conductedBy :: Host -> RevertableProperty DebianLike UnixLike
diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
index a660a016..2b5596bd 100644
--- a/src/Propellor/Property/Dns.hs
+++ b/src/Propellor/Property/Dns.hs
@@ -213,7 +213,7 @@ otherServers :: DnsServerType -> [Host] -> Domain -> [HostName]
otherServers wantedtype hosts domain =
M.keys $ M.filter wanted $ hostMap hosts
where
- wanted h = case M.lookup domain (fromNamedConfMap $ getInfo $ hostInfo h) of
+ wanted h = case M.lookup domain (fromNamedConfMap $ fromInfo $ hostInfo h) of
Nothing -> False
Just conf -> confDnsServerType conf == wantedtype
&& confDomain conf == domain
@@ -468,7 +468,7 @@ genZone inzdomain hostmap zdomain soa =
-- So we can just use the IPAddrs.
addcnames :: Host -> [Either WarningMessage (BindDomain, Record)]
addcnames h = concatMap gen $ filter (inDomain zdomain) $
- mapMaybe getCNAME $ S.toList $ fromDnsInfo $ getInfo info
+ mapMaybe getCNAME $ S.toList $ fromDnsInfo $ fromInfo info
where
info = hostInfo h
gen c = case getAddresses info of
@@ -483,7 +483,7 @@ genZone inzdomain hostmap zdomain soa =
where
info = hostInfo h
l = zip (repeat $ AbsDomain $ hostName h)
- (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (fromDnsInfo $ getInfo info))
+ (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (fromDnsInfo $ fromInfo info))
-- Simplifies the list of hosts. Remove duplicate entries.
-- Also, filter out any CHAMES where the same domain has an
@@ -518,7 +518,7 @@ addNamedConf conf = NamedConfMap (M.singleton domain conf)
domain = confDomain conf
getNamedConf :: Propellor (M.Map Domain NamedConf)
-getNamedConf = asks $ fromNamedConfMap . getInfo . hostInfo
+getNamedConf = asks $ fromNamedConfMap . fromInfo . hostInfo
-- | Generates SSHFP records for hosts in the domain (or with CNAMES
-- in the domain) that have configured ssh public keys.
@@ -531,7 +531,7 @@ genSSHFP domain h = concatMap mk . concat <$> (gen =<< get)
gen = liftIO . mapM genSSHFP' . M.elems . fromMaybe M.empty
mk r = mapMaybe (\d -> if inDomain domain d then Just (d, r) else Nothing)
(AbsDomain hostname : cnames)
- cnames = mapMaybe getCNAME $ S.toList $ fromDnsInfo $ getInfo info
+ cnames = mapMaybe getCNAME $ S.toList $ fromDnsInfo $ fromInfo info
hostname = hostName h
info = hostInfo h
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index d19d15aa..fe1e3b18 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -172,9 +172,9 @@ propagateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Pr
propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr p'
where
p' = infoProperty
- (propertyDesc p)
+ (getDesc p)
(getSatisfy p)
- (propertyInfo p <> dockerinfo)
+ (getInfo p <> dockerinfo)
(propertyChildren p)
dockerinfo = dockerInfo $
mempty { _dockerContainers = M.singleton cn h }
@@ -186,7 +186,7 @@ mkContainerInfo cid@(ContainerId hn _cn) (Container img h) =
where
runparams = map (\(DockerRunParam mkparam) -> mkparam hn)
(_dockerRunParams info)
- info = getInfo $ hostInfo h'
+ info = fromInfo $ hostInfo h'
h' = h
-- Restart by default so container comes up on
-- boot or when docker is upgraded.
@@ -435,7 +435,7 @@ myContainerSuffix = ".propellor"
containerDesc :: (IsProp (Property i)) => ContainerId -> Property i -> Property i
containerDesc cid p = p `describe` desc
where
- desc = "container " ++ fromContainerId cid ++ " " ++ propertyDesc p
+ desc = "container " ++ fromContainerId cid ++ " " ++ getDesc p
runningContainer :: ContainerId -> Image -> [RunParam] -> Property Linux
runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do
@@ -574,7 +574,7 @@ chain hostlist hn s = case toContainerId s of
Nothing -> errorMessage "bad container id"
Just cid -> case findHostNoAlias hostlist hn of
Nothing -> errorMessage ("cannot find host " ++ hn)
- Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ getInfo $ hostInfo parenthost) of
+ Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ fromInfo $ hostInfo parenthost) of
Nothing -> errorMessage ("cannot find container " ++ containerName cid ++ " docked on host " ++ hn)
Just h -> go cid h
where
diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs
index 304d0863..a8b8347a 100644
--- a/src/Propellor/Property/List.hs
+++ b/src/Propellor/Property/List.hs
@@ -35,7 +35,7 @@ toProps ps = Props (map toChildProperty ps)
propertyList :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
propertyList desc (Props ps) =
property desc (ensureChildProperties cs)
- `modifyChildren` (++ cs)
+ `addChildren` cs
where
cs = map toChildProperty ps
@@ -44,7 +44,7 @@ propertyList desc (Props ps) =
combineProperties :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
combineProperties desc (Props ps) =
property desc (combineSatisfy cs NoChange)
- `modifyChildren` (++ cs)
+ `addChildren` cs
where
cs = map toChildProperty ps
diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs
index 5aff4ba4..291d4168 100644
--- a/src/Propellor/Property/Partition.hs
+++ b/src/Propellor/Property/Partition.hs
@@ -68,7 +68,7 @@ kpartx :: FilePath -> ([LoopDev] -> Property DebianLike) -> Property DebianLike
kpartx diskimage mkprop = go `requires` Apt.installed ["kpartx"]
where
go :: Property DebianLike
- go = property' (propertyDesc (mkprop [])) $ \w -> do
+ go = property' (getDesc (mkprop [])) $ \w -> do
cleanup -- idempotency
loopdevs <- liftIO $ kpartxParse
<$> readProcess "kpartx" ["-avs", diskimage]
diff --git a/src/Propellor/Property/Postfix.hs b/src/Propellor/Property/Postfix.hs
index 7d9e7068..45aa4e42 100644
--- a/src/Propellor/Property/Postfix.hs
+++ b/src/Propellor/Property/Postfix.hs
@@ -304,7 +304,7 @@ saslAuthdInstalled = setupdaemon
-- | Uses `saslpasswd2` to set the password for a user in the sasldb2 file.
--
-- The password is taken from the privdata.
-saslPasswdSet :: Domain -> User -> Property HasInfo
+saslPasswdSet :: Domain -> User -> Property (HasInfo + UnixLike)
saslPasswdSet domain (User user) = go `changesFileContent` "/etc/sasldb2"
where
go = withPrivData src ctx $ \getpw ->
diff --git a/src/Propellor/Property/Scheduled.hs b/src/Propellor/Property/Scheduled.hs
index 534e1e88..95e4e362 100644
--- a/src/Propellor/Property/Scheduled.hs
+++ b/src/Propellor/Property/Scheduled.hs
@@ -22,18 +22,18 @@ import qualified Data.Map as M
-- last run.
period :: (IsProp (Property i)) => Property i -> Recurrance -> Property i
period prop recurrance = flip describe desc $ adjustPropertySatisfy prop $ \satisfy -> do
- lasttime <- liftIO $ getLastChecked (propertyDesc prop)
+ lasttime <- liftIO $ getLastChecked (getDesc prop)
nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime
t <- liftIO localNow
if Just t >= nexttime
then do
r <- satisfy
- liftIO $ setLastChecked t (propertyDesc prop)
+ liftIO $ setLastChecked t (getDesc prop)
return r
else noChange
where
schedule = Schedule recurrance AnyTime
- desc = propertyDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")"
+ desc = getDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")"
-- | Like period, but parse a human-friendly string.
periodParse :: (IsProp (Property i)) => Property i -> String -> Property i
diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs
index 2234ad5c..d909e4df 100644
--- a/src/Propellor/Property/Systemd.hs
+++ b/src/Propellor/Property/Systemd.hs
@@ -214,13 +214,13 @@ container name system mkchroot = Container name c h
--
-- Reverting this property stops the container, removes the systemd unit,
-- and deletes the chroot and all its contents.
-nspawned :: Container -> RevertableProperty HasInfo
+nspawned :: Container -> RevertableProperty (HasInfo + UnixLike) UnixLike
nspawned c@(Container name (Chroot.Chroot loc builder _) h) =
p `describe` ("nspawned " ++ name)
where
p = enterScript c
`before` chrootprovisioned
- `before` nspawnService c (_chrootCfg $ getInfo $ hostInfo h)
+ `before` nspawnService c (_chrootCfg $ fromInfo $ hostInfo h)
`before` containerprovisioned
-- Chroot provisioning is run in systemd-only mode,
@@ -336,7 +336,7 @@ mungename = replace "/" "_"
-- When there is no leading dash, "--" is prepended to the parameter.
--
-- Reverting the property will remove a parameter, if it's present.
-containerCfg :: String -> RevertableProperty HasInfo
+containerCfg :: String -> RevertableProperty (HasInfo + UnixLike) UnixLike
containerCfg p = RevertableProperty (mk True) (mk False)
where
mk b = pureInfoProperty ("container configuration " ++ (if b then "" else "without ") ++ p') $
@@ -348,18 +348,18 @@ containerCfg p = RevertableProperty (mk True) (mk False)
-- | Bind mounts </etc/resolv.conf> from the host into the container.
--
-- This property is enabled by default. Revert it to disable it.
-resolvConfed :: RevertableProperty HasInfo
+resolvConfed :: RevertableProperty (HasInfo + UnixLike) UnixLike
resolvConfed = containerCfg "bind=/etc/resolv.conf"
-- | Link the container's journal to the host's if possible.
-- (Only works if the host has persistent journal enabled.)
--
-- This property is enabled by default. Revert it to disable it.
-linkJournal :: RevertableProperty HasInfo
+linkJournal :: RevertableProperty (HasInfo + UnixLike) UnixLike
linkJournal = containerCfg "link-journal=try-guest"
-- | Disconnect networking of the container from the host.
-privateNetwork :: RevertableProperty HasInfo
+privateNetwork :: RevertableProperty (HasInfo + UnixLike) UnixLike
privateNetwork = containerCfg "private-network"
class Publishable a where
@@ -397,7 +397,7 @@ instance Publishable (Proto, Bound Port) where
-- > & Systemd.running Systemd.networkd
-- > & Systemd.publish (Port 80 ->- Port 8080)
-- > & Apt.installedRunning "apache2"
-publish :: Publishable p => p -> RevertableProperty HasInfo
+publish :: Publishable p => p -> RevertableProperty (HasInfo + UnixLike) UnixLike
publish p = containerCfg $ "--port=" ++ toPublish p
class Bindable a where
@@ -410,9 +410,9 @@ instance Bindable (Bound FilePath) where
toBind v = hostSide v ++ ":" ++ containerSide v
-- | Bind mount a file or directory from the host into the container.
-bind :: Bindable p => p -> RevertableProperty HasInfo
+bind :: Bindable p => p -> RevertableProperty (HasInfo + UnixLike) UnixLike
bind p = containerCfg $ "--bind=" ++ toBind p
-- | Read-only mind mount.
-bindRo :: Bindable p => p -> RevertableProperty HasInfo
+bindRo :: Bindable p => p -> RevertableProperty (HasInfo + UnixLike) UnixLike
bindRo p = containerCfg $ "--bind-ro=" ++ toBind p
diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index 5f103b8a..944696dd 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -90,7 +90,7 @@ spin' mprivdata relay target hst = do
error "remote propellor failed"
where
hn = fromMaybe target relay
- sys = case getInfo (hostInfo hst) of
+ sys = case fromInfo (hostInfo hst) of
InfoVal o -> Just o
NoInfoVal -> Nothing
@@ -170,7 +170,7 @@ getSshTarget target hst
return ip
configips = map fromIPAddr $ mapMaybe getIPAddr $
- S.toList $ fromDnsInfo $ getInfo $ hostInfo hst
+ S.toList $ fromDnsInfo $ fromInfo $ hostInfo hst
-- Update the privdata, repo url, and git repo over the ssh
-- connection, talking to the user's local propellor instance which is
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index ccbfd3e0..2bddfc1a 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -26,11 +26,7 @@ module Propellor.Types
, type (+)
, addInfoProperty
, addInfoProperty'
- , addChildrenProperty
, adjustPropertySatisfy
- , propertyInfo
- , propertyDesc
- , propertyChildren
, RevertableProperty(..)
, (<!>)
, ChildProperty
@@ -124,12 +120,15 @@ type Desc = String
-- internally, so you needn't worry about them.
data Property metatypes = Property metatypes Desc (Propellor Result) Info [ChildProperty]
+instance Show (Property metatypes) where
+ show p = "property " ++ show (getDesc p)
+
-- | Since there are many different types of Properties, they cannot be put
-- into a list. The simplified ChildProperty can be put into a list.
data ChildProperty = ChildProperty Desc (Propellor Result) Info [ChildProperty]
instance Show ChildProperty where
- show (ChildProperty desc _ _ _) = desc
+ show = getDesc
-- | Constructs a Property, from a description and an action to run to
-- ensure the Property is met.
@@ -170,28 +169,10 @@ addInfoProperty'
addInfoProperty' (Property t d a oldi c) newi =
Property t d a (oldi <> newi) c
--- | Adds children to a Property.
-addChildrenProperty :: Property metatypes -> [ChildProperty] -> Property metatypes
-addChildrenProperty (Property t s a i cs) cs' = Property t s a i (cs ++ cs')
-
-- | Changes the action that is performed to satisfy a property.
adjustPropertySatisfy :: Property metatypes -> (Propellor Result -> Propellor Result) -> Property metatypes
adjustPropertySatisfy (Property t d s i c) f = Property t d (f s) i c
-propertyInfo :: Property metatypes -> Info
-propertyInfo (Property _ _ _ i _) = i
-
-propertyDesc :: Property metatypes -> Desc
-propertyDesc (Property _ d _ _ _) = d
-
-instance Show (Property metatypes) where
- show p = "property " ++ show (propertyDesc p)
-
--- | A Property can include a list of child properties that it also
--- satisfies. This allows them to be introspected to collect their info, etc.
-propertyChildren :: Property metatypes -> [ChildProperty]
-propertyChildren (Property _ _ _ _ c) = c
-
-- | A property that can be reverted. The first Property is run
-- normally and the second is run when it's reverted.
data RevertableProperty setupmetatypes undometatypes = RevertableProperty
@@ -209,14 +190,16 @@ instance Show (RevertableProperty setupmetatypes undometatypes) where
-> RevertableProperty setupmetatypes undometatypes
setup <!> undo = RevertableProperty setup undo
--- | Class of types that can be used as properties of a host.
class IsProp p where
setDesc :: p -> Desc -> p
getDesc :: p -> Desc
- modifyChildren :: p -> ([ChildProperty] -> [ChildProperty]) -> p
+ getChildren :: p -> [ChildProperty]
+ addChildren :: p -> [ChildProperty] -> p
-- | Gets the info of the property, combined with all info
-- of all children properties.
getInfoRecursive :: p -> Info
+ -- | Info, not including info from children.
+ getInfo :: p -> Info
-- | Gets a ChildProperty representing the Property.
-- You should not normally need to use this.
toChildProperty :: p -> ChildProperty
@@ -227,19 +210,23 @@ class IsProp p where
instance IsProp (Property metatypes) where
setDesc (Property t _ a i c) d = Property t d a i c
- getDesc = propertyDesc
- modifyChildren (Property t d a i c) f = Property t d a i (f c)
+ getDesc (Property _ d _ _ _) = d
+ getChildren (Property _ _ _ _ c) = c
+ addChildren (Property t d a i c) c' = Property t d a i (c ++ c')
getInfoRecursive (Property _ _ _ i c) =
i <> mconcat (map getInfoRecursive c)
+ getInfo (Property _ _ _ i _) = i
toChildProperty (Property _ d a i c) = ChildProperty d a i c
getSatisfy (Property _ _ a _ _) = a
instance IsProp ChildProperty where
setDesc (ChildProperty _ a i c) d = ChildProperty d a i c
getDesc (ChildProperty d _ _ _) = d
- modifyChildren (ChildProperty d a i c) f = ChildProperty d a i (f c)
+ getChildren (ChildProperty _ _ _ c) = c
+ addChildren (ChildProperty d a i c) c' = ChildProperty d a i (c ++ c')
getInfoRecursive (ChildProperty _ _ i c) =
i <> mconcat (map getInfoRecursive c)
+ getInfo (ChildProperty _ _ i _) = i
toChildProperty = id
getSatisfy (ChildProperty _ a _ _) = a
@@ -248,9 +235,12 @@ instance IsProp (RevertableProperty setupmetatypes undometatypes) where
setDesc (RevertableProperty p1 p2) d =
RevertableProperty (setDesc p1 d) (setDesc p2 ("not " ++ d))
getDesc (RevertableProperty p1 _) = getDesc p1
- modifyChildren (RevertableProperty p1 p2) f = RevertableProperty (modifyChildren p1 f) (modifyChildren p2 f)
+ getChildren (RevertableProperty p1 _) = getChildren p1
+ -- | Only add children to the active side.
+ addChildren (RevertableProperty p1 p2) c = RevertableProperty (addChildren p1 c) p2
-- | Return the Info of the currently active side.
getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1
+ getInfo (RevertableProperty p1 _p2) = getInfo p1
toChildProperty (RevertableProperty p1 _p2) = toChildProperty p1
getSatisfy (RevertableProperty p1 _) = getSatisfy p1
diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs
index bc1543e2..c7f6b82f 100644
--- a/src/Propellor/Types/Info.hs
+++ b/src/Propellor/Types/Info.hs
@@ -5,7 +5,7 @@ module Propellor.Types.Info (
IsInfo(..),
addInfo,
toInfo,
- getInfo,
+ fromInfo,
mapInfo,
propagatableInfo,
InfoVal(..),
@@ -51,8 +51,8 @@ toInfo :: IsInfo v => v -> Info
toInfo = addInfo mempty
-- The list is reversed here because addInfo builds it up in reverse order.
-getInfo :: IsInfo v => Info -> v
-getInfo (Info l) = mconcat (mapMaybe extractInfoEntry (reverse l))
+fromInfo :: IsInfo v => Info -> v
+fromInfo (Info l) = mconcat (mapMaybe extractInfoEntry (reverse l))
-- | Maps a function over all values stored in the Info that are of the
-- appropriate type.