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
|
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Tox.Relay where
import Data.Aeson (ToJSON(..),FromJSON(..))
import qualified Data.Aeson as JSON
import Data.ByteString as B
import Data.Data
import Data.Functor.Contravariant
import Data.Hashable
import qualified Data.HashMap.Strict as HashMap
import Data.Monoid
import Data.Serialize
import qualified Data.Vector as Vector
import Data.Word
import Network.Socket
import qualified Rank2
import qualified Text.ParserCombinators.ReadP as RP
import Crypto.Tox
import Data.Tox.Onion
import qualified Network.Tox.NodeId as UDP
newtype ConId = ConId Word8
deriving (Eq,Show,Ord,Data,Serialize)
badcon :: ConId
badcon = ConId 0
-- Maps to a range -120 .. 119
c2key :: ConId -> Maybe Int
c2key (ConId x) | x < 16 = Nothing
| otherwise = Just $ case divMod (x - 15) 2 of
(q,0) -> negate $ fromIntegral q
(q,1) -> fromIntegral q
-- Maps to range 16 .. 255
-- negatives become odds
key2c :: Int -> ConId
key2c y = ConId $ if y < 0 then 15 + fromIntegral (negate y * 2)
else 16 + fromIntegral (y * 2)
data RelayPacket
= RoutingRequest PublicKey
| RoutingResponse ConId PublicKey -- 0 for refusal, 16-255 for success.
| ConnectNotification ConId
| DisconnectNotification ConId
| RelayPing Nonce8
| RelayPong Nonce8
| OOBSend PublicKey ByteString
| OOBRecv PublicKey ByteString
| OnionPacket Nonce24 (Addressed (Forwarding N2 (OnionMessage Encrypted))) -- (OnionRequest N0)
| OnionPacketResponse (OnionMessage Encrypted)
-- 0x0A through 0x0F reserved for future use.
| RelayData ByteString ConId
deriving (Eq,Ord,Show,Data)
newtype PacketNumber = PacketNumber { packetNumberToWord8 :: Word8 }
deriving (Eq,Ord,Show)
pattern PingPacket = PacketNumber 4
pattern OnionPacketID = PacketNumber 8
packetNumber :: RelayPacket -> PacketNumber
packetNumber (RelayData _ (ConId conid)) = PacketNumber $ conid -- 0 to 15 not allowed.
packetNumber rp = PacketNumber $ fromIntegral $ pred $ constrIndex $ toConstr rp
instance Sized RelayPacket where
size = mappend (ConstSize 1) $ VarSize $ \x -> case x of
RoutingRequest k -> 32
RoutingResponse rpid k -> 33
ConnectNotification conid -> 1
DisconnectNotification conid -> 1
RelayPing pingid -> 8
RelayPong pingid -> 8
OOBSend k bs -> 32 + B.length bs
OOBRecv k bs -> 32 + B.length bs
OnionPacket n24 query -> 24 + case contramap (`asTypeOf` query) size of
ConstSize n -> n
VarSize f -> f query
OnionPacketResponse answer -> case contramap (`asTypeOf` answer) size of
ConstSize n -> n
VarSize f -> f answer
RelayData bs _ -> B.length bs
instance Serialize RelayPacket where
get = do
pktid <- getWord8
case pktid of
0 -> RoutingRequest <$> getPublicKey
1 -> RoutingResponse <$> get <*> getPublicKey
2 -> ConnectNotification <$> get
3 -> DisconnectNotification <$> get
4 -> RelayPing <$> get
5 -> RelayPong <$> get
6 -> OOBSend <$> getPublicKey <*> (remaining >>= getBytes)
7 -> OOBRecv <$> getPublicKey <*> (remaining >>= getBytes)
8 -> OnionPacket <$> get <*> get
9 -> OnionPacketResponse <$> get
conid -> (`RelayData` ConId conid) <$> (remaining >>= getBytes)
put rp = do
putWord8 $ packetNumberToWord8 $ packetNumber rp
case rp of
RoutingRequest k -> putPublicKey k
RoutingResponse rpid k -> put rpid >> putPublicKey k
ConnectNotification conid -> put conid
DisconnectNotification conid -> put conid
RelayPing pingid -> put pingid
RelayPong pingid -> put pingid
OOBSend k bs -> putPublicKey k >> putByteString bs
OOBRecv k bs -> putPublicKey k >> putByteString bs
OnionPacket n24 query -> put n24 >> put query
OnionPacketResponse answer -> put answer
RelayData bs _ -> putByteString bs
-- | Initial client-to-server handshake message.
newtype Hello (f :: * -> *) = Hello (Asymm (f HelloData))
deriving instance Show (f HelloData) => Show (Hello f)
helloFrom :: Hello f -> PublicKey
helloFrom (Hello x) = senderKey x
helloNonce :: Hello f -> Nonce24
helloNonce (Hello x) = asymmNonce x
helloData :: Hello f -> f HelloData
helloData (Hello x) = asymmData x
instance Rank2.Functor Hello where
f <$> Hello (Asymm k n dta) = Hello $ Asymm k n (f dta)
instance Payload Serialize Hello where
mapPayload _ f (Hello (Asymm k n dta)) = Hello $ Asymm k n (f dta)
instance Rank2.Foldable Hello where
foldMap f (Hello (Asymm k n dta)) = f dta
instance Rank2.Traversable Hello where
traverse f (Hello (Asymm k n dta)) = Hello . Asymm k n <$> f dta
instance Sized (Hello Encrypted) where
size = ConstSize 56 <> contramap helloData size
instance Serialize (Hello Encrypted) where
get = Hello <$> getAsymm
put (Hello asym) = putAsymm asym
data HelloData = HelloData
{ sessionPublicKey :: PublicKey
, sessionBaseNonce :: Nonce24
}
deriving Show
instance Sized HelloData where size = ConstSize 56
instance Serialize HelloData where
get = HelloData <$> getPublicKey <*> get
put (HelloData k n) = putPublicKey k >> put n
-- | Handshake server-to-client response packet.
data Welcome (f :: * -> *) = Welcome
{ welcomeNonce :: Nonce24
, welcomeData :: f HelloData
}
deriving instance Show (f HelloData) => Show (Welcome f)
instance Rank2.Functor Welcome where
f <$> Welcome n dta = Welcome n (f dta)
instance Payload Serialize Welcome where
mapPayload _ f (Welcome n dta) = Welcome n (f dta)
instance Rank2.Foldable Welcome where
foldMap f (Welcome _ dta) = f dta
instance Rank2.Traversable Welcome where
traverse f (Welcome n dta) = Welcome n <$> f dta
instance Sized (Welcome Encrypted) where
size = ConstSize 24 <> contramap welcomeData size
instance Serialize (Welcome Encrypted) where
get = Welcome <$> get <*> get
put (Welcome n dta) = put n >> put dta
data NodeInfo = NodeInfo
{ udpNodeInfo :: UDP.NodeInfo
, tcpPort :: PortNumber
}
deriving (Eq,Ord)
instance Read NodeInfo where
readsPrec _ = RP.readP_to_S $ do
udp <- RP.readS_to_P reads
port <- RP.between (RP.char '{') (RP.char '}') $ do
mapM_ RP.char ("tcp:" :: String)
w16 <- RP.readS_to_P reads
return $ fromIntegral (w16 :: Word16)
return $ NodeInfo udp port
instance ToJSON NodeInfo where
toJSON (NodeInfo udp port) = case (toJSON udp) of
JSON.Object tbl -> JSON.Object $ HashMap.insert "tcp_ports"
(JSON.Array $ Vector.fromList
[JSON.Number (fromIntegral port)])
tbl
x -> x -- Shouldn't happen.
instance FromJSON NodeInfo where
parseJSON json = do
udp <- parseJSON json
port <- case json of
JSON.Object v -> do
portnum:_ <- v JSON..: "tcp_ports"
return (fromIntegral (portnum :: Word16))
_ -> fail "TCP.NodeInfo: Expected JSON object."
return $ NodeInfo udp port
instance Hashable NodeInfo where
hashWithSalt s n = hashWithSalt s (udpNodeInfo n)
|
