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
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
module Network.Tox.Onion.Handlers where
import Network.Kademlia.Search
import Network.Tox.DHT.Transport
import Network.Tox.DHT.Handlers hiding (Message,Client)
import Network.Tox.Onion.Transport
import Network.QueryResponse as QR hiding (Client)
import qualified Network.QueryResponse as QR (Client)
import Crypto.Tox
import qualified Data.Wrapper.PSQ as PSQ
;import Data.Wrapper.PSQ (PSQ)
import Crypto.Error.Types (CryptoFailable (..),
throwCryptoError)
import Control.Arrow
import System.IO
import qualified Data.ByteArray as BA
import Data.Function
import Data.Serialize as S
import qualified Data.Wrapper.PSQInt as Int
import Network.Kademlia
import Network.Address (WantIP (..), ipFamily, testIdBit)
import qualified Network.Kademlia.Routing as R
import Control.TriadCommittee
import qualified Data.MinMaxPSQ as MinMaxPSQ
;import Data.MinMaxPSQ (MinMaxPSQ')
import Network.BitTorrent.DHT.Token as Token
import Control.Exception hiding (Handler)
import Control.Monad
import Control.Concurrent.STM
import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
import Network.Socket
import Data.IP
import Data.Maybe
import Data.Bits
import Data.Ord
import Data.Functor.Identity
type Client r = QR.Client String PacketKind TransactionId (OnionDestination r) Message
type Message = OnionMessage Identity
classify :: Message -> MessageClass String PacketKind TransactionId
classify msg = go msg
where
go (OnionAnnounce announce) = IsQuery AnnounceType
$ TransactionId (snd $ runIdentity $ assymData announce)
(assymNonce announce)
go (OnionAnnounceResponse n8 n24 resp) = IsResponse (TransactionId n8 n24)
go (OnionToRoute {}) = IsQuery DataRequestType (TransactionId (Nonce8 0) (Nonce24 zeros24))
go (OnionToRouteResponse {}) = IsResponse (TransactionId (Nonce8 0) (Nonce24 zeros24))
-- Toxcore generates `ping_id`s by taking a 32 byte sha hash of the current time,
-- some secret bytes generated when the instance is created, the current time
-- divided by a 20 second timeout, the public key of the requester and the source
-- ip/port that the packet was received from. Since the ip/port that the packet
-- was received from is in the `ping_id`, the announce packets being sent with a
-- ping id must be sent using the same path as the packet that we received the
-- `ping_id` from or announcing will fail.
--
-- The reason for this 20 second timeout in toxcore is that it gives a reasonable
-- time (20 to 40 seconds) for a peer to announce himself while taking in count
-- all the possible delays with some extra seconds.
-- dhtd: src/Network/Tox/Onion/Handlers.hs:(67,1)-(101,23): Non-exhaustive patterns in function announceH
announceH :: Routing -> TVar SessionTokens -> TVar AnnouncedKeys -> OnionDestination r -> AnnounceRequest -> IO AnnounceResponse
announceH routing toks keydb oaddr req = do
case () of
_ | announcePingId req == zeros32
-> go False
_ -> let Nonce32 bs = announcePingId req
tok = fromPaddedByteString 32 bs
in checkToken toks (onionNodeInfo oaddr) tok >>= go
`catch` (\(SomeException e) -> hPutStrLn stderr ("announceH Exception! "++show e) >> throw e)
where
go withTok = do
let naddr = onionNodeInfo oaddr
ns <- getNodesH routing naddr (GetNodes (announceSeeking req))
tm <- getPOSIXTime
let storing = case oaddr of
OnionToOwner _ pth -> guard (nodeId naddr == announceSeeking req) >> Just pth
_ -> Nothing
record <- atomically $ do
forM_ storing $ \retpath -> when withTok $ do
let toxpath = AnnouncedRoute naddr{ nodeId = announceKey req } retpath
-- Note: The following distance calculation assumes that
-- our nodeid doesn't change and is the same for both
-- routing4 and routing6.
d = xorNodeId (nodeId (tentativeId routing))
(announceSeeking req)
modifyTVar' keydb (insertKey tm (announceSeeking req) toxpath d)
ks <- readTVar keydb
return $ snd . snd <$> MinMaxPSQ.lookup' (announceSeeking req) (keyAssoc ks)
newtok <- maybe (return $ zeros32)
(const $ Nonce32 . toPaddedByteString 32 <$> grantToken toks naddr)
storing
let k = case record of
Nothing -> NotStored newtok
Just _ | isJust storing -> Acknowledged newtok
Just (AnnouncedRoute ni _) -> SendBackKey $ id2key (nodeId ni)
let response = AnnounceResponse k ns
hPutStrLn stderr $ unwords ["Announce:", show req, "-reply->", show response]
return response
dataToRouteH ::
TVar AnnouncedKeys
-> Transport err (OnionDestination r) (OnionMessage f)
-> addr
-> OnionMessage f
-> IO ()
dataToRouteH keydb udp _ (OnionToRoute pub assym) = do
let k = key2id pub
mb <- atomically $ do
ks <- readTVar keydb
forM (MinMaxPSQ.lookup' k (keyAssoc ks)) $ \(p,(cnt,rpath)) -> do
writeTVar keydb $ ks { keyAssoc = MinMaxPSQ.insert' k (cnt + 1, rpath) p (keyAssoc ks) }
return rpath
forM_ mb $ \rpath -> do
-- forward
sendMessage udp (toOnionDestination rpath) $ OnionToRouteResponse assym
hPutStrLn stderr $ "Forwarding data-to-route -->"++show k
type NodeDistance = NodeId
data AnnouncedRoute = AnnouncedRoute NodeInfo (ReturnPath N3)
toOnionDestination :: AnnouncedRoute -> OnionDestination r
toOnionDestination (AnnouncedRoute ni rpath) = OnionToOwner ni rpath
data AnnouncedKeys = AnnouncedKeys
{ keyByAge :: !(PSQ NodeId (Down POSIXTime)) -- timeout of 300 seconds
, keyAssoc :: !(MinMaxPSQ' NodeId NodeDistance (Int,AnnouncedRoute))
}
insertKey :: POSIXTime -> NodeId -> AnnouncedRoute -> NodeDistance -> AnnouncedKeys -> AnnouncedKeys
insertKey tm pub toxpath d keydb = AnnouncedKeys
{ keyByAge = PSQ.insert pub (Down tm) (keyByAge keydb)
, keyAssoc = case MinMaxPSQ.lookup' pub (keyAssoc keydb) of
Just (_,(cnt,_)) -> MinMaxPSQ.insert' pub (cnt,toxpath) d (keyAssoc keydb)
Nothing -> MinMaxPSQ.insert' pub (0 ,toxpath) d (keyAssoc keydb)
}
areq :: Message -> Either String AnnounceRequest
areq (OnionAnnounce assym) = Right $ fst $ runIdentity $ assymData assym
areq _ = Left "Unexpected non-announce OnionMessage"
handlers :: Transport err (OnionDestination r) Message
-> Routing
-> TVar SessionTokens
-> TVar AnnouncedKeys
-> PacketKind
-> Maybe (MethodHandler String TransactionId (OnionDestination r) Message)
handlers net routing toks keydb AnnounceType
= Just
$ MethodHandler areq (\(TransactionId n8 n24) src dst -> OnionAnnounceResponse n8 n24 . Identity)
$ announceH routing toks keydb
handlers net _ _ keydb _ = Just $ NoReply Right $ dataToRouteH keydb net
toxidSearch :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
-> Client r
-> Search NodeId (IP, PortNumber) (Maybe Nonce32) NodeInfo PublicKey
toxidSearch getTimeout client = Search
{ searchSpace = toxSpace
, searchNodeAddress = nodeIP &&& nodePort
, searchQuery = announce getTimeout client
}
announceSerializer :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
-> MethodSerializer
TransactionId
(OnionDestination r)
(OnionMessage Identity)
PacketKind
AnnounceRequest
(Maybe AnnounceResponse)
announceSerializer getTimeout = MethodSerializer
{ methodTimeout = getTimeout
, method = AnnounceType
, wrapQuery = \(TransactionId n8 n24) src dst req ->
-- :: tid -> addr -> addr -> a -> OnionMessage Identity
OnionAnnounce $ Assym
{ -- The public key is our real long term public key if we want to
-- announce ourselves, a temporary one if we are searching for
-- friends.
senderKey = fromJust $ onionKey src -- TODO: FIXME: this should be a temporary alias key
, assymNonce = n24
, assymData = Identity (req, n8)
}
, unwrapResponse = \case -- :: OnionMessage Identity -> b
OnionAnnounceResponse _ _ resp -> Just $ runIdentity resp
_ -> Nothing
}
unwrapAnnounceResponse :: AnnounceResponse -> ([NodeInfo], [PublicKey], Maybe Nonce32)
unwrapAnnounceResponse (AnnounceResponse is_stored (SendNodes ns))
= case is_stored of
NotStored n32 -> (ns, [], Just n32)
SendBackKey k -> (ns, [k], Nothing)
Acknowledged n32 -> (ns, [], Just n32)
announce :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
-> Client r
-> NodeId
-> NodeInfo
-> IO (Maybe ([NodeInfo],[PublicKey],Maybe Nonce32))
announce getTimeout client nid ni =
-- Four tries and then we tap out.
flip fix 4 $ \loop n -> do
let oaddr = OnionDestination ni Nothing
mb <- QR.sendQuery client (announceSerializer getTimeout) (AnnounceRequest zeros32 nid zeroID) oaddr
maybe (if n>0 then loop $! n - 1 else return Nothing)
(return . Just . unwrapAnnounceResponse)
$ join mb
|
