diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,84 @@ +# This file has been generated -- see https://github.com/hvr/multi-ghc-travis +language: c +sudo: false + +cache: + directories: + - $HOME/.cabsnap + - $HOME/.cabal/packages + +before_cache: + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log + - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar + +matrix: + include: + - env: CABALVER=1.22 GHCVER=7.10.1 + compiler: ": #GHC 7.10.1" + addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} + - env: CABALVER=1.22 GHCVER=7.10.2 + compiler: ": #GHC 7.10.2" + addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} + - env: CABALVER=1.22 GHCVER=head + compiler: ": #GHC head" + addons: {apt: {packages: [cabal-install-1.22,ghc-head,alex-3.1.4,happy-1.19.5], sources: [hvr-ghc]}} + + allow_failures: + - env: CABALVER=1.22 GHCVER=head + +before_install: + - unset CC + - export HAPPYVER=1.19.5 + - export ALEXVER=3.1.4 + - export PATH=~/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/happy/$HAPPYVER/bin:/opt/alex/$ALEXVER/bin:$PATH + +install: + - cabal --version + - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" + - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; + then + zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > + $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; + 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 + - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt + + # check whether current requested install-plan matches cached package-db snapshot + - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt; + then + echo "cabal build-cache HIT"; + rm -rfv .ghc; + cp -a $HOME/.cabsnap/ghc $HOME/.ghc; + cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; + else + 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; + if [ "$GHCVER" = "7.10.1" ]; then cabal install Cabal-1.22.4.0; fi; + fi + + # snapshot package-db on cache miss + - if [ ! -d $HOME/.cabsnap ]; + then + echo "snapshotting package-db to build-cache"; + mkdir $HOME/.cabsnap; + cp -a $HOME/.ghc $HOME/.cabsnap/ghc; + cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; + fi + + - cabal install + +script: + - cabal configure --enable-tests -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 + + # Check that the resulting source distribution can be built & installed. + # 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 --force-reinstalls "$SRC_TGZ") diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +This is free and unencumbered software released into the public domain. + +Anyone is free to copy, modify, publish, use, compile, sell, or +distribute this software, either in source code form or as a compiled +binary, for any purpose, commercial or non-commercial, and by any +means. + +In jurisdictions that recognize copyright laws, the author or authors +of this software dedicate any and all copyright interest in the +software to the public domain. We make this dedication for the benefit +of the public at large and to the detriment of our heirs and +successors. We intend this dedication to be an overt act of +relinquishment in perpetuity of all present and future rights to this +software under copyright law. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR +OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. + +For more information, please refer to diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +# cacophony + +[![Build Status](https://travis-ci.org/centromere/cacophony.svg?branch=master)](https://travis-ci.org/centromere/cacophony) +[![Haskell](http://b.repl.ca/v1/language-haskell-blue.png)](http://www.haskell.org) + +This library implements the [Noise](https://github.com/trevp/noise/blob/master/noise.md) protocol. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/benchmarks/bench.hs b/benchmarks/bench.hs new file mode 100644 --- /dev/null +++ b/benchmarks/bench.hs @@ -0,0 +1,6 @@ +module Main + ( main + ) where + +main :: IO () +main = return () diff --git a/cacophony.cabal b/cacophony.cabal new file mode 100644 --- /dev/null +++ b/cacophony.cabal @@ -0,0 +1,134 @@ +name: cacophony +version: 0.1.0.0 +synopsis: A library implementing the Noise protocol. +license: PublicDomain +license-file: LICENSE +author: John Galt +maintainer: centromere@users.noreply.github.com +homepage: https://github.com/centromere/cacophony/wiki +bug-reports: https://github.com/centromere/cacophony/issues +category: Cryptography +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC == 7.10.1, GHC == 7.10.2 + +extra-source-files: + .travis.yml + README.md + LICENSE + +source-repository head + type: git + location: https://github.com/centromere/cacophony.git + +-------------------------------------------------------------------------------- +-- FLAGS + +flag hlint + +flag doctest + +flag llvm + default: False + manual: True + +-------------------------------------------------------------------------------- +-- LIBRARY + +library + build-depends: + base >=4.8 && <4.9, + bytestring, + cryptonite, + lens, + memory, + mtl + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: + Crypto.Noise.Cipher + Crypto.Noise.Cipher.ChaChaPoly1305 + Crypto.Noise.Curve + Crypto.Noise.Curve.Curve25519 + Crypto.Noise.Descriptors + Crypto.Noise.Handshake + Crypto.Noise.Hash + Crypto.Noise.Hash.SHA256 + Crypto.Noise.Internal.CipherState + Crypto.Noise.Internal.SymmetricHandshakeState + Crypto.Noise.Internal.HandshakeState + Crypto.Noise.Types + ghc-options: -rtsopts -with-rtsopts=-N -Wall -fwarn-tabs + + if flag(llvm) + ghc-options: -fllvm + +-------------------------------------------------------------------------------- +-- TESTS + +test-suite test-cacophony + type: exitcode-stdio-1.0 + main-is: Tests.hs + ghc-options: -Wall -fwarn-tabs + hs-source-dirs: tests + default-language: Haskell2010 + + build-depends: + base >= 4.8 && < 4.9, + bytestring, + cacophony, + memory, + mtl, + QuickCheck, + tasty, + tasty-quickcheck + + other-modules: + CipherState, + Handshake, + Imports, + Instances, + SymmetricHandshakeState + +test-suite hlint + type: exitcode-stdio-1.0 + main-is: hlint.hs + ghc-options: -Wall -fwarn-tabs + hs-source-dirs: tests + default-language: Haskell2010 + + if !flag(hlint) + buildable: False + else + build-depends: + base >= 4.8 && < 4.9, + hlint + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: doctests.hs + ghc-options: -threaded -Wall -fwarn-tabs + hs-source-dirs: tests + default-language: Haskell2010 + + if !flag(doctest) + buildable: False + else + build-depends: + base, + filepath, + directory, + doctest + +-------------------------------------------------------------------------------- +-- BENCHMARKS + +benchmark bench + type: exitcode-stdio-1.0 + main-is: bench.hs + ghc-options: -Wall -fwarn-tabs + hs-source-dirs: benchmarks + default-language: Haskell2010 + + build-depends: + base >= 4.8 && < 4.9 diff --git a/src/Crypto/Noise/Cipher.hs b/src/Crypto/Noise/Cipher.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Noise/Cipher.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE TypeFamilies #-} +---------------------------------------------------------------- +-- | +-- Module : Crypto.Noise.Cipher +-- Maintainer : John Galt +-- Stability : experimental +-- Portability : POSIX + +module Crypto.Noise.Cipher + ( -- * Classes + Cipher(..), + -- * Types + Plaintext(..), + AssocData(..) + ) where + +import Crypto.Noise.Types + +-- | Typeclass for ciphers. +class Cipher c where + -- | Represents encrypted data containing an authentication tag. + data Ciphertext c :: * + + -- | Represents a symmetric key. + data SymmetricKey c :: * + + -- | Represents a nonce. + data Nonce c :: * + + -- | Returns the name of the cipher. This is used when generating + -- the handshake name. + cipherName :: proxy c -> ScrubbedBytes + + -- | Encrypts data. + cipherEncrypt :: SymmetricKey c + -> Nonce c + -> AssocData + -> Plaintext + -> Ciphertext c + + -- | Decrypts data. Will fail catastrophically if the authentication + -- tag is invalid. + cipherDecrypt :: SymmetricKey c + -> Nonce c + -> AssocData + -> Ciphertext c + -> Maybe Plaintext + + -- | Returns a Nonce set to zero. + cipherZeroNonce :: Nonce c + + -- | Increments a nonce. + cipherIncNonce :: Nonce c -> Nonce c + + -- | Imports a symmetric key. If the input is greater than 32 bytes, it + -- is truncated. + cipherBytesToSym :: ScrubbedBytes -> SymmetricKey c + + -- | Exports a Ciphertext. The authentication tag follows the + -- actual ciphertext. + cipherTextToBytes :: Ciphertext c -> ScrubbedBytes + + -- | Imports a Ciphertext. + cipherBytesToText :: ScrubbedBytes -> Ciphertext c + +-- | Represents plaintext which can be encrypted. +newtype Plaintext = Plaintext ScrubbedBytes + +-- | Represents the associated data for AEAD. +newtype AssocData = AssocData ScrubbedBytes diff --git a/src/Crypto/Noise/Cipher/ChaChaPoly1305.hs b/src/Crypto/Noise/Cipher/ChaChaPoly1305.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Noise/Cipher/ChaChaPoly1305.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleInstances #-} +---------------------------------------------------------------- +-- | +-- Module : Crypto.Noise.Cipher.ChaChaPoly1305 +-- Maintainer : John Galt +-- Stability : experimental +-- Portability : POSIX + +module Crypto.Noise.Cipher.ChaChaPoly1305 + ( -- * Types + ChaChaPoly1305 + ) where + +import Crypto.Error (throwCryptoError) +import qualified Crypto.Cipher.ChaChaPoly1305 as CCP +import qualified Crypto.MAC.Poly1305 as P +import qualified Data.ByteArray as B (take, drop, length) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS (replicate) + +import Crypto.Noise.Cipher +import Crypto.Noise.Types + +-- | Represents the ChaCha cipher with Poly1305 for AEAD. +data ChaChaPoly1305 + +instance Cipher ChaChaPoly1305 where + newtype Ciphertext ChaChaPoly1305 = CTCCP1305 (ScrubbedBytes, P.Auth) + newtype SymmetricKey ChaChaPoly1305 = SKCCP1305 ScrubbedBytes + newtype Nonce ChaChaPoly1305 = NCCP1305 CCP.Nonce + + cipherName _ = convert ("ChaChaPoly" :: ByteString) + cipherEncrypt = encrypt + cipherDecrypt = decrypt + cipherZeroNonce = zeroNonce + cipherIncNonce = incNonce + cipherBytesToSym = bytesToSym + cipherTextToBytes = ctToBytes + cipherBytesToText = bytesToCt + +encrypt :: SymmetricKey ChaChaPoly1305 -> Nonce ChaChaPoly1305 -> AssocData -> Plaintext -> Ciphertext ChaChaPoly1305 +encrypt (SKCCP1305 k) (NCCP1305 n) (AssocData ad) (Plaintext plaintext) = + CTCCP1305 (out, P.Auth (convert authTag)) + where + initState = throwCryptoError $ CCP.initialize k n + afterAAD = CCP.finalizeAAD (CCP.appendAAD ad initState) + (out, afterEnc) = CCP.encrypt plaintext afterAAD + authTag = CCP.finalize afterEnc + +decrypt :: SymmetricKey ChaChaPoly1305 -> Nonce ChaChaPoly1305 -> AssocData -> Ciphertext ChaChaPoly1305 -> Maybe Plaintext +decrypt (SKCCP1305 k) (NCCP1305 n) (AssocData ad) (CTCCP1305 (ct, auth)) = + if auth == calcAuthTag then + return $ Plaintext out + else + Nothing + where + initState = throwCryptoError $ CCP.initialize k n + afterAAD = CCP.finalizeAAD (CCP.appendAAD ad initState) + (out, afterDec) = CCP.decrypt ct afterAAD + calcAuthTag = CCP.finalize afterDec + +zeroNonce :: Nonce ChaChaPoly1305 +zeroNonce = NCCP1305 . throwCryptoError $ CCP.nonce8 constant iv + where + constant = BS.replicate 4 0 + iv = BS.replicate 8 0 + +incNonce :: Nonce ChaChaPoly1305 -> Nonce ChaChaPoly1305 +incNonce (NCCP1305 n) = NCCP1305 $ CCP.incrementNonce n + +bytesToSym :: ScrubbedBytes -> SymmetricKey ChaChaPoly1305 +bytesToSym = SKCCP1305 . B.take 32 + +ctToBytes :: Ciphertext ChaChaPoly1305 -> ScrubbedBytes +ctToBytes (CTCCP1305 (ct, a)) = ct `append` convert a + +bytesToCt :: ScrubbedBytes -> Ciphertext ChaChaPoly1305 +bytesToCt bytes = + CTCCP1305 (B.take (B.length bytes - 16) bytes + , P.Auth . convert $ B.drop (B.length bytes - 16) bytes + ) diff --git a/src/Crypto/Noise/Curve.hs b/src/Crypto/Noise/Curve.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Noise/Curve.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE TypeFamilies #-} +---------------------------------------------------------------- +-- | +-- Module : Crypto.Noise.Curve +-- Maintainer : John Galt +-- Stability : experimental +-- Portability : POSIX + +module Crypto.Noise.Curve + ( -- * Classes + Curve(..), + -- * Types + KeyPair + ) where + +import Data.ByteArray (ScrubbedBytes) + +-- | Typeclass for EC curves. +class Curve c where + -- | Represents a public key. + data PublicKey c :: * + + -- | Represents a secret key. + data SecretKey c :: * + + -- | Returns the name of the curve. This is used when generating + -- the handshake name. + curveName :: proxy c -> ScrubbedBytes + + -- | Returns the length of public keys for this Curve in bytes. + curveLength :: proxy c -> Int + + -- | Generates a KeyPair. + curveGenKey :: IO (KeyPair c) + + -- | Performs ECDH. + curveDH :: SecretKey c -> PublicKey c -> ScrubbedBytes + + -- | Exports a PublicKey. + curvePubToBytes :: PublicKey c -> ScrubbedBytes + + -- | Imports a PublicKey. + curveBytesToPub :: ScrubbedBytes -> PublicKey c + + -- | Exports a SecretKey. + curveSecToBytes :: SecretKey c -> ScrubbedBytes + + -- | Imports a SecretKey. + curveBytesToPair :: ScrubbedBytes -> KeyPair c + +-- | Represents a private/public EC keypair for a given Curve. +type KeyPair c = (SecretKey c, PublicKey c) diff --git a/src/Crypto/Noise/Curve/Curve25519.hs b/src/Crypto/Noise/Curve/Curve25519.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Noise/Curve/Curve25519.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleInstances #-} +---------------------------------------------------------------- +-- | +-- Module : Crypto.Noise.Curve.Curve25519 +-- Maintainer : John Galt +-- Stability : experimental +-- Portability : POSIX + +module Crypto.Noise.Curve.Curve25519 + ( -- * Types + Curve25519 + ) where + +import Crypto.Random.Entropy +import qualified Crypto.PubKey.Curve25519 as C +import Data.ByteString (ByteString) + +import Crypto.Noise.Curve +import Crypto.Noise.Types + +-- | Represents curve25519 curve. +data Curve25519 + +instance Curve Curve25519 where + newtype PublicKey Curve25519 = PK25519 C.PublicKey + newtype SecretKey Curve25519 = SK25519 C.SecretKey + + curveName _ = convert ("25519" :: ByteString) + curveLength _ = 32 + curveGenKey = genKey + curveDH = dh + curvePubToBytes = pubToBytes + curveBytesToPub = bytesToPub + curveSecToBytes = secToBytes + curveBytesToPair = bytesToPair + +genKey :: IO (KeyPair Curve25519) +genKey = do + r <- getEntropy 32 :: IO ScrubbedBytes + let sk = either error id $ C.secretKey r + pk = C.toPublic sk + return (SK25519 sk, PK25519 pk) + +dh :: SecretKey Curve25519 -> PublicKey Curve25519 -> ScrubbedBytes +dh (SK25519 sk) (PK25519 pk) = convert $ C.dh pk sk + +pubToBytes :: PublicKey Curve25519 -> ScrubbedBytes +pubToBytes (PK25519 pk) = convert pk + +bytesToPub :: ScrubbedBytes -> PublicKey Curve25519 +bytesToPub b = PK25519 . either error id $ C.publicKey b + +secToBytes :: SecretKey Curve25519 -> ScrubbedBytes +secToBytes (SK25519 sk) = convert sk + +bytesToPair :: ScrubbedBytes -> KeyPair Curve25519 +bytesToPair bs = (SK25519 sk, PK25519 pk) + where + sk = either error id $ C.secretKey bs + pk = C.toPublic sk diff --git a/src/Crypto/Noise/Descriptors.hs b/src/Crypto/Noise/Descriptors.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Noise/Descriptors.hs @@ -0,0 +1,848 @@ +---------------------------------------------------------------- +-- | +-- Module : Crypto.Noise.Descriptors +-- Maintainer : John Galt +-- Stability : experimental +-- Portability : POSIX +-- +-- This module contains all of the descriptors for all the handshakes +-- specified in the protocol. The first two characters of the name +-- represent the handshake the descriptor belongs to (NN, KN, NK, etc). The +-- next character represents whether the descriptor 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 descriptor is intended to be used. +-- Regular handshake steps begin at 1, but descriptors for pre-messages are +-- numbered 0. The descriptors 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. +-- +-- For example, in Noise_NN, Alice passes noiseNNI1 to 'writeHandshakeMsg'. +-- The resulting ByteString is transmitted to Bob, where he passes the +-- noiseNNR1 descriptor to 'readHandshakeMsg'. This covers the __@-> e@__ +-- step of the handshake. Next, Bob passes noiseNNR2 to +-- 'writeHandshakeMsgFinal' and transmits the resulting ByteString to Alice. +-- Finally, Alice passes noiseNNI2 to 'readHandshakeMsgFinal'. This covers +-- the __@<- e, dhee@__ step of the handshake. +module Crypto.Noise.Descriptors + ( -- * Functions + -- ** Noise_NN + noiseNNI1, + noiseNNR1, + noiseNNR2, + noiseNNI2, + -- ** Noise_KN + noiseKNI0, + noiseKNR0, + noiseKNI1, + noiseKNR1, + noiseKNR2, + noiseKNI2, + -- * Noise_NK + noiseNKI0, + noiseNKR0, + noiseNKI1, + noiseNKR1, + noiseNKR2, + noiseNKI2, + -- * Noise_KK + noiseKKI0, + noiseKKR0, + noiseKKI1, + noiseKKR1, + noiseKKR2, + noiseKKI2, + -- * Noise_NE + noiseNEI0, + noiseNER0, + noiseNEI1, + noiseNER1, + noiseNER2, + noiseNEI2, + -- * Noise_KE + noiseKEI0, + noiseKER0, + noiseKEI1, + noiseKER1, + noiseKER2, + noiseKEI2, + -- * Noise_NX + noiseNXI1, + noiseNXR1, + noiseNXR2, + noiseNXI2, + -- * Noise_KX + noiseKXI0, + noiseKXR0, + noiseKXI1, + noiseKXR1, + noiseKXR2, + noiseKXI2, + -- ** Noise_XN + noiseXNI1, + noiseXNR1, + noiseXNR2, + noiseXNI2, + noiseXNI3, + noiseXNR3, + -- * Noise_IN + noiseINI1, + noiseINR1, + noiseINR2, + noiseINI2, + -- ** Noise_XK + noiseXKI0, + noiseXKR0, + noiseXKI1, + noiseXKR1, + noiseXKR2, + noiseXKI2, + noiseXKI3, + noiseXKR3, + -- * Noise_IK + noiseIKI0, + noiseIKR0, + noiseIKI1, + noiseIKR1, + noiseIKR2, + noiseIKI2, + -- ** Noise_XE + noiseXEI0, + noiseXER0, + noiseXEI1, + noiseXER1, + noiseXER2, + noiseXEI2, + noiseXEI3, + noiseXER3, + -- * Noise_IE + noiseIEI0, + noiseIER0, + noiseIEI1, + noiseIER1, + noiseIER2, + noiseIEI2, + -- ** Noise_XX + noiseXXI1, + noiseXXR1, + noiseXXR2, + noiseXXI2, + noiseXXI3, + noiseXXR3, + -- * Noise_IX + noiseIXI1, + noiseIXR1, + noiseIXR2, + noiseIXI2 + ) where + +import Control.Monad ((>=>)) +import Data.ByteString (ByteString, append) + +import Crypto.Noise.Cipher +import Crypto.Noise.Curve +import Crypto.Noise.Hash +import Crypto.Noise.Internal.HandshakeState + +-------------------------------------------------------------------------------- +-- Noise_NN + +noiseNNI1 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseNNI1 = tokenWE + +noiseNNR1 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseNNR1 = tokenRE + +noiseNNR2 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseNNR2 = do + e <- tokenWE + tokenDHEE + return e + +noiseNNI2 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseNNI2 buf = do + rest <- tokenRE buf + tokenDHEE + return rest + +-------------------------------------------------------------------------------- +-- Noise_KN + +noiseKNI0 :: (Cipher c, Curve d, Hash h) + => Descriptor c d h () +noiseKNI0 = tokenPreLS + +noiseKNR0 :: (Cipher c, Curve d, Hash h) + => Descriptor c d h () +noiseKNR0 = tokenPreRS + +noiseKNI1 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseKNI1 = tokenWE + +noiseKNR1 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseKNR1 = tokenRE + +noiseKNR2 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseKNR2 = do + e <- tokenWE + tokenDHEE + tokenDHES + return e + +noiseKNI2 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseKNI2 buf = do + rest <- tokenRE buf + tokenDHEE + tokenDHSE + return rest + +-------------------------------------------------------------------------------- +-- Noise_NK + +noiseNKI0 :: (Cipher c, Curve d, Hash h) + => Descriptor c d h () +noiseNKI0 = tokenPreRS + +noiseNKR0 :: (Cipher c, Curve d, Hash h) + => Descriptor c d h () +noiseNKR0 = tokenPreLS + +noiseNKI1 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseNKI1 = do + e <- tokenWE + tokenDHES + return e + +noiseNKR1 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseNKR1 buf = do + rest <- tokenRE buf + tokenDHSE + return rest + +noiseNKR2 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseNKR2 = do + e <- tokenWE + tokenDHEE + return e + +noiseNKI2 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseNKI2 buf = do + rest <- tokenRE buf + tokenDHEE + return rest + +-------------------------------------------------------------------------------- +-- Noise_KK + +noiseKKI0 :: (Cipher c, Curve d, Hash h) + => Descriptor c d h () +noiseKKI0 = do + tokenPreRS + tokenPreLS + +noiseKKR0 :: (Cipher c, Curve d, Hash h) + => Descriptor c d h () +noiseKKR0 = do + tokenPreLS + tokenPreRS + +noiseKKI1 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseKKI1 = do + e <- tokenWE + tokenDHES + tokenDHSS + return e + +noiseKKR1 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseKKR1 buf = do + rest <- tokenRE buf + tokenDHSE + tokenDHSS + return rest + +noiseKKR2 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseKKR2 = do + e <- tokenWE + tokenDHEE + tokenDHES + return e + +noiseKKI2 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseKKI2 buf = do + rest <- tokenRE buf + tokenDHEE + tokenDHSE + return rest + +-------------------------------------------------------------------------------- +-- Noise_NE + +noiseNEI0 :: (Cipher c, Curve d, Hash h) + => Descriptor c d h () +noiseNEI0 = do + tokenPreRS + tokenPreRE + +noiseNER0 :: (Cipher c, Curve d, Hash h) + => Descriptor c d h () +noiseNER0 = do + tokenPreLS + tokenPreLE + +noiseNEI1 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseNEI1 = do + e <- tokenWE + tokenDHEE + tokenDHES + return e + +noiseNER1 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseNER1 buf = do + rest <- tokenRE buf + tokenDHEE + tokenDHSE + return rest + +noiseNER2 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseNER2 = do + e <- tokenWE + tokenDHEE + return e + +noiseNEI2 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseNEI2 buf = do + rest <- tokenRE buf + tokenDHEE + return rest + +-------------------------------------------------------------------------------- +-- Noise_KE + +noiseKEI0 :: (Cipher c, Curve d, Hash h) + => Descriptor c d h () +noiseKEI0 = do + tokenPreRS + tokenPreRE + tokenPreLS + +noiseKER0 :: (Cipher c, Curve d, Hash h) + => Descriptor c d h () +noiseKER0 = do + tokenPreLS + tokenPreLE + tokenPreRS + +noiseKEI1 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseKEI1 = do + e <- tokenWE + tokenDHEE + tokenDHES + tokenDHSE + return e + +noiseKER1 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseKER1 buf = do + rest <- tokenRE buf + tokenDHEE + tokenDHSE + tokenDHES + return rest + +noiseKER2 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseKER2 = do + e <- tokenWE + tokenDHEE + tokenDHSE + return e + +noiseKEI2 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseKEI2 buf = do + rest <- tokenRE buf + tokenDHEE + tokenDHES + return rest + +-------------------------------------------------------------------------------- +-- Noise_NX + +noiseNXI1 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseNXI1 = tokenWE + +noiseNXR1 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseNXR1 = tokenRE + +noiseNXR2 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseNXR2 = do + e <- tokenWE + tokenDHEE + s <- tokenWS + tokenDHSE + return $ e `append` s + +noiseNXI2 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseNXI2 buf = do + rest <- tokenRE buf + tokenDHEE + rest' <- tokenRS rest + tokenDHES + return rest' + +-------------------------------------------------------------------------------- +-- Noise_KX + +noiseKXI0 :: (Cipher c, Curve d, Hash h) + => Descriptor c d h () +noiseKXI0 = tokenPreLS + +noiseKXR0 :: (Cipher c, Curve d, Hash h) + => Descriptor c d h () +noiseKXR0 = tokenPreRS + +noiseKXI1 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseKXI1 = tokenWE + +noiseKXR1 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseKXR1 = tokenRE + +noiseKXR2 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseKXR2 = do + e <- tokenWE + tokenDHEE + tokenDHES + s <- tokenWS + tokenDHSE + return $ e `append` s + +noiseKXI2 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseKXI2 buf = do + rest <- tokenRE buf + tokenDHEE + tokenDHSE + rest' <- tokenRS rest + tokenDHES + return rest' + +-------------------------------------------------------------------------------- +-- Noise_XN + +noiseXNI1 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseXNI1 = tokenWE + +noiseXNR1 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseXNR1 = tokenRE + +noiseXNR2 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseXNR2 = do + e <- tokenWE + tokenDHEE + return e + +noiseXNI2 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseXNI2 buf = do + rest <- tokenRE buf + tokenDHEE + return rest + +noiseXNI3 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseXNI3 = do + s <- tokenWS + tokenDHSE + return s + +noiseXNR3 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseXNR3 buf = do + rest <- tokenRS buf + tokenDHES + return rest + +-------------------------------------------------------------------------------- +-- Noise_IN + +noiseINI1 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseINI1 = do + s <- tokenWS + e <- tokenWE + return $ s `append` e + +noiseINR1 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseINR1 buf = do + rest <- tokenRS buf + tokenRE rest + +noiseINR2 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseINR2 = do + e <- tokenWE + tokenDHEE + tokenDHES + return e + +noiseINI2 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseINI2 buf = do + rest <- tokenRE buf + tokenDHEE + tokenDHSE + return rest + +-------------------------------------------------------------------------------- +-- Noise_XK + +noiseXKI0 :: (Cipher c, Curve d, Hash h) + => Descriptor c d h () +noiseXKI0 = tokenPreRS + +noiseXKR0 :: (Cipher c, Curve d, Hash h) + => Descriptor c d h () +noiseXKR0 = tokenPreLS + +noiseXKI1 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseXKI1 = do + e <- tokenWE + tokenDHES + return e + +noiseXKR1 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseXKR1 buf = do + rest <- tokenRE buf + tokenDHSE + return rest + +noiseXKR2 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseXKR2 = do + e <- tokenWE + tokenDHEE + return e + +noiseXKI2 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseXKI2 buf = do + rest <- tokenRE buf + tokenDHEE + return rest + +noiseXKI3 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseXKI3 = do + s <- tokenWS + tokenDHSE + return s + +noiseXKR3 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseXKR3 buf = do + rest <- tokenRS buf + tokenDHES + return rest + +-------------------------------------------------------------------------------- +-- Noise_IK + +noiseIKI0 :: (Cipher c, Curve d, Hash h) + => Descriptor c d h () +noiseIKI0 = tokenPreRS + +noiseIKR0 :: (Cipher c, Curve d, Hash h) + => Descriptor c d h () +noiseIKR0 = tokenPreLS + +noiseIKI1 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseIKI1 = do + e <- tokenWE + tokenDHES + s <- tokenWS + tokenDHSS + return $ e `append` s + +noiseIKR1 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseIKR1 buf = do + rest <- tokenRE buf + tokenDHSE + rest' <- tokenRS rest + tokenDHSS + return rest' + +noiseIKR2 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseIKR2 = do + e <- tokenWE + tokenDHEE + tokenDHES + return e + +noiseIKI2 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseIKI2 buf = do + rest <- tokenRE buf + tokenDHEE + tokenDHSE + return rest + +-------------------------------------------------------------------------------- +-- Noise_XE + +noiseXEI0 :: (Cipher c, Curve d, Hash h) + => Descriptor c d h () +noiseXEI0 = do + tokenPreRS + tokenPreRE + +noiseXER0 :: (Cipher c, Curve d, Hash h) + => Descriptor c d h () +noiseXER0 = do + tokenPreLS + tokenPreLE + +noiseXEI1 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseXEI1 = do + e <- tokenWE + tokenDHEE + tokenDHES + return e + +noiseXER1 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseXER1 buf = do + rest <- tokenRE buf + tokenDHEE + tokenDHSE + return rest + +noiseXER2 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseXER2 = do + e <- tokenWE + tokenDHEE + return e + +noiseXEI2 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseXEI2 buf = do + rest <- tokenRE buf + tokenDHEE + return rest + +noiseXEI3 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseXEI3 = do + s <- tokenWS + tokenDHSE + return s + +noiseXER3 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseXER3 buf = do + rest <- tokenRS buf + tokenDHES + return rest + +-------------------------------------------------------------------------------- +-- Noise_IE + +noiseIEI0 :: (Cipher c, Curve d, Hash h) + => Descriptor c d h () +noiseIEI0 = do + tokenPreRS + tokenPreRE + +noiseIER0 :: (Cipher c, Curve d, Hash h) + => Descriptor c d h () +noiseIER0 = do + tokenPreLS + tokenPreLE + +noiseIEI1 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseIEI1 = do + e <- tokenWE + tokenDHEE + tokenDHES + s <- tokenWS + tokenDHSE + return $ e `append` s + +noiseIER1 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseIER1 buf = do + rest <- tokenRE buf + tokenDHEE + tokenDHSE + rest' <- tokenRS rest + tokenDHES + return rest' + +noiseIER2 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseIER2 = do + e <- tokenWE + tokenDHEE + tokenDHES + return e + +noiseIEI2 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseIEI2 buf = do + rest <- tokenRE buf + tokenDHEE + tokenDHSE + return rest + +-------------------------------------------------------------------------------- +-- Noise_XX + +noiseXXI1 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseXXI1 = tokenWE + +noiseXXR1 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseXXR1 = tokenRE + +noiseXXR2 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseXXR2 = do + e <- tokenWE + tokenDHEE + s <- tokenWS + tokenDHSE + return $ e `append` s + +noiseXXI2 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseXXI2 buf = do + rest <- tokenRE buf + tokenDHEE + rest' <- tokenRS rest + tokenDHES + return rest' + +noiseXXI3 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseXXI3 = do + s <- tokenWS + tokenDHSE + return s + +noiseXXR3 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseXXR3 buf = do + rest <- tokenRS buf + tokenDHES + return rest + +-------------------------------------------------------------------------------- +-- Noise_IX + +noiseIXI1 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseIXI1 = do + s <- tokenWS + e <- tokenWE + return $ e `append` s + +noiseIXR1 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseIXR1 = tokenRS >=> tokenRE + +noiseIXR2 :: (Cipher c, Curve d, Hash h) + => DescriptorIO c d h ByteString +noiseIXR2 = do + e <- tokenWE + tokenDHEE + tokenDHES + s <- tokenWS + tokenDHSE + return $ e `append` s + +noiseIXI2 :: (Cipher c, Curve d, Hash h) + => ByteString + -> Descriptor c d h ByteString +noiseIXI2 buf = do + rest <- tokenRE buf + tokenDHEE + tokenDHSE + rest' <- tokenRS rest + tokenDHES + return rest' diff --git a/src/Crypto/Noise/Handshake.hs b/src/Crypto/Noise/Handshake.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Noise/Handshake.hs @@ -0,0 +1,26 @@ +---------------------------------------------------------------- +-- | +-- Module : Crypto.Noise.Handshake +-- Maintainer : John Galt +-- Stability : experimental +-- Portability : POSIX +-- +-- For more information regarding Descriptors, please see the +-- "Crypto.Noise.Descriptors" module. +module Crypto.Noise.Handshake + ( -- * Types + HandshakeState, + Descriptor, + DescriptorIO, + -- * Functions + getRemoteStaticKey, + handshakeState, + writeHandshakeMsg, + readHandshakeMsg, + writeHandshakeMsgFinal, + readHandshakeMsgFinal, + encryptPayload, + decryptPayload + ) where + +import Crypto.Noise.Internal.HandshakeState diff --git a/src/Crypto/Noise/Hash.hs b/src/Crypto/Noise/Hash.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Noise/Hash.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE TypeFamilies #-} +---------------------------------------------------------------- +-- | +-- Module : Crypto.Noise.Hash +-- Maintainer : John Galt +-- Stability : experimental +-- Portability : POSIX + +module Crypto.Noise.Hash + ( -- * Classes + Hash(..) + ) where + +import Crypto.Noise.Types + +-- | Typeclass for hashes. +class Hash h where + -- | Represents a chaining key used as part of HKDF. + data ChainingKey h :: * + + -- | Represents a hash digest. + data Digest h :: * + + -- | Returns the name of the hash. This is used when generating the + -- handshake name. + hashName :: proxy h -> ScrubbedBytes + + -- | Returns the length of the hash output in bytes. + hashLength :: proxy h -> Int + + -- | Hashes data. + hash :: ScrubbedBytes -> Digest h + + -- | Performs HKDF. + hashHKDF :: ChainingKey h -> ScrubbedBytes -> (ChainingKey h, ScrubbedBytes) + + -- | Converts a series of bytes to a chaining key. + hashBytesToCK :: ScrubbedBytes -> ChainingKey h + + -- | Converts a chaining key to a series of bytes. + hashCKToBytes :: ChainingKey h -> ScrubbedBytes + + -- | Converts a hash digest to a series of bytes. + hashToBytes :: Digest h -> ScrubbedBytes diff --git a/src/Crypto/Noise/Hash/SHA256.hs b/src/Crypto/Noise/Hash/SHA256.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Noise/Hash/SHA256.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings, TypeFamilies, FlexibleInstances #-} +---------------------------------------------------------------- +-- | +-- Module : Crypto.Noise.Hash.SHA256 +-- Maintainer : John Galt +-- Stability : experimental +-- Portability : POSIX + +module Crypto.Noise.Hash.SHA256 + ( -- * Types + SHA256 + ) where + +import qualified Crypto.Hash as H +import qualified Crypto.MAC.HMAC as M +import Data.ByteString (ByteString) + +import Crypto.Noise.Hash +import Crypto.Noise.Types + +-- | Represents the SHA256 hash. +data SHA256 + +instance Hash SHA256 where + newtype ChainingKey SHA256 = HCKSHA256 ScrubbedBytes + newtype Digest SHA256 = HDSHA256 (H.Digest H.SHA256) + + hashName _ = convert ("SHA256" :: ByteString) + hashLength _ = 32 + hash = hash' + hashHKDF = hkdf + hashBytesToCK = bytesToCK + hashCKToBytes = ckToBytes + hashToBytes = toBytes + +hash' :: ScrubbedBytes -> Digest SHA256 +hash' bs = HDSHA256 $ H.hash bs + +hkdf :: ChainingKey SHA256 -> ScrubbedBytes -> (ChainingKey SHA256, ScrubbedBytes) +hkdf (HCKSHA256 ck) d = (HCKSHA256 ck', sk) + where + x01 = convert ("\x01" :: ByteString) :: ScrubbedBytes + x02 = convert ("\x02" :: ByteString) :: ScrubbedBytes + + hmac1 = M.hmac ck d :: M.HMAC H.SHA256 + temp = convert . M.hmacGetDigest $ hmac1 :: ScrubbedBytes + hmac2 = M.hmac temp x01 :: M.HMAC H.SHA256 + hmac3 = M.hmac temp (convert hmac2 `append` x02) :: M.HMAC H.SHA256 + ck' = convert . M.hmacGetDigest $ hmac2 + sk = convert . M.hmacGetDigest $ hmac3 + +bytesToCK :: ScrubbedBytes -> ChainingKey SHA256 +bytesToCK = HCKSHA256 + +ckToBytes :: ChainingKey SHA256 -> ScrubbedBytes +ckToBytes (HCKSHA256 ck) = ck + +toBytes :: Digest SHA256 -> ScrubbedBytes +toBytes (HDSHA256 d) = convert d diff --git a/src/Crypto/Noise/Internal/CipherState.hs b/src/Crypto/Noise/Internal/CipherState.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Noise/Internal/CipherState.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE TemplateHaskell #-} +---------------------------------------------------------------- +-- | +-- Module : Crypto.Noise.Internal.CipherState +-- Maintainer : John Galt +-- Stability : experimental +-- Portability : POSIX + +module Crypto.Noise.Internal.CipherState + ( -- * Types + CipherState(CipherState), + -- * Lenses + csk, + csn, + -- * Functions + encryptAndIncrement, + decryptAndIncrement + ) where + +import Control.Lens +import Data.Maybe (fromMaybe) + +import Crypto.Noise.Cipher + +data CipherState c = + CipherState { _csk :: SymmetricKey c + , _csn :: Nonce c + } + +$(makeLenses ''CipherState) + +encryptAndIncrement :: Cipher c => AssocData -> Plaintext -> CipherState c -> (Ciphertext c, CipherState c) +encryptAndIncrement ad plaintext cs = (ct, newState) + where + ct = cipherEncrypt (cs ^. csk) (cs ^. csn) ad plaintext + newState = cs & csn %~ cipherIncNonce + +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") + (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 new file mode 100644 --- /dev/null +++ b/src/Crypto/Noise/Internal/HandshakeState.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE OverloadedStrings, FlexibleInstances, + GeneralizedNewtypeDeriving, TemplateHaskell, + RankNTypes, FlexibleContexts, ScopedTypeVariables #-} +---------------------------------------------------------------- +-- | +-- Module : Crypto.Noise.Internal.HandshakeState +-- Maintainer : John Galt +-- Stability : experimental +-- Portability : POSIX + +module Crypto.Noise.Internal.HandshakeState + ( -- * Classes + MonadHandshake(..), + -- * Types + HandshakeState, + Descriptor, + DescriptorIO, + -- * Functions + runDescriptorT, + getRemoteStaticKey, + handshakeState, + writeHandshakeMsg, + readHandshakeMsg, + writeHandshakeMsgFinal, + readHandshakeMsgFinal, + encryptPayload, + decryptPayload + ) where + +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.Proxy + +import Crypto.Noise.Cipher +import Crypto.Noise.Curve +import Crypto.Noise.Hash +import Crypto.Noise.Internal.CipherState +import Crypto.Noise.Internal.SymmetricHandshakeState +import Crypto.Noise.Types + +-- | Contains the state of a handshake. +data HandshakeState c d h = + HandshakeState { _hssSymmetricHandshake :: SymmetricHandshakeState c h + , _hssLocalStaticKey :: Maybe (KeyPair d) + , _hssLocalEphemeralKey :: Maybe (KeyPair d) + , _hssRemoteStaticKey :: Maybe (PublicKey d) + , _hssRemoteEphemeralKey :: Maybe (PublicKey d) + } + +$(makeLenses ''HandshakeState) + +newtype DescriptorT c d h m a = DescriptorT { unD :: StateT (HandshakeState c d h) m a } + deriving (Functor, Applicative, Monad, MonadIO, MonadState(HandshakeState c d h)) + +-- | Represents a series of operations that can be performed on a Noise +-- message. +type Descriptor c d h a = DescriptorT c d h Identity a + +-- | Represents a series of operations that will result in a Noise message. +-- This must be done in IO to facilitate the generation of ephemeral +-- keys. +type DescriptorIO c d h a = DescriptorT c d h IO a + +runDescriptorT :: Monad m => DescriptorT c d h m a -> HandshakeState c d h -> m (a, HandshakeState c d h) +runDescriptorT = runStateT . unD + +class Monad m => MonadHandshake m where + tokenPreLS :: m () + tokenPreRS :: m () + tokenPreLE :: m () + tokenPreRE :: m () + tokenRE :: ByteString -> m ByteString + tokenRS :: ByteString -> m ByteString + tokenWE :: MonadIO m => m ByteString + tokenWS :: m ByteString + tokenDHEE :: m () + tokenDHES :: m () + tokenDHSE :: m () + tokenDHSS :: m () + +instance (Monad m, Cipher c, Curve d, Hash h) => MonadHandshake (DescriptorT c d h m) where + tokenPreLS = tokenPreLX hssLocalStaticKey + + tokenPreRS = tokenPreRX hssRemoteStaticKey + + tokenPreLE = tokenPreLX hssLocalEphemeralKey + + tokenPreRE = tokenPreRX hssRemoteEphemeralKey + + tokenRE buf = tokenRX buf hssRemoteEphemeralKey + + tokenRS buf = tokenRX buf hssRemoteStaticKey + + tokenWE = do + ~kp@(_, pk) <- liftIO curveGenKey + hs <- get + let pk' = curvePubToBytes pk + shs = hs ^. hssSymmetricHandshake + (ct, shs') = encryptAndHash (Plaintext pk') shs + put $ hs & hssLocalEphemeralKey .~ Just kp & hssSymmetricHandshake .~ shs' + return . convert $ ct + + tokenWS = do + hs <- get + let pk = curvePubToBytes . snd . getLocalStaticKey $ hs + shs = hs ^. hssSymmetricHandshake + (ct, shs') = encryptAndHash ((Plaintext . convert) pk) shs + put $ hs & hssSymmetricHandshake .~ shs' + return . convert $ ct + + tokenDHEE = do + hs <- get + let shs = hs ^. hssSymmetricHandshake + ~(sk, _) = getLocalEphemeralKey hs + rpk = getRemoteEphemeralKey hs + dh = curveDH sk rpk + shs' = mixKey dh shs + put $ hs & hssSymmetricHandshake .~ shs' + + tokenDHES = do + hs <- get + let shs = hs ^. hssSymmetricHandshake + ~(sk, _) = getLocalEphemeralKey hs + rpk = getRemoteStaticKey hs + dh = curveDH sk rpk + shs' = mixKey dh shs + put $ hs & hssSymmetricHandshake .~ shs' + + tokenDHSE = do + hs <- get + let shs = hs ^. hssSymmetricHandshake + ~(sk, _) = getLocalStaticKey hs + rpk = getRemoteEphemeralKey hs + dh = curveDH sk rpk + shs' = mixKey dh shs + put $ hs & hssSymmetricHandshake .~ shs' + + tokenDHSS = do + hs <- get + let shs = hs ^. hssSymmetricHandshake + ~(sk, _) = getLocalStaticKey hs + rpk = getRemoteStaticKey hs + dh = curveDH sk rpk + shs' = mixKey dh shs + put $ hs & hssSymmetricHandshake .~ shs' + +getLocalStaticKey :: Curve d => HandshakeState c d h -> KeyPair d +getLocalStaticKey hs = fromMaybe (error "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") + (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") + (hs ^. hssRemoteStaticKey) + +getRemoteEphemeralKey :: Curve d => HandshakeState c d h -> PublicKey d +getRemoteEphemeralKey hs = fromMaybe (error "remote ephemeral key not set") + (hs ^. hssRemoteEphemeralKey) + +tokenPreLX :: (MonadState (HandshakeState c d h) m, Cipher c, Curve d, Hash h) + => Lens' (HandshakeState c d h) (Maybe (KeyPair d)) + -> m () +tokenPreLX keyToView = do + hs <- get + let shs = hs ^. hssSymmetricHandshake + (_, pk) = fromMaybe (error "tokenPreLX: local key not set") (hs ^. keyToView) + shs' = mixHash (curvePubToBytes pk) shs + put $ hs & hssSymmetricHandshake .~ shs' + +tokenPreRX :: (MonadState (HandshakeState c d h) m, Cipher c, Curve d, Hash h) + => Lens' (HandshakeState c d h) (Maybe (PublicKey d)) + -> m () +tokenPreRX keyToView = do + hs <- get + let shs = hs ^. hssSymmetricHandshake + pk = fromMaybe (error "tokenPreRX: remote key not set") (hs ^. keyToView) + shs' = mixHash (curvePubToBytes pk) shs + put $ hs & hssSymmetricHandshake .~ shs' + +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 ^. hssSymmetricHandshake . shsHasKey + (b, rest) = B.splitAt (d hasKey) buf + ct = cipherBytesToText . convert $ b + shs = hs ^. hssSymmetricHandshake + (Plaintext pt, shs') = decryptAndHash ct shs + + put $ hs & keyToUpdate .~ Just (curveBytesToPub pt) & hssSymmetricHandshake .~ shs' + + 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 +-- 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". +handshakeState :: (Cipher c, Curve d, Hash h) + => ScrubbedBytes + -- ^ Handshake name + -> Maybe (KeyPair d) + -- ^ Local static key + -> Maybe (KeyPair d) + -- ^ Local ephemeral key + -> Maybe (PublicKey d) + -- ^ Remote public static key + -> Maybe (PublicKey d) + -- ^ Remote public ephemeral key + -> Maybe (Descriptor c d h ()) + -- ^ Pre-message processing descriptor + -> HandshakeState c d h +handshakeState hn ls le rs re = maybe hs hs' + where + hs = HandshakeState (symmetricHandshake hn) ls le rs re + hs' desc = snd . runIdentity $ runDescriptorT desc hs + +-- | Creates a handshake message. The plaintext can be left empty if no +-- plaintext is to be transmitted. All subsequent handshake processing +-- must use the returned state. +writeHandshakeMsg :: (Cipher c, Curve d, Hash h) + => HandshakeState c d h + -- ^ The handshake state + -> DescriptorIO c d h ByteString + -- ^ A descriptor for this particular message + -> Plaintext + -- ^ Optional message to transmit + -> IO (ByteString, HandshakeState c d h) +writeHandshakeMsg hs desc payload = do + (d, hs') <- runDescriptorT desc hs + let (ep, shs') = encryptAndHash payload $ hs' ^. hssSymmetricHandshake + hs'' = hs' & hssSymmetricHandshake .~ shs' + return (d `B.append` convert ep, hs'') + +-- | Reads a handshake message. All subsequent handshake processing must +-- use the returned state. +readHandshakeMsg :: (Cipher c, Curve d, Hash h) + => HandshakeState c d h + -- ^ The handshake state + -> ByteString + -- ^ The handshake message received + -> (ByteString -> Descriptor c d h ByteString) + -- ^ A descriptor for this particular message + -> (Plaintext, HandshakeState c d h) +readHandshakeMsg hs buf desc = (dp, hs'') + where + (d, hs') = runIdentity $ runDescriptorT (desc buf) hs + (dp, shs') = decryptAndHash (cipherBytesToText (convert d)) + $ hs' ^. hssSymmetricHandshake + hs'' = hs' & hssSymmetricHandshake .~ shs' + +-- | The final call of a handshake negotiation. Used to generate a pair of +-- CipherStates, one for each transmission direction. +writeHandshakeMsgFinal :: (Cipher c, Curve d, Hash h) + => HandshakeState c d h + -- ^ The handshake state + -> DescriptorIO c d h ByteString + -- ^ A descriptor for this particular message + -> Plaintext + -- ^ Optional message to transmit + -> IO (ByteString, CipherState c, CipherState c) +writeHandshakeMsgFinal hs desc payload = do + (d, hs') <- writeHandshakeMsg hs desc payload + let (cs1, cs2) = split $ hs' ^. hssSymmetricHandshake + return (d, cs1, cs2) + +-- | The final call of a handshake negotiation. Used to generate a pair of +-- CipherStates, one for each transmission direction. +readHandshakeMsgFinal :: (Cipher c, Curve d, Hash h) + => HandshakeState c d h + -- ^ The handshake state + -> ByteString + -- ^ The handshake message received + -> (ByteString -> Descriptor c d h ByteString) + -- ^ A descriptor for this particular message + -> (Plaintext, CipherState c, CipherState c) +readHandshakeMsgFinal hs buf desc = (pt, cs1, cs2) + where + (pt, hs') = readHandshakeMsg hs buf desc + (cs1, cs2) = split $ hs' ^. hssSymmetricHandshake + +-- | Encrypts a payload. The returned 'CipherState' must be used for all +-- subsequent calls. +encryptPayload :: Cipher c + => Plaintext + -- ^ The data to encrypt + -> CipherState c + -- ^ The CipherState to use for encryption + -> (ByteString, CipherState c) +encryptPayload pt cs = ((convert . cipherTextToBytes) ct, cs') + where + (ct, cs') = encryptAndIncrement ad pt cs + ad = AssocData $ convert ("" :: ByteString) + +-- | Decrypts a payload. The returned 'CipherState' must be used for all +-- subsequent calls. +decryptPayload :: Cipher c + => ByteString + -- ^ The data to decrypt + -> CipherState c + -- ^ The CipherState to use for decryption + -> (Plaintext, CipherState c) +decryptPayload ct cs = (pt, cs') + where + (pt, cs') = decryptAndIncrement ad ((cipherBytesToText . convert) ct) cs + ad = AssocData $ convert ("" :: ByteString) diff --git a/src/Crypto/Noise/Internal/SymmetricHandshakeState.hs b/src/Crypto/Noise/Internal/SymmetricHandshakeState.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Noise/Internal/SymmetricHandshakeState.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE TemplateHaskell, FlexibleContexts, ScopedTypeVariables #-} +---------------------------------------------------------------- +-- | +-- Module : Crypto.Noise.Internal.SymmetricHandshakeState +-- Maintainer : John Galt +-- Stability : experimental +-- Portability : POSIX + +module Crypto.Noise.Internal.SymmetricHandshakeState + ( -- * Types + SymmetricHandshakeState(SymmetricHandshakeState), + -- * Lenses + shsCipher, + shsHasKey, + shsh, + -- * Functions + symmetricHandshake, + mixKey, + mixHash, + encryptAndHash, + decryptAndHash, + split + ) where + +import Control.Lens +import Data.ByteArray as BA (length, replicate) +import Data.ByteString (empty) +import Data.Proxy + +import Crypto.Noise.Cipher +import Crypto.Noise.Hash +import Crypto.Noise.Internal.CipherState +import Crypto.Noise.Types + +data SymmetricHandshakeState c h = + SymmetricHandshakeState { _shsCipher :: CipherState c + , _shsHasKey :: Bool + , _shsck :: ChainingKey h + , _shsh :: Either ScrubbedBytes (Digest h) + } + +$(makeLenses ''SymmetricHandshakeState) + +symmetricHandshake :: forall c h. (Cipher c, Hash h) => ScrubbedBytes -> SymmetricHandshakeState c h +symmetricHandshake hsn = SymmetricHandshakeState cs 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 + ck = hashBytesToCK . shshBytes $ hsn' + cs = CipherState undefined undefined + +mixKey :: (Cipher c, Hash h) => ScrubbedBytes -> SymmetricHandshakeState c h -> SymmetricHandshakeState c h +mixKey d shs = shs & shsCipher .~ cs + & shsHasKey .~ True + & shsck .~ ck + where + (ck, k) = hashHKDF (shs ^. shsck) d + cs = CipherState (cipherBytesToSym k) cipherZeroNonce + +mixHash :: (Cipher c, Hash h) => ScrubbedBytes -> SymmetricHandshakeState c h -> SymmetricHandshakeState c h +mixHash d shs = shs & shsh %~ Right . hash . (`append` d) . shshBytes + +encryptAndHash :: (Cipher c, Hash h) => Plaintext -> SymmetricHandshakeState c h -> (ScrubbedBytes, SymmetricHandshakeState c h) +encryptAndHash (Plaintext pt) shs + | shs ^. shsHasKey = (cipherTextToBytes ct, kshs) + | otherwise = (pt, nkshs) + where + (ct, cs) = encryptAndIncrement (AssocData (shshBytes (shs ^. shsh))) (Plaintext pt) (shs ^. shsCipher) + kshs = mixHash (cipherTextToBytes ct) shs & shsCipher .~ cs + nkshs = mixHash pt shs + +decryptAndHash :: (Cipher c, Hash h) => Ciphertext c -> SymmetricHandshakeState c h -> (Plaintext, SymmetricHandshakeState c h) +decryptAndHash ct shs + | shs ^. shsHasKey = (pt, kshs') + | otherwise = (Plaintext (cipherTextToBytes ct), nkshs') + where + (pt, cs) = decryptAndIncrement (AssocData (shshBytes (shs ^. shsh))) ct (shs ^. shsCipher) + kshs' = mixHash (cipherTextToBytes ct) (shs & shsCipher .~ cs) + nkshs' = mixHash (cipherTextToBytes ct) shs + +split :: (Cipher c, Hash h) => SymmetricHandshakeState c h -> (CipherState c, CipherState c) +split shs = (cs1, cs2) + where + (cs1k, cs2k) = hashHKDF (shs ^. shsck) (convert empty) + cs1k' = cipherBytesToSym . hashCKToBytes $ cs1k + cs2k' = cipherBytesToSym cs2k + cs1 = CipherState cs1k' cipherZeroNonce + cs2 = CipherState cs2k' cipherZeroNonce + +shshBytes :: Hash h => Either ScrubbedBytes (Digest h) -> ScrubbedBytes +shshBytes (Left h) = h +shshBytes (Right h) = hashToBytes h diff --git a/src/Crypto/Noise/Types.hs b/src/Crypto/Noise/Types.hs new file mode 100644 --- /dev/null +++ b/src/Crypto/Noise/Types.hs @@ -0,0 +1,16 @@ +---------------------------------------------------------------- +-- | +-- Module : Crypto.Noise.Types +-- Maintainer : John Galt +-- Stability : experimental +-- Portability : POSIX + +module Crypto.Noise.Types + ( -- * Types + ScrubbedBytes, + -- * Functions + convert, + append + ) where + +import Data.ByteArray (ScrubbedBytes, convert, append) diff --git a/tests/CipherState.hs b/tests/CipherState.hs new file mode 100644 --- /dev/null +++ b/tests/CipherState.hs @@ -0,0 +1,31 @@ +module CipherState where + +import Imports +import Instances() + +import Control.Monad.State (runState, state) + +import Crypto.Noise.Cipher +import Crypto.Noise.Cipher.ChaChaPoly1305 +import Crypto.Noise.Internal.CipherState + +roundTripProp :: AssocData -> Plaintext -> CipherState ChaChaPoly1305 -> Property +roundTripProp ad pt cs = (decrypt . encrypt) pt === pt + where + encrypt p = encryptAndIncrement ad p cs + decrypt (ct, _) = fst $ decryptAndIncrement ad ct cs + +manyRoundTripsProp :: AssocData -> [Plaintext] -> CipherState ChaChaPoly1305 -> Property +manyRoundTripsProp ad pts cs = (fst . manyDecrypts . manyEncrypts) pts === pts + where + encrypt = encryptAndIncrement ad + decrypt = decryptAndIncrement ad + doMany f xs = runState . mapM (state . f) $ xs + manyEncrypts xs = doMany encrypt xs cs + manyDecrypts (cts, _) = doMany decrypt cts cs + +tests :: TestTree +tests = testGroup "CipherState" + [ testProperty "ChaChaPoly1305 one roundtrip" $ property roundTripProp + , testProperty "ChaChaPoly1305 many roundtrips" $ property manyRoundTripsProp + ] diff --git a/tests/Handshake.hs b/tests/Handshake.hs new file mode 100644 --- /dev/null +++ b/tests/Handshake.hs @@ -0,0 +1,785 @@ +{-# LANGUAGE OverloadedStrings #-} +module Handshake where + +import Imports +import Instances() + +import Data.Proxy + +import Crypto.Noise.Descriptors +import Crypto.Noise.Handshake +import Crypto.Noise.Cipher +import Crypto.Noise.Cipher.ChaChaPoly1305 +import Crypto.Noise.Curve +import Crypto.Noise.Curve.Curve25519 +import Crypto.Noise.Hash +import Crypto.Noise.Hash.SHA256 +import Crypto.Noise.Types + +import Data.ByteString (ByteString) +import qualified Data.ByteArray as BA (concat) + +sampleHSPT :: Plaintext +sampleHSPT = Plaintext $ convert ("cacophony" :: ByteString) + +makeHSN :: ByteString -> ScrubbedBytes +makeHSN hs = BA.concat [convert hs, u, a, u, b, u, c] + where + a = curveName (Proxy :: Proxy Curve25519) + b = cipherName (Proxy :: Proxy ChaChaPoly1305) + c = hashName (Proxy :: Proxy SHA256) + u = convert ("_" :: ByteString) + +-------------------------------------------------------------------------------- +-- Noise_NN + +hsnNN :: ScrubbedBytes +hsnNN = makeHSN "Noise_NN" + +doNN :: Plaintext -> Property +doNN pt = ioProperty $ do + let aliceNN = handshakeState hsnNN Nothing Nothing Nothing Nothing Nothing + :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + bobNN = handshakeState hsnNN Nothing Nothing Nothing Nothing Nothing + :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + (aliceToBob1, aliceNN') <- writeHandshakeMsg aliceNN noiseNNI1 sampleHSPT + let (hsptFromAlice1, bobNN') = readHandshakeMsg bobNN aliceToBob1 noiseNNR1 + + (bobToAlice1, csBob1, csBob2) <- writeHandshakeMsgFinal bobNN' noiseNNR2 sampleHSPT + let (hsptFromBob1, csAlice1, csAlice2) = readHandshakeMsgFinal aliceNN' bobToAlice1 noiseNNI2 + + 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 + +-------------------------------------------------------------------------------- +-- Noise_KN + +hsnKN :: ScrubbedBytes +hsnKN = makeHSN "Noise_KN" + +doKN :: Plaintext -> Property +doKN pt = ioProperty $ do + aliceStaticKey@(_, aliceStaticPK) <- curveGenKey :: IO (KeyPair Curve25519) + + let aliceKN = handshakeState + hsnKN + (Just aliceStaticKey) + Nothing + Nothing + Nothing + (Just noiseKNI0) :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + bobKN = handshakeState + hsnKN + Nothing + Nothing + (Just aliceStaticPK) + Nothing + (Just noiseKNR0) :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + (aliceToBob1, aliceKN') <- writeHandshakeMsg aliceKN noiseKNI1 sampleHSPT + let (hsptFromAlice1, bobKN') = readHandshakeMsg bobKN aliceToBob1 noiseKNR1 + + (bobToAlice1, csBob1, csBob2) <- writeHandshakeMsgFinal bobKN' noiseKNR2 sampleHSPT + let (hsptFromBob1, csAlice1, csAlice2) = readHandshakeMsgFinal aliceKN' bobToAlice1 noiseKNI2 + + 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 + +-------------------------------------------------------------------------------- +-- Noise_NK + +hsnNK :: ScrubbedBytes +hsnNK = makeHSN "Noise_NK" + +doNK :: Plaintext -> Property +doNK pt = ioProperty $ do + bobStaticKey@(_, bobStaticPK) <- curveGenKey :: IO (KeyPair Curve25519) + + let aliceNK = handshakeState + hsnNK + Nothing + Nothing + (Just bobStaticPK) + Nothing + (Just noiseNKI0) :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + bobNK = handshakeState + hsnNK + (Just bobStaticKey) + Nothing + Nothing + Nothing + (Just noiseNKR0) :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + (aliceToBob1, aliceNK') <- writeHandshakeMsg aliceNK noiseNKI1 sampleHSPT + let (hsptFromAlice1, bobNK') = readHandshakeMsg bobNK aliceToBob1 noiseNKR1 + + (bobToAlice1, csBob1, csBob2) <- writeHandshakeMsgFinal bobNK' noiseNKR2 sampleHSPT + let (hsptFromBob1, csAlice1, csAlice2) = readHandshakeMsgFinal aliceNK' bobToAlice1 noiseNKI2 + + 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 + +-------------------------------------------------------------------------------- +-- Noise_KK + +hsnKK :: ScrubbedBytes +hsnKK = makeHSN "Noise_KK" + +doKK :: Plaintext -> Property +doKK pt = ioProperty $ do + aliceStaticKey@(_, aliceStaticPK) <- curveGenKey :: IO (KeyPair Curve25519) + bobStaticKey@(_, bobStaticPK) <- curveGenKey :: IO (KeyPair Curve25519) + + let aliceKK = handshakeState + hsnKK + (Just aliceStaticKey) + Nothing + (Just bobStaticPK) + Nothing + (Just noiseKKI0) :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + bobKK = handshakeState + hsnKK + (Just bobStaticKey) + Nothing + (Just aliceStaticPK) + Nothing + (Just noiseKKR0) :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + (aliceToBob1, aliceKK') <- writeHandshakeMsg aliceKK noiseKKI1 sampleHSPT + let (hsptFromAlice1, bobKK') = readHandshakeMsg bobKK aliceToBob1 noiseKKR1 + + (bobToAlice1, csBob1, csBob2) <- writeHandshakeMsgFinal bobKK' noiseKKR2 sampleHSPT + let (hsptFromBob1, csAlice1, csAlice2) = readHandshakeMsgFinal aliceKK' bobToAlice1 noiseKKI2 + + 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 + +-------------------------------------------------------------------------------- +-- Noise_NE + +hsnNE :: ScrubbedBytes +hsnNE = makeHSN "Noise_NE" + +doNE :: Plaintext -> Property +doNE pt = ioProperty $ do + bobStaticKey@(_, bobStaticPK) <- curveGenKey :: IO (KeyPair Curve25519) + bobEphemeralKey@(_, bobEphemeralPK) <- curveGenKey :: IO (KeyPair Curve25519) + + let aliceNE = handshakeState + hsnNE + Nothing + Nothing + (Just bobStaticPK) + (Just bobEphemeralPK) + (Just noiseNEI0) :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + bobNE = handshakeState + hsnNE + (Just bobStaticKey) + (Just bobEphemeralKey) + Nothing + Nothing + (Just noiseNER0) :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + (aliceToBob1, aliceNE') <- writeHandshakeMsg aliceNE noiseNEI1 sampleHSPT + let (hsptFromAlice1, bobNE') = readHandshakeMsg bobNE aliceToBob1 noiseNER1 + + (bobToAlice1, csBob1, csBob2) <- writeHandshakeMsgFinal bobNE' noiseNER2 sampleHSPT + let (hsptFromBob1, csAlice1, csAlice2) = readHandshakeMsgFinal aliceNE' bobToAlice1 noiseNEI2 + + 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 + +-------------------------------------------------------------------------------- +-- Noise_KE + +hsnKE :: ScrubbedBytes +hsnKE = makeHSN "Noise_KE" + +doKE :: Plaintext -> Property +doKE pt = ioProperty $ do + aliceStaticKey@(_, aliceStaticPK) <- curveGenKey :: IO (KeyPair Curve25519) + bobStaticKey@(_, bobStaticPK) <- curveGenKey :: IO (KeyPair Curve25519) + bobEphemeralKey@(_, bobEphemeralPK) <- curveGenKey :: IO (KeyPair Curve25519) + + let aliceKE = handshakeState + hsnKE + (Just aliceStaticKey) + Nothing + (Just bobStaticPK) + (Just bobEphemeralPK) + (Just noiseKEI0) :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + bobKE = handshakeState + hsnKE + (Just bobStaticKey) + (Just bobEphemeralKey) + (Just aliceStaticPK) + Nothing + (Just noiseKER0) :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + (aliceToBob1, aliceKE') <- writeHandshakeMsg aliceKE noiseKEI1 sampleHSPT + let (hsptFromAlice1, bobKE') = readHandshakeMsg bobKE aliceToBob1 noiseKER1 + + (bobToAlice1, csBob1, csBob2) <- writeHandshakeMsgFinal bobKE' noiseKER2 sampleHSPT + let (hsptFromBob1, csAlice1, csAlice2) = readHandshakeMsgFinal aliceKE' bobToAlice1 noiseKEI2 + + 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 + +-------------------------------------------------------------------------------- +-- Noise_NX + +hsnNX :: ScrubbedBytes +hsnNX = makeHSN "Noise_NX" + +doNX :: Plaintext -> Property +doNX pt = ioProperty $ do + bobStaticKey <- curveGenKey :: IO (KeyPair Curve25519) + + let aliceNX = handshakeState + hsnNX + Nothing + Nothing + Nothing + Nothing + Nothing :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + bobNX = handshakeState + hsnNX + (Just bobStaticKey) + Nothing + Nothing + Nothing + Nothing :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + (aliceToBob1, aliceNX') <- writeHandshakeMsg aliceNX noiseNXI1 sampleHSPT + let (hsptFromAlice1, bobNX') = readHandshakeMsg bobNX aliceToBob1 noiseNXR1 + + (bobToAlice1, csBob1, csBob2) <- writeHandshakeMsgFinal bobNX' noiseNXR2 sampleHSPT + let (hsptFromBob1, csAlice1, csAlice2) = readHandshakeMsgFinal aliceNX' bobToAlice1 noiseNXI2 + + 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 + +-------------------------------------------------------------------------------- +-- Noise_KX + +hsnKX :: ScrubbedBytes +hsnKX = makeHSN "Noise_KX" + +doKX :: Plaintext -> Property +doKX pt = ioProperty $ do + aliceStaticKey@(_, aliceStaticPK) <- curveGenKey :: IO (KeyPair Curve25519) + bobStaticKey <- curveGenKey :: IO (KeyPair Curve25519) + + let aliceKX = handshakeState + hsnKX + (Just aliceStaticKey) + Nothing + Nothing + Nothing + (Just noiseKXI0) :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + bobKX = handshakeState + hsnKX + (Just bobStaticKey) + Nothing + (Just aliceStaticPK) + Nothing + (Just noiseKXR0) :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + (aliceToBob1, aliceKX') <- writeHandshakeMsg aliceKX noiseKXI1 sampleHSPT + let (hsptFromAlice1, bobKX') = readHandshakeMsg bobKX aliceToBob1 noiseKXR1 + + (bobToAlice1, csBob1, csBob2) <- writeHandshakeMsgFinal bobKX' noiseKXR2 sampleHSPT + let (hsptFromBob1, csAlice1, csAlice2) = readHandshakeMsgFinal aliceKX' bobToAlice1 noiseKXI2 + + 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 + +-------------------------------------------------------------------------------- +-- Noise_XN + +hsnXN :: ScrubbedBytes +hsnXN = makeHSN "Noise_XN" + +doXN :: Plaintext -> Property +doXN pt = ioProperty $ do + aliceStaticKey <- curveGenKey :: IO (KeyPair Curve25519) + + let aliceXN = handshakeState + hsnXN + (Just aliceStaticKey) + Nothing + Nothing + Nothing + Nothing :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + bobXN = handshakeState + hsnXN + Nothing + Nothing + Nothing + Nothing + Nothing :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + (aliceToBob1, aliceXN') <- writeHandshakeMsg aliceXN noiseXNI1 sampleHSPT + let (hsptFromAlice1, bobXN') = readHandshakeMsg bobXN aliceToBob1 noiseXNR1 + + (bobToAlice1, bobXN'') <- writeHandshakeMsg bobXN' noiseXNR2 sampleHSPT + let (hsptFromBob1, aliceXN'') = readHandshakeMsg aliceXN' bobToAlice1 noiseXNI2 + + (aliceToBob2, csAlice1, csAlice2) <- writeHandshakeMsgFinal aliceXN'' noiseXNI3 sampleHSPT + let (hsptFromBob2, csBob1, csBob2) = readHandshakeMsgFinal bobXN'' aliceToBob2 noiseXNR3 + + 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 + +-------------------------------------------------------------------------------- +-- Noise_IN + +hsnIN :: ScrubbedBytes +hsnIN = makeHSN "Noise_IN" + +doIN :: Plaintext -> Property +doIN pt = ioProperty $ do + aliceStaticKey <- curveGenKey :: IO (KeyPair Curve25519) + + let aliceIN = handshakeState + hsnIN + (Just aliceStaticKey) + Nothing + Nothing + Nothing + Nothing :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + bobIN = handshakeState + hsnIN + Nothing + Nothing + Nothing + Nothing + Nothing :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + (aliceToBob1, aliceIN') <- writeHandshakeMsg aliceIN noiseINI1 sampleHSPT + let (hsptFromAlice1, bobIN') = readHandshakeMsg bobIN aliceToBob1 noiseINR1 + + (bobToAlice1, csBob1, csBob2) <- writeHandshakeMsgFinal bobIN' noiseINR2 sampleHSPT + let (hsptFromBob1, csAlice1, csAlice2) = readHandshakeMsgFinal aliceIN' bobToAlice1 noiseINI2 + + 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 + +-------------------------------------------------------------------------------- +-- Noise_XK + +hsnXK :: ScrubbedBytes +hsnXK = makeHSN "Noise_XK" + +doXK :: Plaintext -> Property +doXK pt = ioProperty $ do + aliceStaticKey <- curveGenKey :: IO (KeyPair Curve25519) + bobStaticKey@(_, bobStaticPK) <- curveGenKey :: IO (KeyPair Curve25519) + + let aliceXK = handshakeState + hsnXK + (Just aliceStaticKey) + Nothing + (Just bobStaticPK) + Nothing + (Just noiseXKI0) :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + bobXK = handshakeState + hsnXK + (Just bobStaticKey) + Nothing + Nothing + Nothing + (Just noiseXKR0) :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + (aliceToBob1, aliceXK') <- writeHandshakeMsg aliceXK noiseXKI1 sampleHSPT + let (hsptFromAlice1, bobXK') = readHandshakeMsg bobXK aliceToBob1 noiseXKR1 + + (bobToAlice1, bobXK'') <- writeHandshakeMsg bobXK' noiseXKR2 sampleHSPT + let (hsptFromBob1, aliceXK'') = readHandshakeMsg aliceXK' bobToAlice1 noiseXKI2 + + (aliceToBob2, csAlice1, csAlice2) <- writeHandshakeMsgFinal aliceXK'' noiseXKI3 sampleHSPT + let (hsptFromBob2, csBob1, csBob2) = readHandshakeMsgFinal bobXK'' aliceToBob2 noiseXKR3 + + 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 + +-------------------------------------------------------------------------------- +-- Noise_IK + +hsnIK :: ScrubbedBytes +hsnIK = makeHSN "Noise_IK" + +doIK :: Plaintext -> Property +doIK pt = ioProperty $ do + aliceStaticKey@(_, aliceStaticPK) <- curveGenKey :: IO (KeyPair Curve25519) + bobStaticKey@(_, bobStaticPK) <- curveGenKey :: IO (KeyPair Curve25519) + + let aliceIK = handshakeState + hsnIK + (Just aliceStaticKey) + Nothing + (Just bobStaticPK) + Nothing + (Just noiseIKI0) :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + bobIK = handshakeState + hsnIK + (Just bobStaticKey) + Nothing + (Just aliceStaticPK) + Nothing + (Just noiseIKR0) :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + (aliceToBob1, aliceIK') <- writeHandshakeMsg aliceIK noiseIKI1 sampleHSPT + let (hsptFromAlice1, bobIK') = readHandshakeMsg bobIK aliceToBob1 noiseIKR1 + + (bobToAlice1, csBob1, csBob2) <- writeHandshakeMsgFinal bobIK' noiseIKR2 sampleHSPT + let (hsptFromBob1, csAlice1, csAlice2) = readHandshakeMsgFinal aliceIK' bobToAlice1 noiseIKI2 + + 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 + +-------------------------------------------------------------------------------- +-- Noise_XE + +hsnXE :: ScrubbedBytes +hsnXE = makeHSN "Noise_XE" + +doXE :: Plaintext -> Property +doXE pt = ioProperty $ do + aliceStaticKey <- curveGenKey :: IO (KeyPair Curve25519) + bobStaticKey@(_, bobStaticPK) <- curveGenKey :: IO (KeyPair Curve25519) + bobEphemeralKey@(_, bobEphemeralPK) <- curveGenKey :: IO (KeyPair Curve25519) + + let aliceXE = handshakeState + hsnXE + (Just aliceStaticKey) + Nothing + (Just bobStaticPK) + (Just bobEphemeralPK) + (Just noiseXEI0) :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + bobXE = handshakeState + hsnXE + (Just bobStaticKey) + (Just bobEphemeralKey) + Nothing + Nothing + (Just noiseXER0) :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + (aliceToBob1, aliceXE') <- writeHandshakeMsg aliceXE noiseXEI1 sampleHSPT + let (hsptFromAlice1, bobXE') = readHandshakeMsg bobXE aliceToBob1 noiseXER1 + + (bobToAlice1, bobXE'') <- writeHandshakeMsg bobXE' noiseXER2 sampleHSPT + let (hsptFromBob1, aliceXE'') = readHandshakeMsg aliceXE' bobToAlice1 noiseXEI2 + + (aliceToBob2, csAlice1, csAlice2) <- writeHandshakeMsgFinal aliceXE'' noiseXEI3 sampleHSPT + let (hsptFromBob2, csBob1, csBob2) = readHandshakeMsgFinal bobXE'' aliceToBob2 noiseXER3 + + 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 + +-------------------------------------------------------------------------------- +-- Noise_IE + +hsnIE :: ScrubbedBytes +hsnIE = makeHSN "Noise_IE" + +doIE :: Plaintext -> Property +doIE pt = ioProperty $ do + aliceStaticKey@(_, aliceStaticPK) <- curveGenKey :: IO (KeyPair Curve25519) + bobStaticKey@(_, bobStaticPK) <- curveGenKey :: IO (KeyPair Curve25519) + bobEphemeralKey@(_, bobEphemeralPK) <- curveGenKey :: IO (KeyPair Curve25519) + + let aliceIE = handshakeState + hsnIE + (Just aliceStaticKey) + Nothing + (Just bobStaticPK) + (Just bobEphemeralPK) + (Just noiseIEI0) :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + bobIE = handshakeState + hsnIE + (Just bobStaticKey) + (Just bobEphemeralKey) + (Just aliceStaticPK) + Nothing + (Just noiseIER0) :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + (aliceToBob1, aliceIE') <- writeHandshakeMsg aliceIE noiseIEI1 sampleHSPT + let (hsptFromAlice1, bobIE') = readHandshakeMsg bobIE aliceToBob1 noiseIER1 + + (bobToAlice1, csBob1, csBob2) <- writeHandshakeMsgFinal bobIE' noiseIER2 sampleHSPT + let (hsptFromBob1, csAlice1, csAlice2) = readHandshakeMsgFinal aliceIE' bobToAlice1 noiseIEI2 + + 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 + +-------------------------------------------------------------------------------- +-- Noise_XX + +hsnXX :: ScrubbedBytes +hsnXX = makeHSN "Noise_XX" + +doXX :: Plaintext -> Property +doXX pt = ioProperty $ do + aliceStaticKey <- curveGenKey :: IO (KeyPair Curve25519) + bobStaticKey <- curveGenKey :: IO (KeyPair Curve25519) + + let aliceXX = handshakeState + hsnXX + (Just aliceStaticKey) + Nothing + Nothing + Nothing + Nothing :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + bobXX = handshakeState + hsnXX + (Just bobStaticKey) + Nothing + Nothing + Nothing + Nothing :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + (aliceToBob1, aliceXX') <- writeHandshakeMsg aliceXX noiseXXI1 sampleHSPT + let (hsptFromAlice1, bobXX') = readHandshakeMsg bobXX aliceToBob1 noiseXXR1 + + (bobToAlice1, bobXX'') <- writeHandshakeMsg bobXX' noiseXXR2 sampleHSPT + let (hsptFromBob1, aliceXX'') = readHandshakeMsg aliceXX' bobToAlice1 noiseXXI2 + + (aliceToBob2, csAlice1, csAlice2) <- writeHandshakeMsgFinal aliceXX'' noiseXXI3 sampleHSPT + let (hsptFromBob2, csBob1, csBob2) = readHandshakeMsgFinal bobXX'' aliceToBob2 noiseXXR3 + + 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 + +-------------------------------------------------------------------------------- +-- Noise_IX + +hsnIX :: ScrubbedBytes +hsnIX = makeHSN "Noise_IX" + +doIX :: Plaintext -> Property +doIX pt = ioProperty $ do + aliceStaticKey <- curveGenKey :: IO (KeyPair Curve25519) + bobStaticKey <- curveGenKey :: IO (KeyPair Curve25519) + + let aliceIX = handshakeState + hsnIX + (Just aliceStaticKey) + Nothing + Nothing + Nothing + Nothing :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + bobIX = handshakeState + hsnIX + (Just bobStaticKey) + Nothing + Nothing + Nothing + Nothing :: HandshakeState ChaChaPoly1305 Curve25519 SHA256 + + (aliceToBob1, aliceIX') <- writeHandshakeMsg aliceIX noiseIXI1 sampleHSPT + let (hsptFromAlice1, bobIX') = readHandshakeMsg bobIX aliceToBob1 noiseIXR1 + + (bobToAlice1, csBob1, csBob2) <- writeHandshakeMsgFinal bobIX' noiseIXR2 sampleHSPT + let (hsptFromBob1, csAlice1, csAlice2) = readHandshakeMsgFinal aliceIX' bobToAlice1 noiseIXI2 + + 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 + +tests :: TestTree +tests = testGroup "Handshakes" + [ testProperty "Noise_NN" $ property doNN + , testProperty "Noise_KN" $ property doKN + , testProperty "Noise_NK" $ property doNK + , testProperty "Noise_KK" $ property doKK + , testProperty "Noise_NE" $ property doNE + , testProperty "Noise_KE" $ property doKE + , testProperty "Noise_NX" $ property doNX + , testProperty "Noise_KX" $ property doKX + , testProperty "Noise_XN" $ property doXN + , testProperty "Noise_IN" $ property doIN + , testProperty "Noise_XK" $ property doXK + , testProperty "Noise_IK" $ property doIK + , testProperty "Noise_XE" $ property doXE + , testProperty "Noise_IE" $ property doIE + , testProperty "Noise_XX" $ property doXX + ] diff --git a/tests/Imports.hs b/tests/Imports.hs new file mode 100644 --- /dev/null +++ b/tests/Imports.hs @@ -0,0 +1,7 @@ +module Imports + ( + module X + ) where + +import Test.Tasty as X +import Test.Tasty.QuickCheck as X diff --git a/tests/Instances.hs b/tests/Instances.hs new file mode 100644 --- /dev/null +++ b/tests/Instances.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE FlexibleInstances, StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Instances where + +import Control.Monad (liftM, replicateM) +import qualified Data.ByteArray as BA +import qualified Data.ByteString as BS +import Test.QuickCheck + +import Crypto.Noise.Cipher +import Crypto.Noise.Internal.CipherState + +instance Eq Plaintext where + (Plaintext pt1) == (Plaintext pt2) = pt1 `BA.eq` pt2 + +instance Show Plaintext where + show (Plaintext pt) = show (BA.convert pt :: BS.ByteString) + +instance Show AssocData where + show (AssocData ad) = show (BA.convert ad :: BS.ByteString) + +instance Show (SymmetricKey a) where + show _ = "" + +instance Show (Nonce a) where + show _ = "" + +deriving instance Show (CipherState a) + +instance Arbitrary BA.ScrubbedBytes where + arbitrary = BA.convert `liftM` BS.pack <$> arbitrary + +instance Arbitrary Plaintext where + arbitrary = Plaintext `liftM` arbitrary + +instance Arbitrary AssocData where + arbitrary = AssocData `liftM` arbitrary + +instance Cipher c => Arbitrary (CipherState c) where + arbitrary = do + a <- (BA.convert . BS.pack) <$> replicateM 32 arbitrary + return $ CipherState (cipherBytesToSym a) cipherZeroNonce diff --git a/tests/SymmetricHandshakeState.hs b/tests/SymmetricHandshakeState.hs new file mode 100644 --- /dev/null +++ b/tests/SymmetricHandshakeState.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} +module SymmetricHandshakeState where + +import Imports +import Instances() + +import Control.Monad.State (runState, state) + +import Data.ByteString (ByteString) + +import Crypto.Noise.Cipher +import Crypto.Noise.Cipher.ChaChaPoly1305 +import Crypto.Noise.Hash.SHA256 +import Crypto.Noise.Internal.SymmetricHandshakeState +import Crypto.Noise.Types + +shs :: SymmetricHandshakeState ChaChaPoly1305 SHA256 +shs = symmetricHandshake $ convert ("handshake name" :: ByteString) + +roundTripProp :: Plaintext -> Property +roundTripProp pt = (decrypt . encrypt) pt === pt + where + encrypt p = encryptAndHash p shs + decrypt (ct, _) = fst $ decryptAndHash (cipherBytesToText ct) shs + +manyRoundTripsProp :: [Plaintext] -> Property +manyRoundTripsProp pts = (fst . manyDecrypts . manyEncrypts) pts === pts + where + encrypt = encryptAndHash + decrypt = decryptAndHash . cipherBytesToText + doMany f xs = runState . mapM (state . f) $ xs + manyEncrypts xs = doMany encrypt xs shs + manyDecrypts (cts, _) = doMany decrypt cts shs + +tests :: TestTree +tests = testGroup "SymmetricHandshake" + [ testProperty "ChaChaPoly1305 one roundtrip" $ property roundTripProp + , testProperty "ChaChaPoly1305 many roundtrips" $ property manyRoundTripsProp + ] diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,17 @@ +module Main where + +import Imports + +import qualified CipherState +import qualified SymmetricHandshakeState +import qualified Handshake + +tests :: TestTree +tests = testGroup "cacophony" + [ CipherState.tests + , SymmetricHandshakeState.tests + , Handshake.tests + ] + +main :: IO () +main = defaultMain tests diff --git a/tests/doctests.hs b/tests/doctests.hs new file mode 100644 --- /dev/null +++ b/tests/doctests.hs @@ -0,0 +1,28 @@ +module Main + ( main + ) where + +import Control.Monad +import Data.List +import System.Directory +import System.FilePath + +import Test.DocTest + +main :: IO () +main = allSources >>= \sources -> doctest ("-isrc":sources) + +allSources :: IO [FilePath] +allSources = getFiles ".hs" "src" + +getFiles :: String -> FilePath -> IO [FilePath] +getFiles ext root = filter (isSuffixOf ext) <$> go root + where + go dir = do + (dirs, files) <- getFilesAndDirectories dir + (files ++) . concat <$> mapM go dirs + +getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) +getFilesAndDirectories dir = do + c <- fmap (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir + (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c diff --git a/tests/hlint.hs b/tests/hlint.hs new file mode 100644 --- /dev/null +++ b/tests/hlint.hs @@ -0,0 +1,17 @@ +module Main where + +import Control.Monad +import Language.Haskell.HLint +import System.Environment +import System.Exit + +main :: IO () +main = do + args <- getArgs + hints <- hlint $ [ "src" + , "benchmarks" + , "tests" + , "--hint=tests/.hlint" + , "--cpp-define=HLINT" + ] `mappend` args + unless (null hints) exitFailure