4 files changed, 179 insertions, 39 deletions

diff --git a/ToxChat.hs b/ToxChat.hs
new file mode 100644
index 00000000..fba5d33b
--- /dev/null
+++ b/ToxChat.hs
@@ -0,0 +1,107 @@
+{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+module ToxChat
+    ( module Chat
+    , module ToxChat
+    ) where
+
+import Control.Concurrent.STM
+import Control.Monad
+import Data.Char
+import Data.Dependent.Sum
+import Data.Function
+import qualified Data.Map     as Map
+         ;import Data.Map     (Map)
+import Data.Maybe
+import qualified Data.Text    as T
+         ;import Data.Text    (Text)
+import Debug.Trace
+
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent.Lifted
+import GHC.Conc                  (labelThread)
+#endif
+
+import Chat
+import Data.Tox.Msg
+import DebugTag
+import DPut
+import MUC
+import Network.Tox.AggregateSession
+
+forkUntilSignaled :: String -> STM (IO ()) -> IO (IO ())
+forkUntilSignaled lbl action = do
+    quitSignal <- newTVarIO False
+    t <- forkIO $ do
+        fix $ \loop -> join $ atomically
+            $ orElse (do readTVar quitSignal >>= check
+                         return $ return ())
+                     (fmap (>> loop) $ action)
+    labelThread t lbl
+    return $ atomically (writeTVar quitSignal True)
+
+data RoomData k = RoomData
+    { room           :: Maybe (Room k)
+    , pendingInvites :: [(AggregateSession,Int,Maybe Text,Invite)]
+    }
+
+chatevents :: (Ord conkey, Show conkey) => TVar (Map Text (RoomData conkey)) -> STM (IO ())
+chatevents rsvar = do
+    rs <- readTVar rsvar
+    if Map.null rs
+      then retry
+      else do
+        ios <- flip Map.traverseWithKey rs $ \rkey r -> do
+            ps <- maybe (return mempty) roomPending $ room r
+            trace ("roomPending " ++ show ps) $ return ()
+            case Map.toList ps of
+                (k,t):ts -> do
+                    roomCommit (fromJust $ room r) k t
+                    modifyTVar' rsvar
+                        $ Map.adjust (\d -> d { pendingInvites = take 1 (pendingInvites d)})
+                                     rkey
+                    return $ do
+                        dput XJabber $ "toxchat-committed " ++ show (rkey,length ts,k,t)
+                        case membershipEffect $ chatMessage t of
+                            MembershipEffect Outside Inside -> do
+                                forM_ (pendingInvites r) $ \(c,i,jid,inv) -> do
+                                    -- TODO b <- checkCompatible me them c
+                                    dput XJabber $ "Replying to invite " ++ show inv
+                                    dispatchMessage c (Just i)
+                                        $ Pkt INVITE_GROUPCHAT ==> inv { invite = AcceptedInvite }
+                            _ -> return ()
+                _ -> retry
+        return $ foldl1 (>>) ios
+
+data InviteCache m = InviteCache
+    { rememberInvite :: AggregateSession -> Int {- session ID -} -> Maybe Text {- origin -} -> Invite -> m ()
+    , lookupInvite   :: Text {- chatroom JID -} -> m (Maybe Invite)
+    }
+
+forkToxChat :: MUC -> IO (IO (), InviteCache IO)
+forkToxChat muc = do
+    (chan, rs) <- atomically $ do
+        c <- dupTChan (mucChan muc)
+        rs <- newTVar Map.empty -- TODO: This seems to redundantly duplicate MUC{mucRooms}.
+        return (c,rs)
+    quit <- forkUntilSignaled "toxchat" $ orElse (chatevents rs) $ do
+        e <- readTChan chan
+        case e of
+            MUCCreate room jid nick r -> modifyTVar' rs $
+                Map.alter (\d -> Just $ RoomData (Just r) (maybe [] pendingInvites d))
+                          (T.toLower room)
+        return $ case e of
+            MUCCreate room jid nick _ ->
+                dput XJabber $ unwords $ map T.unpack
+                    [ "MUCCreate", room, jid, nick ]
+    return $ (,) quit InviteCache
+        { rememberInvite = \c i jid inv -> do
+            dput XJabber $ "remember invite " ++ show (T.pack $ show $ inviteChatID inv, i, jid )
+            atomically $ do
+              modifyTVar' rs $ Map.alter (\d -> Just $ RoomData (room =<< (d:: Maybe (RoomData _)))
+                                                                ( ((c,i,jid,inv) :) $ maybe [] pendingInvites d))
+                                       (T.pack $ map toLower $ show $ inviteChatID inv)
+        , lookupInvite = \_ -> return Nothing
+        }
diff --git a/ToxToXMPP.hs b/ToxToXMPP.hs
index 4814553d..1420c642 100644
--- a/ToxToXMPP.hs
+++ b/ToxToXMPP.hs
@@ -8,7 +8,7 @@ module ToxToXMPP where
 
 import Control.Monad
 import Crypto.Tox
-import Data.Conduit                 as C
+import Conduit                      as C
 import qualified Data.Conduit.List  as CL
 import Data.Dependent.Sum
 import Data.Function
@@ -44,19 +44,38 @@ toxUserStatus Tox.Away = XMPP.Away
 toxUserStatus Busy     = DoNotDisturb
 toxUserStatus _        = XMPP.Away -- Default, shouldn't occur.
 
-toxToXmpp :: Monad m => SockAddr -> PublicKey -> Text -> ConduitM Tox.CryptoMessage XML.Event m ()
-toxToXmpp laddr me theirhost = do
+-- Currently unused, see note in 'toxJID'.
+toJabberResource :: Int -> Maybe Text
+toJabberResource addr = T.pack . show <$> Just (positive addr)
+ where
+    positive addr | addr < 0  = 2 * negate addr + 1
+                  | otherwise = 2 * addr
+
+toxJID :: Text -> Int -> Text
+toxJID theirhost addr =
+    -- unsplitJID (Nothing, theirhost, toJabberResource addr)
+    --
+    -- Not encoding the Tox session ID because Pidgin apparently doesn't
+    -- cope well with resource IDs occuring on bare hostname JIDs.
+    unsplitJID (Nothing, theirhost, Nothing)
+
+toxToXmpp :: Monad m =>
+    (Int -> Maybe Text -> Invite -> m ())
+    -> SockAddr
+    -> PublicKey
+    -> Text
+    -> ConduitM (Int,Tox.CryptoMessage) XML.Event m ()
+toxToXmpp store_invite _ me theirhost = do
     CL.sourceList $ XMPP.greet' "jabber:server" theirhost
     let me_u    = Nothing
         me_h    = xmppHostname me
-        im_from = (Just $ unsplitJID (Nothing, theirhost, Nothing)) -- /from/
         im_to   = (Just $ unsplitJID
                             ( me_u
                             -- /to/ should match local address of this node.
                             , me_h
                             , Nothing))
     let
-      statelessMessages = \case
+      statelessMessages addr im_from = \case
 
         Pkt MESSAGE :=> Identity bs ->
             xmppInstantMessage "jabber:server" im_from im_to [] bs
@@ -75,7 +94,8 @@ toxToXmpp laddr me theirhost = do
                 [ attr "style" "font-weight:bold; color:red" ]
                 ("INVITE(todo)" <> (T.pack $ show ginv))
             case invite ginv of
-                GroupInvite {} -> xmppInvite "jabber:server"  me_h (fromJust im_from) (fromJust im_to) ginv
+                GroupInvite {} -> do C.lift $ store_invite addr im_from ginv
+                                     xmppInvite "jabber:server"  me_h (fromJust im_from) (fromJust im_to) ginv
                 _              -> return ()
 
         toxmsg -> do
@@ -84,24 +104,27 @@ toxToXmpp laddr me theirhost = do
                 (T.pack $ "Unhandled message: " ++ show (msgID toxmsg))
 
     flip fix available $ \loop status -> do
-        let go (Pkt USERSTATUS :=> Identity st) = do
-                let status' = status { presenceShow = toxUserStatus st }
-                xmppPresence "jabber:server" im_from status'
-                loop status'
-
-            go (Pkt STATUSMESSAGE :=> Identity bs) = do
-                let status' = status { presenceStatus = [("",bs)] }
-                xmppPresence "jabber:server" im_from status'
-                loop status'
-
-            go (Pkt ONLINE :=> _) = do
-                xmppPresence "jabber:server" im_from status
-                loop status
-
-            go x = do
-                statelessMessages x
-                loop status
-        await >>= mapM_ go
+        m <- await
+        forM_ m $ \(addr,x) -> do
+        let im_from = (Just $ toxJID theirhost addr)
+        case x of
+          Pkt USERSTATUS :=> Identity st -> do
+            let status' = status { presenceShow = toxUserStatus st }
+            xmppPresence "jabber:server" im_from status'
+            loop status'
+
+          Pkt STATUSMESSAGE :=> Identity bs -> do
+            let status' = status { presenceStatus = [("",bs)] }
+            xmppPresence "jabber:server" im_from status'
+            loop status'
+
+          Pkt ONLINE :=> _ -> do
+            xmppPresence "jabber:server" im_from status
+            loop status
+
+          x -> do
+            statelessMessages addr im_from x
+            loop status
 
 xmppPresence :: Monad m => Text -> Maybe Text -> StanzaType -> ConduitM i XML.Event m ()
 xmppPresence namespace mjid p = do
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index a602b772..6756b14b 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -115,6 +115,7 @@ import qualified Connection.Tcp as Tcp (ConnectionEvent(..),noCleanUp,TCPStatus)
 import DPut
 import DebugTag
 import LocalChat
