summaryrefslogtreecommitdiff
path: root/dht/examples/testTox.hs
blob: 6db977bef27cb1e511a848833c3ed705a6510852 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
#ifdef THREAD_DEBUG
import Control.Concurrent.Lifted.Instrument
#else
import Control.Concurrent.Lifted
#endif
import Control.Concurrent.STM.TChan
import Control.Concurrent.STM.TMChan
import Control.Concurrent.STM.TVar
import Control.Monad
import Control.Monad.STM
import Crypto.Tox
import qualified Data.IntMap.Strict          as IntMap
import Data.Function
import DebugUtil
import DPut
import DebugTag
import HandshakeCache
import Network.QueryResponse
import Network.Socket
import Network.Tox
import Network.Tox.ContactInfo
import Network.Tox.Session
import Network.Tox.Crypto.Transport
import Network.Tox.DHT.Handlers              as DHT
import Network.Tox.DHT.Transport
import Network.Tox.Onion.Transport
import Connection
import qualified Data.HashMap.Strict as HashMap
         ;import Data.HashMap.Strict (HashMap)
import qualified Data.Map.Strict as Map
import Data.Time.Clock.POSIX
import System.Exit
import Data.Dependent.Sum
import Data.Tox.Msg

makeToxNode :: UDPTransport -> Maybe SecretKey
        -> ( ContactInfo extra -> SockAddr -> Session -> IO () )
        -> IO (Tox extra)
makeToxNode udp sec onSessionF = do
    keysdb <- newKeysDatabase
    crypto <- newToxCrypto sec
    newToxOverTransport keysdb
                        (SockAddrInet 0 0)
                        onSessionF
                        crypto
                        udp
                        Nothing


setToxID :: Tox () -> Maybe SecretKey -> IO ()
setToxID tox (Just sec) = atomically $ addContactInfo (toxContactInfo tox) sec ()

sessionChan :: TVar (Map.Map PublicKey [Session]) -> TChan (TMChan CryptoMessage)
                -> ContactInfo extra -> SockAddr -> Session -> IO ()
sessionChan remotes tchan acnt saddr s = do
    ch <- atomically $ do
        modifyTVar' remotes $  (`Map.alter` sTheirUserKey s) $ \case
            Just ss  -> Just (s : ss)
            Nothing  -> Just [s]
        session_chan <- newTMChan
        writeTChan tchan session_chan
        return session_chan
    let onPacket loop Nothing          = return ()
        onPacket loop (Just (Left e))  = dput XUnused e >> loop
        onPacket loop (Just (Right (x,()))) = do
            atomically $ writeTMChan ch x
            loop
    -- forkIO $ fix $ awaitMessage (sTransport s) . onPacket
    return ()

netCrypto :: Tox extra -> SecretKey -> NodeInfo -> PublicKey -> IO ()
netCrypto tox me ni them = do
    mcookie <- cookieRequest (toxCryptoKeys tox) (toxDHT tox) (toPublic me) ni
    case mcookie of
        Just cookie -> do
            hs <- cacheHandshake (toxHandshakeCache tox) me them ni cookie
            sendMessage (toxHandshakes tox) (nodeAddr ni) hs
        Nothing -> do
            dput XUnused "Timeout requesting cookie."


