blob: bb9ab6d0fe743c7274414863ac852b479bee6875 (
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
|
{- 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 r))) = void $ do
let pairdata = verifiableVal r
let repo = remoteUserName pairdata ++ "@" ++
fromMaybe (showAddr $ remoteAddress pairdata)
(remoteHostName 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. -}
addAlert dstatus $ pairRequestAlert repo msg
dispatch (Just (PairAckM _)) = noop -- TODO
|