summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Ssh.hs
blob: c23a121bbaedda05d5c25e0c1b4d2156a5ab5166 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
{-# LANGUAGE DeriveDataTypeable, TypeFamilies #-}

module Propellor.Property.Ssh (
	installed,
	restarted,
	PubKeyText,
	SshKeyType(..),
	-- * Daemon configuration
	sshdConfig,
	ConfigKeyword,
	setSshdConfigBool,
	setSshdConfig,
	RootLogin(..),
	permitRootLogin,
	passwordAuthentication,
	noPasswords,
	listenPort,
	-- * Host keys
	randomHostKeys,
	hostKeys,
	hostKey,
	hostPubKey,
	getHostPubKey,
	-- * User keys and configuration
	userKeys,
	userKeyAt,
	knownHost,
	unknownHost,
	authorizedKeysFrom,
	unauthorizedKeysFrom,
	authorizedKeys,
	authorizedKey,
	hasAuthorizedKeys,
	getUserPubKeys,
) where

import Propellor.Base
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Service as Service
import qualified Propellor.Property.Apt as Apt
import Propellor.Property.User
import Propellor.Types.Info
import Utility.FileMode

import System.PosixCompat
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Semigroup as Sem
import Data.List

installed :: Property UnixLike
installed = "ssh installed" ==> (aptinstall `pickOS` unsupportedOS)
  where
	aptinstall :: Property DebianLike
	aptinstall = Apt.installed ["ssh"]

restarted :: Property DebianLike
restarted = Service.restarted "ssh"

sshBool :: Bool -> String
sshBool True = "yes"
sshBool False = "no"

sshdConfig :: FilePath
sshdConfig = "/etc/ssh/sshd_config"

type ConfigKeyword = String

setSshdConfigBool :: ConfigKeyword -> Bool -> Property DebianLike
setSshdConfigBool setting allowed = setSshdConfig setting (sshBool allowed)

setSshdConfig :: ConfigKeyword -> String -> Property DebianLike
setSshdConfig setting v = File.fileProperty desc f sshdConfig
	`onChange` restarted
  where
	desc = unwords [ "ssh config:", setting, v ]
	cfgline = setting ++ " " ++ v
	wantedline s
		| s == cfgline = True
		| (setting ++ " ") `isPrefixOf` s = False
		| otherwise = True
	f ls
		| cfgline `elem` ls = filter wantedline ls
		| otherwise = filter wantedline ls ++ [cfgline]

data RootLogin
	= RootLogin Bool  -- ^ allow or prevent root login
	| 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 DebianLike
permitRootLogin (RootLogin b) = setSshdConfigBool "PermitRootLogin" b
permitRootLogin WithoutPassword = setSshdConfig "PermitRootLogin" "without-password"
permitRootLogin ForcedCommandsOnly = setSshdConfig "PermitRootLogin" "forced-commands-only"

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 DebianLike
noPasswords = check (hasAuthorizedKeys (User "root")) $
	passwordAuthentication False

dotDir :: User -> IO FilePath
dotDir user = do
	h <- homedir user
	return $ h </> ".ssh"

dotFile :: FilePath -> User -> IO FilePath
dotFile f user = do
	d <- dotDir user
	return $ d </> f

-- | Makes the ssh server listen on a given port, in addition to any other
-- ports it is configured to listen on.
--
-- Revert to prevent it listening on a particular port.
listenPort :: Port -> RevertableProperty DebianLike DebianLike
listenPort port = enable <!> disable
  where
	portline = "Port " ++ val port
	enable = sshdConfig `File.containsLine` portline
		`describe` ("ssh listening on " ++ portline)
		`onChange` restarted
	disable = sshdConfig `File.lacksLine` portline
		`describe` ("ssh not listening on " ++ portline)
		`onChange` restarted

hasAuthorizedKeys :: User -> IO Bool
hasAuthorizedKeys = go <=< dotFile "authorized_keys"
  where
	go f = not . null <$> catchDefaultIO "" (readFile f)

-- | 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 DebianLike
randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
	`onChange` restarted
  where
	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 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"
type PubKeyText = String

-- | Installs the specified list of ssh host keys.
--
-- 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 + 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 :: Bool -> [Property DebianLike]
	removestale b = map (tightenTargets . File.notPresent . flip keyFile b) staletypes
	cleanup :: Property DebianLike
	cleanup
		| 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 + 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 ++ ")"
	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.
keyFileContent :: [String] -> [File.Line]
keyFileContent keylines = keylines ++ [""]

keyFile :: SshKeyType -> Bool -> FilePath
keyFile keytype ispub = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++ ext
  where
	ext = if ispub then ".pub" else ""

-- | 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 + UnixLike)
hostPubKey t = pureInfoProperty "ssh pubkey known" . HostKeyInfo . M.singleton t

getHostPubKey :: Propellor (M.Map SshKeyType PubKeyText)
getHostPubKey = fromHostKeyInfo <$> askInfo

newtype HostKeyInfo = HostKeyInfo
	{ fromHostKeyInfo :: M.Map SshKeyType PubKeyText }
	deriving (Eq, Ord, Typeable, Show)

instance IsInfo HostKeyInfo where
	propagateInfo _ = PropagateInfo False

instance Sem.Semigroup HostKeyInfo where
	HostKeyInfo old <> HostKeyInfo new =
		-- new first because union prefers values from the first
		-- parameter when there is a duplicate key
		HostKeyInfo (new `M.union` old)

instance Monoid HostKeyInfo where
	mempty = HostKeyInfo M.empty
	mappend = (Sem.<>)

userPubKeys :: User -> [(SshKeyType, PubKeyText)] -> Property (HasInfo + UnixLike)
userPubKeys u@(User n) l = pureInfoProperty ("ssh pubkey for " ++ n) $
	UserKeyInfo (M.singleton u (S.fromList l))

