Merge pull request #276 from ocheron/kmac

Keccak Message Authentication Code (KMAC)

Crypto/Hash/SHAKE.hs

@@ -17,7 +17,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 module Crypto.Hash.SHAKE
-    (  SHAKE128 (..), SHAKE256 (..)
+    (  SHAKE128 (..), SHAKE256 (..), HashSHAKE (..)
     ) where
 
 import           Control.Monad (when)
@@ -32,6 +32,13 @@ import           Data.Proxy (Proxy(..))
 import           GHC.TypeLits (Nat, KnownNat, type (+))
 import           Crypto.Internal.Nat
 
+-- | Type class of SHAKE algorithms.
+class HashAlgorithm a => HashSHAKE a where
+    -- | Alternate finalization needed for cSHAKE
+    cshakeInternalFinalize :: Ptr (Context a) -> Ptr (Digest a) -> IO ()
+    -- | Get the digest bit length
+    cshakeOutputLength :: a -> Int
+
 -- | SHAKE128 (128 bits) extendable output function.  Supports an arbitrary
 -- digest size, to be specified as a type parameter of kind 'Nat'.
 --
@@ -52,6 +59,10 @@ instance KnownNat bitlen => HashAlgorithm (SHAKE128 bitlen) where
     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)
+
 -- | SHAKE256 (256 bits) extendable output function.  Supports an arbitrary
 -- digest size, to be specified as a type parameter of kind 'Nat'.
 --
@@ -72,6 +83,10 @@ instance KnownNat bitlen => HashAlgorithm (SHAKE256 bitlen) where
     hashInternalUpdate        = c_sha3_update
     hashInternalFinalize      = shakeFinalizeOutput (Proxy :: Proxy bitlen)
 
+instance KnownNat bitlen => HashSHAKE (SHAKE256 bitlen) where
+    cshakeInternalFinalize = cshakeFinalizeOutput (Proxy :: Proxy bitlen)
+    cshakeOutputLength _ = integralNatVal (Proxy :: Proxy bitlen)
+
 shakeFinalizeOutput :: KnownNat bitlen
                     => proxy bitlen
                     -> Ptr (Context a)
@@ -82,6 +97,16 @@ shakeFinalizeOutput d ctx dig = do
     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
@@ -100,5 +125,8 @@ 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 ()

Crypto/MAC/KMAC.hs

