From ea3c97cea6cb2a690afca743fa8fecfbb533d69b Mon Sep 17 00:00:00 2001 From: joe Date: Fri, 18 May 2018 23:16:46 -0400 Subject: Daemon options to enable or disable XMPP. --- Presence/Presence.hs | 7 ++++--- Presence/XMPPServer.hs | 7 ++++--- examples/dhtd.hs | 56 ++++++++++++++++++++++++++++++-------------------- todo.txt | 4 ++++ 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/.tox/secret + tox: Add fallback trials to cookie response in case response is from another address than request. ui: Online help. -- cgit v1.2.3