Forward instant messages from XMPP clients to Tox peers.

1 files changed, 67 insertions, 0 deletions

diff --git a/XMPPToTox.hs b/XMPPToTox.hs
new file mode 100644
index 00000000..7ca4330e
--- /dev/null
+++ b/XMPPToTox.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+module XMPPToTox
+    ( module XMPPToTox
+    , CryptoMessage(..)
+    , MessageID(..)
+    ) where
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Catch
+import Data.Conduit
+import Data.Function
+import Data.Monoid
+import Data.Text                    (Text)
+import Data.Text.Encoding           as T
+import Data.XML.Types               as XML
+import Network.Tox.Crypto.Transport (CryptoMessage (..), MessageID (..))
+import Text.XML.Stream.Parse        as XML
+
+-- Debugging.  Not real Tox message.
+funnyMessage :: MonadThrow m => Text -> ConduitM i CryptoMessage m ()
+funnyMessage txt = yield $ UpToN Padding (T.encodeUtf8 txt)
+
+sendMsg :: MonadThrow m => Text -> ConduitM i CryptoMessage m ()
+sendMsg txt = yield $ UpToN MESSAGE (T.encodeUtf8 txt)
+
+
+eom :: MonadThrow m => ConduitM Event o m ()
+eom = many_ ignoreAnyTreeContent
+
+msgToTox :: MonadThrow m =>
+                  ConduitM Event CryptoMessage m (Maybe ())
+msgToTox = tag' "{jabber:server}message"
+                (requireAttr "type" >>= \case
+                    "chat" -> ignoreAttrs
+                    _      -> empty)
+ $ \_ -> many_ $ choose
+    [ tagIgnoreAttrs "{jabber:server}body"
+       $ do content >>= sendMsg
+            eom
+    , tagIgnoreAttrs "{http://jabber.org/protocol/chatstates}composing"
+       $ do yield $ TwoByte TYPING 1
+            eom
+    , tagIgnoreAttrs "{http://jabber.org/protocol/chatstates}paused"
+       $ do yield $ TwoByte TYPING 0
+            eom
+    , ignoreAnyTreeContent
+    ]
+
+unknownToTox :: MonadThrow m =>
+                      ConduitM Event CryptoMessage m (Maybe ())
+unknownToTox = tag anyName (\n -> ignoreAttrs >> return n) $ \n -> do
+    funnyMessage $ nameLocalName n
+    eom
+
+
+xmppToTox :: MonadThrow m => Conduit XML.Event m CryptoMessage
+xmppToTox = do
+    eventBeginDocument <- await
+    streamTag <- await
+    fix $ \loop -> do
+        got <- choose
+            [ msgToTox
+            , unknownToTox
+            ]
+        forM_ got $ \_ -> loop