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
125
126
|
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TupleSections #-}
module Network.Tox.Crypto.Handlers where
import Network.Tox.Crypto.Transport
import Network.Tox.DHT.Transport (Cookie(..),CookieData(..))
import Crypto.Tox
import Control.Concurrent.STM
import Network.Address
import qualified Data.Map.Strict as Map
import Crypto.Hash
import Control.Applicative
import Control.Monad
import Data.Time.Clock.POSIX
data NetCryptoSessionStatus = Unaccepted | Accepted | Confirmed
deriving (Eq,Ord,Show,Enum)
data NetCryptoSession = NCrypto { ncState :: TVar NetCryptoSessionStatus
, ncTheirPacketNonce:: TVar Nonce24 -- base nonce + packet number
, ncMyPacketNonce :: TVar Nonce24 -- base nonce + packet number
, ncHandShake :: TVar (Maybe (Handshake Encrypted))
, ncCookie :: TVar (Maybe Cookie)
, ncTheirSessionPublic :: Maybe PublicKey
, ncSessionSecret :: SecretKey
, ncSockAddr :: SockAddr
}
data NetCryptoSessions = NCSessions { netCryptoSessions :: TVar (Map.Map SockAddr NetCryptoSession)
, transportCrypto :: TransportCrypto
}
newSessionsState :: TransportCrypto -> IO NetCryptoSessions
newSessionsState crypto = error "todo"
data HandshakeParams
= HParam
{ hpTheirBaseNonce :: Maybe Nonce24 -- ignore and generate your own
, hpOtherCookie :: Maybe Cookie
, hpTheirSessionKeyPublic :: PublicKey
, hpMySecretKey :: SecretKey
, hpCookieRemotePubkey :: PublicKey
, hpCookieRemoteDhtkey :: PublicKey
}
newHandShakeData :: TransportCrypto -> HandshakeParams -> HandshakeData
newHandShakeData = error "todo"
cryptoNetHandler :: NetCryptoSessions -> SockAddr -> NetCrypto -> IO (Maybe (NetCrypto -> NetCrypto))
cryptoNetHandler sessions addr (NetHandshake (Handshake (Cookie n24 ecookie) nonce24 encrypted)) = do
let crypto = transportCrypto sessions
allsessions = netCryptoSessions sessions
anyRight xs f = foldr1 (<|>) $ map f xs
seckeys <- map fst <$> atomically (readTVar (userKeys crypto))
symkey <- atomically $ transportSymmetric crypto
now <- getPOSIXTime
let lr = do -- Either Monad
(CookieData cookieTime remotePubkey remoteDhtkey) <- (decodePlain =<< decryptSymmetric symkey n24 ecookie)
(key,HandshakeData { baseNonce, sessionKey, cookieHash, otherCookie })
<- anyRight seckeys $ \key -> (key,) <$> (decodePlain =<< decrypt (computeSharedSecret key remotePubkey nonce24) encrypted)
-- check cookie time < 15 seconds ago
guard (now - fromIntegral cookieTime < 15)
-- cookie hash is valid? sha512 of ecookie
let hinit = hashInit
hctx = hashUpdate hinit n24
hctx' = hashUpdate hctx ecookie
digest = hashFinalize hctx'
guard (cookieHash == digest)
-- known friend?
-- todo
return
HParam
{ hpTheirBaseNonce = Just baseNonce
, hpOtherCookie = Just otherCookie
, hpTheirSessionKeyPublic = sessionKey
, hpMySecretKey = key
, hpCookieRemotePubkey = remotePubkey
, hpCookieRemoteDhtkey = remoteDhtkey
}
case lr of
Left _ -> return ()
Right hp@(HParam
{ hpTheirBaseNonce = Just theirBaseNonce
, hpOtherCookie = Just otherCookie
, hpTheirSessionKeyPublic = theirSessionKey
, hpMySecretKey = key
, hpCookieRemotePubkey = remotePublicKey
, hpCookieRemoteDhtkey = remoteDhtPublicKey
}) -> do
sessionsmap <- atomically $ readTVar allsessions
case Map.lookup addr sessionsmap of
Nothing -> do -- create new session
ncState0 <- atomically $ newTVar Accepted
ncTheirPacketNonce0 <- atomically $ newTVar theirBaseNonce
n24 <- atomically $ transportNewNonce crypto
let myhandshakeData = newHandShakeData crypto hp
plain = encodePlain myhandshakeData
state = computeSharedSecret key remoteDhtPublicKey n24
encrypted = encrypt state plain
myhandshake = Handshake { handshakeCookie = otherCookie
, handshakeNonce = n24
, handshakeData = encrypted
}
ncMyPacketNonce0 <- atomically $ newTVar (baseNonce myhandshakeData)
ncHandShake0 <- atomically $ newTVar (Just myhandshake)
cookie0 <- atomically $ newTVar (Just otherCookie)
newsession <- generateSecretKey
let netCryptoSession =
NCrypto { ncState = ncState0
, ncTheirPacketNonce= ncTheirPacketNonce0
, ncMyPacketNonce = ncMyPacketNonce0
, ncHandShake = ncHandShake0
, ncCookie = cookie0
, ncTheirSessionPublic = Just theirSessionKey
, ncSessionSecret = newsession
, ncSockAddr = addr
}
atomically $ modifyTVar allsessions (Map.insert addr netCryptoSession)
Just netCryptoSession -> return () -- TODO: UPdate existing session
return Nothing
cryptoNetHandler sessions addr (NetCrypto (CryptoPacket nonce16 encrypted)) = do
let crypto = transportCrypto sessions
-- Handle Encrypted Message
-- TODO
return Nothing
-- cryptoNetHandler _ _ _ = return $ Just id
|
