cacophony 0.9.2 → 0.10.0

raw patch · 68 files changed

+25521/−42460 lines, 68 filesdep +haskelinedep +processdep −auto-updatedep −fast-loggerdep −network-simpledep ~basedep ~cryptonitedep ~exceptionsnew-component:exe:noise-replPVP ok

version bump matches the API change (PVP)

Dependencies added: haskeline, process

Dependencies removed: auto-update, fast-logger, network-simple, unix, unix-time

Dependency ranges changed: base, cryptonite, exceptions, memory

API changes (from Hackage documentation)

Files

• .travis.yml +19/−64
• README.md +84/−68
• benchmarks/Handshakes.hs +0/−229
• benchmarks/Keys.hs +175/−0
• benchmarks/Main.hs +121/−0
• benchmarks/Types.hs +181/−52
• benchmarks/bench.hs +0/−142
• cacophony.cabal +134/−218
• changelog.md +10/−0
• examples/echo-client/Client.hs +0/−92
• examples/echo-client/Main.hs +0/−98
• examples/echo-client/Parse.hs +0/−26
• examples/echo-server/Handshakes.hs +0/−187
• examples/echo-server/Log.hs +0/−51
• examples/echo-server/Main.hs +0/−106
• examples/echo-server/Parse.hs +0/−116
• examples/echo-server/Server.hs +0/−127
• examples/echo-server/Types.hs +0/−88
• package.yaml +157/−0
• src/Crypto/Noise.hs +120/−48
• src/Crypto/Noise/Cipher.hs +31/−3
• src/Crypto/Noise/Cipher/AESGCM.hs +47/−36
• src/Crypto/Noise/Cipher/ChaChaPoly1305.hs +42/−14
• src/Crypto/Noise/DH.hs +8/−9
• src/Crypto/Noise/DH/Curve25519.hs +3/−4
• src/Crypto/Noise/DH/Curve448.hs +3/−4
• src/Crypto/Noise/Exception.hs +50/−0
• src/Crypto/Noise/HandshakePatterns.hs +290/−175
• src/Crypto/Noise/Hash.hs +6/−3
• src/Crypto/Noise/Hash/BLAKE2b.hs +37/−37
• src/Crypto/Noise/Hash/BLAKE2s.hs +35/−35
• src/Crypto/Noise/Hash/SHA256.hs +18/−16
• src/Crypto/Noise/Hash/SHA512.hs +18/−16
• src/Crypto/Noise/Internal/CipherState.hs +56/−32
• src/Crypto/Noise/Internal/Handshake.hs +0/−70
• src/Crypto/Noise/Internal/Handshake/Interpreter.hs +247/−0
• src/Crypto/Noise/Internal/Handshake/Pattern.hs +99/−0
• src/Crypto/Noise/Internal/Handshake/State.hs +145/−0
• src/Crypto/Noise/Internal/Handshake/Validation.hs +251/−0
• src/Crypto/Noise/Internal/HandshakePattern.hs +0/−44
• src/Crypto/Noise/Internal/NoiseState.hs +59/−367
• src/Crypto/Noise/Internal/SymmetricState.hs +54/−52
• src/Crypto/Noise/Internal/Types.hs +0/−37
• src/Crypto/Noise/Validation.hs +15/−0
• stack.yaml +6/−0
• tests/.hlint +2/−0
• tests/hlint/hlint.hs +1/−1
• tests/vectors/Generate.hs +152/−129
• tests/vectors/Handshakes.hs +0/−229
• tests/vectors/Keys.hs +199/−0
• tests/vectors/Main.hs +19/−0
• tests/vectors/Types.hs +214/−120
• tests/vectors/VectorFile.hs +46/−63
• tests/vectors/Verify.hs +110/−127
• tests/vectors/vectors.hs +0/−21
• tools/convert_vectors.py +0/−29
• tools/noise-repl/Client.hs +256/−0
• tools/noise-repl/Main.hs +45/−0
• tools/noise-repl/Options.hs +120/−0
• tools/noise-repl/Pipe.hs +46/−0
• tools/noise-repl/Socket.hs +36/−0
• tools/noise-repl/Types.hs +246/−0
• tools/pretty-print/format-vectors.py +32/−0
• tools/pretty-print/vector-template.jinja +72/−0
• tools/run_benchmarks.sh +0/−31
• tools/vector_template.jinja +0/−68
• vectors/cacophony.txt +21404/−19292
• vectors/noise-c-basic.txt +0/−19684

@@ -1,81 +1,36 @@-# This file has been generated -- see https://github.com/hvr/multi-ghc-travis language: c-sudo: false+dist: trusty  cache:   directories:-    - $HOME/.cabsnap-    - $HOME/.cabal/packages+    - $HOME/.stack -before_cache:-  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log-  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar+addons:+  apt:+    packages:+      - libgmp-dev  matrix:   include:-    - env: CABALVER=1.22 GHCVER=7.10.3-      compiler: ": #GHC 7.10.3"-      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}-    - env: CABALVER=1.24 GHCVER=8.0.1-      compiler: ": #GHC 8.0.1"-      addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}-    - env: CABALVER=head GHCVER=head-      compiler: ": #GHC head"-      addons: {apt: {packages: [cabal-install-head,ghc-head,alex-3.1.7,happy-1.19.5], sources: [hvr-ghc]}}+    - env: ARGS="--resolver lts-8"+      compiler: ": #stack 8.0.2" +    - env: ARGS="--resolver nightly"+      compiler: ": #stack nightly"+   allow_failures:-   - env: CABALVER=head GHCVER=head+    - env: ARGS="--resolver nightly"+      compiler: ": #stack nightly"  before_install:   - unset CC-  - export HAPPYVER=1.19.5-  - export ALEXVER=3.1.7-  - export PATH=~/.cabal/bin:/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/happy/$HAPPYVER/bin:/opt/alex/$ALEXVER/bin:$PATH+  - mkdir -p ~/.local/bin+  - export PATH=$HOME/.local/bin:$PATH+  - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'  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 --enable-benchmarks -fbuild-examples --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 --enable-benchmarks -fbuild-examples cacophony.cabal;-    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+  - stack $ARGS setup  script:-  - cabal configure --enable-tests --enable-benchmarks -fbuild-examples -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 --enable-tests --run-tests -fbuild-examples --force-reinstalls "$SRC_TGZ")+  - stack $ARGS --no-terminal test --flag "cacophony:build-tools" --bench --no-run-benchmarks --haddock --no-haddock-deps+  - stack sdist

