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

@@ -12,3 +12,4 @@ benchs/Hash
 *.sublime-workspace
 .cabal-sandbox/
 cabal.sandbox.config
+stack.yaml.lock

.haskell-ci

@@ -1,20 +1,21 @@
 # compiler supported and their equivalent LTS
 compiler: ghc-8.0 lts-9.21
-compiler: ghc-8.2 lts-10.4
+compiler: ghc-8.2 lts-11.22
-compiler: ghc-8.4 ghc-8.4-alpha2
+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: testdeps extradep=QuickCheck-2.11.3 extradep=ansi-terminal-0.8.0.1 extradep=async-2.1.1.1 extradep=call-stack-0.1.0 extradep=clock-0.7.2 extradep=optparse-applicative-0.14.0.0 extradep=random-1.1 extradep=tagged-0.8.5 extradep=unbounded-delays-0.1.1.0 extradep=tasty-1.0.0.1 extradep=tasty-hunit-0.10.0.1 extradep=tasty-kat-0.0.3 extradep=tasty-quickcheck-0.9.2 extradep=ansi-wl-pprint-0.6.8.2 extradep=colour-2.3.4 extradep=tf-random-0.5 extradep=transformers-compat-0.5.1.4 extradep=primitive-0.6.3.0 allow-newer
 option: gaugedeps extradep=gauge-0.2.1
-
+option: basementmin extradep=basement-0.0.8 extradep=memory-0.14.18
-option: basementmin extradep=basement-0.0.6 extradep=foundation-0.0.19 extradep=memory-0.14.14
 
 # builds
-build: ghc-8.2 basementmin gaugedeps
 build: ghc-8.0 basementmin gaugedeps
-build: ghc-8.0 basementmin gaugedeps os=osx
+build: ghc-8.2 basementmin
-build: ghc-8.4 basementmin testdeps gaugedeps extradep=vector-0.12.0.1
+build: ghc-8.4
+build: ghc-8.6 os=linux,osx,windows
+build: ghc-8.8 os=linux,windows
 
 # packages
 package: '.'

.hlint.yaml

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

.travis.yml

@@ -1,7 +1,4 @@
-# ~*~ auto-generated by haskell-ci with config : 26f0e346401960c8aed161c0e7d667cbc8aaeff9264b6ea514e302ae9b0f6a79 ~*~
+# ~*~ auto-generated by haskell-ci with config : 4fdddfa41dd039e198b8d125a70471f7dd140fa01001d99126af56fb31429ece ~*~
-
-# Use new container infrastructure to enable caching
-sudo: false
 
 # Caching so the next build will be fast too.
 cache:
@@ -10,27 +7,32 @@ cache:
   - $HOME/.stack
   - $HOME/.local
 
-matrix:
+language: generic
+os: linux
+
+jobs:
   include:
-  - { env: BUILD=stack RESOLVER=ghc-8.2, compiler: ghc-8.2, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } }
+  - { env: BUILD=stack RESOLVER=ghc-8.0, addons: { apt: { packages: [ libgmp-dev ] } } }
-  - { env: BUILD=stack RESOLVER=ghc-8.0, compiler: ghc-8.0, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } }
+  - { env: BUILD=stack RESOLVER=ghc-8.2, addons: { apt: { packages: [ libgmp-dev ] } } }
-  - { env: BUILD=stack RESOLVER=ghc-8.0, compiler: ghc-8.0, language: generic, addons: { apt: { packages: [ libgmp-dev ] } }, os: osx }
+  - { env: BUILD=stack RESOLVER=ghc-8.4, addons: { apt: { packages: [ libgmp-dev ] } } }
-  - { env: BUILD=stack RESOLVER=ghc-8.4, compiler: ghc-8.4, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } }
+  - { env: BUILD=stack RESOLVER=ghc-8.6, addons: { apt: { packages: [ libgmp-dev ] } } }
-  - { env: BUILD=hlint, compiler: hlint, language: generic }
+  - { env: BUILD=stack RESOLVER=ghc-8.6, addons: { apt: { packages: [ libgmp-dev ] } }, os: osx }
-  - { env: BUILD=weeder, compiler: weeder, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } }
+  - { 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: BUILD=hlint, compiler: hlint, language: generic }
+  - { env: BUILD=hlint }
-  - { env: BUILD=weeder, compiler: weeder, language: generic, addons: { apt: { packages: [ libgmp-dev ] } } }
+  - { env: BUILD=weeder, addons: { apt: { packages: [ libgmp-dev ] } } }
 
 install:
-  - export PATH=$HOME/.local/bin::$HOME/.cabal/bin:$PATH
+  - 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 --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin
+          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
@@ -47,20 +49,24 @@ script:
     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-10.4, packages: [ '.' ], extra-deps: [ basement-0.0.6, foundation-0.0.19, memory-0.14.14, gauge-0.2.1 ], flags: {} }" > stack.yaml
+        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.0)
-        echo "{ resolver: lts-9.21, packages: [ '.' ], extra-deps: [ basement-0.0.6, foundation-0.0.19, memory-0.14.14, 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.0)
-        echo "{ resolver: lts-9.21, packages: [ '.' ], extra-deps: [ basement-0.0.6, foundation-0.0.19, memory-0.14.14, 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.4)
-        echo "{ setup-info: { ghc: { \"linux32-nopie\": { \"8.4.0.20180118\": { url: \"https://downloads.haskell.org/~ghc/8.4.1-alpha2/ghc-8.4.0.20180118-i386-deb8-linux.tar.xz\", sha256: \"be1a3b5de9f671199533d22f2810d9b62c6392b32b39833cd384a094566703c6\" } }, \"windows32\": { \"8.4.0.20180118\": { url: \"https://downloads.haskell.org/~ghc/8.4.1-alpha2/ghc-8.4.0.20180118-i386-unknown-mingw32.tar.xz\", sha256: \"3f4b9291ad35d89ca7b3561312a4329545aedceb5c4c8c5c4cf01550037376a1\" } }, \"linux64\": { \"8.4.0.20180118\": { url: \"https://downloads.haskell.org/~ghc/8.4.1-alpha2/ghc-8.4.0.20180118-x86_64-deb8-linux.tar.xz\", sha256: \"55b54bce14661c19288c3413b8fab95d2b7fae407986323c7f0b6a732bec6a38\" } }, \"linux64-tinfo\": { \"8.4.0.20180118\": { url: \"https://downloads.haskell.org/~ghc/8.4.1-alpha2/ghc-8.4.0.20180118-x86_64-deb8-linux.tar.xz\", sha256: \"55b54bce14661c19288c3413b8fab95d2b7fae407986323c7f0b6a732bec6a38\" } }, \"linux64-tinfo6\": { \"8.4.0.20180118\": { url: \"https://downloads.haskell.org/~ghc/8.4.1-alpha2/ghc-8.4.0.20180118-x86_64-fedora27-linux.tar.xz\", sha256: \"47c7e4350c9560f984bde75b243aa10c91e37494152d87d20f84fcee857338ef\" } }, \"linux64-tinfo-nopie\": { \"8.4.0.20180118\": { url: \"https://downloads.haskell.org/~ghc/8.4.1-alpha2/ghc-8.4.0.20180118-x86_64-fedora27-linux.tar.xz\", sha256: \"47c7e4350c9560f984bde75b243aa10c91e37494152d87d20f84fcee857338ef\" } }, \"linux64-nopie\": { \"8.4.0.20180118\": { url: \"https://downloads.haskell.org/~ghc/8.4.1-alpha2/ghc-8.4.0.20180118-x86_64-deb8-linux.tar.xz\", sha256: \"55b54bce14661c19288c3413b8fab95d2b7fae407986323c7f0b6a732bec6a38\" } }, \"windows64\": { \"8.4.0.20180118\": { url: \"https://downloads.haskell.org/~ghc/8.4.1-alpha2/ghc-8.4.0.20180118-x86_64-unknown-mingw32.tar.xz\", sha256: \"93dd7f80e3c645b79a91f3023046144ec88927961a3443019034e2893de43752\" } }, \"macosx\": { \"8.4.0.20180118\": { url: \"https://downloads.haskell.org/~ghc/8.4.1-alpha2/ghc-8.4.0.20180118-x86_64-apple-darwin.tar.xz\", sha256: \"b3119b255ab3d1a09fcf9919bddbbe2cd77f9175de14e4b23f20b40abe5edea1\" } } } }, resolver: ghc-8.4.0.20180118, compiler: ghc-8.4.0.20180118, compiler-check: match-exact, packages: [ '.' ], extra-deps: [ vector-0.12.0.1, basement-0.0.6, foundation-0.0.19, memory-0.14.14, QuickCheck-2.11.3, ansi-terminal-0.8.0.1, async-2.1.1.1, call-stack-0.1.0, clock-0.7.2, optparse-applicative-0.14.0.0, random-1.1, tagged-0.8.5, unbounded-delays-0.1.1.0, tasty-1.0.0.1, tasty-hunit-0.10.0.1, tasty-kat-0.0.3, tasty-quickcheck-0.9.2, ansi-wl-pprint-0.6.8.2, colour-2.3.4, tf-random-0.5, transformers-compat-0.5.1.4, primitive-0.6.3.0, gauge-0.2.1 ], flags: {}, allow-newer: true }" > stack.yaml
+        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
@@ -69,7 +75,7 @@ script:
       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
+      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

CHANGELOG.md

@@ -1,3 +1,52 @@
+## 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

Crypto/Cipher/AES.hs

@@ -19,8 +19,6 @@ import Crypto.Cipher.Types.Block
 import Crypto.Cipher.AES.Primitive
 import Crypto.Internal.Imports
 
-import Data.ByteArray as BA
-
 -- | AES with 128 bit key
 newtype AES128 = AES128 AES
     deriving (NFData)

Crypto/Cipher/AES/Primitive.hs

@@ -37,6 +37,9 @@ module Crypto.Cipher.AES.Primitive
     , decryptCTR
     , decryptXTS
 
+    -- * CTR with 32-bit wrapping
+    , combineC32
+
     -- * Incremental GCM
     , gcmMode
     , gcmInit
@@ -128,7 +131,7 @@ newtype AESCCM = AESCCM ScrubbedBytes
     deriving (NFData)
 
 sizeGCM :: Int
-sizeGCM = 80
+sizeGCM = 320
 
 sizeOCB :: Int
 sizeOCB = 160
