diff options
author | James Crayne <jim.crayne@gmail.com> | 2019-09-28 13:43:29 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2020-01-01 19:27:53 -0500 |
commit | 11987749fc6e6d3e53ea737d46d5ab13a16faeb8 (patch) | |
tree | 5716463275c2d3e902889db619908ded2a73971c /dht/src/Data/Tox/Onion.hs | |
parent | add2c76bced51fde5e9917e7449ef52be70faf87 (diff) |
Factor out some new libraries
word64-map:
Data.Word64Map
network-addr:
Network.Address
tox-crypto:
Crypto.Tox
lifted-concurrent:
Control.Concurrent.Lifted.Instrument
Control.Concurrent.Async.Lifted.Instrument
psq-wrap:
Data.Wrapper.PSQInt
Data.Wrapper.PSQ
minmax-psq:
Data.MinMaxPSQ
tasks:
Control.Concurrent.Tasks
kad:
Network.Kademlia
Network.Kademlia.Bootstrap
Network.Kademlia.Routing
Network.Kademlia.CommonAPI
Network.Kademlia.Persistence
Network.Kademlia.Search
Diffstat (limited to 'dht/src/Data/Tox/Onion.hs')
-rw-r--r-- | dht/src/Data/Tox/Onion.hs | 1029 |
1 files changed, 1029 insertions, 0 deletions
diff --git a/dht/src/Data/Tox/Onion.hs b/dht/src/Data/Tox/Onion.hs new file mode 100644 index 00000000..bd802c75 --- /dev/null +++ b/dht/src/Data/Tox/Onion.hs | |||
@@ -0,0 +1,1029 @@ | |||
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 #-} | ||
19 | module Data.Tox.Onion where | ||
20 | |||
21 | |||
22 | import Network.Address (fromSockAddr,toSockAddr,setPort,either4or6,sockAddrPort) | ||
23 | import Network.QueryResponse | ||
24 | import Crypto.Tox hiding (encrypt,decrypt) | ||
25 | import Network.Tox.NodeId | ||
26 | import qualified Crypto.Tox as ToxCrypto | ||
27 | import Network.Tox.DHT.Transport (NodeInfo(..),NodeId(..),SendNodes(..),nodeInfo,DHTPublicKey(..),FriendRequest,asymNodeInfo) | ||
28 | |||
29 | import Control.Applicative | ||
30 | import Control.Arrow | ||
31 | import Control.Concurrent.STM | ||
32 | import Control.Monad | ||
33 | import qualified Data.ByteString as B | ||
34 | ;import Data.ByteString (ByteString) | ||
35 | import Data.Data | ||
36 | import Data.Function | ||
37 | import Data.Functor.Contravariant | ||
38 | import Data.Functor.Identity | ||
39 | #if MIN_VERSION_iproute(1,7,4) | ||
40 | import Data.IP hiding (fromSockAddr) | ||
41 | #else | ||
42 | import Data.IP | ||
43 | #endif | ||
44 | import Data.Maybe | ||
45 | import Data.Monoid | ||
46 | import Data.Serialize as S | ||
47 | import Data.Type.Equality | ||
48 | import Data.Typeable | ||
49 | import Data.Word | ||
50 | import GHC.Generics () | ||
51 | import GHC.TypeLits | ||
52 | import Network.Socket | ||
53 | import qualified Text.ParserCombinators.ReadP as RP | ||
54 | import Data.Hashable | ||
55 | import DPut | ||
56 | import DebugTag | ||
57 | import Data.Word64Map (fitsInInt) | ||
58 | import Data.Bits (shiftR,shiftL) | ||
59 | import qualified Rank2 | ||
60 | |||
61 | type HandleLo a = Maybe (Either String (ByteString, SockAddr)) -> IO a | ||
62 | |||
63 | type UDPTransport = Transport String SockAddr ByteString | ||
64 | |||
65 | |||
66 | getOnionAsymm :: Get (Asymm (Encrypted DataToRoute)) | ||
67 | getOnionAsymm = getAliasedAsymm | ||
68 | |||
69 | putOnionAsymm :: Serialize a => Word8 -> Put -> Asymm a -> Put | ||
70 | putOnionAsymm typ p a = put typ >> p >> putAliasedAsymm a | ||
71 | |||
72 | data 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 | |||
78 | deriving instance ( Eq (f (AnnounceRequest, Nonce8)) | ||
79 | , Eq (f AnnounceResponse) | ||
80 | , Eq (f DataToRoute) | ||
81 | ) => Eq (OnionMessage f) | ||
82 | |||
83 | deriving instance ( Ord (f (AnnounceRequest, Nonce8)) | ||
84 | , Ord (f AnnounceResponse) | ||
85 | , Ord (f DataToRoute) | ||
86 | ) => Ord (OnionMessage f) | ||
87 | |||
88 | deriving instance ( Show (f (AnnounceRequest, Nonce8)) | ||
89 | , Show (f AnnounceResponse) | ||
90 | , Show (f DataToRoute) | ||
91 | ) => Show (OnionMessage f) | ||
92 | |||
93 | instance 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 | |||
103 | instance Rank2.Functor OnionMessage where | ||
104 | f <$> m = mapPayload (Proxy :: Proxy Serialize) f m | ||
105 | |||
106 | instance 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 | |||
113 | msgNonce :: OnionMessage f -> Nonce24 | ||
114 | msgNonce (OnionAnnounce a) = asymmNonce a | ||
115 | msgNonce (OnionAnnounceResponse _ n24 _) = n24 | ||
116 | msgNonce (OnionToRoute _ a) = asymmNonce a | ||
117 | msgNonce (OnionToRouteResponse a) = asymmNonce a | ||
118 | |||
119 | data AliasSelector = SearchingAlias | AnnouncingAlias SecretKey PublicKey | ||
120 | deriving (Eq,Show) | ||
121 | |||
122 | data 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 | |||
134 | onionAliasSelector :: OnionDestination r -> AliasSelector | ||
135 | onionAliasSelector (OnionToOwner {} ) = SearchingAlias | ||
136 | onionAliasSelector (OnionDestination{onionAliasSelector' = sel}) = sel | ||
137 | |||
138 | onionKey :: OnionDestination r -> PublicKey | ||
139 | onionKey od = id2key . nodeId $ onionNodeInfo od | ||
140 | |||
141 | instance 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 | |||
152 | instance 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 | |||
165 | onionToOwner :: Asymm a -> ReturnPath N3 -> SockAddr -> Either String (OnionDestination r) | ||
166 | onionToOwner 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 | |||
172 | onion :: Sized msg => | ||
173 | ByteString | ||
174 | -> SockAddr | ||
175 | -> Get (Asymm (Encrypted msg) -> t) | ||
176 | -> Either String (t, OnionDestination r) | ||
177 | onion bs saddr getf = do (f,(asymm,ret3)) <- runGet ((,) <$> getf <*> getOnionRequest) bs | ||
178 | oaddr <- onionToOwner asymm ret3 saddr | ||
179 | return (f asymm, oaddr) | ||
180 | |||
181 | parseOnionAddr :: (SockAddr -> Nonce8 -> IO (Maybe (OnionDestination r))) | ||
182 | -> (ByteString, SockAddr) | ||
183 | -> IO (Either (OnionMessage Encrypted,OnionDestination r) | ||
184 | (ByteString,SockAddr)) | ||
185 | parseOnionAddr 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 | |||
203 | getOnionReply :: Word8 -> Maybe (Get (OnionMessage Encrypted)) | ||
204 | getOnionReply 0x84 = Just $ OnionAnnounceResponse <$> get <*> get <*> get | ||
205 | getOnionReply 0x86 = Just $ OnionToRouteResponse <$> getOnionAsymm | ||
206 | getOnionReply _ = Nothing | ||
207 | |||
208 | putOnionMsg :: OnionMessage Encrypted -> Put | ||
209 | putOnionMsg (OnionAnnounce a) = putOnionAsymm 0x83 (return ()) a | ||
210 | putOnionMsg (OnionToRoute pubkey a) = putOnionAsymm 0x85 (putPublicKey pubkey) a | ||
211 | putOnionMsg (OnionAnnounceResponse n8 n24 x) = put (0x84 :: Word8) >> put n8 >> put n24 >> put x | ||
212 | putOnionMsg (OnionToRouteResponse a) = putOnionAsymm 0x86 (return ()) a | ||
213 | |||
214 | newtype 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. | ||
238 | routeId :: NodeId -> RouteId | ||
239 | routeId nid = RouteId $ mod (hash nid) 12 | ||
240 | |||
241 | |||
242 | |||
243 | forwardOnions :: TransportCrypto -> UDPTransport -> (Int -> OnionMessage Encrypted -> IO ()) {- ^ TCP relay send -} -> UDPTransport | ||
244 | forwardOnions crypto udp sendTCP = udp { awaitMessage = forwardAwait crypto udp sendTCP } | ||
245 | |||
246 | forwardAwait :: TransportCrypto -> UDPTransport -> (Int -> OnionMessage Encrypted -> IO ()) {- ^ TCP relay send -} -> HandleLo a -> IO a | ||
247 | forwardAwait 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 | |||
260 | forward :: forall c b b1. (Serialize b, Show b) => | ||
261 | (Maybe (Either String b1) -> c) -> ByteString -> (b -> c) -> c | ||
262 | forward kont bs f = either (kont . Just . Left) f $ decode $ B.tail bs | ||
263 | |||
264 | class SumToThree a b | ||
265 | |||
266 | instance SumToThree N0 N3 | ||
267 | instance SumToThree (S a) b => SumToThree a (S b) | ||
268 | |||
269 | class ( 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 | |||
275 | instance LessThanThree N0 | ||
276 | instance LessThanThree N1 | ||
277 | instance LessThanThree N2 | ||
278 | |||
279 | type 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 | ||
286 | data 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 | {- | ||
295 | instance (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 | |||
309 | instance (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 | |||
319 | deriving instance ( Show (Forwarding (ThreeMinus n) (OnionMessage Encrypted)) | ||
320 | , KnownNat (PeanoNat n) | ||
321 | ) => Show (OnionRequest n) | ||
322 | |||
323 | instance 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 | |||
328 | instance ( 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 | |||
351 | data OnionResponse n = OnionResponse | ||
352 | { pathToOwner :: ReturnPath n | ||
353 | , msgToOwner :: OnionMessage Encrypted | ||
354 | } | ||
355 | deriving (Eq,Ord) | ||
356 | |||
357 | deriving instance KnownNat (PeanoNat n) => Show (OnionResponse n) | ||
358 | |||
359 | instance ( 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 | |||
364 | instance (Sized (ReturnPath n)) => Sized (OnionResponse (S n)) where | ||
365 | size = contramap pathToOwner size <> contramap msgToOwner size | ||
366 | |||
367 | data Addressed a = Addressed { sockAddr :: SockAddr, unaddressed :: a } | ||
368 | | TCPIndex { tcpIndex :: Int, unaddressed :: a } | ||
369 | deriving (Eq,Ord,Show) | ||
370 | |||
371 | instance (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 | |||
381 | instance 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 | |||
386 | getForwardAddr :: S.Get SockAddr | ||
387 | getForwardAddr = 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 | |||
396 | putForwardAddr :: SockAddr -> S.Put | ||
397 | putForwardAddr 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 | |||
406 | addrToIndex :: SockAddr -> Int | ||
407 | addrToIndex (SockAddrInet6 _ _ (lo, hi, _, _) _) = | ||
408 | if fitsInInt (Proxy :: Proxy Word64) | ||
409 | then fromIntegral lo + (fromIntegral hi `shiftL` 32) | ||
410 | else fromIntegral lo | ||
411 | addrToIndex _ = 0 | ||
412 | |||
413 | indexToAddr :: Int -> SockAddr | ||
414 | indexToAddr 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. | ||
420 | instance 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 | |||
429 | data N0 | ||
430 | data S n | ||
431 | type N1 = S N0 | ||
432 | type N2 = S N1 | ||
433 | type N3 = S N2 | ||
434 | |||
435 | deriving instance Data N0 | ||
436 | deriving instance Data n => Data (S n) | ||
437 | |||
438 | class KnownPeanoNat n where | ||
439 | peanoVal :: p n -> Int | ||
440 | |||
441 | instance KnownPeanoNat N0 where | ||
442 | peanoVal _ = 0 | ||
443 | instance KnownPeanoNat n => KnownPeanoNat (S n) where | ||
444 | peanoVal _ = 1 + peanoVal (Proxy :: Proxy n) | ||
445 | |||
446 | type family PeanoNat p where | ||
447 | PeanoNat N0 = 0 | ||
448 | PeanoNat (S n) = 1 + PeanoNat n | ||
449 | |||
450 | data ReturnPath n where | ||
451 | NoReturnPath :: ReturnPath N0 | ||
452 | ReturnPath :: Nonce24 -> Encrypted (Addressed (ReturnPath n)) -> ReturnPath (S n) | ||
453 | |||
454 | deriving instance Eq (ReturnPath n) | ||
455 | deriving instance Ord (ReturnPath n) | ||
456 | |||
457 | -- Size: 59 = 1(family) + 16(ip) + 2(port) +16(mac) + 24(nonce) | ||
458 | instance Sized (ReturnPath N0) where size = ConstSize 0 | ||
459 | instance 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 | {- | ||
465 | instance KnownNat (PeanoNat n) => Sized (ReturnPath n) where | ||
466 | size = ConstSize $ 59 * fromIntegral (natVal (Proxy :: Proxy (PeanoNat n))) | ||
467 | -} | ||
468 | |||
469 | instance Serialize (ReturnPath N0) where get = pure NoReturnPath | ||
470 | put NoReturnPath = pure () | ||
471 | |||
472 | instance Serialize (ReturnPath N1) where | ||
473 | get = ReturnPath <$> get <*> get | ||
474 | put (ReturnPath n24 p) = put n24 >> put p | ||
475 | |||
476 | instance (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) | ||
483 | instance (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 | |||
488 | instance 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 | |||
498 | data Forwarding n msg where | ||
499 | NotForwarded :: msg -> Forwarding N0 msg | ||
500 | Forwarding :: PublicKey -> Encrypted (Addressed (Forwarding n msg)) -> Forwarding (S n) msg | ||
501 | |||
502 | deriving instance Eq msg => Eq (Forwarding n msg) | ||
503 | deriving instance Ord msg => Ord (Forwarding n msg) | ||
504 | |||
505 | instance Show msg => Show (Forwarding N0 msg) where | ||
506 | show (NotForwarded x) = "NotForwarded "++show x | ||
507 | |||
508 | instance ( 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 | |||
517 | instance 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 | |||
522 | instance 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 | |||
527 | instance Serialize msg => Serialize (Forwarding N0 msg) where | ||
528 | get = NotForwarded <$> get | ||
529 | put (NotForwarded msg) = put msg | ||
530 | |||
531 | instance (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 | {- | ||
536 | rewrap :: (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)) | ||
544 | rewrap 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 | |||
554 | handleOnionRequest :: 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 | ||
560 | handleOnionRequest 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 | |||
582 | wrapSymmetric :: Serialize (ReturnPath n) => | ||
583 | SymmetricKey -> Nonce24 -> (forall x. x -> Addressed x) -> ReturnPath n -> ReturnPath (S n) | ||
584 | wrapSymmetric sym n saddr rpath = ReturnPath n $ encryptSymmetric sym n (encodePlain $ saddr rpath) | ||
585 | |||
586 | peelSymmetric :: Serialize (Addressed (ReturnPath n)) | ||
587 | => SymmetricKey -> ReturnPath (S n) -> Either String (Addressed (ReturnPath n)) | ||
588 | peelSymmetric sym (ReturnPath nonce e) = decryptSymmetric sym nonce e >>= decodePlain | ||
589 | |||
590 | |||
591 | peelOnion :: Serialize (Addressed (Forwarding n t)) | ||
592 | => TransportCrypto | ||
593 | -> Nonce24 | ||
594 | -> Forwarding (S n) t | ||
595 | -> IO (Either String (Addressed (Forwarding n t))) | ||
596 | peelOnion crypto nonce (Forwarding k fwd) = do | ||
597 | fmap runIdentity . uncomposed <$> decryptMessage crypto (dhtKey crypto) nonce (Right $ Asymm k nonce fwd) | ||
598 | |||
599 | handleOnionResponse :: (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 | ||
608 | handleOnionResponse 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 | |||
626 | data 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 | |||
633 | instance Sized AnnounceRequest where size = ConstSize (32*3) | ||
634 | |||
635 | instance 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 | |||
639 | getOnionRequest :: Sized msg => Get (Asymm (Encrypted msg), ReturnPath N3) | ||
640 | getOnionRequest = 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 | |||
649 | putRequest :: ( KnownPeanoNat n | ||
650 | , Serialize (OnionRequest n) | ||
651 | , Typeable n | ||
652 | ) => OnionRequest n -> Put | ||
653 | putRequest req = do | ||
654 | let tag = 0x80 + fromIntegral (peanoVal req) | ||
655 | when (tag <= 0x82) (putWord8 tag) | ||
656 | put req | ||
657 | |||
658 | putResponse :: (KnownPeanoNat n, Serialize (OnionResponse n)) => OnionResponse n -> Put | ||
659 | putResponse 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 | |||
667 | data KeyRecord = NotStored Nonce32 | ||
668 | | SendBackKey PublicKey | ||
669 | | Acknowledged Nonce32 | ||
670 | deriving Show | ||
671 | |||
672 | instance Sized KeyRecord where size = ConstSize 33 | ||
673 | |||
674 | instance 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 | |||
685 | data AnnounceResponse = AnnounceResponse | ||
686 | { is_stored :: KeyRecord | ||
687 | , announceNodes :: SendNodes | ||
688 | } | ||
689 | deriving Show | ||
690 | |||
691 | instance Sized AnnounceResponse where | ||
692 | size = contramap is_stored size <> contramap announceNodes size | ||
693 | |||
694 | getNodeList :: S.Get [NodeInfo] | ||
695 | getNodeList = do | ||
696 | n <- S.get | ||
697 | (:) n <$> (getNodeList <|> pure []) | ||
698 | |||
699 | instance 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 | |||
703 | data DataToRoute = DataToRoute | ||
704 | { dataFromKey :: PublicKey -- Real public key of sender | ||
705 | , dataToRoute :: Encrypted OnionData -- (Word8,ByteString) -- DHTPK 0x9c | ||
706 | } | ||
707 | deriving Show | ||
708 | |||
709 | instance Sized DataToRoute where | ||
710 | size = ConstSize 32 <> contramap dataToRoute size | ||
711 | |||
712 | instance Serialize DataToRoute where | ||
713 | get = DataToRoute <$> getPublicKey <*> get | ||
714 | put (DataToRoute k dta) = putPublicKey k >> put dta | ||
715 | |||
716 | data 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 | |||
740 | instance 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 | |||
751 | instance 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 | |||
761 | selectKey :: TransportCrypto -> OnionMessage f -> OnionDestination r -> IO (SecretKey, PublicKey) | ||
762 | selectKey crypto _ rpath@(OnionDestination (AnnouncingAlias skey pkey) _ _) | ||
763 | = return (skey, pkey) | ||
764 | selectKey crypto msg rpath = return $ aliasKey crypto rpath | ||
765 | |||
766 | encrypt :: TransportCrypto | ||
767 | -> OnionMessage Identity | ||
768 | -> OnionDestination r | ||
769 | -> IO (OnionMessage Encrypted, OnionDestination r) | ||
770 | encrypt 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 | |||
782 | decrypt :: TransportCrypto -> OnionMessage Encrypted -> OnionDestination r -> IO (Either String (OnionMessage Identity, OnionDestination r)) | ||
783 | decrypt 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 | |||
804 | senderkey :: OnionDestination r -> t -> (PublicKey, t) | ||
805 | senderkey addr e = (onionKey addr, e) | ||
806 | |||
807 | aliasKey :: TransportCrypto -> OnionDestination r -> (SecretKey,PublicKey) | ||
808 | aliasKey crypto (OnionToOwner {}) = (transportSecret &&& transportPublic) crypto | ||
809 | aliasKey crypto (OnionDestination {}) = (onionAliasSecret &&& onionAliasPublic) crypto | ||
810 | |||
811 | dhtKey :: TransportCrypto -> (SecretKey,PublicKey) | ||
812 | dhtKey crypto = (transportSecret &&& transportPublic) crypto | ||
813 | |||
814 | decryptMessage :: Serialize x => | ||
815 | TransportCrypto | ||
816 | -> (SecretKey,PublicKey) | ||
817 | -> Nonce24 | ||
818 | -> Either (PublicKey, Encrypted x) | ||
819 | (Asymm (Encrypted x)) | ||
820 | -> IO ((Either String ∘ Identity) x) | ||
821 | decryptMessage 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 | |||
827 | sequenceMessage :: Applicative m => OnionMessage (m ∘ f) -> m (OnionMessage f) | ||
828 | sequenceMessage (OnionAnnounce a) = fmap OnionAnnounce $ sequenceA $ fmap uncomposed a | ||
829 | sequenceMessage (OnionAnnounceResponse n8 n24 dta) = OnionAnnounceResponse n8 n24 <$> uncomposed dta | ||
830 | sequenceMessage (OnionToRoute pub a) = pure $ OnionToRoute pub a | ||
831 | sequenceMessage (OnionToRouteResponse a) = pure $ OnionToRouteResponse a | ||
832 | -- sequenceMessage (OnionToRouteResponse a) = fmap OnionToRouteResponse $ sequenceA $ fmap uncomposed a | ||
833 | |||
834 | transcode :: forall f g. (forall a. Serialize a => Nonce24 -> Either (f a) (Asymm (f a)) -> g a) -> OnionMessage f -> OnionMessage g | ||
835 | transcode f (OnionAnnounce a) = OnionAnnounce $ a { asymmData = f (asymmNonce a) (Right a) } | ||
836 | transcode f (OnionAnnounceResponse n8 n24 dta) = OnionAnnounceResponse n8 n24 $ f n24 $ Left dta | ||
837 | transcode f (OnionToRoute pub a) = OnionToRoute pub a | ||
838 | transcode f (OnionToRouteResponse a) = OnionToRouteResponse a | ||
839 | -- transcode f (OnionToRouteResponse a) = OnionToRouteResponse $ a { asymmData = f (asymmNonce a) (Right a) } | ||
840 | |||
841 | |||
842 | data 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 | |||
853 | wrapOnion :: Serialize (Forwarding n msg) => | ||
854 | TransportCrypto | ||
855 | -> SecretKey | ||
856 | -> Nonce24 | ||
857 | -> PublicKey | ||
858 | -> SockAddr | ||
859 | -> Forwarding n msg | ||
860 | -> IO (Forwarding (S n) msg) | ||
861 | wrapOnion 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 | |||
866 | wrapOnionPure :: Serialize (Forwarding n msg) => | ||
867 | SecretKey | ||
868 | -> ToxCrypto.State | ||
869 | -> SockAddr | ||
870 | -> Forwarding n msg | ||
871 | -> Forwarding (S n) msg | ||
872 | wrapOnionPure 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 | ||
884 | data Rendezvous = Rendezvous | ||
885 | { rendezvousKey :: PublicKey | ||
886 | , rendezvousNode :: NodeInfo | ||
887 | } | ||
888 | deriving Eq | ||
889 | |||
890 | instance Show Rendezvous where | ||
891 | showsPrec d (Rendezvous k ni) | ||
892 | = showsPrec d (key2id k) | ||
893 | . (':' :) | ||
894 | . showsPrec d ni | ||
895 | |||
896 | instance 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 | |||
907 | data AnnouncedRendezvous = AnnouncedRendezvous | ||
908 | { remoteUserKey :: PublicKey | ||
909 | , rendezvous :: Rendezvous | ||
910 | } | ||
911 | deriving Eq | ||
912 | |||
913 | instance Show AnnouncedRendezvous where | ||
914 | showsPrec d (AnnouncedRendezvous remote rendez) | ||
915 | = showsPrec d (key2id remote) | ||
916 | . (':' :) | ||
917 | . showsPrec d rendez | ||
918 | |||
919 | instance 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 | |||
935 | selectAlias :: TransportCrypto -> NodeId -> STM AliasSelector | ||
936 | selectAlias 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 | |||
944 | parseDataToRoute | ||
945 | :: TransportCrypto | ||
946 | -> (OnionMessage Encrypted,OnionDestination r) | ||
947 | -> IO (Either ((PublicKey,OnionData),AnnouncedRendezvous) (OnionMessage Encrypted, OnionDestination r)) | ||
948 | parseDataToRoute 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 | ||
992 | parseDataToRoute _ msg = return $ Right msg | ||
993 | |||
994 | encodeDataToRoute :: TransportCrypto | ||
995 | -> ((PublicKey,OnionData),AnnouncedRendezvous) | ||
996 | -> IO (Maybe (OnionMessage Encrypted,OnionDestination r)) | ||
997 | encodeDataToRoute 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 ) | ||