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
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
|
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Tox where
import Control.Arrow
import Control.Concurrent.STM
import qualified Crypto.Cipher.Salsa as Salsa
import qualified Crypto.Cipher.XSalsa as XSalsa
import Crypto.ECC.Class
import qualified Crypto.Error as Cryptonite
import Crypto.Error.Types
import qualified Crypto.MAC.Poly1305 as Poly1305
import Crypto.PubKey.Curve25519
import Crypto.PubKey.ECC.Types
import Crypto.Random
import Data.Bool
import qualified Data.ByteArray as BA
;import Data.ByteArray (ByteArrayAccess,Bytes)
import qualified Data.ByteString as B
;import Data.ByteString (ByteString)
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Char8 as C8
import Data.ByteString.Lazy (toStrict)
import Data.Data
import Data.IP
import Data.Maybe
import Data.Monoid
import qualified Data.Serialize as S
import Data.Typeable
import Data.Word
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import GHC.Generics (Generic)
import Network.Address (Address, fromSockAddr, sockAddrPort,
toSockAddr, setPort,un4map)
import Network.QueryResponse
import Network.Socket
import System.Endian
import Data.Hashable
import Data.Bits
import Data.Bits.ByteString ()
import qualified Text.ParserCombinators.ReadP as RP
import Data.Char
newtype NodeId = NodeId ByteString
deriving (Eq,Ord,ByteArrayAccess, Bits)
instance Show NodeId where
show (NodeId bs) = C8.unpack $ Base16.encode bs
instance S.Serialize NodeId where
get = NodeId <$> S.getBytes 32
put (NodeId bs) = S.putByteString bs
instance FiniteBits NodeId where
finiteBitSize _ = 256
instance Read NodeId where
readsPrec _ str
| (bs, xs) <- Base16.decode $ C8.pack str
, B.length bs == 32
= [ (NodeId bs, drop 40 str) ]
| otherwise = []
zeroID :: NodeId
zeroID = NodeId $ B.replicate 32 0
data NodeInfo = NodeInfo
{ nodeId :: NodeId
, nodeIP :: IP
, nodePort :: PortNumber
}
deriving (Eq,Ord)
instance S.Serialize NodeInfo where
get = do
nid <- S.get
addrfam <- S.get :: S.Get Word8
ip <- case addrfam of
2 -> IPv4 <$> S.get
10 -> IPv6 <$> S.get
130 -> IPv4 <$> S.get -- TODO: TCP
138 -> IPv6 <$> S.get -- TODO: TCP
_ -> fail "unsupported address family"
port <- S.get :: S.Get PortNumber
return $ NodeInfo nid ip port
put (NodeInfo nid ip port) = do
S.put nid
case ip of
IPv4 ip4 -> S.put (2 :: Word8) >> S.put ip4
IPv6 ip6 -> S.put (10 :: Word8) >> S.put ip6
S.put port
-- 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]
--
hexdigit :: Char -> Bool
hexdigit c = ('0' <= c && c <= '9') || ( 'a' <= c && c <= 'f') || ( 'A' <= c && c <= 'F')
instance Read NodeInfo where
readsPrec i = RP.readP_to_S $ do
RP.skipSpaces
let n = 64 -- characters in node id.
parseAddr = RP.between (RP.char '(') (RP.char ')') (RP.munch (/=')'))
RP.+++ RP.munch (not . isSpace)
nodeidAt = do hexhash <- sequence $ replicate n (RP.satisfy hexdigit)
RP.char '@' RP.+++ RP.satisfy isSpace
addrstr <- parseAddr
nid <- case Base16.decode $ C8.pack hexhash of
(bs,_) | B.length bs==32 -> return (NodeId bs)
_ -> fail "Bad node id."
return (nid,addrstr)
(nid,addrstr) <- ( nodeidAt RP.+++ ( (zeroID,) <$> parseAddr) )
let raddr = do
ip <- RP.between (RP.char '[') (RP.char ']')
(IPv6 <$> RP.readS_to_P (readsPrec i))
RP.+++ (IPv4 <$> RP.readS_to_P (readsPrec i))
_ <- RP.char ':'
port <- toEnum <$> RP.readS_to_P (readsPrec i)
return (ip, port)
(ip,port) <- case RP.readP_to_S raddr addrstr of
[] -> fail "Bad address."
((ip,port),_):_ -> return (ip,port)
return $ NodeInfo nid ip port
-- The Hashable instance depends only on the IP address and port number.
instance Hashable NodeInfo where
hashWithSalt s ni = hashWithSalt s (nodeIP ni , nodePort ni)
{-# INLINE hashWithSalt #-}
instance Show NodeInfo where
showsPrec _ (NodeInfo nid ip port) =
shows nid . ('@' :) . showsip . (':' :) . shows port
where
showsip
| IPv4 ip4 <- ip = shows ip4
| IPv6 ip6 <- ip , Just ip4 <- un4map ip6 = shows ip4
| otherwise = ('[' :) . shows ip . (']' :)
nodeAddr :: NodeInfo -> SockAddr
nodeAddr (NodeInfo _ ip port) = setPort port $ toSockAddr ip
nodeInfo :: NodeId -> SockAddr -> Either String NodeInfo
nodeInfo nid saddr
| Just ip <- fromSockAddr saddr
, Just port <- sockAddrPort saddr = Right $ NodeInfo nid ip port
| otherwise = Left "Address family not supported."
data TransactionId = TransactionId
{ transactionKey :: Nonce8 -- ^ Used to lookup pending query.
, cryptoNonce :: Nonce24 -- ^ Used during the encryption layer.
}
newtype Method = MessageType Word8
deriving (Eq, Ord, S.Serialize)
pattern PingType = MessageType 0
pattern PongType = MessageType 1
pattern GetNodesType = MessageType 2
pattern SendNodesType = MessageType 4
instance Show Method where
showsPrec d PingType = mappend "PingType"
showsPrec d PongType = mappend "PongType"
showsPrec d GetNodesType = mappend "GetNodesType"
showsPrec d SendNodesType = mappend "SendNodesType"
showsPrec d (MessageType x) = mappend "MessageType " . showsPrec (d+1) x
newtype Nonce8 = Nonce8 Word64
deriving (Eq, Ord)
instance ByteArrayAccess Nonce8 where
length _ = 8
withByteArray (Nonce8 w64) kont =
allocaBytes 8 $ \p -> do
poke (castPtr p :: Ptr Word64) $ toBE64 w64
kont p
instance Show Nonce8 where
showsPrec d nonce = quoted (mappend $ bin2hex nonce)
newtype Nonce24 = Nonce24 ByteString
deriving (Eq, Ord, ByteArrayAccess)
instance Show Nonce24 where
showsPrec d nonce = quoted (mappend $ bin2hex nonce)
instance S.Serialize Nonce24 where
get = Nonce24 <$> S.getBytes 24
put (Nonce24 bs) = S.putByteString bs
quoted :: ShowS -> ShowS
quoted shows s = '"':shows ('"':s)
bin2hex :: ByteArrayAccess bs => bs -> String
bin2hex = C8.unpack . Base16.encode . BA.convert
data Message a = Message
{ msgType :: Method
, msgOrigin :: NodeId
, msgNonce :: Nonce24 -- cryptoNonce of TransactionId
, msgPayload :: a
}
deriving (Eq, Show, Generic, Functor, Foldable, Traversable)
data Ciphered = Ciphered { cipheredMAC :: Poly1305.Auth
, cipheredBytes :: ByteString }
deriving Eq
getMessage :: S.Get (Message Ciphered)
getMessage = do
typ <- S.get
nid <- S.get
tid <- S.get
mac <- Poly1305.Auth . BA.convert <$> S.getBytes 16
cnt <- S.remaining
bs <- S.getBytes cnt
return Message { msgType = typ
, msgOrigin = nid
, msgNonce = tid
, msgPayload = Ciphered mac bs }
putMessage :: Message Ciphered -> S.Put
putMessage (Message {..}) = do
S.put msgType
S.put msgOrigin
S.put msgNonce
let Ciphered (Poly1305.Auth mac) bs = msgPayload
S.putByteString (BA.convert mac)
S.putByteString bs
{-
data Plain a = Plain
{ plainId :: Nonce8 -- transactionKey of TransactionId
, plainPayload :: a
}
deriving (Eq, Show, Generic, Functor, Foldable, Traversable)
instance Serialize a => Serialize (Plain a) where
get = flip Plain <$> get get
put (Plain tid a) = put a >> put tid
-}
-- TODO: Cache symmetric keys.
data SecretsCache = SecretsCache
newEmptyCache = return SecretsCache
id2key :: NodeId -> PublicKey
id2key recipient = case publicKey recipient of
CryptoPassed key -> key
-- This should never happen because a NodeId is 32 bytes.
CryptoFailed e -> error ("Unexpected pattern fail: "++show e)
key2id :: PublicKey -> NodeId
key2id pk = case S.decode (BA.convert pk) of
Left _ -> error "key2id"
Right nid -> nid
zeros32 :: Bytes
zeros32 = BA.replicate 32 0
zeros24 :: Bytes
zeros24 = BA.take 24 zeros32
hsalsa20 k n = a <> b
where
Salsa.State st = XSalsa.initialize 20 k n
(_, as) = BA.splitAt 4 st
(a, xs) = BA.splitAt 16 as
(_, bs) = BA.splitAt 24 xs
(b, _ ) = BA.splitAt 16 bs
computeSharedSecret :: SecretKey -> NodeId -> Nonce24 -> (Poly1305.State, XSalsa.State)
computeSharedSecret sk recipient nonce = (hash, crypt)
where
-- diffie helman
shared = ecdh (Proxy :: Proxy Curve_X25519) sk (id2key recipient)
-- shared secret XSalsa key
k = hsalsa20 shared zeros24
-- cipher state
st0 = XSalsa.initialize 20 k nonce
-- Poly1305 key
(rs, crypt) = XSalsa.combine st0 zeros32
-- Since rs is 32 bytes, this pattern should never fail...
Cryptonite.CryptoPassed hash = Poly1305.initialize rs
encryptMessage :: SecretKey -> SecretsCache -> NodeId -> Message ByteString -> Message Ciphered
encryptMessage sk _ recipient plaintext
= withSecret encipherAndHash sk recipient (msgNonce plaintext) <$> plaintext
decryptMessage :: SecretKey -> SecretsCache -> Message Ciphered -> Either String (Message ByteString)
decryptMessage sk _ ciphertext
= mapM (withSecret decipherAndAuth sk (msgOrigin ciphertext) (msgNonce ciphertext)) ciphertext
withSecret f sk recipient nonce x = f hash crypt x
where
(hash, crypt) = computeSharedSecret sk recipient nonce
encipherAndHash :: Poly1305.State -> XSalsa.State -> ByteString -> Ciphered
encipherAndHash hash crypt m = Ciphered a c
where
c = fst . XSalsa.combine crypt $ m
a = Poly1305.finalize . Poly1305.update hash $ c
decipherAndAuth :: Poly1305.State -> XSalsa.State -> Ciphered -> Either String ByteString
decipherAndAuth hash crypt (Ciphered mac c)
| (a == mac) = Right m
| otherwise = Left "decipherAndAuth: auth fail"
where
m = fst . XSalsa.combine crypt $ c
a = Poly1305.finalize . Poly1305.update hash $ c
-- TODO:
-- Represents the encrypted portion of a Tox packet.
-- data Payload a = Payload a !Nonce8
--
-- Generic packet type: Message (Payload ByteString)
parsePacket :: SecretKey -> SecretsCache -> ByteString -> SockAddr -> Either String (Message ByteString, NodeInfo)
parsePacket sk cache bs addr = do ciphered <- S.runGet getMessage bs
msg <- decryptMessage sk cache ciphered
ni <- nodeInfo (msgOrigin msg) addr
return (msg, ni)
encodePacket :: SecretKey -> SecretsCache -> Message ByteString -> NodeInfo -> (ByteString, SockAddr)
encodePacket sk cache msg ni = ( S.runPut . putMessage $ encryptMessage sk cache (nodeId ni) msg
, nodeAddr ni )
newClient :: SockAddr -> IO (Client String Method TransactionId NodeInfo (Message ByteString))
newClient addr = do
udp <- udpTransport addr
secret <- generateSecretKey
let pubkey = key2id $ toPublic secret
cache <- newEmptyCache
drg <- getSystemDRG
self <- atomically $ newTVar
$ NodeInfo pubkey (fromMaybe (toEnum 0) $ fromSockAddr addr)
(fromMaybe 0 $ sockAddrPort addr)
let net = layerTransport (parsePacket secret cache)
(encodePacket secret cache)
udp
dispatch tbl = DispatchMethods
{ classifyInbound = classify
, lookupHandler = handlers
, tableMethods = tbl
}
genNonce24 var (TransactionId nonce8 _) = atomically $ do
(g,pending) <- readTVar var
let (bs, g') = randomBytesGenerate 24 g
writeTVar var (g',pending)
return $ TransactionId nonce8 (Nonce24 bs)
client tbl var = Client
{ clientNet = net
, clientDispatcher = dispatch tbl
, clientErrorReporter = ignoreErrors -- TODO
, clientPending = var
, clientAddress = \maddr -> atomically (readTVar self)
, clientResponseId = genNonce24 var
}
if fitsInInt (Proxy :: Proxy Word64)
then do
let intmapT = transactionMethods (contramapT intKey intMapMethods) gen
intmap_var <- atomically $ newTVar (drg, mempty)
return (client intmapT intmap_var)
else do
let mapT = transactionMethods (contramapT nonceKey mapMethods) gen
map_var <- atomically $ newTVar (drg, mempty)
return (client mapT map_var)
last8 :: ByteString -> Nonce8
last8 bs
| let len = B.length bs
, (len >= 8)
= Nonce8 $ let bs' = B.drop (len - 8) bs
Right w = S.runGet S.getWord64be bs'
in w
| otherwise
= Nonce8 0
dropEnd8 :: ByteString -> ByteString
dropEnd8 bs = B.take (B.length bs - 8) bs
classify :: Message ByteString -> MessageClass String Method TransactionId
classify (Message { msgType = typ
, msgPayload = bs
, msgNonce = nonce24 }) = go $ TransactionId (last8 bs) nonce24
where
go = case typ of
PingType -> IsQuery PingType
GetNodesType -> IsQuery GetNodesType
PongType -> IsResponse
SendNodesType -> IsResponse
encodePayload typ (TransactionId (Nonce8 tid) nonce) self dest b
= Message { msgType = typ
, msgOrigin = nodeId self
, msgNonce = nonce
, msgPayload = S.encode b <> S.runPut (S.putWord64be tid)
}
decodePayload :: S.Serialize a => Message ByteString -> Either String a
decodePayload msg = S.decode $ dropEnd8 $ msgPayload msg
handler typ f = Just $ MethodHandler decodePayload (encodePayload typ) f
handlers :: Method -> Maybe (MethodHandler String TransactionId NodeInfo (Message ByteString))
handlers PingType = handler PingType pingH
handlers GetNodesType = error "find_node"
handlers _ = Nothing
data Ping = Ping deriving Show
data Pong = Pong deriving Show
instance S.Serialize Ping where
get = do w8 <- S.get
if (w8 :: Word8) /= 0
then fail "Malformed ping."
else return Ping
put Ping = S.put (0 :: Word8)
instance S.Serialize Pong where
get = do w8 <- S.get
if (w8 :: Word8) /= 1
then fail "Malformed pong."
else return Pong
put Pong = S.put (1 :: Word8)
newtype GetNodes = GetNodes NodeId
deriving (Eq,Ord,Show,Read,S.Serialize)
newtype SendNodes = SendNodes [NodeInfo]
deriving (Eq,Ord,Show,Read)
instance S.Serialize SendNodes where
get = do
cnt <- S.get :: S.Get Word8
ns <- sequence $ replicate (fromIntegral cnt) S.get
return $ SendNodes ns
put (SendNodes ns) = do
let ns' = take 4 ns
S.put (fromIntegral (length ns') :: Word8)
mapM_ S.put ns'
pingH :: NodeInfo -> Ping -> IO Pong
pingH _ Ping = return Pong
intKey :: TransactionId -> Int
intKey (TransactionId (Nonce8 w) _) = fromIntegral w
nonceKey :: TransactionId -> Nonce8
nonceKey (TransactionId n _) = n
-- randomBytesGenerate :: ByteArray byteArray => Int -> gen -> (byteArray, gen)
-- gen :: forall gen. DRG gen => gen -> ((Nonce8, Nonce24), gen)
gen :: SystemDRG -> (TransactionId, SystemDRG)
gen g = let (bs, g') = randomBytesGenerate 24 g
(ws, g'') = randomBytesGenerate 8 g'
Right w = S.runGet S.getWord64be ws
in ( TransactionId (Nonce8 w) (Nonce24 bs), g'' )
|