@@ -317,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 ())
@@ -578,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 ()
 

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,15 +5,33 @@
 -- Portability : Good
 {-# LANGUAGE MagicHash #-}
 module Crypto.Cipher.Blowfish.Box
-    ( createKeySchedule
+    (   KeySchedule(..)
+    ,   createKeySchedule
+    ,   copyKeySchedule
     ) where
 
-import Crypto.Internal.WordArray (mutableArray32FromAddrBE, MutableArray32)
+import           Crypto.Internal.WordArray (MutableArray32,
+                                            mutableArray32FromAddrBE,
+                                            mutableArrayRead32,
+                                            mutableArrayWrite32)
+
+newtype KeySchedule = KeySchedule MutableArray32
+
+-- | 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.
-createKeySchedule :: IO MutableArray32
+createKeySchedule :: IO KeySchedule
-createKeySchedule = mutableArray32FromAddrBE 1042 "\
+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,197 +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
+newtype Context = Context Array32
-data Context = BF (Int -> Word32) -- p
-                  (Int -> Word32) -- sbox0
-                  (Int -> Word32) -- sbox1
-                  (Int -> Word32) -- sbox2
-                  (Int -> Word32) -- sbox2
 
 instance NFData Context where
-    rnf (BF p a b c d) = p `seq` a `seq` b `seq` c `seq` d `seq` ()
+    rnf a = a `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
 
 -- | 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
+    | B.length key > (448 `div` 8) = CryptoFailed CryptoError_KeySizeInvalid
-    | otherwise           = CryptoPassed $ makeKeySchedule key (Nothing :: Maybe (Bytes, Int))
+    | otherwise                    = CryptoPassed $ unsafeDoIO $ do
-  where len = B.length key
+        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
+-- Input need to be a multiple of 8 bytes
--- Cost must be between 4 and 31 inclusive
+encrypt :: ByteArray ba => Context -> ba -> ba
--- See <https://www.usenix.org/conference/1999-usenix-annual-technical-conference/future-adaptable-password-scheme>
+encrypt ctx ba
-eksBlowfish :: (ByteArrayAccess salt, ByteArrayAccess password) => Int -> salt -> password -> Context
+    | B.length ba == 0         = B.empty
-eksBlowfish cost salt key
+    | B.length ba `mod` 8 /= 0 = error "invalid data length"
-    | B.length salt /= 16 = error "bcrypt salt must be 16 bytes"
+    | otherwise                = B.mapAsWord64 (cipherBlock ctx False) ba
-    | otherwise           = makeKeySchedule key (Just (salt, cost))
 
-coreCrypto :: Context -> Word64 -> Word64
+-- | Decrypt blocks
-coreCrypto (BF p s0 s1 s2 s3) input = doRound input 0
+--
-  where
+-- Input need to be a multiple of 8 bytes
-    -- transform the input over 16 rounds
+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)
+            let newr = fromIntegral (i `shiftR` 32) `xor` p roundIndex
-                newi = ((i `shiftL` 32) `xor` (f newr)) .|. (fromIntegral newr)
+                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)
+    f t = let a = s0 (0xff .&. (t `shiftR` 24))
-              b = s1 (fromIntegral $ (t `shiftR` 16) .&. 0xff)
+              b = s1 (0xff .&. (t `shiftR` 16))
-              c = s2 (fromIntegral $ (t `shiftR` 8) .&. 0xff)
+              c = s2 (0xff .&. (t `shiftR` 8))
-              d = s3 (fromIntegral $ t .&. 0xff)
+              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
+-- | Blowfish encrypt a Word using the current state of the key schedule
--- For the expensive version, the salt and cost factor are supplied. Salt must be
+cipherBlockMutable :: KeySchedule -> Word64 -> IO Word64
--- a 128-bit byte array.
+cipherBlockMutable (KeySchedule ma) input = doRound input 0
---
+    where
--- The standard case is just a single key expansion with the salt set to zero.
+    -- | Transform the input over 16 rounds
-makeKeySchedule :: (ByteArrayAccess key, ByteArrayAccess salt) => key-> Maybe (salt, Int) -> Context
+    doRound !i roundIndex
-makeKeySchedule keyBytes saltCost =
+        | roundIndex == 16 = do
-    let v = unsafeDoIO $ do
+            pVal1 <- mutableArrayRead32 ma 16
-              mv <- createKeySchedule
+            pVal2 <- mutableArrayRead32 ma 17
-              case saltCost of
+            let final = (fromIntegral pVal1 `shiftL` 32) .|. fromIntegral pVal2
-                  -- Standard blowfish
+            return $ rotateL (i `xor` final) 32
-                  Nothing -> expandKey mv 0 0 keyBytes
+        | otherwise     = do
-                  -- The expensive case
+            pVal <- mutableArrayRead32 ma roundIndex
-                  Just (s, cost)  -> do
+            let newr = fromIntegral (i `shiftR` 32) `xor` pVal
-                      let (salt1, salt2) = splitSalt s
+            newr' <- f newr
-                      expandKey mv salt1 salt2 keyBytes
+            let newi = ((i `shiftL` 32) `xor` newr') .|. fromIntegral newr
-                      forM_ [1..2^cost :: Int] $ \_ -> do
+            doRound newi (roundIndex+1)
-                          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))
 
-        -- Indices of the S-Box arrays, each containing 256 32-bit words
+    -- | The Blowfish Feistel function F
-        -- The first 18 words contain the P-Array of subkeys
+    f   :: Word32 -> IO Word64
-        s0 = 18
+    f t = do
-        s1 = 274
+        a <- s0 (0xff .&. (t `shiftR` 24))
-        s2 = 530
+        b <- s1 (0xff .&. (t `shiftR` 16))
-        s3 = 786
+        c <- s2 (0xff .&. (t `shiftR` 8))
+        d <- s3 (0xff .&.  t)
+        return (fromIntegral (((a + b) `xor` c) + d) `shiftL` 32)
 
-expandKey :: ByteArrayAccess ba
+    -- | S-Box arrays, each containing 256 32-bit words
-          => MutableArray32      -- ^ The key schedule
+    --   The first 18 words contain the P-Array of subkeys
-          -> Word64              -- ^ First word of the salt
+    s0, s1, s2, s3 :: Word32 -> IO Word32
-          -> Word64              -- ^ Second word of the salt
+    s0 i = mutableArrayRead32 ma (fromIntegral i + 18)
-          -> ba                  -- ^ The key
+    s1 i = mutableArrayRead32 ma (fromIntegral i + 274)
-          -> IO ()
+    s2 i = mutableArrayRead32 ma (fromIntegral i + 530)
-expandKey mv salt1 salt2 key = do
+    s3 i = mutableArrayRead32 ma (fromIntegral i + 786)
-    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
 
-        -- | Go through the entire key schedule overwriting the P-Array and S-Boxes
+iterKeyStream :: (ByteArrayAccess x)
-        prepare mctx = loop 0 salt1 salt1 salt2
+    => x
-          where loop i input slt1 slt2
+    -> Word32
-                  | i == 1042   = return ()
+    -> Word32
-                  | otherwise = do
+    -> (Int -> Word32 -> Word32 -> Word32 -> Word32 -> (Word32 -> Word32 -> IO ()) -> IO ())
-                      ninput <- coreCryptoMutable input
+    -> IO ()
-                      let (nl, nr) = w64to32 ninput
+iterKeyStream x a0 a1 g = f 0 0 a0 a1
-                      mutableArrayWrite32 mctx i     nl
+    where
-                      mutableArrayWrite32 mctx (i+1) nr
+        len          = B.length x
-                      loop (i+2) (ninput `xor` slt2) slt2 slt1
+        -- Avoiding the modulo operation when interating over the ring
-
+        -- buffer is assumed to be more efficient here. All other
-                -- | Blowfish encrypt a Word using the current state of the key schedule
+        -- implementations do this, too. The branch prediction shall prefer
-                coreCryptoMutable :: Word64 -> IO Word64
+        -- the branch with the increment.
-                coreCryptoMutable input = doRound input 0
+        n j          = if j + 1 >= len then 0 else j + 1
-                  where doRound i roundIndex
+        f i j0 b0 b1 = g i l r b0 b1 (f (i + 2) j8)
-                          | roundIndex == 16 = do
+            where
-                              pVal1 <- mutableArrayRead32 mctx 16
+                j1 = n j0
-                              pVal2 <- mutableArrayRead32 mctx 17
+                j2 = n j1
-                              let final = (fromIntegral pVal1 `shiftL` 32) .|. fromIntegral pVal2
+                j3 = n j2
-                              return $ rotateL (i `xor` final) 32
+                j4 = n j3
-                          | otherwise     = do
+                j5 = n j4
-                              pVal <- mutableArrayRead32 mctx roundIndex
+                j6 = n j5
-                              let newr = fromIntegral (i `shiftR` 32) `xor` pVal
+                j7 = n j6
-                              newr' <- f newr
+                j8 = n j7
-                              let newi = ((i `shiftL` 32) `xor` newr') .|. (fromIntegral newr)
+                x0 = fromIntegral (B.index x j0)
-                              doRound newi (roundIndex+1)
+                x1 = fromIntegral (B.index x j1)
-
+                x2 = fromIntegral (B.index x j2)
-                -- The Blowfish Feistel function F
+                x3 = fromIntegral (B.index x j3)
-                f   :: Word32 -> IO Word64
+                x4 = fromIntegral (B.index x j4)
-                f t = do a <- mutableArrayRead32 mctx (s0 + fromIntegral ((t `shiftR` 24) .&. 0xff))
+                x5 = fromIntegral (B.index x j5)
-                         b <- mutableArrayRead32 mctx (s1 + fromIntegral ((t `shiftR` 16) .&. 0xff))
+                x6 = fromIntegral (B.index x j6)
-                         c <- mutableArrayRead32 mctx (s2 + fromIntegral ((t `shiftR` 8) .&. 0xff))
+                x7 = fromIntegral (B.index x j7)
-                         d <- mutableArrayRead32 mctx (s3 + fromIntegral (t .&. 0xff))
+                l  = shiftL x0 24 .|. shiftL x1 16 .|. shiftL x2 8 .|. x3
-                         return (fromIntegral (((a + b) `xor` c) + d) `shiftL` 32)
+                r  = shiftL x4 24 .|. shiftL x5 16 .|. shiftL x6 8 .|. x7
-                  where s0 = 18
+{-# INLINE iterKeyStream #-}
-                        s1 = 274
+-- Benchmarking shows that GHC considers this function too big to inline
-                        s2 = 530
+-- although forcing inlining causes an actual improvement.
-                        s3 = 786
+-- It is assumed that all function calls (especially the continuation)
+-- collapse into a tight loop after inlining.

Crypto/Cipher/ChaCha.hs

@@ -41,14 +41,14 @@ 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"
+    | kLen `notElem` [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"
+    | nonceLen `notElem` [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"
+    | 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

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

@@ -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"
+    | kLen `notElem` [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"
+    | nonceLen `notElem` [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"
+    | 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

@@ -7,7 +7,6 @@ module Crypto.Cipher.Twofish
 import Crypto.Cipher.Twofish.Primitive
 import Crypto.Cipher.Types
 import Crypto.Cipher.Utils
-import Crypto.Internal.Imports
 
 newtype Twofish128 = Twofish128 Twofish
 

Crypto/Cipher/Twofish/Primitive.hs

@@ -8,15 +8,12 @@ module Crypto.Cipher.Twofish.Primitive
     ) where
 
 import           Crypto.Error
-import           Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray, Bytes)
+import           Crypto.Internal.ByteArray (ByteArray)
 import qualified Crypto.Internal.ByteArray as B
 import           Crypto.Internal.WordArray
-import           Crypto.Internal.Words
 import           Data.Word
-import           Data.Int
 import           Data.Bits
 import           Data.List
-import           Control.Monad
 
 -- Based on the Golang referance implementation
 -- https://github.com/golang/crypto/blob/master/twofish/twofish.go
@@ -206,7 +203,7 @@ sWords key = sWord
 
 data Column = Zero | One | Two | Three deriving (Show, Eq, Enum, Bounded)
 
-genSboxes :: ByteArray ba => KeyPackage ba -> [Word8] -> (Array32, Array32, Array32, Array32)
+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

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

@@ -22,6 +22,7 @@ module Crypto.Cipher.Types.Base
 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
@@ -36,7 +37,7 @@ 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

Crypto/Cipher/Types/Block.hs

@@ -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,7 +163,7 @@ 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 $ loop i (B.length bs - 1)

Crypto/Cipher/Utils.hs

@@ -4,7 +4,6 @@ module Crypto.Cipher.Utils
 
 import Crypto.Error
 import Crypto.Cipher.Types
-import Crypto.Internal.Imports
 
 import Data.ByteArray as BA
 

Crypto/Cipher/XSalsa.hs

@@ -12,18 +12,17 @@
 {-# LANGUAGE ForeignFunctionInterface #-}
 module Crypto.Cipher.XSalsa
     ( initialize
+    , derive
     , combine
     , generate
     , State
     ) where
 
-import           Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray, ScrubbedBytes)
+import           Crypto.Internal.ByteArray (ByteArrayAccess)
 import qualified Crypto.Internal.ByteArray as B
 import           Crypto.Internal.Compat
 import           Crypto.Internal.Imports
 import           Foreign.Ptr
-import           Foreign.Storable
-import           Foreign.C.Types
 import           Crypto.Cipher.Salsa hiding (initialize)
 
 -- | Initialize a new XSalsa context with the number of rounds,
@@ -36,15 +35,41 @@ initialize :: (ByteArrayAccess key, ByteArrayAccess nonce)
 initialize nbRounds key nonce
     | kLen /= 32                      = error "XSalsa: key length should be 256 bits"
     | nonceLen /= 24                  = error "XSalsa: nonce length should be 192 bits"
-    | not (nbRounds `elem` [8,12,20]) = error "XSalsa: rounds should be 8, 12 or 20"
+    | 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 (fromIntegral nbRounds) kLen keyPtr nonceLen noncePtr
+                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

@@ -44,7 +44,7 @@ compute' g = MP . foldl' (step $ g) (B.replicate bsz 0) . chunks . pad (ZERO bsz
       where
         (hd, tl) = B.splitAt bsz msg
 
--- | Compute Miyaguchi-Preneel one way compress using the infered block cipher.
+-- | 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/

Crypto/Data/AFIS.hs

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

Crypto/ECC.hs

@@ -8,6 +8,7 @@
 -- Elliptic Curve Cryptography
 --
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -21,6 +22,7 @@ module Crypto.ECC
     , EllipticCurve(..)
     , EllipticCurveDH(..)
     , EllipticCurveArith(..)
+    , EllipticCurveBasepointArith(..)
     , KeyPair(..)
     , SharedSecret(..)
     ) where
@@ -31,17 +33,18 @@ 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.Proxy
 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.Function (on)
 import           Data.ByteArray (convert)
 import           Data.Data (Data())
-import           Data.Typeable (Typeable())
+import           Data.Kind (Type)
+import           Data.Proxy
 
 -- | An elliptic curve key pair composed of the private part (a scalar), and
 -- the associated point.
@@ -55,10 +58,10 @@ newtype SharedSecret = SharedSecret ScrubbedBytes
 
 class EllipticCurve curve where
     -- | Point on an Elliptic Curve
-    type Point curve  :: *
+    type Point curve  :: Type
 
     -- | Scalar in the Elliptic Curve domain
-    type Scalar curve :: *
+    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
@@ -99,7 +102,7 @@ class EllipticCurve curve => EllipticCurveDH curve where
     -- value or an exception.
     ecdh :: proxy curve -> Scalar curve -> Point curve -> CryptoFailable SharedSecret
 
-class EllipticCurve curve => EllipticCurveArith curve where
+class (EllipticCurve curve, Eq (Point curve)) => EllipticCurveArith curve where
     -- | Add points on a curve
     pointAdd :: proxy curve -> Point curve -> Point curve -> Point curve
 
@@ -112,11 +115,40 @@ class EllipticCurve curve => EllipticCurveArith curve where
 --   -- | 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,Typeable)
+    deriving (Show,Data)
 
 instance EllipticCurve Curve_P256R1 where
     type Point Curve_P256R1 = P256.Point
@@ -134,11 +166,11 @@ instance EllipticCurve Curve_P256R1 where
             uncompressed = B.singleton 4
             xy = P256.pointToBinary p
     decodePoint _ mxy = case B.uncons mxy of
-        Nothing -> CryptoFailed $ CryptoError_PointSizeInvalid
+        Nothing -> CryptoFailed CryptoError_PointSizeInvalid
         Just (m,xy)
             -- uncompressed
             | m == 4 -> P256.pointFromBinary xy
-            | otherwise -> CryptoFailed $ CryptoError_PointFormatInvalid
+            | otherwise -> CryptoFailed CryptoError_PointFormatInvalid
 
 instance EllipticCurveArith Curve_P256R1 where
     pointAdd  _ a b = P256.pointAdd a b
@@ -149,8 +181,19 @@ 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,Typeable)
+    deriving (Show,Data)
 
 instance EllipticCurve Curve_P384R1 where
     type Point Curve_P384R1 = Simple.Point Simple.SEC_p384r1
@@ -172,8 +215,19 @@ instance EllipticCurveDH Curve_P384R1 where
       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,Typeable)
+    deriving (Show,Data)
 
 instance EllipticCurve Curve_P521R1 where
     type Point Curve_P521R1 = Simple.Point Simple.SEC_p521r1
@@ -195,8 +249,19 @@ instance EllipticCurveDH Curve_P521R1 where
       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,Typeable)
+    deriving (Show,Data)
 
 instance EllipticCurve Curve_X25519 where
     type Point Curve_X25519 = X25519.PublicKey
@@ -215,7 +280,7 @@ instance EllipticCurveDH Curve_X25519 where
     ecdh prx s p = checkNonZeroDH (ecdhRaw prx s p)
 
 data Curve_X448 = Curve_X448
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance EllipticCurve Curve_X448 where
     type Point Curve_X448 = X448.PublicKey
@@ -234,7 +299,7 @@ instance EllipticCurveDH Curve_X448 where
     ecdh prx s p = checkNonZeroDH (ecdhRaw prx s p)
 
 data Curve_Edwards25519 = Curve_Edwards25519
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance EllipticCurve Curve_Edwards25519 where
     type Point Curve_Edwards25519 = Edwards25519.Point
@@ -251,6 +316,22 @@ instance EllipticCurveArith Curve_Edwards25519 where
     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
@@ -272,7 +353,7 @@ encodeECPoint (Simple.Point x y) = B.concat [uncompressed,xb,yb]
 
 decodeECPoint :: (Simple.Curve curve, ByteArray bs) => bs -> CryptoFailable (Simple.Point curve)
 decodeECPoint mxy = case B.uncons mxy of
-    Nothing     -> CryptoFailed $ CryptoError_PointSizeInvalid
+    Nothing     -> CryptoFailed CryptoError_PointSizeInvalid
     Just (m,xy)
         -- uncompressed
         | m == 4 ->
@@ -281,4 +362,47 @@ decodeECPoint mxy = case B.uncons mxy of
                 x = os2ip xb
                 y = os2ip yb
              in Simple.pointFromIntegers (x,y)
-        | otherwise -> CryptoFailed $ CryptoError_PointFormatInvalid
+        | 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

@@ -73,15 +73,12 @@ module Crypto.ECC.Edwards25519
     , pointsMulVarTime
     ) where
 
-import           Data.Bits
 import           Data.Word
 import           Foreign.C.Types
 import           Foreign.Ptr
-import           Foreign.Storable
 
 import           Crypto.Error
-import           Crypto.Internal.ByteArray (ByteArrayAccess, Bytes,
+import           Crypto.Internal.ByteArray (Bytes, ScrubbedBytes, withByteArray)
-                                            ScrubbedBytes, withByteArray)
 import qualified Crypto.Internal.ByteArray as B
 import           Crypto.Internal.Compat
 import           Crypto.Internal.Imports
@@ -286,45 +283,45 @@ pointsMulVarTime (Scalar s1) (Scalar s2) (Point p) =
         withByteArray p  $ \pp  ->
              ed25519_base_double_scalarmul_vartime out ps1 pp ps2
 
-foreign import ccall "cryptonite_ed25519_scalar_eq"
+foreign import ccall unsafe "cryptonite_ed25519_scalar_eq"
     ed25519_scalar_eq :: Ptr Scalar
                       -> Ptr Scalar
                       -> IO CInt
 
-foreign import ccall "cryptonite_ed25519_scalar_encode"
+foreign import ccall unsafe "cryptonite_ed25519_scalar_encode"
     ed25519_scalar_encode :: Ptr Word8
                           -> Ptr Scalar
                           -> IO ()
 
-foreign import ccall "cryptonite_ed25519_scalar_decode_long"
+foreign import ccall unsafe "cryptonite_ed25519_scalar_decode_long"
     ed25519_scalar_decode_long :: Ptr Scalar
                                -> Ptr Word8
                                -> CSize
                                -> IO ()
 
-foreign import ccall "cryptonite_ed25519_scalar_add"
+foreign import ccall unsafe "cryptonite_ed25519_scalar_add"
     ed25519_scalar_add :: Ptr Scalar -- sum
                        -> Ptr Scalar -- a
                        -> Ptr Scalar -- b
                        -> IO ()
 
-foreign import ccall "cryptonite_ed25519_scalar_mul"
+foreign import ccall unsafe "cryptonite_ed25519_scalar_mul"
     ed25519_scalar_mul :: Ptr Scalar -- out
                        -> Ptr Scalar -- a
                        -> Ptr Scalar -- b
                        -> IO ()
 
-foreign import ccall "cryptonite_ed25519_point_encode"
+foreign import ccall unsafe "cryptonite_ed25519_point_encode"
     ed25519_point_encode :: Ptr Word8
                          -> Ptr Point
                          -> IO ()
 
-foreign import ccall "cryptonite_ed25519_point_decode_vartime"
+foreign import ccall unsafe "cryptonite_ed25519_point_decode_vartime"
     ed25519_point_decode_vartime :: Ptr Point
                                  -> Ptr Word8
                                  -> IO CInt
 
-foreign import ccall "cryptonite_ed25519_point_eq"
+foreign import ccall unsafe "cryptonite_ed25519_point_eq"
     ed25519_point_eq :: Ptr Point
                      -> Ptr Point
                      -> IO CInt
@@ -333,23 +330,23 @@ foreign import ccall "cryptonite_ed25519_point_has_prime_order"
     ed25519_point_has_prime_order :: Ptr Point
                                   -> IO CInt
 
-foreign import ccall "cryptonite_ed25519_point_negate"
+foreign import ccall unsafe "cryptonite_ed25519_point_negate"
     ed25519_point_negate :: Ptr Point -- minus_a
                          -> Ptr Point -- a
                          -> IO ()
 
-foreign import ccall "cryptonite_ed25519_point_add"
+foreign import ccall unsafe "cryptonite_ed25519_point_add"
     ed25519_point_add :: Ptr Point -- sum
                       -> Ptr Point -- a
                       -> Ptr Point -- b
                       -> IO ()
 
-foreign import ccall "cryptonite_ed25519_point_double"
+foreign import ccall unsafe "cryptonite_ed25519_point_double"
     ed25519_point_double :: Ptr Point -- two_a
                          -> Ptr Point -- a
                          -> IO ()
 
-foreign import ccall "cryptonite_ed25519_point_mul_by_cofactor"
+foreign import ccall unsafe "cryptonite_ed25519_point_mul_by_cofactor"
     ed25519_point_mul_by_cofactor :: Ptr Point -- eight_a
                                   -> Ptr Point -- a
                                   -> IO ()

Crypto/ECC/Simple/Prim.hs

@@ -17,8 +17,7 @@ module Crypto.ECC.Simple.Prim
     ) where
 
 import Data.Maybe
-import Crypto.Internal.Imports
+import Data.Proxy
-import Crypto.Internal.Proxy
 import Crypto.Number.ModArithmetic
 import Crypto.Number.F2m
 import Crypto.Number.Generate (generateBetween)

Crypto/ECC/Simple/Types.hs

@@ -84,28 +84,28 @@ data CurveParameters curve = CurveParameters
     , curveEccG :: Point curve -- ^ base point
     , curveEccN :: Integer     -- ^ order of G
     , curveEccH :: Integer     -- ^ cofactor
-    } deriving (Show,Eq,Data,Typeable)
+    } deriving (Show,Eq,Data)
 
 newtype CurveBinaryParam = CurveBinaryParam Integer
-    deriving (Show,Read,Eq,Data,Typeable)
+    deriving (Show,Read,Eq,Data)
 
 newtype CurvePrimeParam = CurvePrimeParam Integer
-    deriving (Show,Read,Eq,Data,Typeable)
+    deriving (Show,Read,Eq,Data)
 
 data CurveType =
       CurveBinary CurveBinaryParam
     | CurvePrime CurvePrimeParam
-    deriving (Show,Read,Eq,Data,Typeable)
+    deriving (Show,Read,Eq,Data)
 
 -- | ECC Private Number
 newtype Scalar curve = Scalar Integer
-    deriving (Show,Read,Eq,Data,Typeable,NFData)
+    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,Typeable)
+    deriving (Show,Read,Eq,Data)
 
 instance NFData (Point curve) where
     rnf (Point x y) = x `seq` y `seq` ()

Crypto/Error/Types.hs

@@ -23,7 +23,6 @@ import qualified Control.Exception as E
 import           Data.Data
 
 import           Basement.Monad (MonadFailure(..))
-import           Crypto.Internal.Imports
 
 -- | Enumeration of all possible errors that can be found in this library
 data CryptoError =
@@ -53,7 +52,7 @@ data CryptoError =
     | CryptoError_SaltTooSmall
     | CryptoError_OutputLengthTooSmall
     | CryptoError_OutputLengthTooBig
-    deriving (Show,Eq,Enum,Data,Typeable)
+    deriving (Show,Eq,Enum,Data)
 
 instance E.Exception CryptoError
 
@@ -83,7 +82,7 @@ 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

Crypto/Hash.hs

@@ -28,15 +28,20 @@ module Crypto.Hash
     -- * Hash methods parametrized by algorithm
     , hashInitWith
     , hashWith
+    , hashPrefixWith
     -- * Hash methods
     , hashInit
     , hashUpdates
     , hashUpdate
     , hashFinalize
+    , hashFinalizePrefix
     , hashBlockSize
     , hashDigestSize
     , hash
+    , hashPrefix
     , hashlazy
+    , hashPutContext
+    , hashGetContext
     -- * Hash algorithms
     , module Crypto.Hash.Algorithms
     ) where
@@ -44,20 +49,24 @@ module Crypto.Hash
 import           Basement.Types.OffsetSize (CountOf (..))
 import           Basement.Block (Block, unsafeFreeze)
 import           Basement.Block.Mutable (copyFromPtr, new)
-import           Control.Monad
 import           Crypto.Internal.Compat (unsafeDoIO)
 import           Crypto.Hash.Types
 import           Crypto.Hash.Algorithms
-import           Foreign.Ptr (Ptr)
+import           Foreign.Ptr (Ptr, plusPtr)
-import           Crypto.Internal.ByteArray (ByteArrayAccess)
+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)
@@ -82,9 +91,17 @@ hashUpdates :: forall a ba . (HashAlgorithm a, ByteArrayAccess ba)
 hashUpdates c l
     | null ls   = c
     | otherwise = Context $ B.copyAndFreeze c $ \(ctx :: Ptr (Context a)) ->
-        mapM_ (\b -> B.withByteArray b $ \d -> hashInternalUpdate ctx d (fromIntegral $ B.length b)) ls
+        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 :: forall a . HashAlgorithm a
@@ -95,6 +112,24 @@ hashFinalize !c =
         ((!_) :: 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
 hashInitWith _ = hashInit
@@ -103,6 +138,10 @@ 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
@@ -110,7 +149,7 @@ hashWith _ = hash
 digestFromByteString :: forall a ba . (HashAlgorithm a, ByteArrayAccess ba) => ba -> Maybe (Digest a)
 digestFromByteString = from undefined
   where
-        from :: HashAlgorithm a => a -> ba -> Maybe (Digest a)
+        from :: a -> ba -> Maybe (Digest a)
         from alg bs
             | B.length bs == (hashDigestSize alg) = Just $ Digest $ unsafeDoIO $ copyBytes bs
             | otherwise                           = Nothing
@@ -122,3 +161,16 @@ digestFromByteString = from undefined
             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

@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
 -- |
 -- Module      : Crypto.Hash.Algorithms
 -- License     : BSD-style
@@ -10,6 +9,8 @@
 --
 module Crypto.Hash.Algorithms
     ( HashAlgorithm
+    , HashAlgorithmPrefix
+    , HashAlgorithmResumable
     -- * Hash algorithms
     , Blake2s_160(..)
     , Blake2s_224(..)
@@ -42,12 +43,10 @@ module Crypto.Hash.Algorithms
     , SHA3_256(..)
     , SHA3_384(..)
     , SHA3_512(..)
-#if MIN_VERSION_base(4,7,0)
     , SHAKE128(..)
     , SHAKE256(..)
     , Blake2b(..), Blake2bp(..)
     , Blake2s(..), Blake2sp(..)
-#endif
     , Skein256_224(..)
     , Skein256_256(..)
     , Skein512_224(..)
@@ -57,7 +56,7 @@ 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
@@ -78,7 +77,5 @@ import           Crypto.Hash.Tiger
 import           Crypto.Hash.Skein256
 import           Crypto.Hash.Skein512
 import           Crypto.Hash.Whirlpool
-#if MIN_VERSION_base(4,7,0)
 import           Crypto.Hash.SHAKE
 import           Crypto.Hash.Blake2
-#endif

Crypto/Hash/Blake2.hs

@@ -42,9 +42,8 @@ module Crypto.Hash.Blake2
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
 import           Data.Data
-import           Data.Typeable
 import           Data.Word (Word8, Word32)
-import           GHC.TypeLits (Nat, KnownNat, natVal)
+import           GHC.TypeLits (Nat, KnownNat)
 import           Crypto.Internal.Nat
 
 -- | Fast and secure alternative to SHA1 and HMAC-SHA1
@@ -58,7 +57,7 @@ import           Crypto.Internal.Nat
 -- * Blake2s 256
 --
 data Blake2s (bitlen :: Nat) = Blake2s
-  deriving (Show, Typeable)
+    deriving (Show,Data)
 
 instance (IsDivisibleBy8 bitlen, KnownNat bitlen, IsAtLeast bitlen 8, IsAtMost bitlen 256)
       => HashAlgorithm (Blake2s bitlen)
@@ -93,7 +92,7 @@ foreign import ccall unsafe "cryptonite_blake2s_finalize"
 -- * Blake2b 512
 --
 data Blake2b (bitlen :: Nat) = Blake2b
-  deriving (Show, Typeable)
+    deriving (Show,Data)
 
 instance (IsDivisibleBy8 bitlen, KnownNat bitlen, IsAtLeast bitlen 8, IsAtMost bitlen 512)
       => HashAlgorithm (Blake2b bitlen)
@@ -116,7 +115,7 @@ 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, Typeable)
+    deriving (Show,Data)
 
 instance (IsDivisibleBy8 bitlen, KnownNat bitlen, IsAtLeast bitlen 8, IsAtMost bitlen 256)
       => HashAlgorithm (Blake2sp bitlen)
@@ -139,7 +138,7 @@ 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, Typeable)
+    deriving (Show,Data)
 
 instance (IsDivisibleBy8 bitlen, KnownNat bitlen, IsAtLeast bitlen 8, IsAtMost bitlen 512)
       => HashAlgorithm (Blake2bp bitlen)

Crypto/Hash/Blake2b.hs

@@ -19,13 +19,12 @@ module Crypto.Hash.Blake2b
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
 import           Data.Data
-import           Data.Typeable
 import           Data.Word (Word8, Word32)
 
 
 -- | Blake2b (160 bits) cryptographic hash algorithm
 data Blake2b_160 = Blake2b_160
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm Blake2b_160 where
     type HashBlockSize           Blake2b_160 = 128
@@ -40,7 +39,7 @@ instance HashAlgorithm Blake2b_160 where
 
 -- | Blake2b (224 bits) cryptographic hash algorithm
 data Blake2b_224 = Blake2b_224
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm Blake2b_224 where
     type HashBlockSize           Blake2b_224 = 128
@@ -55,7 +54,7 @@ instance HashAlgorithm Blake2b_224 where
 
 -- | Blake2b (256 bits) cryptographic hash algorithm
 data Blake2b_256 = Blake2b_256
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm Blake2b_256 where
     type HashBlockSize           Blake2b_256 = 128
@@ -70,7 +69,7 @@ instance HashAlgorithm Blake2b_256 where
 
 -- | Blake2b (384 bits) cryptographic hash algorithm
 data Blake2b_384 = Blake2b_384
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm Blake2b_384 where
     type HashBlockSize           Blake2b_384 = 128
@@ -85,7 +84,7 @@ instance HashAlgorithm Blake2b_384 where
 
 -- | Blake2b (512 bits) cryptographic hash algorithm
 data Blake2b_512 = Blake2b_512
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm Blake2b_512 where
     type HashBlockSize           Blake2b_512 = 128

Crypto/Hash/Blake2bp.hs

@@ -19,13 +19,12 @@ module Crypto.Hash.Blake2bp
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
 import           Data.Data
-import           Data.Typeable
 import           Data.Word (Word8, Word32)
 
 
 -- | Blake2bp (512 bits) cryptographic hash algorithm
 data Blake2bp_512 = Blake2bp_512
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm Blake2bp_512 where
     type HashBlockSize           Blake2bp_512 = 128

Crypto/Hash/Blake2s.hs

@@ -19,13 +19,12 @@ module Crypto.Hash.Blake2s
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
 import           Data.Data
-import           Data.Typeable
 import           Data.Word (Word8, Word32)
 
 
 -- | Blake2s (160 bits) cryptographic hash algorithm
 data Blake2s_160 = Blake2s_160
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm Blake2s_160 where
     type HashBlockSize           Blake2s_160 = 64
@@ -40,7 +39,7 @@ instance HashAlgorithm Blake2s_160 where
 
 -- | Blake2s (224 bits) cryptographic hash algorithm
 data Blake2s_224 = Blake2s_224
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm Blake2s_224 where
     type HashBlockSize           Blake2s_224 = 64
@@ -55,7 +54,7 @@ instance HashAlgorithm Blake2s_224 where
 
 -- | Blake2s (256 bits) cryptographic hash algorithm
 data Blake2s_256 = Blake2s_256
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm Blake2s_256 where
     type HashBlockSize           Blake2s_256 = 64

Crypto/Hash/Blake2sp.hs

@@ -19,13 +19,12 @@ module Crypto.Hash.Blake2sp
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
 import           Data.Data
-import           Data.Typeable
 import           Data.Word (Word8, Word32)
 
 
 -- | Blake2sp (224 bits) cryptographic hash algorithm
 data Blake2sp_224 = Blake2sp_224
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm Blake2sp_224 where
     type HashBlockSize           Blake2sp_224 = 64
@@ -40,7 +39,7 @@ instance HashAlgorithm Blake2sp_224 where
 
 -- | Blake2sp (256 bits) cryptographic hash algorithm
 data Blake2sp_256 = Blake2sp_256
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm Blake2sp_256 where
     type HashBlockSize           Blake2sp_256 = 64

Crypto/Hash/IO.hs

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

Crypto/Hash/Keccak.hs

@@ -19,13 +19,12 @@ module Crypto.Hash.Keccak
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
 import           Data.Data
-import           Data.Typeable
 import           Data.Word (Word8, Word32)
 
 
 -- | Keccak (224 bits) cryptographic hash algorithm
 data Keccak_224 = Keccak_224
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm Keccak_224 where
     type HashBlockSize           Keccak_224 = 144
@@ -38,9 +37,13 @@ instance HashAlgorithm Keccak_224 where
     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,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm Keccak_256 where
     type HashBlockSize           Keccak_256 = 136
@@ -53,9 +56,13 @@ instance HashAlgorithm Keccak_256 where
     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,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm Keccak_384 where
     type HashBlockSize           Keccak_384 = 104
@@ -68,9 +75,13 @@ instance HashAlgorithm Keccak_384 where
     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,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm Keccak_512 where
     type HashBlockSize           Keccak_512 = 72
@@ -83,6 +94,10 @@ instance HashAlgorithm Keccak_512 where
     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 ()
@@ -92,3 +107,9 @@ foreign import ccall "cryptonite_keccak_update"
 
 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/MD2.hs

@@ -17,12 +17,11 @@ module Crypto.Hash.MD2 ( MD2 (..) ) where
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
 import           Data.Data
-import           Data.Typeable
 import           Data.Word (Word8, Word32)
 
 -- | MD2 cryptographic hash algorithm
 data MD2 = MD2
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm MD2 where
     type HashBlockSize           MD2 = 16

Crypto/Hash/MD4.hs

@@ -17,12 +17,11 @@ module Crypto.Hash.MD4 ( MD4 (..) ) where
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
 import           Data.Data
-import           Data.Typeable
 import           Data.Word (Word8, Word32)
 
 -- | MD4 cryptographic hash algorithm
 data MD4 = MD4
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm MD4 where
     type HashBlockSize           MD4 = 64

Crypto/Hash/MD5.hs

@@ -17,12 +17,11 @@ module Crypto.Hash.MD5 ( MD5 (..) ) where
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
 import           Data.Data
-import           Data.Typeable
 import           Data.Word (Word8, Word32)
 
 -- | MD5 cryptographic hash algorithm
 data MD5 = MD5
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm MD5 where
     type HashBlockSize           MD5 = 64
@@ -35,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 ()
 
@@ -43,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

@@ -17,12 +17,11 @@ module Crypto.Hash.RIPEMD160 ( RIPEMD160 (..) ) where
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
 import           Data.Data
-import           Data.Typeable
 import           Data.Word (Word8, Word32)
 
 -- | RIPEMD160 cryptographic hash algorithm
 data RIPEMD160 = RIPEMD160
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm RIPEMD160 where
     type HashBlockSize           RIPEMD160 = 64

Crypto/Hash/SHA1.hs

@@ -17,12 +17,11 @@ module Crypto.Hash.SHA1 ( SHA1 (..) ) where
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
 import           Data.Data
-import           Data.Typeable
 import           Data.Word (Word8, Word32)
 
 -- | SHA1 cryptographic hash algorithm
 data SHA1 = SHA1
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm SHA1 where
     type HashBlockSize           SHA1 = 64
@@ -35,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 ()
 
@@ -43,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

@@ -17,12 +17,11 @@ module Crypto.Hash.SHA224 ( SHA224 (..) ) where
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
 import           Data.Data
-import           Data.Typeable
 import           Data.Word (Word8, Word32)
 
 -- | SHA224 cryptographic hash algorithm
 data SHA224 = SHA224
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm SHA224 where
     type HashBlockSize           SHA224 = 64
@@ -35,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 ()
 
@@ -43,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

@@ -17,12 +17,11 @@ module Crypto.Hash.SHA256 ( SHA256 (..) ) where
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
 import           Data.Data
-import           Data.Typeable
 import           Data.Word (Word8, Word32)
 
 -- | SHA256 cryptographic hash algorithm
 data SHA256 = SHA256
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm SHA256 where
     type HashBlockSize           SHA256 = 64
@@ -35,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 ()
 
@@ -43,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

@@ -19,13 +19,12 @@ module Crypto.Hash.SHA3
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
 import           Data.Data
-import           Data.Typeable
 import           Data.Word (Word8, Word32)
 
 
 -- | SHA3 (224 bits) cryptographic hash algorithm
 data SHA3_224 = SHA3_224
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm SHA3_224 where
     type HashBlockSize           SHA3_224 = 144
@@ -38,9 +37,13 @@ instance HashAlgorithm SHA3_224 where
     hashInternalUpdate        = c_sha3_update
     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,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm SHA3_256 where
     type HashBlockSize           SHA3_256 = 136
@@ -53,9 +56,13 @@ instance HashAlgorithm SHA3_256 where
     hashInternalUpdate        = c_sha3_update
     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,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm SHA3_384 where
     type HashBlockSize           SHA3_384 = 104
@@ -68,9 +75,13 @@ instance HashAlgorithm SHA3_384 where
     hashInternalUpdate        = c_sha3_update
     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,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm SHA3_512 where
     type HashBlockSize           SHA3_512 = 72
@@ -83,6 +94,10 @@ instance HashAlgorithm SHA3_512 where
     hashInternalUpdate        = c_sha3_update
     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"
     c_sha3_init :: Ptr (Context a) -> Word32 -> IO ()
@@ -92,3 +107,9 @@ foreign import ccall "cryptonite_sha3_update"
 
 foreign import ccall unsafe "cryptonite_sha3_finalize"
     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

@@ -17,12 +17,11 @@ module Crypto.Hash.SHA384 ( SHA384 (..) ) where
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
 import           Data.Data
-import           Data.Typeable
 import           Data.Word (Word8, Word32)
 
 -- | SHA384 cryptographic hash algorithm
 data SHA384 = SHA384
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm SHA384 where
     type HashBlockSize           SHA384 = 128
@@ -35,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 ()
 
@@ -43,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

@@ -17,12 +17,11 @@ module Crypto.Hash.SHA512 ( SHA512 (..) ) where
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
 import           Data.Data
-import           Data.Typeable
 import           Data.Word (Word8, Word32)
 
 -- | SHA512 cryptographic hash algorithm
 data SHA512 = SHA512
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm SHA512 where
     type HashBlockSize           SHA512 = 128
@@ -35,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 ()
 
@@ -43,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

@@ -19,13 +19,12 @@ module Crypto.Hash.SHA512t
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
 import           Data.Data
-import           Data.Typeable
 import           Data.Word (Word8, Word32)
 
 
 -- | SHA512t (224 bits) cryptographic hash algorithm
 data SHA512t_224 = SHA512t_224
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm SHA512t_224 where
     type HashBlockSize           SHA512t_224 = 128
@@ -40,7 +39,7 @@ instance HashAlgorithm SHA512t_224 where
 
 -- | SHA512t (256 bits) cryptographic hash algorithm
 data SHA512t_256 = SHA512t_256
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm SHA512t_256 where
     type HashBlockSize           SHA512t_256 = 128

Crypto/Hash/SHAKE.hs

@@ -12,37 +12,44 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 module Crypto.Hash.SHAKE
-    (  SHAKE128 (..), SHAKE256 (..)
+    (  SHAKE128 (..), SHAKE256 (..), HashSHAKE (..)
     ) where
 
+import           Control.Monad (when)
 import           Crypto.Hash.Types
-import           Foreign.Ptr (Ptr)
+import           Foreign.Ptr (Ptr, castPtr)
-import           Data.Typeable
+import           Foreign.Storable (Storable(..))
+import           Data.Bits
+import           Data.Data
 import           Data.Word (Word8, Word32)
 
-import           Data.Proxy (Proxy(..))
+import           GHC.TypeLits (Nat, KnownNat, type (+))
-import           GHC.TypeLits (Nat, KnownNat, natVal)
 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 (multiple of 8 bits), to be specified as a type parameter
+-- digest size, to be specified as a type parameter of kind 'Nat'.
--- 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, Typeable)
+    deriving (Show, Data)
 
-instance (IsDivisibleBy8 bitlen, KnownNat bitlen) => HashAlgorithm (SHAKE128 bitlen) where
+instance KnownNat bitlen => HashAlgorithm (SHAKE128 bitlen) where
     type HashBlockSize           (SHAKE128 bitlen)  = 168
-    type HashDigestSize          (SHAKE128 bitlen) = Div8 bitlen
+    type HashDigestSize          (SHAKE128 bitlen) = Div8 (bitlen + 7)
     type HashInternalContextSize (SHAKE128 bitlen) = 376
     hashBlockSize  _          = 168
     hashDigestSize _          = byteLen (Proxy :: Proxy bitlen)
@@ -51,19 +58,26 @@ instance (IsDivisibleBy8 bitlen, KnownNat bitlen) => HashAlgorithm (SHAKE128 bit
     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 (multiple of 8 bits), to be specified as a type parameter
+-- digest size, to be specified as a type parameter of kind 'Nat'.
--- 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, Typeable)
+    deriving (Show, Data)
 
-instance (IsDivisibleBy8 bitlen, KnownNat bitlen) => HashAlgorithm (SHAKE256 bitlen) where
+instance KnownNat bitlen => HashAlgorithm (SHAKE256 bitlen) where
     type HashBlockSize           (SHAKE256 bitlen) = 136
-    type HashDigestSize          (SHAKE256 bitlen) = Div8 bitlen
+    type HashDigestSize          (SHAKE256 bitlen) = Div8 (bitlen + 7)
     type HashInternalContextSize (SHAKE256 bitlen) = 344
     hashBlockSize  _          = 136
     hashDigestSize _          = byteLen (Proxy :: Proxy bitlen)
@@ -72,7 +86,15 @@ instance (IsDivisibleBy8 bitlen, KnownNat bitlen) => HashAlgorithm (SHAKE256 bit
     hashInternalUpdate        = c_sha3_update
     hashInternalFinalize      = shakeFinalizeOutput (Proxy :: Proxy bitlen)
 
-shakeFinalizeOutput :: (IsDivisibleBy8 bitlen, KnownNat 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)
@@ -80,6 +102,26 @@ shakeFinalizeOutput :: (IsDivisibleBy8 bitlen, KnownNat bitlen)
 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 ()
@@ -90,5 +132,14 @@ foreign import ccall "cryptonite_sha3_update"
 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

@@ -19,13 +19,12 @@ module Crypto.Hash.Skein256
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
 import           Data.Data
-import           Data.Typeable
 import           Data.Word (Word8, Word32)
 
 
 -- | Skein256 (224 bits) cryptographic hash algorithm
 data Skein256_224 = Skein256_224
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm Skein256_224 where
     type HashBlockSize           Skein256_224 = 32
@@ -40,7 +39,7 @@ instance HashAlgorithm Skein256_224 where
 
 -- | Skein256 (256 bits) cryptographic hash algorithm
 data Skein256_256 = Skein256_256
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm Skein256_256 where
     type HashBlockSize           Skein256_256 = 32

Crypto/Hash/Skein512.hs

@@ -19,13 +19,12 @@ module Crypto.Hash.Skein512
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
 import           Data.Data
-import           Data.Typeable
 import           Data.Word (Word8, Word32)
 
 
 -- | Skein512 (224 bits) cryptographic hash algorithm
 data Skein512_224 = Skein512_224
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm Skein512_224 where
     type HashBlockSize           Skein512_224 = 64
@@ -40,7 +39,7 @@ instance HashAlgorithm Skein512_224 where
 
 -- | Skein512 (256 bits) cryptographic hash algorithm
 data Skein512_256 = Skein512_256
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm Skein512_256 where
     type HashBlockSize           Skein512_256 = 64
@@ -55,7 +54,7 @@ instance HashAlgorithm Skein512_256 where
 
 -- | Skein512 (384 bits) cryptographic hash algorithm
 data Skein512_384 = Skein512_384
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm Skein512_384 where
     type HashBlockSize           Skein512_384 = 64
@@ -70,7 +69,7 @@ instance HashAlgorithm Skein512_384 where
 
 -- | Skein512 (512 bits) cryptographic hash algorithm
 data Skein512_512 = Skein512_512
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm Skein512_512 where
     type HashBlockSize           Skein512_512 = 64

Crypto/Hash/Tiger.hs

@@ -17,12 +17,11 @@ module Crypto.Hash.Tiger ( Tiger (..) ) where
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
 import           Data.Data
-import           Data.Typeable
 import           Data.Word (Word8, Word32)
 
 -- | Tiger cryptographic hash algorithm
 data Tiger = Tiger
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm Tiger where
     type HashBlockSize           Tiger = 64

Crypto/Hash/Types.hs

@@ -8,10 +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
@@ -19,10 +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)
+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.
 --
@@ -52,12 +61,31 @@ 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)
 
@@ -71,7 +99,7 @@ newtype Context a = Context Bytes
 -- Creating a digest from a bytearray is also possible with function
 -- 'Crypto.Hash.digestFromByteString'.
 newtype Digest a = Digest (Block Word8)
-    deriving (Eq,Ord,ByteArrayAccess)
+    deriving (Eq,Ord,ByteArrayAccess, Data)
 
 instance NFData (Digest a) where
     rnf (Digest u) = u `deepseq` ()
@@ -79,3 +107,21 @@ instance NFData (Digest a) where
 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

@@ -17,12 +17,11 @@ module Crypto.Hash.Whirlpool ( Whirlpool (..) ) where
 import           Crypto.Hash.Types
 import           Foreign.Ptr (Ptr)
 import           Data.Data
-import           Data.Typeable
 import           Data.Word (Word8, Word32)
 
 -- | Whirlpool cryptographic hash algorithm
 data Whirlpool = Whirlpool
-    deriving (Show,Data,Typeable)
+    deriving (Show,Data)
 
 instance HashAlgorithm Whirlpool where
     type HashBlockSize           Whirlpool = 64

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/CompatPrim.hs

@@ -23,15 +23,21 @@ module Crypto.Internal.CompatPrim
     , convert4To32
     ) where
 
-import GHC.Prim
 #if !defined(ARCH_IS_LITTLE_ENDIAN) && !defined(ARCH_IS_BIG_ENDIAN)
 import Data.Memory.Endian (getSystemEndianness, Endianness(..))
 #endif
 
+#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 big endian machine, this function is a nop.
-be32Prim :: Word# -> Word#
+be32Prim :: Word32# -> Word32#
 #ifdef ARCH_IS_LITTLE_ENDIAN
 be32Prim = byteswap32Prim
 #elif defined(ARCH_IS_BIG_ENDIAN)
@@ -43,7 +49,7 @@ be32Prim w = if getSystemEndianness == LittleEndian then byteswap32Prim w else w
 -- | Byteswap Word# to or from Little Endian
 --
 -- On a little endian machine, this function is a nop.
-le32Prim :: Word# -> Word#
+le32Prim :: Word32# -> Word32#
 #ifdef ARCH_IS_LITTLE_ENDIAN
 le32Prim w = w
 #elif defined(ARCH_IS_BIG_ENDIAN)
@@ -54,16 +60,11 @@ le32Prim w = if getSystemEndianness == LittleEndian then w else byteswap32Prim w
 
 -- | Simple compatibility for byteswap the lower 32 bits of a Word#
 -- at the primitive level
-byteswap32Prim :: Word# -> Word#
+byteswap32Prim :: Word32# -> Word32#
-#if __GLASGOW_HASKELL__ >= 708
+#if __GLASGOW_HASKELL__ >= 902
-byteswap32Prim w = byteSwap32# w
+byteswap32Prim w = wordToWord32# (byteSwap32# (word32ToWord# w))
 #else
-byteswap32Prim w =
+byteswap32Prim w = byteSwap32# 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))
 #endif
 
 -- | Combine 4 word8 [a,b,c,d] to a word32 representing [a,b,c,d]

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

@@ -9,20 +9,21 @@ module Crypto.Internal.Nat
     , type IsAtMost, type IsAtLeast
     , byteLen
     , integralNatVal
+    , type IsDiv8
     , type Div8
     , type Mod8
     ) where
 
 import           GHC.TypeLits
 
-byteLen :: (KnownNat bitlen, IsDivisibleBy8 bitlen, Num a) => proxy bitlen -> a
+byteLen :: (KnownNat bitlen, Num a) => proxy bitlen -> a
-byteLen d = fromInteger (natVal d `div` 8)
+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 bitlen n 'True  = 'True
+    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)
@@ -37,7 +38,7 @@ type family IsLE (bitlen :: Nat) (n :: Nat) (c :: Bool) where
 type IsAtMost  (bitlen :: Nat) (n :: Nat) = IsLE bitlen n (bitlen <=? n) ~ 'True
 
 type family IsGE (bitlen :: Nat) (n :: Nat) (c :: Bool) where
-    IsGE bitlen n 'True  = 'True
+    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)
@@ -120,7 +121,7 @@ type family Div8 (bitLen :: Nat) where
     Div8 n  = 8 + Div8 (n - 64)
 
 type family IsDiv8 (bitLen :: Nat) (n :: Nat) where
-    IsDiv8 bitLen 0 = 'True
+    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")
@@ -130,15 +131,15 @@ type family IsDiv8 (bitLen :: Nat) (n :: Nat) where
     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 bitLen 1 = 'False
+    IsDiv8 _ 1 = 'False
-    IsDiv8 bitLen 2 = 'False
+    IsDiv8 _ 2 = 'False
-    IsDiv8 bitLen 3 = 'False
+    IsDiv8 _ 3 = 'False
-    IsDiv8 bitLen 4 = 'False
+    IsDiv8 _ 4 = 'False
-    IsDiv8 bitLen 5 = 'False
+    IsDiv8 _ 5 = 'False
-    IsDiv8 bitLen 6 = 'False
+    IsDiv8 _ 6 = 'False
-    IsDiv8 bitLen 7 = 'False
+    IsDiv8 _ 7 = 'False
 #endif
-    IsDiv8 bitLen n = IsDiv8 n (Mod8 n)
+    IsDiv8 _ n = IsDiv8 n (Mod8 n)
 
 type family Mod8 (n :: Nat) where
     Mod8 0 = 0
@@ -207,4 +208,6 @@ type family Mod8 (n :: Nat) where
     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/Proxy.hs

@@ -1,13 +0,0 @@
--- |
--- Module      : Crypto.Internal.Proxy
--- License     : BSD-style
--- Maintainer  : Vincent Hanquez <vincent@snarc.org>
--- Stability   : experimental
--- Portability : Good
---
-module Crypto.Internal.Proxy
-    ( Proxy(..)
-    ) where
-
--- | A type witness for 'a' as phantom type
-data Proxy a = Proxy

Crypto/KDF/Argon2.hs

@@ -25,7 +25,7 @@ module Crypto.KDF.Argon2
     , hash
     ) where
 
-import           Crypto.Internal.ByteArray (ScrubbedBytes, ByteArray, ByteArrayAccess)
+import           Crypto.Internal.ByteArray (ByteArray, ByteArrayAccess)
 import qualified Crypto.Internal.ByteArray as B
 import           Crypto.Error
 import           Control.Monad (when)

Crypto/KDF/BCrypt.hs

@@ -11,7 +11,7 @@
 -- >>> validatePassword password bcryptHash
 -- >>> True
 -- >>> let otherPassword = B.pack "otherpassword"
--- >>> otherHash <- hashPassword 12 otherPasssword :: IO B.ByteString
+-- >>> otherHash <- hashPassword 12 otherPassword :: IO B.ByteString
 -- >>> validatePassword otherPassword otherHash
 -- >>> True
 --
@@ -52,11 +52,16 @@ module Crypto.KDF.BCrypt
     )
 where
 
-import           Control.Monad (unless, when)
+import           Control.Monad                    (forM_, unless, when)
-import           Crypto.Cipher.Blowfish.Primitive (eksBlowfish, encrypt)
+import           Crypto.Cipher.Blowfish.Primitive (Context, createKeySchedule,
-import           Crypto.Random (MonadRandom, getRandomBytes)
+                                                   encrypt, expandKey,
-import           Data.ByteArray (ByteArrayAccess, ByteArray, Bytes)
+                                                   expandKeyWithSalt,
-import qualified Data.ByteArray as B
+                                                   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
 
@@ -136,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]
@@ -159,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/PBKDF2.hs

@@ -24,7 +24,7 @@ import           Data.Word
 import           Data.Bits
 import           Foreign.Marshal.Alloc
 import           Foreign.Ptr (plusPtr, Ptr)
-import           Foreign.C.Types (CUInt(..), CInt(..), CSize(..))
+import           Foreign.C.Types (CUInt(..), CSize(..))
 
 import           Crypto.Hash (HashAlgorithm)
 import qualified Crypto.MAC.HMAC as HMAC

Crypto/MAC/CMAC.hs

@@ -94,7 +94,7 @@ bxor = B.xor
 
 
 cipherIPT :: BlockCipher k => k -> [Word8]
-cipherIPT = expandIPT . blockSize   where
+cipherIPT = expandIPT . blockSize
 
 -- Data type which represents the smallest irreducibule binary polynomial
 -- against specified degree.

Crypto/MAC/HMAC.hs

@@ -12,6 +12,7 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Crypto.MAC.HMAC
     ( hmac
+    , hmacLazy
     , HMAC(..)
     -- * Incremental
     , Context(..)
@@ -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
+-- | 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

@@ -33,6 +33,11 @@ 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)
 

Crypto/Number/Basic.hs

@@ -13,8 +13,11 @@ module Crypto.Number.Basic
     , log2
     , numBits
     , numBytes
+    , asPowerOf2AndOdd
     ) where
 
+import Data.Bits
+
 import Crypto.Number.Compat
 
 -- | @sqrti@ returns two integers @(l,b)@ so that @l <= sqrt i <= b@.
@@ -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,7 +72,11 @@ 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)
+#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)
@@ -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
@@ -132,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
@@ -146,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 $
@@ -157,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

@@ -16,14 +16,15 @@ module Crypto.Number.F2m
     , mulF2m
     , squareF2m'
     , squareF2m
+    , powF2m
     , modF2m
+    , sqrtF2m
     , invF2m
     , divF2m
     ) where
 
 import Data.Bits (xor, shift, testBit, setBit)
 import Data.List
-import Crypto.Internal.Imports
 import Crypto.Number.Basic
 
 -- | Binary Polynomial represented by an integer
@@ -67,8 +68,8 @@ mulF2m :: BinaryPolynomial -- ^ Modulus
 mulF2m fx n1 n2
     |    fx < 0
       || n1 < 0
-      || n2 < 0 = error "mulF2m: negative number represent no binary binary polynomial"
+      || n2 < 0 = error "mulF2m: negative number represent no binary polynomial"
-    | fx == 0   = error "modF2m: cannot multiply modulo zero 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
@@ -97,10 +98,37 @@ squareF2m fx = modF2m fx . squareF2m'
 squareF2m' :: Integer
            -> Integer
 squareF2m' n
-    | n < 0     = error "mulF2m: negative number represent no binary binary polynomial"
+    | 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

Crypto/Number/ModArithmetic.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DeriveDataTypeable #-}
 -- |
 -- Module      : Crypto.Number.ModArithmetic
 -- License     : BSD-style
@@ -15,20 +14,23 @@ module Crypto.Number.ModArithmetic
     -- * 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
+-- Before GHC 8.4.2, powModSecInteger is missing from integer-gmp,
--- (which is now integer-gmp2), so is has the same security as old
+-- so expSafe has the same security as expFast.
--- ghc version.
 expSafe :: Integer -- ^ base
-        -> Integer -- ^ exponant
+        -> Integer -- ^ exponent
         -> Integer -- ^ modulo
         -> Integer -- ^ result
 expSafe b e m
@@ -52,14 +53,14 @@ 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
@@ -71,7 +72,7 @@ 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
 
@@ -95,3 +96,122 @@ 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,8 +19,6 @@ module Crypto.Number.Prime
     , isCoprime
     ) where
 
-import Crypto.Internal.Imports
-
 import Crypto.Number.Compat
 import Crypto.Number.Generate
 import Crypto.Number.Basic (sqrti, gcde)
@@ -129,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

Crypto/Number/Serialize.hs

@@ -35,6 +35,7 @@ i2osp m = B.allocAndFreeze sz (\p -> Internal.i2osp m p sz >> return ())
 -- | 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

Crypto/Number/Serialize/Internal.hs

@@ -23,7 +23,7 @@ import           Foreign.Storable
 
 -- | 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
@@ -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

@@ -42,15 +42,14 @@ module Crypto.OTP
     )
 where
 
-import           Data.Bits (shiftL, shiftR, (.&.), (.|.))
+import           Data.Bits (shiftL, (.&.), (.|.))
 import           Data.ByteArray.Mapping (fromW64BE)
 import           Data.List (elemIndex)
 import           Data.Word
-import           Foreign.Storable (poke)
 import           Control.Monad (unless)
 import           Crypto.Hash (HashAlgorithm, SHA1(..))
 import           Crypto.MAC.HMAC
-import           Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray, Bytes)
+import           Crypto.Internal.ByteArray (ByteArrayAccess, Bytes)
 import qualified Crypto.Internal.ByteArray as B
 
 

Crypto/PubKey/Curve25519.hs

@@ -33,9 +33,8 @@ import           GHC.Ptr
 import           Crypto.Error
 import           Crypto.Internal.Compat
 import           Crypto.Internal.Imports
-import           Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray, ScrubbedBytes, Bytes, withByteArray)
+import           Crypto.Internal.ByteArray (ByteArrayAccess, ScrubbedBytes, Bytes, withByteArray)
 import qualified Crypto.Internal.ByteArray as B
-import           Crypto.Error (CryptoFailable(..))
 import           Crypto.Random
 
 -- | A Curve25519 Secret key

Crypto/PubKey/Curve448.hs

@@ -12,7 +12,6 @@
 -- data types are compatible with the encoding specified in RFC 7748.
 --
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MagicHash #-}
 module Crypto.PubKey.Curve448
     ( SecretKey
     , PublicKey
@@ -29,7 +28,6 @@ module Crypto.PubKey.Curve448
 
 import           Data.Word
 import           Foreign.Ptr
-import           GHC.Ptr
 
 import           Crypto.Error
 import           Crypto.Random

Crypto/PubKey/DH.hs

@@ -33,7 +33,7 @@ data Params = Params
     { params_p :: Integer
     , params_g :: Integer
     , params_bits :: Int
-    } deriving (Show,Read,Eq,Data,Typeable)
+    } deriving (Show,Read,Eq,Data)
 
 instance NFData Params where
     rnf (Params p g bits) = rnf p `seq` rnf g `seq` bits `seq` ()

Crypto/PubKey/DSA.hs

@@ -28,18 +28,17 @@ module Crypto.PubKey.DSA
     , toPrivateKey
     ) where
 
-import           Crypto.Random.Types
+
-import           Data.Bits (testBit)
+import Data.Data
-import           Data.Data
+import Data.Maybe
-import           Data.Maybe
+
-import           Crypto.Number.Basic (numBits)
+import Crypto.Number.ModArithmetic (expFast, expSafe, inverse)
-import           Crypto.Number.ModArithmetic (expFast, expSafe, inverse)
+import Crypto.Number.Generate
-import           Crypto.Number.Serialize
+import Crypto.Internal.ByteArray (ByteArrayAccess)
-import           Crypto.Number.Generate
+import Crypto.Internal.Imports
-import           Crypto.Internal.ByteArray (ByteArrayAccess(length), convert, index, dropView, takeView)
+import Crypto.Hash
-import           Crypto.Internal.Imports
+import Crypto.PubKey.Internal (dsaTruncHash)
-import           Crypto.Hash
+import Crypto.Random.Types
-import           Prelude hiding (length)
 
 -- | DSA Public Number, usually embedded in DSA Public Key
 type PublicNumber = Integer
@@ -52,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` ()
@@ -61,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` ()
@@ -70,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` ()
@@ -82,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` ()
@@ -126,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
 
@@ -148,11 +147,8 @@ verify hashAlg pk (Signature r s) m
     | otherwise                            = v == r
     where (Params p g q) = public_params pk
           y       = public_y pk
-          hm      = os2ip . truncateHash $ hashWith hashAlg m
+          hm      = dsaTruncHash hashAlg m q
-
           w       = fromJust $ inverse s q
           u1      = (hm*w) `mod` q
           u2      = (r*w) `mod` q
           v       = ((expFast g u1 p) * (expFast y u2 p)) `mod` p `mod` q
-          -- if the hash is larger than the size of q, truncate it; FIXME: deal with the case of a q not evenly divisible by 8
-          truncateHash h = if numBits (os2ip h) > numBits q then takeView h (numBits q `div` 8) else dropView h 0

Crypto/PubKey/ECC/ECDSA.hs

@@ -11,45 +11,46 @@ module Crypto.PubKey.ECC.ECDSA
     , toPublicKey
     , toPrivateKey
     , signWith
+    , signDigestWith
     , sign
+    , signDigest
     , verify
+    , verifyDigest
     ) where
 
 import Control.Monad
-import Crypto.Random.Types
-import Data.Bits (shiftR)
-import Crypto.Internal.ByteArray (ByteArrayAccess)
 import Data.Data
-import Crypto.Number.Basic (numBits)
+
+import Crypto.Hash
+import Crypto.Internal.ByteArray (ByteArrayAccess)
 import Crypto.Number.ModArithmetic (inverse)
-import Crypto.Number.Serialize
 import Crypto.Number.Generate
 import Crypto.PubKey.ECC.Types
 import Crypto.PubKey.ECC.Prim
-import Crypto.Hash
+import Crypto.PubKey.Internal (dsaTruncHashDigest)
-import Crypto.Hash.Types (hashDigestSize)
+import Crypto.Random.Types
 
 -- | Represent a ECDSA signature namely R and S.
 data Signature = Signature
     { sign_r :: Integer -- ^ ECDSA r
     , sign_s :: Integer -- ^ ECDSA s
-    } deriving (Show,Read,Eq,Data,Typeable)
+    } deriving (Show,Read,Eq,Data)
 
 -- | ECDSA Private Key.
 data PrivateKey = PrivateKey
     { private_curve :: Curve
     , private_d     :: PrivateNumber
-    } deriving (Show,Read,Eq,Data,Typeable)
+    } deriving (Show,Read,Eq,Data)
 
 -- | ECDSA Public Key.
 data PublicKey = PublicKey
     { public_curve :: Curve
     , public_q     :: PublicPoint
-    } deriving (Show,Read,Eq,Data,Typeable)
+    } deriving (Show,Read,Eq,Data)
 
 -- | ECDSA Key Pair.
 data KeyPair = KeyPair Curve PublicPoint PrivateNumber
-    deriving (Show,Read,Eq,Data,Typeable)
+    deriving (Show,Read,Eq,Data)
 
 -- | Public key of a ECDSA Key pair.
 toPublicKey :: KeyPair -> PublicKey
@@ -59,17 +60,16 @@ toPublicKey (KeyPair curve pub _) = PublicKey curve pub
 toPrivateKey :: KeyPair -> PrivateKey
 toPrivateKey (KeyPair curve _ priv) = PrivateKey curve priv
 
--- | Sign message using the private key and an explicit k number.
+-- | Sign digest using the private key and an explicit k number.
 --
 -- /WARNING:/ Vulnerable to timing attacks.
-signWith :: (ByteArrayAccess msg, HashAlgorithm hash)
+signDigestWith :: HashAlgorithm hash
-         => Integer    -- ^ k random number
+               => Integer     -- ^ k random number
-         -> PrivateKey -- ^ private key
+               -> PrivateKey  -- ^ private key
-         -> hash       -- ^ hash function
+               -> Digest hash -- ^ digest to sign
-         -> msg        -- ^ message to sign
+               -> Maybe Signature
-         -> Maybe Signature
+signDigestWith k (PrivateKey curve d) digest = do
-signWith k (PrivateKey curve d) hashAlg msg = do
+    let z = dsaTruncHashDigest digest n
-    let z = tHash hashAlg msg n
         CurveCommon _ _ g n _ = common_curve curve
     let point = pointMul curve k g
     r <- case point of
@@ -80,26 +80,44 @@ signWith k (PrivateKey curve d) hashAlg msg = do
     when (r == 0 || s == 0) Nothing
     return $ Signature r s
 
+-- | Sign message using the private key and an explicit k number.
+--
+-- /WARNING:/ Vulnerable to timing attacks.
+signWith :: (ByteArrayAccess msg, HashAlgorithm hash)
+         => Integer    -- ^ k random number
+         -> PrivateKey -- ^ private key
+         -> hash       -- ^ hash function
+         -> msg        -- ^ message to sign
+         -> Maybe Signature
+signWith k pk hashAlg msg = signDigestWith k pk (hashWith hashAlg msg)
+
+-- | Sign digest using the private key.
+--
+-- /WARNING:/ Vulnerable to timing attacks.
+signDigest :: (HashAlgorithm hash, MonadRandom m)
+           => PrivateKey -> Digest hash -> m Signature
+signDigest pk digest = do
+    k <- generateBetween 1 (n - 1)
+    case signDigestWith k pk digest of
+         Nothing  -> signDigest pk digest
+         Just sig -> return sig
+  where n = ecc_n . common_curve $ private_curve pk
+
 -- | Sign message using the private key.
 --
 -- /WARNING:/ Vulnerable to timing attacks.
 sign :: (ByteArrayAccess msg, HashAlgorithm hash, MonadRandom m)
      => PrivateKey -> hash -> msg -> m Signature
-sign pk hashAlg msg = do
+sign pk hashAlg msg = signDigest pk (hashWith hashAlg msg)
-    k <- generateBetween 1 (n - 1)
-    case signWith k pk hashAlg msg of
-         Nothing  -> sign pk hashAlg msg
-         Just sig -> return sig
-  where n = ecc_n . common_curve $ private_curve pk
 
--- | Verify a bytestring using the public key.
+-- | Verify a digest using the public key.
-verify :: (ByteArrayAccess msg, HashAlgorithm hash) => hash -> PublicKey -> Signature -> msg -> Bool
+verifyDigest :: HashAlgorithm hash => PublicKey -> Signature -> Digest hash -> Bool
-verify _       (PublicKey _ PointO) _ _ = False
+verifyDigest (PublicKey _ PointO) _ _ = False
-verify hashAlg pk@(PublicKey curve q) (Signature r s) msg
+verifyDigest pk@(PublicKey curve q) (Signature r s) digest
     | r < 1 || r >= n || s < 1 || s >= n = False
     | otherwise = maybe False (r ==) $ do
         w <- inverse s n
-        let z  = tHash hashAlg msg n
+        let z  = dsaTruncHashDigest digest n
             u1 = z * w `mod` n
             u2 = r * w `mod` n
             x  = pointAddTwoMuls curve u1 g u2 q
@@ -110,10 +128,6 @@ verify hashAlg pk@(PublicKey curve q) (Signature r s) msg
         g = ecc_g cc
         cc = common_curve $ public_curve pk
 
--- | Truncate and hash.
+-- | Verify a bytestring using the public key.
-tHash :: (ByteArrayAccess msg, HashAlgorithm hash) => hash -> msg -> Integer -> Integer
+verify :: (ByteArrayAccess msg, HashAlgorithm hash) => hash -> PublicKey -> Signature -> msg -> Bool
-tHash hashAlg m n
+verify hashAlg pk sig msg = verifyDigest pk sig (hashWith hashAlg msg)
-    | d > 0 = shiftR e d
-    | otherwise = e
-  where e = os2ip $ hashWith hashAlg m
-        d = hashDigestSize hashAlg * 8 - numBits n

Crypto/PubKey/ECC/P256.hs

@@ -8,7 +8,6 @@
 -- P256 support
 --
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE EmptyDataDecls #-}
 {-# OPTIONS_GHC -fno-warn-unused-binds #-}
 module Crypto.PubKey.ECC.P256
@@ -22,7 +21,9 @@ module Crypto.PubKey.ECC.P256
     , pointDh
     , pointsMulVarTime
     , pointIsValid
+    , pointIsAtInfinity
     , toPoint
+    , pointX
     , pointToIntegers
     , pointFromIntegers
     , pointToBinary
@@ -31,10 +32,13 @@ module Crypto.PubKey.ECC.P256
     -- * Scalar arithmetic
     , scalarGenerate
     , scalarZero
+    , scalarN
     , scalarIsZero
     , scalarAdd
     , scalarSub
+    , scalarMul
     , scalarInv
+    , scalarInvSafe
     , scalarCmp
     , scalarFromBinary
     , scalarToBinary
@@ -45,7 +49,6 @@ module Crypto.PubKey.ECC.P256
 import           Data.Word
 import           Foreign.Ptr
 import           Foreign.C.Types
-import           Control.Monad
 
 import           Crypto.Internal.Compat
 import           Crypto.Internal.Imports
@@ -77,6 +80,9 @@ data P256Scalar
 data P256Y
 data P256X
 
+order :: Integer
+order = 0xffffffff00000000ffffffffffffffffbce6faada7179e84f3b9cac2fc632551
+
 ------------------------------------------------------------------------
 -- Point methods
 ------------------------------------------------------------------------
@@ -110,7 +116,7 @@ pointAdd a b = withNewPoint $ \dx dy ->
 -- | Negate a point
 pointNegate :: Point -> Point
 pointNegate a = withNewPoint $ \dx dy ->
-    withPoint a $ \ax ay -> do
+    withPoint a $ \ax ay ->
         ccryptonite_p256e_point_negate ax ay dx dy
 
 -- | Multiply a point by a scalar
@@ -118,16 +124,16 @@ pointNegate a = withNewPoint $ \dx dy ->
 -- warning: variable time
 pointMul :: Scalar -> Point -> Point
 pointMul scalar p = withNewPoint $ \dx dy ->
-    withScalar scalar $ \n -> withPoint p $ \px py -> withScalarZero $ \nzero ->
+    withScalar scalar $ \n -> withPoint p $ \px py ->
-        ccryptonite_p256_points_mul_vartime nzero n px py dx dy
+        ccryptonite_p256e_point_mul n px py dx dy
 
 -- | Similar to 'pointMul', serializing the x coordinate as binary.
 -- When scalar is multiple of point order the result is all zero.
 pointDh :: ByteArray binary => Scalar -> Point -> binary
 pointDh scalar p =
     B.unsafeCreate scalarSize $ \dst -> withTempPoint $ \dx dy -> do
-        withScalar scalar $ \n -> withPoint p $ \px py -> withScalarZero $ \nzero ->
+        withScalar scalar $ \n -> withPoint p $ \px py ->
-            ccryptonite_p256_points_mul_vartime nzero n px py dx dy
+            ccryptonite_p256e_point_mul n px py dx dy
         ccryptonite_p256_to_bin (castPtr dx) dst
 
 -- | multiply the point @p with @n2 and add a lifted to curve value @n1
@@ -146,6 +152,19 @@ pointIsValid p = unsafeDoIO $ withPoint p $ \px py -> do
     r <- ccryptonite_p256_is_valid_point px py
     return (r /= 0)
 
+-- | Check if a 'Point' is the point at infinity
+pointIsAtInfinity :: Point -> Bool
+pointIsAtInfinity (Point b) = constAllZero b
+
+-- | Return the x coordinate as a 'Scalar' if the point is not at infinity
+pointX :: Point -> Maybe Scalar
+pointX p
+    | pointIsAtInfinity p = Nothing
+    | otherwise           = Just $
+        withNewScalarFreeze $ \d    ->
+        withPoint p         $ \px _ ->
+            ccryptonite_p256_mod ccryptonite_SECP256r1_n (castPtr px) (castPtr d)
+
 -- | Convert a point to (x,y) Integers
 pointToIntegers :: Point -> (Integer, Integer)
 pointToIntegers p = unsafeDoIO $ withPoint p $ \px py ->
@@ -188,12 +207,12 @@ pointFromBinary ba = unsafePointFromBinary ba >>= validatePoint
     validatePoint :: Point -> CryptoFailable Point
     validatePoint p
         | pointIsValid p = CryptoPassed p
-        | otherwise      = CryptoFailed $ CryptoError_PointCoordinatesInvalid
+        | otherwise      = CryptoFailed CryptoError_PointCoordinatesInvalid
 
 -- | Convert from binary to a point, possibly invalid
 unsafePointFromBinary :: ByteArrayAccess ba => ba -> CryptoFailable Point
 unsafePointFromBinary ba
-    | B.length ba /= pointSize = CryptoFailed $ CryptoError_PublicKeySizeInvalid
+    | B.length ba /= pointSize = CryptoFailed CryptoError_PublicKeySizeInvalid
     | otherwise                =
         CryptoPassed $ withNewPoint $ \px py -> B.withByteArray ba $ \src -> do
             ccryptonite_p256_from_bin src                        (castPtr px)
@@ -216,40 +235,39 @@ scalarGenerate = unwrap . scalarFromBinary . witness <$> getRandomBytes 32
 scalarZero :: Scalar
 scalarZero = withNewScalarFreeze $ \d -> ccryptonite_p256_init d
 
+-- | The scalar representing the curve order
+scalarN :: Scalar
+scalarN = throwCryptoError (scalarFromInteger order)
+
 -- | Check if the scalar is 0
 scalarIsZero :: Scalar -> Bool
 scalarIsZero s = unsafeDoIO $ withScalar s $ \d -> do
     result <- ccryptonite_p256_is_zero d
     return $ result /= 0
 
-scalarNeedReducing :: Ptr P256Scalar -> IO Bool
-scalarNeedReducing d = do
-    c <- ccryptonite_p256_cmp d ccryptonite_SECP256r1_n
-    return (c >= 0)
-
 -- | Perform addition between two scalars
 --
 -- > a + b
 scalarAdd :: Scalar -> Scalar -> Scalar
 scalarAdd a b =
-    withNewScalarFreeze $ \d -> withScalar a $ \pa -> withScalar b $ \pb -> do
+    withNewScalarFreeze $ \d -> withScalar a $ \pa -> withScalar b $ \pb ->
-        carry <- ccryptonite_p256_add pa pb d
+        ccryptonite_p256e_modadd ccryptonite_SECP256r1_n pa pb d
-        when (carry /= 0) $ void $ ccryptonite_p256_sub d ccryptonite_SECP256r1_n d
-        needReducing <- scalarNeedReducing d
-        when needReducing $ do
-            ccryptonite_p256_mod ccryptonite_SECP256r1_n d d
 
 -- | Perform subtraction between two scalars
 --
 -- > a - b
 scalarSub :: Scalar -> Scalar -> Scalar
 scalarSub a b =
-    withNewScalarFreeze $ \d -> withScalar a $ \pa -> withScalar b $ \pb -> do
+    withNewScalarFreeze $ \d -> withScalar a $ \pa -> withScalar b $ \pb ->
-        borrow <- ccryptonite_p256_sub pa pb d
+        ccryptonite_p256e_modsub ccryptonite_SECP256r1_n pa pb d
-        when (borrow /= 0) $ void $ ccryptonite_p256_add d ccryptonite_SECP256r1_n d
+
-        --needReducing <- scalarNeedReducing d
+-- | Perform multiplication between two scalars
-        --when needReducing $ do
+--
-        --    ccryptonite_p256_mod ccryptonite_SECP256r1_n d d
+-- > a * b
+scalarMul :: Scalar -> Scalar -> Scalar
+scalarMul a b =
+    withNewScalarFreeze $ \d -> withScalar a $ \pa -> withScalar b $ \pb ->
+         ccryptonite_p256_modmul ccryptonite_SECP256r1_n pa 0 pb d
 
 -- | Give the inverse of the scalar
 --
@@ -261,6 +279,14 @@ scalarInv a =
     withNewScalarFreeze $ \b -> withScalar a $ \pa ->
         ccryptonite_p256_modinv_vartime ccryptonite_SECP256r1_n pa b
 
+-- | Give the inverse of the scalar using safe exponentiation
+--
+-- > 1 / a
+scalarInvSafe :: Scalar -> Scalar
+scalarInvSafe a =
+    withNewScalarFreeze $ \b -> withScalar a $ \pa ->
+        ccryptonite_p256e_scalar_invert pa b
+
 -- | Compare 2 Scalar
 scalarCmp :: Scalar -> Scalar -> Ordering
 scalarCmp a b = unsafeDoIO $
@@ -271,7 +297,7 @@ scalarCmp a b = unsafeDoIO $
 -- | convert a scalar from binary
 scalarFromBinary :: ByteArrayAccess ba => ba -> CryptoFailable Scalar
 scalarFromBinary ba
-    | B.length ba /= scalarSize = CryptoFailed $ CryptoError_SecretKeySizeInvalid
+    | B.length ba /= scalarSize = CryptoFailed CryptoError_SecretKeySizeInvalid
     | otherwise                 =
         CryptoPassed $ withNewScalarFreeze $ \p -> B.withByteArray ba $ \b ->
             ccryptonite_p256_from_bin b p
@@ -312,18 +338,9 @@ withNewScalarFreeze f = Scalar $ B.allocAndFreeze scalarSize f
 withTempPoint :: (Ptr P256X -> Ptr P256Y -> IO a) -> IO a
 withTempPoint f = allocTempScrubbed pointSize (\p -> let px = castPtr p in f px (pxToPy px))
 
-withTempScalar :: (Ptr P256Scalar -> IO a) -> IO a
-withTempScalar f = allocTempScrubbed scalarSize (f . castPtr)
-
 withScalar :: Scalar -> (Ptr P256Scalar -> IO a) -> IO a
 withScalar (Scalar d) f = B.withByteArray d f
 
-withScalarZero :: (Ptr P256Scalar -> IO a) -> IO a
-withScalarZero f =
-    withTempScalar $ \d -> do
-        ccryptonite_p256_init d
-        f d
-
 allocTemp :: Int -> (Ptr Word8 -> IO a) -> IO a
 allocTemp n f = ignoreSnd <$> B.allocRet n f
   where
@@ -352,18 +369,20 @@ foreign import ccall "cryptonite_p256_is_zero"
     ccryptonite_p256_is_zero :: Ptr P256Scalar -> IO CInt
 foreign import ccall "cryptonite_p256_clear"
     ccryptonite_p256_clear :: Ptr P256Scalar -> IO ()
-foreign import ccall "cryptonite_p256_add"
+foreign import ccall "cryptonite_p256e_modadd"
-    ccryptonite_p256_add :: Ptr P256Scalar -> Ptr P256Scalar -> Ptr P256Scalar -> IO CInt
+    ccryptonite_p256e_modadd :: Ptr P256Scalar -> Ptr P256Scalar -> Ptr P256Scalar -> Ptr P256Scalar -> IO ()
 foreign import ccall "cryptonite_p256_add_d"
     ccryptonite_p256_add_d :: Ptr P256Scalar -> P256Digit -> Ptr P256Scalar -> IO CInt
-foreign import ccall "cryptonite_p256_sub"
+foreign import ccall "cryptonite_p256e_modsub"
-    ccryptonite_p256_sub :: Ptr P256Scalar -> Ptr P256Scalar -> Ptr P256Scalar -> IO CInt
+    ccryptonite_p256e_modsub :: Ptr P256Scalar -> Ptr P256Scalar -> Ptr P256Scalar -> Ptr P256Scalar -> IO ()
 foreign import ccall "cryptonite_p256_cmp"
     ccryptonite_p256_cmp :: Ptr P256Scalar -> Ptr P256Scalar -> IO CInt
 foreign import ccall "cryptonite_p256_mod"
     ccryptonite_p256_mod :: Ptr P256Scalar -> Ptr P256Scalar -> Ptr P256Scalar -> IO ()
 foreign import ccall "cryptonite_p256_modmul"
     ccryptonite_p256_modmul :: Ptr P256Scalar -> Ptr P256Scalar -> P256Digit -> Ptr P256Scalar -> Ptr P256Scalar -> IO ()
+foreign import ccall "cryptonite_p256e_scalar_invert"
+    ccryptonite_p256e_scalar_invert :: Ptr P256Scalar -> Ptr P256Scalar -> IO ()
 --foreign import ccall "cryptonite_p256_modinv"
 --    ccryptonite_p256_modinv :: Ptr P256Scalar -> Ptr P256Scalar -> Ptr P256Scalar -> IO ()
 foreign import ccall "cryptonite_p256_modinv_vartime"
@@ -384,6 +403,13 @@ foreign import ccall "cryptonite_p256e_point_negate"
                                    -> Ptr P256X -> Ptr P256Y
                                    -> IO ()
 
+-- compute (out_x,out_y) = n * (in_x,in_y)
+foreign import ccall "cryptonite_p256e_point_mul"
+    ccryptonite_p256e_point_mul :: Ptr P256Scalar -- n
+                                -> Ptr P256X -> Ptr P256Y -- in_{x,y}
+                                -> Ptr P256X -> Ptr P256Y -- out_{x,y}
+                                -> IO ()
+
 -- compute (out_x,out,y) = n1 * G + n2 * (in_x,in_y)
 foreign import ccall "cryptonite_p256_points_mul_vartime"
     ccryptonite_p256_points_mul_vartime :: Ptr P256Scalar -- n1

Crypto/PubKey/ECC/Types.hs

@@ -33,7 +33,7 @@ import           Crypto.Number.Basic (numBits)
 -- | Define either a binary curve or a prime curve.
 data Curve = CurveF2m CurveBinary -- ^ 𝔽(2^m)
            | CurveFP  CurvePrime  -- ^ 𝔽p
-           deriving (Show,Read,Eq,Data,Typeable)
+           deriving (Show,Read,Eq,Data)
 
 -- | ECC Public Point
 type PublicPoint = Point
@@ -44,7 +44,7 @@ type PrivateNumber = Integer
 -- | Define a point on a curve.
 data Point = Point Integer Integer
            | PointO -- ^ Point at Infinity
-           deriving (Show,Read,Eq,Data,Typeable)
+           deriving (Show,Read,Eq,Data)
 
 instance NFData Point where
     rnf (Point x y) = x `seq` y `seq` ()
@@ -53,7 +53,7 @@ instance NFData Point where
 -- | Define an elliptic curve in 𝔽(2^m).
 -- The firt parameter is the Integer representatioin of the irreducible polynomial f(x).
 data CurveBinary = CurveBinary Integer CurveCommon
-    deriving (Show,Read,Eq,Data,Typeable)
+    deriving (Show,Read,Eq,Data)
 
 instance NFData CurveBinary where
     rnf (CurveBinary i cc) = i `seq` cc `seq` ()
@@ -61,7 +61,7 @@ instance NFData CurveBinary where
 -- | Define an elliptic curve in 𝔽p.
 -- The first parameter is the Prime Number.
 data CurvePrime = CurvePrime Integer CurveCommon
-    deriving (Show,Read,Eq,Data,Typeable)
+    deriving (Show,Read,Eq,Data)
 
 -- | Parameters in common between binary and prime curves.
 common_curve :: Curve -> CurveCommon
@@ -84,7 +84,7 @@ data CurveCommon = CurveCommon
     , ecc_g :: Point   -- ^ base point
     , ecc_n :: Integer -- ^ order of G
     , ecc_h :: Integer -- ^ cofactor
-    } deriving (Show,Read,Eq,Data,Typeable)
+    } deriving (Show,Read,Eq,Data)
 
 -- | Define names for known recommended curves.
 data CurveName =
@@ -121,7 +121,7 @@ data CurveName =
     | SEC_t409r1
     | SEC_t571k1
     | SEC_t571r1
-    deriving (Show,Read,Eq,Ord,Enum,Bounded,Data,Typeable)
+    deriving (Show,Read,Eq,Ord,Enum,Bounded,Data)
 
 {-
 curvesOIDs :: [ (CurveName, [Integer]) ]

Crypto/PubKey/ECDSA.hs

@@ -0,0 +1,272 @@
+-- |
+-- Module      : Crypto.PubKey.ECDSA
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Elliptic Curve Digital Signature Algorithm, with the parameterized
+-- curve implementations provided by module "Crypto.ECC".
+--
+-- Public/private key pairs can be generated using
+-- 'curveGenerateKeyPair' or decoded from binary.
+--
+-- /WARNING:/ Only curve P-256 has constant-time implementation.
+-- Signature operations with P-384 and P-521 may leak the private key.
+--
+-- Signature verification should be safe for all curves.
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Crypto.PubKey.ECDSA
+    ( EllipticCurveECDSA (..)
+    -- * Public keys
+    , PublicKey
+    , encodePublic
+    , decodePublic
+    , toPublic
+    -- * Private keys
+    , PrivateKey
+    , encodePrivate
+    , decodePrivate
+    -- * Signatures
+    , Signature(..)
+    , signatureFromIntegers
+    , signatureToIntegers
+    -- * Generation and verification
+    , signWith
+    , signDigestWith
+    , sign
+    , signDigest
+    , verify
+    , verifyDigest
+    ) where
+
+import           Control.Monad
+
+import           Crypto.ECC
+import qualified Crypto.ECC.Simple.Types as Simple
+import           Crypto.Error
+import           Crypto.Hash
+import           Crypto.Hash.Types
+import           Crypto.Internal.ByteArray (ByteArray, ByteArrayAccess)
+import           Crypto.Internal.Imports
+import           Crypto.Number.ModArithmetic (inverseFermat)
+import qualified Crypto.PubKey.ECC.P256 as P256
+import           Crypto.Random.Types
+
+import           Data.Bits
+import qualified Data.ByteArray as B
+import           Data.Data
+
+import           Foreign.Ptr (Ptr)
+import           Foreign.Storable (peekByteOff, pokeByteOff)
+
+-- | Represent a ECDSA signature namely R and S.
+data Signature curve = Signature
+    { sign_r :: Scalar curve -- ^ ECDSA r
+    , sign_s :: Scalar curve -- ^ ECDSA s
+    }
+
+deriving instance Eq (Scalar curve) => Eq (Signature curve)
+deriving instance Show (Scalar curve) => Show (Signature curve)
+
+instance NFData (Scalar curve) => NFData (Signature curve) where
+    rnf (Signature r s) = rnf r `seq` rnf s `seq` ()
+
+-- | ECDSA Public Key.
+type PublicKey curve = Point curve
+
+-- | ECDSA Private Key.
+type PrivateKey curve = Scalar curve
+
+-- | Elliptic curves with ECDSA capabilities.
+class EllipticCurveBasepointArith curve => EllipticCurveECDSA curve where
+    -- | Is a scalar in the accepted range for ECDSA
+    scalarIsValid :: proxy curve -> Scalar curve -> Bool
+
+    -- | Test whether the scalar is zero
+    scalarIsZero :: proxy curve -> Scalar curve -> Bool
+    scalarIsZero prx s = s == throwCryptoError (scalarFromInteger prx 0)
+
+    -- | Scalar inversion modulo the curve order
+    scalarInv :: proxy curve -> Scalar curve -> Maybe (Scalar curve)
+
+    -- | Return the point X coordinate as a scalar
+    pointX :: proxy curve -> Point curve -> Maybe (Scalar curve)
+
+instance EllipticCurveECDSA Curve_P256R1 where
+    scalarIsValid _ s = not (P256.scalarIsZero s)
+                            && P256.scalarCmp s P256.scalarN == LT
+
+    scalarIsZero _ = P256.scalarIsZero
+
+    scalarInv _ s = let inv = P256.scalarInvSafe s
+                     in if P256.scalarIsZero inv then Nothing else Just inv
+
+    pointX _  = P256.pointX
+
+instance EllipticCurveECDSA Curve_P384R1 where
+    scalarIsValid _ = ecScalarIsValid (Proxy :: Proxy Simple.SEC_p384r1)
+
+    scalarIsZero _ = ecScalarIsZero
+
+    scalarInv _ = ecScalarInv (Proxy :: Proxy Simple.SEC_p384r1)
+
+    pointX _  = ecPointX (Proxy :: Proxy Simple.SEC_p384r1)
+
+instance EllipticCurveECDSA Curve_P521R1 where
+    scalarIsValid _ = ecScalarIsValid (Proxy :: Proxy Simple.SEC_p521r1)
+
+    scalarIsZero _ = ecScalarIsZero
+
+    scalarInv _ = ecScalarInv (Proxy :: Proxy Simple.SEC_p521r1)
+
+    pointX _  = ecPointX (Proxy :: Proxy Simple.SEC_p521r1)
+
+
+-- | Create a signature from integers (R, S).
+signatureFromIntegers :: EllipticCurveECDSA curve
+                      => proxy curve -> (Integer, Integer) -> CryptoFailable (Signature curve)
+signatureFromIntegers prx (r, s) =
+    liftA2 Signature (scalarFromInteger prx r) (scalarFromInteger prx s)
+
+-- | Get integers (R, S) from a signature.
+--
+-- The values can then be used to encode the signature to binary with
+-- ASN.1.
+signatureToIntegers :: EllipticCurveECDSA curve
+                    => proxy curve -> Signature curve -> (Integer, Integer)
+signatureToIntegers prx sig =
+    (scalarToInteger prx $ sign_r sig, scalarToInteger prx $ sign_s sig)
+
+-- | Encode a public key into binary form, i.e. the uncompressed encoding
+-- referenced from <https://tools.ietf.org/html/rfc5480 RFC 5480> section 2.2.
+encodePublic :: (EllipticCurve curve, ByteArray bs)
+             => proxy curve -> PublicKey curve -> bs
+encodePublic = encodePoint
+
+-- | Try to decode the binary form of a public key.
+decodePublic :: (EllipticCurve curve, ByteArray bs)
+             => proxy curve -> bs -> CryptoFailable (PublicKey curve)
+decodePublic = decodePoint
+
+-- | Encode a private key into binary form, i.e. the @privateKey@ field
+-- described in <https://tools.ietf.org/html/rfc5915 RFC 5915>.
+encodePrivate :: (EllipticCurveECDSA curve, ByteArray bs)
+              => proxy curve -> PrivateKey curve -> bs
+encodePrivate = encodeScalar
+
+-- | Try to decode the binary form of a private key.
+decodePrivate :: (EllipticCurveECDSA curve, ByteArray bs)
+              => proxy curve -> bs -> CryptoFailable (PrivateKey curve)
+decodePrivate = decodeScalar
+
+-- | Create a public key from a private key.
+toPublic :: EllipticCurveECDSA curve
+         => proxy curve -> PrivateKey curve -> PublicKey curve
+toPublic = pointBaseSmul
+
+-- | Sign digest using the private key and an explicit k scalar.
+signDigestWith :: (EllipticCurveECDSA curve, HashAlgorithm hash)
+               => proxy curve -> Scalar curve -> PrivateKey curve -> Digest hash -> Maybe (Signature curve)
+signDigestWith prx k d digest = do
+    let z = tHashDigest prx digest
+        point = pointBaseSmul prx k
+    r <- pointX prx point
+    kInv <- scalarInv prx k
+    let s = scalarMul prx kInv (scalarAdd prx z (scalarMul prx r d))
+    when (scalarIsZero prx r || scalarIsZero prx s) Nothing
+    return $ Signature r s
+
+-- | Sign message using the private key and an explicit k scalar.
+signWith :: (EllipticCurveECDSA curve, ByteArrayAccess msg, HashAlgorithm hash)
+         => proxy curve -> Scalar curve -> PrivateKey curve -> hash -> msg -> Maybe (Signature curve)
+signWith prx k d hashAlg msg = signDigestWith prx k d (hashWith hashAlg msg)
+
+-- | Sign a digest using hash and private key.
+signDigest :: (EllipticCurveECDSA curve, MonadRandom m, HashAlgorithm hash)
+           => proxy curve -> PrivateKey curve -> Digest hash -> m (Signature curve)
+signDigest prx pk digest = do
+    k <- curveGenerateScalar prx
+    case signDigestWith prx k pk digest of
+        Nothing  -> signDigest prx pk digest
+        Just sig -> return sig
+
+-- | Sign a message using hash and private key.
+sign :: (EllipticCurveECDSA curve, MonadRandom m, ByteArrayAccess msg, HashAlgorithm hash)
+     => proxy curve -> PrivateKey curve -> hash -> msg -> m (Signature curve)
+sign prx pk hashAlg msg = signDigest prx pk (hashWith hashAlg msg)
+
+-- | Verify a digest using hash and public key.
+verifyDigest :: (EllipticCurveECDSA curve, HashAlgorithm hash)
+       => proxy curve -> PublicKey curve -> Signature curve -> Digest hash -> Bool
+verifyDigest prx q (Signature r s) digest
+    | not (scalarIsValid prx r) = False
+    | not (scalarIsValid prx s) = False
+    | otherwise = maybe False (r ==) $ do
+        w <- scalarInv prx s
+        let z  = tHashDigest prx digest
+            u1 = scalarMul prx z w
+            u2 = scalarMul prx r w
+            x  = pointsSmulVarTime prx u1 u2 q
+        pointX prx x
+    -- Note: precondition q /= PointO is not tested because we assume
+    -- point decoding never decodes point at infinity.
+
+-- | Verify a signature using hash and public key.
+verify :: (EllipticCurveECDSA curve, ByteArrayAccess msg, HashAlgorithm hash)
+       => proxy curve -> hash -> PublicKey curve -> Signature curve -> msg -> Bool
+verify prx hashAlg q sig msg = verifyDigest prx q sig (hashWith hashAlg msg)
+
+-- | Truncate a digest based on curve order size.
+tHashDigest :: (EllipticCurveECDSA curve, HashAlgorithm hash)
+            => proxy curve -> Digest hash -> Scalar curve
+tHashDigest prx (Digest digest) = throwCryptoError $ decodeScalar prx encoded
+  where m      = curveOrderBits prx
+        d      = m - B.length digest * 8
+        (n, r) = m `divMod` 8
+        n'     = if r > 0 then succ n else n
+
+        encoded
+            | d >  0    = B.zero (n' - B.length digest) `B.append` digest
+            | d == 0    = digest
+            | r == 0    = B.take n digest
+            | otherwise = shiftBytes digest
+
+        shiftBytes bs = B.allocAndFreeze n' $ \dst ->
+            B.withByteArray bs $ \src -> go dst src 0 0
+
+        go :: Ptr Word8 -> Ptr Word8 -> Word8 -> Int -> IO ()
+        go dst src !a i
+            | i >= n'   = return ()
+            | otherwise = do
+                b <- peekByteOff src i
+                pokeByteOff dst i (unsafeShiftR b (8 - r) .|. unsafeShiftL a r)
+                go dst src b (succ i)
+
+
+ecScalarIsValid :: Simple.Curve c => proxy c -> Simple.Scalar c -> Bool
+ecScalarIsValid prx (Simple.Scalar s) = s > 0 && s < n
+  where n = Simple.curveEccN $ Simple.curveParameters prx
+
+ecScalarIsZero :: forall curve . Simple.Curve curve
+               => Simple.Scalar curve -> Bool
+ecScalarIsZero (Simple.Scalar a) = a == 0
+
+ecScalarInv :: Simple.Curve c
+            => proxy c -> Simple.Scalar c -> Maybe (Simple.Scalar c)
+ecScalarInv prx (Simple.Scalar s)
+    | i == 0    = Nothing
+    | otherwise = Just $ Simple.Scalar i
+  where n = Simple.curveEccN $ Simple.curveParameters prx
+        i = inverseFermat s n
+
+ecPointX :: Simple.Curve c
+         => proxy c -> Simple.Point c -> Maybe (Simple.Scalar c)
+ecPointX _   Simple.PointO      = Nothing
+ecPointX prx (Simple.Point x _) = Just (Simple.Scalar $ x `mod` n)
+  where n = Simple.curveEccN $ Simple.curveParameters prx

Crypto/PubKey/ECIES.hs

@@ -27,7 +27,6 @@ module Crypto.PubKey.ECIES
 import           Crypto.ECC
 import           Crypto.Error
 import           Crypto.Random
-import           Crypto.Internal.Proxy
 
 -- | Generate random a new Shared secret and the associated point
 -- to do a ECIES style encryption

Crypto/PubKey/EdDSA.hs

@@ -0,0 +1,390 @@
+-- |
+-- Module      : Crypto.PubKey.EdDSA
+-- License     : BSD-style
+-- Maintainer  : Olivier Chéron <olivier.cheron@gmail.com>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- EdDSA signature generation and verification, implemented in Haskell and
+-- parameterized with elliptic curve and hash algorithm.  Only edwards25519 is
+-- supported at the moment.
+--
+-- The module provides \"context\" and \"prehash\" variants defined in
+-- <https://tools.ietf.org/html/rfc8032 RFC 8032>.
+--
+-- This implementation is most useful when wanting to customize the hash
+-- algorithm.  See module "Crypto.PubKey.Ed25519" for faster Ed25519 with
+-- SHA-512.
+--
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TypeFamilies               #-}
+module Crypto.PubKey.EdDSA
+    ( SecretKey
+    , PublicKey
+    , Signature
+    -- * Curves with EdDSA implementation
+    , EllipticCurveEdDSA(CurveDigestSize)
+    , publicKeySize
+    , secretKeySize
+    , signatureSize
+    -- * Smart constructors
+    , signature
+    , publicKey
+    , secretKey
+    -- * Methods
+    , toPublic
+    , sign
+    , signCtx
+    , signPh
+    , verify
+    , verifyCtx
+    , verifyPh
+    , generateSecretKey
+    ) where
+
+import           Data.Bits
+import           Data.ByteArray (ByteArray, ByteArrayAccess, Bytes, ScrubbedBytes, View)
+import qualified Data.ByteArray as B
+import           Data.ByteString (ByteString)
+import           Data.Proxy
+
+import           Crypto.ECC
+import qualified Crypto.ECC.Edwards25519 as Edwards25519
+import           Crypto.Error
+import           Crypto.Hash (Digest)
+import           Crypto.Hash.IO
+import           Crypto.Random
+
+import           GHC.TypeLits (KnownNat, Nat)
+
+import           Crypto.Internal.Builder
+import           Crypto.Internal.Compat
+import           Crypto.Internal.Imports
+import           Crypto.Internal.Nat (integralNatVal)
+
+import           Foreign.Storable
+
+
+-- API
+
+-- | An EdDSA Secret key
+newtype SecretKey curve = SecretKey ScrubbedBytes
+    deriving (Show,Eq,ByteArrayAccess,NFData)
+
+-- | An EdDSA public key
+newtype PublicKey curve hash = PublicKey Bytes
+    deriving (Show,Eq,ByteArrayAccess,NFData)
+
+-- | An EdDSA signature
+newtype Signature curve hash = Signature Bytes
+    deriving (Show,Eq,ByteArrayAccess,NFData)
+
+-- | Elliptic curves with an implementation of EdDSA
+class ( EllipticCurveBasepointArith curve
+      , KnownNat (CurveDigestSize curve)
+      ) => EllipticCurveEdDSA curve where
+
+    -- | Size of the digest for this curve (in bytes)
+    type CurveDigestSize curve :: Nat
+
+    -- | Size of secret keys for this curve (in bytes)
+    secretKeySize :: proxy curve -> Int
+
+    -- hash with specified parameters
+    hashWithDom :: (HashAlgorithm hash, ByteArrayAccess ctx, ByteArrayAccess msg)
+                => proxy curve -> hash -> Bool -> ctx -> Builder -> msg -> Bytes
+
+    -- conversion between scalar, point and public key
+    pointPublic :: proxy curve -> Point curve -> PublicKey curve hash
+    publicPoint :: proxy curve -> PublicKey curve hash -> CryptoFailable (Point curve)
+    encodeScalarLE :: ByteArray bs => proxy curve -> Scalar curve -> bs
+    decodeScalarLE :: ByteArrayAccess bs => proxy curve -> bs -> CryptoFailable (Scalar curve)
+
+    -- how to use bits in a secret key
+    scheduleSecret :: ( HashAlgorithm hash
+                      , HashDigestSize hash ~ CurveDigestSize curve
+                      )
+                   => proxy curve
+                   -> hash
+                   -> SecretKey curve
+                   -> (Scalar curve, View Bytes)
+
+-- | Size of public keys for this curve (in bytes)
+publicKeySize :: EllipticCurveEdDSA curve => proxy curve -> Int
+publicKeySize prx = signatureSize prx `div` 2
+
+-- | Size of signatures for this curve (in bytes)
+signatureSize :: forall proxy curve . EllipticCurveEdDSA curve
+              => proxy curve -> Int
+signatureSize _ = integralNatVal (Proxy :: Proxy (CurveDigestSize curve))
+
+
+-- Constructors
+
+-- | Try to build a public key from a bytearray
+publicKey :: ( EllipticCurveEdDSA curve
+             , HashAlgorithm hash
+             , HashDigestSize hash ~ CurveDigestSize curve
+             , ByteArrayAccess ba
+             )
+          => proxy curve -> hash -> ba -> CryptoFailable (PublicKey curve hash)
+publicKey prx _ bs
+    | B.length bs == publicKeySize prx =
+        CryptoPassed (PublicKey $ B.convert bs)
+    | otherwise =
+        CryptoFailed CryptoError_PublicKeySizeInvalid
+
+-- | Try to build a secret key from a bytearray
+secretKey :: (EllipticCurveEdDSA curve, ByteArrayAccess ba)
+          => proxy curve -> ba -> CryptoFailable (SecretKey curve)
+secretKey prx bs
+    | B.length bs == secretKeySize prx =
+        CryptoPassed (SecretKey $ B.convert bs)
+    | otherwise                        =
+        CryptoFailed CryptoError_SecretKeyStructureInvalid
+
+-- | Try to build a signature from a bytearray
+signature :: ( EllipticCurveEdDSA curve
+             , HashAlgorithm hash
+             , HashDigestSize hash ~ CurveDigestSize curve
+             , ByteArrayAccess ba
+             )
+          => proxy curve -> hash -> ba -> CryptoFailable (Signature curve hash)
+signature prx _ bs
+    | B.length bs == signatureSize prx =
+        CryptoPassed (Signature $ B.convert bs)
+    | otherwise =
+        CryptoFailed CryptoError_SecretKeyStructureInvalid
+
+
+-- Conversions
+
+-- | Generate a secret key
+generateSecretKey :: (EllipticCurveEdDSA curve, MonadRandom m)
+                  => proxy curve -> m (SecretKey curve)
+generateSecretKey prx = SecretKey <$> getRandomBytes (secretKeySize prx)
+
+-- | Create a public key from a secret key
+toPublic :: ( EllipticCurveEdDSA curve
+            , HashAlgorithm hash
+            , HashDigestSize hash ~ CurveDigestSize curve
+            )
+         => proxy curve -> hash -> SecretKey curve -> PublicKey curve hash
+toPublic prx alg priv =
+    let p = pointBaseSmul prx (secretScalar prx alg priv)
+     in pointPublic prx p
+
+secretScalar :: ( EllipticCurveEdDSA curve
+                , HashAlgorithm hash
+                , HashDigestSize hash ~ CurveDigestSize curve
+                )
+             => proxy curve -> hash -> SecretKey curve -> Scalar curve
+secretScalar prx alg priv = fst (scheduleSecret prx alg priv)
+
+
+-- EdDSA signature generation & verification
+
+-- | Sign a message using the key pair
+sign :: ( EllipticCurveEdDSA curve
+        , HashAlgorithm hash
+        , HashDigestSize hash ~ CurveDigestSize curve
+        , ByteArrayAccess msg
+        )
+     => proxy curve -> SecretKey curve -> PublicKey curve hash -> msg -> Signature curve hash
+sign prx = signCtx prx emptyCtx
+
+-- | Verify a message
+verify :: ( EllipticCurveEdDSA curve
+          , HashAlgorithm hash
+          , HashDigestSize hash ~ CurveDigestSize curve
+          , ByteArrayAccess msg
+          )
+       => proxy curve -> PublicKey curve hash -> msg -> Signature curve hash -> Bool
+verify prx = verifyCtx prx emptyCtx
+
+-- | Sign a message using the key pair under context @ctx@
+signCtx :: ( EllipticCurveEdDSA curve
+           , HashAlgorithm hash
+           , HashDigestSize hash ~ CurveDigestSize curve
+           , ByteArrayAccess ctx
+           , ByteArrayAccess msg
+           )
+        => proxy curve -> ctx -> SecretKey curve -> PublicKey curve hash -> msg -> Signature curve hash
+signCtx prx = signPhCtx prx False
+
+-- | Verify a message under context @ctx@
+verifyCtx :: ( EllipticCurveEdDSA curve
+             , HashAlgorithm hash
+             , HashDigestSize hash ~ CurveDigestSize curve
+             , ByteArrayAccess ctx
+             , ByteArrayAccess msg
+             )
+          => proxy curve -> ctx -> PublicKey curve hash -> msg -> Signature curve hash -> Bool
+verifyCtx prx = verifyPhCtx prx False
+
+-- | Sign a prehashed message using the key pair under context @ctx@
+signPh :: ( EllipticCurveEdDSA curve
+          , HashAlgorithm hash
+          , HashDigestSize hash ~ CurveDigestSize curve
+          , ByteArrayAccess ctx
+          )
+       => proxy curve -> ctx -> SecretKey curve -> PublicKey curve hash -> Digest prehash -> Signature curve hash
+signPh prx = signPhCtx prx True
+
+-- | Verify a prehashed message under context @ctx@
+verifyPh :: ( EllipticCurveEdDSA curve
+            , HashAlgorithm hash
+            , HashDigestSize hash ~ CurveDigestSize curve
+            , ByteArrayAccess ctx
+            )
+         => proxy curve -> ctx -> PublicKey curve hash -> Digest prehash -> Signature curve hash -> Bool
+verifyPh prx = verifyPhCtx prx True
+
+signPhCtx :: forall proxy curve hash ctx msg .
+             ( EllipticCurveEdDSA curve
+             , HashAlgorithm hash
+             , HashDigestSize hash ~ CurveDigestSize curve
+             , ByteArrayAccess ctx
+             , ByteArrayAccess msg
+             )
+          => proxy curve -> Bool -> ctx -> SecretKey curve -> PublicKey curve hash -> msg -> Signature curve hash
+signPhCtx prx ph ctx priv pub msg =
+    let alg  = undefined :: hash
+        (s, prefix) = scheduleSecret prx alg priv
+        digR = hashWithDom prx alg ph ctx (bytes prefix) msg
+        r    = decodeScalarNoErr prx digR
+        pR   = pointBaseSmul prx r
+        bsR  = encodePoint prx pR
+        sK   = getK prx ph ctx pub bsR msg
+        sS   = scalarAdd prx r (scalarMul prx sK s)
+     in encodeSignature prx (bsR, pR, sS)
+
+verifyPhCtx :: ( EllipticCurveEdDSA curve
+               , HashAlgorithm hash
+               , HashDigestSize hash ~ CurveDigestSize curve
+               , ByteArrayAccess ctx
+               , ByteArrayAccess msg
+               )
+            => proxy curve -> Bool -> ctx -> PublicKey curve hash -> msg -> Signature curve hash -> Bool
+verifyPhCtx prx ph ctx pub msg sig =
+    case doVerify of
+        CryptoPassed verified -> verified
+        CryptoFailed _        -> False
+  where
+    doVerify = do
+        (bsR, pR, sS) <- decodeSignature prx sig
+        nPub <- pointNegate prx `fmap` publicPoint prx pub
+        let sK  = getK prx ph ctx pub bsR msg
+            pR' = pointsSmulVarTime prx sS sK nPub
+        return (pR == pR')
+
+emptyCtx :: Bytes
+emptyCtx = B.empty
+
+getK :: forall proxy curve hash ctx msg .
+        ( EllipticCurveEdDSA curve
+        , HashAlgorithm hash
+        , HashDigestSize hash ~ CurveDigestSize curve
+        , ByteArrayAccess ctx
+        , ByteArrayAccess msg
+        )
+     => proxy curve -> Bool -> ctx -> PublicKey curve hash -> Bytes -> msg -> Scalar curve
+getK prx ph ctx (PublicKey pub) bsR msg =
+    let alg  = undefined :: hash
+        digK = hashWithDom prx alg ph ctx (bytes bsR <> bytes pub) msg
+     in decodeScalarNoErr prx digK
+
+encodeSignature :: EllipticCurveEdDSA curve
+                => proxy curve
+                -> (Bytes, Point curve, Scalar curve)
+                -> Signature curve hash
+encodeSignature prx (bsR, _, sS) = Signature $ buildAndFreeze $
+    bytes bsR <> bytes bsS <> zero len0
+  where
+    bsS  = encodeScalarLE prx sS :: Bytes
+    len0 = signatureSize prx - B.length bsR - B.length bsS
+
+decodeSignature :: ( EllipticCurveEdDSA curve
+                   , HashDigestSize hash ~ CurveDigestSize curve
+                   )
+                => proxy curve
+                -> Signature curve hash
+                -> CryptoFailable (Bytes, Point curve, Scalar curve)
+decodeSignature prx (Signature bs) = do
+    let (bsR, bsS) = B.splitAt (publicKeySize prx) bs
+    pR <- decodePoint prx bsR
+    sS <- decodeScalarLE prx bsS
+    return (bsR, pR, sS)
+
+-- implementations are supposed to decode any scalar up to the size of the digest
+decodeScalarNoErr :: (EllipticCurveEdDSA curve, ByteArrayAccess bs)
+                  => proxy curve -> bs -> Scalar curve
+decodeScalarNoErr prx = unwrap "decodeScalarNoErr" . decodeScalarLE prx
+
+unwrap :: String -> CryptoFailable a -> a
+unwrap name (CryptoFailed _) = error (name ++ ": assumption failed")
+unwrap _    (CryptoPassed x) = x
+
+
+-- Ed25519 implementation
+
+instance EllipticCurveEdDSA Curve_Edwards25519 where
+    type CurveDigestSize Curve_Edwards25519 = 64
+    secretKeySize _ = 32
+
+    hashWithDom _ alg ph ctx bss
+        | not ph && B.null ctx = digestDomMsg alg bss
+        | otherwise            = digestDomMsg alg (dom <> bss)
+      where dom = bytes ("SigEd25519 no Ed25519 collisions" :: ByteString) <>
+                  byte (if ph then 1 else 0) <>
+                  byte (fromIntegral $ B.length ctx) <>
+                  bytes ctx
+
+    pointPublic _ = PublicKey . Edwards25519.pointEncode
+    publicPoint _ = Edwards25519.pointDecode
+    encodeScalarLE _ = Edwards25519.scalarEncode
+    decodeScalarLE _ = Edwards25519.scalarDecodeLong
+
+    scheduleSecret prx alg priv =
+        (decodeScalarNoErr prx clamped, B.dropView hashed 32)
+      where
+        hashed  = digest alg $ \update -> update priv
+
+        clamped :: Bytes
+        clamped = B.copyAndFreeze (B.takeView hashed 32) $ \p -> do
+                      b0  <- peekElemOff p 0  :: IO Word8
+                      b31 <- peekElemOff p 31 :: IO Word8
+                      pokeElemOff p 31 ((b31 .&. 0x7F) .|. 0x40)
+                      pokeElemOff p 0  (b0 .&. 0xF8)
+
+
+{-
+  Optimize hashing by limiting the number of roundtrips between Haskell and C.
+  Hash "update" functions do not use unsafe FFI call, so better concanetate
+  small fragments together and call the update function once.
+
+  Using the IO hash interface avoids context buffer copies.
+
+  Data type Digest is not used directly but converted to Bytes early. Any use of
+  withByteArray on the unpinned Digest backend would require copy through a
+  pinned trampoline.
+-}
+
+digestDomMsg :: (HashAlgorithm alg, ByteArrayAccess msg)
+             => alg -> Builder -> msg -> Bytes
+digestDomMsg alg bss bs = digest alg $ \update ->
+    update (buildAndFreeze bss :: Bytes) >> update bs
+
+digest :: HashAlgorithm alg
+       => alg
+       -> ((forall bs . ByteArrayAccess bs => bs -> IO ()) -> IO ())
+       -> Bytes
+digest alg fn = B.convert $ unsafeDoIO $ do
+    mc <- hashMutableInitWith alg
+    fn (hashMutableUpdate mc)
+    hashMutableFinalize mc

Crypto/PubKey/Internal.hs

@@ -8,10 +8,18 @@
 module Crypto.PubKey.Internal
     ( and'
     , (&&!)
+    , dsaTruncHash
+    , dsaTruncHashDigest
     ) where
 
+import Data.Bits (shiftR)
 import Data.List (foldl')
 
+import Crypto.Hash
+import Crypto.Internal.ByteArray (ByteArrayAccess)
+import Crypto.Number.Basic (numBits)
+import Crypto.Number.Serialize
+
 -- | This is a strict version of and
 and' :: [Bool] -> Bool
 and' l = foldl' (&&!) True l
@@ -22,3 +30,18 @@ True  &&! True  = True
 True  &&! False = False
 False &&! True  = False
 False &&! False = False
+
+-- | Truncate and hash for DSA and ECDSA.
+dsaTruncHash :: (ByteArrayAccess msg, HashAlgorithm hash) => hash -> msg -> Integer -> Integer
+dsaTruncHash hashAlg = dsaTruncHashDigest . hashWith hashAlg
+
+-- | Truncate a digest for DSA and ECDSA.
+dsaTruncHashDigest :: HashAlgorithm hash => Digest hash -> Integer -> Integer
+dsaTruncHashDigest digest n
+    | d > 0 = shiftR e d
+    | otherwise = e
+  where e = os2ip digest
+        d = hashDigestSize (getHashAlg digest) * 8 - numBits n
+
+getHashAlg :: Digest hash -> hash
+getHashAlg _ = undefined

Crypto/PubKey/RSA.hs

@@ -16,7 +16,6 @@ module Crypto.PubKey.RSA
     , generateBlinder
     ) where
 
-import Crypto.Internal.Imports
 import Crypto.Random.Types
 import Crypto.Number.ModArithmetic (inverse, inverseCoprimes)
 import Crypto.Number.Generate (generateMax)
@@ -55,7 +54,7 @@ toPositive int
 --
 generateWith :: (Integer, Integer) -- ^ chosen distinct primes p and q
              -> Int                -- ^ size in bytes
-             -> Integer            -- ^ RSA public exponant 'e'
+             -> Integer            -- ^ RSA public exponent 'e'
              -> Maybe (PublicKey, PrivateKey)
 generateWith (p,q) size e =
     case inverse e phi of
@@ -81,7 +80,7 @@ generateWith (p,q) size e =
 -- | generate a pair of (private, public) key of size in bytes.
 generate :: MonadRandom m
          => Int     -- ^ size in bytes
-         -> Integer -- ^ RSA public exponant 'e'
+         -> Integer -- ^ RSA public exponent 'e'
          -> m (PublicKey, PrivateKey)
 generate size e = loop
   where

Crypto/PubKey/RSA/PKCS15.hs

@@ -111,8 +111,8 @@ pad len m
 -- | Produce a standard PKCS1.5 padding for signature
 padSignature :: ByteArray signature => Int -> signature -> Either Error signature
 padSignature klen signature
-    | klen < siglen+1 = Left SignatureTooLong
+    | klen < siglen + 11 = Left SignatureTooLong
-    | otherwise       = Right (B.pack padding `B.append` signature)
+    | otherwise          = Right (B.pack padding `B.append` signature)
   where
         siglen    = B.length signature
         padding   = 0 : 1 : (replicate (klen - siglen - 3) 0xff ++ [0])

Crypto/PubKey/RSA/PSS.hs

@@ -26,11 +26,12 @@ import           Crypto.PubKey.RSA.Prim
 import           Crypto.PubKey.RSA (generateBlinder)
 import           Crypto.PubKey.MaskGenFunction
 import           Crypto.Hash
+import           Crypto.Number.Basic (numBits)
 import           Data.Bits (xor, shiftR, (.&.))
 import           Data.Word
 
 import           Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray)
-import qualified Crypto.Internal.ByteArray as B (convert)
+import qualified Crypto.Internal.ByteArray as B (convert, eq)
 
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString as B
@@ -69,18 +70,19 @@ signDigestWithSalt :: HashAlgorithm hash
                    -> Digest hash   -- ^ Message digest
                    -> Either Error ByteString
 signDigestWithSalt salt blinder params pk digest
-    | k < hashLen + saltLen + 2 = Left InvalidParameters
+    | emLen < hashLen + saltLen + 2 = Left InvalidParameters
-    | otherwise                 = Right $ dp blinder pk em
+    | otherwise                     = Right $ dp blinder pk em
     where k        = private_size pk
+          emLen    = if emTruncate pubBits then k - 1 else k
           mHash    = B.convert digest
-          dbLen    = k - hashLen - 1
+          dbLen    = emLen - hashLen - 1
           saltLen  = B.length salt
           hashLen  = hashDigestSize (pssHash params)
-          pubBits  = private_size pk * 8 -- to change if public_size is converted in bytes
+          pubBits  = numBits (private_n pk)
           m'       = B.concat [B.replicate 8 0,mHash,salt]
           h        = B.convert $ hashWith (pssHash params) m'
           db       = B.concat [B.replicate (dbLen - saltLen - 1) 0,B.singleton 1,salt]
-          dbmask   = (pssMaskGenAlg params) h dbLen
+          dbmask   = pssMaskGenAlg params h dbLen
           maskedDB = B.pack $ normalizeToKeySize pubBits $ B.zipWith xor db dbmask
           em       = B.concat [maskedDB, h, B.singleton (pssTrailerField params)]
 
@@ -148,7 +150,7 @@ verify :: HashAlgorithm hash
        -> ByteString -- ^ Message to verify
        -> ByteString -- ^ Signature
        -> Bool
-verify params pk m s = verifyDigest params pk mHash s
+verify params pk m = verifyDigest params pk mHash
   where mHash     = hashWith (pssHash params) m
 
 -- | Verify a signature using the PSS Parameters
@@ -161,30 +163,37 @@ verifyDigest :: HashAlgorithm hash
              -> ByteString  -- ^ Signature
              -> Bool
 verifyDigest params pk digest s
-    | public_size pk /= B.length s        = False
+    | B.length s /= k                     = False
+    | B.any (/= 0) pre                    = False
     | B.last em /= pssTrailerField params = False
-    | not (B.all (== 0) ps0)              = False
+    | B.any (/= 0) ps0                    = False
     | b1 /= B.singleton 1                 = False
-    | otherwise                           = h == B.convert h'
+    | otherwise                           = B.eq h h'
         where -- parameters
               hashLen   = hashDigestSize (pssHash params)
               mHash     = B.convert digest
-              dbLen     = public_size pk - hashLen - 1
+              k         = public_size pk
-              pubBits   = public_size pk * 8 -- to change if public_size is converted in bytes
+              emLen     = if emTruncate pubBits then k - 1 else k
+              dbLen     = emLen - hashLen - 1
+              pubBits   = numBits (public_n pk)
               -- unmarshall fields
-              em        = ep pk s
+              (pre, em) = B.splitAt (k - emLen) (ep pk s) -- drop 0..1 byte
-              maskedDB  = B.take (B.length em - hashLen - 1) em
+              maskedDB  = B.take dbLen em
               h         = B.take hashLen $ B.drop (B.length maskedDB) em
-              dbmask    = (pssMaskGenAlg params) h dbLen
+              dbmask    = pssMaskGenAlg params h dbLen
               db        = B.pack $ normalizeToKeySize pubBits $ B.zipWith xor maskedDB dbmask
               (ps0,z)   = B.break (== 1) db
               (b1,salt) = B.splitAt 1 z
               m'        = B.concat [B.replicate 8 0,mHash,salt]
               h'        = hashWith (pssHash params) m'
 
+-- When the modulus has bit length 1 modulo 8 we drop the first byte.
+emTruncate :: Int -> Bool
+emTruncate bits = ((bits-1) .&. 0x7) == 0
+
 normalizeToKeySize :: Int -> [Word8] -> [Word8]
 normalizeToKeySize _    []     = [] -- very unlikely
 normalizeToKeySize bits (x:xs) = x .&. mask : xs
     where mask = if sh > 0 then 0xff `shiftR` (8-sh) else 0xff
-          sh   = ((bits-1) .&. 0x7)
+          sh   = (bits-1) .&. 0x7
 

Crypto/PubKey/RSA/Types.hs

@@ -41,8 +41,8 @@ data Error =
 data PublicKey = PublicKey
     { public_size :: Int      -- ^ size of key in bytes
     , public_n    :: Integer  -- ^ public p*q
-    , public_e    :: Integer  -- ^ public exponant e
+    , public_e    :: Integer  -- ^ public exponent e
-    } deriving (Show,Read,Eq,Data,Typeable)
+    } deriving (Show,Read,Eq,Data)
 
 instance NFData PublicKey where
     rnf (PublicKey sz n e) = rnf n `seq` rnf e `seq` sz `seq` ()
@@ -59,13 +59,13 @@ instance NFData PublicKey where
 --
 data PrivateKey = PrivateKey
     { private_pub  :: PublicKey -- ^ public part of a private key (size, n and e)
-    , private_d    :: Integer   -- ^ private exponant d
+    , private_d    :: Integer   -- ^ private exponent d
     , private_p    :: Integer   -- ^ p prime number
     , private_q    :: Integer   -- ^ q prime number
     , private_dP   :: Integer   -- ^ d mod (p-1)
     , private_dQ   :: Integer   -- ^ d mod (q-1)
     , private_qinv :: Integer   -- ^ q^(-1) mod p
-    } deriving (Show,Read,Eq,Data,Typeable)
+    } deriving (Show,Read,Eq,Data)
 
 instance NFData PrivateKey where
     rnf (PrivateKey pub d p q dp dq qinv) =
@@ -87,7 +87,7 @@ private_e = public_e . private_pub
 --
 -- note the RSA private key contains already an instance of public key for efficiency
 newtype KeyPair = KeyPair PrivateKey
-    deriving (Show,Read,Eq,Data,Typeable,NFData)
+    deriving (Show,Read,Eq,Data,NFData)
 
 -- | Public key of a RSA KeyPair
 toPublicKey :: KeyPair -> PublicKey

Crypto/PubKey/Rabin/Basic.hs

@@ -0,0 +1,230 @@
+-- |
+-- Module      : Crypto.PubKey.Rabin.Basic
+-- License     : BSD-style
+-- Maintainer  : Carlos Rodriguez-Vega <crodveg@yahoo.es>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Rabin cryptosystem for public-key cryptography and digital signature.
+--
+{-# LANGUAGE DeriveDataTypeable #-}
+module Crypto.PubKey.Rabin.Basic
+    ( PublicKey(..)
+    , PrivateKey(..)
+    , Signature(..)
+    , generate
+    , encrypt
+    , encryptWithSeed
+    , decrypt
+    , sign
+    , signWith
+    , verify
+    ) where
+
+import           Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import           Data.Data
+import           Data.Either (rights)
+
+import           Crypto.Hash
+import           Crypto.Number.Basic (gcde, numBytes)
+import           Crypto.Number.ModArithmetic (expSafe, jacobi)
+import           Crypto.Number.Serialize (i2osp, i2ospOf_, os2ip)
+import           Crypto.PubKey.Rabin.OAEP 
+import           Crypto.PubKey.Rabin.Types
+import           Crypto.Random (MonadRandom, getRandomBytes)
+
+-- | Represent a Rabin public key.
+data PublicKey = PublicKey
+    { public_size :: Int      -- ^ size of key in bytes
+    , public_n    :: Integer  -- ^ public p*q
+    } deriving (Show, Read, Eq, Data)
+
+-- | Represent a Rabin private key.
+data PrivateKey = PrivateKey
+    { private_pub :: PublicKey
+    , private_p   :: Integer   -- ^ p prime number
+    , private_q   :: Integer   -- ^ q prime number
+    , private_a   :: Integer
+    , private_b   :: Integer
+    } deriving (Show, Read, Eq, Data)
+
+-- | Rabin Signature.
+data Signature = Signature (Integer, Integer) deriving (Show, Read, Eq, Data)
+
+-- | Generate a pair of (private, public) key of size in bytes.
+-- Primes p and q are both congruent 3 mod 4.
+--
+-- See algorithm 8.11 in "Handbook of Applied Cryptography" by Alfred J. Menezes et al.
+generate :: MonadRandom m
+         => Int
+         -> m (PublicKey, PrivateKey)
+generate size = do
+    (p, q) <- generatePrimes size (\p -> p `mod` 4 == 3) (\q -> q `mod` 4 == 3)
+    return $ generateKeys p q
+  where 
+    generateKeys p q =
+        let n = p*q
+            (a, b, _) = gcde p q 
+            publicKey = PublicKey { public_size = size
+                                    , public_n    = n }
+            privateKey = PrivateKey { private_pub = publicKey
+                                    , private_p   = p
+                                    , private_q   = q
+                                    , private_a   = a
+                                    , private_b   = b }
+            in (publicKey, privateKey)
+
+-- | Encrypt plaintext using public key an a predefined OAEP seed.
+--
+-- See algorithm 8.11 in "Handbook of Applied Cryptography" by Alfred J. Menezes et al.
+encryptWithSeed :: HashAlgorithm hash
+                => ByteString                               -- ^ Seed
+                -> OAEPParams hash ByteString ByteString    -- ^ OAEP padding
+                -> PublicKey                                -- ^ public key
+                -> ByteString                               -- ^ plaintext
+                -> Either Error ByteString
+encryptWithSeed seed oaep pk m =
+    let n  = public_n pk
+        k  = numBytes n
+     in do
+        m' <- pad seed oaep k m
+        let m'' = os2ip m'
+        return $ i2osp $ expSafe m'' 2 n
+
+-- | Encrypt plaintext using public key.
+encrypt :: (HashAlgorithm hash, MonadRandom m)
+        => OAEPParams hash ByteString ByteString    -- ^ OAEP padding parameters
+        -> PublicKey                                -- ^ public key
+        -> ByteString                               -- ^ plaintext 
+        -> m (Either Error ByteString)
+encrypt oaep pk m = do
+    seed <- getRandomBytes hashLen
+    return $ encryptWithSeed seed oaep pk m
+  where
+    hashLen = hashDigestSize (oaepHash oaep) 
+
+-- | Decrypt ciphertext using private key.
+--
+-- See algorithm 8.12 in "Handbook of Applied Cryptography" by Alfred J. Menezes et al.
+decrypt :: HashAlgorithm hash
+        => OAEPParams hash ByteString ByteString    -- ^ OAEP padding parameters
+        -> PrivateKey                               -- ^ private key
+        -> ByteString                               -- ^ ciphertext
+        -> Maybe ByteString
+decrypt oaep pk c =
+    let p  = private_p pk 
+        q  = private_q pk     
+        a  = private_a pk 
+        b  = private_b pk
+        n  = public_n $ private_pub pk
+        k  = numBytes n
+        c' = os2ip c
+        solutions = rights $ toList $ mapTuple (unpad oaep k . i2ospOf_ k) $ sqroot' c' p q a b n
+     in if length solutions /= 1 then Nothing
+        else Just $ head solutions
+      where toList (w, x, y, z) = w:x:y:z:[]
+            mapTuple f (w, x, y, z) = (f w, f x, f y, f z)
+
+-- | Sign message using padding, hash algorithm and private key.
+--
+-- See <https://en.wikipedia.org/wiki/Rabin_signature_algorithm>.
+signWith :: HashAlgorithm hash
+         => ByteString    -- ^ padding
+         -> PrivateKey    -- ^ private key
+         -> hash          -- ^ hash function
+         -> ByteString    -- ^ message to sign
+         -> Either Error Signature
+signWith padding pk hashAlg m = do
+    h <- calculateHash padding pk hashAlg m
+    signature <- calculateSignature h
+    return signature
+  where
+    calculateSignature h =
+        let p = private_p pk
+            q = private_q pk     
+            a = private_a pk 
+            b = private_b pk
+            n = public_n $ private_pub pk
+         in if h >= n then Left MessageTooLong
+            else let (r, _, _, _) = sqroot' h p q a b n
+                  in Right $ Signature (os2ip padding, r)
+
+-- | Sign message using hash algorithm and private key.
+--
+-- See <https://en.wikipedia.org/wiki/Rabin_signature_algorithm>.
+sign :: (MonadRandom m, HashAlgorithm hash)
+     => PrivateKey    -- ^ private key
+     -> hash          -- ^ hash function
+     -> ByteString    -- ^ message to sign
+     -> m (Either Error Signature)
+sign pk hashAlg m = do
+    padding <- findPadding
+    return $ signWith padding pk hashAlg m
+  where 
+    findPadding = do
+        padding <- getRandomBytes 8
+        case calculateHash padding pk hashAlg m of
+            Right _ -> return padding
+            _       -> findPadding
+
+-- | Calculate hash of message and padding.
+-- If the padding is valid, then the result of the hash operation is returned, otherwise an error.
+calculateHash :: HashAlgorithm hash
+              => ByteString    -- ^ padding
+              -> PrivateKey    -- ^ private key
+              -> hash          -- ^ hash function
+              -> ByteString    -- ^ message to sign
+              -> Either Error Integer
+calculateHash padding pk hashAlg m = 
+    let p = private_p pk
+        q = private_q pk
+        h = os2ip $ hashWith hashAlg $ B.append padding m
+     in case (jacobi (h `mod` p) p, jacobi (h `mod` q) q) of
+            (Just 1, Just 1) -> Right h
+            _                -> Left InvalidParameters
+
+-- | Verify signature using hash algorithm and public key.
+--
+-- See <https://en.wikipedia.org/wiki/Rabin_signature_algorithm>.
+verify :: HashAlgorithm hash
+       => PublicKey     -- ^ private key
+       -> hash          -- ^ hash function
+       -> ByteString    -- ^ message
+       -> Signature     -- ^ signature
+       -> Bool
+verify pk hashAlg m (Signature (padding, s)) =
+    let n  = public_n pk
+        p  = i2osp padding
+        h  = os2ip $ hashWith hashAlg $ B.append p m 
+        h' = expSafe s 2 n
+     in h' == h
+
+-- | Square roots modulo prime p where p is congruent 3 mod 4
+-- Value a must be a quadratic residue modulo p (i.e. jacobi symbol (a/n) = 1).
+--
+-- See algorithm 3.36 in "Handbook of Applied Cryptography" by Alfred J. Menezes et al.
+sqroot :: Integer
+       -> Integer   -- ^ prime p
+       -> (Integer, Integer)
+sqroot a p =
+    let r = expSafe a ((p + 1) `div` 4) p
+     in (r, -r)
+
+-- | Square roots modulo n given its prime factors p and q (both congruent 3 mod 4)
+-- Value a must be a quadratic residue of both modulo p and modulo q (i.e. jacobi symbols (a/p) = (a/q) = 1).
+-- 
+-- See algorithm 3.44 in "Handbook of Applied Cryptography" by Alfred J. Menezes et al.
+sqroot' :: Integer 
+        -> Integer  -- ^ prime p
+        -> Integer  -- ^ prime q
+        -> Integer  -- ^ c such that c*p + d*q = 1
+        -> Integer  -- ^ d such that c*p + d*q = 1
+        -> Integer  -- ^ n = p*q
+        -> (Integer, Integer, Integer, Integer)
+sqroot' a p q c d n =
+    let (r, _) = sqroot a p
+        (s, _) = sqroot a q
+        x      = (r*d*q + s*c*p) `mod` n
+        y      = (r*d*q - s*c*p) `mod` n
+     in (x, (-x) `mod` n, y, (-y) `mod` n)

Crypto/PubKey/Rabin/Modified.hs

@@ -0,0 +1,101 @@
+-- |
+-- Module      : Crypto.PubKey.Rabin.Modified
+-- License     : BSD-style
+-- Maintainer  : Carlos Rodriguez-Vega <crodveg@yahoo.es>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Modified-Rabin public-key digital signature algorithm.
+-- See algorithm 11.30 in "Handbook of Applied Cryptography" by Alfred J. Menezes et al.
+--
+{-# LANGUAGE DeriveDataTypeable #-}
+module Crypto.PubKey.Rabin.Modified
+    ( PublicKey(..)
+    , PrivateKey(..)
+    , generate
+    , sign
+    , verify
+    ) where
+
+import           Data.ByteString
+import           Data.Data
+
+import           Crypto.Hash
+import           Crypto.Number.ModArithmetic (expSafe, jacobi)
+import           Crypto.Number.Serialize (os2ip)
+import           Crypto.PubKey.Rabin.Types
+import           Crypto.Random.Types
+
+-- | Represent a Modified-Rabin public key.
+data PublicKey = PublicKey
+    { public_size :: Int      -- ^ size of key in bytes
+    , public_n    :: Integer  -- ^ public p*q
+    } deriving (Show, Read, Eq, Data)
+
+-- | Represent a Modified-Rabin private key.
+data PrivateKey = PrivateKey
+    { private_pub :: PublicKey
+    , private_p   :: Integer   -- ^ p prime number
+    , private_q   :: Integer   -- ^ q prime number
+    , private_d   :: Integer
+    } deriving (Show, Read, Eq, Data)
+
+-- | Generate a pair of (private, public) key of size in bytes.
+-- Prime p is congruent 3 mod 8 and prime q is congruent 7 mod 8.
+generate :: MonadRandom m
+         => Int           
+         -> m (PublicKey, PrivateKey)
+generate size = do
+    (p, q) <- generatePrimes size (\p -> p `mod` 8 == 3) (\q -> q `mod` 8 == 7)
+    return $ generateKeys p q
+  where 
+    generateKeys p q =
+        let n = p*q   
+            d = (n - p - q + 5) `div` 8
+            publicKey = PublicKey { public_size = size
+                                    , public_n    = n }
+            privateKey = PrivateKey { private_pub = publicKey
+                                    , private_p   = p
+                                    , private_q   = q
+                                    , private_d   = d }
+            in (publicKey, privateKey)
+
+-- | Sign message using hash algorithm and private key.
+sign :: HashAlgorithm hash
+     => PrivateKey    -- ^ private key
+     -> hash          -- ^ hash function
+     -> ByteString    -- ^ message to sign
+     -> Either Error Integer
+sign pk hashAlg m =
+    let d = private_d pk
+        n = public_n $ private_pub pk
+        h = os2ip $ hashWith hashAlg m
+        limit = (n - 6) `div` 16
+     in if h > limit then Left MessageTooLong
+        else let h' = 16*h + 6
+              in case jacobi h' n of
+                    Just 1    -> Right $ expSafe h' d n
+                    Just (-1) -> Right $ expSafe (h' `div` 2) d n
+                    _         -> Left InvalidParameters
+
+-- | Verify signature using hash algorithm and public key.
+verify :: HashAlgorithm hash
+       => PublicKey     -- ^ public key
+       -> hash          -- ^ hash function
+       -> ByteString    -- ^ message
+       -> Integer       -- ^ signature
+       -> Bool
+verify pk hashAlg m s =
+    let n   = public_n pk
+        h   = os2ip $ hashWith hashAlg m
+        s'  = expSafe s 2 n
+        s'' = case s' `mod` 8 of
+            6 -> s'
+            3 -> 2*s'
+            7 -> n - s'
+            2 -> 2*(n - s')
+            _ -> 0
+     in case s'' `mod` 16 of
+            6 -> let h' = (s'' - 6) `div` 16
+                  in h' == h 
+            _ -> False

Crypto/PubKey/Rabin/OAEP.hs

@@ -0,0 +1,100 @@
+-- |
+-- Module      : Crypto.PubKey.Rabin.OAEP
+-- License     : BSD-style
+-- Maintainer  : Carlos Rodriguez-Vega <crodveg@yahoo.es>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- OAEP padding scheme.
+-- See <http://en.wikipedia.org/wiki/Optimal_asymmetric_encryption_padding>.
+--
+module Crypto.PubKey.Rabin.OAEP
+    ( OAEPParams(..)
+    , defaultOAEPParams
+    , pad
+    , unpad
+    ) where
+        
+import           Data.ByteString (ByteString)
+import qualified Data.ByteString as B
+import           Data.Bits (xor)
+
+import           Crypto.Hash
+import           Crypto.Internal.ByteArray (ByteArrayAccess, ByteArray)
+import qualified Crypto.Internal.ByteArray as B (convert)
+import           Crypto.PubKey.MaskGenFunction
+import           Crypto.PubKey.Internal (and')
+import           Crypto.PubKey.Rabin.Types
+
+-- | Parameters for OAEP padding.
+data OAEPParams hash seed output = OAEPParams
+    { oaepHash       :: hash                            -- ^ hash function to use
+    , oaepMaskGenAlg :: MaskGenAlgorithm seed output    -- ^ mask Gen algorithm to use
+    , oaepLabel      :: Maybe ByteString                -- ^ optional label prepended to message
+    }
+
+-- | Default Params with a specified hash function.
+defaultOAEPParams :: (ByteArrayAccess seed, ByteArray output, HashAlgorithm hash)
+                  => hash
+                  -> OAEPParams hash seed output
+defaultOAEPParams hashAlg =
+    OAEPParams { oaepHash       = hashAlg
+               , oaepMaskGenAlg = mgf1 hashAlg
+               , oaepLabel      = Nothing
+               }
+
+-- | Pad a message using OAEP.
+pad :: HashAlgorithm hash
+    => ByteString                               -- ^ Seed
+    -> OAEPParams hash ByteString ByteString    -- ^ OAEP params to use
+    -> Int                                      -- ^ size of public key in bytes
+    -> ByteString                               -- ^ Message pad
+    -> Either Error ByteString
+pad seed oaep k msg
+    | k < 2*hashLen+2          = Left InvalidParameters
+    | B.length seed /= hashLen = Left InvalidParameters
+    | mLen > k - 2*hashLen-2   = Left MessageTooLong
+    | otherwise                = Right em
+    where -- parameters
+        mLen       = B.length msg
+        mgf        = oaepMaskGenAlg oaep
+        labelHash  = hashWith (oaepHash oaep) (maybe B.empty id $ oaepLabel oaep)
+        hashLen    = hashDigestSize (oaepHash oaep)
+        -- put fields
+        ps         = B.replicate (k - mLen - 2*hashLen - 2) 0
+        db         = B.concat [B.convert labelHash, ps, B.singleton 0x1, msg]
+        dbmask     = mgf seed (k - hashLen - 1)
+        maskedDB   = B.pack $ B.zipWith xor db dbmask
+        seedMask   = mgf maskedDB hashLen
+        maskedSeed = B.pack $ B.zipWith xor seed seedMask
+        em         = B.concat [B.singleton 0x0, maskedSeed, maskedDB]
+
+-- | Un-pad a OAEP encoded message.
+unpad :: HashAlgorithm hash
+      => OAEPParams hash ByteString ByteString  -- ^ OAEP params to use
+      -> Int                                    -- ^ size of public key in bytes
+      -> ByteString                             -- ^ encoded message (not encrypted)
+      -> Either Error ByteString
+unpad oaep k em
+    | paddingSuccess = Right msg
+    | otherwise      = Left MessageNotRecognized
+    where -- parameters
+        mgf        = oaepMaskGenAlg oaep
+        labelHash  = B.convert $ hashWith (oaepHash oaep) (maybe B.empty id $ oaepLabel oaep)
+        hashLen    = hashDigestSize (oaepHash oaep)
+        -- getting em's fields
+        (pb, em0)  = B.splitAt 1 em
+        (maskedSeed, maskedDB) = B.splitAt hashLen em0
+        seedMask   = mgf maskedDB hashLen
+        seed       = B.pack $ B.zipWith xor maskedSeed seedMask
+        dbmask     = mgf seed (k - hashLen - 1)
+        db         = B.pack $ B.zipWith xor maskedDB dbmask
+        -- getting db's fields
+        (labelHash', db1) = B.splitAt hashLen db
+        (_, db2)   = B.break (/= 0) db1
+        (ps1, msg) = B.splitAt 1 db2
+
+        paddingSuccess = and' [ labelHash' == labelHash -- no need for constant eq
+                              , ps1        == B.replicate 1 0x1
+                              , pb         == B.replicate 1 0x0
+                              ]

Crypto/PubKey/Rabin/RW.hs

@@ -0,0 +1,166 @@
+-- |
+-- Module      : Crypto.PubKey.Rabin.RW
+-- License     : BSD-style
+-- Maintainer  : Carlos Rodriguez-Vega <crodveg@yahoo.es>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- Rabin-Williams cryptosystem for public-key encryption and digital signature. 
+-- See pages 323 - 324 in "Computational Number Theory and Modern Cryptography" by Song Y. Yan.
+-- Also inspired by https://github.com/vanilala/vncrypt/blob/master/vncrypt/vnrw_gmp.c.
+-- 
+{-# LANGUAGE DeriveDataTypeable #-}
+module Crypto.PubKey.Rabin.RW
+    ( PublicKey(..)
+    , PrivateKey(..)
+    , generate
+    , encrypt
+    , encryptWithSeed
+    , decrypt
+    , sign
+    , verify
+    ) where
+
+import           Data.ByteString
+import           Data.Data
+
+import           Crypto.Hash
+import           Crypto.Number.Basic (numBytes)
+import           Crypto.Number.ModArithmetic (expSafe, jacobi)
+import           Crypto.Number.Serialize (i2osp, i2ospOf_, os2ip)
+import           Crypto.PubKey.Rabin.OAEP
+import           Crypto.PubKey.Rabin.Types
+import           Crypto.Random.Types
+
+-- | Represent a Rabin-Williams public key.
+data PublicKey = PublicKey
+    { public_size :: Int      -- ^ size of key in bytes
+    , public_n    :: Integer  -- ^ public p*q
+    } deriving (Show, Read, Eq, Data)
+
+-- | Represent a Rabin-Williams private key.
+data PrivateKey = PrivateKey
+    { private_pub :: PublicKey
+    , private_p   :: Integer   -- ^ p prime number
+    , private_q   :: Integer   -- ^ q prime number
+    , private_d   :: Integer
+    } deriving (Show, Read, Eq, Data)
+
+-- | Generate a pair of (private, public) key of size in bytes.
+-- Prime p is congruent 3 mod 8 and prime q is congruent 7 mod 8.
+generate :: MonadRandom m
+         => Int           
+         -> m (PublicKey, PrivateKey)
+generate size = do
+    (p, q) <- generatePrimes size (\p -> p `mod` 8 == 3) (\q -> q `mod` 8 == 7) 
+    return (generateKeys p q)
+  where 
+    generateKeys p q =
+        let n = p*q   
+            d = ((p - 1)*(q - 1) `div` 4 + 1) `div` 2
+            publicKey = PublicKey { public_size = size
+                                    , public_n    = n }
+            privateKey = PrivateKey { private_pub = publicKey
+                                    , private_p   = p
+                                    , private_q   = q
+                                    , private_d   = d }
+            in (publicKey, privateKey)
+
+-- | Encrypt plaintext using public key an a predefined OAEP seed.
+--
+-- See algorithm 8.11 in "Handbook of Applied Cryptography" by Alfred J. Menezes et al.
+encryptWithSeed :: HashAlgorithm hash
+                => ByteString                               -- ^ Seed
+                -> OAEPParams hash ByteString ByteString    -- ^ OAEP padding
+                -> PublicKey                                -- ^ public key
+                -> ByteString                               -- ^ plaintext
+                -> Either Error ByteString
+encryptWithSeed seed oaep pk m =
+    let n = public_n pk
+        k = numBytes n
+     in do
+        m'  <- pad seed oaep k m
+        m'' <- ep1 n $ os2ip m'
+        return $ i2osp $ ep2 n m''
+
+-- | Encrypt plaintext using public key.
+encrypt :: (HashAlgorithm hash, MonadRandom m)
+        => OAEPParams hash ByteString ByteString    -- ^ OAEP padding parameters
+        -> PublicKey                                -- ^ public key
+        -> ByteString                               -- ^ plaintext 
+        -> m (Either Error ByteString)
+encrypt oaep pk m = do
+    seed <- getRandomBytes hashLen
+    return $ encryptWithSeed seed oaep pk m
+  where
+    hashLen = hashDigestSize (oaepHash oaep)   
+
+-- | Decrypt ciphertext using private key.
+decrypt :: HashAlgorithm hash
+        => OAEPParams hash ByteString ByteString    -- ^ OAEP padding parameters
+        -> PrivateKey                               -- ^ private key
+        -> ByteString                               -- ^ ciphertext
+        -> Maybe ByteString
+decrypt oaep pk c =
+    let d  = private_d pk    
+        n  = public_n $ private_pub pk
+        k  = numBytes n
+        c' = i2ospOf_ k $ dp2 n $ dp1 d n $ os2ip c
+     in case unpad oaep k c' of
+            Left _  -> Nothing
+            Right p -> Just p   
+
+-- | Sign message using hash algorithm and private key.
+sign :: HashAlgorithm hash
+     => PrivateKey  -- ^ private key
+     -> hash        -- ^ hash function
+     -> ByteString  -- ^ message to sign
+     -> Either Error Integer
+sign pk hashAlg m =
+    let d = private_d pk
+        n = public_n $ private_pub pk
+     in do
+        m' <- ep1 n $ os2ip $ hashWith hashAlg m
+        return $ dp1 d n m' 
+
+-- | Verify signature using hash algorithm and public key.
+verify :: HashAlgorithm hash
+       => PublicKey     -- ^ public key
+       -> hash          -- ^ hash function
+       -> ByteString    -- ^ message
+       -> Integer       -- ^ signature
+       -> Bool
+verify pk hashAlg m s =
+    let n  = public_n pk
+        h  = os2ip $ hashWith hashAlg m
+        h' = dp2 n $ ep2 n s
+     in h' == h
+
+-- | Encryption primitive 1
+ep1 :: Integer -> Integer -> Either Error Integer
+ep1 n m =
+    let m'   = 2*m + 1
+        m''  = 2*m'
+        m''' = 2*m''
+     in case jacobi m' n of
+            Just (-1) | m'' < n -> Right m''
+            Just 1 | m''' < n   -> Right m'''
+            _                   -> Left InvalidParameters
+
+-- | Encryption primitive 2
+ep2 :: Integer -> Integer -> Integer
+ep2 n m = expSafe m 2 n
+
+-- | Decryption primitive 1
+dp1 :: Integer -> Integer -> Integer -> Integer
+dp1 d n c = expSafe c d n
+
+-- | Decryption primitive 2
+dp2 :: Integer -> Integer -> Integer
+dp2 n c = let c'  = c `div` 2
+              c'' = (n - c) `div` 2
+           in case c `mod` 4 of
+                0 -> ((c' `div` 2 - 1) `div` 2)
+                1 -> ((c'' `div` 2 - 1) `div` 2)
+                2 -> ((c' - 1) `div` 2)
+                _ -> ((c'' - 1) `div` 2)

Crypto/PubKey/Rabin/Types.hs

@@ -0,0 +1,43 @@
+-- |
+-- Module      : Crypto.PubKey.Rabin.Types
+-- License     : BSD-style
+-- Maintainer  : Carlos Rodriguez-Vega <crodveg@yahoo.es>
+-- Stability   : experimental
+-- Portability : unknown
+--
+module Crypto.PubKey.Rabin.Types
+    ( Error(..)
+    , generatePrimes
+    ) where
+
+import Crypto.Number.Basic (numBits)
+import Crypto.Number.Prime (generatePrime, findPrimeFromWith)
+import Crypto.Random.Types
+
+type PrimeCondition = Integer -> Bool
+
+-- | Error possible during encryption, decryption or signing.
+data Error = MessageTooLong       -- ^ the message to encrypt is too long
+           | MessageNotRecognized -- ^ the message decrypted doesn't have a OAEP structure
+           | InvalidParameters    -- ^ some parameters lead to breaking assumptions
+           deriving (Show, Eq)
+
+-- | Generate primes p & q
+generatePrimes :: MonadRandom m 
+               => Int                   -- ^ size in bytes          
+               -> PrimeCondition        -- ^ condition prime p must satisfy
+               -> PrimeCondition        -- ^ condition prime q must satisfy
+               -> m (Integer, Integer)  -- ^ chosen distinct primes p and q
+generatePrimes size pCond qCond =
+    let pBits = (8*(size `div` 2))
+        qBits = (8*(size - (size `div` 2)))
+     in do
+        p <- generatePrime' pBits pCond
+        q <- generatePrime' qBits qCond
+        return (p, q)
+      where
+        generatePrime' bits cond = do
+            pr' <- generatePrime bits
+            let pr = findPrimeFromWith cond pr'
+            if numBits pr == bits then return pr
+            else generatePrime' bits cond