pairing probably works now (untested)
This commit is contained in:
Joey Hess
parent
a41255723c
commit
d19bbd29d8
11 changed files with 323 additions and 229 deletions
81
Assistant/Pairing/MakeRemote.hs
Normal file
81
Assistant/Pairing/MakeRemote.hs
Normal file
|
|
@ -0,0 +1,81 @@
|
|||
{- 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.ThreadedMonad
|
||||
import Assistant.DaemonStatus
|
||||
import Assistant.ScanRemotes
|
||||
import Assistant.Ssh
|
||||
import Assistant.Pairing
|
||||
import Assistant.Pairing.Network
|
||||
import Assistant.MakeRemote
|
||||
|
||||
import Network.Socket
|
||||
import qualified Data.Text as T
|
||||
|
||||
{- When pairing is complete, this is used to set up the remote for the host
|
||||
- we paired with. -}
|
||||
finishedPairing :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PairMsg -> SshKeyPair -> IO ()
|
||||
finishedPairing st dstatus scanremotes msg keypair = do
|
||||
sshdata <- 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. -}
|
||||
unlessM (knownHost $ sshHostName sshdata) $ do
|
||||
void $ sshTranscript
|
||||
[ sshOpt "StrictHostKeyChecking" "no"
|
||||
, sshOpt "NumberOfPasswordPrompts" "0"
|
||||
, "-n"
|
||||
, genSshHost (sshHostName sshdata) (sshUserName sshdata)
|
||||
, "git-annex-shell -c configlist " ++ T.unpack (sshDirectory sshdata)
|
||||
]
|
||||
""
|
||||
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 (fst <$> getNameInfo [] True False sockaddr) Nothing
|
||||
|
|
@ -1,4 +1,8 @@
|
|||
{- git-annex assistant pairing network code
|
||||
-
|
||||
- All network traffic is sent over multicast UDP. For reliability,
|
||||
- each message is repeated until acknowledged. This is done using a
|
||||
- thread, that gets stopped before the next message is sent.
|
||||
-
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
|
|
@ -7,15 +11,18 @@
|
|||
|
||||
module Assistant.Pairing.Network where
|
||||
|
||||
import Common
|
||||
import Assistant.Common
|
||||
import Assistant.Pairing
|
||||
import Assistant.DaemonStatus
|
||||
import Utility.ThreadScheduler
|
||||
import Utility.Verifiable
|
||||
|
||||
import Network.Multicast
|
||||
import Network.Info
|
||||
import Network.Socket
|
||||
import Control.Exception (bracket)
|
||||
import qualified Data.Map as M
|
||||
import Control.Concurrent
|
||||
|
||||
{- This is an arbitrary port in the dynamic port range, that could
|
||||
- conceivably be used for some other broadcast messages.
|
||||
|
|
@ -30,8 +37,9 @@ multicastAddress :: SomeAddr -> HostName
|
|||
multicastAddress (IPv4Addr _) = "224.0.0.1"
|
||||
multicastAddress (IPv6Addr _) = "ff02::1"
|
||||
|
||||
{- Multicasts a message repeatedly on all interfaces forever, until killed
|
||||
- with a 2 second delay between each transmission.
|
||||
{- Multicasts a message repeatedly on all interfaces, with a 2 second
|
||||
- delay between each transmission. The message is repeated forever
|
||||
- unless a number of repeats is specified.
|
||||
-
|
||||
- The remoteHostAddress is set to the interface's IP address.
|
||||
-
|
||||
|
|
@ -39,15 +47,16 @@ multicastAddress (IPv6Addr _) = "ff02::1"
|
|||
- but it allows new network interfaces to be used as they come up.
|
||||
- On the other hand, the expensive DNS lookups are cached.
|
||||
-}
|
||||
multicastPairMsg :: (SomeAddr -> PairMsg) -> IO ()
|
||||
multicastPairMsg mkmsg = go M.empty
|
||||
multicastPairMsg :: Maybe Int -> Secret -> PairStage -> PairData -> IO ()
|
||||
multicastPairMsg repeats secret stage pairdata = go M.empty repeats
|
||||
where
|
||||
go cache = do
|
||||
go _ (Just 0) = noop
|
||||
go cache n = do
|
||||
addrs <- activeNetworkAddresses
|
||||
let cache' = updatecache cache addrs
|
||||
mapM_ (sendinterface cache') addrs
|
||||
threadDelaySeconds (Seconds 2)
|
||||
go cache'
|
||||
go cache' $ pred <$> n
|
||||
sendinterface cache i = void $ catchMaybeIO $
|
||||
withSocketsDo $ bracket
|
||||
(multicastSender (multicastAddress i) pairingPort)
|
||||
|
|
@ -61,27 +70,23 @@ multicastPairMsg mkmsg = go M.empty
|
|||
updatecache cache (i:is)
|
||||
| M.member i cache = updatecache cache is
|
||||
| otherwise = updatecache (M.insert i (show $ mkmsg i) cache) is
|
||||
mkmsg addr = PairMsg $
|
||||
mkVerifiable (stage, pairdata, addr) secret
|
||||
|
||||
{- Finds the best hostname to use for the host that sent the PairData.
|
||||
-
|
||||
- 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 :: PairData -> IO HostName
|
||||
bestHostName d = case remoteHostName d of
|
||||
Just h -> do
|
||||
let localname = h ++ ".local"
|
||||
addrs <- catchDefaultIO (getAddrInfo Nothing (Just localname) Nothing) []
|
||||
maybe fallback (const $ return localname) (headMaybe addrs)
|
||||
Nothing -> fallback
|
||||
startSending :: DaemonStatusHandle -> PairingInProgress -> IO () -> IO ()
|
||||
startSending dstatus pip sender = do
|
||||
tid <- forkIO sender
|
||||
let pip' = pip { inProgressThreadId = Just tid }
|
||||
oldpip <- modifyDaemonStatus dstatus $
|
||||
\s -> (s { pairingInProgress = Just pip' }, pairingInProgress s)
|
||||
maybe noop stopold oldpip
|
||||
where
|
||||
fallback = do
|
||||
let sockaddr = case remoteAddress d of
|
||||
IPv4Addr a -> SockAddrInet (PortNum 0) a
|
||||
IPv6Addr a -> SockAddrInet6 (PortNum 0) 0 a 0
|
||||
fromMaybe (show $ remoteAddress d)
|
||||
<$> catchDefaultIO (fst <$> getNameInfo [] True False sockaddr) Nothing
|
||||
stopold = maybe noop killThread . inProgressThreadId
|
||||
|
||||
stopSending :: DaemonStatusHandle -> PairingInProgress -> IO ()
|
||||
stopSending dstatus pip = do
|
||||
maybe noop killThread $ inProgressThreadId pip
|
||||
modifyDaemonStatus_ dstatus $ \s -> s { pairingInProgress = Nothing }
|
||||
|
||||
class ToSomeAddr a where
|
||||
toSomeAddr :: a -> SomeAddr
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue