hOpenPGP-3.0.1: Codec/Encryption/OpenPGP/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 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