{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- | A standard signature scheme is a forward-secure signature scheme with a
-- single time period.
--
-- This is the base case in the naive recursive implementation of the sum
-- composition from section 3 of the \"MMM\" paper:
--
-- /Composition and Efficiency Tradeoffs for Forward-Secure Digital Signatures/
-- By Tal Malkin, Daniele Micciancio and Sara Miner
-- <https://eprint.iacr.org/2001/034>
--
-- Specfically it states:
--
-- > In order to unify the presentation, we regard standard signature schemes
-- > as forward-seure signature schemes with one time period, namely T = 1.
--
-- So this module simply provides a wrapper 'CompactSingleKES' that turns any
-- 'DSIGNAlgorithm' into an instance of 'KESAlgorithm' with a single period.
--
-- See "Cardano.Crypto.KES.CompactSum" for the composition case.
--
-- Compared to the implementation in 'Cardano.Crypto.KES.Single', this flavor
-- stores the VerKey used for signing along with the signature. The purpose of
-- this is so that we can avoid storing a pair of VerKeys at every branch node,
-- like 'Cardano.Crypto.KES.Sum' does. See 'Cardano.Crypto.KES.CompactSum' for
-- more details.
module Cardano.Crypto.KES.CompactSingle (
    CompactSingleKES
  , VerKeyKES (..)
  , SignKeyKES (..)
  , SigKES (..)
  ) where

import Data.Proxy (Proxy(..))
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)
import qualified Data.ByteString as BS
import           Control.Monad (guard)

import Control.Exception (assert)

import Cardano.Binary (FromCBOR (..), ToCBOR (..))

import Cardano.Crypto.Hash.Class
import Cardano.Crypto.DSIGN.Class
import qualified Cardano.Crypto.DSIGN as DSIGN
import Cardano.Crypto.KES.Class
import Control.DeepSeq (NFData)


-- | A standard signature scheme is a forward-secure signature scheme with a
-- single time period.
--
data CompactSingleKES d

deriving newtype instance NFData (VerKeyDSIGN d) => NFData (VerKeyKES (CompactSingleKES d))
deriving newtype instance NFData (SignKeyDSIGN d) => NFData (SignKeyKES (CompactSingleKES d))

deriving anyclass instance (NFData (SigDSIGN d), NFData (VerKeyDSIGN d)) => NFData (SigKES (CompactSingleKES d))

instance DSIGNAlgorithm d => KESAlgorithm (CompactSingleKES d) where
    type SeedSizeKES (CompactSingleKES d) = SeedSizeDSIGN d

    --
    -- Key and signature types
    --

    newtype VerKeyKES (CompactSingleKES d) = VerKeyCompactSingleKES (VerKeyDSIGN d)
        deriving forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall d x.
Rep (VerKeyKES (CompactSingleKES d)) x
-> VerKeyKES (CompactSingleKES d)
forall d x.
VerKeyKES (CompactSingleKES d)
-> Rep (VerKeyKES (CompactSingleKES d)) x
$cto :: forall d x.
Rep (VerKeyKES (CompactSingleKES d)) x
-> VerKeyKES (CompactSingleKES d)
$cfrom :: forall d x.
VerKeyKES (CompactSingleKES d)
-> Rep (VerKeyKES (CompactSingleKES d)) x
Generic

    newtype SignKeyKES (CompactSingleKES d) = SignKeyCompactSingleKES (SignKeyDSIGN d)
        deriving forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall d x.
Rep (SignKeyKES (CompactSingleKES d)) x
-> SignKeyKES (CompactSingleKES d)
forall d x.
SignKeyKES (CompactSingleKES d)
-> Rep (SignKeyKES (CompactSingleKES d)) x
$cto :: forall d x.
Rep (SignKeyKES (CompactSingleKES d)) x
-> SignKeyKES (CompactSingleKES d)
$cfrom :: forall d x.
SignKeyKES (CompactSingleKES d)
-> Rep (SignKeyKES (CompactSingleKES d)) x
Generic

    data SigKES (CompactSingleKES d) = SigCompactSingleKES !(SigDSIGN d) !(VerKeyDSIGN d)
        deriving forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall d x.
