summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2017-09-14 20:29:47 -0400
committerjoe <joe@jerkface.net>2017-09-14 20:29:47 -0400
commitf9ca5de790ea7d430b70471f476ad7b1823b8c0a (patch)
tree49a0b2143755e917a0b801bdeefce88716d0e93c
parent7e44a19fae9bc9f90c38641cbc5cf8af9c540ecb (diff)
Switched to the 3-transports (DHT,Onion,Crypto) Tox design.
Diffstat
-rw-r--r--Mainline.hs9
-rw-r--r--Tox.hs1404
-rwxr-xr-xc2
-rw-r--r--examples/dhtd.hs311
-rw-r--r--src/Network/Address.hs4
-rw-r--r--src/Network/QueryResponse.hs25
6 files changed, 373 insertions, 1382 deletions
diff --git a/Mainline.hs b/Mainline.hs
index 44fd6f33..54de925d 100644
--- a/Mainline.hs
+++ b/Mainline.hs
@@ -435,7 +435,7 @@ showParseError bs addr err = showPacket (L8.pack err :) addr " --> " bs
435parsePacket :: ByteString -> SockAddr -> Either String (Message BValue, NodeInfo) 435parsePacket :: ByteString -> SockAddr -> Either String (Message BValue, NodeInfo)
436parsePacket bs addr = left (showParseError bs addr) $ do 436parsePacket bs addr = left (showParseError bs addr) $ do
437 pkt <- BE.decode bs 437 pkt <- BE.decode bs
438 -- TODO: Error packets do not inclucde a valid msgOrigin. 438 -- TODO: Error packets do not include a valid msgOrigin.
439 -- The BE.decode method is using 'zeroID' as a placeholder. 439 -- The BE.decode method is using 'zeroID' as a placeholder.
440 ni <- nodeInfo (msgOrigin pkt) addr 440 ni <- nodeInfo (msgOrigin pkt) addr
441 return (pkt, ni) 441 return (pkt, ni)
@@ -514,8 +514,8 @@ traced (TableMethods ins del lkup)
514 514
515type MainlineClient = Client String Method TransactionId NodeInfo (Message BValue) 515type MainlineClient = Client String Method TransactionId NodeInfo (Message BValue)
516 516
517newClient :: SockAddr -> IO (MainlineClient, Routing, SwarmsDatabase) 517newClient :: SwarmsDatabase -> SockAddr -> IO (MainlineClient, Routing)
518newClient addr = do 518newClient swarms addr = do
519 udp <- udpTransport addr 519 udp <- udpTransport addr
520 nid <- NodeId <$> getRandomBytes 20 520 nid <- NodeId <$> getRandomBytes 20
521 let tentative_info = NodeInfo 521 let tentative_info = NodeInfo
@@ -554,7 +554,6 @@ newClient addr = do
554 sched4 <- newTVar Int.empty 554 sched4 <- newTVar Int.empty
555 sched6 <- newTVar Int.empty 555 sched6 <- newTVar Int.empty
556 return $ Routing tentative_info sched4 tbl4 committee4 sched6 tbl6 committee6 556 return $ Routing tentative_info sched4 tbl4 committee4 sched6 tbl6 committee6
557 swarms <- newSwarmsDatabase
558 map_var <- atomically $ newTVar (0, mempty) 557 map_var <- atomically $ newTVar (0, mempty)
559 let net = onInbound (updateRouting outgoingClient routing) 558 let net = onInbound (updateRouting outgoingClient routing)
560 $ layerTransport parsePacket encodePacket 559 $ layerTransport parsePacket encodePacket
@@ -628,7 +627,7 @@ newClient addr = do
628 (sched6 routing) 627 (sched6 routing)
629 (refreshBucket (nodeSearch client) (routing6 routing)) 628 (refreshBucket (nodeSearch client) (routing6 routing))
630 629
631 return (client, routing, swarms) 630 return (client, routing)
632 631
633-- | Modifies a purely random 'NodeId' to one that is related to a given 632-- | Modifies a purely random 'NodeId' to one that is related to a given
634-- routable address in accordance with BEP 42. 633-- routable address in accordance with BEP 42.
diff --git a/Tox.hs b/Tox.hs
index 03b1ee05..d0656574 100644
--- a/Tox.hs
+++ b/Tox.hs
@@ -6,6 +6,7 @@
6{-# LANGUAGE ExistentialQuantification #-} 6{-# LANGUAGE ExistentialQuantification #-}
7{-# LANGUAGE FlexibleInstances #-} 7{-# LANGUAGE FlexibleInstances #-}
8{-# LANGUAGE GeneralizedNewtypeDeriving #-} 8{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9{-# LANGUAGE LambdaCase #-}
9{-# LANGUAGE NamedFieldPuns #-} 10{-# LANGUAGE NamedFieldPuns #-}
10{-# LANGUAGE PatternSynonyms #-} 11{-# LANGUAGE PatternSynonyms #-}
11{-# LANGUAGE RankNTypes #-} 12{-# LANGUAGE RankNTypes #-}
@@ -68,7 +69,7 @@ import Kademlia
68import Network.Address (Address, WantIP (..), either4or6, 69import Network.Address (Address, WantIP (..), either4or6,
69 fromSockAddr, ipFamily, setPort, 70 fromSockAddr, ipFamily, setPort,
70 sockAddrPort, testIdBit, 71 sockAddrPort, testIdBit,
71 toSockAddr, un4map, genBucketSample') 72 toSockAddr, un4map)
72import Network.BitTorrent.DHT.Search (Search (..)) 73import Network.BitTorrent.DHT.Search (Search (..))
73import qualified Network.DHT.Routing as R 74import qualified Network.DHT.Routing as R
74import Network.QueryResponse 75import Network.QueryResponse
@@ -78,619 +79,88 @@ import System.IO
78import qualified Text.ParserCombinators.ReadP as RP 79import qualified Text.ParserCombinators.ReadP as RP
79import Text.Printf 80import Text.Printf
80import Text.Read 81import Text.Read
81import ToxMessage as Tox hiding (Ping,Pong,SendNodes,GetNodes,AnnounceResponse) 82import ToxMessage as Tox hiding (Ping,Pong,SendNodes,GetNodes,AnnounceResponse,Nonce24,Nonce8)
82 ;import ToxMessage (bin2hex, quoted) 83 ;import ToxMessage (bin2hex, quoted)
83import TriadCommittee 84import TriadCommittee
84import Network.BitTorrent.DHT.Token as Token 85import Network.BitTorrent.DHT.Token as Token
85import GHC.TypeLits 86import GHC.TypeLits
86 87
87{- 88import ToxCrypto hiding (Assym)
88newtype NodeId = NodeId ByteString 89import ToxTransport
89 deriving (Eq,Ord,ByteArrayAccess, Bits, Hashable) 90import ToxAddress
90-} 91import qualified DHTTransport as DHT
91 92import qualified DHTHandlers as DHT
92type NodeId = Tox.PubKey 93import qualified OnionTransport as Onion
93 94import qualified OnionHandlers as Onion
94{- 95import CryptoTransport (NetCrypto)
95instance Show NodeId where 96import XXD
96 show (NodeId bs) = C8.unpack $ Base16.encode bs 97
97 98newCrypto :: IO TransportCrypto
98instance S.Serialize NodeId where 99newCrypto = do
99 get = NodeId <$> S.getBytes 32
100 put (NodeId bs) = S.putByteString bs
101
102instance FiniteBits NodeId where
103 finiteBitSize _ = 256
104
105instance Read NodeId where
106 readsPrec _ str
107 | (bs, xs) <- Base16.decode $ C8.pack str
108 , B.length bs == 32
109 = [ (NodeId bs, drop 64 str) ]
110 | otherwise = []
111-}
112
113zeroID :: NodeId
114zeroID = Tox.PubKey $ B.replicate 32 0
115
116data NodeInfo = NodeInfo
117 { nodeId :: NodeId
118 , nodeIP :: IP
119 , nodePort :: PortNumber
120 }
121 deriving (Eq,Ord)
122
123instance ToJSON NodeInfo where
124 toJSON (NodeInfo nid (IPv4 ip) port)
125 = JSON.object [ "public_key" .= show nid
126 , "ipv4" .= show ip
127 , "port" .= (fromIntegral port :: Int)
128 ]
129 toJSON (NodeInfo nid (IPv6 ip6) port)
130 | Just ip <- un4map ip6
131 = JSON.object [ "public_key" .= show nid
132 , "ipv4" .= show ip
133 , "port" .= (fromIntegral port :: Int)
134 ]
135 | otherwise
136 = JSON.object [ "public_key" .= show nid
137 , "ipv6" .= show ip6
138 , "port" .= (fromIntegral port :: Int)
139 ]
140instance FromJSON NodeInfo where
141 parseJSON (JSON.Object v) = do
142 nidstr <- v JSON..: "public_key"
143 ip6str <- v JSON..:? "ipv6"
144 ip4str <- v JSON..:? "ipv4"
145 portnum <- v JSON..: "port"
146 ip <- maybe empty (return . IPv6) (ip6str >>= readMaybe)
147 <|> maybe empty (return . IPv4) (ip4str >>= readMaybe)
148 let (bs,_) = Base16.decode (C8.pack nidstr)
149 guard (B.length bs == 32)
150 return $ NodeInfo (Tox.PubKey bs) ip (fromIntegral (portnum :: Word16))
151
152getIP :: Word8 -> S.Get IP
153getIP 0x02 = IPv4 <$> S.get
154getIP 0x0a = IPv6 <$> S.get
155getIP 0x82 = IPv4 <$> S.get -- TODO: TCP
156getIP 0x8a = IPv6 <$> S.get -- TODO: TCP
157getIP x = fail ("unsupported address family ("++show x++")")
158
159instance S.Serialize NodeInfo where
160 get = do
161 addrfam <- S.get :: S.Get Word8
162 ip <- getIP addrfam
163 port <- S.get :: S.Get PortNumber
164 nid <- S.get
165 return $ NodeInfo nid ip port
166
167 put (NodeInfo nid ip port) = do
168 case ip of
169 IPv4 ip4 -> S.put (2 :: Word8) >> S.put ip4
170 IPv6 ip6 -> S.put (10 :: Word8) >> S.put ip6
171 S.put port
172 S.put nid
173
174-- node format:
175-- [uint8_t family (2 == IPv4, 10 == IPv6, 130 == TCP IPv4, 138 == TCP IPv6)]
176-- [ip (in network byte order), length=4 bytes if ipv4, 16 bytes if ipv6]
177-- [port (in network byte order), length=2 bytes]
178-- [char array (node_id), length=32 bytes]
179--
180
181
182hexdigit :: Char -> Bool
183hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F')
184
185instance Read NodeInfo where
186 readsPrec i = RP.readP_to_S $ do
187 RP.skipSpaces
188 let n = 64 -- characters in node id.
189 parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')'))
190 RP.+++ RP.munch (not . isSpace)
191 nodeidAt = do hexhash <- sequence $ replicate n (RP.satisfy hexdigit)
192 RP.char '@' RP.+++ RP.satisfy isSpace
193 addrstr <- parseAddr
194 nid <- case Base16.decode $ C8.pack hexhash of
195 (bs,_) | B.length bs==32 -> return (Tox.PubKey bs)
196 _ -> fail "Bad node id."
197 return (nid,addrstr)
198 (nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) )
199 let raddr = do
200 ip <- RP.between (RP.char '[') (RP.char ']')
201 (IPv6 <$> RP.readS_to_P (readsPrec i))
202 RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i))
203 _ <- RP.char ':'
204 port <- toEnum <$> RP.readS_to_P (readsPrec i)
205 return (ip, port)
206
207 (ip,port) <- case RP.readP_to_S raddr addrstr of
208 [] -> fail "Bad address."
209 ((ip,port),_):_ -> return (ip,port)
210 return $ NodeInfo nid ip port
211
212
213-- The Hashable instance depends only on the IP address and port number.
214instance Hashable NodeInfo where
215 hashWithSalt s ni = hashWithSalt s (nodeIP ni , nodePort ni)
216 {-# INLINE hashWithSalt #-}
217
218
219instance Show NodeInfo where
220 showsPrec _ (NodeInfo nid ip port) =
221 shows nid . ('@' :) . showsip . (':' :) . shows port
222 where
223 showsip
224 | IPv4 ip4 <- ip = shows ip4
225 | IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = shows ip4
226 | otherwise = ('[' :) . shows ip . (']' :)
227
228nodeAddr :: NodeInfo -> SockAddr
229nodeAddr (NodeInfo _ ip port) = setPort port $ toSockAddr ip
230
231nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo
232nodeInfo nid saddr
233 | Just ip <- fromSockAddr saddr
234 , Just port <- sockAddrPort saddr = Right $ NodeInfo nid ip port
235 | otherwise = Left "Address family not supported."
236
237data TransactionId = TransactionId
238 { transactionKey :: Tox.Nonce8 -- ^ Used to lookup pending query.
239 , cryptoNonce :: Tox.Nonce24 -- ^ Used during the encryption layer.
240 }
241
242-- 0x18 Cookie Request
243-- 0x19 Cookie Response
244-- 0x1a Crypto Handshake
245-- 0x1b Crypto Data
246
247-- 0x21 LAN Discovery
248
249{-
250newtype Tox.Nonce24 = Tox.Nonce24 ByteString
251 deriving (Eq, Ord, ByteArrayAccess)
252
253instance show tox.nonce24 where
254 showsprec d nonce = quoted (mappend $ bin2hex nonce)
255
256instance S.Serialize Tox.Nonce24 where
257 get = Tox.Nonce24 <$> S.getBytes 24
258 put (Tox.Nonce24 bs) = S.putByteString bs
259-}
260
261newtype SymmetricCiphered = SymmetricCiphered ByteString
262 deriving (Eq,Show)
263
264{-
265data Message a = Message
266 { msgType :: Method
267 , msgOrigin :: NodeId
268 , msgNonce :: Tox.Nonce24 -- cryptoNonce of TransactionId
269 , msgReturnPath :: Maybe (Tox.Nonce24,SymmetricCiphered)
270 , msgPayload :: a
271 }
272 deriving (Eq, Show, Generic, Functor, Foldable, Traversable)
273-}
274
275data Msg = Msg
276 { msgType :: Tox.PacketKind
277 , msgNonce :: Tox.Nonce24
278 , msgData :: ByteString
279 , msgSendBack :: Tox.Nonce8
280 }
281 deriving Show
282
283
284-- typeHasEncryptedPayload OnionResponse1Type = False
285-- typeHasEncryptedPayload _ = True
286
287{-
288msgDHTKey Message{ msgOrigin, msgType = PingType } = Just msgOrigin
289msgDHTKey Message{ msgOrigin, msgType = PongType } = Just msgOrigin
290msgDHTKey Message{ msgOrigin, msgType = GetNodesType } = Just msgOrigin
291msgDHTKey Message{ msgOrigin, msgType = SendNodesType } = Just msgOrigin
292msgDHTKey Message{ msgOrigin, msgType = OnionRequest0 } = Just msgOrigin
293msgDHTKey _ = Nothing
294-}
295
296data Ciphered = Ciphered { cipheredMAC :: Poly1305.Auth
297 , cipheredBytes :: ByteString }
298 deriving Eq
299
300newtype OnionPayload = OnionPayload { unpackOnionPayload :: ByteString }
301
302instance S.Serialize OnionPayload where
303 get = OnionPayload <$> (S.remaining >>= S.getBytes)
304 put (OnionPayload bs) = S.putByteString bs
305
306{-
307getMessage :: S.Get (Message (Either OnionPayload Ciphered))
308getMessage = do
309 typ <- S.get
310 (nid,nonce) <- case typ of -- Seriously... what the fuck?
311 DHTRequestType -> do
312 S.skip 32 -- TODO: get destination key
313 -- If it is ours, decrypt and handle.
314 -- If not ours, search routing table and forward if it's in there.
315 flip (,) <$> S.get <*> S.get
316 OnionRequest0 -> flip (,) <$> S.get <*> S.get
317 OnionRequest1 -> flip (,) <$> S.get <*> S.get
318 -- OnionRequest2 -> flip (,) <$> S.get <*> S.get
319 AnnounceType -> flip (,) <$> S.get <*> S.get
320 OnionResponse1 -> (NodeId $ BA.convert zeros32,) <$> S.get -- XXX: no msgOrigin!
321 _ -> (,) <$> S.get <*> S.get
322 (payload,rpath) <- case typ of
323 OnionResponse1 -> do
324 rpath <- Just . SymmetricCiphered <$> S.getBytes (16 + 19)
325 payload <- Left . OnionPayload <$> (S.remaining >>= S.getBytes)
326 return (payload,rpath)
327 _ -> do
328 payload <- Right <$> getCiphered
329 return (payload,Nothing)
330 return Message { msgType = typ
331 , msgOrigin = nid
332 , msgNonce = nonce
333 , msgReturnPath = rpath
334 , msgPayload = payload }
335
336putOnionPayload :: OnionPayload -> S.Put
337putOnionPayload (OnionPayload bs) = S.putByteString bs
338
339putMessage :: Message (Either OnionPayload Ciphered) -> S.Put
340putMessage (Message {..}) = do
341 S.put msgType
342 case msgType of -- Seriously... what the fuck?
343 DHTRequestType -> S.put msgNonce >> S.put msgOrigin
344 OnionRequest0 -> S.put msgNonce >> S.put msgOrigin
345 OnionRequest1 -> S.put msgNonce >> S.put msgOrigin
346 -- OnionRequest2 -> S.put msgNonce >> S.put msgOrigin
347 AnnounceType -> S.put msgNonce >> S.put msgOrigin
348 _ -> S.put msgOrigin >> S.put msgNonce
349 let putPayload = either putOnionPayload putCiphered msgPayload
350 putReturnPath = forM_ msgReturnPath
351 $ \(nonce,SymmetricCiphered bs) -> do S.put nonce
352 S.putByteString bs
353 case msgType of
354 OnionResponse1 -> putReturnPath >> putPayload
355 _ -> putPayload >> putReturnPath
356-}
357
358{-
359data Plain a = Plain
360 { plainId :: Tox.Nonce8 -- transactionKey of TransactionId
361 , plainPayload :: a
362 }
363 deriving (Eq, Show, Generic, Functor, Foldable, Traversable)
364
365instance Serialize a => Serialize (Plain a) where
366 get = flip Plain <$> get get
367 put (Plain tid a) = put a >> put tid
368-}
369
370-- TODO: Cache shared symmetric keys.
371data SecretsCache = SecretsCache
372newEmptyCache = return SecretsCache
373
374id2key :: NodeId -> PublicKey
375id2key recipient = case publicKey recipient of
376 CryptoPassed key -> key
377 -- This should never happen because a NodeId is 32 bytes.
378 CryptoFailed e -> error ("Unexpected pattern fail: "++show e)
379
380key2id :: PublicKey -> NodeId
381key2id pk = case S.decode (BA.convert pk) of
382 Left _ -> error "key2id"
383 Right nid -> nid
384
385
386zeros32 :: Nonce32
387zeros32 = Nonce32 $ BA.replicate 32 0
388
389zeros24 :: ByteString
390zeros24 = BA.take 24 zs where Nonce32 zs = zeros32
391
392hsalsa20 k n = a <> b
393 where
394 Salsa.State st = XSalsa.initialize 20 k n
395 (_, as) = BA.splitAt 4 st
396 (a, xs) = BA.splitAt 16 as
397 (_, bs) = BA.splitAt 24 xs
398 (b, _ ) = BA.splitAt 16 bs
399
400
401computeSharedSecret :: SecretKey -> NodeId -> Tox.Nonce24 -> (Poly1305.State, XSalsa.State)
402computeSharedSecret sk recipient nonce = (hash, crypt)
403 where
404 -- diffie helman
405 shared = ecdh (Proxy :: Proxy Curve_X25519) sk (id2key recipient)
406 -- shared secret XSalsa key
407 k = hsalsa20 shared zeros24
408 -- cipher state
409 st0 = XSalsa.initialize 20 k nonce
410 -- Poly1305 key
411 (rs, crypt) = XSalsa.combine st0 zs where Nonce32 zs = zeros32
412 -- Since rs is 32 bytes, this pattern should never fail...
413 Cryptonite.CryptoPassed hash = Poly1305.initialize rs
414
415
416{-
417encryptMessage :: SecretKey -> SecretsCache -> NodeId -> Message ByteString -> Message (Either OnionPayload Ciphered)
418encryptMessage sk _ recipient plaintext
419 = if typeHasEncryptedPayload (msgType plaintext)
420 then Right . withSecret encipherAndHash sk recipient (msgNonce plaintext) <$> plaintext
421 else Left . OnionPayload <$> plaintext
422-}
423
424encryptAssymetric :: SecretKey -> NodeId -> NodeId -> Msg -> Tox.Assymetric
425encryptAssymetric sk pk recipient (Msg typ nonce plaintext sendback) = assym
426 where
427 assym = Tox.Assymetric
428 { senderKey = pk
429 , sent = Tox.UnclaimedAssymetric
430 { assymetricNonce = nonce
431 , assymetricData = withSecret encipherAndHash sk recipient nonce (plaintext <> S.encode sendback)
432 }
433 }
434
435encryptUnclm :: SecretKey -> NodeId -> NodeId -> Msg -> Tox.UnclaimedAssymetric
436encryptUnclm sk pk recipient (Msg typ nonce plaintext _) = unclm
437 where
438 unclm = Tox.UnclaimedAssymetric
439 { assymetricNonce = nonce
440 , assymetricData = withSecret encipherAndHash sk recipient nonce plaintext
441 }
442
443
444{-
445decryptMessage :: SecretKey -> SecretsCache -> Message Ciphered -> Either String (Message ByteString)
446decryptMessage sk _ ciphertext
447 = mapM (withSecret decipherAndAuth sk (msgOrigin ciphertext) (msgNonce ciphertext)) ciphertext
448-}
449
450decryptAssymetric :: SecretKey -> Tox.PacketKind -> Tox.Assymetric -> Either String Msg
451decryptAssymetric sk typ assym
452 = f <$> withSecret decipherAndAuth sk
453 (Tox.senderKey assym)
454 nonce
455 (Tox.assymetricData . Tox.sent $ assym)
456 where
457 nonce = Tox.assymetricNonce . Tox.sent $ assym
458 f bs = uncurry (Msg typ nonce)
459 . second (either (const (Tox.Nonce8 0)) id . S.decode)
460 $ B.splitAt (B.length bs - 8) bs
461
462-- TODO: We should not be having to re-serialize this data... :/
463-- There should be a way to pass the Tox.Assymetric value up the layers.
464passThroughAssymetric :: Tox.PacketKind -> Tox.PubKey -> Tox.Assymetric -> Either String Msg
465passThroughAssymetric typ k assym
466 = Right $ Msg
467 { msgNonce = Tox.assymetricNonce . Tox.sent $ assym -- Not used.
468 , msgType = typ
469 , msgData = S.encode (k,assym)
470 , msgSendBack = Nonce8 0 -- Not used.
471 }
472
473{-
474decryptUnclm :: SecretKey -> Tox.PacketKind -> NodeId -> Tox.Nonce8 -> Tox.UnclaimedAssymetric -> Either String Msg
475decryptUnclm sk typ sender n8 unclm
476 = f <$> withSecret decipherAndAuth sk
477 sender
478 nonce
479 (Tox.assymetricData unclm)
480 where
481 nonce = Tox.assymetricNonce unclm
482 f bs = Msg typ nonce bs n8
483-}
484
485withSecret f sk recipient nonce x = f hash crypt x
486 where
487 (hash, crypt) = computeSharedSecret sk recipient nonce
488
489
490-- Encrypt-then-Mac: Encrypt the cleartext, then compute the MAC on the
491-- ciphertext, and prepend it to the ciphertext
492encipherAndHash :: Poly1305.State -> XSalsa.State -> ByteString -> Tox.ImplicitAssymetric
493encipherAndHash hash crypt m = Tox.ImplicitAssymetric (Tox.Auth a) c
494 where
495 c = fst . XSalsa.combine crypt $ m
496 a = Poly1305.finalize . Poly1305.update hash $ c
497
498decipherAndAuth :: Poly1305.State -> XSalsa.State -> Tox.ImplicitAssymetric -> Either String ByteString
499decipherAndAuth hash crypt (Tox.ImplicitAssymetric (Tox.Auth mac) c)
500 | (a == mac) = Right m
501 | otherwise = Left "decipherAndAuth: auth fail"
502 where
503 m = fst . XSalsa.combine crypt $ c
504 a = Poly1305.finalize . Poly1305.update hash $ c
505
506nibble :: Word8 -> Char
507nibble b = intToDigit (fromIntegral (b .&. 0x0F))
508
509xxd :: Int -> ByteString -> [String]
510xxd offset bs | B.null bs = []
511xxd offset bs = printf "%03x: %s" offset ds : xxd (offset + B.length xs) bs'
512 where
513 ds = unwords $ map (\byte -> [nibble (byte `shiftR` 4), nibble byte])
514 $ B.unpack xs
515 (xs,bs') = B.splitAt 16 bs
516
517{-
518showPayloadError ciphered naddr flow err = unlines (map (prefix ++) xs)
519 where
520 xs = unwords [show (msgType ciphered), err]
521 : xxd 0 (BA.convert mac <> ciphertext)
522
523 Message { msgPayload = Ciphered (Poly1305.Auth mac) ciphertext } = ciphered
524
525 prefix = show naddr <> flow
526
527showParseError bs addr err = unlines $
528 concat [ either show show (either4or6 addr), " --> ", err ]
529 : xxd 0 bs
530
531unzipMessage :: Message (Either a b) -> Either (Message a) (Message b)
532unzipMessage msg = either (\x -> Left msg { msgPayload = x })
533 (\y -> Right msg { msgPayload = y })
534 (msgPayload msg)
535
536-- TODO:
537-- Represents the encrypted portion of a Tox packet.
538-- data Payload a = Payload a !Tox.Nonce8
539--
540-- Generic packet type: Message (Payload ByteString)
541
542parsePacket :: SecretKey -> SecretsCache -> ByteString -> SockAddr -> Either String (Message ByteString, NodeInfo)
543parsePacket sk cache bs addr = left (showParseError bs addr) $ do
544 msg <- S.runGet getMessage bs
545 ni <- nodeInfo (msgOrigin msg) addr
546 let decrypt ciphered = left (showPayloadError ciphered ni " --> ") $ do
547 msg <- decryptMessage sk cache ciphered
548 return (msg, ni)
549 passthrough onion = return (unpackOnionPayload <$> onion, ni)
550 either passthrough decrypt $ unzipMessage msg
551
552encodePacket :: SecretKey -> SecretsCache -> Message ByteString -> NodeInfo -> (ByteString, SockAddr)
553encodePacket sk cache msg ni = ( S.runPut . putMessage $ encryptMessage sk cache (nodeId ni) msg
554 , nodeAddr ni )
555-}
556
557data ToxPath = forall n. (Tox.OnionPacket n) => ToxPath NodeInfo (Tox.ReturnPath n)
558
559instance Show ToxPath where
560 show (ToxPath ni rpath)
561 | natVal rpath == 0 = show ni
562 | otherwise = "Aliased("++show ni++")"
563
564msgLayer :: SecretKey
565 -> NodeId
566 -> Transport String ToxPath (Tox.PacketKind,InterediateRep)
567 -> Transport String ToxPath Msg
568msgLayer sk pk = layerTransport parse serialize
569 where
570 parse :: (Tox.PacketKind,InterediateRep) -> ToxPath -> Either String (Msg,ToxPath)
571 parse (typ,Assym x) addr = fmap (,addr) $ decryptAssymetric sk typ x
572 parse (typ,Assym' x) addr = fmap (,addr) $ decryptAssymetric sk typ x
573 parse (typ,ToRoute k x) addr = fmap (,addr) $ passThroughAssymetric typ k x
574 parse (typ,Unclm n x) addr = Right ( Msg typ (Tox.assymetricNonce x) (S.encode (Tox.assymetricData x)) n
575 , addr)
576 serialize :: Msg -> ToxPath -> ((Tox.PacketKind,InterediateRep),ToxPath)
577 serialize x addr@(ToxPath ni _) = case Tox.pktClass (msgType x) of
578 Tox.AssymetricClass {} -> ((msgType x, Assym $ encryptAssymetric sk pk (nodeId ni) x), addr)
579 Tox.AliasedClass {} -> ((msgType x, Assym' $ encryptAssymetric sk pk (nodeId ni) x), addr)
580 Tox.NoncedUnclaimedClass {} -> ((msgType x, Unclm (msgSendBack x) $ encryptUnclm sk pk (nodeId ni) x),addr)
581
582data InterediateRep = Assym Tox.Assymetric
583 | Assym' Tox.Assymetric
584 | ToRoute Tox.PubKey Tox.Assymetric
585 | Unclm Tox.Nonce8 Tox.UnclaimedAssymetric
586 | RouteResponse Tox.Packet
587
588asymLayer :: Transport String SockAddr Tox.Packet -> Transport String ToxPath (Tox.PacketKind,InterediateRep)
589asymLayer = layerTransport parse (\p@(typ,_) -> trace ("SERIALIZE "++show typ) $ serialize p)
590 where
591 parse :: Tox.Packet -> SockAddr -> Either String ((Tox.PacketKind,InterediateRep),ToxPath)
592 parse x addr = case Tox.pktClass (Tox.pktKind x) of
593 Tox.AssymetricClass top fromp -> go Tox.senderKey fromp Assym
594 Tox.AliasedClass top fromp -> goalias $ fromp x
595 Tox.ToRouteClass top fromp -> do let (key,y) = fromp x
596 ((typ,Assym' a),addr') <- goalias y
597 return ((typ,ToRoute key a),addr')
598 Tox.NoncedUnclaimedClass top fromp -> go (const zeroID) fromp (uncurry Unclm)
599 -- OnionClass
600 where go mkaddr fromp c = let y = fromp x
601 in fmap ( ((Tox.pktKind x,c y),)
602 . (\ni -> ToxPath ni Tox.emptyReturnPath)
603 )
604 $ nodeInfo (mkaddr y) addr
605 goalias (Tox.Aliased a,rpath) = fmap (\ni -> ( (Tox.pktKind x, Assym' a)
606 , ToxPath ni rpath ))
607 $ nodeInfo (Tox.senderKey a) addr
608
609 serialize :: (Tox.PacketKind,InterediateRep) -> ToxPath -> (Tox.Packet,SockAddr)
610 serialize (typ,Assym assym) (ToxPath addr rpath) = (x,nodeAddr addr)
611 where x = case Tox.pktClass typ of Tox.AssymetricClass top _ -> top assym
612 serialize (typ,Assym' assym) (ToxPath addr rpath) = (x,nodeAddr addr) -- TODO rpath
613 where x = case Tox.pktClass typ of Tox.AliasedClass top _ -> top (Tox.Aliased assym, error "todo: ReturnPath")
614 -- An unclm sent to a ToxPath is turned into an OnionResponse before being sent out.
615 serialize (typ,Unclm nonce unclm) (ToxPath addr rpath) = (Tox.mkOnion rpath x,nodeAddr addr)
616 where x = case Tox.pktClass typ of Tox.NoncedUnclaimedClass top _ -> top nonce unclm
617 serialize (_,RouteResponse x) (ToxPath addr rpath) = (Tox.mkOnion rpath x, nodeAddr addr)
618 -- OnionClass
619
620toxLayer :: Transport String SockAddr ByteString -> Transport String SockAddr Tox.Packet
621toxLayer = layerTransport (\x addr -> (,addr) <$> S.decode x)
622 (\x addr -> (S.encode x, addr))
623
624data Routing = Routing
625 { tentativeId :: NodeInfo
626 , sched4 :: !( TVar (Int.PSQ POSIXTime) )
627 , routing4 :: !( TVar (R.BucketList NodeInfo) )
628 , committee4 :: TriadCommittee NodeId SockAddr
629 , sched6 :: !( TVar (Int.PSQ POSIXTime) )
630 , routing6 :: !( TVar (R.BucketList NodeInfo) )
631 , committee6 :: TriadCommittee NodeId SockAddr
632 }
633
634type ToxClient = Client String Tox.PacketKind TransactionId ToxPath Msg
635
636encodePayload :: S.Serialize b => Tox.PacketKind -> TransactionId -> addr -> addr -> b -> Msg
637encodePayload typ (TransactionId nonce8 nonce24) _ _ b = Msg typ nonce24 (S.encode b) nonce8
638
639trimPackets :: SockAddr -> ByteString -> IO (Maybe (ByteString -> ByteString))
640trimPackets addr bs = do
641 hPutStrLn stderr $ "GOT " ++ show (Tox.PacketKind (B.head bs))
642 return $ case Tox.PacketKind (B.head bs) of
643 PingType -> Just id
644 PongType -> Just id
645 SendNodesType -> Just id
646 GetNodesType -> Just id
647 AnnounceType -> Just id
648 AnnounceResponseType -> Just id
649 DataRequestType -> Just id
650 -- DataResponseType -> Just id
651 OnionResponse3Type -> Just id
652 _ -> Nothing
653
654newClient :: SockAddr -> IO (ToxClient, Routing, TVar AnnouncedKeys)
655newClient addr = do
656 udp <- udpTransport addr
657 secret <- generateSecretKey 100 secret <- generateSecretKey
658 let pubkey = key2id $ toPublic secret 101 let pubkey = toPublic secret
659 hPutStrLn stderr $ "pubkey = " ++ show pubkey
660 cache <- newEmptyCache
661 (symkey, drg) <- do 102 (symkey, drg) <- do
662 drg0 <- getSystemDRG 103 drg0 <- getSystemDRG
663 return $ randomBytesGenerate 32 drg0 :: IO (ByteString, SystemDRG) 104 return $ randomBytesGenerate 32 drg0 :: IO (ByteString, SystemDRG)
664 let tentative_ip4 = fromMaybe (IPv4 $ toEnum 0) (IPv4 <$> fromSockAddr addr) 105 noncevar <- atomically $ newTVar $ fst $ withDRG drg drgNew
665 tentative_ip6 = fromMaybe (IPv6 $ toEnum 0) (IPv6 <$> fromSockAddr addr) 106 hPutStrLn stderr $ "secret(tox) = " ++ DHT.showHex secret
666 tentative_info = NodeInfo 107 hPutStrLn stderr $ "public(tox) = " ++ DHT.showHex pubkey
667 { nodeId = pubkey 108 hPutStrLn stderr $ "symmetric(tox) = " ++ DHT.showHex symkey
668 , nodeIP = fromMaybe (toEnum 0) (fromSockAddr addr) 109 return TransportCrypto
669 , nodePort = fromMaybe 0 $ sockAddrPort addr 110 { transportSecret = secret
670 } 111 , transportPublic = pubkey
671 tentative_info4 = tentative_info { nodeIP = tentative_ip4 } 112 , transportSymmetric = return $ SymmetricKey symkey
672 tentative_info6 <- 113 , transportNewNonce = do
673 maybe (tentative_info { nodeIP = tentative_ip6 }) 114 drg1 <- readTVar noncevar
674 (\ip6 -> tentative_info { nodeIP = IPv6 ip6 }) 115 let (nonce, drg2) = withDRG drg1 (Nonce24 <$> getRandomBytes 24)
675 <$> global6 116 writeTVar noncevar drg2
676 addr4 <- atomically $ newTChan 117 return nonce
677 addr6 <- atomically $ newTChan 118 }
678 routing <- atomically $ do 119
679 let nobkts = R.defaultBucketCount :: Int 120updateIP :: TVar (R.BucketList NodeInfo) -> SockAddr -> STM ()
680 tbl4 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info4 nobkts 121updateIP tblvar a = do
681 tbl6 <- newTVar $ R.nullTable (comparing nodeId) (\s -> hashWithSalt s . nodeId) tentative_info6 nobkts 122 bkts <- readTVar tblvar
682 let updateIPVote tblvar addrvar a = do 123 case nodeInfo (nodeId (R.thisNode bkts)) a of
683 bkts <- readTVar tblvar 124 Right ni -> writeTVar tblvar (bkts { R.thisNode = ni })
684 case nodeInfo (nodeId (R.thisNode bkts)) a of 125 Left _ -> return ()
685 Right ni -> writeTVar tblvar (bkts { R.thisNode = ni })
686 Left _ -> return ()
687 writeTChan addrvar (a,map fst $ concat $ R.toList bkts)
688 committee4 <- newTriadCommittee $ updateIPVote tbl4 addr4
689 committee6 <- newTriadCommittee $ updateIPVote tbl6 addr6
690 sched4 <- newTVar Int.empty
691 sched6 <- newTVar Int.empty
692 return $ Routing tentative_info sched4 tbl4 committee4 sched6 tbl6 committee6
693 126
127genNonce24 :: DRG g =>
128 TVar (g, pending) -> DHT.TransactionId -> IO DHT.TransactionId
129genNonce24 var (DHT.TransactionId nonce8 _) = atomically $ do
130 (g,pending) <- readTVar var
131 let (bs, g') = randomBytesGenerate 24 g
132 writeTVar var (g',pending)
133 return $ DHT.TransactionId nonce8 (Nonce24 bs)
134
135
136gen :: forall gen. DRG gen => gen -> (DHT.TransactionId, gen)
137gen g = let (bs, g') = randomBytesGenerate 24 g
138 (ws, g'') = randomBytesGenerate 8 g'
139 Right w = S.runGet S.getWord64be ws
140 in ( DHT.TransactionId (Nonce8 w) (Nonce24 bs), g'' )
141
142intKey :: DHT.TransactionId -> Int
143intKey (DHT.TransactionId (Nonce8 w) _) = fromIntegral w
144
145nonceKey :: DHT.TransactionId -> Nonce8
146nonceKey (DHT.TransactionId n _) = n
147
148myAddr :: DHT.Routing -> Maybe NodeInfo -> IO NodeInfo
149myAddr routing maddr = atomically $ do
150 let var = case flip DHT.prefer4or6 Nothing <$> maddr of
151 Just Want_IP6 -> DHT.routing6 routing
152 _ -> DHT.routing4 routing
153 a <- readTVar var
154 return $ R.thisNode a
155
156newClient :: (DRG g, Show addr, Show meth) =>
157 g -> Transport String addr x
158 -> (x -> MessageClass String meth DHT.TransactionId)
159 -> (Maybe addr -> IO addr)
160 -> (meth -> Maybe (MethodHandler String DHT.TransactionId addr x))
161 -> (Client String meth DHT.TransactionId addr x -> Transport String addr x -> Transport String addr x)
162 -> IO (Client String meth DHT.TransactionId addr x)
163newClient drg net classify selfAddr handlers modifynet = do
694 -- If we have 8-byte keys for IntMap, then use it for transaction lookups. 164 -- If we have 8-byte keys for IntMap, then use it for transaction lookups.
695 -- Otherwise, use ordinary Map. The details of which will be hidden by an 165 -- Otherwise, use ordinary Map. The details of which will be hidden by an
696 -- existential closure (see mkclient below). 166 -- existential closure (see mkclient below).
@@ -704,680 +174,84 @@ newClient addr = do
704 let mapT = transactionMethods (contramapT nonceKey mapMethods) gen 174 let mapT = transactionMethods (contramapT nonceKey mapMethods) gen
705 map_var <- atomically $ newTVar (drg, mempty) 175 map_var <- atomically $ newTVar (drg, mempty)
706 return $ Left (mapT,map_var) 176 return $ Left (mapT,map_var)
707 keydb <- atomically $ newTVar $ AnnouncedKeys PSQ.empty MinMaxPSQ.empty 177 let dispatch tbl var handlers = DispatchMethods
708 toks <- do 178 { classifyInbound = classify
709 nil <- nullSessionTokens 179 , lookupHandler = handlers -- var
710 atomically $ newTVar nil { maxInterval = 20 } -- 20 second timeout on announce ping-ids. 180 , tableMethods = tbl
711 let net = addHandler (handleMessage client) 181 }
712 $ addVerbosity 182 mkclient (tbl,var) handlers =
713 $ msgLayer secret pubkey 183 let client = Client
714 $ onInbound (updateRouting client routing) 184 { clientNet = addHandler (handleMessage client) $ modifynet client net
715 $ asymnet 185 , clientDispatcher = dispatch tbl var handlers -- (fmap (contramapAddr (\(ToxPath ni _) -> ni)) . handlers)
716 asymnet = asymLayer 186 , clientErrorReporter = (printErrors stderr) { reportTimeout = reportTimeout ignoreErrors }
717 -- $ addHandler (handleMessage aclient) 187 , clientPending = var
718 $ toxLayer 188 , clientAddress = selfAddr
719 $ addVerbosity2 189 , clientResponseId = genNonce24 var
720 $ addHandler trimPackets udp 190 }
721 191 in client
722 dispatch tbl var handlers = DispatchMethods 192 return $ either mkclient mkclient tblvar handlers
723 { classifyInbound = classify 193
724 , lookupHandler = handlers -- var 194data Tox = Tox
725 , tableMethods = tbl 195 { toxDHT :: DHT.Client
726 } 196 , toxOnion :: Onion.Client
727 197 , toxCrypto :: Transport String SockAddr NetCrypto
728 handler typ f = Just $ MethodHandler (S.decode . msgData) (encodePayload typ) (f . (\(ToxPath ni _)->ni)) 198 , toxRouting :: DHT.Routing
729 199 , toxTokens :: TVar SessionTokens
730 handler' typ f = Just $ MethodHandler (S.decode . msgData) (encodePayload typ) f 200 , toxAnnouncedKeys :: TVar Onion.AnnouncedKeys
731
732 -- (decryptAssymetric secret) (encryptAssymetric secret . cryptoNonce) f
733
734
735 -- handlers :: TVar -> Method -> Maybe Handler
736 -- handlers :: forall h u. (TVar (h, u (MVar Msg)) -> Tox.PacketKind -> Maybe Handler)
737 handlers :: Tox.PacketKind -> Maybe Handler
738 handlers PingType = handler PongType pingH
739 handlers GetNodesType = handler SendNodesType $ getNodesH routing
740 handlers AnnounceType = handler' AnnounceResponseType $ announceH routing toks keydb
741 handlers DataRequestType = Just $ NoReply (S.decode . msgData) $ dataToRouteH keydb asymnet
742 {-
743 handlers var OnionRequest0 = noreply OnionRequest0
744 $ onionSend0H (symmetricCipher (return symkey)
745 (fst <$> readTVar var)
746 (modifyTVar' var . first . const))
747 udp
748 handlers var OnionResponse1 = noreply OnionResponse1
749 $ onionResponse1H (symmetricDecipher (return symkey))
750 udp
751 -}
752 handlers _ = Nothing
753 -- TODO DHTRequest public key (onion)
754 -- TODO DHTRequest NAT ping
755 -- TODO BootstrapInfo 0xf0
756
757 announceHandlers _ = Nothing
758
759 genNonce24 var (TransactionId nonce8 _) = atomically $ do
760 (g,pending) <- readTVar var
761 let (bs, g') = randomBytesGenerate 24 g
762 writeTVar var (g',pending)
763 return $ TransactionId nonce8 (Tox.Nonce24 bs)
764
765 client = either mkclient mkclient tblvar handlers
766
767 mkclient :: DRG g =>
768 ( TransactionMethods (g,t (MVar Msg))
769 TransactionId
770 Msg
771 , TVar (g, t (MVar Msg))
772 )
773 -- -> (forall h u. (TVar (h, u (MVar Msg)) -> Tox.PacketKind -> Maybe Handler))
774 -> (Tox.PacketKind -> Maybe Handler)
775 -> ToxClient
776 mkclient (tbl,var) handlers = Client
777 { clientNet = net
778 , clientDispatcher = dispatch tbl var handlers -- (fmap (contramapAddr (\(ToxPath ni _) -> ni)) . handlers)
779 , clientErrorReporter = (printErrors stderr) { reportTimeout = reportTimeout ignoreErrors }
780 , clientPending = var
781 , clientAddress = \maddr -> atomically $ do
782 let var = case flip prefer4or6 Nothing . (\(ToxPath ni _) -> ni) <$> maddr of
783 Just Want_IP6 -> routing6 routing
784 _ -> routing4 routing
785 a <- readTVar var
786 return $ ToxPath (R.thisNode a) Tox.emptyReturnPath
787 , clientResponseId = genNonce24 var
788 }
789
790 return (client, routing, keydb)
791
792toxKademlia :: ToxClient -> TriadCommittee NodeId SockAddr -> TVar (R.BucketList NodeInfo) -> TVar (Int.PSQ POSIXTime) -> Kademlia NodeId NodeInfo
793toxKademlia client committee var sched
794 = Kademlia quietInsertions
795 toxSpace
796 (vanillaIO var $ ping client)
797 { tblTransition = \tr -> do
798 io1 <- transitionCommittee committee tr
799 io2 <- touchBucket toxSpace (15*60) var sched tr
800 return $ do
801 io1 >> io2
802 hPutStrLn stderr $ unwords
803 [ show (transitionedTo tr)
804 , show (transitioningNode tr)
805 ]
806 }
807
808toxSpace :: R.KademliaSpace NodeId NodeInfo
809toxSpace = R.KademliaSpace
810 { R.kademliaLocation = nodeId
811 , R.kademliaTestBit = testIdBit
812 , R.kademliaXor = xor
813 , R.kademliaSample = genBucketSample'
814 }
815
816
817{-
818last8 :: ByteString -> Tox.Nonce8
819last8 bs
820 | let len = B.length bs
821 , (len >= 8)
822 = Tox.Nonce8 $ let bs' = B.drop (len - 8) bs
823 Right w = S.runGet S.getWord64be bs'
824 in w
825 | otherwise
826 = Tox.Nonce8 0
827
828dropEnd8 :: ByteString -> ByteString
829dropEnd8 bs = B.take (B.length bs - 8) bs
830-}
831
832data Payload a = Payload
833 { payload :: a
834 , sendback :: Tox.Nonce8
835 } 201 }
836 202
837instance S.Serialize a => S.Serialize (Payload a) where 203addVerbosity :: Show addr => Transport err addr ByteString -> Transport err addr ByteString
838 get = Payload <$> S.get <*> S.get
839 put (Payload a nonce) = S.put a >> S.put nonce
840
841
842-- Add detailed printouts for every packet.
843addVerbosity tr = 204addVerbosity tr =
844 tr { awaitMessage = \kont -> awaitMessage tr $ \m -> do 205 tr { awaitMessage = \kont -> awaitMessage tr $ \m -> do
845 forM_ m $ mapM_ $ \(msg,addr) -> do 206 forM_ m $ mapM_ $ \(msg,addr) -> do
846 hPutStrLn stderr ( (show addr) 207 when (not (B.null msg || elem (B.head msg) [0,1,2,4])) $ do
847 ++ " --> " ++ show (msgType msg)) 208 mapM_ (\x -> hPutStrLn stderr ( (show addr) ++ " --> " ++ x))
848 kont m 209 $ xxd 0 msg
849 , sendMessage = \addr msg -> do
850 hPutStrLn stderr ( (show addr)
851 ++ " <-- " ++ show msg ) -- (msgType msg))
852 sendMessage tr addr msg
853 }
854
855addVerbosity2 tr =
856 tr { awaitMessage = \kont -> awaitMessage tr $ \m -> do
857 forM_ m $ mapM_ $ \(msg,addr) -> do
858 hPutStrLn stderr ( (show addr)
859 ++ " -2-> " ++ show (Tox.PacketKind $ B.head msg))
860 -- forM_ (xxd 0 msg) (hPutStrLn stderr)
861 kont m 210 kont m
862 , sendMessage = \addr msg -> do 211 , sendMessage = \addr msg -> do
863 hPutStrLn stderr ( (show addr) 212 when (not (B.null msg || elem (B.head msg) [0,1,2,4])) $ do
864 ++ " <-2- " ++ show (Tox.PacketKind $ B.head msg)) 213 mapM_ (\x -> hPutStrLn stderr ( (show addr) ++ " <-- " ++ x))
865 forM_ (xxd 0 msg) (hPutStrLn stderr) 214 $ xxd 0 msg
866 sendMessage tr addr msg 215 sendMessage tr addr msg
867 } 216 }
868 217
218newKeysDatabase :: IO (TVar Onion.AnnouncedKeys)
219newKeysDatabase =
220 atomically $ newTVar $ Onion.AnnouncedKeys PSQ.empty MinMaxPSQ.empty
869 221
870classify :: Msg -> MessageClass String Tox.PacketKind TransactionId 222newTox :: TVar Onion.AnnouncedKeys -> SockAddr -> IO Tox
871classify (Msg { msgType = typ 223newTox keydb addr = do
872 , msgData = bs 224 udp <- addVerbosity <$> udpTransport addr
873 , msgSendBack = nonce8 225 crypto <- newCrypto
874 , msgNonce = nonce24 }) = go $ TransactionId nonce8 nonce24 226 drg <- drgNew
875 where 227 let lookupClose _ = return Nothing
876 go = case typ of 228 (dhtcrypt,onioncrypt,cryptonet) <- toxTransport crypto lookupClose udp
877 PingType -> IsQuery typ
878 GetNodesType -> IsQuery typ
879 PongType -> IsResponse
880 SendNodesType -> IsResponse
881 OnionResponse1Type -> IsResponse
882 OnionResponse2Type -> IsResponse
883 OnionResponse3Type -> IsResponse
884 DHTRequestType -> IsQuery typ
885 OnionRequest0Type -> IsQuery typ
886 OnionRequest1Type -> IsQuery typ
887 OnionRequest2Type -> IsQuery typ
888 AnnounceType -> IsQuery typ
889 DataRequestType -> IsQuery typ
890 DataResponseType -> IsResponse
891 _ -> const $ IsUnknown ("Unknown message type: "++show typ)
892
893{-
894encodePayload typ (TransactionId (Tox.Nonce8 tid) nonce) self dest b
895 = Message { msgType = typ
896 , msgOrigin = nodeId self
897 , msgNonce = nonce
898 , msgReturnPath = Nothing
899 , msgPayload = S.encode b <> S.runPut (S.putWord64be tid)
900 }
901
902decodePayload :: S.Serialize a => Message ByteString -> Either String a
903decodePayload msg = S.decode $ dropEnd8 $ msgPayload msg
904-}
905
906type Handler = MethodHandler String TransactionId ToxPath Msg
907
908{-
909noreply :: Tox.PacketKind
910 -> (addr -> Msg -> IO ())
911 -> Maybe (MethodHandler String tid addr Msg)
912noreply typ f = Just $ NoReply (mapM deserialize) f
913 where
914 deserialize = S.decode . bool id dropEnd8 (typeHasEncryptedPayload typ)
915-}
916
917transitionCommittee :: TriadCommittee NodeId SockAddr -> RoutingTransition NodeInfo -> STM (IO ())
918transitionCommittee committee (RoutingTransition ni Stranger) = do
919 delVote committee (nodeId ni)
920 return $ do
921 hPutStrLn stderr $ "delVote "++show (nodeId ni)
922transitionCommittee committee _ = return $ return ()
923
924updateRouting :: ToxClient -> Routing -> ToxPath -> (Tox.PacketKind, InterediateRep) -> IO ()
925updateRouting client routing (ToxPath naddr _) (typ,Assym msg) = do
926 hPutStrLn stderr $ "updateRouting "++show typ
927 case prefer4or6 naddr Nothing of
928 Want_IP4 -> updateTable client naddr (routing4 routing) (committee4 routing) (sched4 routing)
929 Want_IP6 -> updateTable client naddr (routing6 routing) (committee6 routing) (sched6 routing)
930updateRouting _ _ _ (typ,_) = do
931 hPutStrLn stderr $ "updateRouting (ignored) "++show typ
932
933updateTable client naddr tbl committee sched = do
934 self <- atomically $ R.thisNode <$> readTVar tbl
935 when (nodeIP self /= nodeIP naddr) $ do
936 -- TODO: IP address vote?
937 insertNode (toxKademlia client committee tbl sched) naddr
938
939
940data Ping = Ping deriving Show
941data Pong = Pong deriving Show
942
943instance S.Serialize Ping where
944 get = do w8 <- S.get
945 if (w8 :: Word8) /= 0
946 then fail "Malformed ping."
947 else return Ping
948 put Ping = S.put (0 :: Word8)
949
950instance S.Serialize Pong where
951 get = do w8 <- S.get
952 if (w8 :: Word8) /= 1
953 then fail "Malformed pong."
954 else return Pong
955 put Pong = S.put (1 :: Word8)
956
957newtype GetNodes = GetNodes NodeId
958 deriving (Eq,Ord,Show,Read,S.Serialize)
959
960newtype SendNodes = SendNodes [NodeInfo]
961 deriving (Eq,Ord,Show,Read)
962
963instance S.Serialize SendNodes where
964 get = do
965 cnt <- S.get :: S.Get Word8
966 ns <- sequence $ replicate (fromIntegral cnt) S.get
967 return $ SendNodes ns
968
969 put (SendNodes ns) = do
970 let ns' = take 4 ns
971 S.put (fromIntegral (length ns') :: Word8)
972 mapM_ S.put ns'
973
974
975-- self -> A
976-- OnionRequest0: Message (OnionWrap (OnionWrap (Forward msg)))
977-- OnionRequest0: Message (OnionWrap (OnionWrap Ciphered))
978-- OnionRequest0: Message (OnionWrap Ciphered)
979-- OnionRequest0: Message Ciphered
980
981-- A -> B
982-- OnionRequest0: Message Ciphered
983-- OnionRequest0: Message (OnionWrap Ciphered)
984-- OnionRequest1: Message Ciphered ++ SockAddr
985-- OnionRequest1: Message Ciphered ++ SymmetricCiphered
986--
987-- B -> C
988-- OnionRequest1: Message Ciphered ++ SymmetricCiphered
989-- OnionRequest1: Message (OnionWrap Ciphered) ++ SymmetricCiphered
990-- OnionRequest2: Message Ciphered ++ (SockAddr ++ SymmetricCiphered)
991-- OnionRequest2: Message Ciphered ++ SymmetricCiphered
992--
993-- C -> D
994-- OnionRequest2: Message Ciphered ++ SymmetricCiphered
995-- OnionRequest2: Message (Forward msg) ++ SymmetricCiphered
996-- ?????????????: msg ++ ( SockAddr ++ SymmetricCiphered)
997-- ?????????????: msg ++ SymmetricCiphered
998
999-- D -> C
1000-- ?????????????: msg ++ SymmetricCiphered
1001-- OnionResponse3: Message SymmetricCiphered ++ response
1002--
1003-- C -> B
1004-- OnionResponse3: Message SymmetricCiphered ++ response
1005-- OnionResponse3: Message (SockAddr ++ SymmetricCiphered) ++ response
1006-- OnionResponse2: Message SymmetricCiphered ++ response
1007--
1008-- B -> A
1009-- OnionResponse2: Message SymmetricCiphered ++ response
1010-- OnionResponse2: Message (SockAddr ++ SymmetricCiphered) ++ response
1011-- OnionResponse1: Message SymmetricCiphered ++ response
1012--
1013-- A -> self
1014-- OnionResponse1: Message SymmetricCiphered ++ response
1015-- OnionResponse1: Message SockAddr ++ response
1016-- ??????????????: response
1017--
1018-- Onion payloads:
1019-- AnounceRequest (0x83)
1020-- = SeekingKey nid
1021-- | AnnouncingKey pingid nid sendback_key
1022--
1023-- AnnounceResponse (0x84)
1024-- = KeyNotFound pingid [ni] -- is_stored=0
1025-- | KeyFound sendback_key [ni] -- is_stored=1
1026-- | Announced pingid [ni] -- is_stored=2 What's the pingid for in this caes?
1027-- -- Should it be a fresh one?
1028--
1029-- -- After you find an announce node for your friend, you share your dht nodeid thus:
1030-- DataToRouteRequest (0x85)
1031-- -- cleartext: Public key of destination node (used to lookup the sendback_key,ip,port of onion-return path)
1032-- -- cleartext: nonce
1033-- -- cleartext: alias (just generated key)
1034-- -- encrypted (nonce,alias,sendback_key):
1035-- real public key
1036-- id byte
1037-- -- encrypted
1038-- DHTPublicKey (0x9c)
1039-- { no_replay :: Word64
1040-- , dhtKey :: NodeId
1041-- , nearbyNodes :: [NodeInfo]
1042-- }
1043-- payload (optional)
1044--
1045-- -- The announce node forwards your message thus:
1046-- -- This is the same as 0x85, but the destination key was removed.
1047-- DataToRouteResponse (0x86)
1048-- -- cleartext: nonce
1049-- -- cleartext: alias
1050-- -- encrypted payload.
1051
1052data OnionWrap a = OnionWrap
1053 { forwardAddress :: SockAddr
1054 , forwardAlias :: NodeId
1055 , onionPayload :: a
1056 }
1057
1058instance S.Serialize (OnionWrap Ciphered) where
1059 get = getOnion
1060 put = putOnion
1061
1062getOnion :: S.Get (OnionWrap Ciphered)
1063getOnion = do
1064 addr <- getForwardAddr
1065 alias <- S.get
1066 ciphered <- getCiphered
1067 return $ OnionWrap addr alias ciphered
1068
1069getForwardAddr :: S.Get SockAddr
1070getForwardAddr = do
1071 addrfam <- S.get :: S.Get Word8
1072 ip <- getIP addrfam
1073 case ip of IPv4 _ -> S.skip 12 -- compliant peers would zero-fill this.
1074 IPv6 _ -> return ()
1075 port <- S.get :: S.Get PortNumber
1076 return $ setPort port $ toSockAddr ip
1077
1078 229
1079putForwardAddr :: SockAddr -> S.Put 230 routing <- DHT.newRouting addr crypto updateIP updateIP
1080putForwardAddr saddr = fromMaybe (return $ error "unsupported SockAddr family") $ do 231 let dhtnet0 = layerTransport (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt
1081 port <- sockAddrPort saddr 232 dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr routing) (DHT.handlers routing)
1082 ip <- fromSockAddr $ either id id $ either4or6 saddr 233 $ \client net -> onInbound (DHT.updateRouting client routing) net
1083 return $ do
1084 case ip of
1085 IPv4 ip4 -> S.put (0x02 :: Word8) >> S.put ip4 >> S.putByteString (B.replicate 12 0)
1086 IPv6 ip6 -> S.put (0x0a :: Word8) >> S.put ip6
1087 S.put port
1088 234
1089putOnion :: OnionWrap Ciphered -> S.Put 235 toks <- do
1090putOnion = error "todo: putOnion" 236 nil <- nullSessionTokens
1091 237 atomically $ newTVar nil { maxInterval = 20 } -- 20 second timeout on announce ping-ids.
1092getCiphered :: S.Get Ciphered 238 oniondrg <- drgNew
1093getCiphered = do 239 let onionnet = layerTransport (Onion.decrypt crypto) (Onion.encrypt crypto) onioncrypt
1094 mac <- Poly1305.Auth . BA.convert <$> S.getBytes 16 240 onionclient <- newClient oniondrg onionnet Onion.classify (const $ return $ Onion.OnionToMe addr)
1095 cnt <- S.remaining 241 (Onion.handlers onionnet routing toks keydb)
1096 bs <- S.getBytes cnt 242 (const id)
1097 return $ Ciphered mac bs 243 return Tox
1098 244 { toxDHT = dhtclient
1099putCiphered :: Ciphered -> S.Put 245 , toxOnion = onionclient
1100putCiphered (Ciphered (Poly1305.Auth mac) bs) = do 246 , toxCrypto = cryptonet
1101 S.putByteString (BA.convert mac) 247 , toxRouting = routing
1102 S.putByteString bs 248 , toxTokens = toks
1103 249 , toxAnnouncedKeys = keydb
1104newtype Nonce32 = Nonce32 ByteString
1105 deriving (Eq, Ord, ByteArrayAccess, Data)
1106
1107instance S.Serialize Nonce32 where
1108 get = Nonce32 <$> S.getBytes 32
1109 put (Nonce32 bs) = S.putByteString bs
1110
1111data AnnounceRequest = AnnounceRequest
1112 { announcePingId :: Nonce32 -- Ping ID
1113 , announceSeeking :: NodeId -- Public key we are searching for
1114 , announceKey :: NodeId -- Public key that we want those sending back data packets to use
1115 }
1116
1117instance S.Serialize AnnounceRequest where
1118 get = AnnounceRequest <$> S.get <*> S.get <*> S.get
1119 put (AnnounceRequest p s k) = S.put (p,s,k)
1120
1121data KeyRecord = NotStored Nonce32
1122 | SendBackKey Tox.PubKey
1123 | Acknowledged Nonce32
1124
1125instance S.Serialize KeyRecord where
1126 get = do
1127 is_stored <- S.get :: S.Get Word8
1128 case is_stored of
1129 1 -> SendBackKey <$> S.get
1130 2 -> Acknowledged <$> S.get
1131 _ -> NotStored <$> S.get
1132 put (NotStored n32) = S.put (0 :: Word8) >> S.put n32
1133 put (SendBackKey key) = S.put (1 :: Word8) >> S.put key
1134 put (Acknowledged n32) = S.put (2 :: Word8) >> S.put n32
1135
1136data AnnounceResponse = AnnounceResponse
1137 { is_stored :: KeyRecord
1138 , announceNodes :: SendNodes
1139 }
1140
1141instance S.Serialize AnnounceResponse where
1142 get = AnnounceResponse <$> S.get <*> S.get
1143 put (AnnounceResponse st ns) = S.put st >> S.put ns
1144
1145pingH :: NodeInfo -> Ping -> IO Pong
1146pingH _ Ping = return Pong
1147
1148prefer4or6 :: NodeInfo -> Maybe WantIP -> WantIP
1149prefer4or6 addr iptyp = fromMaybe (ipFamily $ nodeIP addr) iptyp
1150
1151-- TODO: This should cover more cases
1152isLocal (IPv6 ip6) = (ip6 == toEnum 0)
1153isLocal (IPv4 ip4) = (ip4 == toEnum 0)
1154
1155isGlobal = not . isLocal
1156
1157getNodesH :: Routing -> NodeInfo -> GetNodes -> IO SendNodes
1158getNodesH routing addr (GetNodes nid) = do
1159 let preferred = prefer4or6 addr Nothing
1160
1161 (append4,append6) <- atomically $ do
1162 ni4 <- R.thisNode <$> readTVar (routing4 routing)
1163 ni6 <- R.thisNode <$> readTVar (routing6 routing)
1164 return $ case ipFamily (nodeIP addr) of
1165 Want_IP4 | isGlobal (nodeIP ni6) -> (id, (++ [ni6]))
1166 Want_IP6 | isGlobal (nodeIP ni4) -> ((++ [ni4]), id)
1167 _ -> (id, id)
1168 ks <- go append4 $ routing4 routing
1169 ks6 <- go append6 $ routing6 routing
1170 let (ns1,ns2) = case preferred of Want_IP6 -> (ks6,ks)
1171 Want_IP4 -> (ks,ks6)
1172 return $ SendNodes
1173 $ if null ns2 then ns1
1174 else take 4 (take 3 ns1 ++ ns2)
1175 where
1176 go f var = f . R.kclosest toxSpace k nid <$> atomically (readTVar var)
1177
1178 k = 4
1179
1180
1181dataToRouteH :: TVar AnnouncedKeys -> Transport err ToxPath (Tox.PacketKind,InterediateRep) -> addr -> (Tox.PubKey,Assymetric) -> IO ()
1182dataToRouteH keydb udp _ (k,assym) = do
1183 mb <- atomically $ do
1184 ks <- readTVar keydb
1185 forM (MinMaxPSQ.lookup' k (keyAssoc ks)) $ \(p,(cnt,rpath)) -> do
1186 writeTVar keydb $ ks { keyAssoc = MinMaxPSQ.insert' k (cnt + 1, rpath) p (keyAssoc ks) }
1187 return rpath
1188 forM_ mb $ \rpath -> do
1189 -- forward
1190 sendMessage udp rpath (DataResponseType, RouteResponse $ DataToRouteResponse $ Aliased assym)
1191 hPutStrLn stderr $ "Forwarding data-to-route -->"++show k
1192
1193-- Toxcore generates `ping_id`s by taking a 32 byte sha hash of the current time,
1194-- some secret bytes generated when the instance is created, the current time
1195-- divided by a 20 second timeout, the public key of the requester and the source
1196-- ip/port that the packet was received from. Since the ip/port that the packet
1197-- was received from is in the `ping_id`, the announce packets being sent with a
1198-- ping id must be sent using the same path as the packet that we received the
1199-- `ping_id` from or announcing will fail.
1200--
1201-- The reason for this 20 second timeout in toxcore is that it gives a reasonable
1202-- time (20 to 40 seconds) for a peer to announce himself while taking in count
1203-- all the possible delays with some extra seconds.
1204announceH :: Routing -> TVar SessionTokens -> TVar AnnouncedKeys -> ToxPath -> AnnounceRequest -> IO AnnounceResponse
1205announceH routing toks keydb (ToxPath naddr retpath) req = do
1206 case () of
1207 _ | announcePingId req == zeros32
1208 -> go False
1209
1210 _ | Nonce32 bs <- announcePingId req
1211 , let tok = fromPaddedByteString 32 bs
1212 -> checkToken toks naddr tok >>= go
1213 `catch` (\(SomeException e) -> hPutStrLn stderr ("announceH Exception! "++show e) >> throw e)
1214 where
1215 go withTok = do
1216 ns <- getNodesH routing naddr (GetNodes (announceSeeking req))
1217 tm <- getPOSIXTime
1218 let storing = (nodeId naddr == announceSeeking req)
1219 record <- atomically $ do
1220 when (withTok && storing) $ do
1221 let toxpath = ToxPath naddr{ nodeId = announceKey req } retpath
1222 -- Note: The following distance calculation assumes that
1223 -- our nodeid doesn't change and is the same for both
1224 -- routing4 and routing6.
1225 d = xor (nodeId (tentativeId routing))
1226 (announceSeeking req)
1227 modifyTVar' keydb (insertKey tm (announceSeeking req) toxpath d)
1228 ks <- readTVar keydb
1229 return $ snd . snd <$> MinMaxPSQ.lookup' (announceSeeking req) (keyAssoc ks)
1230 newtok <- if storing
1231 then Nonce32 . toPaddedByteString 32 <$> grantToken toks naddr
1232 else return $ zeros32
1233 let k = case record of
1234 Nothing -> NotStored newtok
1235 Just (ToxPath {}) | storing -> Acknowledged newtok
1236 Just (ToxPath ni _) -> SendBackKey (nodeId ni)
1237 return $ AnnounceResponse k ns
1238
1239{-
1240symmetricCipher :: DRG g => STM ByteString -> STM g -> (g -> STM ()) -> ByteString -> IO (Tox.Nonce24, SymmetricCiphered)
1241symmetricCipher currentSymmetricKey readG writeG bs = (>>= \e -> hPutStrLn stderr (show e) >> Cryptonite.throwCryptoErrorIO e) $ atomically $ do
1242 g <- readG
1243 let (sym_nonce_bytes, g') = randomBytesGenerate 12 g
1244 writeG g'
1245 symmkey <- currentSymmetricKey
1246 return $ do
1247 sym_nonce <- Symmetric.nonce12 sym_nonce_bytes
1248 symm <- Symmetric.initialize symmkey sym_nonce
1249 let (rpath_bs, symm') = Symmetric.encrypt bs symm
1250 auth = Symmetric.finalize symm' -- 16 bytes
1251 -- For a single SockAddr, bs will be 19 bytes which gives
1252 -- 12 + 16 + 19 = 47 bytes.
1253 -- We need 12 more make 59 bytes, so we'll include the nonce twice.
1254 nonce24 = Tox.Nonce24 $ sym_nonce <> sym_nonce
1255 return ( nonce24
1256 , SymmetricCiphered (BA.convert auth <> rpath_bs)
1257 )
1258
1259symmetricDecipher currentSymmetricKey (Tox.Nonce24 nonce24) (SymmetricCiphered bs) = atomically $ do
1260 symmkey <- currentSymmetricKey
1261 return $ do
1262 let sym_nonce_bytes = B.drop 12 nonce24
1263 (mac, bs'') = B.splitAt 16 bs
1264 symm <- left show . Cryptonite.eitherCryptoError $ do
1265 sym_nonce <- Symmetric.nonce12 sym_nonce_bytes
1266 Symmetric.initialize symmkey sym_nonce
1267 let (ds, symm') = Symmetric.decrypt bs'' symm
1268 auth = Symmetric.finalize symm'
1269 if BA.convert auth /= mac
1270 then Left "symmetricDecipher: Auth fail."
1271 else return $ ds
1272-}
1273
1274{-
1275
1276-- OnionRequest0
1277onionSend0H :: (ByteString -> IO (Tox.Nonce24,SymmetricCiphered))
1278 -> Transport err SockAddr ByteString
1279 -> NodeInfo
1280 -> Message (OnionWrap Ciphered)
1281 -> IO ()
1282onionSend0H symcipher udp addr Message{ msgNonce
1283 , msgPayload = OnionWrap forward alias ciphered } = do
1284 hPutStrLn stderr $ "onionSend0H( " ++ show addr ++ " --> " ++ either show show (either4or6 forward) ++ ")"
1285 (nonce,rpath) <- symcipher (S.runPut $ putForwardAddr forward)
1286 sendMessage udp forward $ S.runPut $ putMessage
1287 Message { msgType = OnionRequest1
1288 , msgOrigin = alias
1289 , msgNonce = msgNonce
1290 , msgReturnPath = Just (nonce,rpath)
1291 , msgPayload = Right ciphered
1292 }
1293 hPutStrLn stderr $ "onionSend0H SENT ( " ++ show addr ++ " --> " ++ either show show (either4or6 forward) ++ ")"
1294
1295-- OnionResponse1
1296--
1297-- No public-key decryption here.
1298onionResponse1H ::
1299 (Tox.Nonce24 -> SymmetricCiphered -> IO (Either String ByteString))
1300 -> Transport err SockAddr ByteString
1301 -> NodeInfo
1302 -> Message OnionPayload
1303 -> IO ()
1304onionResponse1H symdecipher udp addr Message{ msgNonce
1305 , msgReturnPath
1306 , msgPayload
1307 }
1308 = do
1309 hPutStrLn stderr $ "onionResponse1H " ++ show addr ++ maybe " Nothing" (const" Just") msgReturnPath
1310 forM_ msgReturnPath $ \rpath -> do
1311 eaddr <- (>>= S.runGet getForwardAddr) <$> symdecipher msgNonce rpath
1312 let go forward = do
1313 hPutStrLn stderr $ "onionResponse1H( " ++ show addr ++ " --> " ++ either show show (either4or6 forward) ++ ")"
1314 sendMessage udp forward (unpackOnionPayload msgPayload)
1315 either (hPutStrLn stderr . mappend "onionResponse1H decipher ERROR ") (\x -> go x >> hPutStrLn stderr "onionResponse1H SENT") eaddr
1316
1317-}
1318
1319intKey :: TransactionId -> Int
1320intKey (TransactionId (Tox.Nonce8 w) _) = fromIntegral w
1321
1322nonceKey :: TransactionId -> Tox.Nonce8
1323nonceKey (TransactionId n _) = n
1324
1325-- randomBytesGenerate :: ByteArray byteArray => Int -> gen -> (byteArray, gen)
1326gen :: forall gen. DRG gen => gen -> (TransactionId, gen)
1327-- gen :: SystemDRG -> (TransactionId, SystemDRG)
1328gen g = let (bs, g') = randomBytesGenerate 24 g
1329 (ws, g'') = randomBytesGenerate 8 g'
1330 Right w = S.runGet S.getWord64be ws
1331 in ( TransactionId (Tox.Nonce8 w) (Tox.Nonce24 bs), g'' )
1332
1333
1334
1335toxSend meth unwrap msg client nid addr = do
1336 reply <- sendQuery client serializer (msg nid) (ToxPath addr Tox.emptyReturnPath)
1337 -- sendQuery will return (Just (Left _)) on a parse error. We're going to
1338 -- blow it away with the join-either sequence.
1339 -- TODO: Do something with parse errors.
1340 return $ join $ either (const Nothing) Just <$> reply
1341 where
1342 serializer = MethodSerializer
1343 { methodTimeout = 5
1344 , method = meth
1345 -- wrapQuery :: tid -> addr -> addr -> a -> x
1346 , wrapQuery = encodePayload meth
1347 -- unwrapResponse :: x -> b
1348 , unwrapResponse = fmap unwrap . S.decode . msgData
1349 } 250 }
1350 251
1351ping :: ToxClient -> NodeInfo -> IO Bool 252forkTox :: Tox -> IO (IO ())
1352ping client addr = 253forkTox tox = do
1353 fromMaybe False 254 _ <- forkListener "toxCrypto" (toxCrypto tox)
1354 <$> toxSend PingType (\Pong -> True) (const Ping) client () addr 255 _ <- forkListener "toxOnion" (clientNet $ toxOnion tox)
1355 256 forkListener "toxDHT" (clientNet $ toxDHT tox)
1356getNodes :: ToxClient -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],()))
1357getNodes = toxSend GetNodesType unwrapNodes $ GetNodes
1358
1359unwrapNodes (SendNodes ns) = (ns,ns,())
1360
1361toxSearch qry = Search
1362 { searchSpace = toxSpace
1363 , searchNodeAddress = nodeIP &&& nodePort
1364 , searchQuery = qry
1365 }
1366 257
1367nodeSearch client = toxSearch (getNodes client)
1368
1369
1370type NodeDistance = Tox.PubKey
1371
1372data AnnouncedKeys = AnnouncedKeys
1373 { keyByAge :: PSQ NodeId (Down POSIXTime) -- timeout of 300 seconds
1374 , keyAssoc :: MinMaxPSQ' Tox.PubKey NodeDistance (Int,ToxPath)
1375 }
1376
1377insertKey :: POSIXTime -> Tox.PubKey -> ToxPath -> NodeDistance -> AnnouncedKeys -> AnnouncedKeys
1378insertKey tm pub toxpath d keydb = AnnouncedKeys
1379 { keyByAge = PSQ.insert pub (Down tm) (keyByAge keydb)
1380 , keyAssoc = case MinMaxPSQ.lookup' pub (keyAssoc keydb) of
1381 Just (_,(cnt,_)) -> MinMaxPSQ.insert' pub (cnt,toxpath) d (keyAssoc keydb)
1382 Nothing -> MinMaxPSQ.insert' pub (0 ,toxpath) d (keyAssoc keydb)
1383 }
diff --git a/c b/c
index a9d9755a..9457716f 100755
--- a/c
+++ b/c
@@ -4,4 +4,4 @@ defs="-DBENCODE_AESON -DTHREAD_DEBUG"
4hide="-hide-package crypto-random -hide-package crypto-api -hide-package crypto-numbers -hide-package cryptohash -hide-package prettyclass" 4hide="-hide-package crypto-random -hide-package crypto-api -hide-package crypto-numbers -hide-package cryptohash -hide-package prettyclass"
5cbits="cbits/*.c" 5cbits="cbits/*.c"
6# -Wno-typed-holes 6# -Wno-typed-holes
7$compile -fdefer-typed-holes -freverse-errors $hide -isrc -XOverloadedStrings -XRecordWildCards $defs $cbits "$@" 7$compile -Wmissing-signatures -fdefer-typed-holes -freverse-errors $hide -isrc -XOverloadedStrings -XRecordWildCards $defs $cbits "$@"
diff --git a/examples/dhtd.hs b/examples/dhtd.hs
index 232abd6e..f651ba1b 100644
--- a/examples/dhtd.hs
+++ b/examples/dhtd.hs
@@ -14,6 +14,7 @@
14{-# LANGUAGE ScopedTypeVariables #-} 14{-# LANGUAGE ScopedTypeVariables #-}
15{-# LANGUAGE TupleSections #-} 15{-# LANGUAGE TupleSections #-}
16{-# LANGUAGE TypeFamilies #-} 16{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeOperators #-}
17 18
18import Control.Arrow 19import Control.Arrow
19import Control.Concurrent.STM 20import Control.Concurrent.STM
@@ -64,6 +65,10 @@ import Data.Wrapper.PSQ as PSQ (pattern (:->))
64import qualified Data.Wrapper.PSQ as PSQ 65import qualified Data.Wrapper.PSQ as PSQ
65import Data.Ord 66import Data.Ord
66import Data.Time.Clock.POSIX 67import Data.Time.Clock.POSIX
68import qualified DHTTransport as Tox
69import qualified DHTHandlers as Tox
70import qualified OnionHandlers as Tox
71import Data.Typeable
67 72
68showReport :: [(String,String)] -> String 73showReport :: [(String,String)] -> String
69showReport kvs = showColumns $ map (\(x,y)->[x,y]) kvs 74showReport kvs = showColumns $ map (\(x,y)->[x,y]) kvs
@@ -88,7 +93,10 @@ hPutClient h s = hPutStr h ('.' : marshalForClient s)
88hPutClientChunk :: Handle -> String -> IO () 93hPutClientChunk :: Handle -> String -> IO ()
89hPutClientChunk h s = hPutStr h (' ' : marshalForClient s) 94hPutClientChunk h s = hPutStr h (' ' : marshalForClient s)
90 95
91data DHTQuery nid ni = forall addr r tok. Ord addr => DHTQuery 96data DHTQuery nid ni = forall addr r tok.
97 ( Ord addr
98 , Typeable r
99 )=> DHTQuery
92 { qsearch :: Search nid addr tok ni r 100 { qsearch :: Search nid addr tok ni r
93 , qhandler :: ni -> nid -> IO ([ni], [r], tok) 101 , qhandler :: ni -> nid -> IO ([ni], [r], tok)
94 , qshowR :: r -> String 102 , qshowR :: r -> String
@@ -111,13 +119,16 @@ data DHT = forall nid ni. ( Show ni
111 , Show nid 119 , Show nid
112 , Ord nid 120 , Ord nid
113 , Hashable nid 121 , Hashable nid
122 , Typeable ni
123 , S.Serialize nid
114 ) => 124 ) =>
115 DHT 125 DHT
116 { dhtBuckets :: TVar (BucketList ni) 126 { dhtBuckets :: TVar (BucketList ni)
117 , dhtPing :: ni -> IO Bool 127 , dhtPing :: ni -> IO Bool
118 , dhtQuery :: Map.Map String (DHTQuery nid ni) 128 , dhtQuery :: Map.Map String (DHTQuery nid ni)
119 , dhtParseId :: String -> Either String nid 129 , dhtParseId :: String -> Either String nid
120 , dhtSearches :: TVar (Map.Map (String,nid) (DHTSearch nid ni)) 130 , dhtSearches :: TVar (Map.Map (String,nid) (DHTSearch nid ni))
131 , dhtFallbackNodes :: IO [ni]
121 } 132 }
122 133
123nodesFileName :: String -> String 134nodesFileName :: String -> String
@@ -459,140 +470,228 @@ clientSession s@Session{..} sock cnum h = do
459 _ -> cmd0 $ hPutClient h "error." 470 _ -> cmd0 $ hPutClient h "error."
460 471
461 472
462readExternals :: [TVar (BucketList Mainline.NodeInfo)] -> IO [SockAddr] 473readExternals :: (ni -> SockAddr) -> [TVar (BucketList ni)] -> IO [SockAddr]
463readExternals vars = do 474readExternals nodeAddr vars = do
464 as <- atomically $ mapM (fmap (Mainline.nodeAddr . selfNode) . readTVar) vars 475 as <- atomically $ mapM (fmap (nodeAddr . selfNode) . readTVar) vars
465 let unspecified (SockAddrInet _ 0) = True 476 let unspecified (SockAddrInet _ 0) = True
466 unspecified (SockAddrInet6 _ _ (0,0,0,0) _) = True 477 unspecified (SockAddrInet6 _ _ (0,0,0,0) _) = True
467 unspecified _ = False 478 unspecified _ = False
468 -- TODO: Filter to only global addresses? 479 -- TODO: Filter to only global addresses?
469 return $ filter (not . unspecified) as 480 return $ filter (not . unspecified) as
470 481
471defaultPort :: String 482data Options = Options
472defaultPort = "6881" 483 { portbt :: String
484 , porttox :: String
485 , ip6bt :: Bool
486 , ip6tox :: Bool
487 }
488 deriving (Eq,Show)
489
490sensibleDefaults :: Options
491sensibleDefaults = Options
492 { portbt = "6881"
493 , porttox = "33445"
494 , ip6bt = True
495 , ip6tox = True
496 }
497
498-- bt=<port>,tox=<port>
499-- -4
500parseArgs :: [String] -> Options -> Options
501parseArgs [] opts = opts
502parseArgs ("-4":args) opts = parseArgs args opts
503 { ip6bt = False
504 , ip6tox = False }
505parseArgs (arg:args) opts = parseArgs args opts
506 { portbt = fromMaybe (portbt opts) $ Prelude.lookup "bt" ports
507 , porttox = fromMaybe (porttox opts) $ Prelude.lookup "tox" ports }
508 where
509 ports = map ( (dropWhile (==',') *** dropWhile (=='='))
510 . break (=='=') )
511 $ groupBy (const (/= ',')) arg
512
473 513
474main :: IO () 514main :: IO ()
475main = do 515main = do
476 args <- getArgs 516 args <- getArgs
477 p <- case take 2 (dropWhile (/="-p") args) of 517 let opts = parseArgs args sensibleDefaults
478 ["-p",port] | not ("-" `isPrefixOf` port) -> return port 518 print opts
479 ("-p":_) -> error "Port not specified! (-p PORT)"
480 _ -> return defaultPort
481 addr <- getBindAddress p True{- ipv6 -}
482
483 (bt,btR,swarms) <- Mainline.newClient addr
484 519
520 swarms <- Mainline.newSwarmsDatabase
485 -- Restore peer database before forking the listener thread. 521 -- Restore peer database before forking the listener thread.
486 peerdb <- left show <$> tryIOError (L.readFile "bt-peers.dat") 522 peerdb <- left show <$> tryIOError (L.readFile "bt-peers.dat")
487 either (hPutStrLn stderr . ("bt-peers.dat: "++)) 523 either (hPutStrLn stderr . ("bt-peers.dat: "++))
488 (atomically . writeTVar (Mainline.contactInfo swarms)) 524 (atomically . writeTVar (Mainline.contactInfo swarms))
489 (peerdb >>= S.decodeLazy) 525 (peerdb >>= S.decodeLazy)
490 526
491 quitBt <- forkListener (clientNet bt) 527 (quitBt,btdhts,btips) <- case portbt opts of
492 528 "" -> return (return (), Map.empty,return [])
493 let toxport = succ $ fromMaybe 33445 (fromIntegral <$> sockAddrPort addr) 529 p -> do
494 addrTox <- getBindAddress (show toxport) True 530 addr <- getBindAddress p (ip6bt opts)
495 (tox,toxR,toxkeys) <- Tox.newClient addrTox 531 (bt,btR) <- Mainline.newClient swarms addr
496 532 quitBt <- forkListener "bt" (clientNet bt)
497 quitTox <- forkListener (clientNet tox) 533 mainlineSearches <- atomically $ newTVar Map.empty
498 534 let mainlineDHT bkts wantip = DHT
499 mainlineSearches <- atomically $ newTVar Map.empty 535 { dhtBuckets = bkts btR
500 toxSearches <- atomically $ newTVar Map.empty 536 , dhtPing = Mainline.ping bt
501 537 , dhtQuery = Map.fromList
502 let mainlineDHT bkts = DHT 538 [ ("node", DHTQuery (Mainline.nodeSearch bt)
503 { dhtBuckets = bkts btR 539 (\ni -> fmap Mainline.unwrapNodes
504 , dhtPing = Mainline.ping bt 540 . Mainline.findNodeH btR ni
505 , dhtQuery = Map.fromList 541 . flip Mainline.FindNode (Just Want_Both))
506 [ ("node", DHTQuery (Mainline.nodeSearch bt) 542 show
507 (\ni -> fmap Mainline.unwrapNodes 543 (const Nothing))
508 . Mainline.findNodeH btR ni 544 , ("peer", DHTQuery (Mainline.peerSearch bt)
509 . flip Mainline.FindNode (Just Want_Both)) 545 (\ni -> fmap Mainline.unwrapPeers
510 show 546 . Mainline.getPeersH btR swarms ni
511 (const Nothing)) 547 . flip Mainline.GetPeers (Just Want_Both)
512 , ("peer", DHTQuery (Mainline.peerSearch bt) 548 . (read . show)) -- TODO: InfoHash -> NodeId
513 (\ni -> fmap Mainline.unwrapPeers 549 (show . pPrint)
514 . Mainline.getPeersH btR swarms ni 550 (Just . show))
515 . flip Mainline.GetPeers (Just Want_Both) 551 ]
516 . (read . show)) -- TODO: InfoHash -> NodeId 552 , dhtParseId = readEither :: String -> Either String Mainline.NodeId
517 (show . pPrint) 553 , dhtSearches = mainlineSearches
518 (Just . show)) 554 , dhtFallbackNodes = Mainline.bootstrapNodes wantip
519 ] 555 }
520 , dhtParseId = readEither :: String -> Either String Mainline.NodeId 556 dhts = Map.fromList $
521 , dhtSearches = mainlineSearches 557 ("bt4", mainlineDHT Mainline.routing4 Want_IP4)
522 } 558 : if ip6bt opts
523 toxDHT bkts = DHT 559 then [ ("bt6", mainlineDHT Mainline.routing6 Want_IP6) ]
524 { dhtBuckets = bkts toxR 560 else []
525 , dhtPing = Tox.ping tox 561 ips :: IO [SockAddr]
526 , dhtQuery = Map.fromList 562 ips = readExternals Mainline.nodeAddr
527 [ ("node", DHTQuery (Tox.nodeSearch tox) 563 [ Mainline.routing4 btR
528 (\ni -> fmap Tox.unwrapNodes 564 , Mainline.routing6 btR
529 . Tox.getNodesH toxR ni 565 ]
530 . Tox.GetNodes) 566 return (quitBt,dhts,ips)
531 show 567
532 (const Nothing)) 568 keysdb <- Tox.newKeysDatabase
533 ] 569
534 , dhtParseId = readEither :: String -> Either String Tox.NodeId 570 (quitTox,toxdhts,toxips) <- case porttox opts of
535 , dhtSearches = toxSearches 571 "" -> return (return (), Map.empty, return [])
536 } 572 toxport -> do
537 dhts = Map.fromList 573 addrTox <- getBindAddress toxport (ip6tox opts)
538 [ ("bt4", mainlineDHT Mainline.routing4) 574 tox <- Tox.newTox keysdb addrTox
539 , ("bt6", mainlineDHT Mainline.routing6) 575 quitTox <- Tox.forkTox tox
540 , ("tox4", toxDHT Tox.routing4) 576
541 , ("tox6", toxDHT Tox.routing6) 577 toxSearches <- atomically $ newTVar Map.empty
542 ] 578
579 let toxDHT bkts = DHT
580 { dhtBuckets = bkts (Tox.toxRouting tox)
581 , dhtPing = Tox.ping (Tox.toxDHT tox)
582 , dhtQuery = Map.fromList
583 [ ("node", DHTQuery (Tox.nodeSearch $ Tox.toxDHT tox)
584 (\ni -> fmap Tox.unwrapNodes
585 . Tox.getNodesH (Tox.toxRouting tox) ni
586 . Tox.GetNodes)
587 show
588 (const Nothing))
589 ]
590 , dhtParseId = readEither :: String -> Either String Tox.NodeId
591 , dhtSearches = toxSearches
592 , dhtFallbackNodes = return []
593 }
594 dhts = Map.fromList $
595 ("tox4", toxDHT Tox.routing4)
596 : if ip6tox opts
597 then [ ("tox6", toxDHT Tox.routing6) ]
598 else []
599 ips :: IO [SockAddr]
600 ips = readExternals Tox.nodeAddr [ Tox.routing4 $ Tox.toxRouting tox
601 , Tox.routing6 $ Tox.toxRouting tox ]
602 return (quitTox, dhts, ips)
603
604 let dhts = Map.union btdhts toxdhts
543 605
544 waitForSignal <- do 606 waitForSignal <- do
545 signalQuit <- newEmptyMVar 607 signalQuit <- newEmptyMVar
546 let session = clientSession $ Session 608 let session = clientSession $ Session
547 { netname = "bt4" -- initial default DHT 609 { netname = concat $ take 1 $ Map.keys dhts -- initial default DHT
548 , dhts = dhts -- all DHTs 610 , dhts = dhts -- all DHTs
549 , signalQuit = signalQuit 611 , signalQuit = signalQuit
550 , swarms = swarms 612 , swarms = swarms
551 , toxkeys = toxkeys 613 , toxkeys = keysdb
552 , externalAddresses = readExternals 614 , externalAddresses = liftM2 (++) btips toxips
553 [ Mainline.routing4 btR
554 , Mainline.routing6 btR
555 ]
556 } 615 }
557 srv <- streamServer (withSession session) (SockAddrUnix "dht.sock") 616 srv <- streamServer (withSession session) (SockAddrUnix "dht.sock")
558 return $ do 617 return $ do
559 () <- takeMVar signalQuit 618 () <- takeMVar signalQuit
560 quitListening srv 619 quitListening srv
561 620
621
622 forM_ (Map.toList dhts)
623 $ \(netname, dht@DHT { dhtBuckets = bkts
624 , dhtQuery = qrys
625 , dhtPing = ping
626 , dhtFallbackNodes = getBootstrapNodes }) -> do
627 btSaved <- loadNodes netname -- :: IO [Mainline.NodeInfo]
628 putStrLn $ "Loaded "++show (length btSaved)++" nodes for "++netname++"."
629 fallbackNodes <- getBootstrapNodes
630 let isNodesSearch :: ni :~: r -> Search nid addr tok ni r -> Search nid addr tok ni ni
631 isNodesSearch Refl sch = sch
632 fork $ do
633 myThreadId >>= flip labelThread ("bootstrap."++netname)
634 case Map.lookup "node" qrys of
635 Just DHTQuery { qsearch = srch } -> do
636 case eqT of
637 Just witness -> bootstrap (isNodesSearch witness srch) bkts ping btSaved fallbackNodes
638 _ -> error $ "Missing node-search for "++netname++"."
639 saveNodes netname dht
640 Nothing -> return ()
641 return ()
642
643 {-
562 let bkts4 = Mainline.routing4 btR 644 let bkts4 = Mainline.routing4 btR
563 btSaved4 <- loadNodes "bt4" :: IO [Mainline.NodeInfo] 645 (fallbackNodes4,fallbackNodes6) <- case portbt opts of
564 putStrLn $ "Loaded "++show (length btSaved4)++" nodes for bt4." 646 [] -> return ([],[])
565 fallbackNodes4 <- Mainline.bootstrapNodes Want_IP4 647 _ -> do
566 fork $ do 648 btSaved4 <- loadNodes "bt4" :: IO [Mainline.NodeInfo]
567 myThreadId >>= flip labelThread "bootstrap.Mainline4" 649 putStrLn $ "Loaded "++show (length btSaved4)++" nodes for bt4."
568 bootstrap (Mainline.nodeSearch bt) bkts4 (Mainline.ping bt) btSaved4 fallbackNodes4 650 fallbackNodes4 <- Mainline.bootstrapNodes Want_IP4
569 saveNodes "bt4" (dhts Map.! "bt4") 651 fork $ do
570 652 myThreadId >>= flip labelThread "bootstrap.Mainline4"
571 btSaved6 <- loadNodes "bt6" 653 bootstrap (Mainline.nodeSearch bt) bkts4 (Mainline.ping bt) btSaved4 fallbackNodes4
572 putStrLn $ "Loaded "++show (length btSaved6)++" nodes for bt6." 654 saveNodes "bt4" (dhts Map.! "bt4")
573 let bkts6 = Mainline.routing6 btR 655
574 fallbackNodes6 <- Mainline.bootstrapNodes Want_IP6 656 fallbackNodes6 <- case ip6bt opts of
575 fork $ do 657 True -> do
576 myThreadId >>= flip labelThread "bootstrap.Mainline6" 658 btSaved6 <- loadNodes "bt6"
577 bootstrap (Mainline.nodeSearch bt) bkts6 (Mainline.ping bt) btSaved6 fallbackNodes6 659 putStrLn $ "Loaded "++show (length btSaved6)++" nodes for bt6."
578 saveNodes "bt6" (dhts Map.! "bt6") 660 let bkts6 = Mainline.routing6 btR
579 661 fallbackNodes6 <- Mainline.bootstrapNodes Want_IP6
580 toxSaved4 <- loadNodes "tox4" 662 fork $ do
581 putStrLn $ "Loaded "++show (length toxSaved4)++" nodes for tox4" 663 myThreadId >>= flip labelThread "bootstrap.Mainline6"
582 fork $ do 664 bootstrap (Mainline.nodeSearch bt) bkts6 (Mainline.ping bt) btSaved6 fallbackNodes6
583 myThreadId >>= flip labelThread "bootstrap.Tox4" 665 saveNodes "bt6" (dhts Map.! "bt6")
584 bootstrap (Tox.nodeSearch tox) (Tox.routing4 toxR) (Tox.ping tox) toxSaved4 [] 666 return fallbackNodes6
585 saveNodes "tox4" (dhts Map.! "tox4") 667 False -> return []
586 668 return (fallbackNodes4,fallbackNodes6)
587 toxSaved6 <- loadNodes "tox6" 669
588 putStrLn $ "Loaded "++show (length toxSaved6)++" nodes for tox6" 670 (toxSaved4, toxSaved6) <- case porttox opts of
589 fork $ do 671 [] -> return ([],[])
590 myThreadId >>= flip labelThread "bootstrap.Tox6" 672 _ -> do
591 bootstrap (Tox.nodeSearch tox) (Tox.routing6 toxR) (Tox.ping tox) toxSaved6 [] 673 toxSaved4 <- loadNodes "tox4"
592 saveNodes "tox6" (dhts Map.! "tox6") 674 putStrLn $ "Loaded "++show (length toxSaved4)++" nodes for tox4"
675 fork $ do
676 myThreadId >>= flip labelThread "bootstrap.Tox4"
677 bootstrap (Tox.nodeSearch $ Tox.toxDHT tox) (Tox.routing4 (Tox.toxRouting tox)) (Tox.ping $ Tox.toxDHT tox) toxSaved4 []
678 saveNodes "tox4" (dhts Map.! "tox4")
679
680 toxSaved6 <- case ip6tox opts of
681 True -> do
682 toxSaved6 <- loadNodes "tox6"
683 putStrLn $ "Loaded "++show (length toxSaved6)++" nodes for tox6"
684 fork $ do
685 myThreadId >>= flip labelThread "bootstrap.Tox6"
686 bootstrap (Tox.nodeSearch $ Tox.toxDHT tox) (Tox.routing6 (Tox.toxRouting tox)) (Tox.ping $ Tox.toxDHT tox) toxSaved6 []
687 saveNodes "tox6" (dhts Map.! "tox6")
688 return toxSaved6
689 False -> return []
690 return (toxSaved4,toxSaved6)
593 691
594 hPutStr stderr $ showReport $ map (("bootstrap (IPv4)",) . show) fallbackNodes4 692 hPutStr stderr $ showReport $ map (("bootstrap (IPv4)",) . show) fallbackNodes4
595 ++ map (("bootstrap (IPv6)",) . show) fallbackNodes6 693 ++ map (("bootstrap (IPv6)",) . show) fallbackNodes6
694 -}
596 695
597 waitForSignal 696 waitForSignal
598 697
diff --git a/src/Network/Address.hs b/src/Network/Address.hs
index cc06ac0d..9a601dcd 100644
--- a/src/Network/Address.hs
+++ b/src/Network/Address.hs
@@ -648,6 +648,10 @@ genBucketSample' gen self (q,m,b)
648 | otherwise = either error id . S.decode . build <$> gen (nodeIdSize - q + 1) 648 | otherwise = either error id . S.decode . build <$> gen (nodeIdSize - q + 1)
649 where 649 where
650 nodeIdSize = finiteBitSize (undefined :: nid) `div` 8 650 nodeIdSize = finiteBitSize (undefined :: nid) `div` 8
651
652 -- Prepends q bytes to modified input:
653 -- applies mask m
654 -- toggles bit b
651 build tl = BS.init hd <> BS.cons (h .|. t) (BS.tail tl) 655 build tl = BS.init hd <> BS.cons (h .|. t) (BS.tail tl)
652 where 656 where
653 hd = BS.take q $ S.encode self 657 hd = BS.take q $ S.encode self
diff --git a/src/Network/QueryResponse.hs b/src/Network/QueryResponse.hs
index 1346174f..41e25486 100644
--- a/src/Network/QueryResponse.hs
+++ b/src/Network/QueryResponse.hs
@@ -30,6 +30,7 @@ import Data.Maybe
30import Data.Typeable 30import Data.Typeable
31import Network.Socket 31import Network.Socket
32import Network.Socket.ByteString as B 32import Network.Socket.ByteString as B
33import System.Endian
33import System.IO 34import System.IO
34import System.IO.Error 35import System.IO.Error
35import System.Timeout 36import System.Timeout
@@ -120,15 +121,15 @@ onInbound f tr = addHandler (\addr x -> f addr x >> return (Just id)) tr
120-- Example usage: 121-- Example usage:
121-- 122--
122-- > -- Start client. 123-- > -- Start client.
123-- > quitServer <- forkListener (clientNet client) 124-- > quitServer <- forkListener "listener" (clientNet client)
124-- > -- Send a query q, recieve a response r. 125-- > -- Send a query q, recieve a response r.
125-- > r <- sendQuery client method q 126-- > r <- sendQuery client method q
126-- > -- Quit client. 127-- > -- Quit client.
127-- > quitServer 128-- > quitServer
128forkListener :: Transport err addr x -> IO (IO ()) 129forkListener :: String -> Transport err addr x -> IO (IO ())
129forkListener client = do 130forkListener name client = do
130 thread_id <- forkIO $ do 131 thread_id <- forkIO $ do
131 myThreadId >>= flip labelThread "listener" 132 myThreadId >>= flip labelThread ("listener."++name)
132 fix $ awaitMessage client . const 133 fix $ awaitMessage client . const
133 return $ do 134 return $ do
134 closeTransport client 135 closeTransport client
@@ -470,9 +471,23 @@ udpTransport bind_address = do
470 r <- handle (ignoreEOF $ Just $ Right (B.empty, SockAddrInet 0 0)) $ do 471 r <- handle (ignoreEOF $ Just $ Right (B.empty, SockAddrInet 0 0)) $ do
471 Just . Right <$!> B.recvFrom sock udpBufferSize 472 Just . Right <$!> B.recvFrom sock udpBufferSize
472 kont $! r 473 kont $! r
473 , sendMessage = \addr bs -> void $ B.sendTo sock bs addr 474 , sendMessage = case family of
474 -- TODO: sendTo: does not exist (Network is unreachable) 475 -- TODO: sendTo: does not exist (Network is unreachable)
475 -- Occurs when IPv6 network is not available. 476 -- Occurs when IPv6 network is not available.
476 -- Currently, we require -threaded to prevent a forever-hang in this case. 477 -- Currently, we require -threaded to prevent a forever-hang in this case.
478 AF_INET6 -> \case
479 (SockAddrInet port addr) -> \bs ->
480 -- Change IPv4 to 4mapped6 address.
481 void $ B.sendTo sock bs $ SockAddrInet6 port 0 (0,0,0x0000ffff,fromBE32 addr) 0
482 addr6 -> \bs -> void $ B.sendTo sock bs addr6
483 AF_INET -> \case
484 (SockAddrInet6 port 0 (0,0,0x0000ffff,raw4) 0) -> \bs -> do
485 let host4 = toBE32 raw4
486 -- Change 4mapped6 to ordinary IPv4.
487 -- hPutStrLn stderr $ "4mapped6 -> "++show (SockAddrInet port host4)
488 void $ B.sendTo sock bs (SockAddrInet port host4)
489 addr@(SockAddrInet6 {}) -> \bs -> hPutStrLn stderr ("Discarding packet to "++show addr)
490 addr4 -> \bs -> void $ B.sendTo sock bs addr4
491 _ -> \addr bs -> void $ B.sendTo sock bs addr
477 , closeTransport = close sock 492 , closeTransport = close sock
478 } 493 }
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 12:48:53 +0000