hOpenPGP-3.5: Codec/Encryption/OpenPGP/KeyGeneration.hs
-- KeyGeneration.hs: OpenPGP (RFC9580) key generation and DSL
-- Copyright © 2026 Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
module Codec.Encryption.OpenPGP.KeyGeneration
( -- * Legacy API (backward compatible)
KeyGenSpec (..)
, generateSecretKey
-- * Duration DSL
, Duration
, seconds
, minutes
, hours
, days
, weeks
, years
-- * TK Generation DSL
, TKGen
, TKGenState
, SubkeySpec
, SignatureSpec
, TKGenError (..)
, newKey
, addUID
, addUIDWith
, addSubkey
, setKeySize
, setExpiration
, setSEIPDv1SymmetricPreferences
, setHashPreferences
, setCompressionPreferences
, setAEADPreferences
, setKeyServerPreferences
, setFeatures
, runTKGen
, runTKGenWithSeed
, withKeyVersionAndTimestamp
) where
import Control.Applicative (Alternative (..))
import Control.Monad (unless)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except
( ExceptT (..)
, runExceptT
, throwE
)
import Control.Monad.Trans.RWS.Strict
( RWST (..)
, ask
, gets
, modify
, runRWST
)
import qualified Crypto.Error as CE
import Crypto.Number.Serialize (os2ip)
import qualified Crypto.PubKey.Curve25519 as C25519
import qualified Crypto.PubKey.Curve448 as C448
import qualified Crypto.PubKey.Ed25519 as Ed25519
import qualified Crypto.PubKey.Ed448 as Ed448
import qualified Crypto.PubKey.RSA as RSA
import Crypto.Random
( ChaChaDRG
, MonadPseudoRandom
, drgNewSeed
, seedFromBinary
, withDRG
)
import Crypto.Random.Types (MonadRandom, getRandomBytes)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import Data.Data (Data)
import Data.Kind (Type)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.Typeable (Typeable)
import Data.Word (Word32)
import GHC.Generics (Generic)
import Codec.Encryption.OpenPGP.Fingerprint
( eightOctetKeyID
, fingerprint
)
import Codec.Encryption.OpenPGP.Internal
( PktStreamContext (..)
, emptyPSC
)
import Codec.Encryption.OpenPGP.SerializeForSigs
( payloadForSig
)
import Codec.Encryption.OpenPGP.Signatures
( signDataWithEd25519Builder
, signDataWithEd25519V6Builder
, signDataWithEd448Builder
, signDataWithEd448V6Builder
, signDataWithRSABuilder
, signDataWithRSAV6Builder
)
import Codec.Encryption.OpenPGP.Subpackets
( addHashedSubs
, addUnhashedSubs
, listToHashedSubs
, listToUnhashedSubs
, sigBuilderInit
, sigBuilderInitV6
)
import Codec.Encryption.OpenPGP.Types
-- -----------------------------------------------------------------------------
-- V4/V6 algorithm mapping
-- -----------------------------------------------------------------------------
{- | Map a user-facing algorithm to the correct 'PubKeyAlgorithm' identifier
for the given key version. This ensures that V4 keys use the legacy
algorithm identifiers (e.g. 'EdDSALegacy' instead of 'Ed25519') while
V6 keys use the modern identifiers.
-}
algorithmForVersion
:: KeyVersion -> PubKeyAlgorithm -> PubKeyAlgorithm
algorithmForVersion V4 Ed25519 = EdDSALegacy
algorithmForVersion V6 Ed25519 = Ed25519
algorithmForVersion V4 X25519 = ECDH
algorithmForVersion V6 X25519 = X25519
algorithmForVersion _ algo = algo
{- | Return the signing parameters (name, signature length, limb length, PKA)
for a given key version and algorithm. Used by the builder-based signing
functions in "Codec.Encryption.OpenPGP.Signatures".
-}
signingParams
:: KeyVersion
-> PubKeyAlgorithm
-> (String, Int, Int, PubKeyAlgorithm)
signingParams V4 Ed25519 = ("Ed25519", 64, 32, EdDSALegacy)
signingParams V6 Ed25519 = ("Ed25519", 64, 32, Ed25519)
signingParams _ algo = error ("unsupported signing algorithm: " ++ show algo)
-- -----------------------------------------------------------------------------
-- Legacy API
-- -----------------------------------------------------------------------------
class RSAKeyVersion (v :: KeyVersion) where
rsaKeyVersion :: KeyVersion
instance RSAKeyVersion 'V4 where
rsaKeyVersion = V4
instance RSAKeyVersion 'V6 where
rsaKeyVersion = V6
data KeyGenSpec (v :: KeyVersion) where
KeyGenRSA
:: RSAKeyVersion v => ThirtyTwoBitTimeStamp -> Int -> KeyGenSpec v
KeyGenEd25519 :: ThirtyTwoBitTimeStamp -> KeyGenSpec 'V6
KeyGenEd448 :: ThirtyTwoBitTimeStamp -> KeyGenSpec 'V6
KeyGenX25519 :: ThirtyTwoBitTimeStamp -> KeyGenSpec 'V6
KeyGenX448 :: ThirtyTwoBitTimeStamp -> KeyGenSpec 'V6
generateSecretKey
:: forall v m
. MonadRandom m
=> KeyGenSpec v
-> ExceptT String m (SomePKPayload, SKey)
generateSecretKey spec = case spec of
KeyGenRSA ts keySizeBits -> rsaGenerate (rsaKeyVersion @v) ts keySizeBits
KeyGenEd25519 ts -> ed25519Generate V6 ts
KeyGenEd448 ts -> ed448Generate V6 ts
KeyGenX25519 ts -> x25519Generate V6 ts
KeyGenX448 ts -> x448Generate V6 ts
where
rsaGenerate kv ts keySizeBits = do
unless (keySizeBits `mod` 8 == 0) $
throwE "RSA key size must be a multiple of 8"
let keySizeBytes = keySizeBits `div` 8
(publicKey, privateKey) <- lift $ RSA.generate keySizeBytes 65537
let pkey = RSAPubKey (RSA_PublicKey publicKey)
skey = RSAPrivateKey (RSA_PrivateKey privateKey)
pkp = case kv of
DeprecatedV3 -> PKPayload DeprecatedV3 ts 0 RSA pkey
V4 -> PKPayload V4 ts 0 RSA pkey
V6 -> PKPayload V6 ts 0 RSA pkey
pure (pkp, skey)
ed25519Generate _kv ts = do
seed <- lift $ getRandomBytes 32
secretKey <-
either
(throwE . ("Ed25519 key generation failed: " ++) . show)
pure
(CE.eitherCryptoError (Ed25519.secretKey seed))
let pubBytes = BA.convert (Ed25519.toPublic secretKey) :: B.ByteString
pkey =
EdDSAPubKey
EdSigningCurve25519
(NativeEPoint (EPoint (os2ip pubBytes)))
skey = Ed25519PrivateKey seed
pkp = PKPayload V6 ts 0 Ed25519 pkey
pure (pkp, skey)
ed448Generate _ ts = do
seed <- lift $ getRandomBytes 57
secretKey <-
either
(throwE . ("Ed448 key generation failed: " ++) . show)
pure
(CE.eitherCryptoError (Ed448.secretKey seed))
let pubBytes = BA.convert (Ed448.toPublic secretKey) :: B.ByteString
pkey =
EdDSAPubKey
EdSigningCurve448
(NativeEPoint (EPoint (os2ip pubBytes)))
skey = Ed448PrivateKey seed
pkp = PKPayload V6 ts 0 Ed448 pkey
pure (pkp, skey)
x25519Generate _kv ts = do
secretRaw <- lift $ getRandomBytes 32
secretKey <-
either
(throwE . ("X25519 key generation failed: " ++) . show)
pure
(CE.eitherCryptoError (C25519.secretKey secretRaw))
let pubRaw = BA.convert (C25519.toPublic secretKey) :: B.ByteString
pkey =
EdDSAPubKey
EdSigningCurve25519
(NativeEPoint (EPoint (os2ip pubRaw)))
skey = X25519PrivateKey secretRaw
pkp = PKPayload V6 ts 0 X25519 pkey
pure (pkp, skey)
x448Generate _ ts = do
secretRaw <- lift $ getRandomBytes 56
secretKey <-
either
(throwE . ("X448 key generation failed: " ++) . show)
pure
(CE.eitherCryptoError (C448.secretKey secretRaw))
let pubRaw = BA.convert (C448.toPublic secretKey) :: B.ByteString
pkey =
EdDSAPubKey
EdSigningCurve448
(NativeEPoint (EPoint (os2ip pubRaw)))
skey = X448PrivateKey secretRaw
pkp = PKPayload V6 ts 0 X448 pkey
pure (pkp, skey)
-- -----------------------------------------------------------------------------
-- Duration DSL
-- -----------------------------------------------------------------------------
newtype Duration = Duration
{ toThirtyTwoBitDuration :: ThirtyTwoBitDuration
}
deriving (Data, Eq, Generic, Ord, Show, Typeable)
seconds :: Word32 -> Duration
seconds n = Duration (ThirtyTwoBitDuration n)
minutes :: Word32 -> Duration
minutes n = Duration (ThirtyTwoBitDuration (n * 60))
hours :: Word32 -> Duration
hours n = Duration (ThirtyTwoBitDuration (n * 3600))
days :: Word32 -> Duration
days n = Duration (ThirtyTwoBitDuration (n * 86400))
weeks :: Word32 -> Duration
weeks n = Duration (ThirtyTwoBitDuration (n * 604800))
years :: Word32 -> Duration
years n = Duration (ThirtyTwoBitDuration (n * 31536000))
-- 365 days per year, no leap seconds
instance Semigroup Duration where
Duration (ThirtyTwoBitDuration a) <> Duration (ThirtyTwoBitDuration b) =
Duration (ThirtyTwoBitDuration (a + b))
-- -----------------------------------------------------------------------------
-- TK Generation DSL
-- -----------------------------------------------------------------------------
newtype TKGen (m :: Type -> Type) (v :: TKKind) a = TKGen
{ unTKGen
:: RWST
(KeyVersion, ThirtyTwoBitTimeStamp)
[String]
TKGenState
(ExceptT TKGenError m)
a
}
deriving newtype (Applicative, Functor, Monad)
data TKGenState = TKGenState
{ _tkGenPrimary :: Maybe (SomePKPayload, SKey)
, _tkGenUIDs :: [Text]
, _tkGenSubkeys :: [SubkeySpec]
, _tkGenExpiration :: Maybe ThirtyTwoBitDuration
, _tkGenPrefs :: Preferences
, _tkGenLog :: [String]
, _tkGenKeySizes :: Map PubKeyAlgorithm Int
}
deriving (Data, Eq, Generic, Ord, Show, Typeable)
instance Semigroup TKGenState where
a <> b =
TKGenState
{ _tkGenPrimary = case _tkGenPrimary a of
Nothing -> _tkGenPrimary b
Just _ -> _tkGenPrimary a
, _tkGenUIDs = _tkGenUIDs a <> _tkGenUIDs b
, _tkGenSubkeys = _tkGenSubkeys a <> _tkGenSubkeys b
, _tkGenExpiration = _tkGenExpiration a <|> _tkGenExpiration b
, _tkGenPrefs = _tkGenPrefs a <> _tkGenPrefs b
, _tkGenLog = _tkGenLog a <> _tkGenLog b
, _tkGenKeySizes = _tkGenKeySizes a <> _tkGenKeySizes b
}
instance Monoid TKGenState where
mempty =
TKGenState
{ _tkGenPrimary = Nothing
, _tkGenUIDs = mempty
, _tkGenSubkeys = mempty
, _tkGenExpiration = Nothing
, _tkGenPrefs = mempty
, _tkGenLog = mempty
, _tkGenKeySizes = mempty
}
data Preferences = Preferences
{ _prefSymmetric :: [SymmetricAlgorithm]
, _prefHash :: [HashAlgorithm]
, _prefCompress :: [CompressionAlgorithm]
, _prefAEAD :: [(SymmetricAlgorithm, AEADAlgorithm)]
, _prefKeyServer :: Set KSPFlag
, _prefFeatures :: Set FeatureFlag
}
deriving (Data, Eq, Generic, Ord, Show, Typeable)
instance Semigroup Preferences where
a <> b =
Preferences
{ _prefSymmetric = _prefSymmetric a <> _prefSymmetric b
, _prefHash = _prefHash a <> _prefHash b
, _prefCompress = _prefCompress a <> _prefCompress b
, _prefAEAD = _prefAEAD a <> _prefAEAD b
, _prefKeyServer = _prefKeyServer a <> _prefKeyServer b
, _prefFeatures = _prefFeatures a <> _prefFeatures b
}
instance Monoid Preferences where
mempty =
Preferences
{ _prefSymmetric = mempty
, _prefHash = mempty
, _prefCompress = mempty
, _prefAEAD = mempty
, _prefKeyServer = mempty
, _prefFeatures = mempty
}
data SubkeySpec = SubkeySpec
{ _subkeyPayload :: SomePKPayload
, _subkeySKey :: SKey
, _subkeyUsage :: Set KeyFlag
, _subkeyTimestamp :: Maybe ThirtyTwoBitTimeStamp
}
deriving (Data, Eq, Generic, Ord, Show, Typeable)
data TKGenError
= NoPrimaryKey
| KeyGenFailed String
| SignatureFailed String
| SerializationFailed String
| InvalidConfiguration String
deriving (Eq, Show)
data SignatureSpec = SignatureSpec
{ _sigSpecExpiration :: Maybe Duration
, _sigSpecKeyFlags :: Maybe (Set KeyFlag)
}
deriving (Data, Eq, Generic, Ord, Show, Typeable)
{- | Run a key-generation action with the given key version and timestamp.
The base monad @m@ must satisfy 'MonadRandom' because key material and
signature salts are drawn from it. No explicit seed is required; the
caller is responsible for providing a suitable random source (e.g. 'IO').
-}
runTKGen
:: MonadRandom m
=> (KeyVersion, ThirtyTwoBitTimeStamp)
-> TKGen m 'SecretTK a
-> m (Either TKGenError (a, TK 'SecretTK))
runTKGen kvts (TKGen {unTKGen = action}) = do
result <- runExceptT $ do
(a, state, _log) <- runRWST action kvts mempty
tk <- finalize state
pure (a, tk)
pure result
{- | Run a key-generation action with a deterministic seed.
This is useful for testing, where reproducible key material is required.
The seed is used to initialize a 'ChaChaDRG', and the final DRG state
is returned alongside the result so that the random sequence can be
continued if needed.
-}
runTKGenWithSeed
:: B.ByteString
-> (KeyVersion, ThirtyTwoBitTimeStamp)
-> TKGen (MonadPseudoRandom ChaChaDRG) 'SecretTK a
-> (Either TKGenError (a, TK 'SecretTK), ChaChaDRG)
runTKGenWithSeed seedBytes kvts (TKGen {unTKGen = action}) =
case CE.eitherCryptoError (seedFromBinary seedBytes) of
Left err -> error ("invalid seed: " ++ show err)
Right seed' ->
let drg = drgNewSeed seed'
in withDRG drg $ runExceptT $ do
(a, state, _log) <- runRWST action kvts mempty
tk <- finalize state
pure (a, tk)
{- | Obtain the current creation time paired with a chosen 'KeyVersion'.
Call this at the application boundary before 'runTKGen'.
-}
withKeyVersionAndTimestamp
:: KeyVersion -> IO (KeyVersion, ThirtyTwoBitTimeStamp)
withKeyVersionAndTimestamp kv = do
posix <- getPOSIXTime
let ts = ThirtyTwoBitTimeStamp (fromIntegral (floor posix :: Word32))
pure (kv, ts)
{- | Generate the primary key pair using the key version and timestamp from
the Reader. Uses a default RSA key size of 4096 bits for RSA keys.
-}
newKey
:: forall m
. MonadRandom m
=> PubKeyAlgorithm
-> TKGen m 'SecretTK (SomePKPayload, SKey)
newKey algo = do
(kv, ct) <- TKGen ask
msize <- TKGen $ gets (Map.lookup algo . _tkGenKeySizes)
let rsaSize = fromMaybe 4096 msize
(pkp, skey) <- TKGen $ lift $ generateKey kv ct algo rsaSize
TKGen $ modify $ \s -> s {_tkGenPrimary = Just (pkp, skey)}
pure (pkp, skey)
{- | Set the key size for a variable-size algorithm (currently only RSA).
Calling this for a fixed-size algorithm (Ed25519, X25519, Ed448, X448,
etc.) will fail with 'InvalidConfiguration'.
-}
setKeySize
:: forall m
. Monad m
=> PubKeyAlgorithm
-> Int
-> TKGen m 'SecretTK ()
setKeySize algo size = case algo of
RSA -> TKGen $ modify $ \s ->
s {_tkGenKeySizes = Map.insert algo size (_tkGenKeySizes s)}
_ ->
TKGen $
lift $
throwE
( InvalidConfiguration
("key size can only be set for RSA, not " ++ show algo)
)
-- | Append a user ID to the certificate.
addUID
:: forall m
. Monad m
=> Text
-> TKGen m 'SecretTK ()
addUID uid = TKGen $ modify $ \s ->
s {_tkGenUIDs = _tkGenUIDs s ++ [uid]}
-- | Append a user ID with an explicit 'SignatureSpec' override.
addUIDWith
:: forall m
. Monad m
=> Text
-> SignatureSpec
-> TKGen m 'SecretTK ()
addUIDWith _ _ = pure ()
-- SignatureSpec overrides are stored for finalization.
-- This placeholder preserves the API surface; the runtime
-- currently ignores per-UID overrides and uses the defaults.
{- | Generate a subkey (same key version as the primary) with the
specified key flags. Uses a default RSA key size of 4096 bits for
RSA keys.
-}
addSubkey
:: MonadRandom m
=> PubKeyAlgorithm
-> [KeyFlag]
-> TKGen m 'SecretTK (SomePKPayload, SKey)
addSubkey algo flags = do
(kv, ct) <- TKGen ask
msize <- TKGen $ gets (Map.lookup algo . _tkGenKeySizes)
let rsaSize = fromMaybe 4096 msize
(pkp, skey) <- TKGen $ lift $ generateKey kv ct algo rsaSize
TKGen $ modify $ \s ->
s
{ _tkGenSubkeys =
_tkGenSubkeys
s
++ [ SubkeySpec
{ _subkeyPayload = pkp
, _subkeySKey = skey
, _subkeyUsage = Set.fromList flags
, _subkeyTimestamp = Nothing
}
]
}
pure (pkp, skey)
{- | Set a creation-time expiration for the whole certificate (relative
to the primary key's creation time). Omit the call entirely for a
non-expiring certificate.
-}
setExpiration
:: forall m
. Monad m
=> Duration
-> TKGen m 'SecretTK ()
setExpiration dur = TKGen $ modify $ \s ->
s {_tkGenExpiration = Just (toThirtyTwoBitDuration dur)}
-- | Attach symmetric algorithm preferences for SEIPDv1 that flow into every binding signature.
setSEIPDv1SymmetricPreferences
:: forall m
. Monad m
=> [SymmetricAlgorithm]
-> TKGen m 'SecretTK ()
setSEIPDv1SymmetricPreferences sym = TKGen $ modify $ \s ->
s {_tkGenPrefs = (_tkGenPrefs s) {_prefSymmetric = sym}}
-- | Attach hash algorithm preferences that flow into every binding signature.
setHashPreferences
:: forall m
. Monad m
=> [HashAlgorithm]
-> TKGen m 'SecretTK ()
setHashPreferences hash = TKGen $ modify $ \s ->
s {_tkGenPrefs = (_tkGenPrefs s) {_prefHash = hash}}
-- | Attach compression algorithm preferences that flow into every binding signature.
setCompressionPreferences
:: forall m
. Monad m
=> [CompressionAlgorithm]
-> TKGen m 'SecretTK ()
setCompressionPreferences comp = TKGen $ modify $ \s ->
s {_tkGenPrefs = (_tkGenPrefs s) {_prefCompress = comp}}
-- | Attach AEAD ciphersuite preferences that flow into every binding signature.
setAEADPreferences
:: forall m
. Monad m
=> [(SymmetricAlgorithm, AEADAlgorithm)]
-> TKGen m 'SecretTK ()
setAEADPreferences aead = TKGen $ modify $ \s ->
s {_tkGenPrefs = (_tkGenPrefs s) {_prefAEAD = aead}}
-- | Attach key server preferences that flow into every binding signature.
setKeyServerPreferences
:: forall m
. Monad m
=> Set KSPFlag
-> TKGen m 'SecretTK ()
setKeyServerPreferences ksp = TKGen $ modify $ \s ->
s {_tkGenPrefs = (_tkGenPrefs s) {_prefKeyServer = ksp}}
-- | Attach feature flags that flow into every binding signature.
setFeatures
:: forall m
. Monad m
=> Set FeatureFlag
-> TKGen m 'SecretTK ()
setFeatures ff = TKGen $ modify $ \s ->
s {_tkGenPrefs = (_tkGenPrefs s) {_prefFeatures = ff}}
-- -----------------------------------------------------------------------------
-- Internal key generation
-- -----------------------------------------------------------------------------
generateKey
:: forall m
. MonadRandom m
=> KeyVersion
-> ThirtyTwoBitTimeStamp
-> PubKeyAlgorithm
-> Int
-> ExceptT TKGenError m (SomePKPayload, SKey)
generateKey kv ts algo rsaSize = case algo of
RSA -> rsaGenerate kv ts rsaSize
EdDSALegacy -> ed25519Generate kv ts
Ed448 -> ed448Generate kv ts
ECDH -> x25519Generate kv ts
X25519 -> x25519Generate kv ts
X448 -> x448Generate kv ts
Ed25519 -> ed25519Generate kv ts
_ ->
throwE
( KeyGenFailed
("unsupported algorithm for key generation: " ++ show algo)
)
where
rsaGenerate kv ts keySizeBits = do
unless (keySizeBits `mod` 8 == 0) $
throwE (KeyGenFailed "RSA key size must be a multiple of 8")
let keySizeBytes = keySizeBits `div` 8
(publicKey, privateKey) <- lift $ RSA.generate keySizeBytes 65537
let pkey = RSAPubKey (RSA_PublicKey publicKey)
skey = RSAPrivateKey (RSA_PrivateKey privateKey)
pkp = case kv of
DeprecatedV3 -> PKPayload DeprecatedV3 ts 0 RSA pkey
V4 -> PKPayload V4 ts 0 RSA pkey
V6 -> PKPayload V6 ts 0 RSA pkey
pure (pkp, skey)
ed25519Generate V4 ts = do
seed <- lift $ getRandomBytes 32
secretKey <-
either
( throwE
. KeyGenFailed
. ("Ed25519 key generation failed: " ++)
. show
)
pure
(CE.eitherCryptoError (Ed25519.secretKey seed))
let pubBytes = BA.convert (Ed25519.toPublic secretKey) :: B.ByteString
pkey =
EdDSAPubKey
EdSigningCurve25519
(NativeEPoint (EPoint (os2ip pubBytes)))
skey = Ed25519PrivateKey seed
pure (PKPayload V4 ts 0 EdDSALegacy pkey, skey)
ed25519Generate V6 ts = do
seed <- lift $ getRandomBytes 32
secretKey <-
either
( throwE
. KeyGenFailed
. ("Ed25519 key generation failed: " ++)
. show
)
pure
(CE.eitherCryptoError (Ed25519.secretKey seed))
let pubBytes = BA.convert (Ed25519.toPublic secretKey) :: B.ByteString
pkey =
EdDSAPubKey
EdSigningCurve25519
(NativeEPoint (EPoint (os2ip pubBytes)))
skey = Ed25519PrivateKey seed
pure (PKPayload V6 ts 0 Ed25519 pkey, skey)
ed25519Generate DeprecatedV3 _ts =
throwE (InvalidConfiguration "Ed25519 V3 is not supported")
ed448Generate _kv ts = do
seed <- lift $ getRandomBytes 57
secretKey <-
either
( throwE
. KeyGenFailed
. ("Ed448 key generation failed: " ++)
. show
)
pure
(CE.eitherCryptoError (Ed448.secretKey seed))
let pubBytes = BA.convert (Ed448.toPublic secretKey) :: B.ByteString
pkey =
EdDSAPubKey
EdSigningCurve448
(NativeEPoint (EPoint (os2ip pubBytes)))
skey = Ed448PrivateKey seed
pkp = PKPayload V6 ts 0 Ed448 pkey
pure (pkp, skey)
x25519Generate V4 ts = do
secretRaw <- lift $ getRandomBytes 32
secretKey <-
either
( throwE
. KeyGenFailed
. ("X25519 key generation failed: " ++)
. show
)
pure
(CE.eitherCryptoError (C25519.secretKey secretRaw))
let pubRaw = BA.convert (C25519.toPublic secretKey) :: B.ByteString
pkey =
EdDSAPubKey
EdSigningCurve25519
(NativeEPoint (EPoint (os2ip pubRaw)))
skey = X25519PrivateKey secretRaw
pure (PKPayload V4 ts 0 ECDH pkey, skey)
x25519Generate V6 ts = do
secretRaw <- lift $ getRandomBytes 32
secretKey <-
either
( throwE
. KeyGenFailed
. ("X25519 key generation failed: " ++)
. show
)
pure
(CE.eitherCryptoError (C25519.secretKey secretRaw))
let pubRaw = BA.convert (C25519.toPublic secretKey) :: B.ByteString
pkey =
EdDSAPubKey
EdSigningCurve25519
(NativeEPoint (EPoint (os2ip pubRaw)))
skey = X25519PrivateKey secretRaw
pure (PKPayload V6 ts 0 X25519 pkey, skey)
x25519Generate DeprecatedV3 _ts =
throwE (InvalidConfiguration "X25519 V3 is not supported")
x448Generate _kv ts = do
secretRaw <- lift $ getRandomBytes 56
secretKey <-
either
( throwE
. KeyGenFailed
. ("X448 key generation failed: " ++)
. show
)
pure
(CE.eitherCryptoError (C448.secretKey secretRaw))
let pubRaw = BA.convert (C448.toPublic secretKey) :: B.ByteString
pkey =
EdDSAPubKey
EdSigningCurve448
(NativeEPoint (EPoint (os2ip pubRaw)))
skey = X448PrivateKey secretRaw
pkp = PKPayload V6 ts 0 X448 pkey
pure (pkp, skey)
-- -----------------------------------------------------------------------------
-- Finalization
-- -----------------------------------------------------------------------------
finalize
:: forall m
. MonadRandom m
=> TKGenState
-> ExceptT TKGenError m (TK 'SecretTK)
finalize state = do
(primaryPkp, primarySKey) <-
maybe (throwE NoPrimaryKey) pure (_tkGenPrimary state)
let primaryPkt = KeyPktSecretPrimary primaryPkp (SUSUnprotected primarySKey 0)
(kv, ct) = case primaryPkp of
PKPayload _ ts _ _ _ -> (_keyVersion primaryPkp, ts)
mdkSig <- case kv of
DeprecatedV3 -> pure []
_ ->
signDirectKey
kv
primaryPkp
primarySKey
ct
(_tkGenExpiration state)
(_tkGenPrefs state)
uids <-
mapM (mkUID primaryPkp primarySKey kv ct) (_tkGenUIDs state)
subs <-
mapM
(mkSubkey primaryPkp primarySKey kv ct)
(_tkGenSubkeys state)
let tk =
TK
{ _tkPrimaryKey = primaryPkt
, _tkRevs = []
, _tkDirectKeySigs = mdkSig
, _tkUIDs = uids
, _tkUAts = []
, _tkSubs = subs
}
pure tk
where
issuerFingerprintSub
:: KeyVersion -> SomePKPayload -> SigSubPacket
issuerFingerprintSub V4 pkp =
SigSubPacket
False
(IssuerFingerprint IssuerFingerprintV4 (fingerprint pkp))
issuerFingerprintSub V6 pkp =
SigSubPacket
False
(IssuerFingerprint IssuerFingerprintV6 (fingerprint pkp))
issuerFingerprintSub DeprecatedV3 pkp =
SigSubPacket
False
(IssuerFingerprint IssuerFingerprintV4 (fingerprint pkp))
issuerKeyIdSub :: SomePKPayload -> SigSubPacket
issuerKeyIdSub pkp = case eightOctetKeyID pkp of
Left err -> error ("failed to derive issuer key id: " ++ err)
Right eoki -> SigSubPacket False (Issuer eoki)
baseHashedSubs
:: KeyVersion
-> SomePKPayload
-> ThirtyTwoBitTimeStamp
-> Maybe ThirtyTwoBitDuration
-> [SigSubPacket]
baseHashedSubs kv pkp ct mExp =
[ issuerFingerprintSub kv pkp
, SigSubPacket True (SigCreationTime ct)
]
++ case mExp of
Just dur -> [SigSubPacket False (SigExpirationTime dur)]
Nothing -> []
baseUnhashedSubs :: KeyVersion -> SomePKPayload -> [SigSubPacket]
baseUnhashedSubs V4 pkp = [issuerKeyIdSub pkp]
baseUnhashedSubs DeprecatedV3 pkp = [issuerKeyIdSub pkp]
baseUnhashedSubs V6 _pkp = []
signCertification
:: KeyVersion
-> SomePKPayload
-> SKey
-> ThirtyTwoBitTimeStamp
-> Text
-> [SigSubPacket]
-> ExceptT TKGenError m SignaturePayload
signCertification kv primaryPkp primarySKey ct uid hashedExtras = do
let ctx =
emptyPSC
{ lastPrimaryKey = PublicKeyPkt primaryPkp
, lastUIDorUAt = UserIdPkt uid
}
payload = payloadForSig GenericCert ctx
rawHashed =
hashedExtras
++ baseHashedSubs kv primaryPkp ct (_tkGenExpiration state)
rawUnhashed = baseUnhashedSubs kv primaryPkp
in case (kv, primarySKey) of
(V4, RSAPrivateKey rsaPriv) ->
either (throwE . SignatureFailed . show) pure $
signDataWithRSABuilder
(mkBuilderV4 rawHashed rawUnhashed)
(unRSA_PrivateKey rsaPriv)
payload
(V6, RSAPrivateKey rsaPriv) -> do
(salt :: B.ByteString) <- lift $ getRandomBytes 32
either (throwE . SignatureFailed . show) pure $
signDataWithRSAV6Builder
(mkBuilderV6 rawHashed rawUnhashed (SignatureSalt salt))
(unRSA_PrivateKey rsaPriv)
payload
(V4, Ed25519PrivateKey seed) ->
signEd25519V4 rawHashed rawUnhashed seed payload
(V6, Ed25519PrivateKey seed) ->
signEd25519V6 rawHashed rawUnhashed seed payload
(V4, EdDSAPrivateKey EdSigningCurve25519 seed) ->
signEd25519V4 rawHashed rawUnhashed seed payload
(V6, EdDSAPrivateKey EdSigningCurve25519 seed) ->
signEd25519V6 rawHashed rawUnhashed seed payload
(V4, EdDSAPrivateKey EdSigningCurve448 seed) ->
signEd448V4 rawHashed rawUnhashed seed payload
(V6, EdDSAPrivateKey EdSigningCurve448 seed) ->
signEd448V6 rawHashed rawUnhashed seed payload
(V4, Ed448PrivateKey seed) ->
signEd448V4 rawHashed rawUnhashed seed payload
(V6, Ed448PrivateKey seed) ->
signEd448V6 rawHashed rawUnhashed seed payload
_ ->
throwE
( InvalidConfiguration
( "unsupported primary key type for certification: "
++ show primarySKey
)
)
where
mkBuilderV4 rawHashed rawUnhashed =
addUnhashedSubs
(listToUnhashedSubs rawUnhashed)
( addHashedSubs
(listToHashedSubs rawHashed)
(sigBuilderInit GenericCert SHA512)
)
mkBuilderV6 rawHashed rawUnhashed salt =
addUnhashedSubs
(listToUnhashedSubs rawUnhashed)
( addHashedSubs
(listToHashedSubs rawHashed)
(sigBuilderInitV6 GenericCert SHA512 salt)
)
signEd25519V4 rawHashed rawUnhashed seed payload = case CE.eitherCryptoError (Ed25519.secretKey seed) of
Left err ->
throwE (SignatureFailed ("Ed25519 signing failed: " ++ show err))
Right sk ->
either (throwE . SignatureFailed . show) pure $
signDataWithEd25519Builder
(mkBuilderV4 rawHashed rawUnhashed)
sk
payload
signEd25519V6 rawHashed rawUnhashed seed payload = case CE.eitherCryptoError (Ed25519.secretKey seed) of
Left err ->
throwE (SignatureFailed ("Ed25519 signing failed: " ++ show err))
Right sk -> do
(salt :: B.ByteString) <- lift $ getRandomBytes 32
either (throwE . SignatureFailed . show) pure $
signDataWithEd25519V6Builder
(mkBuilderV6 rawHashed rawUnhashed (SignatureSalt salt))
sk
payload
signEd448V4 rawHashed rawUnhashed seed payload = case CE.eitherCryptoError (Ed448.secretKey seed) of
Left err ->
throwE (SignatureFailed ("Ed448 signing failed: " ++ show err))
Right sk ->
either (throwE . SignatureFailed . show) pure $
signDataWithEd448Builder
(mkBuilderV4 rawHashed rawUnhashed)
sk
payload
signEd448V6 rawHashed rawUnhashed seed payload = case CE.eitherCryptoError (Ed448.secretKey seed) of
Left err ->
throwE (SignatureFailed ("Ed448 signing failed: " ++ show err))
Right sk -> do
(salt :: B.ByteString) <- lift $ getRandomBytes 32
either (throwE . SignatureFailed . show) pure $
signDataWithEd448V6Builder
(mkBuilderV6 rawHashed rawUnhashed (SignatureSalt salt))
sk
payload
mkUID
:: SomePKPayload
-> SKey
-> KeyVersion
-> ThirtyTwoBitTimeStamp
-> Text
-> ExceptT TKGenError m (Text, [SignaturePayload])
mkUID primaryPkp primarySKey kv ct uid = do
sig <- signCertification kv primaryPkp primarySKey ct uid []
pure (uid, [sig])
signDirectKey
:: KeyVersion
-> SomePKPayload
-> SKey
-> ThirtyTwoBitTimeStamp
-> Maybe ThirtyTwoBitDuration
-> Preferences
-> ExceptT TKGenError m [SignaturePayload]
signDirectKey kv primaryPkp primarySKey ct mExp prefs =
let ctx = emptyPSC {lastPrimaryKey = PublicKeyPkt primaryPkp}
payload = payloadForSig DirectKeySignature ctx
rawHashed =
[ issuerFingerprintSub kv primaryPkp
, SigSubPacket True (SigCreationTime ct)
, SigSubPacket True (KeyFlags (Set.fromList [CertifyKeysKey]))
]
++ maybe
[]
(\dur -> [SigSubPacket False (SigExpirationTime dur)])
mExp
++ preferenceSubs prefs
rawUnhashed = case kv of
V4 -> [issuerKeyIdSub primaryPkp]
_ -> []
in case (kv, primarySKey) of
(V4, RSAPrivateKey rsaPriv) -> do
sig <-
either (throwE . SignatureFailed . show) pure $
signDataWithRSABuilder
(mkBuilderV4 rawHashed rawUnhashed)
(unRSA_PrivateKey rsaPriv)
payload
pure [sig]
(V6, RSAPrivateKey rsaPriv) -> do
(salt :: B.ByteString) <- lift $ getRandomBytes 32
sig <-
either (throwE . SignatureFailed . show) pure $
signDataWithRSAV6Builder
(mkBuilderV6 rawHashed rawUnhashed (SignatureSalt salt))
(unRSA_PrivateKey rsaPriv)
payload
pure [sig]
(V4, Ed25519PrivateKey seed) -> do
sig <- signEd25519V4 rawHashed rawUnhashed seed payload
pure [sig]
(V6, Ed25519PrivateKey seed) -> do
sig <- signEd25519V6 rawHashed rawUnhashed seed payload
pure [sig]
(V4, EdDSAPrivateKey EdSigningCurve25519 seed) -> do
sig <- signEd25519V4 rawHashed rawUnhashed seed payload
pure [sig]
(V6, EdDSAPrivateKey EdSigningCurve25519 seed) -> do
sig <- signEd25519V6 rawHashed rawUnhashed seed payload
pure [sig]
(V4, EdDSAPrivateKey EdSigningCurve448 seed) -> do
sig <- signEd448V4 rawHashed rawUnhashed seed payload
pure [sig]
(V6, EdDSAPrivateKey EdSigningCurve448 seed) -> do
sig <- signEd448V6 rawHashed rawUnhashed seed payload
pure [sig]
(V4, Ed448PrivateKey seed) -> do
sig <- signEd448V4 rawHashed rawUnhashed seed payload
pure [sig]
(V6, Ed448PrivateKey seed) -> do
sig <- signEd448V6 rawHashed rawUnhashed seed payload
pure [sig]
_ -> pure []
where
mkBuilderV4 rawHashed rawUnhashed =
addUnhashedSubs
(listToUnhashedSubs rawUnhashed)
( addHashedSubs
(listToHashedSubs rawHashed)
(sigBuilderInit DirectKeySignature SHA512)
)
mkBuilderV6 rawHashed rawUnhashed salt =
addUnhashedSubs
(listToUnhashedSubs rawUnhashed)
( addHashedSubs
(listToHashedSubs rawHashed)
(sigBuilderInitV6 DirectKeySignature SHA512 salt)
)
signEd25519V4 rawHashed rawUnhashed seed payload =
case CE.eitherCryptoError (Ed25519.secretKey seed) of
Left err ->
throwE (SignatureFailed ("Ed25519 signing failed: " ++ show err))
Right sk ->
either (throwE . SignatureFailed . show) pure $
signDataWithEd25519Builder
(mkBuilderV4 rawHashed rawUnhashed)
sk
payload
signEd25519V6 rawHashed rawUnhashed seed payload =
case CE.eitherCryptoError (Ed25519.secretKey seed) of
Left err ->
throwE (SignatureFailed ("Ed25519 signing failed: " ++ show err))
Right sk -> do
(salt :: B.ByteString) <- lift $ getRandomBytes 32
either (throwE . SignatureFailed . show) pure $
signDataWithEd25519V6Builder
(mkBuilderV6 rawHashed rawUnhashed (SignatureSalt salt))
sk
payload
signEd448V4 rawHashed rawUnhashed seed payload =
case CE.eitherCryptoError (Ed448.secretKey seed) of
Left err ->
throwE (SignatureFailed ("Ed448 signing failed: " ++ show err))
Right sk ->
either (throwE . SignatureFailed . show) pure $
signDataWithEd448Builder
(mkBuilderV4 rawHashed rawUnhashed)
sk
payload
signEd448V6 rawHashed rawUnhashed seed payload =
case CE.eitherCryptoError (Ed448.secretKey seed) of
Left err ->
throwE (SignatureFailed ("Ed448 signing failed: " ++ show err))
Right sk -> do
(salt :: B.ByteString) <- lift $ getRandomBytes 32
either (throwE . SignatureFailed . show) pure $
signDataWithEd448V6Builder
(mkBuilderV6 rawHashed rawUnhashed (SignatureSalt salt))
sk
payload
preferenceSubs :: Preferences -> [SigSubPacket]
preferenceSubs (Preferences sym hash comp aead ksp ff) =
( if null sym
then []
else [SigSubPacket False (PreferredSymmetricAlgorithms sym)]
)
++ ( if null hash
then []
else [SigSubPacket False (PreferredHashAlgorithms hash)]
)
++ ( if null comp
then []
else [SigSubPacket False (PreferredCompressionAlgorithms comp)]
)
++ ( if null aead
then []
else [SigSubPacket False (PreferredAEADCiphersuites aead)]
)
++ ( if null ksp
then []
else [SigSubPacket False (KeyServerPreferences ksp)]
)
++ ( if null ff
then []
else [SigSubPacket False (Features ff)]
)
signSubkeyBinding
:: KeyVersion
-> SomePKPayload
-> SKey
-> ThirtyTwoBitTimeStamp
-> SubkeySpec
-> ExceptT TKGenError m SignaturePayload
signSubkeyBinding kv primaryPkp primarySKey ct spec = do
let subkp = _subkeyPayload spec
subSKey = _subkeySKey spec
usage = _subkeyUsage spec
ctx =
emptyPSC
{ lastPrimaryKey = PublicKeyPkt primaryPkp
, lastSubkey = PublicSubkeyPkt subkp
}
payload = payloadForSig SubkeyBindingSig ctx
keyFlagsSub = [SigSubPacket True (KeyFlags usage)]
isSigning = not . Set.null . Set.intersection usage . Set.fromList
signingCapable = isSigning [SignDataKey, CertifyKeysKey, AuthKey]
in do
embSig <-
if signingCapable
then do
let bindCtx =
emptyPSC
{ lastPrimaryKey = PublicKeyPkt primaryPkp
, lastSubkey = PublicSubkeyPkt subkp
}
bindPayload = payloadForSig PrimaryKeyBindingSig bindCtx
bindHashed =
[ SigSubPacket True (SigCreationTime ct)
, SigSubPacket True (KeyFlags usage)
, issuerFingerprintSub kv subkp
]
bindUnhashed = baseUnhashedSubs kv subkp
signPrimaryKeyBinding
kv
subSKey
bindHashed
bindUnhashed
bindPayload
else pure Nothing
let embSub = case embSig of
Just sig -> [SigSubPacket True (EmbeddedSignature sig)]
Nothing -> []
rawHashed =
keyFlagsSub
++ embSub
++ baseHashedSubs kv primaryPkp ct (_tkGenExpiration state)
rawUnhashed = baseUnhashedSubs kv primaryPkp
in case (kv, primarySKey) of
(V4, RSAPrivateKey rsaPriv) ->
either (throwE . SignatureFailed . show) pure $
signDataWithRSABuilder
(mkBuilderV4 rawHashed rawUnhashed)
(unRSA_PrivateKey rsaPriv)
payload
(V6, RSAPrivateKey rsaPriv) -> do
(salt :: B.ByteString) <- lift $ getRandomBytes 32
either (throwE . SignatureFailed . show) pure $
signDataWithRSAV6Builder
(mkBuilderV6 rawHashed rawUnhashed (SignatureSalt salt))
(unRSA_PrivateKey rsaPriv)
payload
(V4, Ed25519PrivateKey seed) ->
signEd25519V4 rawHashed rawUnhashed seed payload
(V6, Ed25519PrivateKey seed) ->
signEd25519V6 rawHashed rawUnhashed seed payload
(V4, EdDSAPrivateKey EdSigningCurve25519 seed) ->
signEd25519V4 rawHashed rawUnhashed seed payload
(V6, EdDSAPrivateKey EdSigningCurve25519 seed) ->
signEd25519V6 rawHashed rawUnhashed seed payload
(V4, EdDSAPrivateKey EdSigningCurve448 seed) ->
signEd448V4 rawHashed rawUnhashed seed payload
(V6, EdDSAPrivateKey EdSigningCurve448 seed) ->
signEd448V6 rawHashed rawUnhashed seed payload
(V4, Ed448PrivateKey seed) ->
signEd448V4 rawHashed rawUnhashed seed payload
(V6, Ed448PrivateKey seed) ->
signEd448V6 rawHashed rawUnhashed seed payload
_ ->
throwE
( InvalidConfiguration
( "unsupported primary key type for subkey binding: "
++ show primarySKey
)
)
where
mkBuilderV4 rawHashed rawUnhashed =
addUnhashedSubs
(listToUnhashedSubs rawUnhashed)
( addHashedSubs
(listToHashedSubs rawHashed)
(sigBuilderInit SubkeyBindingSig SHA512)
)
mkBuilderV6 rawHashed rawUnhashed salt =
addUnhashedSubs
(listToUnhashedSubs rawUnhashed)
( addHashedSubs
(listToHashedSubs rawHashed)
(sigBuilderInitV6 SubkeyBindingSig SHA512 salt)
)
mkPkBuilderV4 rawHashed rawUnhashed =
addUnhashedSubs
(listToUnhashedSubs rawUnhashed)
( addHashedSubs
(listToHashedSubs rawHashed)
(sigBuilderInit PrimaryKeyBindingSig SHA512)
)
mkPkBuilderV6 rawHashed rawUnhashed salt =
addUnhashedSubs
(listToUnhashedSubs rawUnhashed)
( addHashedSubs
(listToHashedSubs rawHashed)
(sigBuilderInitV6 PrimaryKeyBindingSig SHA512 salt)
)
signPrimaryKeyBinding V4 sKey h u p =
case sKey of
RSAPrivateKey rsaPriv ->
either (throwE . SignatureFailed . show) (pure . Just) $
signDataWithRSABuilder
(mkPkBuilderV4 h u)
(unRSA_PrivateKey rsaPriv)
p
Ed25519PrivateKey seed -> do
sk <-
either
(throwE . SignatureFailed . show)
pure
(CE.eitherCryptoError (Ed25519.secretKey seed))
either (throwE . SignatureFailed . show) (pure . Just) $
signDataWithEd25519Builder (mkPkBuilderV4 h u) sk p
EdDSAPrivateKey EdSigningCurve25519 seed -> do
sk <-
either
(throwE . SignatureFailed . show)
pure
(CE.eitherCryptoError (Ed25519.secretKey seed))
either (throwE . SignatureFailed . show) (pure . Just) $
signDataWithEd25519Builder (mkPkBuilderV4 h u) sk p
EdDSAPrivateKey EdSigningCurve448 seed -> do
sk <-
either
(throwE . SignatureFailed . show)
pure
(CE.eitherCryptoError (Ed448.secretKey seed))
either (throwE . SignatureFailed . show) (pure . Just) $
signDataWithEd448Builder (mkPkBuilderV4 h u) sk p
Ed448PrivateKey seed -> do
sk <-
either
(throwE . SignatureFailed . show)
pure
(CE.eitherCryptoError (Ed448.secretKey seed))
either (throwE . SignatureFailed . show) (pure . Just) $
signDataWithEd448Builder (mkPkBuilderV4 h u) sk p
_ -> pure Nothing
signPrimaryKeyBinding V6 sKey h u p =
case sKey of
RSAPrivateKey rsaPriv -> do
(salt :: B.ByteString) <- lift $ getRandomBytes 32
either (throwE . SignatureFailed . show) (pure . Just) $
signDataWithRSAV6Builder
(mkPkBuilderV6 h u (SignatureSalt salt))
(unRSA_PrivateKey rsaPriv)
p
Ed25519PrivateKey seed -> do
sk <-
either
(throwE . SignatureFailed . show)
pure
(CE.eitherCryptoError (Ed25519.secretKey seed))
(salt :: B.ByteString) <- lift $ getRandomBytes 32
either (throwE . SignatureFailed . show) (pure . Just) $
signDataWithEd25519V6Builder
(mkPkBuilderV6 h u (SignatureSalt salt))
sk
p
EdDSAPrivateKey EdSigningCurve25519 seed -> do
sk <-
either
(throwE . SignatureFailed . show)
pure
(CE.eitherCryptoError (Ed25519.secretKey seed))
(salt :: B.ByteString) <- lift $ getRandomBytes 32
either (throwE . SignatureFailed . show) (pure . Just) $
signDataWithEd25519V6Builder
(mkPkBuilderV6 h u (SignatureSalt salt))
sk
p
EdDSAPrivateKey EdSigningCurve448 seed -> do
sk <-
either
(throwE . SignatureFailed . show)
pure
(CE.eitherCryptoError (Ed448.secretKey seed))
(salt :: B.ByteString) <- lift $ getRandomBytes 32
either (throwE . SignatureFailed . show) (pure . Just) $
signDataWithEd448V6Builder
(mkPkBuilderV6 h u (SignatureSalt salt))
sk
p
Ed448PrivateKey seed -> do
sk <-
either
(throwE . SignatureFailed . show)
pure
(CE.eitherCryptoError (Ed448.secretKey seed))
(salt :: B.ByteString) <- lift $ getRandomBytes 32
either (throwE . SignatureFailed . show) (pure . Just) $
signDataWithEd448V6Builder
(mkPkBuilderV6 h u (SignatureSalt salt))
sk
p
_ -> pure Nothing
signEd25519V4 rawHashed rawUnhashed seed payload = case CE.eitherCryptoError (Ed25519.secretKey seed) of
Left err ->
throwE (SignatureFailed ("Ed25519 signing failed: " ++ show err))
Right sk ->
either (throwE . SignatureFailed . show) pure $
signDataWithEd25519Builder
(mkBuilderV4 rawHashed rawUnhashed)
sk
payload
signEd25519V6 rawHashed rawUnhashed seed payload = case CE.eitherCryptoError (Ed25519.secretKey seed) of
Left err ->
throwE (SignatureFailed ("Ed25519 signing failed: " ++ show err))
Right sk -> do
(salt :: B.ByteString) <- lift $ getRandomBytes 32
either (throwE . SignatureFailed . show) pure $
signDataWithEd25519V6Builder
(mkBuilderV6 rawHashed rawUnhashed (SignatureSalt salt))
sk
payload
signEd448V4 rawHashed rawUnhashed seed payload = case CE.eitherCryptoError (Ed448.secretKey seed) of
Left err ->
throwE (SignatureFailed ("Ed448 signing failed: " ++ show err))
Right sk ->
either (throwE . SignatureFailed . show) pure $
signDataWithEd448Builder
(mkBuilderV4 rawHashed rawUnhashed)
sk
payload
signEd448V6 rawHashed rawUnhashed seed payload = case CE.eitherCryptoError (Ed448.secretKey seed) of
Left err ->
throwE (SignatureFailed ("Ed448 signing failed: " ++ show err))
Right sk -> do
(salt :: B.ByteString) <- lift $ getRandomBytes 32
either (throwE . SignatureFailed . show) pure $
signDataWithEd448V6Builder
(mkBuilderV6 rawHashed rawUnhashed (SignatureSalt salt))
sk
payload
signBinding
:: KeyVersion
-> SomePKPayload
-> SKey
-> ThirtyTwoBitTimeStamp
-> SubkeySpec
-> ExceptT TKGenError m SignaturePayload
signBinding kv primaryPkp primarySKey ct spec =
signSubkeyBinding kv primaryPkp primarySKey ct spec
mkSubkey
:: SomePKPayload
-> SKey
-> KeyVersion
-> ThirtyTwoBitTimeStamp
-> SubkeySpec
-> ExceptT TKGenError m (KeyPkt 'SecretPkt, [SignaturePayload])
mkSubkey primaryPkp primarySKey kv ct spec = do
let subPkt =
KeyPktSecretSubkey
(_subkeyPayload spec)
(SUSUnprotected (_subkeySKey spec) 0)
sig <- signBinding kv primaryPkp primarySKey ct spec
pure (subPkt, [sig])
-- -----------------------------------------------------------------------------
-- Helper
-- -----------------------------------------------------------------------------