Rep (SigKES (CompactSingleKES d)) x -> SigKES (CompactSingleKES d)
forall d x.
SigKES (CompactSingleKES d) -> Rep (SigKES (CompactSingleKES d)) x
$cto :: forall d x.
Rep (SigKES (CompactSingleKES d)) x -> SigKES (CompactSingleKES d)
$cfrom :: forall d x.
SigKES (CompactSingleKES d) -> Rep (SigKES (CompactSingleKES d)) x
Generic


    --
    -- Metadata and basic key operations
    --

    algorithmNameKES :: forall (proxy :: * -> *). proxy (CompactSingleKES d) -> String
algorithmNameKES proxy (CompactSingleKES d)
_ = forall v (proxy :: * -> *). DSIGNAlgorithm v => proxy v -> String
algorithmNameDSIGN (forall {k} (t :: k). Proxy t
Proxy :: Proxy d) forall a. [a] -> [a] -> [a]
++ String
"_kes_2^0"

    deriveVerKeyKES :: SignKeyKES (CompactSingleKES d) -> VerKeyKES (CompactSingleKES d)
deriveVerKeyKES (SignKeyCompactSingleKES SignKeyDSIGN d
sk) =
        forall d. VerKeyDSIGN d -> VerKeyKES (CompactSingleKES d)
VerKeyCompactSingleKES (forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN SignKeyDSIGN d
sk)

    hashVerKeyKES :: forall h.
HashAlgorithm h =>
VerKeyKES (CompactSingleKES d)
-> Hash h (VerKeyKES (CompactSingleKES d))
hashVerKeyKES (VerKeyCompactSingleKES VerKeyDSIGN d
vk) =
        forall h a b. Hash h a -> Hash h b
castHash (forall v h.
(DSIGNAlgorithm v, HashAlgorithm h) =>
VerKeyDSIGN v -> Hash h (VerKeyDSIGN v)
hashVerKeyDSIGN VerKeyDSIGN d
vk)


    --
    -- Core algorithm operations
    --

    type ContextKES (CompactSingleKES d) = DSIGN.ContextDSIGN d
    type Signable   (CompactSingleKES d) = DSIGN.Signable     d

    signKES :: forall a.
(Signable (CompactSingleKES d) a, HasCallStack) =>
ContextKES (CompactSingleKES d)
-> Word
-> a
-> SignKeyKES (CompactSingleKES d)
-> SigKES (CompactSingleKES d)
signKES ContextKES (CompactSingleKES d)
ctxt Word
t a
a (SignKeyCompactSingleKES SignKeyDSIGN d
sk) =
        forall a. HasCallStack => Bool -> a -> a
assert (Word
t forall a. Eq a => a -> a -> Bool
== Word
0) forall a b. (a -> b) -> a -> b
$
        forall d.
SigDSIGN d -> VerKeyDSIGN d -> SigKES (CompactSingleKES d)
SigCompactSingleKES (forall v a.
(DSIGNAlgorithm v, Signable v a, HasCallStack) =>
ContextDSIGN v -> a -> SignKeyDSIGN v -> SigDSIGN v
signDSIGN ContextKES (CompactSingleKES d)
ctxt a
a SignKeyDSIGN d
sk) (forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
deriveVerKeyDSIGN SignKeyDSIGN d
sk)

    verifyKES :: forall a.
(Signable (CompactSingleKES d) a, HasCallStack) =>
ContextKES (CompactSingleKES d)
-> VerKeyKES (CompactSingleKES d)
-> Word
-> a
-> SigKES (CompactSingleKES d)
-> Either String ()
verifyKES = forall v a.
(OptimizedKESAlgorithm v, Signable v a, HasCallStack) =>
ContextKES v
-> VerKeyKES v -> Word -> a -> SigKES v -> Either String ()
verifyOptimizedKES

    updateKES :: HasCallStack =>
ContextKES (CompactSingleKES d)
-> SignKeyKES (CompactSingleKES d)
-> Word
-> Maybe (SignKeyKES (CompactSingleKES d))
updateKES ContextKES (CompactSingleKES d)
_ctx (SignKeyCompactSingleKES SignKeyDSIGN d
_sk) Word
_to = forall a. Maybe a
Nothing

    totalPeriodsKES :: forall (proxy :: * -> *). proxy (CompactSingleKES d) -> Word
