Merge branch 'master' into uni2work

Small refactor

.appveyor.yml

@@ -0,0 +1,29 @@
+# ~*~ auto-generated by haskell-ci with config : 4fdddfa41dd039e198b8d125a70471f7dd140fa01001d99126af56fb31429ece ~*~
+
+version: "{build}"
+clone_folder: C:\project
+build: off
+cache:
+  - "C:\\SR -> .appveyor.yml"
+
+environment:
+  global:
+    STACK_ROOT: "C:\\SR"
+  matrix:
+    - { BUILD: "ghc-8.6", STACKCMD: "stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps", STACKCFG: "{ resolver: lts-14.27, packages: [ '.' ], extra-deps: [], flags: {} }", STACKURL: "https://www.stackage.org/stack/windows-x86_64" }
+    - { BUILD: "ghc-8.8", STACKCMD: "stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps", STACKCFG: "{ resolver: lts-15.1, packages: [ '.' ], extra-deps: [], flags: {} }", STACKURL: "https://www.stackage.org/stack/windows-x86_64" }
+
+matrix:
+  fast_finish: true
+
+install:
+  - set PATH=C:\Program Files\Git\mingw64\bin;%PATH%
+  - curl -ostack.zip -L %STACKURL%
+  - 7z x stack.zip stack.exe
+  - refreshenv
+test_script:
+  - echo %STACKCFG% > stack.yaml
+  - stack setup > nul
+  - echo "" | %STACKCMD%
+
+

.envrc

@@ -0,0 +1 @@
+use flake

.gitignore

@@ -2,6 +2,7 @@
 *.hi
 *.tix
 *.mix
+.stack-work
 gen/Gen
 gen/Crypto/*
 dist
@@ -9,3 +10,6 @@ QA
 benchs/Bench
 benchs/Hash
 *.sublime-workspace
+.cabal-sandbox/
+cabal.sandbox.config
+stack.yaml.lock

.haskell-ci

@@ -0,0 +1,26 @@
+# compiler supported and their equivalent LTS
+compiler: ghc-8.0 lts-9.21
+compiler: ghc-8.2 lts-11.22
+compiler: ghc-8.4 lts-12.26
+compiler: ghc-8.6 lts-14.27
+compiler: ghc-8.8 lts-15.1
+
+# options
+# option: alias x=y z=v
+option: gaugedeps extradep=gauge-0.2.1
+option: basementmin extradep=basement-0.0.8 extradep=memory-0.14.18
+
+# builds
+build: ghc-8.0 basementmin gaugedeps
+build: ghc-8.2 basementmin
+build: ghc-8.4
+build: ghc-8.6 os=linux,osx,windows
+build: ghc-8.8 os=linux,windows
+
+# packages
+package: '.'
+
+# extra builds
+hlint: allowed-failure
+weeder: allowed-failure
+coverall: false

.hlint.yaml

@@ -0,0 +1,3 @@
+- arguments: [ --cpp-define=ARCH_X86_64
+             ]
+- ignore: { name: Use camelCase }

.travis.yml

@@ -1,54 +1,83 @@
-sudo: false
+# ~*~ auto-generated by haskell-ci with config : 4fdddfa41dd039e198b8d125a70471f7dd140fa01001d99126af56fb31429ece ~*~
 
-env:
- - CABALVER=1.16 GHCVER=7.0.4
- - CABALVER=1.16 GHCVER=7.4.2
- - CABALVER=1.18 GHCVER=7.6.3
- - CABALVER=1.18 GHCVER=7.8.4
- - CABALVER=1.22 GHCVER=7.10.1
- - CABALVER=head GHCVER=head
+# Caching so the next build will be fast too.
+cache:
+  directories:
+  - $HOME/.ghc
+  - $HOME/.stack
+  - $HOME/.local
 
-matrix:
+language: generic
+os: linux
+
+jobs:
+  include:
+  - { env: BUILD=stack RESOLVER=ghc-8.0, addons: { apt: { packages: [ libgmp-dev ] } } }
+  - { env: BUILD=stack RESOLVER=ghc-8.2, addons: { apt: { packages: [ libgmp-dev ] } } }
+  - { env: BUILD=stack RESOLVER=ghc-8.4, addons: { apt: { packages: [ libgmp-dev ] } } }
+  - { env: BUILD=stack RESOLVER=ghc-8.6, addons: { apt: { packages: [ libgmp-dev ] } } }
+  - { env: BUILD=stack RESOLVER=ghc-8.6, addons: { apt: { packages: [ libgmp-dev ] } }, os: osx }
+  - { env: BUILD=stack RESOLVER=ghc-8.8, addons: { apt: { packages: [ libgmp-dev ] } } }
+  - { env: BUILD=hlint }
+  - { env: BUILD=weeder, addons: { apt: { packages: [ libgmp-dev ] } } }
   allow_failures:
-   - env: CABALVER=head GHCVER=head
-
-addons:
-    apt:
-        sources:
-         - hvr-ghc
-        packages:
-         - cabal-install-1.16
-         - cabal-install-1.18
-         - cabal-install-1.20
-         - cabal-install-1.22
-         - cabal-install-head
-         - ghc-7.0.4
-         - ghc-7.4.2
-         - ghc-7.6.3
-         - ghc-7.8.4
-         - ghc-7.10.1
-         - ghc-head
-
-before_install:
- - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
+  - { env: BUILD=hlint }
+  - { env: BUILD=weeder, addons: { apt: { packages: [ libgmp-dev ] } } }
 
 install:
- - cabal --version
- - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
- - travis_retry cabal update
- - if [ "${GHCVER}" = "7.0.4" ]; then cabal install --only-dependencies; else cabal install --only-dependencies --enable-tests; fi
+  - export PATH=$HOME/.local/bin:$HOME/.cabal/bin:$PATH
+  - mkdir -p ~/.local/bin
+  - |
+    case "$BUILD" in
+      stack|weeder)
+        if [ `uname` = "Darwin" ]
+        then
+          travis_retry curl -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin
+        else
+          travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
+        fi
+      ;;
+    cabal)
+      ;;
+    esac
 
 script:
- - if [ "${GHCVER}" != "7.0.4" ]; then cabal configure --enable-tests -v2; else cabal configure -v2; fi
- - cabal build
- - if [ "${GHCVER}" != "7.0.4" ]; then cabal test; fi;
- - cabal check
- - cabal sdist
- - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;
-   cd dist/;
-   if [ -f "$SRC_TGZ" ]; then
-      cabal install --force-reinstalls "$SRC_TGZ";
-   else
-      echo "expected '$SRC_TGZ' not found";
-      exit 1;
-   fi
+- |
+  set -ex
+  if [ "x${RUNTEST}" = "xfalse" ]; then exit 0; fi
+  case "$BUILD" in
+    stack)
+      # create the build stack.yaml
+      case "$RESOLVER" in
+      ghc-8.0)
+        echo "{ resolver: lts-9.21, packages: [ '.' ], extra-deps: [ basement-0.0.8, memory-0.14.18, gauge-0.2.1 ], flags: {} }" > stack.yaml
+        stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps
+        ;;
+      ghc-8.2)
+        echo "{ resolver: lts-11.22, packages: [ '.' ], extra-deps: [ basement-0.0.8, memory-0.14.18 ], flags: {} }" > stack.yaml
+        stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps
+        ;;
+      ghc-8.4)
+        echo "{ resolver: lts-12.26, packages: [ '.' ], extra-deps: [], flags: {} }" > stack.yaml
+        stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps
+        ;;
+      ghc-8.6)
+        echo "{ resolver: lts-14.27, packages: [ '.' ], extra-deps: [], flags: {} }" > stack.yaml
+        stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps
+        ;;
+      ghc-8.8)
+        echo "{ resolver: lts-15.1, packages: [ '.' ], extra-deps: [], flags: {} }" > stack.yaml
+        stack --no-terminal build --install-ghc --coverage --test --bench --no-run-benchmarks --haddock --no-haddock-deps
+        ;;
+      esac
+      ;;
+    hlint)
+      curl -sL https://raw.github.com/ndmitchell/hlint/master/misc/travis.sh | sh -s . --cpp-define=__GLASGOW_HASKELL__=800 --cpp-define=x86_64_HOST_ARCH=1 --cpp-define=mingw32_HOST_OS=1
+      ;;
+    weeder)
+      stack --no-terminal build --install-ghc --ghc-options="-ddump-to-file -ddump-hi" --test --no-run-tests --bench --no-run-benchmarks
+      curl -sL https://raw.github.com/ndmitchell/weeder/master/misc/travis.sh | sh -s .
+      ;;
+  esac
+  set +ex
+

CHANGELOG.md

@@ -1,7 +1,218 @@
+## 0.30
+
+* Fix some C symbol blake2b prefix to be cryptonite_ prefix (fix mixing with other C library)
+* add hmac-lazy
+* Fix compilation with GHC 9.2
+* Drop support for GHC8.0, GHC8.2, GHC8.4, GHC8.6
+
+## 0.29
+
+* advance compilation with gmp breakage due to change upstream
+* Add native EdDSA support
+
+## 0.28
+
+* Add hash constant time capability
+* Prevent possible overflow during hashing by hashing in 4GB chunks
+
+## 0.27
+
+* Optimise AES GCM and CCM
+* Optimise P256R1 implementation
+* Various AES-NI building improvements
+* Add better ECDSA support
+* Add XSalsa derive
+* Implement square roots for ECC binary curve
+* Various tests and benchmarks
+
+## 0.26
+
+* Add Rabin cryptosystem (and variants)
+* Add bcrypt_pbkdf key derivation function
+* Optimize Blowfish implementation
+* Add KMAC (Keccak Message Authentication Code)
+* Add ECDSA sign/verify digest APIs
+* Hash algorithms with runtime output length
+* Update blake2 to latest upstream version
+* RSA-PSS with arbitrary key size
+* SHAKE with output length not divisible by 8
+* Add Read and Data instances for Digest type
+* Improve P256 scalar primitives
+* Fix hash truncation bug in DSA
+* Fix cost parsing for bcrypt
+* Fix ECC failures on arm64
+* Correction to PKCS#1 v1.5 padding
+* Use powModSecInteger when available
+* Drop GHC 7.8 and GHC 7.10 support, refer to pkg-guidelines
+* Optimise GCM mode
+* Add little endian serialization of integer
+
+## 0.25
+
+* Improve digest binary conversion efficiency
+* AES CCM support
+* Add MonadFailure instance for CryptoFailable
+* Various misc improvements on documentation
+* Edwards25519 lowlevel arithmetic support
+* P256 add point negation
+* Improvement in ECC (benchmark, better normalization)
+* Blake2 improvements to context size
+* Use gauge instead of criterion
+* Use haskell-ci for CI scripts
+* Improve Digest memory representation to be 2 less Ints and one less boxing
+  moving from `UArray` to `Block`
+
+## 0.24
+
+* Ed25519: generateSecret & Documentation updates
+* Repair tutorial
+* RSA: Allow signing digest directly
+* IV add: fix overflow behavior
+* P256: validate point when decoding
+* Compilation fix with deepseq disabled
+* Improve Curve448 and use decaf for Ed448
+* Compilation flag blake2 sse merged in sse support
+* Process unaligned data better in hashes and AES, on architecture needing alignment
+* Drop support for ghc 7.6
+* Add ability to create random generator Seed from binary data and
+  loosen constraint on ChaChaDRG seed from ByteArray to ByteArrayAccess.
+* Add 3 associated types with the HashAlgorithm class, to get
+  access to the constant for BlockSize, DigestSize and ContextSize at the type level.
+  the related function that this replaced will be deprecated in later release, and
+  eventually removed.
+
+API CHANGES:
+
+* Improve ECDH safety to return failure for bad inputs (e.g. public point in small order subgroup).
+  To go back to previous behavior you can replace `ecdh` by `ecdhRaw`. It's recommended to
+  use `ecdh` and handle the error appropriately.
+* Users defining their own HashAlgorithm needs to define the
+  HashBlockSize, HashDigest, HashInternalContextSize associated types
+
+## 0.23
+
+* Digest memory usage improvement by using unpinned memory
+* Fix generateBetween to generate within the right bounds
+* Add pure Twofish implementation
+* Fix memory allocation in P256 when using a temp point
+* Consolidate hash benchmark code
+* Add Nat-length Blake2 support (GHC > 8.0)
+* Update tutorial
+
+## 0.22
+
+* Add Argon2 (Password Hashing Competition winner) hash function
+* Update blake2 to latest upstream version
+* Add extra blake2 hashing size
+* Add faster PBKDF2 functions for SHA1/SHA256/SHA512
+* Add SHAKE128 and SHAKE256
+* Cleanup prime generation, and add tests
+* Add Time-based One Time Password (TOTP) and HMAC-based One Time Password (HOTP)
+* Rename Ed448 module name to Curve448, old module name still valid for now
+
+## 0.21
+
+* Drop automated tests with GHC 7.0, GHC 7.4, GHC 7.6. support dropped, but probably still working.
+* Improve non-aligned support in C sources, ChaCha and SHA3 now probably work on arch without support for unaligned access. not complete or tested.
+* Add another ECC framework that is more flexible, allowing different implementations to work instead of
+  the existing Pure haskell NIST implementation.
+* Add ECIES basic primitives
+* Add XSalsa20 stream cipher
+* Process partial buffer correctly with Poly1305
+
+## 0.20
+
+* Fixed hash truncation used in ECDSA signature & verification (Olivier Chéron)
+* Fix ECDH when scalar and coordinate bit sizes differ (Olivier Chéron)
+* Speed up ECDSA verification using Shamir's trick (Olivier Chéron)
+* Fix rdrand on windows
+
+## 0.19
+
+* Add tutorial (Yann Esposito)
+* Derive Show instance for better interaction with Show pretty printer (Eric Mertens)
+
+## 0.18
+
+* Re-used standard rdrand instructions instead of bytedump of rdrand instruction
+* Improvement to F2m, including lots of tests (Andrew Lelechenko)
+* Add error check on salt length in bcrypt
+
+## 0.17
+
+* Add Miyaguchi-Preneel construction (Kei Hibino)
+* Fix buffer length in scrypt (Luke Taylor)
+* build fixes for i686 and arm related to rdrand
+
+## 0.16
+
+* Fix basepoint for Ed448
+
+* Enable 64-bit Curve25519 implementation
+
+## 0.15
+
+* Fix serialization of DH and ECDH
+
+## 0.14
+
+* Reduce size of SHA3 context instead of allocating all-size fit memory. save
+  up to 72 bytes of memory per context for SHA3-512.
+* Add a Seed capability to the main DRG, to be able to debug/reproduce randomized program
+  where you would want to disable the randomness.
+* Add support for Cipher-based Message Authentication Code (CMAC) (Kei Hibino)
+* *CHANGE* Change the `SharedKey` for `Crypto.PubKey.DH` and `Crypto.PubKey.ECC.DH`,
+  from an Integer newtype to a ScrubbedBytes newtype. Prevent mistake where the
+  bytes representation is generated without the right padding (when needed).
+* *CHANGE* Keep The field size in bits, in the `Params` in `Crypto.PubKey.DH`,
+  moving from 2 elements to 3 elements in the structure.
+
+## 0.13
+
+* *SECURITY* Fix buffer overflow issue in SHA384, copying 16 extra bytes from
+  the SHA512 context to the destination memory pointer leading to memory
+  corruption, segfault. (Mikael Bung)
+
+## 0.12
+
+* Fix compilation issue with Ed448 on 32 bits machine.
+
+## 0.11
+
+* Truncate hashing correctly for DSA
+* Add support for HKDF (RFC 5869)
+* Add support for Ed448
+* Extends support for Blake2s to 224 bits version.
+* Compilation workaround for old distribution (RHEL 4.1)
+* Compilation fix for AIX
+* Compilation fix with AESNI and ghci compiling C source in a weird order.
+* Fix example compilation, typo, and warning
+
+## 0.10
+
+* Add reference implementation of blake2 for non-SSE2 platform
+* Add support\_blake2\_sse flag
+
+## 0.9
+
+* Quiet down unused module imports
+* Move Curve25519 over to Crypto.Error instead of using Either String.
+* Add documentation for ChaChaPoly1305
+* Add missing documentation for various modules
+* Add a way to create Poly1305 Auth tag.
+* Added support for the BLAKE2 family of hash algorithms
+* Fix endianness of incrementNonce function for ChaChaPoly1305
+
+## 0.8
+
+* Add support for ChaChaPoly1305 Nonce Increment (John Galt)
+* Move repository to the haskell-crypto organisation
+
 ## 0.7
 
 * Add PKCS5 / PKCS7 padding and unpadding methods
 * Fix ChaChaPoly1305 Decryption
+* Add support for BCrypt (Luke Taylor)
 
 ## 0.6
 

CONTRIBUTING.md

@@ -0,0 +1,10 @@
+cryptonite guideline
+--------------------
+
+not a definitive list:
+
+* 4-spaces for indentation
+* don't use bytestring directly, use the `memory` abstraction
+* hard errors should represented by the equivalent Crypto.Error.Types. Possibly reuse a matching value, otherwise create one.
+* don't use 'error', use throwCryptoError (or the IO cousin) if needed
+* don't add dependencies without a really really really strong motivation. only exception: `foundation`

Crypto/Cipher/AES.hs

@@ -14,6 +14,7 @@ module Crypto.Cipher.AES
 
 import Crypto.Error
 import Crypto.Cipher.Types
+import Crypto.Cipher.Utils
 import Crypto.Cipher.Types.Block
 import Crypto.Cipher.AES.Primitive
 import Crypto.Internal.Imports
@@ -33,17 +34,18 @@ newtype AES256 = AES256 AES
 instance Cipher AES128 where
     cipherName    _ = "AES128"
     cipherKeySize _ = KeySizeFixed 16
-    cipherInit k    = AES128 `fmap` initAES k
+    cipherInit k    = AES128 <$> (initAES =<< validateKeySize (undefined :: AES128) k)
 
 instance Cipher AES192 where
     cipherName    _ = "AES192"
     cipherKeySize _ = KeySizeFixed 24
-    cipherInit k    = AES192 `fmap` initAES k
+    cipherInit k    = AES192 <$> (initAES =<< validateKeySize (undefined :: AES192) k)
 
 instance Cipher AES256 where
     cipherName    _ = "AES256"
     cipherKeySize _ = KeySizeFixed 32
-    cipherInit k    = AES256 `fmap` initAES k
+    cipherInit k    = AES256 <$> (initAES =<< validateKeySize (undefined :: AES256) k)
+
 
 #define INSTANCE_BLOCKCIPHER(CSTR) \
 instance BlockCipher CSTR where \
@@ -55,6 +57,7 @@ instance BlockCipher CSTR where \
     ; ctrCombine (CSTR aes) (IV iv) = encryptCTR aes (IV iv) \
     ; aeadInit AEAD_GCM (CSTR aes) iv = CryptoPassed $ AEAD (gcmMode aes) (gcmInit aes iv) \
     ; aeadInit AEAD_OCB (CSTR aes) iv = CryptoPassed $ AEAD (ocbMode aes) (ocbInit aes iv) \
+    ; aeadInit (AEAD_CCM n m l) (CSTR aes) iv = AEAD (ccmMode aes) <$> ccmInit aes iv n m l \
     ; aeadInit _        _          _  = CryptoFailed CryptoError_AEADModeNotSupported \
     }; \
 instance BlockCipher128 CSTR where \

Crypto/Cipher/AES/Primitive.hs

@@ -11,39 +11,46 @@
 --
 module Crypto.Cipher.AES.Primitive
     (
-    -- * block cipher data types
+    -- * Block cipher data types
       AES
 
     -- * Authenticated encryption block cipher types
     , AESGCM
     , AESOCB
 
-    -- * creation
+    -- * Creation
     , initAES
 
-    -- * misc
+    -- * Miscellanea
     , genCTR
     , genCounter
 
-    -- * encryption
+    -- * Encryption
     , encryptECB
     , encryptCBC
     , encryptCTR
     , encryptXTS
 
-    -- * decryption
+    -- * Decryption
     , decryptECB
     , decryptCBC
     , decryptCTR
     , decryptXTS
 
-    -- * incremental GCM
+    -- * CTR with 32-bit wrapping
+    , combineC32
+
+    -- * Incremental GCM
     , gcmMode
     , gcmInit
 
-    -- * incremental OCB
+    -- * Incremental OCB
     , ocbMode
     , ocbInit
+
+    -- * CCM
+    , ccmMode
+    , ccmInit
     ) where
 
 import           Data.Word
@@ -73,6 +80,7 @@ instance BlockCipher AES where
     ctrCombine = encryptCTR
     aeadInit AEAD_GCM aes iv = CryptoPassed $ AEAD (gcmMode aes) (gcmInit aes iv)
     aeadInit AEAD_OCB aes iv = CryptoPassed $ AEAD (ocbMode aes) (ocbInit aes iv)
+    aeadInit (AEAD_CCM n m l) aes iv = AEAD (ccmMode aes) <$> ccmInit aes iv n m l
     aeadInit _        _   _  = CryptoFailed CryptoError_AEADModeNotSupported
 instance BlockCipher128 AES where
     xtsEncrypt = encryptXTS
@@ -96,6 +104,15 @@ ocbMode aes = AEADModeImpl
     , aeadImplFinalize     = ocbFinish aes
     }
 
+-- | Create an AES AEAD implementation for CCM
+ccmMode :: AES -> AEADModeImpl AESCCM
+ccmMode aes = AEADModeImpl
+    { aeadImplAppendHeader = ccmAppendAAD aes
+    , aeadImplEncrypt      = ccmEncrypt aes
+    , aeadImplDecrypt      = ccmDecrypt aes
+    , aeadImplFinalize     = ccmFinish aes
+    }
+
 
 -- | AES Context (pre-processed key)
 newtype AES = AES ScrubbedBytes
@@ -109,12 +126,19 @@ newtype AESGCM = AESGCM ScrubbedBytes
 newtype AESOCB = AESOCB ScrubbedBytes
     deriving (NFData)
 
+-- | AESCCM State
+newtype AESCCM = AESCCM ScrubbedBytes
+    deriving (NFData)
+
 sizeGCM :: Int
-sizeGCM = 80
+sizeGCM = 320
 
 sizeOCB :: Int
 sizeOCB = 160
 
+sizeCCM :: Int
+sizeCCM = 80
+
 keyToPtr :: AES -> (Ptr AES -> IO a) -> IO a
 keyToPtr (AES b) f = withByteArray b (f . castPtr)
 
@@ -152,6 +176,13 @@ withOCBKeyAndCopySt aes (AESOCB gcmSt) f =
         a     <- withByteArray newSt $ \gcmStPtr -> f (castPtr gcmStPtr) aesPtr
         return (a, AESOCB newSt)
 
+withCCMKeyAndCopySt :: AES -> AESCCM -> (Ptr AESCCM -> Ptr AES -> IO a) -> IO (a, AESCCM)
+withCCMKeyAndCopySt aes (AESCCM ccmSt) f =
+    keyToPtr aes $ \aesPtr -> do
+        newSt <- B.copy ccmSt (\_ -> return ())
+        a     <- withByteArray newSt $ \ccmStPtr -> f (castPtr ccmStPtr) aesPtr
+        return (a, AESCCM newSt)
+
 -- | Initialize a new context with a key
 --
 -- Key needs to be of length 16, 24 or 32 bytes. Any other values will return failure
@@ -289,6 +320,21 @@ decryptXTS :: ByteArray ba
            -> ba         -- ^ output decrypted
 decryptXTS = doXTS c_aes_decrypt_xts
 
+-- | encrypt/decrypt using Counter mode (32-bit wrapping used in AES-GCM-SIV)
+{-# NOINLINE combineC32 #-}
+combineC32 :: ByteArray ba
+           => AES        -- ^ AES Context
+           -> IV AES     -- ^ initial vector of AES block size (usually representing a 128 bit integer)
+           -> ba         -- ^ plaintext input
+           -> ba         -- ^ ciphertext output
+combineC32 ctx iv input
+    | len <= 0          = B.empty
+    | B.length iv /= 16 = error $ "AES error: IV length must be block size (16). Its length is: " ++ show (B.length iv)
+    | otherwise = B.allocAndFreeze len doEncrypt
+  where doEncrypt o = withKeyAndIV ctx iv $ \k v -> withByteArray input $ \i ->
+                      c_aes_encrypt_c32 (castPtr o) k v i (fromIntegral len)
+        len = B.length input
+
 {-# INLINE doECB #-}
 doECB :: ByteArray ba
       => (Ptr b -> Ptr AES -> CString -> CUInt -> IO ())
@@ -447,6 +493,78 @@ ocbFinish ctx ocb taglen = AuthTag $ B.take taglen computeTag
   where computeTag = B.allocAndFreeze 16 $ \t ->
                         withOCBKeyAndCopySt ctx ocb (c_aes_ocb_finish (castPtr t)) >> return ()
 
+ccmGetM :: CCM_M -> Int
+ccmGetL :: CCM_L -> Int
+ccmGetM m = case m of
+  CCM_M4 -> 4
+  CCM_M6 -> 6
+  CCM_M8 -> 8
+  CCM_M10 -> 10
+  CCM_M12 -> 12
+  CCM_M14 -> 14
+  CCM_M16 -> 16
+
+ccmGetL l = case l of
+  CCM_L2 -> 2
+  CCM_L3 -> 3
+  CCM_L4 -> 4
+
+-- | initialize a ccm context
+{-# NOINLINE ccmInit #-}
+ccmInit :: ByteArrayAccess iv => AES -> iv -> Int -> CCM_M -> CCM_L -> CryptoFailable AESCCM
+ccmInit ctx iv n m l
+    | 15 - li /= B.length iv = CryptoFailed CryptoError_IvSizeInvalid
+    | otherwise = unsafeDoIO $ do
+          sm <- B.alloc sizeCCM $ \ccmStPtr ->
+            withKeyAndIV ctx iv $ \k v ->
+            c_aes_ccm_init (castPtr ccmStPtr) k v (fromIntegral $ B.length iv) (fromIntegral n) (fromIntegral mi) (fromIntegral li)
+          return $ CryptoPassed (AESCCM sm)
+  where
+    mi = ccmGetM m
+    li = ccmGetL l
+
+-- | append data which is only going to be authenticated to the CCM context.
+--
+-- needs to happen after initialization and before appending encryption/decryption data.
+{-# NOINLINE ccmAppendAAD #-}
+ccmAppendAAD :: ByteArrayAccess aad => AES -> AESCCM -> aad -> AESCCM
+ccmAppendAAD ctx ccm input = unsafeDoIO $ snd <$> withCCMKeyAndCopySt ctx ccm doAppend
+  where doAppend ccmStPtr aesPtr =
+            withByteArray input $ \i -> c_aes_ccm_aad ccmStPtr aesPtr i (fromIntegral $ B.length input)
+
+-- | append data to encrypt and append to the CCM context
+--
+-- the bytearray needs to be a multiple of AES block size, unless it's the last call to this function.
+-- needs to happen after AAD appending, or after initialization if no AAD data.
+{-# NOINLINE ccmEncrypt #-}
+ccmEncrypt :: ByteArray ba => AES -> AESCCM -> ba -> (ba, AESCCM)
+ccmEncrypt ctx ccm input = unsafeDoIO $ withCCMKeyAndCopySt ctx ccm cbcmacAndIv
+  where len = B.length input
+        cbcmacAndIv ccmStPtr aesPtr =
+            B.alloc len $ \o ->
+            withByteArray input $ \i ->
+            c_aes_ccm_encrypt (castPtr o) ccmStPtr aesPtr i (fromIntegral len)
+
+-- | append data to decrypt and append to the CCM context
+--
+-- the bytearray needs to be a multiple of AES block size, unless it's the last call to this function.
+-- needs to happen after AAD appending, or after initialization if no AAD data.
+{-# NOINLINE ccmDecrypt #-}
+ccmDecrypt :: ByteArray ba => AES -> AESCCM -> ba -> (ba, AESCCM)
+ccmDecrypt ctx ccm input = unsafeDoIO $ withCCMKeyAndCopySt ctx ccm cbcmacAndIv
+  where len = B.length input
+        cbcmacAndIv ccmStPtr aesPtr =
+            B.alloc len $ \o ->
+            withByteArray input $ \i ->
+            c_aes_ccm_decrypt (castPtr o) ccmStPtr aesPtr i (fromIntegral len)
+
+-- | Generate the Tag from CCM context
+{-# NOINLINE ccmFinish #-}
+ccmFinish :: AES -> AESCCM -> Int -> AuthTag
+ccmFinish ctx ccm taglen = AuthTag $ B.take taglen computeTag
+  where computeTag = B.allocAndFreeze 16 $ \t ->
+                        withCCMKeyAndCopySt ctx ccm (c_aes_ccm_finish (castPtr t)) >> return ()
+
 ------------------------------------------------------------------------
 foreign import ccall "cryptonite_aes.h cryptonite_aes_initkey"
     c_aes_init :: Ptr AES -> CString -> CUInt -> IO ()
@@ -478,6 +596,9 @@ foreign import ccall unsafe "cryptonite_aes.h cryptonite_aes_gen_ctr_cont"
 foreign import ccall "cryptonite_aes.h cryptonite_aes_encrypt_ctr"
     c_aes_encrypt_ctr :: CString -> Ptr AES -> Ptr Word8 -> CString -> CUInt -> IO ()
 
+foreign import ccall "cryptonite_aes.h cryptonite_aes_encrypt_c32"
+    c_aes_encrypt_c32 :: CString -> Ptr AES -> Ptr Word8 -> CString -> CUInt -> IO ()
+
 foreign import ccall "cryptonite_aes.h cryptonite_aes_gcm_init"
     c_aes_gcm_init :: Ptr AESGCM -> Ptr AES -> Ptr Word8 -> CUInt -> IO ()
 
@@ -508,3 +629,17 @@ foreign import ccall "cryptonite_aes.h cryptonite_aes_ocb_decrypt"
 foreign import ccall "cryptonite_aes.h cryptonite_aes_ocb_finish"
     c_aes_ocb_finish :: CString -> Ptr AESOCB -> Ptr AES -> IO ()
 
+foreign import ccall "cryptonite_aes.h cryptonite_aes_ccm_init"
+    c_aes_ccm_init :: Ptr AESCCM -> Ptr AES -> Ptr Word8 -> CUInt -> CUInt -> CInt -> CInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_ccm_aad"
+    c_aes_ccm_aad :: Ptr AESCCM -> Ptr AES -> CString -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_ccm_encrypt"
+    c_aes_ccm_encrypt :: CString -> Ptr AESCCM -> Ptr AES -> CString -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_ccm_decrypt"
+    c_aes_ccm_decrypt :: CString -> Ptr AESCCM -> Ptr AES -> CString -> CUInt -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_ccm_finish"
+    c_aes_ccm_finish :: CString -> Ptr AESCCM -> Ptr AES -> IO ()

Crypto/Cipher/AESGCMSIV.hs

@@ -0,0 +1,193 @@
+-- |
+-- Module      : Crypto.Cipher.AESGCMSIV
+-- License     : BSD-style
+-- Maintainer  : Olivier Chéron <olivier.cheron@gmail.com>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Implementation of AES-GCM-SIV, an AEAD scheme with nonce misuse resistance
+-- defined in <https://tools.ietf.org/html/rfc8452 RFC 8452>.
+--
+-- To achieve the nonce misuse-resistance property, encryption requires two
+-- passes on the plaintext, hence no streaming API is provided.  This AEAD
+-- operates on complete inputs held in memory.  For simplicity, the
+-- implementation of decryption uses a similar pattern, with performance
+-- penalty compared to an implementation which is able to merge both passes.
+--
+-- The specification allows inputs up to 2^36 bytes but this implementation
+-- requires AAD and plaintext/ciphertext to be both smaller than 2^32 bytes.
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Crypto.Cipher.AESGCMSIV
+    ( Nonce
+    , nonce
+    , generateNonce
+    , encrypt
+    , decrypt
+    ) where
+
+import Data.Bits
+import Data.Word
+
+import Foreign.C.Types
+import Foreign.C.String
+import Foreign.Ptr (Ptr, plusPtr)
+import Foreign.Storable (peekElemOff, poke, pokeElemOff)
+
+import           Data.ByteArray
+import qualified Data.ByteArray as B
+import           Data.Memory.Endian (toLE)
+import           Data.Memory.PtrMethods (memXor)
+
+import Crypto.Cipher.AES.Primitive
+import Crypto.Cipher.Types
+import Crypto.Error
+import Crypto.Internal.Compat (unsafeDoIO)
+import Crypto.Random
+
+
+-- 12-byte nonces
+
+-- | Nonce value for AES-GCM-SIV, always 12 bytes.
+newtype Nonce = Nonce Bytes deriving (Show, Eq, ByteArrayAccess)
+
+-- | Nonce smart constructor.  Accepts only 12-byte inputs.
+nonce :: ByteArrayAccess iv => iv -> CryptoFailable Nonce
+nonce iv
+    | B.length iv == 12 = CryptoPassed (Nonce $ B.convert iv)
+    | otherwise         = CryptoFailed CryptoError_IvSizeInvalid
+
+-- | Generate a random nonce for use with AES-GCM-SIV.
+generateNonce :: MonadRandom m => m Nonce
+generateNonce = Nonce <$> getRandomBytes 12
+
+
+-- POLYVAL (mutable context)
+
+newtype Polyval = Polyval Bytes
+
+polyvalInit :: ScrubbedBytes -> IO Polyval
+polyvalInit h = Polyval <$> doInit
+  where doInit = B.alloc 272 $ \pctx -> B.withByteArray h $ \ph ->
+            c_aes_polyval_init pctx ph
+
+polyvalUpdate :: ByteArrayAccess ba => Polyval -> ba -> IO ()
+polyvalUpdate (Polyval ctx) bs = B.withByteArray ctx $ \pctx ->
+    B.withByteArray bs $ \pbs -> c_aes_polyval_update pctx pbs sz
+  where sz = fromIntegral (B.length bs)
+
+polyvalFinalize :: Polyval -> IO ScrubbedBytes
+polyvalFinalize (Polyval ctx) = B.alloc 16 $ \dst ->
+    B.withByteArray ctx $ \pctx -> c_aes_polyval_finalize pctx dst
+
+foreign import ccall unsafe "cryptonite_aes.h cryptonite_aes_polyval_init"
+    c_aes_polyval_init :: Ptr Polyval -> CString -> IO ()
+
+foreign import ccall "cryptonite_aes.h cryptonite_aes_polyval_update"
+    c_aes_polyval_update :: Ptr Polyval -> CString -> CUInt -> IO ()
+
+foreign import ccall unsafe "cryptonite_aes.h cryptonite_aes_polyval_finalize"
+    c_aes_polyval_finalize :: Ptr Polyval -> CString -> IO ()
+
+
+-- Key Generation
+
+le32iv :: Word32 -> Nonce -> Bytes
+le32iv n (Nonce iv) = B.allocAndFreeze 16 $ \ptr -> do
+    poke ptr (toLE n)
+    copyByteArrayToPtr iv (ptr `plusPtr` 4)
+
+deriveKeys :: BlockCipher128 aes => aes -> Nonce -> (ScrubbedBytes, AES)
+deriveKeys aes iv =
+    case cipherKeySize aes of
+        KeySizeFixed sz | sz `mod` 8 == 0 ->
+            let mak = buildKey [0 .. 1]
+                key = buildKey [2 .. fromIntegral (sz `div` 8) + 1]
+                mek = throwCryptoError (cipherInit key)
+             in (mak, mek)
+        _ -> error "AESGCMSIV: invalid cipher"
+  where
+    idx n = ecbEncrypt aes (le32iv n iv) `takeView` 8
+    buildKey = B.concat . map idx
+
+
+-- Encryption and decryption
+
+lengthInvalid :: ByteArrayAccess ba => ba -> Bool
+lengthInvalid bs
+    | finiteBitSize len > 32 = len >= 1 `unsafeShiftL` 32
+    | otherwise              = False
+  where len = B.length bs
+
+-- | AEAD encryption with the specified key and nonce.  The key must be given
+-- as an initialized 'Crypto.Cipher.AES.AES128' or 'Crypto.Cipher.AES.AES256'
+-- cipher.
+--
+-- Lengths of additional data and plaintext must be less than 2^32 bytes,
+-- otherwise an exception is thrown.
+encrypt :: (BlockCipher128 aes, ByteArrayAccess aad, ByteArray ba)
+        => aes -> Nonce -> aad -> ba -> (AuthTag, ba)
+encrypt aes iv aad plaintext
+    | lengthInvalid aad = error "AESGCMSIV: aad is too large"
+    | lengthInvalid plaintext = error "AESGCMSIV: plaintext is too large"
+    | otherwise = (AuthTag tag, ciphertext)
+  where
+    (mak, mek) = deriveKeys aes iv
+    ss = getSs mak aad plaintext
+    tag = buildTag mek ss iv
+    ciphertext = combineC32 mek (transformTag tag) plaintext
+
+-- | AEAD decryption with the specified key and nonce.  The key must be given
+-- as an initialized 'Crypto.Cipher.AES.AES128' or 'Crypto.Cipher.AES.AES256'
+-- cipher.
+--
+-- Lengths of additional data and ciphertext must be less than 2^32 bytes,
+-- otherwise an exception is thrown.
+decrypt :: (BlockCipher128 aes, ByteArrayAccess aad, ByteArray ba)
+        => aes -> Nonce -> aad -> ba -> AuthTag -> Maybe ba
+decrypt aes iv aad ciphertext (AuthTag tag)
+    | lengthInvalid aad = error "AESGCMSIV: aad is too large"
+    | lengthInvalid ciphertext = error "AESGCMSIV: ciphertext is too large"
+    | tag `constEq` buildTag mek ss iv = Just plaintext
+    | otherwise = Nothing
+  where
+    (mak, mek) = deriveKeys aes iv
+    ss = getSs mak aad plaintext
+    plaintext = combineC32 mek (transformTag tag) ciphertext
+
+-- Calculate S_s = POLYVAL(mak, X_1, X_2, ...).
+getSs :: (ByteArrayAccess aad, ByteArrayAccess ba)
+      => ScrubbedBytes -> aad -> ba -> ScrubbedBytes
+getSs mak aad plaintext = unsafeDoIO $ do
+    ctx <- polyvalInit mak
+    polyvalUpdate ctx aad
+    polyvalUpdate ctx plaintext
+    polyvalUpdate ctx (lb :: Bytes)  -- the "length block"
+    polyvalFinalize ctx
+  where
+    lb = B.allocAndFreeze 16 $ \ptr -> do
+            pokeElemOff ptr 0 (toLE64 $ B.length aad)
+            pokeElemOff ptr 1 (toLE64 $ B.length plaintext)
+    toLE64 x = toLE (fromIntegral x * 8 :: Word64)
+
+-- XOR the first 12 bytes of S_s with the nonce and clear the most significant
+-- bit of the last byte.
+tagInput :: ScrubbedBytes -> Nonce -> Bytes
+tagInput ss (Nonce iv) =
+    B.copyAndFreeze ss $ \ptr ->
+    B.withByteArray iv $ \ivPtr -> do
+        memXor ptr ptr ivPtr 12
+        b <- peekElemOff ptr 15
+        pokeElemOff ptr 15 (b .&. (0x7f :: Word8))
+
+-- Encrypt the result with AES using the message-encryption key to produce the
+-- tag.
+buildTag :: BlockCipher128 aes => aes -> ScrubbedBytes -> Nonce -> Bytes
+buildTag mek ss iv = ecbEncrypt mek (tagInput ss iv)
+
+-- The initial counter block is the tag with the most significant bit of the
+-- last byte set to one.
+transformTag :: Bytes -> IV AES
+transformTag tag = toIV $ B.copyAndFreeze tag $ \ptr ->
+    peekElemOff ptr 15 >>= pokeElemOff ptr 15 . (.|. (0x80 :: Word8))
+  where toIV bs = let Just iv = makeIV (bs :: Bytes) in iv

Crypto/Cipher/Blowfish/Box.hs

@@ -5,197 +5,33 @@
 -- Portability : Good
 {-# LANGUAGE MagicHash #-}
 module Crypto.Cipher.Blowfish.Box
-    ( createKeySchedule
+    (   KeySchedule(..)
+    ,   createKeySchedule
+    ,   copyKeySchedule
     ) where
 
-import Crypto.Internal.WordArray (mutableArray32, mutableArray32FromAddrBE, MutableArray32)
-import Data.Word (Word32)
+import           Crypto.Internal.WordArray (MutableArray32,
+                                            mutableArray32FromAddrBE,
+                                            mutableArrayRead32,
+                                            mutableArrayWrite32)
 
-createKeySchedule :: IO MutableArray32
-createKeySchedule = mutableArray32 1042 keySchedule
+newtype KeySchedule = KeySchedule MutableArray32
 
-keySchedule :: [Word32]
-keySchedule = [
-    0x243f6a88, 0x85a308d3, 0x13198a2e, 0x03707344,
-    0xa4093822, 0x299f31d0, 0x082efa98, 0xec4e6c89, 0x452821e6, 0x38d01377,
-    0xbe5466cf, 0x34e90c6c, 0xc0ac29b7, 0xc97c50dd, 0x3f84d5b5, 0xb5470917,
-    0x9216d5d9, 0x8979fb1b, 0xd1310ba6, 0x98dfb5ac, 0x2ffd72db, 0xd01adfb7,
-    0xb8e1afed, 0x6a267e96, 0xba7c9045, 0xf12c7f99, 0x24a19947, 0xb3916cf7,
-    0x0801f2e2, 0x858efc16, 0x636920d8, 0x71574e69, 0xa458fea3, 0xf4933d7e,
-    0x0d95748f, 0x728eb658, 0x718bcd58, 0x82154aee, 0x7b54a41d, 0xc25a59b5,
-    0x9c30d539, 0x2af26013, 0xc5d1b023, 0x286085f0, 0xca417918, 0xb8db38ef,
-    0x8e79dcb0, 0x603a180e, 0x6c9e0e8b, 0xb01e8a3e, 0xd71577c1, 0xbd314b27,
-    0x78af2fda, 0x55605c60, 0xe65525f3, 0xaa55ab94, 0x57489862, 0x63e81440,
-    0x55ca396a, 0x2aab10b6, 0xb4cc5c34, 0x1141e8ce, 0xa15486af, 0x7c72e993,
-    0xb3ee1411, 0x636fbc2a, 0x2ba9c55d, 0x741831f6, 0xce5c3e16, 0x9b87931e,
-    0xafd6ba33, 0x6c24cf5c, 0x7a325381, 0x28958677, 0x3b8f4898, 0x6b4bb9af,
-    0xc4bfe81b, 0x66282193, 0x61d809cc, 0xfb21a991, 0x487cac60, 0x5dec8032,
-    0xef845d5d, 0xe98575b1, 0xdc262302, 0xeb651b88, 0x23893e81, 0xd396acc5,
-    0x0f6d6ff3, 0x83f44239, 0x2e0b4482, 0xa4842004, 0x69c8f04a, 0x9e1f9b5e,
-    0x21c66842, 0xf6e96c9a, 0x670c9c61, 0xabd388f0, 0x6a51a0d2, 0xd8542f68,
-    0x960fa728, 0xab5133a3, 0x6eef0b6c, 0x137a3be4, 0xba3bf050, 0x7efb2a98,
-    0xa1f1651d, 0x39af0176, 0x66ca593e, 0x82430e88, 0x8cee8619, 0x456f9fb4,
-    0x7d84a5c3, 0x3b8b5ebe, 0xe06f75d8, 0x85c12073, 0x401a449f, 0x56c16aa6,
-    0x4ed3aa62, 0x363f7706, 0x1bfedf72, 0x429b023d, 0x37d0d724, 0xd00a1248,
-    0xdb0fead3, 0x49f1c09b, 0x075372c9, 0x80991b7b, 0x25d479d8, 0xf6e8def7,
-    0xe3fe501a, 0xb6794c3b, 0x976ce0bd, 0x04c006ba, 0xc1a94fb6, 0x409f60c4,
-    0x5e5c9ec2, 0x196a2463, 0x68fb6faf, 0x3e6c53b5, 0x1339b2eb, 0x3b52ec6f,
-    0x6dfc511f, 0x9b30952c, 0xcc814544, 0xaf5ebd09, 0xbee3d004, 0xde334afd,
-    0x660f2807, 0x192e4bb3, 0xc0cba857, 0x45c8740f, 0xd20b5f39, 0xb9d3fbdb,
-    0x5579c0bd, 0x1a60320a, 0xd6a100c6, 0x402c7279, 0x679f25fe, 0xfb1fa3cc,
-    0x8ea5e9f8, 0xdb3222f8, 0x3c7516df, 0xfd616b15, 0x2f501ec8, 0xad0552ab,
-    0x323db5fa, 0xfd238760, 0x53317b48, 0x3e00df82, 0x9e5c57bb, 0xca6f8ca0,
-    0x1a87562e, 0xdf1769db, 0xd542a8f6, 0x287effc3, 0xac6732c6, 0x8c4f5573,
-    0x695b27b0, 0xbbca58c8, 0xe1ffa35d, 0xb8f011a0, 0x10fa3d98, 0xfd2183b8,
-    0x4afcb56c, 0x2dd1d35b, 0x9a53e479, 0xb6f84565, 0xd28e49bc, 0x4bfb9790,
-    0xe1ddf2da, 0xa4cb7e33, 0x62fb1341, 0xcee4c6e8, 0xef20cada, 0x36774c01,
-    0xd07e9efe, 0x2bf11fb4, 0x95dbda4d, 0xae909198, 0xeaad8e71, 0x6b93d5a0,
-    0xd08ed1d0, 0xafc725e0, 0x8e3c5b2f, 0x8e7594b7, 0x8ff6e2fb, 0xf2122b64,
-    0x8888b812, 0x900df01c, 0x4fad5ea0, 0x688fc31c, 0xd1cff191, 0xb3a8c1ad,
-    0x2f2f2218, 0xbe0e1777, 0xea752dfe, 0x8b021fa1, 0xe5a0cc0f, 0xb56f74e8,
-    0x18acf3d6, 0xce89e299, 0xb4a84fe0, 0xfd13e0b7, 0x7cc43b81, 0xd2ada8d9,
-    0x165fa266, 0x80957705, 0x93cc7314, 0x211a1477, 0xe6ad2065, 0x77b5fa86,
-    0xc75442f5, 0xfb9d35cf, 0xebcdaf0c, 0x7b3e89a0, 0xd6411bd3, 0xae1e7e49,
-    0x00250e2d, 0x2071b35e, 0x226800bb, 0x57b8e0af, 0x2464369b, 0xf009b91e,
-    0x5563911d, 0x59dfa6aa, 0x78c14389, 0xd95a537f, 0x207d5ba2, 0x02e5b9c5,
-    0x83260376, 0x6295cfa9, 0x11c81968, 0x4e734a41, 0xb3472dca, 0x7b14a94a,
-    0x1b510052, 0x9a532915, 0xd60f573f, 0xbc9bc6e4, 0x2b60a476, 0x81e67400,
-    0x08ba6fb5, 0x571be91f, 0xf296ec6b, 0x2a0dd915, 0xb6636521, 0xe7b9f9b6,
-    0xff34052e, 0xc5855664, 0x53b02d5d, 0xa99f8fa1, 0x08ba4799, 0x6e85076a,
-    0x4b7a70e9, 0xb5b32944, 0xdb75092e, 0xc4192623, 0xad6ea6b0, 0x49a7df7d,
-    0x9cee60b8, 0x8fedb266, 0xecaa8c71, 0x699a17ff, 0x5664526c, 0xc2b19ee1,
-    0x193602a5, 0x75094c29, 0xa0591340, 0xe4183a3e, 0x3f54989a, 0x5b429d65,
-    0x6b8fe4d6, 0x99f73fd6, 0xa1d29c07, 0xefe830f5, 0x4d2d38e6, 0xf0255dc1,
-    0x4cdd2086, 0x8470eb26, 0x6382e9c6, 0x021ecc5e, 0x09686b3f, 0x3ebaefc9,
-    0x3c971814, 0x6b6a70a1, 0x687f3584, 0x52a0e286, 0xb79c5305, 0xaa500737,
-    0x3e07841c, 0x7fdeae5c, 0x8e7d44ec, 0x5716f2b8, 0xb03ada37, 0xf0500c0d,
-    0xf01c1f04, 0x0200b3ff, 0xae0cf51a, 0x3cb574b2, 0x25837a58, 0xdc0921bd,
-    0xd19113f9, 0x7ca92ff6, 0x94324773, 0x22f54701, 0x3ae5e581, 0x37c2dadc,
-    0xc8b57634, 0x9af3dda7, 0xa9446146, 0x0fd0030e, 0xecc8c73e, 0xa4751e41,
-    0xe238cd99, 0x3bea0e2f, 0x3280bba1, 0x183eb331, 0x4e548b38, 0x4f6db908,
-    0x6f420d03, 0xf60a04bf, 0x2cb81290, 0x24977c79, 0x5679b072, 0xbcaf89af,
-    0xde9a771f, 0xd9930810, 0xb38bae12, 0xdccf3f2e, 0x5512721f, 0x2e6b7124,
-    0x501adde6, 0x9f84cd87, 0x7a584718, 0x7408da17, 0xbc9f9abc, 0xe94b7d8c,
-    0xec7aec3a, 0xdb851dfa, 0x63094366, 0xc464c3d2, 0xef1c1847, 0x3215d908,
-    0xdd433b37, 0x24c2ba16, 0x12a14d43, 0x2a65c451, 0x50940002, 0x133ae4dd,
-    0x71dff89e, 0x10314e55, 0x81ac77d6, 0x5f11199b, 0x043556f1, 0xd7a3c76b,
-    0x3c11183b, 0x5924a509, 0xf28fe6ed, 0x97f1fbfa, 0x9ebabf2c, 0x1e153c6e,
-    0x86e34570, 0xeae96fb1, 0x860e5e0a, 0x5a3e2ab3, 0x771fe71c, 0x4e3d06fa,
-    0x2965dcb9, 0x99e71d0f, 0x803e89d6, 0x5266c825, 0x2e4cc978, 0x9c10b36a,
-    0xc6150eba, 0x94e2ea78, 0xa5fc3c53, 0x1e0a2df4, 0xf2f74ea7, 0x361d2b3d,
-    0x1939260f, 0x19c27960, 0x5223a708, 0xf71312b6, 0xebadfe6e, 0xeac31f66,
-    0xe3bc4595, 0xa67bc883, 0xb17f37d1, 0x018cff28, 0xc332ddef, 0xbe6c5aa5,
-    0x65582185, 0x68ab9802, 0xeecea50f, 0xdb2f953b, 0x2aef7dad, 0x5b6e2f84,
-    0x1521b628, 0x29076170, 0xecdd4775, 0x619f1510, 0x13cca830, 0xeb61bd96,
-    0x0334fe1e, 0xaa0363cf, 0xb5735c90, 0x4c70a239, 0xd59e9e0b, 0xcbaade14,
-    0xeecc86bc, 0x60622ca7, 0x9cab5cab, 0xb2f3846e, 0x648b1eaf, 0x19bdf0ca,
-    0xa02369b9, 0x655abb50, 0x40685a32, 0x3c2ab4b3, 0x319ee9d5, 0xc021b8f7,
-    0x9b540b19, 0x875fa099, 0x95f7997e, 0x623d7da8, 0xf837889a, 0x97e32d77,
-    0x11ed935f, 0x16681281, 0x0e358829, 0xc7e61fd6, 0x96dedfa1, 0x7858ba99,
-    0x57f584a5, 0x1b227263, 0x9b83c3ff, 0x1ac24696, 0xcdb30aeb, 0x532e3054,
-    0x8fd948e4, 0x6dbc3128, 0x58ebf2ef, 0x34c6ffea, 0xfe28ed61, 0xee7c3c73,
-    0x5d4a14d9, 0xe864b7e3, 0x42105d14, 0x203e13e0, 0x45eee2b6, 0xa3aaabea,
-    0xdb6c4f15, 0xfacb4fd0, 0xc742f442, 0xef6abbb5, 0x654f3b1d, 0x41cd2105,
-    0xd81e799e, 0x86854dc7, 0xe44b476a, 0x3d816250, 0xcf62a1f2, 0x5b8d2646,
-    0xfc8883a0, 0xc1c7b6a3, 0x7f1524c3, 0x69cb7492, 0x47848a0b, 0x5692b285,
-    0x095bbf00, 0xad19489d, 0x1462b174, 0x23820e00, 0x58428d2a, 0x0c55f5ea,
-    0x1dadf43e, 0x233f7061, 0x3372f092, 0x8d937e41, 0xd65fecf1, 0x6c223bdb,
-    0x7cde3759, 0xcbee7460, 0x4085f2a7, 0xce77326e, 0xa6078084, 0x19f8509e,
-    0xe8efd855, 0x61d99735, 0xa969a7aa, 0xc50c06c2, 0x5a04abfc, 0x800bcadc,
-    0x9e447a2e, 0xc3453484, 0xfdd56705, 0x0e1e9ec9, 0xdb73dbd3, 0x105588cd,
-    0x675fda79, 0xe3674340, 0xc5c43465, 0x713e38d8, 0x3d28f89e, 0xf16dff20,
-    0x153e21e7, 0x8fb03d4a, 0xe6e39f2b, 0xdb83adf7, 0xe93d5a68, 0x948140f7,
-    0xf64c261c, 0x94692934, 0x411520f7, 0x7602d4f7, 0xbcf46b2e, 0xd4a20068,
-    0xd4082471, 0x3320f46a, 0x43b7d4b7, 0x500061af, 0x1e39f62e, 0x97244546,
-    0x14214f74, 0xbf8b8840, 0x4d95fc1d, 0x96b591af, 0x70f4ddd3, 0x66a02f45,
-    0xbfbc09ec, 0x03bd9785, 0x7fac6dd0, 0x31cb8504, 0x96eb27b3, 0x55fd3941,
-    0xda2547e6, 0xabca0a9a, 0x28507825, 0x530429f4, 0x0a2c86da, 0xe9b66dfb,
-    0x68dc1462, 0xd7486900, 0x680ec0a4, 0x27a18dee, 0x4f3ffea2, 0xe887ad8c,
-    0xb58ce006, 0x7af4d6b6, 0xaace1e7c, 0xd3375fec, 0xce78a399, 0x406b2a42,
-    0x20fe9e35, 0xd9f385b9, 0xee39d7ab, 0x3b124e8b, 0x1dc9faf7, 0x4b6d1856,
-    0x26a36631, 0xeae397b2, 0x3a6efa74, 0xdd5b4332, 0x6841e7f7, 0xca7820fb,
-    0xfb0af54e, 0xd8feb397, 0x454056ac, 0xba489527, 0x55533a3a, 0x20838d87,
-    0xfe6ba9b7, 0xd096954b, 0x55a867bc, 0xa1159a58, 0xcca92963, 0x99e1db33,
-    0xa62a4a56, 0x3f3125f9, 0x5ef47e1c, 0x9029317c, 0xfdf8e802, 0x04272f70,
-    0x80bb155c, 0x05282ce3, 0x95c11548, 0xe4c66d22, 0x48c1133f, 0xc70f86dc,
-    0x07f9c9ee, 0x41041f0f, 0x404779a4, 0x5d886e17, 0x325f51eb, 0xd59bc0d1,
-    0xf2bcc18f, 0x41113564, 0x257b7834, 0x602a9c60, 0xdff8e8a3, 0x1f636c1b,
-    0x0e12b4c2, 0x02e1329e, 0xaf664fd1, 0xcad18115, 0x6b2395e0, 0x333e92e1,
-    0x3b240b62, 0xeebeb922, 0x85b2a20e, 0xe6ba0d99, 0xde720c8c, 0x2da2f728,
-    0xd0127845, 0x95b794fd, 0x647d0862, 0xe7ccf5f0, 0x5449a36f, 0x877d48fa,
-    0xc39dfd27, 0xf33e8d1e, 0x0a476341, 0x992eff74, 0x3a6f6eab, 0xf4f8fd37,
-    0xa812dc60, 0xa1ebddf8, 0x991be14c, 0xdb6e6b0d, 0xc67b5510, 0x6d672c37,
-    0x2765d43b, 0xdcd0e804, 0xf1290dc7, 0xcc00ffa3, 0xb5390f92, 0x690fed0b,
-    0x667b9ffb, 0xcedb7d9c, 0xa091cf0b, 0xd9155ea3, 0xbb132f88, 0x515bad24,
-    0x7b9479bf, 0x763bd6eb, 0x37392eb3, 0xcc115979, 0x8026e297, 0xf42e312d,
-    0x6842ada7, 0xc66a2b3b, 0x12754ccc, 0x782ef11c, 0x6a124237, 0xb79251e7,
-    0x06a1bbe6, 0x4bfb6350, 0x1a6b1018, 0x11caedfa, 0x3d25bdd8, 0xe2e1c3c9,
-    0x44421659, 0x0a121386, 0xd90cec6e, 0xd5abea2a, 0x64af674e, 0xda86a85f,
-    0xbebfe988, 0x64e4c3fe, 0x9dbc8057, 0xf0f7c086, 0x60787bf8, 0x6003604d,
-    0xd1fd8346, 0xf6381fb0, 0x7745ae04, 0xd736fccc, 0x83426b33, 0xf01eab71,
-    0xb0804187, 0x3c005e5f, 0x77a057be, 0xbde8ae24, 0x55464299, 0xbf582e61,
-    0x4e58f48f, 0xf2ddfda2, 0xf474ef38, 0x8789bdc2, 0x5366f9c3, 0xc8b38e74,
-    0xb475f255, 0x46fcd9b9, 0x7aeb2661, 0x8b1ddf84, 0x846a0e79, 0x915f95e2,
-    0x466e598e, 0x20b45770, 0x8cd55591, 0xc902de4c, 0xb90bace1, 0xbb8205d0,
-    0x11a86248, 0x7574a99e, 0xb77f19b6, 0xe0a9dc09, 0x662d09a1, 0xc4324633,
-    0xe85a1f02, 0x09f0be8c, 0x4a99a025, 0x1d6efe10, 0x1ab93d1d, 0x0ba5a4df,
-    0xa186f20f, 0x2868f169, 0xdcb7da83, 0x573906fe, 0xa1e2ce9b, 0x4fcd7f52,
-    0x50115e01, 0xa70683fa, 0xa002b5c4, 0x0de6d027, 0x9af88c27, 0x773f8641,
-    0xc3604c06, 0x61a806b5, 0xf0177a28, 0xc0f586e0, 0x006058aa, 0x30dc7d62,
-    0x11e69ed7, 0x2338ea63, 0x53c2dd94, 0xc2c21634, 0xbbcbee56, 0x90bcb6de,
-    0xebfc7da1, 0xce591d76, 0x6f05e409, 0x4b7c0188, 0x39720a3d, 0x7c927c24,
-    0x86e3725f, 0x724d9db9, 0x1ac15bb4, 0xd39eb8fc, 0xed545578, 0x08fca5b5,
-    0xd83d7cd3, 0x4dad0fc4, 0x1e50ef5e, 0xb161e6f8, 0xa28514d9, 0x6c51133c,
-    0x6fd5c7e7, 0x56e14ec4, 0x362abfce, 0xddc6c837, 0xd79a3234, 0x92638212,
-    0x670efa8e, 0x406000e0, 0x3a39ce37, 0xd3faf5cf, 0xabc27737, 0x5ac52d1b,
-    0x5cb0679e, 0x4fa33742, 0xd3822740, 0x99bc9bbe, 0xd5118e9d, 0xbf0f7315,
-    0xd62d1c7e, 0xc700c47b, 0xb78c1b6b, 0x21a19045, 0xb26eb1be, 0x6a366eb4,
-    0x5748ab2f, 0xbc946e79, 0xc6a376d2, 0x6549c2c8, 0x530ff8ee, 0x468dde7d,
-    0xd5730a1d, 0x4cd04dc6, 0x2939bbdb, 0xa9ba4650, 0xac9526e8, 0xbe5ee304,
-    0xa1fad5f0, 0x6a2d519a, 0x63ef8ce2, 0x9a86ee22, 0xc089c2b8, 0x43242ef6,
-    0xa51e03aa, 0x9cf2d0a4, 0x83c061ba, 0x9be96a4d, 0x8fe51550, 0xba645bd6,
-    0x2826a2f9, 0xa73a3ae1, 0x4ba99586, 0xef5562e9, 0xc72fefd3, 0xf752f7da,
-    0x3f046f69, 0x77fa0a59, 0x80e4a915, 0x87b08601, 0x9b09e6ad, 0x3b3ee593,
-    0xe990fd5a, 0x9e34d797, 0x2cf0b7d9, 0x022b8b51, 0x96d5ac3a, 0x017da67d,
-    0xd1cf3ed6, 0x7c7d2d28, 0x1f9f25cf, 0xadf2b89b, 0x5ad6b472, 0x5a88f54c,
-    0xe029ac71, 0xe019a5e6, 0x47b0acfd, 0xed93fa9b, 0xe8d3c48d, 0x283b57cc,
-    0xf8d56629, 0x79132e28, 0x785f0191, 0xed756055, 0xf7960e44, 0xe3d35e8c,
-    0x15056dd4, 0x88f46dba, 0x03a16125, 0x0564f0bd, 0xc3eb9e15, 0x3c9057a2,
-    0x97271aec, 0xa93a072a, 0x1b3f6d9b, 0x1e6321f5, 0xf59c66fb, 0x26dcf319,
-    0x7533d928, 0xb155fdf5, 0x03563482, 0x8aba3cbb, 0x28517711, 0xc20ad9f8,
-    0xabcc5167, 0xccad925f, 0x4de81751, 0x3830dc8e, 0x379d5862, 0x9320f991,
-    0xea7a90c2, 0xfb3e7bce, 0x5121ce64, 0x774fbe32, 0xa8b6e37e, 0xc3293d46,
-    0x48de5369, 0x6413e680, 0xa2ae0810, 0xdd6db224, 0x69852dfd, 0x09072166,
-    0xb39a460a, 0x6445c0dd, 0x586cdecf, 0x1c20c8ae, 0x5bbef7dd, 0x1b588d40,
-    0xccd2017f, 0x6bb4e3bb, 0xdda26a7e, 0x3a59ff45, 0x3e350a44, 0xbcb4cdd5,
-    0x72eacea8, 0xfa6484bb, 0x8d6612ae, 0xbf3c6f47, 0xd29be463, 0x542f5d9e,
-    0xaec2771b, 0xf64e6370, 0x740e0d8d, 0xe75b1357, 0xf8721671, 0xaf537d5d,
-    0x4040cb08, 0x4eb4e2cc, 0x34d2466a, 0x0115af84, 0xe1b00428, 0x95983a1d,
-    0x06b89fb4, 0xce6ea048, 0x6f3f3b82, 0x3520ab82, 0x011a1d4b, 0x277227f8,
-    0x611560b1, 0xe7933fdc, 0xbb3a792b, 0x344525bd, 0xa08839e1, 0x51ce794b,
-    0x2f32c9b7, 0xa01fbac9, 0xe01cc87e, 0xbcc7d1f6, 0xcf0111c3, 0xa1e8aac7,
-    0x1a908749, 0xd44fbd9a, 0xd0dadecb, 0xd50ada38, 0x0339c32a, 0xc6913667,
-    0x8df9317c, 0xe0b12b4f, 0xf79e59b7, 0x43f5bb3a, 0xf2d519ff, 0x27d9459c,
-    0xbf97222c, 0x15e6fc2a, 0x0f91fc71, 0x9b941525, 0xfae59361, 0xceb69ceb,
-    0xc2a86459, 0x12baa8d1, 0xb6c1075e, 0xe3056a0c, 0x10d25065, 0xcb03a442,
-    0xe0ec6e0e, 0x1698db3b, 0x4c98a0be, 0x3278e964, 0x9f1f9532, 0xe0d392df,
-    0xd3a0342b, 0x8971f21e, 0x1b0a7441, 0x4ba3348c, 0xc5be7120, 0xc37632d8,
-    0xdf359f8d, 0x9b992f2e, 0xe60b6f47, 0x0fe3f11d, 0xe54cda54, 0x1edad891,
-    0xce6279cf, 0xcd3e7e6f, 0x1618b166, 0xfd2c1d05, 0x848fd2c5, 0xf6fb2299,
-    0xf523f357, 0xa6327623, 0x93a83531, 0x56cccd02, 0xacf08162, 0x5a75ebb5,
-    0x6e163697, 0x88d273cc, 0xde966292, 0x81b949d0, 0x4c50901b, 0x71c65614,
-    0xe6c6c7bd, 0x327a140a, 0x45e1d006, 0xc3f27b9a, 0xc9aa53fd, 0x62a80f00,
-    0xbb25bfe2, 0x35bdd2f6, 0x71126905, 0xb2040222, 0xb6cbcf7c, 0xcd769c2b,
-    0x53113ec0, 0x1640e3d3, 0x38abbd60, 0x2547adf0, 0xba38209c, 0xf746ce76,
-    0x77afa1c5, 0x20756060, 0x85cbfe4e, 0x8ae88dd8, 0x7aaaf9b0, 0x4cf9aa7e,
-    0x1948c25c, 0x02fb8a8c, 0x01c36ae4, 0xd6ebe1f9, 0x90d4f869, 0xa65cdea0,
-    0x3f09252d, 0xc208e69f, 0xb74e6132, 0xce77e25b, 0x578fdfe3, 0x3ac372e6
-    ]
+-- | Copy the state of one key schedule into the other.
+--   The first parameter is the destination and the second the source.
+copyKeySchedule :: KeySchedule -> KeySchedule -> IO ()
+copyKeySchedule (KeySchedule dst) (KeySchedule src) = loop 0
+  where
+    loop 1042 = return ()
+    loop i    = do
+        w32 <-mutableArrayRead32 src i
+        mutableArrayWrite32 dst i w32
+        loop (i + 1)
 
 -- | Create a key schedule mutable array of the pbox followed by
 -- all the sboxes.
-createKeyScheduleOrig :: IO MutableArray32
-createKeyScheduleOrig = mutableArray32FromAddrBE 1042 "\
+createKeySchedule :: IO KeySchedule
+createKeySchedule = KeySchedule `fmap` mutableArray32FromAddrBE 1042 "\
     \\x24\x3f\x6a\x88\x85\xa3\x08\xd3\x13\x19\x8a\x2e\x03\x70\x73\x44\
     \\xa4\x09\x38\x22\x29\x9f\x31\xd0\x08\x2e\xfa\x98\xec\x4e\x6c\x89\
     \\x45\x28\x21\xe6\x38\xd0\x13\x77\xbe\x54\x66\xcf\x34\xe9\x0c\x6c\

Crypto/Cipher/Blowfish/Primitive.hs

@@ -5,195 +5,254 @@
 -- Portability : Good
 
 -- Rewritten by Vincent Hanquez (c) 2015
+--              Lars Petersen (c) 2018
 --
 -- Original code:
 --      Crypto.Cipher.Blowfish.Primitive, copyright (c) 2012 Stijn van Drongelen
 --      based on: BlowfishAux.hs (C) 2002 HardCore SoftWare, Doug Hoyte
 --           (as found in Crypto-4.2.4)
-
+{-# LANGUAGE BangPatterns #-}
 module Crypto.Cipher.Blowfish.Primitive
     ( Context
     , initBlowfish
     , encrypt
     , decrypt
-    , eksBlowfish
+    , KeySchedule
+    , createKeySchedule
+    , freezeKeySchedule
+    , expandKey
+    , expandKeyWithSalt
+    , cipherBlockMutable
     ) where
 
-import           Control.Monad (when)
+import           Control.Monad              (when)
 import           Data.Bits
 import           Data.Memory.Endian
 import           Data.Word
 
+import           Crypto.Cipher.Blowfish.Box
 import           Crypto.Error
+import           Crypto.Internal.ByteArray  (ByteArray, ByteArrayAccess)
+import qualified Crypto.Internal.ByteArray  as B
 import           Crypto.Internal.Compat
 import           Crypto.Internal.Imports
-import           Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray, Bytes)
-import qualified Crypto.Internal.ByteArray as B
-import           Crypto.Internal.Words
 import           Crypto.Internal.WordArray
-import           Crypto.Cipher.Blowfish.Box
 
--- | variable keyed blowfish state
-data Context = BF (Int -> Word32) -- p
-                  (Int -> Word32) -- sbox0
-                  (Int -> Word32) -- sbox1
-                  (Int -> Word32) -- sbox2
-                  (Int -> Word32) -- sbox2
+newtype Context = Context Array32
 
 instance NFData Context where
-    rnf (BF p a b c d) = p `seq` a `seq` b `seq` c `seq` d `seq` ()
-
--- | Encrypt blocks
---
--- Input need to be a multiple of 8 bytes
-encrypt :: ByteArray ba => Context -> ba -> ba
-encrypt = cipher
-
--- | Decrypt blocks
---
--- Input need to be a multiple of 8 bytes
-decrypt :: ByteArray ba => Context -> ba -> ba
-decrypt = cipher . decryptContext
-
-decryptContext :: Context -> Context
-decryptContext (BF p s0 s1 s2 s3) = BF (\i -> p (17-i)) s0 s1 s2 s3
-
-cipher :: ByteArray ba => Context -> ba -> ba
-cipher ctx b
-    | B.length b == 0         = B.empty
-    | B.length b `mod` 8 /= 0 = error "invalid data length"
-    | otherwise               = B.mapAsWord64 (coreCrypto ctx) b
+    rnf a = a `seq` ()
 
 -- | Initialize a new Blowfish context from a key.
 --
 -- key needs to be between 0 and 448 bits.
 initBlowfish :: ByteArrayAccess key => key -> CryptoFailable Context
 initBlowfish key
-    | len > (448 `div` 8) = CryptoFailed CryptoError_KeySizeInvalid
-    | otherwise           = CryptoPassed $ makeKeySchedule key (Nothing :: Maybe (Bytes, Int))
-  where len = B.length key
+    | B.length key > (448 `div` 8) = CryptoFailed CryptoError_KeySizeInvalid
+    | otherwise                    = CryptoPassed $ unsafeDoIO $ do
+        ks <- createKeySchedule
+        expandKey ks key
+        freezeKeySchedule ks
 
--- | The BCrypt "expensive key schedule" version of blowfish.
+-- | Get an immutable Blowfish context by freezing a mutable key schedule.
+freezeKeySchedule :: KeySchedule -> IO Context
+freezeKeySchedule (KeySchedule ma) = Context `fmap` mutableArray32Freeze ma
+
+expandKey :: (ByteArrayAccess key) => KeySchedule -> key -> IO ()
+expandKey ks@(KeySchedule ma) key = do
+    when (B.length key > 0) $ iterKeyStream key 0 0 $ \i l r a0 a1 cont-> do
+        mutableArrayWriteXor32 ma i l
+        mutableArrayWriteXor32 ma (i + 1) r
+        when (i + 2 < 18) (cont a0 a1)
+    loop 0 0 0
+    where
+        loop i l r = do
+            n <- cipherBlockMutable ks (fromIntegral l `shiftL` 32 .|. fromIntegral r)
+            let nl = fromIntegral (n `shiftR` 32)
+                nr = fromIntegral (n .&. 0xffffffff)
+            mutableArrayWrite32 ma i nl
+            mutableArrayWrite32 ma (i + 1) nr
+            when (i < 18 + 1024) (loop (i + 2) nl nr)
+
+expandKeyWithSalt :: (ByteArrayAccess key, ByteArrayAccess salt)
+    => KeySchedule
+    -> key
+    -> salt
+    -> IO ()
+expandKeyWithSalt ks key salt
+    | B.length salt == 16 = expandKeyWithSalt128 ks key (fromBE $ B.toW64BE salt 0) (fromBE $ B.toW64BE salt 8)
+    | otherwise           = expandKeyWithSaltAny ks key salt
+
+expandKeyWithSaltAny :: (ByteArrayAccess key, ByteArrayAccess salt)
+    => KeySchedule         -- ^ The key schedule
+    -> key                 -- ^ The key
+    -> salt                -- ^ The salt
+    -> IO ()
+expandKeyWithSaltAny ks@(KeySchedule ma) key salt = do
+    when (B.length key > 0) $ iterKeyStream key 0 0 $ \i l r a0 a1 cont-> do
+        mutableArrayWriteXor32 ma i l
+        mutableArrayWriteXor32 ma (i + 1) r
+        when (i + 2 < 18) (cont a0 a1)
+    -- Go through the entire key schedule overwriting the P-Array and S-Boxes
+    when (B.length salt > 0) $ iterKeyStream salt 0 0 $ \i l r a0 a1 cont-> do
+        let l' = xor l a0
+        let r' = xor r a1
+        n <- cipherBlockMutable ks (fromIntegral l' `shiftL` 32 .|. fromIntegral r')
+        let nl = fromIntegral (n `shiftR` 32)
+            nr = fromIntegral (n .&. 0xffffffff)
+        mutableArrayWrite32 ma i nl
+        mutableArrayWrite32 ma (i + 1) nr
+        when (i + 2 < 18 + 1024) (cont nl nr)
+
+expandKeyWithSalt128 :: ByteArrayAccess ba
+    => KeySchedule         -- ^ The key schedule
+    -> ba                  -- ^ The key
+    -> Word64              -- ^ First word of the salt
+    -> Word64              -- ^ Second word of the salt
+    -> IO ()
+expandKeyWithSalt128 ks@(KeySchedule ma) key salt1 salt2 = do
+    when (B.length key > 0) $ iterKeyStream key 0 0 $ \i l r a0 a1 cont-> do
+        mutableArrayWriteXor32 ma i l
+        mutableArrayWriteXor32 ma (i + 1) r
+        when (i + 2 < 18) (cont a0 a1)
+    -- Go through the entire key schedule overwriting the P-Array and S-Boxes
+    loop 0 salt1 salt1 salt2
+    where
+        loop i input slt1 slt2
+            | i == 1042   = return ()
+            | otherwise = do
+                n <- cipherBlockMutable ks input
+                let nl = fromIntegral (n `shiftR` 32)
+                    nr = fromIntegral (n .&. 0xffffffff)
+                mutableArrayWrite32 ma i     nl
+                mutableArrayWrite32 ma (i+1) nr
+                loop (i+2) (n `xor` slt2) slt2 slt1
+
+-- | Encrypt blocks
 --
--- Salt must be 128 bits
--- Cost must be between 4 and 31 inclusive
--- See <https://www.usenix.org/conference/1999-usenix-annual-technical-conference/future-adaptable-password-scheme>
-eksBlowfish :: (ByteArrayAccess salt, ByteArrayAccess password) => Int -> salt -> password -> Context
-eksBlowfish cost salt key = makeKeySchedule key (Just (salt, cost))
+-- Input need to be a multiple of 8 bytes
+encrypt :: ByteArray ba => Context -> ba -> ba
+encrypt ctx ba
+    | B.length ba == 0         = B.empty
+    | B.length ba `mod` 8 /= 0 = error "invalid data length"
+    | otherwise                = B.mapAsWord64 (cipherBlock ctx False) ba
 
-coreCrypto :: Context -> Word64 -> Word64
-coreCrypto (BF p s0 s1 s2 s3) input = doRound input 0
-  where
-    -- transform the input over 16 rounds
+-- | Decrypt blocks
+--
+-- Input need to be a multiple of 8 bytes
+decrypt :: ByteArray ba => Context -> ba -> ba
+decrypt ctx ba
+    | B.length ba == 0         = B.empty
+    | B.length ba `mod` 8 /= 0 = error "invalid data length"
+    | otherwise                = B.mapAsWord64 (cipherBlock ctx True) ba
+
+-- | Encrypt or decrypt a single block of 64 bits.
+--
+-- The inverse argument decides whether to encrypt or decrypt.
+cipherBlock :: Context -> Bool -> Word64 -> Word64
+cipherBlock (Context ar) inverse input = doRound input 0
+    where
+    -- | Transform the input over 16 rounds
     doRound :: Word64 -> Int -> Word64
-    doRound i roundIndex
+    doRound !i roundIndex
         | roundIndex == 16 =
             let final = (fromIntegral (p 16) `shiftL` 32) .|. fromIntegral (p 17)
              in rotateL (i `xor` final) 32
         | otherwise     =
-            let newr = fromIntegral (i `shiftR` 32) `xor` (p roundIndex)
-                newi = ((i `shiftL` 32) `xor` (f newr)) .|. (fromIntegral newr)
+            let newr = fromIntegral (i `shiftR` 32) `xor` p roundIndex
+                newi = ((i `shiftL` 32) `xor` f newr) .|. fromIntegral newr
              in doRound newi (roundIndex+1)
+
+    -- | The Blowfish Feistel function F
     f   :: Word32 -> Word64
-    f t = let a = s0 (fromIntegral $ (t `shiftR` 24) .&. 0xff)
-              b = s1 (fromIntegral $ (t `shiftR` 16) .&. 0xff)
-              c = s2 (fromIntegral $ (t `shiftR` 8) .&. 0xff)
-              d = s3 (fromIntegral $ t .&. 0xff)
+    f t = let a = s0 (0xff .&. (t `shiftR` 24))
+              b = s1 (0xff .&. (t `shiftR` 16))
+              c = s2 (0xff .&. (t `shiftR` 8))
+              d = s3 (0xff .&.  t)
            in fromIntegral (((a + b) `xor` c) + d) `shiftL` 32
 
+    -- | S-Box arrays, each containing 256 32-bit words
+    --   The first 18 words contain the P-Array of subkeys
+    s0, s1, s2, s3 :: Word32 -> Word32
+    s0 i            = arrayRead32 ar (fromIntegral i + 18)
+    s1 i            = arrayRead32 ar (fromIntegral i + 274)
+    s2 i            = arrayRead32 ar (fromIntegral i + 530)
+    s3 i            = arrayRead32 ar (fromIntegral i + 786)
+    p              :: Int -> Word32
+    p i | inverse   = arrayRead32 ar (17 - i)
+        | otherwise = arrayRead32 ar i
 
--- | Create a key schedule for either plain Blowfish or the BCrypt "EKS" version
--- For the expensive version, the salt and cost factor are supplied. Salt must be
--- a 128-bit byte array.
---
--- The standard case is just a single key expansion with the salt set to zero.
-makeKeySchedule :: (ByteArrayAccess key, ByteArrayAccess salt) => key-> Maybe (salt, Int) -> Context
-makeKeySchedule keyBytes saltCost =
-    let v = unsafeDoIO $ do
-              mv <- createKeySchedule
-              case saltCost of
-                  -- Standard blowfish
-                  Nothing -> expandKey mv 0 0 keyBytes
-                  -- The expensive case
-                  Just (s, cost)  -> do
-                      let (salt1, salt2) = splitSalt s
-                      expandKey mv salt1 salt2 keyBytes
-                      forM_ [1..2^cost :: Int] $ \_ -> do
-                          expandKey mv 0 0 keyBytes
-                          expandKey mv 0 0 s
-              mutableArray32Freeze mv
-     in BF (\i -> arrayRead32 v i)
-           (\i -> arrayRead32 v (s0+i))
-           (\i -> arrayRead32 v (s1+i))
-           (\i -> arrayRead32 v (s2+i))
-           (\i -> arrayRead32 v (s3+i))
-  where
-        splitSalt s = (fromBE (B.toW64BE s 0), fromBE (B.toW64BE s 8))
+-- | Blowfish encrypt a Word using the current state of the key schedule
+cipherBlockMutable :: KeySchedule -> Word64 -> IO Word64
+cipherBlockMutable (KeySchedule ma) input = doRound input 0
+    where
+    -- | Transform the input over 16 rounds
+    doRound !i roundIndex
+        | roundIndex == 16 = do
+            pVal1 <- mutableArrayRead32 ma 16
+            pVal2 <- mutableArrayRead32 ma 17
+            let final = (fromIntegral pVal1 `shiftL` 32) .|. fromIntegral pVal2
+            return $ rotateL (i `xor` final) 32
+        | otherwise     = do
+            pVal <- mutableArrayRead32 ma roundIndex
+            let newr = fromIntegral (i `shiftR` 32) `xor` pVal
+            newr' <- f newr
+            let newi = ((i `shiftL` 32) `xor` newr') .|. fromIntegral newr
+            doRound newi (roundIndex+1)
 
-        -- Indices of the S-Box arrays, each containing 256 32-bit words
-        -- The first 18 words contain the P-Array of subkeys
-        s0 = 18
-        s1 = 274
-        s2 = 530
-        s3 = 786
+    -- | The Blowfish Feistel function F
+    f   :: Word32 -> IO Word64
+    f t = do
+        a <- s0 (0xff .&. (t `shiftR` 24))
+        b <- s1 (0xff .&. (t `shiftR` 16))
+        c <- s2 (0xff .&. (t `shiftR` 8))
+        d <- s3 (0xff .&.  t)
+        return (fromIntegral (((a + b) `xor` c) + d) `shiftL` 32)
 
-expandKey :: ByteArrayAccess ba
-          => MutableArray32      -- ^ The key schedule
-          -> Word64              -- ^ First word of the salt
-          -> Word64              -- ^ Second word of the salt
-          -> ba                  -- ^ The key
-          -> IO ()
-expandKey mv salt1 salt2 key = do
-    when (len > 0) $ forM_ [0..17] $ \i -> do
-        let a = B.index key ((i * 4 + 0) `mod` len)
-            b = B.index key ((i * 4 + 1) `mod` len)
-            c = B.index key ((i * 4 + 2) `mod` len)
-            d = B.index key ((i * 4 + 3) `mod` len)
-            k = (fromIntegral a `shiftL` 24) .|.
-                (fromIntegral b `shiftL` 16) .|.
-                (fromIntegral c `shiftL`  8) .|.
-                (fromIntegral d)
-        mutableArrayWriteXor32 mv i k
-    prepare mv
-    return ()
-  where
-        len = B.length key
+    -- | S-Box arrays, each containing 256 32-bit words
+    --   The first 18 words contain the P-Array of subkeys
+    s0, s1, s2, s3 :: Word32 -> IO Word32
+    s0 i = mutableArrayRead32 ma (fromIntegral i + 18)
+    s1 i = mutableArrayRead32 ma (fromIntegral i + 274)
+    s2 i = mutableArrayRead32 ma (fromIntegral i + 530)
+    s3 i = mutableArrayRead32 ma (fromIntegral i + 786)
 
-        -- | Go through the entire key schedule overwriting the P-Array and S-Boxes
-        prepare mctx = loop 0 salt1 salt1 salt2
-          where loop i input slt1 slt2
-                  | i == 1042   = return ()
-                  | otherwise = do
-                      ninput <- coreCryptoMutable input
-                      let (nl, nr) = w64to32 ninput
-                      mutableArrayWrite32 mctx i     nl
-                      mutableArrayWrite32 mctx (i+1) nr
-                      loop (i+2) (ninput `xor` slt2) slt2 slt1
-
-                -- | Blowfish encrypt a Word using the current state of the key schedule
-                coreCryptoMutable :: Word64 -> IO Word64
-                coreCryptoMutable input = doRound input 0
-                  where doRound i roundIndex
-                          | roundIndex == 16 = do
-                              pVal1 <- mutableArrayRead32 mctx 16
-                              pVal2 <- mutableArrayRead32 mctx 17
-                              let final = (fromIntegral pVal1 `shiftL` 32) .|. fromIntegral pVal2
-                              return $ rotateL (i `xor` final) 32
-                          | otherwise     = do
-                              pVal <- mutableArrayRead32 mctx roundIndex
-                              let newr = fromIntegral (i `shiftR` 32) `xor` pVal
-                              newr' <- f newr
-                              let newi = ((i `shiftL` 32) `xor` newr') .|. (fromIntegral newr)
-                              doRound newi (roundIndex+1)
-
-                -- The Blowfish Feistel function F
-                f   :: Word32 -> IO Word64
-                f t = do a <- mutableArrayRead32 mctx (s0 + fromIntegral ((t `shiftR` 24) .&. 0xff))
-                         b <- mutableArrayRead32 mctx (s1 + fromIntegral ((t `shiftR` 16) .&. 0xff))
-                         c <- mutableArrayRead32 mctx (s2 + fromIntegral ((t `shiftR` 8) .&. 0xff))
-                         d <- mutableArrayRead32 mctx (s3 + fromIntegral (t .&. 0xff))
-                         return (fromIntegral (((a + b) `xor` c) + d) `shiftL` 32)
-                  where s0 = 18
-                        s1 = 274
-                        s2 = 530
-                        s3 = 786
+iterKeyStream :: (ByteArrayAccess x)
+    => x
+    -> Word32
+    -> Word32
+    -> (Int -> Word32 -> Word32 -> Word32 -> Word32 -> (Word32 -> Word32 -> IO ()) -> IO ())
+    -> IO ()
+iterKeyStream x a0 a1 g = f 0 0 a0 a1
+    where
+        len          = B.length x
+        -- Avoiding the modulo operation when interating over the ring
+        -- buffer is assumed to be more efficient here. All other
+        -- implementations do this, too. The branch prediction shall prefer
+        -- the branch with the increment.
+        n j          = if j + 1 >= len then 0 else j + 1
+        f i j0 b0 b1 = g i l r b0 b1 (f (i + 2) j8)
+            where
+                j1 = n j0
+                j2 = n j1
+                j3 = n j2
+                j4 = n j3
+                j5 = n j4
+                j6 = n j5
+                j7 = n j6
+                j8 = n j7
+                x0 = fromIntegral (B.index x j0)
+                x1 = fromIntegral (B.index x j1)
+                x2 = fromIntegral (B.index x j2)
+                x3 = fromIntegral (B.index x j3)
+                x4 = fromIntegral (B.index x j4)
+                x5 = fromIntegral (B.index x j5)
+                x6 = fromIntegral (B.index x j6)
+                x7 = fromIntegral (B.index x j7)
+                l  = shiftL x0 24 .|. shiftL x1 16 .|. shiftL x2 8 .|. x3
+                r  = shiftL x4 24 .|. shiftL x5 16 .|. shiftL x6 8 .|. x7
+{-# INLINE iterKeyStream #-}
+-- Benchmarking shows that GHC considers this function too big to inline
+-- although forcing inlining causes an actual improvement.
+-- It is assumed that all function calls (especially the continuation)
+-- collapse into a tight loop after inlining.

Crypto/Cipher/CAST5.hs

@@ -0,0 +1,43 @@
+-- |
+-- Module      : Crypto.Cipher.CAST5
+-- License     : BSD-style
+-- Maintainer  : Olivier Chéron <olivier.cheron@gmail.com>
+-- Stability   : stable
+-- Portability : good
+--
+module Crypto.Cipher.CAST5
+    ( CAST5
+    ) where
+
+import           Crypto.Error
+import           Crypto.Cipher.Types
+import           Crypto.Cipher.CAST5.Primitive
+import           Crypto.Internal.ByteArray (ByteArrayAccess)
+import qualified Crypto.Internal.ByteArray as B
+
+-- | CAST5 block cipher (also known as CAST-128).  Key is between
+-- 40 and 128 bits.
+newtype CAST5 = CAST5 Key
+
+instance Cipher CAST5 where
+    cipherName    _ = "CAST5"
+    cipherKeySize _ = KeySizeRange 5 16
+    cipherInit      = initCAST5
+
+instance BlockCipher CAST5 where
+    blockSize _ = 8
+    ecbEncrypt (CAST5 k) = B.mapAsWord64 (encrypt k)
+    ecbDecrypt (CAST5 k) = B.mapAsWord64 (decrypt k)
+
+initCAST5 :: ByteArrayAccess key => key -> CryptoFailable CAST5
+initCAST5 bs
+    | len <   5 = CryptoFailed CryptoError_KeySizeInvalid
+    | len <  16 = CryptoPassed (CAST5 $ buildKey short padded)
+    | len == 16 = CryptoPassed (CAST5 $ buildKey False bs)
+    | otherwise = CryptoFailed CryptoError_KeySizeInvalid
+  where
+    len   = B.length bs
+    short = len <= 10
+
+    padded :: B.Bytes
+    padded = B.convert bs `B.append` B.replicate (16 - len) 0

Crypto/Cipher/CAST5/Primitive.hs

@@ -0,0 +1,573 @@
+{-# LANGUAGE MagicHash #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Crypto.Cipher.CAST5.Primitive
+-- License     :  BSD-style
+--
+-- Haskell implementation of the CAST-128 Encryption Algorithm
+--
+-----------------------------------------------------------------------------
+
+
+module Crypto.Cipher.CAST5.Primitive
+    ( encrypt
+    , decrypt
+    , Key()
+    , buildKey
+    ) where
+
+import Control.Monad (void, (>=>))
+
+import Data.Bits
+import Data.Memory.Endian
+import Data.Word
+
+import           Crypto.Internal.ByteArray (ByteArrayAccess)
+import qualified Crypto.Internal.ByteArray as B
+import           Crypto.Internal.WordArray
+
+
+-- Data Types
+
+data P = P {-# UNPACK #-} !Word32 -- left word
+           {-# UNPACK #-} !Word32 -- right word
+
+data Q = Q {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32
+           {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32
+
+-- | All subkeys for 12 or 16 rounds
+data Key = K12 {-# UNPACK #-} !Array32 -- [ km1, kr1, km2, kr2, ..., km12, kr12 ]
+         | K16 {-# UNPACK #-} !Array32 -- [ km1, kr1, km2, kr2, ..., km16, kr16 ]
+
+
+-- Big-endian Transformations
+
+decomp64 :: Word64 -> P
+decomp64 x = P (fromIntegral (x `shiftR` 32)) (fromIntegral x)
+
+comp64 :: P -> Word64
+comp64 (P l r) = (fromIntegral l `shiftL` 32) .|. fromIntegral r
+
+decomp32 :: Word32 -> (Word8, Word8, Word8, Word8)
+decomp32 x =
+    let a = fromIntegral (x `shiftR` 24)
+        b = fromIntegral (x `shiftR` 16)
+        c = fromIntegral (x `shiftR`  8)
+        d = fromIntegral x
+    in (a, b, c, d)
+
+
+-- Encryption
+
+-- | Encrypts a block using the specified key
+encrypt :: Key -> Word64 -> Word64
+encrypt k = comp64 . cast_enc k . decomp64
+
+cast_enc :: Key -> P -> P
+cast_enc (K12 a) (P l0 r0) = P r12 r11
+  where
+    r1  = type1 a 0  l0  r0
+    r2  = type2 a 2  r0  r1
+    r3  = type3 a 4  r1  r2
+    r4  = type1 a 6  r2  r3
+    r5  = type2 a 8  r3  r4
+    r6  = type3 a 10 r4  r5
+    r7  = type1 a 12 r5  r6
+    r8  = type2 a 14 r6  r7
+    r9  = type3 a 16 r7  r8
+    r10 = type1 a 18 r8  r9
+    r11 = type2 a 20 r9  r10
+    r12 = type3 a 22 r10 r11
+
+cast_enc (K16 a) p = P r16 r15
+  where
+    P r12 r11 = cast_enc (K12 a) p
+
+    r13 = type1 a 24 r11 r12
+    r14 = type2 a 26 r12 r13
+    r15 = type3 a 28 r13 r14
+    r16 = type1 a 30 r14 r15
+
+-- Decryption
+
+-- | Decrypts a block using the specified key
+decrypt :: Key -> Word64 -> Word64
+decrypt k = comp64 . cast_dec k . decomp64
+
+cast_dec :: Key -> P -> P
+cast_dec (K12 a) (P r12 r11) = P l0 r0
+  where
+    r10 = type3 a 22 r12 r11
+    r9  = type2 a 20 r11 r10
+    r8  = type1 a 18 r10 r9
+    r7  = type3 a 16 r9  r8
+    r6  = type2 a 14 r8  r7
+    r5  = type1 a 12 r7  r6
+    r4  = type3 a 10 r6  r5
+    r3  = type2 a 8  r5  r4
+    r2  = type1 a 6  r4  r3
+    r1  = type3 a 4  r3  r2
+    r0  = type2 a 2  r2  r1
+    l0  = type1 a 0  r1  r0
+
+cast_dec (K16 a) (P r16 r15) = cast_dec (K12 a) (P r12 r11)
+  where
+    r14 = type1 a 30 r16 r15
+    r13 = type3 a 28 r15 r14
+    r12 = type2 a 26 r14 r13
+    r11 = type1 a 24 r13 r12
+
+
+-- Non-Identical Rounds
+
+type1 :: Array32 -> Int -> Word32 -> Word32 -> Word32
+type1 arr idx l r =
+    let km = arrayRead32 arr idx
+        kr = arrayRead32 arr (idx + 1)
+        j = (km + r) `rotateL` fromIntegral kr
+        (ja, jb, jc, jd) = decomp32 j
+     in l `xor` (((sbox_s1 ja `xor` sbox_s2 jb) - sbox_s3 jc) + sbox_s4 jd)
+
+type2 :: Array32 -> Int -> Word32 -> Word32 -> Word32
+type2 arr idx l r =
+    let km = arrayRead32 arr idx
+        kr = arrayRead32 arr (idx + 1)
+        j = (km `xor` r) `rotateL` fromIntegral kr
+        (ja, jb, jc, jd) = decomp32 j
+     in l `xor` (((sbox_s1 ja - sbox_s2 jb) + sbox_s3 jc) `xor` sbox_s4 jd)
+
+type3 :: Array32 -> Int -> Word32 -> Word32 -> Word32
+type3 arr idx l r =
+    let km = arrayRead32 arr idx
+        kr = arrayRead32 arr (idx + 1)
+        j = (km - r) `rotateL` fromIntegral kr
+        (ja, jb, jc, jd) = decomp32 j
+     in l `xor` (((sbox_s1 ja + sbox_s2 jb) `xor` sbox_s3 jc) - sbox_s4 jd)
+
+
+-- Key Schedule
+
+-- | Precompute "masking" and "rotation" subkeys
+buildKey :: ByteArrayAccess key
+         => Bool -- ^ @True@ for short keys that only need 12 rounds
+         -> key  -- ^ Input key padded to 16 bytes
+         -> Key  -- ^ Output data structure
+buildKey isShort key =
+    let P x0123 x4567 = decomp64 (fromBE $ B.toW64BE key 0)
+        P x89AB xCDEF = decomp64 (fromBE $ B.toW64BE key 8)
+     in keySchedule isShort (Q x0123 x4567 x89AB xCDEF)
+
+keySchedule :: Bool -> Q -> Key
+keySchedule isShort x
+    | isShort   = K12 $ allocArray32AndFreeze 24 $ \ma ->
+        void (steps123 ma 0 x >>= skip4 >>= steps123 ma 1)
+
+    | otherwise = K16 $ allocArray32AndFreeze 32 $ \ma ->
+        void (steps123 ma 0 x >>= step4 ma 24 >>= steps123 ma 1 >>= step4 ma 25)
+
+  where
+    sbox_s56785 a b c d e = sbox_s5 a `xor` sbox_s6 b `xor` sbox_s7 c `xor` sbox_s8 d `xor` sbox_s5 e
+    sbox_s56786 a b c d e = sbox_s5 a `xor` sbox_s6 b `xor` sbox_s7 c `xor` sbox_s8 d `xor` sbox_s6 e
+    sbox_s56787 a b c d e = sbox_s5 a `xor` sbox_s6 b `xor` sbox_s7 c `xor` sbox_s8 d `xor` sbox_s7 e
+    sbox_s56788 a b c d e = sbox_s5 a `xor` sbox_s6 b `xor` sbox_s7 c `xor` sbox_s8 d `xor` sbox_s8 e
+
+    steps123 ma off = step1 ma off >=> step2 ma (off + 8) >=> step3 ma (off + 16)
+
+    step1 :: MutableArray32 -> Int -> Q -> IO Q
+    step1 ma off (Q x0123 x4567 x89AB xCDEF) = do
+        let (x8, x9, xA, xB) = decomp32 x89AB
+            (xC, xD, xE, xF) = decomp32 xCDEF
+
+            z0123 = x0123 `xor` sbox_s56787 xD xF xC xE x8
+            z4567 = x89AB `xor` sbox_s56788 z0 z2 z1 z3 xA
+            z89AB = xCDEF `xor` sbox_s56785 z7 z6 z5 z4 x9
+            zCDEF = x4567 `xor` sbox_s56786 zA z9 zB z8 xB
+
+            (z0, z1, z2, z3) = decomp32 z0123
+            (z4, z5, z6, z7) = decomp32 z4567
+            (z8, z9, zA, zB) = decomp32 z89AB
+            (zC, zD, zE, zF) = decomp32 zCDEF
+
+        mutableArrayWrite32 ma (off + 0) $ sbox_s56785 z8 z9 z7 z6 z2
+        mutableArrayWrite32 ma (off + 2) $ sbox_s56786 zA zB z5 z4 z6
+        mutableArrayWrite32 ma (off + 4) $ sbox_s56787 zC zD z3 z2 z9
+        mutableArrayWrite32 ma (off + 6) $ sbox_s56788 zE zF z1 z0 zC
+        return (Q z0123 z4567 z89AB zCDEF)
+
+    step2 :: MutableArray32 -> Int -> Q -> IO Q
+    step2 ma off (Q z0123 z4567 z89AB zCDEF) = do
+        let (z0, z1, z2, z3) = decomp32 z0123
+            (z4, z5, z6, z7) = decomp32 z4567
+
+            x0123 = z89AB `xor` sbox_s56787 z5 z7 z4 z6 z0
+            x4567 = z0123 `xor` sbox_s56788 x0 x2 x1 x3 z2
+            x89AB = z4567 `xor` sbox_s56785 x7 x6 x5 x4 z1
+            xCDEF = zCDEF `xor` sbox_s56786 xA x9 xB x8 z3
+
+            (x0, x1, x2, x3) = decomp32 x0123
+            (x4, x5, x6, x7) = decomp32 x4567
+            (x8, x9, xA, xB) = decomp32 x89AB
+            (xC, xD, xE, xF) = decomp32 xCDEF
+
+        mutableArrayWrite32 ma (off + 0) $ sbox_s56785 x3 x2 xC xD x8
+        mutableArrayWrite32 ma (off + 2) $ sbox_s56786 x1 x0 xE xF xD
+        mutableArrayWrite32 ma (off + 4) $ sbox_s56787 x7 x6 x8 x9 x3
+        mutableArrayWrite32 ma (off + 6) $ sbox_s56788 x5 x4 xA xB x7
+        return (Q x0123 x4567 x89AB xCDEF)
+
+    step3 :: MutableArray32 -> Int -> Q -> IO Q
+    step3 ma off (Q x0123 x4567 x89AB xCDEF) = do
+        let (x8, x9, xA, xB) = decomp32 x89AB
+            (xC, xD, xE, xF) = decomp32 xCDEF
+
+            z0123 = x0123 `xor` sbox_s56787 xD xF xC xE x8
+            z4567 = x89AB `xor` sbox_s56788 z0 z2 z1 z3 xA
+            z89AB = xCDEF `xor` sbox_s56785 z7 z6 z5 z4 x9
+            zCDEF = x4567 `xor` sbox_s56786 zA z9 zB z8 xB
+
+            (z0, z1, z2, z3) = decomp32 z0123
+            (z4, z5, z6, z7) = decomp32 z4567
+            (z8, z9, zA, zB) = decomp32 z89AB
+            (zC, zD, zE, zF) = decomp32 zCDEF
+
+        mutableArrayWrite32 ma (off + 0) $ sbox_s56785 z3 z2 zC zD z9
+        mutableArrayWrite32 ma (off + 2) $ sbox_s56786 z1 z0 zE zF zC
+        mutableArrayWrite32 ma (off + 4) $ sbox_s56787 z7 z6 z8 z9 z2
+        mutableArrayWrite32 ma (off + 6) $ sbox_s56788 z5 z4 zA zB z6
+        return (Q z0123 z4567 z89AB zCDEF)
+
+    step4 :: MutableArray32 -> Int -> Q -> IO Q
+    step4 ma off (Q z0123 z4567 z89AB zCDEF) = do
+        let (z0, z1, z2, z3) = decomp32 z0123
+            (z4, z5, z6, z7) = decomp32 z4567
+
+            x0123 = z89AB `xor` sbox_s56787 z5 z7 z4 z6 z0
+            x4567 = z0123 `xor` sbox_s56788 x0 x2 x1 x3 z2
+            x89AB = z4567 `xor` sbox_s56785 x7 x6 x5 x4 z1
+            xCDEF = zCDEF `xor` sbox_s56786 xA x9 xB x8 z3
+
+            (x0, x1, x2, x3) = decomp32 x0123
+            (x4, x5, x6, x7) = decomp32 x4567
+            (x8, x9, xA, xB) = decomp32 x89AB
+            (xC, xD, xE, xF) = decomp32 xCDEF
+
+        mutableArrayWrite32 ma (off + 0) $ sbox_s56785 x8 x9 x7 x6 x3
+        mutableArrayWrite32 ma (off + 2) $ sbox_s56786 xA xB x5 x4 x7
+        mutableArrayWrite32 ma (off + 4) $ sbox_s56787 xC xD x3 x2 x8
+        mutableArrayWrite32 ma (off + 6) $ sbox_s56788 xE xF x1 x0 xD
+        return (Q x0123 x4567 x89AB xCDEF)
+
+    skip4 :: Q -> IO Q
+    skip4 (Q z0123 z4567 z89AB zCDEF) = do
+        let (z0, z1, z2, z3) = decomp32 z0123
+            (z4, z5, z6, z7) = decomp32 z4567
+
+            x0123 = z89AB `xor` sbox_s56787 z5 z7 z4 z6 z0
+            x4567 = z0123 `xor` sbox_s56788 x0 x2 x1 x3 z2
+            x89AB = z4567 `xor` sbox_s56785 x7 x6 x5 x4 z1
+            xCDEF = zCDEF `xor` sbox_s56786 xA x9 xB x8 z3
+
+            (x0, x1, x2, x3) = decomp32 x0123
+            (x4, x5, x6, x7) = decomp32 x4567
+            (x8, x9, xA, xB) = decomp32 x89AB
+
+        return (Q x0123 x4567 x89AB xCDEF)
+
+-- S-Boxes
+
+sbox_s1 :: Word8 -> Word32
+sbox_s1 i = arrayRead32 t (fromIntegral i)
+  where
+    t = array32FromAddrBE 256
+            "\x30\xfb\x40\xd4\x9f\xa0\xff\x0b\x6b\xec\xcd\x2f\x3f\x25\x8c\x7a\x1e\x21\x3f\x2f\x9c\x00\x4d\xd3\x60\x03\xe5\x40\xcf\x9f\xc9\x49\
+            \\xbf\xd4\xaf\x27\x88\xbb\xbd\xb5\xe2\x03\x40\x90\x98\xd0\x96\x75\x6e\x63\xa0\xe0\x15\xc3\x61\xd2\xc2\xe7\x66\x1d\x22\xd4\xff\x8e\
+            \\x28\x68\x3b\x6f\xc0\x7f\xd0\x59\xff\x23\x79\xc8\x77\x5f\x50\xe2\x43\xc3\x40\xd3\xdf\x2f\x86\x56\x88\x7c\xa4\x1a\xa2\xd2\xbd\x2d\
+            \\xa1\xc9\xe0\xd6\x34\x6c\x48\x19\x61\xb7\x6d\x87\x22\x54\x0f\x2f\x2a\xbe\x32\xe1\xaa\x54\x16\x6b\x22\x56\x8e\x3a\xa2\xd3\x41\xd0\
+            \\x66\xdb\x40\xc8\xa7\x84\x39\x2f\x00\x4d\xff\x2f\x2d\xb9\xd2\xde\x97\x94\x3f\xac\x4a\x97\xc1\xd8\x52\x76\x44\xb7\xb5\xf4\x37\xa7\
+            \\xb8\x2c\xba\xef\xd7\x51\xd1\x59\x6f\xf7\xf0\xed\x5a\x09\x7a\x1f\x82\x7b\x68\xd0\x90\xec\xf5\x2e\x22\xb0\xc0\x54\xbc\x8e\x59\x35\
+            \\x4b\x6d\x2f\x7f\x50\xbb\x64\xa2\xd2\x66\x49\x10\xbe\xe5\x81\x2d\xb7\x33\x22\x90\xe9\x3b\x15\x9f\xb4\x8e\xe4\x11\x4b\xff\x34\x5d\
+            \\xfd\x45\xc2\x40\xad\x31\x97\x3f\xc4\xf6\xd0\x2e\x55\xfc\x81\x65\xd5\xb1\xca\xad\xa1\xac\x2d\xae\xa2\xd4\xb7\x6d\xc1\x9b\x0c\x50\
+            \\x88\x22\x40\xf2\x0c\x6e\x4f\x38\xa4\xe4\xbf\xd7\x4f\x5b\xa2\x72\x56\x4c\x1d\x2f\xc5\x9c\x53\x19\xb9\x49\xe3\x54\xb0\x46\x69\xfe\
+            \\xb1\xb6\xab\x8a\xc7\x13\x58\xdd\x63\x85\xc5\x45\x11\x0f\x93\x5d\x57\x53\x8a\xd5\x6a\x39\x04\x93\xe6\x3d\x37\xe0\x2a\x54\xf6\xb3\
+            \\x3a\x78\x7d\x5f\x62\x76\xa0\xb5\x19\xa6\xfc\xdf\x7a\x42\x20\x6a\x29\xf9\xd4\xd5\xf6\x1b\x18\x91\xbb\x72\x27\x5e\xaa\x50\x81\x67\
+            \\x38\x90\x10\x91\xc6\xb5\x05\xeb\x84\xc7\xcb\x8c\x2a\xd7\x5a\x0f\x87\x4a\x14\x27\xa2\xd1\x93\x6b\x2a\xd2\x86\xaf\xaa\x56\xd2\x91\
+            \\xd7\x89\x43\x60\x42\x5c\x75\x0d\x93\xb3\x9e\x26\x18\x71\x84\xc9\x6c\x00\xb3\x2d\x73\xe2\xbb\x14\xa0\xbe\xbc\x3c\x54\x62\x37\x79\
+            \\x64\x45\x9e\xab\x3f\x32\x8b\x82\x77\x18\xcf\x82\x59\xa2\xce\xa6\x04\xee\x00\x2e\x89\xfe\x78\xe6\x3f\xab\x09\x50\x32\x5f\xf6\xc2\
+            \\x81\x38\x3f\x05\x69\x63\xc5\xc8\x76\xcb\x5a\xd6\xd4\x99\x74\xc9\xca\x18\x0d\xcf\x38\x07\x82\xd5\xc7\xfa\x5c\xf6\x8a\xc3\x15\x11\
+            \\x35\xe7\x9e\x13\x47\xda\x91\xd0\xf4\x0f\x90\x86\xa7\xe2\x41\x9e\x31\x36\x62\x41\x05\x1e\xf4\x95\xaa\x57\x3b\x04\x4a\x80\x5d\x8d\
+            \\x54\x83\x00\xd0\x00\x32\x2a\x3c\xbf\x64\xcd\xdf\xba\x57\xa6\x8e\x75\xc6\x37\x2b\x50\xaf\xd3\x41\xa7\xc1\x32\x75\x91\x5a\x0b\xf5\
+            \\x6b\x54\xbf\xab\x2b\x0b\x14\x26\xab\x4c\xc9\xd7\x44\x9c\xcd\x82\xf7\xfb\xf2\x65\xab\x85\xc5\xf3\x1b\x55\xdb\x94\xaa\xd4\xe3\x24\
+            \\xcf\xa4\xbd\x3f\x2d\xea\xa3\xe2\x9e\x20\x4d\x02\xc8\xbd\x25\xac\xea\xdf\x55\xb3\xd5\xbd\x9e\x98\xe3\x12\x31\xb2\x2a\xd5\xad\x6c\
+            \\x95\x43\x29\xde\xad\xbe\x45\x28\xd8\x71\x0f\x69\xaa\x51\xc9\x0f\xaa\x78\x6b\xf6\x22\x51\x3f\x1e\xaa\x51\xa7\x9b\x2a\xd3\x44\xcc\
+            \\x7b\x5a\x41\xf0\xd3\x7c\xfb\xad\x1b\x06\x95\x05\x41\xec\xe4\x91\xb4\xc3\x32\xe6\x03\x22\x68\xd4\xc9\x60\x0a\xcc\xce\x38\x7e\x6d\
+            \\xbf\x6b\xb1\x6c\x6a\x70\xfb\x78\x0d\x03\xd9\xc9\xd4\xdf\x39\xde\xe0\x10\x63\xda\x47\x36\xf4\x64\x5a\xd3\x28\xd8\xb3\x47\xcc\x96\
+            \\x75\xbb\x0f\xc3\x98\x51\x1b\xfb\x4f\xfb\xcc\x35\xb5\x8b\xcf\x6a\xe1\x1f\x0a\xbc\xbf\xc5\xfe\x4a\xa7\x0a\xec\x10\xac\x39\x57\x0a\
+            \\x3f\x04\x44\x2f\x61\x88\xb1\x53\xe0\x39\x7a\x2e\x57\x27\xcb\x79\x9c\xeb\x41\x8f\x1c\xac\xd6\x8d\x2a\xd3\x7c\x96\x01\x75\xcb\x9d\
+            \\xc6\x9d\xff\x09\xc7\x5b\x65\xf0\xd9\xdb\x40\xd8\xec\x0e\x77\x79\x47\x44\xea\xd4\xb1\x1c\x32\x74\xdd\x24\xcb\x9e\x7e\x1c\x54\xbd\
+            \\xf0\x11\x44\xf9\xd2\x24\x0e\xb1\x96\x75\xb3\xfd\xa3\xac\x37\x55\xd4\x7c\x27\xaf\x51\xc8\x5f\x4d\x56\x90\x75\x96\xa5\xbb\x15\xe6\
+            \\x58\x03\x04\xf0\xca\x04\x2c\xf1\x01\x1a\x37\xea\x8d\xbf\xaa\xdb\x35\xba\x3e\x4a\x35\x26\xff\xa0\xc3\x7b\x4d\x09\xbc\x30\x6e\xd9\
+            \\x98\xa5\x26\x66\x56\x48\xf7\x25\xff\x5e\x56\x9d\x0c\xed\x63\xd0\x7c\x63\xb2\xcf\x70\x0b\x45\xe1\xd5\xea\x50\xf1\x85\xa9\x28\x72\
+            \\xaf\x1f\xbd\xa7\xd4\x23\x48\x70\xa7\x87\x0b\xf3\x2d\x3b\x4d\x79\x42\xe0\x41\x98\x0c\xd0\xed\xe7\x26\x47\x0d\xb8\xf8\x81\x81\x4c\
+            \\x47\x4d\x6a\xd7\x7c\x0c\x5e\x5c\xd1\x23\x19\x59\x38\x1b\x72\x98\xf5\xd2\xf4\xdb\xab\x83\x86\x53\x6e\x2f\x1e\x23\x83\x71\x9c\x9e\
+            \\xbd\x91\xe0\x46\x9a\x56\x45\x6e\xdc\x39\x20\x0c\x20\xc8\xc5\x71\x96\x2b\xda\x1c\xe1\xe6\x96\xff\xb1\x41\xab\x08\x7c\xca\x89\xb9\
+            \\x1a\x69\xe7\x83\x02\xcc\x48\x43\xa2\xf7\xc5\x79\x42\x9e\xf4\x7d\x42\x7b\x16\x9c\x5a\xc9\xf0\x49\xdd\x8f\x0f\x00\x5c\x81\x65\xbf"#
+
+sbox_s2 :: Word8 -> Word32
+sbox_s2 i = arrayRead32 t (fromIntegral i)
+  where
+    t = array32FromAddrBE 256
+            "\x1f\x20\x10\x94\xef\x0b\xa7\x5b\x69\xe3\xcf\x7e\x39\x3f\x43\x80\xfe\x61\xcf\x7a\xee\xc5\x20\x7a\x55\x88\x9c\x94\x72\xfc\x06\x51\
+            \\xad\xa7\xef\x79\x4e\x1d\x72\x35\xd5\x5a\x63\xce\xde\x04\x36\xba\x99\xc4\x30\xef\x5f\x0c\x07\x94\x18\xdc\xdb\x7d\xa1\xd6\xef\xf3\
+            \\xa0\xb5\x2f\x7b\x59\xe8\x36\x05\xee\x15\xb0\x94\xe9\xff\xd9\x09\xdc\x44\x00\x86\xef\x94\x44\x59\xba\x83\xcc\xb3\xe0\xc3\xcd\xfb\
+            \\xd1\xda\x41\x81\x3b\x09\x2a\xb1\xf9\x97\xf1\xc1\xa5\xe6\xcf\x7b\x01\x42\x0d\xdb\xe4\xe7\xef\x5b\x25\xa1\xff\x41\xe1\x80\xf8\x06\
+            \\x1f\xc4\x10\x80\x17\x9b\xee\x7a\xd3\x7a\xc6\xa9\xfe\x58\x30\xa4\x98\xde\x8b\x7f\x77\xe8\x3f\x4e\x79\x92\x92\x69\x24\xfa\x9f\x7b\
+            \\xe1\x13\xc8\x5b\xac\xc4\x00\x83\xd7\x50\x35\x25\xf7\xea\x61\x5f\x62\x14\x31\x54\x0d\x55\x4b\x63\x5d\x68\x11\x21\xc8\x66\xc3\x59\
+            \\x3d\x63\xcf\x73\xce\xe2\x34\xc0\xd4\xd8\x7e\x87\x5c\x67\x2b\x21\x07\x1f\x61\x81\x39\xf7\x62\x7f\x36\x1e\x30\x84\xe4\xeb\x57\x3b\
+            \\x60\x2f\x64\xa4\xd6\x3a\xcd\x9c\x1b\xbc\x46\x35\x9e\x81\x03\x2d\x27\x01\xf5\x0c\x99\x84\x7a\xb4\xa0\xe3\xdf\x79\xba\x6c\xf3\x8c\
+            \\x10\x84\x30\x94\x25\x37\xa9\x5e\xf4\x6f\x6f\xfe\xa1\xff\x3b\x1f\x20\x8c\xfb\x6a\x8f\x45\x8c\x74\xd9\xe0\xa2\x27\x4e\xc7\x3a\x34\
+            \\xfc\x88\x4f\x69\x3e\x4d\xe8\xdf\xef\x0e\x00\x88\x35\x59\x64\x8d\x8a\x45\x38\x8c\x1d\x80\x43\x66\x72\x1d\x9b\xfd\xa5\x86\x84\xbb\
+            \\xe8\x25\x63\x33\x84\x4e\x82\x12\x12\x8d\x80\x98\xfe\xd3\x3f\xb4\xce\x28\x0a\xe1\x27\xe1\x9b\xa5\xd5\xa6\xc2\x52\xe4\x97\x54\xbd\
+            \\xc5\xd6\x55\xdd\xeb\x66\x70\x64\x77\x84\x0b\x4d\xa1\xb6\xa8\x01\x84\xdb\x26\xa9\xe0\xb5\x67\x14\x21\xf0\x43\xb7\xe5\xd0\x58\x60\
+            \\x54\xf0\x30\x84\x06\x6f\xf4\x72\xa3\x1a\xa1\x53\xda\xdc\x47\x55\xb5\x62\x5d\xbf\x68\x56\x1b\xe6\x83\xca\x6b\x94\x2d\x6e\xd2\x3b\
+            \\xec\xcf\x01\xdb\xa6\xd3\xd0\xba\xb6\x80\x3d\x5c\xaf\x77\xa7\x09\x33\xb4\xa3\x4c\x39\x7b\xc8\xd6\x5e\xe2\x2b\x95\x5f\x0e\x53\x04\
+            \\x81\xed\x6f\x61\x20\xe7\x43\x64\xb4\x5e\x13\x78\xde\x18\x63\x9b\x88\x1c\xa1\x22\xb9\x67\x26\xd1\x80\x49\xa7\xe8\x22\xb7\xda\x7b\
+            \\x5e\x55\x2d\x25\x52\x72\xd2\x37\x79\xd2\x95\x1c\xc6\x0d\x89\x4c\x48\x8c\xb4\x02\x1b\xa4\xfe\x5b\xa4\xb0\x9f\x6b\x1c\xa8\x15\xcf\
+            \\xa2\x0c\x30\x05\x88\x71\xdf\x63\xb9\xde\x2f\xcb\x0c\xc6\xc9\xe9\x0b\xee\xff\x53\xe3\x21\x45\x17\xb4\x54\x28\x35\x9f\x63\x29\x3c\
+            \\xee\x41\xe7\x29\x6e\x1d\x2d\x7c\x50\x04\x52\x86\x1e\x66\x85\xf3\xf3\x34\x01\xc6\x30\xa2\x2c\x95\x31\xa7\x08\x50\x60\x93\x0f\x13\
+            \\x73\xf9\x84\x17\xa1\x26\x98\x59\xec\x64\x5c\x44\x52\xc8\x77\xa9\xcd\xff\x33\xa6\xa0\x2b\x17\x41\x7c\xba\xd9\xa2\x21\x80\x03\x6f\
+            \\x50\xd9\x9c\x08\xcb\x3f\x48\x61\xc2\x6b\xd7\x65\x64\xa3\xf6\xab\x80\x34\x26\x76\x25\xa7\x5e\x7b\xe4\xe6\xd1\xfc\x20\xc7\x10\xe6\
+            \\xcd\xf0\xb6\x80\x17\x84\x4d\x3b\x31\xee\xf8\x4d\x7e\x08\x24\xe4\x2c\xcb\x49\xeb\x84\x6a\x3b\xae\x8f\xf7\x78\x88\xee\x5d\x60\xf6\
+            \\x7a\xf7\x56\x73\x2f\xdd\x5c\xdb\xa1\x16\x31\xc1\x30\xf6\x6f\x43\xb3\xfa\xec\x54\x15\x7f\xd7\xfa\xef\x85\x79\xcc\xd1\x52\xde\x58\
+            \\xdb\x2f\xfd\x5e\x8f\x32\xce\x19\x30\x6a\xf9\x7a\x02\xf0\x3e\xf8\x99\x31\x9a\xd5\xc2\x42\xfa\x0f\xa7\xe3\xeb\xb0\xc6\x8e\x49\x06\
+            \\xb8\xda\x23\x0c\x80\x82\x30\x28\xdc\xde\xf3\xc8\xd3\x5f\xb1\x71\x08\x8a\x1b\xc8\xbe\xc0\xc5\x60\x61\xa3\xc9\xe8\xbc\xa8\xf5\x4d\
+            \\xc7\x2f\xef\xfa\x22\x82\x2e\x99\x82\xc5\x70\xb4\xd8\xd9\x4e\x89\x8b\x1c\x34\xbc\x30\x1e\x16\xe6\x27\x3b\xe9\x79\xb0\xff\xea\xa6\
+            \\x61\xd9\xb8\xc6\x00\xb2\x48\x69\xb7\xff\xce\x3f\x08\xdc\x28\x3b\x43\xda\xf6\x5a\xf7\xe1\x97\x98\x76\x19\xb7\x2f\x8f\x1c\x9b\xa4\
+            \\xdc\x86\x37\xa0\x16\xa7\xd3\xb1\x9f\xc3\x93\xb7\xa7\x13\x6e\xeb\xc6\xbc\xc6\x3e\x1a\x51\x37\x42\xef\x68\x28\xbc\x52\x03\x65\xd6\
+            \\x2d\x6a\x77\xab\x35\x27\xed\x4b\x82\x1f\xd2\x16\x09\x5c\x6e\x2e\xdb\x92\xf2\xfb\x5e\xea\x29\xcb\x14\x58\x92\xf5\x91\x58\x4f\x7f\
+            \\x54\x83\x69\x7b\x26\x67\xa8\xcc\x85\x19\x60\x48\x8c\x4b\xac\xea\x83\x38\x60\xd4\x0d\x23\xe0\xf9\x6c\x38\x7e\x8a\x0a\xe6\xd2\x49\
+            \\xb2\x84\x60\x0c\xd8\x35\x73\x1d\xdc\xb1\xc6\x47\xac\x4c\x56\xea\x3e\xbd\x81\xb3\x23\x0e\xab\xb0\x64\x38\xbc\x87\xf0\xb5\xb1\xfa\
+            \\x8f\x5e\xa2\xb3\xfc\x18\x46\x42\x0a\x03\x6b\x7a\x4f\xb0\x89\xbd\x64\x9d\xa5\x89\xa3\x45\x41\x5e\x5c\x03\x83\x23\x3e\x5d\x3b\xb9\
+            \\x43\xd7\x95\x72\x7e\x6d\xd0\x7c\x06\xdf\xdf\x1e\x6c\x6c\xc4\xef\x71\x60\xa5\x39\x73\xbf\xbe\x70\x83\x87\x76\x05\x45\x23\xec\xf1"#
+
+sbox_s3 :: Word8 -> Word32
+sbox_s3 i = arrayRead32 t (fromIntegral i)
+  where
+    t = array32FromAddrBE 256
+            "\x8d\xef\xc2\x40\x25\xfa\x5d\x9f\xeb\x90\x3d\xbf\xe8\x10\xc9\x07\x47\x60\x7f\xff\x36\x9f\xe4\x4b\x8c\x1f\xc6\x44\xae\xce\xca\x90\
+            \\xbe\xb1\xf9\xbf\xee\xfb\xca\xea\xe8\xcf\x19\x50\x51\xdf\x07\xae\x92\x0e\x88\x06\xf0\xad\x05\x48\xe1\x3c\x8d\x83\x92\x70\x10\xd5\
+            \\x11\x10\x7d\x9f\x07\x64\x7d\xb9\xb2\xe3\xe4\xd4\x3d\x4f\x28\x5e\xb9\xaf\xa8\x20\xfa\xde\x82\xe0\xa0\x67\x26\x8b\x82\x72\x79\x2e\
+            \\x55\x3f\xb2\xc0\x48\x9a\xe2\x2b\xd4\xef\x97\x94\x12\x5e\x3f\xbc\x21\xff\xfc\xee\x82\x5b\x1b\xfd\x92\x55\xc5\xed\x12\x57\xa2\x40\
+            \\x4e\x1a\x83\x02\xba\xe0\x7f\xff\x52\x82\x46\xe7\x8e\x57\x14\x0e\x33\x73\xf7\xbf\x8c\x9f\x81\x88\xa6\xfc\x4e\xe8\xc9\x82\xb5\xa5\
+            \\xa8\xc0\x1d\xb7\x57\x9f\xc2\x64\x67\x09\x4f\x31\xf2\xbd\x3f\x5f\x40\xff\xf7\xc1\x1f\xb7\x8d\xfc\x8e\x6b\xd2\xc1\x43\x7b\xe5\x9b\
+            \\x99\xb0\x3d\xbf\xb5\xdb\xc6\x4b\x63\x8d\xc0\xe6\x55\x81\x9d\x99\xa1\x97\xc8\x1c\x4a\x01\x2d\x6e\xc5\x88\x4a\x28\xcc\xc3\x6f\x71\
+            \\xb8\x43\xc2\x13\x6c\x07\x43\xf1\x83\x09\x89\x3c\x0f\xed\xdd\x5f\x2f\x7f\xe8\x50\xd7\xc0\x7f\x7e\x02\x50\x7f\xbf\x5a\xfb\x9a\x04\
+            \\xa7\x47\xd2\xd0\x16\x51\x19\x2e\xaf\x70\xbf\x3e\x58\xc3\x13\x80\x5f\x98\x30\x2e\x72\x7c\xc3\xc4\x0a\x0f\xb4\x02\x0f\x7f\xef\x82\
+            \\x8c\x96\xfd\xad\x5d\x2c\x2a\xae\x8e\xe9\x9a\x49\x50\xda\x88\xb8\x84\x27\xf4\xa0\x1e\xac\x57\x90\x79\x6f\xb4\x49\x82\x52\xdc\x15\
+            \\xef\xbd\x7d\x9b\xa6\x72\x59\x7d\xad\xa8\x40\xd8\x45\xf5\x45\x04\xfa\x5d\x74\x03\xe8\x3e\xc3\x05\x4f\x91\x75\x1a\x92\x56\x69\xc2\
+            \\x23\xef\xe9\x41\xa9\x03\xf1\x2e\x60\x27\x0d\xf2\x02\x76\xe4\xb6\x94\xfd\x65\x74\x92\x79\x85\xb2\x82\x76\xdb\xcb\x02\x77\x81\x76\
+            \\xf8\xaf\x91\x8d\x4e\x48\xf7\x9e\x8f\x61\x6d\xdf\xe2\x9d\x84\x0e\x84\x2f\x7d\x83\x34\x0c\xe5\xc8\x96\xbb\xb6\x82\x93\xb4\xb1\x48\
+            \\xef\x30\x3c\xab\x98\x4f\xaf\x28\x77\x9f\xaf\x9b\x92\xdc\x56\x0d\x22\x4d\x1e\x20\x84\x37\xaa\x88\x7d\x29\xdc\x96\x27\x56\xd3\xdc\
+            \\x8b\x90\x7c\xee\xb5\x1f\xd2\x40\xe7\xc0\x7c\xe3\xe5\x66\xb4\xa1\xc3\xe9\x61\x5e\x3c\xf8\x20\x9d\x60\x94\xd1\xe3\xcd\x9c\xa3\x41\
+            \\x5c\x76\x46\x0e\x00\xea\x98\x3b\xd4\xd6\x78\x81\xfd\x47\x57\x2c\xf7\x6c\xed\xd9\xbd\xa8\x22\x9c\x12\x7d\xad\xaa\x43\x8a\x07\x4e\
+            \\x1f\x97\xc0\x90\x08\x1b\xdb\x8a\x93\xa0\x7e\xbe\xb9\x38\xca\x15\x97\xb0\x3c\xff\x3d\xc2\xc0\xf8\x8d\x1a\xb2\xec\x64\x38\x0e\x51\
+            \\x68\xcc\x7b\xfb\xd9\x0f\x27\x88\x12\x49\x01\x81\x5d\xe5\xff\xd4\xdd\x7e\xf8\x6a\x76\xa2\xe2\x14\xb9\xa4\x03\x68\x92\x5d\x95\x8f\
+            \\x4b\x39\xff\xfa\xba\x39\xae\xe9\xa4\xff\xd3\x0b\xfa\xf7\x93\x3b\x6d\x49\x86\x23\x19\x3c\xbc\xfa\x27\x62\x75\x45\x82\x5c\xf4\x7a\
+            \\x61\xbd\x8b\xa0\xd1\x1e\x42\xd1\xce\xad\x04\xf4\x12\x7e\xa3\x92\x10\x42\x8d\xb7\x82\x72\xa9\x72\x92\x70\xc4\xa8\x12\x7d\xe5\x0b\
+            \\x28\x5b\xa1\xc8\x3c\x62\xf4\x4f\x35\xc0\xea\xa5\xe8\x05\xd2\x31\x42\x89\x29\xfb\xb4\xfc\xdf\x82\x4f\xb6\x6a\x53\x0e\x7d\xc1\x5b\
+            \\x1f\x08\x1f\xab\x10\x86\x18\xae\xfc\xfd\x08\x6d\xf9\xff\x28\x89\x69\x4b\xcc\x11\x23\x6a\x5c\xae\x12\xde\xca\x4d\x2c\x3f\x8c\xc5\
+            \\xd2\xd0\x2d\xfe\xf8\xef\x58\x96\xe4\xcf\x52\xda\x95\x15\x5b\x67\x49\x4a\x48\x8c\xb9\xb6\xa8\x0c\x5c\x8f\x82\xbc\x89\xd3\x6b\x45\
+            \\x3a\x60\x94\x37\xec\x00\xc9\xa9\x44\x71\x52\x53\x0a\x87\x4b\x49\xd7\x73\xbc\x40\x7c\x34\x67\x1c\x02\x71\x7e\xf6\x4f\xeb\x55\x36\
+            \\xa2\xd0\x2f\xff\xd2\xbf\x60\xc4\xd4\x3f\x03\xc0\x50\xb4\xef\x6d\x07\x47\x8c\xd1\x00\x6e\x18\x88\xa2\xe5\x3f\x55\xb9\xe6\xd4\xbc\
+            \\xa2\x04\x80\x16\x97\x57\x38\x33\xd7\x20\x7d\x67\xde\x0f\x8f\x3d\x72\xf8\x7b\x33\xab\xcc\x4f\x33\x76\x88\xc5\x5d\x7b\x00\xa6\xb0\
+            \\x94\x7b\x00\x01\x57\x00\x75\xd2\xf9\xbb\x88\xf8\x89\x42\x01\x9e\x42\x64\xa5\xff\x85\x63\x02\xe0\x72\xdb\xd9\x2b\xee\x97\x1b\x69\
+            \\x6e\xa2\x2f\xde\x5f\x08\xae\x2b\xaf\x7a\x61\x6d\xe5\xc9\x87\x67\xcf\x1f\xeb\xd2\x61\xef\xc8\xc2\xf1\xac\x25\x71\xcc\x82\x39\xc2\
+            \\x67\x21\x4c\xb8\xb1\xe5\x83\xd1\xb7\xdc\x3e\x62\x7f\x10\xbd\xce\xf9\x0a\x5c\x38\x0f\xf0\x44\x3d\x60\x6e\x6d\xc6\x60\x54\x3a\x49\
+            \\x57\x27\xc1\x48\x2b\xe9\x8a\x1d\x8a\xb4\x17\x38\x20\xe1\xbe\x24\xaf\x96\xda\x0f\x68\x45\x84\x25\x99\x83\x3b\xe5\x60\x0d\x45\x7d\
+            \\x28\x2f\x93\x50\x83\x34\xb3\x62\xd9\x1d\x11\x20\x2b\x6d\x8d\xa0\x64\x2b\x1e\x31\x9c\x30\x5a\x00\x52\xbc\xe6\x88\x1b\x03\x58\x8a\
+            \\xf7\xba\xef\xd5\x41\x42\xed\x9c\xa4\x31\x5c\x11\x83\x32\x3e\xc5\xdf\xef\x46\x36\xa1\x33\xc5\x01\xe9\xd3\x53\x1c\xee\x35\x37\x83"#
+
+sbox_s4 :: Word8 -> Word32
+sbox_s4 i = arrayRead32 t (fromIntegral i)
+  where
+    t = array32FromAddrBE 256
+            "\x9d\xb3\x04\x20\x1f\xb6\xe9\xde\xa7\xbe\x7b\xef\xd2\x73\xa2\x98\x4a\x4f\x7b\xdb\x64\xad\x8c\x57\x85\x51\x04\x43\xfa\x02\x0e\xd1\
+            \\x7e\x28\x7a\xff\xe6\x0f\xb6\x63\x09\x5f\x35\xa1\x79\xeb\xf1\x20\xfd\x05\x9d\x43\x64\x97\xb7\xb1\xf3\x64\x1f\x63\x24\x1e\x4a\xdf\
+            \\x28\x14\x7f\x5f\x4f\xa2\xb8\xcd\xc9\x43\x00\x40\x0c\xc3\x22\x20\xfd\xd3\x0b\x30\xc0\xa5\x37\x4f\x1d\x2d\x00\xd9\x24\x14\x7b\x15\
+            \\xee\x4d\x11\x1a\x0f\xca\x51\x67\x71\xff\x90\x4c\x2d\x19\x5f\xfe\x1a\x05\x64\x5f\x0c\x13\xfe\xfe\x08\x1b\x08\xca\x05\x17\x01\x21\
+            \\x80\x53\x01\x00\xe8\x3e\x5e\xfe\xac\x9a\xf4\xf8\x7f\xe7\x27\x01\xd2\xb8\xee\x5f\x06\xdf\x42\x61\xbb\x9e\x9b\x8a\x72\x93\xea\x25\
+            \\xce\x84\xff\xdf\xf5\x71\x88\x01\x3d\xd6\x4b\x04\xa2\x6f\x26\x3b\x7e\xd4\x84\x00\x54\x7e\xeb\xe6\x44\x6d\x4c\xa0\x6c\xf3\xd6\xf5\
+            \\x26\x49\xab\xdf\xae\xa0\xc7\xf5\x36\x33\x8c\xc1\x50\x3f\x7e\x93\xd3\x77\x20\x61\x11\xb6\x38\xe1\x72\x50\x0e\x03\xf8\x0e\xb2\xbb\
+            \\xab\xe0\x50\x2e\xec\x8d\x77\xde\x57\x97\x1e\x81\xe1\x4f\x67\x46\xc9\x33\x54\x00\x69\x20\x31\x8f\x08\x1d\xbb\x99\xff\xc3\x04\xa5\
+            \\x4d\x35\x18\x05\x7f\x3d\x5c\xe3\xa6\xc8\x66\xc6\x5d\x5b\xcc\xa9\xda\xec\x6f\xea\x9f\x92\x6f\x91\x9f\x46\x22\x2f\x39\x91\x46\x7d\
+            \\xa5\xbf\x6d\x8e\x11\x43\xc4\x4f\x43\x95\x83\x02\xd0\x21\x4e\xeb\x02\x20\x83\xb8\x3f\xb6\x18\x0c\x18\xf8\x93\x1e\x28\x16\x58\xe6\
+            \\x26\x48\x6e\x3e\x8b\xd7\x8a\x70\x74\x77\xe4\xc1\xb5\x06\xe0\x7c\xf3\x2d\x0a\x25\x79\x09\x8b\x02\xe4\xea\xbb\x81\x28\x12\x3b\x23\
+            \\x69\xde\xad\x38\x15\x74\xca\x16\xdf\x87\x1b\x62\x21\x1c\x40\xb7\xa5\x1a\x9e\xf9\x00\x14\x37\x7b\x04\x1e\x8a\xc8\x09\x11\x40\x03\
+            \\xbd\x59\xe4\xd2\xe3\xd1\x56\xd5\x4f\xe8\x76\xd5\x2f\x91\xa3\x40\x55\x7b\xe8\xde\x00\xea\xe4\xa7\x0c\xe5\xc2\xec\x4d\xb4\xbb\xa6\
+            \\xe7\x56\xbd\xff\xdd\x33\x69\xac\xec\x17\xb0\x35\x06\x57\x23\x27\x99\xaf\xc8\xb0\x56\xc8\xc3\x91\x6b\x65\x81\x1c\x5e\x14\x61\x19\
+            \\x6e\x85\xcb\x75\xbe\x07\xc0\x02\xc2\x32\x55\x77\x89\x3f\xf4\xec\x5b\xbf\xc9\x2d\xd0\xec\x3b\x25\xb7\x80\x1a\xb7\x8d\x6d\x3b\x24\
+            \\x20\xc7\x63\xef\xc3\x66\xa5\xfc\x9c\x38\x28\x80\x0a\xce\x32\x05\xaa\xc9\x54\x8a\xec\xa1\xd7\xc7\x04\x1a\xfa\x32\x1d\x16\x62\x5a\
+            \\x67\x01\x90\x2c\x9b\x75\x7a\x54\x31\xd4\x77\xf7\x91\x26\xb0\x31\x36\xcc\x6f\xdb\xc7\x0b\x8b\x46\xd9\xe6\x6a\x48\x56\xe5\x5a\x79\
+            \\x02\x6a\x4c\xeb\x52\x43\x7e\xff\x2f\x8f\x76\xb4\x0d\xf9\x80\xa5\x86\x74\xcd\xe3\xed\xda\x04\xeb\x17\xa9\xbe\x04\x2c\x18\xf4\xdf\
+            \\xb7\x74\x7f\x9d\xab\x2a\xf7\xb4\xef\xc3\x4d\x20\x2e\x09\x6b\x7c\x17\x41\xa2\x54\xe5\xb6\xa0\x35\x21\x3d\x42\xf6\x2c\x1c\x7c\x26\
+            \\x61\xc2\xf5\x0f\x65\x52\xda\xf9\xd2\xc2\x31\xf8\x25\x13\x0f\x69\xd8\x16\x7f\xa2\x04\x18\xf2\xc8\x00\x1a\x96\xa6\x0d\x15\x26\xab\
+            \\x63\x31\x5c\x21\x5e\x0a\x72\xec\x49\xba\xfe\xfd\x18\x79\x08\xd9\x8d\x0d\xbd\x86\x31\x11\x70\xa7\x3e\x9b\x64\x0c\xcc\x3e\x10\xd7\
+            \\xd5\xca\xd3\xb6\x0c\xae\xc3\x88\xf7\x30\x01\xe1\x6c\x72\x8a\xff\x71\xea\xe2\xa1\x1f\x9a\xf3\x6e\xcf\xcb\xd1\x2f\xc1\xde\x84\x17\
+            \\xac\x07\xbe\x6b\xcb\x44\xa1\xd8\x8b\x9b\x0f\x56\x01\x39\x88\xc3\xb1\xc5\x2f\xca\xb4\xbe\x31\xcd\xd8\x78\x28\x06\x12\xa3\xa4\xe2\
+            \\x6f\x7d\xe5\x32\x58\xfd\x7e\xb6\xd0\x1e\xe9\x00\x24\xad\xff\xc2\xf4\x99\x0f\xc5\x97\x11\xaa\xc5\x00\x1d\x7b\x95\x82\xe5\xe7\xd2\
+            \\x10\x98\x73\xf6\x00\x61\x30\x96\xc3\x2d\x95\x21\xad\xa1\x21\xff\x29\x90\x84\x15\x7f\xbb\x97\x7f\xaf\x9e\xb3\xdb\x29\xc9\xed\x2a\
+            \\x5c\xe2\xa4\x65\xa7\x30\xf3\x2c\xd0\xaa\x3f\xe8\x8a\x5c\xc0\x91\xd4\x9e\x2c\xe7\x0c\xe4\x54\xa9\xd6\x0a\xcd\x86\x01\x5f\x19\x19\
+            \\x77\x07\x91\x03\xde\xa0\x3a\xf6\x78\xa8\x56\x5e\xde\xe3\x56\xdf\x21\xf0\x5c\xbe\x8b\x75\xe3\x87\xb3\xc5\x06\x51\xb8\xa5\xc3\xef\
+            \\xd8\xee\xb6\xd2\xe5\x23\xbe\x77\xc2\x15\x45\x29\x2f\x69\xef\xdf\xaf\xe6\x7a\xfb\xf4\x70\xc4\xb2\xf3\xe0\xeb\x5b\xd6\xcc\x98\x76\
+            \\x39\xe4\x46\x0c\x1f\xda\x85\x38\x19\x87\x83\x2f\xca\x00\x73\x67\xa9\x91\x44\xf8\x29\x6b\x29\x9e\x49\x2f\xc2\x95\x92\x66\xbe\xab\
+            \\xb5\x67\x6e\x69\x9b\xd3\xdd\xda\xdf\x7e\x05\x2f\xdb\x25\x70\x1c\x1b\x5e\x51\xee\xf6\x53\x24\xe6\x6a\xfc\xe3\x6c\x03\x16\xcc\x04\
+            \\x86\x44\x21\x3e\xb7\xdc\x59\xd0\x79\x65\x29\x1f\xcc\xd6\xfd\x43\x41\x82\x39\x79\x93\x2b\xcd\xf6\xb6\x57\xc3\x4d\x4e\xdf\xd2\x82\
+            \\x7a\xe5\x29\x0c\x3c\xb9\x53\x6b\x85\x1e\x20\xfe\x98\x33\x55\x7e\x13\xec\xf0\xb0\xd3\xff\xb3\x72\x3f\x85\xc5\xc1\x0a\xef\x7e\xd2"#
+
+sbox_s5 :: Word8 -> Word32
+sbox_s5 i = arrayRead32 t (fromIntegral i)
+  where
+    t = array32FromAddrBE 256
+            "\x7e\xc9\x0c\x04\x2c\x6e\x74\xb9\x9b\x0e\x66\xdf\xa6\x33\x79\x11\xb8\x6a\x7f\xff\x1d\xd3\x58\xf5\x44\xdd\x9d\x44\x17\x31\x16\x7f\
+            \\x08\xfb\xf1\xfa\xe7\xf5\x11\xcc\xd2\x05\x1b\x00\x73\x5a\xba\x00\x2a\xb7\x22\xd8\x38\x63\x81\xcb\xac\xf6\x24\x3a\x69\xbe\xfd\x7a\
+            \\xe6\xa2\xe7\x7f\xf0\xc7\x20\xcd\xc4\x49\x48\x16\xcc\xf5\xc1\x80\x38\x85\x16\x40\x15\xb0\xa8\x48\xe6\x8b\x18\xcb\x4c\xaa\xde\xff\
+            \\x5f\x48\x0a\x01\x04\x12\xb2\xaa\x25\x98\x14\xfc\x41\xd0\xef\xe2\x4e\x40\xb4\x8d\x24\x8e\xb6\xfb\x8d\xba\x1c\xfe\x41\xa9\x9b\x02\
+            \\x1a\x55\x0a\x04\xba\x8f\x65\xcb\x72\x51\xf4\xe7\x95\xa5\x17\x25\xc1\x06\xec\xd7\x97\xa5\x98\x0a\xc5\x39\xb9\xaa\x4d\x79\xfe\x6a\
+            \\xf2\xf3\xf7\x63\x68\xaf\x80\x40\xed\x0c\x9e\x56\x11\xb4\x95\x8b\xe1\xeb\x5a\x88\x87\x09\xe6\xb0\xd7\xe0\x71\x56\x4e\x29\xfe\xa7\
+            \\x63\x66\xe5\x2d\x02\xd1\xc0\x00\xc4\xac\x8e\x05\x93\x77\xf5\x71\x0c\x05\x37\x2a\x57\x85\x35\xf2\x22\x61\xbe\x02\xd6\x42\xa0\xc9\
+            \\xdf\x13\xa2\x80\x74\xb5\x5b\xd2\x68\x21\x99\xc0\xd4\x21\xe5\xec\x53\xfb\x3c\xe8\xc8\xad\xed\xb3\x28\xa8\x7f\xc9\x3d\x95\x99\x81\
+            \\x5c\x1f\xf9\x00\xfe\x38\xd3\x99\x0c\x4e\xff\x0b\x06\x24\x07\xea\xaa\x2f\x4f\xb1\x4f\xb9\x69\x76\x90\xc7\x95\x05\xb0\xa8\xa7\x74\
+            \\xef\x55\xa1\xff\xe5\x9c\xa2\xc2\xa6\xb6\x2d\x27\xe6\x6a\x42\x63\xdf\x65\x00\x1f\x0e\xc5\x09\x66\xdf\xdd\x55\xbc\x29\xde\x06\x55\
+            \\x91\x1e\x73\x9a\x17\xaf\x89\x75\x32\xc7\x91\x1c\x89\xf8\x94\x68\x0d\x01\xe9\x80\x52\x47\x55\xf4\x03\xb6\x3c\xc9\x0c\xc8\x44\xb2\
+            \\xbc\xf3\xf0\xaa\x87\xac\x36\xe9\xe5\x3a\x74\x26\x01\xb3\xd8\x2b\x1a\x9e\x74\x49\x64\xee\x2d\x7e\xcd\xdb\xb1\xda\x01\xc9\x49\x10\
+            \\xb8\x68\xbf\x80\x0d\x26\xf3\xfd\x93\x42\xed\xe7\x04\xa5\xc2\x84\x63\x67\x37\xb6\x50\xf5\xb6\x16\xf2\x47\x66\xe3\x8e\xca\x36\xc1\
+            \\x13\x6e\x05\xdb\xfe\xf1\x83\x91\xfb\x88\x7a\x37\xd6\xe7\xf7\xd4\xc7\xfb\x7d\xc9\x30\x63\xfc\xdf\xb6\xf5\x89\xde\xec\x29\x41\xda\
+            \\x26\xe4\x66\x95\xb7\x56\x64\x19\xf6\x54\xef\xc5\xd0\x8d\x58\xb7\x48\x92\x54\x01\xc1\xba\xcb\x7f\xe5\xff\x55\x0f\xb6\x08\x30\x49\
+            \\x5b\xb5\xd0\xe8\x87\xd7\x2e\x5a\xab\x6a\x6e\xe1\x22\x3a\x66\xce\xc6\x2b\xf3\xcd\x9e\x08\x85\xf9\x68\xcb\x3e\x47\x08\x6c\x01\x0f\
+            \\xa2\x1d\xe8\x20\xd1\x8b\x69\xde\xf3\xf6\x57\x77\xfa\x02\xc3\xf6\x40\x7e\xda\xc3\xcb\xb3\xd5\x50\x17\x93\x08\x4d\xb0\xd7\x0e\xba\
+            \\x0a\xb3\x78\xd5\xd9\x51\xfb\x0c\xde\xd7\xda\x56\x41\x24\xbb\xe4\x94\xca\x0b\x56\x0f\x57\x55\xd1\xe0\xe1\xe5\x6e\x61\x84\xb5\xbe\
+            \\x58\x0a\x24\x9f\x94\xf7\x4b\xc0\xe3\x27\x88\x8e\x9f\x7b\x55\x61\xc3\xdc\x02\x80\x05\x68\x77\x15\x64\x6c\x6b\xd7\x44\x90\x4d\xb3\
+            \\x66\xb4\xf0\xa3\xc0\xf1\x64\x8a\x69\x7e\xd5\xaf\x49\xe9\x2f\xf6\x30\x9e\x37\x4f\x2c\xb6\x35\x6a\x85\x80\x85\x73\x49\x91\xf8\x40\
+            \\x76\xf0\xae\x02\x08\x3b\xe8\x4d\x28\x42\x1c\x9a\x44\x48\x94\x06\x73\x6e\x4c\xb8\xc1\x09\x29\x10\x8b\xc9\x5f\xc6\x7d\x86\x9c\xf4\
+            \\x13\x4f\x61\x6f\x2e\x77\x11\x8d\xb3\x1b\x2b\xe1\xaa\x90\xb4\x72\x3c\xa5\xd7\x17\x7d\x16\x1b\xba\x9c\xad\x90\x10\xaf\x46\x2b\xa2\
+            \\x9f\xe4\x59\xd2\x45\xd3\x45\x59\xd9\xf2\xda\x13\xdb\xc6\x54\x87\xf3\xe4\xf9\x4e\x17\x6d\x48\x6f\x09\x7c\x13\xea\x63\x1d\xa5\xc7\
+            \\x44\x5f\x73\x82\x17\x56\x83\xf4\xcd\xc6\x6a\x97\x70\xbe\x02\x88\xb3\xcd\xcf\x72\x6e\x5d\xd2\xf3\x20\x93\x60\x79\x45\x9b\x80\xa5\
+            \\xbe\x60\xe2\xdb\xa9\xc2\x31\x01\xeb\xa5\x31\x5c\x22\x4e\x42\xf2\x1c\x5c\x15\x72\xf6\x72\x1b\x2c\x1a\xd2\xff\xf3\x8c\x25\x40\x4e\
+            \\x32\x4e\xd7\x2f\x40\x67\xb7\xfd\x05\x23\x13\x8e\x5c\xa3\xbc\x78\xdc\x0f\xd6\x6e\x75\x92\x22\x83\x78\x4d\x6b\x17\x58\xeb\xb1\x6e\
+            \\x44\x09\x4f\x85\x3f\x48\x1d\x87\xfc\xfe\xae\x7b\x77\xb5\xff\x76\x8c\x23\x02\xbf\xaa\xf4\x75\x56\x5f\x46\xb0\x2a\x2b\x09\x28\x01\
+            \\x3d\x38\xf5\xf7\x0c\xa8\x1f\x36\x52\xaf\x4a\x8a\x66\xd5\xe7\xc0\xdf\x3b\x08\x74\x95\x05\x51\x10\x1b\x5a\xd7\xa8\xf6\x1e\xd5\xad\
+            \\x6c\xf6\xe4\x79\x20\x75\x81\x84\xd0\xce\xfa\x65\x88\xf7\xbe\x58\x4a\x04\x68\x26\x0f\xf6\xf8\xf3\xa0\x9c\x7f\x70\x53\x46\xab\xa0\
+            \\x5c\xe9\x6c\x28\xe1\x76\xed\xa3\x6b\xac\x30\x7f\x37\x68\x29\xd2\x85\x36\x0f\xa9\x17\xe3\xfe\x2a\x24\xb7\x97\x67\xf5\xa9\x6b\x20\
+            \\xd6\xcd\x25\x95\x68\xff\x1e\xbf\x75\x55\x44\x2c\xf1\x9f\x06\xbe\xf9\xe0\x65\x9a\xee\xb9\x49\x1d\x34\x01\x07\x18\xbb\x30\xca\xb8\
+            \\xe8\x22\xfe\x15\x88\x57\x09\x83\x75\x0e\x62\x49\xda\x62\x7e\x55\x5e\x76\xff\xa8\xb1\x53\x45\x46\x6d\x47\xde\x08\xef\xe9\xe7\xd4"#
+
+sbox_s6 :: Word8 -> Word32
+sbox_s6 i = arrayRead32 t (fromIntegral i)
+  where
+    t = array32FromAddrBE 256
+            "\xf6\xfa\x8f\x9d\x2c\xac\x6c\xe1\x4c\xa3\x48\x67\xe2\x33\x7f\x7c\x95\xdb\x08\xe7\x01\x68\x43\xb4\xec\xed\x5c\xbc\x32\x55\x53\xac\
+            \\xbf\x9f\x09\x60\xdf\xa1\xe2\xed\x83\xf0\x57\x9d\x63\xed\x86\xb9\x1a\xb6\xa6\xb8\xde\x5e\xbe\x39\xf3\x8f\xf7\x32\x89\x89\xb1\x38\
+            \\x33\xf1\x49\x61\xc0\x19\x37\xbd\xf5\x06\xc6\xda\xe4\x62\x5e\x7e\xa3\x08\xea\x99\x4e\x23\xe3\x3c\x79\xcb\xd7\xcc\x48\xa1\x43\x67\
+            \\xa3\x14\x96\x19\xfe\xc9\x4b\xd5\xa1\x14\x17\x4a\xea\xa0\x18\x66\xa0\x84\xdb\x2d\x09\xa8\x48\x6f\xa8\x88\x61\x4a\x29\x00\xaf\x98\
+            \\x01\x66\x59\x91\xe1\x99\x28\x63\xc8\xf3\x0c\x60\x2e\x78\xef\x3c\xd0\xd5\x19\x32\xcf\x0f\xec\x14\xf7\xca\x07\xd2\xd0\xa8\x20\x72\
+            \\xfd\x41\x19\x7e\x93\x05\xa6\xb0\xe8\x6b\xe3\xda\x74\xbe\xd3\xcd\x37\x2d\xa5\x3c\x4c\x7f\x44\x48\xda\xb5\xd4\x40\x6d\xba\x0e\xc3\
+            \\x08\x39\x19\xa7\x9f\xba\xee\xd9\x49\xdb\xcf\xb0\x4e\x67\x0c\x53\x5c\x3d\x9c\x01\x64\xbd\xb9\x41\x2c\x0e\x63\x6a\xba\x7d\xd9\xcd\
+            \\xea\x6f\x73\x88\xe7\x0b\xc7\x62\x35\xf2\x9a\xdb\x5c\x4c\xdd\x8d\xf0\xd4\x8d\x8c\xb8\x81\x53\xe2\x08\xa1\x98\x66\x1a\xe2\xea\xc8\
+            \\x28\x4c\xaf\x89\xaa\x92\x82\x23\x93\x34\xbe\x53\x3b\x3a\x21\xbf\x16\x43\x4b\xe3\x9a\xea\x39\x06\xef\xe8\xc3\x6e\xf8\x90\xcd\xd9\
+            \\x80\x22\x6d\xae\xc3\x40\xa4\xa3\xdf\x7e\x9c\x09\xa6\x94\xa8\x07\x5b\x7c\x5e\xcc\x22\x1d\xb3\xa6\x9a\x69\xa0\x2f\x68\x81\x8a\x54\
+            \\xce\xb2\x29\x6f\x53\xc0\x84\x3a\xfe\x89\x36\x55\x25\xbf\xe6\x8a\xb4\x62\x8a\xbc\xcf\x22\x2e\xbf\x25\xac\x6f\x48\xa9\xa9\x93\x87\
+            \\x53\xbd\xdb\x65\xe7\x6f\xfb\xe7\xe9\x67\xfd\x78\x0b\xa9\x35\x63\x8e\x34\x2b\xc1\xe8\xa1\x1b\xe9\x49\x80\x74\x0d\xc8\x08\x7d\xfc\
+            \\x8d\xe4\xbf\x99\xa1\x11\x01\xa0\x7f\xd3\x79\x75\xda\x5a\x26\xc0\xe8\x1f\x99\x4f\x95\x28\xcd\x89\xfd\x33\x9f\xed\xb8\x78\x34\xbf\
+            \\x5f\x04\x45\x6d\x22\x25\x86\x98\xc9\xc4\xc8\x3b\x2d\xc1\x56\xbe\x4f\x62\x8d\xaa\x57\xf5\x5e\xc5\xe2\x22\x0a\xbe\xd2\x91\x6e\xbf\
+            \\x4e\xc7\x5b\x95\x24\xf2\xc3\xc0\x42\xd1\x5d\x99\xcd\x0d\x7f\xa0\x7b\x6e\x27\xff\xa8\xdc\x8a\xf0\x73\x45\xc1\x06\xf4\x1e\x23\x2f\
+            \\x35\x16\x23\x86\xe6\xea\x89\x26\x33\x33\xb0\x94\x15\x7e\xc6\xf2\x37\x2b\x74\xaf\x69\x25\x73\xe4\xe9\xa9\xd8\x48\xf3\x16\x02\x89\
+            \\x3a\x62\xef\x1d\xa7\x87\xe2\x38\xf3\xa5\xf6\x76\x74\x36\x48\x53\x20\x95\x10\x63\x45\x76\x69\x8d\xb6\xfa\xd4\x07\x59\x2a\xf9\x50\
+            \\x36\xf7\x35\x23\x4c\xfb\x6e\x87\x7d\xa4\xce\xc0\x6c\x15\x2d\xaa\xcb\x03\x96\xa8\xc5\x0d\xfe\x5d\xfc\xd7\x07\xab\x09\x21\xc4\x2f\
+            \\x89\xdf\xf0\xbb\x5f\xe2\xbe\x78\x44\x8f\x4f\x33\x75\x46\x13\xc9\x2b\x05\xd0\x8d\x48\xb9\xd5\x85\xdc\x04\x94\x41\xc8\x09\x8f\x9b\
+            \\x7d\xed\xe7\x86\xc3\x9a\x33\x73\x42\x41\x00\x05\x6a\x09\x17\x51\x0e\xf3\xc8\xa6\x89\x00\x72\xd6\x28\x20\x76\x82\xa9\xa9\xf7\xbe\
+            \\xbf\x32\x67\x9d\xd4\x5b\x5b\x75\xb3\x53\xfd\x00\xcb\xb0\xe3\x58\x83\x0f\x22\x0a\x1f\x8f\xb2\x14\xd3\x72\xcf\x08\xcc\x3c\x4a\x13\
+            \\x8c\xf6\x31\x66\x06\x1c\x87\xbe\x88\xc9\x8f\x88\x60\x62\xe3\x97\x47\xcf\x8e\x7a\xb6\xc8\x52\x83\x3c\xc2\xac\xfb\x3f\xc0\x69\x76\
+            \\x4e\x8f\x02\x52\x64\xd8\x31\x4d\xda\x38\x70\xe3\x1e\x66\x54\x59\xc1\x09\x08\xf0\x51\x30\x21\xa5\x6c\x5b\x68\xb7\x82\x2f\x8a\xa0\
+            \\x30\x07\xcd\x3e\x74\x71\x9e\xef\xdc\x87\x26\x81\x07\x33\x40\xd4\x7e\x43\x2f\xd9\x0c\x5e\xc2\x41\x88\x09\x28\x6c\xf5\x92\xd8\x91\
+            \\x08\xa9\x30\xf6\x95\x7e\xf3\x05\xb7\xfb\xff\xbd\xc2\x66\xe9\x6f\x6f\xe4\xac\x98\xb1\x73\xec\xc0\xbc\x60\xb4\x2a\x95\x34\x98\xda\
+            \\xfb\xa1\xae\x12\x2d\x4b\xd7\x36\x0f\x25\xfa\xab\xa4\xf3\xfc\xeb\xe2\x96\x91\x23\x25\x7f\x0c\x3d\x93\x48\xaf\x49\x36\x14\x00\xbc\
+            \\xe8\x81\x6f\x4a\x38\x14\xf2\x00\xa3\xf9\x40\x43\x9c\x7a\x54\xc2\xbc\x70\x4f\x57\xda\x41\xe7\xf9\xc2\x5a\xd3\x3a\x54\xf4\xa0\x84\
+            \\xb1\x7f\x55\x05\x59\x35\x7c\xbe\xed\xbd\x15\xc8\x7f\x97\xc5\xab\xba\x5a\xc7\xb5\xb6\xf6\xde\xaf\x3a\x47\x9c\x3a\x53\x02\xda\x25\
+            \\x65\x3d\x7e\x6a\x54\x26\x8d\x49\x51\xa4\x77\xea\x50\x17\xd5\x5b\xd7\xd2\x5d\x88\x44\x13\x6c\x76\x04\x04\xa8\xc8\xb8\xe5\xa1\x21\
+            \\xb8\x1a\x92\x8a\x60\xed\x58\x69\x97\xc5\x5b\x96\xea\xec\x99\x1b\x29\x93\x59\x13\x01\xfd\xb7\xf1\x08\x8e\x8d\xfa\x9a\xb6\xf6\xf5\
+            \\x3b\x4c\xbf\x9f\x4a\x5d\xe3\xab\xe6\x05\x1d\x35\xa0\xe1\xd8\x55\xd3\x6b\x4c\xf1\xf5\x44\xed\xeb\xb0\xe9\x35\x24\xbe\xbb\x8f\xbd\
+            \\xa2\xd7\x62\xcf\x49\xc9\x2f\x54\x38\xb5\xf3\x31\x71\x28\xa4\x54\x48\x39\x29\x05\xa6\x5b\x1d\xb8\x85\x1c\x97\xbd\xd6\x75\xcf\x2f"#
+
+sbox_s7 :: Word8 -> Word32
+sbox_s7 i = arrayRead32 t (fromIntegral i)
+  where
+    t = array32FromAddrBE 256
+            "\x85\xe0\x40\x19\x33\x2b\xf5\x67\x66\x2d\xbf\xff\xcf\xc6\x56\x93\x2a\x8d\x7f\x6f\xab\x9b\xc9\x12\xde\x60\x08\xa1\x20\x28\xda\x1f\
+            \\x02\x27\xbc\xe7\x4d\x64\x29\x16\x18\xfa\xc3\x00\x50\xf1\x8b\x82\x2c\xb2\xcb\x11\xb2\x32\xe7\x5c\x4b\x36\x95\xf2\xb2\x87\x07\xde\
+            \\xa0\x5f\xbc\xf6\xcd\x41\x81\xe9\xe1\x50\x21\x0c\xe2\x4e\xf1\xbd\xb1\x68\xc3\x81\xfd\xe4\xe7\x89\x5c\x79\xb0\xd8\x1e\x8b\xfd\x43\
+            \\x4d\x49\x50\x01\x38\xbe\x43\x41\x91\x3c\xee\x1d\x92\xa7\x9c\x3f\x08\x97\x66\xbe\xba\xee\xad\xf4\x12\x86\xbe\xcf\xb6\xea\xcb\x19\
+            \\x26\x60\xc2\x00\x75\x65\xbd\xe4\x64\x24\x1f\x7a\x82\x48\xdc\xa9\xc3\xb3\xad\x66\x28\x13\x60\x86\x0b\xd8\xdf\xa8\x35\x6d\x1c\xf2\
+            \\x10\x77\x89\xbe\xb3\xb2\xe9\xce\x05\x02\xaa\x8f\x0b\xc0\x35\x1e\x16\x6b\xf5\x2a\xeb\x12\xff\x82\xe3\x48\x69\x11\xd3\x4d\x75\x16\
+            \\x4e\x7b\x3a\xff\x5f\x43\x67\x1b\x9c\xf6\xe0\x37\x49\x81\xac\x83\x33\x42\x66\xce\x8c\x93\x41\xb7\xd0\xd8\x54\xc0\xcb\x3a\x6c\x88\
+            \\x47\xbc\x28\x29\x47\x25\xba\x37\xa6\x6a\xd2\x2b\x7a\xd6\x1f\x1e\x0c\x5c\xba\xfa\x44\x37\xf1\x07\xb6\xe7\x99\x62\x42\xd2\xd8\x16\
+            \\x0a\x96\x12\x88\xe1\xa5\xc0\x6e\x13\x74\x9e\x67\x72\xfc\x08\x1a\xb1\xd1\x39\xf7\xf9\x58\x37\x45\xcf\x19\xdf\x58\xbe\xc3\xf7\x56\
+            \\xc0\x6e\xba\x30\x07\x21\x1b\x24\x45\xc2\x88\x29\xc9\x5e\x31\x7f\xbc\x8e\xc5\x11\x38\xbc\x46\xe9\xc6\xe6\xfa\x14\xba\xe8\x58\x4a\
+            \\xad\x4e\xbc\x46\x46\x8f\x50\x8b\x78\x29\x43\x5f\xf1\x24\x18\x3b\x82\x1d\xba\x9f\xaf\xf6\x0f\xf4\xea\x2c\x4e\x6d\x16\xe3\x92\x64\
+            \\x92\x54\x4a\x8b\x00\x9b\x4f\xc3\xab\xa6\x8c\xed\x9a\xc9\x6f\x78\x06\xa5\xb7\x9a\xb2\x85\x6e\x6e\x1a\xec\x3c\xa9\xbe\x83\x86\x88\
+            \\x0e\x08\x04\xe9\x55\xf1\xbe\x56\xe7\xe5\x36\x3b\xb3\xa1\xf2\x5d\xf7\xde\xbb\x85\x61\xfe\x03\x3c\x16\x74\x62\x33\x3c\x03\x4c\x28\
+            \\xda\x6d\x0c\x74\x79\xaa\xc5\x6c\x3c\xe4\xe1\xad\x51\xf0\xc8\x02\x98\xf8\xf3\x5a\x16\x26\xa4\x9f\xee\xd8\x2b\x29\x1d\x38\x2f\xe3\
+            \\x0c\x4f\xb9\x9a\xbb\x32\x57\x78\x3e\xc6\xd9\x7b\x6e\x77\xa6\xa9\xcb\x65\x8b\x5c\xd4\x52\x30\xc7\x2b\xd1\x40\x8b\x60\xc0\x3e\xb7\
+            \\xb9\x06\x8d\x78\xa3\x37\x54\xf4\xf4\x30\xc8\x7d\xc8\xa7\x13\x02\xb9\x6d\x8c\x32\xeb\xd4\xe7\xbe\xbe\x8b\x9d\x2d\x79\x79\xfb\x06\
+            \\xe7\x22\x53\x08\x8b\x75\xcf\x77\x11\xef\x8d\xa4\xe0\x83\xc8\x58\x8d\x6b\x78\x6f\x5a\x63\x17\xa6\xfa\x5c\xf7\xa0\x5d\xda\x00\x33\
+            \\xf2\x8e\xbf\xb0\xf5\xb9\xc3\x10\xa0\xea\xc2\x80\x08\xb9\x76\x7a\xa3\xd9\xd2\xb0\x79\xd3\x42\x17\x02\x1a\x71\x8d\x9a\xc6\x33\x6a\
+            \\x27\x11\xfd\x60\x43\x80\x50\xe3\x06\x99\x08\xa8\x3d\x7f\xed\xc4\x82\x6d\x2b\xef\x4e\xeb\x84\x76\x48\x8d\xcf\x25\x36\xc9\xd5\x66\
+            \\x28\xe7\x4e\x41\xc2\x61\x0a\xca\x3d\x49\xa9\xcf\xba\xe3\xb9\xdf\xb6\x5f\x8d\xe6\x92\xae\xaf\x64\x3a\xc7\xd5\xe6\x9e\xa8\x05\x09\
+            \\xf2\x2b\x01\x7d\xa4\x17\x3f\x70\xdd\x1e\x16\xc3\x15\xe0\xd7\xf9\x50\xb1\xb8\x87\x2b\x9f\x4f\xd5\x62\x5a\xba\x82\x6a\x01\x79\x62\
+            \\x2e\xc0\x1b\x9c\x15\x48\x8a\xa9\xd7\x16\xe7\x40\x40\x05\x5a\x2c\x93\xd2\x9a\x22\xe3\x2d\xbf\x9a\x05\x87\x45\xb9\x34\x53\xdc\x1e\
+            \\xd6\x99\x29\x6e\x49\x6c\xff\x6f\x1c\x9f\x49\x86\xdf\xe2\xed\x07\xb8\x72\x42\xd1\x19\xde\x7e\xae\x05\x3e\x56\x1a\x15\xad\x6f\x8c\
+            \\x66\x62\x6c\x1c\x71\x54\xc2\x4c\xea\x08\x2b\x2a\x93\xeb\x29\x39\x17\xdc\xb0\xf0\x58\xd4\xf2\xae\x9e\xa2\x94\xfb\x52\xcf\x56\x4c\
+            \\x98\x83\xfe\x66\x2e\xc4\x05\x81\x76\x39\x53\xc3\x01\xd6\x69\x2e\xd3\xa0\xc1\x08\xa1\xe7\x16\x0e\xe4\xf2\xdf\xa6\x69\x3e\xd2\x85\
+            \\x74\x90\x46\x98\x4c\x2b\x0e\xdd\x4f\x75\x76\x56\x5d\x39\x33\x78\xa1\x32\x23\x4f\x3d\x32\x1c\x5d\xc3\xf5\xe1\x94\x4b\x26\x93\x01\
+            \\xc7\x9f\x02\x2f\x3c\x99\x7e\x7e\x5e\x4f\x95\x04\x3f\xfa\xfb\xbd\x76\xf7\xad\x0e\x29\x66\x93\xf4\x3d\x1f\xce\x6f\xc6\x1e\x45\xbe\
+            \\xd3\xb5\xab\x34\xf7\x2b\xf9\xb7\x1b\x04\x34\xc0\x4e\x72\xb5\x67\x55\x92\xa3\x3d\xb5\x22\x93\x01\xcf\xd2\xa8\x7f\x60\xae\xb7\x67\
+            \\x18\x14\x38\x6b\x30\xbc\xc3\x3d\x38\xa0\xc0\x7d\xfd\x16\x06\xf2\xc3\x63\x51\x9b\x58\x9d\xd3\x90\x54\x79\xf8\xe6\x1c\xb8\xd6\x47\
+            \\x97\xfd\x61\xa9\xea\x77\x59\xf4\x2d\x57\x53\x9d\x56\x9a\x58\xcf\xe8\x4e\x63\xad\x46\x2e\x1b\x78\x65\x80\xf8\x7e\xf3\x81\x79\x14\
+            \\x91\xda\x55\xf4\x40\xa2\x30\xf3\xd1\x98\x8f\x35\xb6\xe3\x18\xd2\x3f\xfa\x50\xbc\x3d\x40\xf0\x21\xc3\xc0\xbd\xae\x49\x58\xc2\x4c\
+            \\x51\x8f\x36\xb2\x84\xb1\xd3\x70\x0f\xed\xce\x83\x87\x8d\xda\xda\xf2\xa2\x79\xc7\x94\xe0\x1b\xe8\x90\x71\x6f\x4b\x95\x4b\x8a\xa3"#
+
+sbox_s8 :: Word8 -> Word32
+sbox_s8 i = arrayRead32 t (fromIntegral i)
+  where
+    t = array32FromAddrBE 256
+            "\xe2\x16\x30\x0d\xbb\xdd\xff\xfc\xa7\xeb\xda\xbd\x35\x64\x80\x95\x77\x89\xf8\xb7\xe6\xc1\x12\x1b\x0e\x24\x16\x00\x05\x2c\xe8\xb5\
+            \\x11\xa9\xcf\xb0\xe5\x95\x2f\x11\xec\xe7\x99\x0a\x93\x86\xd1\x74\x2a\x42\x93\x1c\x76\xe3\x81\x11\xb1\x2d\xef\x3a\x37\xdd\xdd\xfc\
+            \\xde\x9a\xde\xb1\x0a\x0c\xc3\x2c\xbe\x19\x70\x29\x84\xa0\x09\x40\xbb\x24\x3a\x0f\xb4\xd1\x37\xcf\xb4\x4e\x79\xf0\x04\x9e\xed\xfd\
+            \\x0b\x15\xa1\x5d\x48\x0d\x31\x68\x8b\xbb\xde\x5a\x66\x9d\xed\x42\xc7\xec\xe8\x31\x3f\x8f\x95\xe7\x72\xdf\x19\x1b\x75\x80\x33\x0d\
+            \\x94\x07\x42\x51\x5c\x7d\xcd\xfa\xab\xbe\x6d\x63\xaa\x40\x21\x64\xb3\x01\xd4\x0a\x02\xe7\xd1\xca\x53\x57\x1d\xae\x7a\x31\x82\xa2\
+            \\x12\xa8\xdd\xec\xfd\xaa\x33\x5d\x17\x6f\x43\xe8\x71\xfb\x46\xd4\x38\x12\x90\x22\xce\x94\x9a\xd4\xb8\x47\x69\xad\x96\x5b\xd8\x62\
+            \\x82\xf3\xd0\x55\x66\xfb\x97\x67\x15\xb8\x0b\x4e\x1d\x5b\x47\xa0\x4c\xfd\xe0\x6f\xc2\x8e\xc4\xb8\x57\xe8\x72\x6e\x64\x7a\x78\xfc\
+            \\x99\x86\x5d\x44\x60\x8b\xd5\x93\x6c\x20\x0e\x03\x39\xdc\x5f\xf6\x5d\x0b\x00\xa3\xae\x63\xaf\xf2\x7e\x8b\xd6\x32\x70\x10\x8c\x0c\
+            \\xbb\xd3\x50\x49\x29\x98\xdf\x04\x98\x0c\xf4\x2a\x9b\x6d\xf4\x91\x9e\x7e\xdd\x53\x06\x91\x85\x48\x58\xcb\x7e\x07\x3b\x74\xef\x2e\
+            \\x52\x2f\xff\xb1\xd2\x47\x08\xcc\x1c\x7e\x27\xcd\xa4\xeb\x21\x5b\x3c\xf1\xd2\xe2\x19\xb4\x7a\x38\x42\x4f\x76\x18\x35\x85\x60\x39\
+            \\x9d\x17\xde\xe7\x27\xeb\x35\xe6\xc9\xaf\xf6\x7b\x36\xba\xf5\xb8\x09\xc4\x67\xcd\xc1\x89\x10\xb1\xe1\x1d\xbf\x7b\x06\xcd\x1a\xf8\
+            \\x71\x70\xc6\x08\x2d\x5e\x33\x54\xd4\xde\x49\x5a\x64\xc6\xd0\x06\xbc\xc0\xc6\x2c\x3d\xd0\x0d\xb3\x70\x8f\x8f\x34\x77\xd5\x1b\x42\
+            \\x26\x4f\x62\x0f\x24\xb8\xd2\xbf\x15\xc1\xb7\x9e\x46\xa5\x25\x64\xf8\xd7\xe5\x4e\x3e\x37\x81\x60\x78\x95\xcd\xa5\x85\x9c\x15\xa5\
+            \\xe6\x45\x97\x88\xc3\x7b\xc7\x5f\xdb\x07\xba\x0c\x06\x76\xa3\xab\x7f\x22\x9b\x1e\x31\x84\x2e\x7b\x24\x25\x9f\xd7\xf8\xbe\xf4\x72\
+            \\x83\x5f\xfc\xb8\x6d\xf4\xc1\xf2\x96\xf5\xb1\x95\xfd\x0a\xf0\xfc\xb0\xfe\x13\x4c\xe2\x50\x6d\x3d\x4f\x9b\x12\xea\xf2\x15\xf2\x25\
+            \\xa2\x23\x73\x6f\x9f\xb4\xc4\x28\x25\xd0\x49\x79\x34\xc7\x13\xf8\xc4\x61\x81\x87\xea\x7a\x6e\x98\x7c\xd1\x6e\xfc\x14\x36\x87\x6c\
+            \\xf1\x54\x41\x07\xbe\xde\xee\x14\x56\xe9\xaf\x27\xa0\x4a\xa4\x41\x3c\xf7\xc8\x99\x92\xec\xba\xe6\xdd\x67\x01\x6d\x15\x16\x82\xeb\
+            \\xa8\x42\xee\xdf\xfd\xba\x60\xb4\xf1\x90\x7b\x75\x20\xe3\x03\x0f\x24\xd8\xc2\x9e\xe1\x39\x67\x3b\xef\xa6\x3f\xb8\x71\x87\x30\x54\
+            \\xb6\xf2\xcf\x3b\x9f\x32\x64\x42\xcb\x15\xa4\xcc\xb0\x1a\x45\x04\xf1\xe4\x7d\x8d\x84\x4a\x1b\xe5\xba\xe7\xdf\xdc\x42\xcb\xda\x70\
+            \\xcd\x7d\xae\x0a\x57\xe8\x5b\x7a\xd5\x3f\x5a\xf6\x20\xcf\x4d\x8c\xce\xa4\xd4\x28\x79\xd1\x30\xa4\x34\x86\xeb\xfb\x33\xd3\xcd\xdc\
+            \\x77\x85\x3b\x53\x37\xef\xfc\xb5\xc5\x06\x87\x78\xe5\x80\xb3\xe6\x4e\x68\xb8\xf4\xc5\xc8\xb3\x7e\x0d\x80\x9e\xa2\x39\x8f\xeb\x7c\
+            \\x13\x2a\x4f\x94\x43\xb7\x95\x0e\x2f\xee\x7d\x1c\x22\x36\x13\xbd\xdd\x06\xca\xa2\x37\xdf\x93\x2b\xc4\x24\x82\x89\xac\xf3\xeb\xc3\
+            \\x57\x15\xf6\xb7\xef\x34\x78\xdd\xf2\x67\x61\x6f\xc1\x48\xcb\xe4\x90\x52\x81\x5e\x5e\x41\x0f\xab\xb4\x8a\x24\x65\x2e\xda\x7f\xa4\
+            \\xe8\x7b\x40\xe4\xe9\x8e\xa0\x84\x58\x89\xe9\xe1\xef\xd3\x90\xfc\xdd\x07\xd3\x5b\xdb\x48\x56\x94\x38\xd7\xe5\xb2\x57\x72\x01\x01\
+            \\x73\x0e\xde\xbc\x5b\x64\x31\x13\x94\x91\x7e\x4f\x50\x3c\x2f\xba\x64\x6f\x12\x82\x75\x23\xd2\x4a\xe0\x77\x96\x95\xf9\xc1\x7a\x8f\
+            \\x7a\x5b\x21\x21\xd1\x87\xb8\x96\x29\x26\x3a\x4d\xba\x51\x0c\xdf\x81\xf4\x7c\x9f\xad\x11\x63\xed\xea\x7b\x59\x65\x1a\x00\x72\x6e\
+            \\x11\x40\x30\x92\x00\xda\x6d\x77\x4a\x0c\xdd\x61\xad\x1f\x46\x03\x60\x5b\xdf\xb0\x9e\xed\xc3\x64\x22\xeb\xe6\xa8\xce\xe7\xd2\x8a\
+            \\xa0\xe7\x36\xa0\x55\x64\xa6\xb9\x10\x85\x32\x09\xc7\xeb\x8f\x37\x2d\xe7\x05\xca\x89\x51\x57\x0f\xdf\x09\x82\x2b\xbd\x69\x1a\x6c\
+            \\xaa\x12\xe4\xf2\x87\x45\x1c\x0f\xe0\xf6\xa2\x7a\x3a\xda\x48\x19\x4c\xf1\x76\x4f\x0d\x77\x1c\x2b\x67\xcd\xb1\x56\x35\x0d\x83\x84\
+            \\x59\x38\xfa\x0f\x42\x39\x9e\xf3\x36\x99\x7b\x07\x0e\x84\x09\x3d\x4a\xa9\x3e\x61\x83\x60\xd8\x7b\x1f\xa9\x8b\x0c\x11\x49\x38\x2c\
+            \\xe9\x76\x25\xa5\x06\x14\xd1\xb7\x0e\x25\x24\x4b\x0c\x76\x83\x47\x58\x9e\x8d\x82\x0d\x20\x59\xd1\xa4\x66\xbb\x1e\xf8\xda\x0a\x82\
+            \\x04\xf1\x91\x30\xba\x6e\x4e\xc0\x99\x26\x51\x64\x1e\xe7\x23\x0d\x50\xb2\xad\x80\xea\xee\x68\x01\x8d\xb2\xa2\x83\xea\x8b\xf5\x9e"#

Crypto/Cipher/Camellia/Primitive.hs

@@ -6,8 +6,8 @@
 -- Stability   : experimental
 -- Portability : Good
 --
--- this only cover Camellia 128 bits for now, API will change once
--- 192 and 256 mode are implemented too
+-- This only cover Camellia 128 bits for now. The API will change once
+-- 192 and 256 mode are implemented too.
 {-# LANGUAGE MagicHash #-}
 module Crypto.Cipher.Camellia.Primitive
     ( Camellia

Crypto/Cipher/ChaCha.hs

@@ -12,7 +12,7 @@ module Crypto.Cipher.ChaCha
     , combine
     , generate
     , State
-    -- * simple interface for DRG purpose
+    -- * Simple interface for DRG purpose
     , initializeSimple
     , generateSimple
     , StateSimple
@@ -41,24 +41,26 @@ initialize :: (ByteArrayAccess key, ByteArrayAccess nonce)
            -> nonce -- ^ the nonce (64 or 96 bits)
            -> State -- ^ the initial ChaCha state
 initialize nbRounds key nonce
-    | not (kLen `elem` [16,32])       = error "ChaCha: key length should be 128 or 256 bits"
-    | not (nonceLen `elem` [8,12])    = error "ChaCha: nonce length should be 64 or 96 bits"
-    | not (nbRounds `elem` [8,12,20]) = error "ChaCha: rounds should be 8, 12 or 20"
+    | kLen `notElem` [16,32]          = error "ChaCha: key length should be 128 or 256 bits"
+    | nonceLen `notElem` [8,12]       = error "ChaCha: nonce length should be 64 or 96 bits"
+    | nbRounds `notElem` [8,12,20]    = error "ChaCha: rounds should be 8, 12 or 20"
     | otherwise                       = unsafeDoIO $ do
         stPtr <- B.alloc 132 $ \stPtr ->
             B.withByteArray nonce $ \noncePtr  ->
             B.withByteArray key   $ \keyPtr ->
-                ccryptonite_chacha_init stPtr (fromIntegral nbRounds) kLen keyPtr nonceLen noncePtr
+                ccryptonite_chacha_init stPtr  nbRounds kLen keyPtr nonceLen noncePtr
         return $ State stPtr
   where kLen     = B.length key
         nonceLen = B.length nonce
 
 -- | Initialize simple ChaCha State
-initializeSimple :: ByteArray seed
+--
+-- The seed need to be at least 40 bytes long
+initializeSimple :: ByteArrayAccess seed
                  => seed -- ^ a 40 bytes long seed
                  -> StateSimple
 initializeSimple seed
-    | sLen /= 40 = error "ChaCha Random: seed length should be 40 bytes"
+    | sLen < 40 = error "ChaCha Random: seed length should be 40 bytes"
     | otherwise = unsafeDoIO $ do
         stPtr <- B.alloc 64 $ \stPtr ->
                     B.withByteArray seed $ \seedPtr ->

Crypto/Cipher/ChaChaPoly1305.hs

@@ -5,15 +5,42 @@
 -- Stability   : stable
 -- Portability : good
 --
--- A simple AEAD scheme using ChaCha20 and Poly1305.
--- 
--- See RFC7539.
+-- A simple AEAD scheme using ChaCha20 and Poly1305. See
+-- <https://tools.ietf.org/html/rfc7539 RFC 7539>.
+--
+-- The State is not modified in place, so each function changing the State,
+-- returns a new State.
+--
+-- Authenticated Data need to be added before any call to 'encrypt' or 'decrypt',
+-- and once all the data has been added, then 'finalizeAAD' need to be called.
+--
+-- Once 'finalizeAAD' has been called, no further 'appendAAD' call should be make.
+--
+-- >import Data.ByteString.Char8 as B
+-- >import Data.ByteArray
+-- >import Crypto.Error
+-- >import Crypto.Cipher.ChaChaPoly1305 as C
+-- >
+-- >encrypt
+-- >    :: ByteString -- nonce (12 random bytes)
+-- >    -> ByteString -- symmetric key
+-- >    -> ByteString -- optional associated data (won't be encrypted)
+-- >    -> ByteString -- input plaintext to be encrypted
+-- >    -> CryptoFailable ByteString -- ciphertext with a 128-bit tag attached
+-- >encrypt nonce key header plaintext = do
+-- >    st1 <- C.nonce12 nonce >>= C.initialize key
+-- >    let
+-- >        st2 = C.finalizeAAD $ C.appendAAD header st1
+-- >        (out, st3) = C.encrypt plaintext st2
+-- >        auth = C.finalize st3
+-- >    return $ out `B.append` Data.ByteArray.convert auth
 --
 module Crypto.Cipher.ChaChaPoly1305
     ( State
     , Nonce
     , nonce12
     , nonce8
+    , incrementNonce
     , initialize
     , appendAAD
     , finalizeAAD
@@ -22,6 +49,7 @@ module Crypto.Cipher.ChaChaPoly1305
     , finalize
     ) where
 
+import           Control.Monad             (when)
 import           Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray, Bytes, ScrubbedBytes)
 import qualified Crypto.Internal.ByteArray as B
 import           Crypto.Internal.Imports
@@ -30,13 +58,28 @@ import qualified Crypto.Cipher.ChaCha as ChaCha
 import qualified Crypto.MAC.Poly1305  as Poly1305
 import           Data.Memory.Endian
 import qualified Data.ByteArray.Pack as P
+import           Foreign.Ptr
+import           Foreign.Storable
 
+-- | A ChaChaPoly1305 State.
+--
+-- The state is immutable, and only new state can be created
 data State = State !ChaCha.State
                    !Poly1305.State
                    !Word64 -- AAD length
                    !Word64 -- ciphertext length
 
-newtype Nonce = Nonce Bytes
+-- | Valid Nonce for ChaChaPoly1305.
+--
+-- It can be created with 'nonce8' or 'nonce12'
+data Nonce = Nonce8 Bytes | Nonce12 Bytes
+
+instance ByteArrayAccess Nonce where
+  length (Nonce8  n) = B.length n
+  length (Nonce12 n) = B.length n
+
+  withByteArray (Nonce8  n) = B.withByteArray n
+  withByteArray (Nonce12 n) = B.withByteArray n
 
 -- Based on the following pseudo code:
 --
@@ -61,29 +104,60 @@ pad16 n
 -- | Nonce smart constructor 12 bytes IV, nonce constructor
 nonce12 :: ByteArrayAccess iv => iv -> CryptoFailable Nonce
 nonce12 iv
-    | B.length iv /= 12 = CryptoFailed  $ CryptoError_IvSizeInvalid
-    | otherwise         = CryptoPassed $ Nonce (B.convert iv)
+    | B.length iv /= 12 = CryptoFailed CryptoError_IvSizeInvalid
+    | otherwise         = CryptoPassed . Nonce12 . B.convert $ iv
 
 -- | 8 bytes IV, nonce constructor
 nonce8 :: ByteArrayAccess ba
-       => ba -- ^ 4 bytes constant 
+       => ba -- ^ 4 bytes constant
        -> ba -- ^ 8 bytes IV
        -> CryptoFailable Nonce
 nonce8 constant iv
-    | B.length constant /= 4 = CryptoFailed $ CryptoError_IvSizeInvalid
-    | B.length iv       /= 8 = CryptoFailed $ CryptoError_IvSizeInvalid
-    | otherwise              = CryptoPassed $ Nonce $ B.concat [constant, iv]
+    | B.length constant /= 4 = CryptoFailed CryptoError_IvSizeInvalid
+    | B.length iv       /= 8 = CryptoFailed CryptoError_IvSizeInvalid
+    | otherwise              = CryptoPassed . Nonce8 . B.concat $ [constant, iv]
 
+-- | Increment a nonce
+incrementNonce :: Nonce -> Nonce
+incrementNonce (Nonce8  n) = Nonce8  $ incrementNonce' n 4
+incrementNonce (Nonce12 n) = Nonce12 $ incrementNonce' n 0
+
+incrementNonce' :: Bytes -> Int -> Bytes
+incrementNonce' b offset = B.copyAndFreeze b $ \s ->
+    loop s (s `plusPtr` offset)
+    where
+      loop :: Ptr Word8 -> Ptr Word8 -> IO ()
+      loop s p
+          | s == (p `plusPtr` (B.length b - offset - 1)) = peek s >>= poke s . (+) 1
+          | otherwise = do
+              r <- (+) 1 <$> peek p
+              poke p r
+              when (r == 0) $ loop s (p `plusPtr` 1)
+
+-- | Initialize a new ChaChaPoly1305 State
+--
+-- The key length need to be 256 bits, and the nonce
+-- procured using either `nonce8` or `nonce12`
 initialize :: ByteArrayAccess key
            => key -> Nonce -> CryptoFailable State
-initialize key (Nonce nonce)
-    | B.length key /= 32 = CryptoFailed $ CryptoError_KeySizeInvalid
+initialize key (Nonce8  nonce) = initialize' key nonce
+initialize key (Nonce12 nonce) = initialize' key nonce
+
+initialize' :: ByteArrayAccess key
+            => key -> Bytes -> CryptoFailable State
+initialize' key nonce
+    | B.length key /= 32 = CryptoFailed CryptoError_KeySizeInvalid
     | otherwise          = CryptoPassed $ State encState polyState 0 0
   where
     rootState           = ChaCha.initialize 20 key nonce
     (polyKey, encState) = ChaCha.generate rootState 64
     polyState           = throwCryptoError $ Poly1305.initialize (B.take 32 polyKey :: ScrubbedBytes)
 
+-- | Append Authenticated Data to the State and return
+-- the new modified State.
+--
+-- Once no further call to this function need to be make,
+-- the user should call 'finalizeAAD'
 appendAAD :: ByteArrayAccess ba => ba -> State -> State
 appendAAD ba (State encState macState aadLength plainLength) =
     State encState newMacState newLength plainLength
@@ -91,12 +165,15 @@ appendAAD ba (State encState macState aadLength plainLength) =
     newMacState = Poly1305.update macState ba
     newLength   = aadLength + fromIntegral (B.length ba)
 
+-- | Finalize the Authenticated Data and return the finalized State
 finalizeAAD :: State -> State
 finalizeAAD (State encState macState aadLength plainLength) =
     State encState newMacState aadLength plainLength
   where
     newMacState = Poly1305.update macState $ pad16 aadLength
 
+-- | Encrypt a piece of data and returns the encrypted Data and the
+-- updated State.
 encrypt :: ByteArray ba => ba -> State -> (ba, State)
 encrypt input (State encState macState aadLength plainLength) =
     (output, State newEncState newMacState aadLength newPlainLength)
@@ -105,6 +182,8 @@ encrypt input (State encState macState aadLength plainLength) =
     newMacState           = Poly1305.update macState output
     newPlainLength        = plainLength + fromIntegral (B.length input)
 
+-- | Decrypt a piece of data and returns the decrypted Data and the
+-- updated State.
 decrypt :: ByteArray ba => ba -> State -> (ba, State)
 decrypt input (State encState macState aadLength plainLength) =
     (output, State newEncState newMacState aadLength newPlainLength)
@@ -113,9 +192,10 @@ decrypt input (State encState macState aadLength plainLength) =
     newMacState           = Poly1305.update macState input
     newPlainLength        = plainLength + fromIntegral (B.length input)
 
+-- | Generate an authentication tag from the State.
 finalize :: State -> Poly1305.Auth
 finalize (State _ macState aadLength plainLength) =
     Poly1305.finalize $ Poly1305.updates macState
         [ pad16 plainLength
-        , either (error "finalize: internal error") id $ P.fill 16 (P.putStorable (LE aadLength) >> P.putStorable (LE plainLength))
+        , either (error "finalize: internal error") id $ P.fill 16 (P.putStorable (toLE aadLength) >> P.putStorable (toLE plainLength))
         ]

Crypto/Cipher/RC4.hs

@@ -30,6 +30,11 @@ import           Crypto.Internal.Compat
 import           Crypto.Internal.Imports
 
 -- | The encryption state for RC4
+--
+-- This type is an instance of 'ByteArrayAccess' for debugging purpose. Internal
+-- layout is architecture dependent, may contain uninitialized data fragments,
+-- and change in future versions.  The bytearray should not be used as input to
+-- cryptographic algorithms.
 newtype State = State ScrubbedBytes
     deriving (ByteArrayAccess,NFData)
 

Crypto/Cipher/Salsa.hs

@@ -11,7 +11,7 @@ module Crypto.Cipher.Salsa
     ( initialize
     , combine
     , generate
-    , State
+    , State(..)
     ) where
 
 import           Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray, ScrubbedBytes)
@@ -33,14 +33,14 @@ initialize :: (ByteArrayAccess key, ByteArrayAccess nonce)
            -> nonce  -- ^ the nonce (64 or 96 bits)
            -> State  -- ^ the initial Salsa state
 initialize nbRounds key nonce
-    | not (kLen `elem` [16,32])       = error "Salsa: key length should be 128 or 256 bits"
-    | not (nonceLen `elem` [8,12])    = error "Salsa: nonce length should be 64 or 96 bits"
-    | not (nbRounds `elem` [8,12,20]) = error "Salsa: rounds should be 8, 12 or 20"
+    | kLen `notElem` [16,32]          = error "Salsa: key length should be 128 or 256 bits"
+    | nonceLen `notElem` [8,12]       = error "Salsa: nonce length should be 64 or 96 bits"
+    | nbRounds `notElem` [8,12,20]    = error "Salsa: rounds should be 8, 12 or 20"
     | otherwise = unsafeDoIO $ do
         stPtr <- B.alloc 132 $ \stPtr ->
             B.withByteArray nonce $ \noncePtr  ->
             B.withByteArray key   $ \keyPtr ->
-                ccryptonite_salsa_init stPtr (fromIntegral nbRounds) kLen keyPtr nonceLen noncePtr
+                ccryptonite_salsa_init stPtr nbRounds kLen keyPtr nonceLen noncePtr
         return $ State stPtr
   where kLen     = B.length key
         nonceLen = B.length nonce

Crypto/Cipher/Twofish.hs

@@ -0,0 +1,45 @@
+module Crypto.Cipher.Twofish
+    ( Twofish128
+    , Twofish192
+    , Twofish256
+    ) where
+
+import Crypto.Cipher.Twofish.Primitive
+import Crypto.Cipher.Types
+import Crypto.Cipher.Utils
+
+newtype Twofish128 = Twofish128 Twofish
+
+instance Cipher Twofish128 where
+    cipherName    _ = "Twofish128"
+    cipherKeySize _ = KeySizeFixed 16
+    cipherInit key  = Twofish128 <$> (initTwofish =<< validateKeySize (undefined :: Twofish128) key)
+
+instance BlockCipher Twofish128 where
+    blockSize                 _ = 16
+    ecbEncrypt (Twofish128 key) = encrypt key
+    ecbDecrypt (Twofish128 key) = decrypt key
+
+newtype Twofish192 = Twofish192 Twofish
+
+instance Cipher Twofish192 where
+    cipherName    _ = "Twofish192"
+    cipherKeySize _ = KeySizeFixed 24
+    cipherInit key  = Twofish192 <$> (initTwofish =<< validateKeySize (undefined :: Twofish192) key)
+
+instance BlockCipher Twofish192 where
+    blockSize                 _ = 16
+    ecbEncrypt (Twofish192 key) = encrypt key
+    ecbDecrypt (Twofish192 key) = decrypt key
+
+newtype Twofish256 = Twofish256 Twofish
+
+instance Cipher Twofish256 where
+    cipherName    _ = "Twofish256"
+    cipherKeySize _ = KeySizeFixed 32
+    cipherInit key  = Twofish256 <$> (initTwofish =<< validateKeySize (undefined :: Twofish256) key)
+
+instance BlockCipher Twofish256 where
+    blockSize                 _ = 16
+    ecbEncrypt (Twofish256 key) = encrypt key
+    ecbDecrypt (Twofish256 key) = decrypt key

Crypto/Cipher/Twofish/Primitive.hs

@@ -0,0 +1,311 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE BangPatterns #-}
+module Crypto.Cipher.Twofish.Primitive
+    ( Twofish
+    , initTwofish
+    , encrypt
+    , decrypt
+    ) where
+
+import           Crypto.Error
+import           Crypto.Internal.ByteArray (ByteArray)
+import qualified Crypto.Internal.ByteArray as B
+import           Crypto.Internal.WordArray
+import           Data.Word
+import           Data.Bits
+import           Data.List
+
+-- Based on the Golang referance implementation
+-- https://github.com/golang/crypto/blob/master/twofish/twofish.go
+
+
+-- BlockSize is the constant block size of Twofish.
+blockSize :: Int
+blockSize = 16
+
+mdsPolynomial, rsPolynomial :: Word32
+mdsPolynomial = 0x169 -- x^8 + x^6 + x^5 + x^3 + 1, see [TWOFISH] 4.2
+rsPolynomial = 0x14d  -- x^8 + x^6 + x^3 + x^2 + 1, see [TWOFISH] 4.3
+
+data Twofish = Twofish { s :: (Array32, Array32, Array32, Array32)
+                       , k :: Array32 }
+
+data ByteSize = Bytes16 | Bytes24 | Bytes32 deriving (Eq)
+
+data KeyPackage ba = KeyPackage { rawKeyBytes :: ba
+                                , byteSize :: ByteSize }
+
+buildPackage :: ByteArray ba => ba -> Maybe (KeyPackage ba)
+buildPackage key
+    | B.length key == 16 = return $ KeyPackage key Bytes16
+    | B.length key == 24 = return $ KeyPackage key Bytes24
+    | B.length key == 32 = return $ KeyPackage key Bytes32
+    | otherwise = Nothing
+
+-- | Initialize a 128-bit, 192-bit, or 256-bit key
+--
+-- Return the initialized key or a error message if the given
+-- keyseed was not 16-bytes in length.
+initTwofish :: ByteArray key
+            => key -- ^ The key to create the twofish context
+            -> CryptoFailable Twofish
+initTwofish key =
+    case buildPackage key of Nothing -> CryptoFailed CryptoError_KeySizeInvalid
+                             Just keyPackage -> CryptoPassed Twofish { k = generatedK, s = generatedS }
+                                  where generatedK = array32 40 $ genK keyPackage
+                                        generatedS = genSboxes keyPackage $ sWords key
+
+mapBlocks :: ByteArray ba => (ba -> ba) -> ba -> ba
+mapBlocks operation input
+    | B.null rest = blockOutput
+    | otherwise = blockOutput `B.append` mapBlocks operation rest
+        where (block, rest) = B.splitAt blockSize input
+              blockOutput = operation block
+
+-- | Encrypts the given ByteString using the given Key
+encrypt :: ByteArray ba
+        => Twofish     -- ^ The key to use
+        -> ba           -- ^ The data to encrypt
+        -> ba
+encrypt cipher = mapBlocks (encryptBlock cipher)
+
+encryptBlock :: ByteArray ba => Twofish -> ba -> ba
+encryptBlock Twofish { s = (s1, s2, s3, s4), k = ks } message = store32ls ts
+    where (a, b, c, d) = load32ls message
+          a' = a `xor` arrayRead32 ks 0
+          b' = b `xor` arrayRead32 ks 1
+          c' = c `xor` arrayRead32 ks 2
+          d' = d `xor` arrayRead32 ks 3
+          (!a'', !b'', !c'', !d'') = foldl' shuffle (a', b', c', d') [0..7]
+          ts = (c'' `xor` arrayRead32 ks 4, d'' `xor` arrayRead32 ks 5, a'' `xor` arrayRead32 ks 6, b'' `xor` arrayRead32 ks 7)
+
+          shuffle :: (Word32, Word32, Word32, Word32) -> Int -> (Word32, Word32, Word32, Word32)
+          shuffle (!retA, !retB, !retC, !retD) ind = (retA', retB', retC', retD')
+            where [k0, k1, k2, k3] = fmap (\offset -> arrayRead32 ks $ (8 + 4 * ind) + offset) [0..3]
+                  t2 = byteIndex s2 retB `xor` byteIndex s3 (shiftR retB 8) `xor` byteIndex s4 (shiftR retB 16) `xor` byteIndex s1 (shiftR retB 24)
+                  t1 = (byteIndex s1 retA `xor` byteIndex s2 (shiftR retA 8) `xor` byteIndex s3 (shiftR retA 16) `xor` byteIndex s4 (shiftR retA 24)) + t2
+                  retC' = rotateR (retC `xor` (t1 + k0)) 1
+                  retD' = rotateL retD 1 `xor` (t1 + t2 + k1)
+                  t2' = byteIndex s2 retD' `xor` byteIndex s3 (shiftR retD' 8) `xor` byteIndex s4 (shiftR retD' 16) `xor` byteIndex s1 (shiftR retD' 24)
+                  t1' = (byteIndex s1 retC' `xor` byteIndex s2 (shiftR retC' 8) `xor` byteIndex s3 (shiftR retC' 16) `xor` byteIndex s4 (shiftR retC' 24)) + t2'
+                  retA' = rotateR (retA `xor` (t1' + k2)) 1
+                  retB' = rotateL retB 1 `xor` (t1' + t2' + k3)
+
+-- Unsafe, no bounds checking
+byteIndex :: Array32 -> Word32 -> Word32
+byteIndex xs ind  = arrayRead32 xs $ fromIntegral byte
+    where byte = ind `mod` 256
+
+-- | Decrypts the given ByteString using the given Key
+decrypt :: ByteArray ba
+        => Twofish     -- ^ The key to use
+        -> ba           -- ^ The data to decrypt
+        -> ba
+decrypt cipher = mapBlocks (decryptBlock cipher)
+
+{- decryption for 128 bits blocks -}
+decryptBlock :: ByteArray ba => Twofish -> ba -> ba
+decryptBlock Twofish { s = (s1, s2, s3, s4), k = ks } message = store32ls ixs
+    where (a, b, c, d) = load32ls message
+          a' = c `xor` arrayRead32 ks 6
+          b' = d `xor` arrayRead32 ks 7
+          c' = a `xor` arrayRead32 ks 4
+          d' = b `xor` arrayRead32 ks 5
+          (!a'', !b'', !c'', !d'') = foldl' unshuffle (a', b', c', d') [8, 7..1]
+          ixs = (a'' `xor` arrayRead32 ks 0, b'' `xor` arrayRead32 ks 1, c'' `xor` arrayRead32 ks 2, d'' `xor` arrayRead32 ks 3)
+
+          unshuffle :: (Word32, Word32, Word32, Word32) -> Int -> (Word32, Word32, Word32, Word32)
+          unshuffle (!retA, !retB, !retC, !retD) ind = (retA', retB', retC', retD')
+            where [k0, k1, k2, k3] = fmap (\offset -> arrayRead32 ks $ (4 + 4 * ind) + offset) [0..3]
+                  t2 = byteIndex s2 retD `xor` byteIndex s3 (shiftR retD 8) `xor` byteIndex s4 (shiftR retD 16) `xor` byteIndex s1 (shiftR retD 24)
+                  t1 = (byteIndex s1 retC `xor` byteIndex s2 (shiftR retC 8) `xor` byteIndex s3 (shiftR retC 16) `xor` byteIndex s4 (shiftR retC 24)) + t2
+                  retA' = rotateL retA 1 `xor` (t1 + k2)
+                  retB' = rotateR (retB `xor` (t2 + t1 + k3)) 1
+                  t2' = byteIndex s2 retB' `xor` byteIndex s3 (shiftR retB' 8) `xor` byteIndex s4 (shiftR retB' 16) `xor` byteIndex s1 (shiftR retB' 24)
+                  t1' = (byteIndex s1 retA' `xor` byteIndex s2 (shiftR retA' 8) `xor` byteIndex s3 (shiftR retA' 16) `xor` byteIndex s4 (shiftR retA' 24)) + t2'
+                  retC' = rotateL retC 1 `xor` (t1' + k0)
+                  retD' = rotateR (retD `xor` (t2' + t1' + k1)) 1
+
+sbox0 :: Int -> Word8
+sbox0 = arrayRead8 t
+    where t = array8
+            "\xa9\x67\xb3\xe8\x04\xfd\xa3\x76\x9a\x92\x80\x78\xe4\xdd\xd1\x38\
+            \\x0d\xc6\x35\x98\x18\xf7\xec\x6c\x43\x75\x37\x26\xfa\x13\x94\x48\
+            \\xf2\xd0\x8b\x30\x84\x54\xdf\x23\x19\x5b\x3d\x59\xf3\xae\xa2\x82\
+            \\x63\x01\x83\x2e\xd9\x51\x9b\x7c\xa6\xeb\xa5\xbe\x16\x0c\xe3\x61\
+            \\xc0\x8c\x3a\xf5\x73\x2c\x25\x0b\xbb\x4e\x89\x6b\x53\x6a\xb4\xf1\
+            \\xe1\xe6\xbd\x45\xe2\xf4\xb6\x66\xcc\x95\x03\x56\xd4\x1c\x1e\xd7\
+            \\xfb\xc3\x8e\xb5\xe9\xcf\xbf\xba\xea\x77\x39\xaf\x33\xc9\x62\x71\
+            \\x81\x79\x09\xad\x24\xcd\xf9\xd8\xe5\xc5\xb9\x4d\x44\x08\x86\xe7\
+            \\xa1\x1d\xaa\xed\x06\x70\xb2\xd2\x41\x7b\xa0\x11\x31\xc2\x27\x90\
+            \\x20\xf6\x60\xff\x96\x5c\xb1\xab\x9e\x9c\x52\x1b\x5f\x93\x0a\xef\
+            \\x91\x85\x49\xee\x2d\x4f\x8f\x3b\x47\x87\x6d\x46\xd6\x3e\x69\x64\
+            \\x2a\xce\xcb\x2f\xfc\x97\x05\x7a\xac\x7f\xd5\x1a\x4b\x0e\xa7\x5a\
+            \\x28\x14\x3f\x29\x88\x3c\x4c\x02\xb8\xda\xb0\x17\x55\x1f\x8a\x7d\
+            \\x57\xc7\x8d\x74\xb7\xc4\x9f\x72\x7e\x15\x22\x12\x58\x07\x99\x34\
+            \\x6e\x50\xde\x68\x65\xbc\xdb\xf8\xc8\xa8\x2b\x40\xdc\xfe\x32\xa4\
+            \\xca\x10\x21\xf0\xd3\x5d\x0f\x00\x6f\x9d\x36\x42\x4a\x5e\xc1\xe0"#
+
+sbox1 :: Int -> Word8
+sbox1 = arrayRead8 t
+    where t = array8
+            "\x75\xf3\xc6\xf4\xdb\x7b\xfb\xc8\x4a\xd3\xe6\x6b\x45\x7d\xe8\x4b\
+            \\xd6\x32\xd8\xfd\x37\x71\xf1\xe1\x30\x0f\xf8\x1b\x87\xfa\x06\x3f\
+            \\x5e\xba\xae\x5b\x8a\x00\xbc\x9d\x6d\xc1\xb1\x0e\x80\x5d\xd2\xd5\
+            \\xa0\x84\x07\x14\xb5\x90\x2c\xa3\xb2\x73\x4c\x54\x92\x74\x36\x51\
+            \\x38\xb0\xbd\x5a\xfc\x60\x62\x96\x6c\x42\xf7\x10\x7c\x28\x27\x8c\
+            \\x13\x95\x9c\xc7\x24\x46\x3b\x70\xca\xe3\x85\xcb\x11\xd0\x93\xb8\
+            \\xa6\x83\x20\xff\x9f\x77\xc3\xcc\x03\x6f\x08\xbf\x40\xe7\x2b\xe2\
+            \\x79\x0c\xaa\x82\x41\x3a\xea\xb9\xe4\x9a\xa4\x97\x7e\xda\x7a\x17\
+            \\x66\x94\xa1\x1d\x3d\xf0\xde\xb3\x0b\x72\xa7\x1c\xef\xd1\x53\x3e\
+            \\x8f\x33\x26\x5f\xec\x76\x2a\x49\x81\x88\xee\x21\xc4\x1a\xeb\xd9\
+            \\xc5\x39\x99\xcd\xad\x31\x8b\x01\x18\x23\xdd\x1f\x4e\x2d\xf9\x48\
+            \\x4f\xf2\x65\x8e\x78\x5c\x58\x19\x8d\xe5\x98\x57\x67\x7f\x05\x64\
+            \\xaf\x63\xb6\xfe\xf5\xb7\x3c\xa5\xce\xe9\x68\x44\xe0\x4d\x43\x69\
+            \\x29\x2e\xac\x15\x59\xa8\x0a\x9e\x6e\x47\xdf\x34\x35\x6a\xcf\xdc\
+            \\x22\xc9\xc0\x9b\x89\xd4\xed\xab\x12\xa2\x0d\x52\xbb\x02\x2f\xa9\
+            \\xd7\x61\x1e\xb4\x50\x04\xf6\xc2\x16\x25\x86\x56\x55\x09\xbe\x91"#
+
+rs :: [[Word8]]
+rs = [ [0x01, 0xA4, 0x55, 0x87, 0x5A, 0x58, 0xDB, 0x9E]
+     , [0xA4, 0x56, 0x82, 0xF3, 0x1E, 0xC6, 0x68, 0xE5]
+     , [0x02, 0xA1, 0xFC, 0xC1, 0x47, 0xAE, 0x3D, 0x19]
+     , [0xA4, 0x55, 0x87, 0x5A, 0x58, 0xDB, 0x9E, 0x03] ]
+
+
+
+load32ls :: ByteArray ba => ba -> (Word32, Word32, Word32, Word32)
+load32ls message = (intify q1, intify q2, intify q3, intify q4)
+    where (half1, half2) = B.splitAt 8 message
+          (q1, q2) = B.splitAt 4 half1
+          (q3, q4) = B.splitAt 4 half2
+
+          intify :: ByteArray ba => ba -> Word32
+          intify bytes = foldl' (\int (!word, !ind) -> int .|. shiftL (fromIntegral word) (ind * 8) ) 0 (zip (B.unpack bytes) [0..])
+
+store32ls :: ByteArray ba => (Word32, Word32, Word32, Word32) -> ba
+store32ls (a, b, c, d) = B.pack $ concatMap splitWordl [a, b, c, d]
+    where splitWordl :: Word32 -> [Word8]
+          splitWordl w = fmap (\ind -> fromIntegral $ shiftR w (8 * ind)) [0..3]
+
+
+-- Create S words
+sWords :: ByteArray ba => ba -> [Word8]
+sWords key = sWord
+    where word64Count = B.length key `div` 2
+          sWord = concatMap (\wordIndex ->
+                        map (\rsRow ->
+                            foldl' (\acc (!rsVal, !colIndex) ->
+                                acc `xor` gfMult rsPolynomial (B.index key $ 8 * wordIndex + colIndex) rsVal
+                                ) 0 (zip rsRow [0..])
+                            ) rs
+                    ) [0..word64Count - 1]
+
+data Column = Zero | One | Two | Three deriving (Show, Eq, Enum, Bounded)
+
+genSboxes :: KeyPackage ba -> [Word8] -> (Array32, Array32, Array32, Array32)
+genSboxes keyPackage ws = (mkArray b0', mkArray b1', mkArray b2', mkArray b3')
+    where range = [0..255]
+          mkArray = array32 256
+          [w0, w1, w2, w3, w4, w5, w6, w7, w8, w9, w10, w11, w12, w13, w14, w15] = take 16 ws
+          (b0', b1', b2', b3') = sboxBySize $ byteSize keyPackage
+
+          sboxBySize :: ByteSize -> ([Word32], [Word32], [Word32], [Word32])
+          sboxBySize Bytes16 = (b0, b1, b2, b3)
+            where !b0 = fmap mapper range
+                    where mapper :: Int -> Word32
+                          mapper byte = mdsColumnMult ((sbox1 . fromIntegral) ((sbox0 . fromIntegral $ sbox0 byte `xor` w0) `xor` w4)) Zero
+                  !b1 = fmap mapper range
+                    where mapper byte = mdsColumnMult ((sbox0 . fromIntegral) ((sbox0 . fromIntegral $ sbox1 byte `xor` w1) `xor` w5)) One
+                  !b2 = fmap mapper range
+                    where mapper byte = mdsColumnMult ((sbox1 . fromIntegral) ((sbox1 . fromIntegral $ sbox0 byte `xor` w2) `xor` w6)) Two
+                  !b3 = fmap mapper range
+                    where mapper byte = mdsColumnMult ((sbox0 . fromIntegral) ((sbox1 . fromIntegral $ sbox1 byte `xor` w3) `xor` w7)) Three
+
+          sboxBySize Bytes24 = (b0, b1, b2, b3)
+            where !b0 = fmap mapper range
+                    where mapper byte = mdsColumnMult ((sbox1 . fromIntegral) ((sbox0 . fromIntegral) ((sbox0 . fromIntegral $ sbox1 byte `xor` w0) `xor` w4) `xor` w8)) Zero
+                  !b1 = fmap mapper range
+                    where mapper byte = mdsColumnMult ((sbox0 . fromIntegral) ((sbox0 . fromIntegral) ((sbox1 . fromIntegral $ sbox1 byte `xor` w1) `xor` w5) `xor` w9)) One
+                  !b2 = fmap mapper range
+                    where mapper byte = mdsColumnMult ((sbox1 . fromIntegral) ((sbox1 . fromIntegral) ((sbox0 . fromIntegral $ sbox0 byte `xor` w2) `xor` w6) `xor` w10)) Two
+                  !b3 = fmap mapper range
+                    where mapper byte = mdsColumnMult ((sbox0 . fromIntegral) ((sbox1 . fromIntegral) ((sbox1 . fromIntegral $ sbox0 byte `xor` w3) `xor` w7) `xor` w11)) Three
+
+          sboxBySize Bytes32 = (b0, b1, b2, b3)
+            where !b0 = fmap mapper range
+                    where mapper byte = mdsColumnMult ((sbox1 . fromIntegral) ((sbox0 . fromIntegral) ((sbox0 . fromIntegral) ((sbox1 . fromIntegral $ sbox1 byte `xor` w0) `xor` w4) `xor` w8) `xor` w12)) Zero
+                  !b1 = fmap mapper range
+                    where mapper byte = mdsColumnMult ((sbox0 . fromIntegral) ((sbox0 . fromIntegral) ((sbox1 . fromIntegral) ((sbox1 . fromIntegral $ sbox0 byte `xor` w1) `xor` w5) `xor` w9) `xor` w13)) One
+                  !b2 = fmap mapper range
+                    where mapper byte = mdsColumnMult ((sbox1 . fromIntegral) ((sbox1 . fromIntegral) ((sbox0 . fromIntegral) ((sbox0 . fromIntegral $ sbox0 byte `xor` w2) `xor` w6) `xor` w10) `xor` w14)) Two
+                  !b3 = fmap mapper range
+                    where mapper byte = mdsColumnMult ((sbox0 . fromIntegral) ((sbox1 . fromIntegral) ((sbox1 . fromIntegral) ((sbox0 . fromIntegral $ sbox1 byte `xor` w3) `xor` w7) `xor` w11) `xor` w15)) Three
+
+genK :: (ByteArray ba) => KeyPackage ba -> [Word32]
+genK keyPackage = concatMap makeTuple [0..19]
+    where makeTuple :: Word8 -> [Word32]
+          makeTuple idx = [a + b', rotateL (2 * b' + a) 9]
+            where tmp1 = replicate 4 $ 2 * idx
+                  tmp2 = fmap (+1) tmp1
+                  a = h tmp1 keyPackage 0
+                  b = h tmp2 keyPackage 1
+                  b' = rotateL b 8
+
+h :: (ByteArray ba) => [Word8] -> KeyPackage ba -> Int -> Word32
+h input keyPackage offset =  foldl' xorMdsColMult 0 $ zip [y0f, y1f, y2f, y3f] $ enumFrom Zero
+    where key = rawKeyBytes keyPackage
+          [y0, y1, y2, y3] = take 4 input
+          (!y0f, !y1f, !y2f, !y3f) = run (y0, y1, y2, y3) $ byteSize keyPackage
+
+          run :: (Word8, Word8, Word8, Word8) -> ByteSize -> (Word8, Word8, Word8, Word8)
+          run (!y0'', !y1'', !y2'', !y3'') Bytes32 = run (y0', y1', y2', y3') Bytes24
+            where y0' = sbox1 (fromIntegral y0'') `xor` B.index key (4 * (6 + offset) + 0)
+                  y1' = sbox0 (fromIntegral y1'') `xor` B.index key (4 * (6 + offset) + 1)
+                  y2' = sbox0 (fromIntegral y2'') `xor` B.index key (4 * (6 + offset) + 2)
+                  y3' = sbox1 (fromIntegral y3'') `xor` B.index key (4 * (6 + offset) + 3)
+
+          run (!y0'', !y1'', !y2'', !y3'') Bytes24 = run (y0', y1', y2', y3') Bytes16
+            where y0' = sbox1 (fromIntegral y0'') `xor` B.index key (4 * (4 + offset) + 0)
+                  y1' = sbox1 (fromIntegral y1'') `xor` B.index key (4 * (4 + offset) + 1)
+                  y2' = sbox0 (fromIntegral y2'') `xor` B.index key (4 * (4 + offset) + 2)
+                  y3' = sbox0 (fromIntegral y3'') `xor` B.index key (4 * (4 + offset) + 3)
+
+          run (!y0'', !y1'', !y2'', !y3'') Bytes16 = (y0', y1', y2', y3')
+            where y0' = sbox1 . fromIntegral $ (sbox0 . fromIntegral $ (sbox0 (fromIntegral y0'') `xor` B.index key (4 * (2 + offset) + 0))) `xor` B.index key (4 * (0 + offset) + 0)
+                  y1' = sbox0 . fromIntegral $ (sbox0 . fromIntegral $ (sbox1 (fromIntegral y1'') `xor` B.index key (4 * (2 + offset) + 1))) `xor` B.index key (4 * (0 + offset) + 1)
+                  y2' = sbox1 . fromIntegral $ (sbox1 . fromIntegral $ (sbox0 (fromIntegral y2'') `xor` B.index key (4 * (2 + offset) + 2))) `xor` B.index key (4 * (0 + offset) + 2)
+                  y3' = sbox0 . fromIntegral $ (sbox1 . fromIntegral $ (sbox1 (fromIntegral y3'') `xor` B.index key (4 * (2 + offset) + 3))) `xor` B.index key (4 * (0 + offset) + 3)
+
+          xorMdsColMult :: Word32 -> (Word8, Column) -> Word32
+          xorMdsColMult acc wordAndIndex = acc `xor` uncurry mdsColumnMult wordAndIndex
+
+mdsColumnMult :: Word8 -> Column -> Word32
+mdsColumnMult !byte !col =
+    case col of Zero  -> input .|. rotateL mul5B 8 .|. rotateL mulEF 16 .|. rotateL mulEF 24
+                One   -> mulEF .|. rotateL mulEF 8 .|. rotateL mul5B 16 .|. rotateL input 24
+                Two   -> mul5B .|. rotateL mulEF 8 .|. rotateL input 16 .|. rotateL mulEF 24
+                Three -> mul5B .|. rotateL input 8 .|. rotateL mulEF 16 .|. rotateL mul5B 24
+        where input = fromIntegral byte
+              mul5B = fromIntegral $ gfMult mdsPolynomial byte 0x5B
+              mulEF = fromIntegral $ gfMult mdsPolynomial byte 0xEF
+
+tupInd :: (Bits b) => b -> (a, a) -> a
+tupInd b
+    | testBit b 0 = snd
+    | otherwise = fst
+
+gfMult :: Word32 -> Word8 -> Word8 -> Word8
+gfMult p a b = fromIntegral $ run a b' p' result 0
+    where b' = (0, fromIntegral b)
+          p' = (0, p)
+          result = 0
+
+          run :: Word8 -> (Word32, Word32) -> (Word32, Word32) -> Word32 -> Int -> Word32
+          run a' b'' p'' result' count =
+            if count == 7
+            then result''
+            else run a'' b''' p'' result'' (count + 1)
+                where result'' = result' `xor` tupInd (a' .&. 1) b''
+                      a'' = shiftR a' 1
+                      b''' = (fst b'', tupInd (shiftR (snd b'') 7) p'' `xor` shiftL (snd b'') 1)

Crypto/Cipher/Types.hs

@@ -5,7 +5,7 @@
 -- Stability   : Stable
 -- Portability : Excellent
 --
--- symmetric cipher basic types
+-- Symmetric cipher basic types
 --
 {-# LANGUAGE DeriveDataTypeable #-}
 module Crypto.Cipher.Types
@@ -21,6 +21,8 @@ module Crypto.Cipher.Types
     -- , cfb8Decrypt
     -- * AEAD functions
     , AEADMode(..)
+    , CCM_M(..)
+    , CCM_L(..)
     , module Crypto.Cipher.Types.AEAD
     -- * Initial Vector type and constructor
     , IV

Crypto/Cipher/Types/AEAD.hs

@@ -27,24 +27,24 @@ data AEADModeImpl st = AEADModeImpl
 -- | Authenticated Encryption with Associated Data algorithms
 data AEAD cipher = forall st . AEAD
     { aeadModeImpl :: AEADModeImpl st
-    , aeadState    :: st
+    , aeadState    :: !st
     }
 
 -- | Append some header information to an AEAD context
 aeadAppendHeader :: ByteArrayAccess aad => AEAD cipher -> aad -> AEAD cipher
-aeadAppendHeader (AEAD impl st) aad = AEAD impl $ (aeadImplAppendHeader impl) st aad
+aeadAppendHeader (AEAD impl st) aad = AEAD impl $ aeadImplAppendHeader impl st aad
 
 -- | Encrypt some data and update the AEAD context
 aeadEncrypt :: ByteArray ba => AEAD cipher -> ba -> (ba, AEAD cipher)
-aeadEncrypt (AEAD impl st) ba = second (AEAD impl) $ (aeadImplEncrypt impl) st ba
+aeadEncrypt (AEAD impl st) ba = second (AEAD impl) $ aeadImplEncrypt impl st ba
 
 -- | Decrypt some data and update the AEAD context
 aeadDecrypt :: ByteArray ba => AEAD cipher -> ba -> (ba, AEAD cipher)
-aeadDecrypt (AEAD impl st) ba = second (AEAD impl) $ (aeadImplDecrypt impl) st ba
+aeadDecrypt (AEAD impl st) ba = second (AEAD impl) $ aeadImplDecrypt impl st ba
 
 -- | Finalize the AEAD context and return the authentication tag
 aeadFinalize :: AEAD cipher -> Int -> AuthTag
-aeadFinalize (AEAD impl st) n = (aeadImplFinalize impl) st n
+aeadFinalize (AEAD impl st) = aeadImplFinalize impl st
 
 -- | Simple AEAD encryption
 aeadSimpleEncrypt :: (ByteArrayAccess aad, ByteArray ba)

Crypto/Cipher/Types/Base.hs

@@ -5,7 +5,7 @@
 -- Stability   : Stable
 -- Portability : Excellent
 --
--- symmetric cipher basic types
+-- Symmetric cipher basic types
 --
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -14,12 +14,15 @@ module Crypto.Cipher.Types.Base
     , Cipher(..)
     , AuthTag(..)
     , AEADMode(..)
+    , CCM_M(..)
+    , CCM_L(..)
     , DataUnitOffset
     ) where
 
 import           Data.Word
 import           Crypto.Internal.ByteArray (Bytes, ByteArrayAccess, ByteArray)
 import qualified Crypto.Internal.ByteArray as B
+import           Crypto.Internal.DeepSeq
 import           Crypto.Error
 
 -- | Different specifier for key size in bytes
@@ -34,15 +37,18 @@ type DataUnitOffset = Word32
 
 -- | Authentication Tag for AE cipher mode
 newtype AuthTag = AuthTag { unAuthTag :: Bytes }
-    deriving (Show, ByteArrayAccess)
+    deriving (Show, ByteArrayAccess, NFData)
 
 instance Eq AuthTag where
     (AuthTag a) == (AuthTag b) = B.constEq a b
 
+data CCM_M = CCM_M4 | CCM_M6 | CCM_M8 | CCM_M10 | CCM_M12 | CCM_M14 | CCM_M16 deriving (Show, Eq)
+data CCM_L = CCM_L2 | CCM_L3 | CCM_L4 deriving (Show, Eq)
+
 -- | AEAD Mode
 data AEADMode =
       AEAD_OCB -- OCB3
-    | AEAD_CCM
+    | AEAD_CCM Int CCM_M CCM_L
     | AEAD_EAX
     | AEAD_CWC
     | AEAD_GCM

Crypto/Cipher/Types/Block.hs

@@ -5,7 +5,7 @@
 -- Stability   : Stable
 -- Portability : Excellent
 --
--- block cipher basic types
+-- Block cipher basic types
 --
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE ExistentialQuantification #-}
@@ -16,7 +16,7 @@ module Crypto.Cipher.Types.Block
     -- * BlockCipher
       BlockCipher(..)
     , BlockCipher128(..)
-    -- * initialization vector (IV)
+    -- * Initialization vector (IV)
     , IV(..)
     , makeIV
     , nullIV
@@ -37,7 +37,6 @@ module Crypto.Cipher.Types.Block
     ) where
 
 import           Data.Word
-import           Data.Monoid
 import           Crypto.Error
 import           Crypto.Cipher.Types.Base
 import           Crypto.Cipher.Types.GF
@@ -164,27 +163,20 @@ nullIV = toIV undefined
 -- | Increment an IV by a number.
 --
 -- Assume the IV is in Big Endian format.
-ivAdd :: BlockCipher c => IV c -> Int -> IV c
+ivAdd :: IV c -> Int -> IV c
 ivAdd (IV b) i = IV $ 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 = B.copyAndFreeze bs $ loop i (B.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
 
 cbcEncryptGeneric :: (ByteArray ba, BlockCipher cipher) => cipher -> IV cipher -> ba -> ba
 cbcEncryptGeneric cipher ivini input = mconcat $ doEnc ivini $ chunk (blockSize cipher) input

Crypto/Cipher/Types/Stream.hs

@@ -5,7 +5,7 @@
 -- Stability   : Stable
 -- Portability : Excellent
 --
--- stream cipher basic types
+-- Stream cipher basic types
 --
 module Crypto.Cipher.Types.Stream
     ( StreamCipher(..)

Crypto/Cipher/Types/Utils.hs

@@ -5,7 +5,7 @@
 -- Stability   : Stable
 -- Portability : Excellent
 --
--- basic utility for cipher related stuff
+-- Basic utility for cipher related stuff
 --
 module Crypto.Cipher.Types.Utils where
 

Crypto/Cipher/Utils.hs

@@ -0,0 +1,18 @@
+module Crypto.Cipher.Utils
+    ( validateKeySize
+    ) where
+
+import Crypto.Error
+import Crypto.Cipher.Types
+
+import Data.ByteArray as BA
+
+validateKeySize :: (ByteArrayAccess key, Cipher cipher) => cipher -> key -> CryptoFailable key
+validateKeySize c k = if validKeyLength
+                      then CryptoPassed k
+                      else CryptoFailed CryptoError_KeySizeInvalid
+  where keyLength = BA.length k
+        validKeyLength = case cipherKeySize c of
+          KeySizeRange low high -> keyLength >= low && keyLength <= high
+          KeySizeEnum lengths -> keyLength `elem` lengths
+          KeySizeFixed s -> keyLength == s

Crypto/Cipher/XSalsa.hs

@@ -0,0 +1,75 @@
+-- |
+-- Module      : Crypto.Cipher.XSalsa
+-- License     : BSD-style
+-- Maintainer  : Brandon Hamilton <brandon.hamilton@gmail.com>
+-- Stability   : stable
+-- Portability : good
+--
+-- Implementation of XSalsa20 algorithm
+-- <https://cr.yp.to/snuffle/xsalsa-20081128.pdf>
+-- Based on the Salsa20 algorithm with 256 bit key extended with 192 bit nonce
+
+{-# LANGUAGE ForeignFunctionInterface #-}
+module Crypto.Cipher.XSalsa
+    ( initialize
+    , derive
+    , combine
+    , generate
+    , State
+    ) where
+
+import           Crypto.Internal.ByteArray (ByteArrayAccess)
+import qualified Crypto.Internal.ByteArray as B
+import           Crypto.Internal.Compat
+import           Crypto.Internal.Imports
+import           Foreign.Ptr
+import           Crypto.Cipher.Salsa hiding (initialize)
+
+-- | Initialize a new XSalsa context with the number of rounds,
+-- the key and the nonce associated.
+initialize :: (ByteArrayAccess key, ByteArrayAccess nonce)
+           => Int    -- ^ number of rounds (8,12,20)
+           -> key    -- ^ the key (256 bits)
+           -> nonce  -- ^ the nonce (192 bits)
+           -> State  -- ^ the initial XSalsa state
+initialize nbRounds key nonce
+    | kLen /= 32                      = error "XSalsa: key length should be 256 bits"
+    | nonceLen /= 24                  = error "XSalsa: nonce length should be 192 bits"
+    | nbRounds `notElem` [8,12,20]    = error "XSalsa: rounds should be 8, 12 or 20"
+    | otherwise = unsafeDoIO $ do
+        stPtr <- B.alloc 132 $ \stPtr ->
+            B.withByteArray nonce $ \noncePtr  ->
+            B.withByteArray key   $ \keyPtr ->
+                ccryptonite_xsalsa_init stPtr nbRounds kLen keyPtr nonceLen noncePtr
+        return $ State stPtr
+  where kLen     = B.length key
+        nonceLen = B.length nonce
+
+-- | Use an already initialized context and new nonce material to derive another
+-- XSalsa context.
+--
+-- This allows a multi-level cascade where a first key @k1@ and nonce @n1@ is
+-- used to get @HState(k1,n1)@, and this value is then used as key @k2@ to build
+-- @XSalsa(k2,n2)@.  Function 'initialize' is to be called with the first 192
+-- bits of @n1|n2@, and the call to @derive@ should add the remaining 128 bits.
+--
+-- The output context always uses the same number of rounds as the input
+-- context.
+derive :: ByteArrayAccess nonce
+       => State  -- ^ base XSalsa state
+       -> nonce  -- ^ the remainder nonce (128 bits)
+       -> State  -- ^ the new XSalsa state
+derive (State stPtr') nonce
+    | nonceLen /= 16 = error "XSalsa: nonce length should be 128 bits"
+    | otherwise = unsafeDoIO $ do
+        stPtr <- B.copy stPtr' $ \stPtr ->
+            B.withByteArray nonce $ \noncePtr  ->
+                ccryptonite_xsalsa_derive stPtr nonceLen noncePtr
+        return $ State stPtr
+  where nonceLen = B.length nonce
+
+foreign import ccall "cryptonite_xsalsa_init"
+    ccryptonite_xsalsa_init :: Ptr State -> Int -> Int -> Ptr Word8 -> Int -> Ptr Word8 -> IO ()
+
+foreign import ccall "cryptonite_xsalsa_derive"
+    ccryptonite_xsalsa_derive :: Ptr State -> Int -> Ptr Word8 -> IO ()

Crypto/ConstructHash/MiyaguchiPreneel.hs

@@ -0,0 +1,68 @@
+-- |
+-- Module      : Crypto.ConstructHash.MiyaguchiPreneel
+-- License     : BSD-style
+-- Maintainer  : Kei Hibino <ex8k.hibino@gmail.com>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Provide the hash function construction method from block cipher
+-- <https://en.wikipedia.org/wiki/One-way_compression_function>
+--
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Crypto.ConstructHash.MiyaguchiPreneel
+       ( compute, compute'
+       , MiyaguchiPreneel
+       ) where
+
+import           Data.List (foldl')
+
+import           Crypto.Data.Padding (pad, Format (ZERO))
+import           Crypto.Cipher.Types
+import           Crypto.Error (throwCryptoError)
+import           Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray, Bytes)
+import qualified Crypto.Internal.ByteArray as B
+
+
+newtype MiyaguchiPreneel a = MP Bytes
+    deriving (ByteArrayAccess)
+
+instance Eq (MiyaguchiPreneel a) where
+    MP b1 == MP b2  =  B.constEq b1 b2
+
+
+-- | Compute Miyaguchi-Preneel one way compress using the supplied block cipher.
+compute' :: (ByteArrayAccess bin, BlockCipher cipher)
+         => (Bytes -> cipher)       -- ^ key build function to compute Miyaguchi-Preneel. care about block-size and key-size
+         -> bin                     -- ^ input message
+         -> MiyaguchiPreneel cipher -- ^ output tag
+compute' g = MP . foldl' (step $ g) (B.replicate bsz 0) . chunks . pad (ZERO bsz) . B.convert
+  where
+    bsz = blockSize ( g B.empty {- dummy to get block size -} )
+    chunks msg
+      | B.null msg  =  []
+      | otherwise  =   (hd :: Bytes) : chunks tl
+      where
+        (hd, tl) = B.splitAt bsz msg
+
+-- | Compute Miyaguchi-Preneel one way compress using the inferred block cipher.
+--   Only safe when KEY-SIZE equals to BLOCK-SIZE.
+--
+--   Simple usage /mp' msg :: MiyaguchiPreneel AES128/
+compute :: (ByteArrayAccess bin, BlockCipher cipher)
+        => bin                     -- ^ input message
+        -> MiyaguchiPreneel cipher -- ^ output tag
+compute = compute' $ throwCryptoError . cipherInit
+
+-- | computation step of Miyaguchi-Preneel
+step :: (ByteArray ba, BlockCipher k)
+     => (ba -> k)
+     -> ba
+     -> ba
+     -> ba
+step g iv msg =
+    ecbEncrypt k msg `bxor` iv `bxor` msg
+  where
+    k = g iv
+
+bxor :: ByteArray ba => ba -> ba -> ba
+bxor = B.xor

Crypto/Data/AFIS.hs

@@ -5,7 +5,7 @@
 -- Stability   : experimental
 -- Portability : unknown
 --
--- haskell implementation of the Anti-forensic information splitter
+-- Haskell implementation of the Anti-forensic information splitter
 -- available in LUKS. <http://clemens.endorphin.org/AFsplitter>
 --
 -- The algorithm bloats an arbitrary secret with many bits that are necessary for
@@ -77,7 +77,7 @@ split hashAlg rng expandTimes src
             diffuse hashAlg lastBlock blockSize
         fillRandomBlock g blockPtr = do
             let (rand :: Bytes, g') = randomBytesGenerate blockSize g
-            B.withByteArray rand $ \randPtr -> memCopy blockPtr randPtr (fromIntegral blockSize)
+            B.withByteArray rand $ \randPtr -> memCopy blockPtr randPtr blockSize
             return g'
 
 -- | Merge previously diffused data back to the original data.

Crypto/Data/Padding.hs

@@ -6,7 +6,7 @@
 -- Portability : unknown
 --
 -- Various cryptographic padding commonly used for block ciphers
--- or assymetric systems.
+-- or asymmetric systems.
 --
 module Crypto.Data.Padding
     ( Format(..)
@@ -17,9 +17,11 @@ module Crypto.Data.Padding
 import           Data.ByteArray (ByteArray, Bytes)
 import qualified Data.ByteArray as B
 
+-- | Format of padding
 data Format =
       PKCS5     -- ^ PKCS5: PKCS7 with hardcoded size of 8
     | PKCS7 Int -- ^ PKCS7 with padding size between 1 and 255
+    | ZERO Int  -- ^ zero padding with block size
     deriving (Show, Eq)
 
 -- | Apply some pad to a bytearray
@@ -29,6 +31,15 @@ pad (PKCS7 sz) bin = bin `B.append` paddingString
   where
     paddingString = B.replicate paddingByte (fromIntegral paddingByte)
     paddingByte   = sz - (B.length bin `mod` sz)
+pad (ZERO sz)  bin = bin `B.append` paddingString
+  where
+    paddingString = B.replicate paddingSz 0
+    paddingSz
+      | len == 0   =  sz
+      | m == 0     =  0
+      | otherwise  =  sz - m
+    m = len `mod` sz
+    len = B.length bin
 
 -- | Try to remove some padding from a bytearray.
 unpad :: ByteArray byteArray => Format -> byteArray -> Maybe byteArray
@@ -45,3 +56,10 @@ unpad (PKCS7 sz) bin
     paddingSz   = fromIntegral paddingByte
     (content, padding) = B.splitAt (len - paddingSz) bin
     paddingWitness     = B.replicate paddingSz paddingByte :: Bytes
+unpad (ZERO sz)  bin
+    | len == 0                           = Nothing
+    | (len `mod` sz) /= 0                = Nothing
+    | B.index bin (len - 1) /= 0         = Just bin
+    | otherwise                          = Nothing
+  where
+    len         = B.length bin

Crypto/ECC.hs

@@ -0,0 +1,408 @@
+-- |
+-- Module      : Crypto.ECC
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Elliptic Curve Cryptography
+--
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Crypto.ECC
+    ( Curve_P256R1(..)
+    , Curve_P384R1(..)
+    , Curve_P521R1(..)
+    , Curve_X25519(..)
+    , Curve_X448(..)
+    , Curve_Edwards25519(..)
+    , EllipticCurve(..)
+    , EllipticCurveDH(..)
+    , EllipticCurveArith(..)
+    , EllipticCurveBasepointArith(..)
+    , KeyPair(..)
+    , SharedSecret(..)
+    ) where
+
+import qualified Crypto.PubKey.ECC.P256 as P256
+import qualified Crypto.ECC.Edwards25519 as Edwards25519
+import qualified Crypto.ECC.Simple.Types as Simple
+import qualified Crypto.ECC.Simple.Prim as Simple
+import           Crypto.Random
+import           Crypto.Error
+import           Crypto.Internal.Imports
+import           Crypto.Internal.ByteArray (ByteArray, ByteArrayAccess, ScrubbedBytes)
+import qualified Crypto.Internal.ByteArray as B
+import           Crypto.Number.Basic (numBits)
+import           Crypto.Number.Serialize (i2ospOf_, os2ip)
+import qualified Crypto.Number.Serialize.LE as LE
+import qualified Crypto.PubKey.Curve25519 as X25519
+import qualified Crypto.PubKey.Curve448 as X448
+import           Data.ByteArray (convert)
+import           Data.Data (Data())
+import           Data.Kind (Type)
+import           Data.Proxy
+
+-- | An elliptic curve key pair composed of the private part (a scalar), and
+-- the associated point.
+data KeyPair curve = KeyPair
+    { keypairGetPublic  :: !(Point curve)
+    , keypairGetPrivate :: !(Scalar curve)
+    }
+
+newtype SharedSecret = SharedSecret ScrubbedBytes
+    deriving (Eq, ByteArrayAccess, NFData)
+
+class EllipticCurve curve where
+    -- | Point on an Elliptic Curve
+    type Point curve  :: Type
+
+    -- | Scalar in the Elliptic Curve domain
+    type Scalar curve :: Type
+
+    -- | Generate a new random scalar on the curve.
+    -- The scalar will represent a number between 1 and the order of the curve non included
+    curveGenerateScalar :: MonadRandom randomly => proxy curve -> randomly (Scalar curve)
+
+    -- | Generate a new random keypair
+    curveGenerateKeyPair :: MonadRandom randomly => proxy curve -> randomly (KeyPair curve)
+
+    -- | Get the curve size in bits
+    curveSizeBits :: proxy curve -> Int
+
+    -- | Encode a elliptic curve point into binary form
+    encodePoint :: ByteArray bs => proxy curve -> Point curve -> bs
+
+    -- | Try to decode the binary form of an elliptic curve point
+    decodePoint :: ByteArray bs => proxy curve -> bs -> CryptoFailable (Point curve)
+
+class EllipticCurve curve => EllipticCurveDH curve where
+    -- | Generate a Diffie hellman secret value.
+    --
+    -- This is generally just the .x coordinate of the resulting point, that
+    -- is not hashed.
+    --
+    -- use `pointSmul` to keep the result in Point format.
+    --
+    -- /WARNING:/ Curve implementations may return a special value or an
+    -- exception when the public point lies in a subgroup of small order.
+    -- This function is adequate when the scalar is in expected range and
+    -- contributory behaviour is not needed.  Otherwise use 'ecdh'.
+    ecdhRaw :: proxy curve -> Scalar curve -> Point curve -> SharedSecret
+    ecdhRaw prx s = throwCryptoError . ecdh prx s
+
+    -- | Generate a Diffie hellman secret value and verify that the result
+    -- is not the point at infinity.
+    --
+    -- This additional test avoids risks existing with function 'ecdhRaw'.
+    -- Implementations always return a 'CryptoError' instead of a special
+    -- value or an exception.
+    ecdh :: proxy curve -> Scalar curve -> Point curve -> CryptoFailable SharedSecret
+
+class (EllipticCurve curve, Eq (Point curve)) => EllipticCurveArith curve where
+    -- | Add points on a curve
+    pointAdd :: proxy curve -> Point curve -> Point curve -> Point curve
+
+    -- | Negate a curve point
+    pointNegate :: proxy curve -> Point curve -> Point curve
+
+    -- | Scalar Multiplication on a curve
+    pointSmul :: proxy curve -> Scalar curve -> Point curve -> Point curve
+
+--   -- | Scalar Inverse
+--   scalarInverse :: Scalar curve -> Scalar curve
+
+class (EllipticCurveArith curve, Eq (Scalar curve)) => EllipticCurveBasepointArith curve where
+    -- | Get the curve order size in bits
+    curveOrderBits :: proxy curve -> Int
+
+    -- | Multiply a scalar with the curve base point
+    pointBaseSmul :: proxy curve -> Scalar curve -> Point curve
+
+    -- | Multiply the point @p@ with @s2@ and add a lifted to curve value @s1@
+    pointsSmulVarTime :: proxy curve -> Scalar curve -> Scalar curve -> Point curve -> Point curve
+    pointsSmulVarTime prx s1 s2 p = pointAdd prx (pointBaseSmul prx s1) (pointSmul prx s2 p)
+
+    -- | Encode an elliptic curve scalar into big-endian form
+    encodeScalar :: ByteArray bs => proxy curve -> Scalar curve -> bs
+
+    -- | Try to decode the big-endian form of an elliptic curve scalar
+    decodeScalar :: ByteArray bs => proxy curve -> bs -> CryptoFailable (Scalar curve)
+
+    -- | Convert an elliptic curve scalar to an integer
+    scalarToInteger :: proxy curve -> Scalar curve -> Integer
+
+    -- | Try to create an elliptic curve scalar from an integer
+    scalarFromInteger :: proxy curve -> Integer -> CryptoFailable (Scalar curve)
+
+    -- | Add two scalars and reduce modulo the curve order
+    scalarAdd :: proxy curve -> Scalar curve -> Scalar curve -> Scalar curve
+
+    -- | Multiply two scalars and reduce modulo the curve order
+    scalarMul :: proxy curve -> Scalar curve -> Scalar curve -> Scalar curve
+
+-- | P256 Curve
+--
+-- also known as P256
+data Curve_P256R1 = Curve_P256R1
+    deriving (Show,Data)
+
+instance EllipticCurve Curve_P256R1 where
+    type Point Curve_P256R1 = P256.Point
+    type Scalar Curve_P256R1 = P256.Scalar
+    curveSizeBits _ = 256
+    curveGenerateScalar _ = P256.scalarGenerate
+    curveGenerateKeyPair _ = toKeyPair <$> P256.scalarGenerate
+      where toKeyPair scalar = KeyPair (P256.toPoint scalar) scalar
+    encodePoint _ p = mxy
+      where
+        mxy :: forall bs. ByteArray bs => bs
+        mxy = B.concat [uncompressed, xy]
+          where
+            uncompressed, xy :: bs
+            uncompressed = B.singleton 4
+            xy = P256.pointToBinary p
+    decodePoint _ mxy = case B.uncons mxy of
+        Nothing -> CryptoFailed CryptoError_PointSizeInvalid
+        Just (m,xy)
+            -- uncompressed
+            | m == 4 -> P256.pointFromBinary xy
+            | otherwise -> CryptoFailed CryptoError_PointFormatInvalid
+
+instance EllipticCurveArith Curve_P256R1 where
+    pointAdd  _ a b = P256.pointAdd a b
+    pointNegate _ p = P256.pointNegate p
+    pointSmul _ s p = P256.pointMul s p
+
+instance EllipticCurveDH Curve_P256R1 where
+    ecdhRaw _ s p = SharedSecret $ P256.pointDh s p
+    ecdh  prx s p = checkNonZeroDH (ecdhRaw prx s p)
+
+instance EllipticCurveBasepointArith Curve_P256R1 where
+    curveOrderBits _ = 256
+    pointBaseSmul _ = P256.toPoint
+    pointsSmulVarTime _ = P256.pointsMulVarTime
+    encodeScalar _ = P256.scalarToBinary
+    decodeScalar _ = P256.scalarFromBinary
+    scalarToInteger _ = P256.scalarToInteger
+    scalarFromInteger _ = P256.scalarFromInteger
+    scalarAdd _ = P256.scalarAdd
+    scalarMul _ = P256.scalarMul
+
+data Curve_P384R1 = Curve_P384R1
+    deriving (Show,Data)
+
+instance EllipticCurve Curve_P384R1 where
+    type Point Curve_P384R1 = Simple.Point Simple.SEC_p384r1
+    type Scalar Curve_P384R1 = Simple.Scalar Simple.SEC_p384r1
+    curveSizeBits _ = 384
+    curveGenerateScalar _ = Simple.scalarGenerate
+    curveGenerateKeyPair _ = toKeyPair <$> Simple.scalarGenerate
+      where toKeyPair scalar = KeyPair (Simple.pointBaseMul scalar) scalar
+    encodePoint _ point = encodeECPoint point
+    decodePoint _ bs = decodeECPoint bs
+
+instance EllipticCurveArith Curve_P384R1 where
+    pointAdd _ a b = Simple.pointAdd a b
+    pointNegate _ p = Simple.pointNegate p
+    pointSmul _ s p = Simple.pointMul s p
+
+instance EllipticCurveDH Curve_P384R1 where
+    ecdh _ s p = encodeECShared prx (Simple.pointMul s p)
+      where
+        prx = Proxy :: Proxy Simple.SEC_p384r1
+
+instance EllipticCurveBasepointArith Curve_P384R1 where
+    curveOrderBits _ = 384
+    pointBaseSmul _ = Simple.pointBaseMul
+    pointsSmulVarTime _ = ecPointsMulVarTime
+    encodeScalar _ = ecScalarToBinary
+    decodeScalar _ = ecScalarFromBinary
+    scalarToInteger _ = ecScalarToInteger
+    scalarFromInteger _ = ecScalarFromInteger
+    scalarAdd _ = ecScalarAdd
+    scalarMul _ = ecScalarMul
+
+data Curve_P521R1 = Curve_P521R1
+    deriving (Show,Data)
+
+instance EllipticCurve Curve_P521R1 where
+    type Point Curve_P521R1 = Simple.Point Simple.SEC_p521r1
+    type Scalar Curve_P521R1 = Simple.Scalar Simple.SEC_p521r1
+    curveSizeBits _ = 521
+    curveGenerateScalar _ = Simple.scalarGenerate
+    curveGenerateKeyPair _ = toKeyPair <$> Simple.scalarGenerate
+      where toKeyPair scalar = KeyPair (Simple.pointBaseMul scalar) scalar
+    encodePoint _ point = encodeECPoint point
+    decodePoint _ bs = decodeECPoint bs
+
+instance EllipticCurveArith Curve_P521R1 where
+    pointAdd _ a b = Simple.pointAdd a b
+    pointNegate _ p = Simple.pointNegate p
+    pointSmul _ s p = Simple.pointMul s p
+
+instance EllipticCurveDH Curve_P521R1 where
+    ecdh _ s p = encodeECShared prx (Simple.pointMul s p)
+      where
+        prx = Proxy :: Proxy Simple.SEC_p521r1
+
+instance EllipticCurveBasepointArith Curve_P521R1 where
+    curveOrderBits _ = 521
+    pointBaseSmul _ = Simple.pointBaseMul
+    pointsSmulVarTime _ = ecPointsMulVarTime
+    encodeScalar _ = ecScalarToBinary
+    decodeScalar _ = ecScalarFromBinary
+    scalarToInteger _ = ecScalarToInteger
+    scalarFromInteger _ = ecScalarFromInteger
+    scalarAdd _ = ecScalarAdd
+    scalarMul _ = ecScalarMul
+
+data Curve_X25519 = Curve_X25519
+    deriving (Show,Data)
+
+instance EllipticCurve Curve_X25519 where
+    type Point Curve_X25519 = X25519.PublicKey
+    type Scalar Curve_X25519 = X25519.SecretKey
+    curveSizeBits _ = 255
+    curveGenerateScalar _ = X25519.generateSecretKey
+    curveGenerateKeyPair _ = do
+        s <- X25519.generateSecretKey
+        return $ KeyPair (X25519.toPublic s) s
+    encodePoint _ p = B.convert p
+    decodePoint _ bs = X25519.publicKey bs
+
+instance EllipticCurveDH Curve_X25519 where
+    ecdhRaw _ s p = SharedSecret $ convert secret
+      where secret = X25519.dh p s
+    ecdh prx s p = checkNonZeroDH (ecdhRaw prx s p)
+
+data Curve_X448 = Curve_X448
+    deriving (Show,Data)
+
+instance EllipticCurve Curve_X448 where
+    type Point Curve_X448 = X448.PublicKey
+    type Scalar Curve_X448 = X448.SecretKey
+    curveSizeBits _ = 448
+    curveGenerateScalar _ = X448.generateSecretKey
+    curveGenerateKeyPair _ = do
+        s <- X448.generateSecretKey
+        return $ KeyPair (X448.toPublic s) s
+    encodePoint _ p = B.convert p
+    decodePoint _ bs = X448.publicKey bs
+
+instance EllipticCurveDH Curve_X448 where
+    ecdhRaw _ s p = SharedSecret $ convert secret
+      where secret = X448.dh p s
+    ecdh prx s p = checkNonZeroDH (ecdhRaw prx s p)
+
+data Curve_Edwards25519 = Curve_Edwards25519
+    deriving (Show,Data)
+
+instance EllipticCurve Curve_Edwards25519 where
+    type Point Curve_Edwards25519 = Edwards25519.Point
+    type Scalar Curve_Edwards25519 = Edwards25519.Scalar
+    curveSizeBits _ = 255
+    curveGenerateScalar _ = Edwards25519.scalarGenerate
+    curveGenerateKeyPair _ = toKeyPair <$> Edwards25519.scalarGenerate
+      where toKeyPair scalar = KeyPair (Edwards25519.toPoint scalar) scalar
+    encodePoint _ point = Edwards25519.pointEncode point
+    decodePoint _ bs = Edwards25519.pointDecode bs
+
+instance EllipticCurveArith Curve_Edwards25519 where
+    pointAdd _ a b = Edwards25519.pointAdd a b
+    pointNegate _ p = Edwards25519.pointNegate p
+    pointSmul _ s p = Edwards25519.pointMul s p
+
+instance EllipticCurveBasepointArith Curve_Edwards25519 where
+    curveOrderBits _ = 253
+    pointBaseSmul _ = Edwards25519.toPoint
+    pointsSmulVarTime _ = Edwards25519.pointsMulVarTime
+    encodeScalar _ = B.reverse . Edwards25519.scalarEncode
+    decodeScalar _ bs
+        | B.length bs == 32 = Edwards25519.scalarDecodeLong (B.reverse bs)
+        | otherwise         = CryptoFailed CryptoError_SecretKeySizeInvalid
+    scalarToInteger _ s = LE.os2ip (Edwards25519.scalarEncode s :: B.Bytes)
+    scalarFromInteger _ i =
+        case LE.i2ospOf 32 i of
+            Nothing -> CryptoFailed CryptoError_SecretKeySizeInvalid
+            Just bs -> Edwards25519.scalarDecodeLong (bs :: B.Bytes)
+    scalarAdd _ = Edwards25519.scalarAdd
+    scalarMul _ = Edwards25519.scalarMul
+
+checkNonZeroDH :: SharedSecret -> CryptoFailable SharedSecret
+checkNonZeroDH s@(SharedSecret b)
+    | B.constAllZero b = CryptoFailed CryptoError_ScalarMultiplicationInvalid
+    | otherwise        = CryptoPassed s
+
+encodeECShared :: Simple.Curve curve => Proxy curve -> Simple.Point curve -> CryptoFailable SharedSecret
+encodeECShared _   Simple.PointO      = CryptoFailed CryptoError_ScalarMultiplicationInvalid
+encodeECShared prx (Simple.Point x _) = CryptoPassed . SharedSecret $ i2ospOf_ (Simple.curveSizeBytes prx) x
+
+encodeECPoint :: forall curve bs . (Simple.Curve curve, ByteArray bs) => Simple.Point curve -> bs
+encodeECPoint Simple.PointO      = error "encodeECPoint: cannot serialize point at infinity"
+encodeECPoint (Simple.Point x y) = B.concat [uncompressed,xb,yb]
+  where
+    size = Simple.curveSizeBytes (Proxy :: Proxy curve)
+    uncompressed, xb, yb :: bs
+    uncompressed = B.singleton 4
+    xb = i2ospOf_ size x
+    yb = i2ospOf_ size y
+
+decodeECPoint :: (Simple.Curve curve, ByteArray bs) => bs -> CryptoFailable (Simple.Point curve)
+decodeECPoint mxy = case B.uncons mxy of
+    Nothing     -> CryptoFailed CryptoError_PointSizeInvalid
+    Just (m,xy)
+        -- uncompressed
+        | m == 4 ->
+            let siz = B.length xy `div` 2
+                (xb,yb) = B.splitAt siz xy
+                x = os2ip xb
+                y = os2ip yb
+             in Simple.pointFromIntegers (x,y)
+        | otherwise -> CryptoFailed CryptoError_PointFormatInvalid
+
+ecPointsMulVarTime :: forall curve . Simple.Curve curve
+                   => Simple.Scalar curve
+                   -> Simple.Scalar curve -> Simple.Point curve
+                   -> Simple.Point curve
+ecPointsMulVarTime n1 = Simple.pointAddTwoMuls n1 g
+  where g = Simple.curveEccG $ Simple.curveParameters (Proxy :: Proxy curve)
+
+ecScalarFromBinary :: forall curve bs . (Simple.Curve curve, ByteArrayAccess bs)
+                   => bs -> CryptoFailable (Simple.Scalar curve)
+ecScalarFromBinary ba
+    | B.length ba /= size = CryptoFailed CryptoError_SecretKeySizeInvalid
+    | otherwise           = CryptoPassed (Simple.Scalar $ os2ip ba)
+  where size = ecCurveOrderBytes (Proxy :: Proxy curve)
+
+ecScalarToBinary :: forall curve bs . (Simple.Curve curve, ByteArray bs)
+                 => Simple.Scalar curve -> bs
+ecScalarToBinary (Simple.Scalar s) = i2ospOf_ size s
+  where size = ecCurveOrderBytes (Proxy :: Proxy curve)
+
+ecScalarFromInteger :: forall curve . Simple.Curve curve
+                    => Integer -> CryptoFailable (Simple.Scalar curve)
+ecScalarFromInteger s
+    | numBits s > nb = CryptoFailed CryptoError_SecretKeySizeInvalid
+    | otherwise      = CryptoPassed (Simple.Scalar s)
+  where nb = 8 * ecCurveOrderBytes (Proxy :: Proxy curve)
+
+ecScalarToInteger :: Simple.Scalar curve -> Integer
+ecScalarToInteger (Simple.Scalar s) = s
+
+ecCurveOrderBytes :: Simple.Curve c => proxy c -> Int
+ecCurveOrderBytes prx = (numBits n + 7) `div` 8
+  where n = Simple.curveEccN $ Simple.curveParameters prx
+
+ecScalarAdd :: forall curve . Simple.Curve curve
+            => Simple.Scalar curve -> Simple.Scalar curve -> Simple.Scalar curve
+ecScalarAdd (Simple.Scalar a) (Simple.Scalar b) = Simple.Scalar ((a + b) `mod` n)
+  where n = Simple.curveEccN $ Simple.curveParameters (Proxy :: Proxy curve)
+
+ecScalarMul :: forall curve . Simple.Curve curve
+            => Simple.Scalar curve -> Simple.Scalar curve -> Simple.Scalar curve
+ecScalarMul (Simple.Scalar a) (Simple.Scalar b) = Simple.Scalar ((a * b) `mod` n)
+  where n = Simple.curveEccN $ Simple.curveParameters (Proxy :: Proxy curve)

Crypto/ECC/Edwards25519.hs

@@ -0,0 +1,370 @@
+-- |
+-- Module      : Crypto.ECC.Edwards25519
+-- License     : BSD-style
+-- Maintainer  : Olivier Chéron <olivier.cheron@gmail.com>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Arithmetic primitives over curve edwards25519.
+--
+-- Twisted Edwards curves are a familly of elliptic curves allowing
+-- complete addition formulas without any special case and no point at
+-- infinity.  Curve edwards25519 is based on prime 2^255 - 19 for
+-- efficient implementation.  Equation and parameters are given in
+-- <https://tools.ietf.org/html/rfc7748 RFC 7748>.
+--
+-- This module provides types and primitive operations that are useful
+-- to implement cryptographic schemes based on curve edwards25519:
+--
+-- - arithmetic functions for point addition, doubling, negation,
+-- scalar multiplication with an arbitrary point, with the base point,
+-- etc.
+--
+-- - arithmetic functions dealing with scalars modulo the prime order
+-- L of the base point
+--
+-- All functions run in constant time unless noted otherwise.
+--
+-- Warnings:
+--
+-- 1. Curve edwards25519 has a cofactor h = 8 so the base point does
+-- not generate the entire curve and points with order 2, 4, 8 exist.
+-- When implementing cryptographic algorithms, special care must be
+-- taken using one of the following methods:
+--
+--     - points must be checked for membership in the prime-order
+--     subgroup
+--
+--     - or cofactor must be cleared by multiplying points by 8
+--
+--     Utility functions are provided to implement this.  Testing
+--     subgroup membership with 'pointHasPrimeOrder' is 50-time slower
+--     than call 'pointMulByCofactor'.
+--
+-- 2. Scalar arithmetic is always reduced modulo L, allowing fixed
+-- length and constant execution time, but this reduction is valid
+-- only when points are in the prime-order subgroup.
+--
+-- 3. Because of modular reduction in this implementation it is not
+-- possible to multiply points directly by scalars like 8.s or L.
+-- This has to be decomposed into several steps.
+--
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Crypto.ECC.Edwards25519
+    ( Scalar
+    , Point
+    -- * Scalars
+    , scalarGenerate
+    , scalarDecodeLong
+    , scalarEncode
+    -- * Points
+    , pointDecode
+    , pointEncode
+    , pointHasPrimeOrder
+    -- * Arithmetic functions
+    , toPoint
+    , scalarAdd
+    , scalarMul
+    , pointNegate
+    , pointAdd
+    , pointDouble
+    , pointMul
+    , pointMulByCofactor
+    , pointsMulVarTime
+    ) where
+
+import           Data.Word
+import           Foreign.C.Types
+import           Foreign.Ptr
+
+import           Crypto.Error
+import           Crypto.Internal.ByteArray (Bytes, ScrubbedBytes, withByteArray)
+import qualified Crypto.Internal.ByteArray as B
+import           Crypto.Internal.Compat
+import           Crypto.Internal.Imports
+import           Crypto.Random
+
+
+scalarArraySize :: Int
+scalarArraySize = 40 -- maximum [9 * 4 {- 32 bits -}, 5 * 8 {- 64 bits -}]
+
+-- | A scalar modulo prime order of curve edwards25519.
+newtype Scalar = Scalar ScrubbedBytes
+    deriving (Show,NFData)
+
+instance Eq Scalar where
+    (Scalar s1) == (Scalar s2) = unsafeDoIO $
+        withByteArray s1 $ \ps1 ->
+        withByteArray s2 $ \ps2 ->
+            fmap (/= 0) (ed25519_scalar_eq ps1 ps2)
+    {-# NOINLINE (==) #-}
+
+pointArraySize :: Int
+pointArraySize = 160 -- maximum [4 * 10 * 4 {- 32 bits -}, 4 * 5 * 8 {- 64 bits -}]
+
+-- | A point on curve edwards25519.
+newtype Point = Point Bytes
+    deriving NFData
+
+instance Show Point where
+    showsPrec d p =
+        let bs = pointEncode p :: Bytes
+         in showParen (d > 10) $ showString "Point "
+                               . shows (B.convertToBase B.Base16 bs :: Bytes)
+
+instance Eq Point where
+    (Point p1) == (Point p2) = unsafeDoIO $
+        withByteArray p1 $ \pp1 ->
+        withByteArray p2 $ \pp2 ->
+            fmap (/= 0) (ed25519_point_eq pp1 pp2)
+    {-# NOINLINE (==) #-}
+
+-- | Generate a random scalar.
+scalarGenerate :: MonadRandom randomly => randomly Scalar
+scalarGenerate = throwCryptoError . scalarDecodeLong <$> generate
+  where
+    -- Scalar generation is based on a fixed number of bytes so that
+    -- there is no timing leak.  But because of modular reduction
+    -- distribution is not uniform.  We use many more bytes than
+    -- necessary so the probability bias is small.  With 512 bits we
+    -- get 22% of scalars with a higher frequency, but the relative
+    -- probability difference is only 2^(-260).
+    generate :: MonadRandom randomly => randomly ScrubbedBytes
+    generate = getRandomBytes 64
+
+-- | Serialize a scalar to binary, i.e. a 32-byte little-endian
+-- number.
+scalarEncode :: B.ByteArray bs => Scalar -> bs
+scalarEncode (Scalar s) =
+    B.allocAndFreeze 32 $ \out ->
+        withByteArray s $ \ps -> ed25519_scalar_encode out ps
+
+-- | Deserialize a little-endian number as a scalar.  Input array can
+-- have any length from 0 to 64 bytes.
+--
+-- Note: it is not advised to put secret information in the 3 lowest
+-- bits of a scalar if this scalar may be multiplied to untrusted
+-- points outside the prime-order subgroup.
+scalarDecodeLong :: B.ByteArrayAccess bs => bs -> CryptoFailable Scalar
+scalarDecodeLong bs
+    | B.length bs > 64 = CryptoFailed CryptoError_EcScalarOutOfBounds
+    | otherwise        = unsafeDoIO $ withByteArray bs initialize
+  where
+    len = fromIntegral $ B.length bs
+    initialize inp = do
+        s <- B.alloc scalarArraySize $ \ps ->
+                 ed25519_scalar_decode_long ps inp len
+        return $ CryptoPassed (Scalar s)
+{-# NOINLINE scalarDecodeLong #-}
+
+-- | Add two scalars.
+scalarAdd :: Scalar -> Scalar -> Scalar
+scalarAdd (Scalar a) (Scalar b) =
+    Scalar $ B.allocAndFreeze scalarArraySize $ \out ->
+        withByteArray a $ \pa ->
+        withByteArray b $ \pb ->
+             ed25519_scalar_add out pa pb
+
+-- | Multiply two scalars.
+scalarMul :: Scalar -> Scalar -> Scalar
+scalarMul (Scalar a) (Scalar b) =
+    Scalar $ B.allocAndFreeze scalarArraySize $ \out ->
+        withByteArray a $ \pa ->
+        withByteArray b $ \pb ->
+             ed25519_scalar_mul out pa pb
+
+-- | Multiplies a scalar with the curve base point.
+toPoint :: Scalar -> Point
+toPoint (Scalar scalar) =
+    Point $ B.allocAndFreeze pointArraySize $ \out ->
+        withByteArray scalar $ \pscalar ->
+            ed25519_point_base_scalarmul out pscalar
+
+-- | Serialize a point to a 32-byte array.
+--
+-- Format is binary compatible with 'Crypto.PubKey.Ed25519.PublicKey'
+-- from module "Crypto.PubKey.Ed25519".
+pointEncode :: B.ByteArray bs => Point -> bs
+pointEncode (Point p) =
+    B.allocAndFreeze 32 $ \out ->
+        withByteArray p $ \pp ->
+             ed25519_point_encode out pp
+
+-- | Deserialize a 32-byte array as a point, ensuring the point is
+-- valid on edwards25519.
+--
+-- /WARNING:/ variable time
+pointDecode :: B.ByteArrayAccess bs => bs -> CryptoFailable Point
+pointDecode bs
+    | B.length bs == 32 = unsafeDoIO $ withByteArray bs initialize
+    | otherwise         = CryptoFailed CryptoError_PointSizeInvalid
+  where
+    initialize inp = do
+        (res, p) <- B.allocRet pointArraySize $ \pp ->
+                        ed25519_point_decode_vartime pp inp
+        if res == 0 then return $ CryptoFailed CryptoError_PointCoordinatesInvalid
+                    else return $ CryptoPassed (Point p)
+{-# NOINLINE pointDecode #-}
+
+-- | Test whether a point belongs to the prime-order subgroup
+-- generated by the base point.  Result is 'True' for the identity
+-- point.
+--
+-- @
+-- pointHasPrimeOrder p = 'pointNegate' p == 'pointMul' l_minus_one p
+-- @
+pointHasPrimeOrder :: Point -> Bool
+pointHasPrimeOrder (Point p) = unsafeDoIO $
+    withByteArray p $ \pp ->
+        fmap (/= 0) (ed25519_point_has_prime_order pp)
+{-# NOINLINE pointHasPrimeOrder #-}
+
+-- | Negate a point.
+pointNegate :: Point -> Point
+pointNegate (Point a) =
+    Point $ B.allocAndFreeze pointArraySize $ \out ->
+        withByteArray a $ \pa ->
+             ed25519_point_negate out pa
+
+-- | Add two points.
+pointAdd :: Point -> Point -> Point
+pointAdd (Point a) (Point b) =
+    Point $ B.allocAndFreeze pointArraySize $ \out ->
+        withByteArray a $ \pa ->
+        withByteArray b $ \pb ->
+             ed25519_point_add out pa pb
+
+-- | Add a point to itself.
+--
+-- @
+-- pointDouble p = 'pointAdd' p p
+-- @
+pointDouble :: Point -> Point
+pointDouble (Point a) =
+    Point $ B.allocAndFreeze pointArraySize $ \out ->
+        withByteArray a $ \pa ->
+             ed25519_point_double out pa
+
+-- | Multiply a point by h = 8.
+--
+-- @
+-- pointMulByCofactor p = 'pointMul' scalar_8 p
+-- @
+pointMulByCofactor :: Point -> Point
+pointMulByCofactor (Point a) =
+    Point $ B.allocAndFreeze pointArraySize $ \out ->
+        withByteArray a $ \pa ->
+             ed25519_point_mul_by_cofactor out pa
+
+-- | Scalar multiplication over curve edwards25519.
+--
+-- Note: when the scalar had reduction modulo L and the input point
+-- has a torsion component, the output point may not be in the
+-- expected subgroup.
+pointMul :: Scalar -> Point -> Point
+pointMul (Scalar scalar) (Point base) =
+    Point $ B.allocAndFreeze pointArraySize $ \out ->
+        withByteArray scalar $ \pscalar ->
+        withByteArray base   $ \pbase   ->
+             ed25519_point_scalarmul out pbase pscalar
+
+-- | Multiply the point @p@ with @s2@ and add a lifted to curve value @s1@.
+--
+-- @
+-- pointsMulVarTime s1 s2 p = 'pointAdd' ('toPoint' s1) ('pointMul' s2 p)
+-- @
+--
+-- /WARNING:/ variable time
+pointsMulVarTime :: Scalar -> Scalar -> Point -> Point
+pointsMulVarTime (Scalar s1) (Scalar s2) (Point p) =
+    Point $ B.allocAndFreeze pointArraySize $ \out ->
+        withByteArray s1 $ \ps1 ->
+        withByteArray s2 $ \ps2 ->
+        withByteArray p  $ \pp  ->
+             ed25519_base_double_scalarmul_vartime out ps1 pp ps2
+
+foreign import ccall unsafe "cryptonite_ed25519_scalar_eq"
+    ed25519_scalar_eq :: Ptr Scalar
+                      -> Ptr Scalar
+                      -> IO CInt
+
+foreign import ccall unsafe "cryptonite_ed25519_scalar_encode"
+    ed25519_scalar_encode :: Ptr Word8
+                          -> Ptr Scalar
+                          -> IO ()
+
+foreign import ccall unsafe "cryptonite_ed25519_scalar_decode_long"
+    ed25519_scalar_decode_long :: Ptr Scalar
+                               -> Ptr Word8
+                               -> CSize
+                               -> IO ()
+
+foreign import ccall unsafe "cryptonite_ed25519_scalar_add"
+    ed25519_scalar_add :: Ptr Scalar -- sum
+                       -> Ptr Scalar -- a
+                       -> Ptr Scalar -- b
+                       -> IO ()
+
+foreign import ccall unsafe "cryptonite_ed25519_scalar_mul"
+    ed25519_scalar_mul :: Ptr Scalar -- out
+                       -> Ptr Scalar -- a
+                       -> Ptr Scalar -- b
+                       -> IO ()
+
+foreign import ccall unsafe "cryptonite_ed25519_point_encode"
+    ed25519_point_encode :: Ptr Word8
+                         -> Ptr Point
+                         -> IO ()
+
+foreign import ccall unsafe "cryptonite_ed25519_point_decode_vartime"
+    ed25519_point_decode_vartime :: Ptr Point
+                                 -> Ptr Word8
+                                 -> IO CInt
+
+foreign import ccall unsafe "cryptonite_ed25519_point_eq"
+    ed25519_point_eq :: Ptr Point
+                     -> Ptr Point
+                     -> IO CInt
+
+foreign import ccall "cryptonite_ed25519_point_has_prime_order"
+    ed25519_point_has_prime_order :: Ptr Point
+                                  -> IO CInt
+
+foreign import ccall unsafe "cryptonite_ed25519_point_negate"
+    ed25519_point_negate :: Ptr Point -- minus_a
+                         -> Ptr Point -- a
+                         -> IO ()
+
+foreign import ccall unsafe "cryptonite_ed25519_point_add"
+    ed25519_point_add :: Ptr Point -- sum
+                      -> Ptr Point -- a
+                      -> Ptr Point -- b
+                      -> IO ()
+
+foreign import ccall unsafe "cryptonite_ed25519_point_double"
+    ed25519_point_double :: Ptr Point -- two_a
+                         -> Ptr Point -- a
+                         -> IO ()
+
+foreign import ccall unsafe "cryptonite_ed25519_point_mul_by_cofactor"
+    ed25519_point_mul_by_cofactor :: Ptr Point -- eight_a
+                                  -> Ptr Point -- a
+                                  -> IO ()
+
+foreign import ccall "cryptonite_ed25519_point_base_scalarmul"
+    ed25519_point_base_scalarmul :: Ptr Point  -- scaled
+                                 -> Ptr Scalar -- scalar
+                                 -> IO ()
+
+foreign import ccall "cryptonite_ed25519_point_scalarmul"
+    ed25519_point_scalarmul :: Ptr Point  -- scaled
+                            -> Ptr Point  -- base
+                            -> Ptr Scalar -- scalar
+                            -> IO ()
+
+foreign import ccall "cryptonite_ed25519_base_double_scalarmul_vartime"
+    ed25519_base_double_scalarmul_vartime :: Ptr Point  -- combo
+                                          -> Ptr Scalar -- scalar1
+                                          -> Ptr Point  -- base2
+                                          -> Ptr Scalar -- scalar2
+                                          -> IO ()

Crypto/ECC/Simple/Prim.hs

@@ -0,0 +1,207 @@
+-- | Elliptic Curve Arithmetic.
+--
+-- /WARNING:/ These functions are vulnerable to timing attacks.
+{-# LANGUAGE ScopedTypeVariables #-}
+module Crypto.ECC.Simple.Prim
+    ( scalarGenerate
+    , scalarFromInteger
+    , pointAdd
+    , pointNegate
+    , pointDouble
+    , pointBaseMul
+    , pointMul
+    , pointAddTwoMuls
+    , pointFromIntegers
+    , isPointAtInfinity
+    , isPointValid
+    ) where
+
+import Data.Maybe
+import Data.Proxy
+import Crypto.Number.ModArithmetic
+import Crypto.Number.F2m
+import Crypto.Number.Generate (generateBetween)
+import Crypto.ECC.Simple.Types
+import Crypto.Error
+import Crypto.Random
+
+-- | Generate a valid scalar for a specific Curve
+scalarGenerate :: forall randomly curve . (MonadRandom randomly, Curve curve) => randomly (Scalar curve)
+scalarGenerate =
+    Scalar <$> generateBetween 1 (n - 1)
+  where
+    n = curveEccN $ curveParameters (Proxy :: Proxy curve)
+
+scalarFromInteger :: forall curve . Curve curve => Integer -> CryptoFailable (Scalar curve)
+scalarFromInteger n
+    | n < 0  || n >= mx = CryptoFailed $ CryptoError_EcScalarOutOfBounds
+    | otherwise         = CryptoPassed $ Scalar n
+  where
+    mx = case curveType (Proxy :: Proxy curve) of
+            CurveBinary (CurveBinaryParam b) -> b
+            CurvePrime (CurvePrimeParam p)   -> p
+
+--TODO: Extract helper function for `fromMaybe PointO...`
+
+-- | Elliptic Curve point negation:
+-- @pointNegate p@ returns point @q@ such that @pointAdd p q == PointO@.
+pointNegate :: Curve curve => Point curve -> Point curve
+pointNegate        PointO     = PointO
+pointNegate point@(Point x y) =
+    case curveType point of
+        CurvePrime (CurvePrimeParam p) -> Point x (p - y)
+        CurveBinary {} -> Point x (x `addF2m` y)
+
+-- | Elliptic Curve point addition.
+--
+-- /WARNING:/ Vulnerable to timing attacks.
+pointAdd :: Curve curve => Point curve -> Point curve -> Point curve
+pointAdd PointO PointO = PointO
+pointAdd PointO q = q
+pointAdd p PointO = p
+pointAdd p q
+  | p == q             = pointDouble p
+  | p == pointNegate q = PointO
+pointAdd point@(Point xp yp) (Point xq yq) =
+    case ty of
+        CurvePrime (CurvePrimeParam pr) -> fromMaybe PointO $ do
+            s <- divmod (yp - yq) (xp - xq) pr
+            let xr = (s ^ (2::Int) - xp - xq) `mod` pr
+                yr = (s * (xp - xr) - yp) `mod` pr
+            return $ Point xr yr
+        CurveBinary (CurveBinaryParam fx) -> fromMaybe PointO $ do
+            s <- divF2m fx (yp `addF2m` yq) (xp `addF2m` xq)
+            let xr = mulF2m fx s s `addF2m` s `addF2m` xp `addF2m` xq `addF2m` a
+                yr = mulF2m fx s (xp `addF2m` xr) `addF2m` xr `addF2m` yp
+            return $ Point xr yr
+  where
+    ty = curveType point
+    cc = curveParameters point
+    a  = curveEccA cc
+
+-- | Elliptic Curve point doubling.
+--
+-- /WARNING:/ Vulnerable to timing attacks.
+--
+-- This perform the following calculation:
+-- > lambda = (3 * xp ^ 2 + a) / 2 yp
+-- > xr = lambda ^ 2 - 2 xp
+-- > yr = lambda (xp - xr) - yp
+--
+-- With binary curve:
+-- > xp == 0   => P = O
+-- > otherwise =>
+-- >    s = xp + (yp / xp)
+-- >    xr = s ^ 2 + s + a
+-- >    yr = xp ^ 2 + (s+1) * xr
+--
+pointDouble :: Curve curve => Point curve -> Point curve
+pointDouble PointO = PointO
+pointDouble point@(Point xp yp) =
+    case ty of
+        CurvePrime (CurvePrimeParam pr) -> fromMaybe PointO $ do
+            lambda <- divmod (3 * xp ^ (2::Int) + a) (2 * yp) pr
+            let xr = (lambda ^ (2::Int) - 2 * xp) `mod` pr
+                yr = (lambda * (xp - xr) - yp) `mod` pr
+            return $ Point xr yr
+        CurveBinary (CurveBinaryParam fx)
+            | xp == 0    -> PointO
+            | otherwise  -> fromMaybe PointO $ do
+                s <- return . addF2m xp =<< divF2m fx yp xp
+                let xr = mulF2m fx s s `addF2m` s `addF2m` a
+                    yr = mulF2m fx xp xp `addF2m` mulF2m fx xr (s `addF2m` 1)
+                return $ Point xr yr
+  where
+    ty = curveType point
+    cc = curveParameters point
+    a  = curveEccA cc
+
+-- | Elliptic curve point multiplication using the base
+--
+-- /WARNING:/ Vulnerable to timing attacks.
+pointBaseMul :: Curve curve => Scalar curve -> Point curve
+pointBaseMul n = pointMul n (curveEccG $ curveParameters (Proxy :: Proxy curve))
+
+-- | Elliptic curve point multiplication (double and add algorithm).
+--
+-- /WARNING:/ Vulnerable to timing attacks.
+pointMul :: Curve curve => Scalar curve -> Point curve -> Point curve
+pointMul _ PointO = PointO
+pointMul (Scalar n) p
+    | n == 0    = PointO
+    | n == 1    = p
+    | odd n     = pointAdd p (pointMul (Scalar (n - 1)) p)
+    | otherwise = pointMul (Scalar (n `div` 2)) (pointDouble p)
+
+-- | Elliptic curve double-scalar multiplication (uses Shamir's trick).
+--
+-- > pointAddTwoMuls n1 p1 n2 p2 == pointAdd (pointMul n1 p1)
+-- >                                         (pointMul n2 p2)
+--
+-- /WARNING:/ Vulnerable to timing attacks.
+pointAddTwoMuls :: Curve curve => Scalar curve -> Point curve -> Scalar curve -> Point curve -> Point curve
+pointAddTwoMuls _  PointO _  PointO = PointO
+pointAddTwoMuls _  PointO n2 p2     = pointMul n2 p2
+pointAddTwoMuls n1 p1     _  PointO = pointMul n1 p1
+pointAddTwoMuls (Scalar n1) p1 (Scalar n2) p2 = go (n1, n2)
+  where
+    p0 = pointAdd p1 p2
+
+    go (0,  0 ) = PointO
+    go (k1, k2) =
+        let q = pointDouble $ go (k1 `div` 2, k2 `div` 2)
+        in case (odd k1, odd k2) of
+            (True  , True  ) -> pointAdd p0 q
+            (True  , False ) -> pointAdd p1 q
+            (False , True  ) -> pointAdd p2 q
+            (False , False ) -> q
+
+-- | Check if a point is the point at infinity.
+isPointAtInfinity :: Point curve -> Bool
+isPointAtInfinity PointO = True
+isPointAtInfinity _      = False
+
+-- | Make a point on a curve from integer (x,y) coordinate
+--
+-- if the point is not valid related to the curve then an error is
+-- returned instead of a point
+pointFromIntegers :: forall curve . Curve curve => (Integer, Integer) -> CryptoFailable (Point curve)
+pointFromIntegers (x,y)
+    | isPointValid (Proxy :: Proxy curve) x y = CryptoPassed $ Point x y
+    | otherwise                               = CryptoFailed $ CryptoError_PointCoordinatesInvalid
+
+-- | check if a point is on specific curve
+--
+-- This perform three checks:
+--
+-- * x is not out of range
+-- * y is not out of range
+-- * the equation @y^2 = x^3 + a*x + b (mod p)@ holds
+isPointValid :: Curve curve => proxy curve -> Integer -> Integer -> Bool
+isPointValid proxy x y =
+    case ty of
+        CurvePrime (CurvePrimeParam p) ->
+            let a  = curveEccA cc
+                b  = curveEccB cc
+                eqModP z1 z2 = (z1 `mod` p) == (z2 `mod` p)
+                isValid e = e >= 0 && e < p
+             in isValid x && isValid y && (y ^ (2 :: Int)) `eqModP` (x ^ (3 :: Int) + a * x + b)
+        CurveBinary (CurveBinaryParam fx) ->
+            let a  = curveEccA cc
+                b  = curveEccB cc
+                add = addF2m
+                mul = mulF2m fx
+                isValid e = modF2m fx e == e
+             in and [ isValid x
+                    , isValid y
+                    , ((((x `add` a) `mul` x `add` y) `mul` x) `add` b `add` (squareF2m fx y)) == 0
+                    ]
+  where
+    ty = curveType proxy
+    cc = curveParameters proxy
+
+-- | div and mod
+divmod :: Integer -> Integer -> Integer -> Maybe Integer
+divmod y x m = do
+    i <- inverse (x `mod` m) m
+    return $ y * i `mod` m

Crypto/ECC/Simple/Types.hs

@@ -0,0 +1,616 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+-- |
+-- Module      : Crypto.ECC.Simple.Types
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : Experimental
+-- Portability : Excellent
+--
+-- References:
+--   <https://tools.ietf.org/html/rfc5915>
+--
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+module Crypto.ECC.Simple.Types
+    ( Curve(..)
+    , Point(..)
+    , Scalar(..)
+    , CurveType(..)
+    , CurveBinaryParam(..)
+    , CurvePrimeParam(..)
+    , curveSizeBits
+    , curveSizeBytes
+    , CurveParameters(..)
+    -- * Specific curves definition
+    , SEC_p112r1(..)
+    , SEC_p112r2(..)
+    , SEC_p128r1(..)
+    , SEC_p128r2(..)
+    , SEC_p160k1(..)
+    , SEC_p160r1(..)
+    , SEC_p160r2(..)
+    , SEC_p192k1(..)
+    , SEC_p192r1(..) -- aka prime192v1
+    , SEC_p224k1(..)
+    , SEC_p224r1(..)
+    , SEC_p256k1(..)
+    , SEC_p256r1(..) -- aka prime256v1
+    , SEC_p384r1(..)
+    , SEC_p521r1(..)
+    , SEC_t113r1(..)
+    , SEC_t113r2(..)
+    , SEC_t131r1(..)
+    , SEC_t131r2(..)
+    , SEC_t163k1(..)
+    , SEC_t163r1(..)
+    , SEC_t163r2(..)
+    , SEC_t193r1(..)
+    , SEC_t193r2(..)
+    , SEC_t233k1(..) -- aka NIST K-233
+    , SEC_t233r1(..)
+    , SEC_t239k1(..)
+    , SEC_t283k1(..)
+    , SEC_t283r1(..)
+    , SEC_t409k1(..)
+    , SEC_t409r1(..)
+    , SEC_t571k1(..)
+    , SEC_t571r1(..)
+    ) where
+
+import           Data.Data
+import           Crypto.Internal.Imports
+import           Crypto.Number.Basic (numBits)
+
+class Curve curve where
+    curveParameters :: proxy curve -> CurveParameters curve
+    curveType :: proxy curve -> CurveType
+
+-- | get the size of the curve in bits
+curveSizeBits :: Curve curve => proxy curve -> Int
+curveSizeBits proxy =
+    case curveType proxy of
+        CurvePrime (CurvePrimeParam p)   -> numBits p
+        CurveBinary (CurveBinaryParam c) -> numBits c - 1
+
+-- | get the size of the curve in bytes
+curveSizeBytes :: Curve curve => proxy curve -> Int
+curveSizeBytes proxy = (curveSizeBits proxy + 7) `div` 8
+
+-- | Define common parameters in a curve definition
+-- of the form: y^2 = x^3 + ax + b.
+data CurveParameters curve = CurveParameters
+    { curveEccA :: Integer     -- ^ curve parameter a
+    , curveEccB :: Integer     -- ^ curve parameter b
+    , curveEccG :: Point curve -- ^ base point
+    , curveEccN :: Integer     -- ^ order of G
+    , curveEccH :: Integer     -- ^ cofactor
+    } deriving (Show,Eq,Data)
+
+newtype CurveBinaryParam = CurveBinaryParam Integer
+    deriving (Show,Read,Eq,Data)
+
+newtype CurvePrimeParam = CurvePrimeParam Integer
+    deriving (Show,Read,Eq,Data)
+
+data CurveType =
+      CurveBinary CurveBinaryParam
+    | CurvePrime CurvePrimeParam
+    deriving (Show,Read,Eq,Data)
+
+-- | ECC Private Number
+newtype Scalar curve = Scalar Integer
+    deriving (Show,Read,Eq,Data,NFData)
+
+-- | Define a point on a curve.
+data Point curve =
+      Point Integer Integer
+    | PointO -- ^ Point at Infinity
+    deriving (Show,Read,Eq,Data)
+
+instance NFData (Point curve) where
+    rnf (Point x y) = x `seq` y `seq` ()
+    rnf PointO = ()
+
+data SEC_p112r1 = SEC_p112r1 deriving (Show,Read,Eq)
+data SEC_p112r2 = SEC_p112r2 deriving (Show,Read,Eq)
+data SEC_p128r1 = SEC_p128r1 deriving (Show,Read,Eq)
+data SEC_p128r2 = SEC_p128r2 deriving (Show,Read,Eq)
+data SEC_p160k1 = SEC_p160k1 deriving (Show,Read,Eq)
+data SEC_p160r1 = SEC_p160r1 deriving (Show,Read,Eq)
+data SEC_p160r2 = SEC_p160r2 deriving (Show,Read,Eq)
+data SEC_p192k1 = SEC_p192k1 deriving (Show,Read,Eq)
+data SEC_p192r1 = SEC_p192r1 deriving (Show,Read,Eq)
+data SEC_p224k1 = SEC_p224k1 deriving (Show,Read,Eq)
+data SEC_p224r1 = SEC_p224r1 deriving (Show,Read,Eq)
+data SEC_p256k1 = SEC_p256k1 deriving (Show,Read,Eq)
+data SEC_p256r1 = SEC_p256r1 deriving (Show,Read,Eq)
+data SEC_p384r1 = SEC_p384r1 deriving (Show,Read,Eq)
+data SEC_p521r1 = SEC_p521r1 deriving (Show,Read,Eq)
+data SEC_t113r1 = SEC_t113r1 deriving (Show,Read,Eq)
+data SEC_t113r2 = SEC_t113r2 deriving (Show,Read,Eq)
+data SEC_t131r1 = SEC_t131r1 deriving (Show,Read,Eq)
+data SEC_t131r2 = SEC_t131r2 deriving (Show,Read,Eq)
+data SEC_t163k1 = SEC_t163k1 deriving (Show,Read,Eq)
+data SEC_t163r1 = SEC_t163r1 deriving (Show,Read,Eq)
+data SEC_t163r2 = SEC_t163r2 deriving (Show,Read,Eq)
+data SEC_t193r1 = SEC_t193r1 deriving (Show,Read,Eq)
+data SEC_t193r2 = SEC_t193r2 deriving (Show,Read,Eq)
+data SEC_t233k1 = SEC_t233k1 deriving (Show,Read,Eq)
+data SEC_t233r1 = SEC_t233r1 deriving (Show,Read,Eq)
+data SEC_t239k1 = SEC_t239k1 deriving (Show,Read,Eq)
+data SEC_t283k1 = SEC_t283k1 deriving (Show,Read,Eq)
+data SEC_t283r1 = SEC_t283r1 deriving (Show,Read,Eq)
+data SEC_t409k1 = SEC_t409k1 deriving (Show,Read,Eq)
+data SEC_t409r1 = SEC_t409r1 deriving (Show,Read,Eq)
+data SEC_t571k1 = SEC_t571k1 deriving (Show,Read,Eq)
+data SEC_t571r1 = SEC_t571r1 deriving (Show,Read,Eq)
+
+-- | Define names for known recommended curves.
+instance Curve SEC_p112r1 where
+    curveType _ = typeSEC_p112r1
+    curveParameters _ = paramSEC_p112r1
+
+instance Curve SEC_p112r2 where
+    curveType _ = typeSEC_p112r2
+    curveParameters _ = paramSEC_p112r2
+
+instance Curve SEC_p128r1 where
+    curveType _ = typeSEC_p128r1
+    curveParameters _ = paramSEC_p128r1
+
+instance Curve SEC_p128r2 where
+    curveType _ = typeSEC_p128r2
+    curveParameters _ = paramSEC_p128r2
+
+instance Curve SEC_p160k1 where
+    curveType _ = typeSEC_p160k1
+    curveParameters _ = paramSEC_p160k1
+
+instance Curve SEC_p160r1 where
+    curveType _ = typeSEC_p160r1
+    curveParameters _ = paramSEC_p160r1
+
+instance Curve SEC_p160r2 where
+    curveType _ = typeSEC_p160r2
+    curveParameters _ = paramSEC_p160r2
+
+instance Curve SEC_p192k1 where
+    curveType _ = typeSEC_p192k1
+    curveParameters _ = paramSEC_p192k1
+
+instance Curve SEC_p192r1 where
+    curveType _ = typeSEC_p192r1
+    curveParameters _ = paramSEC_p192r1
+
+instance Curve SEC_p224k1 where
+    curveType _ = typeSEC_p224k1
+    curveParameters _ = paramSEC_p224k1
+
+instance Curve SEC_p224r1 where
+    curveType _ = typeSEC_p224r1
+    curveParameters _ = paramSEC_p224r1
+
+instance Curve SEC_p256k1 where
+    curveType _ = typeSEC_p256k1
+    curveParameters _ = paramSEC_p256k1
+
+instance Curve SEC_p256r1 where
+    curveType _ = typeSEC_p256r1
+    curveParameters _ = paramSEC_p256r1
+
+instance Curve SEC_p384r1 where
+    curveType _ = typeSEC_p384r1
+    curveParameters _ = paramSEC_p384r1
+
+instance Curve SEC_p521r1 where
+    curveType _ = typeSEC_p521r1
+    curveParameters _ = paramSEC_p521r1
+
+instance Curve SEC_t113r1 where
+    curveType _ = typeSEC_t113r1
+    curveParameters _ = paramSEC_t113r1
+
+instance Curve SEC_t113r2 where
+    curveType _ = typeSEC_t113r2
+    curveParameters _ = paramSEC_t113r2
+
+instance Curve SEC_t131r1 where
+    curveType _ = typeSEC_t131r1
+    curveParameters _ = paramSEC_t131r1
+
+instance Curve SEC_t131r2 where
+    curveType _ = typeSEC_t131r2
+    curveParameters _ = paramSEC_t131r2
+
+instance Curve SEC_t163k1 where
+    curveType _ = typeSEC_t163k1
+    curveParameters _ = paramSEC_t163k1
+
+instance Curve SEC_t163r1 where
+    curveType _ = typeSEC_t163r1
+    curveParameters _ = paramSEC_t163r1
+
+instance Curve SEC_t163r2 where
+    curveType _ = typeSEC_t163r2
+    curveParameters _ = paramSEC_t163r2
+
+instance Curve SEC_t193r1 where
+    curveType _ = typeSEC_t193r1
+    curveParameters _ = paramSEC_t193r1
+
+instance Curve SEC_t193r2 where
+    curveType _ = typeSEC_t193r2
+    curveParameters _ = paramSEC_t193r2
+
+instance Curve SEC_t233k1 where
+    curveType _ = typeSEC_t233k1
+    curveParameters _ = paramSEC_t233k1
+
+instance Curve SEC_t233r1 where
+    curveType _ = typeSEC_t233r1
+    curveParameters _ = paramSEC_t233r1
+
+instance Curve SEC_t239k1 where
+    curveType _ = typeSEC_t239k1
+    curveParameters _ = paramSEC_t239k1
+
+instance Curve SEC_t283k1 where
+    curveType _ = typeSEC_t283k1
+    curveParameters _ = paramSEC_t283k1
+
+instance Curve SEC_t283r1 where
+    curveType _ = typeSEC_t283r1
+    curveParameters _ = paramSEC_t283r1
+
+instance Curve SEC_t409k1 where
+    curveType _ = typeSEC_t409k1
+    curveParameters _ = paramSEC_t409k1
+
+instance Curve SEC_t409r1 where
+    curveType _ = typeSEC_t409r1
+    curveParameters _ = paramSEC_t409r1
+
+instance Curve SEC_t571k1 where
+    curveType _ = typeSEC_t571k1
+    curveParameters _ = paramSEC_t571k1
+
+instance Curve SEC_t571r1 where
+    curveType _ = typeSEC_t571r1
+    curveParameters _ = paramSEC_t571r1
+
+{-
+curvesOIDs :: [ (CurveName, [Integer]) ]
+curvesOIDs =
+    [ (SEC_p112r1, [1,3,132,0,6])
+    , (SEC_p112r2, [1,3,132,0,7])
+    , (SEC_p128r1, [1,3,132,0,28])
+    , (SEC_p128r2, [1,3,132,0,29])
+    , (SEC_p160k1, [1,3,132,0,9])
+    , (SEC_p160r1, [1,3,132,0,8])
+    , (SEC_p160r2, [1,3,132,0,30])
+    , (SEC_p192k1, [1,3,132,0,31])
+    , (SEC_p192r1, [1,2,840,10045,3,1,1])
+    , (SEC_p224k1, [1,3,132,0,32])
+    , (SEC_p224r1, [1,3,132,0,33])
+    , (SEC_p256k1, [1,3,132,0,10])
+    , (SEC_p256r1, [1,2,840,10045,3,1,7])
+    , (SEC_p384r1, [1,3,132,0,34])
+    , (SEC_p521r1, [1,3,132,0,35])
+    , (SEC_t113r1, [1,3,132,0,4])
+    , (SEC_t113r2, [1,3,132,0,5])
+    , (SEC_t131r1, [1,3,132,0,22])
+    , (SEC_t131r2, [1,3,132,0,23])
+    , (SEC_t163k1, [1,3,132,0,1])
+    , (SEC_t163r1, [1,3,132,0,2])
+    , (SEC_t163r2, [1,3,132,0,15])
+    , (SEC_t193r1, [1,3,132,0,24])
+    , (SEC_t193r2, [1,3,132,0,25])
+    , (SEC_t233k1, [1,3,132,0,26])
+    , (SEC_t233r1, [1,3,132,0,27])
+    , (SEC_t239k1, [1,3,132,0,3])
+    , (SEC_t283k1, [1,3,132,0,16])
+    , (SEC_t283r1, [1,3,132,0,17])
+    , (SEC_t409k1, [1,3,132,0,36])
+    , (SEC_t409r1, [1,3,132,0,37])
+    , (SEC_t571k1, [1,3,132,0,38])
+    , (SEC_t571r1, [1,3,132,0,39])
+    ]
+-}
+
+typeSEC_p112r1 = CurvePrime $ CurvePrimeParam 0xdb7c2abf62e35e668076bead208b
+paramSEC_p112r1 = CurveParameters
+    { curveEccA = 0xdb7c2abf62e35e668076bead2088
+    , curveEccB = 0x659ef8ba043916eede8911702b22
+    , curveEccG = Point 0x09487239995a5ee76b55f9c2f098
+                    0xa89ce5af8724c0a23e0e0ff77500
+    , curveEccN = 0xdb7c2abf62e35e7628dfac6561c5
+    , curveEccH = 1
+    }
+typeSEC_p112r2 = CurvePrime $ CurvePrimeParam 0xdb7c2abf62e35e668076bead208b
+paramSEC_p112r2 = CurveParameters
+    { curveEccA = 0x6127c24c05f38a0aaaf65c0ef02c
+    , curveEccB = 0x51def1815db5ed74fcc34c85d709
+    , curveEccG = Point 0x4ba30ab5e892b4e1649dd0928643
+                    0xadcd46f5882e3747def36e956e97
+    , curveEccN = 0x36df0aafd8b8d7597ca10520d04b
+    , curveEccH = 4
+    }
+typeSEC_p128r1 = CurvePrime $ CurvePrimeParam 0xfffffffdffffffffffffffffffffffff
+paramSEC_p128r1 = CurveParameters
+    { curveEccA = 0xfffffffdfffffffffffffffffffffffc
+    , curveEccB = 0xe87579c11079f43dd824993c2cee5ed3
+    , curveEccG = Point 0x161ff7528b899b2d0c28607ca52c5b86
+                    0xcf5ac8395bafeb13c02da292dded7a83
+    , curveEccN = 0xfffffffe0000000075a30d1b9038a115
+    , curveEccH = 1
+    }
+typeSEC_p128r2 = CurvePrime $ CurvePrimeParam 0xfffffffdffffffffffffffffffffffff
+paramSEC_p128r2 = CurveParameters
+    { curveEccA = 0xd6031998d1b3bbfebf59cc9bbff9aee1
+    , curveEccB = 0x5eeefca380d02919dc2c6558bb6d8a5d
+    , curveEccG = Point 0x7b6aa5d85e572983e6fb32a7cdebc140
+                    0x27b6916a894d3aee7106fe805fc34b44
+    , curveEccN = 0x3fffffff7fffffffbe0024720613b5a3
+    , curveEccH = 4
+    }
+typeSEC_p160k1 = CurvePrime $ CurvePrimeParam 0x00fffffffffffffffffffffffffffffffeffffac73
+paramSEC_p160k1 = CurveParameters
+    { curveEccA = 0x000000000000000000000000000000000000000000
+    , curveEccB = 0x000000000000000000000000000000000000000007
+    , curveEccG = Point 0x003b4c382ce37aa192a4019e763036f4f5dd4d7ebb
+                    0x00938cf935318fdced6bc28286531733c3f03c4fee
+    , curveEccN = 0x0100000000000000000001b8fa16dfab9aca16b6b3
+    , curveEccH = 1
+    }
+typeSEC_p160r1 = CurvePrime $ CurvePrimeParam 0x00ffffffffffffffffffffffffffffffff7fffffff
+paramSEC_p160r1 = CurveParameters
+    { curveEccA = 0x00ffffffffffffffffffffffffffffffff7ffffffc
+    , curveEccB = 0x001c97befc54bd7a8b65acf89f81d4d4adc565fa45
+    , curveEccG = Point 0x004a96b5688ef573284664698968c38bb913cbfc82
+                    0x0023a628553168947d59dcc912042351377ac5fb32
+    , curveEccN = 0x0100000000000000000001f4c8f927aed3ca752257
+    , curveEccH = 1
+    }
+typeSEC_p160r2 = CurvePrime $ CurvePrimeParam 0x00fffffffffffffffffffffffffffffffeffffac73
+paramSEC_p160r2 = CurveParameters
+    { curveEccA = 0x00fffffffffffffffffffffffffffffffeffffac70
+    , curveEccB = 0x00b4e134d3fb59eb8bab57274904664d5af50388ba
+    , curveEccG = Point 0x0052dcb034293a117e1f4ff11b30f7199d3144ce6d
+                    0x00feaffef2e331f296e071fa0df9982cfea7d43f2e
+    , curveEccN = 0x0100000000000000000000351ee786a818f3a1a16b
+    , curveEccH = 1
+    }
+typeSEC_p192k1 = CurvePrime $ CurvePrimeParam 0xfffffffffffffffffffffffffffffffffffffffeffffee37
+paramSEC_p192k1 = CurveParameters
+    { curveEccA = 0x000000000000000000000000000000000000000000000000
+    , curveEccB = 0x000000000000000000000000000000000000000000000003
+    , curveEccG = Point 0xdb4ff10ec057e9ae26b07d0280b7f4341da5d1b1eae06c7d
+                    0x9b2f2f6d9c5628a7844163d015be86344082aa88d95e2f9d
+    , curveEccN = 0xfffffffffffffffffffffffe26f2fc170f69466a74defd8d
+    , curveEccH = 1
+    }
+typeSEC_p192r1 = CurvePrime $ CurvePrimeParam 0xfffffffffffffffffffffffffffffffeffffffffffffffff
+paramSEC_p192r1 = CurveParameters
+    { curveEccA = 0xfffffffffffffffffffffffffffffffefffffffffffffffc
+    , curveEccB = 0x64210519e59c80e70fa7e9ab72243049feb8deecc146b9b1
+    , curveEccG = Point 0x188da80eb03090f67cbf20eb43a18800f4ff0afd82ff1012
+                    0x07192b95ffc8da78631011ed6b24cdd573f977a11e794811
+    , curveEccN = 0xffffffffffffffffffffffff99def836146bc9b1b4d22831
+    , curveEccH = 1
+    }
+typeSEC_p224k1 = CurvePrime $ CurvePrimeParam 0x00fffffffffffffffffffffffffffffffffffffffffffffffeffffe56d
+paramSEC_p224k1 = CurveParameters
+    { curveEccA = 0x0000000000000000000000000000000000000000000000000000000000
+    , curveEccB = 0x0000000000000000000000000000000000000000000000000000000005
+    , curveEccG = Point 0x00a1455b334df099df30fc28a169a467e9e47075a90f7e650eb6b7a45c
+                    0x007e089fed7fba344282cafbd6f7e319f7c0b0bd59e2ca4bdb556d61a5
+    , curveEccN = 0x010000000000000000000000000001dce8d2ec6184caf0a971769fb1f7
+    , curveEccH = 1
+    }
+typeSEC_p224r1 = CurvePrime $ CurvePrimeParam 0xffffffffffffffffffffffffffffffff000000000000000000000001
+paramSEC_p224r1 = CurveParameters
+    { curveEccA = 0xfffffffffffffffffffffffffffffffefffffffffffffffffffffffe
+    , curveEccB = 0xb4050a850c04b3abf54132565044b0b7d7bfd8ba270b39432355ffb4
+    , curveEccG = Point 0xb70e0cbd6bb4bf7f321390b94a03c1d356c21122343280d6115c1d21
+                    0xbd376388b5f723fb4c22dfe6cd4375a05a07476444d5819985007e34
+    , curveEccN = 0xffffffffffffffffffffffffffff16a2e0b8f03e13dd29455c5c2a3d
+    , curveEccH = 1
+    }
+typeSEC_p256k1 = CurvePrime $ CurvePrimeParam 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffefffffc2f
+paramSEC_p256k1 = CurveParameters
+    { curveEccA = 0x0000000000000000000000000000000000000000000000000000000000000000
+    , curveEccB = 0x0000000000000000000000000000000000000000000000000000000000000007
+    , curveEccG = Point 0x79be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798
+                    0x483ada7726a3c4655da4fbfc0e1108a8fd17b448a68554199c47d08ffb10d4b8
+    , curveEccN = 0xfffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364141
+    , curveEccH = 1
+    }
+typeSEC_p256r1 = CurvePrime $ CurvePrimeParam 0xffffffff00000001000000000000000000000000ffffffffffffffffffffffff
+paramSEC_p256r1 = CurveParameters
+    { curveEccA = 0xffffffff00000001000000000000000000000000fffffffffffffffffffffffc
+    , curveEccB = 0x5ac635d8aa3a93e7b3ebbd55769886bc651d06b0cc53b0f63bce3c3e27d2604b
+    , curveEccG = Point 0x6b17d1f2e12c4247f8bce6e563a440f277037d812deb33a0f4a13945d898c296
+                    0x4fe342e2fe1a7f9b8ee7eb4a7c0f9e162bce33576b315ececbb6406837bf51f5
+    , curveEccN = 0xffffffff00000000ffffffffffffffffbce6faada7179e84f3b9cac2fc632551
+    , curveEccH = 1
+    }
+typeSEC_p384r1 = CurvePrime $ CurvePrimeParam 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffeffffffff0000000000000000ffffffff
+paramSEC_p384r1 = CurveParameters
+    { curveEccA = 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffeffffffff0000000000000000fffffffc
+    , curveEccB = 0xb3312fa7e23ee7e4988e056be3f82d19181d9c6efe8141120314088f5013875ac656398d8a2ed19d2a85c8edd3ec2aef
+    , curveEccG = Point 0xaa87ca22be8b05378eb1c71ef320ad746e1d3b628ba79b9859f741e082542a385502f25dbf55296c3a545e3872760ab7
+                    0x3617de4a96262c6f5d9e98bf9292dc29f8f41dbd289a147ce9da3113b5f0b8c00a60b1ce1d7e819d7a431d7c90ea0e5f
+    , curveEccN = 0xffffffffffffffffffffffffffffffffffffffffffffffffc7634d81f4372ddf581a0db248b0a77aecec196accc52973
+    , curveEccH = 1
+    }
+typeSEC_p521r1 = CurvePrime $ CurvePrimeParam 0x01ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff
+paramSEC_p521r1 = CurveParameters
+    { curveEccA = 0x01fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffc
+    , curveEccB = 0x0051953eb9618e1c9a1f929a21a0b68540eea2da725b99b315f3b8b489918ef109e156193951ec7e937b1652c0bd3bb1bf073573df883d2c34f1ef451fd46b503f00
+    , curveEccG = Point 0x00c6858e06b70404e9cd9e3ecb662395b4429c648139053fb521f828af606b4d3dbaa14b5e77efe75928fe1dc127a2ffa8de3348b3c1856a429bf97e7e31c2e5bd66
+                    0x011839296a789a3bc0045c8a5fb42c7d1bd998f54449579b446817afbd17273e662c97ee72995ef42640c550b9013fad0761353c7086a272c24088be94769fd16650
+    , curveEccN = 0x01fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffa51868783bf2f966b7fcc0148f709a5d03bb5c9b8899c47aebb6fb71e91386409
+    , curveEccH = 1
+    }
+typeSEC_t113r1 = CurveBinary $ CurveBinaryParam 0x020000000000000000000000000201
+paramSEC_t113r1 = CurveParameters
+    { curveEccA = 0x003088250ca6e7c7fe649ce85820f7
+    , curveEccB = 0x00e8bee4d3e2260744188be0e9c723
+    , curveEccG = Point 0x009d73616f35f4ab1407d73562c10f
+                    0x00a52830277958ee84d1315ed31886
+    , curveEccN = 0x0100000000000000d9ccec8a39e56f
+    , curveEccH = 2
+    }
+typeSEC_t113r2 = CurveBinary $ CurveBinaryParam 0x020000000000000000000000000201
+paramSEC_t113r2 = CurveParameters
+    { curveEccA = 0x00689918dbec7e5a0dd6dfc0aa55c7
+    , curveEccB = 0x0095e9a9ec9b297bd4bf36e059184f
+    , curveEccG = Point 0x01a57a6a7b26ca5ef52fcdb8164797
+                    0x00b3adc94ed1fe674c06e695baba1d
+    , curveEccN = 0x010000000000000108789b2496af93
+    , curveEccH = 2
+    }
+typeSEC_t131r1 = CurveBinary $ CurveBinaryParam 0x080000000000000000000000000000010d
+paramSEC_t131r1 = CurveParameters
+    { curveEccA = 0x07a11b09a76b562144418ff3ff8c2570b8
+    , curveEccB = 0x0217c05610884b63b9c6c7291678f9d341
+    , curveEccG = Point 0x0081baf91fdf9833c40f9c181343638399
+                    0x078c6e7ea38c001f73c8134b1b4ef9e150
+    , curveEccN = 0x0400000000000000023123953a9464b54d
+    , curveEccH = 2
+    }
+typeSEC_t131r2 = CurveBinary $ CurveBinaryParam 0x080000000000000000000000000000010d
+paramSEC_t131r2 = CurveParameters
+    { curveEccA = 0x03e5a88919d7cafcbf415f07c2176573b2
+    , curveEccB = 0x04b8266a46c55657ac734ce38f018f2192
+    , curveEccG = Point 0x0356dcd8f2f95031ad652d23951bb366a8
+                    0x0648f06d867940a5366d9e265de9eb240f
+    , curveEccN = 0x0400000000000000016954a233049ba98f
+    , curveEccH = 2
+    }
+typeSEC_t163k1 = CurveBinary $ CurveBinaryParam 0x0800000000000000000000000000000000000000c9
+paramSEC_t163k1 = CurveParameters
+    { curveEccA = 0x000000000000000000000000000000000000000001
+    , curveEccB = 0x000000000000000000000000000000000000000001
+    , curveEccG = Point 0x02fe13c0537bbc11acaa07d793de4e6d5e5c94eee8
+                    0x0289070fb05d38ff58321f2e800536d538ccdaa3d9
+    , curveEccN = 0x04000000000000000000020108a2e0cc0d99f8a5ef
+    , curveEccH = 2
+    }
+typeSEC_t163r1 = CurveBinary $ CurveBinaryParam 0x0800000000000000000000000000000000000000c9
+paramSEC_t163r1 = CurveParameters
+    { curveEccA = 0x07b6882caaefa84f9554ff8428bd88e246d2782ae2
+    , curveEccB = 0x0713612dcddcb40aab946bda29ca91f73af958afd9
+    , curveEccG = Point 0x0369979697ab43897789566789567f787a7876a654
+                    0x00435edb42efafb2989d51fefce3c80988f41ff883
+    , curveEccN = 0x03ffffffffffffffffffff48aab689c29ca710279b
+    , curveEccH = 2
+    }
+typeSEC_t163r2 = CurveBinary $ CurveBinaryParam 0x0800000000000000000000000000000000000000c9
+paramSEC_t163r2 = CurveParameters
+    { curveEccA = 0x000000000000000000000000000000000000000001
+    , curveEccB = 0x020a601907b8c953ca1481eb10512f78744a3205fd
+    , curveEccG = Point 0x03f0eba16286a2d57ea0991168d4994637e8343e36
+                    0x00d51fbc6c71a0094fa2cdd545b11c5c0c797324f1
+    , curveEccN = 0x040000000000000000000292fe77e70c12a4234c33
+    , curveEccH = 2
+    }
+typeSEC_t193r1 = CurveBinary $ CurveBinaryParam 0x02000000000000000000000000000000000000000000008001
+paramSEC_t193r1 = CurveParameters
+    { curveEccA = 0x0017858feb7a98975169e171f77b4087de098ac8a911df7b01
+    , curveEccB = 0x00fdfb49bfe6c3a89facadaa7a1e5bbc7cc1c2e5d831478814
+    , curveEccG = Point 0x01f481bc5f0ff84a74ad6cdf6fdef4bf6179625372d8c0c5e1
+                    0x0025e399f2903712ccf3ea9e3a1ad17fb0b3201b6af7ce1b05
+    , curveEccN = 0x01000000000000000000000000c7f34a778f443acc920eba49
+    , curveEccH = 2
+    }
+typeSEC_t193r2 = CurveBinary $ CurveBinaryParam 0x02000000000000000000000000000000000000000000008001
+paramSEC_t193r2 = CurveParameters
+    { curveEccA = 0x0163f35a5137c2ce3ea6ed8667190b0bc43ecd69977702709b
+    , curveEccB = 0x00c9bb9e8927d4d64c377e2ab2856a5b16e3efb7f61d4316ae
+    , curveEccG = Point 0x00d9b67d192e0367c803f39e1a7e82ca14a651350aae617e8f
+                    0x01ce94335607c304ac29e7defbd9ca01f596f927224cdecf6c
+    , curveEccN = 0x010000000000000000000000015aab561b005413ccd4ee99d5
+    , curveEccH = 2
+    }
+typeSEC_t233k1 = CurveBinary $ CurveBinaryParam 0x020000000000000000000000000000000000000004000000000000000001
+paramSEC_t233k1 = CurveParameters
+    { curveEccA = 0x000000000000000000000000000000000000000000000000000000000000
+    , curveEccB = 0x000000000000000000000000000000000000000000000000000000000001
+    , curveEccG = Point 0x017232ba853a7e731af129f22ff4149563a419c26bf50a4c9d6eefad6126
+                    0x01db537dece819b7f70f555a67c427a8cd9bf18aeb9b56e0c11056fae6a3
+    , curveEccN = 0x008000000000000000000000000000069d5bb915bcd46efb1ad5f173abdf
+    , curveEccH = 4
+    }
+typeSEC_t233r1 = CurveBinary $ CurveBinaryParam 0x020000000000000000000000000000000000000004000000000000000001
+paramSEC_t233r1 = CurveParameters
+    { curveEccA = 0x000000000000000000000000000000000000000000000000000000000001
+    , curveEccB = 0x0066647ede6c332c7f8c0923bb58213b333b20e9ce4281fe115f7d8f90ad
+    , curveEccG = Point 0x00fac9dfcbac8313bb2139f1bb755fef65bc391f8b36f8f8eb7371fd558b
+                    0x01006a08a41903350678e58528bebf8a0beff867a7ca36716f7e01f81052
+    , curveEccN = 0x01000000000000000000000000000013e974e72f8a6922031d2603cfe0d7
+    , curveEccH = 2
+    }
+typeSEC_t239k1 = CurveBinary $ CurveBinaryParam 0x800000000000000000004000000000000000000000000000000000000001
+paramSEC_t239k1 = CurveParameters
+    { curveEccA = 0x000000000000000000000000000000000000000000000000000000000000
+    , curveEccB = 0x000000000000000000000000000000000000000000000000000000000001
+    , curveEccG = Point 0x29a0b6a887a983e9730988a68727a8b2d126c44cc2cc7b2a6555193035dc
+                    0x76310804f12e549bdb011c103089e73510acb275fc312a5dc6b76553f0ca
+    , curveEccN = 0x2000000000000000000000000000005a79fec67cb6e91f1c1da800e478a5
+    , curveEccH = 4
+    }
+typeSEC_t283k1 = CurveBinary $ CurveBinaryParam 0x0800000000000000000000000000000000000000000000000000000000000000000010a1
+paramSEC_t283k1 = CurveParameters
+    { curveEccA = 0x000000000000000000000000000000000000000000000000000000000000000000000000
+    , curveEccB = 0x000000000000000000000000000000000000000000000000000000000000000000000001
+    , curveEccG = Point 0x0503213f78ca44883f1a3b8162f188e553cd265f23c1567a16876913b0c2ac2458492836
+                    0x01ccda380f1c9e318d90f95d07e5426fe87e45c0e8184698e45962364e34116177dd2259
+    , curveEccN = 0x01ffffffffffffffffffffffffffffffffffe9ae2ed07577265dff7f94451e061e163c61
+    , curveEccH = 4
+    }
+typeSEC_t283r1 = CurveBinary $ CurveBinaryParam 0x0800000000000000000000000000000000000000000000000000000000000000000010a1
+paramSEC_t283r1 = CurveParameters
+    { curveEccA = 0x000000000000000000000000000000000000000000000000000000000000000000000001
+    , curveEccB = 0x027b680ac8b8596da5a4af8a19a0303fca97fd7645309fa2a581485af6263e313b79a2f5
+    , curveEccG = Point 0x05f939258db7dd90e1934f8c70b0dfec2eed25b8557eac9c80e2e198f8cdbecd86b12053
+                    0x03676854fe24141cb98fe6d4b20d02b4516ff702350eddb0826779c813f0df45be8112f4
+    , curveEccN = 0x03ffffffffffffffffffffffffffffffffffef90399660fc938a90165b042a7cefadb307
+    , curveEccH = 2
+    }
+typeSEC_t409k1 = CurveBinary $ CurveBinaryParam 0x02000000000000000000000000000000000000000000000000000000000000000000000000000000008000000000000000000001
+paramSEC_t409k1 = CurveParameters
+    { curveEccA = 0x00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
+    , curveEccB = 0x00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001
+    , curveEccG = Point 0x0060f05f658f49c1ad3ab1890f7184210efd0987e307c84c27accfb8f9f67cc2c460189eb5aaaa62ee222eb1b35540cfe9023746
+                    0x01e369050b7c4e42acba1dacbf04299c3460782f918ea427e6325165e9ea10e3da5f6c42e9c55215aa9ca27a5863ec48d8e0286b
+    , curveEccN = 0x007ffffffffffffffffffffffffffffffffffffffffffffffffffe5f83b2d4ea20400ec4557d5ed3e3e7ca5b4b5c83b8e01e5fcf
+    , curveEccH = 4
+    }
+typeSEC_t409r1 = CurveBinary $ CurveBinaryParam 0x02000000000000000000000000000000000000000000000000000000000000000000000000000000008000000000000000000001
+paramSEC_t409r1 = CurveParameters
+    { curveEccA = 0x00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001
+    , curveEccB = 0x0021a5c2c8ee9feb5c4b9a753b7b476b7fd6422ef1f3dd674761fa99d6ac27c8a9a197b272822f6cd57a55aa4f50ae317b13545f
+    , curveEccG = Point 0x015d4860d088ddb3496b0c6064756260441cde4af1771d4db01ffe5b34e59703dc255a868a1180515603aeab60794e54bb7996a7
+                    0x0061b1cfab6be5f32bbfa78324ed106a7636b9c5a7bd198d0158aa4f5488d08f38514f1fdf4b4f40d2181b3681c364ba0273c706
+    , curveEccN = 0x010000000000000000000000000000000000000000000000000001e2aad6a612f33307be5fa47c3c9e052f838164cd37d9a21173
+    , curveEccH = 2
+    }
+typeSEC_t571k1 = CurveBinary $ CurveBinaryParam 0x080000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000425
+paramSEC_t571k1 = CurveParameters
+    { curveEccA = 0x000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000
+    , curveEccB = 0x000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001
+    , curveEccG = Point 0x026eb7a859923fbc82189631f8103fe4ac9ca2970012d5d46024804801841ca44370958493b205e647da304db4ceb08cbbd1ba39494776fb988b47174dca88c7e2945283a01c8972
+                    0x0349dc807f4fbf374f4aeade3bca95314dd58cec9f307a54ffc61efc006d8a2c9d4979c0ac44aea74fbebbb9f772aedcb620b01a7ba7af1b320430c8591984f601cd4c143ef1c7a3
+    , curveEccN = 0x020000000000000000000000000000000000000000000000000000000000000000000000131850e1f19a63e4b391a8db917f4138b630d84be5d639381e91deb45cfe778f637c1001
+    , curveEccH = 4
+    }
+typeSEC_t571r1 = CurveBinary $ CurveBinaryParam 0x080000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000425
+paramSEC_t571r1 = CurveParameters
+    { curveEccA = 0x000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001
+    , curveEccB = 0x02f40e7e2221f295de297117b7f3d62f5c6a97ffcb8ceff1cd6ba8ce4a9a18ad84ffabbd8efa59332be7ad6756a66e294afd185a78ff12aa520e4de739baca0c7ffeff7f2955727a
+    , curveEccG = Point 0x0303001d34b856296c16c0d40d3cd7750a93d1d2955fa80aa5f40fc8db7b2abdbde53950f4c0d293cdd711a35b67fb1499ae60038614f1394abfa3b4c850d927e1e7769c8eec2d19
+                    0x037bf27342da639b6dccfffeb73d69d78c6c27a6009cbbca1980f8533921e8a684423e43bab08a576291af8f461bb2a8b3531d2f0485c19b16e2f1516e23dd3c1a4827af1b8ac15b
+    , curveEccN = 0x03ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe661ce18ff55987308059b186823851ec7dd9ca1161de93d5174d66e8382e9bb2fe84e47
+    , curveEccH = 2
+    }

Crypto/Error/Types.hs

@@ -8,6 +8,7 @@
 -- Cryptographic Error enumeration and handling
 --
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies       #-}
 module Crypto.Error.Types
     ( CryptoError(..)
     , CryptoFailable(..)
@@ -21,21 +22,37 @@ module Crypto.Error.Types
 import qualified Control.Exception as E
 import           Data.Data
 
-import           Crypto.Internal.Imports
+import           Basement.Monad (MonadFailure(..))
 
 -- | Enumeration of all possible errors that can be found in this library
 data CryptoError =
     -- symmetric cipher errors
       CryptoError_KeySizeInvalid
     | CryptoError_IvSizeInvalid
+    | CryptoError_SeedSizeInvalid
     | CryptoError_AEADModeNotSupported
     -- public key cryptography error
     | CryptoError_SecretKeySizeInvalid
     | CryptoError_SecretKeyStructureInvalid
     | CryptoError_PublicKeySizeInvalid
+    | CryptoError_SharedSecretSizeInvalid
+    -- elliptic cryptography error
+    | CryptoError_EcScalarOutOfBounds
+    | CryptoError_PointSizeInvalid
+    | CryptoError_PointFormatInvalid
+    | CryptoError_PointFormatUnsupported
+    | CryptoError_PointCoordinatesInvalid
+    | CryptoError_ScalarMultiplicationInvalid
     -- Message authentification error
     | CryptoError_MacKeyInvalid
-    deriving (Show,Eq,Enum,Data,Typeable)
+    | CryptoError_AuthenticationTagSizeInvalid
+    -- Prime generation error
+    | CryptoError_PrimeSizeInvalid
+    -- Parameter errors
+    | CryptoError_SaltTooSmall
+    | CryptoError_OutputLengthTooSmall
+    | CryptoError_OutputLengthTooBig
+    deriving (Show,Eq,Enum,Data)
 
 instance E.Exception CryptoError
 
@@ -50,10 +67,8 @@ instance E.Exception CryptoError
 data CryptoFailable a =
       CryptoPassed a
     | CryptoFailed CryptoError
+    deriving (Show)
 
-instance Show a => Show (CryptoFailable a) where
-    show (CryptoPassed a)   = "CryptoPassed " ++ show a
-    show (CryptoFailed err) = "CryptoFailed " ++ show err
 instance Eq a => Eq (CryptoFailable a) where
     (==) (CryptoPassed a)  (CryptoPassed b)  = a == b
     (==) (CryptoFailed e1) (CryptoFailed e2) = e1 == e2
@@ -67,12 +82,16 @@ instance Applicative CryptoFailable where
     pure a     = CryptoPassed a
     (<*>) fm m = fm >>= \p -> m >>= \r2 -> return (p r2)
 instance Monad CryptoFailable where
-    return a = CryptoPassed a
+    return = pure
     (>>=) m1 m2 = do
         case m1 of
             CryptoPassed a -> m2 a
             CryptoFailed e -> CryptoFailed e
 
+instance MonadFailure CryptoFailable where
+    type Failure CryptoFailable = CryptoError
+    mFail = CryptoFailed
+
 -- | Throw an CryptoError as exception on CryptoFailed result,
 -- otherwise return the computed value
 throwCryptoErrorIO :: CryptoFailable a -> IO a

Crypto/Hash.hs

@@ -16,6 +16,8 @@
 -- > hexSha3_512 :: ByteString -> String
 -- > hexSha3_512 bs = show (hash bs :: Digest SHA3_512)
 --
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE BangPatterns        #-}
 module Crypto.Hash
     (
     -- * Types
@@ -23,77 +25,110 @@ module Crypto.Hash
     , Digest
     -- * Functions
     , digestFromByteString
-    -- * hash methods parametrized by algorithm
+    -- * Hash methods parametrized by algorithm
     , hashInitWith
     , hashWith
-    -- * hash methods
+    , hashPrefixWith
+    -- * Hash methods
     , hashInit
     , hashUpdates
     , hashUpdate
     , hashFinalize
+    , hashFinalizePrefix
     , hashBlockSize
     , hashDigestSize
     , hash
+    , hashPrefix
     , hashlazy
+    , hashPutContext
+    , hashGetContext
     -- * Hash algorithms
     , module Crypto.Hash.Algorithms
     ) where
 
-import           Control.Monad
+import           Basement.Types.OffsetSize (CountOf (..))
+import           Basement.Block (Block, unsafeFreeze)
+import           Basement.Block.Mutable (copyFromPtr, new)
+import           Crypto.Internal.Compat (unsafeDoIO)
 import           Crypto.Hash.Types
 import           Crypto.Hash.Algorithms
-import           Foreign.Ptr (Ptr)
-import           Crypto.Internal.ByteArray (ByteArrayAccess)
+import           Foreign.Ptr (Ptr, plusPtr)
+import           Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray)
 import qualified Crypto.Internal.ByteArray as B
 import qualified Data.ByteString.Lazy as L
+import           Data.Word (Word8)
+import           Data.Int (Int32)
 
 -- | Hash a strict bytestring into a digest.
 hash :: (ByteArrayAccess ba, HashAlgorithm a) => ba -> Digest a
 hash bs = hashFinalize $ hashUpdate hashInit bs
 
+-- | Hash the first N bytes of a bytestring, with code path independent from N.
+hashPrefix :: (ByteArrayAccess ba, HashAlgorithmPrefix a) => ba -> Int -> Digest a
+hashPrefix = hashFinalizePrefix hashInit
+
 -- | Hash a lazy bytestring into a digest.
 hashlazy :: HashAlgorithm a => L.ByteString -> Digest a
 hashlazy lbs = hashFinalize $ hashUpdates hashInit (L.toChunks lbs)
 
 -- | Initialize a new context for this hash algorithm
-hashInit :: HashAlgorithm a
-         => Context a
-hashInit = doInit undefined B.allocAndFreeze
-  where
-        doInit :: HashAlgorithm a => a -> (Int -> (Ptr (Context a) -> IO ()) -> B.Bytes) -> Context a
-        doInit alg alloc = Context $ alloc (hashInternalContextSize alg) hashInternalInit
-{-# NOINLINE hashInit #-}
+hashInit :: forall a . HashAlgorithm a => Context a
+hashInit = Context $ B.allocAndFreeze (hashInternalContextSize (undefined :: a)) $ \(ptr :: Ptr (Context a)) ->
+    hashInternalInit ptr
 
 -- | run hashUpdates on one single bytestring and return the updated context.
 hashUpdate :: (ByteArrayAccess ba, HashAlgorithm a) => Context a -> ba -> Context a
-hashUpdate ctx b = hashUpdates ctx [b]
+hashUpdate ctx b
+    | B.null b  = ctx
+    | otherwise = hashUpdates ctx [b]
 
 -- | Update the context with a list of strict bytestring,
 -- and return a new context with the updates.
-hashUpdates :: (HashAlgorithm a, ByteArrayAccess ba)
+hashUpdates :: forall a ba . (HashAlgorithm a, ByteArrayAccess ba)
             => Context a
             -> [ba]
             -> Context a
-hashUpdates c l = doUpdates (B.copyAndFreeze c)
-  where doUpdates :: HashAlgorithm a => ((Ptr (Context a) -> IO ()) -> B.Bytes) -> Context a
-        doUpdates copy = Context $ copy $ \ctx ->
-            mapM_ (\b -> B.withByteArray b $ \d -> hashInternalUpdate ctx d (fromIntegral $ B.length b)) l
-{-# NOINLINE hashUpdates #-}
+hashUpdates c l
+    | null ls   = c
+    | otherwise = Context $ B.copyAndFreeze c $ \(ctx :: Ptr (Context a)) ->
+        mapM_ (\b -> B.withByteArray b (processBlocks ctx (B.length b))) ls
+  where
+    ls = filter (not . B.null) l
+    -- process the data in 2GB chunks to fit in uint32_t and Int on 32 bit systems
+    processBlocks ctx bytesLeft dataPtr
+        | bytesLeft == 0 = return ()
+        | otherwise = do
+            hashInternalUpdate ctx dataPtr (fromIntegral actuallyProcessed)
+            processBlocks ctx (bytesLeft - actuallyProcessed) (dataPtr `plusPtr` actuallyProcessed)
+        where
+            actuallyProcessed = min bytesLeft (fromIntegral (maxBound :: Int32))
 
 -- | Finalize a context and return a digest.
-hashFinalize :: HashAlgorithm a
+hashFinalize :: forall a . HashAlgorithm a
              => Context a
              -> Digest a
-hashFinalize c = doFinalize undefined (B.copy c) (B.allocAndFreeze)
-  where doFinalize :: HashAlgorithm alg
-                   => alg
-                   -> ((Ptr (Context alg) -> IO ()) -> IO B.Bytes)
-                   -> (Int -> (Ptr (Digest alg)  -> IO ()) -> B.Bytes)
-                   -> Digest alg
-        doFinalize alg copy allocDigest =
-            Digest $ allocDigest (hashDigestSize alg) $ \dig ->
-                (void $ copy $ \ctx -> hashInternalFinalize ctx dig)
-{-# NOINLINE hashFinalize #-}
+hashFinalize !c =
+    Digest $ B.allocAndFreeze (hashDigestSize (undefined :: a)) $ \(dig :: Ptr (Digest a)) -> do
+        ((!_) :: B.Bytes) <- B.copy c $ \(ctx :: Ptr (Context a)) -> hashInternalFinalize ctx dig
+        return ()
+
+-- | Update the context with the first N bytes of a bytestring and return the
+-- digest.  The code path is independent from N but much slower than a normal
+-- 'hashUpdate'.  The function can be called for the last bytes of a message, in
+-- order to exclude a variable padding, without leaking the padding length.  The
+-- begining of the message, never impacted by the padding, should preferably go
+-- through 'hashUpdate' for better performance.
+hashFinalizePrefix :: forall a ba . (HashAlgorithmPrefix a, ByteArrayAccess ba)
+                   => Context a
+                   -> ba
+                   -> Int
+                   -> Digest a
+hashFinalizePrefix !c b len =
+    Digest $ B.allocAndFreeze (hashDigestSize (undefined :: a)) $ \(dig :: Ptr (Digest a)) -> do
+        ((!_) :: B.Bytes) <- B.copy c $ \(ctx :: Ptr (Context a)) ->
+            B.withByteArray b $ \d ->
+                hashInternalFinalizePrefix ctx d (fromIntegral $ B.length b) (fromIntegral len) dig
+        return ()
 
 -- | Initialize a new context for a specified hash algorithm
 hashInitWith :: HashAlgorithm alg => alg -> Context alg
@@ -103,14 +138,39 @@ hashInitWith _ = hashInit
 hashWith :: (ByteArrayAccess ba, HashAlgorithm alg) => alg -> ba -> Digest alg
 hashWith _ = hash
 
+-- | Run the 'hashPrefix' function but takes an explicit hash algorithm parameter
+hashPrefixWith :: (ByteArrayAccess ba, HashAlgorithmPrefix alg) => alg -> ba -> Int -> Digest alg
+hashPrefixWith _ = hashPrefix
+
 -- | Try to transform a bytearray into a Digest of specific algorithm.
 --
 -- If the digest is not the right size for the algorithm specified, then
 -- Nothing is returned.
-digestFromByteString :: (HashAlgorithm a, ByteArrayAccess ba) => ba -> Maybe (Digest a)
+digestFromByteString :: forall a ba . (HashAlgorithm a, ByteArrayAccess ba) => ba -> Maybe (Digest a)
 digestFromByteString = from undefined
   where
-        from :: (HashAlgorithm a, ByteArrayAccess ba) => a -> ba -> Maybe (Digest a)
+        from :: a -> ba -> Maybe (Digest a)
         from alg bs
-            | B.length bs == (hashDigestSize alg) = (Just $ Digest $ B.convert bs)
+            | B.length bs == (hashDigestSize alg) = Just $ Digest $ unsafeDoIO $ copyBytes bs
             | otherwise                           = Nothing
+
+        copyBytes :: ba -> IO (Block Word8)
+        copyBytes ba = do
+            muArray <- new count
+            B.withByteArray ba $ \ptr -> copyFromPtr ptr muArray 0 count
+            unsafeFreeze muArray
+          where
+            count = CountOf (B.length ba)
+
+hashPutContext :: forall a ba. (HashAlgorithmResumable a, ByteArray ba) => Context a -> ba
+hashPutContext !c = B.allocAndFreeze (hashInternalContextSize (undefined :: a)) $ \(ptr :: Ptr Word8) ->
+  B.withByteArray c $ \(ctx :: Ptr (Context a)) -> hashInternalPutContextBE ctx ptr
+
+hashGetContext :: forall a ba. (HashAlgorithmResumable a, ByteArrayAccess ba) => ba -> Maybe (Context a)
+hashGetContext = from undefined
+  where
+        from :: a -> ba -> Maybe (Context a)
+        from alg bs
+          | B.length bs == (hashInternalContextSize alg) = Just $ Context $ B.allocAndFreeze (B.length bs) $ \(ctx :: Ptr (Context a)) ->
+              B.withByteArray bs $ \ptr -> hashInternalGetContextBE ptr ctx
+          | otherwise                                    = Nothing

Crypto/Hash/Algorithms.hs

@@ -9,7 +9,20 @@
 --
 module Crypto.Hash.Algorithms
     ( HashAlgorithm
-    -- * hash algorithms
+    , HashAlgorithmPrefix
+    , HashAlgorithmResumable
+    -- * Hash algorithms
+    , Blake2s_160(..)
+    , Blake2s_224(..)
+    , Blake2s_256(..)
+    , Blake2sp_224(..)
+    , Blake2sp_256(..)
+    , Blake2b_160(..)
+    , Blake2b_224(..)
+    , Blake2b_256(..)
+    , Blake2b_384(..)
+    , Blake2b_512(..)
+    , Blake2bp_512(..)
     , MD2(..)
     , MD4(..)
     , MD5(..)
@@ -22,14 +35,18 @@ module Crypto.Hash.Algorithms
     , SHA512t_256(..)
     , RIPEMD160(..)
     , Tiger(..)
-    , Kekkak_224(..)
-    , Kekkak_256(..)
-    , Kekkak_384(..)
-    , Kekkak_512(..)
+    , Keccak_224(..)
+    , Keccak_256(..)
+    , Keccak_384(..)
+    , Keccak_512(..)
     , SHA3_224(..)
     , SHA3_256(..)
     , SHA3_384(..)
     , SHA3_512(..)
+    , SHAKE128(..)
+    , SHAKE256(..)
+    , Blake2b(..), Blake2bp(..)
+    , Blake2s(..), Blake2sp(..)
     , Skein256_224(..)
     , Skein256_256(..)
     , Skein512_224(..)
@@ -39,7 +56,11 @@ module Crypto.Hash.Algorithms
     , Whirlpool(..)
     ) where
 
-import           Crypto.Hash.Types (HashAlgorithm)
+import           Crypto.Hash.Types (HashAlgorithm, HashAlgorithmPrefix, HashAlgorithmResumable)
+import           Crypto.Hash.Blake2s
+import           Crypto.Hash.Blake2sp
+import           Crypto.Hash.Blake2b
+import           Crypto.Hash.Blake2bp
 import           Crypto.Hash.MD2
 import           Crypto.Hash.MD4
 import           Crypto.Hash.MD5
@@ -50,9 +71,11 @@ import           Crypto.Hash.SHA384
 import           Crypto.Hash.SHA512
 import           Crypto.Hash.SHA512t
 import           Crypto.Hash.SHA3
-import           Crypto.Hash.Kekkak
+import           Crypto.Hash.Keccak
 import           Crypto.Hash.RIPEMD160
 import           Crypto.Hash.Tiger
 import           Crypto.Hash.Skein256
 import           Crypto.Hash.Skein512
 import           Crypto.Hash.Whirlpool
+import           Crypto.Hash.SHAKE
+import           Crypto.Hash.Blake2

Crypto/Hash/Blake2.hs

@@ -0,0 +1,162 @@
+-- |
+-- Module      : Crypto.Hash.Blake2
+-- License     : BSD-style
+-- Maintainer  : Nicolas Di Prima <nicolas@primetype.co.uk>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Module containing the binding functions to work with the
+-- Blake2
+--
+-- Implementation based from [RFC7693](https://tools.ietf.org/html/rfc7693)
+--
+-- Please consider the following when chosing a hash:
+--
+--      Algorithm     | Target | Collision | Digest Size |
+--         Identifier |  Arch  |  Security |   in bytes  |
+--     ---------------+--------+-----------+-------------+
+--      id-blake2b160 | 64-bit |   2**80   |         20  |
+--      id-blake2b256 | 64-bit |   2**128  |         32  |
+--      id-blake2b384 | 64-bit |   2**192  |         48  |
+--      id-blake2b512 | 64-bit |   2**256  |         64  |
+--     ---------------+--------+-----------+-------------+
+--      id-blake2s128 | 32-bit |   2**64   |         16  |
+--      id-blake2s160 | 32-bit |   2**80   |         20  |
+--      id-blake2s224 | 32-bit |   2**112  |         28  |
+--      id-blake2s256 | 32-bit |   2**128  |         32  |
+--     ---------------+--------+-----------+-------------+
+--
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+module Crypto.Hash.Blake2
+    ( Blake2s(..)
+    , Blake2sp(..)
+    , Blake2b(..)
+    , Blake2bp(..)
+    ) where
+
+import           Crypto.Hash.Types
+import           Foreign.Ptr (Ptr)
+import           Data.Data
+import           Data.Word (Word8, Word32)
+import           GHC.TypeLits (Nat, KnownNat)
+import           Crypto.Internal.Nat
+
+-- | Fast and secure alternative to SHA1 and HMAC-SHA1
+--
+-- It is espacially known to target 32bits architectures.
+--
+-- Known supported digest sizes:
+--
+-- * Blake2s 160
+-- * Blake2s 224
+-- * Blake2s 256
+--
+data Blake2s (bitlen :: Nat) = Blake2s
+    deriving (Show,Data)
+
+instance (IsDivisibleBy8 bitlen, KnownNat bitlen, IsAtLeast bitlen 8, IsAtMost bitlen 256)
+      => HashAlgorithm (Blake2s bitlen)
+      where
+    type HashBlockSize           (Blake2s bitlen) = 64
+    type HashDigestSize          (Blake2s bitlen) = Div8 bitlen
+    type HashInternalContextSize (Blake2s bitlen) = 136
+    hashBlockSize  _          = 64
+    hashDigestSize _          = byteLen (Proxy :: Proxy bitlen)
+    hashInternalContextSize _ = 136
+    hashInternalInit p        = c_blake2s_init p (integralNatVal (Proxy :: Proxy bitlen))
+    hashInternalUpdate        = c_blake2s_update
+    hashInternalFinalize p    = c_blake2s_finalize p (integralNatVal (Proxy :: Proxy bitlen))
+
+foreign import ccall unsafe "cryptonite_blake2s_init"
+    c_blake2s_init :: Ptr (Context a) -> Word32 -> IO ()
+foreign import ccall "cryptonite_blake2s_update"
+    c_blake2s_update :: Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()
+foreign import ccall unsafe "cryptonite_blake2s_finalize"
+    c_blake2s_finalize :: Ptr (Context a) -> Word32 -> Ptr (Digest a) -> IO ()
+
+-- | Fast cryptographic hash.
+--
+-- It is especially known to target 64bits architectures.
+--
+-- Known supported digest sizes:
+--
+-- * Blake2b 160
+-- * Blake2b 224
+-- * Blake2b 256
+-- * Blake2b 384
+-- * Blake2b 512
+--
+data Blake2b (bitlen :: Nat) = Blake2b
+    deriving (Show,Data)
+
+instance (IsDivisibleBy8 bitlen, KnownNat bitlen, IsAtLeast bitlen 8, IsAtMost bitlen 512)
+      => HashAlgorithm (Blake2b bitlen)
+      where
+    type HashBlockSize           (Blake2b bitlen) = 128
+    type HashDigestSize          (Blake2b bitlen) = Div8 bitlen
+    type HashInternalContextSize (Blake2b bitlen) = 248
+    hashBlockSize  _          = 128
+    hashDigestSize _          = byteLen (Proxy :: Proxy bitlen)
+    hashInternalContextSize _ = 248
+    hashInternalInit p        = c_blake2b_init p (integralNatVal (Proxy :: Proxy bitlen))
+    hashInternalUpdate        = c_blake2b_update
+    hashInternalFinalize p    = c_blake2b_finalize p (integralNatVal (Proxy :: Proxy bitlen))
+
+foreign import ccall unsafe "cryptonite_blake2b_init"
+    c_blake2b_init :: Ptr (Context a) -> Word32 -> IO ()
+foreign import ccall "cryptonite_blake2b_update"
+    c_blake2b_update :: Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()
+foreign import ccall unsafe "cryptonite_blake2b_finalize"
+    c_blake2b_finalize :: Ptr (Context a) -> Word32 -> Ptr (Digest a) -> IO ()
+
+data Blake2sp (bitlen :: Nat) = Blake2sp
+    deriving (Show,Data)
+
+instance (IsDivisibleBy8 bitlen, KnownNat bitlen, IsAtLeast bitlen 8, IsAtMost bitlen 256)
+      => HashAlgorithm (Blake2sp bitlen)
+      where
+    type HashBlockSize           (Blake2sp bitlen) = 64
+    type HashDigestSize          (Blake2sp bitlen) = Div8 bitlen
+    type HashInternalContextSize (Blake2sp bitlen) = 2185
+    hashBlockSize  _          = 64
+    hashDigestSize _          = byteLen (Proxy :: Proxy bitlen)
+    hashInternalContextSize _ = 2185
+    hashInternalInit p        = c_blake2sp_init p (integralNatVal (Proxy :: Proxy bitlen))
+    hashInternalUpdate        = c_blake2sp_update
+    hashInternalFinalize p    = c_blake2sp_finalize p (integralNatVal (Proxy :: Proxy bitlen))
+
+foreign import ccall unsafe "cryptonite_blake2sp_init"
+    c_blake2sp_init :: Ptr (Context a) -> Word32 -> IO ()
+foreign import ccall "cryptonite_blake2sp_update"
+    c_blake2sp_update :: Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()
+foreign import ccall unsafe "cryptonite_blake2sp_finalize"
+    c_blake2sp_finalize :: Ptr (Context a) -> Word32 -> Ptr (Digest a) -> IO ()
+
+data Blake2bp (bitlen :: Nat) = Blake2bp
+    deriving (Show,Data)
+
+instance (IsDivisibleBy8 bitlen, KnownNat bitlen, IsAtLeast bitlen 8, IsAtMost bitlen 512)
+      => HashAlgorithm (Blake2bp bitlen)
+      where
+    type HashBlockSize           (Blake2bp bitlen) = 128
+    type HashDigestSize          (Blake2bp bitlen) = Div8 bitlen
+    type HashInternalContextSize (Blake2bp bitlen) = 2325
+    hashBlockSize  _          = 128
+    hashDigestSize _          = byteLen (Proxy :: Proxy bitlen)
+    hashInternalContextSize _ = 2325
+    hashInternalInit p        = c_blake2bp_init p (integralNatVal (Proxy :: Proxy bitlen))
+    hashInternalUpdate        = c_blake2bp_update
+    hashInternalFinalize p    = c_blake2bp_finalize p (integralNatVal (Proxy :: Proxy bitlen))
+
+
+foreign import ccall unsafe "cryptonite_blake2bp_init"
+    c_blake2bp_init :: Ptr (Context a) -> Word32 -> IO ()
+foreign import ccall "cryptonite_blake2bp_update"
+    c_blake2bp_update :: Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()
+foreign import ccall unsafe "cryptonite_blake2bp_finalize"
+    c_blake2bp_finalize :: Ptr (Context a) -> Word32 -> Ptr (Digest a) -> IO ()

Crypto/Hash/Blake2b.hs

@@ -0,0 +1,108 @@
+-- |
+-- Module      : Crypto.Hash.Blake2b
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Module containing the binding functions to work with the
+-- Blake2b cryptographic hash.
+--
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+module Crypto.Hash.Blake2b
+    (  Blake2b_160 (..), Blake2b_224 (..), Blake2b_256 (..), Blake2b_384 (..), Blake2b_512 (..)
+    ) where
+
+import           Crypto.Hash.Types
+import           Foreign.Ptr (Ptr)
+import           Data.Data
+import           Data.Word (Word8, Word32)
+
+
+-- | Blake2b (160 bits) cryptographic hash algorithm
+data Blake2b_160 = Blake2b_160
+    deriving (Show,Data)
+
+instance HashAlgorithm Blake2b_160 where
+    type HashBlockSize           Blake2b_160 = 128
+    type HashDigestSize          Blake2b_160 = 20
+    type HashInternalContextSize Blake2b_160 = 248
+    hashBlockSize  _          = 128
+    hashDigestSize _          = 20
+    hashInternalContextSize _ = 248
+    hashInternalInit p        = c_blake2b_init p 160
+    hashInternalUpdate        = c_blake2b_update
+    hashInternalFinalize p    = c_blake2b_finalize p 160
+
+-- | Blake2b (224 bits) cryptographic hash algorithm
+data Blake2b_224 = Blake2b_224
+    deriving (Show,Data)
+
+instance HashAlgorithm Blake2b_224 where
+    type HashBlockSize           Blake2b_224 = 128
+    type HashDigestSize          Blake2b_224 = 28
+    type HashInternalContextSize Blake2b_224 = 248
+    hashBlockSize  _          = 128
+    hashDigestSize _          = 28
+    hashInternalContextSize _ = 248
+    hashInternalInit p        = c_blake2b_init p 224
+    hashInternalUpdate        = c_blake2b_update
+    hashInternalFinalize p    = c_blake2b_finalize p 224
+
+-- | Blake2b (256 bits) cryptographic hash algorithm
+data Blake2b_256 = Blake2b_256
+    deriving (Show,Data)
+
+instance HashAlgorithm Blake2b_256 where
+    type HashBlockSize           Blake2b_256 = 128
+    type HashDigestSize          Blake2b_256 = 32
+    type HashInternalContextSize Blake2b_256 = 248
+    hashBlockSize  _          = 128
+    hashDigestSize _          = 32
+    hashInternalContextSize _ = 248
+    hashInternalInit p        = c_blake2b_init p 256
+    hashInternalUpdate        = c_blake2b_update
+    hashInternalFinalize p    = c_blake2b_finalize p 256
+
+-- | Blake2b (384 bits) cryptographic hash algorithm
+data Blake2b_384 = Blake2b_384
+    deriving (Show,Data)
+
+instance HashAlgorithm Blake2b_384 where
+    type HashBlockSize           Blake2b_384 = 128
+    type HashDigestSize          Blake2b_384 = 48
+    type HashInternalContextSize Blake2b_384 = 248
+    hashBlockSize  _          = 128
+    hashDigestSize _          = 48
+    hashInternalContextSize _ = 248
+    hashInternalInit p        = c_blake2b_init p 384
+    hashInternalUpdate        = c_blake2b_update
+    hashInternalFinalize p    = c_blake2b_finalize p 384
+
+-- | Blake2b (512 bits) cryptographic hash algorithm
+data Blake2b_512 = Blake2b_512
+    deriving (Show,Data)
+
+instance HashAlgorithm Blake2b_512 where
+    type HashBlockSize           Blake2b_512 = 128
+    type HashDigestSize          Blake2b_512 = 64
+    type HashInternalContextSize Blake2b_512 = 248
+    hashBlockSize  _          = 128
+    hashDigestSize _          = 64
+    hashInternalContextSize _ = 248
+    hashInternalInit p        = c_blake2b_init p 512
+    hashInternalUpdate        = c_blake2b_update
+    hashInternalFinalize p    = c_blake2b_finalize p 512
+
+
+foreign import ccall unsafe "cryptonite_blake2b_init"
+    c_blake2b_init :: Ptr (Context a) -> Word32 -> IO ()
+
+foreign import ccall "cryptonite_blake2b_update"
+    c_blake2b_update :: Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()
+
+foreign import ccall unsafe "cryptonite_blake2b_finalize"
+    c_blake2b_finalize :: Ptr (Context a) -> Word32 -> Ptr (Digest a) -> IO ()

Crypto/Hash/Blake2bp.hs

@@ -0,0 +1,48 @@
+-- |
+-- Module      : Crypto.Hash.Blake2bp
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Module containing the binding functions to work with the
+-- Blake2bp cryptographic hash.
+--
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+module Crypto.Hash.Blake2bp
+    (  Blake2bp_512 (..)
+    ) where
+
+import           Crypto.Hash.Types
+import           Foreign.Ptr (Ptr)
+import           Data.Data
+import           Data.Word (Word8, Word32)
+
+
+-- | Blake2bp (512 bits) cryptographic hash algorithm
+data Blake2bp_512 = Blake2bp_512
+    deriving (Show,Data)
+
+instance HashAlgorithm Blake2bp_512 where
+    type HashBlockSize           Blake2bp_512 = 128
+    type HashDigestSize          Blake2bp_512 = 64
+    type HashInternalContextSize Blake2bp_512 = 1768
+    hashBlockSize  _          = 128
+    hashDigestSize _          = 64
+    hashInternalContextSize _ = 1768
+    hashInternalInit p        = c_blake2bp_init p 512
+    hashInternalUpdate        = c_blake2bp_update
+    hashInternalFinalize p    = c_blake2bp_finalize p 512
+
+
+foreign import ccall unsafe "cryptonite_blake2bp_init"
+    c_blake2bp_init :: Ptr (Context a) -> Word32 -> IO ()
+
+foreign import ccall "cryptonite_blake2bp_update"
+    c_blake2bp_update :: Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()
+
+foreign import ccall unsafe "cryptonite_blake2bp_finalize"
+    c_blake2bp_finalize :: Ptr (Context a) -> Word32 -> Ptr (Digest a) -> IO ()

Crypto/Hash/Blake2s.hs

@@ -0,0 +1,78 @@
+-- |
+-- Module      : Crypto.Hash.Blake2s
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Module containing the binding functions to work with the
+-- Blake2s cryptographic hash.
+--
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+module Crypto.Hash.Blake2s
+    (  Blake2s_160 (..), Blake2s_224 (..), Blake2s_256 (..)
+    ) where
+
+import           Crypto.Hash.Types
+import           Foreign.Ptr (Ptr)
+import           Data.Data
+import           Data.Word (Word8, Word32)
+
+
+-- | Blake2s (160 bits) cryptographic hash algorithm
+data Blake2s_160 = Blake2s_160
+    deriving (Show,Data)
+
+instance HashAlgorithm Blake2s_160 where
+    type HashBlockSize           Blake2s_160 = 64
+    type HashDigestSize          Blake2s_160 = 20
+    type HashInternalContextSize Blake2s_160 = 136
+    hashBlockSize  _          = 64
+    hashDigestSize _          = 20
+    hashInternalContextSize _ = 136
+    hashInternalInit p        = c_blake2s_init p 160
+    hashInternalUpdate        = c_blake2s_update
+    hashInternalFinalize p    = c_blake2s_finalize p 160
+
+-- | Blake2s (224 bits) cryptographic hash algorithm
+data Blake2s_224 = Blake2s_224
+    deriving (Show,Data)
+
+instance HashAlgorithm Blake2s_224 where
+    type HashBlockSize           Blake2s_224 = 64
+    type HashDigestSize          Blake2s_224 = 28
+    type HashInternalContextSize Blake2s_224 = 136
+    hashBlockSize  _          = 64
+    hashDigestSize _          = 28
+    hashInternalContextSize _ = 136
+    hashInternalInit p        = c_blake2s_init p 224
+    hashInternalUpdate        = c_blake2s_update
+    hashInternalFinalize p    = c_blake2s_finalize p 224
+
+-- | Blake2s (256 bits) cryptographic hash algorithm
+data Blake2s_256 = Blake2s_256
+    deriving (Show,Data)
+
+instance HashAlgorithm Blake2s_256 where
+    type HashBlockSize           Blake2s_256 = 64
+    type HashDigestSize          Blake2s_256 = 32
+    type HashInternalContextSize Blake2s_256 = 136
+    hashBlockSize  _          = 64
+    hashDigestSize _          = 32
+    hashInternalContextSize _ = 136
+    hashInternalInit p        = c_blake2s_init p 256
+    hashInternalUpdate        = c_blake2s_update
+    hashInternalFinalize p    = c_blake2s_finalize p 256
+
+
+foreign import ccall unsafe "cryptonite_blake2s_init"
+    c_blake2s_init :: Ptr (Context a) -> Word32 -> IO ()
+
+foreign import ccall "cryptonite_blake2s_update"
+    c_blake2s_update :: Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()
+
+foreign import ccall unsafe "cryptonite_blake2s_finalize"
+    c_blake2s_finalize :: Ptr (Context a) -> Word32 -> Ptr (Digest a) -> IO ()

Crypto/Hash/Blake2sp.hs

@@ -0,0 +1,63 @@
+-- |
+-- Module      : Crypto.Hash.Blake2sp
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Module containing the binding functions to work with the
+-- Blake2sp cryptographic hash.
+--
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+module Crypto.Hash.Blake2sp
+    (  Blake2sp_224 (..), Blake2sp_256 (..)
+    ) where
+
+import           Crypto.Hash.Types
+import           Foreign.Ptr (Ptr)
+import           Data.Data
+import           Data.Word (Word8, Word32)
+
+
+-- | Blake2sp (224 bits) cryptographic hash algorithm
+data Blake2sp_224 = Blake2sp_224
+    deriving (Show,Data)
+
+instance HashAlgorithm Blake2sp_224 where
+    type HashBlockSize           Blake2sp_224 = 64
+    type HashDigestSize          Blake2sp_224 = 28
+    type HashInternalContextSize Blake2sp_224 = 1752
+    hashBlockSize  _          = 64
+    hashDigestSize _          = 28
+    hashInternalContextSize _ = 1752
+    hashInternalInit p        = c_blake2sp_init p 224
+    hashInternalUpdate        = c_blake2sp_update
+    hashInternalFinalize p    = c_blake2sp_finalize p 224
+
+-- | Blake2sp (256 bits) cryptographic hash algorithm
+data Blake2sp_256 = Blake2sp_256
+    deriving (Show,Data)
+
+instance HashAlgorithm Blake2sp_256 where
+    type HashBlockSize           Blake2sp_256 = 64
+    type HashDigestSize          Blake2sp_256 = 32
+    type HashInternalContextSize Blake2sp_256 = 1752
+    hashBlockSize  _          = 64
+    hashDigestSize _          = 32
+    hashInternalContextSize _ = 1752
+    hashInternalInit p        = c_blake2sp_init p 256
+    hashInternalUpdate        = c_blake2sp_update
+    hashInternalFinalize p    = c_blake2sp_finalize p 256
+
+
+foreign import ccall unsafe "cryptonite_blake2sp_init"
+    c_blake2sp_init :: Ptr (Context a) -> Word32 -> IO ()
+
+foreign import ccall "cryptonite_blake2sp_update"
+    c_blake2sp_update :: Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()
+
+foreign import ccall unsafe "cryptonite_blake2sp_finalize"
+    c_blake2sp_finalize :: Ptr (Context a) -> Word32 -> Ptr (Digest a) -> IO ()

Crypto/Hash/IO.hs

@@ -8,6 +8,7 @@
 -- Generalized impure cryptographic hash interface
 --
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
 module Crypto.Hash.IO
     ( HashAlgorithm(..)
     , MutableContext
@@ -23,6 +24,11 @@ import qualified Crypto.Internal.ByteArray as B
 import           Foreign.Ptr
 
 -- | A Mutable hash context
+--
+-- This type is an instance of 'B.ByteArrayAccess' for debugging purpose.
+-- Internal layout is architecture dependent, may contain uninitialized data
+-- fragments, and change in future versions.  The bytearray should not be used
+-- as input to cryptographic algorithms.
 newtype MutableContext a = MutableContext B.Bytes
     deriving (B.ByteArrayAccess)
 
@@ -51,18 +57,10 @@ hashMutableUpdate mc dat = doUpdate mc (B.withByteArray mc)
                 hashInternalUpdate ctx d (fromIntegral $ B.length dat)
 
 -- | Finalize a mutable hash context and compute a digest
-hashMutableFinalize :: HashAlgorithm a => MutableContext a -> IO (Digest a)
-hashMutableFinalize mc = doFinalize undefined (B.withByteArray mc) B.alloc
-  where doFinalize :: HashAlgorithm alg
-                   => alg
-                   -> ((Ptr (Context alg) -> IO ()) -> IO ())
-                   -> (Int -> (Ptr (Digest alg)  -> IO ()) -> IO B.Bytes)
-                   -> IO (Digest alg)
-        doFinalize alg withCtx allocDigest = do
-            b <- allocDigest (hashDigestSize alg) $ \dig ->
-                    withCtx $ \ctx ->
-                        hashInternalFinalize ctx dig
-            return $ Digest b
+hashMutableFinalize :: forall a . HashAlgorithm a => MutableContext a -> IO (Digest a)
+hashMutableFinalize mc = do
+    b <- B.alloc (hashDigestSize (undefined :: a)) $ \dig -> B.withByteArray mc $ \(ctx :: Ptr (Context a)) -> hashInternalFinalize ctx dig
+    return $ Digest b
 
 -- | Reset the mutable context to the initial state of the hash
 hashMutableReset :: HashAlgorithm a => MutableContext a -> IO ()

Crypto/Hash/Keccak.hs

@@ -0,0 +1,115 @@
+-- |
+-- Module      : Crypto.Hash.Keccak
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Module containing the binding functions to work with the
+-- Keccak cryptographic hash.
+--
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+module Crypto.Hash.Keccak
+    (  Keccak_224 (..), Keccak_256 (..), Keccak_384 (..), Keccak_512 (..)
+    ) where
+
+import           Crypto.Hash.Types
+import           Foreign.Ptr (Ptr)
+import           Data.Data
+import           Data.Word (Word8, Word32)
+
+
+-- | Keccak (224 bits) cryptographic hash algorithm
+data Keccak_224 = Keccak_224
+    deriving (Show,Data)
+
+instance HashAlgorithm Keccak_224 where
+    type HashBlockSize           Keccak_224 = 144
+    type HashDigestSize          Keccak_224 = 28
+    type HashInternalContextSize Keccak_224 = 352
+    hashBlockSize  _          = 144
+    hashDigestSize _          = 28
+    hashInternalContextSize _ = 352
+    hashInternalInit p        = c_keccak_init p 224
+    hashInternalUpdate        = c_keccak_update
+    hashInternalFinalize p    = c_keccak_finalize p 224
+
+instance HashAlgorithmResumable Keccak_224 where
+  hashInternalPutContextBE = c_sha3_ctx_to_be
+  hashInternalGetContextBE = c_sha3_be_to_ctx
+
+-- | Keccak (256 bits) cryptographic hash algorithm
+data Keccak_256 = Keccak_256
+    deriving (Show,Data)
+
+instance HashAlgorithm Keccak_256 where
+    type HashBlockSize           Keccak_256 = 136
+    type HashDigestSize          Keccak_256 = 32
+    type HashInternalContextSize Keccak_256 = 344
+    hashBlockSize  _          = 136
+    hashDigestSize _          = 32
+    hashInternalContextSize _ = 344
+    hashInternalInit p        = c_keccak_init p 256
+    hashInternalUpdate        = c_keccak_update
+    hashInternalFinalize p    = c_keccak_finalize p 256
+
+instance HashAlgorithmResumable Keccak_256 where
+  hashInternalPutContextBE = c_sha3_ctx_to_be
+  hashInternalGetContextBE = c_sha3_be_to_ctx
+
+-- | Keccak (384 bits) cryptographic hash algorithm
+data Keccak_384 = Keccak_384
+    deriving (Show,Data)
+
+instance HashAlgorithm Keccak_384 where
+    type HashBlockSize           Keccak_384 = 104
+    type HashDigestSize          Keccak_384 = 48
+    type HashInternalContextSize Keccak_384 = 312
+    hashBlockSize  _          = 104
+    hashDigestSize _          = 48
+    hashInternalContextSize _ = 312
+    hashInternalInit p        = c_keccak_init p 384
+    hashInternalUpdate        = c_keccak_update
+    hashInternalFinalize p    = c_keccak_finalize p 384
+
+instance HashAlgorithmResumable Keccak_384 where
+  hashInternalPutContextBE = c_sha3_ctx_to_be
+  hashInternalGetContextBE = c_sha3_be_to_ctx
+
+-- | Keccak (512 bits) cryptographic hash algorithm
+data Keccak_512 = Keccak_512
+    deriving (Show,Data)
+
+instance HashAlgorithm Keccak_512 where
+    type HashBlockSize           Keccak_512 = 72
+    type HashDigestSize          Keccak_512 = 64
+    type HashInternalContextSize Keccak_512 = 280
+    hashBlockSize  _          = 72
+    hashDigestSize _          = 64
+    hashInternalContextSize _ = 280
+    hashInternalInit p        = c_keccak_init p 512
+    hashInternalUpdate        = c_keccak_update
+    hashInternalFinalize p    = c_keccak_finalize p 512
+
+instance HashAlgorithmResumable Keccak_512 where
+  hashInternalPutContextBE = c_sha3_ctx_to_be
+  hashInternalGetContextBE = c_sha3_be_to_ctx
+
+
+foreign import ccall unsafe "cryptonite_keccak_init"
+    c_keccak_init :: Ptr (Context a) -> Word32 -> IO ()
+
+foreign import ccall "cryptonite_keccak_update"
+    c_keccak_update :: Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()
+
+foreign import ccall unsafe "cryptonite_keccak_finalize"
+    c_keccak_finalize :: Ptr (Context a) -> Word32 -> Ptr (Digest a) -> IO ()
+
+foreign import ccall unsafe "cryptonite_sha3_ctx_to_be"
+    c_sha3_ctx_to_be :: Ptr (Context a) -> Ptr Word8 -> IO ()
+
+foreign import ccall unsafe "cryptonite_sha3_be_to_ctx"
+    c_sha3_be_to_ctx :: Ptr Word8 -> Ptr (Context a) -> IO ()

Crypto/Hash/Kekkak.hs

@@ -1,77 +0,0 @@
--- |
--- Module      : Crypto.Hash.Kekkak
--- License     : BSD-style
--- Maintainer  : Vincent Hanquez <vincent@snarc.org>
--- Stability   : experimental
--- Portability : unknown
---
--- module containing the binding functions to work with the
--- Kekkak cryptographic hash.
---
-{-# LANGUAGE ForeignFunctionInterface #-}
-module Crypto.Hash.Kekkak
-    (  Kekkak_224 (..), Kekkak_256 (..), Kekkak_384 (..), Kekkak_512 (..)
-    ) where
-
-import           Crypto.Hash.Types
-import           Foreign.Ptr (Ptr)
-import           Data.Word (Word8, Word32)
-
-
--- | Kekkak (224 bits) cryptographic hash algorithm
-data Kekkak_224 = Kekkak_224
-    deriving (Show)
-
-instance HashAlgorithm Kekkak_224 where
-    hashBlockSize  _          = 144
-    hashDigestSize _          = 28
-    hashInternalContextSize _ = 360
-    hashInternalInit p        = c_kekkak_init p 224
-    hashInternalUpdate        = c_kekkak_update
-    hashInternalFinalize      = c_kekkak_finalize
-
--- | Kekkak (256 bits) cryptographic hash algorithm
-data Kekkak_256 = Kekkak_256
-    deriving (Show)
-
-instance HashAlgorithm Kekkak_256 where
-    hashBlockSize  _          = 136
-    hashDigestSize _          = 32
-    hashInternalContextSize _ = 360
-    hashInternalInit p        = c_kekkak_init p 256
-    hashInternalUpdate        = c_kekkak_update
-    hashInternalFinalize      = c_kekkak_finalize
-
--- | Kekkak (384 bits) cryptographic hash algorithm
-data Kekkak_384 = Kekkak_384
-    deriving (Show)
-
-instance HashAlgorithm Kekkak_384 where
-    hashBlockSize  _          = 104
-    hashDigestSize _          = 48
-    hashInternalContextSize _ = 360
-    hashInternalInit p        = c_kekkak_init p 384
-    hashInternalUpdate        = c_kekkak_update
-    hashInternalFinalize      = c_kekkak_finalize
-
--- | Kekkak (512 bits) cryptographic hash algorithm
-data Kekkak_512 = Kekkak_512
-    deriving (Show)
-
-instance HashAlgorithm Kekkak_512 where
-    hashBlockSize  _          = 72
-    hashDigestSize _          = 64
-    hashInternalContextSize _ = 360
-    hashInternalInit p        = c_kekkak_init p 512
-    hashInternalUpdate        = c_kekkak_update
-    hashInternalFinalize      = c_kekkak_finalize
-
-
-foreign import ccall unsafe "cryptonite_kekkak_init"
-    c_kekkak_init :: Ptr (Context a) -> Word32 -> IO ()
-
-foreign import ccall "cryptonite_kekkak_update"
-    c_kekkak_update :: Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()
-
-foreign import ccall unsafe "cryptonite_kekkak_finalize"
-    c_kekkak_finalize :: Ptr (Context a) -> Ptr (Digest a) -> IO ()

Crypto/Hash/MD2.hs

@@ -5,21 +5,28 @@
 -- Stability   : experimental
 -- Portability : unknown
 --
--- module containing the binding functions to work with the
+-- Module containing the binding functions to work with the
 -- MD2 cryptographic hash.
 --
 {-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
 module Crypto.Hash.MD2 ( MD2 (..) ) where
 
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
+import           Data.Data
 import           Data.Word (Word8, Word32)
 
 -- | MD2 cryptographic hash algorithm
 data MD2 = MD2
-    deriving (Show)
+    deriving (Show,Data)
 
 instance HashAlgorithm MD2 where
+    type HashBlockSize           MD2 = 16
+    type HashDigestSize          MD2 = 16
+    type HashInternalContextSize MD2 = 96
     hashBlockSize  _          = 16
     hashDigestSize _          = 16
     hashInternalContextSize _ = 96

Crypto/Hash/MD4.hs

@@ -5,21 +5,28 @@
 -- Stability   : experimental
 -- Portability : unknown
 --
--- module containing the binding functions to work with the
+-- Module containing the binding functions to work with the
 -- MD4 cryptographic hash.
 --
 {-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
 module Crypto.Hash.MD4 ( MD4 (..) ) where
 
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
+import           Data.Data
 import           Data.Word (Word8, Word32)
 
 -- | MD4 cryptographic hash algorithm
 data MD4 = MD4
-    deriving (Show)
+    deriving (Show,Data)
 
 instance HashAlgorithm MD4 where
+    type HashBlockSize           MD4 = 64
+    type HashDigestSize          MD4 = 16
+    type HashInternalContextSize MD4 = 96
     hashBlockSize  _          = 64
     hashDigestSize _          = 16
     hashInternalContextSize _ = 96

Crypto/Hash/MD5.hs

@@ -5,21 +5,28 @@
 -- Stability   : experimental
 -- Portability : unknown
 --
--- module containing the binding functions to work with the
+-- Module containing the binding functions to work with the
 -- MD5 cryptographic hash.
 --
 {-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
 module Crypto.Hash.MD5 ( MD5 (..) ) where
 
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
+import           Data.Data
 import           Data.Word (Word8, Word32)
 
 -- | MD5 cryptographic hash algorithm
 data MD5 = MD5
-    deriving (Show)
+    deriving (Show,Data)
 
 instance HashAlgorithm MD5 where
+    type HashBlockSize           MD5 = 64
+    type HashDigestSize          MD5 = 16
+    type HashInternalContextSize MD5 = 96
     hashBlockSize  _          = 64
     hashDigestSize _          = 16
     hashInternalContextSize _ = 96
@@ -27,6 +34,9 @@ instance HashAlgorithm MD5 where
     hashInternalUpdate        = c_md5_update
     hashInternalFinalize      = c_md5_finalize
 
+instance HashAlgorithmPrefix MD5 where
+    hashInternalFinalizePrefix = c_md5_finalize_prefix
+
 foreign import ccall unsafe "cryptonite_md5_init"
     c_md5_init :: Ptr (Context a)-> IO ()
 
@@ -35,3 +45,6 @@ foreign import ccall "cryptonite_md5_update"
 
 foreign import ccall unsafe "cryptonite_md5_finalize"
     c_md5_finalize :: Ptr (Context a) -> Ptr (Digest a) -> IO ()
+
+foreign import ccall "cryptonite_md5_finalize_prefix"
+    c_md5_finalize_prefix :: Ptr (Context a) -> Ptr Word8 -> Word32 -> Word32 -> Ptr (Digest a) -> IO ()

Crypto/Hash/RIPEMD160.hs

@@ -5,21 +5,28 @@
 -- Stability   : experimental
 -- Portability : unknown
 --
--- module containing the binding functions to work with the
+-- Module containing the binding functions to work with the
 -- RIPEMD160 cryptographic hash.
 --
 {-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
 module Crypto.Hash.RIPEMD160 ( RIPEMD160 (..) ) where
 
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
+import           Data.Data
 import           Data.Word (Word8, Word32)
 
 -- | RIPEMD160 cryptographic hash algorithm
 data RIPEMD160 = RIPEMD160
-    deriving (Show)
+    deriving (Show,Data)
 
 instance HashAlgorithm RIPEMD160 where
+    type HashBlockSize           RIPEMD160 = 64
+    type HashDigestSize          RIPEMD160 = 20
+    type HashInternalContextSize RIPEMD160 = 128
     hashBlockSize  _          = 64
     hashDigestSize _          = 20
     hashInternalContextSize _ = 128

Crypto/Hash/SHA1.hs

@@ -5,21 +5,28 @@
 -- Stability   : experimental
 -- Portability : unknown
 --
--- module containing the binding functions to work with the
+-- Module containing the binding functions to work with the
 -- SHA1 cryptographic hash.
 --
 {-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
 module Crypto.Hash.SHA1 ( SHA1 (..) ) where
 
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
+import           Data.Data
 import           Data.Word (Word8, Word32)
 
 -- | SHA1 cryptographic hash algorithm
 data SHA1 = SHA1
-    deriving (Show)
+    deriving (Show,Data)
 
 instance HashAlgorithm SHA1 where
+    type HashBlockSize           SHA1 = 64
+    type HashDigestSize          SHA1 = 20
+    type HashInternalContextSize SHA1 = 96
     hashBlockSize  _          = 64
     hashDigestSize _          = 20
     hashInternalContextSize _ = 96
@@ -27,6 +34,9 @@ instance HashAlgorithm SHA1 where
     hashInternalUpdate        = c_sha1_update
     hashInternalFinalize      = c_sha1_finalize
 
+instance HashAlgorithmPrefix SHA1 where
+    hashInternalFinalizePrefix = c_sha1_finalize_prefix
+
 foreign import ccall unsafe "cryptonite_sha1_init"
     c_sha1_init :: Ptr (Context a)-> IO ()
 
@@ -35,3 +45,6 @@ foreign import ccall "cryptonite_sha1_update"
 
 foreign import ccall unsafe "cryptonite_sha1_finalize"
     c_sha1_finalize :: Ptr (Context a) -> Ptr (Digest a) -> IO ()
+
+foreign import ccall "cryptonite_sha1_finalize_prefix"
+    c_sha1_finalize_prefix :: Ptr (Context a) -> Ptr Word8 -> Word32 -> Word32 -> Ptr (Digest a) -> IO ()

Crypto/Hash/SHA224.hs

@@ -5,21 +5,28 @@
 -- Stability   : experimental
 -- Portability : unknown
 --
--- module containing the binding functions to work with the
+-- Module containing the binding functions to work with the
 -- SHA224 cryptographic hash.
 --
 {-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
 module Crypto.Hash.SHA224 ( SHA224 (..) ) where
 
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
+import           Data.Data
 import           Data.Word (Word8, Word32)
 
 -- | SHA224 cryptographic hash algorithm
 data SHA224 = SHA224
-    deriving (Show)
+    deriving (Show,Data)
 
 instance HashAlgorithm SHA224 where
+    type HashBlockSize           SHA224 = 64
+    type HashDigestSize          SHA224 = 28
+    type HashInternalContextSize SHA224 = 192
     hashBlockSize  _          = 64
     hashDigestSize _          = 28
     hashInternalContextSize _ = 192
@@ -27,6 +34,9 @@ instance HashAlgorithm SHA224 where
     hashInternalUpdate        = c_sha224_update
     hashInternalFinalize      = c_sha224_finalize
 
+instance HashAlgorithmPrefix SHA224 where
+    hashInternalFinalizePrefix = c_sha224_finalize_prefix
+
 foreign import ccall unsafe "cryptonite_sha224_init"
     c_sha224_init :: Ptr (Context a)-> IO ()
 
@@ -35,3 +45,6 @@ foreign import ccall "cryptonite_sha224_update"
 
 foreign import ccall unsafe "cryptonite_sha224_finalize"
     c_sha224_finalize :: Ptr (Context a) -> Ptr (Digest a) -> IO ()
+
+foreign import ccall "cryptonite_sha224_finalize_prefix"
+    c_sha224_finalize_prefix :: Ptr (Context a) -> Ptr Word8 -> Word32 -> Word32 -> Ptr (Digest a) -> IO ()

Crypto/Hash/SHA256.hs

@@ -5,21 +5,28 @@
 -- Stability   : experimental
 -- Portability : unknown
 --
--- module containing the binding functions to work with the
+-- Module containing the binding functions to work with the
 -- SHA256 cryptographic hash.
 --
 {-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
 module Crypto.Hash.SHA256 ( SHA256 (..) ) where
 
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
+import           Data.Data
 import           Data.Word (Word8, Word32)
 
 -- | SHA256 cryptographic hash algorithm
 data SHA256 = SHA256
-    deriving (Show)
+    deriving (Show,Data)
 
 instance HashAlgorithm SHA256 where
+    type HashBlockSize           SHA256 = 64
+    type HashDigestSize          SHA256 = 32
+    type HashInternalContextSize SHA256 = 192
     hashBlockSize  _          = 64
     hashDigestSize _          = 32
     hashInternalContextSize _ = 192
@@ -27,6 +34,9 @@ instance HashAlgorithm SHA256 where
     hashInternalUpdate        = c_sha256_update
     hashInternalFinalize      = c_sha256_finalize
 
+instance HashAlgorithmPrefix SHA256 where
+    hashInternalFinalizePrefix = c_sha256_finalize_prefix
+
 foreign import ccall unsafe "cryptonite_sha256_init"
     c_sha256_init :: Ptr (Context a)-> IO ()
 
@@ -35,3 +45,6 @@ foreign import ccall "cryptonite_sha256_update"
 
 foreign import ccall unsafe "cryptonite_sha256_finalize"
     c_sha256_finalize :: Ptr (Context a) -> Ptr (Digest a) -> IO ()
+
+foreign import ccall "cryptonite_sha256_finalize_prefix"
+    c_sha256_finalize_prefix :: Ptr (Context a) -> Ptr Word8 -> Word32 -> Word32 -> Ptr (Digest a) -> IO ()

Crypto/Hash/SHA3.hs

@@ -5,66 +5,98 @@
 -- Stability   : experimental
 -- Portability : unknown
 --
--- module containing the binding functions to work with the
+-- Module containing the binding functions to work with the
 -- SHA3 cryptographic hash.
 --
 {-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
 module Crypto.Hash.SHA3
     (  SHA3_224 (..), SHA3_256 (..), SHA3_384 (..), SHA3_512 (..)
     ) where
 
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
+import           Data.Data
 import           Data.Word (Word8, Word32)
 
 
 -- | SHA3 (224 bits) cryptographic hash algorithm
 data SHA3_224 = SHA3_224
-    deriving (Show)
+    deriving (Show,Data)
 
 instance HashAlgorithm SHA3_224 where
+    type HashBlockSize           SHA3_224 = 144
+    type HashDigestSize          SHA3_224 = 28
+    type HashInternalContextSize SHA3_224 = 352
     hashBlockSize  _          = 144
     hashDigestSize _          = 28
-    hashInternalContextSize _ = 360
+    hashInternalContextSize _ = 352
     hashInternalInit p        = c_sha3_init p 224
     hashInternalUpdate        = c_sha3_update
-    hashInternalFinalize      = c_sha3_finalize
+    hashInternalFinalize p    = c_sha3_finalize p 224
+
+instance HashAlgorithmResumable SHA3_224 where
+  hashInternalPutContextBE = c_sha3_ctx_to_be
+  hashInternalGetContextBE = c_sha3_be_to_ctx
 
 -- | SHA3 (256 bits) cryptographic hash algorithm
 data SHA3_256 = SHA3_256
-    deriving (Show)
+    deriving (Show,Data)
 
 instance HashAlgorithm SHA3_256 where
+    type HashBlockSize           SHA3_256 = 136
+    type HashDigestSize          SHA3_256 = 32
+    type HashInternalContextSize SHA3_256 = 344
     hashBlockSize  _          = 136
     hashDigestSize _          = 32
-    hashInternalContextSize _ = 360
+    hashInternalContextSize _ = 344
     hashInternalInit p        = c_sha3_init p 256
     hashInternalUpdate        = c_sha3_update
-    hashInternalFinalize      = c_sha3_finalize
+    hashInternalFinalize p    = c_sha3_finalize p 256
+
+instance HashAlgorithmResumable SHA3_256 where
+  hashInternalPutContextBE = c_sha3_ctx_to_be
+  hashInternalGetContextBE = c_sha3_be_to_ctx
 
 -- | SHA3 (384 bits) cryptographic hash algorithm
 data SHA3_384 = SHA3_384
-    deriving (Show)
+    deriving (Show,Data)
 
 instance HashAlgorithm SHA3_384 where
+    type HashBlockSize           SHA3_384 = 104
+    type HashDigestSize          SHA3_384 = 48
+    type HashInternalContextSize SHA3_384 = 312
     hashBlockSize  _          = 104
     hashDigestSize _          = 48
-    hashInternalContextSize _ = 360
+    hashInternalContextSize _ = 312
     hashInternalInit p        = c_sha3_init p 384
     hashInternalUpdate        = c_sha3_update
-    hashInternalFinalize      = c_sha3_finalize
+    hashInternalFinalize p    = c_sha3_finalize p 384
+
+instance HashAlgorithmResumable SHA3_384 where
+  hashInternalPutContextBE = c_sha3_ctx_to_be
+  hashInternalGetContextBE = c_sha3_be_to_ctx
 
 -- | SHA3 (512 bits) cryptographic hash algorithm
 data SHA3_512 = SHA3_512
-    deriving (Show)
+    deriving (Show,Data)
 
 instance HashAlgorithm SHA3_512 where
+    type HashBlockSize           SHA3_512 = 72
+    type HashDigestSize          SHA3_512 = 64
+    type HashInternalContextSize SHA3_512 = 280
     hashBlockSize  _          = 72
     hashDigestSize _          = 64
-    hashInternalContextSize _ = 360
+    hashInternalContextSize _ = 280
     hashInternalInit p        = c_sha3_init p 512
     hashInternalUpdate        = c_sha3_update
-    hashInternalFinalize      = c_sha3_finalize
+    hashInternalFinalize p    = c_sha3_finalize p 512
+
+instance HashAlgorithmResumable SHA3_512 where
+  hashInternalPutContextBE = c_sha3_ctx_to_be
+  hashInternalGetContextBE = c_sha3_be_to_ctx
 
 
 foreign import ccall unsafe "cryptonite_sha3_init"
@@ -74,4 +106,10 @@ foreign import ccall "cryptonite_sha3_update"
     c_sha3_update :: Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()
 
 foreign import ccall unsafe "cryptonite_sha3_finalize"
-    c_sha3_finalize :: Ptr (Context a) -> Ptr (Digest a) -> IO ()
+    c_sha3_finalize :: Ptr (Context a) -> Word32 -> Ptr (Digest a) -> IO ()
+
+foreign import ccall unsafe "cryptonite_sha3_ctx_to_be"
+    c_sha3_ctx_to_be :: Ptr (Context a) -> Ptr Word8 -> IO ()
+
+foreign import ccall unsafe "cryptonite_sha3_be_to_ctx"
+    c_sha3_be_to_ctx :: Ptr Word8 -> Ptr (Context a) -> IO ()

Crypto/Hash/SHA384.hs

@@ -5,21 +5,28 @@
 -- Stability   : experimental
 -- Portability : unknown
 --
--- module containing the binding functions to work with the
+-- Module containing the binding functions to work with the
 -- SHA384 cryptographic hash.
 --
 {-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
 module Crypto.Hash.SHA384 ( SHA384 (..) ) where
 
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
+import           Data.Data
 import           Data.Word (Word8, Word32)
 
 -- | SHA384 cryptographic hash algorithm
 data SHA384 = SHA384
-    deriving (Show)
+    deriving (Show,Data)
 
 instance HashAlgorithm SHA384 where
+    type HashBlockSize           SHA384 = 128
+    type HashDigestSize          SHA384 = 48
+    type HashInternalContextSize SHA384 = 256
     hashBlockSize  _          = 128
     hashDigestSize _          = 48
     hashInternalContextSize _ = 256
@@ -27,6 +34,9 @@ instance HashAlgorithm SHA384 where
     hashInternalUpdate        = c_sha384_update
     hashInternalFinalize      = c_sha384_finalize
 
+instance HashAlgorithmPrefix SHA384 where
+    hashInternalFinalizePrefix = c_sha384_finalize_prefix
+
 foreign import ccall unsafe "cryptonite_sha384_init"
     c_sha384_init :: Ptr (Context a)-> IO ()
 
@@ -35,3 +45,6 @@ foreign import ccall "cryptonite_sha384_update"
 
 foreign import ccall unsafe "cryptonite_sha384_finalize"
     c_sha384_finalize :: Ptr (Context a) -> Ptr (Digest a) -> IO ()
+
+foreign import ccall "cryptonite_sha384_finalize_prefix"
+    c_sha384_finalize_prefix :: Ptr (Context a) -> Ptr Word8 -> Word32 -> Word32 -> Ptr (Digest a) -> IO ()

Crypto/Hash/SHA512.hs

@@ -5,21 +5,28 @@
 -- Stability   : experimental
 -- Portability : unknown
 --
--- module containing the binding functions to work with the
+-- Module containing the binding functions to work with the
 -- SHA512 cryptographic hash.
 --
 {-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
 module Crypto.Hash.SHA512 ( SHA512 (..) ) where
 
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
+import           Data.Data
 import           Data.Word (Word8, Word32)
 
 -- | SHA512 cryptographic hash algorithm
 data SHA512 = SHA512
-    deriving (Show)
+    deriving (Show,Data)
 
 instance HashAlgorithm SHA512 where
+    type HashBlockSize           SHA512 = 128
+    type HashDigestSize          SHA512 = 64
+    type HashInternalContextSize SHA512 = 256
     hashBlockSize  _          = 128
     hashDigestSize _          = 64
     hashInternalContextSize _ = 256
@@ -27,6 +34,9 @@ instance HashAlgorithm SHA512 where
     hashInternalUpdate        = c_sha512_update
     hashInternalFinalize      = c_sha512_finalize
 
+instance HashAlgorithmPrefix SHA512 where
+    hashInternalFinalizePrefix = c_sha512_finalize_prefix
+
 foreign import ccall unsafe "cryptonite_sha512_init"
     c_sha512_init :: Ptr (Context a)-> IO ()
 
@@ -35,3 +45,6 @@ foreign import ccall "cryptonite_sha512_update"
 
 foreign import ccall unsafe "cryptonite_sha512_finalize"
     c_sha512_finalize :: Ptr (Context a) -> Ptr (Digest a) -> IO ()
+
+foreign import ccall "cryptonite_sha512_finalize_prefix"
+    c_sha512_finalize_prefix :: Ptr (Context a) -> Ptr Word8 -> Word32 -> Word32 -> Ptr (Digest a) -> IO ()

Crypto/Hash/SHA512t.hs

@@ -5,42 +5,52 @@
 -- Stability   : experimental
 -- Portability : unknown
 --
--- module containing the binding functions to work with the
+-- Module containing the binding functions to work with the
 -- SHA512t cryptographic hash.
 --
 {-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
 module Crypto.Hash.SHA512t
     (  SHA512t_224 (..), SHA512t_256 (..)
     ) where
 
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
+import           Data.Data
 import           Data.Word (Word8, Word32)
 
 
 -- | SHA512t (224 bits) cryptographic hash algorithm
 data SHA512t_224 = SHA512t_224
-    deriving (Show)
+    deriving (Show,Data)
 
 instance HashAlgorithm SHA512t_224 where
+    type HashBlockSize           SHA512t_224 = 128
+    type HashDigestSize          SHA512t_224 = 28
+    type HashInternalContextSize SHA512t_224 = 256
     hashBlockSize  _          = 128
     hashDigestSize _          = 28
-    hashInternalContextSize _ = 264
+    hashInternalContextSize _ = 256
     hashInternalInit p        = c_sha512t_init p 224
     hashInternalUpdate        = c_sha512t_update
-    hashInternalFinalize      = c_sha512t_finalize
+    hashInternalFinalize p    = c_sha512t_finalize p 224
 
 -- | SHA512t (256 bits) cryptographic hash algorithm
 data SHA512t_256 = SHA512t_256
-    deriving (Show)
+    deriving (Show,Data)
 
 instance HashAlgorithm SHA512t_256 where
+    type HashBlockSize           SHA512t_256 = 128
+    type HashDigestSize          SHA512t_256 = 32
+    type HashInternalContextSize SHA512t_256 = 256
     hashBlockSize  _          = 128
     hashDigestSize _          = 32
-    hashInternalContextSize _ = 264
+    hashInternalContextSize _ = 256
     hashInternalInit p        = c_sha512t_init p 256
     hashInternalUpdate        = c_sha512t_update
-    hashInternalFinalize      = c_sha512t_finalize
+    hashInternalFinalize p    = c_sha512t_finalize p 256
 
 
 foreign import ccall unsafe "cryptonite_sha512t_init"
@@ -50,4 +60,4 @@ foreign import ccall "cryptonite_sha512t_update"
     c_sha512t_update :: Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()
 
 foreign import ccall unsafe "cryptonite_sha512t_finalize"
-    c_sha512t_finalize :: Ptr (Context a) -> Ptr (Digest a) -> IO ()
+    c_sha512t_finalize :: Ptr (Context a) -> Word32 -> Ptr (Digest a) -> IO ()

Crypto/Hash/SHAKE.hs

@@ -0,0 +1,145 @@
+-- |
+-- Module      : Crypto.Hash.SHAKE
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Module containing the binding functions to work with the
+-- SHA3 extendable output functions (SHAKE).
+--
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Crypto.Hash.SHAKE
+    (  SHAKE128 (..), SHAKE256 (..), HashSHAKE (..)
+    ) where
+
+import           Control.Monad (when)
+import           Crypto.Hash.Types
+import           Foreign.Ptr (Ptr, castPtr)
+import           Foreign.Storable (Storable(..))
+import           Data.Bits
+import           Data.Data
+import           Data.Word (Word8, Word32)
+
+import           GHC.TypeLits (Nat, KnownNat, type (+))
+import           Crypto.Internal.Nat
+
+-- | Type class of SHAKE algorithms.
+class HashAlgorithm a => HashSHAKE a where
+    -- | Alternate finalization needed for cSHAKE
+    cshakeInternalFinalize :: Ptr (Context a) -> Ptr (Digest a) -> IO ()
+    -- | Get the digest bit length
+    cshakeOutputLength :: a -> Int
+
+-- | SHAKE128 (128 bits) extendable output function.  Supports an arbitrary
+-- digest size, to be specified as a type parameter of kind 'Nat'.
+--
+-- Note: outputs from @'SHAKE128' n@ and @'SHAKE128' m@ for the same input are
+-- correlated (one being a prefix of the other).  Results are unrelated to
+-- 'SHAKE256' results.
+data SHAKE128 (bitlen :: Nat) = SHAKE128
+    deriving (Show, Data)
+
+instance KnownNat bitlen => HashAlgorithm (SHAKE128 bitlen) where
+    type HashBlockSize           (SHAKE128 bitlen)  = 168
+    type HashDigestSize          (SHAKE128 bitlen) = Div8 (bitlen + 7)
+    type HashInternalContextSize (SHAKE128 bitlen) = 376
+    hashBlockSize  _          = 168
+    hashDigestSize _          = byteLen (Proxy :: Proxy bitlen)
+    hashInternalContextSize _ = 376
+    hashInternalInit p        = c_sha3_init p 128
+    hashInternalUpdate        = c_sha3_update
+    hashInternalFinalize      = shakeFinalizeOutput (Proxy :: Proxy bitlen)
+
+instance KnownNat bitlen => HashSHAKE (SHAKE128 bitlen) where
+    cshakeInternalFinalize = cshakeFinalizeOutput (Proxy :: Proxy bitlen)
+    cshakeOutputLength _ = integralNatVal (Proxy :: Proxy bitlen)
+
+instance KnownNat bitlen => HashAlgorithmResumable (SHAKE128 bitlen) where
+  hashInternalPutContextBE = c_sha3_ctx_to_be
+  hashInternalGetContextBE = c_sha3_be_to_ctx
+
+-- | SHAKE256 (256 bits) extendable output function.  Supports an arbitrary
+-- digest size, to be specified as a type parameter of kind 'Nat'.
+--
+-- Note: outputs from @'SHAKE256' n@ and @'SHAKE256' m@ for the same input are
+-- correlated (one being a prefix of the other).  Results are unrelated to
+-- 'SHAKE128' results.
+data SHAKE256 (bitlen :: Nat) = SHAKE256
+    deriving (Show, Data)
+
+instance KnownNat bitlen => HashAlgorithm (SHAKE256 bitlen) where
+    type HashBlockSize           (SHAKE256 bitlen) = 136
+    type HashDigestSize          (SHAKE256 bitlen) = Div8 (bitlen + 7)
+    type HashInternalContextSize (SHAKE256 bitlen) = 344
+    hashBlockSize  _          = 136
+    hashDigestSize _          = byteLen (Proxy :: Proxy bitlen)
+    hashInternalContextSize _ = 344
+    hashInternalInit p        = c_sha3_init p 256
+    hashInternalUpdate        = c_sha3_update
+    hashInternalFinalize      = shakeFinalizeOutput (Proxy :: Proxy bitlen)
+
+instance KnownNat bitlen => HashSHAKE (SHAKE256 bitlen) where
+    cshakeInternalFinalize = cshakeFinalizeOutput (Proxy :: Proxy bitlen)
+    cshakeOutputLength _ = integralNatVal (Proxy :: Proxy bitlen)
+
+instance KnownNat bitlen => HashAlgorithmResumable (SHAKE256 bitlen) where
+  hashInternalPutContextBE = c_sha3_ctx_to_be
+  hashInternalGetContextBE = c_sha3_be_to_ctx
+
+shakeFinalizeOutput :: KnownNat bitlen
+                    => proxy bitlen
+                    -> Ptr (Context a)
+                    -> Ptr (Digest a)
+                    -> IO ()
+shakeFinalizeOutput d ctx dig = do
+    c_sha3_finalize_shake ctx
+    c_sha3_output ctx dig (byteLen d)
+    shakeTruncate d (castPtr dig)
+
+cshakeFinalizeOutput :: KnownNat bitlen
+                     => proxy bitlen
+                     -> Ptr (Context a)
+                     -> Ptr (Digest a)
+                     -> IO ()
+cshakeFinalizeOutput d ctx dig = do
+    c_sha3_finalize_cshake ctx
+    c_sha3_output ctx dig (byteLen d)
+    shakeTruncate d (castPtr dig)
+
+shakeTruncate :: KnownNat bitlen => proxy bitlen -> Ptr Word8 -> IO ()
+shakeTruncate d ptr =
+    when (bits > 0) $ do
+        byte <- peekElemOff ptr index
+        pokeElemOff ptr index (byte .&. mask)
+  where
+    mask = (1 `shiftL` bits) - 1
+    (index, bits) = integralNatVal d `divMod` 8
+
+foreign import ccall unsafe "cryptonite_sha3_init"
+    c_sha3_init :: Ptr (Context a) -> Word32 -> IO ()
+
+foreign import ccall "cryptonite_sha3_update"
+    c_sha3_update :: Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()
+
+foreign import ccall unsafe "cryptonite_sha3_finalize_shake"
+    c_sha3_finalize_shake :: Ptr (Context a) -> IO ()
+
+foreign import ccall unsafe "cryptonite_sha3_finalize_cshake"
+    c_sha3_finalize_cshake :: Ptr (Context a) -> IO ()
+
+foreign import ccall unsafe "cryptonite_sha3_output"
+    c_sha3_output :: Ptr (Context a) -> Ptr (Digest a) -> Word32 -> IO ()
+
+foreign import ccall unsafe "cryptonite_sha3_ctx_to_be"
+    c_sha3_ctx_to_be :: Ptr (Context a) -> Ptr Word8 -> IO ()
+
+foreign import ccall unsafe "cryptonite_sha3_be_to_ctx"
+    c_sha3_be_to_ctx :: Ptr Word8 -> Ptr (Context a) -> IO ()

Crypto/Hash/Skein256.hs

@@ -5,42 +5,52 @@
 -- Stability   : experimental
 -- Portability : unknown
 --
--- module containing the binding functions to work with the
+-- Module containing the binding functions to work with the
 -- Skein256 cryptographic hash.
 --
 {-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
 module Crypto.Hash.Skein256
     (  Skein256_224 (..), Skein256_256 (..)
     ) where
 
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
+import           Data.Data
 import           Data.Word (Word8, Word32)
 
 
 -- | Skein256 (224 bits) cryptographic hash algorithm
 data Skein256_224 = Skein256_224
-    deriving (Show)
+    deriving (Show,Data)
 
 instance HashAlgorithm Skein256_224 where
+    type HashBlockSize           Skein256_224 = 32
+    type HashDigestSize          Skein256_224 = 28
+    type HashInternalContextSize Skein256_224 = 96
     hashBlockSize  _          = 32
     hashDigestSize _          = 28
     hashInternalContextSize _ = 96
     hashInternalInit p        = c_skein256_init p 224
     hashInternalUpdate        = c_skein256_update
-    hashInternalFinalize      = c_skein256_finalize
+    hashInternalFinalize p    = c_skein256_finalize p 224
 
 -- | Skein256 (256 bits) cryptographic hash algorithm
 data Skein256_256 = Skein256_256
-    deriving (Show)
+    deriving (Show,Data)
 
 instance HashAlgorithm Skein256_256 where
+    type HashBlockSize           Skein256_256 = 32
+    type HashDigestSize          Skein256_256 = 32
+    type HashInternalContextSize Skein256_256 = 96
     hashBlockSize  _          = 32
     hashDigestSize _          = 32
     hashInternalContextSize _ = 96
     hashInternalInit p        = c_skein256_init p 256
     hashInternalUpdate        = c_skein256_update
-    hashInternalFinalize      = c_skein256_finalize
+    hashInternalFinalize p    = c_skein256_finalize p 256
 
 
 foreign import ccall unsafe "cryptonite_skein256_init"
@@ -50,4 +60,4 @@ foreign import ccall "cryptonite_skein256_update"
     c_skein256_update :: Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()
 
 foreign import ccall unsafe "cryptonite_skein256_finalize"
-    c_skein256_finalize :: Ptr (Context a) -> Ptr (Digest a) -> IO ()
+    c_skein256_finalize :: Ptr (Context a) -> Word32 -> Ptr (Digest a) -> IO ()

Crypto/Hash/Skein512.hs

@@ -5,66 +5,82 @@
 -- Stability   : experimental
 -- Portability : unknown
 --
--- module containing the binding functions to work with the
+-- Module containing the binding functions to work with the
 -- Skein512 cryptographic hash.
 --
 {-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
 module Crypto.Hash.Skein512
     (  Skein512_224 (..), Skein512_256 (..), Skein512_384 (..), Skein512_512 (..)
     ) where
 
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
+import           Data.Data
 import           Data.Word (Word8, Word32)
 
 
 -- | Skein512 (224 bits) cryptographic hash algorithm
 data Skein512_224 = Skein512_224
-    deriving (Show)
+    deriving (Show,Data)
 
 instance HashAlgorithm Skein512_224 where
+    type HashBlockSize           Skein512_224 = 64
+    type HashDigestSize          Skein512_224 = 28
+    type HashInternalContextSize Skein512_224 = 160
     hashBlockSize  _          = 64
     hashDigestSize _          = 28
     hashInternalContextSize _ = 160
     hashInternalInit p        = c_skein512_init p 224
     hashInternalUpdate        = c_skein512_update
-    hashInternalFinalize      = c_skein512_finalize
+    hashInternalFinalize p    = c_skein512_finalize p 224
 
 -- | Skein512 (256 bits) cryptographic hash algorithm
 data Skein512_256 = Skein512_256
-    deriving (Show)
+    deriving (Show,Data)
 
 instance HashAlgorithm Skein512_256 where
+    type HashBlockSize           Skein512_256 = 64
+    type HashDigestSize          Skein512_256 = 32
+    type HashInternalContextSize Skein512_256 = 160
     hashBlockSize  _          = 64
     hashDigestSize _          = 32
     hashInternalContextSize _ = 160
     hashInternalInit p        = c_skein512_init p 256
     hashInternalUpdate        = c_skein512_update
-    hashInternalFinalize      = c_skein512_finalize
+    hashInternalFinalize p    = c_skein512_finalize p 256
 
 -- | Skein512 (384 bits) cryptographic hash algorithm
 data Skein512_384 = Skein512_384
-    deriving (Show)
+    deriving (Show,Data)
 
 instance HashAlgorithm Skein512_384 where
+    type HashBlockSize           Skein512_384 = 64
+    type HashDigestSize          Skein512_384 = 48
+    type HashInternalContextSize Skein512_384 = 160
     hashBlockSize  _          = 64
     hashDigestSize _          = 48
     hashInternalContextSize _ = 160
     hashInternalInit p        = c_skein512_init p 384
     hashInternalUpdate        = c_skein512_update
-    hashInternalFinalize      = c_skein512_finalize
+    hashInternalFinalize p    = c_skein512_finalize p 384
 
 -- | Skein512 (512 bits) cryptographic hash algorithm
 data Skein512_512 = Skein512_512
-    deriving (Show)
+    deriving (Show,Data)
 
 instance HashAlgorithm Skein512_512 where
+    type HashBlockSize           Skein512_512 = 64
+    type HashDigestSize          Skein512_512 = 64
+    type HashInternalContextSize Skein512_512 = 160
     hashBlockSize  _          = 64
     hashDigestSize _          = 64
     hashInternalContextSize _ = 160
     hashInternalInit p        = c_skein512_init p 512
     hashInternalUpdate        = c_skein512_update
-    hashInternalFinalize      = c_skein512_finalize
+    hashInternalFinalize p    = c_skein512_finalize p 512
 
 
 foreign import ccall unsafe "cryptonite_skein512_init"
@@ -74,4 +90,4 @@ foreign import ccall "cryptonite_skein512_update"
     c_skein512_update :: Ptr (Context a) -> Ptr Word8 -> Word32 -> IO ()
 
 foreign import ccall unsafe "cryptonite_skein512_finalize"
-    c_skein512_finalize :: Ptr (Context a) -> Ptr (Digest a) -> IO ()
+    c_skein512_finalize :: Ptr (Context a) -> Word32 -> Ptr (Digest a) -> IO ()

Crypto/Hash/Tiger.hs

@@ -5,21 +5,28 @@
 -- Stability   : experimental
 -- Portability : unknown
 --
--- module containing the binding functions to work with the
+-- Module containing the binding functions to work with the
 -- Tiger cryptographic hash.
 --
 {-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
 module Crypto.Hash.Tiger ( Tiger (..) ) where
 
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
+import           Data.Data
 import           Data.Word (Word8, Word32)
 
 -- | Tiger cryptographic hash algorithm
 data Tiger = Tiger
-    deriving (Show)
+    deriving (Show,Data)
 
 instance HashAlgorithm Tiger where
+    type HashBlockSize           Tiger = 64
+    type HashDigestSize          Tiger = 24
+    type HashInternalContextSize Tiger = 96
     hashBlockSize  _          = 64
     hashDigestSize _          = 24
     hashInternalContextSize _ = 96

Crypto/Hash/Types.hs

@@ -8,8 +8,14 @@
 -- Crypto hash types definitions
 --
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
 module Crypto.Hash.Types
     ( HashAlgorithm(..)
+    , HashAlgorithmPrefix(..)
+    , HashAlgorithmResumable(..)
     , Context(..)
     , Digest(..)
     ) where
@@ -17,7 +23,15 @@ module Crypto.Hash.Types
 import           Crypto.Internal.Imports
 import           Crypto.Internal.ByteArray (ByteArrayAccess, Bytes)
 import qualified Crypto.Internal.ByteArray as B
+import           Control.Monad.ST
+import           Data.Char (digitToInt, isHexDigit)
 import           Foreign.Ptr (Ptr)
+import           Basement.Block (Block, unsafeFreeze)
+import           Basement.Block.Mutable (MutableBlock, new, unsafeWrite)
+import           Basement.NormalForm (deepseq)
+import           Basement.Types.OffsetSize (CountOf(..), Offset(..))
+import           GHC.TypeLits (Nat)
+import           Data.Data (Data)
 
 -- | Class representing hashing algorithms.
 --
@@ -25,6 +39,13 @@ import           Foreign.Ptr (Ptr)
 -- and lowlevel. the Hash module takes care of
 -- hidding the mutable interface properly.
 class HashAlgorithm a where
+    -- | Associated type for the block size of the hash algorithm
+    type HashBlockSize a :: Nat
+    -- | Associated type for the digest size of the hash algorithm
+    type HashDigestSize a :: Nat
+    -- | Associated type for the internal context size of the hash algorithm
+    type HashInternalContextSize a :: Nat
+
     -- | Get the block size of a hash algorithm
     hashBlockSize           :: a -> Int
     -- | Get the digest size of a hash algorithm
@@ -40,19 +61,67 @@ class HashAlgorithm a where
     -- | Finalize the context and set the digest raw memory to the right value
     hashInternalFinalize :: Ptr (Context a) -> Ptr (Digest a) -> IO ()
 
+-- | Hashing algorithms with a constant-time implementation.
+class HashAlgorithm a => HashAlgorithmPrefix a where
+    -- | Update the context with the first N bytes of a buffer and finalize this
+    -- context.  The code path executed is independent from N and depends only
+    -- on the complete buffer length.
+    hashInternalFinalizePrefix :: Ptr (Context a)
+                               -> Ptr Word8 -> Word32
+                               -> Word32
+                               -> Ptr (Digest a)
+                               -> IO ()
+class HashAlgorithm a => HashAlgorithmResumable a where
+  hashInternalPutContextBE :: Ptr (Context a) -> Ptr Word8 -> IO ()
+  hashInternalGetContextBE :: Ptr Word8 -> Ptr (Context a) -> IO ()
+
 {-
 hashContextGetAlgorithm :: HashAlgorithm a => Context a -> a
 hashContextGetAlgorithm = undefined
 -}
 
 -- | Represent a context for a given hash algorithm.
+--
+-- This type is an instance of 'ByteArrayAccess' for debugging purpose. Internal
+-- layout is architecture dependent, may contain uninitialized data fragments,
+-- and change in future versions.  The bytearray should not be used as input to
+-- cryptographic algorithms.
 newtype Context a = Context Bytes
     deriving (ByteArrayAccess,NFData)
 
 -- | Represent a digest for a given hash algorithm.
-newtype Digest a = Digest Bytes
-    deriving (Eq,Ord,ByteArrayAccess,NFData)
+--
+-- This type is an instance of 'ByteArrayAccess' from package
+-- <https://hackage.haskell.org/package/memory memory>.
+-- Module "Data.ByteArray" provides many primitives to work with those values
+-- including conversion to other types.
+--
+-- Creating a digest from a bytearray is also possible with function
+-- 'Crypto.Hash.digestFromByteString'.
+newtype Digest a = Digest (Block Word8)
+    deriving (Eq,Ord,ByteArrayAccess, Data)
+
+instance NFData (Digest a) where
+    rnf (Digest u) = u `deepseq` ()
 
 instance Show (Digest a) where
     show (Digest bs) = map (toEnum . fromIntegral)
                      $ B.unpack (B.convertToBase B.Base16 bs :: Bytes)
+
+instance HashAlgorithm a => Read (Digest a) where
+    readsPrec _ str = runST $ do mut <- new (CountOf len)
+                                 loop mut len str
+      where
+        len = hashDigestSize (undefined :: a)
+
+        loop :: MutableBlock Word8 s -> Int -> String -> ST s [(Digest a, String)]
+        loop mut 0   cs          = (\b -> [(Digest b, cs)]) <$> unsafeFreeze mut
+        loop _   _   []          = return []
+        loop _   _   [_]         = return []
+        loop mut n   (c:(d:ds))
+            | not (isHexDigit c) = return []
+            | not (isHexDigit d) = return []
+            | otherwise          = do
+                let w8 = fromIntegral $ digitToInt c * 16 + digitToInt d
+                unsafeWrite mut (Offset $ len - n) w8
+                loop mut (n - 1) ds

Crypto/Hash/Whirlpool.hs

@@ -5,21 +5,28 @@
 -- Stability   : experimental
 -- Portability : unknown
 --
--- module containing the binding functions to work with the
+-- Module containing the binding functions to work with the
 -- Whirlpool cryptographic hash.
 --
 {-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
 module Crypto.Hash.Whirlpool ( Whirlpool (..) ) where
 
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
+import           Data.Data
 import           Data.Word (Word8, Word32)
 
 -- | Whirlpool cryptographic hash algorithm
 data Whirlpool = Whirlpool
-    deriving (Show)
+    deriving (Show,Data)
 
 instance HashAlgorithm Whirlpool where
+    type HashBlockSize           Whirlpool = 64
+    type HashDigestSize          Whirlpool = 64
+    type HashInternalContextSize Whirlpool = 168
     hashBlockSize  _          = 64
     hashDigestSize _          = 64
     hashInternalContextSize _ = 168

Crypto/Internal/Builder.hs

@@ -0,0 +1,53 @@
+-- |
+-- Module      : Crypto.Internal.Builder
+-- License     : BSD-style
+-- Maintainer  : Olivier Chéron <olivier.cheron@gmail.com>
+-- Stability   : stable
+-- Portability : Good
+--
+-- Delaying and merging ByteArray allocations.  This is similar to module
+-- "Data.ByteArray.Pack" except the total length is computed automatically based
+-- on what is appended.
+--
+{-# LANGUAGE BangPatterns #-}
+module Crypto.Internal.Builder
+    ( Builder
+    , buildAndFreeze
+    , builderLength
+    , byte
+    , bytes
+    , zero
+    ) where
+
+import           Data.ByteArray (ByteArray, ByteArrayAccess)
+import qualified Data.ByteArray as B
+import           Data.Memory.PtrMethods (memSet)
+
+import           Foreign.Ptr (Ptr, plusPtr)
+import           Foreign.Storable (poke)
+
+import           Crypto.Internal.Imports hiding (empty)
+
+data Builder =  Builder !Int (Ptr Word8 -> IO ())  -- size and initializer
+
+instance Semigroup Builder where
+    (Builder s1 f1) <> (Builder s2 f2) = Builder (s1 + s2) f
+      where f p = f1 p >> f2 (p `plusPtr` s1)
+
+builderLength :: Builder -> Int
+builderLength (Builder s _) = s
+
+buildAndFreeze :: ByteArray ba => Builder -> ba
+buildAndFreeze (Builder s f) = B.allocAndFreeze s f
+
+byte :: Word8 -> Builder
+byte !b = Builder 1 (`poke` b)
+
+bytes :: ByteArrayAccess ba => ba -> Builder
+bytes bs = Builder (B.length bs) (B.copyByteArrayToPtr bs)
+
+zero :: Int -> Builder
+zero s = if s > 0 then Builder s (\p -> memSet p 0 s) else empty
+
+empty :: Builder
+empty = Builder 0 (const $ return ())

Crypto/Internal/ByteArray.hs

@@ -7,13 +7,33 @@
 --
 -- Simple and efficient byte array types
 --
+{-# LANGUAGE BangPatterns #-}
 {-# OPTIONS_HADDOCK hide #-}
 module Crypto.Internal.ByteArray
     ( module Data.ByteArray
     , module Data.ByteArray.Mapping
     , module Data.ByteArray.Encoding
+    , constAllZero
     ) where
 
 import Data.ByteArray
 import Data.ByteArray.Mapping
 import Data.ByteArray.Encoding
+
+import Data.Bits ((.|.))
+import Data.Word (Word8)
+import Foreign.Ptr (Ptr)
+import Foreign.Storable (peekByteOff)
+
+import Crypto.Internal.Compat (unsafeDoIO)
+
+constAllZero :: ByteArrayAccess ba => ba -> Bool
+constAllZero b = unsafeDoIO $ withByteArray b $ \p -> loop p 0 0
+  where
+    loop :: Ptr b -> Int -> Word8 -> IO Bool
+    loop p i !acc
+        | i == len  = return $! acc == 0
+        | otherwise = do
+            e <- peekByteOff p i
+            loop p (i+1) (acc .|. e)
+    len = Data.ByteArray.length b

Crypto/Internal/Compat.hs

@@ -5,8 +5,8 @@
 -- Stability   : stable
 -- Portability : Good
 --
--- This module try to keep all the difference between versions of base
--- or other needed packages, so that modules don't need to use CPP
+-- This module tries to keep all the difference between versions of base
+-- or other needed packages, so that modules don't need to use CPP.
 --
 {-# LANGUAGE CPP #-}
 module Crypto.Internal.Compat
@@ -19,10 +19,10 @@ import System.IO.Unsafe
 import Data.Word
 import Data.Bits
 
--- | perform io for hashes that do allocation and ffi.
--- unsafeDupablePerformIO is used when possible as the
+-- | Perform io for hashes that do allocation and FFI.
+-- 'unsafeDupablePerformIO' is used when possible as the
 -- computation is pure and the output is directly linked
--- to the input. we also do not modify anything after it has
+-- to the input. We also do not modify anything after it has
 -- been returned to the user.
 unsafeDoIO :: IO a -> a
 #if __GLASGOW_HASKELL__ > 704

Crypto/Internal/CompatPrim.hs

@@ -5,11 +5,11 @@
 -- Stability   : stable
 -- Portability : Compat
 --
--- This module try to keep all the difference between versions of ghc primitive
+-- This module tries to keep all the difference between versions of ghc primitive
 -- or other needed packages, so that modules don't need to use CPP.
 --
 -- Note that MagicHash and CPP conflicts in places, making it "more interesting"
--- to write compat code for primitives
+-- to write compat code for primitives.
 --
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE BangPatterns #-}
@@ -23,43 +23,51 @@ module Crypto.Internal.CompatPrim
     , convert4To32
     ) where
 
-import GHC.Prim
-
--- | byteswap Word# to or from Big Endian
---
--- on a big endian machine, this function is a nop.
-be32Prim :: Word# -> Word#
-#ifdef ARCH_IS_LITTLE_ENDIAN
-be32Prim = byteswap32Prim
-#else
-be32Prim w = w
+#if !defined(ARCH_IS_LITTLE_ENDIAN) && !defined(ARCH_IS_BIG_ENDIAN)
+import Data.Memory.Endian (getSystemEndianness, Endianness(..))
 #endif
 
--- | byteswap Word# to or from Little Endian
+#if __GLASGOW_HASKELL__ >= 902
+import GHC.Prim
+#else
+import GHC.Prim hiding (Word32#)
+type Word32# = Word#
+#endif
+
+-- | Byteswap Word# to or from Big Endian
 --
--- on a little endian machine, this function is a nop.
-le32Prim :: Word# -> Word#
+-- On a big endian machine, this function is a nop.
+be32Prim :: Word32# -> Word32#
+#ifdef ARCH_IS_LITTLE_ENDIAN
+be32Prim = byteswap32Prim
+#elif defined(ARCH_IS_BIG_ENDIAN)
+be32Prim = id
+#else
+be32Prim w = if getSystemEndianness == LittleEndian then byteswap32Prim w else w
+#endif
+
+-- | Byteswap Word# to or from Little Endian
+--
+-- On a little endian machine, this function is a nop.
+le32Prim :: Word32# -> Word32#
 #ifdef ARCH_IS_LITTLE_ENDIAN
 le32Prim w = w
-#else
+#elif defined(ARCH_IS_BIG_ENDIAN)
 le32Prim = byteswap32Prim
+#else
+le32Prim w = if getSystemEndianness == LittleEndian then w else byteswap32Prim w
 #endif
 
 -- | Simple compatibility for byteswap the lower 32 bits of a Word#
 -- at the primitive level
-byteswap32Prim :: Word# -> Word#
-#if __GLASGOW_HASKELL__ >= 708
-byteswap32Prim w = byteSwap32# w
+byteswap32Prim :: Word32# -> Word32#
+#if __GLASGOW_HASKELL__ >= 902
+byteswap32Prim w = wordToWord32# (byteSwap32# (word32ToWord# w))
 #else
-byteswap32Prim w =
-    let !a =       uncheckedShiftL# w 24#
-        !b = and# (uncheckedShiftL# w 8#) 0x00ff0000##
-        !c = and# (uncheckedShiftRL# w 8#) 0x0000ff00##
-        !d = and# (uncheckedShiftRL# w 24#) 0x000000ff##
-     in or# a (or# b (or# c d))
+byteswap32Prim w = byteSwap32# w
 #endif
 
--- | combine 4 word8 [a,b,c,d] to a word32 representing [a,b,c,d]
+-- | Combine 4 word8 [a,b,c,d] to a word32 representing [a,b,c,d]
 convert4To32 :: Word# -> Word# -> Word# -> Word#
              -> Word#
 convert4To32 a b c d = or# (or# c1 c2) (or# c3 c4)
@@ -69,11 +77,24 @@ convert4To32 a b c d = or# (or# c1 c2) (or# c3 c4)
         !c2 = uncheckedShiftL# b 16#
         !c3 = uncheckedShiftL# c 8#
         !c4 = d
-#else
+#elif defined(ARCH_IS_BIG_ENDIAN)
         !c1 = uncheckedShiftL# d 24#
         !c2 = uncheckedShiftL# c 16#
         !c3 = uncheckedShiftL# b 8#
         !c4 = a
+#else
+        !c1
+            | getSystemEndianness == LittleEndian = uncheckedShiftL# a 24#
+            | otherwise                           = uncheckedShiftL# d 24#
+        !c2
+            | getSystemEndianness == LittleEndian = uncheckedShiftL# b 16#
+            | otherwise                           = uncheckedShiftL# c 16#
+        !c3
+            | getSystemEndianness == LittleEndian = uncheckedShiftL# c 8#
+            | otherwise                           = uncheckedShiftL# b 8#
+        !c4
+            | getSystemEndianness == LittleEndian = d
+            | otherwise                           = a
 #endif
 
 -- | Simple wrapper to handle pre 7.8 and future, where

Crypto/Internal/DeepSeq.hs

@@ -30,4 +30,6 @@ instance NFData Word64 where rnf w = w `seq` ()
 instance NFData Bytes where rnf b = b `seq` ()
 instance NFData ScrubbedBytes where rnf b = b `seq` ()
 
+instance NFData Integer  where rnf i = i `seq` ()
+
 #endif

Crypto/Internal/Imports.hs

@@ -5,11 +5,15 @@
 -- Stability   : experimental
 -- Portability : unknown
 --
+{-# LANGUAGE CPP #-}
 module Crypto.Internal.Imports
     ( module X
     ) where
 
 import Data.Word               as X
+#if !(MIN_VERSION_base(4,11,0))
+import Data.Semigroup          as X (Semigroup(..))
+#endif
 import Control.Applicative     as X
 import Control.Monad           as X (forM, forM_, void)
 import Control.Arrow           as X (first, second)

Crypto/Internal/Nat.hs

@@ -0,0 +1,213 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Crypto.Internal.Nat
+    ( type IsDivisibleBy8
+    , type IsAtMost, type IsAtLeast
+    , byteLen
+    , integralNatVal
+    , type IsDiv8
+    , type Div8
+    , type Mod8
+    ) where
+
+import           GHC.TypeLits
+
+byteLen :: (KnownNat bitlen, Num a) => proxy bitlen -> a
+byteLen d = fromInteger ((natVal d + 7) `div` 8)
+
+integralNatVal :: (KnownNat bitlen, Num a) => proxy bitlen -> a
+integralNatVal = fromInteger . natVal
+
+type family IsLE (bitlen :: Nat) (n :: Nat) (c :: Bool) where
+    IsLE _ _ 'True  = 'True
+#if MIN_VERSION_base(4,9,0)
+    IsLE bitlen n 'False = TypeError
+      (     ('Text "bitlen " ':<>: 'ShowType bitlen ':<>: 'Text " is greater than " ':<>: 'ShowType n)
+      ':$$: ('Text "You have tried to use an invalid Digest size. Please, refer to the documentation.")
+      )
+#else
+    IsLE bitlen n 'False = 'False
+#endif
+
+-- | ensure the given `bitlen` is lesser or equal to `n`
+--
+type IsAtMost  (bitlen :: Nat) (n :: Nat) = IsLE bitlen n (bitlen <=? n) ~ 'True
+
+type family IsGE (bitlen :: Nat) (n :: Nat) (c :: Bool) where
+    IsGE _ _ 'True  = 'True
+#if MIN_VERSION_base(4,9,0)
+    IsGE bitlen n 'False = TypeError
+      (     ('Text "bitlen " ':<>: 'ShowType bitlen ':<>: 'Text " is lesser than " ':<>: 'ShowType n)
+      ':$$: ('Text "You have tried to use an invalid Digest size. Please, refer to the documentation.")
+      )
+#else
+    IsGE bitlen n 'False = 'False
+#endif
+
+-- | ensure the given `bitlen` is greater or equal to `n`
+--
+type IsAtLeast (bitlen :: Nat) (n :: Nat) = IsGE bitlen n (n <=? bitlen) ~ 'True
+
+type family Div8 (bitLen :: Nat) where
+    Div8 0 = 0
+    Div8 1 = 0
+    Div8 2 = 0
+    Div8 3 = 0
+    Div8 4 = 0
+    Div8 5 = 0
+    Div8 6 = 0
+    Div8 7 = 0
+    Div8 8 = 1
+    Div8 9 = 1
+    Div8 10 = 1
+    Div8 11 = 1
+    Div8 12 = 1
+    Div8 13 = 1
+    Div8 14 = 1
+    Div8 15 = 1
+    Div8 16 = 2
+    Div8 17 = 2
+    Div8 18 = 2
+    Div8 19 = 2
+    Div8 20 = 2
+    Div8 21 = 2
+    Div8 22 = 2
+    Div8 23 = 2
+    Div8 24 = 3
+    Div8 25 = 3
+    Div8 26 = 3
+    Div8 27 = 3
+    Div8 28 = 3
+    Div8 29 = 3
+    Div8 30 = 3
+    Div8 31 = 3
+    Div8 32 = 4
+    Div8 33 = 4
+    Div8 34 = 4
+    Div8 35 = 4
+    Div8 36 = 4
+    Div8 37 = 4
+    Div8 38 = 4
+    Div8 39 = 4
+    Div8 40 = 5
+    Div8 41 = 5
+    Div8 42 = 5
+    Div8 43 = 5
+    Div8 44 = 5
+    Div8 45 = 5
+    Div8 46 = 5
+    Div8 47 = 5
+    Div8 48 = 6
+    Div8 49 = 6
+    Div8 50 = 6
+    Div8 51 = 6
+    Div8 52 = 6
+    Div8 53 = 6
+    Div8 54 = 6
+    Div8 55 = 6
+    Div8 56 = 7
+    Div8 57 = 7
+    Div8 58 = 7
+    Div8 59 = 7
+    Div8 60 = 7
+    Div8 61 = 7
+    Div8 62 = 7
+    Div8 63 = 7
+    Div8 64 = 8
+    Div8 n  = 8 + Div8 (n - 64)
+
+type family IsDiv8 (bitLen :: Nat) (n :: Nat) where
+    IsDiv8 _ 0 = 'True
+#if MIN_VERSION_base(4,9,0)
+    IsDiv8 bitLen 1 = TypeError ('Text "bitLen " ':<>: 'ShowType bitLen ':<>: 'Text " is not divisible by 8")
+    IsDiv8 bitLen 2 = TypeError ('Text "bitLen " ':<>: 'ShowType bitLen ':<>: 'Text " is not divisible by 8")
+    IsDiv8 bitLen 3 = TypeError ('Text "bitLen " ':<>: 'ShowType bitLen ':<>: 'Text " is not divisible by 8")
+    IsDiv8 bitLen 4 = TypeError ('Text "bitLen " ':<>: 'ShowType bitLen ':<>: 'Text " is not divisible by 8")
+    IsDiv8 bitLen 5 = TypeError ('Text "bitLen " ':<>: 'ShowType bitLen ':<>: 'Text " is not divisible by 8")
+    IsDiv8 bitLen 6 = TypeError ('Text "bitLen " ':<>: 'ShowType bitLen ':<>: 'Text " is not divisible by 8")
+    IsDiv8 bitLen 7 = TypeError ('Text "bitLen " ':<>: 'ShowType bitLen ':<>: 'Text " is not divisible by 8")
+#else
+    IsDiv8 _ 1 = 'False
+    IsDiv8 _ 2 = 'False
+    IsDiv8 _ 3 = 'False
+    IsDiv8 _ 4 = 'False
+    IsDiv8 _ 5 = 'False
+    IsDiv8 _ 6 = 'False
+    IsDiv8 _ 7 = 'False
+#endif
+    IsDiv8 _ n = IsDiv8 n (Mod8 n)
+
+type family Mod8 (n :: Nat) where
+    Mod8 0 = 0
+    Mod8 1 = 1
+    Mod8 2 = 2
+    Mod8 3 = 3
+    Mod8 4 = 4
+    Mod8 5 = 5
+    Mod8 6 = 6
+    Mod8 7 = 7
+    Mod8 8 = 0
+    Mod8 9 = 1
+    Mod8 10 = 2
+    Mod8 11 = 3
+    Mod8 12 = 4
+    Mod8 13 = 5
+    Mod8 14 = 6
+    Mod8 15 = 7
+    Mod8 16 = 0
+    Mod8 17 = 1
+    Mod8 18 = 2
+    Mod8 19 = 3
+    Mod8 20 = 4
+    Mod8 21 = 5
+    Mod8 22 = 6
+    Mod8 23 = 7
+    Mod8 24 = 0
+    Mod8 25 = 1
+    Mod8 26 = 2
+    Mod8 27 = 3
+    Mod8 28 = 4
+    Mod8 29 = 5
+    Mod8 30 = 6
+    Mod8 31 = 7
+    Mod8 32 = 0
+    Mod8 33 = 1
+    Mod8 34 = 2
+    Mod8 35 = 3
+    Mod8 36 = 4
+    Mod8 37 = 5
+    Mod8 38 = 6
+    Mod8 39 = 7
+    Mod8 40 = 0
+    Mod8 41 = 1
+    Mod8 42 = 2
+    Mod8 43 = 3
+    Mod8 44 = 4
+    Mod8 45 = 5
+    Mod8 46 = 6
+    Mod8 47 = 7
+    Mod8 48 = 0
+    Mod8 49 = 1
+    Mod8 50 = 2
+    Mod8 51 = 3
+    Mod8 52 = 4
+    Mod8 53 = 5
+    Mod8 54 = 6
+    Mod8 55 = 7
+    Mod8 56 = 0
+    Mod8 57 = 1
+    Mod8 58 = 2
+    Mod8 59 = 3
+    Mod8 60 = 4
+    Mod8 61 = 5
+    Mod8 62 = 6
+    Mod8 63 = 7
+    Mod8 n = Mod8 (n - 64)
+
+-- | ensure the given `bitlen` is divisible by 8
+--
+type IsDivisibleBy8 bitLen = IsDiv8 bitLen bitLen ~ 'True

Crypto/Internal/WordArray.hs

@@ -1,5 +1,5 @@
 -- |
--- Module      : Crypto.Internal.Compat
+-- Module      : Crypto.Internal.WordArray
 -- License     : BSD-style
 -- Maintainer  : Vincent Hanquez <vincent@snarc.org>
 -- Stability   : stable
@@ -8,7 +8,7 @@
 -- Small and self contained array representation
 -- with limited safety for internal use.
 --
--- the array produced should never be exposed to the user directly
+-- The array produced should never be exposed to the user directly.
 --
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE MagicHash #-}
@@ -20,6 +20,8 @@ module Crypto.Internal.WordArray
     , MutableArray32
     , array8
     , array32
+    , array32FromAddrBE
+    , allocArray32AndFreeze
     , mutableArray32
     , array64
     , arrayRead8
@@ -58,21 +60,21 @@ array8 = Array8
 
 -- | Create an Array of Word32 of specific size from a list of Word32
 array32 :: Int -> [Word32] -> Array32
-array32 (I# n) l = unsafeDoIO $ IO $ \s ->
-    case newAlignedPinnedByteArray# (n *# 4#) 4# s of
-        (# s', mbarr #) -> loop 0# s' mbarr l
-  where
-        loop _ st mb [] = freezeArray mb st
-        loop i st mb ((W32# x):xs)
-            | booleanPrim (i ==# n) = freezeArray mb st
-            | otherwise =
-                let !st' = writeWord32Array# mb i x st
-                 in loop (i +# 1#) st' mb xs
-        freezeArray mb st =
-            case unsafeFreezeByteArray# mb st of
-                (# st', b #) -> (# st', Array32 b #)
+array32 n l = unsafeDoIO (mutableArray32 n l >>= mutableArray32Freeze)
 {-# NOINLINE array32 #-}
 
+-- | Create an Array of BE Word32 aliasing an Addr
+array32FromAddrBE :: Int -> Addr# -> Array32
+array32FromAddrBE n a =
+    unsafeDoIO (mutableArray32FromAddrBE n a >>= mutableArray32Freeze)
+{-# NOINLINE array32FromAddrBE #-}
+
+-- | Create an Array of Word32 using an initializer
+allocArray32AndFreeze :: Int -> (MutableArray32 -> IO ()) -> Array32
+allocArray32AndFreeze n f =
+    unsafeDoIO (mutableArray32 n [] >>= \m -> f m >> mutableArray32Freeze m)
+{-# NOINLINE allocArray32AndFreeze #-}
+
 -- | Create an Array of Word64 of specific size from a list of Word64
 array64 :: Int -> [Word64] -> Array64
 array64 (I# n) l = unsafeDoIO $ IO $ \s ->

Crypto/KDF/Argon2.hs

@@ -0,0 +1,157 @@
+-- |
+-- Module      : Crypto.KDF.Argon2
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Argon2 hashing function (P-H-C winner)
+--
+-- Recommended to use this module qualified
+--
+-- File started from Argon2.hs, from Oliver Charles
+-- at https://github.com/ocharles/argon2
+--
+module Crypto.KDF.Argon2
+    (
+      Options(..)
+    , TimeCost
+    , MemoryCost
+    , Parallelism
+    , Variant(..)
+    , Version(..)
+    , defaultOptions
+    -- * Hashing function
+    , hash
+    ) where
+
+import           Crypto.Internal.ByteArray (ByteArray, ByteArrayAccess)
+import qualified Crypto.Internal.ByteArray as B
+import           Crypto.Error
+import           Control.Monad (when)
+import           Data.Word
+import           Foreign.C
+import           Foreign.Ptr
+
+-- | Which variant of Argon2 to use. You should choose the variant that is most
+-- applicable to your intention to hash inputs.
+data Variant =
+      Argon2d  -- ^ Argon2d is faster than Argon2i and uses data-depending memory access,
+               -- which makes it suitable for cryptocurrencies and applications with no
+               -- threats from side-channel timing attacks.
+    | Argon2i  -- ^ Argon2i uses data-independent memory access, which is preferred
+               -- for password hashing and password-based key derivation. Argon2i
+               -- is slower as it makes more passes over the memory to protect from
+               -- tradeoff attacks.
+    | Argon2id -- ^ Argon2id is a hybrid of Argon2i and Argon2d, using a combination
+               -- of data-depending and data-independent memory accesses, which gives
+               -- some of Argon2i's resistance to side-channel cache timing attacks
+               -- and much of Argon2d's resistance to GPU cracking attacks
+    deriving (Eq,Ord,Read,Show,Enum,Bounded)
+
+-- | Which version of Argon2 to use
+data Version = Version10 | Version13
+    deriving (Eq,Ord,Read,Show,Enum,Bounded)
+
+-- | The time cost, which defines the amount of computation realized and therefore the execution time, given in number of iterations.
+--
+-- 'FFI.ARGON2_MIN_TIME' <= 'hashIterations' <= 'FFI.ARGON2_MAX_TIME'
+type TimeCost = Word32
+
+-- | The memory cost, which defines the memory usage, given in kibibytes.
+--
+-- max 'FFI.ARGON2_MIN_MEMORY' (8 * 'hashParallelism') <= 'hashMemory' <= 'FFI.ARGON2_MAX_MEMORY'
+type MemoryCost = Word32
+
+-- | A parallelism degree, which defines the number of parallel threads.
+--
+-- 'FFI.ARGON2_MIN_LANES' <= 'hashParallelism' <= 'FFI.ARGON2_MAX_LANES' && 'FFI.ARGON_MIN_THREADS' <= 'hashParallelism' <= 'FFI.ARGON2_MAX_THREADS'
+type Parallelism = Word32
+
+-- | Parameters that can be adjusted to change the runtime performance of the
+-- hashing.
+data Options = Options
+    { iterations  :: !TimeCost
+    , memory      :: !MemoryCost
+    , parallelism :: !Parallelism
+    , variant     :: !Variant     -- ^ Which variant of Argon2 to use.
+    , version     :: !Version     -- ^ Which version of Argon2 to use.
+    }
+    deriving (Eq,Ord,Read,Show)
+
+saltMinLength :: Int
+saltMinLength = 8
+
+outputMinLength :: Int
+outputMinLength = 4
+
+-- specification allows up to 2^32-1 but this is too big for a signed Int
+-- on a 32-bit architecture, so we limit tag length to 2^31-1 bytes
+outputMaxLength :: Int
+outputMaxLength = 0x7fffffff
+
+defaultOptions :: Options
+defaultOptions =
+    Options { iterations  = 1
+            , memory      = 2 ^ (17 :: Int)
+            , parallelism = 4
+            , variant     = Argon2i
+            , version     = Version13
+            }
+
+hash :: (ByteArrayAccess password, ByteArrayAccess salt, ByteArray out)
+     => Options
+     -> password
+     -> salt
+     -> Int
+     -> CryptoFailable out
+hash options password salt outLen
+    | saltLen < saltMinLength  = CryptoFailed CryptoError_SaltTooSmall
+    | outLen < outputMinLength = CryptoFailed CryptoError_OutputLengthTooSmall
+    | outLen > outputMaxLength = CryptoFailed CryptoError_OutputLengthTooBig
+    | otherwise                = CryptoPassed $ B.allocAndFreeze outLen $ \out -> do
+        res <- B.withByteArray password $ \pPass ->
+               B.withByteArray salt     $ \pSalt ->
+                    argon2_hash (iterations options)
+                                (memory options)
+                                (parallelism options)
+                                pPass
+                                (csizeOfInt passwordLen)
+                                pSalt
+                                (csizeOfInt saltLen)
+                                out
+                                (csizeOfInt outLen)
+                                (cOfVariant $ variant options)
+                                (cOfVersion $ version options)
+        when (res /= 0) $ error "argon2: hash: internal error"
+  where
+    saltLen = B.length salt
+    passwordLen = B.length password
+
+data Pass
+data Salt
+data HashOut
+
+type CVariant = CInt -- valid value is 0 (Argon2d), 1 (Argon2i) and 2 (Argon2id)
+type CVersion = CInt -- valid value is 0x10, 0x13
+
+cOfVersion :: Version -> CVersion
+cOfVersion Version10 = 0x10
+cOfVersion Version13 = 0x13
+
+cOfVariant :: Variant -> CVariant
+cOfVariant Argon2d  = 0
+cOfVariant Argon2i  = 1
+cOfVariant Argon2id = 2
+
+csizeOfInt :: Int -> CSize
+csizeOfInt = fromIntegral
+
+foreign import ccall unsafe "cryptonite_argon2_hash"
+    argon2_hash :: Word32 -> Word32 -> Word32
+                -> Ptr Pass -> CSize
+                -> Ptr Salt -> CSize
+                -> Ptr HashOut -> CSize
+                -> CVariant
+                -> CVersion
+                -> IO CInt

Crypto/KDF/BCrypt.hs

@@ -1,24 +1,48 @@
 
 -- | Password encoding and validation using bcrypt.
 --
+-- Example usage:
+--
+-- >>> import Crypto.KDF.BCrypt (hashPassword, validatePassword)
+-- >>> import qualified Data.ByteString.Char8 as B
+-- >>>
+-- >>> let bcryptHash = B.pack "$2a$10$MJJifxfaqQmbx1Mhsq3oq.YmMmfNhkyW4s/MS3K5rIMVfB7w0Q/OW"
+-- >>> let password = B.pack "password"
+-- >>> validatePassword password bcryptHash
+-- >>> True
+-- >>> let otherPassword = B.pack "otherpassword"
+-- >>> otherHash <- hashPassword 12 otherPassword :: IO B.ByteString
+-- >>> validatePassword otherPassword otherHash
+-- >>> True
+--
 -- See <https://www.usenix.org/conference/1999-usenix-annual-technical-conference/future-adaptable-password-scheme>
 -- for details of the original algorithm.
 --
--- Hashes are strings of the form @$2a$10$MJJifxfaqQmbx1Mhsq3oq.YmMmfNhkyW4s/MS3K5rIMVfB7w0Q/OW@ which
--- encode a version number, an integer cost parameter and the concatenated salt and hash bytes (each
--- separately Base64 encoded. Incrementing the cost parameter approximately doubles the time taken
--- to calculate the hash.
+-- The functions @hashPassword@ and @validatePassword@ should be all that
+-- most users need.
 --
--- The different version numbers have evolved because of bugs in the standard C implementations.
--- The most up to date version is @2b@ and this implementation the @2b@ version prefix, but will also
--- attempt to validate against hashes with versions @2a@ and @2y@. Version @2@ or @2x@ will be rejected.
--- No attempt is made to differentiate between the different versions when validating a password, but
--- in practice this shouldn't cause any problems if passwords are UTF-8 encoded (which they should be).
+-- Hashes are strings of the form
+-- @$2a$10$MJJifxfaqQmbx1Mhsq3oq.YmMmfNhkyW4s/MS3K5rIMVfB7w0Q/OW@ which
+-- encode a version number, an integer cost parameter and the concatenated
+-- salt and hash bytes (each separately Base64 encoded. Incrementing the
+-- cost parameter approximately doubles the time taken to calculate the hash.
 --
--- The cost parameter can be between 4 and 31 inclusive, but anything less than 10 is probably not strong
--- enough. High values may be prohibitively slow depending on your hardware. Choose the highest value you
--- can without having an unacceptable impact on your users. The cost parameter can also varied depending on
--- the account, since it is unique to an individual hash.
+-- The different version numbers evolved to account for bugs in the standard
+-- C implementations. They don't represent different versions of the algorithm
+-- itself and in most cases should produce identical results.
+-- The most up to date version is @2b@ and this implementation uses the
+-- @2b@ version prefix, but will also attempt to validate
+-- against hashes with versions @2a@ and @2y@. Version @2@ or @2x@ will be
+-- rejected. No attempt is made to differentiate between the different versions
+-- when validating a password, but in practice this shouldn't cause any problems
+-- if passwords are UTF-8 encoded (which they should be) and less than 256
+-- characters long.
+--
+-- The cost parameter can be between 4 and 31 inclusive, but anything less than
+-- 10 is probably not strong enough. High values may be prohibitively slow
+-- depending on your hardware. Choose the highest value you can without having
+-- an unacceptable impact on your users. The cost parameter can also be varied
+-- depending on the account, since it is unique to an individual hash.
 
 module Crypto.KDF.BCrypt
     ( hashPassword
@@ -28,17 +52,24 @@ module Crypto.KDF.BCrypt
     )
 where
 
-import           Control.Monad (unless, when)
-import           Crypto.Cipher.Blowfish.Primitive (eksBlowfish, encrypt)
-import           Crypto.Random (MonadRandom, getRandomBytes)
-import           Data.ByteArray (ByteArrayAccess, ByteArray, Bytes)
-import qualified Data.ByteArray as B
+import           Control.Monad                    (forM_, unless, when)
+import           Crypto.Cipher.Blowfish.Primitive (Context, createKeySchedule,
+                                                   encrypt, expandKey,
+                                                   expandKeyWithSalt,
+                                                   freezeKeySchedule)
+import           Crypto.Internal.Compat
+import           Crypto.Random                    (MonadRandom, getRandomBytes)
+import           Data.ByteArray                   (ByteArray, ByteArrayAccess,
+                                                   Bytes)
+import qualified Data.ByteArray                   as B
 import           Data.ByteArray.Encoding
 import           Data.Char
 
 data BCryptHash = BCH Char Int Bytes Bytes
 
 -- | Create a bcrypt hash for a password with a provided cost value.
+-- Typically used to create a hash when a new user account is registered
+-- or when a user changes their password.
 --
 -- Each increment of the cost approximately doubles the time taken.
 -- The 16 bytes of random salt will be generated internally.
@@ -55,6 +86,8 @@ hashPassword cost password = do
     return $ bcrypt cost (salt :: Bytes) password
 
 -- | Create a bcrypt hash for a password with a provided cost value and salt.
+--
+-- Cost value under 4 will be automatically adjusted back to 10 for safety reason.
 bcrypt :: (ByteArray salt, ByteArray password, ByteArray output)
        => Int
        -- ^ The cost parameter. Should be between 4 and 31 (inclusive).
@@ -68,7 +101,7 @@ bcrypt :: (ByteArray salt, ByteArray password, ByteArray output)
 bcrypt cost salt password = B.concat [header, B.snoc costBytes dollar, b64 salt, b64 hash]
   where
     hash   = rawHash 'b' realCost salt password
-    header = B.pack [dollar, fromIntegral (ord '2'), fromIntegral (ord 'a'), dollar]
+    header = B.pack [dollar, fromIntegral (ord '2'), fromIntegral (ord 'b'), dollar]
     dollar = fromIntegral (ord '$')
     zero   = fromIntegral (ord '0')
     costBytes  = B.pack [zero + fromIntegral (realCost `div` 10), zero + fromIntegral (realCost `mod` 10)]
@@ -80,7 +113,7 @@ bcrypt cost salt password = B.concat [header, B.snoc costBytes dollar, b64 salt,
     b64 :: (ByteArray ba) => ba -> ba
     b64 = convertToBase Base64OpenBSD
 
--- | Check a password against a bcrypt hash
+-- | Check a password against a stored bcrypt hash when authenticating a user.
 --
 -- Returns @False@ if the password doesn't match the hash, or if the hash is
 -- invalid or an unsupported version.
@@ -108,7 +141,7 @@ rawHash _ cost salt password = B.take 23 hash -- Another compatibility bug. Igno
     -- Truncate the password if necessary and append a null byte for C compatibility
     key = B.snoc (B.take 72 password) 0
 
-    ctx = eksBlowfish cost salt key
+    ctx = expensiveBlowfishContext key salt cost
 
     -- The BCrypt plaintext: "OrpheanBeholderScryDoubt"
     orpheanBeholder = B.pack [79,114,112,104,101,97,110,66,101,104,111,108,100,101,114,83,99,114,121,68,111,117,98,116]
@@ -131,10 +164,26 @@ parseBCryptHash bc = do
     costTens  = fromIntegral (B.index bc 4) - zero
     costUnits = fromIntegral (B.index bc 5) - zero
     version   = chr (fromIntegral (B.index bc 2))
-    cost      = costUnits + (if costTens == 0 then 0 else 10^costTens) :: Int
+    cost      = costUnits + 10*costTens :: Int
 
     decodeSaltHash saltHash = do
         let (s, h) = B.splitAt 22 saltHash
         salt <- convertFromBase Base64OpenBSD s
         hash <- convertFromBase Base64OpenBSD h
         return (salt, hash)
+
+-- | Create a key schedule for the BCrypt "EKS" version.
+--
+-- Salt must be a 128-bit byte array.
+-- Cost must be between 4 and 31 inclusive
+-- See <https://www.usenix.org/conference/1999-usenix-annual-technical-conference/future-adaptable-password-scheme>
+expensiveBlowfishContext :: (ByteArrayAccess key, ByteArrayAccess salt) => key-> salt -> Int -> Context
+expensiveBlowfishContext keyBytes saltBytes cost
+  | B.length saltBytes /= 16 = error "bcrypt salt must be 16 bytes"
+  | otherwise = unsafeDoIO $ do
+        ks <- createKeySchedule
+        expandKeyWithSalt ks keyBytes saltBytes
+        forM_ [1..2^cost :: Int] $ \_ -> do
+            expandKey ks keyBytes
+            expandKey ks saltBytes
+        freezeKeySchedule ks

Crypto/KDF/BCryptPBKDF.hs

@@ -0,0 +1,187 @@
+-- |
+-- Module      : Crypto.KDF.BCryptPBKDF
+-- License     : BSD-style
+-- Stability   : experimental
+-- Portability : Good
+--
+-- Port of the bcrypt_pbkdf key derivation function from OpenBSD
+-- as described at <http://man.openbsd.org/bcrypt_pbkdf.3>.
+module Crypto.KDF.BCryptPBKDF
+    ( Parameters (..)
+    , generate
+    , hashInternal
+    )
+where
+
+import           Basement.Block                   (MutableBlock)
+import qualified Basement.Block                   as Block
+import qualified Basement.Block.Mutable           as Block
+import           Basement.Monad                   (PrimState)
+import           Basement.Types.OffsetSize        (CountOf (..), Offset (..))
+import           Control.Exception                (finally)
+import           Control.Monad                    (when)
+import qualified Crypto.Cipher.Blowfish.Box       as Blowfish
+import qualified Crypto.Cipher.Blowfish.Primitive as Blowfish
+import           Crypto.Hash.Algorithms           (SHA512 (..))
+import           Crypto.Hash.Types                (Context,
+                                                   hashDigestSize,
+                                                   hashInternalContextSize,
+                                                   hashInternalFinalize,
+                                                   hashInternalInit,
+                                                   hashInternalUpdate)
+import           Crypto.Internal.Compat           (unsafeDoIO)
+import           Data.Bits
+import qualified Data.ByteArray                   as B
+import           Data.Foldable                    (forM_)
+import           Data.Memory.PtrMethods           (memCopy, memSet, memXor)
+import           Data.Word
+import           Foreign.Ptr                      (Ptr, castPtr)
+import           Foreign.Storable                 (peekByteOff, pokeByteOff)
+
+data Parameters = Parameters
+  { iterCounts   :: Int -- ^ The number of user-defined iterations for the algorithm
+                        --   (must be > 0)
+  , outputLength :: Int -- ^ The number of bytes to generate out of BCryptPBKDF
+                        --   (must be in 1..1024)
+  } deriving (Eq, Ord, Show)
+
+-- | Derive a key of specified length using the bcrypt_pbkdf algorithm.
+generate :: (B.ByteArray pass, B.ByteArray salt, B.ByteArray output)
+       => Parameters
+       -> pass
+       -> salt
+       -> output
+generate params pass salt
+    | iterCounts params < 1       = error "BCryptPBKDF: iterCounts must be > 0"
+    | keyLen < 1 || keyLen > 1024 = error "BCryptPBKDF: outputLength must be in 1..1024"
+    | otherwise                   = B.unsafeCreate keyLen deriveKey
+  where
+    outLen, tmpLen, blkLen, keyLen, passLen, saltLen, ctxLen, hashLen, blocks :: Int
+    outLen  = 32
+    tmpLen  = 32
+    blkLen  = 4
+    passLen = B.length pass
+    saltLen = B.length salt
+    keyLen  = outputLength params
+    ctxLen  = hashInternalContextSize SHA512
+    hashLen = hashDigestSize SHA512 -- 64
+    blocks  = (keyLen + outLen - 1) `div` outLen
+
+    deriveKey :: Ptr Word8 -> IO ()
+    deriveKey keyPtr = do
+        -- Allocate all necessary memory. The algorihm shall not allocate
+        -- any more dynamic memory after this point. Blocks need to be pinned
+        -- as pointers to them are passed to the SHA512 implementation.
+        ksClean        <- Blowfish.createKeySchedule
+        ksDirty        <- Blowfish.createKeySchedule
+        ctxMBlock      <- Block.newPinned (CountOf ctxLen  :: CountOf Word8)
+        outMBlock      <- Block.newPinned (CountOf outLen  :: CountOf Word8)
+        tmpMBlock      <- Block.newPinned (CountOf tmpLen  :: CountOf Word8)
+        blkMBlock      <- Block.newPinned (CountOf blkLen  :: CountOf Word8)
+        passHashMBlock <- Block.newPinned (CountOf hashLen :: CountOf Word8)
+        saltHashMBlock <- Block.newPinned (CountOf hashLen :: CountOf Word8)
+        -- Finally erase all memory areas that contain information from
+        -- which the derived key could be reconstructed.
+        -- As all MutableBlocks are pinned it shall be guaranteed that
+        -- no temporary trampoline buffers are allocated.
+        finallyErase outMBlock $ finallyErase passHashMBlock $
+            B.withByteArray pass                $ \passPtr->
+            B.withByteArray salt                $ \saltPtr->
+            Block.withMutablePtr ctxMBlock      $ \ctxPtr->
+            Block.withMutablePtr outMBlock      $ \outPtr->
+            Block.withMutablePtr tmpMBlock      $ \tmpPtr->
+            Block.withMutablePtr blkMBlock      $ \blkPtr->
+            Block.withMutablePtr passHashMBlock $ \passHashPtr->
+            Block.withMutablePtr saltHashMBlock $ \saltHashPtr-> do
+                -- Hash the password.
+                let shaPtr = castPtr ctxPtr :: Ptr (Context SHA512)
+                hashInternalInit     shaPtr
+                hashInternalUpdate   shaPtr passPtr (fromIntegral passLen)
+                hashInternalFinalize shaPtr (castPtr passHashPtr)
+                passHashBlock <- Block.unsafeFreeze passHashMBlock
+                forM_ [1..blocks] $ \block-> do
+                    -- Poke the increased block counter.
+                    Block.unsafeWrite blkMBlock 0 (fromIntegral $ block `shiftR` 24)
+                    Block.unsafeWrite blkMBlock 1 (fromIntegral $ block `shiftR` 16)
+                    Block.unsafeWrite blkMBlock 2 (fromIntegral $ block `shiftR`  8)
+                    Block.unsafeWrite blkMBlock 3 (fromIntegral $ block `shiftR`  0)
+                    -- First round (slightly different).
+                    hashInternalInit     shaPtr
+                    hashInternalUpdate   shaPtr saltPtr (fromIntegral saltLen)
+                    hashInternalUpdate   shaPtr blkPtr  (fromIntegral blkLen)
+                    hashInternalFinalize shaPtr (castPtr saltHashPtr)
+                    Block.unsafeFreeze saltHashMBlock >>= \x-> do
+                        Blowfish.copyKeySchedule ksDirty ksClean
+                        hashInternalMutable ksDirty passHashBlock x tmpMBlock
+                    memCopy outPtr tmpPtr outLen
+                    -- Remaining rounds.
+                    forM_ [2..iterCounts params] $ const $ do
+                        hashInternalInit     shaPtr
+                        hashInternalUpdate   shaPtr tmpPtr (fromIntegral tmpLen)
+                        hashInternalFinalize shaPtr (castPtr saltHashPtr)
+                        Block.unsafeFreeze saltHashMBlock >>= \x-> do
+                            Blowfish.copyKeySchedule ksDirty ksClean
+                            hashInternalMutable ksDirty passHashBlock x tmpMBlock
+                        memXor outPtr outPtr tmpPtr outLen
+                    -- Spread the current out buffer evenly over the key buffer.
+                    -- After both loops have run every byte of the key buffer
+                    -- will have been written to exactly once and every byte
+                    -- of the output will have been used.
+                    forM_ [0..outLen - 1] $ \outIdx-> do
+                        let keyIdx = outIdx * blocks + block - 1
+                        when (keyIdx < keyLen) $ do
+                            w8 <- peekByteOff outPtr outIdx :: IO Word8
+                            pokeByteOff keyPtr keyIdx w8
+
+-- | Internal hash function used by `generate`.
+--
+-- Normal users should not need this.
+hashInternal :: (B.ByteArrayAccess pass, B.ByteArrayAccess salt, B.ByteArray output)
+    => pass
+    -> salt
+    -> output
+hashInternal passHash saltHash
+    | B.length passHash /= 64 = error "passHash must be 512 bits"
+    | B.length saltHash /= 64 = error "saltHash must be 512 bits"
+    | otherwise = unsafeDoIO $ do
+        ks0 <- Blowfish.createKeySchedule
+        outMBlock <- Block.newPinned 32
+        hashInternalMutable ks0 passHash saltHash outMBlock
+        B.convert `fmap` Block.freeze outMBlock
+
+hashInternalMutable :: (B.ByteArrayAccess pass, B.ByteArrayAccess salt)
+    => Blowfish.KeySchedule
+    -> pass
+    -> salt
+    -> MutableBlock Word8 (PrimState IO)
+    -> IO ()
+hashInternalMutable bfks passHash saltHash outMBlock = do
+    Blowfish.expandKeyWithSalt bfks passHash saltHash
+    forM_ [0..63 :: Int] $ const $ do
+        Blowfish.expandKey bfks saltHash
+        Blowfish.expandKey bfks passHash
+    -- "OxychromaticBlowfishSwatDynamite" represented as 4 Word64 in big-endian.
+    store  0 =<< cipher 64 0x4f78796368726f6d
+    store  8 =<< cipher 64 0x61746963426c6f77
+    store 16 =<< cipher 64 0x6669736853776174
+    store 24 =<< cipher 64 0x44796e616d697465
+    where
+        store :: Offset Word8 -> Word64 -> IO ()
+        store o w64 = do
+            Block.unsafeWrite outMBlock (o + 0) (fromIntegral $ w64 `shiftR` 32)
+            Block.unsafeWrite outMBlock (o + 1) (fromIntegral $ w64 `shiftR` 40)
+            Block.unsafeWrite outMBlock (o + 2) (fromIntegral $ w64 `shiftR` 48)
+            Block.unsafeWrite outMBlock (o + 3) (fromIntegral $ w64 `shiftR` 56)
+            Block.unsafeWrite outMBlock (o + 4) (fromIntegral $ w64 `shiftR`  0)
+            Block.unsafeWrite outMBlock (o + 5) (fromIntegral $ w64 `shiftR`  8)
+            Block.unsafeWrite outMBlock (o + 6) (fromIntegral $ w64 `shiftR` 16)
+            Block.unsafeWrite outMBlock (o + 7) (fromIntegral $ w64 `shiftR` 24)
+        cipher :: Int -> Word64 -> IO Word64
+        cipher 0 block = return block
+        cipher i block = Blowfish.cipherBlockMutable bfks block >>= cipher (i - 1)
+
+finallyErase :: MutableBlock Word8 (PrimState IO) -> IO () -> IO ()
+finallyErase mblock action =
+    action `finally` Block.withMutablePtr mblock (\ptr-> memSet ptr 0 len)
+    where
+        CountOf len = Block.mutableLengthBytes mblock

Crypto/KDF/HKDF.hs

@@ -0,0 +1,84 @@
+-- |
+-- Module      : Crypto.KDF.HKDF
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Key Derivation Function based on HMAC
+--
+-- See RFC5869
+--
+{-# LANGUAGE BangPatterns #-}
+module Crypto.KDF.HKDF
+    ( PRK
+    , extract
+    , extractSkip
+    , expand
+    ) where
+
+import           Data.Word
+import           Crypto.Hash
+import           Crypto.MAC.HMAC
+import           Crypto.Internal.ByteArray (ScrubbedBytes, ByteArray, ByteArrayAccess)
+import qualified Crypto.Internal.ByteArray as B
+
+-- | Pseudo Random Key
+data PRK a = PRK (HMAC a) | PRK_NoExpand ScrubbedBytes
+    deriving (Eq)
+
+instance ByteArrayAccess (PRK a) where
+    length (PRK hm)          = B.length hm
+    length (PRK_NoExpand sb) = B.length sb
+    withByteArray (PRK hm)          = B.withByteArray hm
+    withByteArray (PRK_NoExpand sb) = B.withByteArray sb
+
+-- | Extract a Pseudo Random Key using the parameter and the underlaying hash mechanism
+extract :: (HashAlgorithm a, ByteArrayAccess salt, ByteArrayAccess ikm)
+        => salt  -- ^ Salt
+        -> ikm   -- ^ Input Keying Material
+        -> PRK a -- ^ Pseudo random key
+extract salt ikm = PRK $ hmac salt ikm
+
+-- | Create a PRK directly from the input key material.
+--
+-- Only use when guaranteed to have a good quality and random data to use directly as key.
+-- This effectively skip a HMAC with key=salt and data=key.
+extractSkip :: ByteArrayAccess ikm
+            => ikm
+            -> PRK a
+extractSkip ikm = PRK_NoExpand $ B.convert ikm
+
+-- | Expand key material of specific length out of the parameters
+expand :: (HashAlgorithm a, ByteArrayAccess info, ByteArray out)
+       => PRK a      -- ^ Pseudo Random Key
+       -> info       -- ^ Optional context and application specific information
+       -> Int        -- ^ Output length in bytes
+       -> out        -- ^ Output data
+expand prkAt infoAt outputLength =
+    let hF = hFGet prkAt
+     in B.concat $ loop hF B.empty outputLength 1
+  where
+    hFGet :: (HashAlgorithm a, ByteArrayAccess b) => PRK a -> (b -> HMAC a)
+    hFGet prk = case prk of
+             PRK hmacKey      -> hmac hmacKey
+             PRK_NoExpand ikm -> hmac ikm
+
+    info :: ScrubbedBytes
+    info = B.convert infoAt
+
+    loop :: HashAlgorithm a
+         => (ScrubbedBytes -> HMAC a)
+         -> ScrubbedBytes
+         -> Int
+         -> Word8
+         -> [ScrubbedBytes]
+    loop hF tim1 n i
+        | n <= 0    = []
+        | otherwise =
+            let input   = B.concat [tim1,info,B.singleton i] :: ScrubbedBytes
+                ti      = B.convert $ hF input
+                hashLen = B.length ti
+                r       = n - hashLen
+             in (if n >= hashLen then ti else B.take n ti)
+              : loop hF ti r (i+1)

Crypto/KDF/PBKDF2.hs

@@ -8,17 +8,23 @@
 -- Password Based Key Derivation Function 2
 --
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+
 module Crypto.KDF.PBKDF2
     ( PRF
     , prfHMAC
     , Parameters(..)
     , generate
+    , fastPBKDF2_SHA1
+    , fastPBKDF2_SHA256
+    , fastPBKDF2_SHA512
     ) where
 
 import           Data.Word
 import           Data.Bits
 import           Foreign.Marshal.Alloc
-import           Foreign.Ptr (plusPtr)
+import           Foreign.Ptr (plusPtr, Ptr)
+import           Foreign.C.Types (CUInt(..), CSize(..))
 
 import           Crypto.Hash (HashAlgorithm)
 import qualified Crypto.MAC.HMAC as HMAC
@@ -100,3 +106,70 @@ generate prf params password salt =
             c = fromIntegral ((w `shiftR` 8) .&. 0xff)
             d = fromIntegral (w .&. 0xff)
 {-# NOINLINE generate #-}
+
+fastPBKDF2_SHA1 :: (ByteArrayAccess password, ByteArrayAccess salt, ByteArray out)
+                => Parameters
+                -> password
+                -> salt
+                -> out
+fastPBKDF2_SHA1 params password salt =
+    B.allocAndFreeze (outputLength params) $ \outPtr ->
+    B.withByteArray password $ \passPtr ->
+    B.withByteArray salt $ \saltPtr ->
+        c_cryptonite_fastpbkdf2_hmac_sha1
+            passPtr (fromIntegral $ B.length password)
+            saltPtr (fromIntegral $ B.length salt)
+            (fromIntegral $ iterCounts params)
+            outPtr (fromIntegral $ outputLength params)
+
+fastPBKDF2_SHA256 :: (ByteArrayAccess password, ByteArrayAccess salt, ByteArray out)
+                  => Parameters
+                  -> password
+                  -> salt
+                  -> out
+fastPBKDF2_SHA256 params password salt =
+    B.allocAndFreeze (outputLength params) $ \outPtr ->
+    B.withByteArray password $ \passPtr ->
+    B.withByteArray salt $ \saltPtr ->
+        c_cryptonite_fastpbkdf2_hmac_sha256
+            passPtr (fromIntegral $ B.length password)
+            saltPtr (fromIntegral $ B.length salt)
+            (fromIntegral $ iterCounts params)
+            outPtr (fromIntegral $ outputLength params)
+
+fastPBKDF2_SHA512 :: (ByteArrayAccess password, ByteArrayAccess salt, ByteArray out)
+                  => Parameters
+                  -> password
+                  -> salt
+                  -> out
+fastPBKDF2_SHA512 params password salt =
+    B.allocAndFreeze (outputLength params) $ \outPtr ->
+    B.withByteArray password $ \passPtr ->
+    B.withByteArray salt $ \saltPtr ->
+        c_cryptonite_fastpbkdf2_hmac_sha512
+            passPtr (fromIntegral $ B.length password)
+            saltPtr (fromIntegral $ B.length salt)
+            (fromIntegral $ iterCounts params)
+            outPtr (fromIntegral $ outputLength params)
+
+
+foreign import ccall unsafe "cryptonite_pbkdf2.h cryptonite_fastpbkdf2_hmac_sha1"
+    c_cryptonite_fastpbkdf2_hmac_sha1 :: Ptr Word8 -> CSize
+                                      -> Ptr Word8 -> CSize
+                                      -> CUInt
+                                      -> Ptr Word8 -> CSize
+                                      -> IO ()
+
+foreign import ccall unsafe "cryptonite_pbkdf2.h cryptonite_fastpbkdf2_hmac_sha256"
+    c_cryptonite_fastpbkdf2_hmac_sha256 :: Ptr Word8 -> CSize
+                                        -> Ptr Word8 -> CSize
+                                        -> CUInt
+                                        -> Ptr Word8 -> CSize
+                                        -> IO ()
+
+foreign import ccall unsafe "cryptonite_pbkdf2.h cryptonite_fastpbkdf2_hmac_sha512"
+    c_cryptonite_fastpbkdf2_hmac_sha512 :: Ptr Word8 -> CSize
+                                        -> Ptr Word8 -> CSize
+                                        -> CUInt
+                                        -> Ptr Word8 -> CSize
+                                        -> IO ()

Crypto/KDF/Scrypt.hs

@@ -53,7 +53,7 @@ generate params password salt
         let b = PBKDF2.generate prf (PBKDF2.Parameters 1 intLen) password salt :: B.Bytes
         newSalt <- B.copy b $ \bPtr ->
             allocaBytesAligned (128*(fromIntegral $ n params)*(r params)) 8 $ \v ->
-            allocaBytesAligned (256*r params) 8 $ \xy -> do
+            allocaBytesAligned (256*r params + 64) 8 $ \xy -> do
                 forM_ [0..(p params-1)] $ \i ->
                     ccryptonite_scrypt_smix (bPtr `plusPtr` (i * 128 * (r params)))
                                             (fromIntegral $ r params) (n params) v xy

Crypto/MAC/CMAC.hs

@@ -0,0 +1,132 @@
+-- |
+-- Module      : Crypto.MAC.CMAC
+-- License     : BSD-style
+-- Maintainer  : Kei Hibino <ex8k.hibino@gmail.com>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Provide the CMAC (Cipher based Message Authentification Code) base algorithm.
+-- <http://en.wikipedia.org/wiki/CMAC>
+-- <http://csrc.nist.gov/publications/nistpubs/800-38B/SP_800-38B.pdf>
+--
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Crypto.MAC.CMAC
+    ( cmac
+    , CMAC
+    , subKeys
+    ) where
+
+import           Data.Word
+import           Data.Bits (setBit, testBit, shiftL)
+import           Data.List (foldl')
+
+import           Crypto.Cipher.Types
+import           Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray, Bytes)
+import qualified Crypto.Internal.ByteArray as B
+
+-- | Authentication code
+newtype CMAC a = CMAC Bytes
+    deriving (ByteArrayAccess)
+
+instance Eq (CMAC a) where
+  CMAC b1 == CMAC b2  =  B.constEq b1 b2
+
+-- | compute a MAC using the supplied cipher
+cmac :: (ByteArrayAccess bin, BlockCipher cipher)
+     => cipher      -- ^ key to compute CMAC with
+     -> bin         -- ^ input message
+     -> CMAC cipher -- ^ output tag
+cmac k msg =
+    CMAC $ foldl' (\c m -> ecbEncrypt k $ bxor c m) zeroV ms
+  where
+    bytes = blockSize k
+    zeroV = B.replicate bytes 0 :: Bytes
+    (k1, k2) = subKeys k
+    ms = cmacChunks k k1 k2 $ B.convert msg
+
+cmacChunks :: (BlockCipher k, ByteArray ba) => k -> ba -> ba -> ba -> [ba]
+cmacChunks k k1 k2  =  rec'  where
+    rec' msg
+      | B.null tl  =  if lack == 0
+                      then  [bxor k1 hd]
+                      else  [bxor k2 $ hd `B.append` B.pack (0x80 : replicate (lack - 1) 0)]
+      | otherwise  =        hd : rec' tl
+      where
+          bytes = blockSize k
+          (hd, tl) = B.splitAt bytes msg
+          lack = bytes - B.length hd
+
+-- | make sub-keys used in CMAC
+subKeys :: (BlockCipher k, ByteArray ba)
+        => k         -- ^ key to compute CMAC with
+        -> (ba, ba)  -- ^ sub-keys to compute CMAC
+subKeys k = (k1, k2)   where
+    ipt = cipherIPT k
+    k0 = ecbEncrypt k $ B.replicate (blockSize k) 0
+    k1 = subKey ipt k0
+    k2 = subKey ipt k1
+
+-- polynomial multiply operation to culculate subkey
+subKey :: (ByteArray ba) => [Word8] -> ba -> ba
+subKey ipt ws  =  case B.unpack ws of
+    []                  ->  B.empty
+    w:_  | testBit w 7  ->  B.pack ipt `bxor` shiftL1 ws
+         | otherwise    ->  shiftL1 ws
+
+shiftL1 :: (ByteArray ba) => ba -> ba
+shiftL1 = B.pack . shiftL1W . B.unpack
+
+shiftL1W :: [Word8] -> [Word8]
+shiftL1W []         =  []
+shiftL1W ws@(_:ns)  =  rec' $ zip ws (ns ++ [0])   where
+    rec'  []         =  []
+    rec' ((x,y):ps)  =  w : rec' ps
+      where
+          w | testBit y 7  =  setBit sl1 0
+            | otherwise    =  sl1
+            where     sl1 = shiftL x 1
+
+bxor :: ByteArray ba => ba -> ba -> ba
+bxor = B.xor
+
+
+-----
+
+
+cipherIPT :: BlockCipher k => k -> [Word8]
+cipherIPT = expandIPT . blockSize
+
+-- Data type which represents the smallest irreducibule binary polynomial
+-- against specified degree.
+--
+-- Maximum degree bit and degree 0 bit are omitted.
+-- For example, The value /Q 7 2 1/ corresponds to the degree /128/.
+-- It represents that the smallest irreducible binary polynomial of degree 128
+-- is x^128 + x^7 + x^2 + x^1 + 1.
+data IPolynomial
+  = Q Int Int Int
+---  | T Int
+
+iPolynomial :: Int -> Maybe IPolynomial
+iPolynomial = d  where
+    d   64  =  Just $ Q 4 3 1
+    d  128  =  Just $ Q 7 2 1
+    d    _  =  Nothing
+
+-- Expand a tail bit pattern of irreducible binary polynomial
+expandIPT :: Int -> [Word8]
+expandIPT bytes = expandIPT' bytes ipt  where
+    ipt = maybe (error $ "Irreducible binary polynomial not defined against " ++ show nb ++ " bit") id
+          $ iPolynomial nb
+    nb = bytes * 8
+
+-- Expand a tail bit pattern of irreducible binary polynomial
+expandIPT' :: Int         -- ^ width in byte
+           -> IPolynomial -- ^ irreducible binary polynomial definition
+           -> [Word8]     -- ^ result bit pattern
+expandIPT' bytes (Q x y z) =
+    reverse . setB x . setB y . setB z . setB 0 $ replicate bytes 0
+  where
+    setB i ws =  hd ++ setBit (head tl) r : tail tl  where
+        (q, r) = i `quotRem` 8
+        (hd, tl) = splitAt q ws

Crypto/MAC/HMAC.hs

@@ -5,15 +5,16 @@
 -- Stability   : experimental
 -- Portability : unknown
 --
--- provide the HMAC (Hash based Message Authentification Code) base algorithm.
+-- Provide the HMAC (Hash based Message Authentification Code) base algorithm.
 -- <http://en.wikipedia.org/wiki/HMAC>
 --
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Crypto.MAC.HMAC
     ( hmac
+    , hmacLazy
     , HMAC(..)
-    -- * incremental
+    -- * Incremental
     , Context(..)
     , initialize
     , update
@@ -24,28 +25,36 @@ module Crypto.MAC.HMAC
 import           Crypto.Hash hiding (Context)
 import qualified Crypto.Hash as Hash (Context)
 import           Crypto.Hash.IO
-import           Crypto.Internal.ByteArray (ScrubbedBytes, ByteArray, ByteArrayAccess)
+import           Crypto.Internal.ByteArray (ScrubbedBytes, ByteArrayAccess)
 import qualified Crypto.Internal.ByteArray as B
 import           Data.Memory.PtrMethods
 import           Crypto.Internal.Compat
-import           Crypto.Internal.Imports
+import qualified Data.ByteString.Lazy as L
 
 -- | Represent an HMAC that is a phantom type with the hash used to produce the mac.
 --
--- The Eq instance is constant time.
+-- The Eq instance is constant time.  No Show instance is provided, to avoid
+-- printing by mistake.
 newtype HMAC a = HMAC { hmacGetDigest :: Digest a }
     deriving (ByteArrayAccess)
 
 instance Eq (HMAC a) where
     (HMAC b1) == (HMAC b2) = B.constEq b1 b2
 
--- | compute a MAC using the supplied hashing function
-hmac :: (ByteArrayAccess key, ByteArray message, HashAlgorithm a)
+-- | Compute a MAC using the supplied hashing function
+hmac :: (ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a)
      => key     -- ^ Secret key
      -> message -- ^ Message to MAC
      -> HMAC a
 hmac secret msg = finalize $ updates (initialize secret) [msg]
 
+-- | Compute a MAC using the supplied hashing function, for a lazy input
+hmacLazy :: (ByteArrayAccess key, HashAlgorithm a)
+     => key     -- ^ Secret key
+     -> L.ByteString -- ^ Message to MAC
+     -> HMAC a
+hmacLazy secret msg = finalize $ updates (initialize secret) (L.toChunks msg)
+
 -- | Represent an ongoing HMAC state, that can be appended with 'update'
 -- and finalize to an HMAC with 'hmacFinalize'
 data Context hashalg = Context !(Hash.Context hashalg) !(Hash.Context hashalg)

Crypto/MAC/KMAC.hs

@@ -0,0 +1,144 @@
+-- |
+-- Module      : Crypto.MAC.KMAC
+-- License     : BSD-style
+-- Maintainer  : Olivier Chéron <olivier.cheron@gmail.com>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Provide the KMAC (Keccak Message Authentication Code) algorithm, derived from
+-- the SHA-3 base algorithm Keccak and defined in NIST SP800-185.
+--
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Crypto.MAC.KMAC
+    ( HashSHAKE
+    , kmac
+    , KMAC(..)
+    -- * Incremental
+    , Context
+    , initialize
+    , update
+    , updates
+    , finalize
+    ) where
+
+import qualified Crypto.Hash as H
+import           Crypto.Hash.SHAKE (HashSHAKE(..))
+import           Crypto.Hash.Types (HashAlgorithm(..), Digest(..))
+import qualified Crypto.Hash.Types as H
+import           Crypto.Internal.Builder
+import           Crypto.Internal.Imports
+import           Foreign.Ptr (Ptr)
+import           Data.Bits (shiftR)
+import           Data.ByteArray (ByteArrayAccess)
+import qualified Data.ByteArray as B
+
+
+-- cSHAKE
+
+cshakeInit :: forall a name string prefix . (HashSHAKE a, ByteArrayAccess name, ByteArrayAccess string, ByteArrayAccess prefix)
+           => name -> string -> prefix -> H.Context a
+cshakeInit n s p = H.Context $ B.allocAndFreeze c $ \(ptr :: Ptr (H.Context a)) -> do
+    hashInternalInit ptr
+    B.withByteArray b $ \d -> hashInternalUpdate ptr d (fromIntegral $ B.length b)
+    B.withByteArray p $ \d -> hashInternalUpdate ptr d (fromIntegral $ B.length p)
+  where
+    c = hashInternalContextSize (undefined :: a)
+    w = hashBlockSize (undefined :: a)
+    x = encodeString n <> encodeString s
+    b = buildAndFreeze (bytepad x w) :: B.Bytes
+
+cshakeUpdate :: (HashSHAKE a, ByteArrayAccess ba)
+             => H.Context a -> ba -> H.Context a
+cshakeUpdate = H.hashUpdate
+
+cshakeUpdates :: (HashSHAKE a, ByteArrayAccess ba)
+              => H.Context a -> [ba] -> H.Context a
+cshakeUpdates = H.hashUpdates
+
+cshakeFinalize :: forall a suffix . (HashSHAKE a, ByteArrayAccess suffix)
+               => H.Context a -> suffix -> Digest a
+cshakeFinalize !c s =
+    Digest $ B.allocAndFreeze (hashDigestSize (undefined :: a)) $ \dig -> do
+        ((!_) :: B.Bytes) <- B.copy c $ \(ctx :: Ptr (H.Context a)) -> do
+            B.withByteArray s $ \d ->
+                hashInternalUpdate ctx d (fromIntegral $ B.length s)
+            cshakeInternalFinalize ctx dig
+        return ()
+
+
+-- KMAC
+
+-- | Represent a KMAC that is a phantom type with the hash used to produce the
+-- mac.
+--
+-- The Eq instance is constant time.  No Show instance is provided, to avoid
+-- printing by mistake.
+newtype KMAC a = KMAC { kmacGetDigest :: Digest a }
+    deriving (ByteArrayAccess,NFData)
+
+instance Eq (KMAC a) where
+    (KMAC b1) == (KMAC b2) = B.constEq b1 b2
+
+-- | Compute a KMAC using the supplied customization string and key.
+kmac :: (HashSHAKE a, ByteArrayAccess string, ByteArrayAccess key, ByteArrayAccess ba)
+     => string -> key -> ba -> KMAC a
+kmac str key msg = finalize $ updates (initialize str key) [msg]
+
+-- | Represent an ongoing KMAC state, that can be appended with 'update' and
+-- finalized to a 'KMAC' with 'finalize'.
+newtype Context a = Context (H.Context a)
+
+-- | Initialize a new incremental KMAC context with the supplied customization
+-- string and key.
+initialize :: forall a string key . (HashSHAKE a, ByteArrayAccess string, ByteArrayAccess key)
+           => string -> key -> Context a
+initialize str key = Context $ cshakeInit n str p
+  where
+    n = B.pack [75,77,65,67] :: B.Bytes  -- "KMAC"
+    w = hashBlockSize (undefined :: a)
+    p = buildAndFreeze (bytepad (encodeString key) w) :: B.ScrubbedBytes
+
+-- | Incrementally update a KMAC context.
+update :: (HashSHAKE a, ByteArrayAccess ba) => Context a -> ba -> Context a
+update (Context ctx) = Context . cshakeUpdate ctx
+
+-- | Incrementally update a KMAC context with multiple inputs.
+updates :: (HashSHAKE a, ByteArrayAccess ba) => Context a -> [ba] -> Context a
+updates (Context ctx) = Context . cshakeUpdates ctx
+
+-- | Finalize a KMAC context and return the KMAC.
+finalize :: forall a . HashSHAKE a => Context a -> KMAC a
+finalize (Context ctx) = KMAC $ cshakeFinalize ctx suffix
+  where
+    l = cshakeOutputLength (undefined :: a)
+    suffix = buildAndFreeze (rightEncode l) :: B.Bytes
+
+
+-- Utilities
+
+bytepad :: Builder -> Int -> Builder
+bytepad x w = prefix <> x <> zero padLen
+  where
+    prefix = leftEncode w
+    padLen = (w - builderLength prefix - builderLength x) `mod` w
+
+encodeString :: ByteArrayAccess bin => bin -> Builder
+encodeString s = leftEncode (8 * B.length s) <> bytes s
+
+leftEncode :: Int -> Builder
+leftEncode x = byte len <> digits
+  where
+    digits = i2osp x
+    len    = fromIntegral (builderLength digits)
+
+rightEncode :: Int -> Builder
+rightEncode x = digits <> byte len
+  where
+    digits = i2osp x
+    len    = fromIntegral (builderLength digits)
+
+i2osp :: Int -> Builder
+i2osp i | i >= 256  = i2osp (shiftR i 8) <> byte (fromIntegral i)
+        | otherwise = byte (fromIntegral i)

Crypto/MAC/Poly1305.hs

@@ -14,7 +14,7 @@ module Crypto.MAC.Poly1305
     ( Ctx
     , State
     , Auth(..)
-
+    , authTag
     -- * Incremental MAC Functions
     , initialize -- :: State
     , update     -- :: State -> ByteString -> State
@@ -33,9 +33,15 @@ import           Crypto.Internal.DeepSeq
 import           Crypto.Error
 
 -- | Poly1305 State
+--
+-- This type is an instance of 'ByteArrayAccess' for debugging purpose. Internal
+-- layout is architecture dependent, may contain uninitialized data fragments,
+-- and change in future versions.  The bytearray should not be used as input to
+-- cryptographic algorithms.
 newtype State = State ScrubbedBytes
     deriving (ByteArrayAccess)
 
+-- | Poly1305 State. use State instead of Ctx
 type Ctx = State
 {-# DEPRECATED Ctx "use Poly1305 State instead" #-}
 
@@ -43,6 +49,11 @@ type Ctx = State
 newtype Auth = Auth Bytes
     deriving (ByteArrayAccess,NFData)
 
+authTag :: ByteArrayAccess b => b -> CryptoFailable Auth
+authTag b
+    | B.length b /= 16 = CryptoFailed $ CryptoError_AuthenticationTagSizeInvalid
+    | otherwise        = CryptoPassed $ Auth $ B.convert b
+
 instance Eq Auth where
     (Auth a1) == (Auth a2) = B.constEq a1 a2
 

Crypto/Math/Polynomial.hs

@@ -8,7 +8,7 @@
 
 module Crypto.Math.Polynomial
     ( Monomial(..)
-    -- * polynomial operations
+    -- * Polynomial operations
     , Polynomial
     , toList
     , fromList

Crypto/Number/Basic.hs

@@ -13,12 +13,15 @@ module Crypto.Number.Basic
     , log2
     , numBits
     , numBytes
+    , asPowerOf2AndOdd
     ) where
 
+import Data.Bits
+
 import Crypto.Number.Compat
 
--- | sqrti returns two integer (l,b) so that l <= sqrt i <= b
--- the implementation is quite naive, use an approximation for the first number
+-- | @sqrti@ returns two integers @(l,b)@ so that @l <= sqrt i <= b@.
+-- The implementation is quite naive, use an approximation for the first number
 -- and use a dichotomy algorithm to compute the bound relatively efficiently.
 sqrti :: Integer -> (Integer, Integer)
 sqrti i
@@ -49,7 +52,7 @@ sqrti i
                         else iter (lb+d) ub
             sq a = a * a
 
--- | get the extended GCD of two integer using integer divMod
+-- | Get the extended GCD of two integer using integer divMod
 --
 -- gcde 'a' 'b' find (x,y,gcd(a,b)) where ax + by = d
 --
@@ -63,7 +66,7 @@ gcde a b = onGmpUnsupported (gmpGcde a b) $
         let (q, r) = a' `divMod` b' in
         f t (r, sa - (q * sb), ta - (q * tb))
 
--- | check if a list of integer are all even
+-- | Check if a list of integer are all even
 areEven :: [Integer] -> Bool
 areEven = and . map even
 
@@ -98,3 +101,16 @@ numBits n = gmpSizeInBits n `onGmpUnsupported` (if n == 0 then 1 else computeBit
 -- | Compute the number of bytes for an integer
 numBytes :: Integer -> Int
 numBytes n = gmpSizeInBytes n `onGmpUnsupported` ((numBits n + 7) `div` 8)
+
+-- | Express an integer as an odd number and a power of 2
+asPowerOf2AndOdd :: Integer -> (Int, Integer)
+asPowerOf2AndOdd a
+    | a == 0       = (0, 0)
+    | odd a        = (0, a)
+    | a < 0        = let (e, a1) = asPowerOf2AndOdd $ abs a in (e, -a1)
+    | isPowerOf2 a = (log2 a, 1)
+    | otherwise    = loop a 0
+        where      
+          isPowerOf2 n = (n /= 0) && ((n .&. (n - 1)) == 0)
+          loop n pw = if n `mod` 2 == 0 then loop (n `div` 2) (pw + 1)
+                      else (pw, n)

Crypto/Number/Compat.hs

@@ -22,7 +22,9 @@ module Crypto.Number.Compat
     , gmpSizeInBytes
     , gmpSizeInBits
     , gmpExportInteger
+    , gmpExportIntegerLE
     , gmpImportInteger
+    , gmpImportIntegerLE
     ) where
 
 #ifndef MIN_VERSION_integer_gmp
@@ -70,8 +72,12 @@ gmpLog2 _ = GmpUnsupported
 -- | Compute the power modulus using extra security to remain constant
 -- time wise through GMP
 gmpPowModSecInteger :: Integer -> Integer -> Integer -> GmpSupported Integer
-#if MIN_VERSION_integer_gmp(1,0,0)
-gmpPowModSecInteger b e m = GmpUnsupported
+#if MIN_VERSION_integer_gmp(1,1,0)
+gmpPowModSecInteger _ _ _ = GmpUnsupported
+#elif MIN_VERSION_integer_gmp(1,0,2)
+gmpPowModSecInteger b e m = GmpSupported (powModSecInteger b e m)
+#elif MIN_VERSION_integer_gmp(1,0,0)
+gmpPowModSecInteger _ _ _ = GmpUnsupported
 #elif MIN_VERSION_integer_gmp(0,5,1)
 gmpPowModSecInteger b e m = GmpSupported (powModSecInteger b e m)
 #else
@@ -99,7 +105,9 @@ gmpInverse _ _ = GmpUnsupported
 
 -- | Get the next prime from a specific value through GMP
 gmpNextPrime :: Integer -> GmpSupported Integer
-#if MIN_VERSION_integer_gmp(0,5,1)
+#if MIN_VERSION_integer_gmp(1,1,0)
+gmpNextPrime _ = GmpUnsupported
+#elif MIN_VERSION_integer_gmp(0,5,1)
 gmpNextPrime n = GmpSupported (nextPrimeInteger n)
 #else
 gmpNextPrime _ = GmpUnsupported
@@ -107,7 +115,9 @@ gmpNextPrime _ = GmpUnsupported
 
 -- | Test if a number is prime using Miller Rabin
 gmpTestPrimeMillerRabin :: Int -> Integer -> GmpSupported Bool
-#if MIN_VERSION_integer_gmp(0,5,1)
+#if MIN_VERSION_integer_gmp(1,1,0)
+gmpTestPrimeMillerRabin _ _ = GmpUnsupported
+#elif MIN_VERSION_integer_gmp(0,5,1)
 gmpTestPrimeMillerRabin (I# tries) !n = GmpSupported $
     case testPrimeInteger n tries of
         0# -> False
@@ -116,7 +126,7 @@ gmpTestPrimeMillerRabin (I# tries) !n = GmpSupported $
 gmpTestPrimeMillerRabin _ _ = GmpUnsupported
 #endif
 
--- | Return the size in bytes of a integer
+-- | Return the size in bytes of an integer
 gmpSizeInBytes :: Integer -> GmpSupported Int
 #if MIN_VERSION_integer_gmp(0,5,1)
 gmpSizeInBytes n = GmpSupported (I# (word2Int# (sizeInBaseInteger n 256#)))
@@ -124,6 +134,7 @@ gmpSizeInBytes n = GmpSupported (I# (word2Int# (sizeInBaseInteger n 256#)))
 gmpSizeInBytes _ = GmpUnsupported
 #endif
 
+-- | Return the size in bits of an integer
 gmpSizeInBits :: Integer -> GmpSupported Int
 #if MIN_VERSION_integer_gmp(0,5,1)
 gmpSizeInBits n = GmpSupported (I# (word2Int# (sizeInBaseInteger n 2#)))
@@ -131,7 +142,7 @@ gmpSizeInBits n = GmpSupported (I# (word2Int# (sizeInBaseInteger n 2#)))
 gmpSizeInBits _ = GmpUnsupported
 #endif
 
--- | Export an integer to a memory
+-- | Export an integer to a memory (big-endian)
 gmpExportInteger :: Integer -> Ptr Word8 -> GmpSupported (IO ())
 #if MIN_VERSION_integer_gmp(1,0,0)
 gmpExportInteger n (Ptr addr) = GmpSupported $ do
@@ -145,7 +156,21 @@ gmpExportInteger n (Ptr addr) = GmpSupported $ IO $ \s ->
 gmpExportInteger _ _ = GmpUnsupported
 #endif
 
--- | Import an integer from a memory
+-- | Export an integer to a memory (little-endian)
+gmpExportIntegerLE :: Integer -> Ptr Word8 -> GmpSupported (IO ())
+#if MIN_VERSION_integer_gmp(1,0,0)
+gmpExportIntegerLE n (Ptr addr) = GmpSupported $ do
+    _ <- exportIntegerToAddr n addr 0#
+    return ()
+#elif MIN_VERSION_integer_gmp(0,5,1)
+gmpExportIntegerLE n (Ptr addr) = GmpSupported $ IO $ \s ->
+    case exportIntegerToAddr n addr 0# s of
+        (# s2, _ #) -> (# s2, () #)
+#else
+gmpExportIntegerLE _ _ = GmpUnsupported
+#endif
+
+-- | Import an integer from a memory (big-endian)
 gmpImportInteger :: Int -> Ptr Word8 -> GmpSupported (IO Integer)
 #if MIN_VERSION_integer_gmp(1,0,0)
 gmpImportInteger (I# n) (Ptr addr) = GmpSupported $
@@ -156,3 +181,15 @@ gmpImportInteger (I# n) (Ptr addr) = GmpSupported $ IO $ \s ->
 #else
 gmpImportInteger _ _ = GmpUnsupported
 #endif
+
+-- | Import an integer from a memory (little-endian)
+gmpImportIntegerLE :: Int -> Ptr Word8 -> GmpSupported (IO Integer)
+#if MIN_VERSION_integer_gmp(1,0,0)
+gmpImportIntegerLE (I# n) (Ptr addr) = GmpSupported $
+    importIntegerFromAddr addr (int2Word# n) 0#
+#elif MIN_VERSION_integer_gmp(0,5,1)
+gmpImportIntegerLE (I# n) (Ptr addr) = GmpSupported $ IO $ \s ->
+    importIntegerFromAddr addr (int2Word# n) 0# s
+#else
+gmpImportIntegerLE _ _ = GmpUnsupported
+#endif

Crypto/Number/F2m.hs

@@ -9,100 +9,161 @@
 -- not optimal and it doesn't provide protection against timing
 -- attacks. The 'm' parameter is implicitly derived from the irreducible
 -- polynomial where applicable.
+
 module Crypto.Number.F2m
     ( BinaryPolynomial
     , addF2m
     , mulF2m
+    , squareF2m'
     , squareF2m
+    , powF2m
     , modF2m
+    , sqrtF2m
     , invF2m
     , divF2m
     ) where
 
-import Data.Bits ((.&.),(.|.),xor,shift,testBit)
+import Data.Bits (xor, shift, testBit, setBit)
+import Data.List
 import Crypto.Number.Basic
-import Crypto.Internal.Imports
 
 -- | Binary Polynomial represented by an integer
 type BinaryPolynomial = Integer
 
--- | Addition over F₂m. This is just a synonym of  'xor'.
-addF2m :: Integer -> Integer -> Integer
+-- | Addition over F₂m. This is just a synonym of 'xor'.
+addF2m :: Integer
+       -> Integer
+       -> Integer
 addF2m = xor
 {-# INLINE addF2m #-}
 
--- | Binary polynomial reduction modulo using long division algorithm.
-modF2m :: BinaryPolynomial -- ^ Irreducible binary polynomial
-       -> Integer -> Integer
-modF2m fx = go
-  where
-    lfx = log2 fx
-    go n | s == 0  = n `xor` fx
-         | s < 0 = n
-         | otherwise = go $ n `xor` shift fx s
+-- | Reduction by modulo over F₂m.
+--
+-- This function is undefined for negative arguments, because their bit
+-- representation is platform-dependent. Zero modulus is also prohibited.
+modF2m :: BinaryPolynomial -- ^ Modulus
+       -> Integer
+       -> Integer
+modF2m fx i
+    | fx < 0 || i < 0 = error "modF2m: negative number represent no binary polynomial"
+    | fx == 0         = error "modF2m: cannot divide by zero polynomial"
+    | fx == 1         = 0
+    | otherwise       = go i
       where
-        s = log2 n - lfx
+        lfx = log2 fx
+        go n | s == 0    = n `addF2m` fx
+             | s < 0     = n
+             | otherwise = go $ n `addF2m` shift fx s
+                where s = log2 n - lfx
 {-# INLINE modF2m #-}
 
 -- | Multiplication over F₂m.
 --
---     n1 * n2 (in F(2^m))
-mulF2m :: BinaryPolynomial  -- ^ Irreducible binary polynomial
-       -> Integer -> Integer -> Integer
-mulF2m fx n1 n2 = modF2m fx
-                $ go (if n2 `mod` 2 == 1 then n1 else 0) (log2 n2)
-  where
-    go n s | s == 0  = n
-           | otherwise = if testBit n2 s
-                            then go (n `xor` shift n1 s) (s - 1)
-                            else go n (s - 1)
+-- This function is undefined for negative arguments, because their bit
+-- representation is platform-dependent. Zero modulus is also prohibited.
+mulF2m :: BinaryPolynomial -- ^ Modulus
+       -> Integer
+       -> Integer
+       -> Integer
+mulF2m fx n1 n2
+    |    fx < 0
+      || n1 < 0
+      || n2 < 0 = error "mulF2m: negative number represent no binary polynomial"
+    | fx == 0   = error "mulF2m: cannot multiply modulo zero polynomial"
+    | otherwise = modF2m fx $ go (if n2 `mod` 2 == 1 then n1 else 0) (log2 n2)
+      where
+        go n s | s == 0  = n
+               | otherwise = if testBit n2 s
+                                then go (n `addF2m` shift n1 s) (s - 1)
+                                else go n (s - 1)
 {-# INLINABLE mulF2m #-}
 
 -- | Squaring over F₂m.
--- TODO: This is still slower than @mulF2m@.
-
--- Multiplication table? C?
-squareF2m :: BinaryPolynomial  -- ^ Irreducible binary polynomial
-          -> Integer -> Integer
-squareF2m fx = modF2m fx . square
+--
+-- This function is undefined for negative arguments, because their bit
+-- representation is platform-dependent. Zero modulus is also prohibited.
+squareF2m :: BinaryPolynomial -- ^ Modulus
+          -> Integer
+          -> Integer
+squareF2m fx = modF2m fx . squareF2m'
 {-# INLINE squareF2m #-}
 
-square :: Integer -> Integer
-square n1 = go n1 ln1
-  where
-    ln1 = log2 n1
-    go n s | s == 0 = n
-           | otherwise = go (x .|. y) (s - 1)
-      where
-        x = shift (shift n (2 * (s - ln1) - 1)) (2 * (ln1 - s) + 2)
-        y = n .&. (shift 1 (2 * (ln1 - s) + 1) - 1)
-{-# INLINE square #-}
-
--- | Inversion of @n over F₂m using extended Euclidean algorithm.
+-- | Squaring over F₂m without reduction by modulo.
 --
--- If @n doesn't have an inverse, Nothing is returned.
-invF2m :: BinaryPolynomial -- ^ Irreducible binary polynomial
-       -> Integer -> Maybe Integer
-invF2m _  0 = Nothing
-invF2m fx n
-    | n >= fx   = Nothing
-    | otherwise = go n fx 1 0
-    where
-      go u v g1 g2
-          | u == 1    = Just $ modF2m fx g1
-          | j < 0     = go u  (v  `xor` shift  u (-j)) g1 (g2 `xor` shift g1 (-j))
-          | otherwise = go (u  `xor` shift v  j) v (g1 `xor` shift g2 j) g2
-        where
-          j = log2 u - log2 v
+-- The implementation utilizes the fact that for binary polynomial S(x) we have
+-- S(x)^2 = S(x^2). In other words, insert a zero bit between every bits of argument: 1101 -> 1010001.
+--
+-- This function is undefined for negative arguments, because their bit
+-- representation is platform-dependent.
+squareF2m' :: Integer
+           -> Integer
+squareF2m' n
+    | n < 0     = error "mulF2m: negative number represent no binary polynomial"
+    | otherwise = foldl' (\acc s -> if testBit n s then setBit acc (2 * s) else acc) 0 [0 .. log2 n]
+{-# INLINE squareF2m' #-}
+
+-- | Exponentiation in F₂m by computing @a^b mod fx@.
+--
+-- This implements an exponentiation by squaring based solution. It inherits the
+-- same restrictions as 'squareF2m'. Negative exponents are disallowed.
+powF2m :: BinaryPolynomial -- ^Modulus
+       -> Integer          -- ^a
+       -> Integer          -- ^b
+       -> Integer
+powF2m fx a b
+  | b < 0     = error "powF2m: negative exponents disallowed"
+  | b == 0    = if fx > 1 then 1 else 0
+  | even b    = squareF2m fx x
+  | otherwise = mulF2m fx a (squareF2m' x)
+  where x = powF2m fx a (b `div` 2)
+
+-- | Square rooot in F₂m.
+--
+-- We exploit the fact that @a^(2^m) = a@, or in particular, @a^(2^m - 1) = 1@
+-- from a classical result by Lagrange. Thus the square root is simply @a^(2^(m
+-- - 1))@.
+sqrtF2m :: BinaryPolynomial -- ^Modulus
+        -> Integer          -- ^a
+        -> Integer
+sqrtF2m fx a = go (log2 fx - 1) a
+  where go 0 x = x
+        go n x = go (n - 1) (squareF2m fx x)
+
+-- | Extended GCD algorithm for polynomials. For @a@ and @b@ returns @(g, u, v)@ such that @a * u + b * v == g@.
+--
+-- Reference: https://en.wikipedia.org/wiki/Polynomial_greatest_common_divisor#B.C3.A9zout.27s_identity_and_extended_GCD_algorithm
+gcdF2m :: Integer
+       -> Integer
+       -> (Integer, Integer, Integer)
+gcdF2m a b = go (a, b, 1, 0, 0, 1)
+  where
+    go (g, 0, u, _, v, _)
+        = (g, u, v)
+    go (r0, r1, s0, s1, t0, t1)
+        = go (r1, r0 `addF2m` shift r1 j, s1, s0 `addF2m` shift s1 j, t1, t0 `addF2m` shift t1 j)
+            where j = max 0 (log2 r0 - log2 r1)
+
+-- | Modular inversion over F₂m.
+-- If @n@ doesn't have an inverse, 'Nothing' is returned.
+--
+-- This function is undefined for negative arguments, because their bit
+-- representation is platform-dependent. Zero modulus is also prohibited.
+invF2m :: BinaryPolynomial -- ^ Modulus
+       -> Integer
+       -> Maybe Integer
+invF2m fx n = if g == 1 then Just (modF2m fx u) else Nothing
+  where
+    (g, u, _) = gcdF2m n fx
 {-# INLINABLE invF2m #-}
 
 -- | Division over F₂m. If the dividend doesn't have an inverse it returns
 -- 'Nothing'.
 --
--- Compute n1 / n2
-divF2m :: BinaryPolynomial  -- ^ Irreducible binary polynomial
-       -> Integer  -- ^ Dividend
-       -> Integer  -- ^ Quotient
-       -> Maybe Integer
+-- This function is undefined for negative arguments, because their bit
+-- representation is platform-dependent. Zero modulus is also prohibited.
+divF2m :: BinaryPolynomial -- ^ Modulus
+       -> Integer          -- ^ Dividend
+       -> Integer          -- ^ Divisor
+       -> Maybe Integer    -- ^ Quotient
 divF2m fx n1 n2 = mulF2m fx n1 <$> invF2m fx n2
 {-# INLINE divF2m #-}

Crypto/Number/Generate.hs

@@ -120,6 +120,4 @@ generateMax range
 
 -- | generate a number between the inclusive bound [low,high].
 generateBetween :: MonadRandom m => Integer -> Integer -> m Integer
-generateBetween low high
-    | low == 1  = generateMax high >>= \r -> if r == 0 then generateBetween low high else return r
-    | otherwise = (low +) <$> generateMax (high - low + 1)
+generateBetween low high = (low +) <$> generateMax (high - low + 1)

Crypto/Number/ModArithmetic.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DeriveDataTypeable #-}
 -- |
 -- Module      : Crypto.Number.ModArithmetic
 -- License     : BSD-style
@@ -9,26 +8,29 @@
 
 module Crypto.Number.ModArithmetic
     (
-    -- * exponentiation
+    -- * Exponentiation
       expSafe
     , expFast
-    -- * inverse computing
+    -- * Inverse computing
     , inverse
     , inverseCoprimes
+    , inverseFermat
+    -- * Squares
+    , jacobi
+    , squareRoot
     ) where
 
 import Control.Exception (throw, Exception)
-import Data.Typeable
 import Crypto.Number.Basic
 import Crypto.Number.Compat
 
 -- | Raised when two numbers are supposed to be coprimes but are not.
 data CoprimesAssertionError = CoprimesAssertionError
-    deriving (Show,Typeable)
+    deriving (Show)
 
 instance Exception CoprimesAssertionError
 
--- | Compute the modular exponentiation of base^exponant using
+-- | Compute the modular exponentiation of base^exponent using
 -- algorithms design to avoid side channels and timing measurement
 --
 -- Modulo need to be odd otherwise the normal fast modular exponentiation
@@ -38,11 +40,10 @@ instance Exception CoprimesAssertionError
 -- from expFast, and thus provide the same unstudied and dubious
 -- timing and side channels claims.
 --
--- with GHC 7.10, the powModSecInteger is missing from integer-gmp
--- (which is now integer-gmp2), so is has the same security as old
--- ghc version.
+-- Before GHC 8.4.2, powModSecInteger is missing from integer-gmp,
+-- so expSafe has the same security as expFast.
 expSafe :: Integer -- ^ base
-        -> Integer -- ^ exponant
+        -> Integer -- ^ exponent
         -> Integer -- ^ modulo
         -> Integer -- ^ result
 expSafe b e m
@@ -52,30 +53,30 @@ expSafe b e m
     | otherwise = gmpPowModInteger b e m    `onGmpUnsupported`
                   exponentiation b e m
 
--- | Compute the modular exponentiation of base^exponant using
+-- | Compute the modular exponentiation of base^exponent using
 -- the fastest algorithm without any consideration for
 -- hiding parameters.
 --
 -- Use this function when all the parameters are public,
--- otherwise 'expSafe' should be prefered.
+-- otherwise 'expSafe' should be preferred.
 expFast :: Integer -- ^ base
-        -> Integer -- ^ exponant
+        -> Integer -- ^ exponent
         -> Integer -- ^ modulo
         -> Integer -- ^ result
 expFast b e m = gmpPowModInteger b e m `onGmpUnsupported` exponentiation b e m
 
--- | exponentiation computes modular exponentiation as b^e mod m
+-- | @exponentiation@ computes modular exponentiation as /b^e mod m/
 -- using repetitive squaring.
 exponentiation :: Integer -> Integer -> Integer -> Integer
 exponentiation b e m
     | b == 1    = b
     | e == 0    = 1
     | e == 1    = b `mod` m
-    | even e    = let p = (exponentiation b (e `div` 2) m) `mod` m
+    | even e    = let p = exponentiation b (e `div` 2) m `mod` m
                    in (p^(2::Integer)) `mod` m
     | otherwise = (b * exponentiation b (e-1) m) `mod` m
 
--- | inverse computes the modular inverse as in g^(-1) mod m
+-- | @inverse@ computes the modular inverse as in /g^(-1) mod m/.
 inverse :: Integer -> Integer -> Maybe Integer
 inverse g m = gmpInverse g m `onGmpUnsupported` v
   where
@@ -84,14 +85,133 @@ inverse g m = gmpInverse g m `onGmpUnsupported` v
         | otherwise = Just (x `mod` m)
     (x,_,d) = gcde g m
 
--- | Compute the modular inverse of 2 coprime numbers.
+-- | Compute the modular inverse of two coprime numbers.
 -- This is equivalent to inverse except that the result
 -- is known to exists.
 --
--- if the numbers are not defined as coprime, this function
--- will raise a CoprimesAssertionError.
+-- If the numbers are not defined as coprime, this function
+-- will raise a 'CoprimesAssertionError'.
 inverseCoprimes :: Integer -> Integer -> Integer
 inverseCoprimes g m =
     case inverse g m of
         Nothing -> throw CoprimesAssertionError
         Just i  -> i
+
+-- | Computes the Jacobi symbol (a/n).
+-- 0 ≤ a < n; n ≥ 3 and odd.
+--
+-- The Legendre and Jacobi symbols are indistinguishable exactly when the
+-- lower argument is an odd prime, in which case they have the same value.
+--
+-- See algorithm 2.149 in "Handbook of Applied Cryptography" by Alfred J. Menezes et al.
+jacobi :: Integer -> Integer -> Maybe Integer
+jacobi a n
+    | n < 3 || even n  = Nothing
+    | a == 0 || a == 1 = Just a
+    | n <= a           = jacobi (a `mod` n) n
+    | a < 0            =
+      let b = if n `mod` 4 == 1 then 1 else -1
+       in fmap (*b) (jacobi (-a) n)
+    | otherwise        =
+      let (e, a1) = asPowerOf2AndOdd a
+          nMod8   = n `mod` 8
+          nMod4   = n `mod` 4
+          a1Mod4  = a1 `mod` 4
+          s'      = if even e || nMod8 == 1 || nMod8 == 7 then 1 else -1
+          s       = if nMod4 == 3 && a1Mod4 == 3 then -s' else s'
+          n1      = n `mod` a1
+       in if a1 == 1 then Just s
+          else fmap (*s) (jacobi n1 a1)
+
+-- | Modular inverse using Fermat's little theorem.  This works only when
+-- the modulus is prime but avoids side channels like in 'expSafe'.
+inverseFermat :: Integer -> Integer -> Integer
+inverseFermat g p = expSafe g (p - 2) p
+
+-- | Raised when the assumption about the modulus is invalid.
+data ModulusAssertionError = ModulusAssertionError
+    deriving (Show)
+
+instance Exception ModulusAssertionError
+
+-- | Modular square root of @g@ modulo a prime @p@.
+--
+-- If the modulus is found not to be prime, the function will raise a
+-- 'ModulusAssertionError'.
+--
+-- This implementation is variable time and should be used with public
+-- parameters only.
+squareRoot :: Integer -> Integer -> Maybe Integer
+squareRoot p
+    | p < 2     = throw ModulusAssertionError
+    | otherwise =
+        case p `divMod` 8 of
+           (v, 3) -> method1 (2 * v + 1)
+           (v, 7) -> method1 (2 * v + 2)
+           (u, 5) -> method2 u
+           (_, 1) -> tonelliShanks p
+           (0, 2) -> \a -> Just (if even a then 0 else 1)
+           _      -> throw ModulusAssertionError
+
+  where
+    x `eqMod` y = (x - y) `mod` p == 0
+
+    validate g y | (y * y) `eqMod` g = Just y
+                 | otherwise         = Nothing
+
+    -- p == 4u + 3 and u' == u + 1
+    method1 u' g =
+        let y = expFast g u' p
+         in validate g y
+
+    -- p == 8u + 5
+    method2 u g =
+        let gamma = expFast (2 * g) u p
+            g_gamma = g * gamma
+            i = (2 * g_gamma * gamma) `mod` p
+            y = (g_gamma * (i - 1)) `mod` p
+         in validate g y
+
+tonelliShanks :: Integer -> Integer -> Maybe Integer
+tonelliShanks p a
+    | aa == 0   = Just 0
+    | otherwise =
+        case expFast aa p2 p of
+            b | b == p1   -> Nothing
+              | b == 1    -> Just $ go (expFast aa ((s + 1) `div` 2) p)
+                                       (expFast aa s p)
+                                       (expFast n  s p)
+                                       e
+              | otherwise -> throw ModulusAssertionError
+  where
+    aa = a `mod` p
+    p1 = p - 1
+    p2 = p1 `div` 2
+    n  = findN 2
+
+    x `mul` y = (x * y) `mod` p
+
+    pow2m 0 x = x
+    pow2m i x = pow2m (i - 1) (x `mul` x)
+
+    (e, s) = asPowerOf2AndOdd p1
+
+    -- find a quadratic non-residue
+    findN i
+        | expFast i p2 p == p1 = i
+        | otherwise            = findN (i + 1)
+
+    -- find m such that b^(2^m) == 1 (mod p)
+    findM b i
+        | b == 1    = i
+        | otherwise = findM (b `mul` b) (i + 1)
+
+    go !x b g !r
+        | b == 1    = x
+        | otherwise =
+            let r' = findM b 0
+                z = pow2m (r - r' - 1) g
+                x' = x `mul` z
+                b' = b `mul` g'
+                g' = z `mul` z
+             in go x' b' g' r'

Crypto/Number/Nat.hs

@@ -0,0 +1,63 @@
+-- |
+-- Module      : Crypto.Number.Nat
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : Good
+--
+-- Numbers at type level.
+--
+-- This module provides extensions to "GHC.TypeLits" and "GHC.TypeNats" useful
+-- to work with cryptographic algorithms parameterized with a variable bit
+-- length.  Constraints like @'IsDivisibleBy8' n@ ensure that the type-level
+-- parameter is applicable to the algorithm.
+--
+-- Functions are also provided to test whether constraints are satisfied from
+-- values known at runtime.  The following example shows how to discharge
+-- 'IsDivisibleBy8' in a computation @fn@ requiring this constraint:
+--
+-- > withDivisibleBy8 :: Integer
+-- >                  -> (forall proxy n . (KnownNat n, IsDivisibleBy8 n) => proxy n -> a)
+-- >                  -> Maybe a
+-- > withDivisibleBy8 len fn = do
+-- >     SomeNat p <- someNatVal len
+-- >     Refl <- isDivisibleBy8 p
+-- >     pure (fn p)
+--
+-- Function @withDivisibleBy8@ above returns 'Nothing' when the argument @len@
+-- is negative or not divisible by 8.
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+module Crypto.Number.Nat
+    ( type IsDivisibleBy8
+    , type IsAtMost, type IsAtLeast
+    , isDivisibleBy8
+    , isAtMost
+    , isAtLeast
+    ) where
+
+import           Data.Type.Equality
+import           GHC.TypeLits
+import           Unsafe.Coerce (unsafeCoerce)
+
+import           Crypto.Internal.Nat
+
+-- | get a runtime proof that the constraint @'IsDivisibleBy8' n@ is satified
+isDivisibleBy8 :: KnownNat n => proxy n -> Maybe (IsDiv8 n n :~: 'True)
+isDivisibleBy8 n
+    | mod (natVal n) 8 == 0 = Just (unsafeCoerce Refl)
+    | otherwise             = Nothing
+
+-- | get a runtime proof that the constraint @'IsAtMost' value bound@ is
+-- satified
+isAtMost :: (KnownNat value, KnownNat bound)
+         => proxy value -> proxy' bound -> Maybe ((value <=? bound) :~: 'True)
+isAtMost x y
+    | natVal x <= natVal y  = Just (unsafeCoerce Refl)
+    | otherwise             = Nothing
+
+-- | get a runtime proof that the constraint @'IsAtLeast' value bound@ is
+-- satified
+isAtLeast :: (KnownNat value, KnownNat bound)
+          => proxy value -> proxy' bound -> Maybe ((bound <=? value) :~: 'True)
+isAtLeast = flip isAtMost

Crypto/Number/Prime.hs

@@ -19,45 +19,67 @@ module Crypto.Number.Prime
     , isCoprime
     ) where
 
-import Crypto.Internal.Imports
-
 import Crypto.Number.Compat
 import Crypto.Number.Generate
 import Crypto.Number.Basic (sqrti, gcde)
 import Crypto.Number.ModArithmetic (expSafe)
 import Crypto.Random.Types
 import Crypto.Random.Probabilistic
+import Crypto.Error
 
 import Data.Bits
 
--- | returns if the number is probably prime.
--- first a list of small primes are implicitely tested for divisibility,
+-- | Returns if the number is probably prime.
+-- First a list of small primes are implicitely tested for divisibility,
 -- then a fermat primality test is used with arbitrary numbers and
--- then the Miller Rabin algorithm is used with an accuracy of 30 recursions
+-- then the Miller Rabin algorithm is used with an accuracy of 30 recursions.
 isProbablyPrime :: Integer -> Bool
 isProbablyPrime !n
     | any (\p -> p `divides` n) (filter (< n) firstPrimes) = False
-    | primalityTestFermat 50 (n`div`2) n                   = primalityTestMillerRabin 30 n
+    | n >= 2 && n <= 2903                                  = True
+    | primalityTestFermat 50 (n `div` 2) n                 = primalityTestMillerRabin 30 n
     | otherwise                                            = False
 
--- | generate a prime number of the required bitsize
+-- | Generate a prime number of the required bitsize (i.e. in the range
+-- [2^(b-1)+2^(b-2), 2^b)).
+--
+-- May throw a 'CryptoError_PrimeSizeInvalid' if the requested size is less
+-- than 5 bits, as the smallest prime meeting these conditions is 29.
+-- This function requires that the two highest bits are set, so that when
+-- multiplied with another prime to create a key, it is guaranteed to be of
+-- the proper size.
 generatePrime :: MonadRandom m => Int -> m Integer
 generatePrime bits = do
-    sp <- generateParams bits (Just SetTwoHighest) True
-    return $ findPrimeFrom sp
+    if bits < 5 then
+        throwCryptoError $ CryptoFailed $ CryptoError_PrimeSizeInvalid
+    else do
+        sp <- generateParams bits (Just SetTwoHighest) True
+        let prime = findPrimeFrom sp
+        if prime < 1 `shiftL` bits then
+            return $ prime
+        else generatePrime bits
 
--- | generate a prime number of the form 2p+1 where p is also prime.
+-- | Generate a prime number of the form 2p+1 where p is also prime.
 -- it is also knowed as a Sophie Germaine prime or safe prime.
 --
 -- The number of safe prime is significantly smaller to the number of prime,
 -- as such it shouldn't be used if this number is supposed to be kept safe.
+--
+-- May throw a 'CryptoError_PrimeSizeInvalid' if the requested size is less than
+-- 6 bits, as the smallest safe prime with the two highest bits set is 59.
 generateSafePrime :: MonadRandom m => Int -> m Integer
 generateSafePrime bits = do
-    sp <- generateParams bits (Just SetTwoHighest) True
-    let p = findPrimeFromWith (\i -> isProbablyPrime (2*i+1)) (sp `div` 2)
-    return (2*p+1)
+    if bits < 6 then
+        throwCryptoError $ CryptoFailed $ CryptoError_PrimeSizeInvalid
+    else do
+        sp <- generateParams bits (Just SetTwoHighest) True
+        let p = findPrimeFromWith (\i -> isProbablyPrime (2*i+1)) (sp `div` 2)
+        let val = 2 * p + 1
+        if val < 1 `shiftL` bits then
+            return $ val
+        else generateSafePrime bits
 
--- | find a prime from a starting point where the property hold.
+-- | Find a prime from a starting point where the property hold.
 findPrimeFromWith :: (Integer -> Bool) -> Integer -> Integer
 findPrimeFromWith prop !n
     | even n        = findPrimeFromWith prop (n+1)
@@ -69,7 +91,7 @@ findPrimeFromWith prop !n
                     then n
                     else findPrimeFromWith prop (n+2)
 
--- | find a prime from a starting point with no specific property.
+-- | Find a prime from a starting point with no specific property.
 findPrimeFrom :: Integer -> Integer
 findPrimeFrom n =
     case gmpNextPrime n of
@@ -105,7 +127,7 @@ primalityTestMillerRabin tries !n =
     factorise :: Integer -> Integer -> (Integer, Integer)
     factorise !si !vi
         | vi `testBit` 0 = (si, vi)
-        | otherwise     = factorise (si+1) (vi `shiftR` 1) -- probably faster to not shift v continously, but just once.
+        | otherwise     = factorise (si+1) (vi `shiftR` 1) -- probably faster to not shift v continuously, but just once.
     expmod = expSafe
 
     -- when iteration reach zero, we have a probable prime
@@ -161,7 +183,7 @@ primalityTestNaive n
 isCoprime :: Integer -> Integer -> Bool
 isCoprime m n = case gcde m n of (_,_,d) -> d == 1
 
--- | list of the first primes till 2903..
+-- | List of the first primes till 2903.
 firstPrimes :: [Integer]
 firstPrimes =
     [ 2    , 3    , 5    , 7    , 11   , 13   , 17   , 19   , 23   , 29

Crypto/Number/Serialize.hs

@@ -5,7 +5,7 @@
 -- Stability   : experimental
 -- Portability : Good
 --
--- fast serialization primitives for integer
+-- Fast serialization primitives for integer
 {-# LANGUAGE BangPatterns #-}
 module Crypto.Number.Serialize
     ( i2osp
@@ -19,22 +19,23 @@ import           Crypto.Internal.Compat (unsafeDoIO)
 import qualified Crypto.Internal.ByteArray as B
 import qualified Crypto.Number.Serialize.Internal as Internal
 
--- | os2ip converts a byte string into a positive integer
+-- | @os2ip@ converts a byte string into a positive integer.
 os2ip :: B.ByteArrayAccess ba => ba -> Integer
 os2ip bs = unsafeDoIO $ B.withByteArray bs (\p -> Internal.os2ip p (B.length bs))
 
--- | i2osp converts a positive integer into a byte string
+-- | @i2osp@ converts a positive integer into a byte string.
 --
--- first byte is MSB (most significant byte), last byte is the LSB (least significant byte)
+-- The first byte is MSB (most significant byte); the last byte is the LSB (least significant byte)
 i2osp :: B.ByteArray ba => Integer -> ba
 i2osp 0 = B.allocAndFreeze 1  (\p -> Internal.i2osp 0 p 1 >> return ())
 i2osp m = B.allocAndFreeze sz (\p -> Internal.i2osp m p sz >> return ())
   where
         !sz = numBytes m
 
--- | just like i2osp, but take an extra parameter for size.
--- if the number is too big to fit in @len bytes, nothing is returned
--- otherwise the number is padded with 0 to fit the @len required.
+-- | Just like 'i2osp', but takes an extra parameter for size.
+-- If the number is too big to fit in @len@ bytes, 'Nothing' is returned
+-- otherwise the number is padded with 0 to fit the @len@ required.
+{-# INLINABLE i2ospOf #-}
 i2ospOf :: B.ByteArray ba => Int -> Integer -> Maybe ba
 i2ospOf len m
     | len <= 0  = Nothing
@@ -44,10 +45,10 @@ i2ospOf len m
   where
         !sz = numBytes m
 
--- | just like i2ospOf except that it doesn't expect a failure: i.e.
--- an integer larger than the number of output bytes requested
+-- | Just like 'i2ospOf' except that it doesn't expect a failure: i.e.
+-- an integer larger than the number of output bytes requested.
 --
--- for example if you just took a modulo of the number that represent
+-- For example if you just took a modulo of the number that represent
 -- the size (example the RSA modulo n).
 i2ospOf_ :: B.ByteArray ba => Int -> Integer -> ba
 i2ospOf_ len = maybe (error "i2ospOf_: integer is larger than expected") id . i2ospOf len

Crypto/Number/Serialize/Internal.hs

@@ -5,7 +5,7 @@
 -- Stability   : experimental
 -- Portability : Good
 --
--- fast serialization primitives for integer using raw pointers
+-- Fast serialization primitives for integer using raw pointers
 {-# LANGUAGE BangPatterns #-}
 module Crypto.Number.Serialize.Internal
     ( i2osp
@@ -21,12 +21,12 @@ import           Data.Word (Word8)
 import           Foreign.Ptr
 import           Foreign.Storable
 
--- | fill a pointer with the big endian binary representation of an integer
+-- | Fill a pointer with the big endian binary representation of an integer
 --
--- if the room available @ptrSz is less than the number of bytes needed,
+-- If the room available @ptrSz@ is less than the number of bytes needed,
 -- 0 is returned. Likewise if a parameter is invalid, 0 is returned.
 --
--- returns the number of bytes written
+-- Returns the number of bytes written
 i2osp :: Integer -> Ptr Word8 -> Int -> IO Int
 i2osp m ptr ptrSz
     | ptrSz <= 0 = return 0
@@ -61,7 +61,7 @@ fillPtr p sz m = gmpExportInteger m p `onGmpUnsupported` export (sz-1) m
             pokeByteOff p ofs (fromIntegral b :: Word8)
             export (ofs-1) i'
 
--- | transform a big endian binary integer representation pointed by a pointer and a size
+-- | Transform a big endian binary integer representation pointed by a pointer and a size
 -- into an integer
 os2ip :: Ptr Word8 -> Int -> IO Integer
 os2ip ptr ptrSz
@@ -69,7 +69,7 @@ os2ip ptr ptrSz
     | otherwise  = gmpImportInteger ptrSz ptr `onGmpUnsupported` loop 0 0 ptr
   where
     loop :: Integer -> Int -> Ptr Word8 -> IO Integer
-    loop !acc i p
+    loop !acc i !p
         | i == ptrSz = return acc
         | otherwise  = do
             w <- peekByteOff p i :: IO Word8

Crypto/Number/Serialize/Internal/LE.hs

@@ -0,0 +1,75 @@
+-- |
+-- Module      : Crypto.Number.Serialize.Internal.LE
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : Good
+--
+-- Fast serialization primitives for integer using raw pointers (little endian)
+{-# LANGUAGE BangPatterns #-}
+module Crypto.Number.Serialize.Internal.LE
+    ( i2osp
+    , i2ospOf
+    , os2ip
+    ) where
+
+import           Crypto.Number.Compat
+import           Crypto.Number.Basic
+import           Data.Bits
+import           Data.Memory.PtrMethods
+import           Data.Word (Word8)
+import           Foreign.Ptr
+import           Foreign.Storable
+
+-- | Fill a pointer with the little endian binary representation of an integer
+--
+-- If the room available @ptrSz@ is less than the number of bytes needed,
+-- 0 is returned. Likewise if a parameter is invalid, 0 is returned.
+--
+-- Returns the number of bytes written
+i2osp :: Integer -> Ptr Word8 -> Int -> IO Int
+i2osp m ptr ptrSz
+    | ptrSz <= 0 = return 0
+    | m < 0      = return 0
+    | m == 0     = pokeByteOff ptr 0 (0 :: Word8) >> return 1
+    | ptrSz < sz = return 0
+    | otherwise  = fillPtr ptr sz m >> return sz
+  where
+    !sz    = numBytes m
+
+-- | Similar to 'i2osp', except it will pad any remaining space with zero.
+i2ospOf :: Integer -> Ptr Word8 -> Int -> IO Int
+i2ospOf m ptr ptrSz
+    | ptrSz <= 0 = return 0
+    | m < 0      = return 0
+    | ptrSz < sz = return 0
+    | otherwise  = do
+        memSet ptr 0 ptrSz
+        fillPtr ptr sz m
+        return ptrSz
+  where
+    !sz    = numBytes m
+
+fillPtr :: Ptr Word8 -> Int -> Integer -> IO ()
+fillPtr p sz m = gmpExportIntegerLE m p `onGmpUnsupported` export 0 m
+  where
+    export ofs i
+        | ofs >= sz = return ()
+        | otherwise = do
+            let (i', b) = i `divMod` 256
+            pokeByteOff p ofs (fromIntegral b :: Word8)
+            export (ofs+1) i'
+
+-- | Transform a little endian binary integer representation pointed by a
+-- pointer and a size into an integer
+os2ip :: Ptr Word8 -> Int -> IO Integer
+os2ip ptr ptrSz
+    | ptrSz <= 0 = return 0
+    | otherwise  = gmpImportIntegerLE ptrSz ptr `onGmpUnsupported` loop 0 (ptrSz-1) ptr
+  where
+    loop :: Integer -> Int -> Ptr Word8 -> IO Integer
+    loop !acc i !p
+        | i < 0      = return acc
+        | otherwise  = do
+            w <- peekByteOff p i :: IO Word8
+            loop ((acc `shiftL` 8) .|. fromIntegral w) (i-1) p

Crypto/Number/Serialize/LE.hs

@@ -0,0 +1,54 @@
+-- |
+-- Module      : Crypto.Number.Serialize.LE
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : Good
+--
+-- Fast serialization primitives for integer (little endian)
+{-# LANGUAGE BangPatterns #-}
+module Crypto.Number.Serialize.LE
+    ( i2osp
+    , os2ip
+    , i2ospOf
+    , i2ospOf_
+    ) where
+
+import           Crypto.Number.Basic
+import           Crypto.Internal.Compat (unsafeDoIO)
+import qualified Crypto.Internal.ByteArray as B
+import qualified Crypto.Number.Serialize.Internal.LE as Internal
+
+-- | @os2ip@ converts a byte string into a positive integer.
+os2ip :: B.ByteArrayAccess ba => ba -> Integer
+os2ip bs = unsafeDoIO $ B.withByteArray bs (\p -> Internal.os2ip p (B.length bs))
+
+-- | @i2osp@ converts a positive integer into a byte string.
+--
+-- The first byte is LSB (least significant byte); the last byte is the MSB (most significant byte)
+i2osp :: B.ByteArray ba => Integer -> ba
+i2osp 0 = B.allocAndFreeze 1  (\p -> Internal.i2osp 0 p 1 >> return ())
+i2osp m = B.allocAndFreeze sz (\p -> Internal.i2osp m p sz >> return ())
+  where
+        !sz = numBytes m
+
+-- | Just like 'i2osp', but takes an extra parameter for size.
+-- If the number is too big to fit in @len@ bytes, 'Nothing' is returned
+-- otherwise the number is padded with 0 to fit the @len@ required.
+{-# INLINABLE i2ospOf #-}
+i2ospOf :: B.ByteArray ba => Int -> Integer -> Maybe ba
+i2ospOf len m
+    | len <= 0  = Nothing
+    | m < 0     = Nothing
+    | sz > len  = Nothing
+    | otherwise = Just $ B.unsafeCreate len (\p -> Internal.i2ospOf m p len >> return ())
+  where
+        !sz = numBytes m
+
+-- | Just like 'i2ospOf' except that it doesn't expect a failure: i.e.
+-- an integer larger than the number of output bytes requested.
+--
+-- For example if you just took a modulo of the number that represent
+-- the size (example the RSA modulo n).
+i2ospOf_ :: B.ByteArray ba => Int -> Integer -> ba
+i2ospOf_ len = maybe (error "i2ospOf_: integer is larger than expected") id . i2ospOf len

Crypto/OTP.hs

@@ -0,0 +1,178 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | One-time password implementation as defined by the
+-- <http://tools.ietf.org/html/rfc4226 HOTP> and <http://tools.ietf.org/html/rfc6238 TOTP>
+-- specifications.
+--
+-- Both implementations use a shared key between the client and the server. HOTP passwords
+-- are based on a synchronized counter. TOTP passwords use the same approach but calculate
+-- the counter as a number of time steps from the Unix epoch to the current time, thus
+-- requiring that both client and server have synchronized clocks.
+--
+-- Probably the best-known use of TOTP is in Google's 2-factor authentication.
+--
+-- The TOTP API doesn't depend on any particular time package, so the user needs to supply
+-- the current @OTPTime@ value, based on the system time. For example, using the @hourglass@
+-- package, you could create a @getOTPTime@ function:
+--
+-- >>> import Time.System
+-- >>> import Time.Types
+-- >>>
+-- >>> let getOTPTime = timeCurrent >>= \(Elapsed t) -> return (fromIntegral t :: OTPTime)
+--
+-- Or if you prefer, the @time@ package could be used:
+--
+-- >>> import Data.Time.Clock.POSIX
+-- >>>
+-- >>> let getOTPTime = getPOSIXTime >>= \t -> return (floor t :: OTPTime)
+--
+
+module Crypto.OTP
+    ( OTP
+    , OTPDigits (..)
+    , OTPTime
+    , hotp
+    , resynchronize
+    , totp
+    , totpVerify
+    , TOTPParams
+    , ClockSkew (..)
+    , defaultTOTPParams
+    , mkTOTPParams
+    )
+where
+
+import           Data.Bits (shiftL, (.&.), (.|.))
+import           Data.ByteArray.Mapping (fromW64BE)
+import           Data.List (elemIndex)
+import           Data.Word
+import           Control.Monad (unless)
+import           Crypto.Hash (HashAlgorithm, SHA1(..))
+import           Crypto.MAC.HMAC
+import           Crypto.Internal.ByteArray (ByteArrayAccess, Bytes)
+import qualified Crypto.Internal.ByteArray as B
+
+
+-- | A one-time password which is a sequence of 4 to 9 digits.
+type OTP = Word32
+
+-- | The strength of the calculated HOTP value, namely
+-- the number of digits (between 4 and 9) in the extracted value.
+data OTPDigits = OTP4 | OTP5 | OTP6 | OTP7 | OTP8 | OTP9 deriving (Show)
+
+-- | An integral time value in seconds.
+type OTPTime = Word64
+
+hotp :: forall hash key. (HashAlgorithm hash, ByteArrayAccess key)
+    => hash
+    -> OTPDigits
+    -- ^ Number of digits in the HOTP value extracted from the calculated HMAC
+    -> key
+    -- ^ Shared secret between the client and server
+    -> Word64
+    -- ^ Counter value synchronized between the client and server
+    -> OTP
+    -- ^ The HOTP value
+hotp _ d k c = dt `mod` digitsPower d
+  where
+    mac = hmac k (fromW64BE c :: Bytes) :: HMAC hash
+    offset = fromIntegral (B.index mac (B.length mac - 1) .&. 0xf)
+    dt = (fromIntegral (B.index mac offset       .&. 0x7f) `shiftL` 24) .|.
+         (fromIntegral (B.index mac (offset + 1) .&. 0xff) `shiftL` 16) .|.
+         (fromIntegral (B.index mac (offset + 2) .&. 0xff) `shiftL`  8) .|.
+         fromIntegral  (B.index mac (offset + 3) .&. 0xff)
+
+-- | Attempt to resynchronize the server's counter value
+-- with the client, given a sequence of HOTP values.
+resynchronize :: (HashAlgorithm hash, ByteArrayAccess key)
+    => hash
+    -> OTPDigits
+    -> Word16
+    -- ^ The look-ahead window parameter. Up to this many values will
+    -- be calculated and checked against the value(s) submitted by the client
+    -> key
+    -- ^ The shared secret
+    -> Word64
+    -- ^ The current server counter value
+    -> (OTP, [OTP])
+    -- ^ The first OTP submitted by the client and a list of additional
+    -- sequential OTPs (which may be empty)
+    -> Maybe Word64
+    -- ^ The new counter value, synchronized with the client's current counter
+    -- or Nothing if the submitted OTP values didn't match anywhere within the window
+resynchronize h d s k c (p1, extras) = do
+    offBy <- fmap fromIntegral (elemIndex p1 range)
+    checkExtraOtps (c + offBy + 1) extras
+  where
+    checkExtraOtps ctr [] = Just ctr
+    checkExtraOtps ctr (p:ps)
+        | hotp h d k ctr /= p = Nothing
+        | otherwise           = checkExtraOtps (ctr + 1) ps
+
+    range = map (hotp h d k)[c..c + fromIntegral s]
+
+digitsPower :: OTPDigits -> Word32
+digitsPower OTP4 = 10000
+digitsPower OTP5 = 100000
+digitsPower OTP6 = 1000000
+digitsPower OTP7 = 10000000
+digitsPower OTP8 = 100000000
+digitsPower OTP9 = 1000000000
+
+
+data TOTPParams h = TP !h !OTPTime !Word16 !OTPDigits !ClockSkew deriving (Show)
+
+data ClockSkew = NoSkew | OneStep | TwoSteps | ThreeSteps | FourSteps deriving (Enum, Show)
+
+-- | The default TOTP configuration.
+defaultTOTPParams :: TOTPParams SHA1
+defaultTOTPParams = TP SHA1 0 30 OTP6 TwoSteps
+
+-- | Create a TOTP configuration with customized parameters.
+mkTOTPParams :: (HashAlgorithm hash)
+    => hash
+    -> OTPTime
+    -- ^ The T0 parameter in seconds. This is the Unix time from which to start
+    -- counting steps (default 0). Must be before the current time.
+    -> Word16
+    -- ^ The time step parameter X in seconds (default 30, maximum allowed 300)
+    -> OTPDigits
+    -- ^ Number of required digits in the OTP (default 6)
+    -> ClockSkew
+    -- ^ The number of time steps to check either side of the current value
+    -- to allow for clock skew between client and server and or delay in
+    -- submitting the value. The default is two time steps.
+    -> Either String (TOTPParams hash)
+mkTOTPParams h t0 x d skew = do
+    unless (x > 0) (Left "Time step must be greater than zero")
+    unless (x <= 300) (Left "Time step cannot be greater than 300 seconds")
+    return (TP h t0 x d skew)
+
+-- | Calculate a totp value for the given time.
+totp :: (HashAlgorithm hash, ByteArrayAccess key)
+    => TOTPParams hash
+    -> key
+    -- ^ The shared secret
+    -> OTPTime
+    -- ^ The time for which the OTP should be calculated.
+    -- This is usually the current time as returned by @Data.Time.Clock.POSIX.getPOSIXTime@
+    -> OTP
+totp (TP h t0 x d _) k now = hotp h d k (timeToCounter now t0 x)
+
+-- | Check a supplied TOTP value is valid for the given time,
+-- within the window defined by the skew parameter.
+totpVerify :: (HashAlgorithm hash, ByteArrayAccess key)
+    => TOTPParams hash
+    -> key
+    -> OTPTime
+    -> OTP
+    -> Bool
+totpVerify (TP h t0 x d skew) k now otp = otp `elem` map (hotp h d k) (range window [])
+  where
+    t = timeToCounter now t0 x
+    window = fromIntegral (fromEnum skew)
+    range 0 acc = t : acc
+    range n acc = range (n-1) ((t-n) : (t+n) : acc)
+
+timeToCounter :: Word64 -> Word64 -> Word16 -> Word64
+timeToCounter now t0 x = (now - t0) `div` fromIntegral x

Crypto/PubKey/Curve25519.hs

@@ -9,6 +9,7 @@
 --
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MagicHash #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module Crypto.PubKey.Curve25519
     ( SecretKey
     , PublicKey
@@ -17,19 +18,24 @@ module Crypto.PubKey.Curve25519
     , dhSecret
     , publicKey
     , secretKey
-    -- * methods
+    -- * Methods
     , dh
     , toPublic
+    , generateSecretKey
     ) where
 
+import           Data.Bits
 import           Data.Word
 import           Foreign.Ptr
+import           Foreign.Storable
 import           GHC.Ptr
 
+import           Crypto.Error
 import           Crypto.Internal.Compat
 import           Crypto.Internal.Imports
 import           Crypto.Internal.ByteArray (ByteArrayAccess, ScrubbedBytes, Bytes, withByteArray)
 import qualified Crypto.Internal.ByteArray as B
+import           Crypto.Random
 
 -- | A Curve25519 Secret key
 newtype SecretKey = SecretKey ScrubbedBytes
@@ -45,21 +51,21 @@ newtype DhSecret = DhSecret ScrubbedBytes
     deriving (Show,Eq,ByteArrayAccess,NFData)
 
 -- | Try to build a public key from a bytearray
-publicKey :: ByteArrayAccess bs => bs -> Either String PublicKey
+publicKey :: ByteArrayAccess bs => bs -> CryptoFailable PublicKey
 publicKey bs
-    | B.length bs == 32 = Right $ PublicKey $ B.copyAndFreeze bs (\_ -> return ())
-    | otherwise               = Left "invalid public key size"
+    | B.length bs == 32 = CryptoPassed $ PublicKey $ B.copyAndFreeze bs (\_ -> return ())
+    | otherwise         = CryptoFailed CryptoError_PublicKeySizeInvalid
 
 -- | Try to build a secret key from a bytearray
-secretKey :: ByteArrayAccess bs => bs -> Either String SecretKey
+secretKey :: ByteArrayAccess bs => bs -> CryptoFailable SecretKey
 secretKey bs
     | B.length bs == 32 = unsafeDoIO $ do
         withByteArray bs $ \inp -> do
             valid <- isValidPtr inp
             if valid
-                then (Right . SecretKey) <$> B.copy bs (\_ -> return ())
-                else return $ Left "invalid secret key"
-    | otherwise = Left "secret key invalid size"
+                then (CryptoPassed . SecretKey) <$> B.copy bs (\_ -> return ())
+                else return $ CryptoFailed CryptoError_SecretKeyStructureInvalid
+    | otherwise = CryptoFailed CryptoError_SecretKeySizeInvalid
   where
         --  e[0] &= 0xf8;
         --  e[31] &= 0x7f;
@@ -80,12 +86,15 @@ secretKey bs
 {-# NOINLINE secretKey #-}
 
 -- | Create a DhSecret from a bytearray object
-dhSecret :: ByteArrayAccess b => b -> Either String DhSecret
+dhSecret :: ByteArrayAccess b => b -> CryptoFailable DhSecret
 dhSecret bs
-    | B.length bs == 32 = Right $ DhSecret $ B.copyAndFreeze bs (\_ -> return ())
-    | otherwise         = Left "invalid dh secret size"
+    | B.length bs == 32 = CryptoPassed $ DhSecret $ B.copyAndFreeze bs (\_ -> return ())
+    | otherwise         = CryptoFailed CryptoError_SharedSecretSizeInvalid
 
--- | Compute the Diffie Hellman secret from a public key and a secret key
+-- | Compute the Diffie Hellman secret from a public key and a secret key.
+--
+-- This implementation may return an all-zero value as it does not check for
+-- the condition.
 dh :: PublicKey -> SecretKey -> DhSecret
 dh (PublicKey pub) (SecretKey sec) = DhSecret <$>
     B.allocAndFreeze 32        $ \result ->
@@ -104,6 +113,18 @@ toPublic (SecretKey sec) = PublicKey <$>
         basePoint = Ptr "\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#
 {-# NOINLINE toPublic #-}
 
+-- | Generate a secret key.
+generateSecretKey :: MonadRandom m => m SecretKey
+generateSecretKey = tweakToSecretKey <$> getRandomBytes 32
+  where
+    tweakToSecretKey :: ScrubbedBytes -> SecretKey
+    tweakToSecretKey bin = SecretKey $ B.copyAndFreeze bin $ \inp -> do
+        modifyByte inp 0 (\e0 -> e0 .&. 0xf8)
+        modifyByte inp 31 (\e31 -> (e31 .&. 0x7f) .|. 0x40)
+
+    modifyByte :: Ptr Word8 -> Int -> (Word8 -> Word8) -> IO ()
+    modifyByte p n f = peekByteOff p n >>= pokeByteOff p n . f
+
 foreign import ccall "cryptonite_curve25519_donna"
     ccryptonite_curve25519 :: Ptr Word8 -- ^ public
                            -> Ptr Word8 -- ^ secret

Crypto/PubKey/Curve448.hs

@@ -0,0 +1,116 @@
+-- |
+-- Module      : Crypto.PubKey.Curve448
+-- License     : BSD-style
+-- Maintainer  : John Galt <jgalt@centromere.net>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Curve448 support
+--
+-- Internally uses Decaf point compression to omit the cofactor
+-- and implementation by Mike Hamburg.  Externally API and
+-- data types are compatible with the encoding specified in RFC 7748.
+--
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Crypto.PubKey.Curve448
+    ( SecretKey
+    , PublicKey
+    , DhSecret
+    -- * Smart constructors
+    , dhSecret
+    , publicKey
+    , secretKey
+    -- * Methods
+    , dh
+    , toPublic
+    , generateSecretKey
+    ) where
+
+import           Data.Word
+import           Foreign.Ptr
+
+import           Crypto.Error
+import           Crypto.Random
+import           Crypto.Internal.Compat
+import           Crypto.Internal.Imports
+import           Crypto.Internal.ByteArray (ByteArrayAccess, ScrubbedBytes, Bytes, withByteArray)
+import qualified Crypto.Internal.ByteArray as B
+
+-- | A Curve448 Secret key
+newtype SecretKey = SecretKey ScrubbedBytes
+    deriving (Show,Eq,ByteArrayAccess,NFData)
+
+-- | A Curve448 public key
+newtype PublicKey = PublicKey Bytes
+    deriving (Show,Eq,ByteArrayAccess,NFData)
+
+-- | A Curve448 Diffie Hellman secret related to a
+-- public key and a secret key.
+newtype DhSecret = DhSecret ScrubbedBytes
+    deriving (Show,Eq,ByteArrayAccess,NFData)
+
+-- | Try to build a public key from a bytearray
+publicKey :: ByteArrayAccess bs => bs -> CryptoFailable PublicKey
+publicKey bs
+    | B.length bs == x448_bytes = CryptoPassed $ PublicKey $ B.copyAndFreeze bs (\_ -> return ())
+    | otherwise                 = CryptoFailed CryptoError_PublicKeySizeInvalid
+
+-- | Try to build a secret key from a bytearray
+secretKey :: ByteArrayAccess bs => bs -> CryptoFailable SecretKey
+secretKey bs
+    | B.length bs == x448_bytes = unsafeDoIO $
+        withByteArray bs $ \inp -> do
+            valid <- isValidPtr inp
+            if valid
+                then (CryptoPassed . SecretKey) <$> B.copy bs (\_ -> return ())
+                else return $ CryptoFailed CryptoError_SecretKeyStructureInvalid
+    | otherwise = CryptoFailed CryptoError_SecretKeySizeInvalid
+  where
+        isValidPtr :: Ptr Word8 -> IO Bool
+        isValidPtr _ =
+            return True
+{-# NOINLINE secretKey #-}
+
+-- | Create a DhSecret from a bytearray object
+dhSecret :: ByteArrayAccess b => b -> CryptoFailable DhSecret
+dhSecret bs
+    | B.length bs == x448_bytes = CryptoPassed $ DhSecret $ B.copyAndFreeze bs (\_ -> return ())
+    | otherwise                 = CryptoFailed CryptoError_SharedSecretSizeInvalid
+
+-- | Compute the Diffie Hellman secret from a public key and a secret key.
+--
+-- This implementation may return an all-zero value as it does not check for
+-- the condition.
+dh :: PublicKey -> SecretKey -> DhSecret
+dh (PublicKey pub) (SecretKey sec) = DhSecret <$>
+    B.allocAndFreeze x448_bytes $ \result ->
+    withByteArray sec           $ \psec   ->
+    withByteArray pub           $ \ppub   ->
+        decaf_x448 result ppub psec
+{-# NOINLINE dh #-}
+
+-- | Create a public key from a secret key
+toPublic :: SecretKey -> PublicKey
+toPublic (SecretKey sec) = PublicKey <$>
+    B.allocAndFreeze x448_bytes     $ \result ->
+    withByteArray sec               $ \psec   ->
+        decaf_x448_derive_public_key result psec
+{-# NOINLINE toPublic #-}
+
+-- | Generate a secret key.
+generateSecretKey :: MonadRandom m => m SecretKey
+generateSecretKey = SecretKey <$> getRandomBytes x448_bytes
+
+x448_bytes :: Int
+x448_bytes = 448 `quot` 8
+
+foreign import ccall "cryptonite_decaf_x448"
+    decaf_x448 :: Ptr Word8 -- ^ public
+               -> Ptr Word8 -- ^ basepoint
+               -> Ptr Word8 -- ^ secret
+               -> IO ()
+
+foreign import ccall "cryptonite_decaf_x448_derive_public_key"
+    decaf_x448_derive_public_key :: Ptr Word8 -- ^ public
+                                 -> Ptr Word8 -- ^ secret
+                                 -> IO ()

Crypto/PubKey/DH.hs

@@ -23,42 +23,51 @@ import Crypto.Internal.Imports
 import Crypto.Number.ModArithmetic (expSafe)
 import Crypto.Number.Prime (generateSafePrime)
 import Crypto.Number.Generate (generateMax)
+import Crypto.Number.Serialize (i2ospOf_)
 import Crypto.Random.Types
+import Data.ByteArray (ByteArrayAccess, ScrubbedBytes)
 import Data.Data
 
 -- | Represent Diffie Hellman parameters namely P (prime), and G (generator).
 data Params = Params
     { params_p :: Integer
     , params_g :: Integer
-    } deriving (Show,Read,Eq,Data,Typeable)
+    , params_bits :: Int
+    } deriving (Show,Read,Eq,Data)
+
+instance NFData Params where
+    rnf (Params p g bits) = rnf p `seq` rnf g `seq` bits `seq` ()
 
 -- | Represent Diffie Hellman public number Y.
 newtype PublicNumber = PublicNumber Integer
-    deriving (Show,Read,Eq,Enum,Real,Num,Ord)
+    deriving (Show,Read,Eq,Enum,Real,Num,Ord,NFData)
 
 -- | Represent Diffie Hellman private number X.
 newtype PrivateNumber = PrivateNumber Integer
-    deriving (Show,Read,Eq,Enum,Real,Num,Ord)
+    deriving (Show,Read,Eq,Enum,Real,Num,Ord,NFData)
 
 -- | Represent Diffie Hellman shared secret.
-newtype SharedKey = SharedKey Integer
-    deriving (Show,Read,Eq,Enum,Real,Num,Ord)
+newtype SharedKey = SharedKey ScrubbedBytes
+    deriving (Show,Eq,ByteArrayAccess,NFData)
 
 -- | generate params from a specific generator (2 or 5 are common values)
 -- we generate a safe prime (a prime number of the form 2p+1 where p is also prime)
-generateParams :: MonadRandom m => Int -> Integer -> m Params
+generateParams :: MonadRandom m =>
+                  Int                   -- ^ number of bits
+               -> Integer               -- ^ generator
+               -> m Params
 generateParams bits generator =
-    (\p -> Params p generator) <$> generateSafePrime bits
+    (\p -> Params p generator bits) <$> generateSafePrime bits
 
 -- | generate a private number with no specific property
 -- this number is usually called X in DH text.
 generatePrivate :: MonadRandom m => Params -> m PrivateNumber
-generatePrivate (Params p _) = PrivateNumber <$> generateMax p
+generatePrivate (Params p _ _) = PrivateNumber <$> generateMax p
 
 -- | calculate the public number from the parameters and the private key
 -- this number is usually called Y in DH text.
 calculatePublic :: Params -> PrivateNumber -> PublicNumber
-calculatePublic (Params p g) (PrivateNumber x) = PublicNumber $ expSafe g x p
+calculatePublic (Params p g _) (PrivateNumber x) = PublicNumber $ expSafe g x p
 
 -- | calculate the public number from the parameters and the private key
 -- this number is usually called Y in DH text.
@@ -70,4 +79,4 @@ generatePublic = calculatePublic
 
 -- | generate a shared key using our private number and the other party public number
 getShared :: Params -> PrivateNumber -> PublicNumber -> SharedKey
-getShared (Params p _) (PrivateNumber x) (PublicNumber y) = SharedKey $ expSafe y x p
+getShared (Params p _ bits) (PrivateNumber x) (PublicNumber y) = SharedKey $ i2ospOf_ ((bits + 7) `div` 8) $ expSafe y x p

Crypto/PubKey/DSA.hs

@@ -14,13 +14,13 @@ module Crypto.PubKey.DSA
     , PrivateKey(..)
     , PublicNumber
     , PrivateNumber
-    -- * generation
+    -- * Generation
     , generatePrivate
     , calculatePublic
-    -- * signature primitive
+    -- * Signature primitive
     , sign
     , signWith
-    -- * verification primitive
+    -- * Verification primitive
     , verify
     -- * Key pair
     , KeyPair(..)
@@ -28,15 +28,17 @@ module Crypto.PubKey.DSA
     , toPrivateKey
     ) where
 
-import           Crypto.Random.Types
-import           Data.Data
-import           Data.Maybe
-import           Crypto.Number.ModArithmetic (expFast, expSafe, inverse)
-import           Crypto.Number.Serialize
-import           Crypto.Number.Generate
-import           Crypto.Internal.ByteArray (ByteArrayAccess)
-import           Crypto.Internal.Imports
-import           Crypto.Hash
+
+import Data.Data
+import Data.Maybe
+
+import Crypto.Number.ModArithmetic (expFast, expSafe, inverse)
+import Crypto.Number.Generate
+import Crypto.Internal.ByteArray (ByteArrayAccess)
+import Crypto.Internal.Imports
+import Crypto.Hash
+import Crypto.PubKey.Internal (dsaTruncHash)
+import Crypto.Random.Types
 
 -- | DSA Public Number, usually embedded in DSA Public Key
 type PublicNumber = Integer
@@ -49,7 +51,7 @@ data Params = Params
     { params_p :: Integer -- ^ DSA p
     , params_g :: Integer -- ^ DSA g
     , params_q :: Integer -- ^ DSA q
-    } deriving (Show,Read,Eq,Data,Typeable)
+    } deriving (Show,Read,Eq,Data)
 
 instance NFData Params where
     rnf (Params p g q) = p `seq` g `seq` q `seq` ()
@@ -58,7 +60,7 @@ instance NFData Params where
 data Signature = Signature
     { sign_r :: Integer -- ^ DSA r
     , sign_s :: Integer -- ^ DSA s
-    } deriving (Show,Read,Eq,Data,Typeable)
+    } deriving (Show,Read,Eq,Data)
 
 instance NFData Signature where
     rnf (Signature r s) = r `seq` s `seq` ()
@@ -67,7 +69,7 @@ instance NFData Signature where
 data PublicKey = PublicKey
     { public_params :: Params       -- ^ DSA parameters
     , public_y      :: PublicNumber -- ^ DSA public Y
-    } deriving (Show,Read,Eq,Data,Typeable)
+    } deriving (Show,Read,Eq,Data)
 
 instance NFData PublicKey where
     rnf (PublicKey params y) = y `seq` params `seq` ()
@@ -79,14 +81,14 @@ instance NFData PublicKey where
 data PrivateKey = PrivateKey
     { private_params :: Params        -- ^ DSA parameters
     , private_x      :: PrivateNumber -- ^ DSA private X
-    } deriving (Show,Read,Eq,Data,Typeable)
+    } deriving (Show,Read,Eq,Data)
 
 instance NFData PrivateKey where
     rnf (PrivateKey params x) = x `seq` params `seq` ()
 
 -- | Represent a DSA key pair
 data KeyPair = KeyPair Params PublicNumber PrivateNumber
-    deriving (Show,Read,Eq,Data,Typeable)
+    deriving (Show,Read,Eq,Data)
 
 instance NFData KeyPair where
     rnf (KeyPair params y x) = x `seq` y `seq` params `seq` ()
@@ -123,7 +125,7 @@ signWith k pk hashAlg msg
           x              = private_x pk
           -- compute r,s
           kInv      = fromJust $ inverse k q
-          hm        = os2ip $ hashWith hashAlg msg
+          hm        = dsaTruncHash hashAlg msg q
           r         = expSafe g k p `mod` q
           s         = (kInv * (hm + x * r)) `mod` q
 
@@ -145,8 +147,7 @@ verify hashAlg pk (Signature r s) m
     | otherwise                            = v == r
     where (Params p g q) = public_params pk
           y       = public_y pk
-          hm      = os2ip $ hashWith hashAlg m
-
+          hm      = dsaTruncHash hashAlg m q
           w       = fromJust $ inverse s q
           u1      = (hm*w) `mod` q
           u2      = (r*w) `mod` q