From 53b72dd253ce01a24430429cef400675401292dc Mon Sep 17 00:00:00 2001 From: joe Date: Mon, 25 Jun 2018 17:56:14 -0400 Subject: Separated conduit parser and general tox-manager stuff. --- ToxToXMPP.hs | 500 ++--------------------------------------------------------- 1 file changed, 11 insertions(+), 489 deletions(-) (limited to 'ToxToXMPP.hs') diff --git a/ToxToXMPP.hs b/ToxToXMPP.hs index 9979526a..1493827a 100644 --- a/ToxToXMPP.hs +++ b/ToxToXMPP.hs @@ -3,80 +3,22 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE ViewPatterns #-} -module ToxToXMPP - ( forkAccountWatcher - , JabberClients - , PerClient - , initPerClient - , toxQSearch - , toxAnnounceInterval - , xmppToTox - , toxToXmpp - , interweave - ) where +module ToxToXMPP where -import Control.Applicative -import Data.Conduit as C -import qualified Data.Conduit.List as CL +import Crypto.Tox +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 qualified Data.Text as T + ;import Data.Text (Text) +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 qualified Text.XML.Stream.Parse as XML -import Util (unsplitJID) -import XMPPServer as XMPP - - -import Announcer -import Announcer.Tox -import Connection -import Network.QueryResponse -import Network.Tox.DHT.Handlers (nodeSearch, nodesOfInterest) --- import Control.Concurrent -import Control.Concurrent.STM -import Control.Monad -import Crypto.Tox -import qualified Data.HashMap.Strict as HashMap -import Data.Maybe -import qualified Data.Set as Set -import qualified Data.Text as T -import Data.Time.Clock.POSIX import Network.Address -import Network.Kademlia.Search -import qualified Network.Tox as Tox -import Network.Tox.ContactInfo as Tox -import qualified Network.Tox.Crypto.Handlers as Tox - ;import Network.Tox.Crypto.Handlers (UponCookie (..)) --- import qualified Network.Tox.DHT.Handlers as Tox -import ClientState -import Data.Bits -import Data.Function -import qualified Data.Map as Map -import Data.Text (Text) -import Data.Word -import qualified Network.Kademlia.Routing as R -import Network.Tox -import Network.Tox.DHT.Handlers -import qualified Network.Tox.DHT.Transport as Tox - ;import Network.Tox.DHT.Transport (FriendRequest (..), dhtpk) +import Network.Tox.Crypto.Transport as Tox import Network.Tox.NodeId -import qualified Network.Tox.Onion.Handlers as Tox -import qualified Network.Tox.Onion.Transport as Tox - ;import Network.Tox.Onion.Transport (OnionData (..)) -import Presence -import Text.Read -import XMPPServer (ClientAddress) -#ifdef THREAD_DEBUG -import Control.Concurrent.Lifted.Instrument -#else -import Control.Concurrent.Lifted -import GHC.Conc (labelThread) -#endif -import DPut -import Nesting -import XMPPToTox +import Util (unsplitJID) +import XMPPServer as XMPP toxToXmpp :: Monad m => SockAddr -> PublicKey -> Text -> Conduit Tox.CryptoMessage m XML.Event toxToXmpp laddr me theirhost = do @@ -126,423 +68,3 @@ xmppInstantMessage namespace mfrom mto style text = do C.yield $ EventEndElement "{http://jabber.org/protocol/xhtml-im}html" C.yield $ EventEndElement (ns "message") -key2jid :: Word32 -> PublicKey -> Text -key2jid nospam key = T.pack $ show $ NoSpamId nsp key - where - nsp = NoSpam nospam (Just sum) - sum = nlo `xor` nhi `xor` xorsum key - nlo = fromIntegral (0x0FFFF .&. nospam) :: Word16 - nhi = fromIntegral (0x0FFFF .&. (nospam `shiftR` 16)) :: Word16 - -type JabberClients = Map.Map ClientAddress PerClient - -data PerClient = PerClient - { pcDeliveredFRs :: TVar (Set.Set Tox.FriendRequest) - } - -initPerClient :: STM PerClient -initPerClient = do - frs <- newTVar Set.empty - return PerClient - { pcDeliveredFRs = frs - } - -data ToxToXMPP = ToxToXMPP - { txAnnouncer :: Announcer - , txAccount :: Account JabberClients - , txPresence :: PresenceState - , txTox :: Tox JabberClients - } - -default_nospam :: Word32 -default_nospam = 0x6a7a27fc -- big-endian base64: anon/A== - -nodeinfoStaleTime :: POSIXTime -nodeinfoStaleTime = 600 - -nodeinfoSearchInterval :: POSIXTime -nodeinfoSearchInterval = 15 - -data Awaiting v = Since POSIXTime -data Acquired v = At POSIXTime v -data Moot v = Moot - -data NNS a b c = NNS { -- NetcryptoNegotiationState - sessionDesired :: Bool, - theirPublicKey :: a Tox.DHTPublicKey, - theirAddress :: b NodeInfo, - theirCookie :: c (Tox.Cookie Encrypted), - sessionIsActive :: Bool -} - -data NS - = Stage1 (NNS Moot Moot Moot) - | Stage2 (NNS Awaiting Moot Moot) - | Stage3 (NNS Acquired Awaiting Moot) - | Stage4 (NNS Acquired Acquired Awaiting) - | Stage5 (NNS Acquired Acquired Acquired) - -gotDhtPubkey :: Tox.DHTPublicKey -> ToxToXMPP -> PublicKey -> IO () -gotDhtPubkey theirDhtKey tx theirKey = do - contact <- atomically $ getContact theirKey (txAccount tx) >>= mapM (readTVar . contactLastSeenAddr) - forM_ contact $ \lastSeen -> do - case lastSeen of - Nothing -> doSearch - Just (tm, _) -> do - now <- getPOSIXTime - when (now - tm > nodeinfoStaleTime) doSearch - where - tox :: Tox JabberClients - tox = txTox tx - - myPublicKey = toPublic $ userSecret (txAccount tx) - me = key2id myPublicKey - - doSearch = do - let akey = akeyConnect (txAnnouncer tx) me theirKey - atomically $ registerNodeCallback (toxRouting tox) (nic akey) - scheduleSearch (txAnnouncer tx) akey meth theirDhtKey - - target :: NodeId - target = key2id $ dhtpk theirDhtKey - - meth :: SearchMethod Tox.DHTPublicKey - meth = - SearchMethod - { sSearch = nodeSearch (toxDHT tox) (nodesOfInterest $ toxRouting tox) - , sNearestNodes = nearNodes tox - , sTarget = target - , sInterval = nodeinfoSearchInterval - , sWithResult = \r sr -> return () - } - nic akey = - NodeInfoCallback - { interestingNodeId = target - , listenerId = 2 - , observedAddress = observe akey - , rumoredAddress = assume akey - } - - assume :: AnnounceKey -> POSIXTime -> SockAddr -> NodeInfo -> STM () - assume akey time addr ni = - tput XNodeinfoSearch $ show ("rumor", akey, time, addr, ni) - - observe :: AnnounceKey -> POSIXTime -> NodeInfo -> STM () - observe akey time ni@(nodeAddr -> addr) = do - tput XNodeinfoSearch $ show ("observation", akey, time, addr) - setContactAddr time theirKey ni (txAccount tx) - -gotAddr :: NodeInfo -> ToxToXMPP -> PublicKey -> IO () -gotAddr ni@(nodeAddr -> addr) tx theirKey = do - dhtkey <- (fmap.fmap) snd $ - fmap join $ - atomically $ - traverse readTVar =<< fmap contactKeyPacket <$> getContact theirKey (txAccount tx) - forM_ dhtkey $ gotAddr' ni tx theirKey - -gotAddr' :: NodeInfo -> ToxToXMPP -> PublicKey -> Tox.DHTPublicKey -> IO () -gotAddr' ni@(nodeAddr -> addr) tx theirKey theirDhtKey = atomically blee - - where - myPublicKey = toPublic $ userSecret (txAccount tx) - me = key2id myPublicKey - akey = akeyConnect (txAnnouncer tx) me theirKey - - blee = do - scheduleImmediately (txAnnouncer tx) akey $ - ScheduledItem $ getCookie ni (activeSesh addr) (getContact theirKey (txAccount tx)) - - tox :: Tox JabberClients - tox = txTox tx - - byAddr :: TVar (Map.Map SockAddr Tox.NetCryptoSession) - byAddr = Tox.netCryptoSessions (toxCryptoSessions tox) - - crypto = Tox.transportCrypto $ toxCryptoSessions tox - - readNcVar :: (Tox.NetCryptoSession -> TVar b) -> SockAddr -> STM (Maybe b) - readNcVar v addr = traverse readTVar =<< fmap v . Map.lookup addr <$> readTVar byAddr - - chillSesh :: SockAddr -> STM (Maybe (Status Tox.ToxProgress)) - chillSesh = readNcVar Tox.ncState - - activeSesh :: SockAddr -> STM Bool - activeSesh a = chillSesh a >>= return . \case - Just Established -> True - _ -> False - - readCookie :: SockAddr -> STM (Maybe (UponCookie (Tox.Cookie Encrypted))) - readCookie = readNcVar Tox.ncCookie - readCookie' :: SockAddr -> STM (Maybe (Tox.Cookie Encrypted)) - readCookie' = fmap join . (fmap.fmap) Tox.toMaybe . readCookie - - client :: Network.Tox.DHT.Handlers.Client - client = toxDHT tox - - getCookie - :: NodeInfo - -> STM Bool - -> STM (Maybe Contact) - -> Announcer - -> AnnounceKey - -> POSIXTime - -> STM (IO ()) - getCookie ni isActive getC ann akey now = getCookieAgain - where - getCookieAgain = do - tput XNodeinfoSearch $ show ("getCookieAgain", akey) - mbContact <- getC - case mbContact of - Nothing -> return $ return () - Just contact -> do - active <- isActive - return $ when (not active) getCookieIO - - callRealShakeHands = realShakeHands (userSecret (txAccount tx)) theirKey (dhtpk theirDhtKey) (toxCryptoSessions tox) (nodeAddr ni) - - reschedule n f = scheduleRel ann akey f n - reschedule' n f = reschedule n (ScheduledItem $ \_ _ now -> f now) - - cookieMaxAge = 60 * 5 - - getCookieIO :: IO () - getCookieIO = do - dput XUnused "getCookieIO - entered" - cookieRequest crypto client myPublicKey ni >>= \case - Nothing -> atomically $ reschedule' 5 (const getCookieAgain) - Just cookie -> do - void $ callRealShakeHands cookie - cookieCreationStamp <- getPOSIXTime - let shaker :: POSIXTime -> STM (IO ()) - shaker now = do - active <- isActive - if (active) - then return $ return () - else if (now > cookieCreationStamp + cookieMaxAge) - then return $ - dput XUnused "getCookieIO/shaker - cookie expired" >> - getCookieIO - else do - reschedule' 5 shaker - return . void $ callRealShakeHands cookie - atomically $ reschedule' 5 shaker - -realShakeHands :: SecretKey -> PublicKey -> PublicKey -> Tox.NetCryptoSessions -> SockAddr -> Tox.Cookie Encrypted -> IO Bool -realShakeHands myseckey theirpubkey theirDhtKey allsessions saddr cookie = do - dput XUnused "realShakeHands" - let hp = - HParam - { hpOtherCookie = cookie - , hpMySecretKey = myseckey - , hpCookieRemotePubkey = theirpubkey - , hpCookieRemoteDhtkey = theirDhtKey - , hpTheirBaseNonce = Nothing - , hpTheirSessionKeyPublic = Nothing - } - newsession <- generateSecretKey - timestamp <- getPOSIXTime - (myhandshake, ioAction) <- - atomically $ - Tox.freshCryptoSession allsessions saddr newsession timestamp hp - ioAction - -- send handshake - isJust <$> forM myhandshake (Tox.sendHandshake allsessions saddr) - -dispatch :: ToxToXMPP -> ContactEvent -> IO () -dispatch tx (SessionEstablished theirKey) = stopConnecting tx theirKey "established" -dispatch tx (SessionTerminated theirKey) = startConnecting tx theirKey "terminated" -dispatch tx (AddrChange theirKey saddr) = gotAddr saddr tx theirKey -dispatch tx (PolicyChange theirkey TryingToConnect ) = startConnecting tx theirkey "policy" -dispatch tx (PolicyChange theirkey policy ) = stopConnecting tx theirkey "policy" -dispatch tx (OnionRouted theirKey (OnionDHTPublicKey pkey)) = gotDhtPubkey pkey tx theirKey -dispatch tx (OnionRouted theirkey (OnionFriendRequest fr) ) = do - let ToxToXMPP { txAnnouncer = acr - , txAccount = acnt - , txPresence = st } = tx - k2c <- atomically $ do - refs <- readTVar (accountExtra acnt) - k2c <- Map.intersectionWith (,) refs <$> readTVar (ckeyToChan st) - clients <- readTVar (clients st) - return $ Map.intersectionWith (,) k2c clients - -- TODO: Below we're using a hard coded default as their jabber user id. - -- This isn't the right thing, but we don't know their user-id. Perhaps - -- there should be a way to parse it out of the friend request text. Maybe - -- after a zero-termination, or as visible text (nospam:...). - let theirjid = key2jid default_nospam theirkey - forM_ k2c $ \((PerClient{pcDeliveredFRs},conn),client) -> do - alreadyDelivered <- atomically $ do - frs <- readTVar pcDeliveredFRs - writeTVar pcDeliveredFRs $ Set.insert fr frs - return $ Set.member fr frs - when (not alreadyDelivered) $ do - self <- localJID (clientUser client) (clientProfile client) (clientResource client) - ask <- presenceSolicitation theirjid self - -- TODO Send friend-request text as an instant message or at least - -- embed it in the stanza as a element. - sendModifiedStanzaToClient ask (connChan conn) - -interweave :: [a] -> [a] -> [a] -interweave [] ys = ys -interweave (x:xs) ys = x : interweave ys xs - -akeyDHTKeyShare :: Announcer -> NodeId -> PublicKey -> AnnounceKey -akeyDHTKeyShare announcer me them = - packAnnounceKey announcer $ "dhtkey(" ++ (take 8 $ show me) ++ ")" ++ show (key2id them) - -akeyConnect :: Announcer -> NodeId -> PublicKey -> AnnounceKey -akeyConnect announcer me them = - packAnnounceKey announcer $ "connect(" ++ (take 8 $ show me) ++ ")" ++ show (key2id them) - - --- | Returns a list of nospam values to use for friend requests to send to a --- remote peer. This list is non-empty only when it is desirable to send --- friend requests. -checkSoliciting :: PresenceState -> PublicKey -> PublicKey -> Contact -> IO [NoSpam] -checkSoliciting presence me them contact = do - let theirhost = T.pack $ show (key2id them) ++ ".tox" - myhost = T.pack $ show (key2id me) ++ ".tox" - xs <- getBuddiesAndSolicited presence myhost $ \h -> do - return $ T.toLower h == T.toLower theirhost - return $ do - (is_buddy,their_u,my_uid,xmpp_client_profile) <- xs - guard $ xmpp_client_profile == myhost - NoSpamId nospam _ <- case fmap T.unpack $ their_u of - Just ('$':_) -> maybeToList $ readMaybe $ T.unpack $ unsplitJID (their_u,theirhost,Nothing) - Just ('0':'x':_) -> maybeToList $ readMaybe $ T.unpack $ unsplitJID (their_u,theirhost,Nothing) - _ -> maybeToList $ readMaybe $ T.unpack $ key2jid default_nospam them - return nospam - -nearNodes :: Tox extra -> NodeId -> STM [NodeInfo] -nearNodes tox nid = do - bkts4 <- readTVar $ routing4 $ toxRouting tox - bkts6 <- readTVar $ routing6 $ toxRouting tox - let nss = - map - (R.kclosest (searchSpace (toxQSearch tox)) searchK nid) - [bkts4, bkts6] - return $ foldr interweave [] nss - -startConnecting0 :: ToxToXMPP -> PublicKey -> Contact -> String -> IO () -startConnecting0 tx them contact reason = do - dput XMan $ "START CONNECTING " ++ show (key2id them) ++ "("++reason++")" - -- TODO When a connection is already established, this function should - -- be a no-op. This occurs when an XMPP client disconnects and - -- reconnects while a session is established. - let ToxToXMPP { txTox = tox - , txAnnouncer = announcer - , txAccount = acnt } = tx - let nearNodes nid = do - bkts4 <- readTVar $ routing4 $ toxRouting tox - bkts6 <- readTVar $ routing6 $ toxRouting tox - let nss = map (R.kclosest (searchSpace (toxQSearch tox)) searchK nid) - [bkts4,bkts6] - return $ foldr interweave [] nss - wanted <- atomically $ (==Just TryingToConnect) <$> readTVar (contactPolicy contact) - let mypub = toPublic $ userSecret acnt - me = key2id mypub - soliciting <- checkSoliciting (txPresence tx) mypub them contact - when wanted $ do - akey <- return $ akeyDHTKeyShare announcer me them - -- We send this packet every 30 seconds if there is more - -- than one peer (in the 8) that says they our friend is - -- announced on them. This packet can also be sent through - -- the DHT module as a DHT request packet (see DHT) if we - -- know the DHT public key of the friend and are looking - -- for them in the DHT but have not connected to them yet. - -- 30 second is a reasonable timeout to not flood the - -- network with too many packets while making sure the - -- other will eventually receive the packet. Since packets - -- are sent through every peer that knows the friend, - -- resending it right away without waiting has a high - -- likelihood of failure as the chances of packet loss - -- happening to all (up to to 8) packets sent is low. - -- - let meth = SearchMethod (toxQSearch tox) onResult nearNodes (key2id them) 30 - where - onResult theirkey rendezvous = do - dkey <- Tox.getContactInfo tox - let tr = Tox.toxToRoute tox - route = Tox.AnnouncedRendezvous theirkey rendezvous - dput XMan $ unwords [ take 8 (show $ key2id mypub) ++ ":" - , "Sending my DHT-key" - , show (key2id $ Tox.dhtpk dkey) - , "to" - , show (key2id theirkey) - , "via" - , show (Tox.rendezvousNode rendezvous) - ] - sendMessage tr route (mypub,Tox.OnionDHTPublicKey dkey) - forM_ soliciting $ \cksum@(NoSpam nospam _)-> do - dput XMan $ unwords [ take 8 (show $ key2id mypub) ++ ":" - , "Sending friend-request" - , "with nospam" - , "(" ++ nospam64 cksum ++ "," ++nospam16 cksum ++ ")" - , "to" - , show (key2id theirkey) - , "via" - , show (Tox.rendezvousNode rendezvous) - ] - let fr = FriendRequest - { friendNoSpam = nospam - , friendRequestText = "XMPP friend request" - } - sendMessage tr route (mypub,Tox.OnionFriendRequest fr) - scheduleSearch announcer akey meth them - -startConnecting :: ToxToXMPP -> PublicKey -> String -> IO () -startConnecting tx them reason = do - mc <- atomically $ HashMap.lookup (key2id them) - <$> readTVar (contacts $ txAccount tx) - forM_ mc $ flip (startConnecting0 tx them) reason - - -stopConnecting :: ToxToXMPP -> PublicKey -> String -> IO () -stopConnecting ToxToXMPP{txAnnouncer=announcer,txAccount=acnt} them reason = do - dput XMan $ "STOP CONNECTING " ++ show (key2id them) ++ "("++reason++")" - let pub = toPublic $ userSecret acnt - me = key2id pub - akeyC = akeyConnect announcer me them - akeyD = akeyDHTKeyShare announcer me them - cancel announcer akeyC - cancel announcer akeyD - -forkAccountWatcher :: Account JabberClients -> Tox JabberClients -> PresenceState -> Announcer -> IO ThreadId -forkAccountWatcher acc tox st announcer = forkIO $ do - myThreadId >>= flip labelThread ("tox-xmpp:" - ++ show (key2id $ toPublic $ userSecret acc)) - (chan,cs) <- atomically $ do - chan <- dupTChan $ eventChan acc -- duplicate broadcast channel for reading. - contacts <- readTVar (contacts acc) - return (chan,contacts) - let tx = ToxToXMPP { txAnnouncer = announcer - , txAccount = acc - , txPresence = st - , txTox = tox - } - forM_ (HashMap.toList cs) $ \(them,c) -> do - startConnecting0 tx (id2key them) c "enabled account" - - -- Loop endlessly until accountExtra is null. - fix $ \loop -> do - mev <- atomically $ - (Just <$> readTChan chan) - `orElse` do - refs <- readTVar $ accountExtra acc - check $ Map.null refs - return Nothing - - forM_ mev $ \ev -> dispatch tx ev >> loop - - cs <- atomically $ readTVar (contacts acc) - forM_ (HashMap.toList cs) $ \(them,c) -> do - stopConnecting tx (id2key them) "disabled account" - - -toxQSearch :: Tox extra -> Search Tox.NodeId (IP, PortNumber) Nonce32 Tox.NodeInfo Tox.Rendezvous -toxQSearch tox = Tox.toxidSearch (Tox.onionTimeout tox) (Tox.toxCryptoKeys tox) (Tox.toxOnion tox) - -toxAnnounceInterval :: POSIXTime -toxAnnounceInterval = 15 - - - -- cgit v1.2.3