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
|
{- git-annex assistant pairing remote creation
-
- Copyright 2012 Joey Hess <id@joeyh.name>
-
- 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 Assistant.Sync
import Config.Cost
import Config
import qualified Types.Remote as Remote
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 -> FilePath -> IO ()
setupAuthorizedKeys msg repodir = case validateSshPubKey $ remoteSshPubKey $ pairMsgData msg of
Left err -> error err
Right pubkey ->
unlessM (liftIO $ addAuthorizedKeys True repodir pubkey) $
error "failed setting up ssh authorized keys"
{- When local pairing is complete, this is used to set up the remote for
- the host we paired with. -}
finishedLocalPairing :: PairMsg -> SshKeyPair -> Assistant ()
finishedLocalPairing 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)
]
Nothing
r <- liftAnnex $ addRemote $ makeSshRemote sshdata
liftAnnex $ setRemoteCost (Remote.repo r) semiExpensiveRemoteCost
syncRemote r
{- 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
, sshPort = 22
, needsPubKey = True
, sshCapabilities = [GitAnnexShellCapable, GitCapable, RsyncCapable]
}
{- 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)
|
