add buddy list to pairing UI

Assistant/WebApp/Configurators/Pairing.hs

@@ -14,6 +14,8 @@ import Assistant.Pairing
 import Assistant.WebApp
 import Assistant.WebApp.Types
 import Assistant.WebApp.SideBar
+import Assistant.WebApp.Configurators.XMPP
+import Assistant.Types.Buddies
 import Utility.Yesod
 #ifdef WITH_PAIRING
 import Assistant.Common
@@ -26,6 +28,10 @@ import Utility.Verifiable
 import Utility.Network
 import Annex.UUID
 #endif
+#ifdef WITH_XMPP
+import Assistant.XMPP.Client
+import Network.Protocol.XMPP
+#endif
 import Utility.UserInfo
 
 import Yesod
@@ -39,22 +45,55 @@ import qualified Control.Exception as E
 import Control.Concurrent
 #endif
 
-{- Starts sending out pair requests. -}
+{- Starts either kind of pairing. -}
 getStartPairR :: Handler RepHtml
+#ifdef WITH_XMPP
+getStartPairR = pairPage $ do
+	xmppconfigured <- lift $ isJust <$> runAnnex Nothing getXMPPCreds
 #ifdef WITH_PAIRING
-getStartPairR = promptSecret Nothing $ startPairing PairReq noop pairingAlert Nothing
+	let localsupported = True
 #else
-getStartPairR = noPairing
+	let localsupported = False
+#endif
+	$(widgetFile "configurators/pairing/start")
+#else
+#ifdef WITH_PAIRING
+getStartPairR = redirect StartLocalPairR
+#else
+getStartPairR = noPairing "local or jabber"
+#endif
 #endif
 
