diff options
Diffstat (limited to 'dht/src/Network/Tox/Session.hs')
-rw-r--r-- | dht/src/Network/Tox/Session.hs | 243 |
1 files changed, 243 insertions, 0 deletions
diff --git a/dht/src/Network/Tox/Session.hs b/dht/src/Network/Tox/Session.hs new file mode 100644 index 00000000..189967fa --- /dev/null +++ b/dht/src/Network/Tox/Session.hs | |||
@@ -0,0 +1,243 @@ | |||
1 | -- | This module implements the lossless Tox session protocol. | ||
2 | {-# LANGUAGE TupleSections #-} | ||
3 | module Network.Tox.Session | ||
4 | ( SessionParams(..) | ||
5 | , SessionKey | ||
6 | , Session(..) | ||
7 | , sTheirUserKey | ||
8 | , sClose | ||
9 | , handshakeH | ||
10 | ) where | ||
11 | |||
12 | import Control.Concurrent.STM | ||
13 | import Control.Monad | ||
14 | import Control.Exception | ||
15 | import Data.Dependent.Sum | ||
16 | import Data.Functor.Identity | ||
17 | import Data.Word | ||
18 | import Network.Socket (SockAddr) | ||
19 | |||
20 | import Crypto.Tox | ||
21 | import Data.PacketBuffer (PacketInboundEvent (..)) | ||
22 | import Data.Tox.Msg | ||
23 | import DPut | ||
24 | import DebugTag | ||
25 | import Network.Lossless | ||
26 | import Network.QueryResponse | ||
27 | import Network.SessionTransports | ||
28 | import Network.Tox.Crypto.Transport | ||
29 | import Network.Tox.DHT.Transport (Cookie (..), key2id, longTermKey) | ||
30 | import Network.Tox.Handshake | ||
31 | |||
32 | -- | Alias for 'SecretKey' to document that it is used as the temporary Tox | ||
33 | -- session key corresponding to the 'PublicKey' we sent in the handshake. | ||
34 | type SessionKey = SecretKey | ||
35 | |||
36 | -- | These inputs to 'handshakeH' indicate how to respond to handshakes, how to | ||
37 | -- assign packets to sessions, and what to do with established sessions after | ||
38 | -- they are made lossless by queuing packets and appending sequence numbers. | ||
39 | data SessionParams = SessionParams | ||
40 | { -- | The database of secret keys necessary to encrypt handshake packets. | ||
41 | spCrypto :: TransportCrypto | ||
42 | -- | This is used to create sessions and dispatch packets to them. | ||
43 | , spSessions :: Sessions (CryptoPacket Encrypted) | ||
44 | -- | This method returns the session information corresponding to the | ||
45 | -- cookie pair for the remote address. If no handshake was sent, this | ||
46 | -- should send one immediately. It should return 'Nothing' if anything | ||
47 | -- goes wrong. | ||
48 | , spGetSentHandshake :: SecretKey -> SockAddr | ||
49 | -> Cookie Identity | ||
50 | -> Cookie Encrypted | ||
51 | -> IO (Maybe (SessionKey, HandshakeData)) | ||
52 | -- | This method is invoked on each new session and is responsible for | ||
53 | -- launching any threads necessary to keep the session alive. | ||
54 | , spOnNewSession :: Session -> IO () | ||
55 | } | ||
56 | |||
57 | -- | After a session is established, this information is given to the | ||
58 | -- 'spOnNewSession' callback. | ||
59 | data Session = Session | ||
60 | { -- | This is the secret user (toxid) key that corresponds to the | ||
61 | -- local-end of this session. | ||
62 | sOurKey :: SecretKey | ||
63 | -- | The remote address for this session. (Not unique, see 'sSessionID'). | ||
64 | , sTheirAddr :: SockAddr | ||
65 | -- | The information we sent in the handshake for this session. | ||
66 | , sSentHandshake :: HandshakeData | ||
67 | -- | The information we received in a handshake for this session. | ||
68 | , sReceivedHandshake :: Handshake Identity | ||
69 | -- | This method can be used to trigger packets to be re-sent given a | ||
70 | -- list of their sequence numbers. It should be used when the remote end | ||
71 | -- indicates they lost packets. | ||
72 | , sResendPackets :: [Word32] -> IO () | ||
73 | -- | This list of sequence numbers should be periodically polled and if | ||
74 | -- it is not empty, we should request they re-send these packets. For | ||
75 | -- convenience, a lower bound for the numbers in the list is also | ||
76 | -- returned. Suggested polling interval: a few seconds. | ||
77 | , sMissingInbound :: IO ([Word32],Word32) | ||
78 | -- | A lossless transport for sending and receiving packets in this | ||
79 | -- session. It is up to the caller to spawn the await-loop to handle | ||
80 | -- inbound packets. | ||
81 | , sTransport :: Transport String () CryptoMessage | ||
82 | -- | A unique small integer that identifies this session for as long as | ||
83 | -- it is established. | ||
84 | , sSessionID :: Int | ||
85 | } | ||
86 | |||
87 | -- | Helper to obtain the remote ToxID key from the locally-issued cookie | ||
88 | -- associated with the session. | ||
89 | sTheirUserKey :: Session -> PublicKey | ||
90 | sTheirUserKey s = longTermKey $ runIdentity cookie | ||
91 | where | ||
92 | Cookie _ cookie = handshakeCookie (sReceivedHandshake s) | ||
93 | |||
94 | -- | Helper to close the 'Transport' associated with a session. | ||
95 | sClose :: Session -> IO () | ||
96 | sClose s = closeTransport (sTransport s) | ||
97 | |||
98 | |||
99 | -- | Call this whenever a new handshake arrives so that a session is | ||
100 | -- negotiated. It always returns Nothing which makes it convenient to use with | ||
101 | -- 'Network.QueryResponse.addHandler'. | ||
102 | handshakeH :: SessionParams | ||
103 | -> SockAddr | ||
104 | -> Handshake Encrypted | ||
105 | -> IO (Maybe a) | ||
106 | handshakeH sp saddr handshake = do | ||
107 | decryptHandshake (spCrypto sp) handshake | ||
108 | >>= either (\err -> return ()) | ||
109 | (uncurry $ plainHandshakeH sp saddr) | ||
110 | return Nothing | ||
111 | |||
112 | |||
113 | plainHandshakeH :: SessionParams | ||
114 | -> SockAddr | ||
115 | -> SecretKey | ||
116 | -> Handshake Identity | ||
117 | -> IO () | ||
118 | plainHandshakeH sp saddr skey handshake = do | ||
119 | let hd = runIdentity $ handshakeData handshake | ||
120 | prelude = show saddr ++ " --> " | ||
121 | dput XNetCrypto $ unlines $ map (prelude ++) | ||
122 | [ "handshake: auth=" ++ show (handshakeCookie handshake) | ||
123 | , " : issuing=" ++ show (otherCookie hd) | ||
124 | , " : baseNonce=" ++ show (baseNonce hd) | ||
125 | ] | ||
126 | sent <- spGetSentHandshake sp skey saddr (handshakeCookie handshake) (otherCookie hd) | ||
127 | -- TODO: this is always returning sent = Nothing | ||
128 | dput XNetCrypto $ " <-- (cached) handshake baseNonce " ++ show (fmap (baseNonce . snd) sent) | ||
129 | forM_ sent $ \(hd_skey,hd_sent) -> do | ||
130 | sk <- SessionKeys (spCrypto sp) | ||
131 | hd_skey | ||
132 | (sessionKey hd) | ||
133 | <$> atomically (newTVar $ baseNonce hd) | ||
134 | <*> atomically (newTVar $ baseNonce hd_sent) | ||
135 | m <- newSession (spSessions sp) (\() p -> return p) (decryptPacket sk) saddr | ||
136 | dput XNetCrypto $ prelude ++ "plainHandshakeH: session " ++ maybe "Nothing" (const "Just") m | ||
137 | forM_ m $ \(sid, t) -> do | ||
138 | (t2,resend,getMissing) | ||
139 | <- lossless (\cp a -> return $ fmap (,a) $ checkLossless $ runIdentity $ pktData cp) | ||
140 | (\seqno p@(Pkt m :=> _) _ -> do | ||
141 | y <- encryptPacket sk $ bookKeeping seqno p | ||
142 | return OutgoingInfo | ||
143 | { oIsLossy = lossyness m == Lossy | ||
144 | , oEncoded = y | ||
145 | , oHandleException = Just $ \e -> do | ||
146 | dput XUnexpected $ unlines | ||
147 | [ "<-- " ++ show e | ||
148 | , "<-- while sending " ++ show (seqno,p) ] | ||
149 | throwIO e | ||
150 | }) | ||
151 | () | ||
152 | t | ||
153 | let _ = t :: TransportA String () (CryptoPacket Identity) (CryptoPacket Encrypted) | ||
154 | _ = t2 :: Transport String () CryptoMessage | ||
155 | sendMessage t2 () $ (Pkt ONLINE ==> ()) | ||
156 | spOnNewSession sp Session | ||
157 | { sOurKey = skey | ||
158 | , sTheirAddr = saddr | ||
159 | , sSentHandshake = hd_sent | ||
160 | , sReceivedHandshake = handshake | ||
161 | , sResendPackets = resend | ||
162 | , sMissingInbound = getMissing | ||
163 | , sTransport = t2 | ||
164 | , sSessionID = sid | ||
165 | } | ||
166 | return () | ||
167 | |||
168 | |||
169 | -- | The per-session nonce and key state maintained by 'decryptPacket' and | ||
170 | -- 'encryptPacket'. | ||
171 | data SessionKeys = SessionKeys | ||
172 | { skCrypto :: TransportCrypto -- ^ Cache of shared-secrets. | ||
173 | , skMe :: SessionKey -- ^ My session key | ||
174 | , skThem :: PublicKey -- ^ Their session key | ||
175 | , skNonceIncoming :: TVar Nonce24 -- ^ +21845 when a threshold is reached. | ||
176 | , skNonceOutgoing :: TVar Nonce24 -- ^ +1 on every packet | ||
177 | } | ||
178 | |||
179 | -- | Decrypt an inbound session packet and update the nonce for the next one. | ||
180 | decryptPacket :: SessionKeys -> SockAddr -> CryptoPacket Encrypted -> IO (Maybe (CryptoPacket Identity, ())) | ||
181 | decryptPacket sk saddr (CryptoPacket n16 ciphered) = do | ||
182 | (n24,δ) <- atomically $ do | ||
183 | n <- readTVar (skNonceIncoming sk) | ||
184 | let δ = n16 - nonce24ToWord16 n | ||
185 | return ( n `addtoNonce24` fromIntegral δ, δ ) | ||
186 | secret <- lookupSharedSecret (skCrypto sk) (skMe sk) (skThem sk) n24 | ||
187 | case decodePlain =<< decrypt secret ciphered of | ||
188 | Left e -> return Nothing | ||
189 | Right x -> do | ||
190 | when ( δ > 43690 ) | ||
191 | $ atomically $ writeTVar (skNonceIncoming sk) (n24 `addtoNonce24` 21845) | ||
192 | |||
193 | do let them = key2id $ skThem sk | ||
194 | CryptoData ack seqno _ = x | ||
195 | cm = decodeRawCryptoMsg x | ||
196 | dput XNetCrypto $ unwords [take 8 (show them),"-->",show (msgID cm),show (n24,ack,seqno)] | ||
197 | |||
198 | return $ Just ( CryptoPacket n16 (pure x), () ) | ||
199 | |||
200 | -- | Encrypt an outbound session packet and update the nonce for the next one. | ||
201 | encryptPacket :: SessionKeys -> CryptoData -> IO (CryptoPacket Encrypted) | ||
202 | encryptPacket sk plain = do | ||
203 | n24 <- atomically $ do | ||
204 | n24 <- readTVar (skNonceOutgoing sk) | ||
205 | modifyTVar' (skNonceOutgoing sk) incrementNonce24 | ||
206 | return n24 | ||
207 | secret <- lookupSharedSecret (skCrypto sk) (skMe sk) (skThem sk) n24 | ||
208 | let ciphered = encrypt secret $ encodePlain $ plain | ||
209 | |||
210 | do let them = key2id $ skThem sk | ||
211 | CryptoData ack seqno cm = plain | ||
212 | dput XNetCrypto $ unwords [take 8 (show them),"<--",show (msgID cm),show (n24,ack,seqno)] | ||
213 | |||
214 | return $ CryptoPacket (nonce24ToWord16 n24) ciphered | ||
215 | |||
216 | |||
217 | -- | Add sequence information to an outbound packet. | ||
218 | -- | ||
219 | -- From spec.md: | ||
220 | -- | ||
221 | -- Data in the encrypted packets: | ||
222 | -- | ||
223 | -- [our recvbuffers buffer_start, (highest packet number handled + 1), (big endian)] | ||
224 | -- [uint32_t packet number if lossless, sendbuffer buffer_end if lossy, (big endian)] | ||
225 | -- [data] | ||
226 | bookKeeping :: SequenceInfo -> CryptoMessage -> CryptoData | ||
227 | bookKeeping (SequenceInfo seqno ack) m = CryptoData | ||
228 | { bufferStart = ack :: Word32 | ||
229 | , bufferEnd = seqno :: Word32 | ||
230 | , bufferData = m | ||
231 | } | ||
232 | |||
233 | -- | Classify an inbound packet as lossy or lossless based on its id byte. | ||
234 | checkLossless :: CryptoData -> PacketInboundEvent CryptoMessage | ||
235 | checkLossless cd@CryptoData{ bufferStart = ack | ||
236 | , bufferEnd = no | ||
237 | , bufferData = x } = tag no x' ack | ||
238 | where | ||
239 | x' = decodeRawCryptoMsg cd | ||
240 | tag = case someLossyness (msgID x') of Lossy -> PacketReceivedLossy | ||
241 | _ -> PacketReceived | ||
242 | |||
243 | |||