add buddy list to pairing UI

Assistant/Threads/PairListener.hs

@@ -103,7 +103,7 @@ pairListenerThread urlrenderer = NamedThread "PairListener" $ do
 pairReqReceived :: Bool -> UrlRenderer -> PairMsg -> Assistant ()
 pairReqReceived True _ _ = noop -- ignore our own PairReq
 pairReqReceived False urlrenderer msg = do
-	url <- liftIO $ renderUrl urlrenderer (FinishPairR msg) []
+	url <- liftIO $ renderUrl urlrenderer (FinishLocalPairR msg) []
 	close <- asIO1 removeAlert
 	void $ addAlert $ pairRequestReceivedAlert repo
 		AlertButton

Assistant/Types/Buddies.hs

@@ -14,16 +14,37 @@ import Common.Annex
 import qualified Data.Map as M
 import Control.Concurrent.STM
 import Utility.NotificationBroadcaster
+import Data.Text as T
 
-{- When XMPP is enabled, this is an XMPP buddy map.
+{- For simplicity, dummy types are defined even when XMPP is disabled. -}
- - Otherwise, it's an empty map, for simplicity. -}
 #ifdef WITH_XMPP
-import Assistant.XMPP.Buddies
+import Network.Protocol.XMPP
+import Data.Set as S
+import Data.Ord
+
+newtype Client = Client JID
+	deriving (Eq, Show)
+
+instance Ord Client where
+	compare = comparing show
+
+data Buddy = Buddy
+	{ buddyPresent :: S.Set Client
+	, buddyAway :: S.Set Client
+	, buddyAssistants :: S.Set Client
+	}
 #else
-type Buddies = M.Map String Buddy
 data Buddy
-	deriving (Eq)
 #endif
+	deriving (Eq, Show)
+
+data BuddyID = BuddyID T.Text
+	deriving (Eq, Ord, Show, Read)
+
+data BuddyKey = BuddyKey T.Text
+	deriving (Eq, Ord, Show)
+
+type Buddies = M.Map BuddyKey Buddy
 
 {- A list of buddies, and a way to notify when it changes. -}
 type BuddyList = (TMVar Buddies, NotificationBroadcaster)
@@ -39,6 +60,9 @@ newBuddyList = (,)
 getBuddyList :: BuddyList -> IO [Buddy]
 getBuddyList (v, _) = M.elems <$> atomically (readTMVar v)
 
+getBuddyBroadcaster :: BuddyList -> NotificationBroadcaster
+getBuddyBroadcaster (_, h) = h
+
 {- Applies a function to modify the buddy list, and if it's changed,
  - sends notifications to any listeners. -}
 updateBuddyList :: (Buddies -> Buddies) -> BuddyList -> IO ()
@@ -50,8 +74,3 @@ updateBuddyList a (v, caster) = do
 		return $ buds /= buds'
 	when changed $
 		sendNotification caster
-
-{- Allocates a notification handle for a client to use to listen for
- - changes to the buddy list. -}
-newBuddyListNotificationHandle :: BuddyList -> IO NotificationHandle
-newBuddyListNotificationHandle (_, caster) = newNotificationHandle caster

Assistant/WebApp.hs

@@ -11,7 +11,6 @@ module Assistant.WebApp where
 
 import Assistant.WebApp.Types
 import Assistant.Common
-import Assistant.DaemonStatus
 import Utility.NotificationBroadcaster
 import Utility.Yesod
 import Locations.UserConfig
@@ -95,18 +94,15 @@ runAnnex fallback a = ifM (noAnnex <$> getYesod)
 	, liftAssistant $ liftAnnex a
 	)
 
-waitNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> NotificationId -> GHandler sub WebApp ()
+waitNotifier :: forall sub. (Assistant NotificationBroadcaster) -> NotificationId -> GHandler sub WebApp ()
-waitNotifier selector nid = do
+waitNotifier getbroadcaster nid = liftAssistant $ do
-	notifier <- getNotifier selector
+	b <- getbroadcaster
-	liftIO $ waitNotification $ notificationHandleFromId notifier nid
+	liftIO $ waitNotification $ notificationHandleFromId b nid
 
-newNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> GHandler sub WebApp NotificationId
+newNotifier :: forall sub. (Assistant NotificationBroadcaster) -> GHandler sub WebApp NotificationId
-newNotifier selector = do
+newNotifier getbroadcaster = liftAssistant $ do
-	notifier <- getNotifier selector
+	b <- getbroadcaster
-	liftIO $ notificationHandleToId <$> newNotificationHandle notifier
+	liftIO $ notificationHandleToId <$> newNotificationHandle b
-
-getNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> GHandler sub WebApp NotificationBroadcaster
-getNotifier selector = selector <$> liftAssistant getDaemonStatus
 
 {- Adds the auth parameter as a hidden field on a form. Must be put into
  - every form. -}

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
+startLocalPairing :: PairStage -> IO () -> (AlertButton -> Alert) -> Maybe UUID -> Text -> Secret -> Widget
-startPairing stage oncancel alert muuid displaysecret secret = do
+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 :: Text -> Handler RepHtml
-noPairing = pairPage $
+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
+		redirect redirto
-#else
-getXMPPR = xmppPage $
-	$(widgetFile "configurators/xmpp/disabled")
 #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 :: (NotificationId -> Route WebApp) -> Assistant NotificationBroadcaster -> Handler RepPlain
