{-|
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 (Int -> MACType -> ShowS
[MACType] -> ShowS
MACType -> String
(Int -> MACType -> ShowS)
-> (MACType -> String) -> ([MACType] -> ShowS) -> Show MACType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MACType] -> ShowS
$cshowList :: [MACType] -> ShowS
show :: MACType -> String
$cshow :: MACType -> String
showsPrec :: Int -> MACType -> ShowS
$cshowsPrec :: Int -> MACType -> ShowS
Show, ReadPrec [MACType]
ReadPrec MACType
Int -> ReadS MACType
ReadS [MACType]
(Int -> ReadS MACType)
-> ReadS [MACType]
-> ReadPrec MACType
-> ReadPrec [MACType]
-> Read MACType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [MACType]
$creadListPrec :: ReadPrec [MACType]
readPrec :: ReadPrec MACType
$creadPrec :: ReadPrec MACType
readList :: ReadS [MACType]
$creadList :: ReadS [MACType]
readsPrec :: Int -> ReadS MACType
$creadsPrec :: Int -> ReadS MACType
Read, MACType -> MACType -> Bool
(MACType -> MACType -> Bool)
-> (MACType -> MACType -> Bool) -> Eq MACType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MACType -> MACType -> Bool
$c/= :: MACType -> MACType -> Bool
== :: MACType -> MACType -> Bool
$c== :: MACType -> MACType -> Bool
Eq, Eq MACType
Eq MACType
-> (MACType -> MACType -> Ordering)
-> (MACType -> MACType -> Bool)
-> (MACType -> MACType -> Bool)
-> (MACType -> MACType -> Bool)
-> (MACType -> MACType -> Bool)
-> (MACType -> MACType -> MACType)
-> (MACType -> MACType -> MACType)
-> Ord MACType
MACType -> MACType -> Bool
MACType -> MACType -> Ordering
MACType -> MACType -> MACType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: MACType -> MACType -> MACType
$cmin :: MACType -> MACType -> MACType
max :: MACType -> MACType -> MACType
$cmax :: MACType -> MACType -> MACType
>= :: MACType -> MACType -> Bool
$c>= :: MACType -> MACType -> Bool
> :: MACType -> MACType -> Bool
$c> :: MACType -> MACType -> Bool
<= :: MACType -> MACType -> Bool
$c<= :: MACType -> MACType -> Bool
< :: MACType -> MACType -> Bool
$c< :: MACType -> MACType -> Bool
compare :: MACType -> MACType -> Ordering
$ccompare :: MACType -> MACType -> Ordering
$cp1Ord :: Eq MACType
Ord, (forall x. MACType -> Rep MACType x)
-> (forall x. Rep MACType x -> MACType) -> Generic MACType
forall x. Rep MACType x -> MACType
forall x. MACType -> Rep MACType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MACType x -> MACType
$cfrom :: forall x. MACType -> Rep MACType x
Generic)
  deriving anyclass (Int -> MACType -> Builder ()
(Int -> MACType -> Builder ()) -> Print MACType
forall a. (Int -> a -> Builder ()) -> Print a
toUTF8BuilderP :: Int -> MACType -> Builder ()
$ctoUTF8BuilderP :: Int -> MACType -> Builder ()
T.Print, Value -> Converter MACType
MACType -> Value
MACType -> Builder ()
(Value -> Converter MACType)
-> (MACType -> Value) -> (MACType -> Builder ()) -> JSON MACType
forall a.
(Value -> Converter a)
-> (a -> Value) -> (a -> Builder ()) -> JSON a
encodeJSON :: MACType -> Builder ()
$cencodeJSON :: MACType -> Builder ()
toValue :: MACType -> Value
$ctoValue :: MACType -> Value
fromValue :: Value -> Converter MACType
$cfromValue :: Value -> Converter MACType
JSON)

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 :: 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 -> Secret -> IO ()
{-# INLINABLE setKeyMAC #-}
setKeyMAC :: MAC -> Secret -> IO ()
setKeyMAC (MAC BotanStruct
bts CBytes
_ Int
_) Secret
key =
    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->
        Secret -> (Ptr Word8 -> CSize -> IO ()) -> IO ()
forall r. Secret -> (Ptr Word8 -> CSize -> IO r) -> IO r
withSecret Secret
key ((Ptr Word8 -> CSize -> IO ()) -> IO ())
-> (Ptr Word8 -> CSize -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr Word8
pk CSize
klen ->
            IO CInt -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwBotanIfMinus_ (BotanStructT -> Ptr Word8 -> CSize -> IO CInt
botan_mac_set_key BotanStructT
pbts Ptr Word8
pk CSize
klen)

-- | 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 CEBytes
{-# INLINABLE finalMAC #-}
finalMAC :: MAC -> IO CEBytes
finalMAC (MAC BotanStruct
bts CBytes
_ Int
siz) =
    BotanStruct -> (BotanStructT -> IO CEBytes) -> IO CEBytes
forall a. BotanStruct -> (BotanStructT -> IO a) -> IO a
withBotanStruct BotanStruct
bts ((BotanStructT -> IO CEBytes) -> IO CEBytes)
-> (BotanStructT -> IO CEBytes) -> IO CEBytes
forall a b. (a -> b) -> a -> b
$ \ BotanStructT
pbts -> do
        Int -> (MBA# BotanStructT -> IO ()) -> IO CEBytes
forall r. Int -> (MBA# BotanStructT -> IO r) -> IO CEBytes
newCEBytesUnsafe 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
                    -> Secret   -- ^ key
                    -> V.Bytes  -- ^ input
                    -> CEBytes
{-# INLINABLE mac #-}
mac :: MACType -> Secret -> Bytes -> CEBytes
mac MACType
mt Secret
key Bytes
inp = IO CEBytes -> CEBytes
forall a. IO a -> a
unsafePerformIO (IO CEBytes -> CEBytes) -> IO CEBytes -> CEBytes
forall a b. (a -> b) -> a -> b
$ do
    MAC
m <- HasCallStack => MACType -> IO MAC
MACType -> IO MAC
newMAC MACType
mt
    HasCallStack => MAC -> Secret -> IO ()
MAC -> Secret -> IO ()
setKeyMAC MAC
m Secret
key
    HasCallStack => MAC -> Bytes -> IO ()
MAC -> Bytes -> IO ()
updateMAC MAC
m Bytes
inp
    HasCallStack => MAC -> IO CEBytes
MAC -> IO CEBytes
finalMAC MAC
m

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