XMPP pair requests are now received, and an alert displayed

This commit is contained in:
Joey Hess 2012-11-03 17:34:19 -04:00
parent b95c255b6d
commit 42f030c905
10 changed files with 124 additions and 59 deletions

View file

@ -136,15 +136,15 @@ import Assistant.Threads.NetWatcher
import Assistant.Threads.TransferScanner
import Assistant.Threads.TransferPoller
import Assistant.Threads.ConfigMonitor
#ifdef WITH_XMPP
import Assistant.Threads.XMPPClient
#endif
#ifdef WITH_WEBAPP
import Assistant.WebApp
import Assistant.Threads.WebApp
#ifdef WITH_PAIRING
import Assistant.Threads.PairListener
#endif
#ifdef WITH_XMPP
import Assistant.Threads.XMPPClient
#endif
#else
#warning Building without the webapp. You probably need to install Yesod..
#endif
@ -191,6 +191,9 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do
#ifdef WITH_PAIRING
, assist $ pairListenerThread urlrenderer
#endif
#ifdef WITH_XMPP
, assist $ xmppClientThread urlrenderer
#endif
#endif
, assist $ pushThread
, assist $ pushRetryThread
@ -205,9 +208,6 @@ startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do
, assist $ netWatcherFallbackThread
, assist $ transferScannerThread
, assist $ configMonitorThread
#ifdef WITH_XMPP
, assist $ xmppClientThread
#endif
, watch $ watchThread
]
liftIO waitForTermination

View file

