SecretKey.hs

-- SecretKey.hs: OpenPGP (RFC9580) secret key encryption/decryption
-- Copyright © 2013-2026  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TypeApplications #-}

module Codec.Encryption.OpenPGP.SecretKey
    ( decryptPrivateKey
    , reinterpretUnknownSKeyForPKPayload
    , mkUnencryptedSKAddendum
    , encryptPrivateKeyWithPolicyAndSaltAndIV
    , encryptPrivateKey
    , changePrivateKeyPassphrase
    , changePrivateKeyPassphraseRandom
    , reencryptSecretKeyRandomEither
    , reencryptPrivateKeyTyped
    , SecretKeyError (..)
    , SecretKeyEncryptOptions (..)
    , decryptSecretKey
    , decryptSecretKeyAddendum
    , encryptSecretKey
    , encryptSecretKeyWithPolicy
    , reencryptSecretKey
    , reencryptSecretKeyRandom
    , changeSecretKeyPassphrase
    ) where

import Control.Monad (when)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except
    ( ExceptT
    , except
    , runExceptT
    , throwE
    )
import qualified Crypto.Error as CE
import qualified Crypto.Hash as CH
import qualified Crypto.Hash.Algorithms as CHA
import Crypto.KDF.HKDF (expand, extract)
import Crypto.Number.ModArithmetic (inverse)
import Crypto.Number.Serialize (os2ip)
import qualified Crypto.PubKey.DSA as DSA
import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
import qualified Crypto.PubKey.RSA as R
import Crypto.Random.Types (MonadRandom, getRandomBytes)
import Data.Bifunctor (bimap, first)
import Data.Binary (put)
import Data.Binary.Get
    ( getRemainingLazyByteString
    , getWord16be
    , runGetOrFail
    )
import Data.Binary.Put
    ( Put
    , putByteString
    , putLazyByteString
    , putWord16be
    , runPut
    )
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as BL
import Data.List (nub)
import Data.Word (Word16, Word8)
import qualified "crypton" Crypto.Cipher.Types as CCT

import Codec.Encryption.OpenPGP.BlockCipher
    ( keySize
    , renderCipherError
    )
import Codec.Encryption.OpenPGP.CFB
    ( decryptNoNonce
    , encryptNoNonce
    )
import Codec.Encryption.OpenPGP.Internal.CryptoAES
    ( withAESCipher
    )
import Codec.Encryption.OpenPGP.Internal.RFC7253OCB
    ( decryptWithOCBRFC7253With
    , encryptWithOCBRFC7253
    )
import Codec.Encryption.OpenPGP.Policy
    ( OpenPGPPolicy (..)
    , OpenPGPRFC (..)
    , SecretKeyProtectionPolicy
    , defaultPolicy
    , legacySecretKeyProtectionErrorMessage
    , secretKeyAEADNonceOctets
    , secretKeyDefaultAEADAlgorithm
    , secretKeyDefaultS2KForSalt
    , secretKeyDefaultSymmetricAlgorithm
    , secretKeyProtectionPolicyForKeyVersion
    , secretKeyS2KSaltOctets
    )
import Codec.Encryption.OpenPGP.S2K
    ( renderS2KError
    , skesk2Key
    , string2Key
    )
import Codec.Encryption.OpenPGP.Serialize
    ( getSecretKey
    , putSKeyForPKPayload
    )
import Codec.Encryption.OpenPGP.Types
import Codec.Encryption.OpenPGP.Types.Internal.Base
    ( Passphrase (..)
    )

data SecretKeyError
    = SecretKeyDecryptError String
    | SecretKeyEncryptError String
    | SecretKeyPolicyError String
    | SecretKeyUnsupportedLegacyProtection
    deriving (Eq, Show)

data SecretKeyEncryptOptions = SecretKeyEncryptOptions
    { skeoPolicy :: OpenPGPPolicy
    , skeoGenerateSaltAndIV :: Bool
    , skeoSalt :: Maybe Salt
    , skeoIV :: Maybe IV
    }

decryptPrivateKey
    :: (SomePKPayload, SKAddendum)
    -> BL.ByteString
    -> Either String SKAddendum
decryptPrivateKey (pkp, ska) pp =
    fromSKAddendumForPKPayload pkp ska >>= \case
        SomeSKAddendumV skaV -> toSKAddendum <$> decryptPrivateKeyTyped pkp skaV pp

decryptSecretKey
    :: SecretKey
    -> Passphrase
    -> Either SecretKeyError SKey
decryptSecretKey sk pp =
    decryptSecretKeyAddendum
        (_secretKeyPKPayload sk)
        (_secretKeySKAddendum sk)
        pp >>= \(skey, _) ->
        Right skey

decryptSecretKeyAddendum
    :: SomePKPayload
    -> SKAddendum
    -> Passphrase
    -> Either SecretKeyError (SKey, SKAddendum)
decryptSecretKeyAddendum pkp ska pp =
    case decryptPrivateKey (pkp, ska) (unPassphrase pp) of
        Left err -> Left $ SecretKeyDecryptError err
        Right decrypted ->
            case decrypted of
                SUUnencrypted skey _ -> Right (skey, decrypted)
                _ ->
                    Left $
                        SecretKeyDecryptError
                            "decrypted secret key material was not in unencrypted form"

