{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}

module Cardano.Api.Keys.Class
  ( Key (..)
  , generateSigningKey
  , generateInsecureSigningKey
  , CastVerificationKeyRole (..)
  , CastSigningKeyRole (..)
  , AsType (AsVerificationKey, AsSigningKey)
  )
where

import           Cardano.Api.Hash
import           Cardano.Api.HasTypeProxy
import           Cardano.Api.SerialiseRaw
import           Cardano.Api.SerialiseTextEnvelope

import qualified Cardano.Crypto.DSIGN.Class as Crypto
import qualified Cardano.Crypto.Seed as Crypto

import           Control.Monad.IO.Class
import           Data.Kind (Type)
import qualified System.Random as Random
import           System.Random (StdGen)

-- | An interface for cryptographic keys used for signatures with a 'SigningKey'
-- and a 'VerificationKey' key.
--
-- This interface does not provide actual signing or verifying functions since
-- this API is concerned with the management of keys: generating and
-- serialising.
class
  ( Eq (VerificationKey keyrole)
  , Show (VerificationKey keyrole)
  , SerialiseAsRawBytes (Hash keyrole)
  , HasTextEnvelope (VerificationKey keyrole)
  , HasTextEnvelope (SigningKey keyrole)
  ) =>
  Key keyrole
  where
  -- | The type of cryptographic verification key, for each key role.
  data VerificationKey keyrole :: Type

  -- | The type of cryptographic signing key, for each key role.
  data SigningKey keyrole :: Type

  -- | Get the corresponding verification key from a signing key.
  getVerificationKey
    :: ()
#if MIN_VERSION_base(4,17,0)
    -- GHC 8.10 considers this constraint redundant but ghc-9.6 complains if its not present.
    -- More annoyingly, absence of this constraint does not manifest in this repo, but in
    -- `cardano-cli` :facepalm:.
    => HasTypeProxy keyrole
#endif
    => SigningKey keyrole
    -> VerificationKey keyrole

  -- | Generate a 'SigningKey' deterministically, given a 'Crypto.Seed'. The
  -- required size of the seed is given by 'deterministicSigningKeySeedSize'.
  deterministicSigningKey :: AsType keyrole -> Crypto.Seed -> SigningKey keyrole

  deterministicSigningKeySeedSize :: AsType keyrole -> Word

  verificationKeyHash :: VerificationKey keyrole -> Hash keyrole

-- TODO: We should move this into the Key type class, with the existing impl as the default impl.
-- For KES we can then override it to keep the seed and key in mlocked memory at all times.

-- | Generate a 'SigningKey' using a seed from operating system entropy.
generateSigningKey
  :: MonadIO m
  => Key keyrole
  => AsType keyrole
  -> m (SigningKey keyrole)
generateSigningKey :: forall (m :: * -> *) keyrole.
(MonadIO m, Key keyrole) =>
AsType keyrole -> m (SigningKey keyrole)
generateSigningKey AsType keyrole
keytype = do
  Seed
seed <- IO Seed -> m Seed
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Seed -> m Seed) -> IO Seed -> m Seed
forall a b. (a -> b) -> a -> b
$ Word -> IO Seed
Crypto.readSeedFromSystemEntropy Word
seedSize
  SigningKey keyrole -> m (SigningKey keyrole)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SigningKey keyrole -> m (SigningKey keyrole))
-> SigningKey keyrole -> m (SigningKey keyrole)
forall a b. (a -> b) -> a -> b
$! AsType keyrole -> Seed -> SigningKey keyrole
forall keyrole.
Key keyrole =>
AsType keyrole -> Seed -> SigningKey keyrole
deterministicSigningKey AsType keyrole
keytype Seed
seed
 where
  seedSize :: Word
seedSize = AsType keyrole -> Word
forall keyrole. Key keyrole => AsType keyrole -> Word
deterministicSigningKeySeedSize AsType keyrole
keytype

generateInsecureSigningKey
  :: MonadIO m
  => Key keyrole
  => SerialiseAsRawBytes (SigningKey keyrole)
  => StdGen
  -> AsType keyrole
  -> m (SigningKey keyrole, StdGen)
generateInsecureSigningKey :: forall (m :: * -> *) keyrole.
(MonadIO m, Key keyrole,
 SerialiseAsRawBytes (SigningKey keyrole)) =>
StdGen -> AsType keyrole -> m (SigningKey keyrole, StdGen)
generateInsecureSigningKey StdGen
g AsType keyrole
keytype = do
  let (ByteString
bs, StdGen
g') = Int -> StdGen -> (ByteString, StdGen)
forall g. RandomGen g => Int -> g -> (ByteString, g)
Random.genByteString (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> Word -> Int
forall a b. (a -> b) -> a -> b
$ AsType keyrole -> Word
forall keyrole. Key keyrole => AsType keyrole -> Word
deterministicSigningKeySeedSize AsType keyrole
keytype) StdGen
g
  case AsType (SigningKey keyrole)
-> ByteString
-> Either SerialiseAsRawBytesError (SigningKey keyrole)
forall a.
SerialiseAsRawBytes a =>
AsType a -> ByteString -> Either SerialiseAsRawBytesError a
deserialiseFromRawBytes (AsType keyrole -> AsType (SigningKey keyrole)
forall a. AsType a -> AsType (SigningKey a)
AsSigningKey AsType keyrole
keytype) ByteString
bs of
    Right SigningKey keyrole
key -> (SigningKey keyrole, StdGen) -> m (SigningKey keyrole, StdGen)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SigningKey keyrole
key, StdGen
g')
    Left (SerialiseAsRawBytesError [Char]
msg) -> [Char] -> m (SigningKey keyrole, StdGen)
forall a. HasCallStack => [Char] -> a
error ([Char] -> m (SigningKey keyrole, StdGen))
-> [Char] -> m (SigningKey keyrole, StdGen)
forall a b. (a -> b) -> a -> b
$ [Char]
"generateInsecureSigningKey: Unable to generate insecure key: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
msg

instance HasTypeProxy a => HasTypeProxy (VerificationKey a) where
  data AsType (VerificationKey a) = AsVerificationKey (AsType a)
  proxyToAsType :: Proxy (VerificationKey a) -> AsType (VerificationKey a)
proxyToAsType Proxy (VerificationKey a)
_ = AsType a -> AsType (VerificationKey a)
forall a. AsType a -> AsType (VerificationKey a)
AsVerificationKey (Proxy a -> AsType a
forall t. HasTypeProxy t => Proxy t -> AsType t
proxyToAsType (Proxy a
forall {a}. Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a))

instance HasTypeProxy a => HasTypeProxy (SigningKey a) where
  data AsType (SigningKey a) = AsSigningKey (AsType a)
  proxyToAsType :: Proxy (SigningKey a) -> AsType (SigningKey a)
proxyToAsType Proxy (SigningKey a)
_ = AsType a -> AsType (SigningKey a)
forall a. AsType a -> AsType (SigningKey a)
AsSigningKey (Proxy a -> AsType a
forall t. HasTypeProxy t => Proxy t -> AsType t
proxyToAsType (Proxy a
forall {a}. Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a))

-- | Some key roles share the same representation and it is sometimes
-- legitimate to change the role of a key.
class CastVerificationKeyRole keyroleA keyroleB where
  -- | Change the role of a 'VerificationKey', if the representation permits.
  castVerificationKey :: VerificationKey keyroleA -> VerificationKey keyroleB

class CastSigningKeyRole keyroleA keyroleB where
  -- | Change the role of a 'SigningKey', if the representation permits.
  castSigningKey :: SigningKey keyroleA -> SigningKey keyroleB