Daemon options to enable or disable XMPP.

4 files changed, 46 insertions, 28 deletions

diff --git a/Presence/Presence.hs b/Presence/Presence.hs
index c556a170..97b9d5b8 100644
--- a/Presence/Presence.hs
+++ b/Presence/Presence.hs
@@ -13,7 +13,7 @@ import Control.Concurrent.STM.TMVar
 import Control.Monad.Trans.Resource (runResourceT)
 import Control.Monad.Trans
 import Control.Monad.IO.Class (MonadIO, liftIO)
-import Network.Socket ( SockAddr(..) )
+import Network.Socket ( SockAddr(..), PortNumber )
 import System.Endian (fromBE32)
 import Data.List (nub, (\\), intersect, groupBy, sort, sortBy )
 import Data.Ord (comparing )
@@ -124,8 +124,8 @@ newPresenceState cw toxman xmpp = atomically $ do
             }
 
 
-presenceHooks :: PresenceState -> Int -> XMPPServerParameters
-presenceHooks state verbosity = XMPPServerParameters
+presenceHooks :: PresenceState -> Int -> Maybe PortNumber -> XMPPServerParameters
+presenceHooks state verbosity mport = XMPPServerParameters
     { xmppChooseResourceName        = chooseResourceName state
     , xmppTellClientHisName         = tellClientHisName state
     , xmppTellMyNameToClient        = textHostName
@@ -148,6 +148,7 @@ presenceHooks state verbosity = XMPPServerParameters
     , xmppClientInformSubscription  = clientInformSubscription state
     , xmppPeerInformSubscription    = peerInformSubscription state
     , xmppVerbosity                 = return verbosity
+    , xmppClientPort                = fromMaybe 5222 mport
     }
 
 
diff --git a/Presence/XMPPServer.hs b/Presence/XMPPServer.hs
index ea1500d4..c9132d0f 100644
--- a/Presence/XMPPServer.hs
+++ b/Presence/XMPPServer.hs
@@ -92,8 +92,8 @@ import qualified Connection
 
 peerport :: PortNumber
 peerport = 5269
-clientport :: PortNumber
-clientport = 5222
+-- clientport :: PortNumber
+-- clientport = 5222
 
 my_uuid :: Text
 my_uuid = "154ae29f-98f2-4af4-826d-a40c8a188574"
@@ -213,6 +213,7 @@ data XMPPServerParameters =
     , -- | Called when a remote peer informs us of our subscription status.
       xmppPeerInformSubscription :: IO () -> ConnectionKey -> Stanza -> IO ()
     , xmppVerbosity          :: IO Int
+    , xmppClientPort :: PortNumber -- 5222
     }
 
 
@@ -1841,7 +1842,7 @@ xmppServer xmpp = do
         hPutStrLn stderr $ "Starting peer listen"
         control sv (Listen peerport peer_params)
         hPutStrLn stderr $ "Starting client listen"
-        control sv (Listen clientport client_params)
+        control sv (Listen (xmppClientPort xmpp) client_params)
     return XMPPServer { _xmpp_sv = sv, _xmpp_peer_params = peer_params }
 
 #if MIN_VERSION_stm(2,4,0)
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index a921fea6..fcb02ace 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -393,7 +393,7 @@ data Session = Session
     , toxkeys           :: TVar Tox.AnnouncedKeys
     , userkeys          :: TVar [(SecretKey,PublicKey)]
     , roster            :: Tox.ContactInfo
-    , connectionManager :: ConnectionManager
+    , connectionManager :: Maybe ConnectionManager
     , onionRouter       :: OnionRouter
     , announcer         :: Announcer
     , signalQuit        :: IO ()
@@ -935,8 +935,9 @@ clientSession s@Session{..} sock cnum h = do
                                 where Just (_,(cnt,_)) = MM.lookup' k (Tox.keyAssoc keydb)
                         hPutClient h $ showColumns entries
 
-        ("c", s) | "" <- strp s -> cmd0 $ join $ atomically $ do
-            ConnectionManager mgr <- return connectionManager
+        ("c", s) | Just (ConnectionManager mgr) <- connectionManager
+                 , "" <- strp s
+                 -> cmd0 $ join $ atomically $ do
             cmap <- connections mgr
             cs <- Map.toList <$> mapM connStatus cmap
             let mkrow = Connection.showKey mgr *** Connection.showStatus mgr
