From 36c938e244dc9c28b1f322d348a83ddd24da0587 Mon Sep 17 00:00:00 2001
From: Christopher Vollick <0@psycoti.ca>
Date: Thu, 7 Jan 2021 16:44:33 -0500
Subject: [PATCH] Terminate Jingle Sessions After Transfer

The spec for Jingle claims either side can terminate the session, but suggests
that the receiver should, since it knows when it's received things.

The current code expects the sender to do it, and Conversations expects the
receiver to do it, leading to both sides waiting for the other to do something.

So to fix that, Cheogram needs to send a session terminate once the upload is
complete!

At some point this logic, and the optional "received" that's already there,
should live inside the Jingle library, since they're related to the Jingle
session which this code otherwise knows nothing about.

But that day is not today! Today I just want to see this work, and make sure it
doesn't break anything else. Then we can figure out how to move it inside.

Once I had three things there, I put them in do-notation since I felt that was
clearer than what was there, with the ">>) $" thing.
I also considered putting them all in a sub-notation, since they're all being
lifted right now, but decided that would make it harder later, since I'm
planning on pulling this stuff out into the library at some point.
So no need to make things _too_ clean! Gotta feel the hurt!
---
 Main.hs | 25 ++++++++++++++++++++-----
 1 file changed, 20 insertions(+), 5 deletions(-)

diff --git a/Main.hs b/Main.hs
index 6634c29..fb8491c 100644
--- a/Main.hs
+++ b/Main.hs
@@ -2006,9 +2006,9 @@ main = do
 			jingleHandler <- UIO.runEitherIO $ Jingle.setupJingleHandlers jingleStore s5bListenOn (fromString s5bhost, s5bport)
 				(log "JINGLE")
 				(\iq@(IQ { iqPayload = Just jingle }) path ->
-					forM_ (isNamed (s"{urn:xmpp:jingle:1}content") =<< elementChildren jingle) $ \content ->
-					let fileDesc = mfilter (/=mempty) $ fmap (mconcat . elementText) $ headZ (isNamed (s"{urn:xmpp:jingle:apps:file-transfer:5}desc") =<< elementChildren =<< isNamed (s"{urn:xmpp:jingle:apps:file-transfer:5}file") =<< elementChildren =<< isNamed (s"{urn:xmpp:jingle:apps:file-transfer:5}description") =<< elementChildren content) in
-					(fromIO_ (mapM_ (atomically . writeTChan sendToComponent) =<< componentStanza db (mapToBackend backendHost =<< stanzaTo iq) [registrationJid] (writeTChan adhocBotMessages) toRoomPresences toRejoinManager toJoinPartDebouncer processDirectMessageRouteConfig componentJid (
+					forM_ (isNamed (s"{urn:xmpp:jingle:1}content") =<< elementChildren jingle) $ \content -> do
+					let fileDesc = mfilter (/=mempty) $ fmap (mconcat . elementText) $ headZ (isNamed (s"{urn:xmpp:jingle:apps:file-transfer:5}desc") =<< elementChildren =<< isNamed (s"{urn:xmpp:jingle:apps:file-transfer:5}file") =<< elementChildren =<< isNamed (s"{urn:xmpp:jingle:apps:file-transfer:5}description") =<< elementChildren content)
+					fromIO_ (mapM_ (atomically . writeTChan sendToComponent) =<< componentStanza db (mapToBackend backendHost =<< stanzaTo iq) [registrationJid] (writeTChan adhocBotMessages) toRoomPresences toRejoinManager toJoinPartDebouncer processDirectMessageRouteConfig componentJid (
 						let url = jingleStoreURL ++ (T.takeWhileEnd (/='/') $ fromString path) in
 						ReceivedMessage $ (emptyMessage MessageNormal) {
 							messageFrom = iqFrom iq,
@@ -2020,7 +2020,7 @@ main = do
 								] ++ (maybe [] (\desc -> pure $ NodeElement $ Element (s"{jabber:x:oob}desc") [] [NodeContent $ ContentText desc]) fileDesc))
 							]
 						}
-					)) >>) $ -- TODO: need to end session for Conversations
+						))
 					fromIO_ $ atomically $ writeTChan sendToComponent $ mkStanzaRec $ (emptyIQ IQSet) {
 						iqTo = iqFrom iq,
 						iqFrom = iqTo iq,
@@ -2031,7 +2031,22 @@ main = do
 								NodeElement $ Element (s"{urn:xmpp:jingle:apps:file-transfer:5}received")
 								[(s"creator", fromMaybe [] $ attributeContent (s"creator") content), (s"name", fromMaybe [] $ attributeContent (s"name") content)] []
 							]
-					}
+						}
+					fromIO_ $ atomically $ writeTChan sendToComponent $ mkStanzaRec $ (emptyIQ IQSet) {
+						iqTo = iqFrom iq,
+						iqFrom = iqTo iq,
+						iqID = Just $ s"id-session-terminate",
+						iqPayload = Just $ Element
+							(s"{urn:xmpp:jingle:1}jingle")
+							[(s"action", [s"session-terminate"]), (s"sid", [ContentText $ fromMaybe mempty $ attributeText (s"sid") jingle])]
+							[
+								NodeElement $ Element (s"{urn:xmpp:jingle:1}reason")
+								[]
+								[
+									NodeElement $ Element (s"{urn:xmpp:jingle:1}success") [] []
+								]
+							]
+						}
 				)
 
 			forever $ do
-- 
2.34.5