summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Ssh.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Property/Ssh.hs')
-rw-r--r--src/Propellor/Property/Ssh.hs193
1 files changed, 105 insertions, 88 deletions
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index 26cdbeb7..6e1690d2 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,13 @@ import qualified Data.Map as M
import qualified Data.Set as S
import Data.List
-installed :: Property NoInfo
-installed = Apt.installed ["ssh"]
+installed :: Property UnixLike
+installed = "ssh installed" ==> (aptinstall `pickOS` unsupportedOS)
+ where
+ aptinstall :: Property DebianLike
+ aptinstall = Apt.installed ["ssh"]
-restarted :: Property NoInfo
+restarted :: Property DebianLike
restarted = Service.restarted "ssh"
sshBool :: Bool -> String
@@ -62,10 +65,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 +87,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 +117,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 +136,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,43 +157,51 @@ 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 $
- map (\(t, pub) -> Just $ hostKey ctx t pub) l ++ [cleanup]
+hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property (HasInfo + DebianLike)
+hostKeys ctx l = go `before` cleanup
where
desc = "ssh host keys configured " ++ typelist (map fst l)
+ go :: Property (HasInfo + DebianLike)
+ go = propertyList desc $ toProps $ catMaybes $
+ map (\(t, pub) -> Just $ hostKey ctx t pub) l
typelist tl = "(" ++ unwords (map fromKeyType tl) ++ ")"
alltypes = [minBound..maxBound]
staletypes = let have = map fst l in filter (`notElem` have) alltypes
- removestale b = map (File.notPresent . flip keyFile b) staletypes
+ removestale :: Bool -> [Property DebianLike]
+ removestale b = map (tightenTargets . File.notPresent . flip keyFile b) staletypes
+ cleanup :: 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
+ | null staletypes || null l = doNothing
+ | otherwise =
+ 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 = go `onChange` restarted
where
+ go = combineProperties desc $ props
+ & hostPubKey keytype pub
+ & installpub
+ & installpriv
desc = "ssh host key configured (" ++ fromKeyType keytype ++ ")"
- install writer ispub keylines = do
- let f = keyFile keytype ispub
- ensureProperty $ writer f (keyFileContent keylines)
keysrc ext field = PrivDataSourceFileFromCommand field ("sshkey"++ext)
("ssh-keygen -t " ++ sshKeyTypeParam keytype ++ " -f sshkey")
+ installpub :: Property UnixLike
+ installpub = keywriter File.hasContent True (lines pub)
+ installpriv :: Property (HasInfo + UnixLike)
+ installpriv = withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey ->
+ property' desc $ \w -> getkey $
+ ensureProperty w
+ . keywriter File.hasContentProtected False
+ . privDataLines
+ keywriter p ispub keylines = do
+ let f = keyFile keytype ispub
+ p f (keyFileContent keylines)
-- Make sure that there is a newline at the end;
-- ssh requires this for some types of private keys.
@@ -204,7 +216,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 + UnixLike)
hostPubKey t = pureInfoProperty "ssh pubkey known" . HostKeyInfo . M.singleton t
getHostPubKey :: Propellor (M.Map SshKeyType PubKeyText)
@@ -224,7 +236,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 +260,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 +276,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 +288,21 @@ userKeyAt dest user@(User u) context (keytype, pubkeytext) =
, dest
, Just $ "(" ++ fromKeyType keytype ++ ")"
]
- pubkey = property desc $ install File.hasContent ".pub" [pubkeytext]
- privkey = withPrivData (SshPrivKey keytype u) context $ \getkey ->
- property desc $ getkey $
- install File.hasContentProtected "" . privDataLines
- install writer ext key = do
+ pubkey :: Property UnixLike
+ pubkey = property' desc $ \w ->
+ ensureProperty w =<< installprop File.hasContent ".pub" [pubkeytext]
+ privkey :: Property (HasInfo + UnixLike)
+ privkey = withPrivData (SshPrivKey keytype u) context privkey'
+ privkey' :: ((PrivData -> Propellor Result) -> Propellor Result) -> Property (HasInfo + UnixLike)
+ privkey' getkey = property' desc $ \w -> getkey $ \k ->
+ ensureProperty w
+ =<< installprop File.hasContentProtected "" (privDataLines k)
+ installprop 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)
- ]
+ return $ 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 +317,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 _ [] = 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 +354,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 +365,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 +397,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)
generated by cgit v1.3-2-g0d8e (git 2.53.0) at 2026-06-16 20:28:45 +0000