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') 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