diff options
-rw-r--r-- | src/Crypto/Tox.hs | 29 | ||||
-rw-r--r-- | src/Data/Tox/Relay.hs | 96 | ||||
-rw-r--r-- | src/Network/Tox/Onion/Transport.hs | 7 |
3 files changed, 130 insertions, 2 deletions
diff --git a/src/Crypto/Tox.hs b/src/Crypto/Tox.hs index ad246d4e..bd4cdfba 100644 --- a/src/Crypto/Tox.hs +++ b/src/Crypto/Tox.hs | |||
@@ -6,11 +6,14 @@ | |||
6 | {-# LANGUAGE DeriveFunctor #-} | 6 | {-# LANGUAGE DeriveFunctor #-} |
7 | {-# LANGUAGE DeriveGeneric #-} | 7 | {-# LANGUAGE DeriveGeneric #-} |
8 | {-# LANGUAGE DeriveTraversable #-} | 8 | {-# LANGUAGE DeriveTraversable #-} |
9 | {-# LANGUAGE ExplicitNamespaces #-} | ||
10 | {-# LANGUAGE TypeOperators #-} | 9 | {-# LANGUAGE TypeOperators #-} |
11 | {-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns #-} | 10 | {-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns #-} |
11 | {-# LANGUAGE MultiParamTypeClasses #-} | ||
12 | {-# LANGUAGE ConstraintKinds #-} | ||
13 | {-# LANGUAGE Rank2Types #-} | ||
12 | {-# LANGUAGE NamedFieldPuns #-} | 14 | {-# LANGUAGE NamedFieldPuns #-} |
13 | {-# LANGUAGE PatternSynonyms #-} | 15 | {-# LANGUAGE PatternSynonyms #-} |
16 | {-# LANGUAGE FlexibleContexts #-} | ||
14 | module Crypto.Tox | 17 | module Crypto.Tox |
15 | ( PublicKey | 18 | ( PublicKey |
16 | , publicKey | 19 | , publicKey |
@@ -38,8 +41,11 @@ module Crypto.Tox | |||
38 | , lookupSharedSecret | 41 | , lookupSharedSecret |
39 | , lookupNonceFunction | 42 | , lookupNonceFunction |
40 | , lookupNonceFunctionSTM | 43 | , lookupNonceFunctionSTM |
44 | , Payload(..) | ||
41 | , encrypt | 45 | , encrypt |
42 | , decrypt | 46 | , decrypt |
47 | , decryptPayload | ||
48 | , encryptPayload | ||
43 | , Nonce8(..) | 49 | , Nonce8(..) |
44 | , Nonce24(..) | 50 | , Nonce24(..) |
45 | , incrementNonce24 | 51 | , incrementNonce24 |
@@ -110,6 +116,8 @@ import Data.Time.Clock.POSIX | |||
110 | import Data.Hashable | 116 | import Data.Hashable |
111 | import System.IO.Unsafe (unsafeDupablePerformIO) | 117 | import System.IO.Unsafe (unsafeDupablePerformIO) |
112 | import Data.Functor.Compose | 118 | import Data.Functor.Compose |
119 | import qualified Rank2 | ||
120 | import Data.Functor.Identity | ||
113 | 121 | ||
114 | -- | A 16-byte mac and an arbitrary-length encrypted stream. | 122 | -- | A 16-byte mac and an arbitrary-length encrypted stream. |
115 | newtype Encrypted a = Encrypted ByteString | 123 | newtype Encrypted a = Encrypted ByteString |
@@ -253,6 +261,18 @@ decrypt (State hash crypt) ciphertext | |||
253 | m = fst . XSalsa.combine crypt $ c | 261 | m = fst . XSalsa.combine crypt $ c |
254 | a = Auth . Poly1305.finalize . Poly1305.update hash $ c | 262 | a = Auth . Poly1305.finalize . Poly1305.update hash $ c |
255 | 263 | ||
264 | class Rank2.Functor g => Payload c g where | ||
265 | mapPayload :: proxy c -> (forall a. c a => p a -> q a) -> g p -> g q | ||
266 | |||
267 | decryptPayload :: ( Rank2.Traversable g | ||
268 | , Payload Serialize g | ||
269 | ) => State -> g Encrypted -> Either String (g Identity) | ||
270 | decryptPayload st g = do | ||
271 | plain <- Rank2.traverse (decrypt st) g | ||
272 | Rank2.sequence $ mapPayload (Proxy :: Proxy Serialize) | ||
273 | (Composed . fmap pure . decodePlain) | ||
274 | plain | ||
275 | |||
256 | -- Encrypt-then-Mac: Encrypt the cleartext, then compute the MAC on the | 276 | -- Encrypt-then-Mac: Encrypt the cleartext, then compute the MAC on the |
257 | -- ciphertext, and prepend it to the ciphertext | 277 | -- ciphertext, and prepend it to the ciphertext |
258 | encrypt :: State -> Plain s a -> Encrypted a | 278 | encrypt :: State -> Plain s a -> Encrypted a |
@@ -261,6 +281,13 @@ encrypt (State hash crypt) (Plain m) = Encrypted $ B.append (encode a) c | |||
261 | c = fst . XSalsa.combine crypt $ m | 281 | c = fst . XSalsa.combine crypt $ m |
262 | a = Auth . Poly1305.finalize . Poly1305.update hash $ c | 282 | a = Auth . Poly1305.finalize . Poly1305.update hash $ c |
263 | 283 | ||
284 | encryptPayload :: Payload Serialize g => State -> g Identity -> g Encrypted | ||
285 | encryptPayload st g = | ||
286 | encrypt st | ||
287 | Rank2.<$> mapPayload (Proxy :: Proxy Serialize) | ||
288 | (encodePlain . runIdentity) | ||
289 | g | ||
290 | |||
264 | -- (Poly1305.State, XSalsa.State) | 291 | -- (Poly1305.State, XSalsa.State) |
265 | computeSharedSecret :: SecretKey -> PublicKey -> Nonce24 -> State | 292 | computeSharedSecret :: SecretKey -> PublicKey -> Nonce24 -> State |
266 | computeSharedSecret sk recipient = k `seq` \nonce -> | 293 | computeSharedSecret sk recipient = k `seq` \nonce -> |
diff --git a/src/Data/Tox/Relay.hs b/src/Data/Tox/Relay.hs index e35f49f0..a5366f85 100644 --- a/src/Data/Tox/Relay.hs +++ b/src/Data/Tox/Relay.hs | |||
@@ -1,10 +1,19 @@ | |||
1 | {-# LANGUAGE DeriveDataTypeable #-} | 1 | {-# LANGUAGE DeriveDataTypeable #-} |
2 | {-# LANGUAGE FlexibleInstances #-} | ||
3 | {-# LANGUAGE KindSignatures #-} | ||
4 | {-# LANGUAGE MultiParamTypeClasses #-} | ||
5 | {-# LANGUAGE ConstraintKinds #-} | ||
2 | module Data.Tox.Relay where | 6 | module Data.Tox.Relay where |
3 | 7 | ||
4 | import Data.ByteString | 8 | import Crypto.Error |
9 | import Data.ByteArray as BA | ||
10 | import Data.ByteString as B | ||
5 | import Data.Data | 11 | import Data.Data |
12 | import Data.Functor.Contravariant | ||
13 | import Data.Monoid | ||
6 | import Data.Serialize | 14 | import Data.Serialize |
7 | import Data.Word | 15 | import Data.Word |
16 | import qualified Rank2 | ||
8 | 17 | ||
9 | import Crypto.Tox | 18 | import Crypto.Tox |
10 | import Network.Tox.Onion.Transport | 19 | import Network.Tox.Onion.Transport |
@@ -29,6 +38,24 @@ packetNumber :: RelayPacket -> Word8 | |||
29 | packetNumber (RelayData conid _) = conid -- 0 to 15 not allowed. | 38 | packetNumber (RelayData conid _) = conid -- 0 to 15 not allowed. |
30 | packetNumber rp = fromIntegral $ pred $ constrIndex $ toConstr rp | 39 | packetNumber rp = fromIntegral $ pred $ constrIndex $ toConstr rp |
31 | 40 | ||
41 | instance Sized RelayPacket where | ||
42 | size = mappend (ConstSize 1) $ VarSize $ \x -> case x of | ||
43 | RoutingRequest k -> 32 | ||
44 | RoutingResponse rpid k -> 33 | ||
45 | ConnectNotification conid -> 1 | ||
46 | DisconnectNotification conid -> 1 | ||
47 | RelayPing pingid -> 8 | ||
48 | RelayPong pingid -> 8 | ||
49 | OOBSend k bs -> 32 + B.length bs | ||
50 | OOBRecv k bs -> 32 + B.length bs | ||
51 | OnionPacket query -> case contramap (`asTypeOf` query) size of | ||
52 | ConstSize n -> n | ||
53 | VarSize f -> f query | ||
54 | OnionPacketResponse answer -> case contramap (`asTypeOf` answer) size of | ||
55 | ConstSize n -> n | ||
56 | VarSize f -> f answer | ||
57 | RelayData _ bs -> B.length bs | ||
58 | |||
32 | instance Serialize RelayPacket where | 59 | instance Serialize RelayPacket where |
33 | 60 | ||
34 | get = do | 61 | get = do |
@@ -60,3 +87,70 @@ instance Serialize RelayPacket where | |||
60 | OnionPacket query -> put query | 87 | OnionPacket query -> put query |
61 | OnionPacketResponse answer -> put answer | 88 | OnionPacketResponse answer -> put answer |
62 | RelayData _ bs -> putByteString bs | 89 | RelayData _ bs -> putByteString bs |
90 | |||
91 | -- | Initial client-to-server handshake message. | ||
92 | data Hello (f :: * -> *) = Hello | ||
93 | { helloFrom :: PublicKey | ||
94 | , helloNonce :: Nonce24 | ||
95 | , helloData :: f HelloData | ||
96 | } | ||
97 | |||
98 | instance Rank2.Functor Hello where | ||
99 | f <$> Hello k n dta = Hello k n (f dta) | ||
100 | |||
101 | instance Payload Serialize Hello where | ||
102 | mapPayload _ f (Hello k n dta) = Hello k n (f dta) | ||
103 | |||
104 | instance Rank2.Foldable Hello where | ||
105 | foldMap f (Hello k n dta) = f dta | ||
106 | |||
107 | instance Rank2.Traversable Hello where | ||
108 | traverse f (Hello k n dta) = Hello k n <$> f dta | ||
109 | |||
110 | instance Sized (Hello Encrypted) where | ||
111 | size = ConstSize 56 <> contramap helloData size | ||
112 | |||
113 | instance Serialize (Hello Encrypted) where | ||
114 | get = do CryptoPassed k <- publicKey <$> getBytes 32 | ||
115 | n <- get | ||
116 | dta <- get | ||
117 | return $ Hello k n dta | ||
118 | put (Hello k n dta) = do mapM_ putWord8 $ BA.unpack k | ||
119 | put n | ||
120 | put dta | ||
121 | |||
122 | data HelloData = HelloData | ||
123 | { sessionPublicKey :: PublicKey | ||
124 | , sessionBaseNonce :: Nonce24 | ||
125 | } | ||
126 | |||
127 | instance Sized HelloData where size = ConstSize 56 | ||
128 | |||
129 | instance Serialize HelloData where | ||
130 | get = HelloData <$> (id2key <$> get) <*> get | ||
131 | put (HelloData k n) = put (key2id k) >> put n | ||
132 | |||
133 | -- | Handshake server-to-client response packet. | ||
134 | data Welcome (f :: * -> *) = Welcome | ||
135 | { welcomeNonce :: Nonce24 | ||
136 | , welcomeData :: f HelloData | ||
137 | } | ||
138 | |||
139 | instance Rank2.Functor Welcome where | ||
140 | f <$> Welcome n dta = Welcome n (f dta) | ||
141 | |||
142 | instance Payload Serialize Welcome where | ||
143 | mapPayload _ f (Welcome n dta) = Welcome n (f dta) | ||
144 | |||
145 | instance Rank2.Foldable Welcome where | ||
146 | foldMap f (Welcome _ dta) = f dta | ||
147 | |||
148 | instance Rank2.Traversable Welcome where | ||
149 | traverse f (Welcome n dta) = Welcome n <$> f dta | ||
150 | |||
151 | instance Sized (Welcome Encrypted) where | ||
152 | size = ConstSize 24 <> contramap welcomeData size | ||
153 | |||
154 | instance Serialize (Welcome Encrypted) where | ||
155 | get = Welcome <$> get <*> get | ||
156 | put (Welcome n dta) = put n >> put dta | ||
diff --git a/src/Network/Tox/Onion/Transport.hs b/src/Network/Tox/Onion/Transport.hs index ef9121f2..160b99f7 100644 --- a/src/Network/Tox/Onion/Transport.hs +++ b/src/Network/Tox/Onion/Transport.hs | |||
@@ -347,6 +347,11 @@ deriving instance ( Show (Forwarding (ThreeMinus n) (OnionMessage Encrypted)) | |||
347 | , KnownNat (PeanoNat n) | 347 | , KnownNat (PeanoNat n) |
348 | ) => Show (OnionRequest n) | 348 | ) => Show (OnionRequest n) |
349 | 349 | ||
350 | instance Sized (OnionRequest N0) where -- N1 and N2 are the same, N3 does not encode the nonce. | ||
351 | size = contramap onionNonce size | ||
352 | <> contramap onionForward size | ||
353 | <> contramap pathFromOwner size | ||
354 | |||
350 | instance ( Serialize (Forwarding (ThreeMinus n) (OnionMessage Encrypted)) | 355 | instance ( Serialize (Forwarding (ThreeMinus n) (OnionMessage Encrypted)) |
351 | , Sized (ReturnPath n) | 356 | , Sized (ReturnPath n) |
352 | , Serialize (ReturnPath n) | 357 | , Serialize (ReturnPath n) |
@@ -383,6 +388,8 @@ instance ( Serialize (ReturnPath n) ) => Serialize (OnionResponse n) where | |||
383 | . getOnionReply) | 388 | . getOnionReply) |
384 | put (OnionResponse p m) = put p >> putOnionMsg m | 389 | put (OnionResponse p m) = put p >> putOnionMsg m |
385 | 390 | ||
391 | instance (Sized (ReturnPath n)) => Sized (OnionResponse (S n)) where | ||
392 | size = contramap pathToOwner size <> contramap msgToOwner size | ||
386 | 393 | ||
387 | data Addressed a = Addressed { sockAddr :: SockAddr, unaddressed :: a } | 394 | data Addressed a = Addressed { sockAddr :: SockAddr, unaddressed :: a } |
388 | deriving (Eq,Show) | 395 | deriving (Eq,Show) |