remove xmpp support
I've long considered the XMPP support in git-annex a wart. It's nice to remove it. (This also removes the NetMessager, which was only used for XMPP, and the daemonstatus's desynced list (likewise).) Existing XMPP remotes should be ignored by git-annex. This commit was sponsored by Brock Spratlen on Patreon.
This commit is contained in:
Joey Hess
parent
a7fd200440
commit
d58148031b
64 changed files with 38 additions and 2827 deletions
|
|
@ -37,16 +37,8 @@ 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
|
||||
|
||||
getDeleteRepositoryR :: UUID -> Handler Html
|
||||
getDeleteRepositoryR uuid = notCurrentRepo uuid $ handleXMPPRemoval uuid $ do
|
||||
getDeleteRepositoryR uuid = notCurrentRepo uuid $ do
|
||||
deletionPage $ do
|
||||
reponame <- liftAnnex $ Remote.prettyUUID uuid
|
||||
$(widgetFile "configurators/delete/start")
|
||||
|
|
|
|||
|
|
@ -12,7 +12,6 @@ module Assistant.WebApp.Configurators.Pairing where
|
|||
|
||||
import Assistant.Pairing
|
||||
import Assistant.WebApp.Common
|
||||
import Assistant.Types.Buddies
|
||||
import Annex.UUID
|
||||
#ifdef WITH_PAIRING
|
||||
import Assistant.Pairing.Network
|
||||
|
|
@ -22,17 +21,6 @@ import Assistant.Alert
|
|||
import Assistant.DaemonStatus
|
||||
import Utility.Verifiable
|
||||
#endif
|
||||
#ifdef WITH_XMPP
|
||||
import Assistant.XMPP.Client
|
||||
import Assistant.XMPP.Buddies
|
||||
import Assistant.XMPP.Git
|
||||
import Network.Protocol.XMPP
|
||||
import Assistant.Types.NetMessager
|
||||
import Assistant.NetMessager
|
||||
import Assistant.WebApp.RepoList
|
||||
import Assistant.WebApp.Configurators
|
||||
import Assistant.WebApp.Configurators.XMPP
|
||||
#endif
|
||||
import Utility.UserInfo
|
||||
import Git
|
||||
|
||||
|
|
@ -44,84 +32,6 @@ import Data.Char
|
|||
import qualified Control.Exception as E
|
||||
import Control.Concurrent
|
||||
#endif
|
||||
#ifdef WITH_XMPP
|
||||
import qualified Data.Set as S
|
||||
#endif
|
||||
|
||||
getStartXMPPPairFriendR :: Handler Html
|
||||
#ifdef WITH_XMPP
|
||||
getStartXMPPPairFriendR = ifM (isJust <$> liftAnnex getXMPPCreds)
|
||||
( do
|
||||
{- Ask buddies to send presence info, to get
|
||||
- the buddy list populated. -}
|
||||
liftAssistant $ sendNetMessage QueryPresence
|
||||
pairPage $
|
||||
$(widgetFile "configurators/pairing/xmpp/friend/prompt")
|
||||
, do
|
||||
-- go get XMPP configured, then come back
|
||||
redirect XMPPConfigForPairFriendR
|
||||
)
|
||||
#else
|
||||
getStartXMPPPairFriendR = noXMPPPairing
|
||||
|
||||
noXMPPPairing :: Handler Html
|
||||
noXMPPPairing = noPairing "XMPP"
|
||||
#endif
|
||||
|
||||
getStartXMPPPairSelfR :: Handler Html
|
||||
#ifdef WITH_XMPP
|
||||
getStartXMPPPairSelfR = go =<< liftAnnex getXMPPCreds
|
||||
where
|
||||
go Nothing = do
|
||||
-- go get XMPP configured, then come back
|
||||
redirect XMPPConfigForPairSelfR
|
||||
go (Just creds) = do
|
||||
{- Ask buddies to send presence info, to get
|
||||
- the buddy list populated. -}
|
||||
liftAssistant $ sendNetMessage QueryPresence
|
||||
let account = xmppJID creds
|
||||
pairPage $
|
||||
$(widgetFile "configurators/pairing/xmpp/self/prompt")
|
||||
#else
|
||||
getStartXMPPPairSelfR = noXMPPPairing
|
||||
#endif
|
||||
|
||||
getRunningXMPPPairFriendR :: BuddyKey -> Handler Html
|
||||
getRunningXMPPPairFriendR = sendXMPPPairRequest . Just
|
||||
|
||||
getRunningXMPPPairSelfR :: Handler Html
|
||||
getRunningXMPPPairSelfR = sendXMPPPairRequest Nothing
|
||||
|
||||
{- Sends a XMPP pair request, to a buddy or to self. -}
|
||||
sendXMPPPairRequest :: Maybe BuddyKey -> Handler Html
|
||||
#ifdef WITH_XMPP
|
||||
sendXMPPPairRequest mbid = do
|
||||
bid <- maybe getself return mbid
|
||||
buddy <- liftAssistant $ getBuddy bid <<~ buddyList
|
||||
go $ S.toList . buddyAssistants <$> buddy
|
||||
where
|
||||
go (Just (clients@((Client exemplar):_))) = do
|
||||
u <- liftAnnex getUUID
|
||||
liftAssistant $ forM_ clients $ \(Client c) -> sendNetMessage $
|
||||
PairingNotification PairReq (formatJID c) u
|
||||
xmppPairStatus True $
|
||||
if selfpair then Nothing else Just exemplar
|
||||
go _
|
||||
{- Nudge the user to turn on their other device. -}
|
||||
| selfpair = do
|
||||
liftAssistant $ sendNetMessage QueryPresence
|
||||
pairPage $
|
||||
$(widgetFile "configurators/pairing/xmpp/self/retry")
|
||||
{- Buddy could have logged out, etc.
|
||||
- Go back to buddy list. -}
|
||||
| otherwise = redirect StartXMPPPairFriendR
|
||||
selfpair = isNothing mbid
|
||||
getself = maybe (error "XMPP not configured")
|
||||
(return . BuddyKey . xmppJID)
|
||||
=<< liftAnnex getXMPPCreds
|
||||
#else
|
||||
sendXMPPPairRequest _ = noXMPPPairing
|
||||
#endif
|
||||
|
||||
{- Starts local pairing. -}
|
||||
getStartLocalPairR :: Handler Html
|
||||
|
|
@ -158,41 +68,6 @@ postFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
|
|||
postFinishLocalPairR _ = noLocalPairing
|
||||
#endif
|
||||
|
||||
getConfirmXMPPPairFriendR :: PairKey -> Handler Html
|
||||
#ifdef WITH_XMPP
|
||||
getConfirmXMPPPairFriendR pairkey@(PairKey _ t) = case parseJID t of
|
||||
Nothing -> error "bad JID"
|
||||
Just theirjid -> pairPage $ do
|
||||
let name = buddyName theirjid
|
||||
$(widgetFile "configurators/pairing/xmpp/friend/confirm")
|
||||
#else
|
||||
getConfirmXMPPPairFriendR _ = noXMPPPairing
|
||||
#endif
|
||||
|
||||
getFinishXMPPPairFriendR :: PairKey -> Handler Html
|
||||
#ifdef WITH_XMPP
|
||||
getFinishXMPPPairFriendR (PairKey theiruuid t) = case parseJID t of
|
||||
Nothing -> error "bad JID"
|
||||
Just theirjid -> do
|
||||
selfuuid <- liftAnnex getUUID
|
||||
liftAssistant $ do
|
||||
sendNetMessage $
|
||||
PairingNotification PairAck (formatJID theirjid) selfuuid
|
||||
finishXMPPPairing theirjid theiruuid
|
||||
xmppPairStatus False $ Just theirjid
|
||||
#else
|
||||
getFinishXMPPPairFriendR _ = noXMPPPairing
|
||||
#endif
|
||||
|
||||
{- Displays a page indicating pairing status and
|
||||
- prompting to set up cloud repositories. -}
|
||||
#ifdef WITH_XMPP
|
||||
xmppPairStatus :: Bool -> Maybe JID -> Handler Html
|
||||
xmppPairStatus inprogress theirjid = pairPage $ do
|
||||
let friend = buddyName <$> theirjid
|
||||
$(widgetFile "configurators/pairing/xmpp/end")
|
||||
#endif
|
||||
|
||||
getRunningLocalPairR :: SecretReminder -> Handler Html
|
||||
#ifdef WITH_PAIRING
|
||||
getRunningLocalPairR s = pairPage $ do
|
||||
|
|
|
|||
|
|
@ -1,226 +0,0 @@
|
|||
{- git-annex assistant XMPP configuration
|
||||
-
|
||||
- Copyright 2012 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, OverloadedStrings, FlexibleContexts #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Assistant.WebApp.Configurators.XMPP where
|
||||
|
||||
import Assistant.WebApp.Common
|
||||
import Assistant.WebApp.Notifications
|
||||
import Utility.NotificationBroadcaster
|
||||
#ifdef WITH_XMPP
|
||||
import qualified Remote
|
||||
import Assistant.XMPP.Client
|
||||
import Assistant.XMPP.Buddies
|
||||
import Assistant.Types.Buddies
|
||||
import Assistant.NetMessager
|
||||
import Assistant.Alert
|
||||
import Assistant.DaemonStatus
|
||||
import Assistant.WebApp.RepoList
|
||||
import Assistant.WebApp.Configurators
|
||||
import Assistant.XMPP
|
||||
import qualified Git.Remote.Remove
|
||||
import Remote.List
|
||||
import Creds
|
||||
#endif
|
||||
|
||||
#ifdef WITH_XMPP
|
||||
import Network.Protocol.XMPP
|
||||
import Network
|
||||
import qualified Data.Text as T
|
||||
#endif
|
||||
|
||||
{- When appropriate, displays an alert suggesting to configure a cloud repo
|
||||
- to suppliment an XMPP remote. -}
|
||||
checkCloudRepos :: UrlRenderer -> Remote -> Assistant ()
|
||||
#ifdef WITH_XMPP
|
||||
checkCloudRepos urlrenderer r =
|
||||
unlessM (syncingToCloudRemote <$> getDaemonStatus) $ do
|
||||
buddyname <- getBuddyName $ Remote.uuid r
|
||||
button <- mkAlertButton True "Add a cloud repository" urlrenderer $
|
||||
NeedCloudRepoR $ Remote.uuid r
|
||||
void $ addAlert $ cloudRepoNeededAlert buddyname button
|
||||
#else
|
||||
checkCloudRepos _ _ = noop
|
||||
#endif
|
||||
|
||||
#ifdef WITH_XMPP
|
||||
{- 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
|
||||
#endif
|
||||
|
||||
getNeedCloudRepoR :: UUID -> Handler Html
|
||||
#ifdef WITH_XMPP
|
||||
getNeedCloudRepoR for = page "Cloud repository needed" (Just Configuration) $ do
|
||||
buddyname <- liftAssistant $ getBuddyName for
|
||||
$(widgetFile "configurators/xmpp/needcloudrepo")
|
||||
#else
|
||||
getNeedCloudRepoR _ = xmppPage $
|
||||
$(widgetFile "configurators/xmpp/disabled")
|
||||
#endif
|
||||
|
||||
getXMPPConfigR :: Handler Html
|
||||
getXMPPConfigR = postXMPPConfigR
|
||||
|
||||
postXMPPConfigR :: Handler Html
|
||||
postXMPPConfigR = xmppform DashboardR
|
||||
|
||||
getXMPPConfigForPairFriendR :: Handler Html
|
||||
getXMPPConfigForPairFriendR = postXMPPConfigForPairFriendR
|
||||
|
||||
postXMPPConfigForPairFriendR :: Handler Html
|
||||
postXMPPConfigForPairFriendR = xmppform StartXMPPPairFriendR
|
||||
|
||||
getXMPPConfigForPairSelfR :: Handler Html
|
||||
getXMPPConfigForPairSelfR = postXMPPConfigForPairSelfR
|
||||
|
||||
postXMPPConfigForPairSelfR :: Handler Html
|
||||
postXMPPConfigForPairSelfR = xmppform StartXMPPPairSelfR
|
||||
|
||||
xmppform :: Route WebApp -> Handler Html
|
||||
#ifdef WITH_XMPP
|
||||
xmppform next = xmppPage $ do
|
||||
((result, form), enctype) <- liftH $ do
|
||||
oldcreds <- liftAnnex getXMPPCreds
|
||||
runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ xmppAForm $
|
||||
creds2Form <$> oldcreds
|
||||
let showform problem = $(widgetFile "configurators/xmpp")
|
||||
case result of
|
||||
FormSuccess f -> either (showform . Just) (liftH . storecreds)
|
||||
=<< liftIO (validateForm f)
|
||||
_ -> showform Nothing
|
||||
where
|
||||
storecreds creds = do
|
||||
void $ liftAnnex $ setXMPPCreds creds
|
||||
liftAssistant notifyNetMessagerRestart
|
||||
redirect next
|
||||
#else
|
||||
xmppform _ = xmppPage $
|
||||
$(widgetFile "configurators/xmpp/disabled")
|
||||
#endif
|
||||
|
||||
{- Called by client to get a list of buddies.
|
||||
-
|
||||
- Returns a div, which will be inserted into the calling page.
|
||||
-}
|
||||
getBuddyListR :: NotificationId -> Handler Html
|
||||
getBuddyListR nid = do
|
||||
waitNotifier getBuddyListBroadcaster nid
|
||||
|
||||
p <- widgetToPageContent buddyListDisplay
|
||||
withUrlRenderer $ [hamlet|^{pageBody p}|]
|
||||
|
||||
buddyListDisplay :: Widget
|
||||
buddyListDisplay = do
|
||||
autoUpdate ident NotifierBuddyListR (10 :: Int) (10 :: Int)
|
||||
#ifdef WITH_XMPP
|
||||
myjid <- liftAssistant $ xmppClientID <$> getDaemonStatus
|
||||
let isself (BuddyKey b) = Just b == myjid
|
||||
buddies <- liftAssistant $ do
|
||||
pairedwith <- map fst <$> getXMPPRemotes
|
||||
catMaybes . map (buddySummary pairedwith)
|
||||
<$> (getBuddyList <<~ buddyList)
|
||||
$(widgetFile "configurators/xmpp/buddylist")
|
||||
#else
|
||||
noop
|
||||
#endif
|
||||
where
|
||||
ident = "buddylist"
|
||||
|
||||
#ifdef WITH_XMPP
|
||||
|
||||
getXMPPRemotes :: Assistant [(JID, Remote)]
|
||||
getXMPPRemotes = catMaybes . map pair . filter Remote.isXMPPRemote . syncGitRemotes
|
||||
<$> getDaemonStatus
|
||||
where
|
||||
pair r = maybe Nothing (\jid -> Just (jid, r)) $
|
||||
parseJID $ getXMPPClientID r
|
||||
|
||||
data XMPPForm = XMPPForm
|
||||
{ formJID :: Text
|
||||
, formPassword :: Text }
|
||||
|
||||
creds2Form :: XMPPCreds -> XMPPForm
|
||||
creds2Form c = XMPPForm (xmppJID c) (xmppPassword c)
|
||||
|
||||
xmppAForm :: (Maybe XMPPForm) -> MkAForm XMPPForm
|
||||
xmppAForm d = XMPPForm
|
||||
<$> areq jidField (bfs "Jabber address") (formJID <$> d)
|
||||
<*> areq passwordField (bfs "Password") Nothing
|
||||
|
||||
jidField :: MkField Text
|
||||
jidField = checkBool (isJust . parseJID) bad textField
|
||||
where
|
||||
bad :: Text
|
||||
bad = "This should look like an email address.."
|
||||
|
||||
validateForm :: XMPPForm -> IO (Either String XMPPCreds)
|
||||
validateForm f = do
|
||||
let jid = fromMaybe (error "bad JID") $ parseJID (formJID f)
|
||||
let username = fromMaybe "" (strNode <$> jidNode jid)
|
||||
testXMPP $ XMPPCreds
|
||||
{ xmppUsername = username
|
||||
, xmppPassword = formPassword f
|
||||
, xmppHostname = T.unpack $ strDomain $ jidDomain jid
|
||||
, xmppPort = 5222
|
||||
, xmppJID = formJID f
|
||||
}
|
||||
|
||||
testXMPP :: XMPPCreds -> IO (Either String XMPPCreds)
|
||||
testXMPP creds = do
|
||||
(good, bad) <- partition (either (const False) (const True) . snd)
|
||||
<$> connectXMPP creds (const noop)
|
||||
case good of
|
||||
(((h, PortNumber p), _):_) -> return $ Right $ creds
|
||||
{ xmppHostname = h
|
||||
, xmppPort = fromIntegral p
|
||||
}
|
||||
(((h, _), _):_) -> return $ Right $ creds
|
||||
{ xmppHostname = h
|
||||
}
|
||||
_ -> return $ Left $ intercalate "; " $ map formatlog bad
|
||||
where
|
||||
formatlog ((h, p), Left e) = "host " ++ h ++ ":" ++ showport p ++ " failed: " ++ show e
|
||||
formatlog _ = ""
|
||||
|
||||
showport (PortNumber n) = show n
|
||||
showport (Service s) = s
|
||||
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.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)
|
||||
Loading…
Add table
Add a link
Reference in a new issue