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
|
void $ connectXMPP c $ \jid -> do
|
||||||
fulljid <- bindJID jid
|
fulljid <- bindJID jid
|
||||||
liftIO $ debug thisThread ["XMPP connected", show fulljid]
|
liftIO $ debug thisThread ["XMPP connected", show fulljid]
|
||||||
|
putStanza $ gitAnnexPresence gitAnnexSignature
|
||||||
s <- getSession
|
s <- getSession
|
||||||
_ <- liftIO $ forkIO $ void $ runXMPP s $
|
_ <- liftIO $ forkIO $ void $ runXMPP s $
|
||||||
receivenotifications
|
receivenotifications
|
||||||
|
@ -62,10 +63,7 @@ pushNotifierThread st dstatus pushnotifier = NamedThread thisThread $
|
||||||
|
|
||||||
sendnotifications = forever $ do
|
sendnotifications = forever $ do
|
||||||
us <- liftIO $ waitPush pushnotifier
|
us <- liftIO $ waitPush pushnotifier
|
||||||
let payload = [extendedAway, encodePushNotification us]
|
putStanza $ gitAnnexPresence $ encodePushNotification us
|
||||||
let notification = (emptyPresence PresenceAvailable)
|
|
||||||
{ presencePayloads = payload }
|
|
||||||
putStanza notification
|
|
||||||
|
|
||||||
receivenotifications = forever $ do
|
receivenotifications = forever $ do
|
||||||
s <- getStanza
|
s <- getStanza
|
||||||
|
|
|
@ -84,16 +84,23 @@ xmppCredsFile = do
|
||||||
dir <- fromRepo gitAnnexCredsDir
|
dir <- fromRepo gitAnnexCredsDir
|
||||||
return $ dir </> "notify-xmpp"
|
return $ dir </> "notify-xmpp"
|
||||||
|
|
||||||
{- Marks the client as extended away. -}
|
{- A presence with a git-annex tag in it. -}
|
||||||
extendedAway :: Element
|
gitAnnexPresence :: Element -> Presence
|
||||||
extendedAway = Element (Name (T.pack "show") Nothing Nothing) []
|
gitAnnexPresence tag = (emptyPresence PresenceAvailable)
|
||||||
[NodeContent $ ContentText $ T.pack "xa"]
|
{ 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.
|
{- Name of a git-annex tag, in our own XML namespace.
|
||||||
- (Not using a namespace URL to avoid unnecessary bloat.) -}
|
- (Not using a namespace URL to avoid unnecessary bloat.) -}
|
||||||
gitAnnexTagName :: Name
|
gitAnnexTagName :: Name
|
||||||
gitAnnexTagName = Name (T.pack "git-annex") (Just $ T.pack "git-annex") Nothing
|
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
|
||||||
pushAttr = Name (T.pack "push") Nothing Nothing
|
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,
|
* Prevent idle disconnection. Probably means sending or receiving pings,
|
||||||
but would prefer to avoid eg pinging every 60 seconds as some clients do.
|
but would prefer to avoid eg pinging every 60 seconds as some clients do.
|
||||||
* XMPP pairing
|
* XMPP pairing
|
||||||
|
* git pushes over XMPP (needed for pairing, but also awesome on their own)
|
||||||
|
|
||||||
## design goals
|
## design goals
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue