Adapted computeSharedSecret to a side-effecting interface.

This is to ready the tree for a memoizing cache of shared secrets.

1 files changed, 102 insertions, 76 deletions

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