-- |
-- Module      : Crypto.MAC.HMAC
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unknown
--
-- Provide the HMAC (Hash based Message Authentification Code) base algorithm.
-- <http://en.wikipedia.org/wiki/HMAC>
--
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Crypto.MAC.HMAC
    ( hmac
    , hmacLazy
    , HMAC(..)
    -- * Incremental
    , Context(..)
    , initialize
    , update
    , updates
    , finalize
    ) where

import           Crypto.Hash hiding (Context)
import qualified Crypto.Hash as Hash (Context)
import           Crypto.Hash.IO
import           Crypto.Internal.ByteArray (ScrubbedBytes, ByteArrayAccess)
import qualified Crypto.Internal.ByteArray as B
import           Data.Memory.PtrMethods
import           Crypto.Internal.Compat
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.  No Show instance is provided, to avoid
-- printing by mistake.
newtype HMAC a = HMAC { forall a. HMAC a -> Digest a
hmacGetDigest :: Digest a }
    deriving (HMAC a -> Int
forall a. HMAC a -> Int
forall p. HMAC a -> Ptr p -> IO ()
forall ba.
(ba -> Int)
-> (forall p a. ba -> (Ptr p -> IO a) -> IO a)
-> (forall p. ba -> Ptr p -> IO ())
-> ByteArrayAccess ba
forall a p. HMAC a -> Ptr p -> IO ()
forall p a. HMAC a -> (Ptr p -> IO a) -> IO a
forall a p a. HMAC a -> (Ptr p -> IO a) -> IO a
copyByteArrayToPtr :: forall p. HMAC a -> Ptr p -> IO ()
$ccopyByteArrayToPtr :: forall a p. HMAC a -> Ptr p -> IO ()
withByteArray :: forall p a. HMAC a -> (Ptr p -> IO a) -> IO a
$cwithByteArray :: forall a p a. HMAC a -> (Ptr p -> IO a) -> IO a
length :: HMAC a -> Int
$clength :: forall a. HMAC a -> Int
ByteArrayAccess)

instance Eq (HMAC a) where
    (HMAC Digest a
b1) == :: HMAC a -> HMAC a -> Bool
== (HMAC Digest a
b2) = forall bs1 bs2.
(ByteArrayAccess bs1, ByteArrayAccess bs2) =>
bs1 -> bs2 -> Bool
B.constEq Digest a
b1 Digest a
b2

