From 11987749fc6e6d3e53ea737d46d5ab13a16faeb8 Mon Sep 17 00:00:00 2001 From: James Crayne Date: Sat, 28 Sep 2019 13:43:29 -0400 Subject: 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 --- tox-crypto/CHANGELOG.md | 5 + tox-crypto/CHANGELOG.md.save0 | 5 + tox-crypto/LICENSE | 30 ++ tox-crypto/LICENSE.save0 | 30 ++ tox-crypto/Setup.hs | 2 + tox-crypto/Setup.hs.save0 | 2 + tox-crypto/src/Crypto/Tox.hs | 710 ++++++++++++++++++++++++++++++++++++++++++ tox-crypto/src/DebugTag.hs | 24 ++ tox-crypto/tox-crypto.cabal | 59 ++++ 9 files changed, 867 insertions(+) create mode 100644 tox-crypto/CHANGELOG.md create mode 100644 tox-crypto/CHANGELOG.md.save0 create mode 100644 tox-crypto/LICENSE create mode 100644 tox-crypto/LICENSE.save0 create mode 100644 tox-crypto/Setup.hs create mode 100644 tox-crypto/Setup.hs.save0 create mode 100644 tox-crypto/src/Crypto/Tox.hs create mode 100644 tox-crypto/src/DebugTag.hs create mode 100644 tox-crypto/tox-crypto.cabal (limited to 'tox-crypto') diff --git a/tox-crypto/CHANGELOG.md b/tox-crypto/CHANGELOG.md new file mode 100644 index 00000000..f7064c45 --- /dev/null +++ b/tox-crypto/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for tox-crypto + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/tox-crypto/CHANGELOG.md.save0 b/tox-crypto/CHANGELOG.md.save0 new file mode 100644 index 00000000..f7064c45 --- /dev/null +++ b/tox-crypto/CHANGELOG.md.save0 @@ -0,0 +1,5 @@ +# Revision history for tox-crypto + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/tox-crypto/LICENSE b/tox-crypto/LICENSE new file mode 100644 index 00000000..e8eaef49 --- /dev/null +++ b/tox-crypto/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2019, James Crayne + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of James Crayne nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/tox-crypto/LICENSE.save0 b/tox-crypto/LICENSE.save0 new file mode 100644 index 00000000..e8eaef49 --- /dev/null +++ b/tox-crypto/LICENSE.save0 @@ -0,0 +1,30 @@ +Copyright (c) 2019, James Crayne + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of James Crayne nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/tox-crypto/Setup.hs b/tox-crypto/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/tox-crypto/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/tox-crypto/Setup.hs.save0 b/tox-crypto/Setup.hs.save0 new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/tox-crypto/Setup.hs.save0 @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain 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 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +module Crypto.Tox + ( PublicKey + , publicKey + , getPublicKey + , putPublicKey + , SecretKey + , generateSecretKey + , toPublic + , SymmetricKey(..) + , TransportCrypto(..) + , newCrypto + , SecretsCache + , newSecretsCache + , Encrypted + , Encrypted8(..) + , type (∘), uncomposed, pattern Composed -- type (∘)(..) + , Asymm(..) + , getAsymm + , getAliasedAsymm + , putAsymm + , putAliasedAsymm + , Plain + , encodePlain + , decodePlain + -- , computeSharedSecret + , lookupSharedSecret + , lookupNonceFunction + , lookupNonceFunctionSTM + , Payload(..) + , encrypt + , decrypt + , decryptPayload + , encryptPayload + , Nonce8(..) + , Nonce24(..) + , incrementNonce24 + , nonce24ToWord16 + , addtoNonce24 + , Nonce32(..) + , getRemainingEncrypted + , putEncrypted + , Auth + , Sized(..) + , Size(..) + , State(..) + , zeros32 + , zeros24 + , decryptSymmetric + , encryptSymmetric + , encodeSecret + , decodeSecret + , xorsum + ) where + +import Control.Arrow +import Control.Monad +import qualified Crypto.Cipher.ChaChaPoly1305 as Symmetric +import qualified Crypto.Cipher.Salsa as Salsa +import qualified Crypto.Cipher.XSalsa as XSalsa +import qualified Crypto.Error as Cryptonite +import qualified Crypto.MAC.Poly1305 as Poly1305 +import Crypto.PubKey.Curve25519 +import Data.Bits +import qualified Data.ByteArray as BA + ;import Data.ByteArray as BA (ByteArrayAccess, Bytes) +import Data.ByteString as B +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Char8 as C8 +import Data.Data +import Data.Functor.Contravariant +#if MIN_VERSION_base(4,9,1) +import Data.Kind +#else +import GHC.Exts (Constraint) +#endif +import Data.Ord +import Data.Serialize as S +import Data.Semigroup +import Data.Word +import Foreign.Marshal.Alloc +import Foreign.Ptr +import Foreign.Storable +import System.Endian +import Control.Concurrent.STM +#ifdef CRYPTONITE_BACKPORT +import Crypto.ECC.Class +import Crypto.Error.Types (CryptoFailable (..), throwCryptoError) +#else +import Crypto.ECC +import Crypto.Error +#endif +import Crypto.Random +import Network.Socket (SockAddr) +import GHC.Exts (Word(..),inline) +import GHC.Generics (Generic) +import GHC.Prim +import Data.Word64Map (fitsInInt) +import Data.MinMaxPSQ (MinMaxPSQ') +import qualified Data.MinMaxPSQ as MM +import Data.Time.Clock.POSIX +import Data.Hashable +import System.IO.Unsafe (unsafeDupablePerformIO) +import Data.Functor.Compose +import qualified Rank2 +import Data.Functor.Identity +import DPut +import DebugTag + +-- | A 16-byte mac and an arbitrary-length encrypted stream. +newtype Encrypted a = Encrypted ByteString + deriving (Eq,Ord,Data,ByteArrayAccess,Hashable,Generic) + +newtype Encrypted8 a = E8 (Encrypted (a,Nonce8)) + deriving (Serialize, Show) + +-- Simulating: newtype (f ∘ g) x = Composed { uncomposed :: f (g x) } +pattern Composed x = Compose x +uncomposed = getCompose +type f ∘ g = f `Compose` g +infixr 9 ∘ + +newtype Auth = Auth Poly1305.Auth deriving (Eq, ByteArrayAccess) +instance Ord Auth where + compare (Auth a) (Auth b) = comparing (BA.convert :: Poly1305.Auth -> Bytes) a b +instance Data Auth where + gfoldl k z x = z x + -- Well, this is a little wonky... XXX + gunfold k z c = k (z (Auth . Poly1305.Auth . (BA.convert :: ByteString -> Bytes))) + toConstr _ = con_Auth + dataTypeOf _ = mkDataType "Crypto.Tox" [con_Auth] +con_Auth :: Constr +con_Auth = mkConstr (dataTypeOf (Auth (error "con_Auth"))) "Auth" [] Prefix +instance Serialize Auth where + get = Auth . Poly1305.Auth . BA.convert <$> getBytes 16 + put (Auth (Poly1305.Auth bs)) = putByteString $ BA.convert bs + +instance Typeable a => Show (Encrypted a) where + show (Encrypted _) = "Encrypted "++show (typeOf (undefined :: a)) + +encryptedAuth :: Encrypted a -> Auth +encryptedAuth (Encrypted bs) + | Right auth <- decode (B.take 16 bs) = auth + | otherwise = error "encryptedAuth: insufficient bytes" + +authAndBytes :: Encrypted a -> (Auth, ByteString) +authAndBytes (Encrypted bs) = (auth,bs') + where + (as,bs') = B.splitAt 16 bs + Right auth = decode as + +-- | Info about a type's serialized length. Either the length is known +-- independently of the value, or the length depends on the value. +data Size a + = VarSize (a -> Int) + | ConstSize { constSize :: !Int } + deriving Typeable + +instance Contravariant Size where + contramap f sz = case sz of + ConstSize n -> ConstSize n + VarSize g -> VarSize (\x -> g (f x)) + +instance Semigroup (Size a) where + ConstSize x <> ConstSize y = ConstSize (x + y) + VarSize f <> ConstSize y = VarSize $ \x -> f x + y + ConstSize x <> VarSize g = VarSize $ \y -> x + g y + VarSize f <> VarSize g = VarSize $ \x -> f x + g x + +instance Monoid (Size a) where + mappend = (<>) + mempty = ConstSize 0 + + +class Sized a where size :: Size a + +instance Sized a => Serialize (Encrypted a) where + get = case size :: Size a of + VarSize _ -> Encrypted <$> (remaining >>= getBytes) + ConstSize n -> Encrypted <$> getBytes (16 + n) -- 16 extra for Poly1305 mac + put = putEncrypted + +instance Sized a => Sized (Encrypted a) where + size = case size :: Size a of + ConstSize n -> ConstSize $ n + 16 + VarSize _ -> VarSize $ \(Encrypted bs) -> B.length bs + +instance (Sized a, Sized b) => Sized (a,b) where + size = case (size :: Size a, size :: Size b) of + (ConstSize a , ConstSize b) -> ConstSize $ a + b + (VarSize f , ConstSize b) -> VarSize $ \(a, _) -> f a + b + (ConstSize a , VarSize g) -> VarSize $ \(_, b) -> a + g b + (VarSize f , VarSize g) -> VarSize $ \(a, b) -> f a + g b + +getRemainingEncrypted :: Get (Encrypted a) +getRemainingEncrypted = Encrypted <$> (remaining >>= getBytes) + +putEncrypted :: Encrypted a -> Put +putEncrypted (Encrypted bs) = putByteString bs + +newtype Plain (s:: * -> Constraint) a = Plain ByteString + deriving (Eq,Ord,Show,ByteArrayAccess) + + +decodePlain :: Serialize a => Plain Serialize a -> Either String a +decodePlain (Plain bs) = decode bs + +encodePlain :: Serialize a => a -> Plain Serialize a +encodePlain a = Plain $ encode a + +storePlain :: Storable a => a -> IO (Plain Storable a) +storePlain a = Plain <$> BA.create (sizeOf a) (`poke` a) + +retrievePlain :: Storable a => Plain Storable a -> IO a +retrievePlain (Plain bs) = BA.withByteArray bs peek + +decryptSymmetric :: SymmetricKey -> Nonce24 -> Encrypted a -> Either String (Plain s a) +decryptSymmetric (SymmetricKey symmkey) (Nonce24 n24) (Encrypted bs) = do + let sym_nonce_bytes = B.take 12 n24 + (mac, bs'') = B.splitAt 16 bs + symm <- left show . Cryptonite.eitherCryptoError $ do + sym_nonce <- Symmetric.nonce12 sym_nonce_bytes + Symmetric.initialize symmkey sym_nonce + let (ds, symm') = Symmetric.decrypt bs'' symm + auth = Symmetric.finalize symm' + if BA.convert auth /= mac + then Left "Symmetric decryption failed. Incorrect key material?" + else return $ Plain ds + +encryptSymmetric :: SymmetricKey -> Nonce24 -> Plain s x -> Encrypted x +encryptSymmetric (SymmetricKey symmkey) (Nonce24 n24) (Plain bs) = Encrypted es + where + Cryptonite.CryptoPassed es = do + sym_nonce <- Symmetric.nonce12 (BA.take 12 n24) + symm <- Symmetric.initialize symmkey sym_nonce + let (rpath_bs, symm') = Symmetric.encrypt bs symm + auth = Symmetric.finalize symm' -- 16 bytes + return (BA.convert auth `BA.append` rpath_bs) + + +data State = State Poly1305.State XSalsa.State + +decrypt :: State -> Encrypted a -> Either String (Plain s a) +decrypt (State hash crypt) ciphertext + | (a == mac) = Right (Plain m) + | otherwise = Left "Asymmetric decryption failed. Incorrect key material?" + where + (mac, c) = authAndBytes ciphertext + m = fst . XSalsa.combine crypt $ c + a = Auth . Poly1305.finalize . Poly1305.update hash $ c + +class Rank2.Functor g => Payload c g where + mapPayload :: proxy c -> (forall a. c a => p a -> q a) -> g p -> g q + +decryptPayload :: ( Rank2.Traversable g + , Payload Serialize g + ) => State -> g Encrypted -> Either String (g Identity) +decryptPayload st g = do + plain <- Rank2.traverse (decrypt st) g + Rank2.sequence $ mapPayload (Proxy :: Proxy Serialize) + (Composed . fmap pure . decodePlain) + plain + +-- Encrypt-then-Mac: Encrypt the cleartext, then compute the MAC on the +-- ciphertext, and prepend it to the ciphertext +encrypt :: State -> Plain s a -> Encrypted a +encrypt (State hash crypt) (Plain m) = Encrypted $ B.append (encode a) c + where + c = fst . XSalsa.combine crypt $ m + a = Auth . Poly1305.finalize . Poly1305.update hash $ c + +encryptPayload :: Payload Serialize g => State -> g Identity -> g Encrypted +encryptPayload st g = + encrypt st + Rank2.<$> mapPayload (Proxy :: Proxy Serialize) + (encodePlain . runIdentity) + g + +-- (Poly1305.State, XSalsa.State) +computeSharedSecret :: SecretKey -> PublicKey -> Nonce24 -> State +computeSharedSecret sk recipient = k `seq` \nonce -> + let -- cipher state + st0 = XSalsa.initialize 20 k nonce + -- Poly1305 key + (rs, crypt) = XSalsa.combine st0 zs where Nonce32 zs = zeros32 + -- Since rs is 32 bytes, this pattern should never fail... + Cryptonite.CryptoPassed hash = Poly1305.initialize rs + in State hash crypt + where + -- diffie helman +#if MIN_VERSION_cryptonite(0,24,0) + -- TODO: Handle failure. + -- Failure was observed... + -- Reproduce by issuing tox command "ping 192.168.10.1:33446" without specifying + -- the public key portion of the node id. + -- "Irrefutable pattern failed for pattern CryptoPassed shared" + Cryptonite.CryptoPassed shared = ecdh (Proxy :: Proxy Curve_X25519) sk recipient +#else + shared = ecdh (Proxy :: Proxy Curve_X25519) sk recipient +#endif + -- shared secret XSalsa key + k = hsalsa20 shared zeros24 + +unsafeFirstWord64 :: ByteArrayAccess ba => ba -> Word64 +unsafeFirstWord64 ba = unsafeDupablePerformIO $ BA.withByteArray ba peek +{-# INLINE unsafeFirstWord64 #-} + +instance Hashable PublicKey where + hashWithSalt salt pk = hashWithSalt salt (unsafeFirstWord64 pk) + {-# INLINE hashWithSalt #-} + +instance Hashable SecretKey where + hashWithSalt salt sk = hashWithSalt salt (unsafeFirstWord64 sk) + {-# INLINE hashWithSalt #-} + +instance Ord PublicKey where compare = unsafeCompare32Bytes + {-# INLINE compare #-} +instance Ord SecretKey where compare = unsafeCompare32Bytes + {-# INLINE compare #-} + +unsafeCompare32Bytes :: (ByteArrayAccess ba, ByteArrayAccess bb) + => ba -> bb -> Ordering +unsafeCompare32Bytes ba bb = + unsafeDupablePerformIO $ BA.withByteArray ba + $ \pa -> BA.withByteArray bb + $ \pb -> unsafeCompare32Bytes' 3 pa pb + +unsafeCompare32Bytes' :: Int -> Ptr Word64 -> Ptr Word64 -> IO Ordering +unsafeCompare32Bytes' !n !pa !pb = do + a <- peek pa + b <- peek pb + if n == 0 + then return $! inline compare a b + else case inline compare a b of + EQ -> unsafeCompare32Bytes' (n - 1) + (pa `plusPtr` 8) + (pb `plusPtr` 8) + neq -> return neq + + + +lookupSharedSecret :: TransportCrypto -> SecretKey -> PublicKey -> Nonce24 -> IO State +lookupSharedSecret crypto sk recipient nonce + = ($ nonce) <$> lookupNonceFunction crypto sk recipient + +{-# INLINE lookupNonceFunction #-} +lookupNonceFunction :: TransportCrypto -> SecretKey -> PublicKey -> IO (Nonce24 -> State) +lookupNonceFunction c@(TransportCrypto{secretsCache}) sk recipient = do + now <- getPOSIXTime + atomically $ lookupNonceFunctionSTM now c sk recipient + +{-# INLINE lookupNonceFunctionSTM #-} +-- | This version of 'lookupNonceFunction' is STM instead of IO, this means if some later part of +-- of the transaction fails, we may end up forgoing a computation that could have been cached. +-- Use with care. In most circumstances you probably want 'lookupNonceFunction'. It also commits +-- us to using TVars to store the cache. +lookupNonceFunctionSTM :: POSIXTime -> TransportCrypto -> SecretKey -> PublicKey -> STM (Nonce24 -> State) +lookupNonceFunctionSTM now TransportCrypto{secretsCache} sk recipient = do + mm <- readTVar $ sharedSecret secretsCache + case MM.lookup' recipient mm of + Nothing -> do + let miss = computeSharedSecret sk recipient + writeTVar (sharedSecret secretsCache) + (MM.insertTake' 160 recipient (MM.singleton' sk miss (Down now)) (Down now) mm) + return miss + Just (stamp,smm) -> do + let (r,v) = case MM.lookup' sk smm of + Nothing | let miss = computeSharedSecret sk recipient + -> (miss, MM.insertTake' 3 sk miss (Down now) smm) + Just (stamp2,hit) -> (hit , MM.insert' sk hit (Down now) smm) + writeTVar (sharedSecret secretsCache) + (MM.insertTake' 160 recipient v (Down now) mm) + return r + + +hsalsa20 :: (ByteArrayAccess t, ByteArrayAccess t1) => t1 -> t -> BA.ScrubbedBytes +hsalsa20 k n = BA.append a b + where + Salsa.State st = XSalsa.initialize 20 k n + (_, as) = BA.splitAt 4 st + (a, xs) = BA.splitAt 16 as + (_, bs) = BA.splitAt 24 xs + (b, _ ) = BA.splitAt 16 bs + + +newtype Nonce24 = Nonce24 ByteString + deriving (Eq, Ord, ByteArrayAccess, Data, Generic, Hashable) + +nonce24ToWord16 :: Nonce24 -> Word16 +nonce24ToWord16 (Nonce24 n24) = fromIntegral (B.index n24 23) + 256 * fromIntegral (B.index n24 22) + +addtoNonce24 :: Nonce24 -> Word -> Nonce24 +addtoNonce24 (Nonce24 n24) n = unsafeDupablePerformIO $ Nonce24 <$> BA.copy n24 init + where + init :: Ptr Word -> IO () + init ptr | fitsInInt (Proxy :: Proxy Word64) = do + let frmBE64 = fromIntegral . fromBE64 . fromIntegral + tBE64 = fromIntegral . toBE64 . fromIntegral + !(W# input) = n + W# w1 <- frmBE64 <$> peek ptr + W# w2 <- frmBE64 <$> peekElemOff ptr 1 + W# w3 <- frmBE64 <$> peekElemOff ptr 2 + let (# overflw, sum #) = plusWord2# w3 input + (# overflw', sum' #) = plusWord2# w2 overflw + (# discard, sum'' #) = plusWord2# w1 overflw' + poke ptr $ tBE64 (W# sum'') + pokeElemOff ptr 1 $ tBE64 (W# sum') + pokeElemOff ptr 2 $ tBE64 (W# sum) + + init ptr | fitsInInt (Proxy :: Proxy Word32) = do + let frmBE32 = fromIntegral . fromBE32 . fromIntegral + tBE32 = fromIntegral . toBE32 . fromIntegral + !(W# input) = n + W# w1 <- frmBE32 <$> peek ptr + W# w2 <- frmBE32 <$> peekElemOff ptr 1 + W# w3 <- frmBE32 <$> peekElemOff ptr 2 + W# w4 <- frmBE32 <$> peekElemOff ptr 3 + W# w5 <- frmBE32 <$> peekElemOff ptr 4 + W# w6 <- frmBE32 <$> peekElemOff ptr 5 + let (# overflw_, sum_ #) = plusWord2# w6 input + (# overflw__, sum__ #) = plusWord2# w5 overflw_ + (# overflw___, sum___ #) = plusWord2# w6 overflw__ + (# overflw, sum #) = plusWord2# w3 overflw___ + (# overflw', sum' #) = plusWord2# w2 overflw + (# discard, sum'' #) = plusWord2# w1 overflw' + poke ptr $ tBE32 (W# sum'') + pokeElemOff ptr 1 $ tBE32 (W# sum') + pokeElemOff ptr 2 $ tBE32 (W# sum) + pokeElemOff ptr 3 $ tBE32 (W# sum___) + pokeElemOff ptr 4 $ tBE32 (W# sum__) + pokeElemOff ptr 5 $ tBE32 (W# sum_) + init _ = error "incrementNonce24: I only support 64 and 32 bits" + +incrementNonce24 :: Nonce24 -> Nonce24 +incrementNonce24 nonce24 = addtoNonce24 nonce24 1 +{-# INLINE incrementNonce24 #-} + +quoted :: ShowS -> ShowS +quoted shows s = '"':shows ('"':s) + +bin2hex :: ByteArrayAccess bs => bs -> String +bin2hex = C8.unpack . Base16.encode . BA.convert + +bin2base64 :: ByteArrayAccess bs => bs -> String +bin2base64 = C8.unpack . Base64.encode . BA.convert + + +instance Show Nonce24 where + showsPrec d nonce = quoted (mappend $ bin2hex nonce) + +instance Sized Nonce24 where size = ConstSize 24 + +instance Serialize Nonce24 where + get = Nonce24 <$> getBytes 24 + put (Nonce24 bs) = putByteString bs + +newtype Nonce8 = Nonce8 Word64 + deriving (Eq, Ord, Data, Serialize) + +-- Note: Big-endian to match Serialize instance. +instance Storable Nonce8 where + sizeOf _ = 8 + alignment _ = alignment (undefined::Word64) + peek ptr = Nonce8 . fromBE64 <$> peek (castPtr ptr) + poke ptr (Nonce8 w) = poke (castPtr ptr) (toBE64 w) + +instance Sized Nonce8 where size = ConstSize 8 + +instance ByteArrayAccess Nonce8 where + length _ = 8 + withByteArray (Nonce8 w64) kont = + allocaBytes 8 $ \p -> do + poke (castPtr p :: Ptr Word64) $ toBE64 w64 + kont p + +instance Show Nonce8 where + showsPrec d nonce = quoted (mappend $ bin2hex nonce) + + +newtype Nonce32 = Nonce32 ByteString + deriving (Eq, Ord, ByteArrayAccess, Data) + +instance Show Nonce32 where + showsPrec d nonce = mappend $ bin2base64 nonce + +instance Read Nonce32 where + readsPrec _ str = either (const []) id $ do + let (ds,ss) = Prelude.splitAt 43 str + ss' <- case ss of + '=':xs -> Right xs -- optional terminating '=' + _ -> Right ss + bs <- Base64.decode (C8.pack $ ds ++ ['=']) + if B.length bs == 32 + then Right [ (Nonce32 bs, ss') ] + else Left "Insuffiicent base64 digits while parsing Nonce32." + +instance Serialize Nonce32 where + get = Nonce32 <$> getBytes 32 + put (Nonce32 bs) = putByteString bs + +instance Sized Nonce32 where size = ConstSize 32 + + +zeros32 :: Nonce32 +zeros32 = Nonce32 $ BA.replicate 32 0 + +zeros24 :: ByteString +zeros24 = BA.take 24 zs where Nonce32 zs = zeros32 + +-- | `32` | sender's DHT public key | +-- | `24` | nonce | +-- | `?` | encrypted message | +data Asymm a = Asymm + { senderKey :: PublicKey + , asymmNonce :: Nonce24 + , asymmData :: a + } + deriving (Functor,Foldable,Traversable, Show, Eq, Ord) + +instance Sized a => Sized (Asymm a) where + size = case size of + ConstSize a -> ConstSize $ a + 24 + 32 + VarSize f -> VarSize $ \Asymm { asymmData = x } -> f x + 24 + 32 + +-- | Field order: senderKey, then nonce This is the format used by +-- Ping/Pong/GetNodes/SendNodes. +-- +-- See 'getAliasedAsymm' if the nonce precedes the key. +getAsymm :: Serialize a => Get (Asymm a) +getAsymm = Asymm <$> getPublicKey <*> get <*> get + +putAsymm :: Serialize a => Asymm a -> Put +putAsymm (Asymm key nonce dta) = putPublicKey key >> put nonce >> put dta + +-- | Field order: nonce, and then senderKey. +getAliasedAsymm :: Serialize a => Get (Asymm a) +getAliasedAsymm = flip Asymm <$> get <*> getPublicKey <*> get + +putAliasedAsymm :: Serialize a => Asymm a -> Put +putAliasedAsymm (Asymm key nonce dta) = put nonce >> putPublicKey key >> put dta + +data SecretsCache = SecretsCache + { sharedSecret :: TVar (MinMaxPSQ' PublicKey + (Down POSIXTime) + (MinMaxPSQ' SecretKey (Down POSIXTime) (Nonce24 -> State))) + } + +newSecretsCache :: IO SecretsCache +newSecretsCache = atomically (SecretsCache <$> newTVar MM.empty) + + +newtype SymmetricKey = SymmetricKey ByteString + +instance Show SymmetricKey where + show (SymmetricKey bs) = bin2base64 bs + +data TransportCrypto = TransportCrypto + { transportSecret :: SecretKey + , transportPublic :: PublicKey + , onionAliasSecret :: SecretKey + , onionAliasPublic :: PublicKey + , rendezvousSecret :: SecretKey + , rendezvousPublic :: PublicKey + , transportSymmetric :: STM SymmetricKey + , transportNewNonce :: STM Nonce24 + , transportNewKey :: STM SecretKey + , userKeys :: STM [(SecretKey,PublicKey)] + , pendingCookies :: TVar [(SockAddr, (Int, PublicKey))] + , secretsCache :: SecretsCache + } + +getPublicKey :: S.Get PublicKey +getPublicKey = eitherCryptoError . publicKey <$> S.getBytes 32 + >>= either (fail . show) return + +putPublicKey :: PublicKey -> S.Put +putPublicKey bs = S.putByteString $ BA.convert bs + +-- 32 bytes -> 42 base64 digits. +-- +encodeSecret :: SecretKey -> Maybe C8.ByteString +encodeSecret k = do + (a,bs) <- BA.uncons (BA.convert k) + -- Bytes + -- 1 31 + -- a | bs + (cs,c) <- unsnoc bs + -- Bytes + -- 1 30 1 + -- a | cs | c + -- + -- Based on the following pasted from the generateSecretKey function: + -- + -- tweakToSecretKey :: ScrubbedBytes -> SecretKey + -- tweakToSecretKey bin = SecretKey $ B.copyAndFreeze bin $ \inp -> do + -- modifyByte inp 0 (\e0 -> e0 .&. 0xf8) + -- modifyByte inp 31 (\e31 -> (e31 .&. 0x7f) .|. 0x40) + -- + -- We know the following holds: + -- a == a .&. 0xf8 + -- c == (c .&. 0x7f) .|. 0x40 + -- + -- Therefore, there are 5 reserved bits: + -- a := aaaa a000 + -- c := 01dd cccc + -- + -- That gives us 256 - 5 = 251 bits to encode. + -- 42 * 6 = 252 + -- + let -- We'll reserve the first bit as zero so that the encoded + -- key starts with a digit between A and f. Other digits will be + -- arbitrary. + -- + -- The middle 30 bytes will be encoded as is from the source byte + -- string (cs). It remains to compute the first (a') and last (c') + -- bytes. + xs = Base64.encode $ a' `BA.cons` cs `BA.snoc` c' + -- a' := 0aaaaadd + a' = shiftR a 1 .|. (shiftR c 4 .&. 0x03) + -- c' := cccc0000 + c' = shiftL c 4 + return $ BA.take 42 xs + +-- 42 base64 digits. First digit should be between A and f. The rest are +-- arbitrary. +decodeSecret :: C8.ByteString -> Maybe SecretKey +decodeSecret k64 | B.length k64 < 42 = Nothing +decodeSecret k64 = do + xs <- either (const Nothing) Just $ Base64.decode $ B.append k64 "A=" + (a',ds) <- B.uncons $ B.take 32 xs + (cs,c') <- B.unsnoc ds + let c = 0x40 .|. shiftR c' 4 .|. ( 0x30 .&. shiftL a' 4) + a = 0xf8 .&. shiftL a' 1 + case secretKey $ B.cons a cs `B.snoc` c of + CryptoPassed x -> Just x + _ -> Nothing + +-- Treats byte pairs as big-endian. +xorsum :: ByteArrayAccess ba => ba -> Word16 +xorsum bs = unsafeDupablePerformIO $ BA.withByteArray bs $ \ptr16 -> do + let (wcnt,r) = BA.length bs `divMod` 2 + loop cnt !ac = do + ac' <- xor ac <$> peekElemOff ptr16 cnt + case cnt of 0 -> return $ fromBE16 ac' + _ -> loop (cnt - 1) ac' + loop (wcnt - 1) $ case r of + 0 -> 0 + _ -> 256 * fromIntegral (BA.index bs (BA.length bs - 1)) + +showHex :: BA.ByteArrayAccess ba => ba -> String +showHex bs = C8.unpack $ Base16.encode $ BA.convert bs + +newCrypto :: IO TransportCrypto +newCrypto = do + secret <- generateSecretKey + alias <- generateSecretKey + ralias <- generateSecretKey + let pubkey = toPublic secret + aliaspub = toPublic alias + raliaspub = toPublic ralias + ukeys <- atomically $ newTVar [] + (symkey, drg) <- do + drg0 <- getSystemDRG + return $ randomBytesGenerate 32 drg0 :: IO (ByteString, SystemDRG) + noncevar <- atomically $ newTVar $ fst $ withDRG drg drgNew + cookieKeys <- atomically $ newTVar [] + cache <- newSecretsCache + dput XNetCrypto $ "secret(tox) = " ++ showHex secret + dput XNetCrypto $ "public(tox) = " ++ showHex pubkey + dput XNetCrypto $ "symmetric(tox) = " ++ showHex symkey + return TransportCrypto + { transportSecret = secret + , transportPublic = pubkey + , onionAliasSecret = alias + , onionAliasPublic = aliaspub + , rendezvousSecret = ralias + , rendezvousPublic = raliaspub + , transportSymmetric = return $ SymmetricKey symkey + , transportNewNonce = do + drg1 <- readTVar noncevar + let (nonce, drg2) = withDRG drg1 (Nonce24 <$> getRandomBytes 24) + writeTVar noncevar drg2 + return nonce + , transportNewKey = do + drg1 <- readTVar noncevar + let (k, drg2) = withDRG drg1 generateSecretKey + writeTVar noncevar drg2 + return k + , userKeys = return [] + , pendingCookies = cookieKeys + , secretsCache = cache + } + 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 @@ +module DebugTag where + +import Data.Typeable + +-- | Debug Tags, add more as needed, but ensure XAnnounce is always first, XMisc last +data DebugTag + = XAnnounce + | XBitTorrent + | XDHT + | XLan + | XMan + | XNetCrypto + | XNetCryptoOut + | XOnion + | XRoutes + | XPing + | XRefresh + | XJabber + | XTCP + | XMisc + | XNodeinfoSearch + | XUnexpected -- Used only for special anomalous errors that we didn't expect to happen. + | XUnused -- Never commit code that uses XUnused. + deriving (Eq, Ord, Show, Read, Enum, Bounded,Typeable) diff --git a/tox-crypto/tox-crypto.cabal b/tox-crypto/tox-crypto.cabal new file mode 100644 index 00000000..9737e5d9 --- /dev/null +++ b/tox-crypto/tox-crypto.cabal @@ -0,0 +1,59 @@ +-- Initial tox-crypto.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: tox-crypto +version: 0.1.0.0 +-- synopsis: +-- description: +license: BSD3 +license-file: LICENSE +author: James Crayne +maintainer: jim.crayne@gmail.com +-- copyright: +-- category: +build-type: Simple +extra-source-files: CHANGELOG.md +cabal-version: >=1.10 + +library + exposed-modules: Crypto.Tox + -- other-modules: + other-extensions: CPP + , GeneralizedNewtypeDeriving + , ScopedTypeVariables + , KindSignatures + , DeriveDataTypeable + , DeriveFunctor + , DeriveGeneric + , DeriveTraversable + , TypeOperators + , MagicHash + , UnboxedTuples + , BangPatterns + , MultiParamTypeClasses + , ConstraintKinds + , Rank2Types + , NamedFieldPuns + , PatternSynonyms + , FlexibleContexts + build-depends: + base + , cpu + , memory + , base64-bytestring + , base16-bytestring + , cereal + , word64-map + , contravariant + , rank2classes + , network + , bytestring + , stm + , ghc-prim + , time + , cryptonite + , dput-hslogger + , hashable + , minmax-psq + hs-source-dirs: src + default-language: Haskell2010 -- cgit v1.2.3