{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Cardano.Protocol.Crypto.KES (
  KESKeyPair (..),
) where

import Cardano.Crypto.KES (
  UnsoundPureKESAlgorithm (..),
  seedSizeKES,
  unsoundPureDeriveVerKeyKES,
  unsoundPureGenKeyKES,
 )
import qualified Cardano.Crypto.KES.Class as KES
import Cardano.Crypto.Seed
import Cardano.Protocol.Crypto
import Data.Proxy
import Test.Cardano.Ledger.Binary.Arbitrary (genByteString)
import Test.Cardano.Ledger.Common

data KESKeyPair c = KESKeyPair
  { forall c. KESKeyPair c -> UnsoundPureSignKeyKES (KES c)
kesSignKey :: !(KES.UnsoundPureSignKeyKES (KES c))
  , forall c. KESKeyPair c -> VerKeyKES (KES c)
kesVerKey :: !(KES.VerKeyKES (KES c))
  }

instance Show (KES.VerKeyKES (KES c)) => Show (KESKeyPair c) where
  show :: KESKeyPair c -> String
show (KESKeyPair UnsoundPureSignKeyKES (KES c)
_ VerKeyKES (KES c)
vk) =
    -- showing `SignKeyKES` is impossible for security reasons.
    String
"KESKeyPair <SignKeyKES> " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> VerKeyKES (KES c) -> String
forall a. Show a => a -> String
show VerKeyKES (KES c)
vk

-- TODO: upstream into `cardano-base`

-- | Generate a `Seed` with specified number of bytes, which can only be positive.
genSeedN :: HasCallStack => Int -> Gen Seed
genSeedN :: HasCallStack => Int -> Gen Seed
genSeedN Int
n
  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 = ByteString -> Seed
mkSeedFromBytes (ByteString -> Seed) -> Gen ByteString -> Gen Seed
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen ByteString
genByteString Int
n
  | Bool
otherwise = String -> Gen Seed
forall a. HasCallStack => String -> a
error (String -> Gen Seed) -> String -> Gen Seed
forall a b. (a -> b) -> a -> b
$ String
"Seed cannot be empty. Supplied " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" for the size of the seed"

instance Crypto c => Arbitrary (KESKeyPair c) where
  arbitrary :: Gen (KESKeyPair c)
arbitrary = do
    UnsoundPureSignKeyKES (KES c)
signKey <- Seed -> UnsoundPureSignKeyKES (KES c)
forall v.
UnsoundPureKESAlgorithm v =>
Seed -> UnsoundPureSignKeyKES v
unsoundPureGenKeyKES (Seed -> UnsoundPureSignKeyKES (KES c))
-> Gen Seed -> Gen (UnsoundPureSignKeyKES (KES c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasCallStack => Int -> Gen Seed
Int -> Gen Seed
genSeedN (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Proxy (KES c) -> Word
forall v (proxy :: * -> *). KESAlgorithm v => proxy v -> Word
seedSizeKES (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(KES c))))
    KESKeyPair c -> Gen (KESKeyPair c)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (KESKeyPair c -> Gen (KESKeyPair c))
-> KESKeyPair c -> Gen (KESKeyPair c)
forall a b. (a -> b) -> a -> b
$
      KESKeyPair
        { kesSignKey :: UnsoundPureSignKeyKES (KES c)
kesSignKey = UnsoundPureSignKeyKES (KES c)
signKey
        , kesVerKey :: VerKeyKES (KES c)
kesVerKey = UnsoundPureSignKeyKES (KES c) -> VerKeyKES (KES c)
forall v.
UnsoundPureKESAlgorithm v =>
UnsoundPureSignKeyKES v -> VerKeyKES v
unsoundPureDeriveVerKeyKES UnsoundPureSignKeyKES (KES c)
signKey
        }