automatic repolist updating

This commit is contained in:
Joey Hess 2012-11-13 17:50:54 -04:00
parent b7af4438f8
commit d468e37f46
14 changed files with 135 additions and 70 deletions

View file

@ -44,6 +44,7 @@ modifyDaemonStatus a = do
sendNotification $ changeNotifier s
return b
{- Returns a function that updates the lists of syncable remotes. -}
calcSyncRemotes :: Annex (DaemonStatus -> DaemonStatus)
calcSyncRemotes = do
@ -60,7 +61,9 @@ calcSyncRemotes = do
{- Updates the sycRemotes list from the list of all remotes in Annex state. -}
updateSyncRemotes :: Assistant ()
updateSyncRemotes = modifyDaemonStatus_ =<< liftAnnex calcSyncRemotes
updateSyncRemotes = do
modifyDaemonStatus_ =<< liftAnnex calcSyncRemotes
liftIO . sendNotification =<< syncRemotesNotifier <$> getDaemonStatus
{- Load any previous daemon status file, and store it in a MVar for this
- process to use as its DaemonStatus. Also gets current transfer status. -}

View file

@ -72,8 +72,9 @@ reloadConfigs changedconfigs = do
sequence_ as
void preferredContentMapLoad
{- Changes to the remote log, or the trust log, can affect the
- syncRemotes list -}
when (Logs.Remote.remoteLog `elem` fs || Logs.Trust.trustLog `elem` fs) $
- syncRemotes list. Changes to the uuid log may affect its
- display so are also included. -}
when (any (`elem` fs) [remoteLog, trustLog, uuidLog]) $
updateSyncRemotes
where
(fs, as) = unzip $ filter (flip S.member changedfiles . fst)

View file

@ -47,6 +47,8 @@ data DaemonStatus = DaemonStatus
, transferNotifier :: NotificationBroadcaster
-- Broadcasts notifications when there's a change to the alerts
, alertNotifier :: NotificationBroadcaster
-- Broadcasts notifications when the syncRemotes change
, syncRemotesNotifier :: NotificationBroadcaster
}
type TransferMap = M.Map Transfer TransferInfo
@ -70,3 +72,4 @@ newDaemonStatus = DaemonStatus
<*> newNotificationBroadcaster
<*> newNotificationBroadcaster
<*> newNotificationBroadcaster
<*> newNotificationBroadcaster

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

3
debian/changelog vendored
View file

@ -2,6 +2,9 @@ git-annex (3.20121113) UNRELEASED; urgency=low
* Show error message to user when testing XMPP creds.
* Fix build of assistant without yesod.
* webapp: The list of repositiories refreshes when new repositories are
added, including when new repository configurations are pushed in from
remotes.
-- Joey Hess <joeyh@debian.org> Tue, 13 Nov 2012 13:17:07 -0400

View file

@ -9,38 +9,23 @@
$nothing
A pair request has been sent to all other devices using your jabber #
account.
$else
Pair request accepted.
<h2>
Configure a shared cloud repository
$else
Pair request accepted.
<h2>
Configure a shared cloud repository
$maybe name <- friend
<p>
&#9730; To share files with #{name}, you'll need a repository in #
the cloud, that you both can access.
$if null cloudrepolist
<hr>
^{makeCloudRepositories}
$else
<p>
Make sure that #{name} has access to one of these cloud repositories, #
and that the repository is enabled.
^{repoTable cloudrepolist}
<hr>
Or, add a new cloud repository:
^{makeCloudRepositories}
$nothing
<p>
&#9730; To share files with your other devices, when they're not #
nearby, you'll need a repository in the cloud.
$if null cloudrepolist
<hr>
^{makeCloudRepositories}
$else
<p>
Make sure that your other devices are configured to access one of #
these cloud repositories, and that the repository is enabled here #
too.
^{repoTable cloudrepolist}
<hr>
Or, add a new cloud repository:
^{makeCloudRepositories}
<p>
Make sure that your other devices are configured to access a #
cloud repository, and that the same repository is enabled here #
too.
^{cloudrepolist}
<h2>
Add a cloud repository
^{makeCloudRepositories}

View file

@ -1,7 +1,5 @@
<div .span9>
<h2>
Your repositories
^{repoTable repolist}
^{repolist}
<div .row-fluid>
<div .span6>
<h2>

View file

@ -0,0 +1,36 @@
<div ##{ident}>
$if onlyCloud reposelector
$if not (null repolist)
<h2>
Cloud repositories
$else
No cloud repositories are configured yet.
$else
$if not (null repolist)
<h2>
Repositories
<table .table .table-condensed>
<tbody>
$forall (num, name, actions) <- repolist
<tr>
<td>
#{num}
<td>
#{name}
<td>
$if needsEnabled actions
<a href="@{setupRepoLink actions}">
<i .icon-warning-sign></i> not enabled
$else
<a href="@{syncToggleLink actions}">
$if notSyncing actions
<i .icon-pause></i> syncing paused
$else
<i .icon-refresh></i> syncing enabled
<td>
$if needsEnabled actions
<a href="@{setupRepoLink actions}">
enable
$else
<a href="@{setupRepoLink actions}">
configure

View file

@ -1,25 +0,0 @@
<table .table .table-condensed>
<tbody>
$forall (num, name, actions) <- repolist
<tr>
<td>
#{num}
<td>
#{name}
<td>
$if needsEnabled actions
<a href="@{setupRepoLink actions}">
<i .icon-warning-sign></i> not enabled
$else
<a href="@{syncToggleLink actions}">
$if notSyncing actions
<i .icon-pause></i> syncing paused
$else
<i .icon-refresh></i> syncing enabled
<td>
$if needsEnabled actions
<a href="@{setupRepoLink actions}">
enable
$else
<a href="@{setupRepoLink actions}">
configure