send git-annex tag in initial presence
Will be used for finding other git-annex clients for pairing
This commit is contained in:
parent
e7df22916d
commit
64e1d7b579
3 changed files with 14 additions and 8 deletions
|
@ -46,6 +46,7 @@ pushNotifierThread st dstatus pushnotifier = NamedThread thisThread $
|
|||
void $ connectXMPP c $ \jid -> do
|
||||
fulljid <- bindJID jid
|
||||
liftIO $ debug thisThread ["XMPP connected", show fulljid]
|
||||
putStanza $ gitAnnexPresence gitAnnexSignature
|
||||
s <- getSession
|
||||
_ <- liftIO $ forkIO $ void $ runXMPP s $
|
||||
receivenotifications
|
||||
|
@ -62,10 +63,7 @@ pushNotifierThread st dstatus pushnotifier = NamedThread thisThread $
|
|||
|
||||
sendnotifications = forever $ do
|
||||
us <- liftIO $ waitPush pushnotifier
|
||||
let payload = [extendedAway, encodePushNotification us]
|
||||
let notification = (emptyPresence PresenceAvailable)
|
||||
{ presencePayloads = payload }
|
||||
putStanza notification
|
||||
putStanza $ gitAnnexPresence $ encodePushNotification us
|
||||
|
||||
receivenotifications = forever $ do
|
||||
s <- getStanza
|
||||
|
|
|
@ -84,16 +84,23 @@ xmppCredsFile = do
|
|||
dir <- fromRepo gitAnnexCredsDir
|
||||
return $ dir </> "notify-xmpp"
|
||||
|
||||
{- Marks the client as extended away. -}
|
||||
extendedAway :: Element
|
||||
extendedAway = Element (Name (T.pack "show") Nothing Nothing) []
|
||||
[NodeContent $ ContentText $ T.pack "xa"]
|
||||
{- A presence with a git-annex tag in it. -}
|
||||
gitAnnexPresence :: Element -> Presence
|
||||
gitAnnexPresence tag = (emptyPresence PresenceAvailable)
|
||||
{ presencePayloads = [extendedAway, tag] }
|
||||
where
|
||||
extendedAway = Element (Name (T.pack "show") Nothing Nothing) []
|
||||
[NodeContent $ ContentText $ T.pack "xa"]
|
||||
|
||||
{- Name of a git-annex tag, in our own XML namespace.
|
||||
- (Not using a namespace URL to avoid unnecessary bloat.) -}
|
||||
gitAnnexTagName :: Name
|
||||
gitAnnexTagName = Name (T.pack "git-annex") (Just $ T.pack "git-annex") Nothing
|
||||
|
||||
{- A git-annex tag, to let other clients know we're a git-annex client too. -}
|
||||
gitAnnexSignature :: Element
|
||||
gitAnnexSignature = Element gitAnnexTagName [] []
|
||||
|
||||
pushAttr :: Name
|
||||
pushAttr = Name (T.pack "push") Nothing Nothing
|
||||
|
||||
|
|
|
@ -7,6 +7,7 @@ who share a repository, that is stored in the [[cloud]].
|
|||
* Prevent idle disconnection. Probably means sending or receiving pings,
|
||||
but would prefer to avoid eg pinging every 60 seconds as some clients do.
|
||||
* XMPP pairing
|
||||
* git pushes over XMPP (needed for pairing, but also awesome on their own)
|
||||
|
||||
## design goals
|
||||
|
||||
|
|
Loading…
Reference in a new issue