summaryrefslogtreecommitdiff
path: root/src/Data/Tox.hs
blob: b79e0b9acc71c638653b37400c3dc89fe1f3405d (plain)
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
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE DeriveTraversable     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms       #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UnboxedTuples         #-}
module Data.Tox where

import Data.Bits
import Data.ByteString (ByteString)
import Data.Data (Data)
import Data.Word
import Data.LargeWord
import Data.IP
import Data.Serialize
-- import Network.BitTorrent.Address (NodeInfo(..)) -- Serialize IP
import GHC.Generics (Generic)
import Network.Socket
import Network.DatagramServer.Types
import qualified Network.DatagramServer.Types as Envelope (NodeId)
import Crypto.PubKey.ECC.Types

type Key32   = Word256 -- 32 byte key
type Nonce8  = Word64  -- 8 bytes
type Nonce24 = Word192 -- 24 bytes


data NodeFormat  = NodeFormat
    { nodePublicKey :: Key32 -- 32 byte public key
    , nodeIsTCP :: Bool -- This has no analog in mainline NodeInfo structure
    , nodeIP :: IP -- IPv4 or IPv6  address
    , nodePort :: PortNumber
    }
 deriving (Eq, Ord, Show)

encodeFamily :: (Family, SocketType) -> Word8
encodeFamily (AF_INET   , Datagram) = 2
encodeFamily (AF_INET6  , Datagram) = 10
encodeFamily (AF_INET   , Stream  ) = 130
encodeFamily (AF_INET6  , Stream  ) = 138
encodeFamily _ = error "Unsupported protocol"

newtype MessageType = MessageType Word8
 deriving (Eq, Ord, Show, Read)

instance Serialize MessageType where
    put (MessageType b) = put b
    get = MessageType <$> get

pattern Ping      = MessageType 0
pattern Pong      = MessageType 1
pattern GetNodes  = MessageType 2
pattern SendNodes = MessageType 4
{-
 #define NET_PACKET_PING_REQUEST    0   /* Ping request packet ID. */
 #define NET_PACKET_PING_RESPONSE   1   /* Ping response packet ID. */
 #define NET_PACKET_GET_NODES       2   /* Get nodes request packet ID. */
 #define NET_PACKET_SEND_NODES_IPV6 4   /* Send nodes response packet ID for other addresses. */
 #define NET_PACKET_COOKIE_REQUEST  24  /* Cookie request packet */
 #define NET_PACKET_COOKIE_RESPONSE 25  /* Cookie response packet */
 #define NET_PACKET_CRYPTO_HS       26  /* Crypto handshake packet */
 #define NET_PACKET_CRYPTO_DATA     27  /* Crypto data packet */
 #define NET_PACKET_CRYPTO          32  /* Encrypted data packet ID. */
 #define NET_PACKET_LAN_DISCOVERY   33  /* LAN discovery packet ID. */

 /* See:  docs/Prevent_Tracking.txt and onion.{c, h} */
 #define NET_PACKET_ONION_SEND_INITIAL 128
 #define NET_PACKET_ONION_SEND_1 129
 #define NET_PACKET_ONION_SEND_2 130

 #define NET_PACKET_ANNOUNCE_REQUEST 131
 #define NET_PACKET_ANNOUNCE_RESPONSE 132
 #define NET_PACKET_ONION_DATA_REQUEST 133
 #define NET_PACKET_ONION_DATA_RESPONSE 134

 #define NET_PACKET_ONION_RECV_3 140
 #define NET_PACKET_ONION_RECV_2 141
 #define NET_PACKET_ONION_RECV_1 142
 -}


-- FIXME Orphan Serialize intance for large words
instance (Serialize a, Serialize b) => Serialize (LargeKey a b) where
   put (LargeKey lo hi) = put hi >> put lo
   get = flip LargeKey <$> get <*> get

-- | Use with 'PingPayload', 'GetNodesPayload', or 'SendNodesPayload'
data Message a = Message
    { msgType    :: MessageType
    , msgClient  :: NodeId Message
    , msgNonce   :: Nonce24
    , msgPayload :: a
    }
 deriving (Show, Generic, Functor, Foldable, Traversable)

deriving instance Show (NodeId Message) -- TODO: print as hex

isQuery :: Message a -> Bool
isQuery (Message { msgType = SendNodes })                  = False
isQuery (Message { msgType = MessageType typ }) | even typ = True
isQuery _                                                  = False

isResponse :: Message a -> Bool
isResponse m = not (isQuery m)

isError :: Message a -> Bool
isError _ = False

data PingPayload = PingPayload
    { isPong :: Bool
    , pingId :: Nonce8
    }

data GetNodesPayload = GetNodesPayload
    { nodesForWho :: NodeId Message
    , nodesNonce :: Nonce8
    }

data SendNodesPayload = SendNodesPayload

