95 lines
3.2 KiB
Haskell
95 lines
3.2 KiB
Haskell
{- 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)
|