summaryrefslogtreecommitdiff
path: root/Assistant/Pairing/MakeRemote.hs
blob: d7e95686f12623e808a5c24df74bab698746ad46 (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
{- git-annex assistant pairing remote creation
 -
 - Copyright 2012 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Assistant.Pairing.MakeRemote where

import Assistant.Common
import Assistant.Ssh
import Assistant.Pairing
import Assistant.Pairing.Network
import Assistant.MakeRemote

import Network.Socket
import qualified Data.Text as T

{- Authorized keys are set up before pairing is complete, so that the other
 - side can immediately begin syncing. -}
setupAuthorizedKeys :: PairMsg -> IO ()
setupAuthorizedKeys msg = do
	validateSshPubKey pubkey
	unlessM (liftIO $ addAuthorizedKeys False pubkey) $
		error "failed setting up ssh authorized keys"
	where
		pubkey = remoteSshPubKey $ pairMsgData msg

{- When pairing is complete, this is used to set up the remote for the host
 - we paired with. -}
finishedPairing :: PairMsg -> SshKeyPair -> Assistant ()
finishedPairing msg keypair = do
	sshdata <- liftIO $ setupSshKeyPair keypair =<< pairMsgToSshData msg
	{- Ensure that we know the ssh host key for the host we paired with.
	 - If we don't, ssh over to get it. -}
	liftIO $ unlessM (knownHost $ sshHostName sshdata) $
		void $ sshTranscript
			[ sshOpt "StrictHostKeyChecking" "no"
			, sshOpt "NumberOfPasswordPrompts" "0"
			, "-n"
			, genSshHost (sshHostName sshdata) (sshUserName sshdata)
			, "git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata)
			]
			""
	st <- getAssistant threadState
	dstatus <- getAssistant daemonStatusHandle
	scanremotes <- getAssistant scanRemoteMap
	void $ liftIO $ makeSshRemote st dstatus scanremotes False sshdata

{- Mostly a straightforward conversion.  Except:
 -  * Determine the best hostname to use to contact the host.
 -  * Strip leading ~/ from the directory name.
 -}
pairMsgToSshData :: PairMsg -> IO SshData
pairMsgToSshData msg = do
	let d = pairMsgData msg
	hostname <- liftIO $ bestHostName msg
	let dir = case remoteDirectory d of
		('~':'/':v) -> v
		v -> v
	return SshData
		{ sshHostName = T.pack hostname
		, sshUserName = Just (T.pack $ remoteUserName d)
		, sshDirectory = T.pack dir
		, sshRepoName = genSshRepoName hostname dir
		, needsPubKey = True
		, rsyncOnly = False
		}

{- Finds the best hostname to use for the host that sent the PairMsg.
 -
 - If remoteHostName is set, tries to use a .local address based on it.
 - That's the most robust, if this system supports .local.
 - Otherwise, looks up the hostname in the DNS for the remoteAddress,
 - if any. May fall back to remoteAddress if there's no DNS. Ugh. -}
bestHostName :: PairMsg -> IO HostName
bestHostName msg = case remoteHostName $ pairMsgData msg of
	Just h -> do
		let localname = h ++ ".local"
		addrs <- catchDefaultIO [] $
			getAddrInfo Nothing (Just localname) Nothing
		maybe fallback (const $ return localname) (headMaybe addrs)
	Nothing -> fallback
	where
		fallback = do
			let a = pairMsgAddr msg
			let sockaddr = case a of
				IPv4Addr addr -> SockAddrInet (PortNum 0) addr
				IPv6Addr addr -> SockAddrInet6 (PortNum 0) 0 addr 0
			fromMaybe (showAddr a)
				<$> catchDefaultIO Nothing
					(fst <$> getNameInfo [] True False sockaddr)