diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -42,7 +42,7 @@ fi - travis_retry cabal update - "sed -i 's/^jobs:.*$/jobs: 2/' $HOME/.cabal/config" - - cabal install --only-dependencies --enable-tests --dry -v cacophony.cabal > installplan.txt + - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v cacophony.cabal > installplan.txt - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt # check whether current requested install-plan matches cached package-db snapshot @@ -56,7 +56,7 @@ echo "cabal build-cache MISS"; rm -rf $HOME/.cabsnap; mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; - cabal install --only-dependencies --enable-tests cacophony.cabal; + cabal install --only-dependencies --enable-tests --enable-benchmarks cacophony.cabal; if [ "$GHCVER" = "7.10.1" ]; then cabal install Cabal-1.22.4.0; fi; fi @@ -72,7 +72,7 @@ - cabal install script: - - cabal configure --enable-tests -v2 # -v2 provides useful information for debugging + - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging - cabal build # this builds all libraries and executables (including tests) - cabal test - cabal sdist # tests that a source-distribution can be generated @@ -81,4 +81,4 @@ # If there are no other `.tar.gz` files in `dist`, this can be even simpler: # `cabal install --force-reinstalls dist/*-*.tar.gz` - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && - (cd dist && cabal install --enable-tests --run-tests --force-reinstalls "$SRC_TGZ") + (cd dist && cabal install --enable-tests --enable-benchmarks --run-tests --force-reinstalls "$SRC_TGZ") diff --git a/benchmarks/bench.hs b/benchmarks/bench.hs --- a/benchmarks/bench.hs +++ b/benchmarks/bench.hs @@ -1,6 +1,189 @@ -module Main - ( main - ) where +{-# LANGUAGE OverloadedStrings, RankNTypes, ScopedTypeVariables #-} +module Main where +import Control.DeepSeq (($!!)) +import Control.Exception (handle) +import Criterion.Main +import Data.Proxy + +import Crypto.Noise.Cipher +import Crypto.Noise.Cipher.ChaChaPoly1305 +import Crypto.Noise.Curve +import Crypto.Noise.Curve.Curve25519 +import Crypto.Noise.Handshake +import Crypto.Noise.Hash +import Crypto.Noise.Hash.SHA256 +import Crypto.Noise.Types + +import HandshakeStates +import Instances() + +data HandshakeType c d h = + NoiseNN + | NoiseKN + | NoiseNK + | NoiseKK + | NoiseNE + | NoiseKE + | NoiseNX + | NoiseKXi + | NoiseXN + | NoiseIN + | NoiseXK + | NoiseIK + | NoiseXE + | NoiseIE + | NoiseXX + | NoiseIX + | NoiseN + | NoiseK + | NoiseX + +is25519 :: KeyPair Curve25519 +is25519 = curveBytesToPair . bsToSB' $ "I\f\232\218A\210\230\147\FS\222\167\v}l\243!\168.\ESC\t\SYN\"\169\179A`\DC28\211\169tC" + +rs25519 :: KeyPair Curve25519 +rs25519 = curveBytesToPair . bsToSB' $ "\ETB\157\&7\DC2\252\NUL\148\172\148\133\218\207\&8\221y\144\209\168FX\224Ser_\178|\153.\FSg&" + +re25519 :: KeyPair Curve25519 +re25519 = curveBytesToPair . bsToSB' $ "<\231\151\151\180\217\146\DLEI}\160N\163iKc\162\210Y\168R\213\206&gm\169r\SUB[\\'" + +mkHandshakes :: forall c d h proxy. (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeKeys d + -> proxy (c, h) + -> [Benchmark] +mkHandshakes ihks rhks _ = + let nni, nnr, kni, knr, nki, nkr, kki, kkr, nei, ner, kei, ker, nxi, nxr, + kxi, kxr, xni, xnr, ini, inr, xki, xkr, iki, ikr, xei, xer, iei, ier, + xxi, xxr, ixi, ixr, ni, nr, ki, kr, xi, xr :: HandshakeState c d h + nni = noiseNNIHS ihks + nnr = noiseNNRHS rhks + kni = noiseKNIHS ihks + knr = noiseKNRHS rhks + nki = noiseNKIHS ihks + nkr = noiseNKRHS rhks + kki = noiseKKIHS ihks + kkr = noiseKKRHS rhks + nei = noiseNEIHS ihks + ner = noiseNERHS rhks + kei = noiseKEIHS ihks + ker = noiseKERHS rhks + nxi = noiseNXIHS ihks + nxr = noiseNXRHS rhks + kxi = noiseKXIHS ihks + kxr = noiseKXRHS rhks + xni = noiseXNIHS ihks + xnr = noiseXNRHS rhks + ini = noiseINIHS ihks + inr = noiseINRHS rhks + xki = noiseXKIHS ihks + xkr = noiseXKRHS rhks + iki = noiseIKIHS ihks + ikr = noiseIKRHS rhks + xei = noiseXEIHS ihks + xer = noiseXERHS rhks + iei = noiseIEIHS ihks + ier = noiseIERHS rhks + xxi = noiseXXIHS ihks + xxr = noiseXXRHS rhks + ixi = noiseIXIHS ihks + ixr = noiseIXRHS rhks + ni = noiseNIHS ihks + nr = noiseNRHS rhks + ki = noiseKIHS ihks + kr = noiseKRHS rhks + xi = noiseXIHS ihks + xr = noiseXRHS rhks in + + [ bench "NoisePSK_NN" $ whnfIO (twoMessage nni nnr) + , bench "NoisePSK_KN" $ whnfIO (twoMessage kni knr) + , bench "NoisePSK_NK" $ whnfIO (twoMessage nki nkr) + , bench "NoisePSK_KK" $ whnfIO (twoMessage kki kkr) + , bench "NoisePSK_NE" $ whnfIO (twoMessage nei ner) + , bench "NoisePSK_KE" $ whnfIO (twoMessage kei ker) + , bench "NoisePSK_NX" $ whnfIO (twoMessage nxi nxr) + , bench "NoisePSK_KX" $ whnfIO (twoMessage kxi kxr) + , bench "NoisePSK_XN" $ whnfIO (threeMessage xni xnr) + , bench "NoisePSK_IN" $ whnfIO (twoMessage ini inr) + , bench "NoisePSK_XK" $ whnfIO (threeMessage xki xkr) + , bench "NoisePSK_IK" $ whnfIO (twoMessage iki ikr) + , bench "NoisePSK_XE" $ whnfIO (threeMessage xei xer) + , bench "NoisePSK_IE" $ whnfIO (twoMessage iei ier) + , bench "NoisePSK_XX" $ whnfIO (threeMessage xxi xxr) + , bench "NoisePSK_IX" $ whnfIO (twoMessage ixi ixr) + , bench "NoisePSK_N" $ whnfIO (oneMessage ni nr ) + , bench "NoisePSK_K" $ whnfIO (oneMessage ki kr ) + , bench "NoisePSK_X" $ whnfIO (oneMessage xi xr ) + ] + +oneMessage :: (Cipher c, Curve d, Hash h) + => HandshakeState c d h + -> HandshakeState c d h + -> IO Plaintext +oneMessage ihs rhs = handle (\(_ :: NoiseException) -> return "") $ do + (aliceToBob1, csAlice1, _) <- writeMessageFinal ihs "" + let (_, csBob1, _) = readMessageFinal rhs aliceToBob1 + x = decrypt csBob1 . encrypt csAlice1 $ "" + + return $!! x + + where + encrypt cs p = fst $ encryptPayload p cs + decrypt cs ct = fst $ decryptPayload ct cs + +twoMessage :: (Cipher c, Curve d, Hash h) + => HandshakeState c d h + -> HandshakeState c d h + -> IO (Plaintext, Plaintext) +twoMessage ihs rhs = handle (\(_ :: NoiseException) -> return ("", "")) $ do + (aliceToBob1, ihs') <- writeMessage ihs "" + let (_, rhs') = readMessage rhs aliceToBob1 + + (bobToAlice1, csBob1, csBob2) <- writeMessageFinal rhs' "" + let (_, csAlice1, csAlice2) = readMessageFinal ihs' bobToAlice1 + x = decrypt csBob1 . encrypt csAlice1 $ "" + y = decrypt csAlice2 . encrypt csBob2 $ "" + + return $!! (x, y) + + where + encrypt cs p = fst $ encryptPayload p cs + decrypt cs ct = fst $ decryptPayload ct cs + +threeMessage :: (Cipher c, Curve d, Hash h) + => HandshakeState c d h + -> HandshakeState c d h + -> IO (Plaintext, Plaintext) +threeMessage ihs rhs = handle (\(_ :: NoiseException) -> return ("", "")) $ do + (aliceToBob1, ihs') <- writeMessage ihs "" + let (_, rhs') = readMessage rhs aliceToBob1 + + (bobToAlice1, rhs'') <- writeMessage rhs' "" + let (_, ihs'') = readMessage ihs' bobToAlice1 + + (aliceToBob2, csAlice1, csAlice2) <- writeMessageFinal ihs'' "" + let (_, csBob1, csBob2) = readMessageFinal rhs'' aliceToBob2 + x = decrypt csBob1 . encrypt csAlice1 $ "" + y = decrypt csAlice2 . encrypt csBob2 $ "" + + return $!! (x, y) + + where + encrypt cs p = fst $ encryptPayload p cs + decrypt cs ct = fst $ decryptPayload ct cs + main :: IO () -main = return () +main = + let p = Just "cacophony" + p' = Just "not cacophony" + hks = HandshakeKeys p is25519 rs25519 re25519 + hks' = HandshakeKeys p' is25519 rs25519 re25519 in + defaultMain + [ bgroup "Curve25519-ChaChaPoly1305-SHA256" + [ bgroup "with valid PSK" + (mkHandshakes hks hks (Proxy :: Proxy (ChaChaPoly1305, SHA256))) + , bgroup "with invalid PSK" + (mkHandshakes hks hks' (Proxy :: Proxy (ChaChaPoly1305, SHA256))) + ] + ] diff --git a/cacophony.cabal b/cacophony.cabal --- a/cacophony.cabal +++ b/cacophony.cabal @@ -1,5 +1,5 @@ name: cacophony -version: 0.3.0 +version: 0.4.0 synopsis: A library implementing the Noise protocol. license: PublicDomain license-file: LICENSE @@ -52,6 +52,7 @@ default-language: Haskell2010 exposed-modules: Crypto.Noise.Cipher + Crypto.Noise.Cipher.AESGCM Crypto.Noise.Cipher.ChaChaPoly1305 Crypto.Noise.Curve Crypto.Noise.Curve.Curve25519 @@ -59,7 +60,10 @@ Crypto.Noise.Handshake Crypto.Noise.HandshakePatterns Crypto.Noise.Hash + Crypto.Noise.Hash.BLAKE2b + Crypto.Noise.Hash.BLAKE2s Crypto.Noise.Hash.SHA256 + Crypto.Noise.Hash.SHA512 Crypto.Noise.Internal.CipherState Crypto.Noise.Internal.SymmetricState Crypto.Noise.Internal.HandshakeState @@ -72,9 +76,9 @@ -------------------------------------------------------------------------------- -- TESTS -test-suite test-cacophony +test-suite properties type: exitcode-stdio-1.0 - main-is: Tests.hs + main-is: properties.hs ghc-options: -Wall -fwarn-tabs hs-source-dirs: tests default-language: Haskell2010 @@ -90,8 +94,8 @@ other-modules: CipherState, - Handshake, - HandshakeStates, + Handshakes, + HandshakeStates Imports, Instances, SymmetricState @@ -137,4 +141,8 @@ default-language: Haskell2010 build-depends: - base >=4.8 && <5 + base >=4.8 && <5, + bytestring, + cacophony, + criterion, + deepseq diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,21 @@ +# 0.4.0 + +* Improved documentation + +* Added basic benchmarks + +* Added better exception handling + +* Improved handshakeState API + +* Added psk2 functionality + +* Unit test cleanup + +* Renamed symmetricHandshake to symmetricState + +* Added BLAKE2, SHA512, AESGCM support + # 0.3.0 * Brought API up to date with current version of spec (17) diff --git a/src/Crypto/Noise/Cipher/AESGCM.hs b/src/Crypto/Noise/Cipher/AESGCM.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Noise/Cipher/AESGCM.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleInstances #-} +---------------------------------------------------------------- +-- | +-- Module : Crypto.Noise.Cipher.AESGCM +-- Maintainer : John Galt +-- Stability : experimental +-- Portability : POSIX + +module Crypto.Noise.Cipher.AESGCM + ( -- * Types + AESGCM + ) where + +import Crypto.Error (throwCryptoError) +import Crypto.Cipher.AES (AES256) +import Crypto.Cipher.Types (AuthTag(..), AEADMode(AEAD_GCM), + cipherInit, aeadInit, aeadSimpleEncrypt, + aeadSimpleDecrypt) +import Data.ByteArray (ByteArray) +import qualified Data.ByteArray as B (take, drop, length, replicate, copyAndFreeze) +import Data.Word (Word8) +import Foreign.Ptr +import Foreign.Storable + +import Crypto.Noise.Cipher +import Crypto.Noise.Types + +-- | Represents the ChaCha cipher with Poly1305 for AEAD. +data AESGCM + +instance Cipher AESGCM where + newtype Ciphertext AESGCM = CTAES (AuthTag, ScrubbedBytes) + newtype SymmetricKey AESGCM = SKAES ScrubbedBytes + newtype Nonce AESGCM = NAES ScrubbedBytes + + cipherName _ = bsToSB' "AESGCM" + cipherEncrypt = encrypt + cipherDecrypt = decrypt + cipherZeroNonce = zeroNonce + cipherIncNonce = incNonce + cipherBytesToSym = bytesToSym + cipherTextToBytes = ctToBytes + cipherBytesToText = bytesToCt + +encrypt :: SymmetricKey AESGCM + -> Nonce AESGCM + -> AssocData + -> Plaintext + -> Ciphertext AESGCM +encrypt (SKAES k) (NAES n) (AssocData ad) (Plaintext plaintext) = + CTAES $ aeadSimpleEncrypt aead ad plaintext 16 + where + state = throwCryptoError . cipherInit $ k :: AES256 + aead = throwCryptoError $ aeadInit AEAD_GCM state n + +decrypt :: SymmetricKey AESGCM + -> Nonce AESGCM + -> AssocData + -> Ciphertext AESGCM + -> Maybe Plaintext +decrypt (SKAES k) (NAES n) (AssocData ad) (CTAES (authTag, ct)) = + Plaintext <$> aeadSimpleDecrypt aead ad ct authTag + where + state = throwCryptoError . cipherInit $ k :: AES256 + aead = throwCryptoError $ aeadInit AEAD_GCM state n + +zeroNonce :: Nonce AESGCM +zeroNonce = NAES (B.replicate 12 0 :: ScrubbedBytes) + +incNonce :: Nonce AESGCM + -> Nonce AESGCM +incNonce (NAES n) = NAES $ ivAdd n 1 + +bytesToSym :: ScrubbedBytes + -> SymmetricKey AESGCM +bytesToSym = SKAES . B.take 32 + +ctToBytes :: Ciphertext AESGCM + -> ScrubbedBytes +ctToBytes (CTAES (a, ct)) = ct `append` convert a + +bytesToCt :: ScrubbedBytes + -> Ciphertext AESGCM +bytesToCt bytes = + CTAES ( AuthTag . convert $ B.drop (B.length bytes - 16) bytes + , B.take (B.length bytes - 16) bytes + ) + +ivAdd :: ByteArray b => b -> Int -> b +ivAdd b i = copy b + where copy :: ByteArray bs => bs -> bs + copy bs = B.copyAndFreeze bs $ \p -> do + let until0 accu = do + r <- loop accu (B.length bs - 1) p + case r of + 0 -> return () + _ -> until0 r + until0 i + + loop :: Int -> Int -> Ptr Word8 -> IO Int + loop 0 _ _ = return 0 + loop acc ofs p = do + v <- peek (p `plusPtr` ofs) :: IO Word8 + let accv = acc + fromIntegral v + (hi,lo) = accv `divMod` 256 + poke (p `plusPtr` ofs) (fromIntegral lo :: Word8) + if ofs == 0 + then return hi + else loop hi (ofs - 1) p diff --git a/src/Crypto/Noise/Curve/Curve25519.hs b/src/Crypto/Noise/Curve/Curve25519.hs --- a/src/Crypto/Noise/Curve/Curve25519.hs +++ b/src/Crypto/Noise/Curve/Curve25519.hs @@ -11,7 +11,8 @@ Curve25519 ) where -import Crypto.Random.Entropy +import Crypto.Error (throwCryptoError) +import Crypto.Random.Entropy (getEntropy) import qualified Crypto.PubKey.Curve25519 as C import Crypto.Noise.Curve @@ -36,7 +37,7 @@ genKey :: IO (KeyPair Curve25519) genKey = do r <- getEntropy 32 :: IO ScrubbedBytes - let sk = either error id $ C.secretKey r + let sk = throwCryptoError . C.secretKey $ r pk = C.toPublic sk return (SK25519 sk, PK25519 pk) @@ -47,7 +48,7 @@ pubToBytes (PK25519 pk) = convert pk bytesToPub :: ScrubbedBytes -> PublicKey Curve25519 -bytesToPub b = PK25519 . either error id $ C.publicKey b +bytesToPub b = PK25519 . throwCryptoError . C.publicKey $ b secToBytes :: SecretKey Curve25519 -> ScrubbedBytes secToBytes (SK25519 sk) = convert sk @@ -55,5 +56,5 @@ bytesToPair :: ScrubbedBytes -> KeyPair Curve25519 bytesToPair bs = (SK25519 sk, PK25519 pk) where - sk = either error id $ C.secretKey bs + sk = throwCryptoError . C.secretKey $ bs pk = C.toPublic sk diff --git a/src/Crypto/Noise/Handshake.hs b/src/Crypto/Noise/Handshake.hs --- a/src/Crypto/Noise/Handshake.hs +++ b/src/Crypto/Noise/Handshake.hs @@ -5,8 +5,8 @@ -- Stability : experimental -- Portability : POSIX -- --- For more information regarding MessagePatterns, please see the --- "Crypto.Noise.MessagePatterns" module. +-- For more information regarding HandshakePatterns, please see the +-- "Crypto.Noise.HandshakePatterns" module. module Crypto.Noise.Handshake ( -- * Types HandshakeState, diff --git a/src/Crypto/Noise/HandshakePatterns.hs b/src/Crypto/Noise/HandshakePatterns.hs --- a/src/Crypto/Noise/HandshakePatterns.hs +++ b/src/Crypto/Noise/HandshakePatterns.hs @@ -1,9 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} ---------------------------------------------------------------- -- | -- Module : Crypto.Noise.HandshakePatterns -- Maintainer : John Galt -- Stability : experimental -- Portability : POSIX +-- +-- This module contains all of the handshake patterns specified in the +-- protocol. The first two characters of the name represent the handshake +-- the pattern describes (NN, KN, NK, etc). The last character represents +-- whether the pattern is intended to be used by the __I__nitiator or the +-- __R__esponder. These functions are intended to be passed to the +-- 'Crypto.Noise.Handshake.handshakeState' function. The (de-)serialization +-- of (pre-)messages is beyond the scope of this library, but public keys +-- can be imported/exported using the 'curveBytesToPub' and 'curvePubToBytes' +-- functions. module Crypto.Noise.HandshakePatterns ( -- * Functions @@ -54,115 +65,115 @@ import Crypto.Noise.MessagePatterns noiseNNI :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseNNI = HandshakePattern Nothing [noiseNNI1] [noiseNNI2] +noiseNNI = HandshakePattern "NN" Nothing [noiseNNI1] [noiseNNI2] noiseNNR :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseNNR = HandshakePattern Nothing [noiseNNR2] [noiseNNR1] +noiseNNR = HandshakePattern "NN" Nothing [noiseNNR2] [noiseNNR1] noiseKNI :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseKNI = HandshakePattern (Just noiseKNI0) [noiseKNI1] [noiseKNI2] +noiseKNI = HandshakePattern "KN" (Just noiseKNI0) [noiseKNI1] [noiseKNI2] noiseKNR :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseKNR = HandshakePattern (Just noiseKNR0 )[noiseKNR2] [noiseKNR1] +noiseKNR = HandshakePattern "KN" (Just noiseKNR0) [noiseKNR2] [noiseKNR1] noiseNKI :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseNKI = HandshakePattern (Just noiseNKI0) [noiseNKI1] [noiseNKI2] +noiseNKI = HandshakePattern "NK" (Just noiseNKI0) [noiseNKI1] [noiseNKI2] noiseNKR :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseNKR = HandshakePattern (Just noiseNKR0) [noiseNKR2] [noiseNKR1] +noiseNKR = HandshakePattern "NK" (Just noiseNKR0) [noiseNKR2] [noiseNKR1] noiseKKI :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseKKI = HandshakePattern (Just noiseKKI0) [noiseKKI1] [noiseKKI2] +noiseKKI = HandshakePattern "KK" (Just noiseKKI0) [noiseKKI1] [noiseKKI2] noiseKKR :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseKKR = HandshakePattern (Just noiseKKR0) [noiseKKR2] [noiseKKR1] +noiseKKR = HandshakePattern "KK" (Just noiseKKR0) [noiseKKR2] [noiseKKR1] noiseNEI :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseNEI = HandshakePattern (Just noiseNEI0) [noiseNEI1] [noiseNEI2] +noiseNEI = HandshakePattern "NE" (Just noiseNEI0) [noiseNEI1] [noiseNEI2] noiseNER :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseNER = HandshakePattern (Just noiseNER0) [noiseNER2] [noiseNER1] +noiseNER = HandshakePattern "NE" (Just noiseNER0) [noiseNER2] [noiseNER1] noiseKEI :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseKEI = HandshakePattern (Just noiseKEI0) [noiseKEI1] [noiseKEI2] +noiseKEI = HandshakePattern "KE" (Just noiseKEI0) [noiseKEI1] [noiseKEI2] noiseKER :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseKER = HandshakePattern (Just noiseKER0) [noiseKER2] [noiseKER1] +noiseKER = HandshakePattern "KE" (Just noiseKER0) [noiseKER2] [noiseKER1] noiseNXI :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseNXI = HandshakePattern Nothing [noiseNXI1] [noiseNXI2] +noiseNXI = HandshakePattern "NX" Nothing [noiseNXI1] [noiseNXI2] noiseNXR :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseNXR = HandshakePattern Nothing [noiseNXR2] [noiseNXR1] +noiseNXR = HandshakePattern "NX" Nothing [noiseNXR2] [noiseNXR1] noiseKXI :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseKXI = HandshakePattern (Just noiseKXI0) [noiseKXI1] [noiseKXI2] +noiseKXI = HandshakePattern "KX" (Just noiseKXI0) [noiseKXI1] [noiseKXI2] noiseKXR :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseKXR = HandshakePattern (Just noiseKXR0) [noiseKXR2] [noiseKXR1] +noiseKXR = HandshakePattern "KX" (Just noiseKXR0) [noiseKXR2] [noiseKXR1] noiseXNI :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseXNI = HandshakePattern Nothing [noiseXNI1, noiseXNI3] [noiseXNI2] +noiseXNI = HandshakePattern "XN" Nothing [noiseXNI1, noiseXNI3] [noiseXNI2] noiseXNR :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseXNR = HandshakePattern Nothing [noiseXNR2] [noiseXNR1, noiseXNR3] +noiseXNR = HandshakePattern "XN" Nothing [noiseXNR2] [noiseXNR1, noiseXNR3] noiseINI :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseINI = HandshakePattern Nothing[noiseINI1] [noiseINI2] +noiseINI = HandshakePattern "IN" Nothing[noiseINI1] [noiseINI2] noiseINR :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseINR = HandshakePattern Nothing [noiseINR2] [noiseINR1] +noiseINR = HandshakePattern "IN" Nothing [noiseINR2] [noiseINR1] noiseXKI :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseXKI = HandshakePattern (Just noiseXKI0) [noiseXKI1, noiseXKI3] [noiseXKI2] +noiseXKI = HandshakePattern "XK" (Just noiseXKI0) [noiseXKI1, noiseXKI3] [noiseXKI2] noiseXKR :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseXKR = HandshakePattern (Just noiseXKR0) [noiseXKR2] [noiseXKR1, noiseXKR3] +noiseXKR = HandshakePattern "XK" (Just noiseXKR0) [noiseXKR2] [noiseXKR1, noiseXKR3] noiseIKI :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseIKI = HandshakePattern (Just noiseIKI0) [noiseIKI1] [noiseIKI2] +noiseIKI = HandshakePattern "IK" (Just noiseIKI0) [noiseIKI1] [noiseIKI2] noiseIKR :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseIKR = HandshakePattern (Just noiseIKR0) [noiseIKR2] [noiseIKR1] +noiseIKR = HandshakePattern "IK" (Just noiseIKR0) [noiseIKR2] [noiseIKR1] noiseXEI :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseXEI = HandshakePattern (Just noiseXEI0) [noiseXEI1, noiseXEI3] [noiseXEI2] +noiseXEI = HandshakePattern "XE" (Just noiseXEI0) [noiseXEI1, noiseXEI3] [noiseXEI2] noiseXER :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseXER = HandshakePattern (Just noiseXER0) [noiseXER2] [noiseXER1, noiseXER3] +noiseXER = HandshakePattern "XE" (Just noiseXER0) [noiseXER2] [noiseXER1, noiseXER3] noiseIEI :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseIEI = HandshakePattern (Just noiseIEI0) [noiseIEI1] [noiseIEI2] +noiseIEI = HandshakePattern "IE" (Just noiseIEI0) [noiseIEI1] [noiseIEI2] noiseIER :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseIER = HandshakePattern (Just noiseIER0) [noiseIER2] [noiseIER1] +noiseIER = HandshakePattern "IE" (Just noiseIER0) [noiseIER2] [noiseIER1] noiseXXI :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseXXI = HandshakePattern Nothing [noiseXXI1, noiseXXI3] [noiseXXI2] +noiseXXI = HandshakePattern "XX" Nothing [noiseXXI1, noiseXXI3] [noiseXXI2] noiseXXR :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseXXR = HandshakePattern Nothing [noiseXXR2] [noiseXXR1, noiseXXR3] +noiseXXR = HandshakePattern "XX" Nothing [noiseXXR2] [noiseXXR1, noiseXXR3] noiseIXI :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseIXI = HandshakePattern Nothing [noiseIXI1] [noiseIXI2] +noiseIXI = HandshakePattern "IX" Nothing [noiseIXI1] [noiseIXI2] noiseIXR :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseIXR = HandshakePattern Nothing [noiseIXR2] [noiseIXR1] +noiseIXR = HandshakePattern "IX" Nothing [noiseIXR2] [noiseIXR1] noiseNI :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseNI = HandshakePattern (Just noiseNI0) [noiseNI1] [] +noiseNI = HandshakePattern "N" (Just noiseNI0) [noiseNI1] [] noiseNR :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseNR = HandshakePattern (Just noiseNR0) [] [noiseNR1] +noiseNR = HandshakePattern "N" (Just noiseNR0) [] [noiseNR1] noiseKI :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseKI = HandshakePattern (Just noiseKI0) [noiseKI1] [] +noiseKI = HandshakePattern "K" (Just noiseKI0) [noiseKI1] [] noiseKR :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseKR = HandshakePattern (Just noiseKR0) [] [noiseKR1] +noiseKR = HandshakePattern "K" (Just noiseKR0) [] [noiseKR1] noiseXI :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseXI = HandshakePattern (Just noiseXI0) [noiseXI1] [] +noiseXI = HandshakePattern "X" (Just noiseXI0) [noiseXI1] [] noiseXR :: (Cipher c, Curve d, Hash h) => HandshakePattern c d h -noiseXR = HandshakePattern (Just noiseXR0) [] [noiseXR1] +noiseXR = HandshakePattern "X" (Just noiseXR0) [] [noiseXR1] diff --git a/src/Crypto/Noise/Hash/BLAKE2b.hs b/src/Crypto/Noise/Hash/BLAKE2b.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Noise/Hash/BLAKE2b.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings, TypeFamilies #-} +---------------------------------------------------------------- +-- | +-- Module : Crypto.Noise.Hash.BLAKE2b +-- Maintainer : John Galt +-- Stability : experimental +-- Portability : POSIX + +module Crypto.Noise.Hash.BLAKE2b + ( -- * Types + BLAKE2b + ) where + +import qualified Crypto.Hash as H +import qualified Crypto.MAC.HMAC as M + +import Crypto.Noise.Hash +import Crypto.Noise.Types + +-- | Represents the BLAKE2b hash. +data BLAKE2b + +instance Hash BLAKE2b where + newtype ChainingKey BLAKE2b = HCKB2s ScrubbedBytes + newtype Digest BLAKE2b = HDB2s (H.Digest H.Blake2b_512) + + hashName _ = bsToSB' "BLAKE2b" + hashLength _ = 64 + hash = hashB + hashHKDF = hkdfB + hashBytesToCK = bytesToCKB + hashCKToBytes = ckToBytesB + hashToBytes = toBytesB + +hashB :: ScrubbedBytes + -> Digest BLAKE2b +hashB bs = HDB2s $ H.hash bs + +hkdfB :: ChainingKey BLAKE2b + -> ScrubbedBytes + -> (ChainingKey BLAKE2b, ScrubbedBytes) +hkdfB (HCKB2s ck) d = (HCKB2s ck', sk) + where + x01 = bsToSB' "\x01" + x02 = bsToSB' "\x02" + + hmac1 = M.hmac ck d :: M.HMAC H.Blake2b_512 + temp = convert . M.hmacGetDigest $ hmac1 :: ScrubbedBytes + hmac2 = M.hmac temp x01 :: M.HMAC H.Blake2b_512 + hmac3 = M.hmac temp (convert hmac2 `append` x02) :: M.HMAC H.Blake2b_512 + ck' = convert . M.hmacGetDigest $ hmac2 + sk = convert . M.hmacGetDigest $ hmac3 + +bytesToCKB :: ScrubbedBytes + -> ChainingKey BLAKE2b +bytesToCKB = HCKB2s + +ckToBytesB :: ChainingKey BLAKE2b + -> ScrubbedBytes +ckToBytesB (HCKB2s ck) = ck + +toBytesB :: Digest BLAKE2b + -> ScrubbedBytes +toBytesB (HDB2s d) = convert d diff --git a/src/Crypto/Noise/Hash/BLAKE2s.hs b/src/Crypto/Noise/Hash/BLAKE2s.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Noise/Hash/BLAKE2s.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings, TypeFamilies #-} +---------------------------------------------------------------- +-- | +-- Module : Crypto.Noise.Hash.BLAKE2s +-- Maintainer : John Galt +-- Stability : experimental +-- Portability : POSIX + +module Crypto.Noise.Hash.BLAKE2s + ( -- * Types + BLAKE2s + ) where + +import qualified Crypto.Hash as H +import qualified Crypto.MAC.HMAC as M + +import Crypto.Noise.Hash +import Crypto.Noise.Types + +-- | Represents the BLAKE2s hash. +data BLAKE2s + +instance Hash BLAKE2s where + newtype ChainingKey BLAKE2s = HCKB2s ScrubbedBytes + newtype Digest BLAKE2s = HDB2s (H.Digest H.Blake2s_256) + + hashName _ = bsToSB' "BLAKE2s" + hashLength _ = 32 + hash = hashS + hashHKDF = hkdfS + hashBytesToCK = bytesToCKS + hashCKToBytes = ckToBytesS + hashToBytes = toBytesS + +hashS :: ScrubbedBytes + -> Digest BLAKE2s +hashS bs = HDB2s $ H.hash bs + +hkdfS :: ChainingKey BLAKE2s + -> ScrubbedBytes + -> (ChainingKey BLAKE2s, ScrubbedBytes) +hkdfS (HCKB2s ck) d = (HCKB2s ck', sk) + where + x01 = bsToSB' "\x01" + x02 = bsToSB' "\x02" + + hmac1 = M.hmac ck d :: M.HMAC H.Blake2s_256 + temp = convert . M.hmacGetDigest $ hmac1 :: ScrubbedBytes + hmac2 = M.hmac temp x01 :: M.HMAC H.Blake2s_256 + hmac3 = M.hmac temp (convert hmac2 `append` x02) :: M.HMAC H.Blake2s_256 + ck' = convert . M.hmacGetDigest $ hmac2 + sk = convert . M.hmacGetDigest $ hmac3 + +bytesToCKS :: ScrubbedBytes + -> ChainingKey BLAKE2s +bytesToCKS = HCKB2s + +ckToBytesS :: ChainingKey BLAKE2s + -> ScrubbedBytes +ckToBytesS (HCKB2s ck) = ck + +toBytesS :: Digest BLAKE2s + -> ScrubbedBytes +toBytesS (HDB2s d) = convert d diff --git a/src/Crypto/Noise/Hash/SHA256.hs b/src/Crypto/Noise/Hash/SHA256.hs --- a/src/Crypto/Noise/Hash/SHA256.hs +++ b/src/Crypto/Noise/Hash/SHA256.hs @@ -11,7 +11,7 @@ SHA256 ) where -import qualified Crypto.Hash as H +import qualified Crypto.Hash as H import qualified Crypto.MAC.HMAC as M import Crypto.Noise.Hash diff --git a/src/Crypto/Noise/Hash/SHA512.hs b/src/Crypto/Noise/Hash/SHA512.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Noise/Hash/SHA512.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleInstances #-} +---------------------------------------------------------------- +-- | +-- Module : Crypto.Noise.Hash.SHA512 +-- Maintainer : John Galt +-- Stability : experimental +-- Portability : POSIX + +module Crypto.Noise.Hash.SHA512 + ( -- * Types + SHA512 + ) where + +import qualified Crypto.Hash as H +import qualified Crypto.MAC.HMAC as M + +import Crypto.Noise.Hash +import Crypto.Noise.Types + +-- | Represents the SHA512 hash. +data SHA512 + +instance Hash SHA512 where + newtype ChainingKey SHA512 = HCKSHA512 ScrubbedBytes + newtype Digest SHA512 = HDSHA512 (H.Digest H.SHA512) + + hashName _ = bsToSB' "SHA512" + hashLength _ = 64 + hash = hash' + hashHKDF = hkdf + hashBytesToCK = bytesToCK + hashCKToBytes = ckToBytes + hashToBytes = toBytes + +hash' :: ScrubbedBytes -> Digest SHA512 +hash' bs = HDSHA512 $ H.hash bs + +hkdf :: ChainingKey SHA512 -> ScrubbedBytes -> (ChainingKey SHA512, ScrubbedBytes) +hkdf (HCKSHA512 ck) d = (HCKSHA512 ck', sk) + where + x01 = bsToSB' "\x01" + x02 = bsToSB' "\x02" + + hmac1 = M.hmac ck d :: M.HMAC H.SHA512 + temp = convert . M.hmacGetDigest $ hmac1 :: ScrubbedBytes + hmac2 = M.hmac temp x01 :: M.HMAC H.SHA512 + hmac3 = M.hmac temp (convert hmac2 `append` x02) :: M.HMAC H.SHA512 + ck' = convert . M.hmacGetDigest $ hmac2 + sk = convert . M.hmacGetDigest $ hmac3 + +bytesToCK :: ScrubbedBytes -> ChainingKey SHA512 +bytesToCK = HCKSHA512 + +ckToBytes :: ChainingKey SHA512 -> ScrubbedBytes +ckToBytes (HCKSHA512 ck) = ck + +toBytes :: Digest SHA512 -> ScrubbedBytes +toBytes (HDSHA512 d) = convert d diff --git a/src/Crypto/Noise/Internal/CipherState.hs b/src/Crypto/Noise/Internal/CipherState.hs --- a/src/Crypto/Noise/Internal/CipherState.hs +++ b/src/Crypto/Noise/Internal/CipherState.hs @@ -17,10 +17,12 @@ decryptAndIncrement ) where +import Control.Exception (throw) import Control.Lens import Data.Maybe (fromMaybe) import Crypto.Noise.Cipher +import Crypto.Noise.Types (NoiseException(DecryptionFailure)) -- | Represents a symmetric key and associated nonce. data CipherState c = @@ -39,6 +41,6 @@ decryptAndIncrement :: Cipher c => AssocData -> Ciphertext c -> CipherState c -> (Plaintext, CipherState c) decryptAndIncrement ad ct cs = (pt, newState) where - pt = fromMaybe (error "decryptAndIncrement: error decrypting ciphertext") + pt = fromMaybe (throw (DecryptionFailure "decryptAndIncrement")) (cipherDecrypt (cs ^. csk) (cs ^. csn) ad ct) newState = cs & csn %~ cipherIncNonce diff --git a/src/Crypto/Noise/Internal/HandshakeState.hs b/src/Crypto/Noise/Internal/HandshakeState.hs --- a/src/Crypto/Noise/Internal/HandshakeState.hs +++ b/src/Crypto/Noise/Internal/HandshakeState.hs @@ -18,7 +18,10 @@ HandshakeState, -- * Functions runMessagePatternT, + getLocalStaticKey, + getLocalEphemeralKey, getRemoteStaticKey, + getRemoteEphemeralKey, handshakeState, writeMessage, readMessage, @@ -28,12 +31,13 @@ decryptPayload ) where +import Control.Exception (throw) import Control.Lens hiding (re) import Control.Monad.State import Data.ByteString (ByteString) import qualified Data.ByteString as B (append, splitAt) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isJust) import Data.Proxy import Crypto.Noise.Cipher @@ -64,10 +68,11 @@ -- | Represents a series of message patterns, the first for writing and the -- second for reading. data HandshakePattern c d h = - HandshakePattern { _hpPreMsg :: Maybe (MessagePattern c d h ()) - , _hpWriteMsg :: [MessagePatternIO c d h ByteString] - , _hpReadMsg :: [ByteString -> MessagePattern c d h ByteString] - } + HandshakePattern { _hpName :: ByteString + , _hpPreMsg :: Maybe (MessagePattern c d h ()) + , _hpWriteMsg :: [MessagePatternIO c d h ByteString] + , _hpReadMsg :: [ByteString -> MessagePattern c d h ByteString] + } -- | Contains the state of a handshake. data HandshakeState c d h = @@ -105,18 +110,52 @@ tokenPreRE = tokenPreRX hssRemoteEphemeralKey - tokenRE buf = tokenRX buf hssRemoteEphemeralKey + tokenRE buf = do + hs <- get - tokenRS buf = tokenRX buf hssRemoteStaticKey + let (b, rest) = B.splitAt (curveLength (Proxy :: Proxy d)) buf + reBytes = convert b + ss = hs ^. hssSymmetricState + ss' = mixHash reBytes ss + ss'' = if ss ^. ssHasPSK then mixKey reBytes ss' else ss' + put $ hs & hssRemoteEphemeralKey .~ Just (curveBytesToPub reBytes) + & hssSymmetricState .~ ss'' + + return rest + + tokenRS buf = do + hs <- get + if isJust (hs ^. hssRemoteStaticKey) then + throw . HandshakeStateFailure $ "unable to overwrite remote static key" + else do + let hasKey = hs ^. hssSymmetricState . ssHasKey + (b, rest) = B.splitAt (d hasKey) buf + ct = cipherBytesToText . convert $ b + ss = hs ^. hssSymmetricState + (Plaintext pt, ss') = decryptAndHash ct ss + + put $ hs & hssRemoteStaticKey .~ Just (curveBytesToPub pt) + & hssSymmetricState .~ ss' + + return rest + + where + len = curveLength (Proxy :: Proxy d) + d hk + | hk = len + 16 + | otherwise = len + tokenWE = do ~kp@(_, pk) <- liftIO curveGenKey hs <- get - let pk' = curvePubToBytes pk - ss = hs ^. hssSymmetricState - (ct, ss') = encryptAndHash (Plaintext pk') ss - put $ hs & hssLocalEphemeralKey .~ Just kp & hssSymmetricState .~ ss' - return . convert $ ct + let pk' = curvePubToBytes pk + ss = hs ^. hssSymmetricState + ss' = mixHash pk' ss + ss'' = if ss' ^. ssHasPSK then mixKey pk' ss' else ss' + put $ hs & hssLocalEphemeralKey .~ Just kp + & hssSymmetricState .~ ss'' + return . convert $ pk' tokenWS = do hs <- get @@ -150,7 +189,7 @@ ~(sk, _) = getLocalStaticKey hs rpk = getRemoteEphemeralKey hs dh = curveDH sk rpk - ss' = mixKey dh ss + ss' = mixKey dh ss put $ hs & hssSymmetricState .~ ss' tokenDHSS = do @@ -163,22 +202,22 @@ put $ hs & hssSymmetricState .~ ss' getLocalStaticKey :: Curve d => HandshakeState c d h -> KeyPair d -getLocalStaticKey hs = fromMaybe (error "local static key not set") +getLocalStaticKey hs = fromMaybe (throw (HandshakeStateFailure "local static key not set")) (hs ^. hssLocalStaticKey) getLocalEphemeralKey :: Curve d => HandshakeState c d h -> KeyPair d -getLocalEphemeralKey hs = fromMaybe (error "local ephemeral key not set") +getLocalEphemeralKey hs = fromMaybe (throw (HandshakeStateFailure "local ephemeral key not set")) (hs ^. hssLocalEphemeralKey) -- | Returns the remote party's public static key. This is useful when -- the static key has been transmitted to you and you want to save it for -- future use. getRemoteStaticKey :: Curve d => HandshakeState c d h -> PublicKey d -getRemoteStaticKey hs = fromMaybe (error "remote static key not set") +getRemoteStaticKey hs = fromMaybe (throw (HandshakeStateFailure "remote static key not set")) (hs ^. hssRemoteStaticKey) getRemoteEphemeralKey :: Curve d => HandshakeState c d h -> PublicKey d -getRemoteEphemeralKey hs = fromMaybe (error "remote ephemeral key not set") +getRemoteEphemeralKey hs = fromMaybe (throw (HandshakeStateFailure "remote ephemeral key not set")) (hs ^. hssRemoteEphemeralKey) tokenPreLX :: (MonadState (HandshakeState c d h) m, Cipher c, Curve d, Hash h) @@ -187,7 +226,8 @@ tokenPreLX keyToView = do hs <- get let ss = hs ^. hssSymmetricState - (_, pk) = fromMaybe (error "tokenPreLX: local key not set") (hs ^. keyToView) + (_, pk) = fromMaybe (throw (HandshakeStateFailure "tokenPreLX: local key not set")) + (hs ^. keyToView) ss' = mixHash (curvePubToBytes pk) ss put $ hs & hssSymmetricState .~ ss' @@ -197,44 +237,23 @@ tokenPreRX keyToView = do hs <- get let ss = hs ^. hssSymmetricState - pk = fromMaybe (error "tokenPreRX: remote key not set") (hs ^. keyToView) + pk = fromMaybe (throw (HandshakeStateFailure "tokenPreRX: remote key not set")) + (hs ^. keyToView) ss' = mixHash (curvePubToBytes pk) ss put $ hs & hssSymmetricState .~ ss' -tokenRX :: forall c d h m. (MonadState (HandshakeState c d h) m, Cipher c, Curve d, Hash h) - => ByteString - -> Lens' (HandshakeState c d h) (Maybe (PublicKey d)) - -> m ByteString -tokenRX buf keyToUpdate = do - hs <- get - - let hasKey = hs ^. hssSymmetricState . ssHasKey - (b, rest) = B.splitAt (d hasKey) buf - ct = cipherBytesToText . convert $ b - ss = hs ^. hssSymmetricState - (Plaintext pt, ss') = decryptAndHash ct ss - - put $ hs & keyToUpdate .~ Just (curveBytesToPub pt) & hssSymmetricState .~ ss' - - return rest - - where - len = curveLength (Proxy :: Proxy d) - d hk - | hk = len + 16 - | otherwise = len - --- | Constructs a HandshakeState. The keys you need to provide are +-- | Constructs a 'HandshakeState'. The keys you need to provide are -- dependent on the type of handshake you are using. If you fail to --- provide a key that your handshake type depends on, you will receive an --- error such as "local static key not set". +-- provide a key that your handshake type depends on, or you provide +-- a static key which is supposed to be set during the exchange, you will +-- receive a 'HandshakeStateFailure' exception. handshakeState :: forall c d h. (Cipher c, Curve d, Hash h) - => ByteString - -- ^ Handshake pattern name - -> HandshakePattern c d h + => HandshakePattern c d h -- ^ The handshake pattern to use -> Plaintext -- ^ Prologue + -> Maybe Plaintext + -- ^ Pre-shared key -> Maybe (KeyPair d) -- ^ Local static key -> Maybe (KeyPair d) @@ -244,17 +263,36 @@ -> Maybe (PublicKey d) -- ^ Remote public ephemeral key -> HandshakeState c d h -handshakeState hpn hsp (Plaintext pro) ls le rs re = maybe hs' hs'' $ hsp ^. hpPreMsg +handshakeState hp (Plaintext pro) (Just (Plaintext psk)) ls le rs re = + maybe hs' hs'' $ hp ^. hpPreMsg where - p = bsToSB' "Noise_" - a = curveName (Proxy :: Proxy d) - b = cipherName (Proxy :: Proxy c) - c = hashName (Proxy :: Proxy h) - u = bsToSB' "_" - hpn' = concatSB [p, bsToSB' hpn, u, a, u, b, u, c] - hs = HandshakeState (symmetricHandshake hpn') hsp ls le rs re - hs' = hs & hssSymmetricState %~ mixHash pro - hs'' mp = snd . runIdentity $ runMessagePatternT mp hs + hsPro x = x & hssSymmetricState %~ mixHash pro + hsPSK x = x & hssSymmetricState %~ mixPSK psk + hs = HandshakeState (symmetricState (mkHPN hp True)) hp ls le rs re + hs' = hsPSK . hsPro $ hs + hs'' mp = snd . runIdentity $ runMessagePatternT mp hs' + +handshakeState hp (Plaintext pro) Nothing ls le rs re = + maybe hs' hs'' $ hp ^. hpPreMsg + where + hsPro x = x & hssSymmetricState %~ mixHash pro + hs = HandshakeState (symmetricState (mkHPN hp False)) hp ls le rs re + hs' = hsPro hs + hs'' mp = snd . runIdentity $ runMessagePatternT mp hs' + +mkHPN :: forall c d h. (Cipher c, Curve d, Hash h) + => HandshakePattern c d h + -> Bool + -> ScrubbedBytes +mkHPN hp psk = if psk then hpn' ppsk else hpn' p + where + p = bsToSB' "Noise_" + ppsk = bsToSB' "NoisePSK_" + a = curveName (Proxy :: Proxy d) + b = cipherName (Proxy :: Proxy c) + c = hashName (Proxy :: Proxy h) + u = bsToSB' "_" + hpn' pfx = concatSB [pfx, bsToSB' (hp ^. hpName), u, a, u, b, u, c] -- | Creates a handshake message. The plaintext can be left empty if no -- plaintext is to be transmitted. All subsequent handshake processing diff --git a/src/Crypto/Noise/Internal/SymmetricState.hs b/src/Crypto/Noise/Internal/SymmetricState.hs --- a/src/Crypto/Noise/Internal/SymmetricState.hs +++ b/src/Crypto/Noise/Internal/SymmetricState.hs @@ -12,10 +12,12 @@ -- * Lenses ssCipher, ssHasKey, + ssHasPSK, ssh, -- * Functions - symmetricHandshake, + symmetricState, mixKey, + mixPSK, mixHash, encryptAndHash, decryptAndHash, @@ -35,21 +37,22 @@ data SymmetricState c h = SymmetricState { _ssCipher :: CipherState c , _ssHasKey :: Bool + , _ssHasPSK :: Bool , _ssck :: ChainingKey h , _ssh :: Either ScrubbedBytes (Digest h) } $(makeLenses ''SymmetricState) -symmetricHandshake :: forall c h. (Cipher c, Hash h) => ScrubbedBytes -> SymmetricState c h -symmetricHandshake hsn = SymmetricState cs False ck hsn' +symmetricState :: forall c h. (Cipher c, Hash h) => ScrubbedBytes -> SymmetricState c h +symmetricState hsn = SymmetricState cs False False ck hsn' where hashLen = hashLength (Proxy :: Proxy h) shouldHash = BA.length hsn > hashLen hsn' = if shouldHash then - Left $ hsn `append` BA.replicate (hashLen - BA.length hsn) 0 - else Right $ hash hsn + else + Left $ hsn `append` BA.replicate (hashLen - BA.length hsn) 0 ck = hashBytesToCK . sshBytes $ hsn' cs = CipherState undefined undefined @@ -61,6 +64,13 @@ (ck, k) = hashHKDF (ss ^. ssck) d cs = CipherState (cipherBytesToSym k) cipherZeroNonce +mixPSK :: (Cipher c, Hash h) => ScrubbedBytes -> SymmetricState c h -> SymmetricState c h +mixPSK psk ss = ss'' & ssHasPSK .~ True + where + (ck, tmp) = hashHKDF (ss ^. ssck) psk + ss' = ss & ssck .~ ck + ss'' = mixHash tmp ss' + mixHash :: (Cipher c, Hash h) => ScrubbedBytes -> SymmetricState c h -> SymmetricState c h mixHash d ss = ss & ssh %~ Right . hash . (`append` d) . sshBytes @@ -75,12 +85,12 @@ decryptAndHash :: (Cipher c, Hash h) => Ciphertext c -> SymmetricState c h -> (Plaintext, SymmetricState c h) decryptAndHash ct ss - | ss ^. ssHasKey = (pt, kss') - | otherwise = (Plaintext (cipherTextToBytes ct), nkss') + | ss ^. ssHasKey = (pt, kss) + | otherwise = (Plaintext (cipherTextToBytes ct), nkss) where (pt, cs) = decryptAndIncrement (AssocData (sshBytes (ss ^. ssh))) ct (ss ^. ssCipher) - kss' = mixHash (cipherTextToBytes ct) (ss & ssCipher .~ cs) - nkss' = mixHash (cipherTextToBytes ct) ss + kss = mixHash (cipherTextToBytes ct) ss & ssCipher .~ cs + nkss = mixHash (cipherTextToBytes ct) ss split :: (Cipher c, Hash h) => SymmetricState c h -> (CipherState c, CipherState c) split ss = (cs1, cs2) diff --git a/src/Crypto/Noise/MessagePatterns.hs b/src/Crypto/Noise/MessagePatterns.hs --- a/src/Crypto/Noise/MessagePatterns.hs +++ b/src/Crypto/Noise/MessagePatterns.hs @@ -5,18 +5,12 @@ -- Stability : experimental -- Portability : POSIX -- --- This module contains all of the message patterns for all the handshakes --- specified in the protocol. The first two characters of the name --- represent the handshake the pattern belongs to (NN, KN, NK, etc). The --- next character represents whether the pattern is intended to be used --- by the __I__nitiator or the __R__esponder. Finally, the number indicates --- the step of the handshake in which the pattern is intended to be used. --- Regular handshake steps begin at 1, but patterns for pre-messages are --- numbered 0. The patterns for pre-messages are intended to be passed --- to the 'handshakeState' function. The (de-)serialization of pre-messages --- is beyond the scope of this library, but public keys can be --- imported/exported using the 'curveBytesToPub' and 'curvePubToBytes' --- functions. +-- This module contains all of the message patterns specified in the +-- protocol. Their nomenclature is the same as +-- "Crypto.Noise.HandshakePatterns" plus an additional digit +-- representing the step of the handshake in which the pattern is +-- intended to be used. Zero indicates a pre-message pattern. + module Crypto.Noise.MessagePatterns ( -- * Functions -- ** Noise_NN @@ -394,7 +388,7 @@ noiseKER2 = do e <- tokenWE tokenDHEE - tokenDHSE + tokenDHES return e noiseKEI2 :: (Cipher c, Curve d, Hash h) @@ -403,7 +397,7 @@ noiseKEI2 buf = do rest <- tokenRE buf tokenDHEE - tokenDHES + tokenDHSE return rest -------------------------------------------------------------------------------- @@ -526,16 +520,14 @@ noiseINI1 :: (Cipher c, Curve d, Hash h) => MessagePatternIO c d h ByteString noiseINI1 = do - s <- tokenWS e <- tokenWE - return $ s `append` e + s <- tokenWS + return $ e `append` s noiseINR1 :: (Cipher c, Curve d, Hash h) => ByteString -> MessagePattern c d h ByteString -noiseINR1 buf = do - rest <- tokenRS buf - tokenRE rest +noiseINR1 = tokenRE >=> tokenRS noiseINR2 :: (Cipher c, Curve d, Hash h) => MessagePatternIO c d h ByteString @@ -824,14 +816,14 @@ noiseIXI1 :: (Cipher c, Curve d, Hash h) => MessagePatternIO c d h ByteString noiseIXI1 = do - s <- tokenWS e <- tokenWE - return $ s `append` e + s <- tokenWS + return $ e `append` s noiseIXR1 :: (Cipher c, Curve d, Hash h) => ByteString -> MessagePattern c d h ByteString -noiseIXR1 = tokenRS >=> tokenRE +noiseIXR1 = tokenRE >=> tokenRS noiseIXR2 :: (Cipher c, Curve d, Hash h) => MessagePatternIO c d h ByteString diff --git a/src/Crypto/Noise/Types.hs b/src/Crypto/Noise/Types.hs --- a/src/Crypto/Noise/Types.hs +++ b/src/Crypto/Noise/Types.hs @@ -8,6 +8,7 @@ module Crypto.Noise.Types ( -- * Types ScrubbedBytes, + NoiseException(..), -- * Functions convert, append, @@ -19,10 +20,25 @@ sbEq ) where +import Control.Exception (Exception) import Data.ByteArray (ScrubbedBytes, concat, convert, append, eq) import qualified Data.ByteString as BS (ByteString) import qualified Data.ByteString.Lazy as BL (ByteString, toStrict, fromStrict) import Prelude hiding (concat) + +-- | Represents exceptions which can occur. 'DecryptionFailure' is thrown +-- if a symmetric decryption operation fails, which is usually the result +-- of an invalid authentication tag. 'HandshakeStateFailure' is thrown if +-- the 'Crypto.Noise.Handshake.HandshakeState' is improperly initialized +-- for the given handshake type. +-- +-- If your goal is to detect an invalid PSK, prologue, etc, you'll want +-- to catch 'DecryptionFailure'. +data NoiseException = DecryptionFailure String + | HandshakeStateFailure String + deriving (Show) + +instance Exception NoiseException -- | Concatenates a list of 'ScrubbedBytes'. concatSB :: [ScrubbedBytes] -> ScrubbedBytes diff --git a/tests/Handshake.hs b/tests/Handshake.hs deleted file mode 100644 --- a/tests/Handshake.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Handshake where - -import Crypto.Noise.Cipher -import Crypto.Noise.Curve -import Crypto.Noise.Handshake -import Crypto.Noise.Hash -import Crypto.Noise.Types - -import HandshakeStates -import Imports -import Instances() - -data HandshakeType = NoiseNN - | NoiseKN - | NoiseNK - | NoiseKK - | NoiseNE - | NoiseKE - | NoiseNX - | NoiseKX - | NoiseXN - | NoiseIN - | NoiseXK - | NoiseIK - | NoiseXE - | NoiseIE - | NoiseXX - | NoiseIX - | NoiseN - | NoiseK - | NoiseX - -sampleHSPT :: Plaintext -sampleHSPT = Plaintext . bsToSB' $ "cacophony" - -mkHandshakeProp :: HandshakeType - -> Plaintext - -> Property -mkHandshakeProp ht = - case ht of - NoiseNN -> twoMessage noiseNNIHS noiseNNRHS - NoiseKN -> twoMessage noiseKNIHS noiseKNRHS - NoiseNK -> twoMessage noiseNKIHS noiseNKRHS - NoiseKK -> twoMessage noiseKKIHS noiseKKRHS - NoiseNE -> twoMessage noiseNEIHS noiseNERHS - NoiseKE -> twoMessage noiseKEIHS noiseKERHS - NoiseNX -> twoMessage noiseNXIHS noiseNXRHS - NoiseKX -> twoMessage noiseKXIHS noiseKXRHS - NoiseXN -> threeMessage noiseXNIHS noiseXNRHS - NoiseIN -> twoMessage noiseINIHS noiseINRHS - NoiseXK -> threeMessage noiseXKIHS noiseXKRHS - NoiseIK -> twoMessage noiseIKIHS noiseIKRHS - NoiseXE -> threeMessage noiseXEIHS noiseXERHS - NoiseIE -> twoMessage noiseIEIHS noiseIERHS - NoiseXX -> threeMessage noiseXXIHS noiseXXRHS - NoiseIX -> twoMessage noiseIXIHS noiseIXRHS - NoiseN -> oneMessage noiseNIHS noiseNRHS - NoiseK -> oneMessage noiseKIHS noiseKRHS - NoiseX -> oneMessage noiseXIHS noiseXRHS - -oneMessage :: (Cipher c, Curve d, Hash h) - => HandshakeState c d h - -> HandshakeState c d h - -> Plaintext - -> Property -oneMessage ihs rhs pt = ioProperty $ do - (aliceToBob1, csAlice1, _) <- writeMessageFinal ihs sampleHSPT - let (hsptFromBob1, csBob1, _) = readMessageFinal rhs aliceToBob1 - - return $ conjoin - [ (decrypt csBob1 . encrypt csAlice1) pt === pt - , (decrypt csAlice1 . encrypt csBob1) pt === pt - , hsptFromBob1 === sampleHSPT - ] - - where - encrypt cs p = fst $ encryptPayload p cs - decrypt cs ct = fst $ decryptPayload ct cs - -twoMessage :: (Cipher c, Curve d, Hash h) - => HandshakeState c d h - -> HandshakeState c d h - -> Plaintext - -> Property -twoMessage ihs rhs pt = ioProperty $ do - (aliceToBob1, ihs') <- writeMessage ihs sampleHSPT - let (hsptFromAlice1, rhs') = readMessage rhs aliceToBob1 - - (bobToAlice1, csBob1, csBob2) <- writeMessageFinal rhs' sampleHSPT - let (hsptFromBob1, csAlice1, csAlice2) = readMessageFinal ihs' bobToAlice1 - - return $ conjoin - [ (decrypt csBob1 . encrypt csAlice1) pt === pt - , (decrypt csBob2 . encrypt csAlice2) pt === pt - , (decrypt csAlice1 . encrypt csBob1) pt === pt - , (decrypt csAlice2 . encrypt csBob2) pt === pt - , hsptFromAlice1 === sampleHSPT - , hsptFromBob1 === sampleHSPT - ] - - where - encrypt cs p = fst $ encryptPayload p cs - decrypt cs ct = fst $ decryptPayload ct cs - -threeMessage :: (Cipher c, Curve d, Hash h) - => HandshakeState c d h - -> HandshakeState c d h - -> Plaintext - -> Property -threeMessage ihs rhs pt = - ioProperty $ do - (aliceToBob1, ihs') <- writeMessage ihs sampleHSPT - let (hsptFromAlice1, rhs') = readMessage rhs aliceToBob1 - - (bobToAlice1, rhs'') <- writeMessage rhs' sampleHSPT - let (hsptFromBob1, ihs'') = readMessage ihs' bobToAlice1 - - (aliceToBob2, csAlice1, csAlice2) <- writeMessageFinal ihs'' sampleHSPT - let (hsptFromBob2, csBob1, csBob2) = readMessageFinal rhs'' aliceToBob2 - - return $ conjoin - [ (decrypt csBob1 . encrypt csAlice1) pt === pt - , (decrypt csBob2 . encrypt csAlice2) pt === pt - , (decrypt csAlice1 . encrypt csBob1) pt === pt - , (decrypt csAlice2 . encrypt csBob2) pt === pt - , hsptFromAlice1 === sampleHSPT - , hsptFromBob1 === sampleHSPT - , hsptFromBob2 === sampleHSPT - ] - - where - encrypt cs p = fst $ encryptPayload p cs - decrypt cs ct = fst $ decryptPayload ct cs - -tests :: TestTree -tests = testGroup "Handshakes" - [ testProperty "Noise_NN" . property . mkHandshakeProp $ NoiseNN - , testProperty "Noise_KN" . property . mkHandshakeProp $ NoiseKN - , testProperty "Noise_NK" . property . mkHandshakeProp $ NoiseNK - , testProperty "Noise_KK" . property . mkHandshakeProp $ NoiseKK - , testProperty "Noise_NE" . property . mkHandshakeProp $ NoiseNE - , testProperty "Noise_KE" . property . mkHandshakeProp $ NoiseKE - , testProperty "Noise_NX" . property . mkHandshakeProp $ NoiseNX - , testProperty "Noise_KX" . property . mkHandshakeProp $ NoiseKX - , testProperty "Noise_XN" . property . mkHandshakeProp $ NoiseXN - , testProperty "Noise_IN" . property . mkHandshakeProp $ NoiseIN - , testProperty "Noise_XK" . property . mkHandshakeProp $ NoiseXK - , testProperty "Noise_IK" . property . mkHandshakeProp $ NoiseIK - , testProperty "Noise_XE" . property . mkHandshakeProp $ NoiseXE - , testProperty "Noise_IE" . property . mkHandshakeProp $ NoiseIE - , testProperty "Noise_XX" . property . mkHandshakeProp $ NoiseXX - , testProperty "Noise_IX" . property . mkHandshakeProp $ NoiseIX - , testProperty "Noise_N" . property . mkHandshakeProp $ NoiseN - , testProperty "Noise_K" . property . mkHandshakeProp $ NoiseK - , testProperty "Noise_X" . property . mkHandshakeProp $ NoiseX - ] diff --git a/tests/HandshakeStates.hs b/tests/HandshakeStates.hs --- a/tests/HandshakeStates.hs +++ b/tests/HandshakeStates.hs @@ -1,436 +1,508 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, RecordWildCards #-} module HandshakeStates where -import Crypto.Noise.Cipher.ChaChaPoly1305 +import Crypto.Noise.Cipher import Crypto.Noise.Curve -import Crypto.Noise.Curve.Curve25519 import Crypto.Noise.Handshake import Crypto.Noise.HandshakePatterns -import Crypto.Noise.Hash.SHA256 -import Crypto.Noise.Types - -initStatic :: KeyPair Curve25519 -initStatic = curveBytesToPair . bsToSB' $ "I\f\232\218A\210\230\147\FS\222\167\v}l\243!\168.\ESC\t\SYN\"\169\179A`\DC28\211\169tC" - -respStatic :: KeyPair Curve25519 -respStatic = curveBytesToPair . bsToSB' $ "\ETB\157\&7\DC2\252\NUL\148\172\148\133\218\207\&8\221y\144\209\168FX\224Ser_\178|\153.\FSg&" +import Crypto.Noise.Hash -respEphemeral :: KeyPair Curve25519 -respEphemeral = curveBytesToPair . bsToSB' $ "<\231\151\151\180\217\146\DLEI}\160N\163iKc\162\210Y\168R\213\206&gm\169r\SUB[\\'" +data HandshakeKeys d = + HandshakeKeys { psk :: Maybe Plaintext + , initStatic :: KeyPair d + , respStatic :: KeyPair d + , respEphemeral :: KeyPair d + } -noiseNNIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseNNIHS = +noiseNNIHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseNNIHS HandshakeKeys{..} = handshakeState - "NN" noiseNNI "" + psk Nothing Nothing Nothing Nothing -noiseKNIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseKNIHS = +noiseKNIHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseKNIHS HandshakeKeys{..} = handshakeState - "KN" noiseKNI "" + psk (Just initStatic) Nothing Nothing Nothing -noiseNKIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseNKIHS = +noiseNKIHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseNKIHS HandshakeKeys{..} = handshakeState - "NK" noiseNKI "" + psk Nothing Nothing (Just (snd respStatic)) Nothing -noiseKKIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseKKIHS = +noiseKKIHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseKKIHS HandshakeKeys{..} = handshakeState - "KK" noiseKKI "" + psk (Just initStatic) Nothing (Just (snd respStatic)) Nothing -noiseNEIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseNEIHS = +noiseNEIHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseNEIHS HandshakeKeys{..} = handshakeState - "NE" noiseNEI "" + psk Nothing Nothing (Just (snd respStatic)) (Just (snd respEphemeral)) -noiseKEIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseKEIHS = +noiseKEIHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseKEIHS HandshakeKeys{..} = handshakeState - "KE" noiseKEI "" + psk (Just initStatic) Nothing (Just (snd respStatic)) (Just (snd respEphemeral)) -noiseNXIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseNXIHS = +noiseNXIHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseNXIHS HandshakeKeys{..} = handshakeState - "NX" noiseNXI "" + psk Nothing Nothing Nothing Nothing -noiseKXIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseKXIHS = +noiseKXIHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseKXIHS HandshakeKeys{..} = handshakeState - "KX" noiseKXI "" + psk (Just initStatic) Nothing - (Just (snd respStatic)) Nothing + Nothing -noiseXNIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseXNIHS = +noiseXNIHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseXNIHS HandshakeKeys{..} = handshakeState - "XN" noiseXNI "" + psk (Just initStatic) Nothing Nothing Nothing -noiseINIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseINIHS = +noiseINIHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseINIHS HandshakeKeys{..} = handshakeState - "IN" noiseINI "" + psk (Just initStatic) Nothing Nothing Nothing -noiseXKIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseXKIHS = +noiseXKIHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseXKIHS HandshakeKeys{..} = handshakeState - "XK" noiseXKI "" + psk (Just initStatic) Nothing (Just (snd respStatic)) Nothing -noiseIKIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseIKIHS = +noiseIKIHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseIKIHS HandshakeKeys{..} = handshakeState - "IK" noiseIKI "" + psk (Just initStatic) Nothing (Just (snd respStatic)) Nothing -noiseXEIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseXEIHS = +noiseXEIHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseXEIHS HandshakeKeys{..} = handshakeState - "XE" noiseXEI "" + psk (Just initStatic) Nothing (Just (snd respStatic)) (Just (snd respEphemeral)) -noiseIEIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseIEIHS = +noiseIEIHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseIEIHS HandshakeKeys{..} = handshakeState - "IE" noiseIEI "" + psk (Just initStatic) Nothing (Just (snd respStatic)) (Just (snd respEphemeral)) -noiseXXIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseXXIHS = +noiseXXIHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseXXIHS HandshakeKeys{..} = handshakeState - "XX" noiseXXI "" + psk (Just initStatic) Nothing Nothing Nothing -noiseIXIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseIXIHS = +noiseIXIHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseIXIHS HandshakeKeys{..} = handshakeState - "IX" noiseIXI "" + psk (Just initStatic) Nothing Nothing Nothing -noiseNIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseNIHS = +noiseNIHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseNIHS HandshakeKeys{..} = handshakeState - "N" noiseNI "" + psk Nothing Nothing (Just (snd respStatic)) Nothing -noiseKIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseKIHS = +noiseKIHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseKIHS HandshakeKeys{..} = handshakeState - "K" noiseKI "" + psk (Just initStatic) Nothing (Just (snd respStatic)) Nothing -noiseXIHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseXIHS = +noiseXIHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseXIHS HandshakeKeys{..} = handshakeState - "X" noiseXI "" + psk (Just initStatic) Nothing (Just (snd respStatic)) Nothing -noiseNNRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseNNRHS = +noiseNNRHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseNNRHS HandshakeKeys{..} = handshakeState - "NN" noiseNNR "" + psk Nothing Nothing Nothing Nothing -noiseKNRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseKNRHS = +noiseKNRHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseKNRHS HandshakeKeys{..} = handshakeState - "KN" noiseKNR "" + psk Nothing Nothing (Just (snd initStatic)) Nothing -noiseNKRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseNKRHS = +noiseNKRHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseNKRHS HandshakeKeys{..} = handshakeState - "NK" noiseNKR "" + psk (Just respStatic) Nothing Nothing Nothing -noiseKKRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseKKRHS = +noiseKKRHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseKKRHS HandshakeKeys{..} = handshakeState - "KK" noiseKKR "" + psk (Just respStatic) Nothing (Just (snd initStatic)) Nothing -noiseNERHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseNERHS = +noiseNERHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseNERHS HandshakeKeys{..} = handshakeState - "NE" noiseNER "" + psk (Just respStatic) (Just respEphemeral) Nothing Nothing -noiseKERHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseKERHS = +noiseKERHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseKERHS HandshakeKeys{..} = handshakeState - "KE" noiseKER "" + psk (Just respStatic) (Just respEphemeral) (Just (snd initStatic)) Nothing -noiseNXRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseNXRHS = +noiseNXRHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseNXRHS HandshakeKeys{..} = handshakeState - "NX" noiseNXR "" + psk (Just respStatic) Nothing Nothing Nothing -noiseKXRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseKXRHS = +noiseKXRHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseKXRHS HandshakeKeys{..} = handshakeState - "KX" noiseKXR "" + psk (Just respStatic) Nothing (Just (snd initStatic)) Nothing -noiseXNRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseXNRHS = +noiseXNRHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseXNRHS HandshakeKeys{..} = handshakeState - "XN" noiseXNR "" + psk Nothing Nothing Nothing Nothing -noiseINRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseINRHS = +noiseINRHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseINRHS HandshakeKeys{..} = handshakeState - "IN" noiseINR "" + psk Nothing Nothing Nothing Nothing -noiseXKRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseXKRHS = +noiseXKRHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseXKRHS HandshakeKeys{..} = handshakeState - "XK" noiseXKR "" + psk (Just respStatic) Nothing Nothing Nothing -noiseIKRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseIKRHS = +noiseIKRHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseIKRHS HandshakeKeys{..} = handshakeState - "IK" noiseIKR "" + psk (Just respStatic) Nothing Nothing Nothing -noiseXERHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseXERHS = +noiseXERHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseXERHS HandshakeKeys{..} = handshakeState - "XE" noiseXER "" + psk (Just respStatic) (Just respEphemeral) Nothing Nothing -noiseIERHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseIERHS = +noiseIERHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseIERHS HandshakeKeys{..} = handshakeState - "IE" noiseIER "" + psk (Just respStatic) (Just respEphemeral) Nothing Nothing -noiseXXRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseXXRHS = +noiseXXRHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseXXRHS HandshakeKeys{..} = handshakeState - "XX" noiseXXR "" + psk (Just respStatic) Nothing Nothing Nothing -noiseIXRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseIXRHS = +noiseIXRHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseIXRHS HandshakeKeys{..} = handshakeState - "IX" noiseIXR "" + psk (Just respStatic) Nothing Nothing Nothing -noiseNRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseNRHS = +noiseNRHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseNRHS HandshakeKeys{..} = handshakeState - "N" noiseNR "" + psk (Just respStatic) Nothing Nothing Nothing -noiseKRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseKRHS = +noiseKRHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseKRHS HandshakeKeys{..} = handshakeState - "K" noiseKR "" + psk (Just respStatic) Nothing (Just (snd initStatic)) Nothing -noiseXRHS :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 -noiseXRHS = +noiseXRHS :: (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> HandshakeState c d h +noiseXRHS HandshakeKeys{..} = handshakeState - "X" noiseXR "" + psk (Just respStatic) Nothing Nothing diff --git a/tests/Handshakes.hs b/tests/Handshakes.hs new file mode 100644 --- /dev/null +++ b/tests/Handshakes.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE OverloadedStrings, RankNTypes, ScopedTypeVariables #-} +module Handshakes where + +import Data.Proxy + +import Crypto.Noise.Cipher +import Crypto.Noise.Cipher.AESGCM +import Crypto.Noise.Cipher.ChaChaPoly1305 +import Crypto.Noise.Curve +import Crypto.Noise.Curve.Curve25519 +import Crypto.Noise.Handshake +import Crypto.Noise.Hash +import Crypto.Noise.Hash.BLAKE2s +import Crypto.Noise.Hash.BLAKE2b +import Crypto.Noise.Hash.SHA256 +import Crypto.Noise.Hash.SHA512 +import Crypto.Noise.Types + +import Imports +import Instances() + +import HandshakeStates + +data HandshakeType c d h = + NoiseNN + | NoiseKN + | NoiseNK + | NoiseKK + | NoiseNE + | NoiseKE + | NoiseNX + | NoiseKX + | NoiseXN + | NoiseIN + | NoiseXK + | NoiseIK + | NoiseXE + | NoiseIE + | NoiseXX + | NoiseIX + | NoiseN + | NoiseK + | NoiseX + +is25519 :: KeyPair Curve25519 +is25519 = curveBytesToPair . bsToSB' $ "I\f\232\218A\210\230\147\FS\222\167\v}l\243!\168.\ESC\t\SYN\"\169\179A`\DC28\211\169tC" + +rs25519 :: KeyPair Curve25519 +rs25519 = curveBytesToPair . bsToSB' $ "\ETB\157\&7\DC2\252\NUL\148\172\148\133\218\207\&8\221y\144\209\168FX\224Ser_\178|\153.\FSg&" + +re25519 :: KeyPair Curve25519 +re25519 = curveBytesToPair . bsToSB' $ "<\231\151\151\180\217\146\DLEI}\160N\163iKc\162\210Y\168R\213\206&gm\169r\SUB[\\'" + +sampleHSPT :: Plaintext +sampleHSPT = Plaintext . bsToSB' $ "cacophony" + +mkHandshakeProps :: forall c d h proxy. (Cipher c, Curve d, Hash h) + => HandshakeKeys d + -> proxy (c, h) + -> [TestTree] +mkHandshakeProps hks _ = + let nni, nnr, kni, knr, nki, nkr, kki, kkr, nei, ner, kei, ker, nxi, nxr, + kxi, kxr, xni, xnr, ini, inr, xki, xkr, iki, ikr, xei, xer, iei, ier, + xxi, xxr, ixi, ixr, ni, nr, ki, kr, xi, xr :: HandshakeState c d h + nni = noiseNNIHS hks + nnr = noiseNNRHS hks + kni = noiseKNIHS hks + knr = noiseKNRHS hks + nki = noiseNKIHS hks + nkr = noiseNKRHS hks + kki = noiseKKIHS hks + kkr = noiseKKRHS hks + nei = noiseNEIHS hks + ner = noiseNERHS hks + kei = noiseKEIHS hks + ker = noiseKERHS hks + nxi = noiseNXIHS hks + nxr = noiseNXRHS hks + kxi = noiseKXIHS hks + kxr = noiseKXRHS hks + xni = noiseXNIHS hks + xnr = noiseXNRHS hks + ini = noiseINIHS hks + inr = noiseINRHS hks + xki = noiseXKIHS hks + xkr = noiseXKRHS hks + iki = noiseIKIHS hks + ikr = noiseIKRHS hks + xei = noiseXEIHS hks + xer = noiseXERHS hks + iei = noiseIEIHS hks + ier = noiseIERHS hks + xxi = noiseXXIHS hks + xxr = noiseXXRHS hks + ixi = noiseIXIHS hks + ixr = noiseIXRHS hks + ni = noiseNIHS hks + nr = noiseNRHS hks + ki = noiseKIHS hks + kr = noiseKRHS hks + xi = noiseXIHS hks + xr = noiseXRHS hks in + + [ testProperty "Noise_NN" (property (twoMessage nni nnr)) + , testProperty "Noise_KN" (property (twoMessage kni knr)) + , testProperty "Noise_NK" (property (twoMessage nki nkr)) + , testProperty "Noise_KK" (property (twoMessage kki kkr)) + , testProperty "Noise_NE" (property (twoMessage nei ner)) + , testProperty "Noise_KE" (property (twoMessage kei ker)) + , testProperty "Noise_NX" (property (twoMessage nxi nxr)) + , testProperty "Noise_KX" (property (twoMessage kxi kxr)) + , testProperty "Noise_XN" (property (threeMessage xni xnr)) + , testProperty "Noise_IN" (property (twoMessage ini inr)) + , testProperty "Noise_XK" (property (threeMessage xki xkr)) + , testProperty "Noise_IK" (property (twoMessage iki ikr)) + , testProperty "Noise_XE" (property (threeMessage xei xer)) + , testProperty "Noise_IE" (property (twoMessage iei ier)) + , testProperty "Noise_XX" (property (threeMessage xxi xxr)) + , testProperty "Noise_IX" (property (twoMessage ixi ixr)) + , testProperty "Noise_N" (property (oneMessage ni nr )) + , testProperty "Noise_K" (property (oneMessage ki kr )) + , testProperty "Noise_X" (property (oneMessage xi xr )) + ] + +oneMessage :: (Cipher c, Curve d, Hash h) + => HandshakeState c d h + -> HandshakeState c d h + -> Plaintext + -> Property +oneMessage ihs rhs pt = ioProperty $ do + (aliceToBob1, csAlice1, _) <- writeMessageFinal ihs sampleHSPT + let (hsptFromBob1, csBob1, _) = readMessageFinal rhs aliceToBob1 + + return $ conjoin + [ (decrypt csBob1 . encrypt csAlice1) pt === pt + , (decrypt csAlice1 . encrypt csBob1) pt === pt + , hsptFromBob1 === sampleHSPT + ] + + where + encrypt cs p = fst $ encryptPayload p cs + decrypt cs ct = fst $ decryptPayload ct cs + +twoMessage :: (Cipher c, Curve d, Hash h) + => HandshakeState c d h + -> HandshakeState c d h + -> Plaintext + -> Property +twoMessage ihs rhs pt = ioProperty $ do + (aliceToBob1, ihs') <- writeMessage ihs sampleHSPT + let (hsptFromAlice1, rhs') = readMessage rhs aliceToBob1 + + (bobToAlice1, csBob1, csBob2) <- writeMessageFinal rhs' sampleHSPT + let (hsptFromBob1, csAlice1, csAlice2) = readMessageFinal ihs' bobToAlice1 + + return $ conjoin + [ (decrypt csBob1 . encrypt csAlice1) pt === pt + , (decrypt csBob2 . encrypt csAlice2) pt === pt + , (decrypt csAlice1 . encrypt csBob1) pt === pt + , (decrypt csAlice2 . encrypt csBob2) pt === pt + , hsptFromAlice1 === sampleHSPT + , hsptFromBob1 === sampleHSPT + ] + + where + encrypt cs p = fst $ encryptPayload p cs + decrypt cs ct = fst $ decryptPayload ct cs + +threeMessage :: (Cipher c, Curve d, Hash h) + => HandshakeState c d h + -> HandshakeState c d h + -> Plaintext + -> Property +threeMessage ihs rhs pt = + ioProperty $ do + (aliceToBob1, ihs') <- writeMessage ihs sampleHSPT + let (hsptFromAlice1, rhs') = readMessage rhs aliceToBob1 + + (bobToAlice1, rhs'') <- writeMessage rhs' sampleHSPT + let (hsptFromBob1, ihs'') = readMessage ihs' bobToAlice1 + + (aliceToBob2, csAlice1, csAlice2) <- writeMessageFinal ihs'' sampleHSPT + let (hsptFromBob2, csBob1, csBob2) = readMessageFinal rhs'' aliceToBob2 + + return $ conjoin + [ (decrypt csBob1 . encrypt csAlice1) pt === pt + , (decrypt csBob2 . encrypt csAlice2) pt === pt + , (decrypt csAlice1 . encrypt csBob1) pt === pt + , (decrypt csAlice2 . encrypt csBob2) pt === pt + , hsptFromAlice1 === sampleHSPT + , hsptFromBob1 === sampleHSPT + , hsptFromBob2 === sampleHSPT + ] + + where + encrypt cs p = fst $ encryptPayload p cs + decrypt cs ct = fst $ decryptPayload ct cs + +tests :: TestTree +tests = + let p = Just "cacophony" + hks = HandshakeKeys Nothing is25519 rs25519 re25519 + hks' = HandshakeKeys p is25519 rs25519 re25519 in + testGroup "Handshakes" + [ testGroup "Curve25519-ChaChaPoly1305-SHA256" + [ testGroup "without PSK" + (mkHandshakeProps hks (Proxy :: Proxy (ChaChaPoly1305, SHA256))) + , testGroup "with PSK" + (mkHandshakeProps hks' (Proxy :: Proxy (ChaChaPoly1305, SHA256))) + ] + , testGroup "Curve25519-ChaChaPoly1305-SHA512" + [ testGroup "without PSK" + (mkHandshakeProps hks (Proxy :: Proxy (ChaChaPoly1305, SHA512))) + , testGroup "with PSK" + (mkHandshakeProps hks' (Proxy :: Proxy (ChaChaPoly1305, SHA512))) + ] + , testGroup "Curve25519-ChaChaPoly1305-BLAKE2s" + [ testGroup "without PSK" + (mkHandshakeProps hks (Proxy :: Proxy (ChaChaPoly1305, BLAKE2s))) + , testGroup "with PSK" + (mkHandshakeProps hks' (Proxy :: Proxy (ChaChaPoly1305, BLAKE2s))) + ] + , testGroup "Curve25519-ChaChaPoly1305-BLAKE2b" + [ testGroup "without PSK" + (mkHandshakeProps hks (Proxy :: Proxy (ChaChaPoly1305, BLAKE2b))) + , testGroup "with PSK" + (mkHandshakeProps hks' (Proxy :: Proxy (ChaChaPoly1305, BLAKE2b))) + ] + , testGroup "Curve25519-AESGCM-SHA256" + [ testGroup "without PSK" + (mkHandshakeProps hks (Proxy :: Proxy (AESGCM, SHA256))) + , testGroup "with PSK" + (mkHandshakeProps hks' (Proxy :: Proxy (AESGCM, SHA256))) + ] + , testGroup "Curve25519-AESGCM-SHA512" + [ testGroup "without PSK" + (mkHandshakeProps hks (Proxy :: Proxy (AESGCM, SHA512))) + , testGroup "with PSK" + (mkHandshakeProps hks' (Proxy :: Proxy (AESGCM, SHA512))) + ] + , testGroup "Curve25519-AESGCM-BLAKE2s" + [ testGroup "without PSK" + (mkHandshakeProps hks (Proxy :: Proxy (AESGCM, BLAKE2s))) + , testGroup "with PSK" + (mkHandshakeProps hks' (Proxy :: Proxy (AESGCM, BLAKE2s))) + ] + , testGroup "Curve25519-AESGCM-BLAKE2b" + [ testGroup "without PSK" + (mkHandshakeProps hks (Proxy :: Proxy (AESGCM, BLAKE2b))) + , testGroup "with PSK" + (mkHandshakeProps hks' (Proxy :: Proxy (AESGCM, BLAKE2b))) + ] + ] diff --git a/tests/SymmetricState.hs b/tests/SymmetricState.hs --- a/tests/SymmetricState.hs +++ b/tests/SymmetricState.hs @@ -13,7 +13,7 @@ import Crypto.Noise.Types shs :: SymmetricState ChaChaPoly1305 SHA256 -shs = symmetricHandshake $ bsToSB' "handshake name" +shs = symmetricState $ bsToSB' "handshake name" roundTripProp :: Plaintext -> Property roundTripProp pt = (decrypt . encrypt) pt === pt diff --git a/tests/Tests.hs b/tests/Tests.hs deleted file mode 100644 --- a/tests/Tests.hs +++ /dev/null @@ -1,17 +0,0 @@ -module Main where - -import Imports - -import qualified CipherState -import qualified SymmetricState -import qualified Handshake - -tests :: TestTree -tests = testGroup "cacophony" - [ CipherState.tests - , SymmetricState.tests - , Handshake.tests - ] - -main :: IO () -main = defaultMain tests diff --git a/tests/properties.hs b/tests/properties.hs new file mode 100644 --- /dev/null +++ b/tests/properties.hs @@ -0,0 +1,17 @@ +module Main where + +import Imports + +import qualified CipherState +import qualified SymmetricState +import qualified Handshakes + +tests :: TestTree +tests = testGroup "cacophony" + [ CipherState.tests + , SymmetricState.tests + , Handshakes.tests + ] + +main :: IO () +main = defaultMain tests