diff options
author | 2012-09-08 15:07:44 -0400 | |
---|---|---|
committer | 2012-09-08 15:07:44 -0400 | |
commit | 0f0c7f8d701f813f226424d5ae2f21f40a983536 (patch) | |
tree | 607f274278fd76ff48ca774bd971f2c2256cb7e7 /Assistant/Threads | |
parent | aa0227958eeb5fb1580bbd461340c6d3eb4be611 (diff) |
added pair listener thread
Diffstat (limited to 'Assistant/Threads')
-rw-r--r-- | Assistant/Threads/PairListener.hs | 50 |
1 files changed, 50 insertions, 0 deletions
diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs new file mode 100644 index 000000000..f76f0ed4e --- /dev/null +++ b/Assistant/Threads/PairListener.hs @@ -0,0 +1,50 @@ +{- 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.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 |