204 lines
6.8 KiB
Haskell
204 lines
6.8 KiB
Haskell
{- git-annex XMPP client
|
||
-
|
||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||
-
|
||
- Licensed under the GNU GPL version 3 or higher.
|
||
-}
|
||
|
||
module Assistant.Threads.XMPPClient where
|
||
|
||
import Assistant.Common
|
||
import Assistant.XMPP
|
||
import Assistant.XMPP.Client
|
||
import Assistant.NetMessager
|
||
import Assistant.Types.NetMessager
|
||
import Assistant.Types.Buddies
|
||
import Assistant.XMPP.Buddies
|
||
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 :: 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 iopairReqReceived
|
||
restartableClient ioclientthread
|
||
where
|
||
go iorelay iodebug iopull ioupdatebuddies ioemptybuddies iopairReqReceived = do
|
||
v <- liftAnnex getXMPPCreds
|
||
case v of
|
||
Nothing -> noop
|
||
Just c -> liftIO $ loop c =<< getCurrentTime
|
||
where
|
||
debug' = void . liftIO . iodebug
|
||
|
||
{- When the client exits, it's restarted;
|
||
- if it keeps failing, back off to wait 5 minutes before
|
||
- trying it again. -}
|
||
loop c starttime = do
|
||
runclient c
|
||
now <- getCurrentTime
|
||
if diffUTCTime now starttime > 300
|
||
then do
|
||
void $ iodebug ["connection lost; reconnecting"]
|
||
loop c now
|
||
else do
|
||
void $ iodebug ["connection failed; will retry"]
|
||
threadDelaySeconds (Seconds 300)
|
||
loop c =<< getCurrentTime
|
||
|
||
runclient c = void $ connectXMPP c $ \jid -> do
|
||
fulljid <- bindJID jid
|
||
debug' ["connected", show fulljid]
|
||
{- The buddy list starts empty each time
|
||
- the client connects, so that stale info
|
||
- is not retained. -}
|
||
void $ liftIO ioemptybuddies
|
||
putStanza $ gitAnnexPresence gitAnnexSignature
|
||
xmppThread $ receivenotifications fulljid
|
||
forever $ do
|
||
a <- liftIO $ iorelay fulljid
|
||
a
|
||
|
||
receivenotifications fulljid = forever $ do
|
||
l <- decodeStanza fulljid <$> getStanza
|
||
debug' ["received:", show l]
|
||
mapM_ handle l
|
||
|
||
handle (PresenceMessage p) =
|
||
void $ liftIO $ ioupdatebuddies p
|
||
handle (GotNetMessage QueryPresence) =
|
||
putStanza $ gitAnnexPresence gitAnnexSignature
|
||
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"
|
||
|
||
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 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
|
||
| isPresenceQuery p = impliedp $ GotNetMessage QueryPresence
|
||
| otherwise = [PresenceMessage p]
|
||
where
|
||
-- Some things are sent via presence, so imply a presence message,
|
||
-- along with their real value.
|
||
impliedp v = [PresenceMessage p, v]
|
||
pushed = concat $ catMaybes $ map decodePushNotification $
|
||
presencePayloads p
|
||
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]
|
||
|
||
{- Waits for a NetMessager message to be sent, and relays it to XMPP. -}
|
||
relayNetMessage :: JID -> Assistant (XMPP ())
|
||
relayNetMessage fulljid = convert <$> waitNetMessage
|
||
where
|
||
convert (NotifyPush us) = putStanza $ pushNotification us
|
||
convert QueryPresence = putStanza $ presenceQuery
|
||
convert (PairingNotification stage t u) = case parseJID t of
|
||
Nothing -> noop
|
||
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 ()
|
||
restartableClient a = forever $ do
|
||
tid <- liftIO $ forkIO a
|
||
waitNetMessagerRestart
|
||
liftIO $ killThread tid
|
||
|
||
{- Runs a XMPP action in a separate thread, using a session to allow it
|
||
- to access the same XMPP client. -}
|
||
xmppThread :: XMPP () -> XMPP ()
|
||
xmppThread a = do
|
||
s <- getSession
|
||
void $ liftIO $ forkIO $
|
||
void $ runXMPP s a
|
||
|
||
{- We only pull from one remote out of the set listed in the push
|
||
- notification, as an optimisation.
|
||
-
|
||
- Note that it might be possible (though very unlikely) for the push
|
||
- notification to take a while to be sent, and multiple pushes happen
|
||
- before it is sent, so it includes multiple remotes that were pushed
|
||
- to at different times.
|
||
-
|
||
- It could then be the case that the remote we choose had the earlier
|
||
- push sent to it, but then failed to get the later push, and so is not
|
||
- fully up-to-date. If that happens, the pushRetryThread will come along
|
||
- and retry the push, and we'll get another notification once it succeeds,
|
||
- and pull again. -}
|
||
pull :: [UUID] -> Assistant ()
|
||
pull [] = noop
|
||
pull us = do
|
||
rs <- filter matching . syncRemotes <$> getDaemonStatus
|
||
debug $ "push notification for" : map (fromUUID . Remote.uuid ) rs
|
||
pullone rs =<< liftAnnex (inRepo Git.Branch.current)
|
||
where
|
||
matching r = Remote.uuid r `S.member` s
|
||
s = S.fromList us
|
||
|
||
pullone [] _ = noop
|
||
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
|
||
}
|