automatic repolist updating
This commit is contained in:
parent
b7af4438f8
commit
d468e37f46
14 changed files with 135 additions and 70 deletions
|
@ -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. -}
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
3
debian/changelog
vendored
|
@ -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
|
||||
|
||||
|
|
|
@ -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>
|
||||
☂ 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>
|
||||
☂ 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}
|
||||
|
|
|
@ -1,7 +1,5 @@
|
|||
<div .span9>
|
||||
<h2>
|
||||
Your repositories
|
||||
^{repoTable repolist}
|
||||
^{repolist}
|
||||
<div .row-fluid>
|
||||
<div .span6>
|
||||
<h2>
|
||||
|
|
36
templates/configurators/repositories/list.hamlet
Normal file
36
templates/configurators/repositories/list.hamlet
Normal 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
|
|
@ -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
|
Loading…
Reference in a new issue