encryptSecretKey
    :: MonadRandom m
    => SomePKPayload
    -> SKey
    -> Passphrase
    -> SecretKeyEncryptOptions
    -> m (Either SecretKeyError SKAddendum)
encryptSecretKey pkp skey newPassphrase opts = do
    result <- runExceptT $ do
        (salt, iv) <-
            if skeoGenerateSaltAndIV opts
                then do
                    nextMaterial <-
                        lift $ generateSecretKeyProtectionMaterial (skeoPolicy opts) pkp
                    except $ first SecretKeyPolicyError nextMaterial
                else case (skeoSalt opts, skeoIV opts) of
                    (Just salt, Just iv) -> return (salt, iv)
                    _ ->
                        throwE $
                            SecretKeyEncryptError
                                "skeoGenerateSaltAndIV is False but skeoSalt or skeoIV are Nothing"
        ska <-
            except
                (first SecretKeyEncryptError $ mkUnencryptedSKAddendum pkp skey)
        except
            ( first SecretKeyEncryptError $
                encryptPrivateKeyWithPolicyAndSaltAndIV
                    (skeoPolicy opts)
                    pkp
                    salt
                    iv
                    ska
                    (unPassphrase newPassphrase)
            )
    return result

encryptSecretKeyWithPolicy
    :: MonadRandom m
    => OpenPGPPolicy
    -> SomePKPayload
    -> SKey
    -> Passphrase
    -> m (Either SecretKeyError SKAddendum)
encryptSecretKeyWithPolicy policy pkp skey pp = do
    encryptSecretKey
        pkp
        skey
        pp
        SecretKeyEncryptOptions
            { skeoPolicy = policy
            , skeoGenerateSaltAndIV = True
            , skeoSalt = Nothing
            , skeoIV = Nothing
            }

reencryptSecretKey
    :: MonadRandom m
    => SecretKey
    -> Passphrase
    -> Passphrase
    -> SecretKeyEncryptOptions
    -> m (Either SecretKeyError SecretKey)
reencryptSecretKey sk oldPassphrase newPassphrase opts = do
    result <- runExceptT $ do
        let pkp = _secretKeyPKPayload sk
            originalSka = _secretKeySKAddendum sk
        decrypted <-
            except $
                first SecretKeyDecryptError $
                    decryptPrivateKey (pkp, originalSka) (unPassphrase oldPassphrase)
        case decrypted of
            SUUnencrypted skey _ -> do
                let pp = unPassphrase newPassphrase
                (salt, iv) <-
                    if skeoGenerateSaltAndIV opts
                        then do
                            nextMaterial <-
                                lift $ generateSecretKeyProtectionMaterial (skeoPolicy opts) pkp
                            except $ first SecretKeyPolicyError nextMaterial
                        else case (skeoSalt opts, skeoIV opts) of
                            (Just salt, Just iv) -> return (salt, iv)
                            _ ->
                                throwE $
                                    SecretKeyEncryptError
                                        "skeoGenerateSaltAndIV is False but skeoSalt or skeoIV are Nothing"
                newSka <-
                    except $
                        reencryptWithPolicyAndSaltAndIV
                            pkp
                            originalSka
                            salt
                            iv
                            skey
                            pp
                            (skeoPolicy opts)
                return $ sk {_secretKeySKAddendum = newSka}
            _ ->
                throwE $
                    SecretKeyDecryptError
                        "decrypted secret key material was not in unencrypted form"
    return result

reencryptWithPolicyAndSaltAndIV
    :: SomePKPayload
    -> SKAddendum
    -> Salt
    -> IV
    -> SKey
    -> BL.ByteString
    -> OpenPGPPolicy
    -> Either SecretKeyError SKAddendum
reencryptWithPolicyAndSaltAndIV pkp originalSka salt iv skey pp policy =
    first
        SecretKeyEncryptError
        (fromSKAddendumForPKPayload pkp originalSka) >>= \case
        SomeSKAddendumV skaV ->
            first SecretKeyEncryptError $
                toSKAddendum
                    <$> reencryptPrivateKeyTypedWithPolicy
                        policy
                        pkp
                        skaV
                        salt
                        iv
                        skey
                        pp

reencryptSecretKeyRandom
    :: MonadRandom m
    => SecretKey
    -> Passphrase
    -> Passphrase
    -> OpenPGPPolicy
    -> m (Either SecretKeyError SecretKey)
reencryptSecretKeyRandom sk oldPassphrase newPassphrase policy = do
    reencryptSecretKey
        sk
        oldPassphrase
        newPassphrase
        SecretKeyEncryptOptions
            { skeoPolicy = policy
            , skeoGenerateSaltAndIV = True
            , skeoSalt = Nothing
            , skeoIV = Nothing
            }

