module Z.Crypto.MAC (
MACType(..)
, MAC, macName, macSize
, newMAC
, setKeyMAC
, updateMAC
, finalMAC
, clearMAC
, mac, macChunks
, sinkToMAC
, macTypeToCBytes
, withMAC
, 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
| GMAC BlockCipherType
| CBC_MAC BlockCipherType
| HMAC HashType
| Poly1305
| SipHash Int Int
| X9'19_MAC
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 -> Int
macSize :: {-# UNPACK #-} !Int
}
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
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
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))
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)
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))
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)
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
mac :: HasCallStack => MACType
-> Secret
-> V.Bytes
-> 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
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