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

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