{-# DEPRECATED
    changeSecretKeyPassphrase
    "Use reencryptSecretKey or reencryptSecretKeyRandom instead"
    #-}
changeSecretKeyPassphrase
    :: MonadRandom m
    => SecretKey
    -> Passphrase
    -> Passphrase
    -> m (Either SecretKeyError SecretKey)
changeSecretKeyPassphrase sk oldPassphrase newPassphrase =
    reencryptSecretKey
        sk
        oldPassphrase
        newPassphrase
        SecretKeyEncryptOptions
            { skeoPolicy = defaultPolicy
            , skeoGenerateSaltAndIV = True
            , skeoSalt = Nothing
            , skeoIV = Nothing
            }

decryptPrivateKeyTyped
    :: SomePKPayload
    -> SKAddendumV v
    -> BL.ByteString
    -> Either String (SKAddendumV v)
decryptPrivateKeyTyped pkp (SKA16bit sa s2k iv payload) pp = do
    (sk, cksum) <-
        decryptS2KProtectedPayload
            pkp
            sa
            s2k
            iv
            payload
            pp
            parse16BitProtectedSecretKey
    pure (SKAUnencryptedLegacy sk cksum)
decryptPrivateKeyTyped pkp (SKASHA1Legacy sa s2k iv payload) pp = do
    (sk, cksum) <-
        decryptS2KProtectedPayload
            pkp
            sa
            s2k
            iv
            payload
            pp
            parseSHA1ProtectedSecretKey
    pure (SKAUnencryptedLegacy sk cksum)
decryptPrivateKeyTyped pkp (SKASHA1V6 sa s2k iv payload) pp = do
    (sk, _) <-
        decryptS2KProtectedPayload
            pkp
            sa
            s2k
            iv
            payload
            pp
            parseSHA1ProtectedSecretKey
    pure (SKAUnencryptedV6 sk)
decryptPrivateKeyTyped pkp (SKAAEADV6 sa aa s2k iv payload) pp = do
    sk <- decryptAEADPayloadCore pkp sa aa s2k iv payload pp
    pure (SKAUnencryptedV6 sk)
decryptPrivateKeyTyped pkp (SKAAEADLegacy sa aa s2k iv payload) pp = do
    sk <- decryptAEADPayloadCore pkp sa aa s2k iv payload pp
    pure (SKAUnencryptedLegacy sk 0)
decryptPrivateKeyTyped pkp (SKASymLegacy sa iv payload) pp = do
    keyLen <- first renderCipherError (keySize sa)
    dek <-
        first
            renderS2KError
            (string2Key (Simple DeprecatedMD5) keyLen pp)
    p <-
        first
            renderCipherError
            (decryptNoNonce sa iv (BL.toStrict payload) dek)
    (sk, cksum) <- parse16BitProtectedSecretKey pkp p
    pure (SKAUnencryptedLegacy sk cksum)
decryptPrivateKeyTyped pkp (SKASymV6 sa iv payload) pp = do
    keyLen <- first renderCipherError (keySize sa)
    dek <-
        first
            renderS2KError
            (string2Key (Simple DeprecatedMD5) keyLen pp)
    p <-
        first
            renderCipherError
            (decryptNoNonce sa iv (BL.toStrict payload) dek)
    (sk, _) <- parse16BitProtectedSecretKey pkp p
    pure (SKAUnencryptedV6 sk)
decryptPrivateKeyTyped _ ska@(SKAUnencryptedLegacy {}) _ = Right ska
decryptPrivateKeyTyped _ ska@(SKAUnencryptedV6 {}) _ = Right ska

reinterpretUnknownSKeyForPKPayload
    :: SomePKPayload -> SKey -> Either String SKey
reinterpretUnknownSKeyForPKPayload _ sk@RSAPrivateKey {} = Right sk
reinterpretUnknownSKeyForPKPayload _ sk@DSAPrivateKey {} = Right sk
reinterpretUnknownSKeyForPKPayload _ sk@ElGamalPrivateKey {} = Right sk
reinterpretUnknownSKeyForPKPayload _ sk@ECDHPrivateKey {} = Right sk
reinterpretUnknownSKeyForPKPayload _ sk@ECDSAPrivateKey {} = Right sk
reinterpretUnknownSKeyForPKPayload _ sk@EdDSAPrivateKey {} = Right sk
reinterpretUnknownSKeyForPKPayload _ sk@X25519PrivateKey {} = Right sk
reinterpretUnknownSKeyForPKPayload _ sk@X448PrivateKey {} = Right sk
reinterpretUnknownSKeyForPKPayload pkp (UnknownSKey payload) =
    case runGetOrFail
        ((,) <$> getSecretKey pkp <*> getRemainingLazyByteString)
        payload of
        Left (_, _, err) -> Left err
        Right (_, _, (skey, trailing))
            | BL.null trailing -> Right skey
            | otherwise ->
                Left "decoded secret key material has trailing bytes"

mkUnencryptedSKAddendum
    :: SomePKPayload -> SKey -> Either String SKAddendum
mkUnencryptedSKAddendum pkp skey = do
    payload <- legacySecretKeyPayload pkp skey
    let checksum =
            case _keyVersion pkp of
                V6 -> 0
                _ -> checksum16 (BL.toStrict payload)
    pure (SUUnencrypted skey checksum)

decryptS2KProtectedPayload
    :: SomePKPayload
    -> SymmetricAlgorithm
    -> S2K
    -> IV
    -> BL.ByteString
    -> BL.ByteString
    -> (SomePKPayload -> B.ByteString -> Either String (SKey, Word16))
    -> Either String (SKey, Word16)
decryptS2KProtectedPayload pkp sa s2k iv payload pp parser = do
    dek <-
        first renderS2KError (skesk2Key (SKESK4Packet sa s2k Nothing) pp)
    decrypted <-
        first
            renderCipherError
            (decryptNoNonce sa iv (BL.toStrict payload) dek)
    parser pkp decrypted
parse16BitProtectedSecretKey
    :: SomePKPayload -> B.ByteString -> Either String (SKey, Word16)
parse16BitProtectedSecretKey pkp p
    | B.length p < 2 =
        Left "secret key payload is too short for a 16-bit checksum"
    | otherwise = do
        let (skeyPayload, checksumPayload) = B.splitAt (B.length p - 2) p
        sk <- decodeSecretKey pkp skeyPayload
        cksum <- decodeChecksum checksumPayload
        let expected = checksum16 skeyPayload
        if cksum == expected
            then Right (sk, cksum)
            else
                Left
                    ( "16-bit secret key checksum mismatch (expected "
                        ++ show expected
                        ++ ", got "
                        ++ show cksum
                        ++ ")"
                    )

parseSHA1ProtectedSecretKey
    :: SomePKPayload -> B.ByteString -> Either String (SKey, Word16)
parseSHA1ProtectedSecretKey pkp p
    | B.length p < 20 =
        Left "secret key payload is too short for a SHA1 checksum"
    | otherwise = do
        let (skeyPayload, hashPayload) = B.splitAt (B.length p - 20) p
            expected = BA.convert (CH.hash skeyPayload :: CH.Digest CH.SHA1)
        sk <- decodeSecretKey pkp skeyPayload
        if hashPayload == expected
            then Right (sk, checksum16 skeyPayload)
            else Left "SHA1 secret key checksum mismatch"

decodeSecretKey
    :: SomePKPayload -> B.ByteString -> Either String SKey
decodeSecretKey pkp payloadBytes =
    bimap
        (\(_, _, x) -> x)
        (\(_, _, x) -> x)
        (runGetOrFail (getSecretKey pkp) (BL.fromStrict payloadBytes))

decodeChecksum :: B.ByteString -> Either String Word16
decodeChecksum checksumBytes =
    bimap
        (\(_, _, x) -> x)
        (\(_, _, x) -> x)
        (runGetOrFail getWord16be (BL.fromStrict checksumBytes))
decryptAEADPayloadCore
    :: SomePKPayload
    -> SymmetricAlgorithm
    -> AEADAlgorithm
    -> S2K
    -> IV
    -> BL.ByteString
    -> BL.ByteString
    -> Either String SKey
decryptAEADPayloadCore pkp sa aa s2k iv payload pp = do
    keyLen <- first renderCipherError (keySize sa)
    keyMaterial <- first renderS2KError (string2Key s2k keyLen pp)
    let keyCandidates = [keyMaterial]
        tagCandidates = [0xC5, 0xC7, 0x94, 0x95, 0x96, 0x97, 0x9C, 0x9D, 0x9E, 0x9F]
        infoCandidates =
            nub
                [ B.pack
                    [tag, keyVersionByte (_keyVersion pkp), fromFVal sa, fromFVal aa]
                | tag <- tagCandidates
                ]
        pkpBytes = BL.toStrict (runPut (put pkp))
        adCandidates =
            nub
                [B.cons tagByte pkpBytes | tagByte <- tagCandidates]
        aaCandidates = [aa]
        nonce = unIV iv
        payloadStrict = BL.toStrict payload
        tagLen = 16
        tryDecrypt candidateKeyMaterial info ad aaTry = do
            when (B.length payloadStrict < tagLen) $
                Left "v6 AEAD secret key payload too short"
            let (ciphertext, tagBytes) = B.splitAt (B.length payloadStrict - tagLen) payloadStrict
                authTag = CCT.AuthTag (BA.convert tagBytes)
                prk = extract @CHA.SHA256 B.empty candidateKeyMaterial
                kekCandidates =
                    nub
                        [ B.take keyLen candidateKeyMaterial
                        , (expand @CHA.SHA256 prk info keyLen :: B.ByteString)
                        , (expand @CHA.SHA256 prk B.empty keyLen :: B.ByteString)
                        ]
                tryKeks = go Nothing
                  where
                    go merr [] =
                        Left $
                            "could not decrypt using any KEK candidate"
                                ++ maybe "" (\e -> " (last error: " ++ e ++ ")") merr
                    go merr (kek : ks) =
                        case decryptWithKey sa aaTry kek ad nonce ciphertext authTag of
                            Right cleartext -> Right cleartext
                            Left err -> go (Just (maybe err id merr)) ks
            tryKeks kekCandidates
        tryAll = go Nothing
          where
            go merr [] =
                Left $
                    "could not decrypt v6 AEAD secret key payload"
                        ++ maybe "" (\e -> " (last error: " ++ e ++ ")") merr
            go merr ((keyMaterialCandidate, info, ad, aaTry) : xs) =
                case tryDecrypt keyMaterialCandidate info ad aaTry of
                    Right cleartext -> Right cleartext
                    Left err -> go (Just (maybe err id merr)) xs
    cleartext <-
        tryAll
            [ (k, i, a, m)
            | k <- keyCandidates
            , i <- infoCandidates
            , a <- adCandidates
            , m <- aaCandidates
            ]
    parseSecretKeyExact pkp cleartext

checksum16 :: B.ByteString -> Word16
checksum16 =
    fromIntegral
        . B.foldl'
            (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer))
            0

