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/Onion/Transport.hs | 178 +++++++++++++++++++++---------------- 1 file changed, 102 insertions(+), 76 deletions(-) (limited to 'src/Network/Tox/Onion/Transport.hs') 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 -- cgit v1.2.3