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