automatic repolist updating

Assistant/WebApp/Configurators.hs

@@ -14,6 +14,7 @@ import Assistant.DaemonStatus
 import Assistant.WebApp
 import Assistant.WebApp.Types
 import Assistant.WebApp.SideBar
+import Assistant.WebApp.Notifications
 import Assistant.WebApp.Utility
 import Assistant.WebApp.Configurators.Local
 import Utility.Yesod
@@ -51,7 +52,11 @@ getConfigR = ifM (inFirstRun)
 introDisplay :: Text -> Widget
 introDisplay ident = do
 	webapp <- lift getYesod
-	repolist <- lift $ repoList False True False
+	repolist <- lift $ repoList $ RepoSelector
+		{ onlyCloud = False
+		, onlyConfigured = True
+		, includeHere = False
+		}
 	let n = length repolist
 	let numrepos = show n
 	$(widgetFile "configurators/intro")
@@ -68,7 +73,11 @@ getRepositoriesR :: Handler RepHtml
 getRepositoriesR = bootstrap (Just Config) $ do
 	sideBarDisplay
 	setTitle "Repositories"
-	repolist <- lift $ repoList False False True
+	let repolist = repoListDisplay $ RepoSelector
+		{ onlyCloud = False
+		, onlyConfigured = False
+		, includeHere = True
+		}
 	$(widgetFile "configurators/repositories")
 
 data Actions
@@ -103,16 +112,35 @@ notSyncing :: Actions -> Bool
 notSyncing (SyncingRepoActions _ _) = False
 notSyncing _ = True
 
-repoTable :: RepoList -> Widget
-repoTable repolist = $(widgetFile "configurators/repositories/table")
+{- Called by client to get a list of repos, that refreshes
+ - when new repos as added.
+ -
+ - Returns a div, which will be inserted into the calling page.
+ -}
+getRepoListR :: RepoListNotificationId -> Handler RepHtml
+getRepoListR (RepoListNotificationId nid reposelector) = do
+	waitNotifier getRepoListBroadcaster nid
+	page <- widgetToPageContent $ repoListDisplay reposelector
+	hamletToRepHtml $ [hamlet|^{pageBody page}|]
+
+repoListDisplay :: RepoSelector -> Widget
+repoListDisplay reposelector = do
+	autoUpdate ident (NotifierRepoListR reposelector) (10 :: Int) (10 :: Int)
+
+	repolist <- lift $ repoList reposelector
+
+	$(widgetFile "configurators/repositories/list")
+
+  where
+	ident = "repolist"
 
 type RepoList = [(String, String, Actions)]
 
 {- A numbered list of known repositories,
  - with actions that can be taken on them. -}
-repoList :: Bool -> Bool -> Bool -> Handler RepoList
-repoList onlycloud onlyconfigured includehere
-	| onlyconfigured = list =<< configured
+repoList :: RepoSelector -> Handler RepoList
+repoList reposelector
+	| onlyConfigured reposelector = list =<< configured
 	| otherwise = list =<< (++) <$> configured <*> rest
   where
 	configured = do
@@ -121,7 +149,7 @@ repoList onlycloud onlyconfigured includehere
 		runAnnex [] $ do
 			u <- getUUID
 			let l = map Remote.uuid rs
-			let l' = if includehere then u : l else l
+			let l' = if includeHere reposelector then u : l else l
 			return $ zip l' $ map mkSyncingRepoActions l'
 	rest = runAnnex [] $ do
 		m <- readRemoteLog
@@ -134,11 +162,11 @@ repoList onlycloud onlyconfigured includehere
 		return $ zip unsyncable (map mkNotSyncingRepoActions unsyncable) ++ unconfigured
 	wantedrepo r
 		| Remote.readonly r = False
-		| onlycloud = Git.repoIsUrl (Remote.repo r) && not (isXMPPRemote r)
+		| onlyCloud reposelector = Git.repoIsUrl (Remote.repo r) && not (isXMPPRemote r)
 		| otherwise = True
 	wantedremote Nothing = False
 	wantedremote (Just (iscloud, _))