-{- Runs on the system that responds to a pair request; sets up the ssh
+{- Starts pairing with an XMPP buddy. -}
+getStartXMPPPairR :: BuddyID -> Handler RepHtml
+#ifdef WITH_XMPP
+getStartXMPPPairR (BuddyID bid) = case parseJID bid of
+	Nothing -> error "bad JID"
+	Just jid -> error "TODO"
+#else
+getStartXMPPPairR _ = noPairing "XMPP"
+#endif
+
+{- Starts local pairing. -}
+getStartLocalPairR :: Handler RepHtml
+#ifdef WITH_PAIRING
+getStartLocalPairR = promptSecret Nothing $
+	startLocalPairing PairReq noop pairingAlert Nothing
+#else
+getStartLocalPairR = noLocalPairing
+
+noLocalPairing :: Handler RepHtml
+noLocalPairing = noPairing "local"
+#endif
+
+{- Runs on the system that responds to a local pair request; sets up the ssh
  - authorized key first so that the originating host can immediately sync
  - with us. -}
-getFinishPairR :: PairMsg -> Handler RepHtml
+getFinishLocalPairR :: PairMsg -> Handler RepHtml
 #ifdef WITH_PAIRING
-getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do
+getFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
 	liftIO $ setup
-	startPairing PairAck cleanup alert uuid "" secret
+	startLocalPairing PairAck cleanup alert uuid "" secret
   where
 	alert = pairRequestAcknowledgedAlert (pairRepo msg) . Just
 	setup  = setupAuthorizedKeys msg
@@ -62,21 +101,21 @@ getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do
 		remoteSshPubKey $ pairMsgData msg
 	uuid = Just $ pairUUID $ pairMsgData msg
 #else
-getFinishPairR _ = noPairing
+getFinishLocalPairR _ = noLocalPairing
 #endif
 
-getInprogressPairR :: SecretReminder -> Handler RepHtml
+getRunningLocalPairR :: SecretReminder -> Handler RepHtml
 #ifdef WITH_PAIRING
-getInprogressPairR s = pairPage $ do
+getRunningLocalPairR s = pairPage $ do
 	let secret = fromSecretReminder s
-	$(widgetFile "configurators/pairing/inprogress")
+	$(widgetFile "configurators/pairing/local/inprogress")
 #else
-getInprogressPairR _ = noPairing
+getRunningLocalPairR _ = noLocalPairing
 #endif
 
 #ifdef WITH_PAIRING
 
-{- Starts pairing, at either the PairReq (initiating host) or 
+{- Starts local pairing, at either the PairReq (initiating host) or 
  - PairAck (responding host) stage.
  -
  - Displays an alert, and starts a thread sending the pairing message,
@@ -85,8 +124,8 @@ getInprogressPairR _ = noPairing
  -
  - Redirects to the pairing in progress page.
  -}
-startPairing :: PairStage -> IO () -> (AlertButton -> Alert) -> Maybe UUID -> Text -> Secret -> Widget
-startPairing stage oncancel alert muuid displaysecret secret = do
+startLocalPairing :: PairStage -> IO () -> (AlertButton -> Alert) -> Maybe UUID -> Text -> Secret -> Widget
+startLocalPairing stage oncancel alert muuid displaysecret secret = do
 	urlrender <- lift getUrlRender
 	reldir <- fromJust . relDir <$> lift getYesod
 
@@ -106,7 +145,7 @@ startPairing stage oncancel alert muuid displaysecret secret = do
 		startSending pip stage $ sendrequests sender
 	void $ liftIO $ forkIO thread
 
-	lift $ redirect $ InprogressPairR $ toSecretReminder displaysecret
+	lift $ redirect $ RunningLocalPairR $ toSecretReminder displaysecret
   where
 	{- Sends pairing messages until the thread is killed,
 	 - and shows an activity alert while doing it.
@@ -164,7 +203,7 @@ promptSecret msg cont = pairPage $ do
 		u <- T.pack <$> liftIO myUserName
 		let sameusername = username == u
 		let authtoken = webAppFormAuthToken
-		$(widgetFile "configurators/pairing/prompt")
+		$(widgetFile "configurators/pairing/local/prompt")
 
 {- This counts unicode characters as more than one character,
  - but that's ok; they *do* provide additional entropy. -}
@@ -189,8 +228,8 @@ sampleQuote = T.unwords
 
 #else
 
-noPairing :: Handler RepHtml
-noPairing = pairPage $
+noPairing :: Text -> Handler RepHtml
+noPairing pairingtype = pairPage $
 	$(widgetFile "configurators/pairing/disabled")
 
 #endif

Assistant/WebApp/Configurators/XMPP.hs

@@ -12,13 +12,17 @@ module Assistant.WebApp.Configurators.XMPP where
 
 import Assistant.WebApp
 import Assistant.WebApp.Types
+import Assistant.WebApp.Notifications
 import Assistant.WebApp.SideBar
+import Assistant.Types.Buddies
 import Assistant.Alert
 import Assistant.DaemonStatus
 import Utility.Yesod
-#ifdef WITH_XMPP
+import Utility.NotificationBroadcaster
 import Assistant.Common
+#ifdef WITH_XMPP
 import Assistant.XMPP.Client
+import Assistant.XMPP.Buddies
 import Assistant.Pushes
 import Utility.SRV
 #endif
@@ -45,7 +49,23 @@ xmppNeeded = whenM (isNothing <$> runAnnex Nothing getXMPPCreds) $ do
 
 getXMPPR :: Handler RepHtml
 #ifdef WITH_XMPP
-getXMPPR = xmppPage $ do
+getXMPPR = getXMPPR' ConfigR
+#else
+getXMPPR = xmppPage $
+	$(widgetFile "configurators/xmpp/disabled")
+#endif
+
+getXMPPForPairingR :: Handler RepHtml
+#ifdef WITH_XMPP
+getXMPPForPairingR = getXMPPR' StartPairR
+#else
+getXMPPForPairingR = xmppPage $
+	$(widgetFile "configurators/xmpp/disabled")
+#endif
+
+#ifdef WITH_XMPP
+getXMPPR' :: Route WebApp -> Handler RepHtml
+getXMPPR' redirto = xmppPage $ do
 	((result, form), enctype) <- lift $ do
 		oldcreds <- runAnnex Nothing getXMPPCreds
 		runFormGet $ renderBootstrap $ xmppAForm $
@@ -61,12 +81,33 @@ getXMPPR = xmppPage $ do
 	storecreds creds = do
 		void $ runAnnex undefined $ setXMPPCreds creds
 		liftAssistant notifyRestart
-		redirect ConfigR
-#else
-getXMPPR = xmppPage $
-	$(widgetFile "configurators/xmpp/disabled")
+		redirect redirto
 #endif
 
+{- Called by client to get a list of buddies.
+ -
+ - Returns a div, which will be inserted into the calling page.
+ -}
+getBuddyListR :: NotificationId -> Handler RepHtml
+getBuddyListR nid = do
+	waitNotifier getBuddyListBroadcaster nid
+
+	page <- widgetToPageContent $ buddyListDisplay
+	hamletToRepHtml $ [hamlet|^{pageBody page}|]
+
+buddyListDisplay :: Widget
+buddyListDisplay = do
+	autoUpdate ident NotifierBuddyListR (10 :: Int) (10 :: Int)
+#ifdef WITH_XMPP
+	buddies <- lift $ liftAssistant $ catMaybes . map buddySummary
+		<$> (getBuddyList <<~ buddyList)
+#else
+	let buddies = []
+#endif
+	$(widgetFile "configurators/xmpp/buddylist")
+  where
+	ident = "buddylist"
+
 #ifdef WITH_XMPP
 
 data XMPPForm = XMPPForm

Assistant/WebApp/DashBoard.hs

@@ -71,7 +71,7 @@ simplifyTransfers (v@(t1, _):r@((t2, _):l))
  -}
 getTransfersR :: NotificationId -> Handler RepHtml
 getTransfersR nid = do
-	waitNotifier transferNotifier nid
+	waitNotifier getTransferBroadcaster nid
 
 	page <- widgetToPageContent $ transfersDisplay False
 	hamletToRepHtml $ [hamlet|^{pageBody page}|]

Assistant/WebApp/Notifications.hs

@@ -12,6 +12,8 @@ module Assistant.WebApp.Notifications where
 import Assistant.Common
 import Assistant.WebApp
 import Assistant.WebApp.Types
+import Assistant.DaemonStatus
+import Assistant.Types.Buddies
 import Utility.NotificationBroadcaster
 import Utility.Yesod
 
@@ -40,9 +42,9 @@ autoUpdate ident geturl ms_delay ms_startdelay = do
  - of NotificationIds when noscript pages are loaded. This constructs a
  - notifier url for a given Route and NotificationBroadcaster.
  -}
-notifierUrl :: (NotificationId -> Route WebApp) -> (DaemonStatus -> NotificationBroadcaster) -> Handler RepPlain
-notifierUrl route selector = do
-	(urlbits, _params) <- renderRoute . route <$> newNotifier selector
+notifierUrl :: (NotificationId -> Route WebApp) -> Assistant NotificationBroadcaster -> Handler RepPlain
+notifierUrl route broadcaster = do
+	(urlbits, _params) <- renderRoute . route <$> newNotifier broadcaster
 	webapp <- getYesod
 	return $ RepPlain $ toContent $ T.concat
 		[ "/"
@@ -52,7 +54,19 @@ notifierUrl route selector = do
 		]
 
 getNotifierTransfersR :: Handler RepPlain
-getNotifierTransfersR = notifierUrl TransfersR transferNotifier
+getNotifierTransfersR = notifierUrl TransfersR getTransferBroadcaster
 
 getNotifierSideBarR :: Handler RepPlain
-getNotifierSideBarR = notifierUrl SideBarR alertNotifier
+getNotifierSideBarR = notifierUrl SideBarR getAlertBroadcaster
+
+getNotifierBuddyListR :: Handler RepPlain
+getNotifierBuddyListR = notifierUrl BuddyListR getBuddyListBroadcaster
+
+getTransferBroadcaster :: Assistant NotificationBroadcaster
+getTransferBroadcaster = transferNotifier <$> getDaemonStatus
+
+getAlertBroadcaster :: Assistant NotificationBroadcaster
+getAlertBroadcaster = alertNotifier <$> getDaemonStatus
+
+getBuddyListBroadcaster :: Assistant NotificationBroadcaster
+getBuddyListBroadcaster =  getBuddyBroadcaster <$> getAssistant buddyList

Assistant/WebApp/SideBar.hs

@@ -59,7 +59,7 @@ sideBarDisplay = do
  -}
 getSideBarR :: NotificationId -> Handler RepHtml
 getSideBarR nid = do
-	waitNotifier alertNotifier nid
+	waitNotifier getAlertBroadcaster nid
 
 	{- This 0.1 second delay avoids very transient notifications from
 	 - being displayed and churning the sidebar unnecesarily. 

Assistant/WebApp/Types.hs

@@ -14,6 +14,7 @@ import Assistant.Common
 import Assistant.Ssh
 import Assistant.Alert
 import Assistant.Pairing
+import Assistant.Types.Buddies
 import Utility.NotificationBroadcaster
 import Utility.WebApp
 import Logs.Transfer
@@ -88,3 +89,7 @@ instance PathPiece SecretReminder where
 instance PathPiece UUID where
     toPathPiece = pack . show
     fromPathPiece = readish . unpack
+
+instance PathPiece BuddyID where
+    toPathPiece = pack . show
+    fromPathPiece = readish . unpack

Assistant/WebApp/routes

@@ -7,6 +7,7 @@
 /config ConfigR GET
 /config/repository RepositoriesR GET
 /config/xmpp XMPPR GET
+/config/xmpp/for/pairing XMPPForPairingR GET
 
 /config/repository/new/first FirstRepositoryR GET
 /config/repository/new NewRepositoryR GET
@@ -26,17 +27,24 @@
 /config/repository/add/cloud/S3 AddS3R GET
 
 /config/repository/pair/start StartPairR GET
-/config/repository/pair/inprogress/#SecretReminder InprogressPairR GET
-/config/repository/pair/finish/#PairMsg FinishPairR GET
+/config/repository/pair/local/start StartLocalPairR GET
+/config/repository/pair/local/running/#SecretReminder RunningLocalPairR GET
+/config/repository/pair/local/finish/#PairMsg FinishLocalPairR GET
+/config/repository/pair/xmpp/start/#BuddyID StartXMPPPairR GET
 
 /config/repository/enable/rsync/#UUID EnableRsyncR GET
 /config/repository/enable/directory/#UUID EnableDirectoryR GET
 /config/repository/enable/S3/#UUID EnableS3R GET
 
 /transfers/#NotificationId TransfersR GET
-/sidebar/#NotificationId SideBarR GET
 /notifier/transfers NotifierTransfersR GET
+
+/sidebar/#NotificationId SideBarR GET
 /notifier/sidebar NotifierSideBarR GET
+
+/buddylist/#NotificationId BuddyListR GET
+/notifier/buddylist NotifierBuddyListR GET
+
 /alert/close/#AlertId CloseAlert GET
 /alert/click/#AlertId ClickAlert GET
 /filebrowser FileBrowserR GET POST