summaryrefslogtreecommitdiff
path: root/src/Data/Tox/Onion.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Data/Tox/Onion.hs')
-rw-r--r--src/Data/Tox/Onion.hs1029
1 files changed, 0 insertions, 1029 deletions
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 )