{-|
Module      : Z.Crypto.MAC
Description : Message Authentication Codes (MAC)
Copyright   : YouShi, Dong Han, 2021
License     : BSD
Maintainer  : winterland1989@gmail.com
Stability   : experimental
Portability : non-portable

A Message Authentication Code algorithm computes a tag over a message utilizing a shared secret key. Thus a valid tag confirms the authenticity and integrity of the message. Only entities in possession of the shared secret key are able to verify the tag.

-}

module Z.Crypto.MAC (
    -- * MAC type
    MACType(..)
  , MAC, macName, macSize
    -- * IUF interface
  , newMAC
  , setKeyMAC
  , updateMAC
  , finalMAC
  , clearMAC
  -- * function interface
  , mac, macChunks
  -- * BIO interface
  , sinkToMAC
  -- * Internal helper
  , macTypeToCBytes
  , withMAC
    -- * re-export
  , HashType(..), BlockCipherType(..)
  , module Z.Crypto.SafeMem
  ) where

import           GHC.Generics
import           System.IO.Unsafe  (unsafePerformIO)
import           Z.Botan.Exception
import           Z.Botan.FFI
import           Z.Crypto.SafeMem
import           Z.Crypto.Cipher   (BlockCipherType(..), blockCipherTypeToCBytes)
import           Z.Crypto.Hash     (HashType(..), hashTypeToCBytes)
import           Z.Data.CBytes     as CB
import           Z.Data.JSON       (JSON)
import qualified Z.Data.Text       as T
import qualified Z.Data.Vector     as V
import           Z.Foreign
import           Z.IO.BIO


data MACType = CMAC BlockCipherType
                -- ^ A modern CBC-MAC variant that avoids the security problems of plain CBC-MAC.
                -- Approved by NIST. Also sometimes called OMAC.
             | GMAC BlockCipherType
               -- ^ GMAC is related to the GCM authenticated cipher mode.
               -- It is quite slow unless hardware support for carryless multiplications is available.
               --  A new nonce must be used with each message authenticated, or otherwise all security is lost.
             | CBC_MAC BlockCipherType
              -- ^ An older authentication code based on a block cipher.
              -- Serious security problems,
              -- in particular insecure if messages of several different lengths are authenticated.
              --  Avoid unless required for compatibility.
             | HMAC HashType
              -- ^ A message authentication code based on a hash function. Very commonly used.
             | Poly1305
             -- ^ A polynomial mac (similar to GMAC). Very fast, but tricky to use safely.
             -- Forms part of the ChaCha20Poly1305 AEAD mode.
             -- A new key must be used for each message, or all security is lost.
             | SipHash Int Int
             -- ^ A modern and very fast PRF. Produces only a 64-bit output.
             -- Defaults to “SipHash(2,4)” which is the recommended configuration,
             -- using 2 rounds for each input block and 4 rounds for finalization.
             | X9'19_MAC
             -- ^ A CBC-MAC variant sometimes used in finance. Always uses DES.
             -- Sometimes called the “DES retail MAC”, also standardized in ISO 9797-1.
             -- It is slow and has known attacks. Avoid unless required.
  deriving (Show, Read, Eq, Ord, Generic)
  deriving anyclass (T.Print, JSON)

macTypeToCBytes :: MACType -> CBytes
macTypeToCBytes (CMAC bc   ) = CB.concat ["CMAC(", blockCipherTypeToCBytes bc, ")"]
macTypeToCBytes (GMAC bc   ) = CB.concat ["GMAC(", blockCipherTypeToCBytes bc, ")"]
macTypeToCBytes (CBC_MAC bc) = CB.concat ["CBC-MAC(", blockCipherTypeToCBytes bc, ")"]
macTypeToCBytes (HMAC ht)    = CB.concat ["HMAC(", hashTypeToCBytes ht, ")"]
macTypeToCBytes Poly1305     = "Poly1305"
macTypeToCBytes (SipHash r1 r2) = CB.concat ["SipHash(", sizeCBytes r1, ",", sizeCBytes r2, ")"]
  where
    sizeCBytes = CB.fromText . T.toText
