summaryrefslogtreecommitdiff
path: root/src/Propellor
diff options
context:
space:
mode:
authorJoey Hess2016-03-25 18:39:50 -0400
committerJoey Hess2016-03-25 18:39:50 -0400
commitce8d34d094be30e1432ecaaae81b188671180624 (patch)
tree289e2bba5ca5291c14255c5b5fe6cf6d007a1bcf /src/Propellor
parent860d1dd77e1789a91ed61bdceab667d94c9bd345 (diff)
ported more
Ssh is WIP and failing to compile quite badly
Diffstat (limited to 'src/Propellor')
-rw-r--r--src/Propellor/PropAccum.hs7
-rw-r--r--src/Propellor/Property/Aiccu.hs16
-rw-r--r--src/Propellor/Property/Apache.hs54
-rw-r--r--src/Propellor/Property/Concurrent.hs10
-rw-r--r--src/Propellor/Property/ConfFile.hs8
-rw-r--r--src/Propellor/Property/Cron.hs6
-rw-r--r--src/Propellor/Property/Debootstrap.hs8
-rw-r--r--src/Propellor/Property/LetsEncrypt.hs7
-rw-r--r--src/Propellor/Property/List.hs1
-rw-r--r--src/Propellor/Property/Ssh.hs167
-rw-r--r--src/Propellor/Types.hs1
11 files changed, 143 insertions, 142 deletions
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 <jelmer@samba.org>
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 $
[ "<VirtualHost *:" ++ fromPort port ++ ">"
, "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