summaryrefslogtreecommitdiff
path: root/src/Data/Tox
diff options
context:
space:
mode:
Diffstat (limited to 'src/Data/Tox')
-rw-r--r--src/Data/Tox/Message.hs84
-rw-r--r--src/Data/Tox/Msg.hs311
-rw-r--r--src/Data/Tox/Onion.hs1029
-rw-r--r--src/Data/Tox/Relay.hs232
4 files changed, 0 insertions, 1656 deletions
diff --git a/src/Data/Tox/Message.hs b/src/Data/Tox/Message.hs
deleted file mode 100644
index 9f1ce339..00000000
--- a/src/Data/Tox/Message.hs
+++ /dev/null
@@ -1,84 +0,0 @@
1-- | This module assigns meaningful symbolic names to Tox message ids and
2-- classifies messages as lossy or lossless.
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE PatternSynonyms #-}
5{-# LANGUAGE ViewPatterns #-}
6module Data.Tox.Message where
7
8import Data.Word
9
10-- | The one-byte type code prefix that classifies a 'CryptoMessage'.
11newtype MessageID = MessageID Word8 deriving (Eq,Enum,Ord,Bounded)
12pattern Padding = MessageID 0 -- ^ 0 padding (skipped until we hit a non zero (data id) byte)
13pattern PacketRequest = MessageID 1 -- ^ 1 packet request packet (lossy packet)
14pattern KillPacket = MessageID 2 -- ^ 2 connection kill packet (lossy packet)
15pattern UnspecifiedPacket003 = MessageID 3 -- ^ 3+ unspecified
16pattern PING = MessageID 16 -- ^ 16+ reserved for Messenger usage (lossless packets)
17-- TODO: rename to ALIVE 16
18-- SHARE_RELAYS 17
19-- FRIEND_REQUESTS 18
20pattern ONLINE = MessageID 24 -- 1 byte
21pattern OFFLINE = MessageID 25 -- 1 byte
22-- LOSSLESS_RANGE_SIZE 32
23pattern NICKNAME = MessageID 48 -- up to 129 bytes
24pattern STATUSMESSAGE = MessageID 49 -- up to 1008 bytes
25pattern USERSTATUS = MessageID 50 -- 2 bytes
26pattern TYPING = MessageID 51 -- 2 bytes
27-- LOSSY_RANGE_SIZE 63
28pattern MESSAGE = MessageID 64 -- up to 1373 bytes
29pattern ACTION = MessageID 65 -- up to 1373 bytes
30pattern MSI = MessageID 69
31pattern FILE_SENDREQUEST = MessageID 80 -- 1+1+4+8+32+max255 = up to 301
32pattern FILE_CONTROL = MessageID 81 -- 8 bytes if seek, otherwise 4
33pattern FILE_DATA = MessageID 82 -- up to 1373
34pattern INVITE_GROUPCHAT = MessageID 95
35pattern INVITE_GROUPCHAT0 = MessageID 96 -- 0x60
36-- TODO: rename to INVITE_CONFERENCE 96
37pattern ONLINE_PACKET = MessageID 97 -- 0x61
38pattern DIRECT_GROUPCHAT = MessageID 98 -- 0x62
39-- TODO: rename to DIRECT_CONFERENCE 98
40pattern MESSAGE_GROUPCHAT = MessageID 99 -- 0x63
41-- TODO: rename to MESSAGE_CONFERENCE 99
42-- LOSSLESS_RANGE_START 160
43pattern MessengerLossy192 = MessageID 192 -- ^ 192+ reserved for Messenger usage (lossy packets)
44pattern LOSSY_GROUPCHAT = MessageID 199 -- 0xC7
45pattern Messenger255 = MessageID 255 -- ^ 255 reserved for Messenger usage (lossless packet)
46
47instance Show MessageID where
48 show Padding = "Padding"
49 show PacketRequest = "PacketRequest"
50 show KillPacket = "KillPacket"
51 show UnspecifiedPacket003 = "UnspecifiedPacket003"
52 show PING = "PING"
53 show ONLINE = "ONLINE"
54 show OFFLINE = "OFFLINE"
55 show NICKNAME = "NICKNAME"
56 show STATUSMESSAGE = "STATUSMESSAGE"
57 show USERSTATUS = "USERSTATUS"
58 show TYPING = "TYPING"
59 show MESSAGE = "MESSAGE"
60 show ACTION = "ACTION"
61 show MSI = "MSI"
62 show FILE_SENDREQUEST = "FILE_SENDREQUEST"
63 show FILE_CONTROL = "FILE_CONTROL"
64 show FILE_DATA = "FILE_DATA"
65 show INVITE_GROUPCHAT = "INVITE_GROUPCHAT"
66 show ONLINE_PACKET = "ONLINE_PACKET"
67 show DIRECT_GROUPCHAT = "DIRECT_GROUPCHAT"
68 show MESSAGE_GROUPCHAT = "MESSAGE_GROUPCHAT"
69 show MessengerLossy192 = "MessengerLossy192"
70 show LOSSY_GROUPCHAT = "LOSSY_GROUPCHAT"
71 show Messenger255 = "Messenger255"
72 show (MessageID n) = "MessageID " ++ show n
73
74data LossyOrLossless = Lossless | Lossy
75 deriving (Eq,Ord,Enum,Show,Bounded)
76
77-- | Classify a packet as lossy or lossless.
78lossyness :: MessageID -> LossyOrLossless
79lossyness (fromEnum -> x) | x < 3 = Lossy
80lossyness (fromEnum -> x) | {-16 <= x,-} x < 192 = Lossless
81lossyness (fromEnum -> x) | 192 <= x, x < 255 = Lossy
82lossyness (fromEnum -> 255) = Lossless
83
84
diff --git a/src/Data/Tox/Msg.hs b/src/Data/Tox/Msg.hs
deleted file mode 100644
index 66ec6eb1..00000000
--- a/src/Data/Tox/Msg.hs
+++ /dev/null
@@ -1,311 +0,0 @@
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DefaultSignatures #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE KindSignatures #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE StandaloneDeriving #-}
10{-# LANGUAGE TypeFamilies #-}
11module Data.Tox.Msg where
12
13import Crypto.Error
14import qualified Crypto.PubKey.Ed25519 as Ed25519
15import Data.ByteArray as BA
16import Data.ByteString as B
17import Data.Dependent.Sum
18import Data.Functor.Contravariant
19import Data.Functor.Identity
20import Data.GADT.Compare
21import Data.GADT.Show
22import Data.Monoid
23import Data.Serialize
24import Data.Text as T
25import Data.Text.Encoding as T
26import Data.Typeable
27import Data.Word
28import GHC.TypeLits
29
30import Crypto.Tox
31import Data.PacketBuffer (compressSequenceNumbers, decompressSequenceNumbers)
32import Network.Tox.NodeId
33
34newtype Unknown = Unknown B.ByteString deriving (Eq,Show)
35newtype Padded = Padded B.ByteString deriving (Eq,Show)
36
37-- The 'UserStatus' equivalent in Presence is:
38--
39-- data JabberShow = Offline
40-- | ExtendedAway
41-- | Away -- Tox equiv: Away (1)
42-- | DoNotDisturb -- Tox equiv: Busy (2)
43-- | Available -- Tox equiv: Online (0)
44-- | Chatty
45-- deriving (Show,Enum,Ord,Eq,Read)
46--
47-- The Enum instance on 'UserStatus' is not arbitrary. It corresponds
48-- to on-the-wire id numbers.
49data UserStatus = Online | Away | Busy deriving (Show,Read,Eq,Ord,Enum)
50
51instance Serialize UserStatus where
52 get = do
53 x <- get :: Get Word8
54 return (toEnum8 x)
55 put x = put (fromEnum8 x)
56
57
58newtype MissingPackets = MissingPackets [Word32]
59 deriving (Eq,Show)
60
61data Msg (n :: Nat) t where
62 Padding :: Msg 0 Padded
63 PacketRequest :: Msg 1 MissingPackets
64 KillPacket :: Msg 2 ()
65 ALIVE :: Msg 16 ()
66 SHARE_RELAYS :: Msg 17 Unknown
67 FRIEND_REQUESTS :: Msg 18 Unknown
68 ONLINE :: Msg 24 ()
69 OFFLINE :: Msg 25 ()
70 NICKNAME :: Msg 48 Text
71 STATUSMESSAGE :: Msg 49 Text
72 USERSTATUS :: Msg 50 UserStatus
73 TYPING :: Msg 51 Bool
74 MESSAGE :: Msg 64 Text
75 ACTION :: Msg 65 Text
76 MSI :: Msg 69 Unknown
77 FILE_SENDREQUEST :: Msg 80 Unknown
78 FILE_CONTROL :: Msg 81 Unknown
79 FILE_DATA :: Msg 82 Unknown
80 INVITE_GROUPCHAT :: Msg 95 Invite
81 INVITE_CONFERENCE :: Msg 96 Unknown
82 ONLINE_PACKET :: Msg 97 Unknown
83 DIRECT_CONFERENCE :: Msg 98 Unknown
84 MESSAGE_CONFERENCE :: Msg 99 Unknown
85 LOSSY_CONFERENCE :: Msg 199 Unknown
86
87deriving instance Show (Msg n a)
88
89msgbyte :: KnownNat n => Msg n a -> Word8
90msgbyte m = fromIntegral (natVal $ proxy m)
91 where proxy :: Msg n a -> Proxy n
92 proxy _ = Proxy
93
94data Pkt a where Pkt :: (KnownNat n, Packet a, KnownMsg n) => Msg n a -> Pkt a
95
96deriving instance (Show (Pkt a))
97
98type CryptoMessage = DSum Pkt Identity
99
100msgID (Pkt mid :=> Identity _) = M mid
101
102-- TODO
103instance GShow Pkt where gshowsPrec = showsPrec
104instance ShowTag Pkt Identity where
105 showTaggedPrec (Pkt _) = showsPrec
106
107instance GEq Pkt where geq (Pkt _) (Pkt _) = eqT
108instance EqTag Pkt Identity where eqTagged (Pkt _) (Pkt _) = (==)
109
110someMsgVal :: KnownMsg n => Msg n a -> SomeMsg
111someMsgVal m = msgid (proxy m)
112 where proxy :: Msg n a -> Proxy n
113 proxy _ = Proxy
114
115class KnownMsg (n::Nat) where msgid :: proxy n -> SomeMsg
116
117instance KnownMsg 0 where msgid _ = M Padding
118instance KnownMsg 1 where msgid _ = M PacketRequest
119instance KnownMsg 2 where msgid _ = M KillPacket
120instance KnownMsg 16 where msgid _ = M ALIVE
121instance KnownMsg 17 where msgid _ = M SHARE_RELAYS
122instance KnownMsg 18 where msgid _ = M FRIEND_REQUESTS
123instance KnownMsg 24 where msgid _ = M ONLINE
124instance KnownMsg 25 where msgid _ = M OFFLINE
125instance KnownMsg 48 where msgid _ = M NICKNAME
126instance KnownMsg 49 where msgid _ = M STATUSMESSAGE
127instance KnownMsg 50 where msgid _ = M USERSTATUS
128instance KnownMsg 51 where msgid _ = M TYPING
129instance KnownMsg 64 where msgid _ = M MESSAGE
130instance KnownMsg 65 where msgid _ = M ACTION
131instance KnownMsg 69 where msgid _ = M MSI
132instance KnownMsg 80 where msgid _ = M FILE_SENDREQUEST
133instance KnownMsg 81 where msgid _ = M FILE_CONTROL
134instance KnownMsg 82 where msgid _ = M FILE_DATA
135instance KnownMsg 95 where msgid _ = M INVITE_GROUPCHAT
136instance KnownMsg 96 where msgid _ = M INVITE_CONFERENCE
137instance KnownMsg 97 where msgid _ = M ONLINE_PACKET
138instance KnownMsg 98 where msgid _ = M DIRECT_CONFERENCE
139instance KnownMsg 99 where msgid _ = M MESSAGE_CONFERENCE
140
141msgTag :: Word8 -> Maybe SomeMsg
142msgTag 0 = Just $ M Padding
143msgTag 1 = Just $ M PacketRequest
144msgTag 2 = Just $ M KillPacket
145msgTag 16 = Just $ M ALIVE
146msgTag 17 = Just $ M SHARE_RELAYS
147msgTag 18 = Just $ M FRIEND_REQUESTS
148msgTag 24 = Just $ M ONLINE
149msgTag 25 = Just $ M OFFLINE
150msgTag 48 = Just $ M NICKNAME
151msgTag 49 = Just $ M STATUSMESSAGE
152msgTag 50 = Just $ M USERSTATUS
153msgTag 51 = Just $ M TYPING
154msgTag 64 = Just $ M MESSAGE
155msgTag 65 = Just $ M ACTION
156msgTag 69 = Just $ M MSI
157msgTag 80 = Just $ M FILE_SENDREQUEST
158msgTag 81 = Just $ M FILE_CONTROL
159msgTag 82 = Just $ M FILE_DATA
160msgTag 95 = Just $ M INVITE_GROUPCHAT
161msgTag 96 = Just $ M INVITE_CONFERENCE
162msgTag 97 = Just $ M ONLINE_PACKET
163msgTag 98 = Just $ M DIRECT_CONFERENCE
164msgTag 99 = Just $ M MESSAGE_CONFERENCE
165msgTag _ = Nothing
166
167
168class (Typeable t, Eq t, Show t, Sized t) => Packet t where
169 getPacket :: Word32 -> Get t
170 putPacket :: Word32 -> t -> Put
171 default getPacket :: Serialize t => Word32 -> Get t
172 getPacket _ = get
173 default putPacket :: Serialize t => Word32 -> t -> Put
174 putPacket _ t = put t
175
176instance Sized UserStatus where size = ConstSize 1
177instance Packet UserStatus
178
179instance Sized () where size = ConstSize 0
180instance Packet () where
181 getPacket _ = return ()
182 putPacket _ _ = return ()
183
184instance Sized MissingPackets where size = VarSize $ \(MissingPackets ws) -> Prelude.length ws
185instance Packet MissingPackets where
186 getPacket seqno = do
187 bs <- B.unpack <$> (remaining >>= getBytes)
188 return $ MissingPackets (decompressSequenceNumbers seqno bs)
189 putPacket seqno (MissingPackets ws) = do
190 mapM_ putWord8 $ compressSequenceNumbers seqno ws
191
192instance Sized Unknown where size = VarSize $ \(Unknown bs) -> B.length bs
193instance Packet Unknown where
194 getPacket _ = Unknown <$> (remaining >>= getBytes)
195 putPacket _ (Unknown bs) = putByteString bs
196
197instance Sized Padded where size = VarSize $ \(Padded bs) -> B.length bs
198instance Packet Padded where
199 getPacket _ = Padded <$> (remaining >>= getBytes)
200 putPacket _ (Padded bs) = putByteString bs
201
202instance Sized Text where size = VarSize (B.length . T.encodeUtf8)
203instance Packet Text where
204 getPacket _ = T.decodeUtf8 <$> (remaining >>= getBytes)
205 putPacket _ = putByteString . T.encodeUtf8
206
207instance Sized Bool where size = ConstSize 1
208instance Packet Bool where
209 getPacket _ = (/= 0) <$> getWord8
210 putPacket _ False = putWord8 0
211 putPacket _ True = putWord8 1
212
213data SomeMsg where
214 M :: (KnownMsg n, KnownNat n, Packet t) => Msg n t -> SomeMsg
215
216instance Eq SomeMsg where
217 M m == M n = msgbyte m == msgbyte n
218
219instance Show SomeMsg where
220 show (M m) = show m
221
222toEnum8 :: (Enum a, Integral word8) => word8 -> a
223toEnum8 = toEnum . fromIntegral
224
225fromEnum8 :: Enum a => a -> Word8
226fromEnum8 = fromIntegral . fromEnum
227
228data LossyOrLossless = Lossless | Lossy deriving (Eq,Ord,Enum,Show,Bounded)
229
230someLossyness (M m) = lossyness m
231
232lossyness :: KnownNat n => Msg n t -> LossyOrLossless
233lossyness m = case msgbyte m of
234 x | x < 3 -> Lossy
235 | {-16 <= x,-} x < 192 -> Lossless
236 | 192 <= x, x < 255 -> Lossy
237 | otherwise -> Lossless
238
239
240newtype ChatID = ChatID Ed25519.PublicKey
241 deriving Eq
242
243instance Sized ChatID where size = ConstSize 32
244
245instance Serialize ChatID where
246 get = do
247 bs <- getBytes 32
248 case Ed25519.publicKey bs of
249 CryptoPassed ed -> return $ ChatID ed
250 CryptoFailed e -> fail (show e)
251 put (ChatID ed) = putByteString $ BA.convert ed
252
253instance Read ChatID where
254 readsPrec _ s
255 | Right bs <- parseToken32 s
256 , CryptoPassed ed <- Ed25519.publicKey bs
257 = [ (ChatID ed, Prelude.drop 43 s) ]
258 | otherwise = []
259
260instance Show ChatID where
261 show (ChatID ed) = showToken32 ed
262
263data InviteType = GroupInvite { groupName :: Text }
264 | AcceptedInvite
265 | ConfirmedInvite { inviteNodes :: [NodeInfo] }
266 deriving (Eq,Show)
267
268instance Sized InviteType where
269 size = VarSize $ \x -> case x of
270 GroupInvite name -> B.length (T.encodeUtf8 name)
271 AcceptedInvite -> 0
272 ConfirmedInvite ns -> 0 -- TODO: size of node list.
273
274data Invite = Invite
275 { inviteChatID :: ChatID
276 , inviteChatKey :: PublicKey
277 , invite :: InviteType
278 }
279 deriving (Eq,Show)
280
281instance Sized Invite where
282 size = contramap inviteChatID size
283 <> contramap (key2id . inviteChatKey) size
284 <> contramap invite size
285
286instance Serialize Invite where
287 get = do
288 group_packet_id <- getWord8 -- expecting 254=GP_FRIEND_INVITE
289 invite_type <- getWord8
290 chatid <- get
291 chatkey <- getPublicKey
292 Invite chatid chatkey <$> case invite_type of
293 0 -> do bs <- remaining >>= getBytes -- TODO: size can be determined from group shared state.
294 return $ GroupInvite $ decodeUtf8 bs
295 1 -> return AcceptedInvite
296 2 -> return $ ConfirmedInvite [] -- TODO: decode nodes
297
298 put x = do
299 putWord8 254 -- GP_FRIEND_INVITE
300 putWord8 $ case invite x of
301 GroupInvite {} -> 0 -- GROUP_INVITE
302 AcceptedInvite -> 1 -- GROUP_INVITE_ACCEPTED
303 ConfirmedInvite {} -> 2 -- GROUP_INVITE_CONFIRMATION
304 put $ inviteChatID x
305 putPublicKey $ inviteChatKey x
306 case invite x of
307 GroupInvite name -> putByteString $ encodeUtf8 name
308 AcceptedInvite -> return ()
309 ConfirmedInvite ns -> return () -- TODO: encode nodes.
310
311instance Packet Invite where
diff --git a/src/Data/Tox/Onion.hs b/src/Data/Tox/Onion.hs
deleted file mode 100644
index bd802c75..00000000
--- a/src/Data/Tox/Onion.hs
+++ /dev/null
@@ -1,1029 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GADTs #-}
7{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8{-# LANGUAGE KindSignatures #-}
9{-# LANGUAGE LambdaCase #-}
10{-# LANGUAGE MultiParamTypeClasses #-}
11{-# LANGUAGE PartialTypeSignatures #-}
12{-# LANGUAGE RankNTypes #-}
13{-# LANGUAGE ScopedTypeVariables #-}
14{-# LANGUAGE StandaloneDeriving #-}
15{-# LANGUAGE TupleSections #-}
16{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE UndecidableInstances #-}
19module Data.Tox.Onion where
20
21
22import Network.Address (fromSockAddr,toSockAddr,setPort,either4or6,sockAddrPort)
23import Network.QueryResponse
24import Crypto.Tox hiding (encrypt,decrypt)
25import Network.Tox.NodeId
26import qualified Crypto.Tox as ToxCrypto
27import Network.Tox.DHT.Transport (NodeInfo(..),NodeId(..),SendNodes(..),nodeInfo,DHTPublicKey(..),FriendRequest,asymNodeInfo)
28
29import Control.Applicative
30import Control.Arrow
31import Control.Concurrent.STM
32import Control.Monad
33import qualified Data.ByteString as B
34 ;import Data.ByteString (ByteString)
35import Data.Data
36import Data.Function
37import Data.Functor.Contravariant
38import Data.Functor.Identity
39#if MIN_VERSION_iproute(1,7,4)
40import Data.IP hiding (fromSockAddr)
41#else
42import Data.IP
43#endif
44import Data.Maybe
45import Data.Monoid
46import Data.Serialize as S
47import Data.Type.Equality
48import Data.Typeable
49import Data.Word
50import GHC.Generics ()
51import GHC.TypeLits
52import Network.Socket
53import qualified Text.ParserCombinators.ReadP as RP
54import Data.Hashable
55import DPut
56import DebugTag
57import Data.Word64Map (fitsInInt)
58import Data.Bits (shiftR,shiftL)
59import qualified Rank2
60
61type HandleLo a = Maybe (Either String (ByteString, SockAddr)) -> IO a
62
63type UDPTransport = Transport String SockAddr ByteString
64
65
66getOnionAsymm :: Get (Asymm (Encrypted DataToRoute))
67getOnionAsymm = getAliasedAsymm
68
69putOnionAsymm :: Serialize a => Word8 -> Put -> Asymm a -> Put
70putOnionAsymm typ p a = put typ >> p >> putAliasedAsymm a
71
72data OnionMessage (f :: * -> *)
73 = OnionAnnounce (Asymm (f (AnnounceRequest,Nonce8)))
74 | OnionAnnounceResponse Nonce8 Nonce24 (f AnnounceResponse) -- XXX: Why is Nonce8 transmitted in the clear?
75 | OnionToRoute PublicKey (Asymm (Encrypted DataToRoute)) -- destination key, aliased Asymm
76 | OnionToRouteResponse (Asymm (Encrypted DataToRoute))
77
78deriving instance ( Eq (f (AnnounceRequest, Nonce8))
79 , Eq (f AnnounceResponse)
80 , Eq (f DataToRoute)
81 ) => Eq (OnionMessage f)
82
83deriving instance ( Ord (f (AnnounceRequest, Nonce8))
84 , Ord (f AnnounceResponse)
85 , Ord (f DataToRoute)
86 ) => Ord (OnionMessage f)
87
88deriving instance ( Show (f (AnnounceRequest, Nonce8))
89 , Show (f AnnounceResponse)
90 , Show (f DataToRoute)
91 ) => Show (OnionMessage f)
92
93instance Data (OnionMessage Encrypted) where
94 gfoldl f z txt = z (either error id . S.decode) `f` S.encode txt
95 toConstr _ = error "OnionMessage.toConstr"
96 gunfold _ _ = error "OnionMessage.gunfold"
97#if MIN_VERSION_base(4,2,0)
98 dataTypeOf _ = mkNoRepType "Network.Tox.Onion.Transport.OnionMessage"
99#else
100 dataTypeOf _ = mkNorepType "Network.Tox.Onion.Transport.OnionMessage"
101#endif
102
103instance Rank2.Functor OnionMessage where
104 f <$> m = mapPayload (Proxy :: Proxy Serialize) f m
105
106instance Payload Serialize OnionMessage where
107 mapPayload _ f (OnionAnnounce a) = OnionAnnounce (fmap f a)
108 mapPayload _ f (OnionAnnounceResponse n8 n24 a) = OnionAnnounceResponse n8 n24 (f a)
109 mapPayload _ f (OnionToRoute k a) = OnionToRoute k a
110 mapPayload _ f (OnionToRouteResponse a) = OnionToRouteResponse a
111
112
113msgNonce :: OnionMessage f -> Nonce24
114msgNonce (OnionAnnounce a) = asymmNonce a
115msgNonce (OnionAnnounceResponse _ n24 _) = n24
116msgNonce (OnionToRoute _ a) = asymmNonce a
117msgNonce (OnionToRouteResponse a) = asymmNonce a
118
119data AliasSelector = SearchingAlias | AnnouncingAlias SecretKey PublicKey
120 deriving (Eq,Show)
121
122data OnionDestination r
123 = OnionToOwner
124 { onionNodeInfo :: NodeInfo
125 , onionReturnPath :: ReturnPath N3 -- ^ Somebody else's path to us.
126 }
127 | OnionDestination
128 { onionAliasSelector' :: AliasSelector
129 , onionNodeInfo :: NodeInfo
130 , onionRouteSpec :: Maybe r -- ^ Our own onion-path.
131 }
132 deriving Show
133
134onionAliasSelector :: OnionDestination r -> AliasSelector
135onionAliasSelector (OnionToOwner {} ) = SearchingAlias
136onionAliasSelector (OnionDestination{onionAliasSelector' = sel}) = sel
137
138onionKey :: OnionDestination r -> PublicKey
139onionKey od = id2key . nodeId $ onionNodeInfo od
140
141instance Sized (OnionMessage Encrypted) where
142 size = VarSize $ \case
143 OnionAnnounce a -> case size of ConstSize n -> n + 1
144 VarSize f -> f a + 1
145 OnionAnnounceResponse n8 n24 x -> case size of ConstSize n -> n + 33
146 VarSize f -> f x + 33
147 OnionToRoute pubkey a -> case size of ConstSize n -> n + 33
148 VarSize f -> f a + 33
149 OnionToRouteResponse a -> case size of ConstSize n -> n + 1
150 VarSize f -> f a + 1
151
152instance Serialize (OnionMessage Encrypted) where
153 get = do
154 typ <- get
155 case typ :: Word8 of
156 0x83 -> OnionAnnounce <$> getAliasedAsymm
157 0x85 -> OnionToRoute <$> getPublicKey <*> getAliasedAsymm
158 t -> fail ("Unknown onion payload: " ++ show t)
159 `fromMaybe` getOnionReply t
160 put (OnionAnnounce a) = putWord8 0x83 >> putAliasedAsymm a
161 put (OnionToRoute k a) = putWord8 0x85 >> putPublicKey k >> putAliasedAsymm a
162 put (OnionAnnounceResponse n8 n24 x) = putWord8 0x84 >> put n8 >> put n24 >> put x
163 put (OnionToRouteResponse a) = putWord8 0x86 >> putAliasedAsymm a
164
165onionToOwner :: Asymm a -> ReturnPath N3 -> SockAddr -> Either String (OnionDestination r)
166onionToOwner asymm ret3 saddr = do
167 ni <- nodeInfo (key2id $ senderKey asymm) saddr
168 return $ OnionToOwner ni ret3
169-- data CookieAddress = WithoutCookie NodeInfo | CookieAddress Cookie SockAddr
170
171
172onion :: Sized msg =>
173 ByteString
174 -> SockAddr
175 -> Get (Asymm (Encrypted msg) -> t)
176 -> Either String (t, OnionDestination r)
177onion bs saddr getf = do (f,(asymm,ret3)) <- runGet ((,) <$> getf <*> getOnionRequest) bs
178 oaddr <- onionToOwner asymm ret3 saddr
179 return (f asymm, oaddr)
180
181parseOnionAddr :: (SockAddr -> Nonce8 -> IO (Maybe (OnionDestination r)))
182 -> (ByteString, SockAddr)
183 -> IO (Either (OnionMessage Encrypted,OnionDestination r)
184 (ByteString,SockAddr))
185parseOnionAddr lookupSender (msg,saddr)
186 | Just (typ,bs) <- B.uncons msg
187 , let right = Right (msg,saddr)
188 query = return . either (const right) Left
189 = case typ of
190 0x83 -> query $ onion bs saddr (pure OnionAnnounce) -- Announce Request
191 0x85 -> query $ onion bs saddr (OnionToRoute <$> getPublicKey) -- Onion Data Request
192 _ -> case flip runGet bs <$> getOnionReply typ of
193 Just (Right msg@(OnionAnnounceResponse n8 _ _)) -> do
194 maddr <- lookupSender saddr n8
195 maybe (return right) -- Response unsolicited or too late.
196 (return . Left . \od -> (msg,od))
197 maddr
198 Just (Right msg@(OnionToRouteResponse asym)) -> do
199 let ni = asymNodeInfo saddr asym
200 return $ Left (msg, OnionDestination SearchingAlias ni Nothing)
201 _ -> return right
202
203getOnionReply :: Word8 -> Maybe (Get (OnionMessage Encrypted))
204getOnionReply 0x84 = Just $ OnionAnnounceResponse <$> get <*> get <*> get
205getOnionReply 0x86 = Just $ OnionToRouteResponse <$> getOnionAsymm
206getOnionReply _ = Nothing
207
208putOnionMsg :: OnionMessage Encrypted -> Put
209putOnionMsg (OnionAnnounce a) = putOnionAsymm 0x83 (return ()) a
210putOnionMsg (OnionToRoute pubkey a) = putOnionAsymm 0x85 (putPublicKey pubkey) a
211putOnionMsg (OnionAnnounceResponse n8 n24 x) = put (0x84 :: Word8) >> put n8 >> put n24 >> put x
212putOnionMsg (OnionToRouteResponse a) = putOnionAsymm 0x86 (return ()) a
213
214newtype RouteId = RouteId Int
215 deriving Show
216
217
218-- We used to derive the RouteId from the Nonce8 associated with the query.
219-- This is problematic because a nonce generated by toxcore will not validate
220-- if it is received via a different route than it was issued. This is
221-- described by the Tox spec:
222--
223-- Toxcore generates `ping_id`s by taking a 32 byte sha hash of the current
224-- time, some secret bytes generated when the instance is created, the
225-- current time divided by a 20 second timeout, the public key of the
226-- requester and the source ip/port that the packet was received from. Since
227-- the ip/port that the packet was received from is in the `ping_id`, the
228-- announce packets being sent with a ping id must be sent using the same
229-- path as the packet that we received the `ping_id` from or announcing will
230-- fail.
231--
232-- The original idea was:
233--
234-- > routeId :: Nonce8 -> RouteId
235-- > routeId (Nonce8 w8) = RouteId $ mod (fromIntegral w8) 12
236--
237-- Instead, we'll just hash the destination node id.
238routeId :: NodeId -> RouteId
239routeId nid = RouteId $ mod (hash nid) 12
240
241
242
243forwardOnions :: TransportCrypto -> UDPTransport -> (Int -> OnionMessage Encrypted -> IO ()) {- ^ TCP relay send -} -> UDPTransport
244forwardOnions crypto udp sendTCP = udp { awaitMessage = forwardAwait crypto udp sendTCP }
245
246forwardAwait :: TransportCrypto -> UDPTransport -> (Int -> OnionMessage Encrypted -> IO ()) {- ^ TCP relay send -} -> HandleLo a -> IO a
247forwardAwait crypto udp sendTCP kont = do
248 fix $ \another -> do
249 awaitMessage udp $ \case
250 m@(Just (Right (bs,saddr))) -> case B.head bs of
251 0x80 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy N0) crypto (Addressed saddr) udp another
252 0x81 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy N1) crypto (Addressed saddr) udp another
253 0x82 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy N2) crypto (Addressed saddr) udp another
254 0x8c -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N3) crypto saddr udp sendTCP another
255 0x8d -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N2) crypto saddr udp sendTCP another
256 0x8e -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N1) crypto saddr udp sendTCP another
257 _ -> kont m
258 m -> kont m
259
260forward :: forall c b b1. (Serialize b, Show b) =>
261 (Maybe (Either String b1) -> c) -> ByteString -> (b -> c) -> c
262forward kont bs f = either (kont . Just . Left) f $ decode $ B.tail bs
263
264class SumToThree a b
265
266instance SumToThree N0 N3
267instance SumToThree (S a) b => SumToThree a (S b)
268
269class ( Serialize (ReturnPath n)
270 , Serialize (ReturnPath (S n))
271 , Serialize (Forwarding (ThreeMinus (S n)) (OnionMessage Encrypted))
272 , ThreeMinus n ~ S (ThreeMinus (S n))
273 ) => LessThanThree n
274
275instance LessThanThree N0
276instance LessThanThree N1
277instance LessThanThree N2
278
279type family ThreeMinus n where
280 ThreeMinus N3 = N0
281 ThreeMinus N2 = N1
282 ThreeMinus N1 = N2
283 ThreeMinus N0 = N3
284
285-- n = 0, 1, 2
286data OnionRequest n = OnionRequest
287 { onionNonce :: Nonce24
288 , onionForward :: Forwarding (ThreeMinus n) (OnionMessage Encrypted)
289 , pathFromOwner :: ReturnPath n
290 }
291 deriving (Eq,Ord)
292
293
294{-
295instance (Typeable n, Sized (ReturnPath n), Serialize (ReturnPath n)
296 , Serialize (Forwarding (ThreeMinus n) (OnionMessage Encrypted))
297 ) => Data (OnionRequest n) where
298 gfoldl f z txt = z (either error id . S.decode) `f` S.encode txt
299 toConstr _ = error "OnionRequest.toConstr"
300 gunfold _ _ = error "OnionRequest.gunfold"
301#if MIN_VERSION_base(4,2,0)
302 dataTypeOf _ = mkNoRepType "Network.Tox.Onion.Transport.OnionRequest"
303#else
304 dataTypeOf _ = mkNorepType "Network.Tox.Onion.Transport.OnionRequest"
305#endif
306-}
307
308
309instance (Typeable n, Serialize (ReturnPath n)) => Data (OnionResponse n) where
310 gfoldl f z txt = z (either error id . S.decode) `f` S.encode txt
311 toConstr _ = error "OnionResponse.toConstr"
312 gunfold _ _ = error "OnionResponse.gunfold"
313#if MIN_VERSION_base(4,2,0)
314 dataTypeOf _ = mkNoRepType "Network.Tox.Onion.Transport.OnionResponse"
315#else
316 dataTypeOf _ = mkNorepType "Network.Tox.Onion.Transport.OnionResponse"
317#endif
318
319deriving instance ( Show (Forwarding (ThreeMinus n) (OnionMessage Encrypted))
320 , KnownNat (PeanoNat n)
321 ) => Show (OnionRequest n)
322
323instance Sized (OnionRequest N0) where -- N1 and N2 are the same, N3 does not encode the nonce.
324 size = contramap onionNonce size
325 <> contramap onionForward size
326 <> contramap pathFromOwner size
327
328instance ( Serialize (Forwarding (ThreeMinus n) (OnionMessage Encrypted))
329 , Sized (ReturnPath n)
330 , Serialize (ReturnPath n)
331 , Typeable n
332 ) => Serialize (OnionRequest n) where
333 get = do
334 -- TODO share code with 'getOnionRequest'
335 n24 <- case eqT :: Maybe (n :~: N3) of
336 Just Refl -> return $ Nonce24 zeros24
337 Nothing -> get
338 cnt <- remaining
339 let fwdsize = case size :: Size (ReturnPath n) of ConstSize n -> cnt - n
340 fwd <- isolate fwdsize get
341 rpath <- get
342 return $ OnionRequest n24 fwd rpath
343 put (OnionRequest n f p) = maybe (put n) (\Refl -> return ()) (eqT :: Maybe (n :~: N3)) >> put f >> put p
344
345-- getRequest :: _
346-- getRequest = OnionRequest <$> get <*> get <*> get
347
348-- n = 1, 2, 3
349-- Attributed (Encrypted (
350
351data OnionResponse n = OnionResponse
352 { pathToOwner :: ReturnPath n
353 , msgToOwner :: OnionMessage Encrypted
354 }
355 deriving (Eq,Ord)
356
357deriving instance KnownNat (PeanoNat n) => Show (OnionResponse n)
358
359instance ( Serialize (ReturnPath n) ) => Serialize (OnionResponse n) where
360 get = OnionResponse <$> get <*> (get >>= fromMaybe (fail "illegal onion forwarding")
361 . getOnionReply)
362 put (OnionResponse p m) = put p >> putOnionMsg m
363
364instance (Sized (ReturnPath n)) => Sized (OnionResponse (S n)) where
365 size = contramap pathToOwner size <> contramap msgToOwner size
366
367data Addressed a = Addressed { sockAddr :: SockAddr, unaddressed :: a }
368 | TCPIndex { tcpIndex :: Int, unaddressed :: a }
369 deriving (Eq,Ord,Show)
370
371instance (Typeable a, Serialize a) => Data (Addressed a) where
372 gfoldl f z a = z (either error id . S.decode) `f` S.encode a
373 toConstr _ = error "Addressed.toConstr"
374 gunfold _ _ = error "Addressed.gunfold"
375#if MIN_VERSION_base(4,2,0)
376 dataTypeOf _ = mkNoRepType "Network.Tox.Onion.Transport.Addressed"
377#else
378 dataTypeOf _ = mkNorepType "Network.Tox.Onion.Transport.Addressed"
379#endif
380
381instance Sized a => Sized (Addressed a) where
382 size = case size :: Size a of
383 ConstSize n -> ConstSize $ 1{-family-} + 16{-ip-} + 2{-port-} + n
384 VarSize f -> VarSize $ \x -> 1{-family-} + 16{-ip-} + 2{-port-} + f (unaddressed x)
385
386getForwardAddr :: S.Get SockAddr
387getForwardAddr = do
388 addrfam <- S.get :: S.Get Word8
389 ip <- getIP addrfam
390 case ip of IPv4 _ -> S.skip 12 -- compliant peers would zero-fill this.
391 IPv6 _ -> return ()
392 port <- S.get :: S.Get PortNumber
393 return $ setPort port $ toSockAddr ip
394
395
396putForwardAddr :: SockAddr -> S.Put
397putForwardAddr saddr = fromMaybe (return $ error "unsupported SockAddr family") $ do
398 port <- sockAddrPort saddr
399 ip <- fromSockAddr $ either id id $ either4or6 saddr
400 return $ do
401 case ip of
402 IPv4 ip4 -> S.put (0x02 :: Word8) >> S.put ip4 >> S.putByteString (B.replicate 12 0)
403 IPv6 ip6 -> S.put (0x0a :: Word8) >> S.put ip6
404 S.put port
405
406addrToIndex :: SockAddr -> Int
407addrToIndex (SockAddrInet6 _ _ (lo, hi, _, _) _) =
408 if fitsInInt (Proxy :: Proxy Word64)
409 then fromIntegral lo + (fromIntegral hi `shiftL` 32)
410 else fromIntegral lo
411addrToIndex _ = 0
412
413indexToAddr :: Int -> SockAddr
414indexToAddr x = SockAddrInet6 0 0 (fromIntegral x, fromIntegral (x `shiftR` 32),0,0) 0
415
416-- Note, toxcore would check an address family byte here to detect a TCP-bound
417-- packet, but we instead use the IPv6 id and rely on the port number being
418-- zero. Since it will be symmetrically encrypted for our eyes only, it's not
419-- important to conform on this point.
420instance Serialize a => Serialize (Addressed a) where
421 get = do saddr <- getForwardAddr
422 a <- get
423 case sockAddrPort saddr of
424 Just 0 -> return $ TCPIndex (addrToIndex saddr) a
425 _ -> return $ Addressed saddr a
426 put (Addressed addr x) = putForwardAddr addr >> put x
427 put (TCPIndex idx x) = putForwardAddr (indexToAddr idx) >> put x
428
429data N0
430data S n
431type N1 = S N0
432type N2 = S N1
433type N3 = S N2
434
435deriving instance Data N0
436deriving instance Data n => Data (S n)
437
438class KnownPeanoNat n where
439 peanoVal :: p n -> Int
440
441instance KnownPeanoNat N0 where
442 peanoVal _ = 0
443instance KnownPeanoNat n => KnownPeanoNat (S n) where
444 peanoVal _ = 1 + peanoVal (Proxy :: Proxy n)
445
446type family PeanoNat p where
447 PeanoNat N0 = 0
448 PeanoNat (S n) = 1 + PeanoNat n
449
450data ReturnPath n where
451 NoReturnPath :: ReturnPath N0
452 ReturnPath :: Nonce24 -> Encrypted (Addressed (ReturnPath n)) -> ReturnPath (S n)
453
454deriving instance Eq (ReturnPath n)
455deriving instance Ord (ReturnPath n)
456
457-- Size: 59 = 1(family) + 16(ip) + 2(port) +16(mac) + 24(nonce)
458instance Sized (ReturnPath N0) where size = ConstSize 0
459instance Sized (ReturnPath n) => Sized (ReturnPath (S n)) where
460 size = ConstSize 59 <> contramap (\x -> let _ = x :: ReturnPath (S n)
461 in error "non-constant ReturnPath size")
462 (size :: Size (ReturnPath n))
463
464{-
465instance KnownNat (PeanoNat n) => Sized (ReturnPath n) where
466 size = ConstSize $ 59 * fromIntegral (natVal (Proxy :: Proxy (PeanoNat n)))
467-}
468
469instance Serialize (ReturnPath N0) where get = pure NoReturnPath
470 put NoReturnPath = pure ()
471
472instance Serialize (ReturnPath N1) where
473 get = ReturnPath <$> get <*> get
474 put (ReturnPath n24 p) = put n24 >> put p
475
476instance (Sized (ReturnPath n), Serialize (ReturnPath n)) => Serialize (ReturnPath (S (S n))) where
477 get = ReturnPath <$> get <*> get
478 put (ReturnPath n24 p) = put n24 >> put p
479
480
481{-
482-- This doesn't work because it tried to infer it for (0 - 1)
483instance (Serialize (Encrypted (Addressed (ReturnPath (n - 1))))) => Serialize (ReturnPath n) where
484 get = ReturnPath <$> get <*> get
485 put (ReturnPath n24 p) = put n24 >> put p
486-}
487
488instance KnownNat (PeanoNat n) => Show (ReturnPath n) where
489 show rpath = "ReturnPath" ++ show (natVal (Proxy :: Proxy (PeanoNat n)))
490
491
492-- instance KnownNat n => Serialize (ReturnPath n) where
493-- -- Size: 59 = 1(family) + 16(ip) + 2(port) +16(mac) + 24(nonce)
494-- get = ReturnPath <$> getBytes ( 59 * (fromIntegral $ natVal $ Proxy @n) )
495-- put (ReturnPath bs) = putByteString bs
496
497
498data Forwarding n msg where
499 NotForwarded :: msg -> Forwarding N0 msg
500 Forwarding :: PublicKey -> Encrypted (Addressed (Forwarding n msg)) -> Forwarding (S n) msg
501
502deriving instance Eq msg => Eq (Forwarding n msg)
503deriving instance Ord msg => Ord (Forwarding n msg)
504
505instance Show msg => Show (Forwarding N0 msg) where
506 show (NotForwarded x) = "NotForwarded "++show x
507
508instance ( KnownNat (PeanoNat (S n))
509 , Show (Encrypted (Addressed (Forwarding n msg)))
510 ) => Show (Forwarding (S n) msg) where
511 show (Forwarding k a) = unwords [ "Forwarding"
512 , "("++show (natVal (Proxy :: Proxy (PeanoNat (S n))))++")"
513 , show (key2id k)
514 , show a
515 ]
516
517instance Sized msg => Sized (Forwarding N0 msg)
518 where size = case size :: Size msg of
519 ConstSize n -> ConstSize n
520 VarSize f -> VarSize $ \(NotForwarded x) -> f x
521
522instance Sized (Forwarding n msg) => Sized (Forwarding (S n) msg)
523 where size = ConstSize 32
524 <> contramap (\(Forwarding _ e) -> e)
525 (size :: Size (Encrypted (Addressed (Forwarding n msg))))
526
527instance Serialize msg => Serialize (Forwarding N0 msg) where
528 get = NotForwarded <$> get
529 put (NotForwarded msg) = put msg
530
531instance (Serialize (Encrypted (Addressed (Forwarding n msg)))) => Serialize (Forwarding (S n) msg) where
532 get = Forwarding <$> getPublicKey <*> get
533 put (Forwarding k x) = putPublicKey k >> put x
534
535{-
536rewrap :: (ThreeMinus n ~ S (ThreeMinus (S n)),
537 Serialize (ReturnPath n),
538 Serialize
539 (Forwarding (ThreeMinus (S n)) (OnionMessage Encrypted))) =>
540 TransportCrypto
541 -> (forall x. x -> Addressed x)
542 -> OnionRequest n
543 -> IO (Either String (OnionRequest (S n), SockAddr))
544rewrap crypto saddr (OnionRequest nonce msg rpath) = do
545 (sym, snonce) <- atomically ( (,) <$> transportSymmetric crypto
546 <*> transportNewNonce crypto )
547 peeled <- peelOnion crypto nonce msg
548 return $ peeled >>= \case
549 Addressed dst msg'
550 -> Right (OnionRequest nonce msg' $ wrapSymmetric sym snonce saddr rpath, dst)
551 _ -> Left "Onion forward to TCP client?"
552-}
553
554handleOnionRequest :: forall a proxy n.
555 ( LessThanThree n
556 , KnownPeanoNat n
557 , Sized (ReturnPath n)
558 , Typeable n
559 ) => proxy n -> TransportCrypto -> (forall x. x -> Addressed x) -> UDPTransport -> IO a -> OnionRequest n -> IO a
560handleOnionRequest proxy crypto saddr udp kont (OnionRequest nonce msg rpath) = do
561 let n = peanoVal rpath
562 dput XOnion $ "handleOnionRequest " ++ show n
563 (sym, snonce) <- atomically ( (,) <$> transportSymmetric crypto
564 <*> transportNewNonce crypto )
565 peeled <- peelOnion crypto nonce msg
566 let showDestination = case saddr () of
567 Addressed a _ -> either show show $ either4or6 a
568 TCPIndex i _ -> "TCP" ++ show [i]
569
570 case peeled of
571 Left e -> do
572 dput XOnion $ unwords [ "peelOnion:", show n, showDestination, e]
573 kont
574 Right (Addressed dst msg') -> do
575 dput XOnion $ unwords [ "peelOnion:", show n, showDestination, "-->", either show show (either4or6 dst), "SUCCESS"]
576 sendMessage udp dst (runPut $ putRequest $ OnionRequest nonce msg' $ wrapSymmetric sym snonce saddr rpath)
577 kont
578 Right (TCPIndex {}) -> do
579 dput XUnexpected "handleOnionRequest: Onion forward to TCP client?"
580 kont
581
582wrapSymmetric :: Serialize (ReturnPath n) =>
583 SymmetricKey -> Nonce24 -> (forall x. x -> Addressed x) -> ReturnPath n -> ReturnPath (S n)
584wrapSymmetric sym n saddr rpath = ReturnPath n $ encryptSymmetric sym n (encodePlain $ saddr rpath)
585
586peelSymmetric :: Serialize (Addressed (ReturnPath n))
587 => SymmetricKey -> ReturnPath (S n) -> Either String (Addressed (ReturnPath n))
588peelSymmetric sym (ReturnPath nonce e) = decryptSymmetric sym nonce e >>= decodePlain
589
590
591peelOnion :: Serialize (Addressed (Forwarding n t))
592 => TransportCrypto
593 -> Nonce24
594 -> Forwarding (S n) t
595 -> IO (Either String (Addressed (Forwarding n t)))
596peelOnion crypto nonce (Forwarding k fwd) = do
597 fmap runIdentity . uncomposed <$> decryptMessage crypto (dhtKey crypto) nonce (Right $ Asymm k nonce fwd)
598
599handleOnionResponse :: (KnownPeanoNat n, Sized (ReturnPath n), Serialize (ReturnPath n), Typeable n) =>
600 proxy (S n)
601 -> TransportCrypto
602 -> SockAddr
603 -> UDPTransport
604 -> (Int -> OnionMessage Encrypted -> IO ()) -- ^ TCP-relay onion send.
605 -> IO a
606 -> OnionResponse (S n)
607 -> IO a
608handleOnionResponse proxy crypto saddr udp sendTCP kont (OnionResponse path msg) = do
609 sym <- atomically $ transportSymmetric crypto
610 case peelSymmetric sym path of
611 Left e -> do
612 -- todo report encryption error
613 let n = peanoVal path
614 dput XMisc $ unwords [ "peelSymmetric:", show n, either show show (either4or6 saddr), e]
615 kont
616 Right (Addressed dst path') -> do
617 sendMessage udp dst (runPut $ putResponse $ OnionResponse path' msg)
618 kont
619 Right (TCPIndex dst path') -> do
620 case peanoVal path' of
621 0 -> sendTCP dst msg
622 n -> dput XUnexpected $ "handleOnionResponse: TCP-bound OnionResponse" ++ show n ++ " not supported."
623 kont
624
625
626data AnnounceRequest = AnnounceRequest
627 { announcePingId :: Nonce32 -- Ping ID
628 , announceSeeking :: NodeId -- Public key we are searching for
629 , announceKey :: NodeId -- Public key that we want those sending back data packets to use
630 }
631 deriving Show
632
633instance Sized AnnounceRequest where size = ConstSize (32*3)
634
635instance S.Serialize AnnounceRequest where
636 get = AnnounceRequest <$> S.get <*> S.get <*> S.get
637 put (AnnounceRequest p s k) = S.put (p,s,k)
638
639getOnionRequest :: Sized msg => Get (Asymm (Encrypted msg), ReturnPath N3)
640getOnionRequest = do
641 -- Assumes return path is constant size so that we can isolate
642 -- the variable-sized prefix.
643 cnt <- remaining
644 a <- isolate (case size :: Size (ReturnPath N3) of ConstSize n -> cnt - n)
645 getAliasedAsymm
646 path <- get
647 return (a,path)
648
649putRequest :: ( KnownPeanoNat n
650 , Serialize (OnionRequest n)
651 , Typeable n
652 ) => OnionRequest n -> Put
653putRequest req = do
654 let tag = 0x80 + fromIntegral (peanoVal req)
655 when (tag <= 0x82) (putWord8 tag)
656 put req
657
658putResponse :: (KnownPeanoNat n, Serialize (OnionResponse n)) => OnionResponse n -> Put
659putResponse resp = do
660 let tag = 0x8f - fromIntegral (peanoVal resp)
661 -- OnionResponse N0 is an alias for the OnionMessage Encrypted type which includes a tag
662 -- in it's Serialize instance.
663 when (tag /= 0x8f) (putWord8 tag)
664 put resp
665
666
667data KeyRecord = NotStored Nonce32
668 | SendBackKey PublicKey
669 | Acknowledged Nonce32
670 deriving Show
671
672instance Sized KeyRecord where size = ConstSize 33
673
674instance S.Serialize KeyRecord where
675 get = do
676 is_stored <- S.get :: S.Get Word8
677 case is_stored of
678 1 -> SendBackKey <$> getPublicKey
679 2 -> Acknowledged <$> S.get
680 _ -> NotStored <$> S.get
681 put (NotStored n32) = S.put (0 :: Word8) >> S.put n32
682 put (SendBackKey key) = S.put (1 :: Word8) >> putPublicKey key
683 put (Acknowledged n32) = S.put (2 :: Word8) >> S.put n32
684
685data AnnounceResponse = AnnounceResponse
686 { is_stored :: KeyRecord
687 , announceNodes :: SendNodes
688 }
689 deriving Show
690
691instance Sized AnnounceResponse where
692 size = contramap is_stored size <> contramap announceNodes size
693
694getNodeList :: S.Get [NodeInfo]
695getNodeList = do
696 n <- S.get
697 (:) n <$> (getNodeList <|> pure [])
698
699instance S.Serialize AnnounceResponse where
700 get = AnnounceResponse <$> S.get <*> (SendNodes <$> getNodeList)
701 put (AnnounceResponse st (SendNodes ns)) = S.put st >> mapM_ S.put ns
702
703data DataToRoute = DataToRoute
704 { dataFromKey :: PublicKey -- Real public key of sender
705 , dataToRoute :: Encrypted OnionData -- (Word8,ByteString) -- DHTPK 0x9c
706 }
707 deriving Show
708
709instance Sized DataToRoute where
710 size = ConstSize 32 <> contramap dataToRoute size
711
712instance Serialize DataToRoute where
713 get = DataToRoute <$> getPublicKey <*> get
714 put (DataToRoute k dta) = putPublicKey k >> put dta
715
716data OnionData
717 = -- | type 0x9c
718 --
719 -- We send this packet every 30 seconds if there is more than one peer (in
720 -- the 8) that says they our friend is announced on them. This packet can
721 -- also be sent through the DHT module as a DHT request packet (see DHT) if
722 -- we know the DHT public key of the friend and are looking for them in the
723 -- DHT but have not connected to them yet. 30 second is a reasonable
724 -- timeout to not flood the network with too many packets while making sure
725 -- the other will eventually receive the packet. Since packets are sent
726 -- through every peer that knows the friend, resending it right away
727 -- without waiting has a high likelihood of failure as the chances of
728 -- packet loss happening to all (up to to 8) packets sent is low.
729 --
730 -- If a friend is online and connected to us, the onion will stop all of
731 -- its actions for that friend. If the peer goes offline it will restart
732 -- searching for the friend as if toxcore was just started.
733 OnionDHTPublicKey DHTPublicKey
734 | -- | type 0x20
735 --
736 --
737 OnionFriendRequest FriendRequest -- 0x20
738 deriving (Eq,Show)
739
740instance Sized OnionData where
741 size = VarSize $ \case
742 OnionDHTPublicKey dhtpk -> case size of
743 ConstSize n -> n -- Override because OnionData probably
744 -- should be treated as variable sized.
745 VarSize f -> f dhtpk
746 -- FIXME: inconsitantly, we have to add in the tag byte for this case.
747 OnionFriendRequest req -> 1 + case size of
748 ConstSize n -> n
749 VarSize f -> f req
750
751instance Serialize OnionData where
752 get = do
753 tag <- get
754 case tag :: Word8 of
755 0x9c -> OnionDHTPublicKey <$> get
756 0x20 -> OnionFriendRequest <$> get
757 _ -> fail $ "Unknown onion data: "++show tag
758 put (OnionDHTPublicKey dpk) = put (0x9c :: Word8) >> put dpk
759 put (OnionFriendRequest fr) = put (0x20 :: Word8) >> put fr
760
761selectKey :: TransportCrypto -> OnionMessage f -> OnionDestination r -> IO (SecretKey, PublicKey)
762selectKey crypto _ rpath@(OnionDestination (AnnouncingAlias skey pkey) _ _)
763 = return (skey, pkey)
764selectKey crypto msg rpath = return $ aliasKey crypto rpath
765
766encrypt :: TransportCrypto
767 -> OnionMessage Identity
768 -> OnionDestination r
769 -> IO (OnionMessage Encrypted, OnionDestination r)
770encrypt crypto msg rpath = do
771 (skey,pkey) <- selectKey crypto msg rpath -- source key
772 let okey = onionKey rpath -- destination key
773 encipher1 :: Serialize a => SecretKey -> PublicKey -> Nonce24 -> a -> (IO ∘ Encrypted) a
774 encipher1 sk pk n a = Composed $ do
775 secret <- lookupSharedSecret crypto sk pk n
776 return $ ToxCrypto.encrypt secret $ encodePlain a
777 encipher :: Serialize a => Nonce24 -> Either (Identity a) (Asymm (Identity a)) -> (IO ∘ Encrypted) a
778 encipher n d = encipher1 skey okey n $ either runIdentity (runIdentity . asymmData) d
779 m <- sequenceMessage $ transcode encipher msg
780 return (m, rpath)
781
782decrypt :: TransportCrypto -> OnionMessage Encrypted -> OnionDestination r -> IO (Either String (OnionMessage Identity, OnionDestination r))
783decrypt crypto msg addr = do
784 (skey,pkey) <- selectKey crypto msg addr
785 let decipher1 :: Serialize a =>
786 TransportCrypto -> SecretKey -> Nonce24
787 -> Either (PublicKey,Encrypted a) (Asymm (Encrypted a))
788 -> (IO ∘ Either String ∘ Identity) a
789 decipher1 crypto k n arg = Composed $ do
790 let (sender,e) = either id (senderKey &&& asymmData) arg
791 secret <- lookupSharedSecret crypto k sender n
792 return $ Composed $ do
793 plain <- ToxCrypto.decrypt secret e
794 Identity <$> decodePlain plain
795 decipher :: Serialize a
796 => Nonce24 -> Either (Encrypted a) (Asymm (Encrypted a))
797 -> (IO ∘ Either String ∘ Identity) a
798 decipher = (\n -> decipher1 crypto skey n . left (senderkey addr))
799 foo <- sequenceMessage $ transcode decipher msg
800 return $ do
801 msg <- sequenceMessage foo
802 Right (msg, addr)
803
804senderkey :: OnionDestination r -> t -> (PublicKey, t)
805senderkey addr e = (onionKey addr, e)
806
807aliasKey :: TransportCrypto -> OnionDestination r -> (SecretKey,PublicKey)
808aliasKey crypto (OnionToOwner {}) = (transportSecret &&& transportPublic) crypto
809aliasKey crypto (OnionDestination {}) = (onionAliasSecret &&& onionAliasPublic) crypto
810
811dhtKey :: TransportCrypto -> (SecretKey,PublicKey)
812dhtKey crypto = (transportSecret &&& transportPublic) crypto
813
814decryptMessage :: Serialize x =>
815 TransportCrypto
816 -> (SecretKey,PublicKey)
817 -> Nonce24
818 -> Either (PublicKey, Encrypted x)
819 (Asymm (Encrypted x))
820 -> IO ((Either String ∘ Identity) x)
821decryptMessage crypto (sk,pk) n arg = do
822 let (sender,e) = either id (senderKey &&& asymmData) arg
823 plain = Composed . fmap Identity . (>>= decodePlain)
824 secret <- lookupSharedSecret crypto sk sender n
825 return $ plain $ ToxCrypto.decrypt secret e
826
827sequenceMessage :: Applicative m => OnionMessage (m ∘ f) -> m (OnionMessage f)
828sequenceMessage (OnionAnnounce a) = fmap OnionAnnounce $ sequenceA $ fmap uncomposed a
829sequenceMessage (OnionAnnounceResponse n8 n24 dta) = OnionAnnounceResponse n8 n24 <$> uncomposed dta
830sequenceMessage (OnionToRoute pub a) = pure $ OnionToRoute pub a
831sequenceMessage (OnionToRouteResponse a) = pure $ OnionToRouteResponse a
832-- sequenceMessage (OnionToRouteResponse a) = fmap OnionToRouteResponse $ sequenceA $ fmap uncomposed a
833
834transcode :: forall f g. (forall a. Serialize a => Nonce24 -> Either (f a) (Asymm (f a)) -> g a) -> OnionMessage f -> OnionMessage g
835transcode f (OnionAnnounce a) = OnionAnnounce $ a { asymmData = f (asymmNonce a) (Right a) }
836transcode f (OnionAnnounceResponse n8 n24 dta) = OnionAnnounceResponse n8 n24 $ f n24 $ Left dta
837transcode f (OnionToRoute pub a) = OnionToRoute pub a
838transcode f (OnionToRouteResponse a) = OnionToRouteResponse a
839-- transcode f (OnionToRouteResponse a) = OnionToRouteResponse $ a { asymmData = f (asymmNonce a) (Right a) }
840
841
842data OnionRoute = OnionRoute
843 { routeAliasA :: SecretKey
844 , routeAliasB :: SecretKey
845 , routeAliasC :: SecretKey
846 , routeNodeA :: NodeInfo
847 , routeNodeB :: NodeInfo
848 , routeNodeC :: NodeInfo
849 , routeRelayPort :: Maybe PortNumber
850 }
851
852
853wrapOnion :: Serialize (Forwarding n msg) =>
854 TransportCrypto
855 -> SecretKey
856 -> Nonce24
857 -> PublicKey
858 -> SockAddr
859 -> Forwarding n msg
860 -> IO (Forwarding (S n) msg)
861wrapOnion crypto skey nonce destkey saddr fwd = do
862 let plain = encodePlain $ Addressed saddr fwd
863 secret <- lookupSharedSecret crypto skey destkey nonce
864 return $ Forwarding (toPublic skey) $ ToxCrypto.encrypt secret plain
865
866wrapOnionPure :: Serialize (Forwarding n msg) =>
867 SecretKey
868 -> ToxCrypto.State
869 -> SockAddr
870 -> Forwarding n msg
871 -> Forwarding (S n) msg
872wrapOnionPure skey st saddr fwd = Forwarding (toPublic skey) (ToxCrypto.encrypt st plain)
873 where
874 plain = encodePlain $ Addressed saddr fwd
875
876
877
878-- TODO
879-- Two types of packets may be sent to Rendezvous via OnionToRoute requests.
880--
881-- (1) DHT public key packet (0x9c)
882--
883-- (2) Friend request
884data Rendezvous = Rendezvous
885 { rendezvousKey :: PublicKey
886 , rendezvousNode :: NodeInfo
887 }
888 deriving Eq
889
890instance Show Rendezvous where
891 showsPrec d (Rendezvous k ni)
892 = showsPrec d (key2id k)
893 . (':' :)
894 . showsPrec d ni
895
896instance Read Rendezvous where
897 readsPrec d = RP.readP_to_S $ do
898 rkstr <- RP.munch (/=':')
899 RP.char ':'
900 nistr <- RP.munch (const True)
901 return Rendezvous
902 { rendezvousKey = id2key $ read rkstr
903 , rendezvousNode = read nistr
904 }
905
906
907data AnnouncedRendezvous = AnnouncedRendezvous
908 { remoteUserKey :: PublicKey
909 , rendezvous :: Rendezvous
910 }
911 deriving Eq
912
913instance Show AnnouncedRendezvous where
914 showsPrec d (AnnouncedRendezvous remote rendez)
915 = showsPrec d (key2id remote)
916 . (':' :)
917 . showsPrec d rendez
918
919instance Read AnnouncedRendezvous where
920 readsPrec d = RP.readP_to_S $ do
921 ukstr <- RP.munch (/=':')
922 RP.char ':'
923 rkstr <- RP.munch (/=':')
924 RP.char ':'
925 nistr <- RP.munch (const True)
926 return AnnouncedRendezvous
927 { remoteUserKey = id2key $ read ukstr
928 , rendezvous = Rendezvous
929 { rendezvousKey = id2key $ read rkstr
930 , rendezvousNode = read nistr
931 }
932 }
933
934
935selectAlias :: TransportCrypto -> NodeId -> STM AliasSelector
936selectAlias crypto pkey = do
937 ks <- filter (\(sk,pk) -> pk == id2key pkey)
938 <$> userKeys crypto
939 maybe (return SearchingAlias)
940 (return . uncurry AnnouncingAlias)
941 (listToMaybe ks)
942
943
944parseDataToRoute
945 :: TransportCrypto
946 -> (OnionMessage Encrypted,OnionDestination r)
947 -> IO (Either ((PublicKey,OnionData),AnnouncedRendezvous) (OnionMessage Encrypted, OnionDestination r))
948parseDataToRoute crypto (OnionToRouteResponse dta, od) = do
949 ks <- atomically $ userKeys crypto
950
951 omsg0 <- decryptMessage crypto (rendezvousSecret crypto,rendezvousPublic crypto)
952 (asymmNonce dta)
953 (Right dta) -- using Asymm{senderKey} as remote key
954 let eOuter = fmap runIdentity $ uncomposed omsg0
955
956 anyRight [] f = return $ Left "parseDataToRoute: no user key"
957 anyRight (x:xs) f = f x >>= either (const $ anyRight xs f) (return . Right)
958
959 -- TODO: We don't currently have a way to look up which user key we
960 -- announced using along this onion route. Therefore, for now, we will
961 -- try all our user keys to see if any can decrypt the packet.
962 eInner <- case eOuter of
963 Left e -> return $ Left e
964 Right dtr -> anyRight ks $ \(sk,pk) -> do
965 omsg0 <- decryptMessage crypto
966 (sk,pk)
967 (asymmNonce dta)
968 (Left (dataFromKey dtr, dataToRoute dtr))
969 return $ do
970 omsg <- fmap runIdentity . uncomposed $ omsg0
971 Right (pk,dtr,omsg)
972
973 let e = do
974 (pk,dtr,omsg) <- eInner
975 return ( (pk, omsg)
976 , AnnouncedRendezvous
977 (dataFromKey dtr)
978 $ Rendezvous (rendezvousPublic crypto) $ onionNodeInfo od )
979 r = either (const $ Right (OnionToRouteResponse dta,od)) Left e
980 -- parseDataToRoute OnionToRouteResponse decipherAndAuth: auth fail
981 case e of
982 Left _ -> dput XMisc $ "Failed keys: " ++ show (map (key2id . snd) ks)
983 Right _ -> return ()
984 dput XMisc $ unlines
985 [ "parseDataToRoute " ++ either id (const "Right") e
986 , " crypto inner.me = " ++ either id (\(pk,_,_) -> show $ key2id pk) eInner
987 , " inner.them = " ++ either id (show . key2id . dataFromKey) eOuter
988 , " outer.me = " ++ show (key2id $ rendezvousPublic crypto)
989 , " outer.them = " ++ show (key2id $ senderKey dta)
990 ]
991 return r
992parseDataToRoute _ msg = return $ Right msg
993
994encodeDataToRoute :: TransportCrypto
995 -> ((PublicKey,OnionData),AnnouncedRendezvous)
996 -> IO (Maybe (OnionMessage Encrypted,OnionDestination r))
997encodeDataToRoute crypto ((me,omsg), AnnouncedRendezvous toxid (Rendezvous pub ni)) = do
998 nonce <- atomically $ transportNewNonce crypto
999 asel <- atomically $ selectAlias crypto (key2id me)
1000 let (sk,pk) = case asel of
1001 AnnouncingAlias sk pk -> (sk,pk)
1002 _ -> (onionAliasSecret crypto, onionAliasPublic crypto)
1003 innerSecret <- lookupSharedSecret crypto sk toxid nonce
1004 let plain = encodePlain $ DataToRoute { dataFromKey = pk
1005 , dataToRoute = ToxCrypto.encrypt innerSecret $ encodePlain omsg
1006 }
1007 outerSecret <- lookupSharedSecret crypto (onionAliasSecret crypto) pub nonce
1008 let dta = ToxCrypto.encrypt outerSecret plain
1009 dput XOnion $ unlines
1010 [ "encodeDataToRoute me=" ++ show (key2id me)
1011 , " dhtpk=" ++ case omsg of
1012 OnionDHTPublicKey dmsg -> show (key2id $ dhtpk dmsg)
1013 OnionFriendRequest fr -> "friend request"
1014 , " ns=" ++ case omsg of
1015 OnionDHTPublicKey dmsg -> show (dhtpkNodes dmsg)
1016 OnionFriendRequest fr -> "friend request"
1017 , " crypto inner.me =" ++ show (key2id pk)
1018 , " inner.you=" ++ show (key2id toxid)
1019 , " outer.me =" ++ show (key2id $ onionAliasPublic crypto)
1020 , " outer.you=" ++ show (key2id pub)
1021 , " " ++ show (AnnouncedRendezvous toxid (Rendezvous pub ni))
1022 , " " ++ show dta
1023 ]
1024 return $ Just ( OnionToRoute toxid -- Public key of destination node
1025 Asymm { senderKey = onionAliasPublic crypto
1026 , asymmNonce = nonce
1027 , asymmData = dta
1028 }
1029 , OnionDestination SearchingAlias ni Nothing )
diff --git a/src/Data/Tox/Relay.hs b/src/Data/Tox/Relay.hs
deleted file mode 100644
index c563db8d..00000000
--- a/src/Data/Tox/Relay.hs
+++ /dev/null
@@ -1,232 +0,0 @@
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE KindSignatures #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE PatternSynonyms #-}
8{-# LANGUAGE StandaloneDeriving #-}
9{-# LANGUAGE UndecidableInstances #-}
10module Data.Tox.Relay where
11
12import Data.Aeson (ToJSON(..),FromJSON(..))
13import qualified Data.Aeson as JSON
14import Data.ByteString as B
15import Data.Data
16import Data.Functor.Contravariant
17import Data.Hashable
18import qualified Data.HashMap.Strict as HashMap
19import Data.Monoid
20import Data.Serialize
21import qualified Data.Vector as Vector
22import Data.Word
23import Network.Socket
24import qualified Rank2
25import qualified Text.ParserCombinators.ReadP as RP
26
27import Crypto.Tox
28import Data.Tox.Onion
29import qualified Network.Tox.NodeId as UDP
30
31newtype ConId = ConId Word8
32 deriving (Eq,Show,Ord,Data,Serialize)
33
34badcon :: ConId
35badcon = ConId 0
36
37-- Maps to a range -120 .. 119
38c2key :: ConId -> Maybe Int
39c2key (ConId x) | x < 16 = Nothing
40 | otherwise = Just $ case divMod (x - 15) 2 of
41 (q,0) -> negate $ fromIntegral q
42 (q,1) -> fromIntegral q
43
44-- Maps to range 16 .. 255
45-- negatives become odds
46key2c :: Int -> ConId
47key2c y = ConId $ if y < 0 then 15 + fromIntegral (negate y * 2)
48 else 16 + fromIntegral (y * 2)
49
50data RelayPacket
51 = RoutingRequest PublicKey
52 | RoutingResponse ConId PublicKey -- 0 for refusal, 16-255 for success.
53 | ConnectNotification ConId
54 | DisconnectNotification ConId
55 | RelayPing Nonce8
56 | RelayPong Nonce8
57 | OOBSend PublicKey ByteString
58 | OOBRecv PublicKey ByteString
59 | OnionPacket Nonce24 (Addressed (Forwarding N2 (OnionMessage Encrypted))) -- (OnionRequest N0)
60 | OnionPacketResponse (OnionMessage Encrypted)
61 -- 0x0A through 0x0F reserved for future use.
62 | RelayData ByteString ConId
63 deriving (Eq,Ord,Show,Data)
64
65newtype PacketNumber = PacketNumber { packetNumberToWord8 :: Word8 }
66 deriving (Eq,Ord,Show)
67
68pattern PingPacket = PacketNumber 4
69pattern OnionPacketID = PacketNumber 8
70
71packetNumber :: RelayPacket -> PacketNumber
72packetNumber (RelayData _ (ConId conid)) = PacketNumber $ conid -- 0 to 15 not allowed.
73packetNumber rp = PacketNumber $ fromIntegral $ pred $ constrIndex $ toConstr rp
74
75instance Sized RelayPacket where
76 size = mappend (ConstSize 1) $ VarSize $ \x -> case x of
77 RoutingRequest k -> 32
78 RoutingResponse rpid k -> 33
79 ConnectNotification conid -> 1
80 DisconnectNotification conid -> 1
81 RelayPing pingid -> 8
82 RelayPong pingid -> 8
83 OOBSend k bs -> 32 + B.length bs
84 OOBRecv k bs -> 32 + B.length bs
85 OnionPacket n24 query -> 24 + case contramap (`asTypeOf` query) size of
86 ConstSize n -> n
87 VarSize f -> f query
88 OnionPacketResponse answer -> case contramap (`asTypeOf` answer) size of
89 ConstSize n -> n
90 VarSize f -> f answer
91 RelayData bs _ -> B.length bs
92
93instance Serialize RelayPacket where
94
95 get = do
96 pktid <- getWord8
97 case pktid of
98 0 -> RoutingRequest <$> getPublicKey
99 1 -> RoutingResponse <$> get <*> getPublicKey
100 2 -> ConnectNotification <$> get
101 3 -> DisconnectNotification <$> get
102 4 -> RelayPing <$> get
103 5 -> RelayPong <$> get
104 6 -> OOBSend <$> getPublicKey <*> (remaining >>= getBytes)
105 7 -> OOBRecv <$> getPublicKey <*> (remaining >>= getBytes)
106 8 -> OnionPacket <$> get <*> get
107 9 -> OnionPacketResponse <$> get
108 conid -> (`RelayData` ConId conid) <$> (remaining >>= getBytes)
109
110 put rp = do
111 putWord8 $ packetNumberToWord8 $ packetNumber rp
112 case rp of
113 RoutingRequest k -> putPublicKey k
114 RoutingResponse rpid k -> put rpid >> putPublicKey k
115 ConnectNotification conid -> put conid
116 DisconnectNotification conid -> put conid
117 RelayPing pingid -> put pingid
118 RelayPong pingid -> put pingid
119 OOBSend k bs -> putPublicKey k >> putByteString bs
120 OOBRecv k bs -> putPublicKey k >> putByteString bs
121 OnionPacket n24 query -> put n24 >> put query
122 OnionPacketResponse answer -> put answer
123 RelayData bs _ -> putByteString bs
124
125-- | Initial client-to-server handshake message.
126newtype Hello (f :: * -> *) = Hello (Asymm (f HelloData))
127
128deriving instance Show (f HelloData) => Show (Hello f)
129
130helloFrom :: Hello f -> PublicKey
131helloFrom (Hello x) = senderKey x
132
133helloNonce :: Hello f -> Nonce24
134helloNonce (Hello x) = asymmNonce x
135
136helloData :: Hello f -> f HelloData
137helloData (Hello x) = asymmData x
138
139instance Rank2.Functor Hello where
140 f <$> Hello (Asymm k n dta) = Hello $ Asymm k n (f dta)
141
142instance Payload Serialize Hello where
143 mapPayload _ f (Hello (Asymm k n dta)) = Hello $ Asymm k n (f dta)
144
145instance Rank2.Foldable Hello where
146 foldMap f (Hello (Asymm k n dta)) = f dta
147
148instance Rank2.Traversable Hello where
149 traverse f (Hello (Asymm k n dta)) = Hello . Asymm k n <$> f dta
150
151instance Sized (Hello Encrypted) where
152 size = ConstSize 56 <> contramap helloData size
153
154instance Serialize (Hello Encrypted) where
155 get = Hello <$> getAsymm
156 put (Hello asym) = putAsymm asym
157
158data HelloData = HelloData
159 { sessionPublicKey :: PublicKey
160 , sessionBaseNonce :: Nonce24
161 }
162 deriving Show
163
164instance Sized HelloData where size = ConstSize 56
165
166instance Serialize HelloData where
167 get = HelloData <$> getPublicKey <*> get
168 put (HelloData k n) = putPublicKey k >> put n
169
170-- | Handshake server-to-client response packet.
171data Welcome (f :: * -> *) = Welcome
172 { welcomeNonce :: Nonce24
173 , welcomeData :: f HelloData
174 }
175
176deriving instance Show (f HelloData) => Show (Welcome f)
177
178instance Rank2.Functor Welcome where
179 f <$> Welcome n dta = Welcome n (f dta)
180
181instance Payload Serialize Welcome where
182 mapPayload _ f (Welcome n dta) = Welcome n (f dta)
183
184instance Rank2.Foldable Welcome where
185 foldMap f (Welcome _ dta) = f dta
186
187instance Rank2.Traversable Welcome where
188 traverse f (Welcome n dta) = Welcome n <$> f dta
189
190instance Sized (Welcome Encrypted) where
191 size = ConstSize 24 <> contramap welcomeData size
192
193instance Serialize (Welcome Encrypted) where
194 get = Welcome <$> get <*> get
195 put (Welcome n dta) = put n >> put dta
196
197data NodeInfo = NodeInfo
198 { udpNodeInfo :: UDP.NodeInfo
199 , tcpPort :: PortNumber
200 }
201 deriving (Eq,Ord)
202
203instance Read NodeInfo where
204 readsPrec _ = RP.readP_to_S $ do
205 udp <- RP.readS_to_P reads
206 port <- RP.between (RP.char '{') (RP.char '}') $ do
207 mapM_ RP.char ("tcp:" :: String)
208 w16 <- RP.readS_to_P reads
209 return $ fromIntegral (w16 :: Word16)
210 return $ NodeInfo udp port
211
212instance ToJSON NodeInfo where
213 toJSON (NodeInfo udp port) = case (toJSON udp) of
214 JSON.Object tbl -> JSON.Object $ HashMap.insert "tcp_ports"
215 (JSON.Array $ Vector.fromList
216 [JSON.Number (fromIntegral port)])
217 tbl
218 x -> x -- Shouldn't happen.
219
220instance FromJSON NodeInfo where
221 parseJSON json = do
222 udp <- parseJSON json
223 port <- case json of
224 JSON.Object v -> do
225 portnum:_ <- v JSON..: "tcp_ports"
226 return (fromIntegral (portnum :: Word16))
227 _ -> fail "TCP.NodeInfo: Expected JSON object."
228 return $ NodeInfo udp port
229
230instance Hashable NodeInfo where
231 hashWithSalt s n = hashWithSalt s (udpNodeInfo n)
232
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 19:44:27 +0000