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