{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Crypto.MAC.HMAC
( hmac
, hmacLazy
, HMAC(..)
, 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
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
hmac :: (ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a)
=> key
-> message
-> 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]
hmacLazy :: (ByteArrayAccess key, HashAlgorithm a)
=> key
-> L.ByteString
-> 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)
data Context hashalg = Context !(Hash.Context hashalg) !(Hash.Context hashalg)
initialize :: (ByteArrayAccess key, HashAlgorithm a)
=> 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
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
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 #-}
update :: (ByteArrayAccess message, HashAlgorithm a)
=> Context a
-> message
-> Context a
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)
updates :: (ByteArrayAccess message, HashAlgorithm a)
=> Context a
-> [message]
-> Context a
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 :: 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]