1-- |
2-- Module      : Crypto.MAC.HMAC
3-- License     : BSD-style
4-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
5-- Stability   : experimental
6-- Portability : unknown
7--
8-- Provide the HMAC (Hash based Message Authentification Code) base algorithm.
9-- <http://en.wikipedia.org/wiki/HMAC>
10--
11{-# LANGUAGE BangPatterns #-}
12{-# LANGUAGE GeneralizedNewtypeDeriving #-}
13module Crypto.MAC.HMAC
14    ( hmac
15    , HMAC(..)
16    -- * Incremental
17    , Context(..)
18    , initialize
19    , update
20    , updates
21    , finalize
22    ) where
23
24import           Crypto.Hash hiding (Context)
25import qualified Crypto.Hash as Hash (Context)
26import           Crypto.Hash.IO
27import           Crypto.Internal.ByteArray (ScrubbedBytes, ByteArrayAccess)
28import qualified Crypto.Internal.ByteArray as B
29import           Data.Memory.PtrMethods
30import           Crypto.Internal.Compat
31
32-- | Represent an HMAC that is a phantom type with the hash used to produce the mac.
33--
34-- The Eq instance is constant time.  No Show instance is provided, to avoid
35-- printing by mistake.
36newtype HMAC a = HMAC { hmacGetDigest :: Digest a }
37    deriving (ByteArrayAccess)
38
39instance Eq (HMAC a) where
40    (HMAC b1) == (HMAC b2) = B.constEq b1 b2
41
42-- | compute a MAC using the supplied hashing function
43hmac :: (ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a)
44     => key     -- ^ Secret key
45     -> message -- ^ Message to MAC
46     -> HMAC a
47hmac secret msg = finalize $ updates (initialize secret) [msg]
48
49-- | Represent an ongoing HMAC state, that can be appended with 'update'
50-- and finalize to an HMAC with 'hmacFinalize'
51data Context hashalg = Context !(Hash.Context hashalg) !(Hash.Context hashalg)
52
53-- | Initialize a new incremental HMAC context
54initialize :: (ByteArrayAccess key, HashAlgorithm a)
55           => key       -- ^ Secret key
56           -> Context a
57initialize secret = unsafeDoIO (doHashAlg undefined)
58  where
59        doHashAlg :: HashAlgorithm a => a -> IO (Context a)
60        doHashAlg alg = do
61            !withKey <- case B.length secret `compare` blockSize of
62                            EQ -> return $ B.withByteArray secret
63                            LT -> do key <- B.alloc blockSize $ \k -> do
64                                        memSet k 0 blockSize
65                                        B.withByteArray secret $ \s -> memCopy k s (B.length secret)
66                                     return $ B.withByteArray (key :: ScrubbedBytes)
67                            GT -> do
68                                -- hash the secret key
69                                ctx <- hashMutableInitWith alg
70                                hashMutableUpdate ctx secret
71                                digest <- hashMutableFinalize ctx
72                                hashMutableReset ctx
73                                -- pad it if necessary
74                                if digestSize < blockSize
75                                    then do
76                                        key <- B.alloc blockSize $ \k -> do
77                                            memSet k 0 blockSize
78                                            B.withByteArray digest $ \s -> memCopy k s (B.length digest)
79                                        return $ B.withByteArray (key :: ScrubbedBytes)
80                                    else
81                                       return $ B.withByteArray digest
82            (inner, outer) <- withKey $ \keyPtr ->
83                (,) <$> B.alloc blockSize (\p -> memXorWith p 0x36 keyPtr blockSize)
84                    <*> B.alloc blockSize (\p -> memXorWith p 0x5c keyPtr blockSize)
85            return $ Context (hashUpdates initCtx [outer :: ScrubbedBytes])
86                             (hashUpdates initCtx [inner :: ScrubbedBytes])
87          where
88                blockSize  = hashBlockSize alg
89                digestSize = hashDigestSize alg
90                initCtx    = hashInitWith alg
91{-# NOINLINE initialize #-}
92
93-- | Incrementally update a HMAC context
94update :: (ByteArrayAccess message, HashAlgorithm a)
95       => Context a  -- ^ Current HMAC context
96       -> message    -- ^ Message to append to the MAC
97       -> Context a  -- ^ Updated HMAC context
98update (Context octx ictx) msg =
99    Context octx (hashUpdate ictx msg)
100
101-- | Increamentally update a HMAC context with multiple inputs
102updates :: (ByteArrayAccess message, HashAlgorithm a)
103        => Context a -- ^ Current HMAC context
104        -> [message] -- ^ Messages to append to the MAC
105        -> Context a -- ^ Updated HMAC context
106updates (Context octx ictx) msgs =
107    Context octx (hashUpdates ictx msgs)
108
109-- | Finalize a HMAC context and return the HMAC.
110finalize :: HashAlgorithm a
111         => Context a
112         -> HMAC a
113finalize (Context octx ictx) =
114    HMAC $ hashFinalize $ hashUpdates octx [hashFinalize ictx]
115