1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
module Network.Tox.Handshake where
import Control.Arrow
import Control.Concurrent.STM
import Control.Lens
import Control.Monad
import Crypto.Hash
import Crypto.Tox
import Data.Time.Clock.POSIX
import Network.Tox.Crypto.Transport
import Network.Tox.DHT.Handlers (createCookieSTM)
import Network.Tox.DHT.Transport (Cookie (..), CookieData (..))
import Network.Tox.NodeId
#ifdef THREAD_DEBUG
#else
import Control.Concurrent
import GHC.Conc (labelThread)
#endif
import DPut
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 (SecretKey,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 ( key
, hshake { handshakeCookie = Cookie n24 (pure cd)
, handshakeData = pure hsdata
} )
data HandshakeParams
= HParam
{ hpTheirBaseNonce :: Maybe Nonce24 -- ignore and generate your own
, hpOtherCookie :: Cookie Encrypted
, hpTheirSessionKeyPublic :: Maybe PublicKey
, hpMySecretKey :: SecretKey
, hpCookieRemotePubkey :: PublicKey
, hpCookieRemoteDhtkey :: PublicKey
}
newHandShakeData :: POSIXTime -> TransportCrypto -> Nonce24 -> HandshakeParams -> NodeInfo -> PublicKey -> STM HandshakeData
newHandShakeData timestamp crypto basenonce hp nodeinfo mySessionPublic = do
let HParam {hpOtherCookie,hpMySecretKey,hpCookieRemotePubkey,hpCookieRemoteDhtkey} = hp
hinit = hashInit
Cookie n24 encrypted = hpOtherCookie
hctx = hashUpdate hinit n24
hctx' = hashUpdate hctx encrypted
digest = hashFinalize hctx'
freshCookie <- createCookieSTM timestamp crypto nodeinfo hpCookieRemotePubkey
return HandshakeData
{ baseNonce = basenonce
, sessionKey = mySessionPublic
, cookieHash = digest
, otherCookie = freshCookie
}
toHandshakeParams :: (SecretKey, Handshake Identity) -> HandshakeParams
toHandshakeParams (key,hs)
= let hd = runIdentity $ handshakeData hs
Cookie _ cd0 = handshakeCookie hs
CookieData _ remotePublicKey remoteDhtPublicKey = runIdentity cd0
in HParam { hpTheirBaseNonce = Just $ baseNonce hd
, hpOtherCookie = otherCookie hd
, hpTheirSessionKeyPublic = Just $ sessionKey hd
, hpMySecretKey = key
, hpCookieRemotePubkey = remotePublicKey
, hpCookieRemoteDhtkey = remoteDhtPublicKey
}
encodeHandshake :: POSIXTime
-> TransportCrypto
-> SecretKey
-> PublicKey
-> Cookie Encrypted
-> HandshakeData
-> STM (Handshake Encrypted)
encodeHandshake timestamp crypto me them otherCookie myhandshakeData = do
n24 <- transportNewNonce crypto
state <- ($ n24) <$> lookupNonceFunctionSTM timestamp crypto me them
return Handshake { handshakeCookie = otherCookie
, handshakeNonce = n24
, handshakeData = encrypt state $ encodePlain myhandshakeData
}
|
