summaryrefslogtreecommitdiff
path: root/Assistant/WebApp/Configurators/Ssh.hs
blob: 7fba8ff523fb703d7653e3fe0cc1248eee626d9c (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
{- git-annex assistant webapp configurator for ssh-based remotes
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}

module Assistant.WebApp.Configurators.Ssh where

import Assistant.Common
import Assistant.Ssh
import Assistant.MakeRemote
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Utility.Yesod
import Utility.Rsync (rsyncUrlIsShell)
import Logs.Remote
import Remote

import Yesod
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Map as M
import Network.BSD
import System.Posix.User

sshConfigurator :: Widget -> Handler RepHtml
sshConfigurator a = bootstrap (Just Config) $ do
	sideBarDisplay
	setTitle "Add a remote server"
	a

data SshInput = SshInput
	{ hostname :: Maybe Text
	, username :: Maybe Text
	, directory :: Maybe Text
	}
	deriving (Show)

{- SshInput is only used for applicative form prompting, this converts
 - the result of such a form into a SshData. -}
mkSshData :: SshInput -> SshData
mkSshData s = SshData 
	{ sshHostName = fromMaybe "" $ hostname s
	, sshUserName = username s
	, sshDirectory = fromMaybe "" $ directory s
	, sshRepoName = genSshRepoName
		(T.unpack $ fromJust $ hostname s)
		(maybe "" T.unpack $ directory s)
	, needsPubKey = False
	, rsyncOnly = False
	}

sshInputAForm :: SshInput -> AForm WebApp WebApp SshInput
sshInputAForm def = SshInput
	<$> aopt check_hostname "Host name" (Just $ hostname def)
	<*> aopt check_username "User name" (Just $ username def)
	<*> aopt textField "Directory" (Just $ Just $ fromMaybe (T.pack gitAnnexAssistantDefaultDir) $ directory def)
	where
		check_hostname = checkM (liftIO . checkdns) textField
		checkdns t = do
			let h = T.unpack t
			r <- catchMaybeIO $ getHostByName h
			return $ case r of
				-- canonicalize input hostname if it had no dot
				Just hostentry
					| '.' `elem` h -> Right t
					| otherwise -> Right $ T.pack $ hostName hostentry
				Nothing -> Left bad_hostname

		check_username = checkBool (all (`notElem` "/:@ \t") . T.unpack)
			bad_username textField
		
		bad_hostname = "cannot resolve host name" :: Text
		bad_username = "bad user name" :: Text

data ServerStatus
	= UntestedServer
	| UnusableServer Text -- reason why it's not usable
	| UsableRsyncServer
	| UsableSshInput
	deriving (Eq)

usable :: ServerStatus -> Bool
usable UntestedServer = False
usable (UnusableServer _) = False
usable UsableRsyncServer = True
usable UsableSshInput = True

getAddSshR :: Handler RepHtml
getAddSshR = sshConfigurator $ do
	u <- liftIO $ T.pack . userName
		<$> (getUserEntryForID =<< getEffectiveUserID)
	((result, form), enctype) <- lift $
		runFormGet $ renderBootstrap $ sshInputAForm $
			SshInput Nothing (Just u) Nothing
	case result of
		FormSuccess sshinput -> do
			s <- liftIO $ testServer sshinput
			case s of
				Left status -> showform form enctype status
				Right sshdata -> lift $ redirect $ ConfirmSshR sshdata
		_ -> showform form enctype UntestedServer
	where
		showform form enctype status = do
			let authtoken = webAppFormAuthToken
			$(widgetFile "configurators/ssh/add")

{- To enable an existing rsync special remote, parse the SshInput from
 - its rsyncurl, and display a form whose only real purpose is to check
 - if ssh public keys need to be set up. From there, we can proceed with
 - the usual repo setup; all that code is idempotent.
 -
 - Note that there's no EnableSshR because ssh remotes are not special
 - remotes, and so their configuration is not shared between repositories.
 -}
getEnableRsyncR :: UUID -> Handler RepHtml
getEnableRsyncR u = do
	m <- runAnnex M.empty readRemoteLog
	case parseSshRsyncUrl =<< M.lookup "rsyncurl" =<< M.lookup u m of
		Nothing -> redirect AddSshR
		Just sshinput -> sshConfigurator $ do
			((result, form), enctype) <- lift $
				runFormGet $ renderBootstrap $ sshInputAForm sshinput
			case result of
				FormSuccess sshinput'
					| isRsyncNet (hostname sshinput') ->
						void $ lift $ makeRsyncNet sshinput'
					| otherwise -> do
						s <- liftIO $ testServer sshinput'
						case s of
							Left status -> showform form enctype status
							Right sshdata -> enable sshdata
				_ -> showform form enctype UntestedServer
	where
		showform form enctype status = do
			description <- lift $ runAnnex "" $
				T.pack . concat <$> prettyListUUIDs [u]
			let authtoken = webAppFormAuthToken
			$(widgetFile "configurators/ssh/enable")
		enable sshdata = 
			lift $ redirect $ ConfirmSshR $
				sshdata { rsyncOnly = True }

{- Converts a rsyncurl value to a SshInput. But only if it's a ssh rsync
 - url; rsync:// urls or bare path names are not supported.
 -
 - The hostname is stored mangled in the remote log for rsync special
 - remotes configured by this webapp. So that mangling has to reversed
 - here to get back the original hostname.
 -}
parseSshRsyncUrl :: String -> Maybe SshInput
parseSshRsyncUrl u
	| not (rsyncUrlIsShell u) = Nothing
	| otherwise = Just $ SshInput
			{ hostname = val $ unMangleSshHostName host
			, username = if null user then Nothing else val user
			, directory = val dir
			}
		where
			val = Just . T.pack
			(userhost, dir) = separate (== ':') u
			(user, host) = if '@' `elem` userhost
				then separate (== '@') userhost
				else (userhost, "")

{- Test if we can ssh into the server.
 -
 - Two probe attempts are made. First, try sshing in using the existing
 - configuration, but don't let ssh prompt for any password. If
 - passwordless login is already enabled, use it. Otherwise,
 - a special ssh key will need to be generated just for this server.
 -
 - Once logged into the server, probe to see if git-annex-shell is
 - available, or rsync.
 -}
testServer :: SshInput -> IO (Either ServerStatus SshData)
testServer (SshInput { hostname = Nothing }) = return $
	Left $ UnusableServer "Please enter a host name."
testServer sshinput@(SshInput { hostname = Just hn }) = do
	status <- probe [sshOpt "NumberOfPasswordPrompts" "0"]
	if usable status
		then ret status False
		else do
			status' <- probe []
			if usable status'
				then ret status' True
				else return $ Left status'
	where
		ret status needspubkey = return $ Right $
			(mkSshData sshinput)
				{ needsPubKey = needspubkey
				, rsyncOnly = status == UsableRsyncServer
				}
		probe extraopts = do
			let remotecommand = join ";"
				[ report "loggedin"
				, checkcommand "git-annex-shell"
				, checkcommand "rsync"
				]
			knownhost <- knownHost hn
			let sshopts = filter (not . null) $ extraopts ++
				{- If this is an already known host, let
				 - ssh check it as usual.
				 - Otherwise, trust the host key. -}
				[ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
				, "-n" -- don't read from stdin
				, genSshHost (fromJust $ hostname sshinput) (username sshinput)
				, remotecommand
				]
			parsetranscript . fst <$> sshTranscript sshopts ""
		parsetranscript s
			| reported "git-annex-shell" = UsableSshInput
			| reported "rsync" = UsableRsyncServer
			| reported "loggedin" = UnusableServer
				"Neither rsync nor git-annex are installed on the server. Perhaps you should go install them?"
			| otherwise = UnusableServer $ T.pack $
				"Failed to ssh to the server. Transcript: " ++ s
			where
				reported r = token r `isInfixOf` s
		checkcommand c = "if which " ++ c ++ "; then " ++ report c ++ "; fi"
		token r = "git-annex-probe " ++ r
		report r = "echo " ++ token r

{- Runs a ssh command; if it fails shows the user the transcript,
 - and if it succeeds, runs an action. -}
sshSetup :: [String] -> String -> Handler RepHtml -> Handler RepHtml
sshSetup opts input a = do
	(transcript, ok) <- liftIO $ sshTranscript opts input
	if ok
		then a
		else showSshErr transcript

showSshErr :: String -> Handler RepHtml
showSshErr msg = sshConfigurator $
	$(widgetFile "configurators/ssh/error")

getConfirmSshR :: SshData -> Handler RepHtml
getConfirmSshR sshdata = sshConfigurator $ do
	let authtoken = webAppFormAuthToken
	$(widgetFile "configurators/ssh/confirm")

getMakeSshGitR :: SshData -> Handler RepHtml
getMakeSshGitR = makeSsh False

getMakeSshRsyncR :: SshData -> Handler RepHtml
getMakeSshRsyncR = makeSsh True

makeSsh :: Bool -> SshData -> Handler RepHtml
makeSsh rsync sshdata
	| needsPubKey sshdata = do
		keypair <- liftIO genSshKeyPair
		sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
		makeSsh' rsync sshdata' (Just keypair)
	| otherwise = makeSsh' rsync sshdata Nothing

makeSsh' :: Bool -> SshData -> Maybe SshKeyPair -> Handler RepHtml
makeSsh' rsync sshdata keypair =
	sshSetup [sshhost, remoteCommand] "" $
		makeSshRepo rsync sshdata
	where
		sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata)
		remotedir = T.unpack $ sshDirectory sshdata
		remoteCommand = join "&&" $ catMaybes
			[ Just $ "mkdir -p " ++ shellEscape remotedir
			, Just $ "cd " ++ shellEscape remotedir
			, if rsync then Nothing else Just "git init --bare --shared"
			, if rsync then Nothing else Just "git annex init"
			, if needsPubKey sshdata
				then addAuthorizedKeysCommand (rsyncOnly sshdata) . sshPubKey <$> keypair
				else Nothing
			]

makeSshRepo :: Bool -> SshData -> Handler RepHtml
makeSshRepo forcersync sshdata = do
	webapp <- getYesod
	liftIO $ makeSshRemote
		(fromJust $ threadState webapp)
		(daemonStatus webapp)
		(scanRemotes webapp)
		forcersync sshdata
	redirect RepositoriesR

getAddRsyncNetR :: Handler RepHtml
getAddRsyncNetR = do
	((result, form), enctype) <- runFormGet $
		renderBootstrap $ sshInputAForm $
			SshInput Nothing Nothing Nothing
	let showform status = bootstrap (Just Config) $ do
		sideBarDisplay
		setTitle "Add a Rsync.net repository"	
		let authtoken = webAppFormAuthToken
		$(widgetFile "configurators/addrsync.net")
	case result of
		FormSuccess sshinput
			| isRsyncNet (hostname sshinput) ->
				makeRsyncNet sshinput
			| otherwise ->
				showform $ UnusableServer
					"That is not a rsync.net host name."
		_ -> showform UntestedServer

makeRsyncNet :: SshInput -> Handler RepHtml
makeRsyncNet sshinput = do
	knownhost <- liftIO $ maybe (return False) knownHost (hostname sshinput)
	keypair <- liftIO $ genSshKeyPair
	sshdata <- liftIO $ setupSshKeyPair keypair $
		(mkSshData sshinput)
			{ sshRepoName = "rsync.net"
			, needsPubKey = True
			, rsyncOnly = True
			}
	{- I'd prefer to separate commands with && , but
	 - rsync.net's shell does not support that.
	 -
	 - The dd method of appending to the authorized_keys file is the
	 - one recommended by rsync.net documentation. I touch the file first
	 - to not need to use a different method to create it.
	 -}
	let remotecommand = join ";"
		[ "mkdir -p .ssh"
		, "touch .ssh/authorized_keys"
		, "dd of=.ssh/authorized_keys oflag=append conv=notrunc"
		, "mkdir -p " ++ T.unpack (sshDirectory sshdata)
		]
	let sshopts = filter (not . null)
		[ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
		, genSshHost (sshHostName sshdata) (sshUserName sshdata)
		, remotecommand
		]
	sshSetup sshopts (sshPubKey keypair) $
		makeSshRepo True sshdata

isRsyncNet :: Maybe Text -> Bool
isRsyncNet Nothing = False
isRsyncNet (Just host) = ".rsync.net" `T.isSuffixOf` T.toLower host