-		| onlycloud = iscloud
+		| onlyCloud reposelector = iscloud
 		| otherwise = True
 	findinfo m u = case M.lookup u m of
 		Nothing -> Nothing

Assistant/WebApp/Configurators/Pairing.hs

@@ -158,7 +158,11 @@ getFinishXMPPPairR _ = noXMPPPairing
 xmppPairEnd :: Bool -> Maybe JID -> Handler RepHtml
 xmppPairEnd inprogress theirjid = pairPage $ do
 	let friend = buddyName <$> theirjid
-	cloudrepolist <- lift $ repoList True False False
+	let cloudrepolist = repoListDisplay $ RepoSelector
+		{ onlyCloud = True
+		, onlyConfigured = False
+		, includeHere = False
+		}
 	$(widgetFile "configurators/pairing/xmpp/end")
 #endif
 

Assistant/WebApp/Configurators/XMPP.hs

@@ -97,7 +97,7 @@ getBuddyListR :: NotificationId -> Handler RepHtml
 getBuddyListR nid = do
 	waitNotifier getBuddyListBroadcaster nid
 
-	page <- widgetToPageContent $ buddyListDisplay
+	page <- widgetToPageContent buddyListDisplay
 	hamletToRepHtml $ [hamlet|^{pageBody page}|]
 
 buddyListDisplay :: Widget

Assistant/WebApp/Notifications.hs

@@ -62,6 +62,11 @@ getNotifierSideBarR = notifierUrl SideBarR getAlertBroadcaster
 getNotifierBuddyListR :: Handler RepPlain
 getNotifierBuddyListR = notifierUrl BuddyListR getBuddyListBroadcaster
 
+getNotifierRepoListR :: RepoSelector -> Handler RepPlain
+getNotifierRepoListR reposelector = notifierUrl route getRepoListBroadcaster
+  where
+	route nid = RepoListR $ RepoListNotificationId nid reposelector
+
 getTransferBroadcaster :: Assistant NotificationBroadcaster
 getTransferBroadcaster = transferNotifier <$> getDaemonStatus
 
@@ -70,3 +75,6 @@ getAlertBroadcaster = alertNotifier <$> getDaemonStatus
 
 getBuddyListBroadcaster :: Assistant NotificationBroadcaster
 getBuddyListBroadcaster =  getBuddyBroadcaster <$> getAssistant buddyList
+
+getRepoListBroadcaster :: Assistant NotificationBroadcaster
+getRepoListBroadcaster =  syncRemotesNotifier <$> getDaemonStatus

Assistant/WebApp/Types.hs

@@ -62,6 +62,16 @@ data WebAppState = WebAppState
 	, otherRepos :: [(String, String)] -- name and path to other repos
 	}
 
+data RepoSelector = RepoSelector
+	{ onlyCloud :: Bool
+	, onlyConfigured :: Bool
+	, includeHere :: Bool
+	}
+	deriving (Read, Show, Eq)
+
+data RepoListNotificationId = RepoListNotificationId NotificationId RepoSelector
+	deriving (Read, Show, Eq)
+
 instance PathPiece SshData where
     toPathPiece = pack . show
     fromPathPiece = readish . unpack
@@ -97,3 +107,11 @@ instance PathPiece BuddyKey where
 instance PathPiece PairKey where
     toPathPiece = pack . show
     fromPathPiece = readish . unpack
+
+instance PathPiece RepoListNotificationId where
+    toPathPiece = pack . show
+    fromPathPiece = readish . unpack
+
+instance PathPiece RepoSelector where
+    toPathPiece = pack . show
+    fromPathPiece = readish . unpack

Assistant/WebApp/routes

@@ -47,6 +47,9 @@
 /buddylist/#NotificationId BuddyListR GET
 /notifier/buddylist NotifierBuddyListR GET
 
+/repolist/#RepoListNotificationId RepoListR GET
+/notifier/repolist/#RepoSelector NotifierRepoListR GET
+
 /alert/close/#AlertId CloseAlert GET
 /alert/click/#AlertId ClickAlert GET
 /filebrowser FileBrowserR GET POST