Merge branch 'dht-presence' of blackbird:bittorrent

5 files changed, 58 insertions, 16 deletions

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
 import Data.Monoid
 import Data.Serialize                 (Serialize)
 import Data.Time.Clock.POSIX          (POSIXTime)
-import qualified Data.Wrapper.PSQInt  as Int
-         ;import Data.Wrapper.PSQInt  (pattern (:->))
 import Network.Address                (bucketRange,genBucketSample)
 import Network.Kademlia.Search
 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
 import Control.Exception hiding (Handler)
 import Control.Applicative
 import Control.Arrow
-import Control.Concurrent                     (MVar)
+import Control.Concurrent                     (MVar,killThread)
 import Control.Concurrent.STM
 import Control.Monad
 import Control.Monad.Fix
@@ -485,18 +485,19 @@ forkTox tox = do
     quit <- forkListener "toxCrypto" (toxCrypto tox)
     forkPollForRefresh (DHT.refresher4 $ toxRouting tox)
     forkPollForRefresh (DHT.refresher6 $ toxRouting tox)
-    return ( quit
+    keygc <- Onion.forkAnnouncedKeysGC (toxAnnouncedKeys tox)
+    return ( killThread keygc >> quit
            , bootstrap (DHT.refresher4 $ toxRouting tox)
            , bootstrap (DHT.refresher6 $ toxRouting tox)
            )
 
--- TODO: Don't export this.
+-- TODO: Don't export this.  The exported interface is 'toxAnnounceToLan'.
 announceToLan :: Socket -> NodeId -> IO ()
 announceToLan sock nid = do
     addrs <- broadcastAddrs
     forM_ addrs $ \addr -> do
     (broadcast_info:_) <- getAddrInfo (Just defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Datagram })
-                                      (Just addr) -- TODO: Detect broadcast address.
+                                      (Just addr)
                                       (Just "33445")
     let broadcast = addrAddress broadcast_info
         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 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE CPP #-}
 module Network.Tox.Crypto.Handlers where
 
 import Network.Tox.NodeId
@@ -40,8 +41,12 @@ import System.IO.Temp
 import System.Environment
 import System.Directory
 import System.Random -- for ping fuzz
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
 import Control.Concurrent
 import GHC.Conc (labelThread)
+#endif
 import PingMachine
 import qualified Data.IntMap.Strict as IntMap
 import Control.Concurrent.Supply
@@ -719,8 +724,8 @@ updateCryptoSession sessions addr newsession timestamp hp session handshake = do
           dmsg ("   ncTheirDHTKey=" ++ show (ncTheirDHTKey session)
                          ++ bool "{/=}" "{==}" (ncTheirDHTKey session == HaveDHTKey (hpCookieRemoteDhtkey hp))
                          ++ "hpCookieRemoteDhtkey=" ++ show (hpCookieRemoteDhtkey hp))
-          if (  -- Just ncTheirBaseNonce0 /= hpTheirBaseNonce hp -- XXX: Do we really want to compare base nonce here?
-                -- ||
+          if (  toMaybe ncTheirBaseNonce0 /= hpTheirBaseNonce hp
+                ||
                ncTheirDHTKey session /= HaveDHTKey (hpCookieRemoteDhtkey hp)
              )
             then freshCryptoSession sessions addr newsession timestamp hp
@@ -1042,10 +1047,16 @@ sendCrypto crypto session updateLocal cm = do
             PQ.OGEncodeFail -> return (Left "Failed to encode outgoing packet")
 
 sendOnline :: TransportCrypto -> NetCryptoSession -> IO (Either String ())
-sendOnline crypto session = sendCrypto crypto session (return ()) (OneByte ONLINE)
+sendOnline crypto session = do
+    let cm=OneByte ONLINE
+    addMsgToLastN False (cm ^. messageType) session (Out cm)
+    sendCrypto crypto session (return ()) (OneByte ONLINE)
 
 sendOffline :: TransportCrypto -> NetCryptoSession -> IO (Either String ())
-sendOffline crypto session = sendCrypto crypto session (return ()) (OneByte OFFLINE)
+sendOffline crypto session = do
+    let cm=OneByte OFFLINE
+    addMsgToLastN False (cm ^. messageType) session (Out cm)
+    sendCrypto crypto session (return ()) (OneByte OFFLINE)
 
 
 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
                 _               -> Left "Hostname should be 43 base64 digits followed by .tox."
     pub <- id2key <$> readEither base64
     let ustr = Text.unpack u
-    '$' : b64digits <- Right ustr -- TODO: support 0x prefix also.
-    NoSpam nospam (Just x) <- readEither $ map (\case; '?' -> '0'; c -> c) ustr
+    case ustr of
+        '$' : b64digits       -> solveBase64NoSpamID b64digits pub
+        '0' : 'x' : hexdigits -> do nospam <- readEither ('0':'x':hexdigits)
+                                    return $ NoSpamId nospam pub
+
+solveBase64NoSpamID :: String -> PublicKey -> Either String NoSpamId
+solveBase64NoSpamID b64digits pub = do
+    NoSpam nospam (Just x) <- readEither $ '$' : map (\case; '?' -> '0'; c -> c) b64digits
     let nlo = fromIntegral (0x0FFFF .&. nospam) :: Word16
         nhi = fromIntegral (0x0FFFF .&. (nospam `shiftR` 16)) :: Word16
         sum = x `xor` nlo `xor` nhi `xor` xorsum pub
@@ -583,7 +589,6 @@ parseNoSpamJID jid = do
             let bitpos = q * 6 + p * 2
                 ac' = ac `xor` shiftR (fromIntegral b `shiftL` 48) bitpos
             solve ns ac'
-
     n64' <- solve ns n64
     let nospam' = fromIntegral (n64' `shiftR` 32)
         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)
 import qualified Network.QueryResponse as QR (Client)
 import Crypto.Tox
 import qualified Data.Wrapper.PSQ             as PSQ