main :: IO ()
main = do
    mapM_ setVerbose ([ minBound .. maxBound ]::[DebugTag])
    setQuiet XRoutes

    (udpA,udpB) <- testPairTransport

    a_remotes <- atomically (newTVar Map.empty)
    a_sessions <- atomically newTChan
    a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf
        <- makeToxNode udpA (decodeSecret "YrJQFG7Xppg4WAyhooONNGSCRVQbrRF9L4VoQQsetF")
                            (sessionChan a_remotes a_sessions)
    a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf
        `setToxID` -- BDDj3maMmK8hR3mTpju29wmtE2YJ5cf8NlNEWi1dXlI
            decodeSecret "UdZUB9Mf1RD3pVGh02OsRJM6YpmGqJiVxYGVIVHkAG"

    -- a_sessions <- sessionChan a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf

    b_remotes <- atomically (newTVar Map.empty)
    b_sessions <- atomically newTChan
    let b = read "OM7znaPMYkTbm.9GcZJAdnDATXmZxZ9fnaSTP3qNCZk@2.0.0.0:2"
    b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk
        <- makeToxNode udpB (decodeSecret "Lm2pnsu1+80I8h9txMoZyGgcNwfaoqBlIfg5TwWUXL")
                            (sessionChan b_remotes b_sessions)
    b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk
        `setToxID` -- AvETKhO-YqnNRopZrj8K3xUpGtGbX0sLhZZjh2VufJB
            decodeSecret "L7WNtNIbm0ajNlPrkWvSRpn0nypTUZxlHBckZPlTje"

    -- b_sessions <- sessionChan b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk

    (a_quit,_,_) <- forkTox a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf False False
    (b_quit,_,_) <- forkTox b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk False False

    threadReport False >>= putStrLn

    [(a_secret,a_public)] <- atomically (userKeys (toxCryptoKeys a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf))
    [(_,b_public)] <- atomically (userKeys (toxCryptoKeys b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk))
    mbAccount <- atomically $ do
        accs <- readTVar (accounts $ toxContactInfo a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf)
        return $ HashMap.lookup (key2id a_public) accs
    now <- getPOSIXTime
    case mbAccount of
       Just account -> atomically $ do
            setContactPolicy b_public TryingToConnect account
            setContactAddr now b_public b account
       Nothing -> dput XUnused "MISSING Account!"

    dput XUnused $ "a_public = " ++ show (key2id a_public)
    dput XUnused $ "BDD... = " ++ show (read "BDDj3maMmK8hR3mTpju29wmtE2YJ5cf8NlNEWi1dXlI":: NodeId)

    -- Tell /a/ about /b/'s DHT-key.
    updateContactInfo (toxContactInfo a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf)
                      (AnnouncedRendezvous (id2key $ read "AvETKhO-YqnNRopZrj8K3xUpGtGbX0sLhZZjh2VufJB") -- b toxid
                                           (Rendezvous (error "pointless mitm key") b))
                    $ ( id2key $ read "BDDj3maMmK8hR3mTpju29wmtE2YJ5cf8NlNEWi1dXlI" -- a toxid
                      , OnionDHTPublicKey DHTPublicKey
                        { dhtpkNonce = 0
                        , dhtpk      = id2key $ nodeId b
                        , dhtpkNodes = SendNodes []
                        }
                      )

    DHT.ping (toxDHT a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf) b

    -- sendMessage (toxHandshakes a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf) (nodeAddr b) hs

    (b_quit,_,_) <- forkTox b_OM7znaPMYkTbm'9GcZJAdnDATXmZxZ9fnaSTP3qNCZk False False

    forkIO $ do
        tid <- myThreadId
        labelThread tid "testToxLaunch"
        netCrypto a_Ct7g5azVcJ8KnvxzbXs9GqeqcjrP7VdZXIC'uHeTlRf a_secret b b_public
        dput XUnused "REACHEDREACHEDREACHEDREACHED"
        dput XUnused "REACHEDREACHEDREACHEDREACHED"
        dput XUnused "REACHEDREACHEDREACHEDREACHED"
        threadDelay 1000000
        -- a says "Howdy"
        mp_a <- atomically . readTVar $ a_remotes
        case Map.lookup b_public mp_a of
            Just [session] -> do
                dput XUnused "----------------- HOWDY ---------------"
                sendMessage (sTransport session) () (Pkt MESSAGE :=> "Howdy")
            Just xs -> dput XUnused "Unexpectedly a has TOO MANY sesions for b"
            Nothing -> dput XUnused "Unexpectedly a has NO session for b"
        -- b says "Hey you!"
        mp_b <- atomically . readTVar $ b_remotes
        case Map.lookup a_public mp_b of
            Just [session] -> do
                dput XUnused "----------------- HEY YOU ---------------"
                sendMessage (sTransport session) () (Pkt MESSAGE :=> "Hey you!")
            Just xs -> dput XUnused "Unexpectedly b has TOO MANY sesions for a"
            Nothing -> dput XUnused "Unexpectedly b has NO session for a"

    putStrLn "Type Enter to quit..."
    getLine

    a_quit
    b_quit

    threadDelay 500000
    threadReport False >>= putStrLn