webapp: Display an alert when there are XMPP remotes, and a cloud transfer repository needs to be configured.

This commit is contained in:
Joey Hess 2013-03-15 17:52:41 -04:00
parent 39e979fb65
commit 77c82de4ea
13 changed files with 146 additions and 27 deletions

View file

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

View file

@ -13,6 +13,7 @@ module Assistant.WebApp.Configurators.XMPP where
import Assistant.WebApp.Common
import Assistant.WebApp.Notifications
import Utility.NotificationBroadcaster
import qualified Remote
#ifdef WITH_XMPP
import Assistant.XMPP.Client
import Assistant.XMPP.Buddies
@ -21,6 +22,9 @@ import Assistant.NetMessager
import Assistant.Alert
import Assistant.DaemonStatus
import Utility.SRV
import Assistant.WebApp.RepoList
import Assistant.WebApp.Configurators
import Assistant.XMPP
#endif
#ifdef WITH_XMPP
@ -30,7 +34,7 @@ import qualified Data.Text as T
import Control.Exception (SomeException)
#endif
{- Displays an alert suggesting to configure XMPP, with a button. -}
{- Displays an alert suggesting to configure XMPP. -}
xmppNeeded :: Handler ()
#ifdef WITH_XMPP
xmppNeeded = whenM (isNothing <$> liftAnnex getXMPPCreds) $ do
@ -46,6 +50,48 @@ xmppNeeded = whenM (isNothing <$> liftAnnex getXMPPCreds) $ do
xmppNeeded = return ()
#endif
{- Displays an alert suggesting to configure a cloud repo
- to suppliment an XMPP remote. -}
cloudRepoNeeded :: UrlRenderer -> UUID -> Assistant ()
#ifdef WITH_XMPP
cloudRepoNeeded urlrenderer for = do
buddyname <- getBuddyName for
url <- liftIO $ renderUrl urlrenderer (NeedCloudRepoR for) []
close <- asIO1 removeAlert
void $ addAlert $ cloudRepoNeededAlert buddyname $ AlertButton
{ buttonLabel = "Add a cloud repository"
, buttonUrl = url
, buttonAction = Just close
}
#else
cloudRepoNeeded = return ()
#endif
{- Returns the name of the friend corresponding to a
- repository's UUID, but not if it's our name. -}
getBuddyName :: UUID -> Assistant (Maybe String)
getBuddyName u = go =<< getclientjid
where
go Nothing = return Nothing
go (Just myjid) = (T.unpack . buddyName <$>)
. headMaybe
. filter (\j -> baseJID j /= baseJID myjid)
. map fst
. filter (\(_, r) -> Remote.uuid r == u)
<$> getXMPPRemotes
getclientjid = maybe Nothing parseJID . xmppClientID
<$> getDaemonStatus
getNeedCloudRepoR :: UUID -> Handler RepHtml
#ifdef WITH_XMPP
getNeedCloudRepoR for = page "Cloud repository needed" (Just Configuration) $ do
buddyname <- lift $ liftAssistant $ getBuddyName for
$(widgetFile "configurators/xmpp/needcloudrepo")
#else
needCloudRepoR = xmppPage $
$(widgetFile "configurators/xmpp/disabled")
#endif
getXMPPR :: Handler RepHtml
#ifdef WITH_XMPP
getXMPPR = xmppPage $ do
@ -86,8 +132,7 @@ buddyListDisplay = do
myjid <- lift $ liftAssistant $ xmppClientID <$> getDaemonStatus
let isself (BuddyKey b) = Just b == myjid
buddies <- lift $ liftAssistant $ do
rs <- filter isXMPPRemote . syncGitRemotes <$> getDaemonStatus
let pairedwith = catMaybes $ map (parseJID . getXMPPClientID) rs
pairedwith <- map fst <$> getXMPPRemotes
catMaybes . map (buddySummary pairedwith)
<$> (getBuddyList <<~ buddyList)
$(widgetFile "configurators/xmpp/buddylist")
@ -97,6 +142,13 @@ buddyListDisplay = do
#ifdef WITH_XMPP
getXMPPRemotes :: Assistant [(JID, Remote)]
getXMPPRemotes = catMaybes . map pair . filter isXMPPRemote . syncGitRemotes
<$> getDaemonStatus
where
pair r = maybe Nothing (\jid -> Just (jid, r)) $
parseJID $ getXMPPClientID r
data XMPPForm = XMPPForm
{ formJID :: Text
, formPassword :: Text }