summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoe Crayne <joe@jerkface.net>2018-09-08 06:37:10 -0400
committerJoe Crayne <joe@jerkface.net>2018-11-03 10:23:45 -0400
commit36cd21f0b42c09cbcf3a215afbcd754cc37d1c4e (patch)
tree548a3c6eb5c03692327f561a6d5afbcf3c1d5f4e
parent0c7768ba8eb62a6a74176f737a1c9c42308d5a8c (diff)
Switched to new session tracker.
Diffstat
-rw-r--r--ToxManager.hs8
-rw-r--r--dht-client.cabal4
-rw-r--r--examples/dhtd.hs816
-rw-r--r--src/Network/Tox.hs165
-rw-r--r--src/Network/Tox/AggregateSession.hs127
5 files changed, 274 insertions, 846 deletions
diff --git a/ToxManager.hs b/ToxManager.hs
index 44b7a5ef..4ea6736d 100644
--- a/ToxManager.hs
+++ b/ToxManager.hs
@@ -39,12 +39,10 @@ import qualified Network.Tox as Tox
39 ;import Network.Tox 39 ;import Network.Tox
40import Network.Tox.AggregateSession 40import Network.Tox.AggregateSession
41import Network.Tox.ContactInfo as Tox 41import Network.Tox.ContactInfo as Tox
42import qualified Network.Tox.Crypto.Handlers as Tox
43import Network.Tox.DHT.Handlers (nodeSearch, nodesOfInterest) 42import Network.Tox.DHT.Handlers (nodeSearch, nodesOfInterest)
44import Network.Tox.DHT.Handlers 43import Network.Tox.DHT.Handlers
45import qualified Network.Tox.DHT.Transport as Tox 44import qualified Network.Tox.DHT.Transport as Tox
46 ;import Network.Tox.DHT.Transport (FriendRequest (..), dhtpk) 45 ;import Network.Tox.DHT.Transport (FriendRequest (..), dhtpk)
47import Network.Tox.Handshake (HandshakeParams (..))
48import Network.Tox.NodeId 46import Network.Tox.NodeId
49import qualified Network.Tox.Onion.Handlers as Tox 47import qualified Network.Tox.Onion.Handlers as Tox
50import qualified Network.Tox.Onion.Transport as Tox 48import qualified Network.Tox.Onion.Transport as Tox
@@ -414,14 +412,10 @@ gotAddr' ni@(nodeAddr -> addr) tx theirKey theirDhtKey = atomically blee
414 return $ when (not active) getCookieIO 412 return $ when (not active) getCookieIO
415 413
416 callRealShakeHands cookie = do 414 callRealShakeHands cookie = do
417 {-
418 forM_ (nodeInfo (key2id $ dhtpk theirDhtKey) (nodeAddr ni)) $ \ni' -> do 415 forM_ (nodeInfo (key2id $ dhtpk theirDhtKey) (nodeAddr ni)) $ \ni' -> do
419 hs <- cacheHandshake (toxHandshakeCache tox) (userSecret (txAccount tx)) theirKey ni' cookie 416 hs <- cacheHandshake (toxHandshakeCache tox) (userSecret (txAccount tx)) theirKey ni' cookie
420 dput XNetCrypto $ show addr ++ "<-- handshake " ++ show (key2id theirKey) 417 dput XNetCrypto $ show addr ++ "<-- handshake " ++ show (key2id theirKey)
421 sendMessage (toxHandshakes tox) (nodeAddr ni) hs 418 sendMessage (toxHandshakes tox) (nodeAddr ni) hs
422 -}
423 realShakeHands (userSecret (txAccount tx)) theirKey (dhtpk theirDhtKey) (toxCryptoSessions tox) (nodeAddr ni) cookie
424
425 419
426 reschedule n f = scheduleRel ann akey f n 420 reschedule n f = scheduleRel ann akey f n
427 reschedule' n f = reschedule n (ScheduledItem $ \_ _ now -> f now) 421 reschedule' n f = reschedule n (ScheduledItem $ \_ _ now -> f now)
@@ -457,6 +451,7 @@ gotAddr' ni@(nodeAddr -> addr) tx theirKey theirDhtKey = atomically blee
457 atomically $ reschedule' 5 shaker 451 atomically $ reschedule' 5 shaker
458 452
459 453
454{-
460realShakeHands :: SecretKey -> PublicKey -> PublicKey -> Tox.NetCryptoSessions -> SockAddr -> Tox.Cookie Encrypted -> IO Bool 455realShakeHands :: SecretKey -> PublicKey -> PublicKey -> Tox.NetCryptoSessions -> SockAddr -> Tox.Cookie Encrypted -> IO Bool
461realShakeHands myseckey theirpubkey theirDhtKey allsessions saddr cookie = do 456realShakeHands myseckey theirpubkey theirDhtKey allsessions saddr cookie = do
462 dput XUnused "realShakeHands" 457 dput XUnused "realShakeHands"
@@ -477,6 +472,7 @@ realShakeHands myseckey theirpubkey theirDhtKey allsessions saddr cookie = do
477 ioAction 472 ioAction
478 -- send handshake 473 -- send handshake
479 isJust <$> forM myhandshake (Tox.sendHandshake allsessions saddr) 474 isJust <$> forM myhandshake (Tox.sendHandshake allsessions saddr)
475-}
480 476
481 477
482 478
diff --git a/dht-client.cabal b/dht-client.cabal
index 55ca6a04..29cf7a39 100644
--- a/dht-client.cabal
+++ b/dht-client.cabal
@@ -150,9 +150,13 @@ library
150 ToxManager 150 ToxManager
151 XMPPToTox 151 XMPPToTox
152 DebugUtil 152 DebugUtil
153 Data.IntervalSet
153 Data.Tox.Message 154 Data.Tox.Message
154 HandshakeCache 155 HandshakeCache
156 Network.Lossless
157 Network.SessionTransports
155 Network.Tox.AggregateSession 158 Network.Tox.AggregateSession
159 Network.Tox.Session
156 160
157 build-depends: base 161 build-depends: base
158 , containers 162 , containers
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 5bc2b87a..7c66fd73 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -1,5 +1,4 @@
1{-# LANGUAGE BangPatterns #-} 1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE ViewPatterns #-}
3{-# LANGUAGE CPP #-} 2{-# LANGUAGE CPP #-}
4{-# LANGUAGE ExistentialQuantification #-} 3{-# LANGUAGE ExistentialQuantification #-}
5{-# LANGUAGE FlexibleContexts #-} 4{-# LANGUAGE FlexibleContexts #-}
@@ -13,10 +12,12 @@
13{-# LANGUAGE PatternSynonyms #-} 12{-# LANGUAGE PatternSynonyms #-}
14{-# LANGUAGE RankNTypes #-} 13{-# LANGUAGE RankNTypes #-}
15{-# LANGUAGE RecordWildCards #-} 14{-# LANGUAGE RecordWildCards #-}
15{-# LANGUAGE RecursiveDo #-}
16{-# LANGUAGE ScopedTypeVariables #-} 16{-# LANGUAGE ScopedTypeVariables #-}
17{-# LANGUAGE TupleSections #-} 17{-# LANGUAGE TupleSections #-}
18{-# LANGUAGE TypeFamilies #-} 18{-# LANGUAGE TypeFamilies #-}
19{-# LANGUAGE TypeOperators #-} 19{-# LANGUAGE TypeOperators #-}
20{-# LANGUAGE ViewPatterns #-}
20 21
21module Main where 22module Main where
22 23
@@ -29,20 +30,18 @@ import Control.Monad
29import Control.Monad.IO.Class (liftIO) 30import Control.Monad.IO.Class (liftIO)
30import Data.Array.MArray (getAssocs) 31import Data.Array.MArray (getAssocs)
31import Data.Bool 32import Data.Bool
33import Data.Bits (xor)
32import Data.Char 34import Data.Char
33import Data.Conduit as C 35import Data.Conduit as C
34import qualified Data.Conduit.List as C 36import qualified Data.Conduit.List as C
35import Data.Function 37import Data.Function
38import Data.Functor.Identity
36import Data.Hashable 39import Data.Hashable
37import Data.List 40import Data.List
38import Data.Word
39import Data.InOrOut
40import qualified Data.IntMap.Strict as IntMap 41import qualified Data.IntMap.Strict as IntMap
41import qualified Data.Map.Strict as Map 42import qualified Data.Map.Strict as Map
42import Data.Maybe 43import Data.Maybe
43import qualified Data.Set as Set 44import qualified Data.Set as Set
44import Data.Tuple
45import Data.Time.Clock
46import qualified Data.XML.Types as XML 45import qualified Data.XML.Types as XML
47import GHC.Conc (threadStatus,ThreadStatus(..)) 46import GHC.Conc (threadStatus,ThreadStatus(..))
48import GHC.Stats 47import GHC.Stats
@@ -64,8 +63,6 @@ import qualified Data.HashMap.Strict as HashMap
64import qualified Data.Text as T 63import qualified Data.Text as T
65import qualified Data.Text.Encoding as T 64import qualified Data.Text.Encoding as T
66import System.Posix.Signals 65import System.Posix.Signals
67import qualified Data.Array.Unboxed as U
68import qualified Data.Conduit as Conduit
69 66
70import Announcer 67import Announcer
71import Announcer.Tox 68import Announcer.Tox
@@ -84,8 +81,6 @@ import qualified Network.BitTorrent.MainlineDHT as Mainline
84import qualified Network.Tox as Tox 81import qualified Network.Tox as Tox
85import qualified Data.ByteString.Lazy as L 82import qualified Data.ByteString.Lazy as L
86import qualified Data.ByteString.Char8 as B 83import qualified Data.ByteString.Char8 as B
87import qualified Data.Text.Encoding as E
88import qualified Data.Text.Encoding.Error as E
89import Control.Concurrent.Tasks 84import Control.Concurrent.Tasks
90import System.IO.Error 85import System.IO.Error
91import qualified Data.Serialize as S 86import qualified Data.Serialize as S
@@ -99,23 +94,17 @@ import qualified Network.Tox.DHT.Transport as Tox
99import qualified Network.Tox.DHT.Handlers as Tox 94import qualified Network.Tox.DHT.Handlers as Tox
100import qualified Network.Tox.Onion.Transport as Tox 95import qualified Network.Tox.Onion.Transport as Tox
101import qualified Network.Tox.Onion.Handlers as Tox 96import qualified Network.Tox.Onion.Handlers as Tox
102import qualified Network.Tox.Crypto.Transport as Tox (CryptoMessage(..),putCryptoMessage,getCryptoMessage) 97import qualified Network.Tox.Crypto.Transport as Tox (CryptoMessage(..),handshakeCookie, pattern PacketRequest, pattern PING)
103import qualified Network.Tox.Crypto.Handlers as Tox
104import Data.Typeable 98import Data.Typeable
105import Network.Tox.ContactInfo as Tox 99import Network.Tox.ContactInfo as Tox
106import OnionRouter 100import OnionRouter
107import Data.PacketQueue
108import qualified Data.Word64Map as W64 101import qualified Data.Word64Map as W64
109import Network.Tox.AggregateSession 102import Network.Tox.AggregateSession
110import System.FilePath 103import qualified Network.Tox.Session as Tox (Session)
111import System.Process 104 ;import Network.Tox.Session hiding (Session)
112import System.Posix.IO
113import Data.Word64RangeMap
114import Network.Tox.Crypto.Transport
115import Data.Conduit.Cereal
116import qualified Data.Conduit.Binary as Conduit
117 105
118-- Presence imports. 106-- Presence imports.
107import Connection.Tcp (TCPStatus)
119import ConsoleWriter 108import ConsoleWriter
120import Presence 109import Presence
121import XMPPServer 110import XMPPServer
@@ -123,8 +112,6 @@ import Connection
123import ToxToXMPP 112import ToxToXMPP
124import XMPPToTox 113import XMPPToTox
125import qualified Connection.Tcp as Tcp (ConnectionEvent(..),noCleanUp,TCPStatus) 114import qualified Connection.Tcp as Tcp (ConnectionEvent(..),noCleanUp,TCPStatus)
126import Control.Concurrent.Supply
127import qualified Data.CyclicBuffer as CB
128import DPut 115import DPut
129 116
130 117
@@ -309,7 +296,6 @@ data Session = Session
309 , dhts :: Map.Map String DHT 296 , dhts :: Map.Map String DHT
310 , externalAddresses :: IO [SockAddr] 297 , externalAddresses :: IO [SockAddr]
311 , swarms :: Mainline.SwarmsDatabase 298 , swarms :: Mainline.SwarmsDatabase
312 , cryptosessions :: Tox.NetCryptoSessions
313 , toxkeys :: TVar Tox.AnnouncedKeys 299 , toxkeys :: TVar Tox.AnnouncedKeys
314 , roster :: Tox.ContactInfo JabberClients 300 , roster :: Tox.ContactInfo JabberClients
315 , announceToLan :: IO () 301 , announceToLan :: IO ()
@@ -383,17 +369,6 @@ clientSession s@Session{..} sock cnum h = do
383 hPutClient h $ showReport (zip (map (drop 1 . show) allDebugTags) (map f vs)) 369 hPutClient h $ showReport (zip (map (drop 1 . show) allDebugTags) (map f vs))
384 let readHex :: (Read n, Integral n) => String -> Maybe n 370 let readHex :: (Read n, Integral n) => String -> Maybe n
385 readHex s = readMaybe ("0x" ++ s) 371 readHex s = readMaybe ("0x" ++ s)
386 strToSession :: String -> IO (Either String Tox.NetCryptoSession)
387 strToSession idStr
388 = case readHex idStr of
389 Nothing -> return (Left "Unable to parse session id")
390 Just id -> do
391 sessions <- filter ((==id) . Tox.ncSessionId)
392 . concat
393 . Map.elems <$> (atomically $ readTVar (Tox.netCryptoSessionsByKey cryptosessions))
394 case sessions of
395 [] -> return (Left "Session not found")
396 (x:xs) -> return (Right x)
397 let mkrow :: (SecretKey, PublicKey) -> (String,String) 372 let mkrow :: (SecretKey, PublicKey) -> (String,String)
398 mkrow (a,b) | Just x <- encodeSecret a= (B.unpack x, show (Tox.key2id b)) 373 mkrow (a,b) | Just x <- encodeSecret a= (B.unpack x, show (Tox.key2id b))
399 mkrow _ = error (concat ["Assertion fail in 'mkrow' function at ", __FILE__, ":", show __LINE__]) 374 mkrow _ = error (concat ["Assertion fail in 'mkrow' function at ", __FILE__, ":", show __LINE__])
@@ -690,247 +665,6 @@ clientSession s@Session{..} sock cnum h = do
690 setVerbose tag 665 setVerbose tag
691 hPutClient h $ "Showing " ++ show tag ++ " messages." 666 hPutClient h $ "Showing " ++ show tag ++ " messages."
692 667
693 -- list information about current netcrypto sesssions
694 ("sessions", s) | "" <- strp s
695 -> cmd0 $ do
696 sessions <- concat . Map.elems <$> (atomically $ readTVar (Tox.netCryptoSessionsByKey cryptosessions))
697 let sessionsReport = mapM showPerSession sessions
698 headers = ["SessionID", "YourKey", "TheirKey", "Address", "NextMsg", "Dropped" {-,"Handled","Unhandled" -}
699 ,"Progress" ]
700 showPerSession (Tox.NCrypto
701 { ncState = progressVar
702 , ncSessionId = id
703 , ncMyPublicKey = yourkey
704 , ncTheirPublicKey = theirkey
705 , ncLastNMsgs = lastN
706 , ncSockAddr = sockAddr
707 }) = do
708 progress <- atomically $ readTVar progressVar
709 (num,dropped) <- atomically $ liftA2 (,) (CB.getTotal lastN) (CB.getDropped lastN)
710 as <- atomically (CB.cyclicBufferViewList lastN)
711 let (h,u) = partition (fst . snd) as
712 countHandled = length h
713 countUnhandled = length u
714 return [ printf "%x" id -- "SessionID"
715 , take 8 $ show (Tox.key2id yourkey) -- "YourKey"
716 , show (Tox.key2id theirkey)-- "TheirKey"
717 , drop 11 $ show sockAddr -- "Address"
718 , show num -- "NextMsg"
719 , show dropped -- "Dropped"
720 -- , show countHandled -- "Handled"
721 -- , show countUnhandled -- "Unhandled"
722 , show progress
723 ]
724 if null sessions
725 then hPutClient h "No sessions."
726 else do
727 rows <- sessionsReport
728 hPutClient h (showColumns (headers:rows))
729 -- session <N> set key val
730 ("session",s) | (idStr,"set",unstripped) <- twoWords s
731 , (key,val,unstripped2) <- twoWords unstripped
732 , let setmap = [("ncRequestInterval", \s x -> writeTVar (Tox.ncRequestInterval s) x)
733 ,("ncAliveInterval", \s x -> writeTVar (Tox.ncAliveInterval s) x)
734 ,("ncIdleEvent", \s x -> writeTVar (Tox.ncIdleEvent s) x)
735 ,("ncTimeOut", \s x -> writeTVar (Tox.ncTimeOut s) x)
736 ]
737 , Just stmFunc <- Data.List.lookup key setmap
738 -> cmd0 $ do
739 lrSession <- strToSession idStr
740 case lrSession of
741 Left s -> hPutClient h s
742 Right session -> do
743 case readMaybe val of
744 Just (x::Int) -> do
745 atomically (stmFunc session x)
746 hPutClient h $ "Session " ++ idStr ++ ": " ++ key ++ " = " ++ val
747 _ ->
748 hPutClient h $ "Invalid " ++ key ++ " value: " ++ val
749
750 -- session <N> interval factor
751 ("session",s) | (idStr,"interval",unstripped) <- twoWords s
752 , val <- strp unstripped
753 -> cmd0 $ do
754 lrSession <- strToSession idStr
755 let displayIntervals session = atomically $ do
756 intervals <- forM [Tox.ncRequestInterval,Tox.ncAliveInterval, Tox.ncIdleEvent, Tox.ncTimeOut] $ \i -> readTVar (i session)
757 let keys = ["ncRequestInterval","ncAliveInterval","ncIdleEvent","ncTimeOut"]
758 return (intercalate "\n" $
759 map (\(key,val) -> "Session " ++ idStr ++ ": " ++ key ++ " = " ++ val)
760 (zip keys (map show intervals)))
761 case lrSession of
762 Left s -> hPutClient h s
763 Right session -> do
764 case readMaybe val of
765 Just (factor::Double) -> do
766 atomically $ do
767 modifyTVar (Tox.ncRequestInterval session) (round . (*factor) . fromIntegral)
768 modifyTVar (Tox.ncAliveInterval session) (round . (*factor) . fromIntegral)
769 modifyTVar (Tox.ncIdleEvent session) (round . (*factor) . fromIntegral)
770 modifyTVar (Tox.ncTimeOut session) (round . (*factor) . fromIntegral)
771 displayIntervals session >>= hPutClient h
772 _ -> displayIntervals session >>= hPutClient h . (("No parse (" ++ show val ++ ").\n") ++)
773
774 -- report error when setting invalid keys
775 ("session",s) | (idStr,"set",unstripped) <- twoWords s
776 , (key,val,unstripped2) <- twoWords unstripped
777 -> cmd0 $ do
778 lrSession <- strToSession idStr
779 case lrSession of
780 Left s -> hPutClient h s
781 Right session -> hPutClient h $ "What is " ++ key ++ "?"
782 -- session <N> tail
783 -- show context (latest lossless messages)
784 ("session", s) | (idStr,tailcmd,unstripped) <- twoWords s
785 , "" <- strp unstripped
786 , tailcmd `elem` ["tail","context"]
787 -> cmd0 $ do
788 lrSession <- strToSession idStr
789 case lrSession of
790 Left s -> hPutClient h s
791 Right session -> do
792 msgs <- atomically $ CB.cyclicBufferViewList (Tox.ncLastNMsgs session)
793 hPutClientB h (B.unlines (map showMsg msgs))
794 -- session <N> me
795 -- display information about how you look to that session
796 ("session", s) | (idStr,"me",unstripped) <- twoWords s
797 , "" <- strp unstripped
798 -> cmd0 $ do
799 lrSession <- strToSession idStr
800 case lrSession of
801 Left s -> hPutClient h s
802 Right session -> do
803 view <- atomically (readTVar (Tox.ncView session) >>= Tox.viewSnapshot)
804 hPutClientB h (vShowMe view 0)
805 -- session <N> them
806 -- display information about the person on the other end of the session
807 ("session", s) | (idStr,them,unstripped) <- twoWords s
808 , "" <- strp unstripped
809 , them `elem` ["them","you"]
810 -> cmd0 $ do
811 lrSession <- strToSession idStr
812 case lrSession of
813 Left s -> hPutClient h s
814 Right session -> do
815 view <- atomically (readTVar (Tox.ncView session) >>= Tox.viewSnapshot)
816 hPutClientB h (vShowThem view 0)
817 -- session <N> online
818 -- send ONLINE packet to session N
819 ("session", s) | (idStr,"online",unstripped) <- twoWords s
820 , stripped <- strp unstripped
821 -> cmd0 $ do
822 lrSession <- strToSession idStr
823 case lrSession of
824 Left s -> hPutClient h s
825 Right session -> do
826 case mbTox of
827 Nothing -> hPutClient h "Requires Tox enabled."
828 Just tox-> do
829 Tox.sendOnline (Tox.toxCryptoKeys tox) session
830 hPutClient h "sent ONLINE"
831 -- session <N> online
832 -- send OFFLINE packet to session N
833 ("session", s) | (idStr,"offline",unstripped) <- twoWords s
834 , stripped <- strp unstripped
835 -> cmd0 $ do
836 lrSession <- strToSession idStr
837 case lrSession of
838 Left s -> hPutClient h s
839 Right session -> do
840 case mbTox of
841 Nothing -> hPutClient h "Requires Tox enabled."
842 Just tox-> do
843 Tox.sendOffline (Tox.toxCryptoKeys tox) session
844 hPutClient h "sent OFFLINE"
845 -- session <N> kill
846 -- send KILL packet to session N
847 ("session", s) | (idStr,"kill",unstripped) <- twoWords s
848 , stripped <- strp unstripped
849 -> cmd0 $ do
850 lrSession <- strToSession idStr
851 case lrSession of
852 Left s -> hPutClient h s
853 Right session -> do
854 case mbTox of
855 Nothing -> hPutClient h "Requires Tox enabled."
856 Just tox-> do
857 Tox.sendKill (Tox.toxCryptoKeys tox) session
858 hPutClient h "sent KillPacket"
859 -- session <N> nick <NICKNAME>
860 -- send NICK packet to session N, setting nick to NICKNAME
861 ("session", s) | (idStr,"nick",unstripped) <- twoWords s
862 , nick <- strp unstripped
863 -> cmd0 $ do
864 lrSession <- strToSession idStr
865 case lrSession of
866 Left s -> hPutClient h s
867 Right session -> do
868 case mbTox of
869 Nothing -> hPutClient h "Requires Tox enabled."
870 Just tox-> do
871 Tox.setNick (Tox.toxCryptoKeys tox) session (B.pack nick)
872 hPutClient h "sent NICKNAME"
873 -- session <N> status <STATUS>
874 -- send USERSTATUS packet to session N, set status to STATUS
875 ("session", s) | (idStr,"status",unstripped) <- twoWords s
876 , statusStr <- strp unstripped
877 -> cmd0 $ do
878 lrSession <- strToSession idStr
879 case lrSession of
880 Left s -> hPutClient h s
881 Right session -> do
882 case mbTox of
883 Nothing -> hPutClient h "Requires Tox enabled."
884 Just tox-> do
885 case readMaybe statusStr of
886 Nothing -> hPutClient h "Unable to parse status"
887 Just status -> do
888 Tox.setStatus (Tox.toxCryptoKeys tox) session status
889 hPutClient h "sent USERSTATUS"
890 -- session <N> typing <TYPINGSTATUS>
891 -- send TYPING packet to session N, set typing to TYPINGSTATUS
892 ("session", s) | (idStr,"typing",unstripped) <- twoWords s
893 , typingstatus <- strp unstripped
894 -> cmd0 $ do
895 lrSession <- strToSession idStr
896 case lrSession of
897 Left s -> hPutClient h s
898 Right session -> do
899 case mbTox of
900 Nothing -> hPutClient h "Requires Tox enabled."
901 Just tox-> do
902 case readMaybe typingstatus of
903 Nothing -> hPutClient h "Unable to parse status"
904 Just status -> do
905 Tox.setTyping (Tox.toxCryptoKeys tox) session status
906 hPutClient h "sent TYPINGSTATUS"
907 -- session <N> statusmsg <MSG>
908 -- send STATUSMESSAGE packet to session N, setting status message to MSG
909 ("session", s) | (idStr,"statusmsg",statusmsg) <- twoWords s
910 -> cmd0 $ do
911 lrSession <- strToSession idStr
912 case lrSession of
913 Left s -> hPutClient h s
914 Right session -> do
915 case mbTox of
916 Nothing -> hPutClient h "Requires Tox enabled."
917 Just tox-> do
918 Tox.setStatusMsg (Tox.toxCryptoKeys tox) session (B.pack statusmsg)
919 hPutClient h "sent STATUSMESSAGE"
920 -- session <N> c <MSG>
921 -- send MESSAGE packet to session N (send chat message MSG)
922 ("session", s) | (idStr,msgcmd,msg) <- twoWords s
923 , msgcmd `elem` ["c","msg","send"]
924 -> cmd0 $ do
925 lrSession <- strToSession idStr
926 case lrSession of
927 Left s -> hPutClient h s
928 Right session -> do
929 case mbTox of
930 Nothing -> hPutClient h "Requires Tox enabled."
931 Just tox-> do
932 Tox.sendChatMsg (Tox.toxCryptoKeys tox) session (B.pack msg)
933 hPutClient h "sent MESSAGE"
934 668
935 ("onion", s) -> cmd0 $ do 669 ("onion", s) -> cmd0 $ do
936 now <- getPOSIXTime 670 now <- getPOSIXTime
@@ -955,11 +689,6 @@ clientSession s@Session{..} sock cnum h = do
955 , "pending: " ++ show (W64.size pqs) ] 689 , "pending: " ++ show (W64.size pqs) ]
956 hPutClient h $ showColumns $ ["","responses","timeouts", "age", "version"]:r 690 hPutClient h $ showColumns $ ["","responses","timeouts", "age", "version"]:r
957 691
958 -- necrypto <FRIEND-TOXID>
959 -- establish a netcrypto session with specified person
960 ("netcrypto", s) -> cmd0 $ do
961 let exes = Map.fromList [("atox",("/usr/bin/tmux -c","atox"))]
962 netcrypto (Map.lookup netname dhts) selectedKey h roster mbTox exes (strp s)
963 ("g", s) | Just DHT{..} <- Map.lookup netname dhts 692 ("g", s) | Just DHT{..} <- Map.lookup netname dhts
964 -> cmd0 $ do 693 -> cmd0 $ do
965 -- arguments: method 694 -- arguments: method
@@ -1309,153 +1038,6 @@ clientSession s@Session{..} sock cnum h = do
1309 1038
1310 _ -> cmd0 $ hPutClient h "error." 1039 _ -> cmd0 $ hPutClient h "error."
1311 1040
1312netcrypto
1313 :: Maybe DHT
1314 -> Maybe PublicKey
1315 -> ClientHandle
1316 -> ContactInfo extra1
1317 -> Maybe (Tox.Tox extra2)
1318 -> Map.Map String (String,String) -- profile name to (multiplexer,exe name) for supported child executables
1319 -> String
1320 -> IO ()
1321netcrypto _ _ h _ Nothing _ _ = hPutClient h "Requires Tox enabled."
1322netcrypto _ Nothing h _ _ _ _ = hPutClient h "No key is selected, see k command."
1323netcrypto (Just (DHT {..})) (Just mypubkey) h roster (Just tox) exes paramStr =
1324 either
1325 (const $
1326 either
1327 (hPutClient h . ("Bad netcrypto target: " ++))
1328 goNodeInfo
1329 (readEither keystr) -- attempt read as NodeInfo type
1330 )
1331 (goPubkey . Tox.id2key) $
1332 readEither keystr -- attempt read as NodeId type
1333 where
1334 params = words paramStr
1335 keystr = bool (head params) "" (null params)
1336 -- TODO:
1337 -- execProfiles:
1338 -- atox@24-25,48-51,64-45 gnome-tox-notifier@24-25,49,50
1339 -- ^-- word64 type values that should be forwarded to this process
1340 execParams=drop 1 params
1341 parseExecParam :: String -> (String,[(Maybe Word64,Maybe Word64)])
1342 parseExecParam param = let (name,drop 1 -> rangesCombined) = span (/='@') param
1343 wordsBy x str = groupBy (const (/=x)) str
1344 rangesUnparsed = wordsBy ',' rangesCombined
1345 parseRange :: String -> (Maybe Word64,Maybe Word64)
1346 parseRange "all" = (Nothing,Nothing)
1347 parseRange x = let (low,drop 1 -> high) = break (==',') x
1348 in (readMaybe low,readMaybe high)
1349 in (name,map parseRange rangesUnparsed)
1350 execs = map parseExecParam execParams
1351
1352
1353 goNodeInfo userkey_nodeinfo = do
1354 msec <-
1355 atomically $ do
1356 fmap userSecret . HashMap.lookup (Tox.key2id mypubkey) <$>
1357 readTVar (accounts roster)
1358 case msec of
1359 Nothing -> hPutClient h "Error getting secret key"
1360 Just sec -> do
1361 let their_pub = Tox.id2key $ Tox.nodeId userkey_nodeinfo
1362 their_addr = Tox.nodeAddr userkey_nodeinfo
1363 let acsVar = accounts (Tox.toxContactInfo tox)
1364 acsmap <- atomically $ readTVar acsVar
1365 case HashMap.lookup (Tox.key2id mypubkey) acsmap of
1366 Nothing -> hPutClient h "Unable to find account for selected key"
1367 Just account -> do
1368 now <- getPOSIXTime
1369 atomically $ do
1370 mcontact <- HashMap.lookup (Tox.nodeId userkey_nodeinfo) <$> readTVar (contacts account)
1371 forM_ mcontact $ \contact -> do
1372 mnid <- fmap (Tox.key2id . Tox.dhtpk . snd) <$> readTVar (contactKeyPacket contact)
1373 forM_ mnid $ \nid -> do
1374 forM_ (Tox.nodeInfo nid their_addr) $ \their_ni -> do
1375 setContactAddr now their_pub their_ni account
1376 sessions <- Tox.netCrypto tox sec their_pub
1377 exeDir <- takeDirectory <$> getExecutablePath
1378 forM_ sessions $ \session -> do
1379 forM_ execs $ \(exekey,ranges) -> do
1380 case Map.lookup exekey exes of
1381 Nothing -> return ()
1382 Just (multiplexer,exename) -> do
1383 let exepath = exeDir </> exename
1384 (myReadFd,myWriteFd) <- System.Posix.IO.createPipe
1385 myRead <- fdToHandle myReadFd
1386 myWrite <- fdToHandle myWriteFd
1387 whoAmI <- atomically $ newTVar mypubkey
1388 whoAreThey <- atomically $ newTVar their_pub
1389 let fdArgs = [show myWriteFd,show myReadFd]
1390 if null multiplexer
1391 then callProcess exepath fdArgs
1392 else do
1393 let (multiplexer_exe,multiplexer_args) = splitAt 1 (words multiplexer)
1394 callProcess multiplexer (multiplexer_args ++ [intercalate " " (exepath:fdArgs)])
1395 -- tell subprocess who is talking to who
1396 B.hPutStr myWrite ("\NUL\NUL" `B.append` S.encode (Tox.key2id mypubkey))
1397 B.hPutStr myWrite ("\NUL\SOH" `B.append` S.encode (Tox.key2id their_pub))
1398 -- add hooks so subprocess is updated on incoming
1399 let makeHook session typ
1400 = \session msg
1401 -> do -- if (getMessageType msg == typ)
1402 me <- atomically $ readTVar whoAmI
1403 when (me /= mypubkey) $ do
1404 atomically $ writeTVar whoAmI mypubkey
1405 B.hPutStr myWrite ("\NUL\NUL" `B.append` S.encode (Tox.key2id mypubkey))
1406 them <- atomically $ readTVar whoAreThey
1407 when (them /= their_pub) $ do
1408 atomically $ writeTVar whoAreThey their_pub
1409 B.hPutStr myWrite ("\NUL\SOH" `B.append` S.encode (Tox.key2id their_pub))
1410 B.hPutStr myWrite (S.runPut $ Tox.putCryptoMessage 0 msg)
1411 return (Just id)
1412 addHooks currentHooks typs = forM_ typs $ \typ -> modifyTVar (Tox.ncHooks session) (Map.insert typ (currentHooks typ ++ [makeHook session typ]))
1413 case ranges of
1414 [(Nothing,Nothing)] -> atomically $ do
1415 typs <- map fromWord64 . filter (/=0) . U.elems <$> readTVar (Tox.ncIncomingTypeArray session)
1416 addHooks (const []) typs
1417 _ -> atomically . forM_ ranges $ \range -> do
1418 case range of
1419 (Just first,Just last) -> do
1420 let typs = map fromWord64 [first .. last]
1421 hooks <- readTVar (Tox.ncHooks session)
1422 let currentHooks typ = fromMaybe [] (Map.lookup typ hooks)
1423 addHooks currentHooks typs
1424 -- forward messages from subprocess
1425 forwardThread <- forkIO $ do
1426 tid <- myThreadId
1427 let sidStr = printf "(%x)" (Tox.ncSessionId session)
1428 labelThread tid (exekey ++ ".forward" ++ sidStr)
1429 let myconduit = Conduit.sourceHandle myRead .| conduitGet2 (Tox.getCryptoMessage 0) -- :: ConduitT i CryptoMessage IO ()
1430 Conduit.runConduit (myconduit .| awaitForever (\msg -> do
1431 let typ = toWord64 (getMessageType msg)
1432 mbSendIt <- liftIO $ atomically (lookupInRangeMap typ (Tox.ncOutHooks session))
1433 case mbSendIt of
1434 Just sendit -> liftIO . void $ sendit (Tox.toxCryptoKeys tox) session msg
1435 Nothing -> return () -- do
1436 -- uncomment to let unhooked pass thru:
1437 -- if lossyness (msgId msg) == Lossless
1438 -- then sendLossless (Tox.toxCryptoKeys tox) session msg
1439 -- else sendLossy (Tox.toxCryptoKeys tox) session msg
1440 ))
1441 -- add hook to killThread on kill packet
1442 atomically $ do
1443 hooks <- readTVar (Tox.ncHooks session)
1444 let currentHooks = fromMaybe [] $ Map.lookup (Msg KillPacket) hooks
1445 let myhook :: Tox.NetCryptoSession -> CryptoMessage -> IO (Maybe (CryptoMessage -> CryptoMessage))
1446 myhook _ _ = killThread forwardThread >> return (Just id)
1447 modifyTVar' (Tox.ncHooks session) (Map.insert (Msg KillPacket) (currentHooks ++ [myhook]))
1448 hPutClient h "Handshake sent"
1449 goPubkey their_pub = do
1450 msec <-
1451 atomically $ do
1452 ks <- map swap <$> myKeyPairs roster
1453 return $ Data.List.lookup mypubkey ks
1454 case msec of
1455 Nothing -> hPutClient h "Error getting secret key"
1456 Just sec -> do
1457 Tox.netCrypto tox sec their_pub
1458 hPutClient h "Handshake sent"
1459 1041
1460readExternals :: (ni -> SockAddr) -> [TVar (BucketList ni)] -> IO [SockAddr] 1042readExternals :: (ni -> SockAddr) -> [TVar (BucketList ni)] -> IO [SockAddr]
1461readExternals nodeAddr vars = do 1043readExternals nodeAddr vars = do
@@ -1533,12 +1115,15 @@ noArgPing f [] x = f x
1533noArgPing _ _ _ = return Nothing 1115noArgPing _ _ _ = return Nothing
1534 1116
1535-- | Create a Conduit Source by repeatedly calling an IO action. 1117-- | Create a Conduit Source by repeatedly calling an IO action.
1536ioToSource :: IO (Maybe x) -> IO () -> C.Source IO x 1118ioToSource :: IO (Maybe x) -> IO () -> ConduitT () x IO ()
1537ioToSource !action !onEOF = liftIO action >>= \case 1119ioToSource !action !onEOF = liftIO action >>= \case
1538 Nothing -> liftIO onEOF 1120 Nothing -> do
1121 dput XNetCrypto "ioToSource terminated."
1122 liftIO onEOF
1539 Just item -> do C.yield item 1123 Just item -> do C.yield item
1540 ioToSource action onEOF 1124 ioToSource action onEOF
1541 1125
1126{-
1542newXmmpSink :: Tox.NetCryptoSession -> C.Sink (Flush Tox.CryptoMessage) IO () 1127newXmmpSink :: Tox.NetCryptoSession -> C.Sink (Flush Tox.CryptoMessage) IO ()
1543newXmmpSink session@(Tox.NCrypto { ncOutgoingQueue = outGoingQVar }) = C.awaitForever $ \flush_cyptomessage -> do 1128newXmmpSink session@(Tox.NCrypto { ncOutgoingQueue = outGoingQVar }) = C.awaitForever $ \flush_cyptomessage -> do
1544 let sendit :: Tox.NetCryptoSession -> Flush Tox.CryptoMessage -> IO () 1129 let sendit :: Tox.NetCryptoSession -> Flush Tox.CryptoMessage -> IO ()
@@ -1563,80 +1148,23 @@ newXmmpSink session@(Tox.NCrypto { ncOutgoingQueue = outGoingQVar }) = C.awaitFo
1563 _ -> return () 1148 _ -> return ()
1564 sendit session Flush = return () 1149 sendit session Flush = return ()
1565 liftIO $ sendit session flush_cyptomessage 1150 liftIO $ sendit session flush_cyptomessage
1151-}
1566 1152
1567 1153
1568-- | Called upon a new Tox friend-connection session with a remote peer in
1569-- order to set up translating conduits that simulate a remote XMPP server.
1570announceToxJabberPeer :: PublicKey -- ^ This node's long-term user key.
1571 -> PublicKey -- ^ Remote tox node's long-term user key.
1572 -> TChan ((SockAddr,ConnectionData), Tcp.ConnectionEvent XML.Event)
1573 -> SockAddr -- ^ Local bind address for incoming Tox packets.
1574 -> SockAddr -- ^ Remote address for this connection.
1575 -> STM Bool
1576 -> C.Source IO Tox.CryptoMessage
1577 -> C.Sink (Flush Tox.CryptoMessage) IO ()
1578 -> IO (Maybe (Tox.NetCryptoSession -> Tox.NetCryptoSession))
1579announceToxJabberPeer me them echan laddr saddr pingflag tsrc tsnk
1580 = do
1581 atomically $ do
1582 v <- newTVar Nothing
1583 writeTChan echan
1584 ( (saddr, ConnectionData (Left (Local laddr)) XMPPServer.Tox (xmppHostname me) v)
1585 , Tcp.Connection pingflag xsrc xsnk )
1586 return Nothing
1587 where
1588 xsrc = tsrc =$= toxToXmpp laddr me (xmppHostname them)
1589 xsnk = flushPassThrough xmppToTox =$= tsnk
1590
1591vShowMe :: Tox.ViewSnapshot -> Int -> B.ByteString
1592vShowMe (Tox.ViewSnapshot { vNick, vStatus, vStatusMsg, vTyping }) indent
1593 = B.unlines
1594 . map doRow $ [ ["Nick: ", vNick ]
1595 , ["Status: ", "(" <> pshow vStatus <> ") " <> vStatusMsg ]
1596 , ["Typing: ", pshow vTyping ]
1597 ]
1598 where (<>) = B.append
1599 space = B.replicate indent ' '
1600 doRow = B.append space . B.concat
1601
1602vShowThem :: Tox.ViewSnapshot -> Int -> B.ByteString
1603vShowThem (Tox.ViewSnapshot { vTheirNick, vTheirStatus, vTheirStatusMsg, vTheirTyping }) indent
1604 = B.unlines
1605 . map doRow $ [ ["Nick: ", vTheirNick ]
1606 , ["Status: ", "(" <> pshow vTheirStatus <> ") " <> vTheirStatusMsg ]
1607 , ["Typing: ", pshow vTheirTyping ]
1608 ]
1609 where (<>) = B.append
1610 space = B.replicate indent ' '
1611 doRow = B.append space . B.concat
1612
1613showMsg ::(Word32, (Bool,(Tox.ViewSnapshot, InOrOut Tox.CryptoMessage))) -> B.ByteString
1614showMsg (n,(flg,(snapshot,iocm))) = B.concat [bool " " "h " flg, showmsg' (snapshot,iocm)]
1615 where
1616 showmsg' (snapshot,In cm) = B.concat [Tox.vTheirNick snapshot,"> ", pshow cm]
1617 showmsg' (snapshot,Out cm) = B.concat [{-utf8boldify-} (Tox.vNick snapshot),": ",pshow cm]
1618 utf8boldify s = boldify (T.decodeUtf8With E.lenientDecode s)
1619 where
1620 boldify :: T.Text -> B.ByteString
1621 boldify j = E.encodeUtf8 $ T.map addIt j
1622 where addIt x = let o = ord x in case o of
1623 _ | o <= 90 && o >= 65 -> chr (o + 119743)
1624 _ | o <= 122 && o >= 97 -> chr (o + 119737)
1625 _ -> x
1626
1627onNewToxSession :: XMPPServer 1154onNewToxSession :: XMPPServer
1628 -> TVar (Map.Map Uniq24 AggregateSession) 1155 -> TVar (Map.Map Uniq24 AggregateSession)
1629 -> ContactInfo extra 1156 -> ContactInfo extra
1630 -> SockAddr 1157 -> SockAddr
1631 -> Tox.NetCryptoSession 1158 -> Tox.Session
1632 -> IO () 1159 -> IO ()
1633onNewToxSession sv ssvar ContactInfo{accounts} addrTox netcrypto = do 1160onNewToxSession sv ssvar ContactInfo{accounts} addrTox netcrypto = do
1634 let them s = Tox.ncTheirPublicKey s 1161 let them s = Tox.longTermKey $ runIdentity cookie -- remote tox key
1162 where Tox.Cookie _ cookie = Tox.handshakeCookie (sReceivedHandshake s)
1635 1163
1636 me s = Tox.ncMyPublicKey s 1164 me s = toPublic $ sOurKey s
1637 1165
1638 onStatusChange :: (Tox.NetCryptoSession -> Tcp.ConnectionEvent XML.Event -> STM ()) 1166 onStatusChange :: (Tox.Session -> Tcp.ConnectionEvent XML.Event -> STM ())
1639 -> AggregateSession -> Tox.NetCryptoSession -> Status Tox.ToxProgress -> STM () 1167 -> AggregateSession -> Tox.Session -> Status Tox.ToxProgress -> STM ()
1640 onStatusChange announce c s Established = onConnect announce c s 1168 onStatusChange announce c s Established = onConnect announce c s
1641 onStatusChange announce _ s _ = onEOF announce s 1169 onStatusChange announce _ s _ = onEOF announce s
1642 1170
@@ -1686,7 +1214,6 @@ onNewToxSession sv ssvar ContactInfo{accounts} addrTox netcrypto = do
1686 return c 1214 return c
1687 Just c -> return c 1215 Just c -> return c
1688 1216
1689 atomically $ Tox.addDestroySessionHook netcrypto (Just 0) $ void . delSession c . fromIntegral . Tox.ncSessionId
1690 addSession c netcrypto 1217 addSession c netcrypto
1691 1218
1692 return () 1219 return ()
@@ -1755,126 +1282,22 @@ selectManager mtman tcp profile = case T.splitAt 43 profile of
1755 } 1282 }
1756 1283
1757 1284
1758main :: IO () 1285initTox :: Options
1759main = do 1286 -> TVar (Map.Map Uniq24 AggregateSession)
1760 args <- getArgs 1287 -> TVar Tox.AnnouncedKeys -> Maybe XMPPServer -> IO ( Maybe (Tox.Tox JabberClients) , IO ()
1761 let opts = parseArgs args sensibleDefaults 1288 , Map.Map String DHT
1762 print opts 1289 , IO [SockAddr]
1763 1290 , [SockAddr])
1764 swarms <- Mainline.newSwarmsDatabase 1291initTox opts ssvar keysdb mbxmpp = case porttox opts of
1765 -- Restore peer database before forking the listener thread.
1766 peerdb <- left show <$> tryIOError (L.readFile "bt-peers.dat")
1767 either (dput XMisc . ("bt-peers.dat: "++))
1768 (atomically . writeTVar (Mainline.contactInfo swarms))
1769 (peerdb >>= S.decodeLazy)
1770
1771 announcer <- forkAnnouncer
1772
1773 -- Default: quiet all tags (except XMisc).
1774 forM [minBound .. maxBound] setQuiet
1775 forM (verboseTags opts) setVerbose
1776
1777 (quitBt,btdhts,btips,baddrs) <- case portbt opts of
1778 "" -> return (return (), Map.empty,return [],[])
1779 p -> do
1780 addr <- getBindAddress p (ip6bt opts)
1781 (bt,btR,btBootstrap4, btBootstrap6) <- Mainline.newClient swarms addr
1782 quitBt <- forkListener "bt" (clientNet bt)
1783 mainlineSearches <- atomically $ newTVar Map.empty
1784 peerPort <- atomically $ newTVar 6881 -- BitTorrent client TCP port.
1785 let mainlineDHT bkts wantip = DHT
1786 { dhtBuckets = bkts btR
1787 , dhtPing = Map.singleton "ping" $ DHTPing
1788 { pingQuery = noArgPing $ fmap (bool Nothing (Just ())) . Mainline.ping bt
1789 , pingShowResult = show
1790 }
1791 , dhtQuery = Map.fromList
1792 [ ("node", DHTQuery
1793 { qsearch = (Mainline.nodeSearch bt)
1794 , qhandler = (\ni -> fmap Mainline.unwrapNodes
1795 . Mainline.findNodeH btR ni
1796 . flip Mainline.FindNode (Just Want_Both))
1797 , qshowR = show
1798 , qshowTok = (const Nothing)
1799 })
1800 -- Maybe (sr :~: pr, stok :~: ptok, sni :~: pni )
1801 -- sr = InfoHash
1802 -- stok = Token
1803 -- sni = NodeInfo
1804 , ("peer", DHTQuery
1805 { qsearch = (Mainline.peerSearch bt)
1806 , qhandler = (\ni -> fmap Mainline.unwrapPeers
1807 . Mainline.getPeersH btR swarms ni
1808 . flip Mainline.GetPeers (Just Want_Both)
1809 . (read . show)) -- TODO: InfoHash -> NodeId
1810 , qshowR = (show . pPrint)
1811 , qshowTok = (Just . show)
1812 })
1813 ]
1814 , dhtParseId = readEither :: String -> Either String Mainline.NodeId
1815 , dhtSearches = mainlineSearches
1816 , dhtFallbackNodes = Mainline.bootstrapNodes wantip
1817 , dhtAnnouncables = Map.fromList
1818 -- Maybe (sr :~: pr, stok :~: ptok, sni :~: pni )
1819 -- dta = Announce
1820 -- pr = Announced
1821 -- ptok = Token
1822 -- pni = NodeInfo
1823 [ ("peer", DHTAnnouncable { announceSendData = Right $ \ih tok -> \case
1824 Just ni -> do
1825 port <- atomically $ readTVar peerPort
1826 let dta = Mainline.mkAnnounce port ih tok
1827 Mainline.announce bt dta ni
1828 Nothing -> return Nothing
1829 , announceParseAddress = readEither
1830 , announceParseData = readEither
1831 , announceParseToken = const $ readEither
1832 , announceInterval = 60 -- TODO: Is one minute good?
1833 , announceTarget = (read . show) -- TODO: InfoHash -> NodeId -- peer
1834 })
1835 , ("port", DHTAnnouncable { announceParseData = readEither
1836 , announceParseToken = \_ _ -> return ()
1837 , announceParseAddress = const $ Right ()
1838 , announceSendData = Right $ \dta () -> \case
1839 Nothing -> do atomically $ writeTVar peerPort (dta :: PortNumber)
1840 return $ Just dta
1841 Just _ -> return Nothing
1842 , announceInterval = 0 -- TODO: The "port" setting should probably
1843 -- be a command rather than an announcement.
1844 , announceTarget = const $ Mainline.zeroID
1845 })]
1846
1847 , dhtSecretKey = return Nothing
1848 , dhtBootstrap = case wantip of
1849 Want_IP4 -> btBootstrap4
1850 Want_IP6 -> btBootstrap6
1851 }
1852 dhts = Map.fromList $
1853 ("bt4", mainlineDHT Mainline.routing4 Want_IP4)
1854 : if ip6bt opts
1855 then [ ("bt6", mainlineDHT Mainline.routing6 Want_IP6) ]
1856 else []
1857 ips :: IO [SockAddr]
1858 ips = readExternals Mainline.nodeAddr
1859 [ Mainline.routing4 btR
1860 , Mainline.routing6 btR
1861 ]
1862 return (quitBt,dhts,ips, [addr])
1863
1864 keysdb <- Tox.newKeysDatabase
1865
1866 _crypto <- Tox.newCrypto
1867 let emptyDestroyHook :: Tox.NetCryptoSession -> IO ()
1868 emptyDestroyHook session = dput XNetCrypto $ "SESSION DESTROY HOOK NOT ADDED ! publkey= " ++ show (Tox.key2id (Tox.ncTheirPublicKey session))
1869 _netCryptoSessionsState <- Tox.newSessionsState _crypto emptyDestroyHook Tox.defaultUnRecHook Tox.defaultCryptoDataHooks
1870 (mbtox,quitTox,toxdhts,toxips,(taddrs::[SockAddr])) <- case porttox opts of
1871 "" -> return (Nothing,return (), Map.empty, return [],[]) 1292 "" -> return (Nothing,return (), Map.empty, return [],[])
1872 toxport -> do 1293 toxport -> do
1873 addrTox <- getBindAddress toxport (ip6tox opts) 1294 addrTox <- getBindAddress toxport (ip6tox opts)
1874 dput XMisc $ "Supplied key: " ++ show (fmap (Tox.key2id . toPublic) (dhtkey opts)) 1295 dput XMisc $ "Supplied key: " ++ show (fmap (Tox.key2id . toPublic) (dhtkey opts))
1875 tox <- Tox.newTox keysdb 1296 tox <- Tox.newTox keysdb
1876 addrTox 1297 addrTox
1877 (Just _netCryptoSessionsState) 1298 (case mbxmpp of
1299 Nothing -> \_ _ _ -> return ()
1300 Just xmpp -> onNewToxSession xmpp ssvar)
1878 (dhtkey opts) 1301 (dhtkey opts)
1879 (quitTox, toxStrap4, toxStrap6) <- Tox.forkTox tox True 1302 (quitTox, toxStrap4, toxStrap6) <- Tox.forkTox tox True
1880 1303
@@ -2060,12 +1483,16 @@ main = do
2060 , Tox.routing6 $ Tox.toxRouting tox ] 1483 , Tox.routing6 $ Tox.toxRouting tox ]
2061 return (Just tox, quitTox, dhts, ips, [addrTox]) 1484 return (Just tox, quitTox, dhts, ips, [addrTox])
2062 1485
2063 let netCryptoSessionsState = maybe _netCryptoSessionsState Tox.toxCryptoSessions mbtox 1486initJabber :: Options
2064 1487 -> TVar (Map.Map Uniq24 AggregateSession)
2065 _ <- UPNP.requestPorts "dht-client" $ map (Datagram,) $ baddrs ++ taddrs 1488 -> Announcer
2066 1489 -> Maybe (Tox.Tox JabberClients)
2067 ssvar <- atomically $ newTVar Map.empty 1490 -> Map.Map String DHT
2068 (msv,mconns,mstate) <- case portxmpp opts of 1491 -> IO ( Maybe XMPPServer
1492 , Maybe (Manager TCPStatus T.Text)
1493 , Maybe (PresenceState Pending)
1494 )
1495initJabber opts ssvar announcer mbtox toxdhts = case portxmpp opts of
2069 "" -> return (Nothing,Nothing,Nothing) 1496 "" -> return (Nothing,Nothing,Nothing)
2070 p -> do 1497 p -> do
2071 cport <- getBindAddress p True{-IPv6 supported-} 1498 cport <- getBindAddress p True{-IPv6 supported-}
@@ -2092,50 +1519,124 @@ main = do
2092 conns <- xmppConnections sv 1519 conns <- xmppConnections sv
2093 return (Just sv, Just conns, Just state) 1520 return (Just sv, Just conns, Just state)
2094 1521
2095 forM_ (take 1 taddrs) $ \addrTox -> do 1522main :: IO ()
2096 atomically $ Tox.addNewSessionHook netCryptoSessionsState $ \mbNoSpam netcrypto -> do 1523main = do
2097 {- 1524 args <- getArgs
2098 -- allsessionsMap <- atomically $ readTVar (netCryptoSessions netCryptoSessionsState) 1525 let opts = parseArgs args sensibleDefaults
2099 let sockAddr = Tox.ncSockAddr netcrypto 1526 print opts
2100 pubKey = Tox.ncTheirPublicKey netcrypto 1527
2101 tmchan <- atomically newTMChan 1528 swarms <- Mainline.newSwarmsDatabase
2102 let pingflag = return False -- XMPPServer should never send pings. 1529 -- Restore peer database before forking the listener thread.
2103 -- This is taken care of by the tox layer. 1530 peerdb <- left show <$> tryIOError (L.readFile "bt-peers.dat")
2104 receiveCrypto = atomically $ readTMChan tmchan 1531 either (dput XMisc . ("bt-peers.dat: "++))
2105 onEOF = return () -- setTerminate is called elsewhere. 1532 (atomically . writeTVar (Mainline.contactInfo swarms))
2106 xmppSrc = ioToSource receiveCrypto onEOF 1533 (peerdb >>= S.decodeLazy)
2107 xmppSink = newXmmpSink netcrypto 1534
2108 -} 1535 announcer <- forkAnnouncer
2109 forM_ msv $ \sv -> do 1536
2110 let Tox.HaveDHTKey saddr = Tox.ncSockAddr netcrypto 1537 -- Default: quiet all tags (except XMisc).
2111 {- 1538 forM [minBound .. maxBound] setQuiet
2112 Tox.HaveDHTKey dkey = Tox.ncTheirDHTKey netcrypto 1539 forM (verboseTags opts) setVerbose
2113 nid = Tox.key2id dkey 1540
2114 them = Tox.ncTheirPublicKey netcrypto 1541 (quitBt,btdhts,btips,baddrs) <- case portbt opts of
2115 me = Tox.ncMyPublicKey netcrypto 1542 "" -> return (return (), Map.empty,return [],[])
2116 1543 p -> do
2117 announceToxJabberPeer me them (xmppEventChannel sv) addrTox saddr pingflag xmppSrc xmppSink 1544 addr <- getBindAddress p (ip6bt opts)
2118 -} 1545 (bt,btR,btBootstrap4, btBootstrap6) <- Mainline.newClient swarms addr
2119 1546 quitBt <- forkListener "bt" (clientNet bt)
2120 forM_ mbtox $ \tox -> do 1547 mainlineSearches <- atomically $ newTVar Map.empty
2121 onNewToxSession sv ssvar (Tox.toxContactInfo tox) saddr netcrypto 1548 peerPort <- atomically $ newTVar 6881 -- BitTorrent client TCP port.
2122 {- 1549 let mainlineDHT bkts wantip = DHT
2123 mbacc <- HashMap.lookup (Tox.key2id me) 1550 { dhtBuckets = bkts btR
2124 <$> atomically (readTVar accounts) 1551 , dhtPing = Map.singleton "ping" $ DHTPing
2125 -- TODO: Add account if it doesn't exist? 1552 { pingQuery = noArgPing $ fmap (bool Nothing (Just ())) . Mainline.ping bt
2126 forM_ mbacc $ \acnt -> do 1553 , pingShowResult = show
2127 now <- getPOSIXTime 1554 }
2128 forM_ (either (const Nothing) Just $ Tox.nodeInfo nid saddr) 1555 , dhtQuery = Map.fromList
2129 $ \ni -> do 1556 [ ("node", DHTQuery
2130 atomically $ do setEstablished them acnt 1557 { qsearch = (Mainline.nodeSearch bt)
2131 setContactAddr now them ni acnt 1558 , qhandler = (\ni -> fmap Mainline.unwrapNodes
2132 atomically $ do 1559 . Mainline.findNodeH btR ni
2133 supply <- readTVar (Tox.listenerIDSupply netCryptoSessionsState) 1560 . flip Mainline.FindNode (Just Want_Both))
2134 let (listenerId,supply') = freshId supply 1561 , qshowR = show
2135 writeTVar (Tox.listenerIDSupply netCryptoSessionsState) supply' 1562 , qshowTok = (const Nothing)
2136 modifyTVar' (Tox.ncListeners netcrypto) (IntMap.insert listenerId (0,tmchan)) 1563 })
2137 -} 1564 -- Maybe (sr :~: pr, stok :~: ptok, sni :~: pni )
2138 return Nothing 1565 -- sr = InfoHash
1566 -- stok = Token
1567 -- sni = NodeInfo
1568 , ("peer", DHTQuery
1569 { qsearch = (Mainline.peerSearch bt)
1570 , qhandler = (\ni -> fmap Mainline.unwrapPeers
1571 . Mainline.getPeersH btR swarms ni
1572 . flip Mainline.GetPeers (Just Want_Both)
1573 . (read . show)) -- TODO: InfoHash -> NodeId
1574 , qshowR = (show . pPrint)
1575 , qshowTok = (Just . show)
1576 })
1577 ]
1578 , dhtParseId = readEither :: String -> Either String Mainline.NodeId
1579 , dhtSearches = mainlineSearches
1580 , dhtFallbackNodes = Mainline.bootstrapNodes wantip
1581 , dhtAnnouncables = Map.fromList
1582 -- Maybe (sr :~: pr, stok :~: ptok, sni :~: pni )
1583 -- dta = Announce
1584 -- pr = Announced
1585 -- ptok = Token
1586 -- pni = NodeInfo
1587 [ ("peer", DHTAnnouncable { announceSendData = Right $ \ih tok -> \case
1588 Just ni -> do
1589 port <- atomically $ readTVar peerPort
1590 let dta = Mainline.mkAnnounce port ih tok
1591 Mainline.announce bt dta ni
1592 Nothing -> return Nothing
1593 , announceParseAddress = readEither
1594 , announceParseData = readEither
1595 , announceParseToken = const $ readEither
1596 , announceInterval = 60 -- TODO: Is one minute good?
1597 , announceTarget = (read . show) -- TODO: InfoHash -> NodeId -- peer
1598 })
1599 , ("port", DHTAnnouncable { announceParseData = readEither
1600 , announceParseToken = \_ _ -> return ()
1601 , announceParseAddress = const $ Right ()
1602 , announceSendData = Right $ \dta () -> \case
1603 Nothing -> do atomically $ writeTVar peerPort (dta :: PortNumber)
1604 return $ Just dta
1605 Just _ -> return Nothing
1606 , announceInterval = 0 -- TODO: The "port" setting should probably
1607 -- be a command rather than an announcement.
1608 , announceTarget = const $ Mainline.zeroID
1609 })]
1610
1611 , dhtSecretKey = return Nothing
1612 , dhtBootstrap = case wantip of
1613 Want_IP4 -> btBootstrap4
1614 Want_IP6 -> btBootstrap6
1615 }
1616 dhts = Map.fromList $
1617 ("bt4", mainlineDHT Mainline.routing4 Want_IP4)
1618 : if ip6bt opts
1619 then [ ("bt6", mainlineDHT Mainline.routing6 Want_IP6) ]
1620 else []
1621 ips :: IO [SockAddr]
1622 ips = readExternals Mainline.nodeAddr
1623 [ Mainline.routing4 btR
1624 , Mainline.routing6 btR
1625 ]
1626 return (quitBt,dhts,ips, [addr])
1627
1628 keysdb <- Tox.newKeysDatabase
1629
1630 ssvar <- atomically $ newTVar Map.empty
1631 rec (mbtox,quitTox,toxdhts,toxips,(taddrs::[SockAddr]),msv,mconns,mstate) <- do
1632
1633 (mbtox,quitTox,toxdhts,toxips,(taddrs::[SockAddr])) <- initTox opts ssvar keysdb msv
1634
1635 (msv,mconns,mstate) <- initJabber opts ssvar announcer mbtox toxdhts
1636
1637 return (mbtox,quitTox,toxdhts,toxips,(taddrs::[SockAddr]),msv,mconns,mstate)
1638
1639 _ <- UPNP.requestPorts "dht-client" $ map (Datagram,) $ baddrs ++ taddrs
2139 1640
2140 let dhts = Map.union btdhts toxdhts 1641 let dhts = Map.union btdhts toxdhts
2141 1642
@@ -2157,7 +1658,6 @@ main = do
2157 , dhts = dhts -- all DHTs 1658 , dhts = dhts -- all DHTs
2158 , signalQuit = quitCommand 1659 , signalQuit = quitCommand
2159 , swarms = swarms 1660 , swarms = swarms
2160 , cryptosessions = netCryptoSessionsState
2161 , toxkeys = keysdb 1661 , toxkeys = keysdb
2162 , roster = rstr 1662 , roster = rstr
2163 , announceToLan = fromMaybe (return ()) $ Tox.toxAnnounceToLan <$> mbtox 1663 , announceToLan = fromMaybe (return ()) $ Tox.toxAnnounceToLan <$> mbtox
diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
index 861d71d3..88228c50 100644
--- a/src/Network/Tox.hs
+++ b/src/Network/Tox.hs
@@ -32,31 +32,25 @@ import qualified Data.ByteString as B
32import qualified Data.ByteString.Char8 as C8 32import qualified Data.ByteString.Char8 as C8
33import Data.Data 33import Data.Data
34import Data.Functor.Contravariant 34import Data.Functor.Contravariant
35import Data.IP
36import Data.Maybe 35import Data.Maybe
37import qualified Data.MinMaxPSQ as MinMaxPSQ 36import qualified Data.MinMaxPSQ as MinMaxPSQ
38import qualified Data.Serialize as S 37import qualified Data.Serialize as S
39import Data.Time.Clock.POSIX (getPOSIXTime) 38import Data.Time.Clock.POSIX (getPOSIXTime)
40import Data.Word 39import Data.Word
40import Network.Socket
41import System.Endian
42
43import Network.BitTorrent.DHT.Token as Token
41import qualified Data.Wrapper.PSQ as PSQ 44import qualified Data.Wrapper.PSQ as PSQ
42import System.Global6 45import System.Global6
43import Network.Address (WantIP (..)) 46import Network.Address (WantIP (..),IP)
44import qualified Network.Kademlia.Routing as R 47import qualified Network.Kademlia.Routing as R
45import Network.QueryResponse 48import Network.QueryResponse
46import Network.Socket
47import System.Endian
48import Network.BitTorrent.DHT.Token as Token
49
50import Connection
51import Crypto.Tox 49import Crypto.Tox
52import Data.Word64Map (fitsInInt) 50import Data.Word64Map (fitsInInt)
53import qualified Data.Word64Map (empty) 51import qualified Data.Word64Map (empty)
54import HandshakeCache
55import Network.Kademlia.Bootstrap (forkPollForRefresh, bootstrap) 52import Network.Kademlia.Bootstrap (forkPollForRefresh, bootstrap)
56import Network.Kademlia.Search
57import Network.Tox.Crypto.Transport (Handshake(..),CryptoPacket) 53import Network.Tox.Crypto.Transport (Handshake(..),CryptoPacket)
58import Network.Tox.Handshake
59import Network.Tox.Crypto.Handlers
60import qualified Network.Tox.DHT.Handlers as DHT 54import qualified Network.Tox.DHT.Handlers as DHT
61import qualified Network.Tox.DHT.Transport as DHT 55import qualified Network.Tox.DHT.Transport as DHT
62import Network.Tox.NodeId 56import Network.Tox.NodeId
@@ -66,12 +60,12 @@ import Network.Tox.Transport
66import OnionRouter 60import OnionRouter
67import Network.Tox.ContactInfo 61import Network.Tox.ContactInfo
68import Text.XXD 62import Text.XXD
69import qualified Data.HashMap.Strict as HashMap
70import qualified Data.Map.Strict as Map
71import DPut 63import DPut
72import Network.Tox.Avahi 64import Network.Tox.Avahi
73import Text.Printf 65import Network.Tox.Session
74import Data.List 66import Network.SessionTransports
67import Network.Kademlia.Search
68import HandshakeCache
75 69
76newCrypto :: IO TransportCrypto 70newCrypto :: IO TransportCrypto
77newCrypto = do 71newCrypto = do
@@ -207,7 +201,6 @@ data Tox extra = Tox
207 , toxCrypto :: Transport String SockAddr (CryptoPacket Encrypted) 201 , toxCrypto :: Transport String SockAddr (CryptoPacket Encrypted)
208 , toxHandshakes :: Transport String SockAddr (Handshake Encrypted) 202 , toxHandshakes :: Transport String SockAddr (Handshake Encrypted)
209 , toxHandshakeCache :: HandshakeCache 203 , toxHandshakeCache :: HandshakeCache
210 , toxCryptoSessions :: NetCryptoSessions
211 , toxCryptoKeys :: TransportCrypto 204 , toxCryptoKeys :: TransportCrypto
212 , toxRouting :: DHT.Routing 205 , toxRouting :: DHT.Routing
213 , toxTokens :: TVar SessionTokens 206 , toxTokens :: TVar SessionTokens
@@ -217,97 +210,7 @@ data Tox extra = Tox
217 , toxAnnounceToLan :: IO () 210 , toxAnnounceToLan :: IO ()
218 } 211 }
219 212
220-- | initiate a netcrypto session, blocking 213
221netCrypto :: Tox extra -> SecretKey -> PublicKey{-UserKey -} -> IO [NetCryptoSession]
222netCrypto tox myseckey theirpubkey = netCryptoWithBackoff 1000000 tox myseckey theirpubkey
223
224-- | helper for 'netCrypto', initiate a netcrypto session, retry after specified millisecs
225netCryptoWithBackoff :: Int -> Tox extra -> SecretKey -> PublicKey -> IO [NetCryptoSession]
226netCryptoWithBackoff millisecs tox myseckey theirpubkey = do
227 let mykeyAsId = key2id (toPublic myseckey)
228 -- TODO: check status of connection here:
229 mbContactsVar <- fmap contacts . HashMap.lookup mykeyAsId <$> atomically (readTVar (accounts (toxContactInfo tox)))
230 case mbContactsVar of
231 Nothing -> do
232 dput XNetCrypto ("netCrypto: (" ++ show mykeyAsId ++") accounts lookup failed.")
233 return []
234
235 Just contactsVar -> do
236 let theirkeyAsId = key2id theirpubkey
237 mbContact <- HashMap.lookup theirkeyAsId <$> atomically (readTVar contactsVar)
238 tup <- atomically $ do
239 mc <- HashMap.lookup theirkeyAsId <$> readTVar contactsVar
240 kp <- fmap join $ forM mc $ \c -> readTVar (contactKeyPacket c)
241 sa <- fmap join $ forM mc $ \c -> readTVar (contactLastSeenAddr c)
242 fr <- fmap join $ forM mc $ \c -> readTVar (contactFriendRequest c)
243 cp <- fmap join $ forM mc $ \c -> readTVar (contactPolicy c)
244 return (kp,sa,fr,cp)
245 case tup of
246 (Nothing,Nothing,Nothing,Nothing) -> do
247 dput XNetCrypto ("netCrypto: (" ++ show mykeyAsId ++") friend not found (" ++ show theirkeyAsId ++ ").")
248 return []
249 (mbKeyPkt,Nothing,mbFR,mbPolicy) -> do
250 dput XNetCrypto ("netCrypto: (" ++ show mykeyAsId ++") no SockAddr for friend (" ++ show theirkeyAsId ++ "). TODO: search their node?")
251 return []
252 (Nothing,_,_,_) -> do
253 dput XNetCrypto ("netCrypto: (" ++ show mykeyAsId ++") no DHT-key for friend (" ++ show theirkeyAsId ++ "). TODO: what?")
254 return []
255 (Just (stamp_theirDhtKey,keyPkt),Just (stamp_saddr,saddr),mbFR,mbPolicy)
256 | theirDhtKey <- DHT.dhtpk keyPkt -> do
257 -- Do we already have an active session with this user?
258 sessionsMap <- atomically $ readTVar (netCryptoSessionsByKey (toxCryptoSessions tox) )
259 let sessionUsesIdentity key session = key == ncMyPublicKey session
260 case Map.lookup theirpubkey sessionsMap of
261 -- if sessions found, is it using this private key?
262 Just sessions | matchedSessions <- filter (sessionUsesIdentity (toPublic myseckey)) sessions
263 , not (null matchedSessions)
264 -> do
265 dput XNetCrypto ("netCrypto: Already have a session for " ++ show mykeyAsId ++ "<-->" ++ show theirkeyAsId)
266 return matchedSessions
267 -- if not, send handshake, this is separate session
268 _ -> do
269 -- if no session:
270 -- Convert to NodeInfo, so we can send cookieRequest
271 let crypto = toxCryptoKeys tox
272 client = toxDHT tox
273 case nodeInfo (key2id theirDhtKey) (nodeAddr saddr) of
274 Left e -> dput XNetCrypto ("netCrypto: nodeInfo fail... " ++ e) >> return []
275 Right ni -> do
276 mbCookie <- DHT.cookieRequest crypto client (toPublic myseckey) ni
277 case mbCookie of
278 Nothing -> do
279 dput XNetCrypto ("netCrypto: (" ++ show mykeyAsId ++") <--> (" ++ show theirkeyAsId ++ ").")
280 dput XNetCrypto ("netCrypto: CookieRequest failed. TODO: dhtpkNodes thingy")
281 return []
282 Just cookie -> do
283 dput XNetCrypto "Have cookie, creating handshake packet..."
284 let hp = HParam { hpOtherCookie = cookie
285 , hpMySecretKey = myseckey
286 , hpCookieRemotePubkey = theirpubkey
287 , hpCookieRemoteDhtkey = theirDhtKey
288 , hpTheirBaseNonce = Nothing
289 , hpTheirSessionKeyPublic = Nothing
290 }
291 newsession <- generateSecretKey
292 timestamp <- getPOSIXTime
293 (myhandshake,ioAction)
294 <- atomically $ freshCryptoSession (toxCryptoSessions tox) (nodeAddr saddr) newsession timestamp hp
295 ioAction
296 -- send handshake
297 forM myhandshake $ \response_handshake -> do
298 sendHandshake (toxCryptoSessions tox) (nodeAddr saddr) response_handshake
299 let secnum :: Double
300 secnum = fromIntegral millisecs / 1000000
301 delay = (millisecs * 5 `div` 4)
302 if secnum < 20000000
303 then do
304 dput XNetCrypto $ "sent handshake, now delaying " ++ show (secnum * 1.25) ++ " second(s).."
305 -- threadDelay delay
306 -- Commenting loop for simpler debugging
307 return [] -- netCryptoWithBackoff delay tox myseckey theirpubkey -- hopefully it will find an active session this time.
308 else do
309 dput XNetCrypto "Unable to establish session..."
310 return []
311 214
312-- | Create a DHTPublicKey packet to send to a remote contact. 215-- | Create a DHTPublicKey packet to send to a remote contact.
313getContactInfo :: Tox extra -> IO DHT.DHTPublicKey 216getContactInfo :: Tox extra -> IO DHT.DHTPublicKey
@@ -365,30 +268,24 @@ getOnionAlias crypto dhtself remoteNode = atomically $ do
365 268
366newTox :: TVar Onion.AnnouncedKeys -- ^ Store of announced keys we are a rendezvous for. 269newTox :: TVar Onion.AnnouncedKeys -- ^ Store of announced keys we are a rendezvous for.
367 -> SockAddr -- ^ Bind-address to listen on. 270 -> SockAddr -- ^ Bind-address to listen on.
368 -> Maybe NetCryptoSessions -- ^ State of all one-on-one Tox links. 271 -> ( ContactInfo extra -> SockAddr -> Session -> IO () )
369 -> Maybe SecretKey -- ^ Optional DHT secret key to use. 272 -> Maybe SecretKey -- ^ Optional DHT secret key to use.
370 -> IO (Tox extra) 273 -> IO (Tox extra)
371newTox keydb addr mbSessionsState suppliedDHTKey = do 274newTox keydb addr onsess suppliedDHTKey = do
372 (udp,sock) <- {- addVerbosity <$> -} udpTransport' addr 275 (udp,sock) <- {- addVerbosity <$> -} udpTransport' addr
373 tox <- newToxOverTransport keydb addr mbSessionsState suppliedDHTKey udp 276 tox <- newToxOverTransport keydb addr onsess suppliedDHTKey udp
374 return tox { toxAnnounceToLan = announceToLan sock (key2id $ transportPublic $ toxCryptoKeys tox) } 277 return tox { toxAnnounceToLan = announceToLan sock (key2id $ transportPublic $ toxCryptoKeys tox) }
375 278
376-- | This version of 'newTox' is useful for automated tests using 'testPairTransport'. 279-- | This version of 'newTox' is useful for automated tests using 'testPairTransport'.
377newToxOverTransport :: TVar Onion.AnnouncedKeys 280newToxOverTransport :: TVar Onion.AnnouncedKeys
378 -> SockAddr 281 -> SockAddr
379 -> Maybe NetCryptoSessions 282 -> ( ContactInfo extra -> SockAddr -> Session -> IO () )
380 -> Maybe SecretKey 283 -> Maybe SecretKey
381 -> Onion.UDPTransport 284 -> Onion.UDPTransport
382 -> IO (Tox extra) 285 -> IO (Tox extra)
383newToxOverTransport keydb addr mbSessionsState suppliedDHTKey udp = do 286newToxOverTransport keydb addr onNewSession suppliedDHTKey udp = do
384 roster <- newContactInfo 287 roster <- newContactInfo
385 (crypto0,sessionsState0) <- case mbSessionsState of 288 crypto0 <- newCrypto
386 Nothing -> do
387 crypto <- newCrypto
388 sessionsState <- newSessionsState crypto (const $ dput XUnexpected "Missing destroy hook!") defaultUnRecHook defaultCryptoDataHooks
389 return (crypto,sessionsState)
390 Just s -> return (transportCrypto s, s)
391
392 let -- patch in supplied DHT key 289 let -- patch in supplied DHT key
393 crypto1 = fromMaybe crypto0 $do 290 crypto1 = fromMaybe crypto0 $do
394 k <- suppliedDHTKey 291 k <- suppliedDHTKey
@@ -409,6 +306,7 @@ newToxOverTransport keydb addr mbSessionsState suppliedDHTKey udp = do
409 mkrouting <- DHT.newRouting addr crypto updateIP updateIP 306 mkrouting <- DHT.newRouting addr crypto updateIP updateIP
410 orouter <- newOnionRouter $ dput XRoutes 307 orouter <- newOnionRouter $ dput XRoutes
411 (cryptonet,dhtcrypt,onioncrypt,dtacrypt,handshakes) <- toxTransport crypto orouter lookupClose udp 308 (cryptonet,dhtcrypt,onioncrypt,dtacrypt,handshakes) <- toxTransport crypto orouter lookupClose udp
309 sessions <- initSessions (sendMessage cryptonet)
412 310
413 let dhtnet0 = layerTransportM (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt 311 let dhtnet0 = layerTransportM (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt
414 tbl4 = DHT.routing4 $ mkrouting (error "missing client") 312 tbl4 = DHT.routing4 $ mkrouting (error "missing client")
@@ -417,22 +315,12 @@ newToxOverTransport keydb addr mbSessionsState suppliedDHTKey udp = do
417 $ \client net -> onInbound (DHT.updateRouting client (mkrouting client) orouter) net 315 $ \client net -> onInbound (DHT.updateRouting client (mkrouting client) orouter) net
418 316
419 hscache <- newHandshakeCache crypto (sendMessage handshakes) 317 hscache <- newHandshakeCache crypto (sendMessage handshakes)
420 318 let sparams = SessionParams
421 let sessionsState = sessionsState0 { sendHandshake = sendMessage handshakes 319 { spCrypto = crypto
422 , sendSessionPacket = sendMessage cryptonet 320 , spSessions = sessions
423 , transportCrypto = crypto 321 , spGetSentHandshake = getSentHandshake hscache
424 -- ToxContact -> STM Policy 322 , spOnNewSession = onNewSession roster addr
425 , netCryptoPolicyByKey = policylookup 323 }
426 }
427 policylookup (ToxContact me them) = do
428 macnt <- HashMap.lookup me <$> readTVar (accounts roster)
429 case macnt of
430 Nothing -> return RefusingToConnect
431 Just acnt -> do
432 mc <- HashMap.lookup them <$> readTVar (contacts acnt)
433 case mc of
434 Nothing -> return RefusingToConnect
435 Just c -> fromMaybe RefusingToConnect <$> readTVar (contactPolicy c)
436 324
437 orouter' <- forkRouteBuilder orouter 325 orouter' <- forkRouteBuilder orouter
438 $ \nid ni -> fmap (\(_,ns,_)->ns) 326 $ \nid ni -> fmap (\(_,ns,_)->ns)
@@ -453,10 +341,9 @@ newToxOverTransport keydb addr mbSessionsState suppliedDHTKey udp = do
453 { toxDHT = dhtclient 341 { toxDHT = dhtclient
454 , toxOnion = onionclient 342 , toxOnion = onionclient
455 , toxToRoute = onInbound (updateContactInfo roster) dtacrypt 343 , toxToRoute = onInbound (updateContactInfo roster) dtacrypt
456 , toxCrypto = addHandler (dput XMisc) (sessionPacketH sessionsState) cryptonet 344 , toxCrypto = addHandler (dput XMisc) (sessionHandler sessions) cryptonet
457 , toxHandshakes = addHandler (dput XMisc) (handshakeH sessionsState) handshakes 345 , toxHandshakes = addHandler (dput XMisc) (handshakeH sparams) handshakes
458 , toxHandshakeCache = hscache 346 , toxHandshakeCache = hscache
459 , toxCryptoSessions = sessionsState
460 , toxCryptoKeys = crypto 347 , toxCryptoKeys = crypto
461 , toxRouting = mkrouting dhtclient 348 , toxRouting = mkrouting dhtclient
462 , toxTokens = toks 349 , toxTokens = toks
@@ -526,8 +413,10 @@ announceToLan sock nid = do
526 (Just "33445") 413 (Just "33445")
527 let broadcast = addrAddress broadcast_info 414 let broadcast = addrAddress broadcast_info
528 bs = S.runPut $ DHT.putMessage (DHT.DHTLanDiscovery nid) 415 bs = S.runPut $ DHT.putMessage (DHT.DHTLanDiscovery nid)
416 dput XLan $ show broadcast ++ " <-- LanAnnounce " ++ show nid
529 saferSendTo sock bs broadcast 417 saferSendTo sock bs broadcast
530 418
419
531toxQSearch :: Tox extra -> Search NodeId (IP, PortNumber) Nonce32 NodeInfo Onion.Rendezvous 420toxQSearch :: Tox extra -> Search NodeId (IP, PortNumber) Nonce32 NodeInfo Onion.Rendezvous
532toxQSearch tox = Onion.toxidSearch (onionTimeout tox) (toxCryptoKeys tox) (toxOnion tox) 421toxQSearch tox = Onion.toxidSearch (onionTimeout tox) (toxCryptoKeys tox) (toxOnion tox)
533 422
diff --git a/src/Network/Tox/AggregateSession.hs b/src/Network/Tox/AggregateSession.hs
index edb897e0..1dd10eef 100644
--- a/src/Network/Tox/AggregateSession.hs
+++ b/src/Network/Tox/AggregateSession.hs
@@ -22,7 +22,6 @@ module Network.Tox.AggregateSession
22 22
23import Control.Concurrent.STM 23import Control.Concurrent.STM
24import Control.Concurrent.STM.TMChan 24import Control.Concurrent.STM.TMChan
25import Control.Concurrent.Supply
26import Control.Monad 25import Control.Monad
27import Data.Function 26import Data.Function
28import qualified Data.IntMap.Strict as IntMap 27import qualified Data.IntMap.Strict as IntMap
@@ -47,9 +46,7 @@ import Network.Tox.Crypto.Transport (CryptoMessage (..), pattern KillPacket,
47 pattern PacketRequest) 46 pattern PacketRequest)
48import Network.Tox.DHT.Transport (key2id) 47import Network.Tox.DHT.Transport (key2id)
49import Network.Tox.NodeId (ToxProgress (..)) 48import Network.Tox.NodeId (ToxProgress (..))
50import Network.Tox.Crypto.Handlers 49import Network.Tox.Session
51
52type Session = NetCryptoSession
53 50
54-- | For each component session, we track the current status. 51-- | For each component session, we track the current status.
55data SingleCon = SingleCon 52data SingleCon = SingleCon
@@ -113,47 +110,94 @@ data KeepAliveEvents = DoTimeout -- ^ A session timed-out, close it.
113 | DoRequestMissing -- ^ Detect and request lost packets. 110 | DoRequestMissing -- ^ Detect and request lost packets.
114 deriving Enum 111 deriving Enum
115 112
116-- | This function forks a thread to read all packets from the provided 113-- | This call loops until the provided sesison is closed or times out. It
117-- 'Session' and forward them to 'contactChannel' for a containing 114-- monitors the provided (non-empty) priority queue for scheduled tasks (see
118-- 'AggregateSession' 115-- 'KeepAliveEvents') to perform for the connection.
116keepAlive :: Session -> TVar (PSQ POSIXTime) -> IO ()
117keepAlive s q = do
118 myThreadId >>= flip labelThread
119 (intercalate "." ["beacon"
120 , take 8 $ show $ key2id $ sTheirUserKey s
121 , show $ sSessionID s])
122
123 let outPrint e = dput XNetCrypto $ shows (sSessionID s,sTheirAddr s) $ " <-- " ++ e
124
125 doAlive = do
126 -- outPrint $ "Beacon"
127 sendMessage (sTransport s) () (OneByte PING)
128
129 doRequestMissing = do
130 (ns,nmin) <- sMissingInbound s
131 -- outPrint $ "PacketRequest " ++ show (nmin,ns)
132 sendMessage (sTransport s) () (RequestResend PacketRequest ns)
133
134 re tm again e io = do
135 io
136 atomically $ modifyTVar' q $ PSQ.insert (fromEnum e) tm
137 again
138
139 doEvent again now e = case e of
140 DoTimeout -> do dput XNetCrypto $ "TIMEOUT: " ++ show (sSessionID s)
141 sClose s
142 DoAlive -> re (now + 10) again e doAlive
143 DoRequestMissing -> re (now + 5) again e doRequestMissing -- tox-core does this at 1 second intervals
144
145 fix $ \again -> do
146
147 now <- getPOSIXTime
148 join $ atomically $ do
149 Just ( k :-> tm ) <- PSQ.findMin <$> readTVar q
150 return $ if now < tm then threadDelay (toMicroseconds $ tm - now) >> again
151 else doEvent again now (toEnum k)
152
153-- | This function forks two threads: the 'keepAlive' beacon-sending thread and
154-- a thread to read all packets from the provided 'Session' and forward them to
155-- 'contactChannel' for a containing 'AggregateSession'
119forkSession :: AggregateSession -> Session -> (Status ToxProgress -> STM ()) -> IO ThreadId 156forkSession :: AggregateSession -> Session -> (Status ToxProgress -> STM ()) -> IO ThreadId
120forkSession c s setStatus = forkIO $ do 157forkSession c s setStatus = forkIO $ do
121 myThreadId >>= flip labelThread 158 myThreadId >>= flip labelThread
122 (intercalate "." ["s" 159 (intercalate "." ["s"
123 , take 8 $ show $ key2id $ ncTheirPublicKey s 160 , take 8 $ show $ key2id $ sTheirUserKey s
124 , show $ sSessionID s]) 161 , show $ sSessionID s])
125 tmchan <- atomically $ do 162
126 tmchan <- newTMChan 163 q <- atomically $ newTVar $ fromList
127 supply <- readTVar (listenerIDSupply $ ncAllSessions s) 164 [ fromEnum DoAlive :-> 0
128 let (listenerId,supply') = freshId supply 165 , fromEnum DoRequestMissing :-> 0
129 writeTVar (listenerIDSupply $ ncAllSessions s) supply' 166 ]
130 modifyTVar' (ncListeners s) (IntMap.insert listenerId (0,tmchan))
131 return tmchan
132 167
133 let sendPacket :: CryptoMessage -> STM () 168 let sendPacket :: CryptoMessage -> STM ()
134 sendPacket msg = writeTMChan (contactChannel c) (sSessionID s, msg) 169 sendPacket msg = writeTMChan (contactChannel c) (sSessionID s, msg)
135 170
136 inPrint e = dput XNetCrypto $ shows (sSessionID s,ncSockAddr s) $ " --> " ++ e 171 inPrint e = dput XNetCrypto $ shows (sSessionID s,sTheirAddr s) $ " --> " ++ e
172
173 bump = do
174 -- inPrint $ "BUMP: " ++ show (sSessionID s)
175 now <- getPOSIXTime
176 atomically $ modifyTVar' q $ PSQ.insert (fromEnum DoTimeout) (now + 15)
137 177
138 onPacket body loop Nothing = return () 178 onPacket body loop Nothing = return ()
139 onPacket body loop (Just (Left e)) = inPrint e >> loop 179 onPacket body loop (Just (Left e)) = inPrint e >> loop
140 onPacket body loop (Just (Right x)) = body loop x 180 onPacket body loop (Just (Right x)) = body loop x
141 181
142 awaitPacket body = fix $ (.) (fmap Right <$> atomically (readTMChan tmchan) >>=) 182 awaitPacket body = fix $ awaitMessage (sTransport s) . onPacket body
143 $ onPacket body
144 183
145 atomically $ setStatus $ InProgress AwaitingSessionPacket 184 atomically $ setStatus $ InProgress AwaitingSessionPacket
146 atomically $ setStatus Established 185 awaitPacket $ \_ (online,()) -> do
147 awaitPacket $ \loop x -> do 186 when (msgID online /= ONLINE) $ do
148 case msgID x of 187 inPrint $ "Unexpected initial packet: " ++ show (msgID online)
149 KillPacket -> return () 188 atomically $ do setStatus Established
150 _ -> atomically (sendPacket x) >> loop 189 sendPacket online
151 190 bump
152 atomically $ setStatus Dormant 191 beacon <- forkIO $ keepAlive s q
153 192 awaitPacket $ \awaitNext (x,()) -> do
154 193 bump
155sSessionID :: Session -> Int 194 case msgID x of
156sSessionID s = fromIntegral $ ncSessionId s 195 PING -> return ()
196 KillPacket -> sClose s
197 _ -> atomically $ sendPacket x
198 awaitNext
199 atomically $ setStatus Dormant
200 killThread beacon
157 201
158-- | Add a new session (in 'AwaitingSessionPacket' state) to the 202-- | Add a new session (in 'AwaitingSessionPacket' state) to the
159-- 'AggregateSession'. If the supplied session is not compatible because it is 203-- 'AggregateSession'. If the supplied session is not compatible because it is
@@ -166,8 +210,8 @@ sSessionID s = fromIntegral $ ncSessionId s
166addSession :: AggregateSession -> Session -> IO AddResult 210addSession :: AggregateSession -> Session -> IO AddResult
167addSession c s = do 211addSession c s = do
168 (result,mcon,replaced) <- atomically $ do 212 (result,mcon,replaced) <- atomically $ do
169 let them = ncTheirPublicKey s 213 let them = sTheirUserKey s
170 me = ncMyPublicKey s 214 me = toPublic $ sOurKey s
171 compat <- checkCompatible me them c 215 compat <- checkCompatible me them c
172 let result = case compat of 216 let result = case compat of
173 Nothing -> FirstSession 217 Nothing -> FirstSession
@@ -184,7 +228,7 @@ addSession c s = do
184 writeTVar (contactSession c) imap' 228 writeTVar (contactSession c) imap'
185 return (result,Just con,s0) 229 return (result,Just con,s0)
186 230
187 mapM_ (destroySession . singleSession) replaced 231 mapM_ (sClose . singleSession) replaced
188 forM_ mcon $ \con -> 232 forM_ mcon $ \con ->
189 forkSession c s $ \progress -> do 233 forkSession c s $ \progress -> do
190 writeTVar (singleStatus con) progress 234 writeTVar (singleStatus con) progress
@@ -203,6 +247,7 @@ addSession c s = do
203 return emap' 247 return emap'
204 writeTVar (contactEstablished c) emap' 248 writeTVar (contactEstablished c) emap'
205 return result 249 return result
250
206-- | Information returned from 'delSession'. 251-- | Information returned from 'delSession'.
207data DelResult = NoSession -- ^ Contact is completely disconnected. 252data DelResult = NoSession -- ^ Contact is completely disconnected.
208 | DeletedSession -- ^ Connection removed but session remains active. 253 | DeletedSession -- ^ Connection removed but session remains active.
@@ -230,11 +275,10 @@ delSession c sid = do
230 writeTVar (contactSession c) imap' 275 writeTVar (contactSession c) imap'
231 writeTVar (contactEstablished c) emap' 276 writeTVar (contactEstablished c) emap'
232 return ( IntMap.lookup sid imap, IntMap.null imap') 277 return ( IntMap.lookup sid imap, IntMap.null imap')
233 mapM_ (destroySession . singleSession) con 278 mapM_ (sClose . singleSession) con
234 return $ if r then NoSession 279 return $ if r then NoSession
235 else DeletedSession 280 else DeletedSession
236 281
237
238-- | Send a packet to one or all of the component sessions in the aggregate. 282-- | Send a packet to one or all of the component sessions in the aggregate.
239dispatchMessage :: AggregateSession -> Maybe Int -- ^ 'Nothing' to broadcast, otherwise SessionID. 283dispatchMessage :: AggregateSession -> Maybe Int -- ^ 'Nothing' to broadcast, otherwise SessionID.
240 -> CryptoMessage -> IO () 284 -> CryptoMessage -> IO ()
@@ -242,11 +286,7 @@ dispatchMessage c msid msg = join $ atomically $ do
242 imap <- readTVar (contactSession c) 286 imap <- readTVar (contactSession c)
243 let go = case msid of Nothing -> forM_ imap 287 let go = case msid of Nothing -> forM_ imap
244 Just sid -> forM_ (IntMap.lookup sid imap) 288 Just sid -> forM_ (IntMap.lookup sid imap)
245 return $ go $ \con -> do 289 return $ go $ \con -> sendMessage (sTransport $ singleSession con) () msg
246 eResult <- sendLossless (transportCrypto (ncAllSessions (singleSession con))) (singleSession con) msg
247 case eResult of
248 Left msg -> dput XJabber msg
249 Right pkt -> dput XJabber ("sendLossLess SUCCESS: " ++ show pkt)
250 290
251-- | Retry until: 291-- | Retry until:
252-- 292--
@@ -287,7 +327,6 @@ aggregateStatus c = do
287 | not (IntMap.null imap) -> InProgress AwaitingSessionPacket 327 | not (IntMap.null imap) -> InProgress AwaitingSessionPacket
288 | otherwise -> Dormant 328 | otherwise -> Dormant
289 329
290
291-- | Query whether the supplied ToxID keys are compatible with this aggregate. 330-- | Query whether the supplied ToxID keys are compatible with this aggregate.
292-- 331--
293-- [ Nothing ] Any keys would be compatible because there is not yet any 332-- [ Nothing ] Any keys would be compatible because there is not yet any
@@ -304,8 +343,8 @@ checkCompatible me them c = do
304 imap <- readTVar (contactSession c) 343 imap <- readTVar (contactSession c)
305 return $ case IntMap.elems imap of 344 return $ case IntMap.elems imap of
306 _ | isclosed -> Just False -- All keys are incompatible (closed). 345 _ | isclosed -> Just False -- All keys are incompatible (closed).
307 con:_ -> Just $ ncTheirPublicKey (singleSession con) == them 346 con:_ -> Just $ sTheirUserKey (singleSession con) == them
308 && (ncMyPublicKey $ singleSession con) == me 347 && toPublic (sOurKey $ singleSession con) == me
309 [] -> Nothing 348 [] -> Nothing
310 349
311-- | Returns the local and remote keys that are compatible with this aggregate. 350-- | Returns the local and remote keys that are compatible with this aggregate.
@@ -317,6 +356,6 @@ compatibleKeys c = do
317 imap <- readTVar (contactSession c) 356 imap <- readTVar (contactSession c)
318 return $ case IntMap.elems imap of 357 return $ case IntMap.elems imap of
319 _ | isclosed -> Nothing -- none. 358 _ | isclosed -> Nothing -- none.
320 con:_ -> Just ( ncMyPublicKey $ singleSession con 359 con:_ -> Just ( toPublic (sOurKey $ singleSession con)
321 , ncTheirPublicKey (singleSession con)) 360 , sTheirUserKey (singleSession con))
322 [] -> Nothing -- any. 361 [] -> Nothing -- any.
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 12:01:44 +0000