+import ToxChat
 import MUC
 
 
@@ -1022,7 +1023,7 @@ clientSession s@Session{..} sock cnum h = do
                                ]
                 rs = map mkrow cs
             return $ do
-            hPutClient h $ showColumns rs
+            hPutClient h $ "connections\n" ++ showColumns rs
 
         ("help", s) | Just DHT{..} <- Map.lookup netname dhts
                     -> cmd0 $ do
@@ -1157,11 +1158,12 @@ newXmmpSink session@(Tox.NCrypto { ncOutgoingQueue = outGoingQVar }) = C.awaitFo
 
 onNewToxSession :: XMPPServer
                      -> TVar (Map.Map Uniq24 AggregateSession)
+                     -> InviteCache IO
                      -> ContactInfo extra
                      -> SockAddr
                      -> Tox.Session
                      -> IO ()
-onNewToxSession sv ssvar ContactInfo{accounts} addrTox netcrypto = do
+onNewToxSession sv ssvar invc ContactInfo{accounts} addrTox netcrypto = do
     let them s = Tox.longTermKey $ runIdentity cookie -- remote tox key
          where Tox.Cookie _ cookie = Tox.handshakeCookie (sReceivedHandshake s)
 
@@ -1193,7 +1195,7 @@ onNewToxSession sv ssvar ContactInfo{accounts} addrTox netcrypto = do
                                                     _       -> retry)
                                  (return ())
             toxSnk  = C.mapM_ (uncurry $ dispatchMessage c)
-            xmppSrc = toxSrc .| C.map snd .| toxToXmpp addrTox (me s) (xmppHostname $ them s)
+            xmppSrc = toxSrc .| toxToXmpp (rememberInvite invc c) addrTox (me s) (xmppHostname $ them s)
             xmppSnk = flushPassThrough xmppToTox
                         .| C.mapMaybe (\case Flush   -> Nothing
                                              Chunk x -> Just (Nothing,x))
@@ -1288,11 +1290,14 @@ selectManager mtman tcp profile = case T.splitAt 43 profile of
 
 initTox :: Options
            -> TVar (Map.Map Uniq24 AggregateSession)
-           -> TVar Tox.AnnouncedKeys -> Maybe XMPPServer -> IO ( Maybe (Tox.Tox JabberClients) , IO ()
+           -> TVar Tox.AnnouncedKeys
+           -> Maybe XMPPServer
+           -> InviteCache IO
+           -> IO ( Maybe (Tox.Tox JabberClients) , IO ()
                  , Map.Map String DHT
                  , IO [SockAddr]
                  , [SockAddr])
-initTox opts ssvar keysdb mbxmpp = case porttox opts of
+initTox opts ssvar keysdb mbxmpp invc = case porttox opts of
         "" -> return (Nothing,return (), Map.empty, return [],[])
         toxport -> do
             addrTox <- getBindAddress toxport (ip6tox opts)
@@ -1301,7 +1306,7 @@ initTox opts ssvar keysdb mbxmpp = case porttox opts of
                               addrTox
                               (case mbxmpp of
                                 Nothing   -> \_ _ _ -> return ()
-                                Just xmpp -> onNewToxSession xmpp ssvar)
+                                Just xmpp -> onNewToxSession xmpp ssvar invc)
                               (dhtkey opts)
                               (\_ _ -> return ()) -- TODO: TCP relay send
             (quitTox, toxStrap4, toxStrap6) <- Tox.forkTox tox True
@@ -1493,11 +1498,12 @@ initJabber :: Options
               -> Announcer
               -> Maybe (Tox.Tox JabberClients)
               -> Map.Map String DHT
