{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Crypto.Instances (
  withMLSBFromPSB,
  withMLockedSeedFromPSB,
) where

import Cardano.Crypto.DSIGN.Class hiding (Signable)
import Cardano.Crypto.Libsodium
import Cardano.Crypto.Libsodium.MLockedSeed
import Cardano.Crypto.PinnedSizedBytes
import Cardano.Crypto.Util
import Cardano.Crypto.VRF.Class
import Control.Monad.Class.MonadST
import Control.Monad.Class.MonadThrow
import Data.Maybe (mapMaybe)
import Data.Proxy (Proxy (Proxy))
import GHC.Exts (fromList, fromListN, toList)
import GHC.Stack (HasCallStack)
import GHC.TypeLits (KnownNat, natVal)
import Test.Cardano.Base.Bytes (genByteArray, genByteString)
import Test.Crypto.Util (Message, arbitrarySeedOfSize)
import Test.QuickCheck (Arbitrary (..), Gen)
import qualified Test.QuickCheck.Gen as Gen

-- We cannot allow this instance, because it doesn't guarantee timely
-- forgetting of the MLocked memory, and in a QuickCheck context, where
-- tens of thousands of these values may be generated, waiting for GC to clean
-- up after us could have us run over our mlock quota.
--
-- Instead, use 'arbitrary' to generate a suitably sized PinnedSizedBytes
-- value, and then mlsbFromPSB or withMLSBFromPSB to convert it to an
-- MLockedSizedBytes value.
--
-- instance KnownNat n => Arbitrary (MLockedSizedBytes n) where
--     arbitrary = unsafePerformIO . mlsbFromByteString . BS.pack <$> vectorOf size arbitrary
--       where
--         size :: Int
--         size = fromInteger (natVal (Proxy :: Proxy n))

mlsbFromPSB :: (MonadST m, KnownNat n) => PinnedSizedBytes n -> m (MLockedSizedBytes n)
mlsbFromPSB :: forall (m :: * -> *) (n :: Nat).
(MonadST m, KnownNat n) =>
PinnedSizedBytes n -> m (MLockedSizedBytes n)
mlsbFromPSB = ByteString -> m (MLockedSizedBytes n)
forall (n :: Nat) (m :: * -> *).
(KnownNat n, MonadST m) =>
ByteString -> m (MLockedSizedBytes n)
mlsbFromByteString (ByteString -> m (MLockedSizedBytes n))
-> (PinnedSizedBytes n -> ByteString)
-> PinnedSizedBytes n
-> m (MLockedSizedBytes n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PinnedSizedBytes n -> ByteString
forall (n :: Nat). PinnedSizedBytes n -> ByteString
psbToByteString

withMLSBFromPSB ::
  (MonadST m, MonadThrow m, KnownNat n) => PinnedSizedBytes n -> (MLockedSizedBytes n -> m a) -> m a
withMLSBFromPSB :: forall (m :: * -> *) (n :: Nat) a.
(MonadST m, MonadThrow m, KnownNat n) =>
PinnedSizedBytes n -> (MLockedSizedBytes n -> m a) -> m a
withMLSBFromPSB PinnedSizedBytes n
psb =
  m (MLockedSizedBytes n)
-> (MLockedSizedBytes n -> m ())
-> (MLockedSizedBytes n -> m a)
-> m a
forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
    (PinnedSizedBytes n -> m (MLockedSizedBytes n)
forall (m :: * -> *) (n :: Nat).
(MonadST m, KnownNat n) =>
PinnedSizedBytes n -> m (MLockedSizedBytes n)
mlsbFromPSB PinnedSizedBytes n
psb)
    MLockedSizedBytes n -> m ()
forall (m :: * -> *) (n :: Nat).
MonadST m =>
MLockedSizedBytes n -> m ()
mlsbFinalize

mlockedSeedFromPSB :: (MonadST m, KnownNat n) => PinnedSizedBytes n -> m (MLockedSeed n)
mlockedSeedFromPSB :: forall (m :: * -> *) (n :: Nat).
(MonadST m, KnownNat n) =>
PinnedSizedBytes n -> m (MLockedSeed n)
mlockedSeedFromPSB = (MLockedSizedBytes n -> MLockedSeed n)
-> m (MLockedSizedBytes n) -> m (MLockedSeed n)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MLockedSizedBytes n -> MLockedSeed n
forall (n :: Nat). MLockedSizedBytes n -> MLockedSeed n
MLockedSeed (m (MLockedSizedBytes n) -> m (MLockedSeed n))
-> (PinnedSizedBytes n -> m (MLockedSizedBytes n))
-> PinnedSizedBytes n
-> m (MLockedSeed n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PinnedSizedBytes n -> m (MLockedSizedBytes n)
forall (m :: * -> *) (n :: Nat).
(MonadST m, KnownNat n) =>
PinnedSizedBytes n -> m (MLockedSizedBytes n)
mlsbFromPSB

withMLockedSeedFromPSB ::
  (MonadST m, MonadThrow m, KnownNat n) => PinnedSizedBytes n -> (MLockedSeed n -> m a) -> m a
withMLockedSeedFromPSB :: forall (m :: * -> *) (n :: Nat) a.
(MonadST m, MonadThrow m, KnownNat n) =>
PinnedSizedBytes n -> (MLockedSeed n -> m a) -> m a
withMLockedSeedFromPSB PinnedSizedBytes n
psb =
  m (MLockedSeed n)
-> (MLockedSeed n -> m ()) -> (MLockedSeed n -> m a) -> m a
forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
    (PinnedSizedBytes n -> m (MLockedSeed n)
forall (m :: * -> *) (n :: Nat).
(MonadST m, KnownNat n) =>
PinnedSizedBytes n -> m (MLockedSeed n)
mlockedSeedFromPSB PinnedSizedBytes n
psb)
    MLockedSeed n -> m ()
forall (m :: * -> *) (n :: Nat). MonadST m => MLockedSeed n -> m ()
mlockedSeedFinalize

instance KnownNat n => Arbitrary (PinnedSizedBytes n) where
  arbitrary :: Gen (PinnedSizedBytes n)
arbitrary = do
    let size :: Int
size = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Integer @Int (Integer -> Int) -> (Proxy n -> Integer) -> Proxy n -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n -> Int) -> Proxy n -> Int
forall a b. (a -> b) -> a -> b
$ forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @n
    Gen ByteString
-> (ByteString -> Maybe (PinnedSizedBytes n))
-> Gen (PinnedSizedBytes n)
forall a b. Gen a -> (a -> Maybe b) -> Gen b
Gen.suchThatMap
      (Int -> [Item ByteString] -> ByteString
forall l. IsList l => Int -> [Item l] -> l
fromListN Int
size ([Word8] -> ByteString) -> Gen [Word8] -> Gen ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen Word8 -> Gen [Word8]
forall a. Int -> Gen a -> Gen [a]
Gen.vectorOf Int
size Gen Word8
forall a. Arbitrary a => Gen a
arbitrary)
      ByteString -> Maybe (PinnedSizedBytes n)
forall (n :: Nat).
KnownNat n =>
ByteString -> Maybe (PinnedSizedBytes n)
psbFromByteStringCheck
  shrink :: PinnedSizedBytes n -> [PinnedSizedBytes n]
shrink PinnedSizedBytes n
psb = case ByteString -> [Word8]
ByteString -> [Item ByteString]
forall l. IsList l => l -> [Item l]
toList (ByteString -> [Word8])
-> (PinnedSizedBytes n -> ByteString)
-> PinnedSizedBytes n
-> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PinnedSizedBytes n -> ByteString
forall (n :: Nat). PinnedSizedBytes n -> ByteString
psbToByteString (PinnedSizedBytes n -> [Word8]) -> PinnedSizedBytes n -> [Word8]
forall a b. (a -> b) -> a -> b
$ PinnedSizedBytes n
psb of
    [Word8]
bytes -> ([Word8] -> Maybe (PinnedSizedBytes n))
-> [[Word8]] -> [PinnedSizedBytes n]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (ByteString -> Maybe (PinnedSizedBytes n)
forall (n :: Nat).
KnownNat n =>
ByteString -> Maybe (PinnedSizedBytes n)
psbFromByteStringCheck (ByteString -> Maybe (PinnedSizedBytes n))
-> ([Word8] -> ByteString) -> [Word8] -> Maybe (PinnedSizedBytes n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
[Item ByteString] -> ByteString
forall l. IsList l => [Item l] -> l
fromList) ([[Word8]] -> [PinnedSizedBytes n])
-> ([Word8] -> [[Word8]]) -> [Word8] -> [PinnedSizedBytes n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> [[Word8]]
forall a. Arbitrary a => a -> [a]
shrink ([Word8] -> [PinnedSizedBytes n])
-> [Word8] -> [PinnedSizedBytes n]
forall a b. (a -> b) -> a -> b
$ [Word8]
bytes

instance VRFAlgorithm v => Arbitrary (OutputVRF v) where
  arbitrary :: Gen (OutputVRF v)
arbitrary = do
    let n :: Int
n = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word @Int (Proxy v -> Word
forall v (proxy :: * -> *). VRFAlgorithm v => proxy v -> Word
forall (proxy :: * -> *). proxy v -> Word
sizeOutputVRF (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @v))
    ByteArray -> OutputVRF v
forall v. ByteArray -> OutputVRF v
OutputVRF (ByteArray -> OutputVRF v) -> Gen ByteArray -> Gen (OutputVRF v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen ByteArray
genByteArray Int
n

instance VRFAlgorithm v => Arbitrary (VerKeyVRF v) where
  arbitrary :: Gen (VerKeyVRF v)
arbitrary = SignKeyVRF v -> VerKeyVRF v
forall v. VRFAlgorithm v => SignKeyVRF v -> VerKeyVRF v
deriveVerKeyVRF (SignKeyVRF v -> VerKeyVRF v)
-> Gen (SignKeyVRF v) -> Gen (VerKeyVRF v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (SignKeyVRF v)
forall a. Arbitrary a => Gen a
arbitrary

instance VRFAlgorithm v => Arbitrary (SignKeyVRF v) where
  arbitrary :: Gen (SignKeyVRF v)
arbitrary = Seed -> SignKeyVRF v
forall v. VRFAlgorithm v => Seed -> SignKeyVRF v
genKeyVRF (Seed -> SignKeyVRF v) -> Gen Seed -> Gen (SignKeyVRF v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word -> Gen Seed
arbitrarySeedOfSize Word
seedSize
    where
      seedSize :: Word
seedSize = Proxy v -> Word
forall v (proxy :: * -> *). VRFAlgorithm v => proxy v -> Word
forall (proxy :: * -> *). proxy v -> Word
seedSizeVRF (Proxy v
forall {k} (t :: k). Proxy t
Proxy :: Proxy v)

instance
  ( VRFAlgorithm v
  , ContextVRF v ~ ()
  , Signable v ~ SignableRepresentation
  ) =>
  Arbitrary (CertVRF v)
  where
  arbitrary :: Gen (CertVRF v)
arbitrary = do
    Message
a <- Gen Message
forall a. Arbitrary a => Gen a
arbitrary :: Gen Message
    SignKeyVRF v
sk <- Gen (SignKeyVRF v)
forall a. Arbitrary a => Gen a
arbitrary
    CertVRF v -> Gen (CertVRF v)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (CertVRF v -> Gen (CertVRF v)) -> CertVRF v -> Gen (CertVRF v)
forall a b. (a -> b) -> a -> b
$ (OutputVRF v, CertVRF v) -> CertVRF v
forall a b. (a, b) -> b
snd ((OutputVRF v, CertVRF v) -> CertVRF v)
-> (OutputVRF v, CertVRF v) -> CertVRF v
forall a b. (a -> b) -> a -> b
$ ContextVRF v -> Message -> SignKeyVRF v -> (OutputVRF v, CertVRF v)
forall a.
(HasCallStack, Signable v a) =>
ContextVRF v -> a -> SignKeyVRF v -> (OutputVRF v, CertVRF v)
forall v a.
(VRFAlgorithm v, HasCallStack, Signable v a) =>
ContextVRF v -> a -> SignKeyVRF v -> (OutputVRF v, CertVRF v)
evalVRF () Message
a SignKeyVRF v
sk

instance
  (ContextVRF v ~ (), Signable v ~ SignableRepresentation, VRFAlgorithm v) =>
  Arbitrary (CertifiedVRF v a)
  where
  arbitrary :: Gen (CertifiedVRF v a)
arbitrary = OutputVRF v -> CertVRF v -> CertifiedVRF v a
forall v a. OutputVRF v -> CertVRF v -> CertifiedVRF v a
CertifiedVRF (OutputVRF v -> CertVRF v -> CertifiedVRF v a)
-> Gen (OutputVRF v) -> Gen (CertVRF v -> CertifiedVRF v a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (OutputVRF v)
forall a. Arbitrary a => Gen a
arbitrary Gen (CertVRF v -> CertifiedVRF v a)
-> Gen (CertVRF v) -> Gen (CertifiedVRF v a)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (CertVRF v)
genCertVRF
    where
      genCertVRF :: Gen (CertVRF v)
      genCertVRF :: Gen (CertVRF v)
genCertVRF = Gen (CertVRF v)
forall a. Arbitrary a => Gen a
arbitrary

instance DSIGNAlgorithm v => Arbitrary (VerKeyDSIGN v) where
  arbitrary :: Gen (VerKeyDSIGN v)
arbitrary = SignKeyDSIGN v -> VerKeyDSIGN v
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN (SignKeyDSIGN v -> VerKeyDSIGN v)
-> Gen (SignKeyDSIGN v) -> Gen (VerKeyDSIGN v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (SignKeyDSIGN v)
forall a. Arbitrary a => Gen a
arbitrary

errorInvalidSize :: HasCallStack => Int -> Maybe a -> Gen a
errorInvalidSize :: forall a. HasCallStack => Int -> Maybe a -> Gen a
errorInvalidSize Int
n = Gen a -> (a -> Gen a) -> Maybe a -> Gen a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Gen a
forall a. HasCallStack => [Char] -> a
error ([Char] -> Gen a) -> [Char] -> Gen a
forall a b. (a -> b) -> a -> b
$ [Char]
"Impossible: Invalid size " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n) a -> Gen a
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance DSIGNAlgorithm v => Arbitrary (SignKeyDSIGN v) where
  arbitrary :: Gen (SignKeyDSIGN v)
arbitrary = do
    let n :: Int
n = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy v -> Word
forall v (proxy :: * -> *). DSIGNAlgorithm v => proxy v -> Word
signKeySizeDSIGN (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @v))
    ByteString
bs <- Int -> Gen ByteString
genByteString Int
n
    Int -> Maybe (SignKeyDSIGN v) -> Gen (SignKeyDSIGN v)
forall a. HasCallStack => Int -> Maybe a -> Gen a
errorInvalidSize Int
n (Maybe (SignKeyDSIGN v) -> Gen (SignKeyDSIGN v))
-> Maybe (SignKeyDSIGN v) -> Gen (SignKeyDSIGN v)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe (SignKeyDSIGN v)
forall v. DSIGNAlgorithm v => ByteString -> Maybe (SignKeyDSIGN v)
rawDeserialiseSignKeyDSIGN ByteString
bs

instance DSIGNAlgorithm v => Arbitrary (SigDSIGN v) where
  arbitrary :: Gen (SigDSIGN v)
arbitrary = do
    let n :: Int
n = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy v -> Word
forall v (proxy :: * -> *). DSIGNAlgorithm v => proxy v -> Word
sigSizeDSIGN (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @v))
    ByteString
bs <- Int -> Gen ByteString
genByteString Int
n
    Int -> Maybe (SigDSIGN v) -> Gen (SigDSIGN v)
forall a. HasCallStack => Int -> Maybe a -> Gen a
errorInvalidSize Int
n (Maybe (SigDSIGN v) -> Gen (SigDSIGN v))
-> Maybe (SigDSIGN v) -> Gen (SigDSIGN v)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe (SigDSIGN v)
forall v. DSIGNAlgorithm v => ByteString -> Maybe (SigDSIGN v)
rawDeserialiseSigDSIGN ByteString
bs

instance DSIGNAlgorithm v => Arbitrary (SignedDSIGN v a) where
  arbitrary :: Gen (SignedDSIGN v a)
arbitrary = SigDSIGN v -> SignedDSIGN v a
forall v a. SigDSIGN v -> SignedDSIGN v a
SignedDSIGN (SigDSIGN v -> SignedDSIGN v a)
-> Gen (SigDSIGN v) -> Gen (SignedDSIGN v a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (SigDSIGN v)
forall a. Arbitrary a => Gen a
arbitrary