{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE ViewPatterns #-} module ToxToXMPP ( forkAccountWatcher , JabberClients , PerClient , initPerClient , toxQSearch , toxAnnounceInterval , xmppToTox , toxToXmpp , interweave ) where import Control.Applicative 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 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.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 toxToXmpp :: Monad m => SockAddr -> PublicKey -> Text -> Conduit Tox.CryptoMessage m XML.Event toxToXmpp laddr me theirhost = do CL.sourceList $ XMPP.greet' "jabber:server" theirhost let me_u = T.pack $ show (key2id me) awaitForever $ \case UpToN { msgID = MESSAGE , msgBytes = bs } -> do xmppInstantMessage "jabber:server" (Just $ "root@" <> theirhost) -- /from/ (Just $ unsplitJID (Just me_u,T.pack (show laddr),Nothing)) -- /to/ should match local address of this node. [] (T.decodeUtf8 bs) toxmsg | msgID toxmsg == PacketRequest -> return () toxmsg -> do xmppInstantMessage "jabber:server" (Just theirhost) -- /from/ (Just $ unsplitJID (Just me_u,T.pack (show laddr),Nothing)) -- /to/ should match local address of this node. [ attr "style" "font-weight:bold; color:red" ] (T.pack $ show $ msgID toxmsg) xmppInstantMessage :: Monad m => Text -> Maybe Text -> Maybe Text -> [(Name, [Content])] -> Text -> ConduitM i Event m () xmppInstantMessage namespace mfrom mto style text = do let ns n = n { nameNamespace = Just namespace } C.yield $ EventBeginElement (ns "message") ( maybe id (\t->(attr "from" t:)) mfrom $ maybe id (\t->(attr "to" t:)) mto $ [attr "type" "normal" ] ) C.yield $ EventBeginElement (ns "body") [] C.yield $ EventContent $ ContentText text C.yield $ EventEndElement (ns "body") C.yield $ EventBeginElement "{http://jabber.org/protocol/xhtml-im}html" [] C.yield $ EventBeginElement "{http://www.w3.org/1999/xhtml}body" [] C.yield $ EventBeginElement "{http://www.w3.org/1999/xhtml}p" style C.yield $ EventContent $ ContentText text C.yield $ EventEndElement "{http://www.w3.org/1999/xhtml}p" C.yield $ EventEndElement "{http://www.w3.org/1999/xhtml}body" 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