6c565ec905
This has not been tested at all. It compiles! The only known missing things are support for encryption, and for get/set of special remote configuration, and of key state. (The latter needs separate work to add a new per-key log file to store that state.) Only thing I don't much like is that initremote needs to be passed both type=external and externaltype=foo. It would be better to have just type=foo Most of this is quite straightforward code, that largely wrote itself given the types. The only tricky parts were: * Need to lock the remote when using it to eg make a request, because in theory git-annex could have multiple threads that each try to use a remote at the same time. I don't think that git-annex ever does that currently, but better safe than sorry. * Rather than starting up every external special remote program when git-annex starts, they are started only on demand, when first used. This will avoid slowdown, especially when running fast git-annex query commands. Once started, they keep running until git-annex stops, currently, which may not be ideal, but it's hard to know a better time to stop them. * Bit of a chicken and egg problem with caching the cost of the remote, because setting annex-cost in the git config needs the remote to already be set up. Managed to finesse that. This commit was sponsored by Lukas Anzinger.
96 lines
3.2 KiB
Haskell
96 lines
3.2 KiB
Haskell
{- 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 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 = do
|
|
validateSshPubKey pubkey
|
|
unlessM (liftIO $ addAuthorizedKeys True repodir pubkey) $
|
|
error "failed setting up ssh authorized keys"
|
|
where
|
|
pubkey = remoteSshPubKey $ pairMsgData msg
|
|
|
|
{- 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)
|