diff options
author | Andrew Cady <d@jerkface.net> | 2018-06-09 01:34:43 -0400 |
---|---|---|
committer | Andrew Cady <d@jerkface.net> | 2018-06-09 01:34:43 -0400 |
commit | 626820b99b76b4e4fa0b36e8e92e05d8176c4f43 (patch) | |
tree | 5ced91907da9ff6b9d391ca013533912366ae29c | |
parent | 031d0e35f0532e4573497926a692ced50ba2f4b0 (diff) | |
parent | fb0c6758ec415c5cda5cc7c182e1f83906f365fb (diff) |
Merge branch 'dht-presence' of blackbird:bittorrent
-rw-r--r-- | Connection.hs | 2 | ||||
-rw-r--r-- | bittorrent/src/Network/BitTorrent/Tracker.hs | 1 | ||||
-rw-r--r-- | bittorrent/src/Network/BitTorrent/Tracker/List.hs | 4 | ||||
-rw-r--r-- | bittorrent/src/Network/BitTorrent/Tracker/Message.hs | 22 | ||||
-rw-r--r-- | bittorrent/src/Network/BitTorrent/Tracker/RPC/HTTP.hs | 2 | ||||
-rw-r--r-- | bittorrent/src/Network/BitTorrent/Tracker/Session.hs | 6 | ||||
-rw-r--r-- | examples/dhtd.hs | 16 | ||||
-rw-r--r-- | src/Crypto/Tox.hs | 4 | ||||
-rw-r--r-- | src/Network/Kademlia.hs | 2 | ||||
-rw-r--r-- | src/Network/Tox.hs | 9 | ||||
-rw-r--r-- | src/Network/Tox/Crypto/Handlers.hs | 19 | ||||
-rw-r--r-- | src/Network/Tox/NodeId.hs | 11 | ||||
-rw-r--r-- | src/Network/Tox/Onion/Handlers.hs | 33 | ||||
-rw-r--r-- | todo.txt | 6 |
14 files changed, 91 insertions, 46 deletions
diff --git a/Connection.hs b/Connection.hs index 7228a0e4..58b4f4e5 100644 --- a/Connection.hs +++ b/Connection.hs | |||
@@ -13,7 +13,7 @@ data Status status | |||
13 | = Dormant | 13 | = Dormant |
14 | | InProgress status | 14 | | InProgress status |
15 | | Established | 15 | | Established |
16 | deriving (Eq,Ord,Functor) | 16 | deriving (Show,Eq,Ord,Functor) |
17 | 17 | ||
18 | data Policy | 18 | data Policy |
19 | = RefusingToConnect | 19 | = RefusingToConnect |
diff --git a/bittorrent/src/Network/BitTorrent/Tracker.hs b/bittorrent/src/Network/BitTorrent/Tracker.hs index 6db67559..1191f921 100644 --- a/bittorrent/src/Network/BitTorrent/Tracker.hs +++ b/bittorrent/src/Network/BitTorrent/Tracker.hs | |||
@@ -23,6 +23,7 @@ module Network.BitTorrent.Tracker | |||
23 | , trackerList | 23 | , trackerList |
24 | , Session | 24 | , Session |
25 | , Event (..) | 25 | , Event (..) |
26 | , trackers | ||
26 | , newSession | 27 | , newSession |
27 | , closeSession | 28 | , closeSession |
28 | , withSession | 29 | , withSession |
diff --git a/bittorrent/src/Network/BitTorrent/Tracker/List.hs b/bittorrent/src/Network/BitTorrent/Tracker/List.hs index 0eb11641..1507b4be 100644 --- a/bittorrent/src/Network/BitTorrent/Tracker/List.hs +++ b/bittorrent/src/Network/BitTorrent/Tracker/List.hs | |||
@@ -16,6 +16,7 @@ module Network.BitTorrent.Tracker.List | |||
16 | , TrackerList | 16 | , TrackerList |
17 | 17 | ||
18 | -- * Construction | 18 | -- * Construction |
19 | , trackers | ||
19 | , trackerList | 20 | , trackerList |
20 | , shuffleTiers | 21 | , shuffleTiers |
21 | , mapWithURI | 22 | , mapWithURI |
@@ -116,6 +117,9 @@ fixList mxss mx = do | |||
116 | let xss' = L.filter (not . L.null) xss | 117 | let xss' = L.filter (not . L.null) xss |
117 | return $ maybe xss' (addBackup xss') mx | 118 | return $ maybe xss' (addBackup xss') mx |
118 | 119 | ||
120 | trackers :: [URI] -> TrackerList () | ||
121 | trackers uris = TierList $ map (\uri -> [(uri,())]) uris | ||
122 | |||
119 | -- | Extract set of trackers from torrent file. The 'tAnnounce' key is | 123 | -- | Extract set of trackers from torrent file. The 'tAnnounce' key is |
120 | -- only ignored if the 'tAnnounceList' key is present. | 124 | -- only ignored if the 'tAnnounceList' key is present. |
121 | trackerList :: Torrent -> TrackerList () | 125 | trackerList :: Torrent -> TrackerList () |
diff --git a/bittorrent/src/Network/BitTorrent/Tracker/Message.hs b/bittorrent/src/Network/BitTorrent/Tracker/Message.hs index b9b6a9d3..e01ebbf4 100644 --- a/bittorrent/src/Network/BitTorrent/Tracker/Message.hs +++ b/bittorrent/src/Network/BitTorrent/Tracker/Message.hs | |||
@@ -404,8 +404,8 @@ parseAnnounceQuery params = AnnounceQuery | |||
404 | -- For more info see: <http://www.bittorrent.org/beps/bep_0023.html> | 404 | -- For more info see: <http://www.bittorrent.org/beps/bep_0023.html> |
405 | -- | 405 | -- |
406 | data PeerList ip | 406 | data PeerList ip |
407 | = PeerList [PeerAddr IP] | 407 | = PeerList [PeerAddr] |
408 | | CompactPeerList [PeerAddr ip] | 408 | | CompactPeerList [PeerAddr] |
409 | deriving (Show, Eq, Typeable, Functor) | 409 | deriving (Show, Eq, Typeable, Functor) |
410 | 410 | ||
411 | -- | The empty non-compact peer list. | 411 | -- | The empty non-compact peer list. |
@@ -413,11 +413,11 @@ instance Default (PeerList IP) where | |||
413 | def = PeerList [] | 413 | def = PeerList [] |
414 | {-# INLINE def #-} | 414 | {-# INLINE def #-} |
415 | 415 | ||
416 | getPeerList :: PeerList IP -> [PeerAddr IP] | 416 | getPeerList :: PeerList IP -> [PeerAddr] |
417 | getPeerList (PeerList xs) = xs | 417 | getPeerList (PeerList xs) = xs |
418 | getPeerList (CompactPeerList xs) = xs | 418 | getPeerList (CompactPeerList xs) = xs |
419 | 419 | ||
420 | instance Serialize a => BEncode (PeerList a) where | 420 | instance BEncode (PeerList a) where |
421 | toBEncode (PeerList xs) = toBEncode xs | 421 | toBEncode (PeerList xs) = toBEncode xs |
422 | toBEncode (CompactPeerList xs) = toBEncode $ runPut (mapM_ put xs) | 422 | toBEncode (CompactPeerList xs) = toBEncode $ runPut (mapM_ put xs) |
423 | 423 | ||
@@ -491,10 +491,10 @@ instance BEncode AnnounceInfo where | |||
491 | | L.null v6s = (CompactPeerList v4s, Nothing) | 491 | | L.null v6s = (CompactPeerList v4s, Nothing) |
492 | | otherwise = (CompactPeerList v4s, Just (CompactPeerList v6s)) | 492 | | otherwise = (CompactPeerList v4s, Just (CompactPeerList v6s)) |
493 | 493 | ||
494 | toEither :: PeerAddr IP -> Either (PeerAddr IPv4) (PeerAddr IPv6) | 494 | toEither :: PeerAddr -> Either PeerAddr PeerAddr |
495 | toEither PeerAddr {..} = case peerHost of | 495 | toEither PeerAddr {..} = case peerHost of |
496 | IPv4 ipv4 -> Left $ PeerAddr peerId ipv4 peerPort | 496 | ipv4@IPv4{} -> Left $ PeerAddr peerId ipv4 peerPort |
497 | IPv6 ipv6 -> Right $ PeerAddr peerId ipv6 peerPort | 497 | ipv6@IPv6{} -> Right $ PeerAddr peerId ipv6 peerPort |
498 | 498 | ||
499 | fromBEncode (BDict d) | 499 | fromBEncode (BDict d) |
500 | | Just t <- BE.lookup "failure reason" d = Failure <$> fromBEncode t | 500 | | Just t <- BE.lookup "failure reason" d = Failure <$> fromBEncode t |
@@ -514,7 +514,7 @@ instance BEncode AnnounceInfo where | |||
514 | \but the `peers6' field present" | 514 | \but the `peers6' field present" |
515 | 515 | ||
516 | merge (CompactPeerList ipv4s) Nothing | 516 | merge (CompactPeerList ipv4s) Nothing |
517 | = pure $ CompactPeerList (fmap IPv4 <$> ipv4s) | 517 | = pure $ CompactPeerList ipv4s |
518 | 518 | ||
519 | merge (CompactPeerList _ ) (Just (PeerList _)) | 519 | merge (CompactPeerList _ ) (Just (PeerList _)) |
520 | = fail "PeerList: the `peers6' field value \ | 520 | = fail "PeerList: the `peers6' field value \ |
@@ -522,7 +522,7 @@ instance BEncode AnnounceInfo where | |||
522 | 522 | ||
523 | merge (CompactPeerList ipv4s) (Just (CompactPeerList ipv6s)) | 523 | merge (CompactPeerList ipv4s) (Just (CompactPeerList ipv6s)) |
524 | = pure $ CompactPeerList $ | 524 | = pure $ CompactPeerList $ |
525 | (fmap IPv4 <$> ipv4s) <> (fmap IPv6 <$> ipv6s) | 525 | ipv4s <> ipv6s |
526 | 526 | ||
527 | fromBEncode _ = decodingError "Announce info" | 527 | fromBEncode _ = decodingError "Announce info" |
528 | 528 | ||
@@ -533,13 +533,13 @@ instance Serialize AnnounceInfo where | |||
533 | putWord32be $ fromIntegral respInterval | 533 | putWord32be $ fromIntegral respInterval |
534 | putWord32be $ fromIntegral $ fromMaybe 0 respIncomplete | 534 | putWord32be $ fromIntegral $ fromMaybe 0 respIncomplete |
535 | putWord32be $ fromIntegral $ fromMaybe 0 respComplete | 535 | putWord32be $ fromIntegral $ fromMaybe 0 respComplete |
536 | forM_ (fmap ipv4 <$> getPeerList respPeers) put | 536 | forM_ (getPeerList respPeers) put |
537 | 537 | ||
538 | get = do | 538 | get = do |
539 | interval <- getWord32be | 539 | interval <- getWord32be |
540 | leechers <- getWord32be | 540 | leechers <- getWord32be |
541 | seeders <- getWord32be | 541 | seeders <- getWord32be |
542 | peers <- many $ fmap IPv4 <$> get | 542 | peers <- many $ isolate 6 get -- isolated to specify IPv4. |
543 | 543 | ||
544 | return $ AnnounceInfo { | 544 | return $ AnnounceInfo { |
545 | respWarning = Nothing | 545 | respWarning = Nothing |
diff --git a/bittorrent/src/Network/BitTorrent/Tracker/RPC/HTTP.hs b/bittorrent/src/Network/BitTorrent/Tracker/RPC/HTTP.hs index 9b6e056a..6f7a53bf 100644 --- a/bittorrent/src/Network/BitTorrent/Tracker/RPC/HTTP.hs +++ b/bittorrent/src/Network/BitTorrent/Tracker/RPC/HTTP.hs | |||
@@ -129,7 +129,7 @@ fillRequest Options {..} q r = r | |||
129 | 129 | ||
130 | httpTracker :: BEncode a => Manager -> URI -> SimpleQuery -> IO a | 130 | httpTracker :: BEncode a => Manager -> URI -> SimpleQuery -> IO a |
131 | httpTracker Manager {..} uri q = packHttpException $ do | 131 | httpTracker Manager {..} uri q = packHttpException $ do |
132 | request <- fillRequest options q <$> setUri def {- http-client instance for Request -} uri | 132 | request <- fillRequest options q <$> setUri defaultRequest uri |
133 | response <- runResourceT $ httpLbs request httpMgr | 133 | response <- runResourceT $ httpLbs request httpMgr |
134 | case BE.decode $ BL.toStrict $ responseBody response of | 134 | case BE.decode $ BL.toStrict $ responseBody response of |
135 | Left msg -> throwIO (ParserFailure msg) | 135 | Left msg -> throwIO (ParserFailure msg) |
diff --git a/bittorrent/src/Network/BitTorrent/Tracker/Session.hs b/bittorrent/src/Network/BitTorrent/Tracker/Session.hs index aa4a832f..db6ebaff 100644 --- a/bittorrent/src/Network/BitTorrent/Tracker/Session.hs +++ b/bittorrent/src/Network/BitTorrent/Tracker/Session.hs | |||
@@ -98,7 +98,7 @@ data TrackerSession = TrackerSession | |||
98 | statusSent :: !(Maybe Status) | 98 | statusSent :: !(Maybe Status) |
99 | 99 | ||
100 | -- | Can be used to retrieve peer set. | 100 | -- | Can be used to retrieve peer set. |
101 | , trackerPeers :: Cached [PeerAddr IP] | 101 | , trackerPeers :: Cached [PeerAddr] |
102 | 102 | ||
103 | -- | Can be used to show brief swarm stats in client GUI. | 103 | -- | Can be used to show brief swarm stats in client GUI. |
104 | , trackerScrape :: Cached LastScrape | 104 | , trackerScrape :: Cached LastScrape |
@@ -129,7 +129,7 @@ nextStatus Completed = Nothing -- must keep previous status | |||
129 | seconds :: Int -> NominalDiffTime | 129 | seconds :: Int -> NominalDiffTime |
130 | seconds n = realToFrac (toEnum n :: Uni) | 130 | seconds n = realToFrac (toEnum n :: Uni) |
131 | 131 | ||
132 | cachePeers :: AnnounceInfo -> IO (Cached [PeerAddr IP]) | 132 | cachePeers :: AnnounceInfo -> IO (Cached [PeerAddr]) |
133 | cachePeers AnnounceInfo {..} = | 133 | cachePeers AnnounceInfo {..} = |
134 | newCached (seconds respInterval) | 134 | newCached (seconds respInterval) |
135 | (seconds (fromMaybe respInterval respMinInterval)) | 135 | (seconds (fromMaybe respInterval respMinInterval)) |
@@ -264,7 +264,7 @@ notify mgr ses event = do | |||
264 | -- TODO run announce if sesion have no peers | 264 | -- TODO run announce if sesion have no peers |
265 | -- | The returned list of peers can have duplicates. | 265 | -- | The returned list of peers can have duplicates. |
266 | -- This function /may/ block. Use async if needed. | 266 | -- This function /may/ block. Use async if needed. |
267 | askPeers :: Manager -> Session -> IO [PeerAddr IP] | 267 | askPeers :: Manager -> Session -> IO [PeerAddr] |
268 | askPeers _mgr ses = do | 268 | askPeers _mgr ses = do |
269 | list <- readMVar (sessionTrackers ses) | 269 | list <- readMVar (sessionTrackers ses) |
270 | L.concat <$> collect (tryTakeData . trackerPeers) list | 270 | L.concat <$> collect (tryTakeData . trackerPeers) list |
diff --git a/examples/dhtd.hs b/examples/dhtd.hs index 67507634..369650f9 100644 --- a/examples/dhtd.hs +++ b/examples/dhtd.hs | |||
@@ -622,14 +622,17 @@ clientSession s@Session{..} sock cnum h = do | |||
622 | -> cmd0 $ do | 622 | -> cmd0 $ do |
623 | sessions <- concat . Map.elems <$> (atomically $ readTVar (Tox.netCryptoSessionsByKey cryptosessions)) | 623 | sessions <- concat . Map.elems <$> (atomically $ readTVar (Tox.netCryptoSessionsByKey cryptosessions)) |
624 | let sessionsReport = mapM showPerSession sessions | 624 | let sessionsReport = mapM showPerSession sessions |
625 | headers = ["SessionID", "YourKey", "TheirKey", "NextMsg", "Dropped","Handled","Unhandled"] | 625 | headers = ["SessionID", "YourKey", "TheirKey", "NextMsg", "Dropped" {-,"Handled","Unhandled" -} |
626 | ,"Progress" ] | ||
626 | showPerSession (Tox.NCrypto | 627 | showPerSession (Tox.NCrypto |
627 | { ncSessionId = id | 628 | { ncState = progressVar |
629 | , ncSessionId = id | ||
628 | , ncMyPublicKey = yourkey | 630 | , ncMyPublicKey = yourkey |
629 | , ncTheirPublicKey = theirkey | 631 | , ncTheirPublicKey = theirkey |
630 | , ncLastNMsgs = lastN | 632 | , ncLastNMsgs = lastN |
631 | , ncSockAddr = sockAddr | 633 | , ncSockAddr = sockAddr |
632 | }) = do | 634 | }) = do |
635 | progress <- atomically $ readTVar progressVar | ||
633 | (num,dropped) <- atomically $ liftA2 (,) (CB.getTotal lastN) (CB.getDropped lastN) | 636 | (num,dropped) <- atomically $ liftA2 (,) (CB.getTotal lastN) (CB.getDropped lastN) |
634 | as <- atomically (CB.cyclicBufferViewList lastN) | 637 | as <- atomically (CB.cyclicBufferViewList lastN) |
635 | let (h,u) = partition (fst . snd) as | 638 | let (h,u) = partition (fst . snd) as |
@@ -640,8 +643,9 @@ clientSession s@Session{..} sock cnum h = do | |||
640 | , show (Tox.key2id theirkey)-- "TheirKey" | 643 | , show (Tox.key2id theirkey)-- "TheirKey" |
641 | , show num -- "NextMsg" | 644 | , show num -- "NextMsg" |
642 | , show dropped -- "Dropped" | 645 | , show dropped -- "Dropped" |
643 | , show countHandled -- "Handled" | 646 | -- , show countHandled -- "Handled" |
644 | , show countUnhandled -- "Unhandled" | 647 | -- , show countUnhandled -- "Unhandled" |
648 | , show progress | ||
645 | ] | 649 | ] |
646 | if null sessions | 650 | if null sessions |
647 | then hPutClient h "No sessions." | 651 | then hPutClient h "No sessions." |
@@ -1161,7 +1165,7 @@ clientSession s@Session{..} sock cnum h = do | |||
1161 | keydb <- atomically $ readTVar toxkeys | 1165 | keydb <- atomically $ readTVar toxkeys |
1162 | now <- getPOSIXTime | 1166 | now <- getPOSIXTime |
1163 | let entries = map mkentry $ PSQ.toList (Tox.keyByAge keydb) | 1167 | let entries = map mkentry $ PSQ.toList (Tox.keyByAge keydb) |
1164 | mkentry (k :-> Down tm) = [ show cnt, show k, show (now - tm) ] | 1168 | mkentry (k :-> tm) = [ show cnt, show k, show (now - tm) ] |
1165 | where Just (_,(cnt,_)) = MM.lookup' k (Tox.keyAssoc keydb) | 1169 | where Just (_,(cnt,_)) = MM.lookup' k (Tox.keyAssoc keydb) |
1166 | hPutClient h $ showColumns entries | 1170 | hPutClient h $ showColumns entries |
1167 | 1171 | ||
@@ -1415,7 +1419,7 @@ announceToxJabberPeer them echan laddr saddr pingflag tsrc tsnk | |||
1415 | , Tcp.Connection pingflag xsrc xsnk ) | 1419 | , Tcp.Connection pingflag xsrc xsnk ) |
1416 | return Nothing | 1420 | return Nothing |
1417 | where | 1421 | where |
1418 | xsrc = tsrc =$= toxToXmpp (T.pack $ show them ++ ".tox") | 1422 | xsrc = tsrc =$= toxToXmpp (T.pack $ show (Tox.key2id them) ++ ".tox") |
1419 | xsnk = flushPassThrough xmppToTox =$= tsnk | 1423 | xsnk = flushPassThrough xmppToTox =$= tsnk |
1420 | 1424 | ||
1421 | vShowMe :: Tox.ViewSnapshot -> Int -> B.ByteString | 1425 | vShowMe :: Tox.ViewSnapshot -> Int -> B.ByteString |
diff --git a/src/Crypto/Tox.hs b/src/Crypto/Tox.hs index 71aa99c4..0a7f07c3 100644 --- a/src/Crypto/Tox.hs +++ b/src/Crypto/Tox.hs | |||
@@ -218,7 +218,7 @@ decryptSymmetric (SymmetricKey symmkey) (Nonce24 n24) (Encrypted bs) = do | |||
218 | let (ds, symm') = Symmetric.decrypt bs'' symm | 218 | let (ds, symm') = Symmetric.decrypt bs'' symm |
219 | auth = Symmetric.finalize symm' | 219 | auth = Symmetric.finalize symm' |
220 | if BA.convert auth /= mac | 220 | if BA.convert auth /= mac |
221 | then Left "symmetricDecipher: Auth fail." | 221 | then Left "Symmetric decryption failed. Incorrect key material?" |
222 | else return $ Plain ds | 222 | else return $ Plain ds |
223 | 223 | ||
224 | encryptSymmetric :: SymmetricKey -> Nonce24 -> Plain s x -> Encrypted x | 224 | encryptSymmetric :: SymmetricKey -> Nonce24 -> Plain s x -> Encrypted x |
@@ -237,7 +237,7 @@ data State = State Poly1305.State XSalsa.State | |||
237 | decrypt :: State -> Encrypted a -> Either String (Plain s a) | 237 | decrypt :: State -> Encrypted a -> Either String (Plain s a) |
238 | decrypt (State hash crypt) ciphertext | 238 | decrypt (State hash crypt) ciphertext |
239 | | (a == mac) = Right (Plain m) | 239 | | (a == mac) = Right (Plain m) |
240 | | otherwise = Left "decipherAndAuth: auth fail" | 240 | | otherwise = Left "Asymmetric decryption failed. Incorrect key material?" |
241 | where | 241 | where |
242 | (mac, c) = authAndBytes ciphertext | 242 | (mac, c) = authAndBytes ciphertext |
243 | m = fst . XSalsa.combine crypt $ c | 243 | m = fst . XSalsa.combine crypt $ c |
diff --git a/src/Network/Kademlia.hs b/src/Network/Kademlia.hs index 8956df2c..0ab26e80 100644 --- a/src/Network/Kademlia.hs +++ b/src/Network/Kademlia.hs | |||
@@ -26,8 +26,6 @@ import Data.IP | |||
26 | import Data.Monoid | 26 | import Data.Monoid |
27 | import Data.Serialize (Serialize) | 27 | import Data.Serialize (Serialize) |
28 | import Data.Time.Clock.POSIX (POSIXTime) | 28 | import Data.Time.Clock.POSIX (POSIXTime) |
29 | import qualified Data.Wrapper.PSQInt as Int | ||
30 | ;import Data.Wrapper.PSQInt (pattern (:->)) | ||
31 | import Network.Address (bucketRange,genBucketSample) | 29 | import Network.Address (bucketRange,genBucketSample) |
32 | import Network.Kademlia.Search | 30 | import Network.Kademlia.Search |
33 | import System.Entropy | 31 | import System.Entropy |
diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs index 5bd23da8..3c3bce49 100644 --- a/src/Network/Tox.hs +++ b/src/Network/Tox.hs | |||
@@ -19,7 +19,7 @@ import Debug.Trace | |||
19 | import Control.Exception hiding (Handler) | 19 | import Control.Exception hiding (Handler) |
20 | import Control.Applicative | 20 | import Control.Applicative |
21 | import Control.Arrow | 21 | import Control.Arrow |
22 | import Control.Concurrent (MVar) | 22 | import Control.Concurrent (MVar,killThread) |
23 | import Control.Concurrent.STM | 23 | import Control.Concurrent.STM |
24 | import Control.Monad | 24 | import Control.Monad |
25 | import Control.Monad.Fix | 25 | import Control.Monad.Fix |
@@ -485,18 +485,19 @@ forkTox tox = do | |||
485 | quit <- forkListener "toxCrypto" (toxCrypto tox) | 485 | quit <- forkListener "toxCrypto" (toxCrypto tox) |
486 | forkPollForRefresh (DHT.refresher4 $ toxRouting tox) | 486 | forkPollForRefresh (DHT.refresher4 $ toxRouting tox) |
487 | forkPollForRefresh (DHT.refresher6 $ toxRouting tox) | 487 | forkPollForRefresh (DHT.refresher6 $ toxRouting tox) |
488 | return ( quit | 488 | keygc <- Onion.forkAnnouncedKeysGC (toxAnnouncedKeys tox) |
489 | return ( killThread keygc >> quit | ||
489 | , bootstrap (DHT.refresher4 $ toxRouting tox) | 490 | , bootstrap (DHT.refresher4 $ toxRouting tox) |
490 | , bootstrap (DHT.refresher6 $ toxRouting tox) | 491 | , bootstrap (DHT.refresher6 $ toxRouting tox) |
491 | ) | 492 | ) |
492 | 493 | ||
493 | -- TODO: Don't export this. | 494 | -- TODO: Don't export this. The exported interface is 'toxAnnounceToLan'. |
494 | announceToLan :: Socket -> NodeId -> IO () | 495 | announceToLan :: Socket -> NodeId -> IO () |
495 | announceToLan sock nid = do | 496 | announceToLan sock nid = do |
496 | addrs <- broadcastAddrs | 497 | addrs <- broadcastAddrs |
497 | forM_ addrs $ \addr -> do | 498 | forM_ addrs $ \addr -> do |
498 | (broadcast_info:_) <- getAddrInfo (Just defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Datagram }) | 499 | (broadcast_info:_) <- getAddrInfo (Just defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Datagram }) |
499 | (Just addr) -- TODO: Detect broadcast address. | 500 | (Just addr) |
500 | (Just "33445") | 501 | (Just "33445") |
501 | let broadcast = addrAddress broadcast_info | 502 | let broadcast = addrAddress broadcast_info |
502 | bs = S.runPut $ DHT.putMessage (DHT.DHTLanDiscovery nid) | 503 | bs = S.runPut $ DHT.putMessage (DHT.DHTLanDiscovery nid) |
diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs index 5316acc8..e22388a3 100644 --- a/src/Network/Tox/Crypto/Handlers.hs +++ b/src/Network/Tox/Crypto/Handlers.hs | |||
@@ -2,6 +2,7 @@ | |||
2 | {-# LANGUAGE TupleSections #-} | 2 | {-# LANGUAGE TupleSections #-} |
3 | {-# LANGUAGE TypeOperators #-} | 3 | {-# LANGUAGE TypeOperators #-} |
4 | {-# LANGUAGE DeriveFunctor #-} | 4 | {-# LANGUAGE DeriveFunctor #-} |
5 | {-# LANGUAGE CPP #-} | ||
5 | module Network.Tox.Crypto.Handlers where | 6 | module Network.Tox.Crypto.Handlers where |
6 | 7 | ||
7 | import Network.Tox.NodeId | 8 | import Network.Tox.NodeId |
@@ -40,8 +41,12 @@ import System.IO.Temp | |||
40 | import System.Environment | 41 | import System.Environment |
41 | import System.Directory | 42 | import System.Directory |
42 | import System.Random -- for ping fuzz | 43 | import System.Random -- for ping fuzz |
44 | #ifdef THREAD_DEBUG | ||
45 | import Control.Concurrent.Lifted.Instrument | ||
46 | #else | ||
43 | import Control.Concurrent | 47 | import Control.Concurrent |
44 | import GHC.Conc (labelThread) | 48 | import GHC.Conc (labelThread) |
49 | #endif | ||
45 | import PingMachine | 50 | import PingMachine |
46 | import qualified Data.IntMap.Strict as IntMap | 51 | import qualified Data.IntMap.Strict as IntMap |
47 | import Control.Concurrent.Supply | 52 | import Control.Concurrent.Supply |
@@ -719,8 +724,8 @@ updateCryptoSession sessions addr newsession timestamp hp session handshake = do | |||
719 | dmsg (" ncTheirDHTKey=" ++ show (ncTheirDHTKey session) | 724 | dmsg (" ncTheirDHTKey=" ++ show (ncTheirDHTKey session) |
720 | ++ bool "{/=}" "{==}" (ncTheirDHTKey session == HaveDHTKey (hpCookieRemoteDhtkey hp)) | 725 | ++ bool "{/=}" "{==}" (ncTheirDHTKey session == HaveDHTKey (hpCookieRemoteDhtkey hp)) |
721 | ++ "hpCookieRemoteDhtkey=" ++ show (hpCookieRemoteDhtkey hp)) | 726 | ++ "hpCookieRemoteDhtkey=" ++ show (hpCookieRemoteDhtkey hp)) |
722 | if ( -- Just ncTheirBaseNonce0 /= hpTheirBaseNonce hp -- XXX: Do we really want to compare base nonce here? | 727 | if ( toMaybe ncTheirBaseNonce0 /= hpTheirBaseNonce hp |
723 | -- || | 728 | || |
724 | ncTheirDHTKey session /= HaveDHTKey (hpCookieRemoteDhtkey hp) | 729 | ncTheirDHTKey session /= HaveDHTKey (hpCookieRemoteDhtkey hp) |
725 | ) | 730 | ) |
726 | then freshCryptoSession sessions addr newsession timestamp hp | 731 | then freshCryptoSession sessions addr newsession timestamp hp |
@@ -1042,10 +1047,16 @@ sendCrypto crypto session updateLocal cm = do | |||
1042 | PQ.OGEncodeFail -> return (Left "Failed to encode outgoing packet") | 1047 | PQ.OGEncodeFail -> return (Left "Failed to encode outgoing packet") |
1043 | 1048 | ||
1044 | sendOnline :: TransportCrypto -> NetCryptoSession -> IO (Either String ()) | 1049 | sendOnline :: TransportCrypto -> NetCryptoSession -> IO (Either String ()) |
1045 | sendOnline crypto session = sendCrypto crypto session (return ()) (OneByte ONLINE) | 1050 | sendOnline crypto session = do |
1051 | let cm=OneByte ONLINE | ||
1052 | addMsgToLastN False (cm ^. messageType) session (Out cm) | ||
1053 | sendCrypto crypto session (return ()) (OneByte ONLINE) | ||
1046 | 1054 | ||
1047 | sendOffline :: TransportCrypto -> NetCryptoSession -> IO (Either String ()) | 1055 | sendOffline :: TransportCrypto -> NetCryptoSession -> IO (Either String ()) |
1048 | sendOffline crypto session = sendCrypto crypto session (return ()) (OneByte OFFLINE) | 1056 | sendOffline crypto session = do |
1057 | let cm=OneByte OFFLINE | ||
1058 | addMsgToLastN False (cm ^. messageType) session (Out cm) | ||
1059 | sendCrypto crypto session (return ()) (OneByte OFFLINE) | ||
1049 | 1060 | ||
1050 | 1061 | ||
1051 | sendKill :: TransportCrypto -> NetCryptoSession -> IO (Either String ()) | 1062 | sendKill :: TransportCrypto -> NetCryptoSession -> IO (Either String ()) |
diff --git a/src/Network/Tox/NodeId.hs b/src/Network/Tox/NodeId.hs index 74239710..dab1b14a 100644 --- a/src/Network/Tox/NodeId.hs +++ b/src/Network/Tox/NodeId.hs | |||
@@ -555,8 +555,14 @@ parseNoSpamJID jid = do | |||
555 | _ -> Left "Hostname should be 43 base64 digits followed by .tox." | 555 | _ -> Left "Hostname should be 43 base64 digits followed by .tox." |
556 | pub <- id2key <$> readEither base64 | 556 | pub <- id2key <$> readEither base64 |
557 | let ustr = Text.unpack u | 557 | let ustr = Text.unpack u |
558 | '$' : b64digits <- Right ustr -- TODO: support 0x prefix also. | 558 | case ustr of |
559 | NoSpam nospam (Just x) <- readEither $ map (\case; '?' -> '0'; c -> c) ustr | 559 | '$' : b64digits -> solveBase64NoSpamID b64digits pub |
560 | '0' : 'x' : hexdigits -> do nospam <- readEither ('0':'x':hexdigits) | ||
561 | return $ NoSpamId nospam pub | ||
562 | |||
563 | solveBase64NoSpamID :: String -> PublicKey -> Either String NoSpamId | ||
564 | solveBase64NoSpamID b64digits pub = do | ||
565 | NoSpam nospam (Just x) <- readEither $ '$' : map (\case; '?' -> '0'; c -> c) b64digits | ||
560 | let nlo = fromIntegral (0x0FFFF .&. nospam) :: Word16 | 566 | let nlo = fromIntegral (0x0FFFF .&. nospam) :: Word16 |
561 | nhi = fromIntegral (0x0FFFF .&. (nospam `shiftR` 16)) :: Word16 | 567 | nhi = fromIntegral (0x0FFFF .&. (nospam `shiftR` 16)) :: Word16 |
562 | sum = x `xor` nlo `xor` nhi `xor` xorsum pub | 568 | sum = x `xor` nlo `xor` nhi `xor` xorsum pub |
@@ -583,7 +589,6 @@ parseNoSpamJID jid = do | |||
583 | let bitpos = q * 6 + p * 2 | 589 | let bitpos = q * 6 + p * 2 |
584 | ac' = ac `xor` shiftR (fromIntegral b `shiftL` 48) bitpos | 590 | ac' = ac `xor` shiftR (fromIntegral b `shiftL` 48) bitpos |
585 | solve ns ac' | 591 | solve ns ac' |
586 | |||
587 | n64' <- solve ns n64 | 592 | n64' <- solve ns n64 |
588 | let nospam' = fromIntegral (n64' `shiftR` 32) | 593 | let nospam' = fromIntegral (n64' `shiftR` 32) |
589 | cksum' = fromIntegral (n64' `shiftR` 16) | 594 | cksum' = fromIntegral (n64' `shiftR` 16) |
diff --git a/src/Network/Tox/Onion/Handlers.hs b/src/Network/Tox/Onion/Handlers.hs index 99ef3c69..263d60bd 100644 --- a/src/Network/Tox/Onion/Handlers.hs +++ b/src/Network/Tox/Onion/Handlers.hs | |||
@@ -11,7 +11,7 @@ import Network.QueryResponse as QR hiding (Client) | |||
11 | import qualified Network.QueryResponse as QR (Client) | 11 | import qualified Network.QueryResponse as QR (Client) |
12 | import Crypto.Tox | 12 | import Crypto.Tox |
13 | import qualified Data.Wrapper.PSQ as PSQ | 13 | import qualified Data.Wrapper.PSQ as PSQ |
14 | ;import Data.Wrapper.PSQ (PSQ) | 14 | ;import Data.Wrapper.PSQ (PSQ,pattern (:->)) |
15 | #ifdef CRYPTONITE_BACKPORT | 15 | #ifdef CRYPTONITE_BACKPORT |
16 | import Crypto.Error.Types (CryptoFailable (..), | 16 | import Crypto.Error.Types (CryptoFailable (..), |
17 | throwCryptoError) | 17 | throwCryptoError) |
@@ -35,6 +35,12 @@ import Network.BitTorrent.DHT.Token as Token | |||
35 | 35 | ||
36 | import Control.Exception hiding (Handler) | 36 | import Control.Exception hiding (Handler) |
37 | import Control.Monad | 37 | import Control.Monad |
38 | #ifdef THREAD_DEBUG | ||
39 | import Control.Concurrent.Lifted.Instrument | ||
40 | #else | ||
41 | import Control.Concurrent | ||
42 | import GHC.Conc (labelThread) | ||
43 | #endif | ||
38 | import Control.Concurrent.STM | 44 | import Control.Concurrent.STM |
39 | import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) | 45 | import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) |
40 | import Network.Socket | 46 | import Network.Socket |
@@ -159,7 +165,7 @@ toOnionDestination (AnnouncedRoute ni rpath) = OnionToOwner ni rpath | |||
159 | -- structure. | 165 | -- structure. |
160 | -- | 166 | -- |
161 | data AnnouncedKeys = AnnouncedKeys | 167 | data AnnouncedKeys = AnnouncedKeys |
162 | { keyByAge :: !(PSQ NodeId (Down POSIXTime{-Time at which they announced to you-})) -- TODO: timeout of 300 seconds | 168 | { keyByAge :: !(PSQ NodeId (POSIXTime{-Time at which they announced to you-})) |
163 | , keyAssoc :: !(MinMaxPSQ' NodeId NodeDistance (Int{-count of route usage-},AnnouncedRoute)) | 169 | , keyAssoc :: !(MinMaxPSQ' NodeId NodeDistance (Int{-count of route usage-},AnnouncedRoute)) |
164 | -- ^ PSQ using NodeId(user/public key) as Key | 170 | -- ^ PSQ using NodeId(user/public key) as Key |
165 | -- and using 'NodeDistance' as priority. | 171 | -- and using 'NodeDistance' as priority. |
@@ -172,12 +178,33 @@ data AnnouncedKeys = AnnouncedKeys | |||
172 | 178 | ||
173 | insertKey :: POSIXTime -> NodeId -> AnnouncedRoute -> NodeDistance -> AnnouncedKeys -> AnnouncedKeys | 179 | insertKey :: POSIXTime -> NodeId -> AnnouncedRoute -> NodeDistance -> AnnouncedKeys -> AnnouncedKeys |
174 | insertKey tm pub toxpath d keydb = AnnouncedKeys | 180 | insertKey tm pub toxpath d keydb = AnnouncedKeys |
175 | { keyByAge = PSQ.insert pub (Down tm) (keyByAge keydb) | 181 | { keyByAge = PSQ.insert pub tm (keyByAge keydb) |
176 | , keyAssoc = case MinMaxPSQ.lookup' pub (keyAssoc keydb) of | 182 | , keyAssoc = case MinMaxPSQ.lookup' pub (keyAssoc keydb) of |
177 | Just (_,(cnt,_)) -> MinMaxPSQ.insert' pub (cnt,toxpath) d (keyAssoc keydb) | 183 | Just (_,(cnt,_)) -> MinMaxPSQ.insert' pub (cnt,toxpath) d (keyAssoc keydb) |
178 | Nothing -> MinMaxPSQ.insert' pub (0 ,toxpath) d (keyAssoc keydb) | 184 | Nothing -> MinMaxPSQ.insert' pub (0 ,toxpath) d (keyAssoc keydb) |
179 | } | 185 | } |
180 | 186 | ||
187 | -- | Forks a thread to garbage-collect old key announcements. Keys may be | ||
188 | -- discarded after 5 minutes. | ||
189 | forkAnnouncedKeysGC :: TVar AnnouncedKeys -> IO ThreadId | ||
190 | forkAnnouncedKeysGC db = forkIO $ do | ||
191 | myThreadId >>= flip labelThread "gc:toxids" | ||
192 | fix $ \loop -> do | ||
193 | cutoff <- getPOSIXTime | ||
194 | threadDelay 300000000 -- 300 seconds | ||
195 | join $ atomically $ do | ||
196 | fix $ \gc -> do | ||
197 | keys <- readTVar db | ||
198 | case PSQ.minView (keyByAge keys) of | ||
199 | Nothing -> return loop | ||
200 | Just (pub :-> tm,kba') | ||
201 | | tm > cutoff -> return loop | ||
202 | | otherwise -> do writeTVar db keys | ||
203 | { keyByAge = kba' | ||
204 | , keyAssoc = MinMaxPSQ.delete pub (keyAssoc keys) | ||
205 | } | ||
206 | gc | ||
207 | |||
181 | areq :: Message -> Either String AnnounceRequest | 208 | areq :: Message -> Either String AnnounceRequest |
182 | areq (OnionAnnounce asymm) = Right $ fst $ runIdentity $ asymmData asymm | 209 | areq (OnionAnnounce asymm) = Right $ fst $ runIdentity $ asymmData asymm |
183 | areq _ = Left "Unexpected non-announce OnionMessage" | 210 | areq _ = Left "Unexpected non-announce OnionMessage" |
@@ -9,10 +9,6 @@ ui: better error message for a +dhtkey without any selected key. | |||
9 | 9 | ||
10 | tox: tcp relay | 10 | tox: tcp relay |
11 | 11 | ||
12 | bug: local IPv6 addresses are occurring in the IPv4 tox routing table. | ||
13 | |||
14 | xmpp: xmpp-added roster keys are not in TransportCrypto and unusable from TOx.Crypto.Handlers. | ||
15 | |||
16 | xmpp: handle tox-friends in roster. | 12 | xmpp: handle tox-friends in roster. |
17 | 13 | ||
18 | tox: Add fallback trials to cookie response in case response is from another address than request. | 14 | tox: Add fallback trials to cookie response in case response is from another address than request. |
@@ -43,8 +39,6 @@ tox: nat ping | |||
43 | 39 | ||
44 | tox: cache diffie-helman secrets | 40 | tox: cache diffie-helman secrets |
45 | 41 | ||
46 | tox: Expire ofline Tox announces. | ||
47 | |||
48 | tox: Chat support. | 42 | tox: Chat support. |
49 | 43 | ||
50 | bt: Collect PeerStore garbage: "Note that you should call .put() every hour for | 44 | bt: Collect PeerStore garbage: "Note that you should call .put() every hour for |