1{- git-annex assistant pairing network code 2 - 3 - All network traffic is sent over multicast UDP. For reliability, 4 - each message is repeated until acknowledged. This is done using a 5 - thread, that gets stopped before the next message is sent. 6 - 7 - Copyright 2012 Joey Hess <id@joeyh.name> 8 - 9 - Licensed under the GNU AGPL version 3 or higher. 10 -} 11 12module Assistant.Pairing.Network where 13 14import Assistant.Common 15import Assistant.Pairing 16import Assistant.DaemonStatus 17import Utility.ThreadScheduler 18import Utility.Verifiable 19 20import Network.Multicast 21import Network.Info 22import Network.Socket 23import qualified Network.Socket.ByteString as B 24import qualified Data.ByteString.UTF8 as BU8 25import qualified Data.Map as M 26import Control.Concurrent 27 28{- This is an arbitrary port in the dynamic port range, that could 29 - conceivably be used for some other broadcast messages. 30 - If so, hope they ignore the garbage from us; we'll certianly 31 - ignore garbage from them. Wild wild west. -} 32pairingPort :: PortNumber 33pairingPort = 55556 34 35{- Goal: Reach all hosts on the same network segment. 36 - Method: Use same address that avahi uses. Other broadcast addresses seem 37 - to not be let through some routers. -} 38multicastAddress :: AddrClass -> HostName 39multicastAddress IPv4AddrClass = "224.0.0.251" 40multicastAddress IPv6AddrClass = "ff02::fb" 41 42{- Multicasts a message repeatedly on all interfaces, with a 2 second 43 - delay between each transmission. The message is repeated forever 44 - unless a number of repeats is specified. 45 - 46 - The remoteHostAddress is set to the interface's IP address. 47 - 48 - Note that new sockets are opened each time. This is hardly efficient, 49 - but it allows new network interfaces to be used as they come up. 50 - On the other hand, the expensive DNS lookups are cached. 51 -} 52multicastPairMsg :: Maybe Int -> Secret -> PairData -> PairStage -> IO () 53multicastPairMsg repeats secret pairdata stage = go M.empty repeats 54 where 55 go _ (Just 0) = noop 56 go cache n = do 57 addrs <- activeNetworkAddresses 58 let cache' = updatecache cache addrs 59 mapM_ (sendinterface cache') addrs 60 threadDelaySeconds (Seconds 2) 61 go cache' $ pred <$> n 62 {- The multicast library currently chokes on ipv6 addresses. -} 63 sendinterface _ (IPv6Addr _) = noop 64 sendinterface cache i = void $ tryIO $ 65 withSocketsDo $ bracket setup cleanup use 66 where 67 setup = multicastSender (multicastAddress IPv4AddrClass) pairingPort 68 cleanup (sock, _) = close sock -- FIXME does not work 69 use (sock, addr) = do 70 setInterface sock (showAddr i) 71 maybe noop 72 (\s -> void $ B.sendTo sock (BU8.fromString s) addr) 73 (M.lookup i cache) 74 updatecache cache [] = cache 75 updatecache cache (i:is) 76 | M.member i cache = updatecache cache is 77 | otherwise = updatecache (M.insert i (show $ mkmsg i) cache) is 78 mkmsg addr = PairMsg $ 79 mkVerifiable (stage, pairdata, addr) secret 80 81startSending :: PairingInProgress -> PairStage -> (PairStage -> IO ()) -> Assistant () 82startSending pip stage sender = do 83 a <- asIO start 84 void $ liftIO $ forkIO a 85 where 86 start = do 87 tid <- liftIO myThreadId 88 let pip' = pip { inProgressPairStage = stage, inProgressThreadId = Just tid } 89 oldpip <- modifyDaemonStatus $ 90 \s -> (s { pairingInProgress = Just pip' }, pairingInProgress s) 91 maybe noop stopold oldpip 92 liftIO $ sender stage 93 stopold = maybe noop (liftIO . killThread) . inProgressThreadId 94 95stopSending :: PairingInProgress -> Assistant () 96stopSending pip = do 97 maybe noop (liftIO . killThread) $ inProgressThreadId pip 98 modifyDaemonStatus_ $ \s -> s { pairingInProgress = Nothing } 99 100class ToSomeAddr a where 101 toSomeAddr :: a -> SomeAddr 102 103instance ToSomeAddr IPv4 where 104 toSomeAddr (IPv4 a) = IPv4Addr a 105 106instance ToSomeAddr IPv6 where 107 toSomeAddr (IPv6 o1 o2 o3 o4) = IPv6Addr (o1, o2, o3, o4) 108 109showAddr :: SomeAddr -> HostName 110showAddr (IPv4Addr a) = show $ IPv4 a 111showAddr (IPv6Addr (o1, o2, o3, o4)) = show $ IPv6 o1 o2 o3 o4 112 113activeNetworkAddresses :: IO [SomeAddr] 114activeNetworkAddresses = filter (not . all (`elem` "0.:") . showAddr) 115 . concatMap (\ni -> [toSomeAddr $ ipv4 ni, toSomeAddr $ ipv6 ni]) 116 <$> getNetworkInterfaces 117 118{- A human-visible description of the repository being paired with. 119 - Note that the repository's description is not shown to the user, because 120 - it could be something like "my repo", which is confusing when pairing 121 - with someone else's repo. However, this has the same format as the 122 - default description of a repo. -} 123pairRepo :: PairMsg -> String 124pairRepo msg = concat 125 [ remoteUserName d 126 , "@" 127 , fromMaybe (showAddr $ pairMsgAddr msg) (remoteHostName d) 128 , ":" 129 , remoteDirectory d 130 ] 131 where 132 d = pairMsgData msg 133