hOpenPGP-3.5: 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
( decryptPrivateKey
, mkUnencryptedSKAddendum
, encryptPrivateKeyWithPolicyAndSaltAndIV
, reencryptPrivateKeyTyped
, reencryptPrivateKeyTypedWithPolicy
, reencryptPrivateKeyWithSaltAndIV
, SecretKeyError (..)
, renderSecretKeyError
, SecretKeyEncryptOptions (..)
, decryptSecretKey
, decryptSecretKeyAddendum
, encryptSecretKey
, encryptSecretKeyWithPolicy
, 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
, 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
data SecretKeyError
= SecretKeyDecryptError String
| SecretKeyEncryptError String
| SecretKeyPolicyError String
| SecretKeyUnsupportedLegacyProtection
deriving (Eq, Show)
renderSecretKeyError :: SecretKeyError -> String
renderSecretKeyError (SecretKeyDecryptError err) = err
renderSecretKeyError (SecretKeyEncryptError err) = err
renderSecretKeyError (SecretKeyPolicyError err) = err
renderSecretKeyError SecretKeyUnsupportedLegacyProtection =
"unsupported legacy secret key protection"
data SecretKeyEncryptOptions = SecretKeyEncryptOptions
{ skeoPolicy :: OpenPGPPolicy
, skeoGenerateSaltAndIV :: Bool
, skeoSalt :: Maybe Salt
, skeoIV :: Maybe IV
}
{-# DEPRECATED decryptPrivateKey "Use decryptSecretKeyAddendum" #-}
decryptPrivateKey
:: (SomePKPayload, SKAddendum)
-> Passphrase
-> Either String SKAddendum
decryptPrivateKey (pkp, ska) (Passphrase pp) =
fromSKAddendumForPKPayload pkp ska >>= \case
SomeSKAddendumV skaV ->
toSKAddendum <$> decryptPrivateKeyTyped pkp skaV (Passphrase 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) pp of
Left err -> Left $ SecretKeyDecryptError err
Right decrypted ->
case decrypted of
SUSUnprotected 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
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) oldPassphrase
case decrypted of
SUSUnprotected 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
(Passphrase 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
-> Passphrase
-> OpenPGPPolicy
-> Either SecretKeyError SKAddendum
reencryptWithPolicyAndSaltAndIV pkp originalSka salt iv skey (Passphrase pp) policy =
first
SecretKeyEncryptError
(fromSKAddendumForPKPayload pkp originalSka)
>>= \case
SomeSKAddendumV skaV ->
first SecretKeyEncryptError $
toSKAddendum
<$> reencryptPrivateKeyTypedWithPolicy
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 String (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 renderCipherError (keySize sa)
dek <-
first
renderS2KError
(string2Key (Simple DeprecatedMD5) keyLen (unPassphrase pp))
p <-
first
renderCipherError
(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 renderCipherError (keySize sa)
dek <-
first
renderS2KError
(string2Key (Simple DeprecatedMD5) keyLen (unPassphrase pp))
p <-
first
renderCipherError
(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 String 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 String (SKey, Word16))
-> Either String (SKey, Word16)
decryptS2KProtectedPayload pkp sa s2k iv payload (Passphrase 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
-> B.ByteString
-> Passphrase
-> Either String SKey
decryptAEADPayloadCore pkp sa aa s2k iv payload (Passphrase 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 =
nubOrd
[ B.pack
[tag, keyVersionByte (_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 "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 $
"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
show
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 show unsupportedSecretKeyAEADError sa kek $ \cipher ->
first
show
(CE.eitherCryptoError (CCT.aeadInit mode cipher nonce))
>>= \aead ->
note
"failed to authenticate v6 AEAD secret key payload"
(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
encryptPrivateKeyWithPolicyAndSaltAndIV
"Use encryptSecretKeyWithPolicy"
#-}
encryptPrivateKeyWithPolicyAndSaltAndIV
:: OpenPGPPolicy
-> SomePKPayload
-> Salt
-> IV
-> SKAddendum
-> Passphrase
-> Either String SKAddendum
encryptPrivateKeyWithPolicyAndSaltAndIV policy pkp salt iv ska (Passphrase pp) =
case ska of
SUSUnprotected skey _ ->
encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV
policy
pkp
salt
iv
skey
(Passphrase pp)
_ -> Right ska
encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV
:: OpenPGPPolicy
-> SomePKPayload
-> Salt
-> IV
-> SKey
-> Passphrase
-> Either String 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 renderCipherError (keySize sa)
keyMaterial <-
first renderS2KError (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
renderCipherError
(encryptNoNonce sa retargetedS2K iv clearWithSHA1 keyMaterial)
pure (SUSCFB sa retargetedS2K iv (BL.fromStrict encrypted))
DeprecatedV3 ->
Left "v3 secret key encryption is not supported"
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))))
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 String B.ByteString
encryptV6SKey pkp skey sa aa s2k iv (Passphrase 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 skPolicy ->
let saltLen = case _keyVersion pkp of
V4 -> 8
_ -> secretKeyS2KSaltOctets skPolicy
in Right (saltLen, secretKeyAEADNonceOctets skPolicy)
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 skPolicy -> do
let expectedSaltLen = case _keyVersion pkp of
V4 -> 8
_ -> secretKeyS2KSaltOctets skPolicy
when (B.length (unSalt salt) /= expectedSaltLen) $
Left
( "secret key S2K salt must be "
++ show expectedSaltLen
++ " octets"
)
when
( _keyVersion pkp == V6
&& B.length (unIV iv) /= secretKeyAEADNonceOctets skPolicy
)
$ Left
( "v6 secret key AEAD nonce must be "
++ show (secretKeyAEADNonceOctets skPolicy)
++ " octets"
)
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 legacySecretKeyProtectionErrorMessage
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 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
show
unsupportedSecretKeyAEADError
sa
kek
(\cipher -> encryptWithOCBRFC7253 cipher nonce ad plaintext)
_ -> do
mode <- aeadMode aa
withAESCipher show unsupportedSecretKeyAEADError sa kek $ \cipher ->
first
show
(CE.eitherCryptoError (CCT.aeadInit mode cipher nonce))
>>= \aead ->
pure (CCT.aeadSimpleEncrypt aead ad plaintext 16)
{-# DEPRECATED reencryptPrivateKeyTyped "Use reencryptSecretKey" #-}
reencryptPrivateKeyTyped
:: SomePKPayload
-> SKAddendumV v
-> Salt
-> IV
-> SKey
-> Passphrase
-> Either String (SKAddendumV v)
reencryptPrivateKeyTyped = reencryptPrivateKeyTypedWithPolicy defaultPolicy
{-# DEPRECATED reencryptPrivateKeyTypedWithPolicy "Use reencryptSecretKey" #-}
reencryptPrivateKeyTypedWithPolicy
:: OpenPGPPolicy
-> SomePKPayload
-> SKAddendumV v
-> Salt
-> IV
-> SKey
-> Passphrase
-> Either String (SKAddendumV v)
reencryptPrivateKeyTypedWithPolicy 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 renderCipherError (keySize sa)
keyMaterial <-
first
renderS2KError
(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
renderCipherError
( encryptNoNonce
sa
(Simple DeprecatedMD5)
iv
clearWithChecksum
keyMaterial
)
SKAUnprotectedLegacy _ _ -> 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
{-# DEPRECATED reencryptPrivateKeyWithSaltAndIV "Use reencryptSecretKey" #-}
reencryptPrivateKeyWithSaltAndIV
:: SomePKPayload
-> SKAddendum
-> Salt
-> IV
-> SKey
-> Passphrase
-> Either String SKAddendum
reencryptPrivateKeyWithSaltAndIV pkp originalSka salt iv skey (Passphrase pp) =
fromSKAddendumForPKPayload pkp originalSka >>= \(SomeSKAddendumV skaV) ->
toSKAddendum
<$> reencryptPrivateKeyTyped pkp skaV salt iv skey (Passphrase pp)
reencryptS2KProtectedSecretKey
:: SomePKPayload
-> Salt
-> IV
-> SKey
-> Passphrase
-> SymmetricAlgorithm
-> S2K
-> ( SymmetricAlgorithm
-> S2K
-> IV
-> BL.ByteString
-> B.ByteString
-> Either String r
)
-> Either String r
reencryptS2KProtectedSecretKey pkp salt iv skey (Passphrase 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
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