+              -> MUC
               -> IO ( Maybe XMPPServer
                     , Maybe (Manager TCPStatus T.Text)
                     , Maybe (PresenceState Pending)
                     )
-initJabber opts ssvar announcer mbtox toxdhts = case portxmpp opts of
+initJabber opts ssvar announcer mbtox toxdhts toxchat = case portxmpp opts of
         "" -> return (Nothing,Nothing,Nothing)
         p  -> do
             cport <- getBindAddress p True{-IPv6 supported-}
@@ -1522,7 +1528,8 @@ initJabber opts ssvar announcer mbtox toxdhts = case portxmpp opts of
             state     <- newPresenceState cw tman sv (selectManager tman tcp)
             chat <- atomically newMUC
             quitChatService <- forkLocalChat chat
-            let chats = Map.singleton "chat" chat
+            let chats = Map.fromList [ ("local", chat)
+                                     , ("ngc", toxchat) ]
             forkXmpp sv (presenceHooks state chats (verbosity opts) (Just cport) (Just sport))
             conns     <- xmppConnections  sv
             return (Just sv, Just conns, Just state)
@@ -1546,6 +1553,9 @@ main = do
     forM ([minBound .. maxBound]::[DebugTag]) setQuiet
     forM (verboseTags opts) setVerbose
 
+    toxchat <- atomically newMUC
+    (quitToxChat,invc) <- forkToxChat toxchat
+
     (quitBt,btdhts,btips,baddrs) <- case portbt opts of
         "" -> return (return (), Map.empty,return [],[])
         p  -> do
@@ -1638,9 +1648,9 @@ main = do
     ssvar <- atomically $ newTVar Map.empty
     rec (mbtox,quitTox,toxdhts,toxips,(taddrs::[SockAddr]),msv,mconns,mstate) <- do
 
-        (mbtox,quitTox,toxdhts,toxips,(taddrs::[SockAddr])) <- initTox opts ssvar keysdb msv
+        (mbtox,quitTox,toxdhts,toxips,(taddrs::[SockAddr])) <- initTox opts ssvar keysdb msv invc
 
-        (msv,mconns,mstate) <- initJabber opts ssvar announcer mbtox toxdhts
+        (msv,mconns,mstate) <- initJabber opts ssvar announcer mbtox toxdhts toxchat
 
         return (mbtox,quitTox,toxdhts,toxips,(taddrs::[SockAddr]),msv,mconns,mstate)
 
diff --git a/src/Data/Tox/Msg.hs b/src/Data/Tox/Msg.hs
index e8c26a56..6550fd95 100644
--- a/src/Data/Tox/Msg.hs
+++ b/src/Data/Tox/Msg.hs
@@ -261,14 +261,14 @@ instance Show ChatID where
     show (ChatID ed) = showToken32 ed
 
 data InviteType = GroupInvite { groupName :: Text }
-                | AccptedInvite
+                | AcceptedInvite
                 | ConfirmedInvite { inviteNodes :: [NodeInfo] }
   deriving (Eq,Show)
 
 instance Sized InviteType where
     size = VarSize $ \x -> case x of
         GroupInvite name   -> B.length (T.encodeUtf8 name)
-        AccptedInvite      -> 0
+        AcceptedInvite     -> 0
         ConfirmedInvite ns -> 0 -- TODO: size of node list.
 
 data Invite = Invite
@@ -292,20 +292,20 @@ instance Serialize Invite where
         Invite chatid chatkey <$> case invite_type of
             0 -> do bs <- remaining >>= getBytes -- TODO: size can be determined from group shared state.
                     return $ GroupInvite $ decodeUtf8 bs
-            1 -> return AccptedInvite
+            1 -> return AcceptedInvite
             2 -> return $ ConfirmedInvite [] -- TODO: decode nodes
 
     put x = do
         putWord8 254 -- GP_FRIEND_INVITE
         putWord8 $ case invite x of
             GroupInvite {}     -> 0 -- GROUP_INVITE
-            AccptedInvite      -> 1 -- GROUP_INVITE_ACCEPTED
+            AcceptedInvite     -> 1 -- GROUP_INVITE_ACCEPTED
             ConfirmedInvite {} -> 2 -- GROUP_INVITE_CONFIRMATION
         put $ inviteChatID x
         put $ key2id $ inviteChatKey x
         case invite x of
             GroupInvite name   -> putByteString $ encodeUtf8 name
-            AccptedInvite      -> return ()
+            AcceptedInvite     -> return ()
             ConfirmedInvite ns -> return () -- TODO: encode nodes.
 
 instance Packet Invite where