decryptWithKey
    :: SymmetricAlgorithm
    -> AEADAlgorithm
    -> B.ByteString
    -> B.ByteString
    -> B.ByteString
    -> B.ByteString
    -> CCT.AuthTag
    -> Either String B.ByteString
decryptWithKey sa aa kek ad nonce ciphertext authTag = do
    let toHex = BC.unpack . B16.encode
        authFailure expectedTag computedTag n a hashAd plaintext =
            "failed to authenticate v6 AEAD secret key payload (expected tag="
                ++ toHex expectedTag
                ++ ", computed tag="
                ++ toHex computedTag
                ++ ", nonce="
                ++ toHex n
                ++ ", ad="
                ++ toHex a
                ++ ", hashAd="
                ++ toHex hashAd
                ++ ", plaintext="
                ++ toHex plaintext
                ++ ")"
        unsupportedSecretKeyAEADError = "unsupported secret-key AEAD symmetric algorithm"
    case aa of
        OCB ->
            withAESCipher
                unsupportedSecretKeyAEADError
                sa
                kek
                ( \cipher ->
                    decryptWithOCBRFC7253With
                        authFailure
                        cipher
                        nonce
                        ad
                        ciphertext
                        authTag
                )
        _ -> do
            mode <- aeadMode aa
            expectedNonceLen <- aeadNonceSize aa
            when (B.length nonce /= expectedNonceLen) $
                Left "invalid nonce size for v6 AEAD secret key payload"
            withAESCipher unsupportedSecretKeyAEADError sa kek $ \cipher ->
                first
                    show
                    (CE.eitherCryptoError (CCT.aeadInit mode cipher nonce)) >>= \aead ->
                    maybe
                        (Left "failed to authenticate v6 AEAD secret key payload")
                        Right
                        (CCT.aeadSimpleDecrypt aead ad ciphertext authTag)

