7 files changed, 213 insertions, 42 deletions

diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index e8a69066..53de4e93 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -85,6 +85,11 @@ data ToxManager k = ToxManager
       -- their public key (in hostname format) and the Policy to set for this
       -- link.
     , setToxConnectionPolicy :: Text -> Text -> Connection.Policy -> IO ()
+      -- | Given a remote Tox key, return the address of a connected peer.
+      --
+      -- The arguments are our public key (in base64 format) followed by
+      -- their public key (in base64 format).
+    , resolveToxPeer         :: Text -> Text -> IO (Maybe PeerAddress)
     }
 
 data PresenceState = forall status. PresenceState
@@ -577,10 +582,25 @@ deliverMessage state fail msg =
     case stanzaOrigin msg of
       ClientOrigin senderk _ -> do
         -- Case 1.  Client -> Peer
-        mto <- fmap join $ mapM rewriteJIDForPeer (stanzaTo msg)
-        fromMaybe fail {- reverse lookup failure -} $ mto <&> \(to',k) -> do
+        mto <- join $ atomically $ do
+            mclient <- Map.lookup senderk <$> readTVar (clients state)
+            return
+              $ fromMaybe -- Resolve XMPP peer.
+                          (fmap join $ mapM rewriteJIDForPeer (stanzaTo msg))
+                $ do (mu,h,rsc) <- splitJID <$> stanzaTo msg
+                     u <- mu
+                     client <- mclient
+                     (toxman,me,them) <- weAreTox state client h
+                     return -- Resolve Tox peer.
+                            $ do maddr <- resolveToxPeer toxman me them
+                                 return $ fmap (u,) maddr
+        fromMaybe (do dput XJabber $ "Unable to resolve "++show (stanzaTo msg)
+                      fail {- reverse lookup failure -})
+                $ mto <&> \(to',k) -> do
         chans <- atomically $ readTVar (pkeyToChan state)
-        fromMaybe fail $ (Map.lookup k chans) <&> \conn -> do
+        fromMaybe (do dput XJabber $ "Peer unavailable: "++ show k
+                      fail)
+                $ (Map.lookup k chans) <&> \conn -> do
         -- original 'from' address is discarded.
         from' <- forClient state senderk (return Nothing)
                         $ return . Just . clientJID conn
@@ -592,12 +612,18 @@ deliverMessage state fail msg =
             pc <- readTVar (pkeyToChan state)
             cc <- readTVar (ckeyToChan state)
             return (pc,cc)
-        fromMaybe fail $ (Map.lookup senderk pchans)
+        fromMaybe (do dput XJabber $ "Unknown peer " ++ show senderk
+                      fail)
+                $ Map.lookup senderk pchans
             <&> \(Conn { connChan = sender_chan
                        , auxData  = ConnectionData (Left laddr) ctyp cprof }) -> do
-        fromMaybe fail $ (stanzaTo msg) <&> \to -> do
+        fromMaybe (do dput XJabber $ "Message missing \"to\" attribute."
+                      fail)
+                $ (stanzaTo msg) <&> \to -> do
         (mine,(n,h,r)) <- rewriteJIDForClient laddr to []
-        if not mine then fail else do
+        if not mine then do dput XJabber $ "Address mis-match " ++ show (laddr,to)
+                            fail
+                    else do
         let to' = unsplitJID (n,h,r)
         let (cmapVar,ckey) = case ctyp of
                 Tox  -> (clientsByProfile state , Just cprof )
@@ -1024,14 +1050,18 @@ clientSubscriptionRequest state fail k stanza chan = do
                                           , stanzaFrom = Just from })
                                      (connChan con)
         let policySetter = fromMaybe (Connection.setPolicy conns h) $ do
-                toxman <- toxManager state
-                (me  , ".tox") <- Just $ Text.splitAt 43 (clientProfile client)
-                (them, ".tox") <- Just $ Text.splitAt 43 h
+                (toxman,_,_) <- weAreTox state client h
                 Just $ setToxConnectionPolicy toxman (clientProfile client) h
         -- Add peer if we are not already associated ...
         policySetter Connection.TryingToConnect
         atomically $ putTMVar svVar (sv,conns)
 
+weAreTox :: PresenceState -> ClientState -> Text -> Maybe (ToxManager ClientAddress,Text{- me -},Text{- them -})
+weAreTox state client h = do
+    toxman <- toxManager state
+    (me  , ".tox") <- Just $ Text.splitAt 43 (clientProfile client)
+    (them, ".tox") <- Just $ Text.splitAt 43 h
+    return (toxman,me,them)
 
 resolvedFromRoster
   :: (ConfigFiles.User -> ConfigFiles.Profile -> IO [L.ByteString])
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index 79335efc..ae861a61 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -41,6 +41,7 @@ module XMPPServer
     , flushPassThrough
     , greet'
     , (<&>)
