1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
{- 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>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Pairing.Network where
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.
- If so, hope they ignore the garbage from us; we'll certianly
- ignore garbage from them. Wild wild west. -}
pairingPort :: PortNumber
pairingPort = 55556
{- Goal: Reach all hosts on the same network segment.
- Method: Use same address that avahi uses. Other broadcast addresses seem
- to not be let through some routers. -}
multicastAddress :: SomeAddr -> HostName
multicastAddress (IPv4Addr _) = "224.0.0.251"
multicastAddress (IPv6Addr _) = "ff02::fb"
{- 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.
-
- Note that new sockets are opened each time. This is hardly efficient,
- but it allows new network interfaces to be used as they come up.
- On the other hand, the expensive DNS lookups are cached.
-}
multicastPairMsg :: Maybe Int -> Secret -> PairData -> PairStage -> IO ()
multicastPairMsg repeats secret pairdata stage = go M.empty repeats
where
go _ (Just 0) = noop
go cache n = do
addrs <- activeNetworkAddresses
let cache' = updatecache cache addrs
mapM_ (sendinterface cache') addrs
threadDelaySeconds (Seconds 2)
go cache' $ pred <$> n
{- The multicast library currently chokes on ipv6 addresses. -}
sendinterface _ (IPv6Addr _) = noop
sendinterface cache i = void $ catchMaybeIO $
withSocketsDo $ bracket setup cleanup use
where
setup = multicastSender (multicastAddress i) pairingPort
cleanup (sock, _) = sClose sock -- FIXME does not work
use (sock, addr) = do
setInterface sock (showAddr i)
maybe noop (\s -> void $ sendTo sock s addr)
(M.lookup i cache)
updatecache cache [] = cache
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
startSending :: DaemonStatusHandle -> PairingInProgress -> PairStage -> (PairStage -> IO ()) -> IO ()
startSending dstatus pip stage sender = void $ forkIO $ do
tid <- myThreadId
let pip' = pip { inProgressPairStage = stage, inProgressThreadId = Just tid }
oldpip <- modifyDaemonStatusOld dstatus $
\s -> (s { pairingInProgress = Just pip' }, pairingInProgress s)
maybe noop stopold oldpip
sender stage
where
stopold = maybe noop killThread . inProgressThreadId
stopSending :: PairingInProgress -> DaemonStatusHandle -> IO ()
stopSending pip dstatus = do
maybe noop killThread $ inProgressThreadId pip
modifyDaemonStatusOld_ dstatus $ \s -> s { pairingInProgress = Nothing }
class ToSomeAddr a where
toSomeAddr :: a -> SomeAddr
instance ToSomeAddr IPv4 where
toSomeAddr (IPv4 a) = IPv4Addr a
instance ToSomeAddr IPv6 where
toSomeAddr (IPv6 o1 o2 o3 o4) = IPv6Addr (o1, o2, o3, o4)
showAddr :: SomeAddr -> HostName
showAddr (IPv4Addr a) = show $ IPv4 a
showAddr (IPv6Addr (o1, o2, o3, o4)) = show $ IPv6 o1 o2 o3 o4
activeNetworkAddresses :: IO [SomeAddr]
activeNetworkAddresses = filter (not . all (`elem` "0.:") . showAddr)
. concatMap (\ni -> [toSomeAddr $ ipv4 ni, toSomeAddr $ ipv6 ni])
<$> getNetworkInterfaces
{- A human-visible description of the repository being paired with.
- Note that the repository's description is not shown to the user, because
- it could be something like "my repo", which is confusing when pairing
- with someone else's repo. However, this has the same format as the
- default decription of a repo. -}
pairRepo :: PairMsg -> String
pairRepo msg = concat
[ remoteUserName d
, "@"
, fromMaybe (showAddr $ pairMsgAddr msg) (remoteHostName d)
, ":"
, remoteDirectory d
]
where
d = pairMsgData msg
|
