summaryrefslogtreecommitdiff
path: root/Assistant
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-11-05 17:43:17 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-11-05 17:43:17 -0400
commita4667e3e8cb7fae50b0c2cb8bc1a46df0b289b6c (patch)
tree9f75d066b025e99f7015818ccbe143d70b5bbae7 /Assistant
parentdedc9790ef60b0965c0c34acd080ef8d4906e07a (diff)
finished XMPP pairing!
This includes keeping track of which buddies we're pairing with, to know which PairAck are legitimate.
Diffstat (limited to 'Assistant')
-rw-r--r--Assistant/Alert.hs2
-rw-r--r--Assistant/Pairing/MakeRemote.hs8
-rw-r--r--Assistant/Threads/PairListener.hs4
-rw-r--r--Assistant/Threads/XMPPClient.hs102
-rw-r--r--Assistant/Types/Buddies.hs1
-rw-r--r--Assistant/XMPP/Buddies.hs9
-rw-r--r--Assistant/XMPP/Git.hs49
7 files changed, 127 insertions, 48 deletions
diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs
index 8d9455e66..9e36ea693 100644
--- a/Assistant/Alert.hs
+++ b/Assistant/Alert.hs
@@ -317,7 +317,7 @@ pairRequestReceivedAlert who button = Alert
pairRequestAcknowledgedAlert :: String -> Maybe AlertButton -> Alert
pairRequestAcknowledgedAlert who button = baseActivityAlert
- { alertData = ["Pair request with", UnTensed (T.pack who), Tensed "in progress" "complete"]
+ { alertData = ["Pairing with", UnTensed (T.pack who), Tensed "in progress" "complete"]
, alertPriority = High
, alertCombiner = Just $ dataCombiner $ \_old new -> new
, alertButton = button
diff --git a/Assistant/Pairing/MakeRemote.hs b/Assistant/Pairing/MakeRemote.hs
index dd15015a0..38f9981e5 100644
--- a/Assistant/Pairing/MakeRemote.hs
+++ b/Assistant/Pairing/MakeRemote.hs
@@ -26,10 +26,10 @@ setupAuthorizedKeys msg repodir = do
where
pubkey = remoteSshPubKey $ pairMsgData msg
-{- When pairing is complete, this is used to set up the remote for the host
- - we paired with. -}
-finishedPairing :: PairMsg -> SshKeyPair -> Assistant ()
-finishedPairing msg keypair = do
+{- When local pairing is complete, this is used to set up the remote for
+ - the host we paired with. -}
+finishedLocalPairing :: PairMsg -> SshKeyPair -> Assistant ()
+finishedLocalPairing msg keypair = do
sshdata <- liftIO $ setupSshKeyPair keypair =<< pairMsgToSshData msg
{- Ensure that we know the ssh host key for the host we paired with.
- If we don't, ssh over to get it. -}
diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs
index c169aa255..44b35a9c3 100644
--- a/Assistant/Threads/PairListener.hs
+++ b/Assistant/Threads/PairListener.hs
@@ -123,7 +123,7 @@ pairAckReceived True (Just pip) msg cache = do
stopSending pip
repodir <- repoPath <$> liftAnnex gitRepo
liftIO $ setupAuthorizedKeys msg repodir
- finishedPairing msg (inProgressSshKeyPair pip)
+ finishedLocalPairing msg (inProgressSshKeyPair pip)
startSending pip PairDone $ multicastPairMsg
(Just 1) (inProgressSecret pip) (inProgressPairData pip)
return $ pip : take 10 cache
@@ -153,4 +153,4 @@ pairDoneReceived False _ _ = noop -- not verified
pairDoneReceived True Nothing _ = noop -- not in progress
pairDoneReceived True (Just pip) msg = do
stopSending pip
- finishedPairing msg (inProgressSshKeyPair pip)
+ finishedLocalPairing msg (inProgressSshKeyPair pip)
diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs
index 1b3f2bdef..3ef701851 100644
--- a/Assistant/Threads/XMPPClient.hs
+++ b/Assistant/Threads/XMPPClient.hs
@@ -22,11 +22,14 @@ import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.Alert
import Assistant.Pairing
+import Assistant.XMPP.Git
+import Annex.UUID
import Network.Protocol.XMPP
import Control.Concurrent
import qualified Data.Text as T
import qualified Data.Set as S
+import qualified Data.Map as M
import qualified Git.Branch
import Data.Time.Clock
@@ -36,17 +39,17 @@ xmppClientThread urlrenderer = NamedThread "XMPPClient" $ do
- can be run from within the XMPP monad using liftIO. Ugly. -}
iodebug <- asIO1 debug
iopull <- asIO1 pull
- iopairReqReceived <- asIO2 $ pairReqReceived urlrenderer
+ iopairMsgReceived <- asIO2 $ pairMsgReceived 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 iopairReqReceived
+ go iorelay iodebug iopull ioupdatebuddies ioemptybuddies iopairMsgReceived
restartableClient ioclientthread
where
- go iorelay iodebug iopull ioupdatebuddies ioemptybuddies iopairReqReceived = do
+ go iorelay iodebug iopull ioupdatebuddies ioemptybuddies iopairMsgReceived = do
v <- liftAnnex getXMPPCreds
case v of
Nothing -> noop
@@ -85,23 +88,19 @@ xmppClientThread urlrenderer = NamedThread "XMPPClient" $ do
receivenotifications selfjid = forever $ do
l <- decodeStanza selfjid <$> getStanza
debug' ["received:", show l]
- mapM_ handle l
+ mapM_ (handle selfjid) l
- handle (PresenceMessage p) =
+ handle _ (PresenceMessage p) =
void $ liftIO $ ioupdatebuddies p
- handle (GotNetMessage QueryPresence) =
+ handle _ (GotNetMessage QueryPresence) =
putStanza gitAnnexSignature
- handle (GotNetMessage (NotifyPush us)) =
+ handle _ (GotNetMessage (NotifyPush us)) =
void $ liftIO $ iopull us
- 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"
+ handle selfjid (GotNetMessage (PairingNotification stage t u)) =
+ maybe noop (\jid -> liftIO $ iopairMsgReceived (stage, u) (selfjid, jid)) (parseJID t)
+ handle _ (Ignorable _) = noop
+ handle _ (Unknown _) = noop
+ handle _ (ProtocolError _) = noop
data XMPPEvent
= GotNetMessage NetMessage
@@ -139,16 +138,18 @@ decodeStanza _ s = [Unknown s]
{- Waits for a NetMessager message to be sent, and relays it to XMPP. -}
relayNetMessage :: JID -> Assistant (XMPP ())
-relayNetMessage selfjid = convert <$> waitNetMessage
+relayNetMessage selfjid = convert =<< waitNetMessage
where
- convert (NotifyPush us) = putStanza $ pushNotification us
- convert QueryPresence = putStanza $ presenceQuery
+ convert (NotifyPush us) = return $ putStanza $ pushNotification us
+ convert QueryPresence = return $ putStanza $ presenceQuery
convert (PairingNotification stage t u) = case parseJID t of
- Nothing -> noop
+ Nothing -> return $ noop
Just tojid
- | tojid == selfjid -> noop
- | otherwise -> putStanza $
- pairingNotification stage u tojid selfjid
+ | tojid == selfjid -> return $ noop
+ | otherwise -> do
+ changeBuddyPairing tojid True
+ return $ putStanza $
+ pairingNotification stage u tojid selfjid
{- Runs the client, handing restart events. -}
restartableClient :: IO () -> Assistant ()
@@ -193,17 +194,44 @@ pull us = do
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
- }
+pairMsgReceived :: UrlRenderer -> (PairStage, UUID) -> (JID, JID) -> Assistant ()
+pairMsgReceived urlrenderer (PairReq, theiruuid) (selfjid, theirjid)
+ -- PairReq from another client using our JID is automatically accepted.
+ | baseJID selfjid == baseJID theirjid = do
+ selfuuid <- liftAnnex getUUID
+ sendNetMessage $
+ PairingNotification PairAck (formatJID theirjid) selfuuid
+ finishXMPPPairing theirjid theiruuid
+ -- Show an alert to let the user decide if they want to pair.
+ | otherwise = do
+ let route = FinishXMPPPairR (PairKey theiruuid $ formatJID theirjid)
+ url <- liftIO $ renderUrl urlrenderer route []
+ close <- asIO1 removeAlert
+ void $ addAlert $ pairRequestReceivedAlert (T.unpack $ buddyName theirjid)
+ AlertButton
+ { buttonUrl = url
+ , buttonLabel = T.pack "Respond"
+ , buttonAction = Just close
+ }
+pairMsgReceived _ (PairAck, theiruuid) (_selfjid, theirjid) =
+ {- PairAck must come from one of the buddies we are pairing with;
+ - don't pair with just anyone. -}
+ whenM (isBuddyPairing theirjid) $ do
+ changeBuddyPairing theirjid False
+ selfuuid <- liftAnnex getUUID
+ sendNetMessage $
+ PairingNotification PairDone (formatJID theirjid) selfuuid
+ finishXMPPPairing theirjid theiruuid
+pairMsgReceived _ (PairDone, _theiruuid) (_selfjid, theirjid) =
+ changeBuddyPairing theirjid False
+
+isBuddyPairing :: JID -> Assistant Bool
+isBuddyPairing jid = maybe False buddyPairing <$>
+ getBuddy (genBuddyKey jid) <<~ buddyList
+
+changeBuddyPairing :: JID -> Bool -> Assistant ()
+changeBuddyPairing jid ispairing =
+ updateBuddyList (M.adjust set key) <<~ buddyList
+ where
+ key = genBuddyKey jid
+ set b = b { buddyPairing = ispairing }
diff --git a/Assistant/Types/Buddies.hs b/Assistant/Types/Buddies.hs
index 8ebd7db7a..36d8a4fed 100644
--- a/Assistant/Types/Buddies.hs
+++ b/Assistant/Types/Buddies.hs
@@ -32,6 +32,7 @@ data Buddy = Buddy
{ buddyPresent :: S.Set Client
, buddyAway :: S.Set Client
, buddyAssistants :: S.Set Client
+ , buddyPairing :: Bool
}
#else
data Buddy = Buddy
diff --git a/Assistant/XMPP/Buddies.hs b/Assistant/XMPP/Buddies.hs
index fe5d8c6a9..fdc307972 100644
--- a/Assistant/XMPP/Buddies.hs
+++ b/Assistant/XMPP/Buddies.hs
@@ -17,8 +17,8 @@ import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
-genKey :: JID -> BuddyKey
-genKey j = BuddyKey $ formatJID $ baseJID j
+genBuddyKey :: JID -> BuddyKey
+genBuddyKey j = BuddyKey $ formatJID $ baseJID j
buddyName :: JID -> Text
buddyName j = maybe (T.pack "") strNode (jidNode j)
@@ -28,7 +28,7 @@ buddyName j = maybe (T.pack "") strNode (jidNode j)
- If the buddy has no clients at all anymore, returns Nothing. -}
buddySummary :: Buddy -> Maybe (Text, Bool, Bool, BuddyKey)
buddySummary b = case clients of
- ((Client j):_) -> Just (buddyName j, away, canpair, genKey j)
+ ((Client j):_) -> Just (buddyName j, away, canpair, genBuddyKey j)
[] -> Nothing
where
away = S.null (buddyPresent b) && S.null (buddyAssistants b)
@@ -39,7 +39,7 @@ buddySummary b = case clients of
updateBuddies :: Presence -> Buddies -> Buddies
updateBuddies p@(Presence { presenceFrom = Just jid }) = M.alter update key
where
- key = genKey jid
+ key = genBuddyKey jid
update (Just b) = Just $ applyPresence p b
update Nothing = newBuddy p
updateBuddies _ = id
@@ -56,6 +56,7 @@ newBuddy p
{ buddyPresent = S.empty
, buddyAway = S.empty
, buddyAssistants = S.empty
+ , buddyPairing = False
}
applyPresence :: Presence -> Buddy -> Buddy
diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs
new file mode 100644
index 000000000..154cbc86d
--- /dev/null
+++ b/Assistant/XMPP/Git.hs
@@ -0,0 +1,49 @@
+{- git over XMPP
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.XMPP.Git where
+
+import Assistant.Common
+import Assistant.XMPP
+import Assistant.XMPP.Buddies
+import Assistant.DaemonStatus
+import Assistant.Alert
+import Assistant.MakeRemote
+import Assistant.Sync
+import Annex.UUID
+import Config
+import qualified Types.Remote as Remote
+
+import Network.Protocol.XMPP
+import qualified Data.Text as T
+
+finishXMPPPairing :: JID -> UUID -> Assistant ()
+finishXMPPPairing jid u = void $ alertWhile alert $
+ makeXMPPGitRemote buddy (baseJID jid) u
+ where
+ buddy = T.unpack $ buddyName jid
+ alert = pairRequestAcknowledgedAlert buddy Nothing
+
+{- A git remote for an XMPP user? This is represented as a git remote
+ - that has no location set. The user's XMPP address is stored in the
+ - xmppaddress setting.
+ -
+ - The UUID of their remote is also stored as usual.
+ -}
+makeXMPPGitRemote :: String -> JID -> UUID -> Assistant Bool
+makeXMPPGitRemote buddyname jid u = do
+ remote <- liftAnnex $ addRemote $ makeGitRemote buddyname "" -- no location
+ liftAnnex $ do
+ let r = Remote.repo remote
+ storeUUID (remoteConfig r "uuid") u
+ setConfig (remoteConfig r "xmppaddress") xmppaddress
+ syncNewRemote remote
+ return True
+ where
+ xmppaddress = T.unpack $ formatJID $ baseJID jid
+
+