aeadMode :: AEADAlgorithm -> Either String CCT.AEADMode
aeadMode EAX = Right CCT.AEAD_EAX
aeadMode OCB = Right CCT.AEAD_OCB
aeadMode GCM = Right CCT.AEAD_GCM
aeadMode (OtherAEADAlgo _) = Left "unknown AEAD mode"

aeadNonceSize :: AEADAlgorithm -> Either String Int
aeadNonceSize EAX = Right 16
aeadNonceSize OCB = Right 15
aeadNonceSize GCM = Right 12
aeadNonceSize (OtherAEADAlgo _) = Left "unknown AEAD nonce size"

parseSecretKeyExact
    :: SomePKPayload -> B.ByteString -> Either String SKey
parseSecretKeyExact pkp cleartext =
    case runGetOrFail
        ((,) <$> getSecretKey pkp <*> getRemainingLazyByteString)
        (BL.fromStrict cleartext) of
        Left (_, _, err) -> Left err
        Right (_, _, (sk, trailing))
            | BL.null trailing -> Right sk
            | otherwise ->
                Left "v6 AEAD secret key cleartext has trailing bytes"

keyVersionByte :: KeyVersion -> Word8
keyVersionByte DeprecatedV3 = 3
keyVersionByte V4 = 4
keyVersionByte V6 = 6

{-# DEPRECATED encryptPrivateKey "Use encryptSecretKeyWithPolicy instead" #-}

-- | generates pseudo-random salt and IV
encryptPrivateKey
    :: MonadRandom m
    => OpenPGPPolicy
    -> SomePKPayload
    -> SKAddendum
    -> BL.ByteString
    -> m (Either String SKAddendum)
encryptPrivateKey policy pkp ska pp = do
    nextMaterial <- generateSecretKeyProtectionMaterial policy pkp
    case nextMaterial of
        Left err -> pure $ Left err
        Right (salt, iv) ->
            pure $
                encryptPrivateKeyWithPolicyAndSaltAndIV policy pkp salt iv ska pp

encryptPrivateKeyWithPolicyAndSaltAndIV
    :: OpenPGPPolicy
    -> SomePKPayload
    -> Salt
    -> IV
    -> SKAddendum
    -> BL.ByteString
    -> Either String SKAddendum
encryptPrivateKeyWithPolicyAndSaltAndIV policy pkp salt iv ska pp =
    case ska of
        SUUnencrypted skey _ ->
            encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV
                policy
                pkp
                salt
                iv
                skey
                pp
        _ -> Right ska

encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV
    :: OpenPGPPolicy
    -> SomePKPayload
    -> Salt
    -> IV
    -> SKey
    -> BL.ByteString
    -> Either String SKAddendum
encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV policy pkp salt iv skey pp = do
    (sa, aa, s2k) <- secretKeyProtectionDefaults policy pkp salt iv
    (\payload -> SUSAEAD sa aa s2k iv (BL.fromStrict payload))
        <$> encryptV6SKey pkp skey sa aa s2k iv pp

{-# DEPRECATED changePrivateKeyPassphrase "Use reencryptSecretKey instead" #-}
changePrivateKeyPassphrase
    :: (SomePKPayload, SKAddendum)
    -> BL.ByteString
    -> Salt
    -> IV
    -> BL.ByteString
    -> Either String SKAddendum
changePrivateKeyPassphrase (pkp, ska) oldPassphrase salt iv newPassphrase = do
    decrypted <- decryptPrivateKey (pkp, ska) oldPassphrase
    case decrypted of
        SUUnencrypted skey _ ->
            reencryptPrivateKeyWithSaltAndIV
                pkp
                ska
                salt
                iv
                skey
                newPassphrase
        _ ->
            Left
                "Unexpected codepath: decrypted private key material was not in unencrypted form"

{-# DEPRECATED
    changePrivateKeyPassphraseRandom
    "Use reencryptSecretKeyRandom instead"
    #-}
changePrivateKeyPassphraseRandom
    :: MonadRandom m
    => (SomePKPayload, SKAddendum)
    -> BL.ByteString
    -> BL.ByteString
    -> m (Either String SKAddendum)
changePrivateKeyPassphraseRandom (pkp, ska) oldPassphrase newPassphrase = do
    nextMaterial <-
        generateSecretKeyProtectionMaterial defaultPolicy pkp
    case nextMaterial of
        Left err -> pure $ Left err
        Right (salt, iv) ->
            pure $
                changePrivateKeyPassphrase
                    (pkp, ska)
                    oldPassphrase
                    salt
                    iv
                    newPassphrase

encodeSKeyMaterial :: SKey -> Either String BL.ByteString
encodeSKeyMaterial keyMaterial =
    case keyMaterial of
        RSAPrivateKey (RSA_PrivateKey (R.PrivateKey _ d p q _ _ _)) ->
            case inverse p q of
                Nothing ->
                    Left
                        "could not derive RSA multiplicative inverse while encrypting secret key"
                Just u ->
                    Right
                        (runPut (put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u)))
        DSAPrivateKey (DSA_PrivateKey (DSA.PrivateKey _ x)) ->
            Right (runPut (put (MPI x)))
        ElGamalPrivateKey x ->
            Right (runPut (put (MPI x)))
        ECDHPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey _ d)) ->
            Right (runPut (put (MPI d)))
        ECDSAPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey _ d)) ->
            Right (runPut (put (MPI d)))
        EdDSAPrivateKey _ bs ->
            Right (runPut (put (MPI (os2ip bs))))
        X25519PrivateKey bs ->
            Right (runPut (putByteString bs))
        X448PrivateKey bs ->
            Right (runPut (putByteString bs))
        UnknownSKey bs ->
            Right (runPut (putLazyByteString bs))