totalPeriodsKES  proxy (CompactSingleKES d)
_ = Word
1

    --
    -- Key generation
    --

    seedSizeKES :: forall (proxy :: * -> *). proxy (CompactSingleKES d) -> Word
seedSizeKES proxy (CompactSingleKES d)
_ = forall v (proxy :: * -> *). DSIGNAlgorithm v => proxy v -> Word
seedSizeDSIGN (forall {k} (t :: k). Proxy t
Proxy :: Proxy d)
    genKeyKES :: Seed -> SignKeyKES (CompactSingleKES d)
genKeyKES Seed
seed = forall d. SignKeyDSIGN d -> SignKeyKES (CompactSingleKES d)
SignKeyCompactSingleKES (forall v. DSIGNAlgorithm v => Seed -> SignKeyDSIGN v
genKeyDSIGN Seed
seed)


    --
    -- raw serialise/deserialise
    --

    sizeVerKeyKES :: forall (proxy :: * -> *). proxy (CompactSingleKES d) -> Word
sizeVerKeyKES  proxy (CompactSingleKES d)
_ = forall v (proxy :: * -> *). DSIGNAlgorithm v => proxy v -> Word
sizeVerKeyDSIGN  (forall {k} (t :: k). Proxy t
Proxy :: Proxy d)
    sizeSignKeyKES :: forall (proxy :: * -> *). proxy (CompactSingleKES d) -> Word
sizeSignKeyKES proxy (CompactSingleKES d)
_ = forall v (proxy :: * -> *). DSIGNAlgorithm v => proxy v -> Word
sizeSignKeyDSIGN (forall {k} (t :: k). Proxy t
Proxy :: Proxy d)
    sizeSigKES :: forall (proxy :: * -> *). proxy (CompactSingleKES d) -> Word
sizeSigKES     proxy (CompactSingleKES d)
_ = forall v (proxy :: * -> *). DSIGNAlgorithm v => proxy v -> Word
sizeSigDSIGN     (forall {k} (t :: k). Proxy t
Proxy :: Proxy d) forall a. Num a => a -> a -> a
+
                       forall v (proxy :: * -> *). DSIGNAlgorithm v => proxy v -> Word
sizeVerKeyDSIGN  (forall {k} (t :: k). Proxy t
Proxy :: Proxy d)

    rawSerialiseVerKeyKES :: VerKeyKES (CompactSingleKES d) -> ByteString
rawSerialiseVerKeyKES  (VerKeyCompactSingleKES  VerKeyDSIGN d
vk) = forall v. DSIGNAlgorithm v => VerKeyDSIGN v -> ByteString
rawSerialiseVerKeyDSIGN VerKeyDSIGN d
vk
    rawSerialiseSignKeyKES :: SignKeyKES (CompactSingleKES d) -> ByteString
rawSerialiseSignKeyKES (SignKeyCompactSingleKES SignKeyDSIGN d
sk) = forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> ByteString
rawSerialiseSignKeyDSIGN SignKeyDSIGN d
sk
    rawSerialiseSigKES :: SigKES (CompactSingleKES d) -> ByteString
rawSerialiseSigKES     (SigCompactSingleKES SigDSIGN d
sig VerKeyDSIGN d
vk) =
      forall v. DSIGNAlgorithm v => SigDSIGN v -> ByteString
rawSerialiseSigDSIGN SigDSIGN d
sig forall a. Semigroup a => a -> a -> a
<> forall v. DSIGNAlgorithm v => VerKeyDSIGN v -> ByteString
rawSerialiseVerKeyDSIGN VerKeyDSIGN d
vk

    rawDeserialiseVerKeyKES :: ByteString -> Maybe (VerKeyKES (CompactSingleKES d))
