cacophony 0.3.0 → 0.4.0

raw patch · 23 files changed

+1194/−452 lines, 23 filesdep +criteriondep +deepseqPVP ok

version bump matches the API change (PVP)

Dependencies added: criterion, deepseq

API changes (from Hackage documentation)

Files

• .travis.yml +4/−4
• benchmarks/bench.hs +187/−4
• cacophony.cabal +14/−6
• changelog.md +18/−0
• src/Crypto/Noise/Cipher/AESGCM.hs +109/−0
• src/Crypto/Noise/Curve/Curve25519.hs +5/−4
• src/Crypto/Noise/Handshake.hs +2/−2
• src/Crypto/Noise/HandshakePatterns.hs +49/−38
• src/Crypto/Noise/Hash/BLAKE2b.hs +64/−0
• src/Crypto/Noise/Hash/BLAKE2s.hs +64/−0
• src/Crypto/Noise/Hash/SHA256.hs +1/−1
• src/Crypto/Noise/Hash/SHA512.hs +58/−0
• src/Crypto/Noise/Internal/CipherState.hs +3/−1
• src/Crypto/Noise/Internal/HandshakeState.hs +96/−58
• src/Crypto/Noise/Internal/SymmetricState.hs +19/−9
• src/Crypto/Noise/MessagePatterns.hs +14/−22
• src/Crypto/Noise/Types.hs +16/−0
• tests/Handshake.hs +0/−157
• tests/HandshakeStates.hs +200/−128
• tests/Handshakes.hs +253/−0
• tests/SymmetricState.hs +1/−1
• tests/Tests.hs +0/−17
• tests/properties.hs +17/−0

@@ -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")

@@ -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)))+    ]+  ]

@@ -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

@@ -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)

@@ -0,0 +1,109 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleInstances #-}+----------------------------------------------------------------+-- |+-- Module      : Crypto.Noise.Cipher.AESGCM+-- Maintainer  : John Galt <jgalt@centromere.net>+-- 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

@@ -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

@@ -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,

@@ -1,9 +1,20 @@+{-# LANGUAGE OverloadedStrings #-} ---------------------------------------------------------------- -- | -- Module      : Crypto.Noise.HandshakePatterns -- Maintainer  : John Galt <jgalt@centromere.net> -- 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]

@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies #-}+----------------------------------------------------------------+-- |+-- Module      : Crypto.Noise.Hash.BLAKE2b+-- Maintainer  : John Galt <jgalt@centromere.net>+-- 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

@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies #-}+----------------------------------------------------------------+-- |+-- Module      : Crypto.Noise.Hash.BLAKE2s+-- Maintainer  : John Galt <jgalt@centromere.net>+-- 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

@@ -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

@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleInstances #-}+----------------------------------------------------------------+-- |+-- Module      : Crypto.Noise.Hash.SHA512+-- Maintainer  : John Galt <jgalt@centromere.net>+-- 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

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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-  ]

@@ -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

@@ -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)))+    ]+  ]

@@ -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

@@ -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

@@ -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