1 files changed, 39 insertions, 0 deletions

diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs
index 56fb4dcf..2a1461f2 100644
--- a/src/Network/Tox/Crypto/Handlers.hs
+++ b/src/Network/Tox/Crypto/Handlers.hs
@@ -9,6 +9,7 @@ import Network.Tox.Crypto.Transport
 import Network.Tox.DHT.Transport (Cookie(..),CookieData(..), CookieRequest(..), NoSpam(..))
 import Network.Tox.DHT.Handlers (Client, cookieRequest, createCookie )
 import Crypto.Tox
+import Control.Arrow
 import Control.Concurrent.STM
 import Control.Concurrent.STM.TMChan
 import Network.Address
@@ -711,6 +712,44 @@ anyRight :: Monad m => a -> [t] -> (t -> m (Either b b1)) -> m (Either a b1)
 anyRight e []     f = return $ Left e
 anyRight e (x:xs) f = f x >>= either (const $ anyRight e xs f) (return . Right)
 
+decryptHandshake :: TransportCrypto -> Handshake Encrypted -> IO (Either String (Handshake Identity))
+decryptHandshake crypto hshake@(Handshake (Cookie n24 ecookie) nonce24 encrypted) = do
+    (ukeys,symkey) <- atomically $ (,) <$> userKeys crypto
+                                       <*> transportSymmetric crypto
+    let seckeys = map fst ukeys
+    dput XNetCrypto "decryptHandshake: trying the following keys:"
+    now <- getPOSIXTime
+    forM_ seckeys $ \k -> dput XNetCrypto $ "  " ++ show (key2id . toPublic $ k)
+    fmap join . sequence $ do -- Either Monad
+            cd@(CookieData cookieTime remotePubkey remoteDhtkey) <- decodePlain =<< decryptSymmetric symkey n24 ecookie
+            Right $ do -- IO Monad
+            decrypted <- anyRight "missing key" seckeys $ \key -> do
+                            dput XNetCrypto $ "(NetCrypto)handshakeH: remotePubkey =  " ++ show (key2id $ remotePubkey)
+                            dput XNetCrypto $ "(NetCrypto)handshakeH: nonce24 =  " ++ show nonce24
+                            secret <- lookupSharedSecret crypto key remotePubkey nonce24
+                            let step1 = decrypt secret encrypted
+                            case step1 of
+                                Left s -> do
+                                    dput XNetCrypto $ "(NetCrypto)handshakeH: (decrypt) " ++ s
+                                    return (Left s)
+                                Right pln -> do
+                                    case decodePlain pln of
+                                        Left s -> do
+                                            dput XNetCrypto $ "(NetCrypto)handshakeH: (decodePlain) " ++ s
+                                            return (Left s)
+                                        Right x -> return (Right (key,x))
+            return $ do -- Either Monad
+            (key,hsdata@HandshakeData { baseNonce, sessionKey, cookieHash, otherCookie }) <- decrypted
+            left (asTypeOf "cookie too old") $ guard (now - fromIntegral cookieTime < 15)
+            let hinit = hashInit
+                hctx = hashUpdate hinit n24
+                hctx' = hashUpdate hctx ecookie
+                digest = hashFinalize hctx'
+            left (asTypeOf "cookie digest mismatch") $ guard (cookieHash == digest)
+            return hshake { handshakeCookie = Cookie n24 (pure cd)
+                          , handshakeData   = pure hsdata
+                          }
+
 handshakeH :: NetCryptoSessions -> SockAddr -> Handshake Encrypted -> IO (Maybe a)
 handshakeH sessions addr hshake@(Handshake (Cookie n24 ecookie) nonce24 encrypted) = do
     dput XNetCrypto ("RECIEVED HANDSHAKE from " ++ show addr)