From 39761dea4e24eb942e4cefbc70b8c8c3d90cf571 Mon Sep 17 00:00:00 2001 From: James Crayne Date: Wed, 30 May 2018 22:56:03 +0000 Subject: This patch: * integrates Connection.Tox and Network.Tox.Crypto.Handlers * Network.Tox.netCrypto function uses freshCryptoSession --- Connection/Tox.hs | 6 ++--- dht-client.cabal | 2 ++ src/Network/Tox.hs | 54 ++++++++++++++++++++------------------ src/Network/Tox/Crypto/Handlers.hs | 30 ++++++++++++++------- 4 files changed, 53 insertions(+), 39 deletions(-) diff --git a/Connection/Tox.hs b/Connection/Tox.hs index 00d15aa7..1d133628 100644 --- a/Connection/Tox.hs +++ b/Connection/Tox.hs @@ -9,7 +9,7 @@ import Data.Dependent.Sum import Data.Functor.Identity import qualified Data.Map as Map -- import Data.Maybe -import Network.Tox +-- import Network.Tox import Network.Tox.NodeId import PingMachine import Text.Read @@ -80,10 +80,10 @@ data ToxProgress data Parameters = Parameters { -- | Various Tox transports and clients. - toxTransports :: Tox + -- toxTransports :: Tox -- | Thread to be forked when a connection is established. -- TODO: this function should accept relevant parameters. - , onToxSession :: IO () + onToxSession :: IO () } data Key = Key NodeId{-me-} NodeId{-them-} diff --git a/dht-client.cabal b/dht-client.cabal index 18de7a62..496c0f5a 100644 --- a/dht-client.cabal +++ b/dht-client.cabal @@ -127,6 +127,7 @@ library Paths PeerResolve Connection.Tcp + Connection.Tox SockAddr TraversableT UTmp @@ -139,6 +140,7 @@ library build-depends: base , containers + , dependent-sum , array , hashable , iproute diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs index 018361aa..9d785f67 100644 --- a/src/Network/Tox.hs +++ b/src/Network/Tox.hs @@ -258,6 +258,7 @@ netCrypto tox myseckey theirpubkey = netCryptoWithBackoff 1000000 tox myseckey t netCryptoWithBackoff :: Int -> Tox -> SecretKey -> PublicKey -> IO [NetCryptoSession] netCryptoWithBackoff millisecs tox myseckey theirpubkey = do let mykeyAsId = key2id (toPublic myseckey) + -- TODO: check status of connection here: mbContactsVar <- fmap contacts . HashMap.lookup mykeyAsId <$> atomically (readTVar (accounts (toxContactInfo tox))) case mbContactsVar of Nothing -> do @@ -321,32 +322,33 @@ netCryptoWithBackoff millisecs tox myseckey theirpubkey = do , hpTheirBaseNonce = error "netCrypto: Unreachable! hpTheirBaseNonce" , hpTheirSessionKeyPublic = error "netCrypto: Unreachable! hpTheirSessionKeyPublic" } - myhandshake <- do - n24' <- atomically $ transportNewNonce crypto - dput XNetCrypto ("Handshake Nonce24: " <> show n24') - newBaseNonce <- atomically $ transportNewNonce crypto - mbMyhandshakeData <- newHandShakeData crypto newBaseNonce hp saddr - forM mbMyhandshakeData $ \hsdata -> do - state <- lookupSharedSecret crypto myseckey theirpubkey n24' - return Handshake { handshakeCookie = cookie - , handshakeNonce = n24' - , handshakeData = encrypt state $ encodePlain hsdata - } - case myhandshake of - Nothing -> hPutStrLn stderr "netCrypto: failed to create HandshakeData." >> return [] - Just handshake -> do - sendMessage (toxCrypto tox) saddr (NetHandshake handshake) - let secnum :: Double - secnum = fromIntegral millisecs / 1000000 - delay = (millisecs * 5 `div` 4) - if secnum < 20000000 - then do - hPutStrLn stderr $ "sent handshake, now delaying " ++ show (secnum * 1.25) ++ " second(s).." - threadDelay delay - netCryptoWithBackoff delay tox myseckey theirpubkey -- hopefully it will find an active session this time. - else do - hPutStrLn stderr "Unable to establish session..." - return [] + freshCryptoSession (toxCryptoSessions tox) saddr hp +-- myhandshake <- do +-- n24' <- atomically $ transportNewNonce crypto +-- dput XNetCrypto ("Handshake Nonce24: " <> show n24') +-- newBaseNonce <- atomically $ transportNewNonce crypto +-- mbMyhandshakeData <- newHandShakeData crypto newBaseNonce hp saddr +-- forM mbMyhandshakeData $ \hsdata -> do +-- state <- lookupSharedSecret crypto myseckey theirpubkey n24' +-- return Handshake { handshakeCookie = cookie +-- , handshakeNonce = n24' +-- , handshakeData = encrypt state $ encodePlain hsdata +-- } +-- case myhandshake of +-- Nothing -> hPutStrLn stderr "netCrypto: failed to create HandshakeData." >> return [] +-- Just handshake -> do +-- sendMessage (toxCrypto tox) saddr (NetHandshake handshake) + let secnum :: Double + secnum = fromIntegral millisecs / 1000000 + delay = (millisecs * 5 `div` 4) + if secnum < 20000000 + then do + hPutStrLn stderr $ "sent handshake, now delaying " ++ show (secnum * 1.25) ++ " second(s).." + threadDelay delay + netCryptoWithBackoff delay tox myseckey theirpubkey -- hopefully it will find an active session this time. + else do + hPutStrLn stderr "Unable to establish session..." + return [] getContactInfo :: Tox -> IO DHT.DHTPublicKey getContactInfo Tox{toxCryptoKeys,toxRouting} = join $ atomically $ do diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs index bcca65e6..dcae9f2f 100644 --- a/src/Network/Tox/Crypto/Handlers.hs +++ b/src/Network/Tox/Crypto/Handlers.hs @@ -50,6 +50,8 @@ import DPut import Debug.Trace import Text.Printf import Data.Bool +import Connection (Status(..)) +import Connection.Tox (ToxProgress(..)) -- * These types are isomorphic to Maybe, but have the advantage of documenting @@ -99,8 +101,8 @@ instance AsMaybe UponCryptoPacket where frmMaybe (Just x) = HaveCryptoPacket x -data NetCryptoSessionStatus = Unaccepted | Accepted {- InProgress AwaitingSessionPacket -} | Confirmed {- Established -} - deriving (Eq,Ord,Show,Enum) +--data NetCryptoSessionStatus = Unaccepted | Accepted {- InProgress AwaitingSessionPacket -} | Confirmed {- Established -} +-- deriving (Eq,Ord,Show,Enum) -- | The idea of IOHook is to replicate the familiar pattern @@ -214,7 +216,7 @@ type SessionID = Word64 type ListenerType = Word64 data NetCryptoSession = NCrypto - { ncState :: TVar NetCryptoSessionStatus + { ncState :: TVar (Status ToxProgress) , ncMyPublicKey :: PublicKey , ncSessionId :: SessionID , ncTheirPublicKey :: PublicKey -- Tox id w/o nospam @@ -503,7 +505,10 @@ freshCryptoSession sessions x <- readTVar (nextSessionId sessions) modifyTVar (nextSessionId sessions) (+1) return x - ncState0 <- atomically $ newTVar Accepted -- (InProgress AwaitingSessionPacket) + -- ncState0 <- atomically $ newTVar Accepted -- (InProgress AwaitingSessionPacket) + ncState0 <- atomically $ newTVar (if isJust mbtheirBaseNonce + then InProgress AwaitingSessionPacket + else InProgress AwaitingHandshake) ncTheirBaseNonce0 <- atomically $ newTVar (frmMaybe mbtheirBaseNonce) n24 <- atomically $ transportNewNonce crypto state <- lookupSharedSecret crypto key remotePublicKey n24 @@ -551,7 +556,7 @@ freshCryptoSession sessions atomically $ do n24 <- readTVar ncMyPacketNonce0 let n24plus1 = incrementNonce24 n24 - writeTVar ncMyPacketNonce0 n24plus1 + trace ("ncMyPacketNonce+1=" ++ show n24plus1) $ writeTVar ncMyPacketNonce0 n24plus1 return (return (f n24, n24, ncOutgoingIdMap0)) pktoq <- atomically $ PQ.newOutGoing pktq ncToWire toWireIO 0 (outboundQueueCapacity sessions) 0 return (HaveHandshake pktoq) @@ -559,6 +564,8 @@ freshCryptoSession sessions listeners <- atomically $ newTVar IntMap.empty msgNum <- atomically $ newTVar 0 dropNum <- atomically $ newTVar 0 + theirbasenonce <- atomically $ readTVar ncTheirBaseNonce0 + dput XNetCrypto $ "freshCryptoSession: Session ncTheirBaseNonce=" ++ show theirbasenonce let netCryptoSession0 = NCrypto { ncState = ncState0 , ncMyPublicKey = toPublic key @@ -635,8 +642,7 @@ updateCryptoSession :: NetCryptoSessions -> SockAddr -> HandshakeParams -> NetCr updateCryptoSession sessions addr hp session = do ncState0 <- atomically $ readTVar (ncState session) ncTheirBaseNonce0 <- atomically $ readTVar (ncTheirBaseNonce session) - -- if (ncState0 >= InProgress AwaitingSessionPacket) - if (ncState0 >= Accepted) + if (ncState0 >= {-Accepted-}InProgress AwaitingSessionPacket) -- If the nonce in the handshake and the dht key are both the same as -- the ones we have saved, assume we already handled this and this is a -- duplicate handshake packet, otherwise disregard everything, and @@ -661,7 +667,7 @@ updateCryptoSession sessions addr hp session = do ++ "hpTheirBaseNonce=" ++ show (hpTheirBaseNonce hp)) if ( ncTheirBaseNonce0 /= frmMaybe (hpTheirBaseNonce hp)) then freshCryptoSession sessions addr hp -- basenonce mismatch, trigger refresh - else atomically $ writeTVar (ncState session) Accepted -- (InProgress AwaitingSessionPacket) + else atomically $ writeTVar (ncState session) {-Accepted-}(InProgress AwaitingSessionPacket) cryptoNetHandler :: NetCryptoSessions -> SockAddr -> NetCrypto -> IO (Maybe (NetCrypto -> NetCrypto)) @@ -728,6 +734,7 @@ cryptoNetHandler sessions addr (NetHandshake (Handshake (Cookie n24 ecookie) non , hpCookieRemotePubkey = remotePublicKey , hpCookieRemoteDhtkey = remoteDhtPublicKey }) -> do + dput XNetCrypto ("cryptoNetHandler: hpTheirBaseNonce = " ++ show theirBaseNonce) sessionsmap <- atomically $ readTVar allsessions -- Do a lookup, so we can handle the update case differently case Map.lookup addr sessionsmap of @@ -752,7 +759,10 @@ cryptoNetHandler sessions addr (NetCrypto (CryptoPacket nonce16 encrypted)) = do Just session@(NCrypto { ncIncomingTypeArray, ncState, ncPacketQueue, ncHooks, ncSessionSecret, ncTheirSessionPublic, ncTheirBaseNonce, ncPingMachine}) -> do - HaveHandshake theirBaseNonce <- atomically $ readTVar ncTheirBaseNonce + mbTheirBaseNonce <- atomically $ readTVar ncTheirBaseNonce + case mbTheirBaseNonce of + NeedHandshake -> dput XNetCrypto "CryptoPacket recieved, but we still dont have their base nonce?" >> return Nothing + HaveHandshake theirBaseNonce -> do -- Try to decrypt message let diff :: Word16 diff = nonce16 - (last2Bytes theirBaseNonce) -- truncating to Word16 @@ -796,7 +806,7 @@ cryptoNetHandler sessions addr (NetCrypto (CryptoPacket nonce16 encrypted)) = do ++ " = " ++ show x) (return ()) writeTVar ncTheirBaseNonce (HaveHandshake y) -- then set session confirmed, - atomically $ writeTVar ncState Confirmed {-Established-} + atomically $ writeTVar ncState {-Confirmed-}Established -- bump ping machine case ncPingMachine of Just pingMachine -> pingBump pingMachine -- cgit v1.2.3