encryptV6SKey
    :: SomePKPayload
    -> SKey
    -> SymmetricAlgorithm
    -> AEADAlgorithm
    -> S2K
    -> IV
    -> BL.ByteString
    -> Either String B.ByteString
encryptV6SKey pkp skey sa aa s2k iv pp = do
    keyLen <- first renderCipherError (keySize sa)
    keyMaterial <- first renderS2KError (string2Key s2k keyLen pp)
    payload <- encodeSKeyMaterial skey
    let info =
            B.pack
                [ 0xC5
                , keyVersionByte (_keyVersion pkp)
                , fromFVal sa
                , fromFVal aa
                ]
        ad = B.cons 0xC5 (BL.toStrict (runPut (put pkp)))
        prk = extract @CHA.SHA256 B.empty keyMaterial
        kek = expand @CHA.SHA256 prk info keyLen :: B.ByteString
    (tag, ciphertext) <-
        encryptWithKey sa aa kek ad (unIV iv) (BL.toStrict payload)
    pure (ciphertext <> BA.convert (CCT.unAuthTag tag))

secretKeyProtectionMaterialLengths
    :: OpenPGPPolicy -> SomePKPayload -> Either String (Int, Int)
secretKeyProtectionMaterialLengths policy pkp =
    case secretKeyProtectionPolicyForEncryption policy (_keyVersion pkp) of
        Just policy ->
            Right
                (secretKeyS2KSaltOctets policy, secretKeyAEADNonceOctets policy)
        Nothing -> Left legacySecretKeyProtectionErrorMessage

generateSecretKeyProtectionMaterial
    :: MonadRandom m
    => OpenPGPPolicy
    -> SomePKPayload
    -> m (Either String (Salt, IV))
generateSecretKeyProtectionMaterial policy pkp =
    case secretKeyProtectionMaterialLengths policy pkp of
        Left err -> pure (Left err)
        Right (saltLen, nonceLen) -> do
            entropy <- getRandomBytes (saltLen + nonceLen)
            let (saltBytes, ivBytes) = B.splitAt saltLen entropy
            pure (Right (Salt saltBytes, IV ivBytes))

secretKeyProtectionDefaults
    :: OpenPGPPolicy
    -> SomePKPayload
    -> Salt
    -> IV
    -> Either String (SymmetricAlgorithm, AEADAlgorithm, S2K)
secretKeyProtectionDefaults policy pkp salt iv =
    case secretKeyProtectionPolicyForEncryption policy (_keyVersion pkp) of
        Just policy -> do
            when (B.length (unSalt salt) /= secretKeyS2KSaltOctets policy) $
                Left
                    ( "v6 secret key S2K salt must be "
                        ++ show (secretKeyS2KSaltOctets policy)
                        ++ " octets"
                    )
            when (B.length (unIV iv) /= secretKeyAEADNonceOctets policy) $
                Left
                    ( "v6 secret key AEAD nonce must be "
                        ++ show (secretKeyAEADNonceOctets policy)
                        ++ " octets"
                    )
            pure
                ( secretKeyDefaultSymmetricAlgorithm policy
                , secretKeyDefaultAEADAlgorithm policy
                , secretKeyDefaultS2KForSalt policy salt
                )
        Nothing -> Left legacySecretKeyProtectionErrorMessage

