summaryrefslogtreecommitdiff
path: root/Utility/SshConfig.hs
blob: 529e5c9903efcc2fc89bf9459b9f08808c50dad0 (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
{- ssh config file parsing and modification
 -
 - Copyright 2013 Joey Hess <joey@kitenet.net>
 -
 - License: BSD-2-clause
 -}

module Utility.SshConfig where

import Common
import Utility.UserInfo
import Utility.Tmp
import Utility.FileMode

import Data.Char
import Data.Ord
import Data.Either

data SshConfig
	= GlobalConfig SshSetting
	| HostConfig Host [Either Comment SshSetting]
	| CommentLine Comment
	deriving (Show)

data Comment = Comment Indent String
	deriving (Show)

data SshSetting = SshSetting Indent Key Value
	deriving (Show)

type Indent = String
type Host = String
type Key = String
type Value = String

{- Parses ~/.ssh/config. Comments and indentation are preserved.
 -
 - Note that there is no parse failure. If a line cannot be parsed, it will
 - be taken to be a SshSetting that contains the whole line as the key,
 - and has no value. -}
parseSshConfig :: String -> [SshConfig]
parseSshConfig = go [] . lines
  where
	go c [] = reverse c
	go c (l:ls)
		| iscomment l = collect $ CommentLine $ mkcomment l
		| otherwise = case splitline l of
			(indent, k, v)
				| isHost k -> hoststanza v c [] ls
				| otherwise -> collect $ GlobalConfig $ SshSetting indent k v
	  where
		collect v = go (v:c) ls

	hoststanza host c hc [] = go (HostConfig host (reverse hc):c) []
	hoststanza host c hc (l:ls)
		| iscomment l = hoststanza host c ((Left $ mkcomment l):hc) ls
		| otherwise = case splitline l of
			(indent, k, v)
			 	| isHost k -> hoststanza v
					(HostConfig host (reverse hc):c) [] ls
				| otherwise -> hoststanza host c
					((Right $ SshSetting indent k v):hc) ls

	iscomment l = all isSpace l || "#" `isPrefixOf` (dropWhile isSpace l)

	splitline l = (indent, k, v)
	  where
		(indent, rest) = span isSpace l
		(k, v) = separate isSpace rest
	
	mkcomment l = Comment indent c
	  where
		(indent, c) = span isSpace l

	isHost v = map toLower v == "host"
	
genSshConfig :: [SshConfig] -> String
genSshConfig = unlines . concatMap gen
  where
	gen (CommentLine c) = [comment c]
	gen (GlobalConfig s) = [setting s]
	gen (HostConfig h cs) = ("Host " ++ h) : map (either comment setting) cs

	setting (SshSetting indent k v) = indent ++ k ++ " " ++ v
	comment (Comment indent c) = indent ++ c

findHostConfigKey :: SshConfig -> Key -> Maybe Value
findHostConfigKey (HostConfig _ cs) wantk = go (rights cs) (map toLower wantk)
  where
  	go [] _ = Nothing
	go ((SshSetting _ k v):rest) wantk'
		| map toLower k == wantk' = Just v
		| otherwise = go rest wantk'
findHostConfigKey _ _ = Nothing

{- Adds a particular Key and Value to a HostConfig. -}
addToHostConfig :: SshConfig -> Key -> Value -> SshConfig
addToHostConfig (HostConfig host cs) k v = 
	HostConfig host $ Right (SshSetting indent k v) : cs
  where
 	{- The indent is taken from any existing SshSetting
	 - in the HostConfig (largest indent wins). -}
	indent = fromMaybe "\t" $ headMaybe $ reverse $
		sortBy (comparing length) $ map getindent cs
	getindent (Right (SshSetting i _ _)) = i
	getindent (Left (Comment i _)) = i
addToHostConfig other _ _ = other

modifyUserSshConfig :: ([SshConfig] -> [SshConfig]) -> IO ()
modifyUserSshConfig modifier = changeUserSshConfig $ 
	genSshConfig . modifier . parseSshConfig

changeUserSshConfig :: (String -> String) -> IO ()
changeUserSshConfig modifier = do
	sshdir <- sshDir
	let configfile = sshdir </> "config"
	whenM (doesFileExist configfile) $ do
		c <- readFileStrict configfile
		let c' = modifier c
		when (c /= c') $
			viaTmp writeSshConfig configfile c'

writeSshConfig :: FilePath -> String -> IO ()
writeSshConfig f s = do
	writeFile f s
	setSshConfigMode f

{- Ensure that the ssh config file lacks any group or other write bits, 
 - since ssh is paranoid about not working if other users can write
 - to one of its config files (.ssh/config and .ssh/authorized_keys).
 -
 - If the chmod fails, ignore the failure, as it might be a filesystem like
 - Android's that does not support file modes.
 -}
setSshConfigMode :: FilePath -> IO ()
setSshConfigMode f = void $ tryIO $ modifyFileMode f $
	removeModes [groupWriteMode, otherWriteMode]

sshDir :: IO FilePath
sshDir = do
	home <- myHomeDir
	return $ home </> ".ssh"