getUserPubKeys :: User -> Propellor [(SshKeyType, PubKeyText)]
getUserPubKeys u = maybe [] S.toList . M.lookup u . fromUserKeyInfo <$> askInfo

newtype UserKeyInfo = UserKeyInfo
	{ fromUserKeyInfo :: M.Map User (S.Set (SshKeyType, PubKeyText)) }
	deriving (Eq, Ord, Typeable, Show)

instance IsInfo UserKeyInfo where
	propagateInfo _ = PropagateInfo False

instance Sem.Semigroup UserKeyInfo where
	UserKeyInfo old <> UserKeyInfo new =
		UserKeyInfo (M.unionWith S.union old new)

instance Monoid UserKeyInfo where
	mempty = UserKeyInfo M.empty
	mappend = (Sem.<>)

-- | Sets up a user with the specified public keys, and the corresponding
-- private keys from the privdata.
--
-- 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 + UnixLike)
userKeys user@(User name) context ks = combineProperties desc $ toProps $
	userPubKeys user ks : map (userKeyAt Nothing user context) ks
  where
	desc = unwords
		[ name
		, "has ssh key"
		, "(" ++ unwords (map (fromKeyType . fst) ks) ++ ")"
		]

-- | Sets up a user with the specified pubic key, and a private
-- key from the privdata.
--
-- 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 + UnixLike)
userKeyAt dest user@(User u) context (keytype, pubkeytext) =
	combineProperties desc $ props
		& pubkey
		& privkey
  where
	desc = unwords $ catMaybes
		[ Just u
		, Just "has ssh key"
		, dest
		, Just $ "(" ++ fromKeyType keytype ++ ")"
		]
	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
		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
			return $ home </> ".ssh" </> "id_" ++ fromKeyType keytype ++ ext
		Just f -> return $ f ++ ext

fromKeyType :: SshKeyType -> String
fromKeyType SshRsa = "rsa"
fromKeyType SshDsa = "dsa"
fromKeyType SshEcdsa = "ecdsa"
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 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
		warningMessage $ "no configured ssh host keys for " ++ hn
		return FailedChange
	go w ls = do
		f <- liftIO $ dotFile "known_hosts" user
		ensureProperty w $ modKnownHost user f $
			f `File.containsLines` ls
				`requires` File.dirExists (takeDirectory f)

-- | Reverts `knownHost`
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 w ls = do
		f <- liftIO $ dotFile "known_hosts" user
		ifM (liftIO $ doesFileExist f)
			( ensureProperty w $ modKnownHost user f $
				f `File.lacksLines` ls
			, return NoChange
			)

knownHostLines :: [Host] -> HostName -> Propellor [File.Line]
knownHostLines hosts hn = keylines <$> fromHost hosts hn getHostPubKey
  where
	keylines (Just m) = map (\k -> hn ++ " " ++ k) (M.elems m)
	keylines Nothing = []

modKnownHost :: User -> FilePath -> Property UnixLike -> Property UnixLike
modKnownHost user f p = p
	`before` File.ownerGroup f user (userGroup user)
	`before` File.ownerGroup (takeDirectory f) user (userGroup user)

-- | Ensures that a local user's authorized_keys contains lines allowing
-- logins from a remote user on the specified Host.
--
-- The ssh keys of the remote user can be set using `userKeys`
--
-- Any other lines in the authorized_keys file are preserved as-is.
authorizedKeysFrom :: User -> (User, Host) -> Property UnixLike
localuser@(User ln) `authorizedKeysFrom` (remoteuser@(User rn), remotehost) =
	property' desc (\w -> go w =<< authorizedKeyLines remoteuser remotehost)
  where
	remote = rn ++ "@" ++ hostName remotehost
	desc = ln ++ " authorized_keys from " ++ remote

	go _ [] = do
		warningMessage $ "no configured ssh user keys for " ++ remote
		return FailedChange
	go w ls = ensureProperty w $ combineProperties desc $ toProps $
		map (setupRevertableProperty . authorizedKey localuser) ls

-- | Reverts `authorizedKeysFrom`
unauthorizedKeysFrom :: User -> (User, Host) -> Property UnixLike
localuser@(User ln) `unauthorizedKeysFrom` (remoteuser@(User rn), remotehost) =
	property' desc (\w -> go w =<< authorizedKeyLines remoteuser remotehost)
  where
	remote = rn ++ "@" ++ hostName remotehost
	desc = ln ++ " unauthorized_keys from " ++ remote

	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 =
	map snd <$> fromHost' remotehost (getUserPubKeys remoteuser)

-- | Makes a user have authorized_keys from the PrivData
--
-- This removes any other lines from the file.
authorizedKeys :: IsContext c => User -> c -> Property (HasInfo + UnixLike)
authorizedKeys user@(User u) context = withPrivData (SshAuthorizedKeys u) context $ \get ->
	property' desc $ \w -> get $ \v -> do
		f <- liftIO $ dotFile "authorized_keys" 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 UnixLike UnixLike
authorizedKey user@(User u) l = add <!> remove
  where
	add = property' (u ++ " has authorized_keys") $ \w -> do
		f <- liftIO $ dotFile "authorized_keys" user
		ensureProperty w $ modAuthorizedKey f user $
			f `File.containsLine` l
				`requires` File.dirExists (takeDirectory f)
	remove = property' (u ++ " lacks authorized_keys") $ \w -> do
		f <- liftIO $ dotFile "authorized_keys" user
		ifM (liftIO $ doesFileExist f)
			( ensureProperty w $ modAuthorizedKey f user $
				f `File.lacksLine` l
			, return NoChange
			)

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)