blob: 12f10070ce06e51abf2e98315062714e66e21572 (
plain)
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
|
{- git-annex assistant thread to listen for incoming pairing traffic
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Threads.PairListener where
import Assistant.Common
import Assistant.Pairing
import Assistant.Pairing.Network
import Assistant.ThreadedMonad
import Assistant.DaemonStatus
import Assistant.Alert
import Utility.Verifiable
import Network.Multicast
import Network.Socket
thisThread :: ThreadName
thisThread = "PairListener"
pairListenerThread :: ThreadState -> DaemonStatusHandle -> NamedThread
pairListenerThread st dstatus = thread $ withSocketsDo $ do
sock <- multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort
forever $ do
msg <- getmsg sock []
dispatch $ readish msg
where
thread = NamedThread thisThread
getmsg sock c = do
(msg, n, _) <- recvFrom sock chunksz
if n < chunksz
then return $ c ++ msg
else getmsg sock $ c ++ msg
where
chunksz = 1024
dispatch Nothing = noop
dispatch (Just (PairReqM (PairReq v))) = unlessM (mypair v) $ do
let pairdata = verifiableVal v
let repo = remoteUserName pairdata ++ "@" ++
fromMaybe (showAddr $ remoteAddress pairdata)
(remoteHostName pairdata) ++
(remoteDirectory pairdata)
let msg = repo ++ " is sending a pair request."
{- Pair request alerts from the same host combine,
- so repeated requests do not add additional alerts. -}
void $ addAlert dstatus $ pairRequestAlert repo msg
dispatch (Just (PairAckM _)) = noop -- TODO
{- Filter out our own pair requests, by checking if we
- can verify using the secrets of any of them. -}
mypair v = any (verified v . inProgressSecret) . pairingInProgress
<$> getDaemonStatus dstatus
|