rawDeserialiseVerKeyKES  = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall d. VerKeyDSIGN d -> VerKeyKES (CompactSingleKES d)
VerKeyCompactSingleKES  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. DSIGNAlgorithm v => ByteString -> Maybe (VerKeyDSIGN v)
rawDeserialiseVerKeyDSIGN
    rawDeserialiseSignKeyKES :: ByteString -> Maybe (SignKeyKES (CompactSingleKES d))
rawDeserialiseSignKeyKES = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall d. SignKeyDSIGN d -> SignKeyKES (CompactSingleKES d)
SignKeyCompactSingleKES forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. DSIGNAlgorithm v => ByteString -> Maybe (SignKeyDSIGN v)
rawDeserialiseSignKeyDSIGN
    rawDeserialiseSigKES :: ByteString -> Maybe (SigKES (CompactSingleKES d))
rawDeserialiseSigKES ByteString
b   = do
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString -> Int
BS.length ByteString
b forall a. Eq a => a -> a -> Bool
== forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
size_total)
        SigDSIGN d
sigma <- forall v. DSIGNAlgorithm v => ByteString -> Maybe (SigDSIGN v)
rawDeserialiseSigDSIGN  ByteString
b_sig
        VerKeyDSIGN d
vk  <- forall v. DSIGNAlgorithm v => ByteString -> Maybe (VerKeyDSIGN v)
rawDeserialiseVerKeyDSIGN ByteString
b_vk
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall d.
SigDSIGN d -> VerKeyDSIGN d -> SigKES (CompactSingleKES d)
SigCompactSingleKES SigDSIGN d
sigma VerKeyDSIGN d
vk)
      where
        b_sig :: ByteString
b_sig = Word -> Word -> ByteString -> ByteString
slice Word
off_sig Word
size_sig ByteString
b
        b_vk :: ByteString
b_vk = Word -> Word -> ByteString -> ByteString
slice Word
off_vk Word
size_vk  ByteString
b

        size_sig :: Word
size_sig   = forall v (proxy :: * -> *). DSIGNAlgorithm v => proxy v -> Word
sizeSigDSIGN    (forall {k} (t :: k). Proxy t
Proxy :: Proxy d)
        size_vk :: Word
size_vk    = forall v (proxy :: * -> *). DSIGNAlgorithm v => proxy v -> Word
sizeVerKeyDSIGN (forall {k} (t :: k). Proxy t
Proxy :: Proxy d)
        size_total :: Word
size_total = forall v (proxy :: * -> *). KESAlgorithm v => proxy v -> Word
sizeSigKES    (forall {k} (t :: k). Proxy t
Proxy :: Proxy (CompactSingleKES d))

        off_sig :: Word
off_sig    = Word
0 :: Word
        off_vk :: Word
off_vk     = Word
size_sig

instance (KESAlgorithm (CompactSingleKES d), DSIGNAlgorithm d) => OptimizedKESAlgorithm (CompactSingleKES d) where
    verifySigKES :: forall a.
(Signable (CompactSingleKES d) a, HasCallStack) =>
ContextKES (CompactSingleKES d)
-> Word -> a -> SigKES (CompactSingleKES d) -> Either String ()
verifySigKES ContextKES (CompactSingleKES d)
ctxt Word
t a
a (SigCompactSingleKES SigDSIGN d
sig VerKeyDSIGN d
vk) =
      forall a. HasCallStack => Bool -> a -> a
assert (Word
t forall a. Eq a => a -> a -> Bool
== Word
0) forall a b. (a -> b) -> a -> b
$
      forall v a.
(DSIGNAlgorithm v, Signable v a, HasCallStack) =>
ContextDSIGN v
-> VerKeyDSIGN v -> a -> SigDSIGN v -> Either String ()
verifyDSIGN ContextKES (CompactSingleKES d)
ctxt VerKeyDSIGN d
vk a
a SigDSIGN d
sig

    verKeyFromSigKES :: ContextKES (CompactSingleKES d)
-> Word
-> SigKES (CompactSingleKES d)
-> VerKeyKES (CompactSingleKES d)
verKeyFromSigKES ContextKES (CompactSingleKES d)
_ctxt Word
t (SigCompactSingleKES SigDSIGN d
_ VerKeyDSIGN d
vk) =
      forall a. HasCallStack => Bool -> a -> a