@ -301,23 +301,23 @@ pairingAlert button = baseActivityAlert
}
pairRequestReceivedAlert :: String -> AlertButton -> Alert
pairRequestReceivedAlert repo button = Alert
pairRequestReceivedAlert who button = Alert
{ alertClass = Message
, alertHeader = Nothing
, alertMessageRender = tenseWords
, alertData = [UnTensed $ T.pack $ repo ++ " is sending a pair request."]
, alertData = [UnTensed $ T.pack $ who ++ " is sending a pair request."]
, alertBlockDisplay = False
, alertPriority = High
, alertClosable = True
, alertIcon = Just InfoIcon
, alertName = Just $ PairAlert repo
, alertName = Just $ PairAlert who
, alertCombiner = Just $ dataCombiner $ \_old new -> new
, alertButton = Just button
}
pairRequestAcknowledgedAlert :: String -> Maybe AlertButton -> Alert
pairRequestAcknowledgedAlert repo button = baseActivityAlert
{ alertData = ["Pair request with", UnTensed (T.pack repo), Tensed "in progress" "complete"]
pairRequestAcknowledgedAlert who button = baseActivityAlert
{ alertData = ["Pair request with", UnTensed (T.pack who), Tensed "in progress" "complete"]
, alertPriority = High
, alertCombiner = Just $ dataCombiner $ \_old new -> new
, alertButton = button

View file

@ -18,27 +18,35 @@ import Assistant.Sync
import Assistant.DaemonStatus
import qualified Remote
import Utility.ThreadScheduler
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.Alert
import Assistant.Pairing
import Network.Protocol.XMPP
import Control.Concurrent
import qualified Data.Text as T
import qualified Data.Set as S
import qualified Git.Branch
import Data.Time.Clock
xmppClientThread :: NamedThread
xmppClientThread = NamedThread "XMPPClient" $ do
xmppClientThread :: UrlRenderer -> NamedThread
xmppClientThread urlrenderer = NamedThread "XMPPClient" $ do
{- All Assistant actions have to be converted into IO actions that
- can be run from within the XMPP monad using liftIO. Ugly. -}
iodebug <- asIO1 debug
iopull <- asIO1 pull
iopairReqReceived <- asIO2 $ pairReqReceived urlrenderer
ioupdatebuddies <- asIO1 $ \p ->
updateBuddyList (updateBuddies p) <<~ buddyList
ioemptybuddies <- asIO $
updateBuddyList (const noBuddies) <<~ buddyList
iorelay <- asIO1 relayNetMessage
ioclientthread <- asIO $
go iorelay iodebug iopull ioupdatebuddies ioemptybuddies
go iorelay iodebug iopull ioupdatebuddies ioemptybuddies iopairReqReceived
restartableClient ioclientthread
where
go iorelay iodebug iopull ioupdatebuddies ioemptybuddies = do
go iorelay iodebug iopull ioupdatebuddies ioemptybuddies iopairReqReceived = do
v <- liftAnnex getXMPPCreds
case v of
Nothing -> noop
@ -75,10 +83,9 @@ xmppClientThread = NamedThread "XMPPClient" $ do
a
receivenotifications fulljid = forever $ do
s <- getStanza
let vs = decodeStanza fulljid s
debug' ["received:", show vs]
mapM_ handle vs
l <- decodeStanza fulljid <$> getStanza
debug' ["received:", show l]
mapM_ handle l
handle (PresenceMessage p) =
void $ liftIO $ ioupdatebuddies p
@ -86,22 +93,28 @@ xmppClientThread = NamedThread "XMPPClient" $ do
putStanza $ gitAnnexPresence gitAnnexSignature
handle (GotNetMessage (NotifyPush us)) =
void $ liftIO $ iopull us
handle (GotNetMessage (PairingNotification stage t u)) = case parseJID t of
Nothing -> noop
Just jid -> error "TODO"
handle (GotNetMessage (PairingNotification stage t u)) =
maybe noop (handlePairing stage u) (parseJID t)
handle (Ignorable _) = noop
handle (Unknown _) = noop
handle (ProtocolError _) = noop
handlePairing PairReq u jid = liftIO $ iopairReqReceived u jid
handlePairing PairAck _ _ = error "TODO"
handlePairing PairDone _ _ = error "TODO"
data XMPPEvent
= GotNetMessage NetMessage
| PresenceMessage Presence
| Ignorable Presence
| Unknown ReceivedStanza
| ProtocolError ReceivedStanza
deriving Show
{- Decodes an XMPP stanza into one or more events. -}
decodeStanza :: JID -> ReceivedStanza -> [XMPPEvent]
decodeStanza fulljid (ReceivedPresence p)
decodeStanza fulljid s@(ReceivedPresence p)
| presenceType p == PresenceError = [ProtocolError s]
| presenceFrom p == Nothing = [Ignorable p]
| presenceFrom p == Just fulljid = [Ignorable p]
| not (null pushed) = impliedp $ GotNetMessage $ NotifyPush pushed
@ -113,7 +126,9 @@ decodeStanza fulljid (ReceivedPresence p)
impliedp v = [PresenceMessage p, v]
pushed = concat $ catMaybes $ map decodePushNotification $
presencePayloads p
decodeStanza _ s@(ReceivedIQ iq) = case decodePairingNotification iq of
decodeStanza _ s@(ReceivedIQ iq)
| iqType iq == IQError = [ProtocolError s]
| otherwise = case decodePairingNotification iq of
Nothing -> [Unknown s]
Just pn -> [GotNetMessage pn]
decodeStanza _ s = [Unknown s]
@ -126,7 +141,9 @@ relayNetMessage fulljid = convert <$> waitNetMessage
convert QueryPresence = putStanza $ presenceQuery
convert (PairingNotification stage t u) = case parseJID t of
Nothing -> noop
Just tojid -> putStanza $ pairingNotification stage u tojid fulljid
Just tojid -> do
liftIO $ print $ pairingNotification stage u tojid fulljid
putStanza $ pairingNotification stage u tojid fulljid
{- Runs the client, handing restart events. -}
restartableClient :: IO () -> Assistant ()
@ -170,3 +187,18 @@ pull us = do
pullone (r:rs) branch =
unlessM (all id . fst <$> manualPull branch [r]) $
pullone rs branch
{- Show an alert when a PairReq is seen, unless the PairReq came from
- another client using our JID. In that case, just start pairing. -}
pairReqReceived :: UrlRenderer -> UUID -> JID -> Assistant ()
pairReqReceived urlrenderer u jid = do
-- TODO: check same JID
let route = FinishXMPPPairR (PairKey u $ formatJID jid)
url <- liftIO $ renderUrl urlrenderer route []
close <- asIO1 removeAlert
void $ addAlert $ pairRequestReceivedAlert (T.unpack $ buddyName jid)
AlertButton
{ buttonUrl = url
, buttonLabel = T.pack "Respond"
, buttonAction = Just close
}

View file

@ -38,11 +38,11 @@ data Buddy
#endif
deriving (Eq, Show)
data BuddyID = BuddyID T.Text
data BuddyKey = BuddyKey T.Text
deriving (Eq, Ord, Show, Read)
data BuddyKey = BuddyKey T.Text
deriving (Eq, Ord, Show)
data PairKey = PairKey UUID T.Text
deriving (Eq, Ord, Show, Read)
type Buddies = M.Map BuddyKey Buddy
@ -60,6 +60,9 @@ newBuddyList = (,)
getBuddyList :: BuddyList -> IO [Buddy]
getBuddyList (v, _) = M.elems <$> atomically (readTMVar v)
getBuddy :: BuddyKey -> BuddyList -> IO (Maybe Buddy)
getBuddy k (v, _) = M.lookup k <$> atomically (readTMVar v)
getBuddyBroadcaster :: BuddyList -> NotificationBroadcaster
getBuddyBroadcaster (_, h) = h

View file

@ -47,6 +47,9 @@ import Data.Char
import qualified Control.Exception as E
import Control.Concurrent
#endif
#ifdef WITH_XMPP
import qualified Data.Set as S
#endif
{- Starts either kind of pairing. -}
getStartPairR :: Handler RepHtml
@ -73,26 +76,35 @@ getStartPairR = noPairing "local or jabber"
{- Starts pairing with an XMPP buddy, or with other clients sharing an
- XMPP account. -}
getStartXMPPPairR :: BuddyID -> Handler RepHtml
getStartXMPPPairR :: BuddyKey -> Handler RepHtml
#ifdef WITH_XMPP
getStartXMPPPairR (BuddyID bid) = case parseJID bid of
Nothing -> error "bad JID"
Just jid -> do
getStartXMPPPairR bid = do
creds <- runAnnex Nothing getXMPPCreds
let ourjid = fromJust $ parseJID =<< xmppJID <$> creds
liftAssistant $ do
buddy <- liftAssistant $ getBuddy bid <<~ buddyList
case S.toList . buddyAssistants <$> buddy of
-- A buddy could have logged out, or the XMPP client restarted;
-- so handle unforseen by going back.
Nothing -> redirect StartPairR
(Just []) -> redirect StartPairR
(Just clients@((Client exemplar):_)) -> do
let samejid = basejid ourjid == basejid exemplar
liftAssistant $ forM_ clients $ \(Client jid) ->
unless (jid == ourjid) $ do
u <- liftAnnex getUUID
sendNetMessage $ PairingNotification
PairReq (formatJID jid) u
pairPage $ do
let samejid = equivjids jid ourjid
let account = formatJID jid
let name = buddyName jid
let account = formatJID $ basejid exemplar
let name = buddyName exemplar
$(widgetFile "configurators/pairing/xmpp/inprogress")
where
equivjids a b = jidNode a == jidNode b && jidDomain a == jidDomain b
basejid j = JID (jidNode j) (jidDomain j) Nothing
#else
getStartXMPPPairR _ = noPairing "XMPP"
getStartXMPPPairR _ = noXMPPPairing
noXMPPPairing :: Handler RepHtml
noXMPPPairing = noPairing "XMPP"
#endif
{- Starts local pairing. -}
@ -125,6 +137,15 @@ getFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
getFinishLocalPairR _ = noLocalPairing
#endif
getFinishXMPPPairR :: PairKey -> Handler RepHtml
#ifdef WITH_XMPP
getFinishXMPPPairR (PairKey u t) = case parseJID t of
Nothing -> error "bad JID"
Just jid -> error "TODO"
#else
getFinishXMPPPairR _ _ = noXMPPPairing
#endif
getRunningLocalPairR :: SecretReminder -> Handler RepHtml
#ifdef WITH_PAIRING
getRunningLocalPairR s = pairPage $ do

View file

@ -90,6 +90,10 @@ instance PathPiece UUID where
toPathPiece = pack . show
fromPathPiece = readish . unpack
instance PathPiece BuddyID where
instance PathPiece BuddyKey where
toPathPiece = pack . show
fromPathPiece = readish . unpack
instance PathPiece PairKey where
toPathPiece = pack . show
fromPathPiece = readish . unpack

View file

@ -30,7 +30,8 @@
/config/repository/pair/local/start StartLocalPairR GET
/config/repository/pair/local/running/#SecretReminder RunningLocalPairR GET
/config/repository/pair/local/finish/#PairMsg FinishLocalPairR GET
/config/repository/pair/xmpp/start/#BuddyID StartXMPPPairR GET
/config/repository/pair/xmpp/start/#BuddyKey StartXMPPPairR GET
/config/repository/pair/xmpp/finish/#PairKey FinishXMPPPairR GET
/config/repository/enable/rsync/#UUID EnableRsyncR GET
/config/repository/enable/directory/#UUID EnableDirectoryR GET

View file

@ -86,24 +86,28 @@ isPresenceQuery p = case filter isGitAnnexTag (presencePayloads p) of
((Element _name attrs _nodes):_) -> any (isAttr queryAttr) attrs
{- A notification about a stage of pairing. Sent as an XMPP ping.
- The pairing info is sent using its id attribute. -}
- The pairing info is sent using its id attribute; it also has a git-annex
- tag to identify it as from us. -}
pairingNotification :: PairStage -> UUID -> JID -> JID -> IQ
pairingNotification pairstage u tojid fromjid = (emptyIQ IQGet)
{ iqTo = Just tojid
, iqFrom = Just fromjid
, iqID = Just $ T.unwords $ map T.pack
[ "git-annex"
, show pairstage
[ show pairstage
, fromUUID u
]
, iqPayload = Just gitAnnexSignature
}
decodePairingNotification :: IQ -> Maybe NetMessage
decodePairingNotification iq = parseid =<< words . T.unpack <$> iqID iq
decodePairingNotification iq@(IQ { iqPayload = Just elt })
| isGitAnnexTag elt = parseid =<< words . T.unpack <$> iqID iq
| otherwise = Nothing
where
parseid ["git-annex", stage, u] =
parseid [stage, u] =
PairingNotification
<$> readish stage
<*> (formatJID <$> iqFrom iq)
<*> pure (toUUID u)
parseid _ = Nothing
decodePairingNotification _ = Nothing

View file

@ -17,9 +17,6 @@ import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
genBuddyID :: JID -> BuddyID
genBuddyID j = BuddyID $ formatJID j
genKey :: JID -> BuddyKey
genKey j = BuddyKey $ formatJID $ JID (jidNode j) (jidDomain j) Nothing
@ -29,9 +26,9 @@ buddyName j = maybe (T.pack "") strNode (jidNode j)
{- Summary of info about a buddy.
-
- If the buddy has no clients at all anymore, returns Nothing. -}
buddySummary :: Buddy -> Maybe (Text, Bool, Bool, BuddyID)
buddySummary :: Buddy -> Maybe (Text, Bool, Bool, BuddyKey)
buddySummary b = case clients of
((Client j):_) -> Just (buddyName j, away, canpair, genBuddyID j)
((Client j):_) -> Just (buddyName j, away, canpair, genKey j)
[] -> Nothing
where
away = S.null (buddyPresent b) && S.null (buddyAssistants b)

View file

@ -14,3 +14,6 @@
<p>
You do not need to leave this page open; pairing will finish #
automatically once #{name} accepts the pair request.
<p>
<a .btn .btn-primary .btn-small href="">
Re-Send pair request