From 8039d812b7ea8ae566f8873452ac34597336ddfc Mon Sep 17 00:00:00 2001 From: joe Date: Sun, 5 Nov 2017 01:25:36 -0500 Subject: Adapted computeSharedSecret to a side-effecting interface. This is to ready the tree for a memoizing cache of shared secrets. --- src/Network/Tox.hs | 2 +- src/Network/Tox/Crypto/Handlers.hs | 21 +++-- src/Network/Tox/DHT/Transport.hs | 37 ++++---- src/Network/Tox/Onion/Transport.hs | 178 +++++++++++++++++++++---------------- src/Network/Tox/Transport.hs | 2 +- 5 files changed, 138 insertions(+), 102 deletions(-) (limited to 'src/Network') diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs index 7179e3c2..40d17a07 100644 --- a/src/Network/Tox.hs +++ b/src/Network/Tox.hs @@ -310,7 +310,7 @@ newTox keydb addr mbSessionsState suppliedDHTKey = do let ignoreErrors _ = return () -- Set this to (hPutStrLn stderr) to debug onion route building. orouter <- newOnionRouter ignoreErrors (dhtcrypt,onioncrypt,dtacrypt,cryptonet) <- toxTransport crypto orouter lookupClose udp - let dhtnet0 = layerTransport (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt + let dhtnet0 = layerTransportM (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr routing) (DHT.handlers crypto routing) id $ \client net -> onInbound (DHT.updateRouting client routing orouter) net diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs index b8e99d2d..ac3d1ef0 100644 --- a/src/Network/Tox/Crypto/Handlers.hs +++ b/src/Network/Tox/Crypto/Handlers.hs @@ -94,9 +94,9 @@ freshCryptoSession sessions ncState0 <- atomically $ newTVar Accepted ncTheirBaseNonce0 <- atomically $ newTVar theirBaseNonce n24 <- atomically $ transportNewNonce crypto + state <- lookupSharedSecret crypto key remoteDhtPublicKey n24 let myhandshakeData = newHandShakeData crypto hp plain = encodePlain myhandshakeData - state = computeSharedSecret key remoteDhtPublicKey n24 encrypted = encrypt state plain myhandshake = Handshake { handshakeCookie = otherCookie , handshakeNonce = n24 @@ -150,14 +150,19 @@ cryptoNetHandler sessions addr (NetHandshake (Handshake (Cookie n24 ecookie) non -- Handle Handshake Message let crypto = transportCrypto sessions allsessions = netCryptoSessions sessions - anyRight xs f = foldr1 (<|>) $ map f xs + anyRight [] f = return $ Left "missing key" + anyRight (x:xs) f = f x >>= either (const $ anyRight xs f) (return . Right) seckeys <- map fst <$> atomically (readTVar (userKeys crypto)) symkey <- atomically $ transportSymmetric crypto now <- getPOSIXTime - let lr = do -- Either Monad + lr <- fmap join . sequence $ do -- Either Monad (CookieData cookieTime remotePubkey remoteDhtkey) <- (decodePlain =<< decryptSymmetric symkey n24 ecookie) - (key,HandshakeData { baseNonce, sessionKey, cookieHash, otherCookie }) - <- anyRight seckeys $ \key -> (key,) <$> (decodePlain =<< decrypt (computeSharedSecret key remotePubkey nonce24) encrypted) + Right $ do -- IO Monad + decrypted <- anyRight seckeys $ \key -> do + secret <- lookupSharedSecret crypto key remotePubkey nonce24 + return $ (key,) <$> (decodePlain =<< decrypt secret encrypted) + return $ do -- Either Monad + (key,HandshakeData { baseNonce, sessionKey, cookieHash, otherCookie }) <- decrypted -- check cookie time < 15 seconds ago guard (now - fromIntegral cookieTime < 15) -- cookie hash is valid? sha512 of ecookie @@ -208,9 +213,11 @@ cryptoNetHandler sessions addr (NetCrypto (CryptoPacket nonce16 encrypted)) = do let diff :: Word16 diff = nonce16 - fromIntegral (last2Bytes theirBaseNonce) -- truncating to Word16 tempNonce <- addtoNonce24 theirBaseNonce (fromIntegral diff) -- expanding to Word - let lr = do -- Either Monad -- + lr <- fmap join $ sequence $ do -- Either Monad -- pubkey <- maybeToEither ncTheirSessionPublic - decodePlain =<< decrypt (computeSharedSecret ncSessionSecret pubkey tempNonce) encrypted + Right $ do -- IO Monad + secret <- lookupSharedSecret crypto ncSessionSecret pubkey tempNonce + return $ decodePlain =<< decrypt secret encrypted case lr of Left _ -> return Nothing -- decryption failed, ignore packet Right cd@(CryptoData {bufferStart, bufferEnd, bufferData=cm}) -> do -- decryption succeeded, diff --git a/src/Network/Tox/DHT/Transport.hs b/src/Network/Tox/DHT/Transport.hs index 736e84d1..bd108276 100644 --- a/src/Network/Tox/DHT/Transport.hs +++ b/src/Network/Tox/DHT/Transport.hs @@ -426,34 +426,37 @@ forwardDHTRequests crypto closeLookup dht = dht { awaitMessage = await' } await' pass m -> pass m -encrypt :: TransportCrypto -> DHTMessage ((,) Nonce8) -> NodeInfo -> (DHTMessage Encrypted8, NodeInfo) -encrypt crypto msg ni = ( transcode (encryptMessage crypto (id2key $ nodeId ni)) msg - , ni ) +encrypt :: TransportCrypto -> DHTMessage ((,) Nonce8) -> NodeInfo -> IO (DHTMessage Encrypted8, NodeInfo) +encrypt crypto msg ni = do + let cipher n plain = Composed $ encryptMessage crypto (id2key $ nodeId ni) n plain + m <- sequenceMessage $ transcode cipher msg + return (m, ni) encryptMessage :: Serialize a => TransportCrypto -> PublicKey -> - Nonce24 -> Either (Nonce8,a) (Asymm (Nonce8,a)) -> Encrypted8 a -encryptMessage crypto destKey n arg = E8 $ ToxCrypto.encrypt secret plain - where - secret = computeSharedSecret (transportSecret crypto) destKey n - plain = encodePlain $ swap $ either id asymmData arg + Nonce24 -> Either (Nonce8,a) (Asymm (Nonce8,a)) -> IO (Encrypted8 a) +encryptMessage crypto destKey n arg = do + let plain = encodePlain $ swap $ either id asymmData arg + secret <- lookupSharedSecret crypto (transportSecret crypto) destKey n + return $ E8 $ ToxCrypto.encrypt secret plain -decrypt :: TransportCrypto -> DHTMessage Encrypted8 -> NodeInfo -> Either String (DHTMessage ((,) Nonce8), NodeInfo) +decrypt :: TransportCrypto -> DHTMessage Encrypted8 -> NodeInfo -> IO (Either String (DHTMessage ((,) Nonce8), NodeInfo)) decrypt crypto msg ni = do - msg' <- sequenceMessage $ transcode (\n -> decryptMessage crypto n . left ((,) $ id2key $ nodeId ni)) msg - return (msg', ni) + let decipher n c = Composed $ decryptMessage crypto n . left ((,) $ id2key $ nodeId ni) $ c + msg' <- sequenceMessage $ transcode decipher msg + return $ fmap (, ni) $ sequenceMessage msg' decryptMessage :: Serialize x => TransportCrypto -> Nonce24 -> Either (PublicKey, Encrypted8 x) (Asymm (Encrypted8 x)) - -> (Either String ∘ ((,) Nonce8)) x -decryptMessage crypto n arg = plain8 $ ToxCrypto.decrypt secret e - where - secret = computeSharedSecret (transportSecret crypto) remotekey n - (remotekey,E8 e) = either id (senderKey &&& asymmData) arg - plain8 = Composed . fmap swap . (>>= decodePlain) + -> IO ((Either String ∘ ((,) Nonce8)) x) +decryptMessage crypto n arg = do + let (remotekey,E8 e) = either id (senderKey &&& asymmData) arg + plain8 = Composed . fmap swap . (>>= decodePlain) + secret <- lookupSharedSecret crypto (transportSecret crypto) remotekey n + return $ plain8 $ ToxCrypto.decrypt secret e sequenceMessage :: Applicative m => DHTMessage (m ∘ f) -> m (DHTMessage f) sequenceMessage (DHTPing asym) = fmap DHTPing $ sequenceA $ fmap uncomposed asym diff --git a/src/Network/Tox/Onion/Transport.hs b/src/Network/Tox/Onion/Transport.hs index 5b7aad0b..539e7cee 100644 --- a/src/Network/Tox/Onion/Transport.hs +++ b/src/Network/Tox/Onion/Transport.hs @@ -231,19 +231,21 @@ routeId :: NodeId -> RouteId routeId nid = RouteId $ mod (hash nid) 12 -encodeOnionAddr :: (NodeInfo -> RouteId -> IO (Maybe OnionRoute)) +encodeOnionAddr :: TransportCrypto + -> (NodeInfo -> RouteId -> IO (Maybe OnionRoute)) -> (OnionMessage Encrypted,OnionDestination RouteId) -> IO (Maybe (ByteString, SockAddr)) -encodeOnionAddr _ (msg,OnionToOwner ni p) = +encodeOnionAddr crypto _ (msg,OnionToOwner ni p) = return $ Just ( runPut $ putResponse (OnionResponse p msg) , nodeAddr ni ) -encodeOnionAddr getRoute (msg,OnionDestination x ni Nothing) = do - encodeOnionAddr getRoute (msg,OnionDestination x ni (Just $ routeId $ nodeId ni) ) +encodeOnionAddr crypto getRoute (msg,OnionDestination x ni Nothing) = do + encodeOnionAddr crypto getRoute (msg,OnionDestination x ni (Just $ routeId $ nodeId ni) ) -- hPutStrLn stderr $ "ONION encode missing routeid" -- return Nothing -encodeOnionAddr getRoute (msg,OnionDestination _ ni (Just rid)) = do +encodeOnionAddr crypto getRoute (msg,OnionDestination _ ni (Just rid)) = do let go route = do - return ( runPut $ putRequest $ wrapForRoute msg ni route + req <- wrapForRoute crypto msg ni route + return ( runPut $ putRequest req , nodeAddr $ routeNodeA route) mapM' f x = do let _ = x :: Maybe OnionRoute @@ -482,7 +484,8 @@ handleOnionRequest proxy crypto saddr udp kont (OnionRequest nonce msg rpath) = hPutStrLn stderr $ "handleOnionRequest " ++ show n (sym, snonce) <- atomically ( (,) <$> transportSymmetric crypto <*> transportNewNonce crypto ) - case peelOnion crypto nonce msg of + peeled <- peelOnion crypto nonce msg + case peeled of Left e -> do -- todo report encryption error hPutStrLn stderr $ unwords [ "peelOnion:", show n, either show show (either4or6 saddr), e] @@ -505,9 +508,9 @@ peelOnion :: Serialize (Addressed (Forwarding n t)) => TransportCrypto -> Nonce24 -> Forwarding (S n) t - -> Either String (Addressed (Forwarding n t)) -peelOnion crypto nonce (Forwarding k fwd) = - fmap runIdentity $ uncomposed $ decryptMessage (dhtKey crypto) nonce (Right $ Asymm k nonce fwd) + -> IO (Either String (Addressed (Forwarding n t))) +peelOnion crypto nonce (Forwarding k fwd) = do + fmap runIdentity . uncomposed <$> decryptMessage crypto (dhtKey crypto) nonce (Right $ Asymm k nonce fwd) handleOnionResponse :: (KnownPeanoNat n, Sized (ReturnPath n), Serialize (ReturnPath n)) => proxy (S n) -> TransportCrypto -> SockAddr -> UDPTransport -> IO a -> OnionResponse (S n) -> IO a handleOnionResponse proxy crypto saddr udp kont (OnionResponse path msg) = do @@ -662,27 +665,42 @@ selectKey crypto _ rpath@(OnionDestination (AnnouncingAlias skey pkey) _ _) = return (skey, pkey) selectKey crypto msg rpath = return $ aliasKey crypto rpath -encrypt :: TransportCrypto -> OnionMessage Identity -> OnionDestination r -> IO (OnionMessage Encrypted, OnionDestination r) +encrypt :: TransportCrypto + -> OnionMessage Identity + -> OnionDestination r + -> IO (OnionMessage Encrypted, OnionDestination r) encrypt crypto msg rpath = do (skey,pkey) <- selectKey crypto msg rpath -- source key let okey = onionKey rpath -- destination key - return ( transcode ( (. (runIdentity . either id asymmData)) - . encryptMessage skey okey) - msg - , rpath) - -encryptMessage :: Serialize a => - SecretKey -> PublicKey -> Nonce24 -> a -> Encrypted a -encryptMessage skey destKey n a = ToxCrypto.encrypt secret plain - where - secret = computeSharedSecret skey destKey n - plain = encodePlain a + encipher1 :: Serialize a => SecretKey -> PublicKey -> Nonce24 -> a -> (IO ∘ Encrypted) a + encipher1 sk pk n a = Composed $ do + secret <- lookupSharedSecret crypto sk pk n + return $ ToxCrypto.encrypt secret $ encodePlain a + encipher :: Serialize a => Nonce24 -> Either (Identity a) (Asymm (Identity a)) -> (IO ∘ Encrypted) a + encipher n d = encipher1 skey okey n $ either runIdentity (runIdentity . asymmData) d + m <- sequenceMessage $ transcode encipher msg + return (m, rpath) decrypt :: TransportCrypto -> OnionMessage Encrypted -> OnionDestination r -> IO (Either String (OnionMessage Identity, OnionDestination r)) decrypt crypto msg addr = do (skey,pkey) <- selectKey crypto msg addr + let decipher1 :: Serialize a => + TransportCrypto -> SecretKey -> PublicKey -> Nonce24 + -> Either (PublicKey,Encrypted a) (Asymm (Encrypted a)) + -> (IO ∘ Either String ∘ Identity) a + decipher1 crypto k pk n d = Composed $ do + secret <- lookupSharedSecret crypto k pk n + let ciphered = either snd asymmData d + return $ Composed $ do + plain <- ToxCrypto.decrypt secret ciphered + Identity <$> decodePlain plain + decipher :: Serialize a + => Nonce24 -> Either (Encrypted a) (Asymm (Encrypted a)) + -> (IO ∘ Either String ∘ Identity) a + decipher = (\n -> decipher1 crypto skey pkey n . left (senderkey addr)) + foo <- sequenceMessage $ transcode decipher msg return $ do - msg <- sequenceMessage $ transcode (\n -> decryptMessage (skey,pkey) n . left (senderkey addr)) msg + msg <- sequenceMessage foo Right (msg, addr) senderkey :: OnionDestination r -> t -> (PublicKey, t) @@ -696,16 +714,17 @@ dhtKey :: TransportCrypto -> (SecretKey,PublicKey) dhtKey crypto = (transportSecret &&& transportPublic) crypto decryptMessage :: Serialize x => - (SecretKey,PublicKey) + TransportCrypto + -> (SecretKey,PublicKey) -> Nonce24 -> Either (PublicKey, Encrypted x) (Asymm (Encrypted x)) - -> (Either String ∘ Identity) x -decryptMessage crypto n arg = plain $ ToxCrypto.decrypt secret e - where - secret = computeSharedSecret (fst crypto) sender n - (sender,e) = either id (senderKey &&& asymmData) arg - plain = Composed . fmap Identity . (>>= decodePlain) + -> IO ((Either String ∘ Identity) x) +decryptMessage crypto (sk,pk) n arg = do + let (sender,e) = either id (senderKey &&& asymmData) arg + plain = Composed . fmap Identity . (>>= decodePlain) + secret <- lookupSharedSecret crypto sk sender n + return $ plain $ ToxCrypto.decrypt secret e sequenceMessage :: Applicative m => OnionMessage (m ∘ f) -> m (OnionMessage f) @@ -732,37 +751,41 @@ data OnionRoute = OnionRoute , routeNodeC :: NodeInfo } -wrapForRoute :: OnionMessage Encrypted -> NodeInfo -> OnionRoute -> OnionRequest N0 -wrapForRoute msg ni r = +wrapForRoute :: TransportCrypto -> OnionMessage Encrypted -> NodeInfo -> OnionRoute -> IO (OnionRequest N0) +wrapForRoute crypto msg ni r = do -- We needn't use the same nonce value here, but I think it is safe to do so. let nonce = msgNonce msg - in OnionRequest - { onionNonce = nonce - , onionForward = wrapOnion (routeAliasA r) - nonce - (id2key . nodeId $ routeNodeA r) - (nodeAddr $ routeNodeB r) - $ wrapOnion (routeAliasB r) - nonce - (id2key . nodeId $ routeNodeB r) - (nodeAddr $ routeNodeC r) - $ wrapOnion (routeAliasC r) - nonce - (id2key . nodeId $ routeNodeC r) - (nodeAddr ni) - $ NotForwarded msg - , pathFromOwner = NoReturnPath - } + fwd <- wrapOnion crypto (routeAliasA r) + nonce + (id2key . nodeId $ routeNodeA r) + (nodeAddr $ routeNodeB r) + =<< wrapOnion crypto (routeAliasB r) + nonce + (id2key . nodeId $ routeNodeB r) + (nodeAddr $ routeNodeC r) + =<< wrapOnion crypto (routeAliasC r) + nonce + (id2key . nodeId $ routeNodeC r) + (nodeAddr ni) + (NotForwarded msg) + return OnionRequest + { onionNonce = nonce + , onionForward = fwd + , pathFromOwner = NoReturnPath + } wrapOnion :: Serialize (Forwarding n msg) => - SecretKey + TransportCrypto + -> SecretKey -> Nonce24 -> PublicKey -> SockAddr -> Forwarding n msg - -> Forwarding (S n) msg -wrapOnion skey nonce destkey saddr fwd = - Forwarding (toPublic skey) $ encryptMessage skey destkey nonce (Addressed saddr fwd) + -> IO (Forwarding (S n) msg) +wrapOnion crypto skey nonce destkey saddr fwd = do + let plain = encodePlain $ Addressed saddr fwd + secret <- lookupSharedSecret crypto skey destkey nonce + return $ Forwarding (toPublic skey) $ ToxCrypto.encrypt secret plain -- TODO @@ -827,28 +850,29 @@ parseDataToRoute parseDataToRoute crypto (OnionToRouteResponse dta, od) = do ks <- atomically $ readTVar $ userKeys crypto - let eOuter = do - fmap runIdentity - $ uncomposed - $ decryptMessage (rendezvousSecret crypto,rendezvousPublic crypto) - (asymmNonce dta) - (Right dta) -- using Asymm{senderKey} as remote key - - -- TODO: We don't currently have a way to look up which user key we - -- announced using along this onion route. Therefore, for now, we will - -- try all our user keys to see if any can decrypt the packet. - eInners = flip map ks $ \(sk,pk) -> do - dtr <- eOuter - omsg <- fmap runIdentity - $ uncomposed - $ decryptMessage (sk,pk) + omsg0 <- decryptMessage crypto (rendezvousSecret crypto,rendezvousPublic crypto) + (asymmNonce dta) + (Right dta) -- using Asymm{senderKey} as remote key + let eOuter = fmap runIdentity $ uncomposed omsg0 + + anyRight [] f = return $ Left "parseDataToRoute: no user key" + anyRight (x:xs) f = f x >>= either (const $ anyRight xs f) (return . Right) + + -- TODO: We don't currently have a way to look up which user key we + -- announced using along this onion route. Therefore, for now, we will + -- try all our user keys to see if any can decrypt the packet. + eInner <- case eOuter of + Left e -> return $ Left e + Right dtr -> anyRight ks $ \(sk,pk) -> do + omsg0 <- decryptMessage crypto + (sk,pk) (asymmNonce dta) (Left (dataFromKey dtr, dataToRoute dtr)) - return (pk,dtr,omsg) - - eInner = foldr (<|>) (Left "no user key") eInners + return $ do + omsg <- fmap runIdentity . uncomposed $ omsg0 + Right (pk,dtr,omsg) - e = do + let e = do (pk,dtr,omsg) <- eInner return ( (pk, omsg) , AnnouncedRendezvous @@ -875,10 +899,12 @@ encodeDataToRoute crypto ((me,omsg), AnnouncedRendezvous toxid (Rendezvous pub n let (sk,pk) = case asel of AnnouncingAlias sk pk -> (sk,pk) _ -> (onionAliasSecret crypto, onionAliasPublic crypto) - let plain = DataToRoute { dataFromKey = pk - , dataToRoute = encryptMessage sk toxid nonce omsg - } - let dta = encryptMessage (onionAliasSecret crypto) pub nonce plain + innerSecret <- lookupSharedSecret crypto sk toxid nonce + let plain = encodePlain $ DataToRoute { dataFromKey = pk + , dataToRoute = ToxCrypto.encrypt innerSecret $ encodePlain omsg + } + outerSecret <- lookupSharedSecret crypto (onionAliasSecret crypto) pub nonce + let dta = ToxCrypto.encrypt outerSecret plain hPutStrLn stderr $ unlines [ "encodeDataToRoute me=" ++ show (key2id me) , " dhtpk=" ++ case omsg of diff --git a/src/Network/Tox/Transport.hs b/src/Network/Tox/Transport.hs index 01928e56..30df93c8 100644 --- a/src/Network/Tox/Transport.hs +++ b/src/Network/Tox/Transport.hs @@ -29,7 +29,7 @@ toxTransport :: toxTransport crypto orouter closeLookup udp = do (dht,udp1) <- partitionTransportM (parseDHTAddr crypto) (fmap Just . encodeDHTAddr) $ forwardOnions crypto udp (onion1,udp2) <- partitionTransportM (parseOnionAddr $ lookupSender orouter) - (encodeOnionAddr $ lookupRoute orouter) + (encodeOnionAddr crypto $ lookupRoute orouter) udp1 (dta,onion) <- partitionTransportM (parseDataToRoute crypto) (encodeDataToRoute crypto) onion1 let netcrypto = layerTransport parseNetCrypto encodeNetCrypto udp2 -- cgit v1.2.3