KeyGeneration.hs

-- KeyGeneration.hs: OpenPGP (RFC9580) key generation
-- Copyright © 2026  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Codec.Encryption.OpenPGP.KeyGeneration
    ( KeyGenSpec (..)
    , generateSecretKey
    ) where

import Control.Monad (unless)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT (..), throwE)
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.Types (MonadRandom, getRandomBytes)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B

import Codec.Encryption.OpenPGP.Types

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 ts
    KeyGenEd448 ts -> ed448Generate ts
    KeyGenX25519 ts -> x25519Generate ts
    KeyGenX448 ts -> x448Generate 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 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 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)