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"
|