-- | 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 :: forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
hmac key
secret message
msg = forall a. HashAlgorithm a => Context a -> HMAC a
finalize forall a b. (a -> b) -> a -> b
$ forall message a.
(ByteArrayAccess message, HashAlgorithm a) =>
Context a -> [message] -> Context a
updates (forall key a.
(ByteArrayAccess key, HashAlgorithm a) =>
key -> Context a
initialize key
secret) [message
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 :: forall key a.
(ByteArrayAccess key, HashAlgorithm a) =>
key -> ByteString -> HMAC a
hmacLazy key
secret ByteString
msg = forall a. HashAlgorithm a => Context a -> HMAC a
finalize forall a b. (a -> b) -> a -> b
$ forall message a.
(ByteArrayAccess message, HashAlgorithm a) =>
Context a -> [message] -> Context a
updates (forall key a.
(ByteArrayAccess key, HashAlgorithm a) =>
key -> Context a
initialize key
secret) (ByteString -> [ByteString]
L.toChunks ByteString
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)

-- | Initialize a new incremental HMAC context
initialize :: (ByteArrayAccess key, HashAlgorithm a)
           => key       -- ^ Secret key
           -> Context a
initialize :: forall key a.
(ByteArrayAccess key, HashAlgorithm a) =>
key -> Context a
initialize key
secret = forall a. IO a -> a
unsafeDoIO (forall a. HashAlgorithm a => a -> IO (Context a)
doHashAlg forall a. HasCallStack => a
undefined)
  where
        doHashAlg :: HashAlgorithm a => a -> IO (Context a)
        doHashAlg :: forall a. HashAlgorithm a => a -> IO (Context a)
doHashAlg a
alg = do
            !(Ptr Word8 -> IO (ScrubbedBytes, ScrubbedBytes))
-> IO (ScrubbedBytes, ScrubbedBytes)
withKey <- case forall ba. ByteArrayAccess ba => ba -> Int
B.length key
secret forall a. Ord a => a -> a -> Ordering
`compare` Int
blockSize of
                            Ordering
EQ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
B.withByteArray key
secret
                            Ordering
LT -> do ScrubbedBytes
key <- forall ba p. ByteArray ba => Int -> (Ptr p -> IO ()) -> IO ba
B.alloc Int
blockSize forall a b. (a -> b) -> a -> b
$ \Ptr Word8
k -> do
                                        Ptr Word8 -> Word8 -> Int -> IO ()
memSet Ptr Word8
k Word8
0 Int
blockSize
                                        forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
B.withByteArray key
secret forall a b. (a -> b) -> a -> b
$ \Ptr Word8
s -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
memCopy Ptr Word8
k Ptr Word8
s (forall ba. ByteArrayAccess ba => ba -> Int
B.length key
secret)
                                     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
B.withByteArray (ScrubbedBytes
key :: ScrubbedBytes)
                            Ordering
GT -> do
                                -- hash the secret key
                                MutableContext a
ctx <- forall alg. HashAlgorithm alg => alg -> IO (MutableContext alg)
hashMutableInitWith a
alg
                                forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
MutableContext a -> ba -> IO ()
hashMutableUpdate MutableContext a
ctx key
secret
                                Digest a
digest <- forall a. HashAlgorithm a => MutableContext a -> IO (Digest a)
hashMutableFinalize MutableContext a
ctx
                                forall a. HashAlgorithm a => MutableContext a -> IO ()
hashMutableReset MutableContext a
ctx
                                -- pad it if necessary
                                if Int
digestSize forall a. Ord a => a -> a -> Bool
< Int
blockSize
                                    then do
                                        ScrubbedBytes
key <- forall ba p. ByteArray ba => Int -> (Ptr p -> IO ()) -> IO ba
B.alloc Int
blockSize forall a b. (a -> b) -> a -> b
$ \Ptr Word8
k -> do
                                            Ptr Word8 -> Word8 -> Int -> IO ()
memSet Ptr Word8
k Word8
0 Int
blockSize
                                            forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
B.withByteArray Digest a
digest forall a b. (a -> b) -> a -> b
$ \Ptr Word8
s -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
memCopy Ptr Word8
k Ptr Word8
s (forall ba. ByteArrayAccess ba => ba -> Int
B.length Digest a
digest)
                                        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
B.withByteArray (ScrubbedBytes
key :: ScrubbedBytes)
                                    else
                                       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall ba p a. ByteArrayAccess ba => ba -> (Ptr p -> IO a) -> IO a
B.withByteArray Digest a
digest
            (ScrubbedBytes
inner, ScrubbedBytes
outer) <- (Ptr Word8 -> IO (ScrubbedBytes, ScrubbedBytes))
-> IO (ScrubbedBytes, ScrubbedBytes)
withKey forall a b. (a -> b) -> a -> b
$ \Ptr Word8
keyPtr ->
                (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall ba p. ByteArray ba => Int -> (Ptr p -> IO ()) -> IO ba
B.alloc Int
blockSize (\Ptr Word8
p -> Ptr Word8 -> Word8 -> Ptr Word8 -> Int -> IO ()
memXorWith Ptr Word8
p Word8
0x36 Ptr Word8
keyPtr Int
blockSize)
                    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall ba p. ByteArray ba => Int -> (Ptr p -> IO ()) -> IO ba
B.alloc Int
blockSize (\Ptr Word8
p -> Ptr Word8 -> Word8 -> Ptr Word8 -> Int -> IO ()
memXorWith Ptr Word8
p Word8
0x5c Ptr Word8
keyPtr Int
blockSize)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall hashalg.
Context hashalg -> Context hashalg -> Context hashalg
Context (forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
Context a -> [ba] -> Context a
hashUpdates Context a
initCtx [ScrubbedBytes
outer :: ScrubbedBytes])
                             (forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
Context a -> [ba] -> Context a
hashUpdates Context a
initCtx [ScrubbedBytes
inner :: ScrubbedBytes])
          where 
                blockSize :: Int
blockSize  = forall a. HashAlgorithm a => a -> Int
hashBlockSize a
alg
                digestSize :: Int
digestSize = forall a. HashAlgorithm a => a -> Int
hashDigestSize a
alg
                initCtx :: Context a
initCtx    = forall alg. HashAlgorithm alg => alg -> Context alg
hashInitWith a
alg
{-# NOINLINE initialize #-}

-- | Incrementally update a HMAC context
update :: (ByteArrayAccess message, HashAlgorithm a)
       => Context a  -- ^ Current HMAC context
       -> message    -- ^ Message to append to the MAC
       -> Context a  -- ^ Updated HMAC context
update :: forall message a.
(ByteArrayAccess message, HashAlgorithm a) =>
Context a -> message -> Context a
update (Context Context a
octx Context a
ictx) message
msg =
    forall hashalg.
Context hashalg -> Context hashalg -> Context hashalg
Context Context a
octx (forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate Context a
ictx message
msg)

-- | Increamentally update a HMAC context with multiple inputs
updates :: (ByteArrayAccess message, HashAlgorithm a)
        => Context a -- ^ Current HMAC context
        -> [message] -- ^ Messages to append to the MAC
        -> Context a -- ^ Updated HMAC context
updates :: forall message a.
(ByteArrayAccess message, HashAlgorithm a) =>
Context a -> [message] -> Context a
updates (Context Context a
octx Context a
ictx) [message]
msgs =
    forall hashalg.
Context hashalg -> Context hashalg -> Context hashalg
Context Context a
octx (forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
Context a -> [ba] -> Context a
hashUpdates Context a
ictx [message]
msgs)

-- | Finalize a HMAC context and return the HMAC.
finalize :: HashAlgorithm a
         => Context a
         -> HMAC a
finalize :: forall a. HashAlgorithm a => Context a -> HMAC a
finalize (Context Context a
octx Context a
ictx) =
    forall a. Digest a -> HMAC a
HMAC forall a b. (a -> b) -> a -> b
$ forall a. HashAlgorithm a => Context a -> Digest a
hashFinalize forall a b. (a -> b) -> a -> b
$ forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
Context a -> [ba] -> Context a
hashUpdates Context a
octx [forall a. HashAlgorithm a => Context a -> Digest a
hashFinalize Context a
ictx]