hOpenPGP-3.6: 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 LambdaCase #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TypeApplications #-}
module Codec.Encryption.OpenPGP.SecretKey
( SecretKeyEncryptOptions (..)
, decryptSecretKey
, decryptSecretKeyAddendum
, encryptSecretKey
, encryptSecretKeyWithPolicy
, mkUnencryptedSKAddendum
, reencryptSecretKey
, reencryptSecretKeyRandom
) where
import Control.Error.Util (note)
import Control.Monad (when)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except
( 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
( 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.Containers.ListUtils (nubOrd)
import Data.Word (Word16, Word8)
import qualified "crypton" Crypto.Cipher.Types as CCT
import Codec.Encryption.OpenPGP.BlockCipher
( keySize
)
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
( skesk2Key
, string2Key
)
import Codec.Encryption.OpenPGP.Serialize
( getSecretKey
, putSKeyForPKPayload
)
import Codec.Encryption.OpenPGP.Types
data SecretKeyEncryptOptions = SecretKeyEncryptOptions
{ skeoPolicy :: OpenPGPPolicy
, skeoGenerateSaltAndIV :: Bool
, skeoSalt :: Maybe Salt
, skeoIV :: Maybe IV
}
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 fromSKAddendumForPKPayload pkp ska of
Left err -> Left (SecretKeyDecryptAddendumError err)
Right (SomeSKAddendumV skaV) ->
case decryptPrivateKeyTyped pkp skaV pp of
Left err -> Left err
Right decryptedV ->
case toSKAddendum decryptedV of
SUSUnprotected skey _ -> Right (skey, toSKAddendum decryptedV)
_ -> Left SecretKeyDecryptNotUnencrypted
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 nextMaterial
else case (skeoSalt opts, skeoIV opts) of
(Just salt, Just iv) -> return (salt, iv)
_ -> throwE SecretKeyEncryptOptionsInconsistent
ska <-
except
(mkUnencryptedSKAddendum pkp skey)
except
( encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV
(skeoPolicy opts)
pkp
salt
iv
skey
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
decryptedSKA <-
except $ case fromSKAddendumForPKPayload pkp originalSka of
Left err -> Left (SecretKeyDecryptAddendumError err)
Right (SomeSKAddendumV skaV) ->
case decryptPrivateKeyTyped pkp skaV oldPassphrase of
Left err -> Left err
Right decryptedV -> Right (toSKAddendum decryptedV)
case decryptedSKA of
SUSUnprotected skey _ -> do
let pp = unPassphrase newPassphrase
(salt, iv) <-
if skeoGenerateSaltAndIV opts
then do
nextMaterial <-
lift $ generateSecretKeyProtectionMaterial (skeoPolicy opts) pkp
except nextMaterial
else case (skeoSalt opts, skeoIV opts) of
(Just salt, Just iv) -> return (salt, iv)
_ -> throwE SecretKeyEncryptOptionsInconsistent
newSka <-
except $
reencryptWithPolicyAndSaltAndIV
pkp
originalSka
salt
iv
skey
(Passphrase pp)
(skeoPolicy opts)
return $ sk {_secretKeySKAddendum = newSka}
_ -> throwE SecretKeyDecryptNotUnencrypted
return result
reencryptWithPolicyAndSaltAndIV
:: SomePKPayload
-> SKAddendum
-> Salt
-> IV
-> SKey
-> Passphrase
-> OpenPGPPolicy
-> Either SecretKeyError SKAddendum
reencryptWithPolicyAndSaltAndIV pkp originalSka salt iv skey (Passphrase pp) policy =
first
SecretKeyEncryptAddendumError
(fromSKAddendumForPKPayload pkp originalSka)
>>= \case
SomeSKAddendumV skaV ->
toSKAddendum
<$> reencryptWithPolicyAndSaltAndIVTyped
policy
pkp
skaV
salt
iv
skey
(Passphrase 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
}
decryptPrivateKeyTyped
:: SomePKPayload
-> SKAddendumV v
-> Passphrase
-> Either SecretKeyError (SKAddendumV v)
decryptPrivateKeyTyped pkp (SKAMalleableCFB sa s2k iv payload) pp = do
(sk, cksum) <-
decryptS2KProtectedPayload
pkp
sa
s2k
iv
payload
pp
parse16BitProtectedSecretKey
pure (SKAUnprotectedLegacy sk cksum)
decryptPrivateKeyTyped pkp (SKACFBLegacy sa s2k iv payload) pp = do
(sk, cksum) <-
decryptS2KProtectedPayload
pkp
sa
s2k
iv
payload
pp
parseSHA1ProtectedSecretKey
pure (SKAUnprotectedLegacy sk cksum)
decryptPrivateKeyTyped pkp (SKACFBV6 sa s2k iv payload) pp = do
(sk, _) <-
decryptS2KProtectedPayload
pkp
sa
s2k
iv
payload
pp
parseSHA1ProtectedSecretKey
pure (SKAUnprotectedV6 sk)
decryptPrivateKeyTyped pkp (SKAAEADV6 sa aa s2k iv payload) pp = do
sk <-
decryptAEADPayloadCore pkp sa aa s2k iv (BL.toStrict payload) pp
pure (SKAUnprotectedV6 sk)
decryptPrivateKeyTyped pkp (SKAAEADLegacy sa aa s2k iv payload) pp = do
sk <-
decryptAEADPayloadCore pkp sa aa s2k iv (BL.toStrict payload) pp
pure (SKAUnprotectedLegacy sk 0)
decryptPrivateKeyTyped pkp (SKALegacyCFBLegacy sa iv payload) pp = do
keyLen <-
first SecretKeyPolicyCipherError (keySize sa)
dek <-
first
SecretKeyInvalidS2KMode
(string2Key (Simple DeprecatedMD5) keyLen (unPassphrase pp))
p <-
first
SecretKeyDecryptCipherError
(decryptNoNonce sa iv (BL.toStrict payload) dek)
(sk, cksum) <- parse16BitProtectedSecretKey pkp p
pure (SKAUnprotectedLegacy sk cksum)
decryptPrivateKeyTyped pkp (SKALegacyCFBV6 sa iv payload) pp = do
keyLen <-
first SecretKeyPolicyCipherError (keySize sa)
dek <-
first
SecretKeyInvalidS2KMode
(string2Key (Simple DeprecatedMD5) keyLen (unPassphrase pp))
p <-
first
SecretKeyDecryptCipherError
(decryptNoNonce sa iv (BL.toStrict payload) dek)
(sk, _) <- parse16BitProtectedSecretKey pkp p
pure (SKAUnprotectedV6 sk)
decryptPrivateKeyTyped _ ska@(SKAUnprotectedLegacy {}) _ = Right ska
decryptPrivateKeyTyped _ ska@(SKAUnprotectedV6 {}) _ = Right ska
mkUnencryptedSKAddendum
:: SomePKPayload -> SKey -> Either SecretKeyError SKAddendum
mkUnencryptedSKAddendum pkp skey = do
payload <- legacySecretKeyPayload pkp skey
let checksum =
case _keyVersion pkp of
V6 -> 0
_ -> checksum16 (BL.toStrict payload)
pure (SUSUnprotected skey checksum)
decryptS2KProtectedPayload
:: SomePKPayload
-> SymmetricAlgorithm
-> S2K
-> IV
-> BL.ByteString
-> Passphrase
-> ( SomePKPayload
-> B.ByteString
-> Either SecretKeyError (SKey, Word16)
)
-> Either SecretKeyError (SKey, Word16)
decryptS2KProtectedPayload pkp sa s2k iv payload (Passphrase pp) parser = do
dek <-
first
SecretKeyInvalidS2KMode
(skesk2Key (SKESK4Packet sa s2k Nothing) pp)
decrypted <-
first
SecretKeyDecryptCipherError
(decryptNoNonce sa iv (BL.toStrict payload) dek)
parser pkp decrypted
parse16BitProtectedSecretKey
:: SomePKPayload
-> B.ByteString
-> Either SecretKeyError (SKey, Word16)
parse16BitProtectedSecretKey pkp p
| B.length p < 2 =
Left
( SecretKeyPayloadTooShort
"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
( SecretKeyChecksumError
( "16-bit secret key checksum mismatch (expected "
++ show expected
++ ", got "
++ show cksum
++ ")"
)
)
parseSHA1ProtectedSecretKey
:: SomePKPayload
-> B.ByteString
-> Either SecretKeyError (SKey, Word16)
parseSHA1ProtectedSecretKey pkp p
| B.length p < 20 =
Left
( SecretKeyPayloadTooShort
"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 (SecretKeyChecksumError "SHA1 secret key checksum mismatch")
decodeSecretKey
:: SomePKPayload -> B.ByteString -> Either SecretKeyError SKey
decodeSecretKey pkp payloadBytes =
first
SecretKeyDecodeError
( bimap
(\(_, _, x) -> x)
(\(_, _, x) -> x)
(runGetOrFail (getSecretKey pkp) (BL.fromStrict payloadBytes))
)
decodeChecksum :: B.ByteString -> Either SecretKeyError Word16
decodeChecksum checksumBytes =
first
SecretKeyDecodeError
( bimap
(\(_, _, x) -> x)
(\(_, _, x) -> x)
(runGetOrFail getWord16be (BL.fromStrict checksumBytes))
)
decryptAEADPayloadCore
:: SomePKPayload
-> SymmetricAlgorithm
-> AEADAlgorithm
-> S2K
-> IV
-> B.ByteString
-> Passphrase
-> Either SecretKeyError SKey
decryptAEADPayloadCore pkp sa aa s2k iv payload (Passphrase pp) = do
keyLen <-
first SecretKeyPolicyCipherError (keySize sa)
keyMaterial <-
first
SecretKeyInvalidS2KMode
(string2Key s2k keyLen pp)
let keyCandidates = [keyMaterial]
tagCandidates = [0xC5, 0xC7, 0x94, 0x95, 0x96, 0x97, 0x9C, 0x9D, 0x9E, 0x9F]
infoCandidates =
nubOrd
[ B.pack
[ tag
, fromIntegral (fromEnum (_keyVersion pkp))
, fromFVal sa
, fromFVal aa
]
| tag <- tagCandidates
]
pkpBytes = BL.toStrict (runPut (put pkp))
adCandidates =
nubOrd
[B.cons tagByte pkpBytes | tagByte <- tagCandidates]
aaCandidates = [aa]
nonce = unIV iv
payloadStrict = payload
tagLen = 16
tryDecrypt candidateKeyMaterial info ad aaTry = do
when (B.length payloadStrict < tagLen) $
Left
(SecretKeyPayloadTooShort "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 =
nubOrd
[ 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 $
SecretKeyAEADError
( "could not decrypt using any KEK candidate"
++ maybe
""
(\e -> " (last error: " ++ renderSecretKeyError e ++ ")")
merr
)
go merr (kek : ks) =
case decryptWithKey sa aaTry kek ad nonce ciphertext authTag of
Right cleartext -> Right cleartext
Left err -> go (Just err) ks
tryKeks kekCandidates
tryAll = go Nothing
where
go merr [] =
Left $
SecretKeyAEADError
( "could not decrypt v6 AEAD secret key payload"
++ maybe
""
(\e -> " (last error: " ++ renderSecretKeyError e ++ ")")
merr
)
go merr ((keyMaterialCandidate, info, ad, aaTry) : xs) =
case tryDecrypt keyMaterialCandidate info ad aaTry of
Right cleartext -> Right cleartext
Left err -> go (Just err) 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 SecretKeyError B.ByteString
decryptWithKey sa aa kek ad nonce ciphertext authTag = do
let toHex = BC.unpack . B16.encode
authFailure expectedTag computedTag n a hashAd plaintext =
SecretKeyAuthError
( "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 =
SecretKeyAEADModeUnsupportedCipher sa
case aa of
OCB ->
withAESCipher
SecretKeyAEADModeCrypto
unsupportedSecretKeyAEADError
sa
kek
( \cipher ->
decryptWithOCBRFC7253With
authFailure
cipher
nonce
ad
ciphertext
authTag
)
_ -> do
mode <- aeadMode aa
expectedNonceLen <- aeadNonceSize aa
when (B.length nonce /= expectedNonceLen) $
Left
( SecretKeyInvalidNonceSize
"invalid nonce size for v6 AEAD secret key payload"
)
withAESCipher
SecretKeyAEADModeCrypto
unsupportedSecretKeyAEADError
sa
kek
$ \cipher ->
first
SecretKeyAEADModeCrypto
(CE.eitherCryptoError (CCT.aeadInit mode cipher nonce))
>>= \aead ->
note
( SecretKeyAuthError
"failed to authenticate v6 AEAD secret key payload"
)
(CCT.aeadSimpleDecrypt aead ad ciphertext authTag)
aeadMode :: AEADAlgorithm -> Either SecretKeyError CCT.AEADMode
aeadMode EAX = Right CCT.AEAD_EAX
aeadMode OCB = Right CCT.AEAD_OCB
aeadMode GCM = Right CCT.AEAD_GCM
aeadMode aa@(OtherAEADAlgo _) = Left (SecretKeyAEADModeUnsupportedAlgo aa)
aeadNonceSize :: AEADAlgorithm -> Either SecretKeyError Int
aeadNonceSize EAX = Right 16
aeadNonceSize OCB = Right 15
aeadNonceSize GCM = Right 12
aeadNonceSize (OtherAEADAlgo _) = Left (SecretKeyInvalidNonceSize "unknown AEAD nonce size")
parseSecretKeyExact
:: SomePKPayload -> B.ByteString -> Either SecretKeyError SKey
parseSecretKeyExact pkp cleartext =
case runGetOrFail
((,) <$> getSecretKey pkp <*> getRemainingLazyByteString)
(BL.fromStrict cleartext) of
Left (_, _, err) -> Left (SecretKeyDecodeError err)
Right (_, _, (sk, trailing))
| BL.null trailing -> Right sk
| otherwise ->
Left
( SecretKeyTrailingBytes
"v6 AEAD secret key cleartext has trailing bytes"
)
encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV
:: OpenPGPPolicy
-> SomePKPayload
-> Salt
-> IV
-> SKey
-> Passphrase
-> Either SecretKeyError SKAddendum
encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV policy pkp salt iv skey (Passphrase pp) = do
(sa, _aa, s2k) <- secretKeyProtectionDefaults policy pkp salt iv
let retargetedS2K = retargetS2K salt s2k
case _keyVersion pkp of
V6 ->
(\payload -> SUSAEAD sa _aa s2k iv (BL.fromStrict payload))
<$> encryptV6SKey pkp skey sa _aa s2k iv (Passphrase pp)
V4 ->
if policyRFC policy == RFC9580
then
(\payload -> SUSAEAD sa _aa s2k iv (BL.fromStrict payload))
<$> encryptV6SKey pkp skey sa _aa s2k iv (Passphrase pp)
else do
keyLen <-
first SecretKeyPolicyCipherError (keySize sa)
keyMaterial <-
first
SecretKeyInvalidS2KMode
(string2Key retargetedS2K keyLen pp)
cleartext <- legacySecretKeyPayload pkp skey
let clearWithSHA1 =
BL.toStrict cleartext
<> BA.convert
( CH.hash
(BL.toStrict cleartext)
:: CH.Digest CH.SHA1
)
encrypted <-
first
SecretKeyEncryptCipherError
(encryptNoNonce sa retargetedS2K iv clearWithSHA1 keyMaterial)
pure (SUSCFB sa retargetedS2K iv (BL.fromStrict encrypted))
DeprecatedV3 ->
Left SecretKeyUnsupportedLegacyProtection
encodeSKeyMaterial :: SKey -> Either SecretKeyError BL.ByteString
encodeSKeyMaterial keyMaterial =
case keyMaterial of
RSAPrivateKey (RSA_PrivateKey (R.PrivateKey _ d p q _ _ _)) ->
case inverse p q of
Nothing ->
Left SecretKeyRSAInverseError
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))))
Ed25519PrivateKey bs ->
Right (runPut (putByteString bs))
Ed448PrivateKey bs ->
Right (runPut (putByteString 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
-> Passphrase
-> Either SecretKeyError B.ByteString
encryptV6SKey pkp skey sa aa s2k iv (Passphrase pp) = do
keyLen <-
first SecretKeyPolicyCipherError (keySize sa)
keyMaterial <-
first
SecretKeyInvalidS2KMode
(string2Key s2k keyLen pp)
payload <- encodeSKeyMaterial skey
let info =
B.pack
[ 0xC5
, fromIntegral (fromEnum (_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 SecretKeyError (Int, Int)
secretKeyProtectionMaterialLengths policy pkp =
case secretKeyProtectionPolicyForEncryption policy (_keyVersion pkp) of
Just skPolicy ->
let saltLen = case _keyVersion pkp of
V4 -> 8
_ -> secretKeyS2KSaltOctets skPolicy
in Right (saltLen, secretKeyAEADNonceOctets skPolicy)
Nothing -> Left SecretKeyUnsupportedLegacyProtection
generateSecretKeyProtectionMaterial
:: MonadRandom m
=> OpenPGPPolicy
-> SomePKPayload
-> m (Either SecretKeyError (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 SecretKeyError (SymmetricAlgorithm, AEADAlgorithm, S2K)
secretKeyProtectionDefaults policy pkp salt iv =
case secretKeyProtectionPolicyForEncryption policy (_keyVersion pkp) of
Just skPolicy -> do
let expectedSaltLen = case _keyVersion pkp of
V4 -> 8
_ -> secretKeyS2KSaltOctets skPolicy
when (B.length (unSalt salt) /= expectedSaltLen) $
Left
( SecretKeyPolicySaltLengthMismatch
expectedSaltLen
(B.length (unSalt salt))
)
when
( _keyVersion pkp == V6
&& B.length (unIV iv) /= secretKeyAEADNonceOctets skPolicy
)
$ Left
( SecretKeyPolicyNonceLengthMismatch
(secretKeyAEADNonceOctets skPolicy)
(B.length (unIV iv))
)
let defaultS2K = secretKeyDefaultS2KForSalt skPolicy salt
s2k = case _keyVersion pkp of
V4 ->
case defaultS2K of
Argon2 {} ->
IteratedSalted
SHA512
(Salt8 (B.take 8 (unSalt salt)))
1024
_ -> defaultS2K
_ -> defaultS2K
let sa = secretKeyDefaultSymmetricAlgorithm skPolicy
aa = secretKeyDefaultAEADAlgorithm skPolicy
pure (sa, aa, s2k)
Nothing -> Left SecretKeyUnsupportedLegacyProtection
secretKeyProtectionPolicyForEncryption
:: OpenPGPPolicy -> KeyVersion -> Maybe SecretKeyProtectionPolicy
secretKeyProtectionPolicyForEncryption policy V4 =
policySecretKeyProtection policy
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 SecretKeyError (CCT.AuthTag, B.ByteString)
encryptWithKey sa aa kek ad nonce plaintext = do
expectedNonceLen <- aeadNonceSize aa
when (B.length nonce /= expectedNonceLen) $
Left
( SecretKeyInvalidNonceSize
"invalid nonce size for v6 AEAD secret key payload"
)
let unsupportedSecretKeyAEADError =
SecretKeyAEADModeUnsupportedCipher sa
case aa of
OCB ->
withAESCipher
SecretKeyAEADModeCrypto
unsupportedSecretKeyAEADError
sa
kek
(\cipher -> encryptWithOCBRFC7253 cipher nonce ad plaintext)
_ -> do
mode <- aeadMode aa
withAESCipher
SecretKeyAEADModeCrypto
unsupportedSecretKeyAEADError
sa
kek
$ \cipher ->
first
SecretKeyAEADModeCrypto
(CE.eitherCryptoError (CCT.aeadInit mode cipher nonce))
>>= \aead ->
pure (CCT.aeadSimpleEncrypt aead ad plaintext 16)
reencryptWithPolicyAndSaltAndIVTyped
:: OpenPGPPolicy
-> SomePKPayload
-> SKAddendumV v
-> Salt
-> IV
-> SKey
-> Passphrase
-> Either SecretKeyError (SKAddendumV v)
reencryptWithPolicyAndSaltAndIVTyped policy pkp skaV salt iv skey pp =
case skaV of
SKAAEADV6 {} -> reencryptV6 policy
SKACFBV6 {} -> reencryptV6 policy
SKALegacyCFBV6 {} -> reencryptV6 policy
SKAUnprotectedV6 {} -> reencryptV6 policy
SKAMalleableCFB sa s2k _ _ ->
reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k $ \sa' s2k' iv' ct km ->
encryptProtectedSecretKey
sa'
s2k'
iv'
ct
km
checksum16Trailer
(SKAMalleableCFB sa' s2k' iv')
SKACFBLegacy sa s2k _ _ ->
reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k $ \sa' s2k' iv' ct km ->
encryptProtectedSecretKey
sa'
s2k'
iv'
ct
km
sha1Trailer
(SKACFBLegacy 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
(SKACFBLegacy sa' s2k' iv')
SKALegacyCFBLegacy sa _ _ -> do
keyLen <-
first SecretKeyPolicyCipherError (keySize sa)
keyMaterial <-
first
SecretKeyInvalidS2KMode
(string2Key (Simple DeprecatedMD5) keyLen (unPassphrase pp))
cleartext <- legacySecretKeyPayload pkp skey
let clearWithChecksum =
BL.toStrict
( cleartext
<> runPut (putWord16be (checksum16 (BL.toStrict cleartext)))
)
(\encrypted -> SKALegacyCFBLegacy sa iv (BL.fromStrict encrypted))
<$> first
SecretKeyEncryptCipherError
( encryptNoNonce
sa
(Simple DeprecatedMD5)
iv
clearWithChecksum
keyMaterial
)
SKAUnprotectedLegacy _ _ -> Left SecretKeyUnsupportedLegacyProtection
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
reencryptS2KProtectedSecretKey
:: SomePKPayload
-> Salt
-> IV
-> SKey
-> Passphrase
-> SymmetricAlgorithm
-> S2K
-> ( SymmetricAlgorithm
-> S2K
-> IV
-> BL.ByteString
-> B.ByteString
-> Either SecretKeyError r
)
-> Either SecretKeyError r
reencryptS2KProtectedSecretKey pkp salt iv skey (Passphrase pp) sa s2k encryptFn = do
keyLen <-
first SecretKeyPolicyCipherError (keySize sa)
let retargetedS2K = retargetS2K salt s2k
keyMaterial <-
first
SecretKeyInvalidS2KMode
(string2Key retargetedS2K keyLen pp)
cleartext <- legacySecretKeyPayload pkp skey
encryptFn sa retargetedS2K iv cleartext keyMaterial
encryptProtectedSecretKey
:: SymmetricAlgorithm
-> S2K
-> IV
-> BL.ByteString
-> B.ByteString
-> (BL.ByteString -> BL.ByteString)
-> (BL.ByteString -> r)
-> Either SecretKeyError r
encryptProtectedSecretKey sa s2k iv cleartext keyMaterial checksumTrailer mkAddendum = do
let clearWithChecksum = BL.toStrict (cleartext <> checksumTrailer cleartext)
encrypted <-
first
SecretKeyEncryptCipherError
(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 SecretKeyError BL.ByteString
legacySecretKeyPayload pkp skey =
first SecretKeyEncodeError $
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