+    , grokStanza
     ) where
 
 import ConnectionKey
diff --git a/ToxManager.hs b/ToxManager.hs
index d16a5d2e..6d0149cf 100644
--- a/ToxManager.hs
+++ b/ToxManager.hs
@@ -26,7 +26,7 @@ import qualified Network.Tox.Onion.Transport as Tox
 import Presence
 import Text.Read
 import ToxToXMPP
-import XMPPServer                            (ClientAddress)
+import XMPPServer
 import DPut
 
 
@@ -140,5 +140,17 @@ toxman announcer toxbkts tox presence = ToxManager
                 Just acc -> setContactPolicy (Tox.id2key themid) TryingToConnect acc
             -- If unscheduled and unconnected, schedule recurring search for this contact.
         _ -> return () -- Remove contact.
+    , resolveToxPeer = \me them -> do
+        let lookupContact accs
+                = do meid <- readMaybe $ T.unpack me
+                     themid <- readMaybe $ T.unpack them
+                     acc <- HashMap.lookup meid accs
+                     return $ HashMap.lookup themid <$> readTVar (contacts acc)
+        atomically $ do
+            accs <- let ContactInfo{ accounts } = Tox.toxContactInfo tox
+                    in readTVar accounts
+            mc <- join <$> sequence (lookupContact accs)
+            maddr <- join <$> mapM (readTVar . contactLastSeenAddr) mc
+            return $ addrToPeerKey . Remote . Tox.nodeAddr . snd <$> maddr
     }
 
diff --git a/ToxToXMPP.hs b/ToxToXMPP.hs
index b75ada6a..9979526a 100644
--- a/ToxToXMPP.hs
+++ b/ToxToXMPP.hs
@@ -15,14 +15,19 @@ module ToxToXMPP
     , interweave
     ) where
 
-import Data.Conduit                 as C
-import qualified Data.Conduit.List  as CL
-import Data.XML.Types               as XML
+import Control.Applicative
+import Data.Conduit                    as C
+import qualified Data.Conduit.List     as CL
+import Data.Monoid
+import Data.Text.Encoding              as T
+import Data.XML.Types                  as XML
 import EventUtil
-import Network.Tox.Crypto.Transport as Tox
-import Network.Tox.Handshake        (HandshakeParams (..))
-import Util                         (unsplitJID)
-import XMPPServer                   as XMPP
+import Network.Tox.Crypto.Transport    as Tox
+import Network.Tox.Handshake           (HandshakeParams (..))
+import qualified Text.XML.Stream.Parse as XML
+import Util                            (unsplitJID)
+import XMPPServer                      as XMPP
+
 
 import Announcer
 import Announcer.Tox
@@ -71,31 +76,39 @@ import GHC.Conc                  (labelThread)
 #endif
 import DPut
 import Nesting
-
-xmppToTox :: Conduit XML.Event IO Tox.CryptoMessage
-xmppToTox = doNestingXML $ do
-    eventBeginDocument <- await
-    streamTag <- await
-    fix $ \loop -> do
-    e <- nextElement
-    -- dput DPut.XMan $ "xmppToTox: " ++ show e
-    --
-    -- (yield e >> awaitForever yield) $$ prettyPrint "xmpp->Tox"
-    -- prettyPrint
-    loop
+import XMPPToTox
 
 toxToXmpp :: Monad m => SockAddr -> PublicKey -> Text -> Conduit Tox.CryptoMessage m XML.Event
 toxToXmpp laddr me theirhost = do
     CL.sourceList $ XMPP.greet' "jabber:server" theirhost
     let me_u = T.pack $ show (key2id me)