macTypeToCBytes X9'19_MAC = "X9.19-MAC"

data MAC = MAC
    { macStruct :: {-# UNPACK #-} !BotanStruct
    , macName   :: {-# UNPACK #-} !CBytes             -- ^ mac algo name
    , macSize   :: {-# UNPACK #-} !Int                -- ^ mac output size in bytes
    }
    deriving (Show, Generic)
    deriving anyclass T.Print

-- | Pass MAC to FFI as 'botan_mac_t'.
withMAC :: MAC -> (BotanStructT -> IO r) -> IO r
{-# INLINABLE withMAC #-}
withMAC (MAC m _ _) = withBotanStruct m

-- | Create a new 'MAC' object.
newMAC :: HasCallStack => MACType -> IO MAC
{-# INLINABLE newMAC #-}
newMAC typ = do
    let name = macTypeToCBytes typ
    bs <- newBotanStruct
        (\ bts -> withCBytesUnsafe name $ \ pt ->
            (botan_mac_init bts pt 0))
        botan_mac_destroy
    (osiz, _) <- withBotanStruct bs $ \ pbs ->
        allocPrimUnsafe @CSize $ \ pl ->
            botan_mac_output_length pbs pl
    return (MAC bs name (fromIntegral osiz))

-- | Set the random key.
setKeyMAC :: HasCallStack => MAC -> Secret -> IO ()
{-# INLINABLE setKeyMAC #-}
setKeyMAC (MAC bts _ _) key =
    withBotanStruct bts $ \pbts->
        withSecret key $ \ pk klen ->
            throwBotanIfMinus_ (botan_mac_set_key pbts pk klen)

-- | Feed a chunk of input into a 'MAC' object.
updateMAC :: HasCallStack => MAC -> V.Bytes -> IO ()
{-# INLINABLE updateMAC #-}
updateMAC (MAC bts _ _) bs =
    withBotanStruct bts $ \ pbts ->
        withPrimVectorUnsafe bs $ \ pbs off len ->
            throwBotanIfMinus_ (hs_botan_mac_update pbts pbs off len)

finalMAC :: HasCallStack => MAC -> IO CEBytes
{-# INLINABLE finalMAC #-}
finalMAC (MAC bts _ siz) =
    withBotanStruct bts $ \ pbts -> do
        newCEBytesUnsafe siz (\ pout ->
            throwBotanIfMinus_ (botan_mac_final pbts pout))

-- | Reset the state of MAC object back to clean, as if no input has been supplied.
clearMAC :: HasCallStack => MAC -> IO ()
{-# INLINABLE clearMAC #-}
clearMAC (MAC bts _ _) =
    throwBotanIfMinus_ (withBotanStruct bts hs_botan_mac_clear)

-- | Trun 'MAC' to a 'V.Bytes' sink, update 'MAC' by write bytes to the sink.
--
sinkToMAC :: HasCallStack => MAC -> Sink V.Bytes
{-# INLINABLE sinkToMAC #-}
sinkToMAC h = \ k mbs -> case mbs of
    Just bs -> updateMAC h bs
    _       -> k EOF

-- | Directly compute a message's mac
mac :: HasCallStack => MACType
                    -> Secret   -- ^ key
                    -> V.Bytes  -- ^ input
                    -> CEBytes
{-# INLINABLE mac #-}
mac mt key inp = unsafePerformIO $ do
    m <- newMAC mt
    setKeyMAC m key
    updateMAC m inp
    finalMAC m

-- | Directly compute a chunked message's mac.
macChunks :: HasCallStack => MACType -> Secret -> [V.Bytes] -> CEBytes
{-# INLINABLE macChunks #-}
macChunks mt key inps = unsafePerformIO $ do
    m <- newMAC mt
    setKeyMAC m key
    mapM_ (updateMAC m) inps
    finalMAC m