-         ;import Data.Wrapper.PSQ             (PSQ)
+         ;import Data.Wrapper.PSQ             (PSQ,pattern (:->))
 #ifdef CRYPTONITE_BACKPORT
 import Crypto.Error.Types                     (CryptoFailable (..),
                                                throwCryptoError)
@@ -35,6 +35,12 @@ import Network.BitTorrent.DHT.Token           as Token
 
 import Control.Exception hiding (Handler)
 import Control.Monad
+#ifdef THREAD_DEBUG
+import Control.Concurrent.Lifted.Instrument
+#else
+import Control.Concurrent
+import GHC.Conc (labelThread)
+#endif
 import Control.Concurrent.STM
 import Data.Time.Clock.POSIX  (POSIXTime, getPOSIXTime)
 import Network.Socket
@@ -159,7 +165,7 @@ toOnionDestination (AnnouncedRoute ni rpath) = OnionToOwner ni rpath
 -- structure.
 --
 data AnnouncedKeys = AnnouncedKeys
-    { keyByAge :: !(PSQ NodeId (Down POSIXTime{-Time at which they announced to you-})) -- TODO: timeout of 300 seconds
+    { keyByAge :: !(PSQ NodeId (POSIXTime{-Time at which they announced to you-}))
     , keyAssoc :: !(MinMaxPSQ' NodeId NodeDistance (Int{-count of route usage-},AnnouncedRoute))
         -- ^ PSQ using NodeId(user/public key) as Key
         --   and using 'NodeDistance' as priority.
@@ -172,12 +178,33 @@ data AnnouncedKeys = AnnouncedKeys
 
 insertKey :: POSIXTime -> NodeId -> AnnouncedRoute -> NodeDistance -> AnnouncedKeys -> AnnouncedKeys
 insertKey tm pub toxpath d keydb = AnnouncedKeys
-    { keyByAge = PSQ.insert pub (Down tm) (keyByAge keydb)
+    { keyByAge = PSQ.insert pub tm (keyByAge keydb)
     , keyAssoc = case MinMaxPSQ.lookup' pub (keyAssoc keydb) of
                     Just (_,(cnt,_)) -> MinMaxPSQ.insert' pub (cnt,toxpath) d (keyAssoc keydb)
                     Nothing          -> MinMaxPSQ.insert' pub (0  ,toxpath) d (keyAssoc keydb)
     }
 
+-- | Forks a thread to garbage-collect old key announcements.  Keys may be
+-- discarded after 5 minutes.
+forkAnnouncedKeysGC :: TVar AnnouncedKeys -> IO ThreadId
+forkAnnouncedKeysGC db = forkIO $ do
+    myThreadId >>= flip labelThread "gc:toxids"
+    fix $ \loop -> do
+    cutoff <- getPOSIXTime
+    threadDelay 300000000 -- 300 seconds
+    join $ atomically $ do
+        fix $ \gc -> do
+        keys <- readTVar db
+        case PSQ.minView (keyByAge keys) of
+            Nothing -> return loop
+            Just (pub :-> tm,kba')
+                | tm > cutoff -> return loop
+                | otherwise   -> do writeTVar db keys
+                                        { keyByAge = kba'
+                                        , keyAssoc = MinMaxPSQ.delete pub (keyAssoc keys)
+                                        }
+                                    gc
+
 areq :: Message -> Either String AnnounceRequest
 areq (OnionAnnounce asymm) = Right $ fst $ runIdentity $ asymmData asymm
 areq _                     = Left "Unexpected non-announce OnionMessage"