summaryrefslogtreecommitdiff
path: root/dht/src/Network/Tox/Session.hs
diff options
context:
space:
mode:
Diffstat (limited to 'dht/src/Network/Tox/Session.hs')
-rw-r--r--dht/src/Network/Tox/Session.hs243
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 #-}
3module Network.Tox.Session
4 ( SessionParams(..)
5 , SessionKey
6 , Session(..)
7 , sTheirUserKey
8 , sClose
9 , handshakeH
10 ) where
11
12import Control.Concurrent.STM
13import Control.Monad
14import Control.Exception
15import Data.Dependent.Sum
16import Data.Functor.Identity
17import Data.Word
18import Network.Socket (SockAddr)
19
20import Crypto.Tox
21import Data.PacketBuffer (PacketInboundEvent (..))
22import Data.Tox.Msg
23import DPut
24import DebugTag
25import Network.Lossless
26import Network.QueryResponse
27import Network.SessionTransports
28import Network.Tox.Crypto.Transport
29import Network.Tox.DHT.Transport (Cookie (..), key2id, longTermKey)
30import 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.
34type 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.
39data 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.
59data 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.
89sTheirUserKey :: Session -> PublicKey
90sTheirUserKey s = longTermKey $ runIdentity cookie
91 where
92 Cookie _ cookie = handshakeCookie (sReceivedHandshake s)
93
94-- | Helper to close the 'Transport' associated with a session.
95sClose :: Session -> IO ()
96sClose 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'.
102handshakeH :: SessionParams
103 -> SockAddr
104 -> Handshake Encrypted
105 -> IO (Maybe a)
106handshakeH sp saddr handshake = do
107 decryptHandshake (spCrypto sp) handshake
108 >>= either (\err -> return ())
109 (uncurry $ plainHandshakeH sp saddr)
110 return Nothing
111
112
113plainHandshakeH :: SessionParams
114 -> SockAddr
115 -> SecretKey
116 -> Handshake Identity
117 -> IO ()
118plainHandshakeH 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'.
171data 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.
180decryptPacket :: SessionKeys -> SockAddr -> CryptoPacket Encrypted -> IO (Maybe (CryptoPacket Identity, ()))
181decryptPacket 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.
201encryptPacket :: SessionKeys -> CryptoData -> IO (CryptoPacket Encrypted)
202encryptPacket 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]
226bookKeeping :: SequenceInfo -> CryptoMessage -> CryptoData
227bookKeeping (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.
234checkLossless :: CryptoData -> PacketInboundEvent CryptoMessage
235checkLossless 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