-    awaitForever $ \toxmsg -> do
-        xmppInstantMessage "jabber:server"
-            (Just theirhost)      -- /from/
-            (Just $ unsplitJID (Just me_u,T.pack (show laddr),Nothing)) -- /to/ should match local address of this node.
-            (T.pack $ show $ msgID toxmsg)
-
-xmppInstantMessage :: Monad m => Text -> Maybe Text -> Maybe Text -> Text -> ConduitM i Event m ()
-xmppInstantMessage namespace mfrom mto text = do
+    awaitForever $ \case
+
+        UpToN { msgID    = MESSAGE
+              , msgBytes = bs      }
+               -> do
+            xmppInstantMessage "jabber:server"
+                (Just $ "root@" <> theirhost)      -- /from/
+                (Just $ unsplitJID (Just me_u,T.pack (show laddr),Nothing)) -- /to/ should match local address of this node.
+                []
+                (T.decodeUtf8 bs)
+
+        toxmsg | msgID toxmsg == PacketRequest -> return ()
+
+        toxmsg -> do
+            xmppInstantMessage "jabber:server"
+                (Just theirhost)      -- /from/
+                (Just $ unsplitJID (Just me_u,T.pack (show laddr),Nothing)) -- /to/ should match local address of this node.
+                [ attr "style" "font-weight:bold; color:red" ]
+                (T.pack $ show $ msgID toxmsg)
+
+xmppInstantMessage :: Monad m => Text
+                              -> Maybe Text
+                              -> Maybe Text
+                              -> [(Name, [Content])]
+                              -> Text
+                              -> ConduitM i Event m ()
+xmppInstantMessage namespace mfrom mto style text = do
     let ns n = n { nameNamespace = Just namespace }
     C.yield $ EventBeginElement (ns "message")
                (  maybe id (\t->(attr "from" t:)) mfrom
@@ -106,8 +119,7 @@ xmppInstantMessage namespace mfrom mto text = do
     C.yield $   EventEndElement (ns "body")
     C.yield $   EventBeginElement "{http://jabber.org/protocol/xhtml-im}html" []
     C.yield $     EventBeginElement "{http://www.w3.org/1999/xhtml}body" []
-    C.yield $        EventBeginElement "{http://www.w3.org/1999/xhtml}p"
-                       [ attr "style" "font-weight:bold; color:red" ]
+    C.yield $        EventBeginElement "{http://www.w3.org/1999/xhtml}p" style
     C.yield $          EventContent $ ContentText text
     C.yield $        EventEndElement "{http://www.w3.org/1999/xhtml}p"
     C.yield $     EventEndElement "{http://www.w3.org/1999/xhtml}body"
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
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index fefec650..e099334e 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -1982,14 +1982,22 @@ main = do
                 xmppSink         = newXmmpSink netcrypto
             forM_ msv $ \sv -> do
                 let Tox.HaveDHTKey saddr = Tox.ncSockAddr netcrypto
-                announceToxJabberPeer (Tox.ncMyPublicKey netcrypto) (Tox.ncTheirPublicKey netcrypto) (xmppEventChannel sv) addrTox saddr pingflag xmppSrc xmppSink
+                    Tox.HaveDHTKey dkey  = Tox.ncTheirDHTKey netcrypto
+                    nid                  = Tox.key2id dkey
+                    them                 = Tox.ncTheirPublicKey netcrypto
+                    me                   = Tox.ncMyPublicKey netcrypto
+                announceToxJabberPeer me them (xmppEventChannel sv) addrTox saddr pingflag xmppSrc xmppSink
                 forM_ mbtox $ \tox -> do
                 let ContactInfo{accounts} = Tox.toxContactInfo tox
-                mbacc <- HashMap.lookup (Tox.key2id $ Tox.ncMyPublicKey netcrypto)
+                mbacc <- HashMap.lookup (Tox.key2id me)
                          <$> atomically (readTVar accounts)
+                -- TODO: Add account if it doesn't exist?
                 forM_ mbacc $ \acnt -> do
                 now <- getPOSIXTime
-                atomically $ setEstablished now (Tox.ncTheirPublicKey netcrypto) acnt
+                forM_ (either (const Nothing) Just $ Tox.nodeInfo nid saddr)
+                    $ \ni -> do
+                atomically $ do setEstablished now them acnt
+                                setContactAddr now them ni acnt
             atomically $ do
                 supply <- readTVar (Tox.listenerIDSupply netCryptoSessionsState)
                 let (listenerId,supply') = freshId supply
diff --git a/examples/test-xmpp.hs b/examples/test-xmpp.hs
new file mode 100644
index 00000000..a8e20c3c
--- /dev/null
+++ b/examples/test-xmpp.hs
@@ -0,0 +1,41 @@
+
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Resource
+-- import Control.Monad.Trans.Class
+import Data.Conduit
+import Data.Conduit.List            as CL
+-- import Data.XML.Types
+import System.Environment
+import Text.XML.Stream.Parse
+
+import XMPPToTox
+
+{-
+parse :: ConduitM Event o (ResourceT IO) ()
+parse = do
+    return ()
+-}
+
+showTox :: CryptoMessage -> ResourceT IO ()
+showTox = liftIO . print
+
+main :: IO ()
+main = do
+    args <- getArgs
+    let xmlfile = args !! 0
+
+    -- runConduit :: Monad m => ConduitM () Void m r -> m r
+
+    -- test-xmpp.hs:19:51: warning: [-Wdeprecations]
+    --    In the use of ‘$$’
+    --    (imported from Data.Conduit, but defined in conduit-1.3.0.3:Data.Conduit.Internal.Conduit):
+    --    Deprecated: "Use runConduit and .|"
+    --
+    -- runResourceT $ parseFile def xmlfile =$= parse $$ return ()
+
+    runResourceT $ runConduit $ do
+        parseFile def xmlfile
+            .| xmppToTox
+            -- CL.mapM_ :: Monad m => (a -> m ()) -> ConduitT a o m ()
+            .| CL.mapM_ showTox
+