summaryrefslogtreecommitdiff
path: root/ToxMessage.hs
diff options
context:
space:
mode:
Diffstat (limited to 'ToxMessage.hs')
-rw-r--r--ToxMessage.hs450
1 files changed, 0 insertions, 450 deletions
diff --git a/ToxMessage.hs b/ToxMessage.hs
deleted file mode 100644
index 41204697..00000000
--- a/ToxMessage.hs
+++ /dev/null
@@ -1,450 +0,0 @@
1{-# LANGUAGE PatternSynonyms #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE DeriveFunctor, DeriveTraversable,DeriveDataTypeable #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE TypeApplications #-}
8{-# LANGUAGE ExistentialQuantification #-}
9{-# LANGUAGE DataKinds, KindSignatures #-}
10module ToxMessage where
11
12import Debug.Trace
13import Data.ByteString (ByteString)
14import qualified Crypto.MAC.Poly1305 as Poly1305 (Auth(..))
15import qualified Crypto.PubKey.Curve25519 as Curve25519
16import Data.ByteArray as BA (ByteArrayAccess, Bytes)
17import qualified Data.ByteArray as BA
18import qualified Data.ByteString as B
19import qualified Data.ByteString.Char8 as C8
20import qualified Data.ByteString.Base16 as Base16
21import Data.Bits
22import Data.Hashable
23import Data.Bits.ByteString ()
24import Data.Word
25import Data.Data
26import Data.Ord
27import Data.Serialize
28import Foreign.Ptr
29import Foreign.Marshal.Alloc
30import System.Endian
31import Foreign.Storable
32import GHC.TypeLits
33import Data.Tuple
34
35newtype Auth = Auth Poly1305.Auth
36 deriving (Eq, ByteArrayAccess)
37
38instance Ord Auth where
39 compare (Auth a) (Auth b) = comparing (BA.convert :: Poly1305.Auth -> Bytes) a b
40
41instance Data Auth where
42 gfoldl k z x = z x
43
44 -- Well, this is a little wonky... XXX
45 gunfold k z c = k (z (Auth . Poly1305.Auth . (BA.convert :: ByteString -> Bytes)))
46
47 toConstr _ = con_Auth
48
49 dataTypeOf _ = mkDataType "ToxMessage" [con_Auth]
50
51con_Auth :: Constr
52con_Auth = mkConstr (dataTypeOf (Auth (error "con_Auth"))) "Auth" [] Prefix
53
54instance Serialize Auth where
55 get = Auth . Poly1305.Auth . BA.convert <$> getBytes 16
56 put (Auth (Poly1305.Auth bs)) = putByteString $ BA.convert bs
57--
58-- | An 'Aliased' 'PubKey' is one that is not the DHT key and so should not go
59-- into the kademlia routing table buckets.
60--
61-- Note: This includes the long-term tox-id key that humans use to friend each
62-- other and is often refered to as your "real public key" by the Tox
63-- documents. For the purposes of the DHT, it is an alias.
64newtype Aliased a = Aliased a
65 deriving (Eq,Ord,Show,Data,Functor,Foldable,Traversable)
66
67newtype Nonce24 = Nonce24 ByteString
68 deriving (Eq, Ord, ByteArrayAccess,Data)
69
70quoted :: ShowS -> ShowS
71quoted shows s = '"':shows ('"':s)
72
73bin2hex :: ByteArrayAccess bs => bs -> String
74bin2hex = C8.unpack . Base16.encode . BA.convert
75
76instance Show Nonce24 where
77 showsPrec d nonce = quoted (mappend $ bin2hex nonce)
78
79instance Serialize Nonce24 where
80 get = Nonce24 <$> getBytes 24
81 put (Nonce24 bs) = putByteString bs
82
83newtype Nonce8 = Nonce8 Word64
84 deriving (Eq, Ord, Data, Serialize)
85
86instance ByteArrayAccess Nonce8 where
87 length _ = 8
88 withByteArray (Nonce8 w64) kont =
89 allocaBytes 8 $ \p -> do
90 poke (castPtr p :: Ptr Word64) $ toBE64 w64
91 kont p
92
93instance Show Nonce8 where
94 showsPrec d nonce = quoted (mappend $ bin2hex nonce)
95
96
97
98
99-- TODO: This should probably be represented by Curve25519.PublicKey, but
100-- ByteString has more instances...
101newtype PubKey = PubKey ByteString
102 deriving (Eq,Ord,Data, ByteArrayAccess, Bits, Hashable)
103
104instance Serialize PubKey where
105 get = PubKey <$> getBytes 32
106 put (PubKey bs) = putByteString bs
107
108instance Show PubKey where
109 show (PubKey bs) = C8.unpack $ Base16.encode bs
110
111instance FiniteBits PubKey where
112 finiteBitSize _ = 256
113
114instance Read PubKey where
115 readsPrec _ str
116 | (bs, xs) <- Base16.decode $ C8.pack str
117 , B.length bs == 32
118 = [ (PubKey bs, drop 64 str) ]
119 | otherwise = []
120
121
122
123-- | A chunk of data encrypted with public-key cryptography.
124data ImplicitAssymetric = ImplicitAssymetric
125 { assymetricAuth :: Auth
126 , assymetricBytes :: ByteString
127 }
128 deriving (Eq, Ord,Data)
129
130getRemaining :: Get ByteString
131getRemaining = remaining >>= getBytes
132
133instance Serialize ImplicitAssymetric where
134 get = ImplicitAssymetric <$> get <*> getRemaining
135 put (ImplicitAssymetric auth bs) = put auth >> putByteString bs
136
137-- | Like ImplicitAssymetric, but includes the nonce used to encrypt.
138data UnclaimedAssymetric = UnclaimedAssymetric
139 { assymetricNonce :: Nonce24
140 , assymetricData :: !ImplicitAssymetric
141 }
142 deriving (Eq, Ord, Data)
143
144instance Serialize UnclaimedAssymetric where
145 get = UnclaimedAssymetric <$> get <*> get
146 put (UnclaimedAssymetric nonce dta) = put nonce >> put dta
147
148-- | Like UnclaimedAssymetric, but includes the public key of the sender.
149data Assymetric = Assymetric
150 { senderKey :: PubKey
151 , sent :: !UnclaimedAssymetric
152 }
153 deriving (Eq, Ord,Data)
154
155-- get requires isolate.
156-- sender key, then nonce
157instance Serialize Assymetric where
158 get = Assymetric <$> get <*> get
159 put (Assymetric key dta) = put key >> put dta
160
161-- Aliased packets have the sender key and nonce reversed.
162instance Serialize (Aliased Assymetric) where
163 get = do
164 nonce <- get
165 key <- get
166 dta <- get
167 return $ Aliased (Assymetric key (UnclaimedAssymetric nonce dta))
168
169 put (Aliased (Assymetric key (UnclaimedAssymetric nonce dta))) = do
170 put nonce
171 put key
172 put dta
173
174
175newtype Cookie = Cookie UnclaimedAssymetric
176 deriving (Eq, Ord,Data)
177
178newtype ReturnPath (n::Nat) = ReturnPath ByteString
179 deriving (Eq, Ord,Data)
180
181emptyReturnPath :: ReturnPath 0
182emptyReturnPath = ReturnPath B.empty
183
184instance KnownNat n => Serialize (ReturnPath n) where
185 -- Size: 59 = 1(family) + 16(ip) + 2(port) +16(mac) + 24(nonce)
186 get = ReturnPath <$> getBytes ( 59 * (fromIntegral $ natVal $ Proxy @n) )
187 put (ReturnPath bs) = putByteString bs
188
189data Symmetric = Symmetric
190 { symmetricNonce :: Nonce24
191 , symmetricAuth :: Auth
192 , symmetricBytes :: ByteString
193 }
194 deriving (Eq, Ord,Data)
195
196-- Test run histogram:
197-- 377 PongType
198-- 387 DataRequestType
199-- 3238 PingType
200-- 9231 DHTRequestType
201-- 10299 PacketKind 130
202-- 12626 PacketKind 129
203-- 16596 OnionRequest0
204-- 16742 SendNodesType
205-- 41877 Announce
206-- 81793 GetNodesType
207data Packet where
208 Ping :: Assymetric -> Packet -- 0x00 -- Assymetric query
209 Pong :: Assymetric -> Packet -- 0x01 -- Assymetric response
210
211 GetNodes :: Assymetric -> Packet -- 0x02 -- Assymetric query
212 SendNodes :: Assymetric -> Packet -- 0x04 -- Assymetric response
213
214 CookieRequest :: Assymetric -> Packet -- 0x18
215 CookieResponse :: UnclaimedAssymetric -> Packet -- 0x19
216
217 OnionRequest0 :: Assymetric -> Packet -- 0x80
218
219
220 CryptoHandshake :: Cookie -> UnclaimedAssymetric -> Packet -- 0x1a
221
222 CryptoData :: Word16 -> ImplicitAssymetric -> Packet -- 0x1b
223
224 DHTRequest :: PubKey -> Assymetric -> Packet -- 0x20 -- Sometimes Assymetric query
225
226 DataToRoute :: PubKey -> Aliased Assymetric -> ReturnPath 3 -> Packet
227 DataToRouteResponse :: Aliased Assymetric -> Packet
228
229 LanDiscovery :: PubKey -> Packet -- 0x21
230
231 OnionRequest1 :: Aliased Assymetric -> Symmetric -> Packet -- 0x81
232 OnionRequest2 :: Aliased Assymetric -> Symmetric -> Packet -- 0x82
233
234 OnionRequest3 :: ByteString -> Symmetric -> Packet -- 0x82
235
236 Announce :: Aliased Assymetric -> ReturnPath 3 -> Packet --0x83
237 AnnounceResponse :: Nonce8 -> UnclaimedAssymetric -> Packet -- 0x84
238
239 OnionResponse3 :: ReturnPath 3 -> Packet -> Packet -- 0x8c
240 OnionResponse2 :: Symmetric -> ByteString -> Packet -- 0x8d
241 OnionResponse1 :: Symmetric -> ByteString -> Packet -- 0x8e
242
243
244 GetBootstrapInfo :: ByteString -> Packet -- 0xf0 + 77 bytes -- ByteString query
245 BootstrapInfo :: Word32 -> ByteString -> Packet -- 0xf0 + version + (256 byte motd) -- ByteSTring response
246
247 deriving (Eq, Ord,Data)
248
249class KnownNat n => OnionPacket n where
250 mkOnion :: ReturnPath n -> Packet -> Packet
251
252instance OnionPacket 0 where mkOnion _ = id
253instance OnionPacket 3 where mkOnion = OnionResponse3
254
255newtype PacketKind = PacketKind Word8
256 deriving (Eq, Ord, Serialize)
257
258-- TODO: Auth fail:
259pattern OnionRequest0Type = PacketKind 128 -- 0x80 Onion Request 0
260pattern OnionRequest1Type = PacketKind 129 -- 0x81 Onion Request 1
261pattern OnionRequest2Type = PacketKind 130 -- 0x82 Onion Request 2
262pattern AnnounceType = PacketKind 131 -- 0x83 Announce Request
263pattern AnnounceResponseType = PacketKind 132 -- 0x84 Announce Response
264
265pattern DataRequestType = PacketKind 133 -- 0x85 Onion Data Request (data to route request packet)
266pattern DataResponseType = PacketKind 134 -- 0x86 Onion Data Response (data to route response packet)
267-- 0x8c Onion Response 3
268-- 0x8d Onion Response 2
269pattern OnionResponse3Type = PacketKind 140 -- 0x8c Onion Response 3
270pattern OnionResponse2Type = PacketKind 141 -- 0x8d Onion Response 2
271pattern OnionResponse1Type = PacketKind 142 -- 0x8e Onion Response 1
272-- 0xf0 Bootstrap Info
273
274-- TODO Fix these fails...
275-- GetNodesType decipherAndAuth: auth fail
276-- MessageType 128 decipherAndAuth: auth fail
277-- MessageType 129 decipherAndAuth: auth fail
278-- MessageType 130 decipherAndAuth: auth fail
279-- MessageType 131 decipherAndAuth: auth fail
280-- MessageType 32 decipherAndAuth: auth fail
281
282-- TODO: Auth fail:
283pattern DHTRequestType = PacketKind 32 -- 0x20 DHT Request
284
285pattern PingType = PacketKind 0 -- 0x00 Ping Request
286pattern PongType = PacketKind 1 -- 0x01 Ping Response
287pattern GetNodesType = PacketKind 2 -- 0x02 Nodes Request
288pattern SendNodesType = PacketKind 4 -- 0x04 Nodes Response
289
290
291instance Show PacketKind where
292 showsPrec d PingType = mappend "PingType"
293 showsPrec d PongType = mappend "PongType"
294 showsPrec d GetNodesType = mappend "GetNodesType"
295 showsPrec d SendNodesType = mappend "SendNodesType"
296 showsPrec d DHTRequestType = mappend "DHTRequestType"
297 showsPrec d OnionRequest0Type = mappend "OnionRequest0"
298 showsPrec d OnionResponse1Type = mappend "OnionResponse1"
299 showsPrec d OnionResponse3Type = mappend "OnionResponse3"
300 showsPrec d AnnounceType = mappend "Announce"
301 showsPrec d AnnounceResponseType = mappend "AnnounceResponse"
302 showsPrec d DataRequestType = mappend "DataRequestType"
303 showsPrec d DataResponseType = mappend "DataResponseType"
304 showsPrec d (PacketKind x) = mappend "PacketKind " . showsPrec (d+1) x
305
306pktKind :: Packet -> PacketKind
307
308-- These are (Assymetric -> Assymetric) queries.
309pktKind Ping {} = PacketKind 0x00
310pktKind Pong {} = PacketKind 0x01
311pktKind GetNodes {} = PacketKind 0x02
312pktKind SendNodes {} = PacketKind 0x04
313
314
315-- This is a (Assymetric -> UnclaimedAssymetric) query
316pktKind CookieRequest {} = PacketKind 0x18
317pktKind CookieResponse {} = PacketKind 0x19
318
319-- Query (Assymetric -> (Nonce8,UnclaimedAssymetric))
320pktKind Announce {} = PacketKind 0x83
321pktKind AnnounceResponse {} = PacketKind 0x84
322
323-- Query (Assymetric -> ByteString)
324pktKind OnionRequest0 {} = PacketKind 0x80
325
326
327-- This is a (ByteString -> ByteString) query
328pktKind GetBootstrapInfo {} = PacketKind 0xf0
329pktKind BootstrapInfo {} = PacketKind 0xf0
330
331
332-- Trigering event. No direct response. (PubKey -> ())
333pktKind LanDiscovery {} = PacketKind 0x21
334
335-- Two cases:
336-- Half-established: (Cookie,UnclaimedAssymetric) -> (Cookie,UnclaimedAssymetric)
337-- Session established: (Cookie,UnclaimedAssymetric) -> (Word16,ImplicitAssymetric)
338pktKind CryptoHandshake {} = PacketKind 0x1a
339
340-- Session data, no direct response.
341-- (reponse to CryptoHandshake, or other data)
342pktKind CryptoData {} = PacketKind 0x1b
343
344-- Two cases:
345-- ( (PubKey, Assymetric) -> response )
346-- ( (PubKey, Assymetric) -> () )
347pktKind DHTRequest {} = PacketKind 0x20
348
349
350-- Query ( (PubKey,Aliased Assymetric) -> Aliased Assymetric)
351pktKind DataToRoute {} = PacketKind 0x85
352pktKind DataToRouteResponse {} = PacketKind 0x86
353
354-- 3 Queries ( (Aliased Assymetric, Symmetric )
355-- -> ( Symmetric, ByteString ) )
356pktKind OnionRequest1 {} = PacketKind 0x81
357pktKind OnionResponse1 {} = PacketKind 0x8e
358
359pktKind OnionRequest2 {} = PacketKind 0x82
360pktKind OnionResponse2 {} = PacketKind 0x8d
361
362pktKind OnionRequest3 {} = PacketKind 0x82
363pktKind OnionResponse3 {} = PacketKind 0x8c
364
365data PacketClass =
366 AssymetricClass (Assymetric -> Packet) (Packet -> Assymetric)
367 | forall n. OnionPacket n => AliasedClass ((Aliased Assymetric,ReturnPath n) -> Packet) (Packet -> (Aliased Assymetric,ReturnPath n))
368 | forall n. OnionPacket n => ToRouteClass ((PubKey,(Aliased Assymetric,ReturnPath n)) -> Packet) (Packet -> (PubKey,(Aliased Assymetric,ReturnPath n)))
369 | forall n. OnionPacket n => OnionClass ((Packet,ReturnPath n) -> Packet) (Packet -> (Packet,ReturnPath n))
370 | NoncedUnclaimedClass (Nonce8 -> UnclaimedAssymetric -> Packet)
371 (Packet -> (Nonce8, UnclaimedAssymetric))
372 | Unclassified
373{-
374data Packet' where
375 :: Assymetric -> Packet
376 :: UnclaimedAssymetric -> Packet
377 :: Word16 -> ImplicitAssymetric -> Packet
378 :: PubKey -> Assymetric -> Packet
379 :: PubKey -> Packet
380 :: Aliased Assymetric -> Symmetric -> Packet
381 :: ByteString -> Symmetric -> Packet
382 :: Aliased Assymetric -> Packet
383 :: Symmetric -> ByteString -> Packet
384 :: ByteString -> Packet
385 :: Word32 -> ByteString -> Packet
386-}
387
388pktClass :: PacketKind -> PacketClass
389pktClass (PacketKind 0) = AssymetricClass Ping (\(Ping a) -> a)
390pktClass (PacketKind 1) = AssymetricClass Pong (\(Pong a) -> a)
391pktClass (PacketKind 2) = AssymetricClass GetNodes (\(GetNodes a) -> a)
392pktClass (PacketKind 4) = AssymetricClass SendNodes (\(SendNodes a) -> a)
393
394pktClass (PacketKind 0x18) = AssymetricClass CookieRequest (\(CookieRequest a) -> a)
395pktClass (PacketKind 0x80) = AssymetricClass OnionRequest0 (\(OnionRequest0 a) -> a)
396pktClass (PacketKind 0x86) = AssymetricClass (DataToRouteResponse . Aliased) (\(DataToRouteResponse (Aliased a)) -> a)
397
398pktClass (PacketKind 0x83) = AliasedClass (uncurry Announce) (\(Announce a r)-> (a,r))
399pktClass (PacketKind 0x84) = NoncedUnclaimedClass AnnounceResponse (\(AnnounceResponse n8 uncl)-> (n8,uncl))
400
401pktClass (PacketKind 0x8c) = OnionClass (uncurry OnionResponse3 . swap) (\(OnionResponse3 r a)-> (a,r))
402
403pktClass DataRequestType = ToRouteClass (\(k,(a,r))-> DataToRoute k a r)
404 (\(DataToRoute k a r) -> (k,(a,r)))
405
406pktClass _ = Unclassified
407
408
409instance Serialize Packet where
410 get = getPacket
411 put = putPacket
412
413getPacket :: Get Packet
414getPacket = do
415 typ <- get
416 case pktClass typ of
417 AssymetricClass toPacket _ -> toPacket <$> get
418 AliasedClass toPacket _ -> do
419 trace ("PARSE "++show typ) $ return ()
420 cnt <- remaining
421 a <- isolate (cnt - 59*3) get
422 r <- get
423 trace ("PARSED "++show typ) $ return ()
424 return $ toPacket (a,r)
425 ToRouteClass toPacket _ -> do
426 trace ("R-PARSE "++show typ) $ return ()
427 cnt <- remaining
428 (pub,a) <- isolate (cnt - 59*3) get
429 r <- get
430 trace ("R-PARSED "++show typ) $ return ()
431 return $ toPacket (pub,(a,r))
432 OnionClass toPacket _ -> do
433 trace ("ONION-PARSE "++show typ) $ return ()
434 p <- get
435 trace ("ONION-PARSED "++show typ) $ return ()
436 return $ toPacket p
437 NoncedUnclaimedClass toPacket _ -> toPacket <$> get <*> get
438 Unclassified -> fail $ "todo: unserialize packet "++show typ
439
440putPacket :: Packet -> PutM ()
441putPacket p = do
442 put $ pktKind p
443 case pktClass (pktKind p) of
444 AssymetricClass _ fromPacket -> put $ fromPacket p
445 AliasedClass _ fromPacket -> put $ fromPacket p
446 ToRouteClass _ fromPacket -> put $ fromPacket p
447 OnionClass _ fromPacket -> put $ swap $ fromPacket p
448 NoncedUnclaimedClass _ fromPacket -> put $ fromPacket p -- putting a pair.
449 Unclassified -> fail $ "todo: serialize packet "++show (pktKind p)
450
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-22 11:38:57 +0000