summaryrefslogtreecommitdiff
path: root/tox-crypto/src
diff options
context:
space:
mode:
Diffstat (limited to 'tox-crypto/src')
-rw-r--r--tox-crypto/src/Crypto/Tox.hs710
-rw-r--r--tox-crypto/src/DebugTag.hs24
2 files changed, 734 insertions, 0 deletions
diff --git a/tox-crypto/src/Crypto/Tox.hs b/tox-crypto/src/Crypto/Tox.hs
new file mode 100644
index 00000000..ea276045
--- /dev/null
+++ b/tox-crypto/src/Crypto/Tox.hs
@@ -0,0 +1,710 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE KindSignatures #-}
5{-# LANGUAGE DeriveDataTypeable #-}
6{-# LANGUAGE DeriveFunctor #-}
7{-# LANGUAGE DeriveGeneric #-}
8{-# LANGUAGE DeriveTraversable #-}
9{-# LANGUAGE TypeOperators #-}
10{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns #-}
11{-# LANGUAGE MultiParamTypeClasses #-}
12{-# LANGUAGE ConstraintKinds #-}
13{-# LANGUAGE Rank2Types #-}
14{-# LANGUAGE NamedFieldPuns #-}
15{-# LANGUAGE PatternSynonyms #-}
16{-# LANGUAGE FlexibleContexts #-}
17{-# LANGUAGE OverloadedStrings #-}
18module Crypto.Tox
19 ( PublicKey
20 , publicKey
21 , getPublicKey
22 , putPublicKey
23 , SecretKey
24 , generateSecretKey
25 , toPublic
26 , SymmetricKey(..)
27 , TransportCrypto(..)
28 , newCrypto
29 , SecretsCache
30 , newSecretsCache
31 , Encrypted
32 , Encrypted8(..)
33 , type (∘), uncomposed, pattern Composed -- type (∘)(..)
34 , Asymm(..)
35 , getAsymm
36 , getAliasedAsymm
37 , putAsymm
38 , putAliasedAsymm
39 , Plain
40 , encodePlain
41 , decodePlain
42 -- , computeSharedSecret
43 , lookupSharedSecret
44 , lookupNonceFunction
45 , lookupNonceFunctionSTM
46 , Payload(..)
47 , encrypt
48 , decrypt
49 , decryptPayload
50 , encryptPayload
51 , Nonce8(..)
52 , Nonce24(..)
53 , incrementNonce24
54 , nonce24ToWord16
55 , addtoNonce24
56 , Nonce32(..)
57 , getRemainingEncrypted
58 , putEncrypted
59 , Auth
60 , Sized(..)
61 , Size(..)
62 , State(..)
63 , zeros32
64 , zeros24
65 , decryptSymmetric
66 , encryptSymmetric
67 , encodeSecret
68 , decodeSecret
69 , xorsum
70 ) where
71
72import Control.Arrow
73import Control.Monad
74import qualified Crypto.Cipher.ChaChaPoly1305 as Symmetric
75import qualified Crypto.Cipher.Salsa as Salsa
76import qualified Crypto.Cipher.XSalsa as XSalsa
77import qualified Crypto.Error as Cryptonite
78import qualified Crypto.MAC.Poly1305 as Poly1305
79import Crypto.PubKey.Curve25519
80import Data.Bits
81import qualified Data.ByteArray as BA
82 ;import Data.ByteArray as BA (ByteArrayAccess, Bytes)
83import Data.ByteString as B
84import qualified Data.ByteString.Base16 as Base16
85import qualified Data.ByteString.Base64 as Base64
86import qualified Data.ByteString.Char8 as C8
87import Data.Data
88import Data.Functor.Contravariant
89#if MIN_VERSION_base(4,9,1)
90import Data.Kind
91#else
92import GHC.Exts (Constraint)
93#endif
94import Data.Ord
95import Data.Serialize as S
96import Data.Semigroup
97import Data.Word
98import Foreign.Marshal.Alloc
99import Foreign.Ptr
100import Foreign.Storable
101import System.Endian
102import Control.Concurrent.STM
103#ifdef CRYPTONITE_BACKPORT
104import Crypto.ECC.Class
105import Crypto.Error.Types (CryptoFailable (..), throwCryptoError)
106#else
107import Crypto.ECC
108import Crypto.Error
109#endif
110import Crypto.Random
111import Network.Socket (SockAddr)
112import GHC.Exts (Word(..),inline)
113import GHC.Generics (Generic)
114import GHC.Prim
115import Data.Word64Map (fitsInInt)
116import Data.MinMaxPSQ (MinMaxPSQ')
117import qualified Data.MinMaxPSQ as MM
118import Data.Time.Clock.POSIX
119import Data.Hashable
120import System.IO.Unsafe (unsafeDupablePerformIO)
121import Data.Functor.Compose
122import qualified Rank2
123import Data.Functor.Identity
124import DPut
125import DebugTag
126
127-- | A 16-byte mac and an arbitrary-length encrypted stream.
128newtype Encrypted a = Encrypted ByteString
129 deriving (Eq,Ord,Data,ByteArrayAccess,Hashable,Generic)
130
131newtype Encrypted8 a = E8 (Encrypted (a,Nonce8))
132 deriving (Serialize, Show)
133
134-- Simulating: newtype (f ∘ g) x = Composed { uncomposed :: f (g x) }
135pattern Composed x = Compose x
136uncomposed = getCompose
137type f ∘ g = f `Compose` g
138infixr 9 ∘
139
140newtype Auth = Auth Poly1305.Auth deriving (Eq, ByteArrayAccess)
141instance Ord Auth where
142 compare (Auth a) (Auth b) = comparing (BA.convert :: Poly1305.Auth -> Bytes) a b
143instance Data Auth where
144 gfoldl k z x = z x
145 -- Well, this is a little wonky... XXX
146 gunfold k z c = k (z (Auth . Poly1305.Auth . (BA.convert :: ByteString -> Bytes)))
147 toConstr _ = con_Auth
148 dataTypeOf _ = mkDataType "Crypto.Tox" [con_Auth]
149con_Auth :: Constr
150con_Auth = mkConstr (dataTypeOf (Auth (error "con_Auth"))) "Auth" [] Prefix
151instance Serialize Auth where
152 get = Auth . Poly1305.Auth . BA.convert <$> getBytes 16
153 put (Auth (Poly1305.Auth bs)) = putByteString $ BA.convert bs
154
155instance Typeable a => Show (Encrypted a) where
156 show (Encrypted _) = "Encrypted "++show (typeOf (undefined :: a))
157
158encryptedAuth :: Encrypted a -> Auth
159encryptedAuth (Encrypted bs)
160 | Right auth <- decode (B.take 16 bs) = auth
161 | otherwise = error "encryptedAuth: insufficient bytes"
162
163authAndBytes :: Encrypted a -> (Auth, ByteString)
164authAndBytes (Encrypted bs) = (auth,bs')
165 where
166 (as,bs') = B.splitAt 16 bs
167 Right auth = decode as
168
169-- | Info about a type's serialized length. Either the length is known
170-- independently of the value, or the length depends on the value.
171data Size a
172 = VarSize (a -> Int)
173 | ConstSize { constSize :: !Int }
174 deriving Typeable
175
176instance Contravariant Size where
177 contramap f sz = case sz of
178 ConstSize n -> ConstSize n
179 VarSize g -> VarSize (\x -> g (f x))
180
181instance Semigroup (Size a) where
182 ConstSize x <> ConstSize y = ConstSize (x + y)
183 VarSize f <> ConstSize y = VarSize $ \x -> f x + y
184 ConstSize x <> VarSize g = VarSize $ \y -> x + g y
185 VarSize f <> VarSize g = VarSize $ \x -> f x + g x
186
187instance Monoid (Size a) where
188 mappend = (<>)
189 mempty = ConstSize 0
190
191
192class Sized a where size :: Size a
193
194instance Sized a => Serialize (Encrypted a) where
195 get = case size :: Size a of
196 VarSize _ -> Encrypted <$> (remaining >>= getBytes)
197 ConstSize n -> Encrypted <$> getBytes (16 + n) -- 16 extra for Poly1305 mac
198 put = putEncrypted
199
200instance Sized a => Sized (Encrypted a) where
201 size = case size :: Size a of
202 ConstSize n -> ConstSize $ n + 16
203 VarSize _ -> VarSize $ \(Encrypted bs) -> B.length bs
204
205instance (Sized a, Sized b) => Sized (a,b) where
206 size = case (size :: Size a, size :: Size b) of
207 (ConstSize a , ConstSize b) -> ConstSize $ a + b
208 (VarSize f , ConstSize b) -> VarSize $ \(a, _) -> f a + b
209 (ConstSize a , VarSize g) -> VarSize $ \(_, b) -> a + g b
210 (VarSize f , VarSize g) -> VarSize $ \(a, b) -> f a + g b
211
212getRemainingEncrypted :: Get (Encrypted a)
213getRemainingEncrypted = Encrypted <$> (remaining >>= getBytes)
214
215putEncrypted :: Encrypted a -> Put
216putEncrypted (Encrypted bs) = putByteString bs
217
218newtype Plain (s:: * -> Constraint) a = Plain ByteString
219 deriving (Eq,Ord,Show,ByteArrayAccess)
220
221
222decodePlain :: Serialize a => Plain Serialize a -> Either String a
223decodePlain (Plain bs) = decode bs
224
225encodePlain :: Serialize a => a -> Plain Serialize a
226encodePlain a = Plain $ encode a
227
228storePlain :: Storable a => a -> IO (Plain Storable a)
229storePlain a = Plain <$> BA.create (sizeOf a) (`poke` a)
230
231retrievePlain :: Storable a => Plain Storable a -> IO a
232retrievePlain (Plain bs) = BA.withByteArray bs peek
233
234decryptSymmetric :: SymmetricKey -> Nonce24 -> Encrypted a -> Either String (Plain s a)
235decryptSymmetric (SymmetricKey symmkey) (Nonce24 n24) (Encrypted bs) = do
236 let sym_nonce_bytes = B.take 12 n24
237 (mac, bs'') = B.splitAt 16 bs
238 symm <- left show . Cryptonite.eitherCryptoError $ do
239 sym_nonce <- Symmetric.nonce12 sym_nonce_bytes
240 Symmetric.initialize symmkey sym_nonce
241 let (ds, symm') = Symmetric.decrypt bs'' symm
242 auth = Symmetric.finalize symm'
243 if BA.convert auth /= mac
244 then Left "Symmetric decryption failed. Incorrect key material?"
245 else return $ Plain ds
246
247encryptSymmetric :: SymmetricKey -> Nonce24 -> Plain s x -> Encrypted x
248encryptSymmetric (SymmetricKey symmkey) (Nonce24 n24) (Plain bs) = Encrypted es
249 where
250 Cryptonite.CryptoPassed es = do
251 sym_nonce <- Symmetric.nonce12 (BA.take 12 n24)
252 symm <- Symmetric.initialize symmkey sym_nonce
253 let (rpath_bs, symm') = Symmetric.encrypt bs symm
254 auth = Symmetric.finalize symm' -- 16 bytes
255 return (BA.convert auth `BA.append` rpath_bs)
256
257
258data State = State Poly1305.State XSalsa.State
259
260decrypt :: State -> Encrypted a -> Either String (Plain s a)
261decrypt (State hash crypt) ciphertext
262 | (a == mac) = Right (Plain m)
263 | otherwise = Left "Asymmetric decryption failed. Incorrect key material?"
264 where
265 (mac, c) = authAndBytes ciphertext
266 m = fst . XSalsa.combine crypt $ c
267 a = Auth . Poly1305.finalize . Poly1305.update hash $ c
268
269class Rank2.Functor g => Payload c g where
270 mapPayload :: proxy c -> (forall a. c a => p a -> q a) -> g p -> g q
271
272decryptPayload :: ( Rank2.Traversable g
273 , Payload Serialize g
274 ) => State -> g Encrypted -> Either String (g Identity)
275decryptPayload st g = do
276 plain <- Rank2.traverse (decrypt st) g
277 Rank2.sequence $ mapPayload (Proxy :: Proxy Serialize)
278 (Composed . fmap pure . decodePlain)
279 plain
280
281-- Encrypt-then-Mac: Encrypt the cleartext, then compute the MAC on the
282-- ciphertext, and prepend it to the ciphertext
283encrypt :: State -> Plain s a -> Encrypted a
284encrypt (State hash crypt) (Plain m) = Encrypted $ B.append (encode a) c
285 where
286 c = fst . XSalsa.combine crypt $ m
287 a = Auth . Poly1305.finalize . Poly1305.update hash $ c
288
289encryptPayload :: Payload Serialize g => State -> g Identity -> g Encrypted
290encryptPayload st g =
291 encrypt st
292 Rank2.<$> mapPayload (Proxy :: Proxy Serialize)
293 (encodePlain . runIdentity)
294 g
295
296-- (Poly1305.State, XSalsa.State)
297computeSharedSecret :: SecretKey -> PublicKey -> Nonce24 -> State
298computeSharedSecret sk recipient = k `seq` \nonce ->
299 let -- cipher state
300 st0 = XSalsa.initialize 20 k nonce
301 -- Poly1305 key
302 (rs, crypt) = XSalsa.combine st0 zs where Nonce32 zs = zeros32
303 -- Since rs is 32 bytes, this pattern should never fail...
304 Cryptonite.CryptoPassed hash = Poly1305.initialize rs
305 in State hash crypt
306 where
307 -- diffie helman
308#if MIN_VERSION_cryptonite(0,24,0)
309 -- TODO: Handle failure.
310 -- Failure was observed...
311 -- Reproduce by issuing tox command "ping 192.168.10.1:33446" without specifying
312 -- the public key portion of the node id.
313 -- "Irrefutable pattern failed for pattern CryptoPassed shared"
314 Cryptonite.CryptoPassed shared = ecdh (Proxy :: Proxy Curve_X25519) sk recipient
315#else
316 shared = ecdh (Proxy :: Proxy Curve_X25519) sk recipient
317#endif
318 -- shared secret XSalsa key
319 k = hsalsa20 shared zeros24
320
321unsafeFirstWord64 :: ByteArrayAccess ba => ba -> Word64
322unsafeFirstWord64 ba = unsafeDupablePerformIO $ BA.withByteArray ba peek
323{-# INLINE unsafeFirstWord64 #-}
324
325instance Hashable PublicKey where
326 hashWithSalt salt pk = hashWithSalt salt (unsafeFirstWord64 pk)
327 {-# INLINE hashWithSalt #-}
328
329instance Hashable SecretKey where
330 hashWithSalt salt sk = hashWithSalt salt (unsafeFirstWord64 sk)
331 {-# INLINE hashWithSalt #-}
332
333instance Ord PublicKey where compare = unsafeCompare32Bytes
334 {-# INLINE compare #-}
335instance Ord SecretKey where compare = unsafeCompare32Bytes
336 {-# INLINE compare #-}
337
338unsafeCompare32Bytes :: (ByteArrayAccess ba, ByteArrayAccess bb)
339 => ba -> bb -> Ordering
340unsafeCompare32Bytes ba bb =
341 unsafeDupablePerformIO $ BA.withByteArray ba
342 $ \pa -> BA.withByteArray bb
343 $ \pb -> unsafeCompare32Bytes' 3 pa pb
344
345unsafeCompare32Bytes' :: Int -> Ptr Word64 -> Ptr Word64 -> IO Ordering
346unsafeCompare32Bytes' !n !pa !pb = do
347 a <- peek pa
348 b <- peek pb
349 if n == 0
350 then return $! inline compare a b
351 else case inline compare a b of
352 EQ -> unsafeCompare32Bytes' (n - 1)
353 (pa `plusPtr` 8)
354 (pb `plusPtr` 8)
355 neq -> return neq
356
357
358
359lookupSharedSecret :: TransportCrypto -> SecretKey -> PublicKey -> Nonce24 -> IO State
360lookupSharedSecret crypto sk recipient nonce
361 = ($ nonce) <$> lookupNonceFunction crypto sk recipient
362
363{-# INLINE lookupNonceFunction #-}
364lookupNonceFunction :: TransportCrypto -> SecretKey -> PublicKey -> IO (Nonce24 -> State)
365lookupNonceFunction c@(TransportCrypto{secretsCache}) sk recipient = do
366 now <- getPOSIXTime
367 atomically $ lookupNonceFunctionSTM now c sk recipient
368
369{-# INLINE lookupNonceFunctionSTM #-}
370-- | This version of 'lookupNonceFunction' is STM instead of IO, this means if some later part of
371-- of the transaction fails, we may end up forgoing a computation that could have been cached.
372-- Use with care. In most circumstances you probably want 'lookupNonceFunction'. It also commits
373-- us to using TVars to store the cache.
374lookupNonceFunctionSTM :: POSIXTime -> TransportCrypto -> SecretKey -> PublicKey -> STM (Nonce24 -> State)
375lookupNonceFunctionSTM now TransportCrypto{secretsCache} sk recipient = do
376 mm <- readTVar $ sharedSecret secretsCache
377 case MM.lookup' recipient mm of
378 Nothing -> do
379 let miss = computeSharedSecret sk recipient
380 writeTVar (sharedSecret secretsCache)
381 (MM.insertTake' 160 recipient (MM.singleton' sk miss (Down now)) (Down now) mm)
382 return miss
383 Just (stamp,smm) -> do
384 let (r,v) = case MM.lookup' sk smm of
385 Nothing | let miss = computeSharedSecret sk recipient
386 -> (miss, MM.insertTake' 3 sk miss (Down now) smm)
387 Just (stamp2,hit) -> (hit , MM.insert' sk hit (Down now) smm)
388 writeTVar (sharedSecret secretsCache)
389 (MM.insertTake' 160 recipient v (Down now) mm)
390 return r
391
392
393hsalsa20 :: (ByteArrayAccess t, ByteArrayAccess t1) => t1 -> t -> BA.ScrubbedBytes
394hsalsa20 k n = BA.append a b
395 where
396 Salsa.State st = XSalsa.initialize 20 k n
397 (_, as) = BA.splitAt 4 st
398 (a, xs) = BA.splitAt 16 as
399 (_, bs) = BA.splitAt 24 xs
400 (b, _ ) = BA.splitAt 16 bs
401
402
403newtype Nonce24 = Nonce24 ByteString
404 deriving (Eq, Ord, ByteArrayAccess, Data, Generic, Hashable)
405
406nonce24ToWord16 :: Nonce24 -> Word16
407nonce24ToWord16 (Nonce24 n24) = fromIntegral (B.index n24 23) + 256 * fromIntegral (B.index n24 22)
408
409addtoNonce24 :: Nonce24 -> Word -> Nonce24
410addtoNonce24 (Nonce24 n24) n = unsafeDupablePerformIO $ Nonce24 <$> BA.copy n24 init
411 where
412 init :: Ptr Word -> IO ()
413 init ptr | fitsInInt (Proxy :: Proxy Word64) = do
414 let frmBE64 = fromIntegral . fromBE64 . fromIntegral
415 tBE64 = fromIntegral . toBE64 . fromIntegral
416 !(W# input) = n
417 W# w1 <- frmBE64 <$> peek ptr
418 W# w2 <- frmBE64 <$> peekElemOff ptr 1
419 W# w3 <- frmBE64 <$> peekElemOff ptr 2
420 let (# overflw, sum #) = plusWord2# w3 input
421 (# overflw', sum' #) = plusWord2# w2 overflw
422 (# discard, sum'' #) = plusWord2# w1 overflw'
423 poke ptr $ tBE64 (W# sum'')
424 pokeElemOff ptr 1 $ tBE64 (W# sum')
425 pokeElemOff ptr 2 $ tBE64 (W# sum)
426
427 init ptr | fitsInInt (Proxy :: Proxy Word32) = do
428 let frmBE32 = fromIntegral . fromBE32 . fromIntegral
429 tBE32 = fromIntegral . toBE32 . fromIntegral
430 !(W# input) = n
431 W# w1 <- frmBE32 <$> peek ptr
432 W# w2 <- frmBE32 <$> peekElemOff ptr 1
433 W# w3 <- frmBE32 <$> peekElemOff ptr 2
434 W# w4 <- frmBE32 <$> peekElemOff ptr 3
435 W# w5 <- frmBE32 <$> peekElemOff ptr 4
436 W# w6 <- frmBE32 <$> peekElemOff ptr 5
437 let (# overflw_, sum_ #) = plusWord2# w6 input
438 (# overflw__, sum__ #) = plusWord2# w5 overflw_
439 (# overflw___, sum___ #) = plusWord2# w6 overflw__
440 (# overflw, sum #) = plusWord2# w3 overflw___
441 (# overflw', sum' #) = plusWord2# w2 overflw
442 (# discard, sum'' #) = plusWord2# w1 overflw'
443 poke ptr $ tBE32 (W# sum'')
444 pokeElemOff ptr 1 $ tBE32 (W# sum')
445 pokeElemOff ptr 2 $ tBE32 (W# sum)
446 pokeElemOff ptr 3 $ tBE32 (W# sum___)
447 pokeElemOff ptr 4 $ tBE32 (W# sum__)
448 pokeElemOff ptr 5 $ tBE32 (W# sum_)
449 init _ = error "incrementNonce24: I only support 64 and 32 bits"
450
451incrementNonce24 :: Nonce24 -> Nonce24
452incrementNonce24 nonce24 = addtoNonce24 nonce24 1
453{-# INLINE incrementNonce24 #-}
454
455quoted :: ShowS -> ShowS
456quoted shows s = '"':shows ('"':s)
457
458bin2hex :: ByteArrayAccess bs => bs -> String
459bin2hex = C8.unpack . Base16.encode . BA.convert
460
461bin2base64 :: ByteArrayAccess bs => bs -> String
462bin2base64 = C8.unpack . Base64.encode . BA.convert
463
464
465instance Show Nonce24 where
466 showsPrec d nonce = quoted (mappend $ bin2hex nonce)
467
468instance Sized Nonce24 where size = ConstSize 24
469
470instance Serialize Nonce24 where
471 get = Nonce24 <$> getBytes 24
472 put (Nonce24 bs) = putByteString bs
473
474newtype Nonce8 = Nonce8 Word64
475 deriving (Eq, Ord, Data, Serialize)
476
477-- Note: Big-endian to match Serialize instance.
478instance Storable Nonce8 where
479 sizeOf _ = 8
480 alignment _ = alignment (undefined::Word64)
481 peek ptr = Nonce8 . fromBE64 <$> peek (castPtr ptr)
482 poke ptr (Nonce8 w) = poke (castPtr ptr) (toBE64 w)
483
484instance Sized Nonce8 where size = ConstSize 8
485
486instance ByteArrayAccess Nonce8 where
487 length _ = 8
488 withByteArray (Nonce8 w64) kont =
489 allocaBytes 8 $ \p -> do
490 poke (castPtr p :: Ptr Word64) $ toBE64 w64
491 kont p
492
493instance Show Nonce8 where
494 showsPrec d nonce = quoted (mappend $ bin2hex nonce)
495
496
497newtype Nonce32 = Nonce32 ByteString
498 deriving (Eq, Ord, ByteArrayAccess, Data)
499
500instance Show Nonce32 where
501 showsPrec d nonce = mappend $ bin2base64 nonce
502
503instance Read Nonce32 where
504 readsPrec _ str = either (const []) id $ do
505 let (ds,ss) = Prelude.splitAt 43 str
506 ss' <- case ss of
507 '=':xs -> Right xs -- optional terminating '='
508 _ -> Right ss
509 bs <- Base64.decode (C8.pack $ ds ++ ['='])
510 if B.length bs == 32
511 then Right [ (Nonce32 bs, ss') ]
512 else Left "Insuffiicent base64 digits while parsing Nonce32."
513
514instance Serialize Nonce32 where
515 get = Nonce32 <$> getBytes 32
516 put (Nonce32 bs) = putByteString bs
517
518instance Sized Nonce32 where size = ConstSize 32
519
520
521zeros32 :: Nonce32
522zeros32 = Nonce32 $ BA.replicate 32 0
523
524zeros24 :: ByteString
525zeros24 = BA.take 24 zs where Nonce32 zs = zeros32
526
527-- | `32` | sender's DHT public key |
528-- | `24` | nonce |
529-- | `?` | encrypted message |
530data Asymm a = Asymm
531 { senderKey :: PublicKey
532 , asymmNonce :: Nonce24
533 , asymmData :: a
534 }
535 deriving (Functor,Foldable,Traversable, Show, Eq, Ord)
536
537instance Sized a => Sized (Asymm a) where
538 size = case size of
539 ConstSize a -> ConstSize $ a + 24 + 32
540 VarSize f -> VarSize $ \Asymm { asymmData = x } -> f x + 24 + 32
541
542-- | Field order: senderKey, then nonce This is the format used by
543-- Ping/Pong/GetNodes/SendNodes.
544--
545-- See 'getAliasedAsymm' if the nonce precedes the key.
546getAsymm :: Serialize a => Get (Asymm a)
547getAsymm = Asymm <$> getPublicKey <*> get <*> get
548
549putAsymm :: Serialize a => Asymm a -> Put
550putAsymm (Asymm key nonce dta) = putPublicKey key >> put nonce >> put dta
551
552-- | Field order: nonce, and then senderKey.
553getAliasedAsymm :: Serialize a => Get (Asymm a)
554getAliasedAsymm = flip Asymm <$> get <*> getPublicKey <*> get
555
556putAliasedAsymm :: Serialize a => Asymm a -> Put
557putAliasedAsymm (Asymm key nonce dta) = put nonce >> putPublicKey key >> put dta
558
559data SecretsCache = SecretsCache
560 { sharedSecret :: TVar (MinMaxPSQ' PublicKey
561 (Down POSIXTime)
562 (MinMaxPSQ' SecretKey (Down POSIXTime) (Nonce24 -> State)))
563 }
564
565newSecretsCache :: IO SecretsCache
566newSecretsCache = atomically (SecretsCache <$> newTVar MM.empty)
567
568
569newtype SymmetricKey = SymmetricKey ByteString
570
571instance Show SymmetricKey where
572 show (SymmetricKey bs) = bin2base64 bs
573
574data TransportCrypto = TransportCrypto
575 { transportSecret :: SecretKey
576 , transportPublic :: PublicKey
577 , onionAliasSecret :: SecretKey
578 , onionAliasPublic :: PublicKey
579 , rendezvousSecret :: SecretKey
580 , rendezvousPublic :: PublicKey
581 , transportSymmetric :: STM SymmetricKey
582 , transportNewNonce :: STM Nonce24
583 , transportNewKey :: STM SecretKey
584 , userKeys :: STM [(SecretKey,PublicKey)]
585 , pendingCookies :: TVar [(SockAddr, (Int, PublicKey))]
586 , secretsCache :: SecretsCache
587 }
588
589getPublicKey :: S.Get PublicKey
590getPublicKey = eitherCryptoError . publicKey <$> S.getBytes 32
591 >>= either (fail . show) return
592
593putPublicKey :: PublicKey -> S.Put
594putPublicKey bs = S.putByteString $ BA.convert bs
595
596-- 32 bytes -> 42 base64 digits.
597--
598encodeSecret :: SecretKey -> Maybe C8.ByteString
599encodeSecret k = do
600 (a,bs) <- BA.uncons (BA.convert k)
601 -- Bytes
602 -- 1 31
603 -- a | bs
604 (cs,c) <- unsnoc bs
605 -- Bytes
606 -- 1 30 1
607 -- a | cs | c
608 --
609 -- Based on the following pasted from the generateSecretKey function:
610 --
611 -- tweakToSecretKey :: ScrubbedBytes -> SecretKey
612 -- tweakToSecretKey bin = SecretKey $ B.copyAndFreeze bin $ \inp -> do
613 -- modifyByte inp 0 (\e0 -> e0 .&. 0xf8)
614 -- modifyByte inp 31 (\e31 -> (e31 .&. 0x7f) .|. 0x40)
615 --
616 -- We know the following holds:
617 -- a == a .&. 0xf8
618 -- c == (c .&. 0x7f) .|. 0x40
619 --
620 -- Therefore, there are 5 reserved bits:
621 -- a := aaaa a000
622 -- c := 01dd cccc
623 --
624 -- That gives us 256 - 5 = 251 bits to encode.
625 -- 42 * 6 = 252
626 --
627 let -- We'll reserve the first bit as zero so that the encoded
628 -- key starts with a digit between A and f. Other digits will be
629 -- arbitrary.
630 --
631 -- The middle 30 bytes will be encoded as is from the source byte
632 -- string (cs). It remains to compute the first (a') and last (c')
633 -- bytes.
634 xs = Base64.encode $ a' `BA.cons` cs `BA.snoc` c'
635 -- a' := 0aaaaadd
636 a' = shiftR a 1 .|. (shiftR c 4 .&. 0x03)
637 -- c' := cccc0000
638 c' = shiftL c 4
639 return $ BA.take 42 xs
640
641-- 42 base64 digits. First digit should be between A and f. The rest are
642-- arbitrary.
643decodeSecret :: C8.ByteString -> Maybe SecretKey
644decodeSecret k64 | B.length k64 < 42 = Nothing
645decodeSecret k64 = do
646 xs <- either (const Nothing) Just $ Base64.decode $ B.append k64 "A="
647 (a',ds) <- B.uncons $ B.take 32 xs
648 (cs,c') <- B.unsnoc ds
649 let c = 0x40 .|. shiftR c' 4 .|. ( 0x30 .&. shiftL a' 4)
650 a = 0xf8 .&. shiftL a' 1
651 case secretKey $ B.cons a cs `B.snoc` c of
652 CryptoPassed x -> Just x
653 _ -> Nothing
654
655-- Treats byte pairs as big-endian.
656xorsum :: ByteArrayAccess ba => ba -> Word16
657xorsum bs = unsafeDupablePerformIO $ BA.withByteArray bs $ \ptr16 -> do
658 let (wcnt,r) = BA.length bs `divMod` 2
659 loop cnt !ac = do
660 ac' <- xor ac <$> peekElemOff ptr16 cnt
661 case cnt of 0 -> return $ fromBE16 ac'
662 _ -> loop (cnt - 1) ac'
663 loop (wcnt - 1) $ case r of
664 0 -> 0
665 _ -> 256 * fromIntegral (BA.index bs (BA.length bs - 1))
666
667showHex :: BA.ByteArrayAccess ba => ba -> String
668showHex bs = C8.unpack $ Base16.encode $ BA.convert bs
669
670newCrypto :: IO TransportCrypto
671newCrypto = do
672 secret <- generateSecretKey
673 alias <- generateSecretKey
674 ralias <- generateSecretKey
675 let pubkey = toPublic secret
676 aliaspub = toPublic alias
677 raliaspub = toPublic ralias
678 ukeys <- atomically $ newTVar []
679 (symkey, drg) <- do
680 drg0 <- getSystemDRG
681 return $ randomBytesGenerate 32 drg0 :: IO (ByteString, SystemDRG)
682 noncevar <- atomically $ newTVar $ fst $ withDRG drg drgNew
683 cookieKeys <- atomically $ newTVar []
684 cache <- newSecretsCache
685 dput XNetCrypto $ "secret(tox) = " ++ showHex secret
686 dput XNetCrypto $ "public(tox) = " ++ showHex pubkey
687 dput XNetCrypto $ "symmetric(tox) = " ++ showHex symkey
688 return TransportCrypto
689 { transportSecret = secret
690 , transportPublic = pubkey
691 , onionAliasSecret = alias
692 , onionAliasPublic = aliaspub
693 , rendezvousSecret = ralias
694 , rendezvousPublic = raliaspub
695 , transportSymmetric = return $ SymmetricKey symkey
696 , transportNewNonce = do
697 drg1 <- readTVar noncevar
698 let (nonce, drg2) = withDRG drg1 (Nonce24 <$> getRandomBytes 24)
699 writeTVar noncevar drg2
700 return nonce
701 , transportNewKey = do
702 drg1 <- readTVar noncevar
703 let (k, drg2) = withDRG drg1 generateSecretKey
704 writeTVar noncevar drg2
705 return k
706 , userKeys = return []
707 , pendingCookies = cookieKeys
708 , secretsCache = cache
709 }
710
diff --git a/tox-crypto/src/DebugTag.hs b/tox-crypto/src/DebugTag.hs
new file mode 100644
index 00000000..9ac04bb0
--- /dev/null
+++ b/tox-crypto/src/DebugTag.hs
@@ -0,0 +1,24 @@
1module DebugTag where
2
3import Data.Typeable
4
5-- | Debug Tags, add more as needed, but ensure XAnnounce is always first, XMisc last
6data DebugTag
7 = XAnnounce
8 | XBitTorrent
9 | XDHT
10 | XLan
11 | XMan
12 | XNetCrypto
13 | XNetCryptoOut
14 | XOnion
15 | XRoutes
16 | XPing
17 | XRefresh
18 | XJabber
19 | XTCP
20 | XMisc
21 | XNodeinfoSearch
22 | XUnexpected -- Used only for special anomalous errors that we didn't expect to happen.
23 | XUnused -- Never commit code that uses XUnused.
24 deriving (Eq, Ord, Show, Read, Enum, Bounded,Typeable)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 07:23:45 +0000