webapp: Fix UI for removing XMPP connection.

This commit is contained in:
Joey Hess 2014-04-20 12:46:33 -04:00
parent 17d2e2b346
commit 9724667a3d
8 changed files with 56 additions and 3 deletions

View file

@ -39,13 +39,21 @@ notCurrentRepo uuid a = do
go Nothing = error "Unknown UUID"
go (Just _) = a
handleXMPPRemoval :: UUID -> Handler Html -> Handler Html
handleXMPPRemoval uuid nonxmpp = do
remote <- fromMaybe (error "unknown remote")
<$> liftAnnex (Remote.remoteFromUUID uuid)
if Remote.isXMPPRemote remote
then deletionPage $ $(widgetFile "configurators/delete/xmpp")
else nonxmpp
getDisableRepositoryR :: UUID -> Handler Html
getDisableRepositoryR uuid = notCurrentRepo uuid $ do
getDisableRepositoryR uuid = notCurrentRepo uuid $ handleXMPPRemoval uuid $ do
void $ liftAssistant $ disableRemote uuid
redirect DashboardR
getDeleteRepositoryR :: UUID -> Handler Html
getDeleteRepositoryR uuid = notCurrentRepo uuid $
getDeleteRepositoryR uuid = notCurrentRepo uuid $ handleXMPPRemoval uuid $ do
deletionPage $ do
reponame <- liftAnnex $ Remote.prettyUUID uuid
$(widgetFile "configurators/delete/start")

View file

@ -25,6 +25,9 @@ import Assistant.WebApp.RepoList
import Assistant.WebApp.Configurators
import Assistant.XMPP
#endif
import qualified Git.Remote
import Remote.List
import Creds
#ifdef WITH_XMPP
import Network.Protocol.XMPP
@ -202,5 +205,22 @@ testXMPP creds = do
showport (UnixSocket s) = s
#endif
getDisconnectXMPPR :: Handler Html
getDisconnectXMPPR = do
#ifdef WITH_XMPP
rs <- filter Remote.isXMPPRemote . syncRemotes
<$> liftAssistant getDaemonStatus
liftAnnex $ do
mapM_ (inRepo . Git.Remote.remove . Remote.name) rs
void remoteListRefresh
removeCreds xmppCredsFile
liftAssistant $ do
updateSyncRemotes
notifyNetMessagerRestart
redirect DashboardR
#else
xmppPage $ $(widgetFile "configurators/xmpp/disabled")
#endif
xmppPage :: Widget -> Handler Html
xmppPage = page "Jabber" (Just Configuration)

View file

@ -20,6 +20,7 @@
/config/xmpp/for/self XMPPConfigForPairSelfR GET POST
/config/xmpp/for/frield XMPPConfigForPairFriendR GET POST
/config/xmpp/needcloudrepo/#UUID NeedCloudRepoR GET
/config/xmpp/disconnect DisconnectXMPPR GET
/config/needconnection ConnectionNeededR GET
/config/fsck ConfigFsckR GET POST
/config/fsck/preferences ConfigFsckPreferencesR POST