summaryrefslogtreecommitdiff
path: root/src/Network/Tox
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2018-06-18 21:04:20 -0400
committerjoe <joe@jerkface.net>2018-06-18 21:04:20 -0400
commit2051912a76c7b6aedbda60f58dd37c39344470ec (patch)
tree9fe1a8820f15e0a70176851f9181d7dff1528b96 /src/Network/Tox
parent772f6547a40eb6a3a1dd76befb691f9160ed2d7a (diff)
Factored Network.Tox.Handshake out of *.Crypto.Handlers.
Diffstat (limited to 'src/Network/Tox')
-rw-r--r--src/Network/Tox/Crypto/Handlers.hs103
-rw-r--r--src/Network/Tox/Handshake.hs124
2 files changed, 129 insertions, 98 deletions
diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs
index 58b2b09a..c5c17e4e 100644
--- a/src/Network/Tox/Crypto/Handlers.hs
+++ b/src/Network/Tox/Crypto/Handlers.hs
@@ -58,6 +58,7 @@ import Text.Printf
58import Data.Bool 58import Data.Bool
59import Connection (Status(..), Policy(..)) 59import Connection (Status(..), Policy(..))
60import Network.Tox.ContactInfo 60import Network.Tox.ContactInfo
61import Network.Tox.Handshake
61 62
62-- | This type indicates the progress of a tox encrypted friend link 63-- | This type indicates the progress of a tox encrypted friend link
63-- connection. Two scenarios are illustrated below. The parenthesis show the 64-- connection. Two scenarios are illustrated below. The parenthesis show the
@@ -465,37 +466,6 @@ newSessionsState crypto unrechook hooks = do
465 , listenerIDSupply = lsupplyVar 466 , listenerIDSupply = lsupplyVar
466 } 467 }
467 468
468data HandshakeParams
469 = HParam
470 { hpTheirBaseNonce :: Maybe Nonce24 -- ignore and generate your own
471 , hpOtherCookie :: Cookie Encrypted
472 , hpTheirSessionKeyPublic :: Maybe PublicKey
473 , hpMySecretKey :: SecretKey
474 , hpCookieRemotePubkey :: PublicKey
475 , hpCookieRemoteDhtkey :: PublicKey
476 }
477
478newHandShakeData :: POSIXTime -> TransportCrypto -> Nonce24 -> HandshakeParams -> SockAddr -> PublicKey -> STM (Maybe HandshakeData)
479newHandShakeData timestamp crypto basenonce (HParam {hpOtherCookie,hpMySecretKey,hpCookieRemotePubkey,hpCookieRemoteDhtkey}) addr mySessionPublic
480 = do
481 freshCookie
482 <- case nodeInfo (key2id hpCookieRemoteDhtkey) addr of
483 Right nodeinfo -> Just <$> createCookieSTM timestamp crypto nodeinfo hpCookieRemotePubkey
484 Left er -> return Nothing
485 let hinit = hashInit
486 Cookie n24 encrypted = hpOtherCookie
487 hctx = hashUpdate hinit n24
488 hctx' = hashUpdate hctx encrypted
489 digest = hashFinalize hctx'
490 return $
491 fmap (\freshCookie' ->
492 HandshakeData
493 { baseNonce = basenonce
494 , sessionKey = mySessionPublic
495 , cookieHash = digest
496 , otherCookie = freshCookie'
497 }) freshCookie
498
499type XMessage = CryptoMessage -- todo 469type XMessage = CryptoMessage -- todo
500 470
501-- THIS Would work if not for the IO shared secret cache... 471-- THIS Would work if not for the IO shared secret cache...
@@ -588,18 +558,11 @@ freshCryptoSession sessions
588 then InProgress AwaitingSessionPacket 558 then InProgress AwaitingSessionPacket
589 else InProgress AwaitingHandshake) 559 else InProgress AwaitingHandshake)
590 ncTheirBaseNonce0 <- newTVar (frmMaybe mbtheirBaseNonce) 560 ncTheirBaseNonce0 <- newTVar (frmMaybe mbtheirBaseNonce)
591 n24 <- transportNewNonce crypto
592 state <- ($ n24) <$> lookupNonceFunctionSTM timestamp crypto key remotePublicKey
593 newBaseNonce <- transportNewNonce crypto 561 newBaseNonce <- transportNewNonce crypto
594 mbMyhandshakeData <- newHandShakeData timestamp crypto newBaseNonce hp addr (toPublic newsession) 562 mbMyhandshakeData <- case nodeInfo (key2id $ hpCookieRemoteDhtkey hp) addr of
595 let encodeHandshake myhandshakeData = let plain = encodePlain myhandshakeData 563 Right nodeinfo -> Just <$> newHandShakeData timestamp crypto newBaseNonce hp nodeinfo (toPublic newsession)
596 -- state = computeSharedSecret key remoteDhtPublicKey n24 564 Left er -> return Nothing -- Unable to send handshake to non-internet socket!
597 encrypted = encrypt state plain 565 myhandshake <- mapM (encodeHandshake timestamp crypto key remotePublicKey otherCookie) mbMyhandshakeData
598 in Handshake { handshakeCookie = otherCookie
599 , handshakeNonce = n24
600 , handshakeData = encrypted
601 }
602 let myhandshake= encodeHandshake <$> mbMyhandshakeData
603 ncHandShake0 <- newTVar (frmMaybe myhandshake) 566 ncHandShake0 <- newTVar (frmMaybe myhandshake)
604 ncMyPacketNonce0 <- newTVar newBaseNonce 567 ncMyPacketNonce0 <- newTVar newBaseNonce
605 cookie0 <- newTVar (HaveCookie otherCookie) 568 cookie0 <- newTVar (HaveCookie otherCookie)
@@ -874,62 +837,6 @@ updateCryptoSession sessions addr newsession timestamp hp session handshake = do
874 writeTVar (ncState session) {-Accepted-}(InProgress AwaitingSessionPacket) 837 writeTVar (ncState session) {-Accepted-}(InProgress AwaitingSessionPacket)
875 return (Nothing,return ()) 838 return (Nothing,return ())
876 839
877anyRight :: Monad m => a -> [t] -> (t -> m (Either b b1)) -> m (Either a b1)
878anyRight e [] f = return $ Left e
879anyRight e (x:xs) f = f x >>= either (const $ anyRight e xs f) (return . Right)
880
881decryptHandshake :: TransportCrypto -> Handshake Encrypted -> IO (Either String (SecretKey,Handshake Identity))
882decryptHandshake crypto hshake@(Handshake (Cookie n24 ecookie) nonce24 encrypted) = do
883 (ukeys,symkey) <- atomically $ (,) <$> userKeys crypto
884 <*> transportSymmetric crypto
885 let seckeys = map fst ukeys
886 dput XNetCrypto "decryptHandshake: trying the following keys:"
887 now <- getPOSIXTime
888 forM_ seckeys $ \k -> dput XNetCrypto $ " " ++ show (key2id . toPublic $ k)
889 fmap join . sequence $ do -- Either Monad
890 cd@(CookieData cookieTime remotePubkey remoteDhtkey) <- decodePlain =<< decryptSymmetric symkey n24 ecookie
891 Right $ do -- IO Monad
892 decrypted <- anyRight "missing key" seckeys $ \key -> do
893 dput XNetCrypto $ "(NetCrypto)handshakeH: remotePubkey = " ++ show (key2id $ remotePubkey)
894 dput XNetCrypto $ "(NetCrypto)handshakeH: nonce24 = " ++ show nonce24
895 secret <- lookupSharedSecret crypto key remotePubkey nonce24
896 let step1 = decrypt secret encrypted
897 case step1 of
898 Left s -> do
899 dput XNetCrypto $ "(NetCrypto)handshakeH: (decrypt) " ++ s
900 return (Left s)
901 Right pln -> do
902 case decodePlain pln of
903 Left s -> do
904 dput XNetCrypto $ "(NetCrypto)handshakeH: (decodePlain) " ++ s
905 return (Left s)
906 Right x -> return (Right (key,x))
907 return $ do -- Either Monad
908 (key,hsdata@HandshakeData { baseNonce, sessionKey, cookieHash, otherCookie }) <- decrypted
909 left (asTypeOf "cookie too old") $ guard (now - fromIntegral cookieTime < 15)
910 let hinit = hashInit
911 hctx = hashUpdate hinit n24
912 hctx' = hashUpdate hctx ecookie
913 digest = hashFinalize hctx'
914 left (asTypeOf "cookie digest mismatch") $ guard (cookieHash == digest)
915 return ( key
916 , hshake { handshakeCookie = Cookie n24 (pure cd)
917 , handshakeData = pure hsdata
918 } )
919
920toHandshakeParams :: (SecretKey, Handshake Identity) -> HandshakeParams
921toHandshakeParams (key,hs)
922 = let hd = runIdentity $ handshakeData hs
923 Cookie _ cd0 = handshakeCookie hs
924 CookieData _ remotePublicKey remoteDhtPublicKey = runIdentity cd0
925 in HParam { hpTheirBaseNonce = Just $ baseNonce hd
926 , hpOtherCookie = otherCookie hd
927 , hpTheirSessionKeyPublic = Just $ sessionKey hd
928 , hpMySecretKey = key
929 , hpCookieRemotePubkey = remotePublicKey
930 , hpCookieRemoteDhtkey = remoteDhtPublicKey
931 }
932
933handshakeH :: NetCryptoSessions -> SockAddr -> Handshake Encrypted -> IO (Maybe a) 840handshakeH :: NetCryptoSessions -> SockAddr -> Handshake Encrypted -> IO (Maybe a)
934handshakeH sessions addrRaw hshake@(Handshake (Cookie n24 ecookie) nonce24 encrypted) = do 841handshakeH sessions addrRaw hshake@(Handshake (Cookie n24 ecookie) nonce24 encrypted) = do
935 let addr = either id id $ either4or6 addrRaw 842 let addr = either id id $ either4or6 addrRaw
diff --git a/src/Network/Tox/Handshake.hs b/src/Network/Tox/Handshake.hs
new file mode 100644
index 00000000..c51f6369
--- /dev/null
+++ b/src/Network/Tox/Handshake.hs
@@ -0,0 +1,124 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE NamedFieldPuns #-}
4{-# LANGUAGE PatternSynonyms #-}
5{-# LANGUAGE TupleSections #-}
6{-# LANGUAGE TypeOperators #-}
7module Network.Tox.Handshake where
8
9import Control.Arrow
10import Control.Concurrent.STM
11import Control.Lens
12import Control.Monad
13import Crypto.Hash
14import Crypto.Tox
15import Data.Time.Clock.POSIX
16import Network.Tox.Crypto.Transport
17import Network.Tox.DHT.Handlers (createCookieSTM)
18import Network.Tox.DHT.Transport (Cookie (..), CookieData (..))
19import Network.Tox.NodeId
20#ifdef THREAD_DEBUG
21#else
22import Control.Concurrent
23import GHC.Conc (labelThread)
24#endif
25import DPut
26
27
28anyRight :: Monad m => a -> [t] -> (t -> m (Either b b1)) -> m (Either a b1)
29anyRight e [] f = return $ Left e
30anyRight e (x:xs) f = f x >>= either (const $ anyRight e xs f) (return . Right)
31
32decryptHandshake :: TransportCrypto -> Handshake Encrypted -> IO (Either String (SecretKey,Handshake Identity))
33decryptHandshake crypto hshake@(Handshake (Cookie n24 ecookie) nonce24 encrypted) = do
34 (ukeys,symkey) <- atomically $ (,) <$> userKeys crypto
35 <*> transportSymmetric crypto
36 let seckeys = map fst ukeys
37 dput XNetCrypto "decryptHandshake: trying the following keys:"
38 now <- getPOSIXTime
39 forM_ seckeys $ \k -> dput XNetCrypto $ " " ++ show (key2id . toPublic $ k)
40 fmap join . sequence $ do -- Either Monad
41 cd@(CookieData cookieTime remotePubkey remoteDhtkey) <- decodePlain =<< decryptSymmetric symkey n24 ecookie
42 Right $ do -- IO Monad
43 decrypted <- anyRight "missing key" seckeys $ \key -> do
44 dput XNetCrypto $ "(NetCrypto)handshakeH: remotePubkey = " ++ show (key2id $ remotePubkey)
45 dput XNetCrypto $ "(NetCrypto)handshakeH: nonce24 = " ++ show nonce24
46 secret <- lookupSharedSecret crypto key remotePubkey nonce24
47 let step1 = decrypt secret encrypted
48 case step1 of
49 Left s -> do
50 dput XNetCrypto $ "(NetCrypto)handshakeH: (decrypt) " ++ s
51 return (Left s)
52 Right pln -> do
53 case decodePlain pln of
54 Left s -> do
55 dput XNetCrypto $ "(NetCrypto)handshakeH: (decodePlain) " ++ s
56 return (Left s)
57 Right x -> return (Right (key,x))
58 return $ do -- Either Monad
59 (key,hsdata@HandshakeData { baseNonce, sessionKey, cookieHash, otherCookie }) <- decrypted
60 left (asTypeOf "cookie too old") $ guard (now - fromIntegral cookieTime < 15)
61 let hinit = hashInit
62 hctx = hashUpdate hinit n24
63 hctx' = hashUpdate hctx ecookie
64 digest = hashFinalize hctx'
65 left (asTypeOf "cookie digest mismatch") $ guard (cookieHash == digest)
66 return ( key
67 , hshake { handshakeCookie = Cookie n24 (pure cd)
68 , handshakeData = pure hsdata
69 } )
70
71
72data HandshakeParams
73 = HParam
74 { hpTheirBaseNonce :: Maybe Nonce24 -- ignore and generate your own
75 , hpOtherCookie :: Cookie Encrypted
76 , hpTheirSessionKeyPublic :: Maybe PublicKey
77 , hpMySecretKey :: SecretKey
78 , hpCookieRemotePubkey :: PublicKey
79 , hpCookieRemoteDhtkey :: PublicKey
80 }
81
82newHandShakeData :: POSIXTime -> TransportCrypto -> Nonce24 -> HandshakeParams -> NodeInfo -> PublicKey -> STM HandshakeData
83newHandShakeData timestamp crypto basenonce hp nodeinfo mySessionPublic = do
84 let HParam {hpOtherCookie,hpMySecretKey,hpCookieRemotePubkey,hpCookieRemoteDhtkey} = hp
85 hinit = hashInit
86 Cookie n24 encrypted = hpOtherCookie
87 hctx = hashUpdate hinit n24
88 hctx' = hashUpdate hctx encrypted
89 digest = hashFinalize hctx'
90 freshCookie <- createCookieSTM timestamp crypto nodeinfo hpCookieRemotePubkey
91 return HandshakeData
92 { baseNonce = basenonce
93 , sessionKey = mySessionPublic
94 , cookieHash = digest
95 , otherCookie = freshCookie
96 }
97
98toHandshakeParams :: (SecretKey, Handshake Identity) -> HandshakeParams
99toHandshakeParams (key,hs)
100 = let hd = runIdentity $ handshakeData hs
101 Cookie _ cd0 = handshakeCookie hs
102 CookieData _ remotePublicKey remoteDhtPublicKey = runIdentity cd0
103 in HParam { hpTheirBaseNonce = Just $ baseNonce hd
104 , hpOtherCookie = otherCookie hd
105 , hpTheirSessionKeyPublic = Just $ sessionKey hd
106 , hpMySecretKey = key
107 , hpCookieRemotePubkey = remotePublicKey
108 , hpCookieRemoteDhtkey = remoteDhtPublicKey
109 }
110
111encodeHandshake :: POSIXTime
112 -> TransportCrypto
113 -> SecretKey
114 -> PublicKey
115 -> Cookie Encrypted
116 -> HandshakeData
117 -> STM (Handshake Encrypted)
118encodeHandshake timestamp crypto me them otherCookie myhandshakeData = do
119 n24 <- transportNewNonce crypto
120 state <- ($ n24) <$> lookupNonceFunctionSTM timestamp crypto me them
121 return Handshake { handshakeCookie = otherCookie
122 , handshakeNonce = n24
123 , handshakeData = encrypt state $ encodePlain myhandshakeData
124 }
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 15:11:25 +0000