@@ -3,19 +3,18 @@ [![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/noiseprotocol/noise_spec/blob/master/noise.md) protocol.+This library implements the [Noise](https://noiseprotocol.org) protocol. -## Basic usage+## Basic Usage  1. Import the modules for the kind of handshake you'd like to use.     For example, if you want to use `Noise_IK_25519_AESGCM_SHA256`, your imports would be:-   ```haskell-   import Control.Lens +   ```haskell    import Crypto.Noise    import Crypto.Noise.Cipher.AESGCM-   import Crypto.Noise.DH+   import Crypto.Noise.DH -- Used to generate and manipulate keys    import Crypto.Noise.DH.Curve25519    import Crypto.Noise.Hash.SHA256    import Crypto.Noise.HandshakePatterns (noiseIK)@@ -23,123 +22,140 @@  2. Set the handshake parameters. -   Select a handshake pattern to use. Patterns are defined in the `Crypto.Noise.HandshakePatterns` module.    Ensure that you provide the keys which are required by the handshake pattern you choose. For example,    the `Noise_IK` pattern requires that the initiator provides a local static key and a remote static key,    while the responder is only responsible for a local static key. You can use `defaultHandshakeOpts` to-   return a default set of options in which the prologue is an empty string, PSKs are disabled, and all-   keys are set to `Nothing`. You must set the local ephemeral key for all handshake patterns, and it-   should never be reused.--   Functions for manipulating DH keys can be found in the `Crypto.Noise.DH` module.+   return a default set of options in which all keys are set to `Nothing`. The initiator must set a+   local ephemeral key for all handshake patterns. The responder must set a local ephemeral key for all+   interactive (i.e. not one-way) patterns.     ```haskell    -- Initiator-   local_ephemeral_key <- dhGenKey :: IO (KeyPair Curve25519)+   localEphemeralKey <- dhGenKey :: IO (KeyPair Curve25519) -   let dho = defaultHandshakeOpts noiseIK InitiatorRole :: HandshakeOpts Curve25519-        iho = dho & hoPrologue       .~ "prologue"-                  & hoPreSharedKey   .~ Just pre_shared_key-                  & hoLocalStatic    .~ Just local_static_key-                  & hoLocalEphemeral .~ Just local_ephemeral_key-                  & hoRemoteStatic   .~ Just remote_static_key -- communicated out-of-band+   let dho = defaultHandshakeOpts InitiatorRole "prologue" :: HandshakeOpts Curve25519+       iho = setLocalStatic      (Just localStaticKey)+             . setLocalEphemeral (Just localEphemeralKey)+             . setRemoteStatic   (Just remoteStaticKey) -- communicated out-of-band+             $ dho     -- Responder-   local_ephemeral_key <- dhGenKey :: IO (KeyPair Curve25519)+   localEphemeralKey <- dhGenKey :: IO (KeyPair Curve25519) -   let dho = defaultHandshakeOpts noiseIK ResponderRole :: HandshakeOpts Curve25519-        rho = dho & hoPrologue       .~ "prologue"-                  & hoPreSharedKey   .~ Just pre_shared_key-                  & hoLocalStatic    .~ Just local_static_key-                  & hoLocalEphemeral .~ Just local_ephemeral_key+   let dho = defaultHandshakeOpts ResponderRole "prologue" :: HandshakeOpts Curve25519+       rho = setLocalStatic      (Just localStaticKey)+             . setLocalEphemeral (Just localEphemeralKey)+             $ dho    ```  3. Create the Noise state.+    ```haskell    -- Initiator-   let ins = noiseState iho :: NoiseState AESGCM Curve25519 SHA256+   let ins = noiseState iho noiseIK :: NoiseState AESGCM Curve25519 SHA256     -- Responder-   let rns = noiseState rho :: NoiseState AESGCM Curve25519 SHA256+   let rns = noiseState rho noiseIK :: NoiseState AESGCM Curve25519 SHA256    ```  4. Send and receive messages.+    ```haskell    -- Initiator-   let writeResult        = writeMessage ins "They must find it difficult -- those who have taken authority as the truth, rather than truth as the authority."-        (ciphertext, ins') = either (error "something terrible happened") id writeResult+   let writeResult = writeMessage "They must find it difficult -- those who have taken authority as the truth, rather than truth as the authority." ins+   case writeResult of+     NoiseResultMessage ciphertext ins' -> ...+     NoiseResultNeedPSK   _ -> error "something terrible happened" -- will never happen in Noise_IK+     NoiseResultException _ -> error "something terrible happened"     -- Responder-   let readResult        = readMessage rns ciphertext-        (plaintext, rns') = either (error "something terrible happened") id readResult+   let readResult = readMessage ciphertext rns+   case readResult of+     NoiseResultMessage plaintext rns' -> ...+     NoiseResultNeedPSK   _ -> error "something terrible happened"+     NoiseResultException _ -> error "something terrible happened"    ``` -   **Ensure that you never re-use a noise state to send more than one message.**+   **Ensure that you never re-use a NoiseState to send more than one message.**     Decrypted messages are stored internally as `ScrubbedBytes` and will be wiped from memory when they are    destroyed. -### Helper functions+### Helper Functions -The following functions are found in `Crypto.Noise` and can be helpful when designing an application which uses-Noise:+The following functions are found in `Crypto.Noise.DH` and are used to manipulate keys: +  * `dhGenKey` -- Generate a fresh (private, public) key pair+  * `dhPubToBytes` -- Convert a public key to `ScrubbedBytes`+  * `dhBytesToPub` -- Convert `ScrubbedBytes` to a public key+  * `dhSecToBytes` -- Convert a private key to `ScrubbedBytes`+  * `dhBytesToPair` -- Convert `ScrubbedBytes` to a (private, public) key pair++The following functions are found in `Crypto.Noise`:+   * `remoteStaticKey` -- For handshake patterns where the remote party's static key is transmitted, this function     can be used to retrieve it. This allows for the creation of public key-based access-control lists.    * `handshakeComplete` -- Returns `True` if the handshake is complete. +  * `processPSKs` -- This function repeatedly applies PSKs to a NoiseState until the list of PSKs becomes empty+    or the handshake pattern stops asking for PSKs.+   * `handshakeHash` -- Retrieves the `h` value associated with the conversation's SymmetricState. This value is     intended to be used for channel binding. For example, the initiator might cryptographically sign this value-    as part of some higher-level authentication scheme. See section 9.4 of the protocol for details.+    as part of some higher-level authentication scheme. See section 11.2 of the protocol for details. +  * `rekeySending` and `rekeyReceiving` -- Rekeys the given NoiseState according to section 11.3 of the protocol.+ ## Vectors  Test vectors can be generated and verified using the `vectors` program. It accepts no arguments. When run, it will check for the existence of `vectors/cacophony.txt` within the current working directory. If it is not found, it is generated. If it is found, it is verified. All files within the `vectors/` directory (regardless-of their name) are also verified.+of their name) are also verified. Note that this program can only generate and verify vectors whose handshake+patterns are pre-defined in this library. -The generated vectors are minified JSON. There is a small python script within the `tools/` directory that-formats the JSON-blob in to something more readable.+## Custom Handshakes -## Example code+If the built-in handshake patterns are insufficient for your application, you can define your own. Note that+this should be done with care. -An echo-server and echo-client are located within the `examples/` directory. The binary protocol they use to-communicate is as follows:-```-C -> S: [psk byte] [pattern byte] [cipher byte] [dh byte] [hash byte]-C -> S: [num message bytes (uint16 big endian)] [message]-S -> C: [num message bytes (uint16 big endian)] [message]-...+Example:++```haskell+noiseFOOpsk0 :: HandshakePattern+noiseFOOpsk0 = handshakePattern "FOOpsk0" $+  preInitiator s            *>+  preResponder s            *>+  initiator (psk *> e *> es *> ss) *>+  responder (e *> ee *> se) ``` -where `message` is any raw Noise handshake or message data.+## Handshake Validation -The prologue is set to the 5 header bytes to prevent a MITM attack.+`HandshakePattern`s can be validated for compliance as described in sections 7.1 and 9.3 of the protocol: -For these example programs, the server chooses the value of the PSK, and the client chooses whether or not-to use a PSK-enabled handshake. Both the server and client expect the PSK file to be base64 encoded. One-way to generate the PSK file is as follows: ```-head -c 32 /dev/random | base64 > psk+λ> let noiseBAD = handshakePattern "BAD" $ preResponder ss *> initiator (e *> se *> e)+[DHInPreMsg (0,0),InitMultipleETokens (1,2),InitSecretNotRandom (1,3)]++λ> validateHandshakePattern noiseKKpsk0+[] ``` -To include these examples in your build, pass the `-fbuild-examples` flag to Cabal.+See the `Crypto.Noise.Validation` module for details. -### Byte definitions+## Tools -| byte | psk      | pattern | cipher     | dh    | hash    |-|------|----------|---------|------------|-------|---------|-| 0x00 | disabled | NN      | ChaChaPoly | 25519 | SHA256  |-| 0x01 | enabled  | KN      | AESGCM     | 448   | SHA512  |-| 0x02 |          | NK      |            |       | BLAKE2s |-| 0x03 |          | KK      |            |       | BLAKE2b |-| 0x04 |          | NX      |            |       |         |-| 0x05 |          | KX      |            |       |         |-| 0x06 |          | XN      |            |       |         |-| 0x07 |          | IN      |            |       |         |-| 0x08 |          | XK      |            |       |         |-| 0x09 |          | IK      |            |       |         |-| 0x0a |          | XX      |            |       |         |-| 0x0b |          | IX      |            |       |         |+### format-vectors.py++Vectors generated by the vector program are formatted as minified JSON. This python script takes the path+to a vector file as an argument and reformats it so that it conforms to+[the style](https://github.com/noiseprotocol/noise_wiki/wiki/Test-vectors) specified on the Noise Wiki.++### noise-repl++This program acts as a kind of REPL for Noise messages. It supports sending and receiving messages via UDP+or via a pipe to a shell command.++All messages transmitted via a pipe are expected to be prepended by a two byte big-endian length.

@@ -1,229 +0,0 @@-{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}-module Handshakes where--import Control.Lens--import Crypto.Noise-import Crypto.Noise.Cipher-import Crypto.Noise.DH-import Crypto.Noise.Hash-import Crypto.Noise.HandshakePatterns--import Types--data HandshakeKeys d =-  HandshakeKeys { hkPrologue       :: Plaintext-                , hkPSK            :: Maybe Plaintext-                , hkLocalStatic    :: KeyPair d-                , hkLocalEphemeral :: KeyPair d-                , hkRemoteStatic   :: PublicKey d-                }--mkNoiseState :: forall c d h. (Cipher c, DH d, Hash h)-             => HandshakeKeys d-             -> HandshakeType-             -> HandshakeRole-             -> CipherType c-             -> HashType h-             -> NoiseState c d h-mkNoiseState HandshakeKeys{..} NoiseNN r _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseNN r :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseKN InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseKN InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseKN ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseKN ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoRemoteStatic   .~ Just hkRemoteStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseNK InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseNK InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoRemoteStatic   .~ Just hkRemoteStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseNK ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseNK ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseKK r _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseKK r :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoRemoteStatic   .~ Just hkRemoteStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseNX InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseNX InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseNX ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseNX ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseKX InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseKX InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseKX ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseKX ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoRemoteStatic   .~ Just hkRemoteStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseXN InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseXN InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseXN ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseXN ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseIN InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseIN InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseIN ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseIN ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseXK InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseXK InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoRemoteStatic   .~ Just hkRemoteStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseXK ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseXK ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseIK InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseIK InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoRemoteStatic   .~ Just hkRemoteStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseIK ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseIK ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseXX r _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseXX r :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseIX r _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseIX r :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseN InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseN InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoRemoteStatic   .~ Just hkRemoteStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseN ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseN ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseK r _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseK r :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoRemoteStatic   .~ Just hkRemoteStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseX InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseX InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoRemoteStatic   .~ Just hkRemoteStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseX ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseX ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral

@@ -0,0 +1,175 @@+{-# LANGUAGE GADTs #-}+module Keys where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Base16 as B16++import Crypto.Noise    (ScrubbedBytes, convert)+import Crypto.Noise.DH+import Crypto.Noise.DH.Curve25519+import Crypto.Noise.DH.Curve448++import Types++data HandshakeKeys = HandshakeKeys+  { hskInitEphemeral    :: Maybe ScrubbedBytes+  , hskRespEphemeral    :: Maybe ScrubbedBytes+  , hskInitStatic       :: Maybe ScrubbedBytes+  , hskRespStatic       :: Maybe ScrubbedBytes+  , hskInitRemoteStatic :: Maybe ScrubbedBytes+  , hskRespRemoteStatic :: Maybe ScrubbedBytes+  }++getKeys :: SomeDHType+        -> PatternName+        -> HandshakeKeys+getKeys dh name = HandshakeKeys+  { hskInitEphemeral    = Just . initiatorEphemeral $ dh+  , hskRespEphemeral    = if name `elem` rePatterns'+                            then Nothing+                            else Just . responderEphemeral $ dh+  , hskInitStatic       = if name `elem` isPatterns+                            then Just . initiatorStatic $ dh+                            else Nothing+  , hskRespStatic       = if name `elem` rsPatterns+                            then Just . responderStatic $ dh+                            else Nothing+  , hskInitRemoteStatic = if name `elem` irPatterns+                            then privateToPublic dh . responderStatic $ dh+                            else Nothing+  , hskRespRemoteStatic = if name `elem` rrPatterns+                            then privateToPublic dh . initiatorStatic $ dh+                            else Nothing+  }++  where+    -- The following patterns do *not* have an ephemeral key for the responder.+    rePatterns' = [ PatternN+                  , PatternK+                  , PatternX+                  , PatternNpsk0+                  , PatternKpsk0+                  , PatternXpsk1+                  ]++    -- The following patterns require a static key for the initiator.+    isPatterns = [ PatternKN+                 , PatternKNpsk0+                 , PatternKNpsk2+                 , PatternKK+                 , PatternKKpsk0+                 , PatternKKpsk2+                 , PatternKX+                 , PatternKXpsk2+                 , PatternXN+                 , PatternXNpsk3+                 , PatternIN+                 , PatternINpsk1+                 , PatternINpsk2+                 , PatternXK+                 , PatternXKpsk3+                 , PatternIK+                 , PatternIKpsk1+                 , PatternIKpsk2+                 , PatternXX+                 , PatternXXpsk3+                 , PatternIX+                 , PatternIXpsk2+                 , PatternK+                 , PatternX+                 , PatternKpsk0+                 , PatternXpsk1+                 ]++    -- The following patterns require a static key for the responder.+    rsPatterns = [ PatternNK+                 , PatternNKpsk0+                 , PatternNKpsk2+                 , PatternKK+                 , PatternKKpsk0+                 , PatternKKpsk2+                 , PatternNX+                 , PatternNXpsk2+                 , PatternKX+                 , PatternKXpsk2+                 , PatternXK+                 , PatternXKpsk3+                 , PatternIK+                 , PatternIKpsk1+                 , PatternIKpsk2+                 , PatternXX+                 , PatternXXpsk3+                 , PatternIX+                 , PatternIXpsk2+                 , PatternN+                 , PatternK+                 , PatternX+                 , PatternNpsk0+                 , PatternKpsk0+                 , PatternXpsk1+                 ]++    -- The following patterns require the initiator to know the responder's+    -- public static key ahead of time (i.e. it is not transmitted).+    irPatterns = [ PatternNK+                 , PatternNKpsk0+                 , PatternNKpsk2+                 , PatternKK+                 , PatternKKpsk0+                 , PatternKKpsk2+                 , PatternXK+                 , PatternXKpsk3+                 , PatternIK+                 , PatternIKpsk1+                 , PatternIKpsk2+                 , PatternN+                 , PatternK+                 , PatternX+                 , PatternNpsk0+                 , PatternKpsk0+                 , PatternXpsk1+                 ]++    -- The following patterns require the responder to know the initiator's+    -- public static key ahead of time (i.e. it is not transmitted).+    rrPatterns = [ PatternKN+                 , PatternKNpsk0+                 , PatternKNpsk2+                 , PatternKK+                 , PatternKKpsk0+                 , PatternKKpsk2+                 , PatternKX+                 , PatternKXpsk2+                 , PatternK+                 , PatternKpsk0+                 ]++privateToPublic :: SomeDHType+                -> ScrubbedBytes+                -> Maybe ScrubbedBytes+privateToPublic (WrapDHType Curve25519) k = fmap (dhPubToBytes . snd) (dhBytesToPair k :: Maybe (KeyPair Curve25519))+privateToPublic (WrapDHType Curve448)   k = fmap (dhPubToBytes . snd) (dhBytesToPair k :: Maybe (KeyPair Curve448))++hexToSB :: ByteString+        -> ScrubbedBytes+hexToSB = convert . fst . B16.decode++initiatorEphemeral :: SomeDHType+                   -> ScrubbedBytes+initiatorEphemeral (WrapDHType Curve25519) = hexToSB "893e28b9dc6ca8d611ab664754b8ceb7bac5117349a4439a6b0569da977c464a"+initiatorEphemeral (WrapDHType Curve448)   = hexToSB "7fd26c8b8a0d5c98c85ff9ca1d7bc66d78578b9f2c4c170850748b27992767e6ea6cc9992a561c9d19dfc342e260c280ef4f3f9b8f879d4e"++responderEphemeral :: SomeDHType+                   -> ScrubbedBytes+responderEphemeral (WrapDHType Curve25519) = hexToSB "bbdb4cdbd309f1a1f2e1456967fe288cadd6f712d65dc7b7793d5e63da6b375b"+responderEphemeral (WrapDHType Curve448)   = hexToSB "3facf7503ebee252465689f1d4e3b1dd219639ef9de4ffd6049d6d71a0f62126840febb99042421ce12af6626d98d9170260390fbc8399a5"++initiatorStatic :: SomeDHType+                -> ScrubbedBytes+initiatorStatic (WrapDHType Curve25519) = hexToSB "e61ef9919cde45dd5f82166404bd08e38bceb5dfdfded0a34c8df7ed542214d1"+initiatorStatic (WrapDHType Curve448)   = hexToSB "34d564c4be963d1b2a89fcfe83e6a72b5e3f5e3127f9f596ffc7575e418dfc1f4e827cfc10c9fed38e92ad56ddf8f08571430df2e76d5411"++responderStatic :: SomeDHType+                -> ScrubbedBytes+responderStatic (WrapDHType Curve25519) = hexToSB "4a3acbfdb163dec651dfa3194dece676d437029c62a408b4c5ea9114246e4893"+responderStatic (WrapDHType Curve448)   = hexToSB "a9b45971180882a79b89a3399544a425ef8136d278efa443ed67d3ff9d36e883bc330c6295bbf6ed73ff6fd10cbed767ad05ce03ebd27c7c"

@@ -0,0 +1,121 @@+{-# LANGUAGE GADTs #-}+module Main where++import Criterion.Main++import Crypto.Noise+import Crypto.Noise.DH++import Keys+import Types++genMessage :: (Cipher c, DH d, Hash h)+           => Bool                -- ^ True if we are writing a message+           -> Maybe ScrubbedBytes -- ^ If a PSK is called for, this value will be used+           -> ScrubbedBytes       -- ^ The payload to write/read+           -> NoiseState c d h    -- ^ The NoiseState to use+           -> NoiseResult c d h+genMessage write mpsk payload state = case result of+  NoiseResultNeedPSK s -> case mpsk of+    Nothing -> NoiseResultException . error $ "PSK requested but none has been configured"+    Just k  -> genMessage write mpsk k s+  r -> r+  where+    operation = if write then writeMessage else readMessage+    result    = operation payload state++genMessages :: (Cipher c, DH d, Hash h)+            => Bool                -- ^ Set to False for one-way patterns+            -> NoiseState c d h    -- ^ Initiator NoiseState+            -> NoiseState c d h    -- ^ Responder NoiseState+            -> Maybe ScrubbedBytes -- ^ PSK+            -> [(ScrubbedBytes, ScrubbedBytes)]+genMessages swap = go []+  where+    go acc s r _ | handshakeComplete s && handshakeComplete r = acc+    go acc sendingState receivingState mpsk =+      case genMessage True mpsk "" sendingState of+        NoiseResultMessage ct sendingState' ->+          case genMessage False mpsk ct receivingState of+            NoiseResultMessage pt receivingState' ->+              if swap+                then go ((pt, ct) : acc) receivingState' sendingState' mpsk+                else go ((pt, ct) : acc) sendingState' receivingState' mpsk+            _ -> error $ "problem encountered during message generation"+        _ -> error $ "problem encountered during message generation"++genNoiseStates :: (Cipher c, DH d, Hash h)+               => CipherType c+               -> HashType h+               -> PatternName+               -> (HandshakeOpts d, HandshakeOpts d)+               -> (NoiseState c d h, NoiseState c d h)+genNoiseStates _ _ pat (iopts, ropts) =+  (noiseState iopts hs, noiseState ropts hs)+  where+    hs = patternToHandshake pat++genOpts :: DH d+        => DHType d+        -> PatternName+        -> (HandshakeOpts d, HandshakeOpts d)+genOpts d pat = (iopts, ropts)+  where+    idho  = defaultHandshakeOpts InitiatorRole mempty+    rdho  = defaultHandshakeOpts ResponderRole mempty++    keys  = getKeys (WrapDHType d) pat++    iopts = setLocalEphemeral (dhBytesToPair =<< hskInitEphemeral    keys)+            . setLocalStatic  (dhBytesToPair =<< hskInitStatic       keys)+            . setRemoteStatic (dhBytesToPub  =<< hskInitRemoteStatic keys)+            $ idho++    ropts = setLocalEphemeral (dhBytesToPair =<< hskRespEphemeral    keys)+            . setLocalStatic  (dhBytesToPair =<< hskRespStatic       keys)+            . setRemoteStatic (dhBytesToPub  =<< hskRespRemoteStatic keys)+            $ rdho++toBench :: SomeCipherType+        -> SomeDHType+        -> SomeHashType+        -> PatternName+        -> [(ScrubbedBytes, ScrubbedBytes)]+toBench (WrapCipherType c) (WrapDHType d) (WrapHashType h) pat =+  genMessages swap ins rns (Just psk)+  where+    psk        = "This is my Austrian perspective!"+    swap       = pat /= PatternN && pat /= PatternK && pat /= PatternX &&+                 pat /= PatternNpsk0 && pat /= PatternKpsk0 && pat /= PatternXpsk1+    opts       = genOpts d pat+    (ins, rns) = genNoiseStates c h pat opts++allHandshakes :: [HandshakeName]+allHandshakes = do+  pattern <- [minBound .. maxBound]++  cipher  <- [ WrapCipherType AESGCM+             , WrapCipherType ChaChaPoly1305+             ]++  dh      <- [ WrapDHType Curve25519+             , WrapDHType Curve448+             ]++  hash    <- [ WrapHashType BLAKE2b+             , WrapHashType BLAKE2s+             , WrapHashType SHA256+             , WrapHashType SHA512+             ]++  return $ HandshakeName pattern cipher dh hash++main :: IO ()+main = do+  let benches = do+        hs <- allHandshakes+        let b   = toBench (hsCipher hs) (hsDH hs) (hsHash hs)+            pat = hsPatternName hs+        return $ bench (show hs) (nf b pat)++  defaultMain benches

@@ -1,83 +1,212 @@-{-# LANGUAGE RankNTypes, KindSignatures, GADTs #-}+{-# LANGUAGE RecordWildCards, RankNTypes, GADTs, KindSignatures #-} module Types where -import Data.ByteArray        (convert)-import Data.ByteString.Char8 (unpack)+import Data.Maybe  (fromMaybe)+import Data.Monoid ((<>))+import Data.Tuple  (swap) -import Crypto.Noise.Cipher+import Crypto.Noise import Crypto.Noise.Cipher.ChaChaPoly1305 import Crypto.Noise.Cipher.AESGCM-import Crypto.Noise.DH import Crypto.Noise.DH.Curve25519 import Crypto.Noise.DH.Curve448-import Crypto.Noise.Hash+import Crypto.Noise.HandshakePatterns import Crypto.Noise.Hash.SHA256 import Crypto.Noise.Hash.SHA512 import Crypto.Noise.Hash.BLAKE2s import Crypto.Noise.Hash.BLAKE2b -data HandshakeType = NoiseNN-                   | NoiseKN-                   | NoiseNK-                   | NoiseKK-                   | NoiseNX-                   | NoiseKX-                   | NoiseXN-                   | NoiseIN-                   | NoiseXK-                   | NoiseIK-                   | NoiseXX-                   | NoiseIX-                   | NoiseN-                   | NoiseK-                   | NoiseX-                   deriving Eq+data PatternName+  = PatternNN+  | PatternKN+  | PatternNK+  | PatternKK+  | PatternNX+  | PatternKX+  | PatternXN+  | PatternIN+  | PatternXK+  | PatternIK+  | PatternXX+  | PatternIX+  | PatternN+  | PatternK+  | PatternX+  | PatternNNpsk0+  | PatternNNpsk2+  | PatternNKpsk0+  | PatternNKpsk2+  | PatternNXpsk2+  | PatternXNpsk3+  | PatternXKpsk3+  | PatternXXpsk3+  | PatternKNpsk0+  | PatternKNpsk2+  | PatternKKpsk0+  | PatternKKpsk2+  | PatternKXpsk2+  | PatternINpsk1+  | PatternINpsk2+  | PatternIKpsk1+  | PatternIKpsk2+  | PatternIXpsk2+  | PatternNpsk0+  | PatternKpsk0+  | PatternXpsk1+  deriving (Eq, Enum, Bounded) +data HandshakeName = HandshakeName+  { hsPatternName :: PatternName+  , hsCipher      :: SomeCipherType+  , hsDH          :: SomeDHType+  , hsHash        :: SomeHashType+  }+ data CipherType :: * -> * where-  CTChaChaPoly1305 :: CipherType ChaChaPoly1305-  CTAESGCM         :: CipherType AESGCM+  ChaChaPoly1305 :: CipherType ChaChaPoly1305+  AESGCM         :: CipherType AESGCM  data SomeCipherType where   WrapCipherType :: forall c. Cipher c => CipherType c -> SomeCipherType  data DHType :: * -> * where-  DTCurve25519 :: DHType Curve25519-  DTCurve448   :: DHType Curve448+  Curve25519 :: DHType Curve25519+  Curve448   :: DHType Curve448  data SomeDHType where   WrapDHType :: forall d. DH d => DHType d -> SomeDHType  data HashType :: * -> * where-  HTSHA256  :: HashType SHA256-  HTSHA512  :: HashType SHA512-  HTBLAKE2s :: HashType BLAKE2s-  HTBLAKE2b :: HashType BLAKE2b+  BLAKE2b :: HashType BLAKE2b+  BLAKE2s :: HashType BLAKE2s+  SHA256  :: HashType SHA256+  SHA512  :: HashType SHA512  data SomeHashType where   WrapHashType :: forall h. Hash h => HashType h -> SomeHashType -instance Show HandshakeType where-  show NoiseNN = "NN"-  show NoiseKN = "KN"-  show NoiseNK = "NK"-  show NoiseKK = "KK"-  show NoiseNX = "NX"-  show NoiseKX = "KX"-  show NoiseXN = "XN"-  show NoiseIN = "IN"-  show NoiseXK = "XK"-  show NoiseIK = "IK"-  show NoiseXX = "XX"-  show NoiseIX = "IX"-  show NoiseN  = "N"-  show NoiseK  = "K"-  show NoiseX  = "X"+patternMap :: [(String, PatternName)]+patternMap =+  [ ("NN", PatternNN)+  , ("KN", PatternKN)+  , ("NK", PatternNK)+  , ("KK", PatternKK)+  , ("NX", PatternNX)+  , ("KX", PatternKX)+  , ("XN", PatternXN)+  , ("IN", PatternIN)+  , ("XK", PatternXK)+  , ("IK", PatternIK)+  , ("XX", PatternXX)+  , ("IX", PatternIX)+  , ("N" , PatternN)+  , ("K" , PatternK)+  , ("X" , PatternX)+  , ("NNpsk0", PatternNNpsk0)+  , ("NNpsk2", PatternNNpsk2)+  , ("NKpsk0", PatternNKpsk0)+  , ("NKpsk2", PatternNKpsk2)+  , ("NXpsk2", PatternNXpsk2)+  , ("XNpsk3", PatternXNpsk3)+  , ("XKpsk3", PatternXKpsk3)+  , ("XXpsk3", PatternXXpsk3)+  , ("KNpsk0", PatternKNpsk0)+  , ("KNpsk2", PatternKNpsk2)+  , ("KKpsk0", PatternKKpsk0)+  , ("KKpsk2", PatternKKpsk2)+  , ("KXpsk2", PatternKXpsk2)+  , ("INpsk1", PatternINpsk1)+  , ("INpsk2", PatternINpsk2)+  , ("IKpsk1", PatternIKpsk1)+  , ("IKpsk2", PatternIKpsk2)+  , ("IXpsk2", PatternIXpsk2)+  , ("Npsk0" , PatternNpsk0)+  , ("Kpsk0" , PatternKpsk0)+  , ("Xpsk1" , PatternXpsk1)+  ] -instance Cipher c => Show (CipherType c) where-  show = unpack . convert . cipherName+dhMap :: [(String, SomeDHType)]+dhMap =+  [ ("25519", WrapDHType Curve25519)+  , ("448"  , WrapDHType Curve448)+  ] -instance DH d => Show (DHType d) where-  show = unpack . convert . dhName+cipherMap :: [(String, SomeCipherType)]+cipherMap =+  [ ("AESGCM"    , WrapCipherType AESGCM)+  , ("ChaChaPoly", WrapCipherType ChaChaPoly1305)+  ] -instance Hash h => Show (HashType h) where-  show = unpack . convert . hashName+hashMap :: [(String, SomeHashType)]+hashMap =+  [ ("BLAKE2b", WrapHashType BLAKE2b)+  , ("BLAKE2s", WrapHashType BLAKE2s)+  , ("SHA256" , WrapHashType SHA256)+  , ("SHA512" , WrapHashType SHA512)+  ]++patternToHandshake :: PatternName+                   -> HandshakePattern+patternToHandshake PatternNN = noiseNN+patternToHandshake PatternKN = noiseKN+patternToHandshake PatternNK = noiseNK+patternToHandshake PatternKK = noiseKK+patternToHandshake PatternNX = noiseNX+patternToHandshake PatternKX = noiseKX+patternToHandshake PatternXN = noiseXN+patternToHandshake PatternIN = noiseIN+patternToHandshake PatternXK = noiseXK+patternToHandshake PatternIK = noiseIK+patternToHandshake PatternXX = noiseXX+patternToHandshake PatternIX = noiseIX+patternToHandshake PatternN  = noiseN+patternToHandshake PatternK  = noiseK+patternToHandshake PatternX  = noiseX+patternToHandshake PatternNNpsk0 = noiseNNpsk0+patternToHandshake PatternNNpsk2 = noiseNNpsk2+patternToHandshake PatternNKpsk0 = noiseNKpsk0+patternToHandshake PatternNKpsk2 = noiseNKpsk2+patternToHandshake PatternNXpsk2 = noiseNXpsk2+patternToHandshake PatternXNpsk3 = noiseXNpsk3+patternToHandshake PatternXKpsk3 = noiseXKpsk3+patternToHandshake PatternXXpsk3 = noiseXXpsk3+patternToHandshake PatternKNpsk0 = noiseKNpsk0+patternToHandshake PatternKNpsk2 = noiseKNpsk2+patternToHandshake PatternKKpsk0 = noiseKKpsk0+patternToHandshake PatternKKpsk2 = noiseKKpsk2+patternToHandshake PatternKXpsk2 = noiseKXpsk2+patternToHandshake PatternINpsk1 = noiseINpsk1+patternToHandshake PatternINpsk2 = noiseINpsk2+patternToHandshake PatternIKpsk1 = noiseIKpsk1+patternToHandshake PatternIKpsk2 = noiseIKpsk2+patternToHandshake PatternIXpsk2 = noiseIXpsk2+patternToHandshake PatternNpsk0  = noiseNpsk0+patternToHandshake PatternKpsk0  = noiseKpsk0+patternToHandshake PatternXpsk1  = noiseXpsk1++instance Show HandshakeName where+  show HandshakeName{..} = "Noise_"+                          <> show hsPatternName+                          <> "_"+                          <> show hsDH+                          <> "_"+                          <> show hsCipher+                          <> "_"+                          <> show hsHash++instance Show PatternName where+  show = fromMaybe "unknown" . flip lookup (fmap swap patternMap)++instance Show SomeCipherType where+  show (WrapCipherType ChaChaPoly1305) = "ChaChaPoly"+  show (WrapCipherType AESGCM)         = "AESGCM"++instance Show SomeDHType where+  show (WrapDHType Curve25519) = "25519"+  show (WrapDHType Curve448)   = "448"++instance Show SomeHashType where+  show (WrapHashType BLAKE2b) = "BLAKE2b"+  show (WrapHashType BLAKE2s) = "BLAKE2s"+  show (WrapHashType SHA256)  = "SHA256"+  show (WrapHashType SHA512)  = "SHA512"

@@ -1,142 +0,0 @@-{-# LANGUAGE OverloadedStrings, GADTs #-}-module Main where--import Criterion.Main-import Data.ByteArray         (ScrubbedBytes, convert)-import Data.ByteString        (ByteString)-import Data.ByteString.Base16 (decode)-import Data.List              (replicate)-import Data.Maybe             (fromJust)-import Data.Monoid            ((<>))-import Prelude hiding         (replicate)--import Crypto.Noise-import Crypto.Noise.Cipher-import Crypto.Noise.DH-import Crypto.Noise.Hash--import Handshakes-import Types--hexToScrubbedBytes :: ByteString-                   -> ScrubbedBytes-hexToScrubbedBytes = convert . fst . decode--hexToPair :: DH d-          => ByteString-          -> KeyPair d-hexToPair = fromJust . dhBytesToPair . convert . fst . decode--initiatorEphemeral :: DH d-                   => DHType d-                   -> KeyPair d-initiatorEphemeral DTCurve25519 = hexToPair "893e28b9dc6ca8d611ab664754b8ceb7bac5117349a4439a6b0569da977c464a"-initiatorEphemeral DTCurve448 = hexToPair "7fd26c8b8a0d5c98c85ff9ca1d7bc66d78578b9f2c4c170850748b27992767e6ea6cc9992a561c9d19dfc342e260c280ef4f3f9b8f879d4e"--responderEphemeral :: DH d-                   => DHType d-                   -> KeyPair d-responderEphemeral DTCurve25519 = hexToPair "bbdb4cdbd309f1a1f2e1456967fe288cadd6f712d65dc7b7793d5e63da6b375b"-responderEphemeral DTCurve448 = hexToPair "3facf7503ebee252465689f1d4e3b1dd219639ef9de4ffd6049d6d71a0f62126840febb99042421ce12af6626d98d9170260390fbc8399a5"--initiatorStatic :: DH d-                => DHType d-                -> KeyPair d-initiatorStatic DTCurve25519 = hexToPair "e61ef9919cde45dd5f82166404bd08e38bceb5dfdfded0a34c8df7ed542214d1"-initiatorStatic DTCurve448 = hexToPair "34d564c4be963d1b2a89fcfe83e6a72b5e3f5e3127f9f596ffc7575e418dfc1f4e827cfc10c9fed38e92ad56ddf8f08571430df2e76d5411"--responderStatic :: DH d-                => DHType d-                -> KeyPair d-responderStatic DTCurve25519 = hexToPair "4a3acbfdb163dec651dfa3194dece676d437029c62a408b4c5ea9114246e4893"-responderStatic DTCurve448 = hexToPair "a9b45971180882a79b89a3399544a425ef8136d278efa443ed67d3ff9d36e883bc330c6295bbf6ed73ff6fd10cbed767ad05ce03ebd27c7c"--mkKeys :: DH d-       => ScrubbedBytes-       -> Maybe ScrubbedBytes-       -> Bool-       -> DHType d-       -> HandshakeKeys d-mkKeys pro psk i d =-  HandshakeKeys { hkPrologue       = pro-                , hkPSK            = psk-                , hkLocalStatic    = if i then initiatorStatic d else responderStatic d-                , hkLocalEphemeral = if i then initiatorEphemeral d else responderEphemeral d-                , hkRemoteStatic   = if i then (snd . responderStatic) d else (snd . initiatorStatic) d-                }--mkHandshakeName :: HandshakeType-                -> Maybe ScrubbedBytes-                -> SomeCipherType-                -> SomeDHType-                -> SomeHashType-                -> String-mkHandshakeName pat psk (WrapCipherType c) (WrapDHType d) (WrapHashType h) =-  maybe "Noise_" (const "NoisePSK_") psk <>-  show pat                               <>-  "_"                                    <>-  show d                                 <>-  "_"                                    <>-  show c                                 <>-  "_"                                    <>-  show h--genMessages :: (Cipher c, DH d, Hash h)-            => Bool-            -> NoiseState c d h-            -> NoiseState c d h-            -> [ScrubbedBytes]-            -> [(ScrubbedBytes, ScrubbedBytes)]-genMessages swap = go []-  where-    go acc _ _ [] = acc-    go acc sendingState receivingState (payload : rest) =-      let writeResult           = writeMessage sendingState payload-          (ct, sendingState')   = either (error "write failed") id writeResult-          (dp, receivingState') = either (error "read failed")-                                         id-                                         $ readMessage receivingState ct in-      if swap-        then go (acc <> [(payload, dp)]) receivingState' sendingState' rest-        else go (acc <> [(payload, dp)]) sendingState' receivingState' rest--mkBench :: (HandshakeType, Int)-        -> Maybe ScrubbedBytes-        -> SomeCipherType-        -> SomeDHType-        -> SomeHashType-        -> [(ScrubbedBytes, ScrubbedBytes)]-mkBench (pat, numMsgs) psk (WrapCipherType c) (WrapDHType d) (WrapHashType h) =-  let ihk = mkKeys "" psk True d-      rhk = mkKeys "" psk False d-      ins = mkNoiseState ihk pat InitiatorRole c h-      rns = mkNoiseState rhk pat ResponderRole c h-      swap = not (pat == NoiseN || pat == NoiseK || pat == NoiseX) in--  genMessages swap ins rns $ replicate numMsgs ""--main :: IO ()-main = do-  let patterns = [ (NoiseNN, 2)-                 , (NoiseKN, 2)-                 , (NoiseNK, 2)-                 , (NoiseKK, 2)-                 , (NoiseNX, 2)-                 , (NoiseKX, 2)-                 , (NoiseXN, 3)-                 , (NoiseIN, 2)-                 , (NoiseXK, 3)-                 , (NoiseIK, 2)-                 , (NoiseXX, 3)-                 , (NoiseIX, 2)-                 , (NoiseN, 1)-                 , (NoiseK, 1)-                 , (NoiseX, 1)-                 ]-      psks     = [Nothing, Just "This is my Austrian perspective!"]-      ciphers  = [WrapCipherType CTChaChaPoly1305, WrapCipherType CTAESGCM]-      dhs      = [WrapDHType DTCurve25519, WrapDHType DTCurve448]-      hashes   = [WrapHashType HTSHA256, WrapHashType HTSHA512, WrapHashType HTBLAKE2s, WrapHashType HTBLAKE2b]-      benches  = [bench (mkHandshakeName pat psk c d h) (nf (mkBench patPair psk c d) h) | patPair@(pat, _) <- patterns, psk <- psks, c <- ciphers, d <- dhs, h <- hashes]--  defaultMain benches

@@ -1,247 +1,163 @@-name:          cacophony-version:       0.9.2-synopsis:      A library implementing the Noise protocol.-license:       PublicDomain-license-file:  LICENSE-author:        John Galt-maintainer:    jgalt@centromere.net-homepage:      https://github.com/centromere/cacophony-bug-reports:   https://github.com/centromere/cacophony/issues-category:      Cryptography-build-type:    Simple-cabal-version: >=1.10-tested-with:   GHC == 7.10.3, GHC == 8.0.2-description:-  This library implements the <https://github.com/trevp/noise/blob/master/noise.md Noise>-  protocol.+-- This file has been generated from package.yaml by hpack version 0.17.0.+--+-- see: https://github.com/sol/hpack +name:           cacophony+version:        0.10.0+synopsis:       A library implementing the Noise protocol.+description:    This library implements the <https://noiseprotocol.org Noise> protocol.+category:       Cryptography+homepage:       https://github.com/centromere/cacophony#readme+bug-reports:    https://github.com/centromere/cacophony/issues+maintainer:     John Galt <jgalt@centromere.net>+license:        PublicDomain+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10+ extra-source-files:-  .travis.yml-  README.md-  changelog.md-  LICENSE-  tests/.hlint-  tools/convert_vectors.py-  tools/run_benchmarks.sh-  tools/vector_template.jinja-  vectors/cacophony.txt-  vectors/noise-c-basic.txt+    .travis.yml+    changelog.md+    LICENSE+    package.yaml+    README.md+    stack.yaml+    tests/.hlint+    tools/pretty-print/format-vectors.py+    tools/pretty-print/vector-template.jinja+    vectors/cacophony.txt  source-repository head   type: git-  location: https://github.com/centromere/cacophony.git------------------------------------------------------------------------------------- FLAGS--flag hlint-  description: Build hlint test--flag vectors-  description: Build vector test+  location: https://github.com/centromere/cacophony -flag build-examples-  description: Build example executables-  default: False+flag build-tools+  description: Build tools   manual: True--flag llvm   default: False-  manual: True ------------------------------------------------------------------------------------ LIBRARY- library+  hs-source-dirs:+      src+  default-extensions: OverloadedStrings+  ghc-options: -Wall   build-depends:-    base       >=4.8 && <5,-    bytestring,-    cryptonite >=0.16,-    exceptions >=0.8.3,-    free,-    lens,-    memory     >=0.14,-    monad-coroutine,-    mtl,-    safe-exceptions,-    transformers-  hs-source-dirs:   src-  default-language: Haskell2010+      base >= 4.9 && < 4.10+    , bytestring+    , cryptonite+    , exceptions+    , free+    , lens+    , memory+    , monad-coroutine+    , mtl+    , safe-exceptions+    , transformers   exposed-modules:-    Crypto.Noise-    Crypto.Noise.Cipher-    Crypto.Noise.Cipher.AESGCM-    Crypto.Noise.Cipher.ChaChaPoly1305-    Crypto.Noise.DH-    Crypto.Noise.DH.Curve25519-    Crypto.Noise.DH.Curve448-    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.HandshakePattern-    Crypto.Noise.Internal.Handshake-    Crypto.Noise.Internal.NoiseState-    Crypto.Noise.Internal.SymmetricState-    Crypto.Noise.Internal.Types-  ghc-options:      -Wall -fwarn-tabs--  if flag(llvm)-    ghc-options: -fllvm------------------------------------------------------------------------------------- EXAMPLES--executable echo-server-  default-language: Haskell2010-  hs-source-dirs:   examples/echo-server-  main-is:          Main.hs--  if flag(build-examples)-    build-depends:-      aeson,-      attoparsec,-      auto-update,-      base               >=4.8 && <5,-      base16-bytestring,-      base64-bytestring,-      bytestring,-      cacophony,-      directory,-      fast-logger,-      lens,-      memory             >=0.14,-      network,-      network-simple,-      unix,-      unix-time-  else-    buildable: False-+      Crypto.Noise+      Crypto.Noise.Cipher+      Crypto.Noise.Cipher.AESGCM+      Crypto.Noise.Cipher.ChaChaPoly1305+      Crypto.Noise.DH+      Crypto.Noise.DH.Curve25519+      Crypto.Noise.DH.Curve448+      Crypto.Noise.Exception+      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.Handshake.Interpreter+      Crypto.Noise.Internal.Handshake.Pattern+      Crypto.Noise.Internal.Handshake.State+      Crypto.Noise.Internal.Handshake.Validation+      Crypto.Noise.Internal.NoiseState+      Crypto.Noise.Internal.SymmetricState+      Crypto.Noise.Validation   other-modules:-    Handshakes-    Log-    Parse-    Server-    Types--  ghc-options:      -threaded -O2 -rtsopts -with-rtsopts=-N -Wall -fwarn-tabs--  if flag(llvm)-    ghc-options: -fllvm--executable echo-client+      Paths_cacophony   default-language: Haskell2010-  hs-source-dirs:   examples/echo-client-  main-is:          Main.hs -  if flag(build-examples)+executable noise-repl+  main-is: Main.hs+  hs-source-dirs:+      tools/noise-repl+  default-extensions: OverloadedStrings+  ghc-options: -Wall -O2 -rtsopts -threaded -with-rtsopts=-N+  if flag(build-tools)     build-depends:-      attoparsec,-      base               >=4.8 && <5,-      base16-bytestring,-      base64-bytestring,-      bytestring,-      cacophony,-      directory,-      lens,-      memory             >=0.14,-      network,-      network-simple,-      unix+        attoparsec+      , base+      , base16-bytestring+      , base64-bytestring+      , bytestring+      , cacophony+      , haskeline+      , network+      , process   else     buildable: False-   other-modules:-    Client-    Parse--  ghc-options:      -threaded -O2 -rtsopts -with-rtsopts=-N -Wall -fwarn-tabs--  if flag(llvm)-    ghc-options: -fllvm------------------------------------------------------------------------------------- TESTS+      Client+      Options+      Pipe+      Socket+      Types+  default-language: Haskell2010  test-suite hlint-  type:             exitcode-stdio-1.0-  main-is:          hlint.hs-  ghc-options:      -Wall -fwarn-tabs-  hs-source-dirs:   tests/hlint+  type: exitcode-stdio-1.0+  main-is: hlint.hs+  hs-source-dirs:+      tests/hlint+  ghc-options: -Wall -O2 -rtsopts -threaded -with-rtsopts=-N+  build-depends:+      base >= 4.9 && < 4.10+    , hlint   default-language: Haskell2010 -  if !flag(hlint)-    buildable: False-  else-    build-depends:-      base  >=4.8 && <5,-      hlint--  if flag(llvm)-    ghc-options: -fllvm- test-suite vectors-  type:             exitcode-stdio-1.0-  main-is:          vectors.hs-  ghc-options:      -threaded -O2 -rtsopts -with-rtsopts=-N -Wall -fwarn-tabs-  hs-source-dirs:   tests/vectors-  default-language: Haskell2010--  if !flag(vectors)-    buildable: False-  else-    build-depends:-      aeson,-      async,-      base              >=4.8 && <5,-      base16-bytestring,-      bytestring,-      cacophony,-      directory,-      free,-      lens,-      memory            >=0.14,-      mtl,-      text-+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+      tests/vectors+  default-extensions: OverloadedStrings+  ghc-options: -Wall -O2 -rtsopts -threaded -with-rtsopts=-N+  build-depends:+      aeson+    , attoparsec+    , base >= 4.9 && < 4.10+    , base16-bytestring+    , bytestring+    , cacophony+    , directory+    , text   other-modules:-    Generate,-    Handshakes,-    Types-    VectorFile,-    Verify--  if flag(llvm)-    ghc-options: -fllvm------------------------------------------------------------------------------------- BENCHMARKS--benchmark bench-  type:             exitcode-stdio-1.0-  main-is:          bench.hs-  ghc-options:      -threaded -O2 -rtsopts -with-rtsopts=-N -Wall -fwarn-tabs-  hs-source-dirs:   benchmarks+      Generate+      Keys+      Types+      VectorFile+      Verify   default-language: Haskell2010 +benchmark bench+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+      benchmarks+  default-extensions: OverloadedStrings+  ghc-options: -Wall -O2 -rtsopts -threaded -with-rtsopts=-N   build-depends:-    async,-    base               >=4.8 && <5,-    base16-bytestring,-    bytestring,-    cacophony,-    criterion,-    deepseq,-    lens,-    memory             >=0.14-+      async+    , base >= 4.9 && < 4.10+    , base16-bytestring+    , bytestring+    , cacophony+    , criterion+    , deepseq   other-modules:-    Handshakes-    Types--  if flag(llvm)-    ghc-options: -fllvm+      Keys+      Types+  default-language: Haskell2010

@@ -1,3 +1,13 @@+# 0.10.0++* Completely refactored API++* Added rev32 support++* Removed examples because they are difficult to maintain++* Added noise-repl tool+ # 0.9.2  * Added ability to export raw symmetric keys

@@ -1,92 +0,0 @@-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}-module Client-  ( runClient-  ) where--import Control.Lens           ((.~), (&))-import Data.Bits              ((.&.), shiftR)-import Data.ByteArray         (ScrubbedBytes, convert)-import Data.ByteString        (ByteString, pack, length)-import qualified Data.ByteString.Char8 as C8 (pack, unpack)-import Data.ByteString.Base16 (encode)-import Data.IORef-import Data.Monoid            ((<>))-import Network.Simple.TCP-import Prelude hiding         (length)--import Crypto.Noise-import Crypto.Noise.Cipher-import Crypto.Noise.Cipher.AESGCM-import Crypto.Noise.DH-import Crypto.Noise.HandshakePatterns (noiseIK)-import Crypto.Noise.Hash-import Crypto.Noise.Hash.SHA256--import Parse--prependLength :: ByteString-              -> ByteString-prependLength msg = pack w16len <> msg-  where-    len    = length msg-    w16len = fmap fromIntegral [(len .&. 0xFF00) `shiftR` 8, len .&. 0xFF]--writeSocket :: Socket-            -> ByteString-            -> IO ()-writeSocket s msg = send s $ prependLength msg--messageLoop :: (Cipher c, DH d, Hash h)-            => IORef ByteString-            -> Socket-            -> NoiseState c d h-            -> IO ()-messageLoop bufRef sock = loop-  where-    loop ns = do-      msg <- convert . C8.pack <$> getLine--      let (ct, ns') = either (error . show) id $ writeMessage ns msg-      writeSocket sock ct--      maybeMessage <- parseSocket bufRef sock messageParser-      case maybeMessage of-        Nothing -> return ()-        Just m  -> do-          let (pt, ns'')  = either (error . show) id $ readMessage ns' m-          putStrLn . ("received: " <>) . C8.unpack . convert $ pt--          loop ns''--runClient :: forall d. DH d-          => String-          -> String-          -> Maybe ScrubbedBytes-          -> KeyPair d-          -> PublicKey d-          -> IO ()-runClient hostname port psk localKey remoteKey =-  connect hostname port $ \(sock, _) -> do-    leftoverBufRef <- newIORef ""--    lek <- dhGenKey :: IO (KeyPair d)--    let dho = defaultHandshakeOpts noiseIK InitiatorRole-        hdr = maybe "\x00\x09\x01\x00\x00" (const "\x01\x09\x01\x00\x00") psk-        ho  = dho & hoPrologue       .~ convert hdr-                  & hoPreSharedKey   .~ psk-                  & hoLocalStatic    .~ Just localKey-                  & hoLocalEphemeral .~ Just lek-                  & hoRemoteStatic   .~ Just remoteKey--        ns :: NoiseState AESGCM d SHA256-        ns = noiseState ho--    putStrLn $ "private ephemeral: " <> (C8.unpack . encode . convert . dhSecToBytes . fst) lek--    send sock hdr-    putStrLn "connection established, begin typing"--    messageLoop leftoverBufRef sock ns--    putStrLn "connection closed"

@@ -1,98 +0,0 @@-{-# LANGUAGE RecordWildCards, OverloadedStrings #-}-module Main where--import Control.Monad         (forM_, (<=<))-import Data.ByteArray        (ScrubbedBytes, convert)-import Data.ByteString       (writeFile, readFile)-import qualified Data.ByteString.Base64 as B64 (encode, decodeLenient)-import Data.Maybe            (fromMaybe)-import Data.Monoid           ((<>))-import Prelude hiding        (writeFile, readFile)-import System.Console.GetOpt-import System.Directory      (doesFileExist)-import System.Environment-import System.IO             (stderr, hPutStr, hPutStrLn)--import Crypto.Noise.DH-import Crypto.Noise.DH.Curve25519-import Crypto.Noise.DH.Curve448--import Client--data Options =-  Options { optShowHelp :: Bool-          , optPSK      :: Maybe FilePath-          }--defaultOptions :: Options-defaultOptions =-  Options { optShowHelp = False-          , optPSK      = Nothing-          }--options :: [OptDescr (Options -> Options)]-options =-  [ Option ['h'] ["help"]-    (NoArg (\o -> o { optShowHelp = True }))-    "show help"-  , Option [] ["psk"]-    (ReqArg (\p o -> o { optPSK = Just p }) "FILE")-    "pre-shared key (base64 encoded file, default: off)"-  ]--parseOptions :: [String] -> Either [String] (Options, [String])-parseOptions argv =-  case getOpt Permute options argv of-    (o, n, [])   -> Right (foldl (flip id) defaultOptions o, n)-    (_, _, errs) -> Left errs--usageHeader :: String-usageHeader = "Usage: echo-server [OPTION] HOSTNAME PORT"--processOptions :: (Options, [String]) -> IO ()-processOptions (Options{..}, [hostname, port]) = do-  localKey <- processPrivateKey "client_key_25519" :: IO (KeyPair Curve25519)-  _ <- processPrivateKey "client_key_448" :: IO (KeyPair Curve448)-  remoteKey <- readPublicKey "server_key_25519.pub" :: IO (PublicKey Curve25519)-  psk <- maybe (return Nothing) (return . Just <=< readPSK) optPSK-  runClient hostname port psk localKey remoteKey--processOptions (_, _) = do-  hPutStrLn stderr "error: a hostname and port must be specified"-  hPutStr stderr $ usageInfo usageHeader options--readPrivateKey :: DH d => FilePath -> IO (KeyPair d)-readPrivateKey f = fromMaybe (error $ "error importing " <> f) . dhBytesToPair . convert <$> readFile f--readPublicKey :: DH d => FilePath -> IO (PublicKey d)-readPublicKey f = (fromMaybe (error $ "error importing " <> f) . dhBytesToPub . convert . B64.decodeLenient) <$> readFile f--readPSK :: FilePath -> IO ScrubbedBytes-readPSK f = convert . B64.decodeLenient <$> readFile f--genAndWriteKey :: DH d => FilePath -> IO (KeyPair d)-genAndWriteKey f = do-  pair@(sec, pub) <- dhGenKey-  writeFile f $ (convert . dhSecToBytes) sec-  writeFile (f <> ".pub") $ (B64.encode . convert . dhPubToBytes) pub-  return pair--processPrivateKey :: DH d => FilePath -> IO (KeyPair d)-processPrivateKey f = do-  exists <- doesFileExist f-  if exists-    then readPrivateKey f-    else genAndWriteKey f--main :: IO ()-main = do-  argv <- getArgs-  let opts = parseOptions argv-  case opts of-    Left errs -> do-      forM_ errs (hPutStr stderr)-      hPutStr stderr $ usageInfo usageHeader options-    Right o ->-      if optShowHelp . fst $ o-        then putStr $ usageInfo usageHeader options-        else processOptions o

@@ -1,26 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Parse where--import Data.Attoparsec.ByteString (Parser, IResult(..), anyWord8, take, parseWith)-import Data.Bits                  ((.|.), shiftL)-import Data.ByteString            (ByteString)-import Data.IORef-import Data.Maybe                 (fromMaybe)-import Data.Monoid                ((<>))-import Network.Simple.TCP         (Socket, recv)-import Prelude hiding             (take)--messageParser :: Parser ByteString-messageParser = do-  l0 <- fromIntegral <$> anyWord8-  l1 <- fromIntegral <$> anyWord8-  take (l0 `shiftL` 8 .|. l1)--parseSocket :: IORef ByteString -> Socket -> Parser a -> IO (Maybe a)-parseSocket bufRef sock p = do-  buf <- readIORef bufRef-  result <- parseWith (fromMaybe "" <$> recv sock 2048) p buf-  case result of-    Fail{} -> return Nothing-    (Partial _)  -> return Nothing-    (Done i r)   -> modifyIORef' bufRef (<> i) >> return (Just r)

@@ -1,187 +0,0 @@-{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}-module Handshakes where--import Control.Lens--import Crypto.Noise-import Crypto.Noise.Cipher-import Crypto.Noise.DH-import Crypto.Noise.Hash-import Crypto.Noise.HandshakePatterns--import Types--data HandshakeKeys d =-  HandshakeKeys { hkPrologue       :: Plaintext-                , hkPSK            :: Maybe Plaintext-                , hkLocalStatic    :: KeyPair d-                , hkLocalEphemeral :: KeyPair d-                , hkRemoteStatic   :: PublicKey d-                }--mkNoiseState :: forall c d h. (Cipher c, DH d, Hash h)-             => HandshakeKeys d-             -> HandshakeType-             -> HandshakeRole-             -> CipherType c-             -> HashType h-             -> NoiseState c d h-mkNoiseState HandshakeKeys{..} NoiseNN r _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseNN r :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseKN InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseKN InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseKN ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseKN ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoRemoteStatic   .~ Just hkRemoteStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseNK InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseNK InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoRemoteStatic   .~ Just hkRemoteStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseNK ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseNK ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseKK r _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseKK r :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoRemoteStatic   .~ Just hkRemoteStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseNX InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseNX InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseNX ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseNX ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseKX InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseKX InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseKX ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseKX ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoRemoteStatic   .~ Just hkRemoteStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseXN InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseXN InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseXN ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseXN ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseIN InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseIN InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseIN ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseIN ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseXK InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseXK InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoRemoteStatic   .~ Just hkRemoteStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseXK ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseXK ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseIK InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseIK InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoRemoteStatic   .~ Just hkRemoteStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseIK ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseIK ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseXX r _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseXX r :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseIX r _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseIX r :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral

@@ -1,51 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Log where--import Control.Exception     (SomeException, displayException)-import Data.Aeson            (encode, object, (.=))-import Data.ByteString       (ByteString)-import Data.ByteString.Char8 (unpack)-import Data.Monoid           ((<>))-import Data.UnixTime         (formatUnixTime, fromEpochTime)-import Network.Socket        (SockAddr)-import System.Log.FastLogger (toLogStr, pushLogStr, LoggerSet, newFileLoggerSet,-                              newStdoutLoggerSet)-import System.Posix          (epochTime)-import System.Posix.Files    (setFileCreationMask)--openLog :: FilePath -> IO LoggerSet-openLog file = do-  _ <- setFileCreationMask 0o000-  newFileLoggerSet 1024 file--openStdOut :: IO LoggerSet-openStdOut = newStdoutLoggerSet 0--logMsg :: LoggerSet-       -> IO ByteString-       -> SockAddr-       -> ByteString-       -> IO ()-logMsg ls getCachedDate ip msg = do-  zdt <- getCachedDate-  (pushLogStr ls . toLogStr) . (<> "\n") . encode $-    object [ "date"    .= unpack zdt-           , "message" .= unpack msg-           , "ip"      .= show ip-           ]--logException :: LoggerSet-             -> IO ByteString-             -> SockAddr-             -> SomeException-             -> IO ()-logException ls getCachedDate ip ex = do-  zdt <- getCachedDate-  (pushLogStr ls . toLogStr) . (<> "\n") . encode $-    object [ "date"      .= unpack zdt-           , "exception" .= displayException ex-           , "ip"        .= show ip-           ]--getDateTime :: IO ByteString-getDateTime = epochTime >>= formatUnixTime "%Y-%m-%d %H:%M:%S %z" . fromEpochTime

@@ -1,106 +0,0 @@-{-# LANGUAGE RecordWildCards, OverloadedStrings #-}-module Main where--import Control.Monad         (forM_)-import Data.ByteArray        (ScrubbedBytes, convert)-import Data.ByteString       (writeFile, readFile)-import qualified Data.ByteString.Base64 as B64 (encode, decodeLenient)-import Data.Maybe            (fromMaybe)-import Data.Monoid           ((<>))-import Prelude hiding        (writeFile, readFile)-import System.Console.GetOpt-import System.Directory      (doesFileExist)-import System.Environment-import System.IO             (stderr, hPutStr, hPutStrLn)--import Crypto.Noise.DH--import Server-import Types--data Options =-  Options { optShowHelp :: Bool-          , optLogFile  :: Maybe FilePath-          }--defaultOptions :: Options-defaultOptions =-  Options { optShowHelp = False-          , optLogFile  = Nothing-          }--options :: [OptDescr (Options -> Options)]-options =-  [ Option ['h'] ["help"]-    (NoArg (\o -> o { optShowHelp = True }))-    "show help"-  , Option ['l'] []-    (ReqArg (\f o -> o { optLogFile = Just f }) "FILE")-    "log output to file (default: stdout)"-  ]--parseOptions :: [String] -> Either [String] (Options, [String])-parseOptions argv =-  case getOpt Permute options argv of-    (o, n, [])   -> Right (foldl (flip id) defaultOptions o, n)-    (_, _, errs) -> Left errs--usageHeader :: String-usageHeader = "Usage: echo-server [OPTION] PORT PSK_FILE"--processOptions :: (Options, [String]) -> IO ()-processOptions (Options{..}, [port, pskFile]) = do-  local25519 <- processPrivateKey "server_key_25519"-  local448 <- processPrivateKey "server_key_448"-  remote25519 <- readPublicKey "client_key_25519.pub"-  remote448 <- readPublicKey "client_key_448.pub"-  psk <- readPSK pskFile--  startServer ServerOpts { soLogFile     = optLogFile-                         , soPort        = port-                         , soPSK         = psk-                         , soLocal25519  = local25519-                         , soRemote25519 = remote25519-                         , soLocal448    = local448-                         , soRemote448   = remote448-                         }--processOptions _ = do-  hPutStrLn stderr "error: a port and base64 encoded PSK file must be specified"-  hPutStr stderr $ usageInfo usageHeader options--readPrivateKey :: DH d => FilePath -> IO (KeyPair d)-readPrivateKey f = fromMaybe (error $ "error importing " <> f) . dhBytesToPair . convert <$> readFile f--readPublicKey :: DH d => FilePath -> IO (PublicKey d)-readPublicKey f = (fromMaybe (error $ "error importing " <> f) . dhBytesToPub . convert . B64.decodeLenient) <$> readFile f--readPSK :: FilePath -> IO ScrubbedBytes-readPSK f = convert . B64.decodeLenient <$> readFile f--genAndWriteKey :: DH d => FilePath -> IO (KeyPair d)-genAndWriteKey f = do-  pair@(sec, pub) <- dhGenKey-  writeFile f $ (convert . dhSecToBytes) sec-  writeFile (f <> ".pub") $ (B64.encode . convert . dhPubToBytes) pub-  return pair--processPrivateKey :: DH d => FilePath -> IO (KeyPair d)-processPrivateKey f = do-  exists <- doesFileExist f-  if exists-    then readPrivateKey f-    else genAndWriteKey f--main :: IO ()-main = do-  argv <- getArgs-  let opts = parseOptions argv-  case opts of-    Left errs -> do-      forM_ errs (hPutStr stderr)-      hPutStr stderr $ usageInfo usageHeader options-    Right o ->-      if optShowHelp . fst $ o-        then putStr $ usageInfo usageHeader options-        else processOptions o

@@ -1,116 +0,0 @@-{-# LANGUAGE OverloadedStrings, GADTs #-}-module Parse where--import Data.Attoparsec.ByteString (Parser, IResult(..), satisfy, anyWord8, take, parseWith)-import Data.Bits                  ((.|.), shiftL)-import Data.ByteString            (ByteString, pack)-import Data.IORef-import Data.Maybe                 (fromMaybe)-import Data.Monoid                ((<>))-import Data.Word                  (Word8)-import Network.Simple.TCP         (Socket, recv)-import Prelude hiding             (take)--import Types--serializeHeader :: Header-                -> ByteString-serializeHeader (psk, hp, ct, dt, ht) =-  pack [pskByte psk, hpByte hp, ctByte ct, dtByte dt, htByte ht]-  where-    pskByte False = 0-    pskByte True  = 1-    hpByte NoiseNN = 0-    hpByte NoiseKN = 1-    hpByte NoiseNK = 2-    hpByte NoiseKK = 3-    hpByte NoiseNX = 4-    hpByte NoiseKX = 5-    hpByte NoiseXN = 6-    hpByte NoiseIN = 7-    hpByte NoiseXK = 8-    hpByte NoiseIK = 9-    hpByte NoiseXX = 10-    hpByte NoiseIX = 11-    ctByte :: SomeCipherType -> Word8-    ctByte (WrapCipherType CTChaChaPoly1305) = 0-    ctByte (WrapCipherType CTAESGCM)         = 1-    dtByte :: SomeDHType -> Word8-    dtByte (WrapDHType DTCurve25519) = 0-    dtByte (WrapDHType DTCurve448)   = 1-    htByte :: SomeHashType -> Word8-    htByte (WrapHashType HTSHA256)  = 0-    htByte (WrapHashType HTSHA512)  = 1-    htByte (WrapHashType HTBLAKE2s) = 2-    htByte (WrapHashType HTBLAKE2b) = 3--pskByteToBool :: Word8 -> Bool-pskByteToBool 0 = False-pskByteToBool 1 = True-pskByteToBool _ = error "invalid PSK setting"--handshakeByteToType :: Word8 -> HandshakeType-handshakeByteToType 0  = NoiseNN-handshakeByteToType 1  = NoiseKN-handshakeByteToType 2  = NoiseNK-handshakeByteToType 3  = NoiseKK-handshakeByteToType 4  = NoiseNX-handshakeByteToType 5  = NoiseKX-handshakeByteToType 6  = NoiseXN-handshakeByteToType 7  = NoiseIN-handshakeByteToType 8  = NoiseXK-handshakeByteToType 9  = NoiseIK-handshakeByteToType 10 = NoiseXX-handshakeByteToType 11 = NoiseIX-handshakeByteToType _  = error "invalid handshake type"--cipherByteToType :: Word8 -> SomeCipherType-cipherByteToType 0 = WrapCipherType CTChaChaPoly1305-cipherByteToType 1 = WrapCipherType CTAESGCM-cipherByteToType _ = error "invalid cipher type"--curveByteToType :: Word8 -> SomeDHType-curveByteToType 0 = WrapDHType DTCurve25519-curveByteToType 1 = WrapDHType DTCurve448-curveByteToType _ = error "invalid curve type"--hashByteToType :: Word8 -> SomeHashType-hashByteToType 0 = WrapHashType HTSHA256-hashByteToType 1 = WrapHashType HTSHA512-hashByteToType 2 = WrapHashType HTBLAKE2s-hashByteToType 3 = WrapHashType HTBLAKE2b-hashByteToType _ = error "invalid hash type"--headerParser :: Parser Header-headerParser = do-  psk <- satisfy (< 2)-  hsb <- satisfy (< 13)-  cib <- satisfy (< 2)-  cub <- satisfy (< 2)-  hb  <- satisfy (< 4)--  return (pskByteToBool psk, handshakeByteToType hsb, cipherByteToType cib, curveByteToType cub, hashByteToType hb)--messageParser :: Parser ByteString-messageParser = do-  l0 <- fromIntegral <$> anyWord8-  l1 <- fromIntegral <$> anyWord8-  take (l0 `shiftL` 8 .|. l1)--parseSocket :: IORef ByteString-            -> Socket-            -> Parser a-            -> IO (Maybe a)-parseSocket bufRef sock p = do-  buf <- readIORef bufRef-  result <- parseWith doRead p buf-  case result of-    Fail{}      -> return Nothing-    (Partial _) -> return Nothing-    (Done i r)  -> modifyIORef' bufRef (const i) >> return (Just r)--  where-    doRead = do-      d <- fromMaybe "" <$> recv sock 2048-      modifyIORef' bufRef (<> d)-      return d

@@ -1,127 +0,0 @@-{-# LANGUAGE OverloadedStrings, RecordWildCards, GADTs,-    ScopedTypeVariables #-}-module Server-  ( startServer-  ) where--import Control.AutoUpdate     (mkAutoUpdate, defaultUpdateSettings, updateAction)-import Control.Exception      (handle)-import Control.Monad          (void)-import Data.Bits              ((.&.), shiftR)-import Data.ByteArray         (ScrubbedBytes, convert)-import Data.ByteString        (ByteString, pack, length)-import Data.ByteString.Base16 (encode)-import qualified Data.ByteString.Char8 as C8 (pack)-import Data.IORef-import Data.Monoid            ((<>))-import Network.Simple.TCP-import Prelude hiding         (log, length)-import System.Timeout--import Crypto.Noise-import Crypto.Noise.Cipher-import Crypto.Noise.DH-import Crypto.Noise.Hash--import Handshakes-import Log-import Parse-import Types--mkHandshakeKeys :: forall d. DH d-                => ScrubbedBytes-                -> Bool-                -> ServerOpts-                -> DHType d-                -> IO (HandshakeKeys d)-mkHandshakeKeys pro psk ServerOpts{..} DTCurve25519 = do-  lek <- dhGenKey :: IO (KeyPair d)--  return-    HandshakeKeys { hkPrologue       = pro-                  , hkPSK            = if psk then Just soPSK else Nothing-                  , hkLocalStatic    = soLocal25519-                  , hkLocalEphemeral = lek-                  , hkRemoteStatic   = soRemote25519-                  }--mkHandshakeKeys pro psk ServerOpts{..} DTCurve448 = do-  lek <- dhGenKey :: IO (KeyPair d)--  return-    HandshakeKeys { hkPrologue       = pro-                  , hkPSK            = if psk then Just soPSK else Nothing-                  , hkLocalStatic    = soLocal448-                  , hkLocalEphemeral = lek-                  , hkRemoteStatic   = soRemote448-                  }--prependLength :: ByteString-              -> ByteString-prependLength msg = pack w16len <> msg-  where-    len    = length msg-    w16len = fmap fromIntegral [(len .&. 0xFF00) `shiftR` 8, len .&. 0xFF]--writeSocket :: Socket-            -> ByteString-            -> IO ()-writeSocket s msg = send s $ prependLength msg--mkProtocolName :: ServerOpts-               -> Header-               -> String-mkProtocolName ServerOpts{..} (psk, hp, WrapCipherType cipherT, WrapDHType curveT, WrapHashType hashT) =-  p <> show hp <> "_" <> show curveT <> "_" <> show cipherT <> "_" <> show hashT-  where-    p = if psk then "NoisePSK_" else "Noise_"--messageLoop :: (Cipher c, DH d, Hash h)-            => IORef ByteString-            -> Socket-            -> NoiseState c d h-            -> IO ()-messageLoop bufRef sock = loop-  where-    loop ns = do-      maybeMessage <- parseSocket bufRef sock messageParser-      case maybeMessage of-        Nothing -> return ()-        Just m  -> do-          let (pt, ns')  = either (error . show) id $ readMessage ns m-              (ct, ns'') = either (error . show) id $ writeMessage ns' pt--          writeSocket sock ct-          loop ns''--startServer :: ServerOpts-            -> IO ()-startServer opts@ServerOpts{..} = do-  logHandle <- maybe openStdOut openLog soLogFile-  au <- mkAutoUpdate defaultUpdateSettings { updateAction = getDateTime }-  let logEx = logException logHandle au-      log   = logMsg logHandle au--  serve HostAny soPort $ \(sock, ip) -> handle (logEx ip) $ do-    log ip "connection established"--    leftoverBufRef <- newIORef ""-    th <- timeout 60000000 $ parseSocket leftoverBufRef sock headerParser-    case th of-      Nothing -> log ip "timeout waiting for header"-      Just maybeHeader ->-        case maybeHeader of-          Nothing -> do-            send sock "failed to parse header\n"-            log ip "failed to parse header"--          Just h@(psk, hp, WrapCipherType cipherT, WrapDHType curveT, WrapHashType hashT) -> do-            log ip $ "client selected " <> C8.pack (mkProtocolName opts h)--            hk <- mkHandshakeKeys (convert . serializeHeader $ h) psk opts curveT-            log ip $ "private ephemeral: " <> (encode . convert . dhSecToBytes . fst . hkLocalEphemeral) hk-            let ns  = mkNoiseState hk hp ResponderRole cipherT hashT--            void . timeout 60000000 $ messageLoop leftoverBufRef sock ns--    log ip "connection closed"

@@ -1,88 +0,0 @@-{-# LANGUAGE RankNTypes, KindSignatures, GADTs #-}-module Types where--import Data.ByteArray        (ScrubbedBytes, convert)-import Data.ByteString.Char8 (unpack)--import Crypto.Noise.Cipher-import Crypto.Noise.Cipher.ChaChaPoly1305-import Crypto.Noise.Cipher.AESGCM-import Crypto.Noise.DH-import Crypto.Noise.DH.Curve25519-import Crypto.Noise.DH.Curve448-import Crypto.Noise.Hash-import Crypto.Noise.Hash.SHA256-import Crypto.Noise.Hash.SHA512-import Crypto.Noise.Hash.BLAKE2s-import Crypto.Noise.Hash.BLAKE2b--data ServerOpts =-  ServerOpts { soLogFile     :: Maybe FilePath-             , soPort        :: String-             , soPSK         :: ScrubbedBytes-             , soLocal25519  :: KeyPair Curve25519-             , soRemote25519 :: PublicKey Curve25519-             , soLocal448    :: KeyPair Curve448-             , soRemote448   :: PublicKey Curve448-             }--data HandshakeType = NoiseNN-                   | NoiseKN-                   | NoiseNK-                   | NoiseKK-                   | NoiseNX-                   | NoiseKX-                   | NoiseXN-                   | NoiseIN-                   | NoiseXK-                   | NoiseIK-                   | NoiseXX-                   | NoiseIX--data CipherType :: * -> * where-  CTChaChaPoly1305 :: CipherType ChaChaPoly1305-  CTAESGCM         :: CipherType AESGCM--data SomeCipherType where-  WrapCipherType :: forall c. Cipher c => CipherType c -> SomeCipherType--data DHType :: * -> * where-  DTCurve25519 :: DHType Curve25519-  DTCurve448   :: DHType Curve448--data SomeDHType where-  WrapDHType :: forall d. DH d => DHType d -> SomeDHType--data HashType :: * -> * where-  HTSHA256  :: HashType SHA256-  HTSHA512  :: HashType SHA512-  HTBLAKE2s :: HashType BLAKE2s-  HTBLAKE2b :: HashType BLAKE2b--data SomeHashType where-  WrapHashType :: forall h. Hash h => HashType h -> SomeHashType--type Header = (Bool, HandshakeType, SomeCipherType, SomeDHType, SomeHashType)--instance Show HandshakeType where-  show NoiseNN = "NN"-  show NoiseKN = "KN"-  show NoiseNK = "NK"-  show NoiseKK = "KK"-  show NoiseNX = "NX"-  show NoiseKX = "KX"-  show NoiseXN = "XN"-  show NoiseIN = "IN"-  show NoiseXK = "XK"-  show NoiseIK = "IK"-  show NoiseXX = "XX"-  show NoiseIX = "IX"--instance Cipher c => Show (CipherType c) where-  show = unpack . convert . cipherName--instance DH d => Show (DHType d) where-  show = unpack . convert . dhName--instance Hash h => Show (HashType h) where-  show = unpack . convert . hashName

@@ -0,0 +1,157 @@+name: cacophony+synopsis: A library implementing the Noise protocol.+version: 0.10.0+license: PublicDomain+license-file: LICENSE+maintainer: John Galt <jgalt@centromere.net>+category: Cryptography+github: centromere/cacophony+ghc-options: -Wall+description: |+  This library implements the <https://noiseprotocol.org Noise> protocol.+extra-source-files:+  - .travis.yml+  - README.md+  - changelog.md+  - LICENSE+  - stack.yaml+  - package.yaml+  - tests/.hlint+  - tools/pretty-print/format-vectors.py+  - tools/pretty-print/vector-template.jinja+  - vectors/cacophony.txt++flags:+  build-tools:+    description: Build tools+    default: False+    manual: True++library:+  source-dirs: src+  dependencies:+    - base >= 4.9 && < 4.10+    - bytestring+    - cryptonite+    - exceptions+    - free+    - lens+    - memory+    - monad-coroutine+    - mtl+    - safe-exceptions+    - transformers++  exposed-modules:+    - Crypto.Noise+    - Crypto.Noise.Cipher+    - Crypto.Noise.Cipher.AESGCM+    - Crypto.Noise.Cipher.ChaChaPoly1305+    - Crypto.Noise.DH+    - Crypto.Noise.DH.Curve25519+    - Crypto.Noise.DH.Curve448+    - Crypto.Noise.Exception+    - 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.Handshake.Interpreter+    - Crypto.Noise.Internal.Handshake.Pattern+    - Crypto.Noise.Internal.Handshake.State+    - Crypto.Noise.Internal.Handshake.Validation+    - Crypto.Noise.Internal.NoiseState+    - Crypto.Noise.Internal.SymmetricState+    - Crypto.Noise.Validation++  default-extensions:+    - OverloadedStrings++tests:+  hlint:+    main: hlint.hs+    source-dirs: tests/hlint+    dependencies:+      - base >= 4.9 && < 4.10+      - hlint++    ghc-options:+      - -O2+      - -rtsopts+      - -threaded+      - -with-rtsopts=-N++  vectors:+    main: Main.hs+    source-dirs: tests/vectors+    dependencies:+      - aeson+      - attoparsec+      - base >= 4.9 && < 4.10+      - base16-bytestring+      - bytestring+      - cacophony+      - directory+      - text++    ghc-options:+      - -O2+      - -rtsopts+      - -threaded+      - -with-rtsopts=-N++    default-extensions:+      - OverloadedStrings++benchmarks:+  bench:+    main: Main.hs+    source-dirs: benchmarks+    dependencies:+      - async+      - base >= 4.9 && < 4.10+      - base16-bytestring+      - bytestring+      - cacophony+      - criterion+      - deepseq++    ghc-options:+      - -O2+      - -rtsopts+      - -threaded+      - -with-rtsopts=-N++    default-extensions:+      - OverloadedStrings++executables:+  noise-repl:+    source-dirs: tools/noise-repl+    main: Main.hs+    when:+      - condition: 'flag(build-tools)'+        then:+          dependencies:+            - attoparsec+            - base+            - base16-bytestring+            - base64-bytestring+            - bytestring+            - cacophony+            - haskeline+            - network+            - process+        else:+          buildable: False++    ghc-options:+      - -O2+      - -rtsopts+      - -threaded+      - -with-rtsopts=-N++    default-extensions:+      - OverloadedStrings

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}-----------------------------------------------------------------+------------------------------------------------- -- | -- Module      : Crypto.Noise -- Maintainer  : John Galt <jgalt@centromere.net>@@ -7,88 +6,133 @@ -- Portability : POSIX -- -- Please see the README for usage information.- module Crypto.Noise   ( -- * Types-    HandshakeRole(..)+    NoiseState+  , NoiseResult(..)+  , HandshakePattern+  , HandshakeRole(..)   , HandshakeOpts-  , NoiseException(..)-  , NoiseState     -- * Functions   , defaultHandshakeOpts   , noiseState   , writeMessage   , readMessage+  , processPSKs   , remoteStaticKey   , handshakeComplete   , handshakeHash-    -- * Lenses-  , hoPattern-  , hoRole-  , hoPrologue-  , hoPreSharedKey-  , hoLocalStatic-  , hoLocalSemiEphemeral-  , hoLocalEphemeral-  , hoRemoteStatic-  , hoRemoteSemiEphemeral-  , hoRemoteEphemeral+  , rekeySending+  , rekeyReceiving+  , handshakePattern+    -- * HandshakeOpts Setters+  , setLocalEphemeral+  , setLocalStatic+  , setRemoteEphemeral+  , setRemoteStatic+    -- * Classes+  , Cipher+  , DH+  , Hash+    -- * Re-exports+  , ScrubbedBytes+  , convert   ) where -import Control.Arrow+import Control.Arrow   (arr, second, (***)) import Control.Exception.Safe import Control.Lens import Data.ByteArray  (ScrubbedBytes, convert)-import Data.ByteString (ByteString) import Data.Maybe      (isJust)-import Prelude hiding  (length)  import Crypto.Noise.Cipher import Crypto.Noise.DH import Crypto.Noise.Hash import Crypto.Noise.Internal.CipherState-import Crypto.Noise.Internal.Handshake+import Crypto.Noise.Internal.Handshake.Pattern hiding (psk)+import Crypto.Noise.Internal.Handshake.State import Crypto.Noise.Internal.NoiseState import Crypto.Noise.Internal.SymmetricState-import Crypto.Noise.Internal.Types --- | Creates a Noise message with the provided payload. Note that the---   payload may not be authenticated or encrypted at all points during the---   handshake. Please see section 8.4 of the protocol document for details.+-- | This type is used to indicate to the user the result of either writing or+--   reading a message. In the simplest case, when processing a handshake or+--   transport message, the (en|de)crypted message and mutated state will be+--   available in 'NoiseResultMessage'. --+--   If during the course of the handshake a pre-shared key is needed, a+--   'NoiseResultNeedPSK' value will be returned along with the mutated state.+--   To continue, the user must re-issue the 'writeMessage' or 'readMessage'+--   call, passing in the PSK as the payload. If no further PSKs are required,+--   the result will be 'NoiseResultMessage'.+--+--   If an exception is encountered at any point while processing a handshake or+--   transport message, 'NoiseResultException' will be returned.+data NoiseResult c d h+  = NoiseResultMessage   ScrubbedBytes (NoiseState c d h)+  | NoiseResultNeedPSK   (NoiseState c d h)+  | NoiseResultException SomeException++-- | Creates a handshake or transport message with the provided payload. Note+--   that the payload may not be authenticated or encrypted at all points during+--   the handshake. Please see section 7.4 of the protocol document for details.+--+--   If a previous call to this function indicated that a pre-shared key is+--   needed, it shall be provided as the payload. See the documentation of+--   'NoiseResult' for details.+-- --   To prevent catastrophic key re-use, this function may only be used to --   secure 2^64 - 1 post-handshake messages.-writeMessage :: (MonadThrow m, Cipher c, Hash h)-             => NoiseState c d h-             -> ScrubbedBytes-             -> m (ByteString, NoiseState c d h)-writeMessage ns msg = maybe-  (first convertArr <$> runHandshake msg ns)-  (\cs -> (ctToBytes *** updateState) <$> encryptAndIncrement "" msg cs)+writeMessage :: (Cipher c, DH d, Hash h)+             => ScrubbedBytes+             -> NoiseState c d h+             -> NoiseResult c d h+writeMessage msg ns = maybe+  (convertHandshakeResult $ resumeHandshake msg ns)+  (convertTransportResult . encryptMsg)   (ns ^. nsSendingCipherState)   where-    convertArr   = arr convert-    ctToBytes    = convertArr . arr cipherTextToBytes-    updateState  = arr $ \cs -> ns & nsSendingCipherState .~ Just cs+    ctToMsg       = arr cipherTextToBytes+    updateState   = arr $ \cs -> ns & nsSendingCipherState .~ Just cs+    encryptMsg cs = (ctToMsg *** updateState) <$> encryptWithAd mempty msg cs --- | Reads a Noise message and returns the embedded payload. If the---   handshake fails, a 'HandshakeError' will be returned. After the handshake---   is complete, if decryption fails a 'DecryptionError' is returned.+-- | Reads a handshake or transport message and returns the embedded payload. If+--   the handshake fails, a 'HandshakeError' will be returned. After the+--   handshake is complete, if decryption fails a 'DecryptionError' is returned. --+--   If a previous call to this function indicated that a pre-shared key is+--   needed, it shall be provided as the payload. See the documentation of+--   'NoiseResult' for details.+-- --   To prevent catastrophic key re-use, this function may only be used to --   receive 2^64 - 1 post-handshake messages.-readMessage :: (MonadThrow m, Cipher c, Hash h)-            => NoiseState c d h-            -> ByteString-            -> m (ScrubbedBytes, NoiseState c d h)-readMessage ns ct = maybe-  (runHandshake (convert ct) ns)-  (\cs -> second updateState <$> decryptAndIncrement "" ct' cs)+readMessage :: (Cipher c, DH d, Hash h)+            => ScrubbedBytes+            -> NoiseState c d h+            -> NoiseResult c d h+readMessage ct ns = maybe+  (convertHandshakeResult $ resumeHandshake ct ns)+  (convertTransportResult . decryptMsg)   (ns ^. nsReceivingCipherState)   where-    ct'         = cipherBytesToText . convert $ ct-    updateState = arr $ \cs -> ns & nsReceivingCipherState .~ Just cs+    ct'           = cipherBytesToText ct+    updateState   = arr $ \cs -> ns & nsReceivingCipherState .~ Just cs+    decryptMsg cs = second updateState <$> decryptWithAd mempty ct' cs +-- | Given an operation ('writeMessage' or 'readMessage'), a list of PSKs, and+--   a 'NoiseResult', this function will repeatedly apply PSKs to the NoiseState+--   until no more are requested or the list of PSKs becomes empty. This is+--   useful for patterns which require two or more PSKs, and you know exactly+--   what they all should be ahead of time.+processPSKs :: (Cipher c, DH d, Hash h)+            => (ScrubbedBytes -> NoiseState c d h -> NoiseResult c d h)+            -> [ScrubbedBytes]+            -> NoiseResult c d h+            -> ([ScrubbedBytes], NoiseResult c d h)+processPSKs _ []                result = ([], result)+processPSKs f psks@(psk : rest) result = case result of+  NoiseResultNeedPSK state' -> processPSKs f rest (f psk state')+  r -> (psks, r)+ -- | For handshake patterns where the remote party's static key is --   transmitted, this function can be used to retrieve it. This allows --   for the creation of public key-based access-control lists.@@ -110,9 +154,37 @@ --   The value returned by this function is only meaningful after the --   handshake is complete. -----   See section 9.4 of the protocol for details.+--   See section 11.2 of the protocol for details. handshakeHash :: Hash h               => NoiseState c d h               -> ScrubbedBytes handshakeHash ns = either id hashToBytes                    $ ns ^. nsHandshakeState . hsSymmetricState . ssh++-- | Rekeys the sending @CipherState@ according to section 11.3 of the protocol.+rekeySending :: (Cipher c, DH d, Hash h)+             => NoiseState c d h+             -> NoiseState c d h+rekeySending ns = ns & nsSendingCipherState %~ (<*>) (pure rekey)++-- | Rekeys the receiving @CipherState@ according to section 11.3 of the+--   protocol.+rekeyReceiving :: (Cipher c, DH d, Hash h)+               => NoiseState c d h+               -> NoiseState c d h+rekeyReceiving ns = ns & nsReceivingCipherState %~ (<*>) (pure rekey)++--------------------------------------------------------------------------------++convertHandshakeResult :: (Cipher c, DH d, Hash h)+                       => Either SomeException (HandshakeResult, NoiseState c d h)+                       -> NoiseResult c d h+convertHandshakeResult hsr = case hsr of+  Left ex -> NoiseResultException ex+  Right (HandshakeResultMessage m, ns) -> NoiseResultMessage m ns+  Right (HandshakeResultNeedPSK  , ns) -> NoiseResultNeedPSK ns++convertTransportResult :: (Cipher c, DH d, Hash h)+                       => Either SomeException (ScrubbedBytes, NoiseState c d h)+                       -> NoiseResult c d h+convertTransportResult = either NoiseResultException (uncurry NoiseResultMessage)

@@ -1,11 +1,10 @@ {-# LANGUAGE TypeFamilies #-}-----------------------------------------------------------------+------------------------------------------------- -- | -- Module      : Crypto.Noise.Cipher -- Maintainer  : John Galt <jgalt@centromere.net> -- Stability   : experimental -- Portability : POSIX- module Crypto.Noise.Cipher   ( -- * Classes     Cipher(..)@@ -14,7 +13,8 @@   , Plaintext   ) where -import Data.ByteArray (ScrubbedBytes)+import Data.ByteArray (ScrubbedBytes, replicate)+import Prelude hiding (replicate)  -- | Typeclass for ciphers. class Cipher c where@@ -46,12 +46,34 @@                     -> Ciphertext c                     -> Maybe Plaintext +  -- | Returns a new 32-byte cipher key as a pseudorandom function of @k@.+  --   Defaults to:+  --+  --   @cipherEncrypt k maxNonce "" zeros@+  --+  --   where @maxNonce = 2^64 - 1@ and @zeros@ is a sequence of 32 bytes filed+  --   with zeros.+  cipherRekey       :: SymmetricKey c+                    -> SymmetricKey c+  cipherRekey k = cipherBytesToSym  .+                  cipherTextToBytes $+                  cipherEncrypt k cipherMaxNonce mempty (replicate 32 0)+   -- | Returns a Nonce set to zero.   cipherZeroNonce   :: Nonce c +  -- | Returns the largest possible Nonce (@2 ^ 64 - 1@).+  cipherMaxNonce    :: Nonce c+   -- | Increments a nonce.   cipherIncNonce    :: Nonce c -> Nonce c +  -- | Tests if two Nonces are equal.+  cipherNonceEq     :: Nonce c -> Nonce c -> Bool++  -- | Compares the value of two Nonces.+  cipherNonceCmp    :: Nonce c -> Nonce c -> Ordering+   -- | Imports a symmetric key. If the input is greater than 32 bytes, it   --   is truncated.   cipherBytesToSym  :: ScrubbedBytes -> SymmetricKey c@@ -71,6 +93,12 @@  -- | Represents plaintext data that can be encrypted. type Plaintext = ScrubbedBytes++instance Cipher c => Eq (Nonce c) where+  (==) = cipherNonceEq++instance Cipher c => Ord (Nonce c) where+  compare = cipherNonceCmp  instance Show (SymmetricKey a) where   show _ = "<symmetric key>"

@@ -1,26 +1,26 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies #-}-----------------------------------------------------------------+{-# LANGUAGE TypeFamilies #-}+------------------------------------------------- -- | -- 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, ScrubbedBytes, convert)-import qualified Data.ByteArray as B (take, drop, length, replicate, copyAndFreeze)-import Data.Word                     (Word8)+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, Bytes, ScrubbedBytes, convert, take,+                            drop, length, copyAndFreeze, zero, append,+                            replicate)+import Data.Word           (Word8) import Foreign.Ptr import Foreign.Storable+import Prelude hiding      (drop, length, replicate, take)  import Crypto.Noise.Cipher @@ -30,13 +30,16 @@ instance Cipher AESGCM where   newtype Ciphertext   AESGCM = CTAES (AuthTag, ScrubbedBytes)   newtype SymmetricKey AESGCM = SKAES ScrubbedBytes-  newtype Nonce        AESGCM = NAES  ScrubbedBytes+  newtype Nonce        AESGCM = NAES  Bytes    cipherName _      = "AESGCM"   cipherEncrypt     = encrypt   cipherDecrypt     = decrypt   cipherZeroNonce   = zeroNonce+  cipherMaxNonce    = maxNonce   cipherIncNonce    = incNonce+  cipherNonceEq     = nonceEq+  cipherNonceCmp    = nonceCmp   cipherBytesToSym  = bytesToSym   cipherSymToBytes  = symToBytes   cipherTextToBytes = ctToBytes@@ -65,15 +68,28 @@     aead  = throwCryptoError $ aeadInit AEAD_GCM state n  zeroNonce :: Nonce AESGCM-zeroNonce = NAES (B.replicate 12 0 :: ScrubbedBytes)+zeroNonce = NAES . zero $ 12 +maxNonce :: Nonce AESGCM+maxNonce = NAES $ zero 4 `append` replicate 8 255+ incNonce :: Nonce AESGCM          -> Nonce AESGCM incNonce (NAES n) = NAES $ ivAdd n 1 +nonceEq :: Nonce AESGCM+        -> Nonce AESGCM+        -> Bool+nonceEq (NAES a) (NAES b) = a == b++nonceCmp :: Nonce AESGCM+         -> Nonce AESGCM+         -> Ordering+nonceCmp (NAES a) (NAES b) = compare a b+ bytesToSym :: ScrubbedBytes            -> SymmetricKey AESGCM-bytesToSym = SKAES . B.take 32+bytesToSym = SKAES . take 32  symToBytes :: SymmetricKey AESGCM            -> ScrubbedBytes@@ -86,30 +102,25 @@ bytesToCt :: ScrubbedBytes           -> Ciphertext AESGCM bytesToCt bytes =-  CTAES ( AuthTag . convert $ B.drop (B.length bytes - 16) bytes-        , B.take (B.length bytes - 16) bytes+  CTAES ( AuthTag . convert $ drop (length bytes - 16) bytes+        , take (length bytes - 16) bytes         ) --- Adapted from cryptonite's Crypto.Cipher.Types.Block module:--- https://github.com/haskell-crypto/cryptonite/blob/149bfa601081c27013811498fa507a83f5ce87ea/Crypto/Cipher/Types/Block.hs#L167-ivAdd :: ByteArray b => b -> Int -> b+-- Adapted from cryptonite's Crypto.Cipher.Types.Block module.+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+        copy bs = copyAndFreeze bs $ loop i (length bs - 1) -        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+        loop :: Int -> Int -> Ptr Word8 -> IO ()+        loop acc ofs p+            | ofs < 0   = return ()+            | otherwise = 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)+                loop hi (ofs - 1) p

@@ -1,22 +1,22 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies #-}-----------------------------------------------------------------+{-# LANGUAGE TypeFamilies #-}+--------------------------------------------------- -- | -- Module      : Crypto.Noise.Cipher.ChaChaPoly1305 -- Maintainer  : John Galt <jgalt@centromere.net> -- Stability   : experimental -- Portability : POSIX- module Crypto.Noise.Cipher.ChaChaPoly1305   ( -- * Types     ChaChaPoly1305   ) where -import           Crypto.Error   (throwCryptoError)+import           Crypto.Error    (throwCryptoError) import qualified Crypto.Cipher.ChaChaPoly1305 as CCP import qualified Crypto.MAC.Poly1305          as P-import           Data.ByteArray (ScrubbedBytes, convert, take, drop, length)-import qualified Data.ByteString              as BS (replicate)-import           Prelude hiding (take, drop, length)+import           Data.ByteArray  (ScrubbedBytes, Bytes, convert, take, drop,+                                  length, replicate, constEq)+import           Data.ByteString (ByteString, reverse)+import           Prelude hiding  (drop, length, replicate, take, reverse)  import Crypto.Noise.Cipher @@ -32,7 +32,10 @@   cipherEncrypt     = encrypt   cipherDecrypt     = decrypt   cipherZeroNonce   = zeroNonce+  cipherMaxNonce    = maxNonce   cipherIncNonce    = incNonce+  cipherNonceEq     = nonceEq+  cipherNonceCmp    = nonceCmp   cipherBytesToSym  = bytesToSym   cipherSymToBytes  = symToBytes   cipherTextToBytes = ctToBytes@@ -69,22 +72,47 @@ zeroNonce :: Nonce ChaChaPoly1305 zeroNonce = NCCP1305 . throwCryptoError $ CCP.nonce8 constant iv   where-    constant = BS.replicate 4 0-    iv       = BS.replicate 8 0+    constant = replicate 4 0 :: Bytes+    iv       = replicate 8 0 :: Bytes -incNonce :: Nonce ChaChaPoly1305 -> Nonce ChaChaPoly1305+maxNonce :: Nonce ChaChaPoly1305+maxNonce = NCCP1305 . throwCryptoError $ CCP.nonce8 constant iv+  where+    constant = replicate 4 0   :: Bytes+    iv       = replicate 8 255 :: Bytes++incNonce :: Nonce ChaChaPoly1305+         -> Nonce ChaChaPoly1305 incNonce (NCCP1305 n) = NCCP1305 $ CCP.incrementNonce n -bytesToSym :: ScrubbedBytes -> SymmetricKey ChaChaPoly1305+nonceEq :: Nonce ChaChaPoly1305+        -> Nonce ChaChaPoly1305+        -> Bool+nonceEq (NCCP1305 a) (NCCP1305 b) = constEq a b++-- | Since nonces in this cipher are little endian, they must be reversed prior+--   to comparison. A ByteString was chosen because it uses memcmp under the+--   hood.+nonceCmp :: Nonce ChaChaPoly1305+         -> Nonce ChaChaPoly1305+         -> Ordering+nonceCmp (NCCP1305 a) (NCCP1305 b) = compare (reverse (convert a :: ByteString))+                                             (reverse (convert b :: ByteString))++bytesToSym :: ScrubbedBytes+           -> SymmetricKey ChaChaPoly1305 bytesToSym = SKCCP1305 . take 32 -symToBytes :: SymmetricKey ChaChaPoly1305 -> ScrubbedBytes+symToBytes :: SymmetricKey ChaChaPoly1305+           -> ScrubbedBytes symToBytes (SKCCP1305 sk) = sk -ctToBytes :: Ciphertext ChaChaPoly1305 -> ScrubbedBytes+ctToBytes :: Ciphertext ChaChaPoly1305+          -> ScrubbedBytes ctToBytes (CTCCP1305 (ct, a)) = ct `mappend` convert a -bytesToCt :: ScrubbedBytes -> Ciphertext ChaChaPoly1305+bytesToCt :: ScrubbedBytes+          -> Ciphertext ChaChaPoly1305 bytesToCt bytes =   CTCCP1305 (take (length bytes - 16) bytes             , P.Auth . convert $ drop (length bytes - 16) bytes

@@ -1,11 +1,10 @@ {-# LANGUAGE TypeFamilies #-}-----------------------------------------------------------------+------------------------------------------------- -- | -- Module      : Crypto.Noise.DH -- Maintainer  : John Galt <jgalt@centromere.net> -- Stability   : experimental -- Portability : POSIX- module Crypto.Noise.DH   ( -- * Classes     DH(..)@@ -30,28 +29,28 @@   -- | Returns the length of public keys for this DH scheme in bytes.   dhLength         :: proxy d -> Int -  -- | Generates a @KeyPair@.+  -- | Generates a 'KeyPair'.   dhGenKey         :: IO (KeyPair d)    -- | Performs DH.   dhPerform        :: SecretKey d -> PublicKey d -> ScrubbedBytes -  -- | Exports a @PublicKey@.+  -- | Exports a 'PublicKey'.   dhPubToBytes     :: PublicKey d -> ScrubbedBytes -  -- | Imports a @PublicKey@.+  -- | Imports a 'PublicKey'.   dhBytesToPub     :: ScrubbedBytes -> Maybe (PublicKey d) -  -- | Exports a @SecretKey@.+  -- | Exports a 'SecretKey'.   dhSecToBytes     :: SecretKey d -> ScrubbedBytes -  -- | Imports a @SecretKey@.+  -- | Imports a 'SecretKey'.   dhBytesToPair    :: ScrubbedBytes -> Maybe (KeyPair d) -  -- | Tests @PublicKey@s for equality.+  -- | Tests 'PublicKey's for equality.   dhPubEq :: PublicKey d -> PublicKey d -> Bool --- | Represents a private/public key pair for a given @Curve@.+-- | Represents a private/public key pair for a given 'DH'. type KeyPair d = (SecretKey d, PublicKey d)  instance DH d => Eq (PublicKey d) where

@@ -1,11 +1,10 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies #-}-----------------------------------------------------------------+{-# LANGUAGE TypeFamilies #-}+------------------------------------------------- -- | -- Module      : Crypto.Noise.DH.Curve25519 -- Maintainer  : John Galt <jgalt@centromere.net> -- Stability   : experimental -- Portability : POSIX- module Crypto.Noise.DH.Curve25519   ( -- * Types     Curve25519@@ -61,4 +60,4 @@ pubEq :: PublicKey Curve25519       -> PublicKey Curve25519       -> Bool-pubEq a b = a == b+pubEq (PK25519 a) (PK25519 b) = a == b

@@ -1,11 +1,10 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies #-}-----------------------------------------------------------------+{-# LANGUAGE TypeFamilies #-}+------------------------------------------------- -- | -- Module      : Crypto.Noise.DH.Curve448 -- Maintainer  : John Galt <jgalt@centromere.net> -- Stability   : experimental -- Portability : POSIX- module Crypto.Noise.DH.Curve448   ( -- * Types     Curve448@@ -61,4 +60,4 @@ pubEq :: PublicKey Curve448       -> PublicKey Curve448       -> Bool-pubEq a b = a == b+pubEq (PK448 a) (PK448 b) = a == b

@@ -0,0 +1,50 @@+-------------------------------------------------+-- |+-- Module      : Crypto.Noise.Exception+-- Maintainer  : John Galt <jgalt@centromere.net>+-- Stability   : experimental+-- Portability : POSIX+module Crypto.Noise.Exception where++import Control.Exception.Safe++-- | Represents the type of key that may be associated with an exception.+data ExceptionKeyType+  = LocalEphemeral+  | LocalStatic+  | RemoteEphemeral+  | RemoteStatic+  deriving Show++-- | Represents the various exceptions which can be thrown.+--+--   * 'StaticKeyOverwrite' occurs when a static key is transmitted by the+--   remote party, but a remote static key has already been set in+--   'HandshakeOpts'.+--+--   * 'InvalidKey' occurs when a key transmitted by the remote party is+--   successfully decrypted but otherwise invalid.+--+--   * 'KeyMissing' occurs when a required key has not been provided to+--   'HandshakeOpts'. The keys which are required depend on the handshake+--   pattern chosen.+--+--   * 'InvalidPattern' occurs when a handshake pattern uses an improper token.+--   This can occur if a user-defined 'HandshakePattern' uses any token other+--   than @e@ or @s@ in a pre-message pattern.+--+--   * 'DecryptionError' occurs when any data fails to decrypt for any reason.+--   This usually occurs if the authentication tag is invalid.+--+--   * 'MessageLimitReached' occurs if the user attempts to send or receive+--   more than @2^64 - 1@ messages. This is needed because nonces are 8-bytes+--   (64 bits), and doing so would cause catastrophic key re-use.+data NoiseException = StaticKeyOverwrite+                    | InvalidKey ExceptionKeyType+                    | KeyMissing ExceptionKeyType+                    | InvalidPattern+                    | DecryptionError+                    | MessageLimitReached+                    deriving Show++instance Exception NoiseException

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}-----------------------------------------------------------------+------------------------------------------------- -- | -- Module      : Crypto.Noise.HandshakePatterns -- Maintainer  : John Galt <jgalt@centromere.net>@@ -7,14 +6,10 @@ -- Portability : POSIX -- -- This module contains all of the handshake patterns specified in sections--- 8.2 and 8.3 as well as unspecified patterns found in previous drafts of--- the protocol.-+-- 7.2, 7.3, and 9.4. module Crypto.Noise.HandshakePatterns-  ( -- * Types-    HandshakePattern-    -- * Functions-  , noiseNN+  ( -- * Standard patterns+    noiseNN   , noiseKN   , noiseNK   , noiseKK@@ -29,21 +24,39 @@   , noiseN   , noiseK   , noiseX-  , noiseXXfallback+  -- * PSK patterns+  , noiseNNpsk0+  , noiseNNpsk2+  , noiseNKpsk0+  , noiseNKpsk2+  , noiseNXpsk2+  , noiseXNpsk3+  , noiseXKpsk3+  , noiseXXpsk3+  , noiseKNpsk0+  , noiseKNpsk2+  , noiseKKpsk0+  , noiseKKpsk2+  , noiseKXpsk2+  , noiseINpsk1+  , noiseINpsk2+  , noiseIKpsk1+  , noiseIKpsk2+  , noiseIXpsk2+  , noiseNpsk0+  , noiseKpsk0+  , noiseXpsk1   ) where -import Crypto.Noise.Internal.HandshakePattern+import Crypto.Noise.Internal.Handshake.Pattern  -- | @Noise_NN(): --  -> e --  <- e, ee@ noiseNN :: HandshakePattern-noiseNN = HandshakePattern "NN" $ do-  initiator e--  responder $ do-    e-    ee+noiseNN = handshakePattern "NN" $+  initiator e *>+  responder (e *> ee)  -- | @Noise_KN(s): --  -> s@@ -51,15 +64,10 @@ --  -> e --  <- e, ee, se@ noiseKN :: HandshakePattern-noiseKN = HandshakePattern "KN" $ do-  preInitiator s--  initiator e--  responder $ do-    e-    ee-    se+noiseKN = handshakePattern "KN" $+  preInitiator s *>+  initiator e    *>+  responder (e *> ee *> se)  -- | @Noise_NK(rs): --  <- s@@ -67,16 +75,10 @@ --  -> e, es --  <- e, ee@ noiseNK :: HandshakePattern-noiseNK = HandshakePattern "NK" $ do-  preResponder s--  initiator $ do-    e-    es--  responder $ do-    e-    ee+noiseNK = handshakePattern "NK" $+  preResponder s      *>+  initiator (e *> es) *>+  responder (e *> ee)  -- | @Noise_KK(s, rs): --  -> s@@ -85,33 +87,19 @@ --  -> e, es, ss --  <- e, ee, se@ noiseKK :: HandshakePattern-noiseKK = HandshakePattern "KK" $ do-  preInitiator s--  preResponder s--  initiator $ do-    e-    es-    ss--  responder $ do-    e-    ee-    se+noiseKK = handshakePattern "KK" $+  preInitiator s            *>+  preResponder s            *>+  initiator (e *> es *> ss) *>+  responder (e *> ee *> se)  -- | @Noise_NX(rs): --  -> e --  <- e, ee, s, es@ noiseNX :: HandshakePattern-noiseNX = HandshakePattern "NX" $ do-  initiator e--  responder $ do-    e-    ee-    s-    es+noiseNX = handshakePattern "NX" $+  initiator e *>+  responder (e *> ee *> s *> es)  -- | @Noise_KX(s, rs): --  -> s@@ -119,47 +107,28 @@ --  -> e --  <- e, ee, se, s, es@ noiseKX :: HandshakePattern-noiseKX = HandshakePattern "KX" $ do-  preInitiator s--  initiator e--  responder $ do-    e-    ee-    se-    s-    es+noiseKX = handshakePattern "KX" $+  preInitiator s *>+  initiator e    *>+  responder (e *> ee *> se *> s *> es)  -- | @Noise_XN(s): --  -> e --  <- e, ee --  -> s, se@ noiseXN :: HandshakePattern-noiseXN = HandshakePattern "XN" $ do-  initiator e--  responder $ do-    e-    ee--  initiator $ do-    s-    se+noiseXN = handshakePattern "XN" $+  initiator e         *>+  responder (e *> ee) *>+  initiator (s *> se)  -- | @Noise_IN(s): --  -> e, s --  <- e, ee, se@ noiseIN :: HandshakePattern-noiseIN = HandshakePattern "IN" $ do-  initiator $ do-    e-    s--  responder $ do-    e-    ee-    se+noiseIN = handshakePattern "IN" $+  initiator (e *> s) *>+  responder (e *> ee *> se)  -- | @Noise_XK(s, rs): --  <- s@@ -168,20 +137,11 @@ --  <- e, ee --  -> s, se@ noiseXK :: HandshakePattern-noiseXK = HandshakePattern "XK" $ do-  preResponder s--  initiator $ do-    e-    es--  responder $ do-    e-    ee--  initiator $ do-    s-    se+noiseXK = handshakePattern "XK" $+  preResponder s      *>+  initiator (e *> es) *>+  responder (e *> ee) *>+  initiator (s *> se)  -- | @Noise_IK(s, rs): --  <- s@@ -189,65 +149,37 @@ --  -> e, es, s, ss --  <- e, ee, se@ noiseIK :: HandshakePattern-noiseIK = HandshakePattern "IK" $ do-  preResponder s--  initiator $ do-    e-    es-    s-    ss--  responder $ do-    e-    ee-    se+noiseIK = handshakePattern "IK" $+  preResponder s                 *>+  initiator (e *> es *> s *> ss) *>+  responder (e *> ee *> se)  -- | @Noise_XX(s, rs): --  -> e --  <- e, ee, s, es --  -> s, se@ noiseXX :: HandshakePattern-noiseXX = HandshakePattern "XX" $ do-  initiator e--  responder $ do-    e-    ee-    s-    es--  initiator $ do-    s-    se+noiseXX = handshakePattern "XX" $+  initiator e                    *>+  responder (e *> ee *> s *> es) *>+  initiator (s *> se)  -- | @Noise_IX(s, rs): --  -> e, s --  <- e, ee, se, s, es@ noiseIX :: HandshakePattern-noiseIX = HandshakePattern "IX" $ do-  initiator $ do-    e-    s--  responder $ do-    e-    ee-    se-    s-    es+noiseIX = handshakePattern "IX" $+  initiator (e *> s) *>+  responder (e *> ee *> se *> s *> es)  -- | @Noise_N(rs): --  <- s --  ... --  -> e, es@ noiseN :: HandshakePattern-noiseN = HandshakePattern "N" $ do-  preResponder s--  initiator $ do-    e-    es+noiseN = handshakePattern "N" $+  preResponder s *>+  initiator (e *> es)  -- | @Noise_K(s, rs): --  -> s@@ -255,45 +187,228 @@ --  ... --  -> e, es, ss@ noiseK :: HandshakePattern-noiseK = HandshakePattern "K" $ do-  preInitiator s--  preResponder s--  initiator $ do-    e-    es-    ss+noiseK = handshakePattern "K" $+  preInitiator s *>+  preResponder s *>+  initiator (e *> es *> ss)  -- | @Noise_X(s, rs): --  <- s --  ... --  -> e, es, s, ss@ noiseX :: HandshakePattern-noiseX = HandshakePattern "X" $ do-  preResponder s+noiseX = handshakePattern "X" $+  preResponder s *>+  initiator (e *> es *> s *> ss) -  initiator $ do-    e-    es-    s-    ss+-- | @Noise_NNpsk0():+--  -> psk, e+--  <- e, ee@+noiseNNpsk0 :: HandshakePattern+noiseNNpsk0 = handshakePattern "NNpsk0" $+  initiator (psk *> e) *>+  responder (e *> ee) --- | @Noise_XXfallback(s, rs, re):---  <- e+-- | @Noise_NNpsk2():+--  -> e+--  <- e, ee, psk@+noiseNNpsk2 :: HandshakePattern+noiseNNpsk2 = handshakePattern "NNpsk2" $+  initiator e *>+  responder (e *> ee *> psk)++-- | @Noise_NKpsk0(rs):+--  <- s --  ...---  -> e, ee, s, se---  <- s, es-noiseXXfallback :: HandshakePattern-noiseXXfallback = HandshakePattern "XXfallback" $ do-  preResponder e+--  -> psk, e, es+--  <- e, ee@+noiseNKpsk0 :: HandshakePattern+noiseNKpsk0 = handshakePattern "NKpsk0" $+  preResponder s *>+  initiator (psk *> e *> es) *>+  responder (e *> ee) -  initiator $ do-    e-    ee-    s-    se+-- | @Noise_NKpsk2(rs):+--  <- s+--  ...+--  -> e, es+--  <- e, ee, psk@+noiseNKpsk2 :: HandshakePattern+noiseNKpsk2 = handshakePattern "NKpsk2" $+  preResponder s *>+  initiator (e *> es) *>+  responder (e *> ee *> psk) -  responder $ do-    s-    es+-- | @Noise_NXpsk2(rs):+--  -> e+--  <- e, ee, s, es, psk@+noiseNXpsk2 :: HandshakePattern+noiseNXpsk2 = handshakePattern "NXpsk2" $+  initiator e *>+  responder (e *> ee *> s *> es *> psk)++-- | @Noise_XNpsk3(s):+--  -> e+--  <- e, ee+--  -> s, se, psk@+noiseXNpsk3 :: HandshakePattern+noiseXNpsk3 = handshakePattern "XNpsk3" $+  initiator e *>+  responder (e *> ee) *>+  initiator (s *> se *> psk)++-- | @Noise_XKpsk3(s, rs):+--  <- s+--  ...+--  -> e, es+--  <- e, ee+--  -> s, se, psk@+noiseXKpsk3 :: HandshakePattern+noiseXKpsk3 = handshakePattern "XKpsk3" $+  preResponder s *>+  initiator (e *> es) *>+  responder (e *> ee) *>+  initiator (s *> se *> psk)++-- | @Noise_XXpsk3(s, rs):+--  -> e+--  <- e, ee, s, es+--  -> s, se, psk@+noiseXXpsk3 :: HandshakePattern+noiseXXpsk3 = handshakePattern "XXpsk3" $+  initiator e *>+  responder (e *> ee *> s *> es) *>+  initiator (s *> se *> psk)++-- | @Noise_KNpsk0(s):+--  -> s+--  ...+--  -> psk, e+--  <- e, ee, se@+noiseKNpsk0 :: HandshakePattern+noiseKNpsk0 = handshakePattern "KNpsk0" $+  preInitiator s *>+  initiator (psk *> e) *>+  responder (e *> ee *> se)++-- | @Noise_KNpsk2(s):+--  -> s+--  ...+--  -> e+--  <- e, ee, se, psk@+noiseKNpsk2 :: HandshakePattern+noiseKNpsk2 = handshakePattern "KNpsk2" $+  preInitiator s *>+  initiator e *>+  responder (e *> ee *> se *> psk)++-- | @Noise_KKpsk0(s, rs):+--  -> s+--  <- s+--  ...+--  -> psk, e, es, ss+--  <- e, ee, se@+noiseKKpsk0 :: HandshakePattern+noiseKKpsk0 = handshakePattern "KKpsk0" $+  preInitiator s *>+  preResponder s *>+  initiator (psk *> e *> es *> ss) *>+  responder (e *> ee *> se)++-- | @Noise_KKpsk2(s, rs):+--  -> s+--  <- s+--  ...+--  -> e, es, ss+--  <- e, ee, se, psk@+noiseKKpsk2 :: HandshakePattern+noiseKKpsk2 = handshakePattern "KKpsk2" $+  preInitiator s *>+  preResponder s *>+  initiator (e *> es *> ss) *>+  responder (e *> ee *> se *> psk)++-- | @Noise_KXpsk2(s, rs):+--  -> s+--  ...+--  -> e+--  <- e, ee, se, s, es, psk@+noiseKXpsk2 :: HandshakePattern+noiseKXpsk2 = handshakePattern "KXpsk2" $+  preInitiator s *>+  initiator e *>+  responder (e *> ee *> se *> s *> es *> psk)++-- | @Noise_INpsk1(s):+--  -> e, s, psk+--  <- e, ee, se@+noiseINpsk1 :: HandshakePattern+noiseINpsk1 = handshakePattern "INpsk1" $+  initiator (e *> s *> psk) *>+  responder (e *> ee *> se)++-- | @Noise_INpsk2(s):+--  -> e, s+--  <- e, ee, se, psk@+noiseINpsk2 :: HandshakePattern+noiseINpsk2 = handshakePattern "INpsk2" $+  initiator (e *> s) *>+  responder (e *> ee *> se *> psk)++-- | @Noise_IKpsk1(s, rs):+--  <- s+--  ...+--  -> e, es, s, ss, psk+--  <- e, ee, se@+noiseIKpsk1 :: HandshakePattern+noiseIKpsk1 = handshakePattern "IKpsk1" $+  preResponder s *>+  initiator (e *> es *> s *> ss *> psk) *>+  responder (e *> ee *> se)++-- | @Noise_IKpsk2(s, rs):+--  <- s+--  ...+--  -> e, es, s, ss+--  <- e, ee, se, psk@+noiseIKpsk2 :: HandshakePattern+noiseIKpsk2 = handshakePattern "IKpsk2" $+  preResponder s *>+  initiator (e *> es *> s *> ss) *>+  responder (e *> ee *> se *> psk)++-- | @Noise_IXpsk2(s, rs):+--  -> e, s+--  <- e, ee, se, s, es, psk@+noiseIXpsk2 :: HandshakePattern+noiseIXpsk2 = handshakePattern "IXpsk2" $+  initiator (e *> s) *>+  responder (e *> ee *> se *> s *> es *> psk)++-- | @Noise_Npsk0(rs):+--  <- s+--  ...+--  -> psk, e, es@+noiseNpsk0 :: HandshakePattern+noiseNpsk0 = handshakePattern "Npsk0" $+  preResponder s *>+  initiator (psk *> e *> es)++-- | @Noise_Kpsk0(s, rs):+--  <- s+--  ...+--  -> psk, e, es, ss@+noiseKpsk0 :: HandshakePattern+noiseKpsk0 = handshakePattern "Kpsk0" $+  preInitiator s *>+  preResponder s *>+  initiator (psk *> e *> es *> ss)++-- | @Noise_Xpsk1(s, rs):+--  <- s+--  ...+--  -> e, es, s, ss, psk@+noiseXpsk1 :: HandshakePattern+noiseXpsk1 = handshakePattern "Xpsk1" $+  preResponder s *>+  initiator (e *> es *> s *> ss *> psk)

@@ -1,17 +1,17 @@ {-# LANGUAGE TypeFamilies #-}-----------------------------------------------------------------+------------------------------------------------- -- | -- Module      : Crypto.Noise.Hash -- Maintainer  : John Galt <jgalt@centromere.net> -- Stability   : experimental -- Portability : POSIX- module Crypto.Noise.Hash   ( -- * Classes     Hash(..)   ) where  import Data.ByteArray (ScrubbedBytes)+import Data.Word      (Word8)  -- | Typeclass for hashes. class Hash h where@@ -32,7 +32,10 @@   hash          :: ScrubbedBytes -> Digest h    -- | Performs HKDF.-  hashHKDF      :: ChainingKey h -> ScrubbedBytes -> (ChainingKey h, ScrubbedBytes)+  hashHKDF      :: ChainingKey h+                -> ScrubbedBytes+                -> Word8+                -> [ScrubbedBytes]    -- | Converts a series of bytes to a chaining key.   hashBytesToCK :: ScrubbedBytes -> ChainingKey h

@@ -1,11 +1,10 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies #-}-----------------------------------------------------------------+{-# LANGUAGE TypeFamilies #-}+------------------------------------------------- -- | -- Module      : Crypto.Noise.Hash.BLAKE2b -- Maintainer  : John Galt <jgalt@centromere.net> -- Stability   : experimental -- Portability : POSIX- module Crypto.Noise.Hash.BLAKE2b   ( -- * Types     BLAKE2b@@ -13,7 +12,9 @@  import qualified Crypto.Hash      as H import qualified Crypto.MAC.HMAC  as M-import Data.ByteArray (ScrubbedBytes, convert)+import Data.ByteArray (ScrubbedBytes, convert, empty, snoc)+import Data.List      (unfoldr)+import Data.Word      (Word8)  import Crypto.Noise.Hash @@ -21,45 +22,44 @@ data BLAKE2b  instance Hash BLAKE2b where-  newtype ChainingKey BLAKE2b = HCKB2s ScrubbedBytes-  newtype Digest      BLAKE2b = HDB2s  (H.Digest H.Blake2b_512)+  newtype ChainingKey BLAKE2b = HCKB2b ScrubbedBytes+  newtype Digest      BLAKE2b = HDB2b  (H.Digest H.Blake2b_512)    hashName   _  = "BLAKE2b"   hashLength _  = 64-  hash          = hashB-  hashHKDF      = hkdfB-  hashBytesToCK = bytesToCKB-  hashCKToBytes = ckToBytesB-  hashToBytes   = toBytesB+  hash          = hash'+  hashHKDF      = hkdf+  hashBytesToCK = bytesToCK+  hashCKToBytes = ckToBytes+  hashToBytes   = toBytes -hashB :: ScrubbedBytes-       -> Digest BLAKE2b-hashB bs = HDB2s $ H.hash bs+hash' :: ScrubbedBytes+      -> Digest BLAKE2b+hash' bs = HDB2b $ H.hash bs -hkdfB :: ChainingKey BLAKE2b-       -> ScrubbedBytes-       -> (ChainingKey BLAKE2b, ScrubbedBytes)-hkdfB (HCKB2s ck) d = (HCKB2s ck', sk)+hkdf :: ChainingKey BLAKE2b+     -> ScrubbedBytes+     -> Word8+     -> [ScrubbedBytes]+hkdf (HCKB2b ck) keyMat numOutputs = loop (empty, 1)   where-    x01, x02 :: ScrubbedBytes-    x01   = "\x01"-    x02   = "\x02"--    hmac1 = M.hmac ck d :: M.HMAC H.Blake2b_512-    temp  = convert hmac1 :: ScrubbedBytes-    hmac2 = M.hmac temp x01 :: M.HMAC H.Blake2b_512-    hmac3 = M.hmac temp (convert hmac2 `mappend` x02) :: M.HMAC H.Blake2b_512-    ck'   = convert hmac2-    sk    = convert hmac3--bytesToCKB :: ScrubbedBytes-            -> ChainingKey BLAKE2b-bytesToCKB = HCKB2s+    hmac key info = convert (M.hmac key info :: M.HMAC H.Blake2b_512) :: ScrubbedBytes+    tempKey = hmac ck keyMat+    loop = unfoldr $ \(c, i) -> let r = hmac tempKey (c `snoc` i) in+      if i == 0+        then Nothing+        else if i <= numOutputs+          then Just (r, (r, i + 1))+          else Nothing -ckToBytesB :: ChainingKey BLAKE2b-            -> ScrubbedBytes-ckToBytesB (HCKB2s ck) = ck+bytesToCK :: ScrubbedBytes+          -> ChainingKey BLAKE2b+bytesToCK = HCKB2b -toBytesB :: Digest BLAKE2b+ckToBytes :: ChainingKey BLAKE2b           -> ScrubbedBytes-toBytesB (HDB2s d) = convert d+ckToBytes (HCKB2b ck) = ck++toBytes :: Digest BLAKE2b+        -> ScrubbedBytes+toBytes (HDB2b d) = convert d

@@ -1,11 +1,10 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies #-}-----------------------------------------------------------------+{-# LANGUAGE TypeFamilies #-}+------------------------------------------------- -- | -- Module      : Crypto.Noise.Hash.BLAKE2s -- Maintainer  : John Galt <jgalt@centromere.net> -- Stability   : experimental -- Portability : POSIX- module Crypto.Noise.Hash.BLAKE2s   ( -- * Types     BLAKE2s@@ -13,7 +12,9 @@  import qualified Crypto.Hash     as H import qualified Crypto.MAC.HMAC as M-import Data.ByteArray (ScrubbedBytes, convert)+import Data.ByteArray (ScrubbedBytes, convert, empty, snoc)+import Data.List      (unfoldr)+import Data.Word      (Word8)  import Crypto.Noise.Hash @@ -26,40 +27,39 @@    hashName   _  = "BLAKE2s"   hashLength _  = 32-  hash          = hashS-  hashHKDF      = hkdfS-  hashBytesToCK = bytesToCKS-  hashCKToBytes = ckToBytesS-  hashToBytes   = toBytesS+  hash          = hash'+  hashHKDF      = hkdf+  hashBytesToCK = bytesToCK+  hashCKToBytes = ckToBytes+  hashToBytes   = toBytes -hashS :: ScrubbedBytes-       -> Digest BLAKE2s-hashS bs = HDB2s $ H.hash bs+hash' :: ScrubbedBytes+      -> Digest BLAKE2s+hash' bs = HDB2s $ H.hash bs -hkdfS :: ChainingKey BLAKE2s-       -> ScrubbedBytes-       -> (ChainingKey BLAKE2s, ScrubbedBytes)-hkdfS (HCKB2s ck) d = (HCKB2s ck', sk)+hkdf :: ChainingKey BLAKE2s+     -> ScrubbedBytes+     -> Word8+     -> [ScrubbedBytes]+hkdf (HCKB2s ck) keyMat numOutputs = loop (empty, 1)   where-    x01, x02 :: ScrubbedBytes-    x01   = "\x01"-    x02   = "\x02"--    hmac1 = M.hmac ck d :: M.HMAC H.Blake2s_256-    temp  = convert hmac1 :: ScrubbedBytes-    hmac2 = M.hmac temp x01 :: M.HMAC H.Blake2s_256-    hmac3 = M.hmac temp (convert hmac2 `mappend` x02) :: M.HMAC H.Blake2s_256-    ck'   = convert hmac2-    sk    = convert hmac3--bytesToCKS :: ScrubbedBytes-            -> ChainingKey BLAKE2s-bytesToCKS = HCKB2s+    hmac key info = convert (M.hmac key info :: M.HMAC H.Blake2s_256) :: ScrubbedBytes+    tempKey = hmac ck keyMat+    loop = unfoldr $ \(c, i) -> let r = hmac tempKey (c `snoc` i) in+      if i == 0+        then Nothing+        else if i <= numOutputs+          then Just (r, (r, i + 1))+          else Nothing -ckToBytesS :: ChainingKey BLAKE2s-            -> ScrubbedBytes-ckToBytesS (HCKB2s ck) = ck+bytesToCK :: ScrubbedBytes+          -> ChainingKey BLAKE2s+bytesToCK = HCKB2s -toBytesS :: Digest BLAKE2s+ckToBytes :: ChainingKey BLAKE2s           -> ScrubbedBytes-toBytesS (HDB2s d) = convert d+ckToBytes (HCKB2s ck) = ck++toBytes :: Digest BLAKE2s+        -> ScrubbedBytes+toBytes (HDB2s d) = convert d

@@ -1,11 +1,10 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies #-}-----------------------------------------------------------------+{-# LANGUAGE TypeFamilies #-}+------------------------------------------------- -- | -- Module      : Crypto.Noise.Hash.SHA256 -- Maintainer  : John Galt <jgalt@centromere.net> -- Stability   : experimental -- Portability : POSIX- module Crypto.Noise.Hash.SHA256   ( -- * Types     SHA256@@ -13,7 +12,9 @@  import qualified Crypto.Hash     as H import qualified Crypto.MAC.HMAC as M-import Data.ByteArray (ScrubbedBytes, convert)+import Data.ByteArray (ScrubbedBytes, convert, empty, snoc)+import Data.List      (unfoldr)+import Data.Word      (Word8)  import Crypto.Noise.Hash @@ -35,19 +36,20 @@ hash' :: ScrubbedBytes -> Digest SHA256 hash' bs = HDSHA256 $ H.hash bs -hkdf :: ChainingKey SHA256 -> ScrubbedBytes -> (ChainingKey SHA256, ScrubbedBytes)-hkdf (HCKSHA256 ck) d = (HCKSHA256 ck', sk)+hkdf :: ChainingKey SHA256+     -> ScrubbedBytes+     -> Word8+     -> [ScrubbedBytes]+hkdf (HCKSHA256 ck) keyMat numOutputs = loop (empty, 1)   where-    x01, x02 :: ScrubbedBytes-    x01   = "\x01"-    x02   = "\x02"--    hmac1 = M.hmac ck d :: M.HMAC H.SHA256-    temp  = convert hmac1 :: ScrubbedBytes-    hmac2 = M.hmac temp x01 :: M.HMAC H.SHA256-    hmac3 = M.hmac temp (convert hmac2 `mappend` x02) :: M.HMAC H.SHA256-    ck'   = convert hmac2-    sk    = convert hmac3+    hmac key info = convert (M.hmac key info :: M.HMAC H.SHA256) :: ScrubbedBytes+    tempKey = hmac ck keyMat+    loop = unfoldr $ \(c, i) -> let r = hmac tempKey (c `snoc` i) in+      if i == 0+        then Nothing+        else if i <= numOutputs+          then Just (r, (r, i + 1))+          else Nothing  bytesToCK :: ScrubbedBytes -> ChainingKey SHA256 bytesToCK = HCKSHA256

@@ -1,11 +1,10 @@-{-# LANGUAGE OverloadedStrings, TypeFamilies #-}-----------------------------------------------------------------+{-# LANGUAGE TypeFamilies #-}+------------------------------------------------- -- | -- Module      : Crypto.Noise.Hash.SHA512 -- Maintainer  : John Galt <jgalt@centromere.net> -- Stability   : experimental -- Portability : POSIX- module Crypto.Noise.Hash.SHA512   ( -- * Types     SHA512@@ -13,7 +12,9 @@  import qualified Crypto.Hash     as H import qualified Crypto.MAC.HMAC as M-import Data.ByteArray (ScrubbedBytes, convert)+import Data.ByteArray (ScrubbedBytes, convert, empty, snoc)+import Data.List      (unfoldr)+import Data.Word      (Word8)  import Crypto.Noise.Hash @@ -35,19 +36,20 @@ hash' :: ScrubbedBytes -> Digest SHA512 hash' bs = HDSHA512 $ H.hash bs -hkdf :: ChainingKey SHA512 -> ScrubbedBytes -> (ChainingKey SHA512, ScrubbedBytes)-hkdf (HCKSHA512 ck) d = (HCKSHA512 ck', sk)+hkdf :: ChainingKey SHA512+     -> ScrubbedBytes+     -> Word8+     -> [ScrubbedBytes]+hkdf (HCKSHA512 ck) keyMat numOutputs = loop (empty, 1)   where-    x01, x02 :: ScrubbedBytes-    x01   = "\x01"-    x02   = "\x02"--    hmac1 = M.hmac ck d :: M.HMAC H.SHA512-    temp  = convert hmac1 :: ScrubbedBytes-    hmac2 = M.hmac temp x01 :: M.HMAC H.SHA512-    hmac3 = M.hmac temp (convert hmac2 `mappend` x02) :: M.HMAC H.SHA512-    ck'   = convert hmac2-    sk    = convert hmac3+    hmac key info = convert (M.hmac key info :: M.HMAC H.SHA512) :: ScrubbedBytes+    tempKey = hmac ck keyMat+    loop = unfoldr $ \(c, i) -> let r = hmac tempKey (c `snoc` i) in+      if i == 0+        then Nothing+        else if i <= numOutputs+          then Just (r, (r, i + 1))+          else Nothing  bytesToCK :: ScrubbedBytes -> ChainingKey SHA512 bytesToCK = HCKSHA512

@@ -1,55 +1,79 @@ {-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_HADDOCK hide #-}-----------------------------------------------------------------+-------------------------------------------------- -- | -- Module      : Crypto.Noise.Internal.CipherState -- Maintainer  : John Galt <jgalt@centromere.net> -- Stability   : experimental -- Portability : POSIX- module Crypto.Noise.Internal.CipherState where  import Control.Exception.Safe import Control.Lens  import Crypto.Noise.Cipher-import Crypto.Noise.Internal.Types+import Crypto.Noise.Exception  data CipherState c =-  CipherState { _csk     :: SymmetricKey c+  CipherState { _csk     :: Maybe (SymmetricKey c)               , _csn     :: Nonce c-              , _csCount :: Integer               } deriving Show  $(makeLenses ''CipherState) -encryptAndIncrement :: (MonadThrow m, Cipher c)-                    => AssocData-                    -> Plaintext-                    -> CipherState c-                    -> m (Ciphertext c, CipherState c)-encryptAndIncrement ad plaintext cs-  | allow     = return (ct, newState)-  | otherwise = throwM $ MessageLimitReached "encryptAndIncrement"+-- | Creates a new CipherState with an optional symmetric key and a zero nonce.+cipherState :: Cipher c+            => Maybe (SymmetricKey c)+            -> CipherState c+cipherState sk = CipherState sk cipherZeroNonce++-- | Encrypts the provided plaintext and increments the nonce. If this+--   CipherState does not have a key associated with it, the plaintext+--   will be returned.+encryptWithAd :: (MonadThrow m, Cipher c)+              => AssocData+              -> Plaintext+              -> CipherState c+              -> m (Ciphertext c, CipherState c)+encryptWithAd ad plaintext cs+  | validNonce cs = return (result, newState)+  | otherwise     = throwM MessageLimitReached   where-    ct       = cipherEncrypt (cs ^. csk) (cs ^. csn) ad plaintext-    newState = cs & csn     %~ cipherIncNonce-                  & csCount %~ (+1)-    allow    = cs ^. csCount < 2 ^ (64 :: Integer) - 1+    result = maybe (cipherBytesToText plaintext)+                   (\k -> cipherEncrypt k (cs ^. csn) ad plaintext)+                   $ cs ^. csk+    newState = cs & csn %~ cipherIncNonce -decryptAndIncrement :: (MonadThrow m, Cipher c)-                    => AssocData-                    -> Ciphertext c-                    -> CipherState c-                    -> m (Plaintext, CipherState c)-decryptAndIncrement ad ct cs-  | allow     =-    maybe (throwM (DecryptionError "decryptAndIncrement"))+-- | Decrypts the provided ciphertext and increments the nonce. If this+--   CipherState does not have a key associated with it, the ciphertext+--   will be returned. If the CipherState does have a key and decryption+--   fails, a @DecryptionError@ will be returned.+decryptWithAd :: (MonadThrow m, Cipher c)+              => AssocData+              -> Ciphertext c+              -> CipherState c+              -> m (Plaintext, CipherState c)+decryptWithAd ad ct cs+  | validNonce cs =+    maybe (throwM DecryptionError)           (\x -> return (x, newState))-          pt-  | otherwise = throwM $ MessageLimitReached "decryptAndIncrement"+          result+  | otherwise     = throwM MessageLimitReached   where-    pt       = cipherDecrypt (cs ^. csk) (cs ^. csn) ad ct-    newState = cs & csn     %~ cipherIncNonce-                  & csCount %~ (+1)-    allow    = cs ^. csCount < 2 ^ (64 :: Integer) - 1+    result   = maybe (Just . cipherTextToBytes $ ct)+                     (\k -> cipherDecrypt k (cs ^. csn) ad ct)+                     $ cs ^. csk+    newState = cs & csn %~ cipherIncNonce++-- | Rekeys the CipherState. If a key has not been established yet, the+--   CipherState is returned unmodified.+rekey :: Cipher c+      => CipherState c+      -> CipherState c+rekey cs = cs & csk %~ (<*>) (pure cipherRekey)++-- | Tests whether the Nonce contained within a CipherState is valid (less+--   than the maximum allowed).+validNonce :: Cipher c+           => CipherState c+           -> Bool+validNonce cs = cs ^. csn < cipherMaxNonce

@@ -1,70 +0,0 @@-{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, FlexibleInstances,-    MultiParamTypeClasses, UndecidableInstances #-}-{-# OPTIONS_HADDOCK hide #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-------------------------------------------------------------------- |--- Module      : Crypto.Noise.Internal.Handshake--- Maintainer  : John Galt <jgalt@centromere.net>--- Stability   : experimental--- Portability : POSIX--module Crypto.Noise.Internal.Handshake where--import Control.Lens-import Control.Monad.Coroutine-import Control.Monad.Coroutine.SuspensionFunctors-import Control.Monad.Catch.Pure-import Control.Monad.State       (MonadState(..), StateT)-import Control.Monad.Trans.Class (MonadTrans(lift))-import Data.ByteArray            (ScrubbedBytes)--import Crypto.Noise.Cipher-import Crypto.Noise.DH-import Crypto.Noise.Internal.HandshakePattern-import Crypto.Noise.Internal.SymmetricState---- | Represents the side of the conversation upon which a party resides.-data HandshakeRole = InitiatorRole | ResponderRole-                     deriving Eq---- | Represents the various options which define a handshake.-data HandshakeOpts d =-  HandshakeOpts { _hoPattern             :: HandshakePattern-                , _hoRole                :: HandshakeRole-                , _hoPrologue            :: Plaintext-                , _hoPreSharedKey        :: Maybe Plaintext-                , _hoLocalStatic         :: Maybe (KeyPair d)-                , _hoLocalSemiEphemeral  :: Maybe (KeyPair d)-                , _hoLocalEphemeral      :: Maybe (KeyPair d)-                , _hoRemoteStatic        :: Maybe (PublicKey d)-                , _hoRemoteSemiEphemeral :: Maybe (PublicKey d)-                , _hoRemoteEphemeral     :: Maybe (PublicKey d)-                }--$(makeLenses ''HandshakeOpts)--data HandshakeState c d h =-  HandshakeState { _hsSymmetricState :: SymmetricState c h-                 , _hsOpts           :: HandshakeOpts d-                 , _hsMsgBuffer      :: ScrubbedBytes-                 }--$(makeLenses ''HandshakeState)--newtype Handshake c d h r =-  Handshake { runHandshake' :: Coroutine (Request ScrubbedBytes ScrubbedBytes) (StateT (HandshakeState c d h) Catch) r-            } deriving ( Functor-                       , Applicative-                       , Monad-                       , MonadThrow-                       , MonadState (HandshakeState c d h)-                       )--instance (Functor f, MonadThrow m) => MonadThrow (Coroutine f m) where-  throwM = lift . throwM--instance (Functor f, MonadState s m) => MonadState s (Coroutine f m) where-  get = lift get-  put = lift . put-  state = lift . state

@@ -0,0 +1,247 @@+{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}+------------------------------------------------------------+-- |+-- Module      : Crypto.Noise.Internal.Handshake.Interpreter+-- Maintainer  : John Galt <jgalt@centromere.net>+-- Stability   : experimental+-- Portability : POSIX+module Crypto.Noise.Internal.Handshake.Interpreter where++import Control.Applicative.Free+import Control.Exception.Safe+import Control.Lens+import Control.Monad.Coroutine.SuspensionFunctors+import Data.ByteArray (splitAt)+import Data.Maybe     (isJust)+import Data.Proxy+import Prelude hiding (splitAt)++import Crypto.Noise.Cipher+import Crypto.Noise.DH+import Crypto.Noise.Exception+import Crypto.Noise.Hash+import Crypto.Noise.Internal.Handshake.Pattern hiding (e, s, ee, es, se, ss)+import Crypto.Noise.Internal.Handshake.State+import Crypto.Noise.Internal.CipherState+import Crypto.Noise.Internal.SymmetricState++-- [ E ] -----------------------------------------------------------------------++interpretToken :: forall c d h r. (Cipher c, DH d, Hash h)+               => HandshakeRole+               -> Token r+               -> Handshake c d h r+interpretToken opRole (E next) = do+  myRole  <- use $ hsOpts . hoRole+  pskMode <- use hsPSKMode++  if opRole == myRole then do+    (_, pk) <- getKeyPair hoLocalEphemeral LocalEphemeral+    let pkBytes = dhPubToBytes pk++    if pskMode+      then hsSymmetricState %= mixKey pkBytes . mixHash pkBytes+      else hsSymmetricState %= mixHash pkBytes++    hsMsgBuffer      <>= pkBytes++  else do+    buf <- use hsMsgBuffer+    let (pkBytes, remainingBytes) = splitAt (dhLength (Proxy :: Proxy d)) buf+    theirKey <- maybe (throwM . InvalidKey $ RemoteEphemeral)+                      return+                      (dhBytesToPub pkBytes)+    hsOpts . hoRemoteEphemeral .= Just theirKey++    if pskMode+      then hsSymmetricState %= mixKey pkBytes . mixHash pkBytes+      else hsSymmetricState %= mixHash pkBytes++    hsMsgBuffer                .= remainingBytes++  return next++-- [ S ] -----------------------------------------------------------------------++interpretToken opRole (S next) = do+  myRole <- use $ hsOpts . hoRole++  if opRole == myRole then do+    ss <- use hsSymmetricState+    (_, pk) <- getKeyPair hoLocalStatic LocalStatic+    (ct, ss') <- encryptAndHash (dhPubToBytes pk) ss+    hsSymmetricState .= ss'+    hsMsgBuffer      <>= cipherTextToBytes ct++  else do+    configuredRemoteStatic <- use $ hsOpts . hoRemoteStatic+    if isJust configuredRemoteStatic+      then throwM StaticKeyOverwrite+      else do+        -- If a SymmetricKey has been established, the static key will be+        -- encrypted. In that case, the number of bytes to be read off the+        -- buffer will be the length of the public key plus a 16 byte+        -- authentication tag.+        k <- use $ hsSymmetricState . ssCipher . csk+        let dhLen     = dhLength (Proxy :: Proxy d)+            lenToRead = if isJust k then dhLen + 16 else dhLen++        buf <- use hsMsgBuffer+        ss  <- use hsSymmetricState+        let (b, rest) = splitAt lenToRead buf+        (pk, ss') <- decryptAndHash (cipherBytesToText b) ss+        pk' <- maybe (throwM . InvalidKey $ RemoteStatic)+                     return+                     (dhBytesToPub pk)++        hsOpts . hoRemoteStatic .= Just pk'+        hsSymmetricState        .= ss'+        hsMsgBuffer             .= rest++  return next++-- [ EE ] -----------------------------------------------------------------------++interpretToken _ (Ee next) = do+  ~(sk, _) <- getKeyPair   hoLocalEphemeral  LocalEphemeral+  rpk      <- getPublicKey hoRemoteEphemeral RemoteEphemeral+  hsSymmetricState %= mixKey (dhPerform sk rpk)++  return next++-- [ ES ] -----------------------------------------------------------------------++interpretToken _ (Es next) = do+  myRole <- use $ hsOpts . hoRole++  if myRole == InitiatorRole then do+    rpk      <- getPublicKey hoRemoteStatic   RemoteStatic+    ~(sk, _) <- getKeyPair   hoLocalEphemeral LocalEphemeral+    hsSymmetricState %= mixKey (dhPerform sk rpk)+  else do+    ~(sk, _) <- getKeyPair   hoLocalStatic     LocalStatic+    rpk      <- getPublicKey hoRemoteEphemeral RemoteEphemeral+    hsSymmetricState %= mixKey (dhPerform sk rpk)++  return next++-- [ SE ] -----------------------------------------------------------------------++interpretToken _ (Se next) = do+  myRole <- use $ hsOpts . hoRole++  if myRole == InitiatorRole then do+    ~(sk, _) <- getKeyPair   hoLocalStatic     LocalStatic+    rpk      <- getPublicKey hoRemoteEphemeral RemoteEphemeral+    hsSymmetricState %= mixKey (dhPerform sk rpk)+  else do+    rpk      <- getPublicKey hoRemoteStatic   RemoteStatic+    ~(sk, _) <- getKeyPair   hoLocalEphemeral LocalEphemeral+    hsSymmetricState %= mixKey (dhPerform sk rpk)++  return next++-- [ SS ] -----------------------------------------------------------------------++interpretToken _ (Ss next) = do+  ~(sk, _) <- getKeyPair   hoLocalStatic  LocalStatic+  rpk      <- getPublicKey hoRemoteStatic RemoteStatic+  hsSymmetricState %= mixKey (dhPerform sk rpk)++  return next++-- [ PSK ] -----------------------------------------------------------------------++interpretToken _ (Psk next) = do+  input <- Handshake <$> request $ HandshakeResultNeedPSK+  hsSymmetricState %= mixKeyAndHash input++  return next++processMsgPattern :: (Cipher c, DH d, Hash h)+                  => HandshakeRole+                  -> MessagePattern r+                  -> Handshake c d h r+processMsgPattern opRole mp = do+  myRole <- use $ hsOpts . hoRole+  buf    <- use hsMsgBuffer+  input  <- Handshake <$> request $ HandshakeResultMessage buf++  if opRole == myRole then do+    hsMsgBuffer .= mempty+    r  <- runAp (interpretToken opRole) mp+    ss <- use hsSymmetricState+    (encPayload, ss') <- encryptAndHash input ss+    hsMsgBuffer      <>= cipherTextToBytes encPayload+    hsSymmetricState .= ss'+    return r++  else do+    hsMsgBuffer .= input+    r         <- runAp (interpretToken opRole) mp+    remaining <- use hsMsgBuffer+    ss        <- use hsSymmetricState+    (decPayload, ss') <- decryptAndHash (cipherBytesToText remaining) ss+    hsMsgBuffer      .= decPayload+    hsSymmetricState .= ss'+    return r++interpretPreToken :: (Cipher c, DH d, Hash h)+                  => HandshakeRole+                  -> Token r+                  -> Handshake c d h r+interpretPreToken opRole (E next) = do+  myRole <- use $ hsOpts . hoRole+  pk <- if opRole == myRole+    then snd <$> getKeyPair hoLocalEphemeral LocalEphemeral+    else getPublicKey hoRemoteEphemeral RemoteEphemeral++  hsSymmetricState %= mixHash (dhPubToBytes pk)++  return next++interpretPreToken opRole (S next) = do+  myRole <- use $ hsOpts . hoRole+  pk <- if opRole == myRole+    then snd <$> getKeyPair hoLocalStatic LocalStatic+    else getPublicKey hoRemoteStatic RemoteStatic++  hsSymmetricState %= mixHash (dhPubToBytes pk)++  return next++interpretPreToken _ _ = throwM InvalidPattern++interpretMessage :: (Cipher c, DH d, Hash h)+                 => Message r+                 -> Handshake c d h r+interpretMessage (PreInitiator mp next) =+  runAp (interpretPreToken InitiatorRole) mp >> return next++interpretMessage (PreResponder mp next) =+  runAp (interpretPreToken ResponderRole) mp >> return next++interpretMessage (Initiator mp next) =+  processMsgPattern InitiatorRole mp >> return next++interpretMessage (Responder mp next) =+  processMsgPattern ResponderRole mp >> return next++runHandshakePattern :: (Cipher c, DH d, Hash h)+                    => HandshakePattern+                    -> Handshake c d h ()+runHandshakePattern hp = runAp interpretMessage $ hp ^. hpMsgSeq++getPublicKey :: Lens' (HandshakeOpts d) (Maybe (PublicKey d))+             -> ExceptionKeyType+             -> Handshake c d h (PublicKey d)+getPublicKey k keyType = do+  r <- use $ hsOpts . k+  maybe (throwM . KeyMissing $ keyType) return r++getKeyPair :: Lens' (HandshakeOpts d) (Maybe (KeyPair d))+           -> ExceptionKeyType+           -> Handshake c d h (KeyPair d)+getKeyPair k keyType = do+  r <- use $ hsOpts . k+  maybe (throwM . KeyMissing $ keyType) return r

@@ -0,0 +1,99 @@+{-# LANGUAGE TemplateHaskell #-}+--------------------------------------------------------+-- |+-- Module      : Crypto.Noise.Internal.Handshake.Pattern+-- Maintainer  : John Galt <jgalt@centromere.net>+-- Stability   : experimental+-- Portability : POSIX+module Crypto.Noise.Internal.Handshake.Pattern where++import Control.Applicative.Free+import Control.Lens+import Data.ByteString (ByteString)++data Token next+  = E   next+  | S   next+  | Ee  next+  | Es  next+  | Se  next+  | Ss  next+  | Psk next++type MessagePattern = Ap Token++e :: MessagePattern ()+e = liftAp $ E ()++s :: MessagePattern ()+s = liftAp $ S ()++ee :: MessagePattern ()+ee = liftAp $ Ee ()++es :: MessagePattern ()+es = liftAp $ Es ()++se :: MessagePattern ()+se = liftAp $ Se ()++ss :: MessagePattern ()+ss = liftAp $ Ss ()++psk :: MessagePattern ()+psk = liftAp $ Psk ()++data Message next+  = PreInitiator (MessagePattern ()) next+  | PreResponder (MessagePattern ()) next+  | Initiator    (MessagePattern ()) next+  | Responder    (MessagePattern ()) next++type MessageSequence = Ap Message++preInitiator :: MessagePattern () -> MessageSequence ()+preInitiator = liftAp . flip PreInitiator ()++preResponder :: MessagePattern () -> MessageSequence ()+preResponder = liftAp . flip PreResponder ()++initiator :: MessagePattern () -> MessageSequence ()+initiator = liftAp . flip Initiator ()++responder :: MessagePattern () -> MessageSequence ()+responder = liftAp . flip Responder ()++-- | This type represents a handshake pattern such as @Noise_IK@. A large set of+--   pre-defined patterns can be found in "Crypto.Noise.HandshakePatterns".+--   Expert users are encouraged to define their own custom patterns with care.+data HandshakePattern = HandshakePattern+  { _hpName    :: ByteString+  , _hpPSKMode :: Bool+  , _hpMsgSeq  :: MessageSequence ()+  }++$(makeLenses ''HandshakePattern)++newtype HasPSK = HasPSK { unPSK :: Bool }++-- | Constructs a 'HandshakePattern' given a protocol name (such as @XXpsk3@)+--   and raw pattern. Please see the README for information about creating your+--   own custom patterns.+handshakePattern :: ByteString+                 -> MessageSequence ()+                 -> HandshakePattern+handshakePattern protoName ms = HandshakePattern protoName hasPSK ms+  where+    hasPSK = unPSK $ runAp_ scanS ms++    scanS (PreInitiator _ _) = mempty+    scanS (PreResponder _ _) = mempty+    scanS (Initiator   mp _) = runAp_ scanP mp+    scanS (Responder   mp _) = runAp_ scanP mp++    scanP (Psk _) = HasPSK True+    scanP _       = mempty++instance Monoid HasPSK where+  mempty = HasPSK False+  (HasPSK a) `mappend` (HasPSK b) = HasPSK $ a || b

@@ -0,0 +1,145 @@+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, GeneralizedNewtypeDeriving,+             FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+------------------------------------------------------+-- |+-- Module      : Crypto.Noise.Internal.Handshake.State+-- Maintainer  : John Galt <jgalt@centromere.net>+-- Stability   : experimental+-- Portability : POSIX+module Crypto.Noise.Internal.Handshake.State where++import Control.Lens+import Control.Monad.Coroutine+import Control.Monad.Coroutine.SuspensionFunctors+import Control.Monad.Catch.Pure+import Control.Monad.State       (MonadState(..), StateT)+import Control.Monad.Trans.Class (MonadTrans(lift))+import Data.ByteArray            (ScrubbedBytes, convert)+import Data.ByteString           (ByteString)+import Data.Monoid               ((<>))+import Data.Proxy++import Crypto.Noise.Cipher+import Crypto.Noise.DH+import Crypto.Noise.Hash+import Crypto.Noise.Internal.Handshake.Pattern hiding (e, s, ee, es, se, ss)+import Crypto.Noise.Internal.SymmetricState++-- | Represents the side of the conversation upon which a party resides.+data HandshakeRole = InitiatorRole | ResponderRole+                     deriving (Show, Eq)++-- | Represents the various options and keys for a handshake parameterized by+--   the 'DH' method.+data HandshakeOpts d =+  HandshakeOpts { _hoRole                :: HandshakeRole+                , _hoPrologue            :: Plaintext+                , _hoLocalEphemeral      :: Maybe (KeyPair d)+                , _hoLocalStatic         :: Maybe (KeyPair d)+                , _hoRemoteEphemeral     :: Maybe (PublicKey d)+                , _hoRemoteStatic        :: Maybe (PublicKey d)+                }++$(makeLenses ''HandshakeOpts)++-- | Holds all state associated with the interpreter.+data HandshakeState c d h =+  HandshakeState { _hsSymmetricState :: SymmetricState c h+                 , _hsOpts           :: HandshakeOpts d+                 , _hsPSKMode        :: Bool+                 , _hsMsgBuffer      :: ScrubbedBytes+                 }++$(makeLenses ''HandshakeState)++-- | This data structure is yielded by the coroutine when more data is needed.+data HandshakeResult+  = HandshakeResultMessage ScrubbedBytes+  | HandshakeResultNeedPSK++-- | All HandshakePattern interpreters run within this Monad.+newtype Handshake c d h r =+  Handshake { runHandshake :: Coroutine (Request HandshakeResult ScrubbedBytes) (StateT (HandshakeState c d h) Catch) r+            } deriving ( Functor+                       , Applicative+                       , Monad+                       , MonadThrow+                       , MonadState (HandshakeState c d h)+                       )++-- | @defaultHandshakeOpts role prologue@ returns a default set of handshake+--   options. All keys are set to 'Nothing'.+defaultHandshakeOpts :: HandshakeRole+                     -> Plaintext+                     -> HandshakeOpts d+defaultHandshakeOpts r p =+  HandshakeOpts { _hoRole                = r+                , _hoPrologue            = p+                , _hoLocalEphemeral      = Nothing+                , _hoLocalStatic         = Nothing+                , _hoRemoteEphemeral     = Nothing+                , _hoRemoteStatic        = Nothing+                }++-- | Sets the local ephemeral key.+setLocalEphemeral :: Maybe (KeyPair d)+                  -> HandshakeOpts d+                  -> HandshakeOpts d+setLocalEphemeral k opts = opts { _hoLocalEphemeral = k }++-- | Sets the local static key.+setLocalStatic :: Maybe (KeyPair d)+               -> HandshakeOpts d+               -> HandshakeOpts d+setLocalStatic k opts = opts { _hoLocalStatic = k }++-- | Sets the remote ephemeral key (rarely needed).+setRemoteEphemeral :: Maybe (PublicKey d)+                   -> HandshakeOpts d+                   -> HandshakeOpts d+setRemoteEphemeral k opts = opts { _hoRemoteEphemeral = k }++-- | Sets the remote static key.+setRemoteStatic :: Maybe (PublicKey d)+                -> HandshakeOpts d+                -> HandshakeOpts d+setRemoteStatic k opts = opts { _hoRemoteStatic = k }++-- | Given a protocol name, returns the full handshake name according to the+--   rules in section 8.+mkHandshakeName :: forall c d h proxy. (Cipher c, DH d, Hash h)+                => ByteString+                -> proxy (c, d, h)+                -> ScrubbedBytes+mkHandshakeName protoName _ =+  "Noise_" <> convert protoName <> "_" <> d <> "_" <> c <> "_" <> h+  where+    c = cipherName (Proxy :: Proxy c)+    d = dhName     (Proxy :: Proxy d)+    h = hashName   (Proxy :: Proxy h)++-- | Constructs a HandshakeState from a given set of options and a protocol+--   name (such as "NN" or "IK").+handshakeState :: forall c d h. (Cipher c, DH d, Hash h)+               => HandshakeOpts d+               -> HandshakePattern+               -> HandshakeState c d h+handshakeState ho hp =+  HandshakeState { _hsSymmetricState = ss'+                 , _hsOpts           = ho+                 , _hsPSKMode        = hp ^. hpPSKMode+                 , _hsMsgBuffer      = mempty+                 }+  where+    ss  = symmetricState $ mkHandshakeName (hp ^. hpName)+                                           (Proxy :: Proxy (c, d, h))+    ss' = mixHash (ho ^. hoPrologue) ss++instance (Functor f, MonadThrow m) => MonadThrow (Coroutine f m) where+  throwM = lift . throwM++instance (Functor f, MonadState s m) => MonadState s (Coroutine f m) where+  get = lift get+  put = lift . put+  state = lift . state

@@ -0,0 +1,251 @@+{-# LANGUAGE TemplateHaskell #-}+-----------------------------------------------------------+-- |+-- Module      : Crypto.Noise.Internal.Handshake.Validation+-- Maintainer  : John Galt <jgalt@centromere.net>+-- Stability   : experimental+-- Portability : POSIX+module Crypto.Noise.Internal.Handshake.Validation where++import Control.Applicative.Free+import Control.Lens+import Control.Monad (when)+import Control.Monad.State++import Crypto.Noise.Internal.Handshake.Pattern++-- | @(message number, token number)@+--+--   Represents the location within the pattern at which an error resides,+--   starting with zero.+type ErrorPosition = (Int, Int)++-- | Represents a single error associated with a pattern.+--+--   * 'InitMultipleETokens', 'InitMultipleSTokens', 'RespMultipleETokens',+--     'RespMultipleSTokens' -- multiple @e@/@s@ tokens were encountered for a+--     message originating with the initiator/responder.+--+--   * 'InitSecretNotRandom', 'RespSecretNotRandom' -- From the protocol:+--+--     > After performing a DH between a remote public key and any local private+--     > key that is not an ephemeral private key, the local party must not send+--     > any encrypted data (i.e. must not call ENCRYPT()) unless it has also+--     > performed a DH between an ephemeral private key and the remote public+--     > key.+--+--   * 'DHInPreMsg' -- A DH token (such as @ee@ or @es@) was found in the+--     pre-message portion of the handshake.+--+--   * 'PSKInPreMsg' -- A @psk@ token was found in the pre-message portion of the+--     handshake.+--+--   * 'PSKWithoutEToken' -- A @psk@ token was used before an @e@ token was+--     encountered.+data InspectionError+  = InitMultipleETokens ErrorPosition+  | InitMultipleSTokens ErrorPosition+  | RespMultipleETokens ErrorPosition+  | RespMultipleSTokens ErrorPosition+  | InitSecretNotRandom ErrorPosition+  | RespSecretNotRandom ErrorPosition+  | DHInPreMsg          ErrorPosition+  | PSKInPreMsg         ErrorPosition+  | PSKWithoutEToken    ErrorPosition+  deriving Show++data Inspection = Inspection+  { _iInitESent    :: Bool+  , _iInitSSent    :: Bool+  , _iInitPSKSent  :: Bool+  , _iRespESent    :: Bool+  , _iRespSSent    :: Bool+  , _iRespPSKSent  :: Bool+  , _iInitRandReq  :: Bool+  , _iInitRandDone :: Bool+  , _iRespRandReq  :: Bool+  , _iRespRandDone :: Bool+  , _iCurTokenPos  :: Int+  , _iCurMsgPos    :: Int+  , _iErrors       :: [InspectionError]+  } deriving Show++$(makeLenses ''Inspection)++inspection :: Inspection+inspection = Inspection+  { _iInitESent    = False+  , _iInitSSent    = False+  , _iInitPSKSent  = False+  , _iRespESent    = False+  , _iRespSSent    = False+  , _iRespPSKSent  = False+  , _iInitRandReq  = False+  , _iInitRandDone = False+  , _iRespRandReq  = False+  , _iRespRandDone = False+  , _iCurTokenPos  = 0+  , _iCurMsgPos    = 0+  , _iErrors       = []+  }++verifyNotInPreMsg :: Message a -> State Inspection ()+verifyNotInPreMsg (PreInitiator _ _) = addError DHInPreMsg+verifyNotInPreMsg (PreResponder _ _) = addError DHInPreMsg+verifyNotInPreMsg (Initiator    _ _) = return ()+verifyNotInPreMsg (Responder    _ _) = return ()++verifyRandDoneIfReq :: Message a -> State Inspection ()+verifyRandDoneIfReq (Initiator _ _) = do+  initRandReq  <- use iInitRandReq+  initRandDone <- use iInitRandDone++  when (initRandReq && not initRandDone) $ addError InitSecretNotRandom++verifyRandDoneIfReq (Responder _ _) = do+  respRandReq  <- use iRespRandReq+  respRandDone <- use iRespRandDone++  when (respRandReq && not respRandDone) $ addError RespSecretNotRandom++verifyRandDoneIfReq _ = return ()++verifyESentIfPSK :: Message a -> State Inspection ()+verifyESentIfPSK (Initiator _ _) = do+  initESent   <- use iInitESent+  initPSKSent <- use iInitPSKSent++  when (initPSKSent && not initESent) $ addError PSKWithoutEToken++verifyESentIfPSK (Responder _ _) = do+  respESent   <- use iRespESent+  respPSKSent <- use iRespPSKSent++  when (respPSKSent && not respESent) $ addError PSKWithoutEToken++verifyESentIfPSK _ = return ()++continueToken :: a -> State Inspection a+continueToken next = iCurTokenPos %= (+ 1) >> return next++continueMsg :: a -> State Inspection a+continueMsg next = iCurTokenPos .= 0 >> iCurMsgPos %= (+ 1) >> return next++addError :: (ErrorPosition -> InspectionError) -> State Inspection ()+addError err = do+  msgPos   <- use iCurMsgPos+  tokenPos <- use iCurTokenPos+  iErrors <>= [err (msgPos, tokenPos)]++inspectToken :: Message m -> Token a -> State Inspection a+inspectToken m (E next) = do+  case m of+    PreInitiator _ _ -> checkInit+    PreResponder _ _ -> checkResp+    Initiator    _ _ -> checkInit+    Responder    _ _ -> checkResp++  continueToken next++  where+    checkInit = do+      initESent <- use iInitESent+      if initESent+        then addError InitMultipleETokens+        else iInitESent .= True++    checkResp = do+      respESent <- use iRespESent+      if respESent+        then addError RespMultipleETokens+        else iRespESent .= True++inspectToken m (S next) = do+  case m of+    PreInitiator _ _ -> checkInit+    PreResponder _ _ -> checkResp+    Initiator    _ _ -> checkInit+    Responder    _ _ -> checkResp++  continueToken next++  where+    checkInit = do+      initSSent <- use iInitSSent+      if initSSent+        then addError InitMultipleSTokens+        else iInitSSent .= True++    checkResp = do+      respSSent <- use iRespSSent+      if respSSent+        then addError RespMultipleSTokens+        else iRespSSent .= True++inspectToken m (Ee next) = do+  verifyNotInPreMsg m++  iInitRandDone .= True+  iRespRandDone .= True++  continueToken next++inspectToken m (Es next) = do+  verifyNotInPreMsg m++  iInitRandDone .= True+  iRespRandReq  .= True++  continueToken next++inspectToken m (Se next) = do+  verifyNotInPreMsg m++  iInitRandReq  .= True+  iRespRandDone .= True++  continueToken next++inspectToken m (Ss next) = do+  verifyNotInPreMsg m++  iInitRandReq .= True+  iRespRandReq .= True++  continueToken next++inspectToken m (Psk next) = do+  case m of+    PreInitiator _ _ -> addError PSKInPreMsg+    PreResponder _ _ -> addError PSKInPreMsg+    Initiator    _ _ -> iInitPSKSent .= True+    Responder    _ _ -> iRespPSKSent .= True++  continueToken next++inspectMessage :: Message a -> State Inspection a+inspectMessage m@(PreInitiator mp next) = do+  runAp (inspectToken m) mp+  continueMsg next++inspectMessage m@(PreResponder mp next) = do+  runAp (inspectToken m) mp+  continueMsg next++inspectMessage m@(Initiator mp next) = do+  runAp (inspectToken m) mp+  verifyRandDoneIfReq m+  verifyESentIfPSK m+  continueMsg next++inspectMessage m@(Responder mp next) = do+  runAp (inspectToken m) mp+  verifyRandDoneIfReq m+  verifyESentIfPSK m+  continueMsg next++-- | Validates a 'HandshakePattern' according to the rules defined in section+--   7.1 and 9.3 of the protocol. If no violations are found, the result will be+--   an empty list.+validateHandshakePattern :: HandshakePattern -> [InspectionError]+validateHandshakePattern hp = execState (runAp inspectMessage $ hp ^. hpMsgSeq) inspection ^. iErrors

@@ -1,44 +0,0 @@-{-# LANGUAGE TemplateHaskell, DeriveFunctor, FlexibleContexts #-}-{-# OPTIONS_HADDOCK hide #-}-------------------------------------------------------------------- |--- Module      : Crypto.Noise.Internal.HandshakePattern--- Maintainer  : John Galt <jgalt@centromere.net>--- Stability   : experimental--- Portability : POSIX--module Crypto.Noise.Internal.HandshakePattern where--import Control.Lens-import Control.Monad.Free.Church-import Control.Monad.Free.TH-import Data.ByteString (ByteString)--data TokenF next-  = E next-  | S next-  | Ee next-  | Es next-  | Se next-  | Ss next-  deriving Functor--$(makeFree ''TokenF)--data HandshakePatternF next-  = PreInitiator (F TokenF ()) next-  | PreResponder (F TokenF ()) next-  | Initiator (F TokenF ()) next-  | Responder (F TokenF ()) next-  deriving Functor--$(makeFree ''HandshakePatternF)---- | This type represents a single handshake pattern and is implemented as a---   Free Monad.-data HandshakePattern =-  HandshakePattern { _hpName    :: ByteString-                   , _hpActions :: F HandshakePatternF ()-                   }--$(makeLenses ''HandshakePattern)

@@ -1,402 +1,94 @@-{-# LANGUAGE OverloadedStrings, TemplateHaskell, ScopedTypeVariables #-}-{-# OPTIONS_HADDOCK hide #-}-----------------------------------------------------------------+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}+------------------------------------------------- -- | -- Module      : Crypto.Noise.Internal.NoiseState -- Maintainer  : John Galt <jgalt@centromere.net> -- Stability   : experimental -- Portability : POSIX- module Crypto.Noise.Internal.NoiseState where +import Control.Lens import Control.Monad.Catch.Pure import Control.Monad.Coroutine import Control.Monad.Coroutine.SuspensionFunctors-import Control.Monad.State  (MonadState(..), runStateT, get, put)-import Control.Monad.Free.Church-import Control.Lens-import Data.ByteArray       (ScrubbedBytes, convert, length, splitAt)-import Data.ByteString      (ByteString)-import Data.Maybe           (isJust)-import Data.Monoid          ((<>))-import Data.Proxy           (Proxy(..))-import Prelude hiding       (concat, splitAt, length)+import Control.Monad.State+import Data.ByteArray (ScrubbedBytes)  import Crypto.Noise.Cipher import Crypto.Noise.DH import Crypto.Noise.Hash import Crypto.Noise.Internal.CipherState-import Crypto.Noise.Internal.SymmetricState-import Crypto.Noise.Internal.Handshake-import Crypto.Noise.Internal.HandshakePattern hiding (e, s, ee, se, es, ss)-import Crypto.Noise.Internal.Types+import Crypto.Noise.Internal.Handshake.Interpreter+import Crypto.Noise.Internal.Handshake.Pattern (HandshakePattern)+import Crypto.Noise.Internal.Handshake.State+import Crypto.Noise.Internal.SymmetricState (split) --- | Represents the complete state of a Noise conversation.+-- | This type represents the state of an entire Noise conversation, and it is+--   used both during the handshake and for every message read and written+--   thereafter (transport messages). It is parameterized by the 'Cipher', 'DH'+--   method, and 'Hash' to be used. data NoiseState c d h =   NoiseState { _nsHandshakeState       :: HandshakeState c d h-             , _nsHandshakeSuspension  :: ScrubbedBytes -> Handshake c d h ()+             , _nsHandshakePattern     :: HandshakePattern+             , _nsHandshakeSuspension  :: Maybe (ScrubbedBytes -> Handshake c d h ())              , _nsSendingCipherState   :: Maybe (CipherState c)              , _nsReceivingCipherState :: Maybe (CipherState c)              }  $(makeLenses ''NoiseState) --- | Returns a default set of handshake options. The prologue is set to an---   empty string, PSK-mode is disabled, and all keys are set to 'Nothing'.-defaultHandshakeOpts :: HandshakePattern-                     -> HandshakeRole-                     -> HandshakeOpts d-defaultHandshakeOpts hp r =-  HandshakeOpts { _hoPattern             = hp-                , _hoRole                = r-                , _hoPrologue            = ""-                , _hoPreSharedKey        = Nothing-                , _hoLocalStatic         = Nothing-                , _hoLocalSemiEphemeral  = Nothing-                , _hoLocalEphemeral      = Nothing-                , _hoRemoteStatic        = Nothing-                , _hoRemoteSemiEphemeral = Nothing-                , _hoRemoteEphemeral     = Nothing-                }--mkHandshakeName :: forall c d h proxy. (Cipher c, DH d, Hash h)-                => ByteString-                -> Bool-                -> proxy (c, d, h)-                -> ScrubbedBytes-mkHandshakeName hpn psk _ = p <> convert hpn <> "_" <> d <> "_" <> c <> "_" <> h-  where-    p = if psk then "NoisePSK_" else "Noise_"-    c = cipherName (Proxy :: Proxy c)-    d = dhName     (Proxy :: Proxy d)-    h = hashName   (Proxy :: Proxy h)--handshakeState :: forall c d h. (Cipher c, DH d, Hash h)-               => HandshakeOpts d-               -> HandshakeState c d h-handshakeState ho | not (validPSK (ho ^. hoPreSharedKey)) = error "pre-shared key must be 32 bytes in length"-                  | otherwise =-  HandshakeState { _hsSymmetricState = ss''-                 , _hsOpts           = ho-                 , _hsMsgBuffer      = mempty-                 }-  where-    validPSK = maybe True (\psk -> length psk == 32)-    ss   = symmetricState $ mkHandshakeName (ho ^. hoPattern ^. hpName)-                                            (isJust (ho ^. hoPreSharedKey))-                                            (Proxy :: Proxy (c, d, h))--    ss'  = mixHash (ho ^. hoPrologue) ss-    ss'' = maybe ss' (`mixPSK` ss') $ ho ^. hoPreSharedKey--runHandshake :: (MonadThrow m, Cipher c, Hash h)-             => ScrubbedBytes-             -> NoiseState c d h-             -> m (ScrubbedBytes, NoiseState c d h)-runHandshake msg ns = reThrow . runCatch $ do-  ((res, ns''), hs') <- runStateT st $ ns ^. nsHandshakeState-  return (res, ns'' & nsHandshakeState .~ hs')--  where-    reThrow = either throwM return-    st = do-      x <- resume . runHandshake' . (ns ^. nsHandshakeSuspension) $ msg-      case x of-        Left (Request req resp) -> return (req, ns & nsHandshakeSuspension .~ (Handshake . resp))-        Right _ -> do-          hs <- get--          let (cs1, cs2) = split (hs ^. hsSymmetricState)-              ns'        = if hs ^. hsOpts . hoRole == InitiatorRole-                             then ns & nsSendingCipherState   .~ Just cs1-                                     & nsReceivingCipherState .~ Just cs2-                             else ns & nsSendingCipherState   .~ Just cs2-                                     & nsReceivingCipherState .~ Just cs1-          return (hs ^. hsMsgBuffer, ns')---- | Creates a 'NoiseState'.-noiseState :: forall c d h. (Cipher c, DH d, Hash h)+-- | Creates a 'NoiseState' from the given handshake options and pattern.+noiseState :: (Cipher c, DH d, Hash h)            => HandshakeOpts d+           -> HandshakePattern            -> NoiseState c d h-noiseState ho =-  NoiseState { _nsHandshakeState       = hs''-             , _nsHandshakeSuspension  = suspension+noiseState ho hp =+  NoiseState { _nsHandshakeState       = handshakeState ho hp+             , _nsHandshakePattern     = hp+             , _nsHandshakeSuspension  = Nothing              , _nsSendingCipherState   = Nothing              , _nsReceivingCipherState = Nothing              } -  where-    hs        = handshakeState ho :: HandshakeState c d h-    coroutine = iterM evalPattern $ ho ^. hoPattern . hpActions-    (suspension, hs'') = case runCatch (runStateT (resume (runHandshake' coroutine)) hs) of-            Left err -> error $ "handshake pattern interpreter threw exception: " <> show err-            Right result -> case result of-              (Left (Request _ resp), hs') -> (Handshake . resp, hs')-              _ -> error "handshake pattern interpreter ended pre-maturely"--processPatternOp :: (Cipher c, DH d, Hash h)-                 => HandshakeRole-                 -> F TokenF ()-                 -> Handshake c d h ()-                 -> Handshake c d h ()-processPatternOp opRole t next = do-  hs <- get-  input <- Handshake <$> request $ hs ^. hsMsgBuffer-  hs' <- get--  if opRole == hs' ^. hsOpts . hoRole then do-    put $ hs' & hsMsgBuffer .~ mempty-    iterM (evalMsgToken opRole) t--    hs'' <- get--    let enc = encryptAndHash (convert input) $ hs'' ^. hsSymmetricState--    (ep, ss) <- either throwM return enc--    put $ hs'' & hsMsgBuffer      %~ (flip mappend . convert) ep-               & hsSymmetricState .~ ss-  else do-    put $ hs' & hsMsgBuffer .~ input-    iterM (evalMsgToken opRole) t--    hs'' <- get--    let remaining = hs'' ^. hsMsgBuffer-        dec       = decryptAndHash (cipherBytesToText (convert remaining))-                    $ hs'' ^. hsSymmetricState--    (dp, ss) <- either (const . throwM . HandshakeError $ "handshake payload failed to decrypt") return dec--    put $ hs'' & hsMsgBuffer      .~ convert dp-               & hsSymmetricState .~ ss--  next--evalPattern :: (Cipher c, DH d, Hash h)-            => HandshakePatternF (Handshake c d h ())-            -> Handshake c d h ()-evalPattern (PreInitiator t next) = do-  iterM (evalPreMsgToken InitiatorRole) t-  next--evalPattern (PreResponder t next) = do-  iterM (evalPreMsgToken ResponderRole) t-  next--evalPattern (Initiator t next) = processPatternOp InitiatorRole t next-evalPattern (Responder t next) = processPatternOp ResponderRole t next--evalMsgToken :: forall c d h. (Cipher c, DH d, Hash h)-             => HandshakeRole-             -> TokenF (Handshake c d h ())-             -> Handshake c d h ()-evalMsgToken opRole (E next) = do-  hs <- get--  if opRole == hs ^. hsOpts . hoRole then do-    (_, pk) <- getLocalEphemeral hs-    let pk'     = dhPubToBytes pk-        ss      = hs ^. hsSymmetricState-        ss'     = mixHash pk' ss-        ss''    = if ss' ^. ssHasPSK then mixKey pk' ss' else ss'--    put $ hs & hsSymmetricState .~ ss''-             & hsMsgBuffer      %~ (flip mappend . convert) pk'--  else do-    let (b, rest) = splitAt (dhLength (Proxy :: Proxy d)) $ hs ^. hsMsgBuffer-        reBytes   = convert b-        ss        = hs ^. hsSymmetricState-        ss'       = mixHash reBytes ss-        ss''      = if ss ^. ssHasPSK then mixKey reBytes ss' else ss'-        theirKey  = dhBytesToPub reBytes--    theirKey' <- maybe (throwM . HandshakeError $ "invalid remote ephemeral key") return theirKey--    put $ hs & hsOpts . hoRemoteEphemeral .~ Just theirKey'-             & hsSymmetricState           .~ ss''-             & hsMsgBuffer                .~ rest--  next--evalMsgToken opRole (S next) = do-  hs <- get--  if opRole == hs ^. hsOpts. hoRole then do-    pk <- dhPubToBytes . snd <$> getLocalStatic hs-    let ss  = hs ^. hsSymmetricState-        enc = encryptAndHash (convert pk) ss--    (ct, ss') <- either throwM return enc--    put $ hs & hsSymmetricState .~ ss'-             & hsMsgBuffer      %~ (flip mappend . convert) ct-  else-    if isJust (hs ^. hsOpts ^. hoRemoteStatic)-      then throwM . InvalidHandshakeOptions $ "unable to overwrite remote static key"-      else do-        let hasKey    = hs ^. hsSymmetricState . ssHasKey-            len       = dhLength (Proxy :: Proxy d)-            -- The magic 16 here represents the length of the auth tag.-            d         = if hasKey then len + 16 else len-            (b, rest) = splitAt d $ hs ^. hsMsgBuffer-            ct        = cipherBytesToText . convert $ b-            ss        = hs ^. hsSymmetricState-            dec       = decryptAndHash ct ss--        (pt, ss')     <- either (const . throwM . HandshakeError $ "failed to decrypt remote static key") return dec-        theirKey'     <- maybe (throwM . HandshakeError $ "invalid remote static key provided") return $ dhBytesToPub pt--        put $ hs & hsOpts . hoRemoteStatic .~ Just theirKey'-                 & hsSymmetricState        .~ ss'-                 & hsMsgBuffer             .~ rest--  next--evalMsgToken _ (Ee next) = do-  hs <- get--  ~(sk, _) <- getLocalEphemeral hs-  rpk      <- getRemoteEphemeral hs--  let ss'  = mixKey (dhPerform sk rpk) $ hs ^. hsSymmetricState--  put $ hs & hsSymmetricState .~ ss'--  next--evalMsgToken _ (Es next) = do-  hs <- get--  let ss = hs ^. hsSymmetricState--  if hs ^. hsOpts . hoRole == InitiatorRole then do-    rpk <- getRemoteStatic hs--    ~(sk, _) <- getLocalEphemeral hs-    let dh  = dhPerform sk rpk-        ss' = mixKey dh ss--    put $ hs & hsSymmetricState .~ ss'--  else do-    ~(sk, _) <- getLocalStatic hs--    rpk <- getRemoteEphemeral hs-    let dh  = dhPerform sk rpk-        ss' = mixKey dh ss--    put $ hs & hsSymmetricState .~ ss'--  next--evalMsgToken _ (Se next) = do-  hs <- get--  let ss = hs ^. hsSymmetricState--  if hs ^. hsOpts . hoRole == InitiatorRole then do-    ~(sk, _) <- getLocalStatic hs--    rpk <- getRemoteEphemeral hs-    let dh  = dhPerform sk rpk-        ss' = mixKey dh ss--    put $ hs & hsSymmetricState .~ ss'--  else do-    rpk <- getRemoteStatic hs--    ~(sk, _) <- getLocalEphemeral hs-    let dh  = dhPerform sk rpk-        ss' = mixKey dh ss--    put $ hs & hsSymmetricState .~ ss'--  next--evalMsgToken _ (Ss next) = do-  hs <- get--  let ss = hs ^. hsSymmetricState--  ~(sk, _) <- getLocalStatic hs-  rpk      <- getRemoteStatic hs-  let dh  = dhPerform sk rpk-      ss' = mixKey dh ss--  put $ hs & hsSymmetricState .~ ss'--  next--evalPreMsgToken :: (Cipher c, DH d, Hash h)-                => HandshakeRole-                -> TokenF (Handshake c d h ())-                -> Handshake c d h ()-evalPreMsgToken opRole (E next) = do-  hs <- get--  let ss = hs ^. hsSymmetricState-  pk <- if opRole == hs ^. hsOpts . hoRole-    then snd <$> getLocalSemiEphemeral hs-    else getRemoteSemiEphemeral hs--  let ss' = mixHash (dhPubToBytes pk) ss--  put $ hs & hsSymmetricState .~ ss'--  next--evalPreMsgToken opRole (S next) = do-  hs <- get--  let ss = hs ^. hsSymmetricState--  pk <- if opRole == hs ^. hsOpts . hoRole-    then snd <$> getLocalStatic hs-    else getRemoteStatic hs--  let ss' = mixHash (dhPubToBytes pk) ss--  put $ hs & hsSymmetricState .~ ss'--  next--evalPreMsgToken _ _ = error "invalid pre-message pattern token"--getLocalStatic :: HandshakeState c d h-               -> Handshake c d h (KeyPair d)-getLocalStatic hs = maybe (throwM (InvalidHandshakeOptions "local static key not set"))-                          return-                          (hs ^. hsOpts ^. hoLocalStatic)+-- | Resumes a handshake in progress using the given input data.+resumeHandshake :: (MonadThrow m, Cipher c, DH d, Hash h)+                => ScrubbedBytes+                -> NoiseState c d h+                -> m (HandshakeResult, NoiseState c d h)+resumeHandshake msg ns = case ns ^. nsHandshakeSuspension of+  Nothing -> do+    let hp = ns ^. nsHandshakePattern+    (_, ns') <- runInterpreter . runHandshakePattern $ hp+    resumeHandshake msg ns' -getLocalSemiEphemeral :: HandshakeState c d h-                      -> Handshake c d h (KeyPair d)-getLocalSemiEphemeral hs = maybe (throwM (InvalidHandshakeOptions "local semi-ephemeral key not set"))-                                 return-                                 (hs ^. hsOpts ^. hoLocalSemiEphemeral)+  Just s -> runInterpreter . s $ msg -getLocalEphemeral :: HandshakeState c d h-                  -> Handshake c d h (KeyPair d)-getLocalEphemeral hs = maybe (throwM (InvalidHandshakeOptions "local ephemeral key not set"))-                             return-                             (hs ^. hsOpts ^. hoLocalEphemeral)+  where+    runInterpreter i = do+      let result = runCatch . runStateT (resume . runHandshake $ i)+                                        $ ns ^. nsHandshakeState+      case result of+        -- The interpreter threw an exception. Propagate it up the chain.+        Left err -> throwM err+        -- The interpreter did not throw an exception. Determine if it finished+        -- running.+        Right (suspension, hs) -> case suspension of+          -- The handshake pattern has not finished running. Save the suspension+          -- and the mutated HandshakeState and return what was yielded.+          Left (Request req resp) -> do+            let ns' = ns & nsHandshakeSuspension .~ Just (Handshake . resp)+                         & nsHandshakeState      .~ hs+            return (req, ns')+          -- The handshake pattern has finished running. Create the CipherStates.+          Right _ -> do+            let (cs1, cs2) = split (hs ^. hsSymmetricState) -getRemoteStatic :: HandshakeState c d h-                -> Handshake c d h (PublicKey d)-getRemoteStatic hs = maybe (throwM (InvalidHandshakeOptions "remote static key not set"))-                           return-                           (hs ^. hsOpts ^. hoRemoteStatic)+                ns'        = if hs ^. hsOpts . hoRole == InitiatorRole+                               then ns & nsSendingCipherState   .~ Just cs1+                                       & nsReceivingCipherState .~ Just cs2+                               else ns & nsSendingCipherState   .~ Just cs2+                                       & nsReceivingCipherState .~ Just cs1 -getRemoteSemiEphemeral :: HandshakeState c d h-                       -> Handshake c d h (PublicKey d)-getRemoteSemiEphemeral hs = maybe (throwM (InvalidHandshakeOptions "remote semi-ephemeral key not set"))-                                  return-                                  (hs ^. hsOpts ^. hoRemoteSemiEphemeral)+                ns''       = ns' & nsHandshakeState .~ hs -getRemoteEphemeral :: HandshakeState c d h-                   -> Handshake c d h (PublicKey d)-getRemoteEphemeral hs = maybe (throwM (InvalidHandshakeOptions "remote ephemeral key not set"))-                              return-                              (hs ^. hsOpts ^. hoRemoteEphemeral)+            return (HandshakeResultMessage (hs ^. hsMsgBuffer), ns'')

@@ -1,19 +1,15 @@ {-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}-{-# OPTIONS_HADDOCK hide #-}-----------------------------------------------------------------+----------------------------------------------------- -- | -- Module      : Crypto.Noise.Internal.SymmetricState -- Maintainer  : John Galt <jgalt@centromere.net> -- Stability   : experimental -- Portability : POSIX- module Crypto.Noise.Internal.SymmetricState where -import Control.Arrow import Control.Exception.Safe import Control.Lens-import Data.ByteArray  (ScrubbedBytes, convert, length, replicate)-import Data.ByteString (empty)+import Data.ByteArray  (ScrubbedBytes, length, replicate) import Data.Proxy import Prelude hiding  (length, replicate) @@ -23,90 +19,96 @@  data SymmetricState c h =   SymmetricState { _ssCipher :: CipherState c-                 , _ssHasKey :: Bool-                 , _ssHasPSK :: Bool                  , _ssck     :: ChainingKey h                  , _ssh      :: Either ScrubbedBytes (Digest h)-                 , _ssk      :: ScrubbedBytes                  }  $(makeLenses ''SymmetricState) +-- | Creates a new SymmetricState from the given protocol name. symmetricState :: forall c h. (Cipher c, Hash h)                => ScrubbedBytes                -> SymmetricState c h-symmetricState hsn = SymmetricState cs False False ck hsn' (convert empty)+symmetricState protoName = SymmetricState cs ck h   where     hashLen    = hashLength (Proxy :: Proxy h)-    shouldHash = length hsn > hashLen-    hsn'       = if shouldHash-                   then Right $ hash hsn-                   else Left $ hsn `mappend` replicate (hashLen - length hsn) 0-    ck         = hashBytesToCK . sshBytes $ hsn'-    cs         = CipherState undefined undefined 0+    shouldHash = length protoName > hashLen+    h         = if shouldHash+                   then Right $ hash protoName+                   else Left $ protoName `mappend` replicate (hashLen - length protoName) 0+    ck         = hashBytesToCK . sshBytes $ h+    cs         = cipherState Nothing +-- | Mixes keying material in to the SymmetricState. mixKey :: (Cipher c, Hash h)        => ScrubbedBytes        -> SymmetricState c h        -> SymmetricState c h-mixKey d ss = ss & ssCipher .~ cs-                 & ssHasKey .~ True-                 & ssck     .~ ck-  where-    (ck, k) = hashHKDF (ss ^. ssck) d-    cs      = CipherState (cipherBytesToSym k) cipherZeroNonce 0--mixPSK :: Hash h-       => ScrubbedBytes-       -> SymmetricState c h-       -> SymmetricState c h-mixPSK psk ss = ss'' & ssHasPSK .~ True+mixKey keyMat ss = ss & ssCipher .~ cs+                      & ssck     .~ hashBytesToCK ck   where-    (ck, tmp) = hashHKDF (ss ^. ssck) psk-    ss'       = ss & ssck .~ ck-    ss''      = mixHash tmp ss'+    [ck, k] = hashHKDF (ss ^. ssck) keyMat 2+    -- k is truncated automatically by cipherBytesToSym+    cs      = cipherState . Just . cipherBytesToSym $ k +-- | Mixes arbitrary data in to the SymmetricState. mixHash :: Hash h         => ScrubbedBytes         -> SymmetricState c h         -> SymmetricState c h mixHash d ss = ss & ssh %~ Right . hash . (`mappend` d) . sshBytes +-- | Mixes key material and arbitrary data in to the SymmetricState.+--   Note that this is not isomorphic to @mixHash . mixKey@.+mixKeyAndHash :: (Cipher c, Hash h)+              => ScrubbedBytes+              -> SymmetricState c h+              -> SymmetricState c h+mixKeyAndHash keyMat ss = ss' & ssCipher .~ cs+                              & ssck     .~ hashBytesToCK ck+  where+    [ck, h, k] = hashHKDF (ss ^. ssck) keyMat 3+    ss'        = mixHash h ss+    cs         = cipherState . Just . cipherBytesToSym $ k++-- | Encrypts the given Plaintext. Note that this may not actually perform+--   encryption if a key has not been established yet, in which case the+--   original plaintext is returned. encryptAndHash :: (MonadThrow m, Cipher c, Hash h)                => Plaintext                -> SymmetricState c h-               -> m (ScrubbedBytes, SymmetricState c h)-encryptAndHash pt ss-  | ss ^. ssHasKey = mix . first toBytes <$> enc-  | otherwise      = return (pt, mixHash pt ss)-  where-    enc          = encryptAndIncrement (sshBytes (ss ^. ssh)) pt (ss ^. ssCipher)-    mix (cb, cs) = (cb, mixHash cb ss & ssCipher .~ cs)-    toBytes      = arr cipherTextToBytes+               -> m (Ciphertext c, SymmetricState c h)+encryptAndHash pt ss = do+  (ct, cs) <- encryptWithAd (sshBytes (ss ^. ssh)) pt (ss ^. ssCipher)+  let ss' = mixHash (cipherTextToBytes ct) ss+  return (ct, ss' & ssCipher .~ cs) +-- | Decrypts the given Ciphertext. Note that this may not actually perform+--   decryption if a key as not been established yet, in which case the+--   original ciphertext is returned. decryptAndHash :: (MonadThrow m, Cipher c, Hash h)                => Ciphertext c                -> SymmetricState c h                -> m (Plaintext, SymmetricState c h)-decryptAndHash ct ss-  | ss ^. ssHasKey = second kss <$> dec-  | otherwise      = return (ct', mixHash ct' ss)-  where-    dec  = decryptAndIncrement (sshBytes (ss ^. ssh)) ct (ss ^. ssCipher)-    kss  = arr $ \cs -> mixHash ct' ss & ssCipher .~ cs-    ct'  = cipherTextToBytes ct+decryptAndHash ct ss = do+  (pt, cs) <- decryptWithAd (sshBytes (ss ^. ssh)) ct (ss ^. ssCipher)+  let ss' = mixHash (cipherTextToBytes ct) ss+  return (pt, ss' & ssCipher .~ cs) +-- | Returns a pair of CipherStates for encrypting transport messages. The+--   first CipherState is for encrypting messages from the Initiator to the+--   Responder, and the second is for encrypting messages from the Responder+--   to the Initiator. split :: (Cipher c, Hash h)       => SymmetricState c h       -> (CipherState c, CipherState c)-split ss = (cs1, cs2)+split ss = (c1, c2)   where-    (cs1k, cs2k) = hashHKDF (ss ^. ssck) (ss ^. ssk)-    cs1k' = cipherBytesToSym . hashCKToBytes $ cs1k-    cs2k' = cipherBytesToSym cs2k-    cs1   = CipherState cs1k' cipherZeroNonce 0-    cs2   = CipherState cs2k' cipherZeroNonce 0+    [k1, k2] = hashHKDF (ss ^. ssck) mempty 2+    c1       = cipherState . Just . cipherBytesToSym $ k1+    c2       = cipherState . Just . cipherBytesToSym $ k2 +-- | Utility function to convert the hash state to ScrubbedBytes. sshBytes :: Hash h          => Either ScrubbedBytes (Digest h)          -> ScrubbedBytes

@@ -1,37 +0,0 @@-------------------------------------------------------------------- |--- Module      : Crypto.Noise.Internal.Types--- Maintainer  : John Galt <jgalt@centromere.net>--- Stability   : experimental--- Portability : POSIX--module Crypto.Noise.Internal.Types where--import Control.Exception.Safe---- | Represents the various exceptions which can be thrown.------   * 'InvalidHandshakeOptions' occurs when a key that is needed is missing, or---   when a key is provided that shouldn't be. For example, it would be an---   error for the initiator to provide a remote static key if using the---   @Noise_NX@ pattern, because that key is transmitted during the---   handshake.------   * 'DecryptionError' occurs when a non-handshake message fails to be---   decrypted.------   * 'HandshakeError' occurs when a handshake message fails to be---   processed. This can be due to an invalid transmitted ephemeral key,---   a transmitted static key which fails to be decrypted, or a handshake---   message payload which fails to be decrypted.------   * 'MessageLimitReached' occurs if the user attempts to send or receive---   more than 2^64 messages. This is needed because nonces are 8-bytes---   (64 bits), and doing so would cause catastrophic key re-use.-data NoiseException = InvalidHandshakeOptions String-                    | DecryptionError String-                    | HandshakeError String-                    | MessageLimitReached String-                    deriving Show--instance Exception NoiseException

@@ -0,0 +1,15 @@+-----------------------------------------------------+-- |+-- Module      : Crypto.Noise.Validation+-- Maintainer  : John Galt <jgalt@centromere.net>+-- Stability   : experimental+-- Portability : POSIX+module Crypto.Noise.Validation+  ( -- * Types+    InspectionError(..)+  , ErrorPosition+    -- * Functions+  , validateHandshakePattern+  ) where++import Crypto.Noise.Internal.Handshake.Validation

@@ -0,0 +1,6 @@+resolver: lts-8.19+packages:+  - '.'+extra-deps: []+flags: {}+extra-package-dbs: []

@@ -4,3 +4,5 @@ import "hint" HLint.HLint  ignore "Reduce duplication"+ignore "Parse error"+ignore "Use module export list"

@@ -11,7 +11,7 @@   hints <- hlint $ [ "src"                    , "benchmarks"                    , "tests"-                   , "examples"+                   , "tools"                    , "--hint=tests/.hlint"                    , "--cpp-define=HLINT"                    ] `mappend` args

@@ -1,153 +1,176 @@-{-# LANGUAGE OverloadedStrings, GADTs #-}+{-# LANGUAGE GADTs, RecordWildCards #-} module Generate where -import Control.Concurrent.Async (mapConcurrently)-import Control.Lens             ((^.))-import Data.Aeson               (encode)-import Data.ByteArray           (ScrubbedBytes, convert)-import Data.ByteString          (ByteString)-import qualified Data.ByteString.Base16 as B16-import Data.ByteString.Lazy     (writeFile)-import Data.Maybe               (fromJust)-import Data.Monoid              ((<>))-import Prelude hiding           (writeFile)+import Control.Exception    (SomeException)+import Data.Aeson           (encode)+import Data.ByteString.Lazy (writeFile)+import Data.Either          (isLeft)+import Data.Monoid          ((<>))+import Prelude hiding       (writeFile)  import Crypto.Noise-import Crypto.Noise.Cipher import Crypto.Noise.DH-import Crypto.Noise.Hash-import Crypto.Noise.Internal.Handshake-import Crypto.Noise.Internal.NoiseState -import Handshakes+import Keys import Types import VectorFile -hexToPlaintext :: ByteString-               -> ScrubbedBytes-hexToPlaintext = convert . fst . B16.decode+genMessage :: (Cipher c, DH d, Hash h)+           => Bool             -- ^ True if we are writing a message+           -> [ScrubbedBytes]  -- ^ List of PSKs available for use+           -> ScrubbedBytes    -- ^ The payload to write/read+           -> NoiseState c d h -- ^ The NoiseState to use+           -> ([ScrubbedBytes], NoiseResult c d h)+genMessage write psks payload state = case result of+  NoiseResultNeedPSK s -> if null psks+    then (psks, NoiseResultException . error $ "not enough PSKs provided for handshake pattern")+    else genMessage write (tail psks) (head psks) s+  r -> (psks, r)+  where+    operation = if write then writeMessage else readMessage+    result    = operation payload state -hexToPair :: DH d-          => ByteString-          -> KeyPair d-hexToPair = fromJust . dhBytesToPair . convert . fst . B16.decode+genMessages :: (Cipher c, DH d, Hash h)+            => Bool             -- ^ Set to False for one-way patterns+            -> NoiseState c d h -- ^ Initiator NoiseState+            -> NoiseState c d h -- ^ Responder NoiseState+            -> [ScrubbedBytes]  -- ^ Initiator PSKs+            -> [ScrubbedBytes]  -- ^ Responder PSKs+            -> [ScrubbedBytes]  -- ^ Payloads+            -> ([Either SomeException Message], ScrubbedBytes)+genMessages swap = go []+  where+    go acc s _ _ _ [] = (acc, handshakeHash s)+    go acc sendingState receivingState spsks rpsks (payload : rest) =+      case genMessage True spsks payload sendingState of+        (spsks', NoiseResultMessage ct sendingState') ->+          case genMessage False rpsks ct receivingState of+            (rpsks', NoiseResultMessage pt receivingState') ->+              if swap+                then go (acc <> [Right (Message pt ct)]) receivingState' sendingState' rpsks' spsks' rest+                else go (acc <> [Right (Message pt ct)]) sendingState' receivingState' spsks' rpsks' rest -initiatorEphemeral :: DH d-                   => DHType d-                   -> KeyPair d-initiatorEphemeral DTCurve25519 = hexToPair "893e28b9dc6ca8d611ab664754b8ceb7bac5117349a4439a6b0569da977c464a"-initiatorEphemeral DTCurve448 = hexToPair "7fd26c8b8a0d5c98c85ff9ca1d7bc66d78578b9f2c4c170850748b27992767e6ea6cc9992a561c9d19dfc342e260c280ef4f3f9b8f879d4e"+            (_, NoiseResultException ex) -> (acc <> [Left ex], handshakeHash sendingState)+            _ -> undefined -- the genMessage function should handle this -responderEphemeral :: DH d-                   => DHType d-                   -> KeyPair d-responderEphemeral DTCurve25519 = hexToPair "bbdb4cdbd309f1a1f2e1456967fe288cadd6f712d65dc7b7793d5e63da6b375b"-responderEphemeral DTCurve448 = hexToPair "3facf7503ebee252465689f1d4e3b1dd219639ef9de4ffd6049d6d71a0f62126840febb99042421ce12af6626d98d9170260390fbc8399a5"+        (_, NoiseResultException ex) -> (acc <> [Left ex], handshakeHash sendingState)+        _ -> undefined -- the genMessage function should handle this -initiatorStatic :: DH d-                => DHType d-                -> KeyPair d-initiatorStatic DTCurve25519 = hexToPair "e61ef9919cde45dd5f82166404bd08e38bceb5dfdfded0a34c8df7ed542214d1"-initiatorStatic DTCurve448 = hexToPair "34d564c4be963d1b2a89fcfe83e6a72b5e3f5e3127f9f596ffc7575e418dfc1f4e827cfc10c9fed38e92ad56ddf8f08571430df2e76d5411"+genNoiseStates :: (Cipher c, DH d, Hash h)+               => CipherType c+               -> HashType h+               -> PatternName+               -> (HandshakeOpts d, HandshakeOpts d)+               -> (NoiseState c d h, NoiseState c d h)+genNoiseStates _ _ pat (iopts, ropts) =+  (noiseState iopts hs, noiseState ropts hs)+  where+    hs = patternToHandshake pat -responderStatic :: DH d-                => DHType d-                -> KeyPair d-responderStatic DTCurve25519 = hexToPair "4a3acbfdb163dec651dfa3194dece676d437029c62a408b4c5ea9114246e4893"-responderStatic DTCurve448 = hexToPair "a9b45971180882a79b89a3399544a425ef8136d278efa443ed67d3ff9d36e883bc330c6295bbf6ed73ff6fd10cbed767ad05ce03ebd27c7c"+genOpts :: DH d+        => DHType d+        -> Vector+        -> (HandshakeOpts d, HandshakeOpts d)+genOpts _ Vector{..} = (iopts, ropts)+  where+    idho  = defaultHandshakeOpts InitiatorRole viPrologue+    rdho  = defaultHandshakeOpts ResponderRole vrPrologue -mkKeys :: DH d-       => Plaintext-       -> Maybe ScrubbedBytes-       -> Bool-       -> DHType d-       -> HandshakeKeys d-mkKeys pro psk i d =-  HandshakeKeys { hkPrologue       = pro-                , hkPSK            = psk-                , hkLocalStatic    = if i then initiatorStatic d else responderStatic d-                , hkLocalEphemeral = if i then initiatorEphemeral d else responderEphemeral d-                , hkRemoteStatic   = if i then (snd . responderStatic) d else (snd . initiatorStatic) d-                }+    iopts = setLocalEphemeral (dhBytesToPair =<< viEphemeral)+            . setLocalStatic  (dhBytesToPair =<< viStatic)+            . setRemoteStatic (dhBytesToPub  =<< virStatic)+            $ idho -genMessages :: (Cipher c, DH d, Hash h)-            => Bool-            -> NoiseState c d h-            -> NoiseState c d h-            -> [ScrubbedBytes]-            -> [(ScrubbedBytes, ByteString)]-genMessages swap = go []+    ropts = setLocalEphemeral (dhBytesToPair =<< vrEphemeral)+            . setLocalStatic  (dhBytesToPair =<< vrStatic)+            . setRemoteStatic (dhBytesToPub  =<< vrrStatic)+            $ rdho++populateVector :: SomeCipherType+               -> SomeDHType+               -> SomeHashType+               -> [ScrubbedBytes]+               -> Vector+               -> Either [Either SomeException Message] Vector+populateVector (WrapCipherType c)+               (WrapDHType d)+               (WrapHashType h)+               payloads+               v@Vector{..} = do+  let (msgs, hsHash) = genMessages swap ins rns viPSKs vrPSKs payloads+  if any isLeft msgs+    then Left msgs+    else pure $ v { vHash     = Just hsHash+                  , vMessages = either undefined id <$> msgs+                  }   where-    go acc _ _ [] = acc-    go acc sendingState receivingState (payload : rest) =-      let writeResult          = writeMessage sendingState payload-          (ct, sendingState')  = either (error "write failed") id writeResult-          (_, receivingState') = either (error "read failed")-                                        id-                                        $ readMessage receivingState ct in-      if swap-        then go (acc <> [(payload, ct)]) receivingState' sendingState' rest-        else go (acc <> [(payload, ct)]) sendingState' receivingState' rest+    pat        = hsPatternName vProtoName+    swap       = pat /= PatternN && pat /= PatternK && pat /= PatternX &&+                 pat /= PatternNpsk0 && pat /= PatternKpsk0 && pat /= PatternXpsk1+    opts       = genOpts d v+    (ins, rns) = genNoiseStates c h pat opts -genVector :: [ScrubbedBytes]-          -> HandshakeType-          -> Maybe ScrubbedBytes-          -> SomeCipherType-          -> SomeDHType-          -> SomeHashType-          -> IO Vector-genVector payloads pat psk cType@(WrapCipherType c) dType@(WrapDHType d) hType@(WrapHashType h) = do-  let ihk  = mkKeys "John Galt" psk True d-      rhk  = mkKeys "John Galt" psk False d-      ins  = mkNoiseState ihk pat InitiatorRole c h-      rns  = mkNoiseState rhk pat ResponderRole c h-      swap = not (pat == NoiseN || pat == NoiseK || pat == NoiseX)-      name = maybe "Noise_" (const "NoisePSK_") psk <>-             show pat                               <>-             "_"                                    <>-             show d                                 <>-             "_"                                    <>-             show c                                 <>-             "_"                                    <>-             show h-      allMsgs = (\(payload, ct) -> Message (Just payload) ct)-                <$> genMessages swap ins rns payloads+genVector :: HandshakeName+          -> [ScrubbedBytes]+          -> Vector+genVector pat payloads = finalVector+  where+    emptyVector = Vector+      { vName       = Nothing+      , vProtoName  = pat+      , vFail       = False+      , viPrologue  = "John Galt"+      , viPSKs      = []+      , viEphemeral = Nothing+      , viStatic    = Nothing+      , virStatic   = Nothing+      , vrPrologue  = "John Galt"+      , vrPSKs      = []+      , vrEphemeral = Nothing+      , vrStatic    = Nothing+      , vrrStatic   = Nothing+      , vHash       = Nothing+      , vMessages   = []+      } -  return-    Vector { vName            = name-           , vPattern         = pat-           , vCipher          = cType-           , vDH              = dType-           , vHash            = hType-           , vFail            = False-           , viPrologue       = hkPrologue ihk-           , viPSK            = hkPSK ihk-           , viStatic         = dhSecToBytes . fst <$> ins ^. nsHandshakeState . hsOpts . hoLocalStatic-           , viSemiEphemeral  = Nothing-           , viEphemeral      = dhSecToBytes . fst <$> ins ^. nsHandshakeState . hsOpts . hoLocalEphemeral-           , virStatic        = dhPubToBytes       <$> ins ^. nsHandshakeState . hsOpts . hoRemoteStatic-           , virSemiEphemeral = Nothing-           , vrPrologue       = hkPrologue rhk-           , vrPSK            = hkPSK rhk-           , vrStatic         = dhSecToBytes . fst <$> rns ^. nsHandshakeState . hsOpts . hoLocalStatic-           , vrSemiEphemeral  = Nothing-           , vrEphemeral      = dhSecToBytes . fst <$> rns ^. nsHandshakeState . hsOpts . hoLocalEphemeral-           , vrrStatic        = dhPubToBytes       <$> rns ^. nsHandshakeState . hsOpts . hoRemoteStatic-           , vrrSemiEphemeral = Nothing-           , vMessages        = allMsgs-           }+    c = hsCipher pat+    d = hsDH     pat+    h = hsHash   pat +    finalVector = either (error "failed to generate messages!")+                         id+                         (populateVector c d h payloads . setKeys $ emptyVector)++allHandshakes :: [HandshakeName]+allHandshakes = do+  pattern <- [minBound .. maxBound]++  cipher  <- [ WrapCipherType AESGCM+             , WrapCipherType ChaChaPoly1305+             ]++  dh      <- [ WrapDHType Curve25519+             , WrapDHType Curve448+             ]++  hash    <- [ WrapHashType BLAKE2b+             , WrapHashType BLAKE2s+             , WrapHashType SHA256+             , WrapHashType SHA512+             ]++  return $ HandshakeName pattern cipher dh hash+ genVectorFile :: FilePath               -> IO () genVectorFile f = do-  let payloads = ["Ludwig von Mises", "Murray Rothbard", "F. A. Hayek", "Carl Menger", "Jean-Baptiste Say", "Eugen Böhm von Bawerk"]-      patterns = [NoiseNN, NoiseKN, NoiseNK, NoiseKK, NoiseNX, NoiseKX, NoiseXN, NoiseIN, NoiseXK, NoiseIK, NoiseXX, NoiseIX, NoiseN, NoiseK, NoiseX]-      psks     = [Nothing, Just "This is my Austrian perspective!"]-      ciphers  = [WrapCipherType CTChaChaPoly1305, WrapCipherType CTAESGCM]-      dhs      = [WrapDHType DTCurve25519, WrapDHType DTCurve448]-      hashes   = [WrapHashType HTSHA256, WrapHashType HTSHA512, WrapHashType HTBLAKE2s, WrapHashType HTBLAKE2b]-      vectors  = [genVector payloads p psk c d h | p <- patterns, psk <- psks, c <- ciphers, d <- dhs, h <- hashes]--  vs <- mapConcurrently id vectors+  let payloads = [ "Ludwig von Mises"+                 , "Murray Rothbard"+                 , "F. A. Hayek"+                 , "Carl Menger"+                 , "Jean-Baptiste Say"+                 , "Eugen Böhm von Bawerk"+                 ]+      vectors  = [ genVector hs payloads | hs <- allHandshakes ] -  writeFile f . encode . VectorFile $ vs+  writeFile f . encode . VectorFile $ vectors

@@ -1,229 +0,0 @@-{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}-module Handshakes where--import Control.Lens--import Crypto.Noise-import Crypto.Noise.Cipher-import Crypto.Noise.DH-import Crypto.Noise.Hash-import Crypto.Noise.HandshakePatterns--import Types--data HandshakeKeys d =-  HandshakeKeys { hkPrologue       :: Plaintext-                , hkPSK            :: Maybe Plaintext-                , hkLocalStatic    :: KeyPair d-                , hkLocalEphemeral :: KeyPair d-                , hkRemoteStatic   :: PublicKey d-                }--mkNoiseState :: forall c d h. (Cipher c, DH d, Hash h)-             => HandshakeKeys d-             -> HandshakeType-             -> HandshakeRole-             -> CipherType c-             -> HashType h-             -> NoiseState c d h-mkNoiseState HandshakeKeys{..} NoiseNN r _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseNN r :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseKN InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseKN InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseKN ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseKN ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoRemoteStatic   .~ Just hkRemoteStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseNK InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseNK InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoRemoteStatic   .~ Just hkRemoteStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseNK ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseNK ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseKK r _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseKK r :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoRemoteStatic   .~ Just hkRemoteStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseNX InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseNX InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseNX ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseNX ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseKX InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseKX InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseKX ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseKX ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoRemoteStatic   .~ Just hkRemoteStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseXN InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseXN InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseXN ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseXN ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseIN InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseIN InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseIN ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseIN ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseXK InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseXK InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoRemoteStatic   .~ Just hkRemoteStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseXK ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseXK ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseIK InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseIK InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoRemoteStatic   .~ Just hkRemoteStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseIK ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseIK ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseXX r _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseXX r :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseIX r _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseIX r :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseN InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseN InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoRemoteStatic   .~ Just hkRemoteStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseN ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseN ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseK r _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseK r :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoRemoteStatic   .~ Just hkRemoteStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseX InitiatorRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseX InitiatorRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoRemoteStatic   .~ Just hkRemoteStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral--mkNoiseState HandshakeKeys{..} NoiseX ResponderRole _ _ = noiseState ho-  where-    dho = defaultHandshakeOpts noiseX ResponderRole :: HandshakeOpts d-    ho  = dho & hoPrologue       .~ hkPrologue-              & hoPreSharedKey   .~ hkPSK-              & hoLocalStatic    .~ Just hkLocalStatic-              & hoLocalEphemeral .~ Just hkLocalEphemeral

@@ -0,0 +1,199 @@+{-# LANGUAGE GADTs #-}+module Keys where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Base16 as B16++import Crypto.Noise    (ScrubbedBytes, convert)+import Crypto.Noise.DH+import Crypto.Noise.DH.Curve25519+import Crypto.Noise.DH.Curve448++import Types+import VectorFile++setKeys :: Vector+        -> Vector+setKeys v@Vector{vProtoName = pat} = v+    -- All patterns require the initiator to have an ephemeral key.+  { viEphemeral = Just . initiatorEphemeral $ dh+  , vrEphemeral = if name `elem` rePatterns'+                    then Nothing+                    else Just . responderEphemeral $ dh+  , viStatic    = if name `elem` isPatterns+                    then Just . initiatorStatic $ dh+                    else Nothing+  , vrStatic    = if name `elem` rsPatterns+                    then Just . responderStatic $ dh+                    else Nothing+  , virStatic   = if name `elem` irPatterns+                    then privateToPublic dh . responderStatic $ dh+                    else Nothing+  , vrrStatic   = if name `elem` rrPatterns+                    then privateToPublic dh . initiatorStatic $ dh+                    else Nothing+  , viPSKs      = [ psk | name `elem` pskPatterns ]+  , vrPSKs      = [ psk | name `elem` pskPatterns ]+  }++  where+    name = hsPatternName pat+    dh   = hsDH          pat++    -- The following patterns do *not* have an ephemeral key for the responder.+    rePatterns' = [ PatternN+                  , PatternK+                  , PatternX+                  , PatternNpsk0+                  , PatternKpsk0+                  , PatternXpsk1+                  ]++    -- The following patterns require a static key for the initiator.+    isPatterns = [ PatternKN+                 , PatternKNpsk0+                 , PatternKNpsk2+                 , PatternKK+                 , PatternKKpsk0+                 , PatternKKpsk2+                 , PatternKX+                 , PatternKXpsk2+                 , PatternXN+                 , PatternXNpsk3+                 , PatternIN+                 , PatternINpsk1+                 , PatternINpsk2+                 , PatternXK+                 , PatternXKpsk3+                 , PatternIK+                 , PatternIKpsk1+                 , PatternIKpsk2+                 , PatternXX+                 , PatternXXpsk3+                 , PatternIX+                 , PatternIXpsk2+                 , PatternK+                 , PatternX+                 , PatternKpsk0+                 , PatternXpsk1+                 ]++    -- The following patterns require a static key for the responder.+    rsPatterns = [ PatternNK+                 , PatternNKpsk0+                 , PatternNKpsk2+                 , PatternKK+                 , PatternKKpsk0+                 , PatternKKpsk2+                 , PatternNX+                 , PatternNXpsk2+                 , PatternKX+                 , PatternKXpsk2+                 , PatternXK+                 , PatternXKpsk3+                 , PatternIK+                 , PatternIKpsk1+                 , PatternIKpsk2+                 , PatternXX+                 , PatternXXpsk3+                 , PatternIX+                 , PatternIXpsk2+                 , PatternN+                 , PatternK+                 , PatternX+                 , PatternNpsk0+                 , PatternKpsk0+                 , PatternXpsk1+                 ]++    -- The following patterns require the initiator to know the responder's+    -- public static key ahead of time (i.e. it is not transmitted).+    irPatterns = [ PatternNK+                 , PatternNKpsk0+                 , PatternNKpsk2+                 , PatternKK+                 , PatternKKpsk0+                 , PatternKKpsk2+                 , PatternXK+                 , PatternXKpsk3+                 , PatternIK+                 , PatternIKpsk1+                 , PatternIKpsk2+                 , PatternN+                 , PatternK+                 , PatternX+                 , PatternNpsk0+                 , PatternKpsk0+                 , PatternXpsk1+                 ]++    -- The following patterns require the responder to know the initiator's+    -- public static key ahead of time (i.e. it is not transmitted).+    rrPatterns = [ PatternKN+                 , PatternKNpsk0+                 , PatternKNpsk2+                 , PatternKK+                 , PatternKKpsk0+                 , PatternKKpsk2+                 , PatternKX+                 , PatternKXpsk2+                 , PatternK+                 , PatternKpsk0+                 ]++    -- The following patterns use the psk token.+    pskPatterns = [ PatternNNpsk0+                  , PatternNNpsk2+                  , PatternNKpsk0+                  , PatternNKpsk2+                  , PatternNXpsk2+                  , PatternXNpsk3+                  , PatternXKpsk3+                  , PatternXXpsk3+                  , PatternKNpsk0+                  , PatternKNpsk2+                  , PatternKKpsk0+                  , PatternKKpsk2+                  , PatternKXpsk2+                  , PatternINpsk1+                  , PatternINpsk2+                  , PatternIKpsk1+                  , PatternIKpsk2+                  , PatternIXpsk2+                  , PatternNpsk0+                  , PatternKpsk0+                  , PatternXpsk1+                  ]++hexToSB :: ByteString+        -> ScrubbedBytes+hexToSB = convert . fst . B16.decode++privateToPublic :: SomeDHType+                -> ScrubbedBytes+                -> Maybe ScrubbedBytes+privateToPublic (WrapDHType Curve25519) k = fmap (dhPubToBytes . snd) (dhBytesToPair k :: Maybe (KeyPair Curve25519))+privateToPublic (WrapDHType Curve448)   k = fmap (dhPubToBytes . snd) (dhBytesToPair k :: Maybe (KeyPair Curve448))++psk :: ScrubbedBytes+psk = "This is my Austrian perspective!"++initiatorEphemeral :: SomeDHType+                   -> ScrubbedBytes+initiatorEphemeral (WrapDHType Curve25519) = hexToSB "893e28b9dc6ca8d611ab664754b8ceb7bac5117349a4439a6b0569da977c464a"+initiatorEphemeral (WrapDHType Curve448)   = hexToSB "7fd26c8b8a0d5c98c85ff9ca1d7bc66d78578b9f2c4c170850748b27992767e6ea6cc9992a561c9d19dfc342e260c280ef4f3f9b8f879d4e"++responderEphemeral :: SomeDHType+                   -> ScrubbedBytes+responderEphemeral (WrapDHType Curve25519) = hexToSB "bbdb4cdbd309f1a1f2e1456967fe288cadd6f712d65dc7b7793d5e63da6b375b"+responderEphemeral (WrapDHType Curve448)   = hexToSB "3facf7503ebee252465689f1d4e3b1dd219639ef9de4ffd6049d6d71a0f62126840febb99042421ce12af6626d98d9170260390fbc8399a5"++initiatorStatic :: SomeDHType+                -> ScrubbedBytes+initiatorStatic (WrapDHType Curve25519) = hexToSB "e61ef9919cde45dd5f82166404bd08e38bceb5dfdfded0a34c8df7ed542214d1"+initiatorStatic (WrapDHType Curve448)   = hexToSB "34d564c4be963d1b2a89fcfe83e6a72b5e3f5e3127f9f596ffc7575e418dfc1f4e827cfc10c9fed38e92ad56ddf8f08571430df2e76d5411"++responderStatic :: SomeDHType+                -> ScrubbedBytes+responderStatic (WrapDHType Curve25519) = hexToSB "4a3acbfdb163dec651dfa3194dece676d437029c62a408b4c5ea9114246e4893"+responderStatic (WrapDHType Curve448)   = hexToSB "a9b45971180882a79b89a3399544a425ef8136d278efa443ed67d3ff9d36e883bc330c6295bbf6ed73ff6fd10cbed767ad05ce03ebd27c7c"

@@ -0,0 +1,19 @@+module Main where++import Data.Monoid      ((<>))+import System.Directory (createDirectoryIfMissing, getDirectoryContents)+import System.Exit      (exitSuccess)++import Generate+import Verify++main :: IO ()+main = do+  createDirectoryIfMissing False "vectors"++  vectorFiles <- filter (\f -> (f /= ".") && (f /= "..")) <$> getDirectoryContents "vectors"+  if "cacophony.txt" `notElem` vectorFiles+    then do+      genVectorFile "vectors/cacophony.txt"+      putStrLn "Generated default vectors."+    else mapM_ verifyVectorFile (fmap ("vectors/" <>) vectorFiles) >> exitSuccess

@@ -1,155 +1,249 @@-{-# LANGUAGE OverloadedStrings, RankNTypes, KindSignatures, GADTs #-}+{-# LANGUAGE RecordWildCards, RankNTypes, GADTs, KindSignatures #-} module Types where +import Control.Monad      (mzero) import Data.Aeson+import Data.Aeson.Types   (typeMismatch)+import Data.Attoparsec.ByteString.Char8+import Data.Maybe         (fromMaybe)+import Data.Monoid        ((<>))+import Data.Text          (pack)+import Data.Text.Encoding (encodeUtf8)+import Data.Tuple         (swap) -import Crypto.Noise.Cipher+import Crypto.Noise import Crypto.Noise.Cipher.ChaChaPoly1305 import Crypto.Noise.Cipher.AESGCM-import Crypto.Noise.DH import Crypto.Noise.DH.Curve25519 import Crypto.Noise.DH.Curve448 import Crypto.Noise.HandshakePatterns-import Crypto.Noise.Hash import Crypto.Noise.Hash.SHA256 import Crypto.Noise.Hash.SHA512 import Crypto.Noise.Hash.BLAKE2s import Crypto.Noise.Hash.BLAKE2b -data HandshakeType = NoiseNN-                   | NoiseKN-                   | NoiseNK-                   | NoiseKK-                   | NoiseNX-                   | NoiseKX-                   | NoiseXN-                   | NoiseIN-                   | NoiseXK-                   | NoiseIK-                   | NoiseXX-                   | NoiseIX-                   | NoiseN-                   | NoiseK-                   | NoiseX-                   deriving Eq+data PatternName+  = PatternNN+  | PatternKN+  | PatternNK+  | PatternKK+  | PatternNX+  | PatternKX+  | PatternXN+  | PatternIN+  | PatternXK+  | PatternIK+  | PatternXX+  | PatternIX+  | PatternN+  | PatternK+  | PatternX+  | PatternNNpsk0+  | PatternNNpsk2+  | PatternNKpsk0+  | PatternNKpsk2+  | PatternNXpsk2+  | PatternXNpsk3+  | PatternXKpsk3+  | PatternXXpsk3+  | PatternKNpsk0+  | PatternKNpsk2+  | PatternKKpsk0+  | PatternKKpsk2+  | PatternKXpsk2+  | PatternINpsk1+  | PatternINpsk2+  | PatternIKpsk1+  | PatternIKpsk2+  | PatternIXpsk2+  | PatternNpsk0+  | PatternKpsk0+  | PatternXpsk1+  deriving (Eq, Enum, Bounded) -instance FromJSON HandshakeType where-  parseJSON (String "NN") = pure NoiseNN-  parseJSON (String "KN") = pure NoiseKN-  parseJSON (String "NK") = pure NoiseNK-  parseJSON (String "KK") = pure NoiseKK-  parseJSON (String "NX") = pure NoiseNX-  parseJSON (String "KX") = pure NoiseKX-  parseJSON (String "XN") = pure NoiseXN-  parseJSON (String "IN") = pure NoiseIN-  parseJSON (String "XK") = pure NoiseXK-  parseJSON (String "IK") = pure NoiseIK-  parseJSON (String "XX") = pure NoiseXX-  parseJSON (String "IX") = pure NoiseIX-  parseJSON (String "N")  = pure NoiseN-  parseJSON (String "K")  = pure NoiseK-  parseJSON (String "X")  = pure NoiseX-  parseJSON _             = error "invalid pattern name"+data HandshakeName = HandshakeName+  { hsPatternName :: PatternName+  , hsCipher      :: SomeCipherType+  , hsDH          :: SomeDHType+  , hsHash        :: SomeHashType+  }  data CipherType :: * -> * where-  CTChaChaPoly1305 :: CipherType ChaChaPoly1305-  CTAESGCM         :: CipherType AESGCM+  ChaChaPoly1305 :: CipherType ChaChaPoly1305+  AESGCM         :: CipherType AESGCM  data SomeCipherType where   WrapCipherType :: forall c. Cipher c => CipherType c -> SomeCipherType -instance FromJSON SomeCipherType where-  parseJSON (String "ChaChaPoly") = pure . WrapCipherType $ CTChaChaPoly1305-  parseJSON (String "AESGCM")     = pure . WrapCipherType $ CTAESGCM-  parseJSON _                     = error "invalid cipher name"--instance ToJSON SomeCipherType where-  toJSON (WrapCipherType CTChaChaPoly1305) = "ChaChaPoly"-  toJSON (WrapCipherType CTAESGCM)         = "AESGCM"--instance Show (CipherType c) where-  show CTChaChaPoly1305 = "ChaChaPoly"-  show CTAESGCM = "AESGCM"- data DHType :: * -> * where-  DTCurve25519 :: DHType Curve25519-  DTCurve448   :: DHType Curve448+  Curve25519 :: DHType Curve25519+  Curve448   :: DHType Curve448  data SomeDHType where   WrapDHType :: forall d. DH d => DHType d -> SomeDHType -instance FromJSON SomeDHType where-  parseJSON (String "25519") = pure . WrapDHType $ DTCurve25519-  parseJSON (String "448")   = pure . WrapDHType $ DTCurve448-  parseJSON _                = error "invalid DH name"--instance ToJSON SomeDHType where-  toJSON (WrapDHType DTCurve25519) = "25519"-  toJSON (WrapDHType DTCurve448)   = "448"--instance Show (DHType d) where-  show DTCurve25519 = "25519"-  show DTCurve448   = "448"- data HashType :: * -> * where-  HTSHA256  :: HashType SHA256-  HTSHA512  :: HashType SHA512-  HTBLAKE2s :: HashType BLAKE2s-  HTBLAKE2b :: HashType BLAKE2b+  BLAKE2b :: HashType BLAKE2b+  BLAKE2s :: HashType BLAKE2s+  SHA256  :: HashType SHA256+  SHA512  :: HashType SHA512  data SomeHashType where   WrapHashType :: forall h. Hash h => HashType h -> SomeHashType -hsTypeToPattern :: HandshakeType-                -> HandshakePattern-hsTypeToPattern NoiseNN = noiseNN-hsTypeToPattern NoiseKN = noiseKN-hsTypeToPattern NoiseNK = noiseNK-hsTypeToPattern NoiseKK = noiseKK-hsTypeToPattern NoiseNX = noiseNX-hsTypeToPattern NoiseKX = noiseKX-hsTypeToPattern NoiseXN = noiseXN-hsTypeToPattern NoiseIN = noiseIN-hsTypeToPattern NoiseXK = noiseXK-hsTypeToPattern NoiseIK = noiseIK-hsTypeToPattern NoiseXX = noiseXX-hsTypeToPattern NoiseIX = noiseIX-hsTypeToPattern NoiseN  = noiseN-hsTypeToPattern NoiseK  = noiseK-hsTypeToPattern NoiseX  = noiseX+patternMap :: [(String, PatternName)]+patternMap =+  [ ("NN", PatternNN)+  , ("KN", PatternKN)+  , ("NK", PatternNK)+  , ("KK", PatternKK)+  , ("NX", PatternNX)+  , ("KX", PatternKX)+  , ("XN", PatternXN)+  , ("IN", PatternIN)+  , ("XK", PatternXK)+  , ("IK", PatternIK)+  , ("XX", PatternXX)+  , ("IX", PatternIX)+  , ("N" , PatternN)+  , ("K" , PatternK)+  , ("X" , PatternX)+  , ("NNpsk0", PatternNNpsk0)+  , ("NNpsk2", PatternNNpsk2)+  , ("NKpsk0", PatternNKpsk0)+  , ("NKpsk2", PatternNKpsk2)+  , ("NXpsk2", PatternNXpsk2)+  , ("XNpsk3", PatternXNpsk3)+  , ("XKpsk3", PatternXKpsk3)+  , ("XXpsk3", PatternXXpsk3)+  , ("KNpsk0", PatternKNpsk0)+  , ("KNpsk2", PatternKNpsk2)+  , ("KKpsk0", PatternKKpsk0)+  , ("KKpsk2", PatternKKpsk2)+  , ("KXpsk2", PatternKXpsk2)+  , ("INpsk1", PatternINpsk1)+  , ("INpsk2", PatternINpsk2)+  , ("IKpsk1", PatternIKpsk1)+  , ("IKpsk2", PatternIKpsk2)+  , ("IXpsk2", PatternIXpsk2)+  , ("Npsk0" , PatternNpsk0)+  , ("Kpsk0" , PatternKpsk0)+  , ("Xpsk1" , PatternXpsk1)+  ] -instance FromJSON SomeHashType where-  parseJSON (String "SHA256")  = pure . WrapHashType $ HTSHA256-  parseJSON (String "SHA512")  = pure . WrapHashType $ HTSHA512-  parseJSON (String "BLAKE2s") = pure . WrapHashType $ HTBLAKE2s-  parseJSON (String "BLAKE2b") = pure . WrapHashType $ HTBLAKE2b-  parseJSON _                  = error "invalid hash name"+dhMap :: [(String, SomeDHType)]+dhMap =+  [ ("25519", WrapDHType Curve25519)+  , ("448"  , WrapDHType Curve448)+  ] -instance ToJSON SomeHashType where-  toJSON (WrapHashType HTSHA256)  = "SHA256"-  toJSON (WrapHashType HTSHA512)  = "SHA512"-  toJSON (WrapHashType HTBLAKE2s) = "BLAKE2s"-  toJSON (WrapHashType HTBLAKE2b) = "BLAKE2b"+cipherMap :: [(String, SomeCipherType)]+cipherMap =+  [ ("AESGCM"    , WrapCipherType AESGCM)+  , ("ChaChaPoly", WrapCipherType ChaChaPoly1305)+  ] -instance Show (HashType h) where-  show HTSHA256  = "SHA256"-  show HTSHA512  = "SHA512"-  show HTBLAKE2s = "BLAKE2s"-  show HTBLAKE2b = "BLAKE2b"+hashMap :: [(String, SomeHashType)]+hashMap =+  [ ("BLAKE2b", WrapHashType BLAKE2b)+  , ("BLAKE2s", WrapHashType BLAKE2s)+  , ("SHA256" , WrapHashType SHA256)+  , ("SHA512" , WrapHashType SHA512)+  ] -instance Show HandshakeType where-  show NoiseNN = "NN"-  show NoiseKN = "KN"-  show NoiseNK = "NK"-  show NoiseKK = "KK"-  show NoiseNX = "NX"-  show NoiseKX = "KX"-  show NoiseXN = "XN"-  show NoiseIN = "IN"-  show NoiseXK = "XK"-  show NoiseIK = "IK"-  show NoiseXX = "XX"-  show NoiseIX = "IX"-  show NoiseN  = "N"-  show NoiseK  = "K"-  show NoiseX  = "X"+parseHandshakeName :: Parser HandshakeName+parseHandshakeName = do+  _ <- string "Noise_"++  let untilUnderscore = anyChar `manyTill'` (char '_')+      untilEOI        = anyChar `manyTill'` endOfInput++  pattern <- (flip lookup patternMap) <$> untilUnderscore+  dh      <- (flip lookup dhMap)      <$> untilUnderscore+  cipher  <- (flip lookup cipherMap)  <$> untilUnderscore+  hash    <- (flip lookup hashMap)    <$> untilEOI+++  let mHandshakeName = do+        p <- pattern+        d <- dh+        c <- cipher+        h <- hash++        return $ HandshakeName p c d h++  maybe mempty return mHandshakeName++patternToHandshake :: PatternName+                   -> HandshakePattern+patternToHandshake PatternNN = noiseNN+patternToHandshake PatternKN = noiseKN+patternToHandshake PatternNK = noiseNK+patternToHandshake PatternKK = noiseKK+patternToHandshake PatternNX = noiseNX+patternToHandshake PatternKX = noiseKX+patternToHandshake PatternXN = noiseXN+patternToHandshake PatternIN = noiseIN+patternToHandshake PatternXK = noiseXK+patternToHandshake PatternIK = noiseIK+patternToHandshake PatternXX = noiseXX+patternToHandshake PatternIX = noiseIX+patternToHandshake PatternN  = noiseN+patternToHandshake PatternK  = noiseK+patternToHandshake PatternX  = noiseX+patternToHandshake PatternNNpsk0 = noiseNNpsk0+patternToHandshake PatternNNpsk2 = noiseNNpsk2+patternToHandshake PatternNKpsk0 = noiseNKpsk0+patternToHandshake PatternNKpsk2 = noiseNKpsk2+patternToHandshake PatternNXpsk2 = noiseNXpsk2+patternToHandshake PatternXNpsk3 = noiseXNpsk3+patternToHandshake PatternXKpsk3 = noiseXKpsk3+patternToHandshake PatternXXpsk3 = noiseXXpsk3+patternToHandshake PatternKNpsk0 = noiseKNpsk0+patternToHandshake PatternKNpsk2 = noiseKNpsk2+patternToHandshake PatternKKpsk0 = noiseKKpsk0+patternToHandshake PatternKKpsk2 = noiseKKpsk2+patternToHandshake PatternKXpsk2 = noiseKXpsk2+patternToHandshake PatternINpsk1 = noiseINpsk1+patternToHandshake PatternINpsk2 = noiseINpsk2+patternToHandshake PatternIKpsk1 = noiseIKpsk1+patternToHandshake PatternIKpsk2 = noiseIKpsk2+patternToHandshake PatternIXpsk2 = noiseIXpsk2+patternToHandshake PatternNpsk0  = noiseNpsk0+patternToHandshake PatternKpsk0  = noiseKpsk0+patternToHandshake PatternXpsk1  = noiseXpsk1++instance FromJSON HandshakeName where+  parseJSON (String s) =+    either (const mzero) pure $ parseOnly parseHandshakeName (encodeUtf8 s)+  parseJSON bad        = typeMismatch "HandshakeName" bad++instance ToJSON HandshakeName where+  toJSON = String . pack . show++instance Show HandshakeName where+  show HandshakeName{..} = "Noise_"+                          <> show hsPatternName+                          <> "_"+                          <> show hsDH+                          <> "_"+                          <> show hsCipher+                          <> "_"+                          <> show hsHash++instance Show PatternName where+  show = fromMaybe "unknown" . flip lookup (map swap patternMap)++instance Show SomeCipherType where+  show (WrapCipherType ChaChaPoly1305) = "ChaChaPoly"+  show (WrapCipherType AESGCM)         = "AESGCM"++instance Show SomeDHType where+  show (WrapDHType Curve25519) = "25519"+  show (WrapDHType Curve448)   = "448"++instance Show SomeHashType where+  show (WrapHashType BLAKE2b) = "BLAKE2b"+  show (WrapHashType BLAKE2s) = "BLAKE2s"+  show (WrapHashType SHA256)  = "SHA256"+  show (WrapHashType SHA512)  = "SHA512"

@@ -1,112 +1,95 @@-{-# LANGUAGE OverloadedStrings, RecordWildCards #-}+{-# LANGUAGE RecordWildCards, RankNTypes, GADTs #-} module VectorFile where -import Control.Monad      (mzero) import Data.Aeson-import Data.ByteArray     (ScrubbedBytes, convert)-import Data.ByteString    (ByteString)+import Data.Aeson.Types   (typeMismatch) import qualified Data.ByteString.Base16 as B16 import Data.Text          (Text) import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Crypto.Noise+ import Types  data Message =-  Message { mPayload    :: Maybe ScrubbedBytes-          , mCiphertext :: ByteString+  Message { mPayload    :: ScrubbedBytes+          , mCiphertext :: ScrubbedBytes           } deriving (Eq, Show)  instance ToJSON Message where   toJSON Message{..} =-    object [ "payload"    .= ((decodeUtf8 . B16.encode . convert) <$> mPayload)-           , "ciphertext" .= (decodeUtf8 . B16.encode) mCiphertext+    object [ "payload"    .= encodeSB mPayload+           , "ciphertext" .= encodeSB mCiphertext            ]  instance FromJSON Message where   parseJSON (Object o) =-    Message <$> (fmap (convert . fst . B16.decode . encodeUtf8) <$> o .:? "payload")-            <*> ((fst . B16.decode . encodeUtf8) <$> o .: "ciphertext")+    Message <$> (decodeSB <$> o .: "payload")+            <*> (decodeSB <$> o .: "ciphertext") -  parseJSON _          = mzero+  parseJSON bad        = typeMismatch "Message" bad  data Vector =-  Vector { vName            :: String-         , vPattern         :: HandshakeType-         , vCipher          :: SomeCipherType-         , vDH              :: SomeDHType-         , vHash            :: SomeHashType-         , vFail            :: Bool-         , viPrologue       :: ScrubbedBytes-         , viPSK            :: Maybe ScrubbedBytes-         , viStatic         :: Maybe ScrubbedBytes-         , viSemiEphemeral  :: Maybe ScrubbedBytes-         , viEphemeral      :: Maybe ScrubbedBytes-         , virStatic        :: Maybe ScrubbedBytes-         , virSemiEphemeral :: Maybe ScrubbedBytes-         , vrPrologue       :: ScrubbedBytes-         , vrPSK            :: Maybe ScrubbedBytes-         , vrStatic         :: Maybe ScrubbedBytes-         , vrSemiEphemeral  :: Maybe ScrubbedBytes-         , vrEphemeral      :: Maybe ScrubbedBytes-         , vrrStatic        :: Maybe ScrubbedBytes-         , vrrSemiEphemeral :: Maybe ScrubbedBytes-         , vMessages        :: [Message]-         }+  Vector { vName       :: Maybe Text+         , vProtoName  :: HandshakeName+         , vFail       :: Bool+         , viPrologue  :: ScrubbedBytes+         , viPSKs      :: [ScrubbedBytes]+         , viEphemeral :: Maybe ScrubbedBytes+         , viStatic    :: Maybe ScrubbedBytes+         , virStatic   :: Maybe ScrubbedBytes+         , vrPrologue  :: ScrubbedBytes+         , vrPSKs      :: [ScrubbedBytes]+         , vrEphemeral :: Maybe ScrubbedBytes+         , vrStatic    :: Maybe ScrubbedBytes+         , vrrStatic   :: Maybe ScrubbedBytes+         , vHash       :: Maybe ScrubbedBytes+         , vMessages   :: [Message]+         } deriving Show  instance ToJSON Vector where-  toJSON Vector{..} = object . stripDefaults . noNulls $+  toJSON Vector{..} = object . stripDefaults . stripEmptyLists . stripNulls $     [ "name"                      .= vName-    , "pattern"                   .= show vPattern-    , "cipher"                    .= vCipher-    , "dh"                        .= vDH-    , "hash"                      .= vHash+    , "protocol_name"             .= vProtoName     , "fail"                      .= vFail     , "init_prologue"             .= encodeSB viPrologue-    , "init_psk"                  .= (encodeSB <$> viPSK)-    , "init_static"               .= (encodeSB <$> viStatic)-    , "init_semiephemeral"        .= (encodeSB <$> viSemiEphemeral)+    , "init_psks"                 .= (encodeSB <$> viPSKs)     , "init_ephemeral"            .= (encodeSB <$> viEphemeral)+    , "init_static"               .= (encodeSB <$> viStatic)     , "init_remote_static"        .= (encodeSB <$> virStatic)-    , "init_remote_semiephemeral" .= (encodeSB <$> virSemiEphemeral)     , "resp_prologue"             .= encodeSB vrPrologue-    , "resp_psk"                  .= (encodeSB <$> vrPSK)-    , "resp_static"               .= (encodeSB <$> vrStatic)-    , "resp_semiephemeral"        .= (encodeSB <$> vrSemiEphemeral)+    , "resp_psks"                 .= (encodeSB <$> vrPSKs)     , "resp_ephemeral"            .= (encodeSB <$> vrEphemeral)+    , "resp_static"               .= (encodeSB <$> vrStatic)     , "resp_remote_static"        .= (encodeSB <$> vrrStatic)-    , "resp_remote_semiephemeral" .= (encodeSB <$> vrrSemiEphemeral)+    , "handshake_hash"            .= (encodeSB <$> vHash)     , "messages"                  .= vMessages     ]      where-      noNulls       = filter (\(_, v) -> v /= Null)-      stripDefaults = filter (\(k, v) -> not (k == "fail" && v == Bool False))+      stripNulls       = filter (\(_, v) -> v /= Null)+      stripEmptyLists  = filter (\(_, v) -> v /= Array mempty)+      stripDefaults    = filter (\(k, v) -> not (k == "fail" && v == Bool False))  instance FromJSON Vector where   parseJSON (Object o) =-    Vector <$> o .:  "name"-           <*> o .:  "pattern"-           <*> o .:  "cipher"-           <*> o .:  "dh"-           <*> o .:  "hash"+    Vector <$> o .:?  "name"+           <*> o .: "protocol_name"            <*> o .:? "fail" .!= False            <*> (decodeSB      <$> o .:  "init_prologue")-           <*> (fmap decodeSB <$> o .:? "init_psk")-           <*> (fmap decodeSB <$> o .:? "init_static")-           <*> (fmap decodeSB <$> o .:? "init_semiephemeral")+           <*> (fmap decodeSB <$> o .:? "init_psks" .!= [])            <*> (fmap decodeSB <$> o .:? "init_ephemeral")+           <*> (fmap decodeSB <$> o .:? "init_static")            <*> (fmap decodeSB <$> o .:? "init_remote_static")-           <*> (fmap decodeSB <$> o .:? "init_remote_semiephemeral")            <*> (decodeSB      <$> o .:  "resp_prologue")-           <*> (fmap decodeSB <$> o .:? "resp_psk")-           <*> (fmap decodeSB <$> o .:? "resp_static")-           <*> (fmap decodeSB <$> o .:? "resp_semiephemeral")+           <*> (fmap decodeSB <$> o .:? "resp_psks" .!= [])            <*> (fmap decodeSB <$> o .:? "resp_ephemeral")+           <*> (fmap decodeSB <$> o .:? "resp_static")            <*> (fmap decodeSB <$> o .:? "resp_remote_static")-           <*> (fmap decodeSB <$> o .:? "resp_remote_semiephemeral")+           <*> (fmap decodeSB <$> o .:? "handshake_hash")            <*> o .: "messages" -  parseJSON _          = mzero+  parseJSON bad        = typeMismatch "Vector" bad  newtype VectorFile = VectorFile { vfVectors  :: [Vector] } @@ -115,7 +98,7 @@  instance FromJSON VectorFile where   parseJSON (Object o) = VectorFile <$> o .: "vectors"-  parseJSON _          = mzero+  parseJSON bad        = typeMismatch "VectorFile" bad  encodeSB :: ScrubbedBytes          -> Text

@@ -1,154 +1,137 @@-{-# LANGUAGE OverloadedStrings, RecordWildCards, ScopedTypeVariables #-} module Verify where -import Control.Arrow-import Control.Concurrent.Async (mapConcurrently)-import Control.Exception        (SomeException)-import Control.Monad.State-import Data.Aeson               (decode)-import Data.ByteArray           (convert)-import Data.ByteString          (ByteString)-import qualified Data.ByteString.Char8 as BS (putStrLn)-import Data.ByteString.Base16   (encode)-import Data.ByteString.Lazy     (readFile)-import Data.Either-import Data.Maybe               (fromMaybe)-import Data.Monoid              ((<>))-import Prelude hiding           (readFile)-import System.Exit              (exitFailure)+import Control.Exception    (SomeException)+import Control.Monad        (forM_)+import Data.Aeson           (eitherDecode)+import Data.Bits+import Data.ByteString.Lazy (readFile)+import Data.Maybe           (fromMaybe)+import Data.Monoid          ((<>))+import Data.Text            (Text, pack)+import Data.Text.IO         (putStrLn)+import Prelude hiding       (readFile, putStrLn)+import System.Exit          (exitFailure) -import Crypto.Noise-import Crypto.Noise.Internal.Handshake-import Crypto.Noise.Cipher-import Crypto.Noise.DH-import Crypto.Noise.Hash+import Crypto.Noise         (ScrubbedBytes) +import Generate import Types import VectorFile -mkHandshakeOpts :: DH d-                => Vector-                -> DHType d-                -> (HandshakeOpts d, HandshakeOpts d)-mkHandshakeOpts Vector{..} _ = (i, r)-  where-    i = HandshakeOpts { _hoPattern             = hsTypeToPattern vPattern-                      , _hoRole                = InitiatorRole-                      , _hoPrologue            = viPrologue-                      , _hoPreSharedKey        = viPSK-                      , _hoLocalStatic         = viStatic         >>= dhBytesToPair-                      , _hoLocalSemiEphemeral  = viSemiEphemeral  >>= dhBytesToPair-                      , _hoLocalEphemeral      = viEphemeral      >>= dhBytesToPair-                      , _hoRemoteStatic        = virStatic        >>= dhBytesToPub-                      , _hoRemoteSemiEphemeral = virSemiEphemeral >>= dhBytesToPub-                      , _hoRemoteEphemeral     = Nothing-                      }+data ValidationResult+  = ResultException      [Either SomeException Message]+  | ResultMsgDifference  [Maybe (Message, Message)]+  | ResultHashDifference ScrubbedBytes ScrubbedBytes+  | ResultSuccess -    r = HandshakeOpts { _hoPattern             = hsTypeToPattern vPattern-                      , _hoRole                = ResponderRole-                      , _hoPrologue            = vrPrologue-                      , _hoPreSharedKey        = vrPSK-                      , _hoLocalStatic         = vrStatic         >>= dhBytesToPair-                      , _hoLocalSemiEphemeral  = vrSemiEphemeral  >>= dhBytesToPair-                      , _hoLocalEphemeral      = vrEphemeral      >>= dhBytesToPair-                      , _hoRemoteStatic        = vrrStatic        >>= dhBytesToPub-                      , _hoRemoteSemiEphemeral = vrrSemiEphemeral >>= dhBytesToPub-                      , _hoRemoteEphemeral     = Nothing-                      }+natureOfFailure :: ValidationResult+                -> Text+natureOfFailure (ResultException _)        = "Exception thrown during handshake."+natureOfFailure (ResultMsgDifference _)    = "Given and calculated messages differ."+natureOfFailure (ResultHashDifference _ _) = "Given and calculated handshake hashes differ."+natureOfFailure ResultSuccess              = "Vector passed but should not have." -mkNoiseStates :: (Cipher c, DH d, Hash h)-             => HandshakeOpts d-             -> HandshakeOpts d-             -> CipherType c-             -> HashType h-             -> (NoiseState c d h, NoiseState c d h)-mkNoiseStates iho rho _ _ = (noiseState iho, noiseState rho)+resultSuccess :: ValidationResult+              -> Bool+resultSuccess ResultSuccess = True+resultSuccess _             = False -verifyMessage :: (Cipher c, Hash h)-              => NoiseState c d h-              -> NoiseState c d h-              -> Message-              -> (Either SomeException (ByteString, ByteString, NoiseState c d h),-                  Either SomeException (ByteString, ByteString, NoiseState c d h))-verifyMessage sendingState receivingState Message{..} = (sendResult, recvResult)-  where-    payload            = fromMaybe "" mPayload-    convertSend (p, s) = (p, mCiphertext, s)-    convertRecv (c, s) = (convert c, convert payload, s)-    sendResult         = convertSend <$> writeMessage sendingState payload-    recvResult         = convertRecv <$> readMessage receivingState mCiphertext+compareMsgs :: [Message] -- ^ Given messages+            -> [Message] -- ^ Calculated messages+            -> [Maybe (Message, Message)]+compareMsgs given calc =+  (\(m1, m2) -> if m1 == m2+    then Nothing+    else Just (m1, m2)) <$> zip given calc  verifyVector :: Vector-             -> [(Either SomeException (ByteString, ByteString),-                  Either SomeException (ByteString, ByteString))]-verifyVector v@Vector{..} =-  case (vCipher, vDH, vHash) of-    (WrapCipherType c, WrapDHType d, WrapHashType h) ->-      let swap       = not $ vPattern == NoiseN || vPattern == NoiseK || vPattern == NoiseX-          (io, ro)   = mkHandshakeOpts v d-          (ins, rns) = mkNoiseStates io ro c h in-      go swap [] ins rns vMessages-+             -> ValidationResult+verifyVector given =+  either ResultException finalResult rawResults   where-    stripState = join (***) (either Left (\(r, e, _) -> Right (r, e)))--    extractState (mr1, mr2) = do-      s1 <- either (const Nothing) (\(_, _, s) -> Just s) mr1-      s2 <- either (const Nothing) (\(_, _, s) -> Just s) mr2-      return (s1, s2)+    cipher = hsCipher . vProtoName $ given+    dh     = hsDH     . vProtoName $ given+    hash   = hsHash   . vProtoName $ given+    rawResults = populateVector cipher dh hash (mPayload <$> vMessages given) given+    finalResult calc =+      let msgComparison  = compareMsgs (vMessages given) (vMessages calc)+          hashComparison = do+            g <- vHash given+            c <- vHash calc+            return (g, c)+      in+        if any (/= Nothing) msgComparison+          then ResultMsgDifference msgComparison+          else case hashComparison of+            Just (g, c) -> if g /= c then ResultHashDifference g c else ResultSuccess+            Nothing     -> ResultSuccess -    go _ acc _ _ [] = acc-    go swap acc sendingState receivingState (msg : rest) =-      let results  = verifyMessage sendingState receivingState msg-          states   = extractState results-          stripped = stripState results in-      maybe (acc <> [stripped]) (\(sendingState', receivingState') ->-        if swap-          then go swap (acc <> [stripped]) receivingState' sendingState' rest-          else go swap (acc <> [stripped]) sendingState' receivingState' rest) states+printMessageComparison :: Message+                       -> Message+                       -> IO ()+printMessageComparison m1 m2 = do+  putStrLn "Message:"+  putStrLn $ "\tGiven payload:\t\t" <> (encodeSB . mPayload) m1+  putStrLn $ "\tGiven ciphertext:\t" <> (encodeSB . mCiphertext) m1+  putStrLn $ "\tCalculated ciphertext:\t" <> (encodeSB . mCiphertext) m2 -printFailure :: Int-             -> Bool-             -> Either SomeException (ByteString, ByteString)+printMessage :: Message              -> IO ()-printFailure i payload mr =-  case mr of-    Left  e -> putStrLn $ "Message " <> show i <> ": " <> show e-    Right (result, expectation) ->-      when (result /= expectation) $ do-        let component = if payload then " payload:" else " ciphertext:"-        putStrLn $ "Message " <> show i <> component-        BS.putStrLn $ "Calculated value:\t" <> encode result-        BS.putStrLn $ "Expectation:\t\t" <> encode expectation-        putStrLn ""+printMessage m = do+  putStrLn "Message:"+  putStrLn $ "\tPayload:\t" <> (encodeSB . mPayload) m+  putStrLn $ "\tCiphertext:\t" <> (encodeSB . mCiphertext) m +printExFailure :: [Either SomeException Message]+               -> IO ()+printExFailure = mapM_ $+  either (\ex -> putStrLn $ "Exception: " <> (pack . show) ex)+         printMessage++printComparisonFailure :: [Maybe (Message, Message)]+                       -> IO ()+printComparisonFailure mms =+  forM_ mms $ maybe (return ()) (uncurry printMessageComparison)++printHashFailure :: ScrubbedBytes+                 -> ScrubbedBytes+                 -> IO ()+printHashFailure given calc = do+  putStrLn $ "Given handshake hash:\t\t" <> encodeSB given+  putStrLn $ "Calculated handshake hash:\t" <> encodeSB calc+ verifyVectorFile :: FilePath                  -> IO () verifyVectorFile f = do   fd <- readFile f -  let mvf = decode fd :: Maybe VectorFile--  vf <- maybe (putStrLn ("error decoding " <> f) >> exitFailure) return mvf--  allResults <- mapConcurrently (\v -> return (vName v, verifyVector v, vFail v)) $ vfVectors vf+  vf <- case eitherDecode fd of+    Left err -> do+      putStrLn $ "Error decoding " <> pack f <> ": " <> pack err+      exitFailure+    Right r -> return r -  let didItFail = all (== True) . fmap ((== (True, True)) . join (***) (either (const False) (uncurry (==))))-      failures  = filter (\(_, results, mustItFail) -> (didItFail results == mustItFail)) allResults+  let results  = (\(idx, v) -> (idx, v, verifyVector v)) <$> zip [0..] (vfVectors vf)+      failures = filter (\(_, v, r) ->+                   vFail v `xor` (not . resultSuccess) r)+                   results    if not (null failures) then do-    putStrLn $ f <> ": The following vectors have failed:\n"-    forM_ failures $ \(name, results, mustFail) -> do-      let failStatus = if mustFail then " (must fail)" else ""-      putStrLn $ name <> failStatus <> ": "-      printLoop 0 results+    putStrLn $ pack f <> ": The following vectors have failed:\n"+    forM_ failures $ \(idx, vector, result) -> do+      putStrLn "================================================================"+      putStrLn $ "Vector number: " <> (pack . show) (idx :: Integer) +      let protoName = (pack . show . vProtoName) vector+      putStrLn $ "Handshake name: " <> fromMaybe protoName (vName vector)+      putStrLn $ "Protocol name: " <> protoName+      putStrLn $ "Should fail?: " <> if vFail vector then "yes" else "no"+      putStrLn $ "Nature of failure: " <> natureOfFailure result+      case result of+        ResultException ems      -> printExFailure ems+        ResultMsgDifference mms  -> printComparisonFailure mms+        ResultHashDifference g c -> printHashFailure g c+        ResultSuccess            -> return ()+      putStrLn ""     exitFailure-  else putStrLn $ f <> ": All vectors passed."--  where-    printLoop _ [] = return ()-    printLoop i ((r1, r2) : rest) = do-      printFailure i False r1-      printFailure i True r2-      printLoop (i + 1) rest+  else putStrLn $ pack f <> ": All vectors passed."