secretKeyProtectionPolicyForEncryption
    :: OpenPGPPolicy -> KeyVersion -> Maybe SecretKeyProtectionPolicy
secretKeyProtectionPolicyForEncryption policy V6 =
    secretKeyProtectionPolicyForKeyVersion policy V6
secretKeyProtectionPolicyForEncryption policy _
    | policyRFC policy == RFC9580 = Nothing
    | otherwise = policySecretKeyProtection policy

encryptWithKey
    :: SymmetricAlgorithm
    -> AEADAlgorithm
    -> B.ByteString
    -> B.ByteString
    -> B.ByteString
    -> B.ByteString
    -> Either String (CCT.AuthTag, B.ByteString)
encryptWithKey sa aa kek ad nonce plaintext = do
    expectedNonceLen <- aeadNonceSize aa
    when (B.length nonce /= expectedNonceLen) $
        Left "invalid nonce size for v6 AEAD secret key payload"
    let unsupportedSecretKeyAEADError = "unsupported secret-key AEAD symmetric algorithm"
    case aa of
        OCB ->
            withAESCipher
                unsupportedSecretKeyAEADError
                sa
                kek
                (\cipher -> encryptWithOCBRFC7253 cipher nonce ad plaintext)
        _ -> do
            mode <- aeadMode aa
            withAESCipher unsupportedSecretKeyAEADError sa kek $ \cipher ->
                first
                    show
                    (CE.eitherCryptoError (CCT.aeadInit mode cipher nonce)) >>= \aead ->
                    pure (CCT.aeadSimpleEncrypt aead ad plaintext 16)