@@ -0,0 +1,169 @@
+-- |
+-- 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           Foreign.Ptr (Ptr, plusPtr)
+import           Foreign.Storable (poke)
+import           Data.Bits (shiftR)
+import           Data.ByteArray (ByteArray, ByteArrayAccess)
+import qualified Data.ByteArray as B
+import           Data.Word (Word8)
+import           Data.Memory.PtrMethods (memSet)
+
+
+-- 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 = builderAllocAndFreeze (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
+
+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 = builderAllocAndFreeze (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 = builderAllocAndFreeze (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)
+
+
+-- Delaying and merging ByteArray allocations
+
+data Builder = Builder !Int (Ptr Word8 -> IO ())  -- size and initializer
+
+(<+>) :: Builder -> Builder -> Builder
+(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
+
+builderAllocAndFreeze :: ByteArray ba => Builder -> ba
+builderAllocAndFreeze (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 = Builder s (\p -> memSet p 0 s)

cbits/cryptonite_sha3.c

@@ -99,8 +99,11 @@ static inline void sha3_do_chunk(uint64_t state[25], uint64_t buf[], int bufsz)
 }
 
 /*
- * Initialize a SHA-3 / SHAKE context: hashlen is the security level (and
+ * Initialize a SHA-3 / SHAKE / cSHAKE context: hashlen is the security level
- * half the capacity) in bits
+ * (and half the capacity) in bits.
+ *
+ * In case of cSHAKE, the message prefix with encoded N and S must be added with
+ * cryptonite_sha3_update.
  */
 void cryptonite_sha3_init(struct sha3_ctx *ctx, uint32_t hashlen)
 {
@@ -110,7 +113,7 @@ void cryptonite_sha3_init(struct sha3_ctx *ctx, uint32_t hashlen)
 	ctx->bufsz = bufsz;
 }
 
-/* Update a SHA-3 / SHAKE context */
+/* Update a SHA-3 / SHAKE / cSHAKE context */
 void cryptonite_sha3_update(struct sha3_ctx *ctx, const uint8_t *data, uint32_t len)
 {
 	uint32_t to_fill;
@@ -171,7 +174,7 @@ void cryptonite_sha3_finalize_with_pad_byte(struct sha3_ctx *ctx, uint8_t pad_by
 }
 
 /*
- * Extract some bytes from a finalized SHA-3 / SHAKE context.
+ * Extract some bytes from a finalized SHA-3 / SHAKE / cSHAKE context.
  * May be called multiple times.
  */
 void cryptonite_sha3_output(struct sha3_ctx *ctx, uint8_t *out, uint32_t len)
@@ -226,6 +229,12 @@ void cryptonite_sha3_finalize_shake(struct sha3_ctx *ctx)
 	cryptonite_sha3_finalize_with_pad_byte(ctx, 0x1F);
 }
 
+/* Finalize a cSHAKE context. Output is read using cryptonite_sha3_output. */
+void cryptonite_sha3_finalize_cshake(struct sha3_ctx *ctx)
+{
+	cryptonite_sha3_finalize_with_pad_byte(ctx, 0x04);
+}
+
 void cryptonite_keccak_init(struct sha3_ctx *ctx, uint32_t hashlen)
 {
 	cryptonite_sha3_init(ctx, hashlen);

cbits/cryptonite_sha3.h

@@ -57,6 +57,7 @@ void cryptonite_sha3_update(struct sha3_ctx *ctx, const uint8_t *data, uint32_t
 void cryptonite_sha3_finalize(struct sha3_ctx *ctx, uint32_t hashlen, uint8_t *out);
 
 void cryptonite_sha3_finalize_shake(struct sha3_ctx *ctx);
+void cryptonite_sha3_finalize_cshake(struct sha3_ctx *ctx);
 void cryptonite_sha3_output(struct sha3_ctx *ctx, uint8_t *out, uint32_t len);
 
 void cryptonite_keccak_init(struct sha3_ctx *ctx, uint32_t hashlen);

cryptonite.cabal

@@ -8,7 +8,7 @@ Description:
     .
     * Hash: SHA1, SHA2, SHA3, SHAKE, MD2, MD4, MD5, Keccak, Skein, Ripemd, Tiger, Whirlpool, Blake2
     .
-    * MAC: HMAC, Poly1305
+    * MAC: HMAC, KMAC, Poly1305
     .
     * Asymmetric crypto: DSA, RSA, DH, ECDH, ECDSA, ECC, Curve25519, Curve448, Ed25519, Ed448
     .
@@ -126,6 +126,7 @@ Library
                      Crypto.MAC.CMAC
                      Crypto.MAC.Poly1305
                      Crypto.MAC.HMAC
+                     Crypto.MAC.KMAC
                      Crypto.Number.Basic
                      Crypto.Number.F2m
                      Crypto.Number.Generate
@@ -404,6 +405,7 @@ Test-Suite test-cryptonite
                      KAT_CMAC
                      KAT_HKDF
                      KAT_HMAC
+                     KAT_KMAC
                      KAT_MiyaguchiPreneel
                      KAT_PBKDF2
                      KAT_OTP

tests/KAT_KMAC.hs

@@ -0,0 +1,129 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module KAT_KMAC (tests) where
+
+import           Crypto.Hash (SHAKE128(..), SHAKE256(..),
+                              HashAlgorithm, digestFromByteString)
+import qualified Crypto.MAC.KMAC as KMAC
+
+import qualified Data.ByteString as B
+
+import Imports
+
+data MACVector hash = MACVector
+    { macString :: ByteString
+    , macKey    :: ByteString
+    , macSecret :: ByteString
+    , macResult :: KMAC.KMAC hash
+    }
+
+instance Show (KMAC.KMAC a) where
+    show (KMAC.KMAC d) = show d
+
+digest :: HashAlgorithm hash => ByteString -> KMAC.KMAC hash
+digest = maybe (error "cannot get digest") KMAC.KMAC . digestFromByteString
+
+vectors128 :: [MACVector (SHAKE128 256)]
+vectors128 =
+    [ MACVector
+        { macString = ""
+        , macKey    = B.pack [ 0x40 .. 0x5f ]
+        , macSecret = B.pack [ 0x00 .. 0x03 ]
+        , macResult = digest "\xe5\x78\x0b\x0d\x3e\xa6\xf7\xd3\xa4\x29\xc5\x70\x6a\xa4\x3a\x00\xfa\xdb\xd7\xd4\x96\x28\x83\x9e\x31\x87\x24\x3f\x45\x6e\xe1\x4e"
+        }
+    , MACVector
+        { macString = "My Tagged Application"
+        , macKey    = B.pack [ 0x40 .. 0x5f ]
+        , macSecret = B.pack [ 0x00 .. 0x03 ]
+        , macResult = digest "\x3b\x1f\xba\x96\x3c\xd8\xb0\xb5\x9e\x8c\x1a\x6d\x71\x88\x8b\x71\x43\x65\x1a\xf8\xba\x0a\x70\x70\xc0\x97\x9e\x28\x11\x32\x4a\xa5"
+        }
+    , MACVector
+        { macString = "My Tagged Application"
+        , macKey    = B.pack [ 0x40 .. 0x5f ]
+        , macSecret = B.pack [ 0x00 .. 0xc7 ]
+        , macResult = digest "\x1f\x5b\x4e\x6c\xca\x02\x20\x9e\x0d\xcb\x5c\xa6\x35\xb8\x9a\x15\xe2\x71\xec\xc7\x60\x07\x1d\xfd\x80\x5f\xaa\x38\xf9\x72\x92\x30"
+        }
+    ]
+
+vectors256 :: [MACVector (SHAKE256 512)]
+vectors256 =
+    [ MACVector
+        { macString = "My Tagged Application"
+        , macKey    = B.pack [ 0x40 .. 0x5f ]
+        , macSecret = B.pack [ 0x00 .. 0x03 ]
+        , macResult = digest "\x20\xc5\x70\xc3\x13\x46\xf7\x03\xc9\xac\x36\xc6\x1c\x03\xcb\x64\xc3\x97\x0d\x0c\xfc\x78\x7e\x9b\x79\x59\x9d\x27\x3a\x68\xd2\xf7\xf6\x9d\x4c\xc3\xde\x9d\x10\x4a\x35\x16\x89\xf2\x7c\xf6\xf5\x95\x1f\x01\x03\xf3\x3f\x4f\x24\x87\x10\x24\xd9\xc2\x77\x73\xa8\xdd"
+        }
+    , MACVector
+        { macString = ""
+        , macKey    = B.pack [ 0x40 .. 0x5f ]
+        , macSecret = B.pack [ 0x00 .. 0xc7 ]
+        , macResult = digest "\x75\x35\x8c\xf3\x9e\x41\x49\x4e\x94\x97\x07\x92\x7c\xee\x0a\xf2\x0a\x3f\xf5\x53\x90\x4c\x86\xb0\x8f\x21\xcc\x41\x4b\xcf\xd6\x91\x58\x9d\x27\xcf\x5e\x15\x36\x9c\xbb\xff\x8b\x9a\x4c\x2e\xb1\x78\x00\x85\x5d\x02\x35\xff\x63\x5d\xa8\x25\x33\xec\x6b\x75\x9b\x69"
+        }
+    , MACVector
+        { macString = "My Tagged Application"
+        , macKey    = B.pack [ 0x40 .. 0x5f ]
+        , macSecret = B.pack [ 0x00 .. 0xc7 ]
+        , macResult = digest "\xb5\x86\x18\xf7\x1f\x92\xe1\xd5\x6c\x1b\x8c\x55\xdd\xd7\xcd\x18\x8b\x97\xb4\xca\x4d\x99\x83\x1e\xb2\x69\x9a\x83\x7d\xa2\xe4\xd9\x70\xfb\xac\xfd\xe5\x00\x33\xae\xa5\x85\xf1\xa2\x70\x85\x10\xc3\x2d\x07\x88\x08\x01\xbd\x18\x28\x98\xfe\x47\x68\x76\xfc\x89\x65"
+        }
+    ]
+
+macTests :: [TestTree]
+macTests =
+    [ testGroup "SHAKE128" (concatMap toMACTest $ zip is vectors128)
+    , testGroup "SHAKE256" (concatMap toMACTest $ zip is vectors256)
+    ]
+    where toMACTest (i, MACVector{..}) =
+            [ testCase (show i) (macResult @=? KMAC.kmac macString macKey macSecret)
+            , testCase ("incr-" ++ show i) (macResult @=?
+                        KMAC.finalize (KMAC.update (KMAC.initialize macString macKey) macSecret))
+            ]
+          is :: [Int]
+          is = [1..]
+
+data MacIncremental a = MacIncremental ByteString ByteString ByteString (KMAC.KMAC a)
+    deriving (Show,Eq)
+
+instance KMAC.HashSHAKE a => Arbitrary (MacIncremental a) where
+    arbitrary = do
+        str <- arbitraryBSof 0 49
+        key <- arbitraryBSof 1 89
+        msg <- arbitraryBSof 1 99
+        return $ MacIncremental str key msg (KMAC.kmac str key msg)
+
+data MacIncrementalList a = MacIncrementalList ByteString ByteString [ByteString] (KMAC.KMAC a)
+    deriving (Show,Eq)
+
+instance KMAC.HashSHAKE a => Arbitrary (MacIncrementalList a) where
+    arbitrary = do
+        str  <- arbitraryBSof 0 49
+        key  <- arbitraryBSof 1 89
+        msgs <- choose (1,20) >>= \n -> replicateM n (arbitraryBSof 1 99)
+        return $ MacIncrementalList str key msgs (KMAC.kmac str key (B.concat msgs))
+
+macIncrementalTests :: [TestTree]
+macIncrementalTests =
+    [ testIncrProperties "SHAKE128_256" (SHAKE128 :: SHAKE128 256)
+    , testIncrProperties "SHAKE256_512" (SHAKE256 :: SHAKE256 512)
+    ]
+  where
+        testIncrProperties :: KMAC.HashSHAKE a => TestName -> a -> TestTree
+        testIncrProperties name a = testGroup name
+            [ testProperty "list-one" (prop_inc0 a)
+            , testProperty "list-multi" (prop_inc1 a)
+            ]
+
+        prop_inc0 :: KMAC.HashSHAKE a => a -> MacIncremental a -> Bool
+        prop_inc0 _ (MacIncremental str secret msg result) =
+            result `assertEq` KMAC.finalize (KMAC.update (KMAC.initialize str secret) msg)
+
+        prop_inc1 :: KMAC.HashSHAKE a => a -> MacIncrementalList a -> Bool
+        prop_inc1 _ (MacIncrementalList str secret msgs result) =
+            result `assertEq` KMAC.finalize (foldl' KMAC.update (KMAC.initialize str secret) msgs)
+
+tests = testGroup "KMAC"
+    [ testGroup "KATs" macTests
+    , testGroup "properties" macIncrementalTests
+    ]

tests/Tests.hs

@@ -18,6 +18,7 @@ import qualified ChaChaPoly1305
 import qualified KAT_MiyaguchiPreneel
 import qualified KAT_CMAC
 import qualified KAT_HMAC
+import qualified KAT_KMAC
 import qualified KAT_HKDF
 import qualified KAT_Argon2
 import qualified KAT_PBKDF2
@@ -53,6 +54,7 @@ tests = testGroup "cryptonite"
         [ Poly1305.tests
         , KAT_CMAC.tests
         , KAT_HMAC.tests
+        , KAT_KMAC.tests
         ]
     , KAT_Curve25519.tests
     , KAT_Curve448.tests