{-|
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
  ) where

import           GHC.Generics
import           System.IO.Unsafe  (unsafePerformIO)
import           Z.Botan.Exception
import           Z.Botan.FFI
import           Z.Crypto.Cipher   (BlockCipherType, blockCipherTypeToCBytes)
import           Z.Crypto.Hash     (HashType, hashTypeToCBytes)
import           Z.Data.CBytes     as CB
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.

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

data MAC = MAC
    { MAC -> BotanStruct
macStruct :: {-# UNPACK #-} !BotanStruct
    , MAC -> CBytes
macName   :: {-# UNPACK #-} !CBytes             -- ^ mac algo name
    , MAC -> Int
macSize   :: {-# UNPACK #-} !Int                -- ^ mac output size in bytes
    }
    deriving (Int -> MAC -> ShowS
[MAC] -> ShowS
MAC -> String
(Int -> MAC -> ShowS)
-> (MAC -> String) -> ([MAC] -> ShowS) -> Show MAC
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MAC] -> ShowS
$cshowList :: [MAC] -> ShowS
show :: MAC -> String
$cshow :: MAC -> String
showsPrec :: Int -> MAC -> ShowS
$cshowsPrec :: Int -> MAC -> ShowS
Show, (forall x. MAC -> Rep MAC x)
-> (forall x. Rep MAC x -> MAC) -> Generic MAC
forall x. Rep MAC x -> MAC
forall x. MAC -> Rep MAC x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MAC x -> MAC
$cfrom :: forall x. MAC -> Rep MAC x
Generic)
    deriving anyclass Int -> MAC -> Builder ()
(Int -> MAC -> Builder ()) -> Print MAC
forall a. (Int -> a -> Builder ()) -> Print a
toUTF8BuilderP :: Int -> MAC -> Builder ()
$ctoUTF8BuilderP :: Int -> MAC -> Builder ()
T.Print

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

-- | Create a new 'MAC' object.
newMAC :: HasCallStack => MACType -> IO MAC
{-# INLINABLE newMAC #-}
newMAC :: MACType -> IO MAC
newMAC MACType
typ = do
    let name :: CBytes
name = MACType -> CBytes
macTypeToCBytes MACType
typ
    BotanStruct
bs <- (MBA# BotanStructT -> IO CInt)
-> FunPtr (BotanStructT -> IO ()) -> IO BotanStruct
forall a.
HasCallStack =>
(MBA# BotanStructT -> IO CInt)
-> FunPtr (BotanStructT -> IO a) -> IO BotanStruct
newBotanStruct
        (\ MBA# BotanStructT
bts -> CBytes -> (BA# Word8 -> IO CInt) -> IO CInt
forall a. CBytes -> (BA# Word8 -> IO a) -> IO a
withCBytesUnsafe CBytes
name ((BA# Word8 -> IO CInt) -> IO CInt)
-> (BA# Word8 -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \ BA# Word8
pt ->
            (MBA# BotanStructT -> BA# Word8 -> Word32 -> IO CInt
botan_mac_init MBA# BotanStructT
bts BA# Word8
pt Word32
0))
        FunPtr (BotanStructT -> IO ())
botan_mac_destroy
    (CSize
osiz, CInt
_) <- BotanStruct
-> (BotanStructT -> IO (CSize, CInt)) -> IO (CSize, CInt)
forall a. BotanStruct -> (BotanStructT -> IO a) -> IO a
withBotanStruct BotanStruct
bs ((BotanStructT -> IO (CSize, CInt)) -> IO (CSize, CInt))
-> (BotanStructT -> IO (CSize, CInt)) -> IO (CSize, CInt)
forall a b. (a -> b) -> a -> b
$ \ BotanStructT
pbs ->
        forall b.
Prim CSize =>
(MBA# BotanStructT -> IO b) -> IO (CSize, b)
forall a b. Prim a => (MBA# BotanStructT -> IO b) -> IO (a, b)
allocPrimUnsafe @CSize ((MBA# BotanStructT -> IO CInt) -> IO (CSize, CInt))
-> (MBA# BotanStructT -> IO CInt) -> IO (CSize, CInt)
forall a b. (a -> b) -> a -> b
$ \ MBA# BotanStructT
pl ->
            BotanStructT -> MBA# BotanStructT -> IO CInt
botan_mac_output_length BotanStructT
pbs MBA# BotanStructT
pl
    MAC -> IO MAC
forall (m :: * -> *) a. Monad m => a -> m a
return (BotanStruct -> CBytes -> Int -> MAC
MAC BotanStruct
bs CBytes
name (CSize -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CSize
osiz))

-- | Set the random key.
setKeyMAC :: HasCallStack => MAC -> V.Bytes -> IO ()
{-# INLINABLE setKeyMAC #-}
setKeyMAC :: MAC -> Bytes -> IO ()
setKeyMAC (MAC BotanStruct
bts CBytes
_ Int
_) Bytes
bs =
    BotanStruct -> (BotanStructT -> IO ()) -> IO ()
forall a. BotanStruct -> (BotanStructT -> IO a) -> IO a
withBotanStruct BotanStruct
bts ((BotanStructT -> IO ()) -> IO ())
-> (BotanStructT -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \BotanStructT
pbts->
        Bytes -> (BA# Word8 -> Int -> Int -> IO ()) -> IO ()
forall a b.
Prim a =>
PrimVector a -> (BA# Word8 -> Int -> Int -> IO b) -> IO b
withPrimVectorUnsafe Bytes
bs ((BA# Word8 -> Int -> Int -> IO ()) -> IO ())
-> (BA# Word8 -> Int -> Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \BA# Word8
pbs Int
off Int
len ->
            IO CInt -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwBotanIfMinus_ (BotanStructT -> BA# Word8 -> Int -> Int -> IO CInt
hs_botan_mac_set_key BotanStructT
pbts BA# Word8
pbs Int
off Int
len)

-- | Feed a chunk of input into a 'MAC' object.
updateMAC :: HasCallStack => MAC -> V.Bytes -> IO ()
{-# INLINABLE updateMAC #-}
updateMAC :: MAC -> Bytes -> IO ()
updateMAC (MAC BotanStruct
bts CBytes
_ Int
_) Bytes
bs =
    BotanStruct -> (BotanStructT -> IO ()) -> IO ()
forall a. BotanStruct -> (BotanStructT -> IO a) -> IO a
withBotanStruct BotanStruct
bts ((BotanStructT -> IO ()) -> IO ())
-> (BotanStructT -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ BotanStructT
pbts ->
        Bytes -> (BA# Word8 -> Int -> Int -> IO ()) -> IO ()
forall a b.
Prim a =>
PrimVector a -> (BA# Word8 -> Int -> Int -> IO b) -> IO b
withPrimVectorUnsafe Bytes
bs ((BA# Word8 -> Int -> Int -> IO ()) -> IO ())
-> (BA# Word8 -> Int -> Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ BA# Word8
pbs Int
off Int
len ->
            IO CInt -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwBotanIfMinus_ (BotanStructT -> BA# Word8 -> Int -> Int -> IO CInt
hs_botan_mac_update BotanStructT
pbts BA# Word8
pbs Int
off Int
len)

finalMAC :: HasCallStack => MAC -> IO V.Bytes
{-# INLINABLE finalMAC #-}
finalMAC :: MAC -> IO Bytes
finalMAC (MAC BotanStruct
bts CBytes
_ Int
siz) =
    BotanStruct -> (BotanStructT -> IO Bytes) -> IO Bytes
forall a. BotanStruct -> (BotanStructT -> IO a) -> IO a
withBotanStruct BotanStruct
bts ((BotanStructT -> IO Bytes) -> IO Bytes)
-> (BotanStructT -> IO Bytes) -> IO Bytes
forall a b. (a -> b) -> a -> b
$ \ BotanStructT
pbts -> do
        (Bytes, ()) -> Bytes
forall a b. (a, b) -> a
fst ((Bytes, ()) -> Bytes) -> IO (Bytes, ()) -> IO Bytes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> (MBA# BotanStructT -> IO ()) -> IO (Bytes, ())
forall a b.
Prim a =>
Int -> (MBA# BotanStructT -> IO b) -> IO (PrimVector a, b)
allocPrimVectorUnsafe Int
siz (\ MBA# BotanStructT
pout ->
            IO CInt -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwBotanIfMinus_ (BotanStructT -> MBA# BotanStructT -> IO CInt
botan_mac_final BotanStructT
pbts MBA# BotanStructT
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 -> IO ()
clearMAC (MAC BotanStruct
bts CBytes
_ Int
_) =
    IO CInt -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwBotanIfMinus_ (BotanStruct -> (BotanStructT -> IO CInt) -> IO CInt
forall a. BotanStruct -> (BotanStructT -> IO a) -> IO a
withBotanStruct BotanStruct
bts BotanStructT -> IO CInt
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 :: MAC -> Sink Bytes
sinkToMAC MAC
h = \ Maybe Void -> IO ()
k Maybe Bytes
mbs -> case Maybe Bytes
mbs of
    Just Bytes
bs -> HasCallStack => MAC -> Bytes -> IO ()
MAC -> Bytes -> IO ()
updateMAC MAC
h Bytes
bs
    Maybe Bytes
_       -> Maybe Void -> IO ()
k Maybe Void
forall a. Maybe a
EOF

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

-- | Directly compute a chunked message's mac.
macChunks :: HasCallStack => MACType -> V.Bytes -> [V.Bytes] -> V.Bytes
{-# INLINABLE macChunks #-}
macChunks :: MACType -> Bytes -> [Bytes] -> Bytes
macChunks MACType
mt Bytes
key [Bytes]
inps = IO Bytes -> Bytes
forall a. IO a -> a
unsafePerformIO (IO Bytes -> Bytes) -> IO Bytes -> Bytes
forall a b. (a -> b) -> a -> b
$ do
    MAC
m <- HasCallStack => MACType -> IO MAC
MACType -> IO MAC
newMAC MACType
mt
    HasCallStack => MAC -> Bytes -> IO ()
MAC -> Bytes -> IO ()
setKeyMAC MAC
m Bytes
key
    (Bytes -> IO ()) -> [Bytes] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HasCallStack => MAC -> Bytes -> IO ()
MAC -> Bytes -> IO ()
updateMAC MAC
m) [Bytes]
inps
    HasCallStack => MAC -> IO Bytes
MAC -> IO Bytes
finalMAC MAC
m