webapp: Rework xmpp nudge to prompt for either xmpp or a ssh remote be set up.

This commit was sponsored by Nathan Howell.
This commit is contained in:
Joey Hess 2014-04-09 16:27:24 -04:00
parent 14349fb752
commit db38678595
14 changed files with 78 additions and 45 deletions

View file

@ -11,11 +11,12 @@ module Assistant.WebApp.Configurators.Edit where
import Assistant.WebApp.Common
import Assistant.WebApp.Gpg
import Assistant.WebApp.Configurators
import Assistant.DaemonStatus
import Assistant.WebApp.MakeRemote (uniqueRemoteName)
import Assistant.WebApp.Configurators.XMPP (xmppNeeded)
import Assistant.ScanRemotes
import Assistant.Sync
import Assistant.Alert
import qualified Assistant.WebApp.Configurators.AWS as AWS
import qualified Assistant.WebApp.Configurators.IA as IA
#ifdef WITH_S3
@ -183,7 +184,7 @@ getEditNewCloudRepositoryR :: UUID -> Handler Html
getEditNewCloudRepositoryR = postEditNewCloudRepositoryR
postEditNewCloudRepositoryR :: UUID -> Handler Html
postEditNewCloudRepositoryR uuid = xmppNeeded >> editForm True (RepoUUID uuid)
postEditNewCloudRepositoryR uuid = connectionNeeded >> editForm True (RepoUUID uuid)
editForm :: Bool -> RepoId -> Handler Html
editForm new (RepoUUID uuid) = page "Edit repository" (Just Configuration) $ do
@ -275,3 +276,23 @@ getUpgradeRepositoryR r = go =<< liftAnnex (repoIdRemote r)
liftAssistant updateSyncRemotes
liftAssistant $ syncRemote rmt
redirect DashboardR
{- If there is no currently connected remote, display an alert suggesting
- to set up one. -}
connectionNeeded :: Handler ()
connectionNeeded = whenM noconnection $ do
urlrender <- getUrlRender
void $ liftAssistant $ do
close <- asIO1 removeAlert
addAlert $ connectionNeededAlert $ AlertButton
{ buttonLabel = "Connnect"
, buttonUrl = urlrender ConnectionNeededR
, buttonAction = Just close
, buttonPrimary = True
}
where
noconnection = S.null . currentlyConnectedRemotes <$> liftAssistant getDaemonStatus
getConnectionNeededR :: Handler Html
getConnectionNeededR = page "Connection needed" (Just Configuration) $ do
$(widgetFile "configurators/needconnection")

View file

@ -32,23 +32,6 @@ import Network
import qualified Data.Text as T
#endif
{- Displays an alert suggesting to configure XMPP. -}
xmppNeeded :: Handler ()
#ifdef WITH_XMPP
xmppNeeded = whenM (isNothing <$> liftAnnex getXMPPCreds) $ do
urlrender <- getUrlRender
void $ liftAssistant $ do
close <- asIO1 removeAlert
addAlert $ xmppNeededAlert $ AlertButton
{ buttonLabel = "Configure a Jabber account"
, buttonUrl = urlrender XMPPConfigR
, buttonAction = Just close
, buttonPrimary = True
}
#else
xmppNeeded = return ()
#endif
{- When appropriate, displays an alert suggesting to configure a cloud repo
- to suppliment an XMPP remote. -}
checkCloudRepos :: UrlRenderer -> Remote -> Assistant ()