{-# DEPRECATED
    reencryptSecretKeyRandomEither
    "Use changeSecretKeyPassphrase or reencryptSecretKeyRandom instead"
    #-}
reencryptSecretKeyRandomEither
    :: MonadRandom m
    => SecretKey -> BL.ByteString -> m (Either String SecretKey)
reencryptSecretKeyRandomEither sk pp =
    reencryptSecretKeyRandom
        sk
        (Passphrase pp)
        (Passphrase pp)
        defaultPolicy
        >>= \case
            Left err -> pure $ Left $ show err
            Right sk' -> pure $ Right sk'

{- | Version-preserving re-encryption of a typed secret-key addendum.

Each constructor family is re-encrypted in kind:
  * V6 variants (AEAD, SHA1, Sym, Unencrypted) → SKAAEADV6 (default v6 policy)
  * SKA16bit / SKASHA1Legacy → same S2K family with updated salt
  * SKAAEADLegacy → re-protected as SKASHA1Legacy (standard v3\/v4 S2K)
  * SKASymLegacy → legacy CFB re-encryption as SKASymLegacy
  * SKAUnencryptedLegacy → Left (cannot re-encrypt unencrypted legacy keys)
-}
reencryptPrivateKeyTyped
    :: SomePKPayload
    -> SKAddendumV v
    -> Salt
    -> IV
    -> SKey
    -> BL.ByteString
    -> Either String (SKAddendumV v)
reencryptPrivateKeyTyped = reencryptPrivateKeyTypedWithPolicy defaultPolicy

reencryptPrivateKeyTypedWithPolicy
    :: OpenPGPPolicy
    -> SomePKPayload
    -> SKAddendumV v
    -> Salt
    -> IV
    -> SKey
    -> BL.ByteString
    -> Either String (SKAddendumV v)
reencryptPrivateKeyTypedWithPolicy policy pkp skaV salt iv skey pp =
    case skaV of
        SKAAEADV6 {} -> reencryptV6 policy
        SKASHA1V6 {} -> reencryptV6 policy
        SKASymV6 {} -> reencryptV6 policy
        SKAUnencryptedV6 {} -> reencryptV6 policy
        SKA16bit sa s2k _ _ ->
            reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k $ \sa' s2k' iv' ct km ->
                encryptProtectedSecretKey
                    sa'
                    s2k'
                    iv'
                    ct
                    km
                    checksum16Trailer
                    (SKA16bit sa' s2k' iv')
        SKASHA1Legacy sa s2k _ _ ->
            reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k $ \sa' s2k' iv' ct km ->
                encryptProtectedSecretKey
                    sa'
                    s2k'
                    iv'
                    ct
                    km
                    sha1Trailer
                    (SKASHA1Legacy sa' s2k' iv')
        SKAAEADLegacy sa _aa s2k _ _ ->
            reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k $ \sa' s2k' iv' ct km ->
                encryptProtectedSecretKey
                    sa'
                    s2k'
                    iv'
                    ct
                    km
                    sha1Trailer
                    (SKASHA1Legacy sa' s2k' iv')
        SKASymLegacy sa _ _ -> do
            keyLen <- first renderCipherError (keySize sa)
            keyMaterial <-
                first
                    renderS2KError
                    (string2Key (Simple DeprecatedMD5) keyLen pp)
            cleartext <- legacySecretKeyPayload pkp skey
            let clearWithChecksum =
                    BL.toStrict
                        ( cleartext
                            <> runPut (putWord16be (checksum16 (BL.toStrict cleartext)))
                        )
            (\encrypted -> SKASymLegacy sa iv (BL.fromStrict encrypted))
                <$> first
                    renderCipherError
                    ( encryptNoNonce
                        sa
                        (Simple DeprecatedMD5)
                        iv
                        clearWithChecksum
                        keyMaterial
                    )
        SKAUnencryptedLegacy _ _ -> Left legacySecretKeyProtectionErrorMessage
  where
    reencryptV6 pol = do
        (sa, aa, s2k) <- secretKeyProtectionDefaults pol pkp salt iv
        (\payload -> SKAAEADV6 sa aa s2k iv (BL.fromStrict payload))
            <$> encryptV6SKey pkp skey sa aa s2k iv pp

reencryptPrivateKeyWithSaltAndIV
    :: SomePKPayload
    -> SKAddendum
    -> Salt
    -> IV
    -> SKey
    -> BL.ByteString
    -> Either String SKAddendum
reencryptPrivateKeyWithSaltAndIV pkp originalSka salt iv skey pp =
    case fromSKAddendumForPKPayload pkp originalSka of
        Left err -> Left err
        Right (SomeSKAddendumV skaV) ->
            toSKAddendum
                <$> reencryptPrivateKeyTyped pkp skaV salt iv skey pp

reencryptS2KProtectedSecretKey
    :: SomePKPayload
    -> Salt
    -> IV
    -> SKey
    -> BL.ByteString
    -> SymmetricAlgorithm
    -> S2K
    -> ( SymmetricAlgorithm
         -> S2K
         -> IV
         -> BL.ByteString
         -> B.ByteString
         -> Either String r
       )
    -> Either String r
reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k encryptFn = do
    keyLen <- first renderCipherError (keySize sa)
    let retargetedS2K = retargetS2K salt s2k
    keyMaterial <-
        first renderS2KError (string2Key retargetedS2K keyLen pp)
    cleartext <- legacySecretKeyPayload pkp skey
    encryptFn sa retargetedS2K iv cleartext keyMaterial

encryptLegacyCFBSecretKey
    :: SomePKPayload
    -> SymmetricAlgorithm
    -> IV
    -> SKey
    -> BL.ByteString
    -> Either String SKAddendum
encryptLegacyCFBSecretKey pkp sa iv skey pp = do
    keyLen <- first renderCipherError (keySize sa)
    keyMaterial <-
        first
            renderS2KError
            (string2Key (Simple DeprecatedMD5) keyLen pp)
    cleartext <- legacySecretKeyPayload pkp skey
    let clearWithChecksum =
            BL.toStrict
                ( cleartext
                    <> runPut (putWord16be (checksum16 (BL.toStrict cleartext)))
                )
    (\encrypted -> SUSym sa iv (BL.fromStrict encrypted))
        <$> first
            renderCipherError
            ( encryptNoNonce
                sa
                (Simple DeprecatedMD5)
                iv
                clearWithChecksum
                keyMaterial
            )

encrypt16BitProtectedSecretKey
    :: SymmetricAlgorithm
    -> S2K
    -> IV
    -> BL.ByteString
    -> B.ByteString
    -> Either String SKAddendum
encrypt16BitProtectedSecretKey sa s2k iv cleartext keyMaterial =
    encryptProtectedSecretKey
        sa
        s2k
        iv
        cleartext
        keyMaterial
        checksum16Trailer
        (\payload -> SUS16bit sa s2k iv payload)

encryptSHA1ProtectedSecretKey
    :: SymmetricAlgorithm
    -> S2K
    -> IV
    -> BL.ByteString
    -> B.ByteString
    -> Either String SKAddendum
encryptSHA1ProtectedSecretKey sa s2k iv cleartext keyMaterial =
    encryptProtectedSecretKey
        sa
        s2k
        iv
        cleartext
        keyMaterial
        sha1Trailer
        (\payload -> SUSSHA1 sa s2k iv payload)

encryptProtectedSecretKey
    :: SymmetricAlgorithm
    -> S2K
    -> IV
    -> BL.ByteString
    -> B.ByteString
    -> (BL.ByteString -> BL.ByteString)
    -> (BL.ByteString -> r)
    -> Either String r
encryptProtectedSecretKey sa s2k iv cleartext keyMaterial checksumTrailer mkAddendum = do
    let clearWithChecksum = BL.toStrict (cleartext <> checksumTrailer cleartext)
    encrypted <-
        first
            renderCipherError
            (encryptNoNonce sa s2k iv clearWithChecksum keyMaterial)
    pure (mkAddendum (BL.fromStrict encrypted))

checksum16Trailer :: BL.ByteString -> BL.ByteString
checksum16Trailer cleartext =
    runPut (putWord16be (checksum16 (BL.toStrict cleartext)))

sha1Trailer :: BL.ByteString -> BL.ByteString
sha1Trailer cleartext =
    BL.fromStrict
        (BA.convert (CH.hash (BL.toStrict cleartext) :: CH.Digest CH.SHA1))

legacySecretKeyPayload
    :: SomePKPayload -> SKey -> Either String BL.ByteString
legacySecretKeyPayload pkp skey =
    runPut <$> putSKeyForPKPayload pkp skey

retargetS2K :: Salt -> S2K -> S2K
retargetS2K salt (Salted ha oldSalt) =
    maybe (Salted ha oldSalt) (Salted ha) (salt8FromSalt salt)
retargetS2K salt (IteratedSalted ha oldSalt cnt) =
    maybe
        (IteratedSalted ha oldSalt cnt)
        (\salt8 -> IteratedSalted ha salt8 cnt)
        (salt8FromSalt salt)
retargetS2K _ s2k = s2k