-- From: docs/updates/DHT.md
--
-- Node format:
-- [uint8_t family (2 == IPv4, 10 == IPv6, 130 == TCP IPv4, 138 == TCP IPv6)]
-- [ip (in network byte order), length=4 bytes if ipv4, 16 bytes if ipv6]
-- [port (in network byte order), length=2 bytes]
-- [char array (node_id), length=32 bytes]
--
-- see also: DHT.h (pack_nodes() and unpack_nodes())
instance Serialize NodeFormat where

    get = do
        typ <- get :: Get Word8
        (ip,istcp) <-
            case typ :: Word8 of
                2   -> (,False) . IPv4 <$> get
                130 -> (,True) . IPv4 <$> get
                10  -> (,False) . IPv6 <$> get
                138 -> (,True) . IPv6 <$> get
                _   -> fail "Unsupported type of Tox node_format structure"
        port <- get
        pubkey <- get
        return $ NodeFormat { nodeIsTCP     = istcp
                            , nodeIP        = ip
                            , nodePort      = port
                            , nodePublicKey = pubkey
                            }

    put (NodeFormat{..}) = do
        put $ case (# nodeIP, nodeIsTCP #) of
                (# IPv4 _, False #) -> 2
                (# IPv4 _, True  #) -> 130
                (# IPv6 _, False #) -> 10
                (# IPv6 _, True  #) -> 138 :: Word8
        put nodeIP
        put nodePort
        put nodePublicKey

-- Note: the char array is a public key, the 32-bytes is provided by libsodium-dev
-- in /usr/include/sodium/crypto_box.h as the symbol crypto_box_PUBLICKEYBYTES
-- but toxcore/crypto_core.c will fail to compile if it is not 32.


-- Ping(Request and response):
--
-- [byte with value: 00 for request, 01 for response]
-- [char array (client node_id), length=32 bytes]
-- [random 24 byte nonce]
-- [Encrypted with the nonce and private key of the sender:
--   [1 byte type (0 for request, 1 for response)]
--   [random 8 byte (ping_id)]
--   ]
--
-- ping_id = a random integer, the response must contain the exact same number as the request


-- Get nodes (Request):
--
-- [byte with value: 02]
-- [char array (client node_id), length=32 bytes]
-- [random 24 byte nonce]
-- [Encrypted with the nonce and private key of the sender:
--   [char array: requested_node_id (node_id of which we want the ip), length=32 bytes]
--   [Sendback data (must be sent back unmodified by in the response), length=8 bytes]
--   ]
--
-- Valid replies: a send_nodes packet

-- Send_nodes (response (for all addresses)):
--
-- [byte with value: 04]
-- [char array  (client node_id), length=32 bytes]
-- [random 24 byte nonce]
-- [Encrypted with the nonce and private key of the sender:
--   [uint8_t number of nodes in this packet]
--   [Nodes in node format, length=?? * (number of nodes (maximum of 4 nodes)) bytes]
--   [Sendback data, length=8 bytes]
--   ]

data ToxCipherContext = ToxCipherContext -- TODO

newtype Ciphered = Ciphered { cipheredBytes :: ByteString }

getMessage :: Get (Message Ciphered)
getMessage = do
        typ <- get
        nid <- get
        tid <- get
        cnt <- remaining
        bs <- getBytes cnt
        return Message { msgType = typ
                       , msgClient = nid
                       , msgNonce = tid
                       , msgPayload = Ciphered bs }

putMessage :: Message Ciphered -> Put
putMessage (Message {..}) = do
        put msgType
        put msgClient
        put msgNonce
        let Ciphered bs = msgPayload
        putByteString bs

decipher :: ToxCipherContext -> Message Ciphered -> Either String (Message ByteString)
decipher = error "TODO TOX: decipher"

encipher :: ToxCipherContext -> Message ByteString -> Message Ciphered
encipher = error "TODO TOX: encipher"

-- see rfc7748
curve25519 :: Curve
curve25519 = CurveFP (CurvePrime prime curvecommon)
 where
    prime = 2^255 - 19 -- (≅ 1 modulo 4)

    -- 1 * v^2 = u^3 + 486662*u^2 + u

    curvecommon = CurveCommon
        { ecc_a = 486662
        , ecc_b = 1
        , ecc_g = Point 9 14781619447589544791020593568409986887264606134616475288964881837755586237401 -- base point
        , ecc_n = 2^252 + 0x14def9dea2f79cd65812631a5cf5d3ed -- order
        , ecc_h = 8 -- cofactor
        }



instance Envelope Message where
    type TransactionID Message = Nonce24
    newtype NodeId Message = NodeId Word256
        deriving (Serialize, Eq, Ord, Bits, FiniteBits)

    envelopePayload = msgPayload

    envelopeTransaction = msgNonce

    envelopeClass Message { msgType = Ping      } = Query
    envelopeClass Message { msgType = Pong      } = Response
    envelopeClass Message { msgType = GetNodes  } = Query
    envelopeClass Message { msgType = SendNodes } = Response

    buildReply self addr qry payload = (fmap (const payload) qry) { msgClient = self }

instance WireFormat ByteString Message where
    type SerializableTo ByteString = Serialize
    type CipherContext ByteString Message = ToxCipherContext

    decodePayload = mapM decode
    encodePayload = fmap encode

    decodeHeaders ctx bs = runGet getMessage bs >>= decipher ctx
    encodeHeaders ctx msg = runPut $ putMessage $ encipher ctx msg