CMAC.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- |
-- Module      : Crypto.MAC.CMAC
-- License     : BSD-style
-- Maintainer  : Kei Hibino <ex8k.hibino@gmail.com>
-- Stability   : experimental
-- Portability : unknown
--
-- Provide the CMAC (Cipher based Message Authentification Code) base algorithm.
-- <http://en.wikipedia.org/wiki/CMAC>
-- <http://csrc.nist.gov/publications/nistpubs/800-38B/SP_800-38B.pdf>
module Crypto.MAC.CMAC (
    cmac,
    CMAC,
    subKeys,
) where

import Data.Bits (setBit, shiftL, testBit)
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import Data.Word

import Crypto.Cipher.Types
import Crypto.Cipher.Types.Block (IV (..))
import Crypto.Internal.ByteArray (ByteArray, ByteArrayAccess, Bytes)
import qualified Crypto.Internal.ByteArray as B

-- | Authentication code
newtype CMAC a = CMAC Bytes
    deriving (ByteArrayAccess)

instance Eq (CMAC a) where
    CMAC b1 == CMAC b2 = B.constEq b1 b2

-- | compute a MAC using the supplied cipher
cmac
    :: (ByteArrayAccess bin, BlockCipher cipher)
    => cipher
    -- ^ key to compute CMAC with
    -> bin
    -- ^ input message
    -> CMAC cipher
    -- ^ output tag
cmac k msg = CMAC $ B.convert $ step (chain zeroV whole) final
  where
    bytes = blockSize k
    zeroV = S.replicate bytes 0
    (k1, k2) = subKeys k

    -- The message is held as a ByteString and sliced, never consumed.  'Bytes'
    -- has no shared representation, so splitting one repeatedly -- which is
    -- what this used to do, once per block -- copied whatever was left of the
    -- message each time, and so the message about n/2 times in all.
    msgBytes = B.convert msg :: ByteString
    msgLen = S.length msgBytes

    -- the last block is the one the subkeys are for, and it is a whole block
    -- only when there is one to be had
    lastLen
        | msgLen > 0 && msgLen `mod` bytes == 0 = bytes
        | otherwise = msgLen `mod` bytes
    (whole, rest) = S.splitAt (msgLen - lastLen) msgBytes
    final
        | lastLen == bytes = bxor k1 rest
        | otherwise =
            bxor k2 $
                S.concat [rest, S.singleton 0x80, S.replicate (bytes - lastLen - 1) 0]

    -- CMAC chains its blocks the way CBC does, so the running state is the
    -- last ciphertext block of a CBC encryption.  Handing the cipher a chunk
    -- at a time rather than a block at a time is what makes that worth saying:
    -- for AES it reaches the C implementation of CBC, where a block at a time
    -- reached a foreign call per sixteen bytes.
    chunkBytes = bytes * 2048
    chain !c bs
        | S.null bs = c
        | otherwise =
            let (hd, tl) = S.splitAt chunkBytes bs
                out = cbcEncrypt k (IV c) hd
             in chain (S.drop (S.length hd - bytes) out) tl

    step c m = ecbEncrypt k (bxor c m) :: ByteString

-- | make sub-keys used in CMAC
subKeys
    :: (BlockCipher k, ByteArray ba)
    => k
    -- ^ key to compute CMAC with
    -> (ba, ba)
    -- ^ sub-keys to compute CMAC
subKeys k = (k1, k2)
  where
    ipt = cipherIPT k
    k0 = ecbEncrypt k $ B.replicate (blockSize k) 0
    k1 = subKey ipt k0
    k2 = subKey ipt k1

-- polynomial multiply operation to culculate subkey
subKey :: ByteArray ba => [Word8] -> ba -> ba
subKey ipt ws = case B.unpack ws of
    [] -> B.empty
    w : _
        | testBit w 7 -> B.pack ipt `bxor` shiftL1 ws
        | otherwise -> shiftL1 ws

shiftL1 :: ByteArray ba => ba -> ba
shiftL1 = B.pack . shiftL1W . B.unpack

shiftL1W :: [Word8] -> [Word8]
shiftL1W [] = []
shiftL1W ws@(_ : ns) = rec' $ zip ws (ns ++ [0])
  where
    rec' [] = []
    rec' ((x, y) : ps) = w : rec' ps
      where
        w
            | testBit y 7 = setBit sl1 0
            | otherwise = sl1
          where
            sl1 = shiftL x 1

bxor :: ByteArray ba => ba -> ba -> ba
bxor = B.bxor

-----

cipherIPT :: BlockCipher k => k -> [Word8]
cipherIPT = expandIPT . blockSize

-- Data type which represents the smallest irreducibule binary polynomial
-- against specified degree.
--
-- Maximum degree bit and degree 0 bit are omitted.
-- For example, The value /Q 7 2 1/ corresponds to the degree /128/.
-- It represents that the smallest irreducible binary polynomial of degree 128
-- is x^128 + x^7 + x^2 + x^1 + 1.
data IPolynomial
    = Q Int Int Int

---  | T Int

iPolynomial :: Int -> Maybe IPolynomial
iPolynomial = d
  where
    d 64 = Just $ Q 4 3 1
    d 128 = Just $ Q 7 2 1
    d _ = Nothing

-- Expand a tail bit pattern of irreducible binary polynomial
expandIPT :: Int -> [Word8]
expandIPT bytes = expandIPT' bytes ipt
  where
    ipt =
        maybe
            ( error $
                "Irreducible binary polynomial not defined against " ++ show nb ++ " bit"
            )
            id
            $ iPolynomial nb
    nb = bytes * 8

-- Expand a tail bit pattern of irreducible binary polynomial
expandIPT'
    :: Int
    -- ^ width in byte
    -> IPolynomial
    -- ^ irreducible binary polynomial definition
    -> [Word8]
    -- ^ result bit pattern
expandIPT' bytes (Q x y z) =
    reverse . setB x . setB y . setB z . setB 0 $ replicate bytes 0
  where
    setB i ws = case tl of
        (a : as) -> hd ++ setBit a r : as
        _ -> error "expandIPT'"
      where
        (q, r) = i `quotRem` 8
        (hd, tl) = splitAt q ws