added pair listener thread

Assistant.hs

@@ -63,8 +63,10 @@
  - Thread 16: TransferScanner
  - 	Does potentially expensive checks to find data that needs to be
  - 	transferred from or to remotes, and queues Transfers.
- - 	Uses the ScanRemotes map.
+ - 	Uses the ScanRemotes map.a
- - Thread 17: WebApp
+ - Thread 17: PairListener
+ - 	Listens for incoming pairing traffic, and takes action.
+ - Thread 18: WebApp
  - 	Spawns more threads as necessary to handle clients.
  - 	Displays the DaemonStatus.
  -
@@ -124,6 +126,9 @@ import Assistant.Threads.TransferScanner
 import Assistant.Threads.TransferPoller
 #ifdef WITH_WEBAPP
 import Assistant.Threads.WebApp
+#ifdef WITH_PAIRING
+import Assistant.Threads.PairListener
+#endif
 #else
 #warning Building without the webapp. You probably need to install Yesod..
 #endif
@@ -169,6 +174,9 @@ startAssistant assistant daemonize webappwaiter = do
 				[ watch $ commitThread st changechan commitchan transferqueue dstatus
 #ifdef WITH_WEBAPP
 				, assist $ webAppThread (Just st) dstatus scanremotes transferqueue transferslots Nothing webappwaiter
+#ifdef WITH_PAIRING
+				, assist $ pairListenerThread st dstatus
+#endif
 #endif
 				, assist $ pushThread st dstatus commitchan pushmap
 				, assist $ pushRetryThread st dstatus pushmap

Assistant/Alert.hs

@@ -27,7 +27,11 @@ data AlertPriority = Filler | Low | Medium | High | Pinned
 
 {- An alert can have an name, which is used to combine it with other similar
  - alerts. -}
-data AlertName = FileAlert TenseChunk | SanityCheckFixAlert | WarningAlert String
+data AlertName 
+	= FileAlert TenseChunk
+	| SanityCheckFixAlert
+	| WarningAlert String
+	| PairRequestAlert String
 	deriving (Eq)
 
 {- The first alert is the new alert, the second is an old alert.
@@ -259,6 +263,20 @@ sanityCheckFixAlert msg = Alert
 		alerthead = "The daily sanity check found and fixed a problem:"
 		alertfoot = "If these problems persist, consider filing a bug report."
 
+pairRequestAlert :: String -> String -> Alert
+pairRequestAlert repo msg = Alert
+	{ alertClass = Message
+	, alertHeader = Just $ tenseWords ["Pair request"]
+	, alertMessageRender = tenseWords
+	, alertData = [UnTensed $ T.pack msg]
+	, alertBlockDisplay = True
+	, alertPriority = High
+	, alertClosable = True
+	, alertIcon = Just "info-sign"
+	, alertName = Just $ PairRequestAlert repo
+	, alertCombiner = Just $ dataCombiner $ const id
+	}
+
 fileAlert :: TenseChunk -> FilePath -> Alert
 fileAlert msg file = (activityAlert Nothing [f])
 	{ alertName = Just $ FileAlert msg

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

Assistant/WebApp/Configurators/Pairing.hs

@@ -24,11 +24,14 @@
  -}
 
 {-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+{-# LANGUAGE CPP #-}
 
 module Assistant.WebApp.Configurators.Pairing where
 
 import Assistant.Common
+#ifdef WITH_PAIRING
 import Assistant.Pairing
+#endif
 import Assistant.DaemonStatus
 import Utility.Verifiable
 import Assistant.WebApp
@@ -46,6 +49,7 @@ import Data.Char
 import System.Posix.User
 
 getStartPairR :: Handler RepHtml
+#ifdef WITH_PAIRING
 getStartPairR = promptSecret Nothing $ \rawsecret secret -> do
 	hostname <- liftIO $ getHostname
 	username <- liftIO $ getUserName
@@ -57,17 +61,29 @@ getStartPairR = promptSecret Nothing $ \rawsecret secret -> do
 	liftIO $ modifyDaemonStatus_ dstatus $
 		\s -> s { pairingInProgress = pip : pairingInProgress s }
 	lift $ redirect $ InprogressPairR rawsecret
+#else
+getStartPairR = noPairing
+#endif
 
 getInprogressPairR :: Text -> Handler RepHtml
+#ifdef WITH_PAIRING
 getInprogressPairR secret = bootstrap (Just Config) $ do
 	sideBarDisplay
 	setTitle "Pairing"
 	$(widgetFile "configurators/inprogresspairing")
+#else
+getInprogressPairR _ = noPairing
+#endif
 
 getFinishPairR :: PairReq -> Handler RepHtml
+#ifdef WITH_PAIRING
 getFinishPairR req = promptSecret (Just req) $ \_ secret -> do
 	error "TODO"
+#else
+getFinishPairR _ = noPairing
+#endif
 
+#ifdef WITH_PAIRING
 data InputSecret = InputSecret { secretText :: Maybe Text }
 
 promptSecret :: Maybe PairReq -> (Text -> Secret -> Widget) -> Handler RepHtml
@@ -128,3 +144,13 @@ sampleQuote = T.unwords
 
 getUserName :: IO String
 getUserName = userName <$> (getUserEntryForID =<< getEffectiveUserID)
+
+#else
+
+noPairing :: Handler RepHtml
+noPairing = bootstrap (Just Config) $ do
+	sideBarDisplay
+	setTitle "Pairing"
+	$(widgetFile "configurators/nopairing")
+
+#endif

templates/configurators/nopairing.hamlet

@@ -0,0 +1,5 @@
+<div .span9 .hero-unit>
+  <h2>
+    Pairing not supported
+  <p>
+    This build of git-annex does not support pairing. Sorry!