@@ -975,6 +976,7 @@ readExternals nodeAddr vars = do
 data Options = Options
     { portbt    :: String
     , porttox   :: String
+    , portxmpp  :: String
     , ip6bt     :: Bool
     , ip6tox    :: Bool
     , dhtkey    :: Maybe SecretKey
@@ -993,6 +995,7 @@ sensibleDefaults :: Options
 sensibleDefaults = Options
     { portbt    = "6881"
     , porttox   = "33445"
+    , portxmpp  = "5222"
     , ip6bt     = True
     , ip6tox    = True
     , dhtkey    = Nothing
@@ -1009,8 +1012,9 @@ 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 }
+    { portbt   = fromMaybe (portbt opts)  $ Prelude.lookup "bt"  ports
+    , porttox  = fromMaybe (porttox opts) $ Prelude.lookup "tox" ports
+    , portxmpp = fromMaybe (portxmpp opts) $ Prelude.lookup "xmpp" ports }
  where
     ports = map ( (dropWhile (==',') *** dropWhile (=='='))
                 . break (=='=') )
@@ -1414,18 +1418,24 @@ main = runResourceT $ liftBaseWith $ \resT -> do
 
     _ <- UPNP.requestPorts "dht-client" $ map (Datagram,) $ baddrs ++ taddrs
 
-    -- XMPP initialization
-    cw        <- newConsoleWriter
-    serverVar <- atomically $ newEmptyTMVar
-    state     <- newPresenceState cw (toxman <$> mbtox) serverVar
-
-    sv    <- resT $ xmppServer (presenceHooks state (verbosity opts))
-    -- 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
-    atomically $ do
-        putTMVar serverVar  (sv,conns) -- Okay, now it's ready. :)
-                                       -- FIXME: This is error prone.
+    (msv,mconns,mstate) <- case portxmpp opts of
+        "" -> return (Nothing,Nothing,Nothing)
+        p  -> do
+            mxmppPort <- sockAddrPort <$> getBindAddress p True{-IPv6 supported-}
+
+            -- XMPP initialization
+            cw        <- newConsoleWriter
+            serverVar <- atomically $ newEmptyTMVar
+            state     <- newPresenceState cw (toxman <$> mbtox) serverVar
+
+            sv    <- resT $ xmppServer (presenceHooks state (verbosity opts) Nothing)
+            -- 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
+            atomically $ do
+                putTMVar serverVar  (sv,conns) -- Okay, now it's ready. :)
+                                               -- FIXME: This is error prone.
+            return (Just sv, Just conns, Just state)
 
     forM_ (take 1 taddrs) $ \addrTox -> do
         atomically $ Tox.addNewSessionHook netCryptoSessionsState $ \mbNoSpam netcrypto -> do
@@ -1437,7 +1447,8 @@ main = runResourceT $ liftBaseWith $ \resT -> do
                 onEOF            = return () -- TODO: Update toxContactInfo, not connected.
                 xmppSrc          = ioToSource receiveCrypto onEOF
                 xmppSink         = newXmmpSink netcrypto
-            announceToxJabberPeer (xmppEventChannel sv) addrTox (Tox.ncSockAddr netcrypto) pingflag xmppSrc xmppSink
+            forM_ msv $ \sv -> do
+                announceToxJabberPeer (xmppEventChannel sv) addrTox (Tox.ncSockAddr netcrypto) pingflag xmppSrc xmppSink
             -- TODO: Update toxContactInfo, connected.
 #endif
             let handleIncoming typ session cd | any ($ typ) [Tox.isKillPacket, Tox.isOFFLINE] = atomically $ do
@@ -1475,7 +1486,7 @@ main = runResourceT $ liftBaseWith $ \resT -> do
                 , toxkeys           = keysdb
                 , userkeys          = toxids
                 , roster            = rstr
-                , connectionManager = ConnectionManager conns
+                , connectionManager = ConnectionManager <$> mconns
                 , onionRouter       = orouter
                 , externalAddresses = liftM2 (++) btips toxips
                 , announcer         = announcer
@@ -1508,16 +1519,17 @@ main = runResourceT $ liftBaseWith $ \resT -> do
 
     forkIO $ do
         myThreadId >>= flip labelThread "XMPP.stanzas"
-        let console = cwPresenceChan <$> consoleWriter state
+        let console = cwPresenceChan <$> (mstate >>= consoleWriter)
         fix $ \loop -> do
         what <- atomically
             $ orElse (do (client,stanza) <- maybe retry takeTMVar console
-                         return $ do informClientPresence0 state Nothing client stanza
+                         return $ forM_ mstate $ \state -> do
+                                     informClientPresence0 state Nothing client stanza
                                      loop)
                      (checkQuit >> return (return ()))
         what
 
-    hPutStrLn stderr "Started XMPP server."
+    forM msv $ \_ -> hPutStrLn stderr "Started XMPP server."
 
     -- Wait for DHT and XMPP threads to finish.
     -- Use ResourceT to clean-up XMPP server.
diff --git a/todo.txt b/todo.txt
index 75c046e0..70af1142 100644
--- a/todo.txt
+++ b/todo.txt
@@ -1,3 +1,7 @@
+xmpp: handle tox-friends in roster.
+
+xmpp: load tox user key from ~/.presence/<pubkey>.tox/secret
+
 tox: Add fallback trials to cookie response in case response is from another address than request.
 
 ui: Online help.