-notifierUrl route selector = do
+notifierUrl route broadcaster = do
-	(urlbits, _params) <- renderRoute . route <$> newNotifier selector
+	(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/local/start StartLocalPairR GET
-/config/repository/pair/finish/#PairMsg FinishPairR 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

Assistant/XMPP/Buddies.hs

@@ -9,32 +9,32 @@ module Assistant.XMPP.Buddies where
 
 import Assistant.XMPP
 import Common.Annex
+import Assistant.Types.Buddies
 
 import Network.Protocol.XMPP
 import qualified Data.Map as M
 import qualified Data.Set as S
-import Data.Ord
+import Data.Text (Text)
+import qualified Data.Text as T
 
-newtype Client = Client JID
+genBuddyID :: JID -> BuddyID
-	deriving (Eq, Show)
+genBuddyID j = BuddyID $ formatJID j
 
-instance Ord Client where
+genKey :: JID -> BuddyKey
-	compare = comparing show
+genKey j = BuddyKey $ formatJID $ JID (jidNode j) (jidDomain j) Nothing
 
-data Buddy = Buddy
+{- Summary of info about a buddy.
-	{ buddyPresent :: S.Set Client
+ -
-	, buddyAway :: S.Set Client
+ - If the buddy has no clients at all anymore, returns Nothing. -}
-	, buddyAssistants :: S.Set Client
+buddySummary :: Buddy -> Maybe (Text, Bool, Bool, BuddyID)
-	}
+buddySummary b = case clients of
-	deriving (Eq, Show)
+	((Client j):_) -> Just (buddyname j, away, canpair, genBuddyID j)
-
+	[] -> Nothing
-{- Note that the buddy map includes one buddy for the user's own JID,
+  where
- - so that we can track other git-annex assistant's sharing the same
+	buddyname j = maybe (T.pack "") strNode (jidNode j)
- - account. -}
+	away = S.null (buddyPresent b) && S.null (buddyAssistants b)
-type Buddies = M.Map String Buddy
+	canpair = not $ S.null (buddyAssistants b)
-
+	clients = S.toList $ buddyPresent b `S.union` buddyAway b `S.union` buddyAssistants b
-genKey :: JID -> String
-genKey j = show $ JID (jidNode j) (jidDomain j) Nothing
 
 {- Updates the buddies with XMPP presence info. -}
 updateBuddies :: Presence -> Buddies -> Buddies

templates/configurators/pairing/disabled.hamlet

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

templates/configurators/pairing/start.hamlet

@@ -0,0 +1,25 @@
+<div .span9 .hero-unit>
+  <h2>
+    Pairing with another computer
+  <p>
+    Pairing with a another computer combines both git-annex repositories # 
+    into a single shared repository, with changes kept in sync.
+  $if localsupported
+    <p>
+      Is the computer you want to pair with located nearby, on the same #
+      local network? (Or sharing a VPN?)
+      <br>
+      If so, the best choice is local pairing.
+      <br>
+      <a .btn .btn-primary href="@{StartLocalPairR}">
+        Start local pairing
+  <p>
+    Or, you can pair with any of your friends using jabber, or with another #
+    computer that shares your jabber account.
+    <p>
+      $if xmppconfigured
+        ^{buddyListDisplay}
+      $else
+        First, you need to #
+        <a .btn .btn-primary href="@{XMPPForPairingR}">
+          configure a jabber account

templates/configurators/repositories.hamlet

@@ -44,12 +44,10 @@
 
       <h3>
         <a href="@{StartPairR}">
-          <i .icon-plus-sign></i> Local computer
+          <i .icon-plus-sign></i> Pair with another computer
       <p>
-        Pair with a local computer to automatically keep files in sync #
+        Connect with another computer used by you, or by a friend,
-        between computers on your local network.
+        that is also running git-annex.
-      <p>
-        For easy sharing with family and friends, or between your devices.
 
       <h3>
         <i .icon-plus-sign></i> Phone

templates/configurators/xmpp/buddylist.hamlet

@@ -0,0 +1,23 @@
+<div .span9 ##{ident}>
+  <table .table>
+    <tbody>
+    $if null buddies
+      <tr>
+        <td> 
+          Nobody is currently available.
+    $else
+      $forall (name, away, canpair, buddyid) <- buddies
+        <tr>
+          <td>
+            <i .icon-user></i> #
+            $if away
+              <span .muted>
+                #{name}
+            $else
+              #{name}
+          <td>
+            $if canpair
+              <a .btn .btn-primary .btn-small href="@{StartXMPPPairR buddyid}">
+                Start pairing
+            $else
+              not using git-annex