From e595ba7d94324b8a9b14e3a43560113908e09337 Mon Sep 17 00:00:00 2001 From: James Crayne Date: Fri, 8 Jun 2018 04:08:46 +0000 Subject: use Control.Concurrent.Lifted.Instrument so threads are listed --- src/Network/Tox/Crypto/Handlers.hs | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'src/Network') diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs index 5316acc8..e79b66fc 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 -- cgit v1.2.3 From e6e9799e4bed42daac27739d2cf2ae77414fb3b5 Mon Sep 17 00:00:00 2001 From: joe Date: Fri, 8 Jun 2018 18:09:26 -0400 Subject: Accept hexadecimal nospam in jabber-id format. --- src/Network/Tox/NodeId.hs | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) (limited to 'src/Network') 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) -- cgit v1.2.3 From f02276f5240cf985ec3c4c3eaa5d1f5bc3daf4e6 Mon Sep 17 00:00:00 2001 From: James Crayne Date: Fri, 8 Jun 2018 10:00:14 +0000 Subject: add ONLINE&OFFLINE messages to last 10 message buffer --- src/Network/Tox/Crypto/Handlers.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) (limited to 'src/Network') diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs index e79b66fc..f59809fd 100644 --- a/src/Network/Tox/Crypto/Handlers.hs +++ b/src/Network/Tox/Crypto/Handlers.hs @@ -1047,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 ()) -- cgit v1.2.3 From cb6bf999a6a2fcafa5ebfa4a26a5154d04bbe8d7 Mon Sep 17 00:00:00 2001 From: joe Date: Sat, 9 Jun 2018 00:31:09 -0400 Subject: Updated error messages referring to non-extant functions. --- src/Crypto/Tox.hs | 4 ++-- src/Network/Tox.hs | 4 ++-- todo.txt | 4 ---- 3 files changed, 4 insertions(+), 8 deletions(-) (limited to 'src/Network') 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 let (ds, symm') = Symmetric.decrypt bs'' symm auth = Symmetric.finalize symm' if BA.convert auth /= mac - then Left "symmetricDecipher: Auth fail." + then Left "Symmetric decryption failed. Incorrect key material?" else return $ Plain ds encryptSymmetric :: SymmetricKey -> Nonce24 -> Plain s x -> Encrypted x @@ -237,7 +237,7 @@ data State = State Poly1305.State XSalsa.State decrypt :: State -> Encrypted a -> Either String (Plain s a) decrypt (State hash crypt) ciphertext | (a == mac) = Right (Plain m) - | otherwise = Left "decipherAndAuth: auth fail" + | otherwise = Left "Asymmetric decryption failed. Incorrect key material?" where (mac, c) = authAndBytes ciphertext m = fst . XSalsa.combine crypt $ c diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs index 5bd23da8..634b0db1 100644 --- a/src/Network/Tox.hs +++ b/src/Network/Tox.hs @@ -490,13 +490,13 @@ forkTox tox = do , 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/todo.txt b/todo.txt index 645197d5..5483efbb 100644 --- a/todo.txt +++ b/todo.txt @@ -9,10 +9,6 @@ ui: better error message for a +dhtkey without any selected key. tox: tcp relay -bug: local IPv6 addresses are occurring in the IPv4 tox routing table. - -xmpp: xmpp-added roster keys are not in TransportCrypto and unusable from TOx.Crypto.Handlers. - xmpp: handle tox-friends in roster. tox: Add fallback trials to cookie response in case response is from another address than request. -- cgit v1.2.3 From fa15dabe75703516c7bbb54fdba2a13ae6c6e9cc Mon Sep 17 00:00:00 2001 From: James Crayne Date: Fri, 8 Jun 2018 11:31:11 +0000 Subject: check basenonce matches on handshake --- src/Network/Tox/Crypto/Handlers.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src/Network') diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs index f59809fd..e22388a3 100644 --- a/src/Network/Tox/Crypto/Handlers.hs +++ b/src/Network/Tox/Crypto/Handlers.hs @@ -724,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 -- cgit v1.2.3 From fb0c6758ec415c5cda5cc7c182e1f83906f365fb Mon Sep 17 00:00:00 2001 From: joe Date: Sat, 9 Jun 2018 01:31:23 -0400 Subject: Expire old tox key announcements after 5 minutes. --- examples/dhtd.hs | 2 +- src/Network/Kademlia.hs | 2 -- src/Network/Tox.hs | 5 +++-- src/Network/Tox/Onion/Handlers.hs | 33 ++++++++++++++++++++++++++++++--- todo.txt | 2 -- 5 files changed, 34 insertions(+), 10 deletions(-) (limited to 'src/Network') diff --git a/examples/dhtd.hs b/examples/dhtd.hs index b845f9df..369650f9 100644 --- a/examples/dhtd.hs +++ b/examples/dhtd.hs @@ -1165,7 +1165,7 @@ clientSession s@Session{..} sock cnum h = do keydb <- atomically $ readTVar toxkeys now <- getPOSIXTime let entries = map mkentry $ PSQ.toList (Tox.keyByAge keydb) - mkentry (k :-> Down tm) = [ show cnt, show k, show (now - tm) ] + mkentry (k :-> tm) = [ show cnt, show k, show (now - tm) ] where Just (_,(cnt,_)) = MM.lookup' k (Tox.keyAssoc keydb) hPutClient h $ showColumns entries 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 634b0db1..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,7 +485,8 @@ 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) ) 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" diff --git a/todo.txt b/todo.txt index 5483efbb..d4b2d828 100644 --- a/todo.txt +++ b/todo.txt @@ -39,8 +39,6 @@ tox: nat ping tox: cache diffie-helman secrets -tox: Expire ofline Tox announces. - tox: Chat support. bt: Collect PeerStore garbage: "Note that you should call .put() every hour for -- cgit v1.2.3