From 91d1833155a2e8be2c435d0a92a750cc9d2f30b5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 25 Mar 2016 14:04:40 -0400 Subject: ported Property.List I wanted to keep propertyList [foo, bar] working, but had some difficulty making the type class approach work. Anyway, that's unlikely to be useful, since foo and bar probably have different types, or could easiy have their types updated breaking it. --- src/Propellor/Property/Concurrent.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src/Propellor/Property/Concurrent.hs') diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs index 74afecc4..8d608a54 100644 --- a/src/Propellor/Property/Concurrent.hs +++ b/src/Propellor/Property/Concurrent.hs @@ -97,7 +97,7 @@ concurrentList getn d (PropList ps) = infoProperty d go mempty ps (p:rest) -> return (rest, Just p) case v of Nothing -> return r - -- This use of propertySatisfy does not lose any + -- This use of getSatisfy does not lose any -- Info asociated with the property, because -- concurrentList sets all the properties as -- children, and so propigates their info. @@ -105,7 +105,7 @@ concurrentList getn d (PropList ps) = infoProperty d go mempty ps hn <- asks hostName r' <- actionMessageOn hn (propertyDesc p) - (propertySatisfy p) + (getSatisfy p) worker q (r <> r') -- | Run an action with the number of capabiities increased as necessary to -- cgit v1.2.3 From ce8d34d094be30e1432ecaaae81b188671180624 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 25 Mar 2016 18:39:50 -0400 Subject: ported more Ssh is WIP and failing to compile quite badly --- src/Propellor/PropAccum.hs | 7 +- src/Propellor/Property/Aiccu.hs | 16 ++-- src/Propellor/Property/Apache.hs | 54 +++++------ src/Propellor/Property/Concurrent.hs | 10 +- src/Propellor/Property/ConfFile.hs | 8 +- src/Propellor/Property/Cron.hs | 6 +- src/Propellor/Property/Debootstrap.hs | 8 +- src/Propellor/Property/LetsEncrypt.hs | 7 +- src/Propellor/Property/List.hs | 1 - src/Propellor/Property/Ssh.hs | 167 +++++++++++++++++----------------- src/Propellor/Types.hs | 1 + 11 files changed, 143 insertions(+), 142 deletions(-) (limited to 'src/Propellor/Property/Concurrent.hs') diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs index 7547a81d..8281b9a1 100644 --- a/src/Propellor/PropAccum.hs +++ b/src/Propellor/PropAccum.hs @@ -15,13 +15,12 @@ module Propellor.PropAccum --, propagateContainer ) where -import Data.Monoid - import Propellor.Types import Propellor.Types.MetaTypes import Propellor.Property -import Propellor.Types.Info -import Propellor.PrivData + +import Data.Monoid +import Prelude -- | Defines a host and its properties. -- diff --git a/src/Propellor/Property/Aiccu.hs b/src/Propellor/Property/Aiccu.hs index 47841a7b..1b28759c 100644 --- a/src/Propellor/Property/Aiccu.hs +++ b/src/Propellor/Property/Aiccu.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} + -- | Maintainer: Jelmer Vernooij module Propellor.Property.Aiccu ( @@ -14,10 +16,10 @@ import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service import qualified Propellor.Property.File as File -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["aiccu"] -restarted :: Property NoInfo +restarted :: Property DebianLike restarted = Service.restarted "aiccu" confPath :: FilePath @@ -41,12 +43,12 @@ config u t p = -- | Configures an ipv6 tunnel using sixxs.net, with the given TunneId -- and sixx.net UserName. -hasConfig :: TunnelId -> UserName -> Property HasInfo -hasConfig t u = prop `onChange` restarted +hasConfig :: TunnelId -> UserName -> Property (HasInfo + DebianLike) +hasConfig t u = prop `onChange` restarted where + prop :: Property (HasInfo + UnixLike) prop = withSomePrivData [(Password (u++"/"++t)), (Password u)] (Context "aiccu") $ - property "aiccu configured" . writeConfig - writeConfig :: (((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Propellor Result - writeConfig getpassword = getpassword $ ensureProperty . go + property' "aiccu configured" . writeConfig + writeConfig getpassword w = getpassword $ ensureProperty w . go go (Password u', p) = confPath `File.hasContentProtected` config u' t p go (f, _) = error $ "Unexpected type of privdata: " ++ show f diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs index e107cb9f..f321143f 100644 --- a/src/Propellor/Property/Apache.hs +++ b/src/Propellor/Property/Apache.hs @@ -6,50 +6,50 @@ import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service import qualified Propellor.Property.LetsEncrypt as LetsEncrypt -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["apache2"] -restarted :: Property NoInfo +restarted :: Property DebianLike restarted = Service.restarted "apache2" -reloaded :: Property NoInfo +reloaded :: Property DebianLike reloaded = Service.reloaded "apache2" type ConfigLine = String type ConfigFile = [ConfigLine] -siteEnabled :: Domain -> ConfigFile -> RevertableProperty NoInfo +siteEnabled :: Domain -> ConfigFile -> RevertableProperty DebianLike DebianLike siteEnabled domain cf = siteEnabled' domain cf siteDisabled domain -siteEnabled' :: Domain -> ConfigFile -> Property NoInfo -siteEnabled' domain cf = combineProperties ("apache site enabled " ++ domain) - [ siteAvailable domain cf +siteEnabled' :: Domain -> ConfigFile -> Property DebianLike +siteEnabled' domain cf = combineProperties ("apache site enabled " ++ domain) $ props + & siteAvailable domain cf `requires` installed `onChange` reloaded - , check (not <$> isenabled) + & check (not <$> isenabled) (cmdProperty "a2ensite" ["--quiet", domain]) `requires` installed `onChange` reloaded - ] where isenabled = boolSystem "a2query" [Param "-q", Param "-s", Param domain] -siteDisabled :: Domain -> Property NoInfo +siteDisabled :: Domain -> Property DebianLike siteDisabled domain = combineProperties ("apache site disabled " ++ domain) - (map File.notPresent (siteCfg domain)) + (toProps $ map File.notPresent (siteCfg domain)) `onChange` (cmdProperty "a2dissite" ["--quiet", domain] `assume` MadeChange) `requires` installed `onChange` reloaded -siteAvailable :: Domain -> ConfigFile -> Property NoInfo +siteAvailable :: Domain -> ConfigFile -> Property DebianLike siteAvailable domain cf = combineProperties ("apache site available " ++ domain) $ - map (`File.hasContent` (comment:cf)) (siteCfg domain) + toProps $ map tightenTargets $ + map (`File.hasContent` (comment:cf)) (siteCfg domain) where comment = "# deployed with propellor, do not modify" -modEnabled :: String -> RevertableProperty NoInfo +modEnabled :: String -> RevertableProperty DebianLike DebianLike modEnabled modname = enable disable where enable = check (not <$> isenabled) @@ -68,7 +68,7 @@ modEnabled modname = enable disable -- -- Note that ports are also specified inside a site's config file, -- so that also needs to be changed. -listenPorts :: [Port] -> Property NoInfo +listenPorts :: [Port] -> Property DebianLike listenPorts ps = "/etc/apache2/ports.conf" `File.hasContent` map portline ps `onChange` restarted where @@ -89,7 +89,7 @@ siteCfg domain = -- -- This was off by default in apache 2.2.22. Newver versions enable -- it by default. This property uses the filename used by the old version. -multiSSL :: Property NoInfo +multiSSL :: Property DebianLike multiSSL = check (doesDirectoryExist "/etc/apache2/conf.d") $ "/etc/apache2/conf.d/ssl" `File.hasContent` [ "NameVirtualHost *:443" @@ -129,11 +129,11 @@ type WebRoot = FilePath -- | A basic virtual host, publishing a directory, and logging to -- the combined apache log file. Not https capable. -virtualHost :: Domain -> Port -> WebRoot -> RevertableProperty NoInfo +virtualHost :: Domain -> Port -> WebRoot -> RevertableProperty DebianLike DebianLike virtualHost domain port docroot = virtualHost' domain port docroot [] -- | Like `virtualHost` but with additional config lines added. -virtualHost' :: Domain -> Port -> WebRoot -> [ConfigLine] -> RevertableProperty NoInfo +virtualHost' :: Domain -> Port -> WebRoot -> [ConfigLine] -> RevertableProperty DebianLike DebianLike virtualHost' domain port docroot addedcfg = siteEnabled domain $ [ "" , "ServerName " ++ domain ++ ":" ++ fromPort port @@ -159,11 +159,11 @@ virtualHost' domain port docroot addedcfg = siteEnabled domain $ -- -- Note that reverting this property does not remove the certificate from -- letsencrypt's cert store. -httpsVirtualHost :: Domain -> WebRoot -> LetsEncrypt.AgreeTOS -> RevertableProperty NoInfo +httpsVirtualHost :: Domain -> WebRoot -> LetsEncrypt.AgreeTOS -> RevertableProperty DebianLike DebianLike httpsVirtualHost domain docroot letos = httpsVirtualHost' domain docroot letos [] -- | Like `httpsVirtualHost` but with additional config lines added. -httpsVirtualHost' :: Domain -> WebRoot -> LetsEncrypt.AgreeTOS -> [ConfigLine] -> RevertableProperty NoInfo +httpsVirtualHost' :: Domain -> WebRoot -> LetsEncrypt.AgreeTOS -> [ConfigLine] -> RevertableProperty DebianLike DebianLike httpsVirtualHost' domain docroot letos addedcfg = setup teardown where setup = setuphttp @@ -185,13 +185,13 @@ httpsVirtualHost' domain docroot letos addedcfg = setup teardown , "RewriteRule ^/(.*) https://" ++ domain ++ "/$1 [L,R,NE]" ] setuphttps = LetsEncrypt.letsEncrypt letos domain docroot - `onChange` combineProperties (domain ++ " ssl cert installed") - [ File.dirExists (takeDirectory cf) - , File.hasContent cf sslvhost - `onChange` reloaded - -- always reload since the cert has changed - , reloaded - ] + `onChange` postsetuphttps + postsetuphttps = combineProperties (domain ++ " ssl cert installed") $ props + & File.dirExists (takeDirectory cf) + & File.hasContent cf sslvhost + `onChange` reloaded + -- always reload since the cert has changed + & reloaded where cf = sslconffile "letsencrypt" sslvhost = vhost (Port 443) diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs index 8d608a54..a86c839f 100644 --- a/src/Propellor/Property/Concurrent.hs +++ b/src/Propellor/Property/Concurrent.hs @@ -77,8 +77,8 @@ 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 :: IO Int -> Desc -> PropList -> Property HasInfo -concurrentList getn d (PropList ps) = infoProperty d go mempty ps +concurrentList :: SingI metatypes => IO Int -> Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes) +concurrentList getn d (Props ps) = property d go `modifyChildren` (++ ps) where go = do n <- liftIO getn @@ -97,14 +97,10 @@ concurrentList getn d (PropList ps) = infoProperty d go mempty ps (p:rest) -> return (rest, Just p) case v of Nothing -> return r - -- This use of getSatisfy does not lose any - -- Info asociated with the property, because - -- concurrentList sets all the properties as - -- children, and so propigates their info. Just p -> do hn <- asks hostName r' <- actionMessageOn hn - (propertyDesc p) + (getDesc p) (getSatisfy p) worker q (r <> r') diff --git a/src/Propellor/Property/ConfFile.hs b/src/Propellor/Property/ConfFile.hs index dac4e564..270e04f1 100644 --- a/src/Propellor/Property/ConfFile.hs +++ b/src/Propellor/Property/ConfFile.hs @@ -37,7 +37,7 @@ adjustSection -> AdjustSection -> InsertSection -> FilePath - -> Property NoInfo + -> Property UnixLike adjustSection desc start past adjust insert = fileProperty desc go where go ls = let (pre, wanted, post) = foldl' find ([], [], []) ls @@ -68,7 +68,7 @@ adjustIniSection -> AdjustSection -> InsertSection -> FilePath - -> Property NoInfo + -> Property UnixLike adjustIniSection desc header = adjustSection desc @@ -77,7 +77,7 @@ adjustIniSection desc header = -- | Ensures that a .ini file exists and contains a section -- with a key=value setting. -containsIniSetting :: FilePath -> (IniSection, IniKey, String) -> Property NoInfo +containsIniSetting :: FilePath -> (IniSection, IniKey, String) -> Property UnixLike containsIniSetting f (header, key, value) = adjustIniSection (f ++ " section [" ++ header ++ "] contains " ++ key ++ "=" ++ value) @@ -93,7 +93,7 @@ containsIniSetting f (header, key, value) = isKeyVal x = (filter (/= ' ') . takeWhile (/= '=')) x `elem` [key, '#':key] -- | Ensures that a .ini file does not contain the specified section. -lacksIniSection :: FilePath -> IniSection -> Property NoInfo +lacksIniSection :: FilePath -> IniSection -> Property UnixLike lacksIniSection f header = adjustIniSection (f ++ " lacks section [" ++ header ++ "]") diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs index 267c6cbc..0966a7e5 100644 --- a/src/Propellor/Property/Cron.hs +++ b/src/Propellor/Property/Cron.hs @@ -80,7 +80,7 @@ niceJob desc times user cddir command = job desc times user cddir -- | Installs a cron job to run propellor. runPropellor :: Times -> Property UnixLike -runPropellor times = withOS "propellor cron job" $ \o os -> - ensureProperty o $ +runPropellor times = withOS "propellor cron job" $ \w o -> + ensureProperty w $ niceJob "propellor" times (User "root") localdir - (bootstrapPropellorCommand os ++ "; ./propellor") + (bootstrapPropellorCommand o ++ "; ./propellor") diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index 7cbf3d98..fd5f6c96 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -101,18 +101,18 @@ extractSuite (System (FreeBSD _) _) = Nothing installed :: RevertableProperty Linux Linux installed = install remove where - install = withOS "debootstrap installed" $ \o os -> + install = withOS "debootstrap installed" $ \w o -> ifM (liftIO $ isJust <$> programPath) ( return NoChange - , ensureProperty o (installon os) + , ensureProperty w (installon o) ) installon (Just (System (Debian _) _)) = aptinstall installon (Just (System (Buntish _) _)) = aptinstall installon _ = sourceInstall - remove = withOS "debootstrap removed" $ \o os -> - ensureProperty o (removefrom os) + remove = withOS "debootstrap removed" $ \w o -> + ensureProperty w (removefrom o) removefrom (Just (System (Debian _) _)) = aptremove removefrom (Just (System (Buntish _) _)) = aptremove removefrom _ = sourceRemove diff --git a/src/Propellor/Property/LetsEncrypt.hs b/src/Propellor/Property/LetsEncrypt.hs index d5528c64..bf38046b 100644 --- a/src/Propellor/Property/LetsEncrypt.hs +++ b/src/Propellor/Property/LetsEncrypt.hs @@ -7,7 +7,7 @@ import qualified Propellor.Property.Apt as Apt import System.Posix.Files -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["letsencrypt"] -- | Tell the letsencrypt client that you agree with the Let's Encrypt @@ -39,15 +39,16 @@ type WebRoot = FilePath -- -- See `Propellor.Property.Apache.httpsVirtualHost` for a more complete -- integration of apache with letsencrypt, that's built on top of this. -letsEncrypt :: AgreeTOS -> Domain -> WebRoot -> Property NoInfo +letsEncrypt :: AgreeTOS -> Domain -> WebRoot -> Property DebianLike letsEncrypt tos domain = letsEncrypt' tos domain [] -- | Like `letsEncrypt`, but the certificate can be obtained for multiple -- domains. -letsEncrypt' :: AgreeTOS -> Domain -> [Domain] -> WebRoot -> Property NoInfo +letsEncrypt' :: AgreeTOS -> Domain -> [Domain] -> WebRoot -> Property DebianLike letsEncrypt' (AgreeTOS memail) domain domains webroot = prop `requires` installed where + prop :: Property UnixLike prop = property desc $ do startstats <- liftIO getstats (transcript, ok) <- liftIO $ diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs index d8c5cff4..304d0863 100644 --- a/src/Propellor/Property/List.hs +++ b/src/Propellor/Property/List.hs @@ -13,7 +13,6 @@ module Propellor.Property.List ( ) where import Propellor.Types -import Propellor.Types.MetaTypes import Propellor.PropAccum import Propellor.Engine import Propellor.Exception diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs index 26cdbeb7..12c06919 100644 --- a/src/Propellor/Property/Ssh.hs +++ b/src/Propellor/Property/Ssh.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, TypeFamilies #-} module Propellor.Property.Ssh ( installed, @@ -47,10 +47,10 @@ import qualified Data.Map as M import qualified Data.Set as S import Data.List -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["ssh"] -restarted :: Property NoInfo +restarted :: Property DebianLike restarted = Service.restarted "ssh" sshBool :: Bool -> String @@ -62,10 +62,10 @@ sshdConfig = "/etc/ssh/sshd_config" type ConfigKeyword = String -setSshdConfigBool :: ConfigKeyword -> Bool -> Property NoInfo +setSshdConfigBool :: ConfigKeyword -> Bool -> Property DebianLike setSshdConfigBool setting allowed = setSshdConfig setting (sshBool allowed) -setSshdConfig :: ConfigKeyword -> String -> Property NoInfo +setSshdConfig :: ConfigKeyword -> String -> Property DebianLike setSshdConfig setting val = File.fileProperty desc f sshdConfig `onChange` restarted where @@ -84,19 +84,19 @@ data RootLogin | WithoutPassword -- ^ disable password authentication for root, while allowing other authentication methods | ForcedCommandsOnly -- ^ allow root login with public-key authentication, but only if a forced command has been specified for the public key -permitRootLogin :: RootLogin -> Property NoInfo +permitRootLogin :: RootLogin -> Property DebianLike permitRootLogin (RootLogin b) = setSshdConfigBool "PermitRootLogin" b permitRootLogin WithoutPassword = setSshdConfig "PermitRootLogin" "without-password" permitRootLogin ForcedCommandsOnly = setSshdConfig "PermitRootLogin" "forced-commands-only" -passwordAuthentication :: Bool -> Property NoInfo +passwordAuthentication :: Bool -> Property DebianLike passwordAuthentication = setSshdConfigBool "PasswordAuthentication" -- | Configure ssh to not allow password logins. -- -- To prevent lock-out, this is done only once root's -- authorized_keys is in place. -noPasswords :: Property NoInfo +noPasswords :: Property DebianLike noPasswords = check (hasAuthorizedKeys (User "root")) $ passwordAuthentication False @@ -114,7 +114,7 @@ dotFile f user = do -- ports it is configured to listen on. -- -- Revert to prevent it listening on a particular port. -listenPort :: Port -> RevertableProperty NoInfo +listenPort :: Port -> RevertableProperty DebianLike DebianLike listenPort port = enable disable where portline = "Port " ++ fromPort port @@ -133,16 +133,17 @@ hasAuthorizedKeys = go <=< dotFile "authorized_keys" -- | Blows away existing host keys and make new ones. -- Useful for systems installed from an image that might reuse host keys. -- A flag file is used to only ever do this once. -randomHostKeys :: Property NoInfo +randomHostKeys :: Property DebianLike randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys" `onChange` restarted where - prop = property "ssh random host keys" $ do + prop :: Property UnixLike + prop = property' "ssh random host keys" $ \w -> do void $ liftIO $ boolSystem "sh" [ Param "-c" , Param "rm -f /etc/ssh/ssh_host_*" ] - ensureProperty $ scriptProperty [ "DPKG_MAINTSCRIPT_NAME=postinst DPKG_MAINTSCRIPT_PACKAGE=openssh-server /var/lib/dpkg/info/openssh-server.postinst configure" ] + ensureProperty w $ scriptProperty [ "DPKG_MAINTSCRIPT_NAME=postinst DPKG_MAINTSCRIPT_PACKAGE=openssh-server /var/lib/dpkg/info/openssh-server.postinst configure" ] `assume` MadeChange -- | The text of a ssh public key, for example, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB3BJ2GqZiTR2LEoDXyYFgh/BduWefjdKXAsAtzS9zeI" @@ -153,8 +154,8 @@ type PubKeyText = String -- The corresponding private keys come from the privdata. -- -- Any host keys that are not in the list are removed from the host. -hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property HasInfo -hostKeys ctx l = propertyList desc $ catMaybes $ +hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property (HasInfo + DebianLike) +hostKeys ctx l = propertyList desc $ toProps $ catMaybes $ map (\(t, pub) -> Just $ hostKey ctx t pub) l ++ [cleanup] where desc = "ssh host keys configured " ++ typelist (map fst l) @@ -162,34 +163,36 @@ hostKeys ctx l = propertyList desc $ catMaybes $ alltypes = [minBound..maxBound] staletypes = let have = map fst l in filter (`notElem` have) alltypes removestale b = map (File.notPresent . flip keyFile b) staletypes + cleanup :: Maybe (Property DebianLike) cleanup | null staletypes || null l = Nothing - | otherwise = Just $ toProp $ - property ("any other ssh host keys removed " ++ typelist staletypes) $ - ensureProperty $ - combineProperties desc (removestale True ++ removestale False) - `onChange` restarted + | otherwise = Just $ + combineProperties ("any other ssh host keys removed " ++ typelist staletypes) + (toProps $ removestale True ++ removestale False) + `onChange` restarted -- | Installs a single ssh host key of a particular type. -- -- The public key is provided to this function; -- the private key comes from the privdata; -hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property HasInfo -hostKey context keytype pub = combineProperties desc - [ hostPubKey keytype pub - , toProp $ property desc $ install File.hasContent True (lines pub) - , withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey -> - property desc $ getkey $ - install File.hasContentProtected False . privDataLines - ] - `onChange` restarted +hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property (HasInfo + DebianLike) +hostKey context keytype pub = combineProperties desc (props + & hostPubKey keytype pub + & installpub + & installpriv + ) `onChange` restarted where desc = "ssh host key configured (" ++ fromKeyType keytype ++ ")" - install writer ispub keylines = do + install w writer ispub keylines = do let f = keyFile keytype ispub - ensureProperty $ writer f (keyFileContent keylines) + ensureProperty w $ writer f (keyFileContent keylines) keysrc ext field = PrivDataSourceFileFromCommand field ("sshkey"++ext) ("ssh-keygen -t " ++ sshKeyTypeParam keytype ++ " -f sshkey") + installpub = property' desc $ \w -> install w File.hasContent True (lines pub) + installpriv = withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey -> + property' desc $ \w -> getkey $ + install w File.hasContentProtected False . privDataLines + -- Make sure that there is a newline at the end; -- ssh requires this for some types of private keys. @@ -204,7 +207,7 @@ keyFile keytype ispub = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++ -- | Indicates the host key that is used by a Host, but does not actually -- configure the host to use it. Normally this does not need to be used; -- use 'hostKey' instead. -hostPubKey :: SshKeyType -> PubKeyText -> Property HasInfo +hostPubKey :: SshKeyType -> PubKeyText -> Property (HasInfo + DebianLike) hostPubKey t = pureInfoProperty "ssh pubkey known" . HostKeyInfo . M.singleton t getHostPubKey :: Propellor (M.Map SshKeyType PubKeyText) @@ -224,7 +227,7 @@ instance Monoid HostKeyInfo where -- parameter when there is a duplicate key HostKeyInfo (new `M.union` old) -userPubKeys :: User -> [(SshKeyType, PubKeyText)] -> Property HasInfo +userPubKeys :: User -> [(SshKeyType, PubKeyText)] -> Property (HasInfo + UnixLike) userPubKeys u@(User n) l = pureInfoProperty ("ssh pubkey for " ++ n) $ UserKeyInfo (M.singleton u (S.fromList l)) @@ -248,8 +251,8 @@ instance Monoid UserKeyInfo where -- -- The public keys are added to the Info, so other properties like -- `authorizedKeysFrom` can use them. -userKeys :: IsContext c => User -> c -> [(SshKeyType, PubKeyText)] -> Property HasInfo -userKeys user@(User name) context ks = combineProperties desc $ +userKeys :: IsContext c => User -> c -> [(SshKeyType, PubKeyText)] -> Property (HasInfo + UnixLike) +userKeys user@(User name) context ks = combineProperties desc $ toProps $ userPubKeys user ks : map (userKeyAt Nothing user context) ks where desc = unwords @@ -264,7 +267,7 @@ userKeys user@(User name) context ks = combineProperties desc $ -- A file can be specified to write the key to somewhere other than -- the default locations. Allows a user to have multiple keys for -- different roles. -userKeyAt :: IsContext c => Maybe FilePath -> User -> c -> (SshKeyType, PubKeyText) -> Property HasInfo +userKeyAt :: IsContext c => Maybe FilePath -> User -> c -> (SshKeyType, PubKeyText) -> Property (HasInfo + UnixLike) userKeyAt dest user@(User u) context (keytype, pubkeytext) = combineProperties desc $ props & pubkey @@ -276,17 +279,16 @@ userKeyAt dest user@(User u) context (keytype, pubkeytext) = , dest , Just $ "(" ++ fromKeyType keytype ++ ")" ] - pubkey = property desc $ install File.hasContent ".pub" [pubkeytext] + pubkey = property' desc $ \w -> install w File.hasContent ".pub" [pubkeytext] privkey = withPrivData (SshPrivKey keytype u) context $ \getkey -> - property desc $ getkey $ - install File.hasContentProtected "" . privDataLines - install writer ext key = do + property' desc $ \w -> getkey $ + install w File.hasContentProtected "" . privDataLines + install w writer ext key = do f <- liftIO $ keyfile ext - ensureProperty $ combineProperties desc - [ writer f (keyFileContent key) - , File.ownerGroup f user (userGroup user) - , File.ownerGroup (takeDirectory f) user (userGroup user) - ] + ensureProperty w $ combineProperties desc $ props + & writer f (keyFileContent key) + & File.ownerGroup f user (userGroup user) + & File.ownerGroup (takeDirectory f) user (userGroup user) keyfile ext = case dest of Nothing -> do home <- homeDirectory <$> getUserEntryForName u @@ -301,33 +303,34 @@ fromKeyType SshEd25519 = "ed25519" -- | Puts some host's ssh public key(s), as set using `hostPubKey` -- or `hostKey` into the known_hosts file for a user. -knownHost :: [Host] -> HostName -> User -> Property NoInfo -knownHost hosts hn user@(User u) = property desc $ - go =<< knownHostLines hosts hn +knownHost :: [Host] -> HostName -> User -> Property UnixLike +knownHost hosts hn user@(User u) = property' desc $ \w -> + go w =<< knownHostLines hosts hn where desc = u ++ " knows ssh key for " ++ hn - go [] = do + go _ [] = do warningMessage $ "no configured ssh host keys for " ++ hn return FailedChange - go ls = do + go w ls = do f <- liftIO $ dotFile "known_hosts" user - modKnownHost user f $ + ensureProperty w $ modKnownHost user f $ f `File.containsLines` ls `requires` File.dirExists (takeDirectory f) -- | Reverts `knownHost` -unknownHost :: [Host] -> HostName -> User -> Property NoInfo -unknownHost hosts hn user@(User u) = property desc $ - go =<< knownHostLines hosts hn +unknownHost :: [Host] -> HostName -> User -> Property UnixLike +unknownHost hosts hn user@(User u) = property' desc $ \w -> + go w =<< knownHostLines hosts hn where desc = u ++ " does not know ssh key for " ++ hn - go [] = return NoChange - go ls = do + go w [] = return NoChange + go w ls = do f <- liftIO $ dotFile "known_hosts" user ifM (liftIO $ doesFileExist f) - ( modKnownHost user f $ f `File.lacksLines` ls + ( ensureProperty w $ modKnownHost user f $ + f `File.lacksLines` ls , return NoChange ) @@ -337,8 +340,8 @@ knownHostLines hosts hn = keylines <$> fromHost hosts hn getHostPubKey keylines (Just m) = map (\k -> hn ++ " " ++ k) (M.elems m) keylines Nothing = [] -modKnownHost :: User -> FilePath -> Property NoInfo -> Propellor Result -modKnownHost user f p = ensureProperty $ p +modKnownHost :: User -> FilePath -> Property UnixLike -> Property UnixLike +modKnownHost user f p = p `requires` File.ownerGroup f user (userGroup user) `requires` File.ownerGroup (takeDirectory f) user (userGroup user) @@ -348,30 +351,30 @@ modKnownHost user f p = ensureProperty $ p -- The ssh keys of the remote user can be set using `keysImported` -- -- Any other lines in the authorized_keys file are preserved as-is. -authorizedKeysFrom :: User -> (User, Host) -> Property NoInfo +authorizedKeysFrom :: User -> (User, Host) -> Property UnixLike localuser@(User ln) `authorizedKeysFrom` (remoteuser@(User rn), remotehost) = - property desc (go =<< authorizedKeyLines remoteuser remotehost) + property' desc (\w -> go w =<< authorizedKeyLines remoteuser remotehost) where remote = rn ++ "@" ++ hostName remotehost desc = ln ++ " authorized_keys from " ++ remote - go [] = do + go _ [] = do warningMessage $ "no configured ssh user keys for " ++ remote return FailedChange - go ls = ensureProperty $ combineProperties desc $ - map (authorizedKey localuser) ls + go w ls = ensureProperty w $ combineProperties desc $ toProps $ + map (setupRevertableProperty . authorizedKey localuser) ls -- | Reverts `authorizedKeysFrom` -unauthorizedKeysFrom :: User -> (User, Host) -> Property NoInfo +unauthorizedKeysFrom :: User -> (User, Host) -> Property UnixLike localuser@(User ln) `unauthorizedKeysFrom` (remoteuser@(User rn), remotehost) = - property desc (go =<< authorizedKeyLines remoteuser remotehost) + property' desc (\w -> go w =<< authorizedKeyLines remoteuser remotehost) where remote = rn ++ "@" ++ hostName remotehost desc = ln ++ " unauthorized_keys from " ++ remote - go [] = return NoChange - go ls = ensureProperty $ combineProperties desc $ - map (revert . authorizedKey localuser) ls + go _ [] = return NoChange + go w ls = ensureProperty w $ combineProperties desc $ toProps $ + map (undoRevertableProperty . authorizedKey localuser) ls authorizedKeyLines :: User -> Host -> Propellor [File.Line] authorizedKeyLines remoteuser remotehost = @@ -380,37 +383,37 @@ authorizedKeyLines remoteuser remotehost = -- | Makes a user have authorized_keys from the PrivData -- -- This removes any other lines from the file. -authorizedKeys :: IsContext c => User -> c -> Property HasInfo +authorizedKeys :: IsContext c => User -> c -> Property (HasInfo + UnixLike) authorizedKeys user@(User u) context = withPrivData (SshAuthorizedKeys u) context $ \get -> - property desc $ get $ \v -> do + property' desc $ \w -> get $ \v -> do f <- liftIO $ dotFile "authorized_keys" user - ensureProperty $ combineProperties desc - [ File.hasContentProtected f (keyFileContent (privDataLines v)) - , File.ownerGroup f user (userGroup user) - , File.ownerGroup (takeDirectory f) user (userGroup user) - ] + ensureProperty w $ combineProperties desc $ props + & File.hasContentProtected f (keyFileContent (privDataLines v)) + & File.ownerGroup f user (userGroup user) + & File.ownerGroup (takeDirectory f) user (userGroup user) where desc = u ++ " has authorized_keys" -- | Ensures that a user's authorized_keys contains a line. -- Any other lines in the file are preserved as-is. -authorizedKey :: User -> String -> RevertableProperty NoInfo +authorizedKey :: User -> String -> RevertableProperty UnixLike UnixLike authorizedKey user@(User u) l = add remove where - add = property (u ++ " has authorized_keys") $ do + add = property' (u ++ " has authorized_keys") $ \w -> do f <- liftIO $ dotFile "authorized_keys" user - modAuthorizedKey f user $ + ensureProperty w $ modAuthorizedKey f user $ f `File.containsLine` l `requires` File.dirExists (takeDirectory f) - remove = property (u ++ " lacks authorized_keys") $ do + remove = property' (u ++ " lacks authorized_keys") $ \w -> do f <- liftIO $ dotFile "authorized_keys" user ifM (liftIO $ doesFileExist f) - ( modAuthorizedKey f user $ f `File.lacksLine` l + ( ensureProperty w $ modAuthorizedKey f user $ + f `File.lacksLine` l , return NoChange ) -modAuthorizedKey :: FilePath -> User -> Property NoInfo -> Propellor Result -modAuthorizedKey f user p = ensureProperty $ p +modAuthorizedKey :: FilePath -> User -> Property UnixLike -> Property UnixLike +modAuthorizedKey f user p = p `before` File.mode f (combineModes [ownerWriteMode, ownerReadMode]) `before` File.ownerGroup f user (userGroup user) `before` File.ownerGroup (takeDirectory f) user (userGroup user) diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index f42f55d7..4b3f665a 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -44,6 +44,7 @@ module Propellor.Types , module Propellor.Types.Result , module Propellor.Types.ZFS , TightenTargets(..) + , SingI ) where import Data.Monoid -- cgit v1.2.3 From 36e97137e538de401bd0340b469e10dca5f4b475 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 26 Mar 2016 19:31:23 -0400 Subject: ported propagateContainer Renamed several utility functions along the way. --- debian/changelog | 5 ++++ doc/todo/type_level_OS_requirements.mdwn | 7 ++--- propellor.cabal | 1 + src/Propellor/Container.hs | 46 ++++++++++++++++++++++++++++++ src/Propellor/Info.hs | 6 ++-- src/Propellor/PrivData.hs | 4 +-- src/Propellor/PropAccum.hs | 33 ---------------------- src/Propellor/Property/Chroot.hs | 43 +++++++++++++--------------- src/Propellor/Property/Concurrent.hs | 2 +- src/Propellor/Property/Conductor.hs | 8 +++--- src/Propellor/Property/Dns.hs | 10 +++---- src/Propellor/Property/Docker.hs | 10 +++---- src/Propellor/Property/List.hs | 4 +-- src/Propellor/Property/Partition.hs | 2 +- src/Propellor/Property/Postfix.hs | 2 +- src/Propellor/Property/Scheduled.hs | 6 ++-- src/Propellor/Property/Systemd.hs | 18 ++++++------ src/Propellor/Spin.hs | 4 +-- src/Propellor/Types.hs | 48 +++++++++++++------------------- src/Propellor/Types/Info.hs | 6 ++-- 20 files changed, 134 insertions(+), 131 deletions(-) create mode 100644 src/Propellor/Container.hs (limited to 'src/Propellor/Property/Concurrent.hs') diff --git a/debian/changelog b/debian/changelog index df518753..8a5b67e4 100644 --- a/debian/changelog +++ b/debian/changelog @@ -49,6 +49,11 @@ propellor (3.0.0) UNRELEASED; urgency=medium For example: upgraded :: Property Debian upgraded = tightenTargets (cmdProperty "apt-get" ["upgrade"]) + - Several utility functions have been renamed: + getInfo to fromInfo + propertyInfo to getInfo + propertyDesc to getDesc + propertyChildren to getChildren * The new `pickOS` property combinator can be used to combine different properties, supporting different OS's, into one Property that chooses what to do based on the Host's OS. diff --git a/doc/todo/type_level_OS_requirements.mdwn b/doc/todo/type_level_OS_requirements.mdwn index 7c2fb78f..f1c3e59f 100644 --- a/doc/todo/type_level_OS_requirements.mdwn +++ b/doc/todo/type_level_OS_requirements.mdwn @@ -21,13 +21,12 @@ withOS. The `os` property would need to yield a `Property (os:[])`, where the type level list contains a type-level eqivilant of the value passed to the -property. Is that possible to do? reification or something? -(See: ) -Or, alternatively, could have less polymorphic `debian` etc +property. Is that possible to do? +Or, alternatively, could have less polymorphic `osDebian` etc properties replace the `os` property. If a Host's list of properties, when all combined together, -contains more than one element in its '[OS], that needs to be a type error, +contains more than one element in its '[OS], that could be a type error, the OS of the Host is indeterminite. Which would be fixed by using the `os` property to specify. diff --git a/propellor.cabal b/propellor.cabal index e47bb2e6..4a7739d3 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -141,6 +141,7 @@ Library Propellor.PropAccum Propellor.Utilities Propellor.CmdLine + Propellor.Container Propellor.Info Propellor.Message Propellor.Debug 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 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 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. -- cgit v1.2.3 From 9d6dc29555b8499d8ae6c73c891b0b5dc19f83e5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 27 Mar 2016 19:59:20 -0400 Subject: improve haddocks and move code around to make them more clear --- propellor.cabal | 1 + src/Propellor/Container.hs | 4 +- src/Propellor/Engine.hs | 4 +- src/Propellor/EnsureProperty.hs | 1 + src/Propellor/Info.hs | 28 +++++- src/Propellor/PrivData.hs | 2 +- src/Propellor/PropAccum.hs | 5 +- src/Propellor/Property.hs | 1 + src/Propellor/Property/Chroot.hs | 3 +- src/Propellor/Property/Concurrent.hs | 2 + src/Propellor/Property/Conductor.hs | 13 +-- src/Propellor/Property/Dns.hs | 2 +- src/Propellor/Property/Docker.hs | 3 +- src/Propellor/Property/FreeBSD/Pkg.hs | 4 +- src/Propellor/Property/List.hs | 2 + src/Propellor/Property/Partition.hs | 1 + src/Propellor/Property/Scheduled.hs | 1 + src/Propellor/Types.hs | 168 ++++++---------------------------- src/Propellor/Types/Core.hs | 106 +++++++++++++++++++++ src/Propellor/Types/Info.hs | 5 + 20 files changed, 196 insertions(+), 160 deletions(-) create mode 100644 src/Propellor/Types/Core.hs (limited to 'src/Propellor/Property/Concurrent.hs') diff --git a/propellor.cabal b/propellor.cabal index f11d2afe..e946f697 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -150,6 +150,7 @@ Library Propellor.EnsureProperty Propellor.Exception Propellor.Types + Propellor.Types.Core Propellor.Types.Chroot Propellor.Types.CmdLine Propellor.Types.Container diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs index 4cd46ae5..c4d6f864 100644 --- a/src/Propellor/Container.hs +++ b/src/Propellor/Container.hs @@ -3,8 +3,10 @@ module Propellor.Container where import Propellor.Types +import Propellor.Types.Core import Propellor.Types.MetaTypes import Propellor.Types.Info +import Propellor.Info import Propellor.PrivData import Propellor.PropAccum @@ -54,7 +56,7 @@ propagateContainer containername c prop = prop convert p = let n = property (getDesc p) (getSatisfy p) :: Property UnixLike n' = n - `addInfoProperty` mapInfo (forceHostContext containername) + `setInfoProperty` mapInfo (forceHostContext containername) (propagatableInfo (getInfo p)) `addChildren` map convert (getChildren p) in toChildProperty n' diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index 4c37e704..f0035c40 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -4,7 +4,6 @@ module Propellor.Engine ( mainProperties, runPropellor, - ensureProperty, ensureChildProperties, fromHost, fromHost', @@ -23,10 +22,11 @@ import Control.Applicative import Prelude import Propellor.Types +import Propellor.Types.MetaTypes +import Propellor.Types.Core import Propellor.Message import Propellor.Exception import Propellor.Info -import Propellor.Property import Utility.Exception -- | Gets the Properties of a Host, and ensures them all, diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs index f9094c5b..ce01d436 100644 --- a/src/Propellor/EnsureProperty.hs +++ b/src/Propellor/EnsureProperty.hs @@ -11,6 +11,7 @@ module Propellor.EnsureProperty ) where import Propellor.Types +import Propellor.Types.Core import Propellor.Types.MetaTypes import Propellor.Exception diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs index ff0b3b5e..b87369c3 100644 --- a/src/Propellor/Info.hs +++ b/src/Propellor/Info.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PackageImports, TypeFamilies, DataKinds, PolyKinds #-} module Propellor.Info ( osDebian, osBuntish, osFreeBSD, + setInfoProperty, + addInfoProperty, pureInfoProperty, pureInfoProperty', askInfo, @@ -22,6 +24,7 @@ module Propellor.Info ( import Propellor.Types import Propellor.Types.Info +import Propellor.Types.MetaTypes import "mtl" Control.Monad.Reader import qualified Data.Set as S @@ -31,11 +34,32 @@ import Data.Monoid import Control.Applicative import Prelude +-- | Adds info to a Property. +-- +-- The new Property will include HasInfo in its metatypes. +setInfoProperty + :: (MetaTypes metatypes' ~ (+) HasInfo metatypes, SingI metatypes') + => Property metatypes + -> Info + -> Property (MetaTypes metatypes') +setInfoProperty (Property _ d a oldi c) newi = + Property sing d a (oldi <> newi) c + +-- | Adds more info to a Property that already HasInfo. +addInfoProperty + :: (IncludesInfo metatypes ~ 'True) + => Property metatypes + -> Info + -> Property metatypes +addInfoProperty (Property t d a oldi c) newi = + Property t d a (oldi <> newi) c + +-- | Makes a property that does nothing but set some `Info`. pureInfoProperty :: (IsInfo v) => Desc -> v -> Property (HasInfo + UnixLike) pureInfoProperty desc v = pureInfoProperty' desc (toInfo v) pureInfoProperty' :: Desc -> Info -> Property (HasInfo + UnixLike) -pureInfoProperty' desc i = addInfoProperty p i +pureInfoProperty' desc i = setInfoProperty p i where p :: Property UnixLike p = property ("has " ++ desc) (return NoChange) diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs index 0bc0c100..d3bb3a6d 100644 --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -127,7 +127,7 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a -> "Fix this by running:" : showSet (map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist) return FailedChange - addinfo p = p `addInfoProperty'` (toInfo privset) + addinfo p = p `addInfoProperty` (toInfo privset) privset = PrivInfo $ S.fromList $ map (\s -> (privDataField s, describePrivDataSource s, hc)) srclist fieldnames = map show fieldlist diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs index 856f2e8e..d9fa8ec7 100644 --- a/src/Propellor/PropAccum.hs +++ b/src/Propellor/PropAccum.hs @@ -16,6 +16,7 @@ module Propellor.PropAccum import Propellor.Types import Propellor.Types.MetaTypes +import Propellor.Types.Core import Propellor.Property import Data.Monoid @@ -30,10 +31,6 @@ import Prelude host :: HostName -> Props metatypes -> Host host hn (Props ps) = Host hn ps (mconcat (map getInfoRecursive ps)) --- | Props is a combination of a list of properties, with their combined --- metatypes. -data Props metatypes = Props [ChildProperty] - -- | Start accumulating a list of properties. -- -- Properties can be added to it using `(&)` etc. diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 70583edc..29a8ec0f 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -53,6 +53,7 @@ import Control.Applicative import Prelude import Propellor.Types +import Propellor.Types.Core import Propellor.Types.ResultCheck import Propellor.Types.MetaTypes import Propellor.Info diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index 811b5baa..09047ce5 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -23,6 +23,7 @@ import Propellor.Container import Propellor.Types.CmdLine import Propellor.Types.Chroot import Propellor.Types.Info +import Propellor.Types.Core import Propellor.Property.Chroot.Util import qualified Propellor.Property.Debootstrap as Debootstrap import qualified Propellor.Property.Systemd.Core as Systemd @@ -151,7 +152,7 @@ provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly = propagateChrootInfo :: Chroot -> Property Linux -> Property (HasInfo + Linux) propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c $ - p `addInfoProperty` chrootInfo c + p `setInfoProperty` chrootInfo c chrootInfo :: Chroot -> Info chrootInfo (Chroot loc _ h) = mempty `addInfo` diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs index ace85a3c..e69dc17d 100644 --- a/src/Propellor/Property/Concurrent.hs +++ b/src/Propellor/Property/Concurrent.hs @@ -37,6 +37,8 @@ module Propellor.Property.Concurrent ( ) where import Propellor.Base +import Propellor.Types.Core +import Propellor.Types.MetaTypes import Control.Concurrent import qualified Control.Concurrent.Async as A diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs index ab747acc..8aa18d20 100644 --- a/src/Propellor/Property/Conductor.hs +++ b/src/Propellor/Property/Conductor.hs @@ -83,16 +83,17 @@ import qualified Propellor.Property.Ssh as Ssh import qualified Data.Set as S -- | Class of things that can be conducted. +-- +-- There are instances for single hosts, and for lists of hosts. +-- With a list, each listed host will be conducted in turn. Failure to conduct +-- one host does not prevent conducting subsequent hosts in the list, but +-- will be propagated as an overall failure of the property. class Conductable c where conducts :: c -> RevertableProperty (HasInfo + UnixLike) (HasInfo + UnixLike) instance Conductable Host where - -- | Conduct the specified host. conducts h = conductorFor h notConductorFor h --- | Each host in the list will be conducted in turn. Failure to conduct --- one host does not prevent conducting subsequent hosts in the list, but --- will be propagated as an overall failure of the property. instance Conductable [Host] where conducts hs = propertyList desc (toProps $ map (setupRevertableProperty . conducts) hs) @@ -246,7 +247,7 @@ orchestrate' h (Conductor c l) -- to have any effect. conductorFor :: Host -> Property (HasInfo + UnixLike) conductorFor h = go - `addInfoProperty` (toInfo (ConductorFor [h])) + `setInfoProperty` (toInfo (ConductorFor [h])) `requires` setupRevertableProperty (conductorKnownHost h) `requires` Ssh.installed where @@ -270,7 +271,7 @@ conductorFor h = go -- Reverts conductorFor. notConductorFor :: Host -> Property (HasInfo + UnixLike) notConductorFor h = (doNothing :: Property UnixLike) - `addInfoProperty` (toInfo (NotConductorFor [h])) + `setInfoProperty` (toInfo (NotConductorFor [h])) `describe` desc `requires` undoRevertableProperty (conductorKnownHost h) where diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs index 2b5596bd..2e2710a6 100644 --- a/src/Propellor/Property/Dns.hs +++ b/src/Propellor/Property/Dns.hs @@ -81,7 +81,7 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs = (partialzone, zonewarnings) = genZone indomain hostmap domain soa baseprop = primaryprop - `addInfoProperty` (toInfo (addNamedConf conf)) + `setInfoProperty` (toInfo (addNamedConf conf)) primaryprop :: Property DebianLike primaryprop = property ("dns primary for " ++ domain) $ do sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap) diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index ddefef15..2ef97438 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -48,6 +48,7 @@ module Propellor.Property.Docker ( import Propellor.Base hiding (init) import Propellor.Types.Docker import Propellor.Types.Container +import Propellor.Types.Core import Propellor.Types.CmdLine import Propellor.Types.Info import Propellor.Container @@ -183,7 +184,7 @@ imagePulled ctr = pulled `describe` msg propagateContainerInfo :: Container -> Property (HasInfo + Linux) -> Property (HasInfo + Linux) propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr $ - p `addInfoProperty'` dockerinfo + p `addInfoProperty` dockerinfo where dockerinfo = dockerInfo $ mempty { _dockerContainers = M.singleton cn h } diff --git a/src/Propellor/Property/FreeBSD/Pkg.hs b/src/Propellor/Property/FreeBSD/Pkg.hs index 6c775b94..704c1db9 100644 --- a/src/Propellor/Property/FreeBSD/Pkg.hs +++ b/src/Propellor/Property/FreeBSD/Pkg.hs @@ -51,7 +51,7 @@ update = go = ifM (pkgUpdated <$> askInfo) ((noChange), (liftIO upd >> return MadeChange)) in (property "pkg update has run" go :: Property FreeBSD) - `addInfoProperty` (toInfo (PkgUpdate "")) + `setInfoProperty` (toInfo (PkgUpdate "")) newtype PkgUpgrade = PkgUpgrade String deriving (Typeable, Monoid, Show) @@ -68,7 +68,7 @@ upgrade = go = ifM (pkgUpgraded <$> askInfo) ((noChange), (liftIO upd >> return MadeChange)) in (property "pkg upgrade has run" go :: Property FreeBSD) - `addInfoProperty` (toInfo (PkgUpdate "")) + `setInfoProperty` (toInfo (PkgUpdate "")) `requires` update type Package = String diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs index a8b8347a..0eec04c7 100644 --- a/src/Propellor/Property/List.hs +++ b/src/Propellor/Property/List.hs @@ -13,6 +13,8 @@ module Propellor.Property.List ( ) where import Propellor.Types +import Propellor.Types.Core +import Propellor.Types.MetaTypes import Propellor.PropAccum import Propellor.Engine import Propellor.Exception diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs index 291d4168..2bf5b927 100644 --- a/src/Propellor/Property/Partition.hs +++ b/src/Propellor/Property/Partition.hs @@ -3,6 +3,7 @@ module Propellor.Property.Partition where import Propellor.Base +import Propellor.Types.Core import qualified Propellor.Property.Apt as Apt import Utility.Applicative diff --git a/src/Propellor/Property/Scheduled.hs b/src/Propellor/Property/Scheduled.hs index 95e4e362..729a3749 100644 --- a/src/Propellor/Property/Scheduled.hs +++ b/src/Propellor/Property/Scheduled.hs @@ -10,6 +10,7 @@ module Propellor.Property.Scheduled ) where import Propellor.Base +import Propellor.Types.Core import Utility.Scheduled import Data.Time.Clock diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index d5959cbb..6d6b14ea 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE PackageImports #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} @@ -8,15 +7,18 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -module Propellor.Types - ( Host(..) +module Propellor.Types ( + -- * Core data types + Host(..) , Property(..) , property - , Info , Desc - , MetaType(..) - , MetaTypes - , TargetOS(..) + , RevertableProperty(..) + , () + , Propellor(..) + , LiftPropellor(..) + , Info + -- * Types of properties , UnixLike , Linux , DebianLike @@ -25,34 +27,22 @@ module Propellor.Types , FreeBSD , HasInfo , type (+) - , addInfoProperty - , addInfoProperty' - , adjustPropertySatisfy - , RevertableProperty(..) - , () - , ChildProperty - , IsProp(..) + , TightenTargets(..) + -- * Combining and modifying properties , Combines(..) , CombinedType , ResultCombiner - , Propellor(..) - , LiftPropellor(..) - , EndAction(..) + , adjustPropertySatisfy + -- * Other included types , module Propellor.Types.OS , module Propellor.Types.Dns , module Propellor.Types.Result , module Propellor.Types.ZFS - , TightenTargets(..) - , SingI ) where import Data.Monoid -import "mtl" Control.Monad.RWS.Strict -import Control.Monad.Catch -import Data.Typeable -import Control.Applicative -import Prelude +import Propellor.Types.Core import Propellor.Types.Info import Propellor.Types.OS import Propellor.Types.Dns @@ -60,89 +50,38 @@ import Propellor.Types.Result import Propellor.Types.MetaTypes import Propellor.Types.ZFS --- | Everything Propellor knows about a system: Its hostname, --- properties and their collected info. -data Host = Host - { hostName :: HostName - , hostProperties :: [ChildProperty] - , hostInfo :: Info - } - deriving (Show, Typeable) - --- | Propellor's monad provides read-only access to info about the host --- it's running on, and a writer to accumulate EndActions. -newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p } - deriving - ( Monad - , Functor - , Applicative - , MonadReader Host - , MonadWriter [EndAction] - , MonadIO - , MonadCatch - , MonadThrow - , MonadMask - ) - -class LiftPropellor m where - liftPropellor :: m a -> Propellor a - -instance LiftPropellor Propellor where - liftPropellor = id - -instance LiftPropellor IO where - liftPropellor = liftIO - -instance Monoid (Propellor Result) where - mempty = return NoChange - -- | The second action is only run if the first action does not fail. - mappend x y = do - rx <- x - case rx of - FailedChange -> return FailedChange - _ -> do - ry <- y - return (rx <> ry) - --- | An action that Propellor runs at the end, after trying to satisfy all --- properties. It's passed the combined Result of the entire Propellor run. -data EndAction = EndAction Desc (Result -> Propellor Result) - -type Desc = String - -- | The core data type of Propellor, this represents a property --- that the system should have, with a descrition, an action to ensure --- it has the property, and perhaps some Info that can be added to Hosts +-- that the system should have, with a descrition, and an action to ensure +-- it has the property. -- that have the property. -- --- A property has a list of `[MetaType]`, which is part of its type. +-- There are different types of properties that target different OS's, +-- and so have different metatypes. +-- For example: "Property DebianLike" and "Property FreeBSD". -- --- There are many instances and type families, which are mostly used +-- Also, some properties have associated `Info`, which is indicated in +-- their type: "Property (HasInfo + DebianLike)" +-- +-- There are many associated type families, which are mostly used -- 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 = getDesc - -- | Constructs a Property, from a description and an action to run to -- ensure the Property is met. -- --- You can specify any metatypes that make sense to indicate what OS --- the property targets, etc. +-- Due to the polymorphic return type of this function, most uses will need +-- to specify a type signature. This lets you specify what OS the property +-- targets, etc. -- -- For example: -- -- > foo :: Property Debian --- > foo = mkProperty "foo" (...) --- --- Note that using this needs LANGUAGE PolyKinds. +-- > foo = property "foo" $ do +-- > ... +-- > return MadeChange property :: SingI metatypes => Desc @@ -150,26 +89,6 @@ property -> Property (MetaTypes metatypes) property d a = Property sing d a mempty mempty --- | Adds info to a Property. --- --- The new Property will include HasInfo in its metatypes. -addInfoProperty - :: (MetaTypes metatypes' ~ (+) HasInfo metatypes, SingI metatypes') - => Property metatypes - -> Info - -> Property (MetaTypes metatypes') -addInfoProperty (Property _ d a oldi c) newi = - Property sing d a (oldi <> newi) c - --- | Adds more info to a Property that already HasInfo. -addInfoProperty' - :: (IncludesInfo metatypes ~ 'True) - => Property metatypes - -> Info - -> Property metatypes -addInfoProperty' (Property t d a oldi c) newi = - Property t d a (oldi <> newi) c - -- | 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 @@ -191,24 +110,6 @@ instance Show (RevertableProperty setupmetatypes undometatypes) where -> RevertableProperty setupmetatypes undometatypes setup undo = RevertableProperty setup undo -class IsProp p where - setDesc :: p -> Desc -> p - getDesc :: p -> Desc - 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 - -- | Gets the action that can be run to satisfy a Property. - -- You should never run this action directly. Use - -- 'Propellor.EnsureProperty.ensureProperty` instead. - getSatisfy :: p -> Propellor Result - instance IsProp (Property metatypes) where setDesc (Property t _ a i c) d = Property t d a i c getDesc (Property _ d _ _ _) = d @@ -220,17 +121,6 @@ instance IsProp (Property metatypes) where 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 - 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 - instance IsProp (RevertableProperty setupmetatypes undometatypes) where -- | Sets the description of both sides. setDesc (RevertableProperty p1 p2) d = diff --git a/src/Propellor/Types/Core.hs b/src/Propellor/Types/Core.hs new file mode 100644 index 00000000..fa939d2b --- /dev/null +++ b/src/Propellor/Types/Core.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} + +module Propellor.Types.Core where + +import Propellor.Types.Info +import Propellor.Types.OS +import Propellor.Types.Result + +import Data.Monoid +import "mtl" Control.Monad.RWS.Strict +import Control.Monad.Catch +import Control.Applicative +import Prelude + +-- | Everything Propellor knows about a system: Its hostname, +-- properties and their collected info. +data Host = Host + { hostName :: HostName + , hostProperties :: [ChildProperty] + , hostInfo :: Info + } + deriving (Show, Typeable) + +-- | Propellor's monad provides read-only access to info about the host +-- it's running on, and a writer to accumulate EndActions. +newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p } + deriving + ( Monad + , Functor + , Applicative + , MonadReader Host + , MonadWriter [EndAction] + , MonadIO + , MonadCatch + , MonadThrow + , MonadMask + ) + +class LiftPropellor m where + liftPropellor :: m a -> Propellor a + +instance LiftPropellor Propellor where + liftPropellor = id + +instance LiftPropellor IO where + liftPropellor = liftIO + +instance Monoid (Propellor Result) where + mempty = return NoChange + -- | The second action is only run if the first action does not fail. + mappend x y = do + rx <- x + case rx of + FailedChange -> return FailedChange + _ -> do + ry <- y + return (rx <> ry) + +-- | An action that Propellor runs at the end, after trying to satisfy all +-- properties. It's passed the combined Result of the entire Propellor run. +data EndAction = EndAction Desc (Result -> Propellor Result) + +type Desc = String + +-- | Props is a combination of a list of properties, with their combined +-- metatypes. +data Props metatypes = Props [ChildProperty] + +-- | 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 = getDesc + +class IsProp p where + setDesc :: p -> Desc -> p + getDesc :: p -> Desc + 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 + -- | Gets the action that can be run to satisfy a Property. + -- You should never run this action directly. Use + -- 'Propellor.EnsureProperty.ensureProperty` instead. + getSatisfy :: p -> Propellor Result + +instance IsProp ChildProperty where + setDesc (ChildProperty _ a i c) d = ChildProperty d a i c + getDesc (ChildProperty d _ _ _) = d + 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 diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs index c7f6b82f..2e188ae5 100644 --- a/src/Propellor/Types/Info.hs +++ b/src/Propellor/Types/Info.hs @@ -19,6 +19,9 @@ import Data.Monoid import Prelude -- | Information about a Host, which can be provided by its properties. +-- +-- Many different types of data can be contained in the same Info value +-- at the same time. See `toInfo` and `fromInfo`. newtype Info = Info [InfoEntry] deriving (Monoid, Show) @@ -47,6 +50,8 @@ class (Typeable v, Monoid v, Show v) => IsInfo v where addInfo :: IsInfo v => Info -> v -> Info addInfo (Info l) v = Info (InfoEntry v:l) +-- | Converts any value in the `IsInfo` type class into an Info, +-- which is otherwise empty. toInfo :: IsInfo v => v -> Info toInfo = addInfo mempty -- cgit v1.2.3