Configurable bind-addresses for xmpp.

1 files changed, 33 insertions, 12 deletions

diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 918df327..0c0e0419 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -429,6 +429,14 @@ clientSession0 s sock cnum h = do
   `catch` \e -> if isEOFError e then return ()
                                 else throwIO e
 
+readKeys :: TVar [(SecretKey, PublicKey)]
+            -> TVar (HashMap.HashMap Tox.NodeId Account)
+            -> STM [(SecretKey, PublicKey)]
+readKeys userkeys roster = do
+    uks <- readTVar userkeys
+    as <- readTVar roster
+    return $ uks ++ map ((userSecret *** Tox.id2key) . swap) (HashMap.toList as)
+
 clientSession :: Session -> t1 -> t -> ClientHandle -> IO ()
 clientSession s@Session{..} sock cnum h = do
     line <- dropWhile isSpace <$> hGetClientLine h
@@ -584,7 +592,7 @@ clientSession s@Session{..} sock cnum h = do
         --      k secrets          (list key pairs, including secret keys)
 
         ("k", s) | ""           <- strp s -> cmd0 $ do
-                        ks <- atomically $ readTVar userkeys
+                        ks <- atomically $ readKeys userkeys (accounts roster)
                         let spaces k | Just sel <- selectedKey, (sel == k) = " *"
                                      | otherwise                           = "  "
                         hPutClient h $ unlines $ map (\(_,k) -> mappend (spaces k) . show . Tox.key2id $ k) ks
@@ -601,17 +609,14 @@ clientSession s@Session{..} sock cnum h = do
                                                   ++ [mappend " *" . show . Tox.key2id $ pubkey]
                         switchKey $ Just pubkey
                  | "secrets"    <- strp s -> cmd0 $ do
-                        ks <- atomically $ do
-                                uks <- readTVar userkeys
-                                as <- readTVar (accounts roster)
-                                return $ uks ++ map ((userSecret *** Tox.id2key) . swap) (HashMap.toList as)
+                        ks <- atomically $ readKeys userkeys (accounts roster)
                         skey <- maybe (return Nothing) (atomically . dhtSecretKey)
                                       $ Map.lookup netname dhts
                         hPutClient h . showReport $ map mkrow ks ++ case skey >>= encodeSecret of
                             Just x  -> [("",""),("dht-key:",B.unpack x)]
                             Nothing -> []
                  | ("sel",_:expr) <- break isSpace s -> do
-                         ks <- atomically $ map (show . Tox.key2id . snd) <$> readTVar userkeys
+                         ks <- atomically $ map (show . Tox.key2id . snd) <$> readKeys userkeys (accounts roster)
                          case find (isInfixOf expr) ks of
                             Just k -> do
                                 hPutClient h $ "Selected key: "++k
@@ -871,6 +876,12 @@ clientSession s@Session{..} sock cnum h = do
                                                             announceInterval)
                                             dta
                                     reportit $ show $ announceTarget dta
+                            ptest = fromMaybe "E:NoMethod"
+                                        $ fmap (\DHTAnnouncable { announceParseData
+                                                                , announceTarget }
+                                                  -> either ("E:"++) (show . announceTarget)
+                                                          $ announceParseData dtastr)
+                                               a
 
                         let aerror = unlines
                                 [ "announce error."
@@ -879,6 +890,10 @@ clientSession s@Session{..} sock cnum h = do
                                 , "publish = " ++ maybe "nil" (const "ok") a
                                 -- , "chktok = " ++ maybe "nil" (const "ok") chktok -- chktok = nil
                                 -- , "chkni = " ++ maybe "nil" (const "ok") chkni
+                                , "ptest = " ++ ptest
+                                , "mameth = " ++ show (fmap (const ()) mameth)
+                                , "lmeth  = " ++ show (fmap (const ()) lmeth)
+                                , "selectedKey = " ++ show selectedKey
                                 ]
                         fromMaybe (hPutClient h aerror) $ mameth <|> lmeth
 
@@ -1007,7 +1022,8 @@ readExternals nodeAddr vars = do
 data Options = Options
     { portbt    :: String
     , porttox   :: String
-    , portxmpp  :: String
+    , portxmpp  :: String -- client-to-server
+    , portxmppS :: String -- server-to-server
     , ip6bt     :: Bool
     , ip6tox    :: Bool
     , dhtkey    :: Maybe SecretKey
@@ -1027,6 +1043,7 @@ sensibleDefaults = Options
     { portbt    = "6881"
     , porttox   = "33445"
     , portxmpp  = "5222"
+    , portxmppS = "5269"
     , ip6bt     = True
     , ip6tox    = True
     , dhtkey    = Nothing
@@ -1045,9 +1062,10 @@ parseArgs ("-4":args) opts         = parseArgs args opts
     { ip6bt  = False
     , ip6tox = False }
 parseArgs (arg:args) opts          = parseArgs args opts
-    { portbt   = fromMaybe (portbt opts)  $ Prelude.lookup "bt"  ports
-    , porttox  = fromMaybe (porttox opts) $ Prelude.lookup "tox" ports
-    , portxmpp = fromMaybe (portxmpp opts) $ Prelude.lookup "xmpp" ports }
+    { portbt    = fromMaybe (portbt opts)  $ Prelude.lookup "bt"  ports
+    , porttox   = fromMaybe (porttox opts) $ Prelude.lookup "tox" ports
+    , portxmpp  = fromMaybe (portxmpp opts) $ Prelude.lookup "xmpp" ports
+    , portxmppS = fromMaybe (portxmppS opts) $ Prelude.lookup "xmpp.s2s" ports }
  where
     ports = map ( (dropWhile (==',') *** dropWhile (=='='))
                 . break (=='=') )
@@ -1482,7 +1500,10 @@ main = runResourceT $ liftBaseWith $ \resT -> do
     (msv,mconns,mstate) <- case portxmpp opts of
         "" -> return (Nothing,Nothing,Nothing)
         p  -> do
-            mxmppPort <- sockAddrPort <$> getBindAddress p True{-IPv6 supported-}
+            cport <- getBindAddress p True{-IPv6 supported-}
+            -- TODO: Allow running without an XMPP server-to-server port.
+            --       This should probably be default for toxmpp use.
+            sport <- getBindAddress (portxmppS opts) True{-IPv6 supported-}
 
             -- XMPP initialization
             cw        <- newConsoleWriter
@@ -1497,7 +1518,7 @@ main = runResourceT $ liftBaseWith $ \resT -> do
                             ]
             state     <- newPresenceState cw (toxman announcer toxbkts <$> mbtox) serverVar
 
-            sv    <- resT $ xmppServer (presenceHooks state (verbosity opts) Nothing)
+            sv    <- resT $ xmppServer (presenceHooks state (verbosity opts) (Just cport) (Just sport))
             -- We now have a server object but it's not ready to use until
             -- we put it into the 'server' field of our /state/ record.
             conns     <- xmppConnections  sv