assert (Word
t forall a. Eq a => a -> a -> Bool
== Word
0) forall a b. (a -> b) -> a -> b
$
      forall d. VerKeyDSIGN d -> VerKeyKES (CompactSingleKES d)
VerKeyCompactSingleKES VerKeyDSIGN d
vk


--
-- VerKey instances
--

deriving instance DSIGNAlgorithm d => Show (VerKeyKES (CompactSingleKES d))
deriving instance DSIGNAlgorithm d => Eq   (VerKeyKES (CompactSingleKES d))

instance DSIGNAlgorithm d => NoThunks (SignKeyKES (CompactSingleKES d))

instance DSIGNAlgorithm d => ToCBOR (VerKeyKES (CompactSingleKES d)) where
  toCBOR :: VerKeyKES (CompactSingleKES d) -> Encoding
toCBOR = forall v. KESAlgorithm v => VerKeyKES v -> Encoding
encodeVerKeyKES
  encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (VerKeyKES (CompactSingleKES d)) -> Size
encodedSizeExpr forall t. ToCBOR t => Proxy t -> Size
_size = forall v. KESAlgorithm v => Proxy (VerKeyKES v) -> Size
encodedVerKeyKESSizeExpr

instance DSIGNAlgorithm d => FromCBOR (VerKeyKES (CompactSingleKES d)) where
  fromCBOR :: forall s. Decoder s (VerKeyKES (CompactSingleKES d))
fromCBOR = forall v s. KESAlgorithm v => Decoder s (VerKeyKES v)
decodeVerKeyKES


--
-- SignKey instances
--

deriving instance DSIGNAlgorithm d => Show (SignKeyKES (CompactSingleKES d))

instance DSIGNAlgorithm d => NoThunks (VerKeyKES  (CompactSingleKES d))

instance DSIGNAlgorithm d => ToCBOR (SignKeyKES (CompactSingleKES d)) where
  toCBOR :: SignKeyKES (CompactSingleKES d) -> Encoding
toCBOR = forall v. KESAlgorithm v => SignKeyKES v -> Encoding
encodeSignKeyKES
  encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (SignKeyKES (CompactSingleKES d)) -> Size
encodedSizeExpr forall t. ToCBOR t => Proxy t -> Size
_size = forall v. KESAlgorithm v => Proxy (SignKeyKES v) -> Size
encodedSignKeyKESSizeExpr

instance DSIGNAlgorithm d => FromCBOR (SignKeyKES (CompactSingleKES d)) where
  fromCBOR :: forall s. Decoder s (SignKeyKES (CompactSingleKES d))
fromCBOR = forall v s. KESAlgorithm v => Decoder s (SignKeyKES v)
decodeSignKeyKES


--
-- Sig instances
--

deriving instance DSIGNAlgorithm d => Show (SigKES (CompactSingleKES d))
deriving instance DSIGNAlgorithm d => Eq   (SigKES (CompactSingleKES d))

instance DSIGNAlgorithm d => NoThunks (SigKES (CompactSingleKES d))

instance DSIGNAlgorithm d => ToCBOR (SigKES (CompactSingleKES d)) where
  toCBOR :: SigKES (CompactSingleKES d) -> Encoding
toCBOR = forall v. KESAlgorithm v => SigKES v -> Encoding
encodeSigKES
  encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (SigKES (CompactSingleKES d)) -> Size
encodedSizeExpr forall t. ToCBOR t => Proxy t -> Size
_size = forall v. KESAlgorithm v => Proxy (SigKES v) -> Size
encodedSigKESSizeExpr

instance DSIGNAlgorithm d => FromCBOR (SigKES (CompactSingleKES d)) where
  fromCBOR :: forall s. Decoder s (SigKES (CompactSingleKES d))
fromCBOR = forall v s. KESAlgorithm v => Decoder s (SigKES v)
decodeSigKES

slice :: Word -> Word -> ByteString -> ByteString
slice :: Word -> Word -> ByteString -> ByteString
slice Word
offset Word
size = Int -> ByteString -> ByteString
BS.take (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
size)
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
BS.drop (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
offset)