-- 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 PackageImports #-}
{-# LANGUAGE TypeApplications #-}

module Codec.Encryption.OpenPGP.SecretKey
  ( decryptPrivateKey
  , reinterpretUnknownSKeyForPKPayload
  , mkUnencryptedSKAddendum
  , encryptPrivateKeyWithPolicyAndSaltAndIV
  , encryptPrivateKey
  , changePrivateKeyPassphrase
  , changePrivateKeyPassphraseRandom
  , changeSecretKeyPassphrase
  , changeSecretKeyPassphraseRandom
  , reencryptSecretKeyRandomEither
  , reencryptPrivateKeyTyped
  ) where

import Codec.Encryption.OpenPGP.BlockCipher (renderCipherError, keySize)
import Codec.Encryption.OpenPGP.CFB (decryptNoNonce, encryptNoNonce)
import Codec.Encryption.OpenPGP.Internal.RFC7253OCB
  ( decryptWithOCBRFC7253With
  , encryptWithOCBRFC7253
  )
import Codec.Encryption.OpenPGP.Internal.CryptoAES (withAESCipher)
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 qualified "crypton" Crypto.Cipher.Types as CCT
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 Control.Monad (when)
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.Base16 as B16
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as BL
import Data.List (nub)
import Data.Word (Word8, Word16)

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

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

-- |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
  pure $ do
    (salt, iv) <- nextMaterial
    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

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"

changePrivateKeyPassphraseRandom ::
     MonadRandom m
  => (SomePKPayload, SKAddendum)
  -> BL.ByteString
  -> BL.ByteString
  -> m (Either String SKAddendum)
changePrivateKeyPassphraseRandom (pkp, ska) oldPassphrase newPassphrase = do
  nextMaterial <- generateSecretKeyProtectionMaterial defaultPolicy pkp
  pure $ do
    (salt, iv) <- nextMaterial
    changePrivateKeyPassphrase
      (pkp, ska)
      oldPassphrase
      salt
      iv
      newPassphrase

changeSecretKeyPassphrase ::
     SecretKey
  -> BL.ByteString
  -> Salt
  -> IV
  -> BL.ByteString
  -> Either String SecretKey
changeSecretKeyPassphrase sk oldPassphrase salt iv newPassphrase = do
  ska <-
    changePrivateKeyPassphrase
      (_secretKeyPKPayload sk, _secretKeySKAddendum sk)
      oldPassphrase
      salt
      iv
      newPassphrase
  return sk {_secretKeySKAddendum = ska}

changeSecretKeyPassphraseRandom ::
     MonadRandom m
  => SecretKey
  -> BL.ByteString
  -> BL.ByteString
  -> m (Either String SecretKey)
changeSecretKeyPassphraseRandom sk oldPassphrase newPassphrase = do
  nextSKA <-
    changePrivateKeyPassphraseRandom
      (_secretKeyPKPayload sk, _secretKeySKAddendum sk)
      oldPassphrase
      newPassphrase
  pure ((\ska -> sk {_secretKeySKAddendum = ska}) <$> nextSKA)

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)

reencryptSecretKeyRandomEither ::
     MonadRandom m => SecretKey -> BL.ByteString -> m (Either String SecretKey)
reencryptSecretKeyRandomEither sk pp =
  changeSecretKeyPassphraseRandom sk pp pp

-- | 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 pkp skaV salt iv skey pp =
  case skaV of
    SKAAEADV6 {}        -> reencryptV6
    SKASHA1V6 {}        -> reencryptV6
    SKASymV6 {}         -> reencryptV6
    SKAUnencryptedV6 {} -> reencryptV6
    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 = do
      (sa, aa, s2k) <- secretKeyProtectionDefaults defaultPolicy 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
