hOpenPGP-3.0.2: Codec/Encryption/OpenPGP/Signatures.hs
-- Signatures.hs: OpenPGP (RFC9580) signature verification
-- Copyright © 2012-2026 Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Codec.Encryption.OpenPGP.Signatures
( SignError(..)
, renderSignError
, CertificationState(..)
, certificationStateAt
, VerificationError(..)
, renderVerificationError
, verifySigWith
, verifyAgainstKeyring
, verifyAgainstKeys
, verifyTKWith
, verifyUnknownTKWith
, signCertificationWithRSA
, signDirectKeyWithRSA
, signKeyRevocationWithRSA
, signSubkeyRevocationWithRSA
, signCertRevocationWithRSA
, signUserIDwithRSA
, crossSignSubkeyWithRSA
, signDataWithEd25519
, signDataWithEd25519Legacy
, signDataWithEd25519V6
, signDataWithEd448
, signDataWithEd448V6
, signDataWithRSA
, signDataWithRSAV6
-- * Builder-based API (Phase 2)
, signDataWithRSABuilder
, signDataWithRSAV6Builder
, signDataWithEd25519Builder
, signDataWithEd25519V6Builder
, signDataWithEd448Builder
, signDataWithEd448V6Builder
, signDataWithAlgorithmicBuilder
-- * Text normalization mode
, TextNormalizationMode(..)
) where
import Control.Applicative ((<|>))
import Control.Error.Util (hush)
import Control.Lens ((&), (^.), _1)
import Control.Monad (liftM2, when)
import Crypto.Error (eitherCryptoError)
import Crypto.Hash (hashWith)
import qualified Crypto.Hash.Algorithms as CHA
import Crypto.Number.Serialize (i2osp, os2ip)
import qualified Crypto.PubKey.DSA as DSA
import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
import qualified Crypto.PubKey.Ed25519 as Ed25519
import qualified Crypto.PubKey.Ed448 as Ed448
import qualified Crypto.PubKey.RSA.PKCS15 as P15
import qualified Crypto.PubKey.RSA.Types as RSATypes
import Data.Bifunctor (first)
import Data.Binary.Put (runPut)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BL
import Data.Either (isRight, lefts, rights)
import Data.Function (on)
import Data.IxSet.Typed ((@=))
import qualified Data.IxSet.Typed as IxSet
import qualified Data.Set as Set
import Data.List (find, intercalate, nub)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Maybe (isJust, mapMaybe)
import Data.Text (Text)
import Data.Time.Clock (UTCTime(..), addUTCTime, diffUTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Word (Word16, Word8)
import GHC.TypeLits (TypeError, ErrorMessage(..))
import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
import Codec.Encryption.OpenPGP.Expirations
( isPKTimeValidWithSelfSignatures
, keyStateAt
, keyStateValid
)
import Codec.Encryption.OpenPGP.Internal
( PktStreamContext(..)
, emptyPSC
, issuer
, issuerFP
)
import Codec.Encryption.OpenPGP.Ontology
( isCertRevocationSig
, isRevocationKeySSP
, isRevokerP
, isSubkeyBindingSig
, isSubkeyRevocation
)
import Codec.Encryption.OpenPGP.SignatureQualities
( sigCT
, sigHA
, sigPKA
, sigType
, signatureHashedSubpacketsKnown
, signatureSubpacketListsKnown
)
import Codec.Encryption.OpenPGP.SerializeForSigs
( payloadForSig
, putKeyforSigning
, putPartialSigforSigning
, putSigTrailer
, putUforSigning
)
import Codec.Encryption.OpenPGP.Policy (signatureV6SaltSizeForHashAlgorithm)
import Codec.Encryption.OpenPGP.Subpackets
( SigBuilder
, TextNormalizationMode(..)
, sbSigType
, sbHashAlgo
, sbHashedSubs
, sbUnhashedSubs
, sbSalt
, sbTextNormMode
, PrivateKeyFor
)
import qualified Codec.Encryption.OpenPGP.Subpackets as SP
import Codec.Encryption.OpenPGP.Types
import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA
import Data.Conduit.OpenPGP.Keyring.Instances ()
data VerificationError
= IssuerSubpacketMismatch
| IssuerSubpacketUncheckable String
| IssuerKeyIdProhibitedInV6Signature
| IssuerFingerprintSubpacketMismatch
| UnsupportedCriticalSubpacket SigType
| UnknownCriticalPacketInStream Word8
| BrokenCriticalPacketInStream Word8 String
| ExternalVerificationError String
| NonSignaturePacket
| UnexpectedSignaturePayloadShape
| MissingHashAlgorithm
| HashComputationFailed String
| UnexpectedKeyVersion
| SignatureHashUnsupportedByAlgorithm HashAlgorithm PubKeyAlgorithm
| KeyRevoked
| SigningKeyUnavailableAtSignatureTime
| MissingIssuer
| SigningKeyNotFound (Maybe EightOctetKeyId) (Maybe Fingerprint)
| MultipleVerificationSuccesses Int
| UnsupportedKeyType PubKeyAlgorithm
| SignatureMismatch PubKeyAlgorithm Fingerprint
| SignatureShapeMismatch PubKeyAlgorithm
| SignatureEncodingInvalid PubKeyAlgorithm String
| SignaturePolicyHashUnsupported HashAlgorithm
| SignaturePolicyPKAMismatch PubKeyAlgorithm PubKeyAlgorithm
| SignatureExpired
| CandidateKeyFailures [VerificationError]
| InvalidSubkeyBackSignature VerificationError
-- ^ An embedded primary-key back-signature (type 0x19) in a subkey
-- binding signature failed to verify.
deriving (Eq, Show)
data CertificationState
= CertificationNotYetKnown
| CertificationActive
| CertificationRevoked
deriving (Eq, Show)
renderVerificationError :: VerificationError -> String
renderVerificationError IssuerSubpacketMismatch =
"verification failed: issuer subpacket does not match the actual signer"
renderVerificationError (IssuerSubpacketUncheckable err) =
"verification failed: issuer subpacket cannot be checked (" ++ err ++ ")"
renderVerificationError IssuerKeyIdProhibitedInV6Signature =
"verification failed: Issuer Key ID subpacket is prohibited in v6 signatures"
renderVerificationError IssuerFingerprintSubpacketMismatch =
"verification failed: issuer fingerprint subpacket does not match the actual signer"
renderVerificationError (UnsupportedCriticalSubpacket sigType) =
"verification failed: unsupported critical hashed subpacket in " ++
show sigType ++ " signature"
renderVerificationError (UnknownCriticalPacketInStream t) =
"verification failed: unknown critical packet type in packet sequence (" ++ show t ++ ")"
renderVerificationError (BrokenCriticalPacketInStream t err) =
"verification failed: broken critical packet type " ++ show t ++ ": " ++ err
renderVerificationError (ExternalVerificationError err) = err
renderVerificationError NonSignaturePacket =
"verification failed: non-signature packet encountered where signature was expected"
renderVerificationError UnexpectedSignaturePayloadShape =
"verification failed: unexpected signature payload shape"
renderVerificationError MissingHashAlgorithm =
"verification failed: signature payload is missing hash algorithm"
renderVerificationError (HashComputationFailed err) =
"verification failed: hash computation error (" ++ err ++ ")"
renderVerificationError UnexpectedKeyVersion =
"verification failed: signing key has unexpected version (only v4 and v6 are supported)"
renderVerificationError (SignatureHashUnsupportedByAlgorithm ha pka) =
"verification failed: hash algorithm " ++ show ha ++
" is not supported by " ++ show pka ++ " signing backend"
renderVerificationError KeyRevoked =
"verification failed: signing key is revoked"
renderVerificationError SigningKeyUnavailableAtSignatureTime =
"verification failed: signing key was not valid at the signature creation time"
renderVerificationError MissingIssuer =
"verification failed: signature is missing issuer information"
renderVerificationError (SigningKeyNotFound meoki mfp) =
"verification failed: signing key not found in keyring" ++ issuerContext meoki mfp
renderVerificationError (MultipleVerificationSuccesses n) =
"verification failed: multiple successful key matches (" ++ show n ++ ")"
renderVerificationError (UnsupportedKeyType pka) =
"verification failed: unsupported public key algorithm for verification (" ++ show pka ++ ")"
renderVerificationError (SignatureMismatch pka fpr) =
"verification failed: " ++ show pka ++ " signature mismatch (signer " ++ show fpr ++ ")"
renderVerificationError (SignatureShapeMismatch pka) =
"verification failed: malformed " ++ show pka ++ " signature encoding"
renderVerificationError (SignatureEncodingInvalid pka err) =
"verification failed: invalid " ++ show pka ++ " key/signature encoding (" ++ err ++ ")"
renderVerificationError (SignaturePolicyHashUnsupported ha) =
"verification failed: unsupported signature hash policy (" ++ show ha ++ ")"
renderVerificationError (SignaturePolicyPKAMismatch sigPka keyPka) =
"verification failed: signature public-key algorithm " ++
show sigPka ++ " does not match key algorithm " ++ show keyPka
renderVerificationError SignatureExpired =
"verification failed: signature expired"
renderVerificationError (CandidateKeyFailures errs) =
"verification failed: no candidate key validated the signature (" ++
intercalate "; " (nub (map renderVerificationError errs)) ++
")"
renderVerificationError (InvalidSubkeyBackSignature err) =
"verification failed: embedded primary-key back-signature verification failed: " ++
renderVerificationError err
issuerContext ::
Maybe EightOctetKeyId -> Maybe Fingerprint -> String
issuerContext meoki mfp =
case (meoki, mfp) of
(Nothing, Nothing) -> ""
_ ->
" (issuer-keyid=" ++
maybe "unknown" show meoki ++
", issuer-fingerprint=" ++
maybe "unknown" show mfp ++
")"
verificationError :: VerificationError -> Either VerificationError a
verificationError = Left
renderVerificationResult :: Either VerificationError a -> Either String a
renderVerificationResult = first renderVerificationError
data SignError
= SignBackendError String
| SignUnsupportedCertificationType SigType
| SignUnsupportedKeySignatureType SigType
| SignV6SaltSizeMismatch HashAlgorithm Word8 Int
| SignProducedWrongLength String Int Int
deriving (Eq, Show)
renderSignError :: SignError -> String
renderSignError (SignBackendError err) =
"signature backend error: " ++ err
renderSignError (SignUnsupportedCertificationType st) =
"unsupported certification signature type: " ++
show st ++
" (expected one of GenericCert/PersonaCert/CasualCert/PositiveCert)"
renderSignError (SignUnsupportedKeySignatureType st) =
"unsupported key signature type: " ++
show st ++
" (expected SignatureDirectlyOnAKey or KeyRevocationSig)"
renderSignError (SignV6SaltSizeMismatch ha expected actual) =
"v6 signature salt size mismatch for " ++
show ha ++
": expected " ++ show expected ++ ", got " ++ show actual
renderSignError (SignProducedWrongLength algo expected actual) =
algo ++ " produced a non-" ++ show expected ++ "-byte signature (got " ++ show actual ++ ")"
data VerifiableSignatureV where
VerifiableSignatureV4 :: SignaturePayloadV 'SigPayloadV4 -> VerifiableSignatureV
VerifiableSignatureV6 :: SignaturePayloadV 'SigPayloadV6 -> VerifiableSignatureV
fromSignaturePayloadVerifiableSignatureV ::
SignaturePayload -> Maybe VerifiableSignatureV
fromSignaturePayloadVerifiableSignatureV sigPayload =
case toSomeSignaturePayload sigPayload of
SomeSignaturePayload (payload@SigPayloadV4Data {}) ->
Just (VerifiableSignatureV4 payload)
SomeSignaturePayload (payload@SigPayloadV6Data {}) ->
Just (VerifiableSignatureV6 payload)
_ -> Nothing
isVerifiableSignaturePayload :: SignaturePayload -> Bool
isVerifiableSignaturePayload = isJust . fromSignaturePayloadVerifiableSignatureV
toSignaturePayloadFromVerifiable :: VerifiableSignatureV -> SignaturePayload
toSignaturePayloadFromVerifiable (VerifiableSignatureV4 payload) =
toSignaturePayload payload
toSignaturePayloadFromVerifiable (VerifiableSignatureV6 payload) =
toSignaturePayload payload
fromPktEitherVerifiableSignatureV :: Pkt -> Either VerificationError VerifiableSignatureV
fromPktEitherVerifiableSignatureV (SignaturePkt sigPayload) =
case fromSignaturePayloadVerifiableSignatureV sigPayload of
Just verifiableSig -> Right verifiableSig
Nothing ->
verificationError UnexpectedSignaturePayloadShape
fromPktEitherVerifiableSignatureV _ =
verificationError NonSignaturePacket
signaturePKAAndMPIsFromClass ::
SomeSignatureV
-> Either VerificationError (PubKeyAlgorithm, NonEmpty MPI)
signaturePKAAndMPIsFromClass =
fmap (\(pka, _, mpis) -> (pka, mpis)) . signatureVerificationMaterialFromClass
signatureLeft16FromClass :: SomeSignatureV -> Either VerificationError Word16
signatureLeft16FromClass =
fmap (\(_, l16, _) -> l16) . signatureVerificationMaterialFromClass
signatureVerificationMaterialFromClass ::
SomeSignatureV
-> Either VerificationError (PubKeyAlgorithm, Word16, NonEmpty MPI)
signatureVerificationMaterialFromClass (SomeSignatureV typedSig) =
case typedSig of
SignatureV3Packet (SigPayloadV3Data _ _ _ pka _ l16 mpis) ->
Right (pka, l16, mpis)
SignatureV4Packet (SigPayloadV4Data _ pka _ _ _ l16 mpis) ->
Right (pka, l16, mpis)
SignatureV6Packet (SigPayloadV6Data _ pka _ _ _ _ l16 mpis) ->
Right (pka, l16, mpis)
_ ->
verificationError UnexpectedSignaturePayloadShape
verifySigWith ::
(Pkt -> Maybe UTCTime -> ByteString -> Either VerificationError Verification)
-> Pkt
-> PktStreamContext
-> Maybe UTCTime
-> Either VerificationError Verification
verifySigWith vf sig@(SignaturePkt _) state mt =
case fromPktEitherVerifiableSignatureV sig of
Right verifiableSig ->
let (st, hs, us, checkSubpacket, checkUnhashedSubpackets) =
verifiableSignatureVerificationInputs verifiableSig
in checkUnhashedSubpackets us *>
verifyWithSubpacketChecks vf sig state mt st hs checkSubpacket
Left err ->
Left err
where
checkV4Subpacket signer i@Issuer {} = checkIssuerSubpacket (eightOctetKeyID signer) i
checkV4Subpacket signer i@IssuerFingerprint {} =
checkIssuerFingerprintSubpacket PKA.IssuerFingerprintV4 (fingerprint signer) i
checkV4Subpacket _ _ = Right True
-- RFC 9580 §5.2.3.35: v6 signatures MUST NOT include an Issuer Key ID subpacket.
-- Treat any such subpacket as a verification error rather than merely uncheckable.
checkV6Subpacket _ Issuer {} =
verificationError IssuerKeyIdProhibitedInV6Signature
checkV6Subpacket signer i@IssuerFingerprint {} =
checkIssuerFingerprintSubpacket PKA.IssuerFingerprintV6 (fingerprint signer) i
checkV6Subpacket _ _ = Right True
rejectV6UnhashedIssuer (SigSubPacket _ Issuer {}) =
verificationError IssuerKeyIdProhibitedInV6Signature
rejectV6UnhashedIssuer _ = Right ()
verifiableSignatureVerificationInputs ::
VerifiableSignatureV
->
( SigType
, [SigSubPacket]
, [SigSubPacket]
, SomePKPayload -> SigSubPacketPayload -> Either VerificationError Bool
, [SigSubPacket] -> Either VerificationError ()
)
verifiableSignatureVerificationInputs
(VerifiableSignatureV4 (SigPayloadV4Data st _ _ hs us _ _)) =
(st, hs, us, checkV4Subpacket, const (Right ()))
verifiableSignatureVerificationInputs
(VerifiableSignatureV6 (SigPayloadV6Data st _ _ _ hs us _ _)) =
(st, hs, us, checkV6Subpacket, mapM_ rejectV6UnhashedIssuer)
verifySigWith _ _ _ _ =
verificationError NonSignaturePacket
verifyWithSubpacketChecks ::
(Pkt -> Maybe UTCTime -> ByteString -> Either VerificationError Verification)
-> Pkt
-> PktStreamContext
-> Maybe UTCTime
-> SigType
-> [SigSubPacket]
-> (SomePKPayload -> SigSubPacketPayload -> Either VerificationError Bool)
-> Either VerificationError Verification
verifyWithSubpacketChecks vf sig state mt sigType hashedSubpackets checkSubpacket = do
mapM_ (rejectUnsupportedCriticalSubpacket sigType) hashedSubpackets
v <- vf sig mt (payloadForSig sigType state)
mapM_ (checkSubpacket (v ^. verificationSigner) . _sspPayload) hashedSubpackets
warnings <-
if sigType == SubkeyBindingSig
then verifySubkeyBackSignatures state mt hashedSubpackets
else Right []
isSignatureExpired sig mt *>
pure
(v
{ _verificationWarnings =
_verificationWarnings v ++ warnings
})
-- | Verify embedded primary-key back-signatures (PrimaryKeyBindingSig, 0x19)
-- found in the hashed subpackets of a SubkeyBindingSig.
--
-- Per RFC 9580 §5.2.3.3, a signing-capable subkey MUST include an embedded
-- PrimaryKeyBindingSig (0x19) made by the subkey. This requirement is
-- enforced strictly for v6 subkeys. For v4 subkeys we still verify any
-- embedded back-sigs that are present, but do not reject a missing one —
-- real-world v4 signing subkeys predate the strict cross-certification
-- mandate and widespread interoperability requires accepting them.
verifySubkeyBackSignatures ::
PktStreamContext
-> Maybe UTCTime
-> [SigSubPacket]
-> Either VerificationError [VerificationWarning]
verifySubkeyBackSignatures state mt hashedSubpackets = do
subkeyPKP <-
maybe
(verificationError NonSignaturePacket)
Right
(subkeyPKPFromPkt (lastSubkey state))
let embeddedSigs =
[ sp
| SigSubPacket _ (EmbeddedSignature sp) <- hashedSubpackets
]
isSigningCapable =
any
(\(SigSubPacket _ payload) ->
case payload of
KeyFlags flags -> SignDataKey `Set.member` flags
_ -> False)
hashedSubpackets
isV6Subkey = _keyVersion subkeyPKP == V6
case embeddedSigs of
[] ->
-- Require back-sig only for v6 signing subkeys (RFC 9580 §5.2.3.3).
if isSigningCapable && isV6Subkey
then Right [MissingSubkeyBackSignatureWarning]
else Right []
_ ->
-- Always verify back-sigs that are present, regardless of key version.
mapM_ (verifyOneBackSig subkeyPKP) embeddedSigs *> Right []
where
verifyOneBackSig subkeyPKP embSigPayload = do
let embSigPkt = SignaturePkt embSigPayload
backSigContext =
emptyPSC
{ lastPrimaryKey = lastPrimaryKey state
, lastSubkey = lastSubkey state
}
case verifyAgainstKey' subkeyPKP embSigPkt mt
(payloadForSig PrimaryKeyBindingSig backSigContext) of
Left err -> verificationError (InvalidSubkeyBackSignature err)
Right _ -> Right ()
rejectUnsupportedCriticalSubpacket :: SigType -> SigSubPacket -> Either VerificationError ()
rejectUnsupportedCriticalSubpacket sigType (SigSubPacket isCritical payload)
| not isCritical = Right ()
| not (isBindingSignatureType sigType) = Right ()
| otherwise =
case payload of
UserDefinedSigSub {} -> verificationError (UnsupportedCriticalSubpacket sigType)
OtherSigSub {} -> verificationError (UnsupportedCriticalSubpacket sigType)
_ -> Right ()
isBindingSignatureType :: SigType -> Bool
isBindingSignatureType SubkeyBindingSig = True
isBindingSignatureType PrimaryKeyBindingSig = True
isBindingSignatureType _ = False
checkIssuerSubpacket ::
Either String EightOctetKeyId
-> SigSubPacketPayload
-> Either VerificationError Bool
checkIssuerSubpacket (Right signer) (Issuer i)
| signer == i = Right True
| otherwise = verificationError IssuerSubpacketMismatch
checkIssuerSubpacket (Left err) (Issuer _) =
verificationError (IssuerSubpacketUncheckable err)
checkIssuerSubpacket _ _ = Right True
checkIssuerFingerprintSubpacket ::
IssuerFingerprintVersion -> Fingerprint -> SigSubPacketPayload -> Either VerificationError Bool
checkIssuerFingerprintSubpacket expectedVersion signer (IssuerFingerprint kv i)
| kv /= expectedVersion = verificationError IssuerFingerprintSubpacketMismatch
| signer == i = Right True
| otherwise = verificationError IssuerFingerprintSubpacketMismatch
checkIssuerFingerprintSubpacket _ _ _ = Right True
verifyTKWith ::
(Pkt -> PktStreamContext -> Maybe UTCTime -> Either VerificationError Verification)
-> Maybe UTCTime
-> TK k
-> Either VerificationError (TK k)
verifyTKWith vsf mt tk = do
verifiedUnknown <- verifyUnknownTKWith vsf mt (tkToUnknown tk)
let typedSubkeys = Map.fromList [ (keyPktToPkt kp, kp) | (kp, _) <- tk ^. tkSubs ]
verifiedTypedSubkeys =
mapMaybe
(\(pkt, sigs) -> (\kp -> (kp, sigs)) <$> Map.lookup pkt typedSubkeys)
(verifiedUnknown ^. tkuSubs)
pure
TK
{ _tkPrimaryKey = tk ^. tkPrimaryKey
, _tkRevs = verifiedUnknown ^. tkuRevs
, _tkUIDs = verifiedUnknown ^. tkuUIDs
, _tkUAts = verifiedUnknown ^. tkuUAts
, _tkSubs = verifiedTypedSubkeys
}
verifyUnknownTKWith ::
(Pkt -> PktStreamContext -> Maybe UTCTime -> Either VerificationError Verification)
-> Maybe UTCTime
-> TKUnknown
-> Either VerificationError TKUnknown
verifyUnknownTKWith vsf mt tk = do
revokers <- checkRevokers tk
revs <- checkKeyRevocations revokers tk
let uids = filter (not . null . snd) . checkUidSigs $ tk ^. tkuUIDs
let uats = filter (not . null . snd) . checkUAtSigs $ tk ^. tkuUAts
let subs = concatMap checkSub $ tk ^. tkuSubs
return (TKUnknown (tk ^. tkuKey) revs uids uats subs)
where
checkRevokers =
Right . concat . rights . map verifyRevoker . filter isRevokerP . _tkuRevs
checkKeyRevocations ::
[(PubKeyAlgorithm, Fingerprint)]
-> TKUnknown
-> Either VerificationError [SignaturePayload]
checkKeyRevocations rs k =
Prelude.sequence . concatMap (filterRevs rs) . rights .
map (liftM2 fmap (,) vSig) $
k ^.
tkuRevs
checkUidSigs :: [(Text, [SignaturePayload])] -> [(Text, [SignaturePayload])]
checkUidSigs =
map
(\(uid, sps) ->
let verified = rights . map (\sp -> fmap ((,) sp) (vUid (uid, sp))) $ sps
in (uid, retainNonRevokedCertifications mt verified))
checkUAtSigs ::
[([UserAttrSubPacket], [SignaturePayload])]
-> [([UserAttrSubPacket], [SignaturePayload])]
checkUAtSigs =
map
(\(uat, sps) ->
let verified = rights . map (\sp -> fmap ((,) sp) (vUAt (uat, sp))) $ sps
in (uat, retainNonRevokedCertifications mt verified))
checkSub :: (Pkt, [SignaturePayload]) -> [(Pkt, [SignaturePayload])]
checkSub (pkt, sps) =
if revokedSub pkt sps
then []
else checkSub' pkt sps
revokedSub :: Pkt -> [SignaturePayload] -> Bool
revokedSub _ [] = False
revokedSub p sigs =
any (vSubSig p) (filter subkeyRevocationEffective sigs)
checkSub' :: Pkt -> [SignaturePayload] -> [(Pkt, [SignaturePayload])]
checkSub' p sps =
let goodsigs =
filter (vSubSig p) .
filter signatureKnown .
filter isSubkeyBindingSig $
sps
in if null goodsigs
then []
else [(p, goodsigs)]
getHasheds = signatureHashedSubpackets
filterRevs ::
[(PubKeyAlgorithm, Fingerprint)]
-> (SignaturePayload, Verification)
-> [Either VerificationError SignaturePayload]
filterRevs vokers spv =
case spv of
(s, _)
| isV4OrV6Sig s && sigType s == Just SignatureDirectlyOnAKey ->
[Right s | signatureKnown s]
(s, v)
| isV4OrV6Sig s
, sigType s == Just KeyRevocationSig
, Just pka <- sigPKA s ->
if (v ^. verificationSigner == tk ^. tkuKey . _1) ||
any
(\(p, f) ->
p == pka && f == fingerprint (v ^. verificationSigner))
vokers
then
if keyRevocationEffective s
then [verificationError KeyRevoked]
else [Right s | signatureKnown s]
else [Right s | signatureKnown s]
_ -> []
isV4OrV6Sig = isVerifiableSignaturePayload
vUid :: (Text, SignaturePayload) -> Either VerificationError Verification
vUid (uid, sp) =
vsf
(SignaturePkt sp)
emptyPSC
{ lastPrimaryKey = PublicKeyPkt (tk ^. tkuKey . _1)
, lastUIDorUAt = UserIdPkt uid
}
Nothing
vUAt ::
([UserAttrSubPacket], SignaturePayload) -> Either VerificationError Verification
vUAt (uat, sp) =
vsf
(SignaturePkt sp)
emptyPSC
{ lastPrimaryKey = PublicKeyPkt (tk ^. tkuKey . _1)
, lastUIDorUAt = UserAttributePkt uat
}
Nothing
vSig :: SignaturePayload -> Either VerificationError Verification
vSig sp =
vsf
(SignaturePkt sp)
emptyPSC {lastPrimaryKey = PublicKeyPkt (tk ^. tkuKey . _1)}
Nothing
vSubSig :: Pkt -> SignaturePayload -> Bool
vSubSig sk sp =
isRight
(vsf
(SignaturePkt sp)
emptyPSC
{ lastPrimaryKey = PublicKeyPkt (tk ^. tkuKey . _1)
, lastSubkey = sk
}
mt)
verifyRevoker ::
SignaturePayload
-> Either VerificationError [(PubKeyAlgorithm, Fingerprint)]
verifyRevoker sp =
vSig sp *>
pure
(map (\(SigSubPacket _ (RevocationKey _ pka fp)) -> (pka, fp)) .
filter isRevocationKeySSP $
getHasheds sp)
retainNonRevokedCertifications ::
Maybe UTCTime -> [(SignaturePayload, Verification)] -> [SignaturePayload]
retainNonRevokedCertifications validationTime verified =
map fst $
filter
((== CertificationActive) . certificationStateAt validationTime verified)
certifications
where
certifications = filter (not . isCertRevocationSig . fst) verified
signatureKnown = signatureKnownAt mt
subkeyRevocationEffective sp = isSubkeyRevocation sp && signatureEffectiveAt mt sp
keyRevocationEffective sp
| isHistoricalKeyRevocation sp = signatureEffectiveAt mt sp
| otherwise = signatureUnexpiredAt mt sp
verifyAgainstKeyring ::
PublicKeyring -> Pkt -> Maybe UTCTime -> ByteString -> Either VerificationError Verification
verifyAgainstKeyring kr sig mt payload = do
let allKeys = map tkToUnknown (IxSet.toList kr)
signerValidationTime = signatureCreationTimeFromPacket sig
ikeys = (kr @=) <$> issuer sig
ifpkeys = (kr @=) <$> issuerFP sig
hintedKeys = maybe [] (map tkToUnknown . IxSet.toList) (ifpkeys <|> ikeys)
hintedResult =
if null hintedKeys
then Left MissingIssuer
else verifyFromCandidates allKeys hintedKeys sig signerValidationTime mt payload
in case hintedResult of
Right v -> Right v
Left hintedErr ->
let fallbackResult =
verifyFromCandidates allKeys allKeys sig signerValidationTime mt payload
in if null hintedKeys
then
case fallbackResult of
Right v -> Right v
Left _ ->
verificationError (SigningKeyNotFound (issuer sig) (issuerFP sig))
else
case fallbackResult of
Right v -> Right v
Left _ -> Left hintedErr
verifyFromCandidates ::
[TKUnknown]
-> [TKUnknown]
-> Pkt
-> Maybe UTCTime
-> Maybe UTCTime
-> ByteString
-> Either VerificationError Verification
verifyFromCandidates allKeys candidateTks sig signerValidationTime verificationTime payload =
let candidateResults =
map
(resolveCandidateSignerPKPs allKeys sig signerValidationTime (const True))
candidateTks
candidateErrors = concatMap fst candidateResults
usablePkps = concatMap snd candidateResults
in if null usablePkps
then
if null candidateErrors
then verificationError (SigningKeyNotFound (issuer sig) (issuerFP sig))
else verificationError (CandidateKeyFailures candidateErrors)
else
case verifyAgainstPKPs usablePkps sig verificationTime payload of
Left (CandidateKeyFailures errs)
| not (null candidateErrors) ->
verificationError (CandidateKeyFailures (candidateErrors ++ errs))
other -> other
verifyAgainstKeys ::
[TKUnknown] -> Pkt -> Maybe UTCTime -> ByteString -> Either VerificationError Verification
verifyAgainstKeys ks sig mt payload = do
let allpkps =
filter
(\x ->
(((fingerprint x ==) <$> issuerFP sig) == Just True) ||
((==) <$> issuer sig <*> hush (eightOctetKeyID x)) ==
Just True)
(concatMap (\x -> (x ^. tkuKey . _1) : mapMaybe (subkeyPKPFromPkt . fst) (_tkuSubs x)) ks)
allCandidatePkps =
concatMap (\x -> (x ^. tkuKey . _1) : mapMaybe (subkeyPKPFromPkt . fst) (_tkuSubs x)) ks
normalizedCandidates
| null allpkps = allCandidatePkps
| otherwise = allpkps
verifyAgainstPKPs normalizedCandidates sig mt payload
verifyAgainstPKPs ::
[SomePKPayload] -> Pkt -> Maybe UTCTime -> ByteString -> Either VerificationError Verification
verifyAgainstPKPs pkps sig mt payload =
case rights results of
[] -> verificationError (CandidateKeyFailures (lefts results))
[r] -> isSignatureExpired sig mt *> pure r
rs -> verificationError (MultipleVerificationSuccesses (length rs))
where
results = map (\pkp -> verifyAgainstKey' pkp sig mt payload) pkps
resolveCandidateSignerPKPs ::
[TKUnknown]
-> Pkt
-> Maybe UTCTime
-> (SomePKPayload -> Bool)
-> TKUnknown
-> ([VerificationError], [SomePKPayload])
resolveCandidateSignerPKPs _ _ Nothing matchesP tk =
([], filter matchesP (candidatePKPs tk))
resolveCandidateSignerPKPs allKeys _ (Just validationTime) matchesP tk =
let rawMatches = filter matchesP (candidatePKPs tk)
in case verifyUnknownTKWith (verifySigWith (verifyAgainstKeys allKeys)) (Just validationTime) tk of
Left err -> (replicate (length rawMatches) err, [])
Right verifiedTK ->
let verifiedMatches =
map
(\pkp ->
case historicallyValidSigner validationTime (timelineValidationTK pkp verifiedTK) pkp of
Right () -> Right pkp
Left err -> Left err)
rawMatches
in (lefts verifiedMatches, rights verifiedMatches)
where
timelineValidationTK pkp verifiedTK'
| fingerprint pkp == fingerprint (tk ^. tkuKey . _1) = tk
| otherwise = verifiedTK'
candidatePKPs :: TKUnknown -> [SomePKPayload]
candidatePKPs tk = (tk ^. tkuKey . _1) : mapMaybe (subkeyPKPFromPkt . fst) (tk ^. tkuSubs)
historicallyValidSigner ::
UTCTime -> TKUnknown -> SomePKPayload -> Either VerificationError ()
historicallyValidSigner validationTime tk pkp
| fingerprint pkp == fingerprint (tk ^. tkuKey . _1) =
if keyStateValid (keyStateAt validationTime tk)
then Right ()
else verificationError SigningKeyUnavailableAtSignatureTime
| otherwise =
case find (\(pkt, _) -> maybe False ((== fingerprint pkp) . fingerprint) (subkeyPKPFromPkt pkt)) (tk ^. tkuSubs) of
Nothing -> verificationError SigningKeyUnavailableAtSignatureTime
Just (subPkt, sigs) ->
case subkeyPKPFromPkt subPkt of
Nothing -> verificationError SigningKeyUnavailableAtSignatureTime
Just subPKP ->
if isPKTimeValidWithSelfSignatures validationTime subPKP sigs
then Right ()
else verificationError SigningKeyUnavailableAtSignatureTime
signatureCreationTimeFromPacket :: Pkt -> Maybe UTCTime
signatureCreationTimeFromPacket (SignaturePkt sigPayload) = signatureCreationTime sigPayload
signatureCreationTimeFromPacket _ = Nothing
signatureCreationTime :: SignaturePayload -> Maybe UTCTime
signatureCreationTime =
fmap (posixSecondsToUTCTime . realToFrac . unThirtyTwoBitTimeStamp) . sigCT
signatureKnownAt :: Maybe UTCTime -> SignaturePayload -> Bool
signatureKnownAt Nothing _ = True
signatureKnownAt (Just validationTime) sigPayload =
maybe False (<= validationTime) (signatureCreationTime sigPayload)
signatureEffectiveAt :: Maybe UTCTime -> SignaturePayload -> Bool
signatureEffectiveAt Nothing _ = True
signatureEffectiveAt (Just validationTime) sigPayload =
signatureKnownAt (Just validationTime) sigPayload &&
maybe True (validationTime <) (signatureExpirationTime sigPayload)
signatureUnexpiredAt :: Maybe UTCTime -> SignaturePayload -> Bool
signatureUnexpiredAt Nothing _ = True
signatureUnexpiredAt (Just validationTime) sigPayload =
maybe True (validationTime <) (signatureExpirationTime sigPayload)
signatureExpirationTime :: SignaturePayload -> Maybe UTCTime
signatureExpirationTime sigPayload =
addDurationToTime <$>
signatureCreationTime sigPayload <*>
signatureExpirationDuration sigPayload
signatureExpirationDuration :: SignaturePayload -> Maybe ThirtyTwoBitDuration
signatureExpirationDuration sigPayload =
signatureHashedSubpacketsKnown sigPayload >>= firstSignatureExpirationDuration
firstSignatureExpirationDuration :: [SigSubPacket] -> Maybe ThirtyTwoBitDuration
firstSignatureExpirationDuration =
foldr
(\subpacket acc ->
case subpacket of
SigSubPacket _ (SigExpirationTime duration) -> Just duration
_ -> acc)
Nothing
addDurationToTime :: UTCTime -> ThirtyTwoBitDuration -> UTCTime
addDurationToTime baseTime duration =
addUTCTime (fromIntegral (unThirtyTwoBitDuration duration)) baseTime
certificationStateAt ::
Maybe UTCTime
-> [(SignaturePayload, Verification)]
-> (SignaturePayload, Verification)
-> CertificationState
certificationStateAt validationTime verified certification@(certificationSig, _)
| not (signatureKnownAt validationTime certificationSig) = CertificationNotYetKnown
| not (signatureEffectiveAt validationTime certificationSig) = CertificationRevoked
| any (`revokesCertification` certification) visibleRevocations = CertificationRevoked
| otherwise = CertificationActive
where
visibleRevocations =
filter
(signatureEffectiveAt validationTime . fst)
(filter (isCertRevocationSig . fst) verified)
revokesCertification ::
(SignaturePayload, Verification)
-> (SignaturePayload, Verification)
-> Bool
revokesCertification (revocationSig, revocationVerification) (certificationSig, certificationVerification) =
sameSigner && certificationPrecedesRevocation certificationSig revocationSig
where
sameSigner =
fingerprint (revocationVerification ^. verificationSigner) ==
fingerprint (certificationVerification ^. verificationSigner)
certificationPrecedesRevocation ::
SignaturePayload -> SignaturePayload -> Bool
certificationPrecedesRevocation certificationSig revocationSig =
case (signatureCreationTime certificationSig, signatureCreationTime revocationSig) of
(Just certificationTime, Just revocationTime) ->
certificationTime < revocationTime
_ -> False
isHistoricalKeyRevocation :: SignaturePayload -> Bool
isHistoricalKeyRevocation sigPayload =
case revocationReasonCode sigPayload of
Just KeySuperseded -> True
Just KeyRetiredAndNoLongerUsed -> True
Just UserIdInfoNoLongerValid -> True
_ -> False
revocationReasonCode :: SignaturePayload -> Maybe RevocationCode
revocationReasonCode sigPayload =
(\(SigSubPacket _ (ReasonForRevocation reasonCode _)) -> reasonCode) <$>
find isReasonForRevocation (signatureSubpackets sigPayload)
where
isReasonForRevocation (SigSubPacket _ ReasonForRevocation {}) = True
isReasonForRevocation _ = False
signatureSubpackets :: SignaturePayload -> [SigSubPacket]
signatureSubpackets sigPayload =
case signatureSubpacketListsKnown sigPayload of
Just (hashed, unhashed) -> hashed ++ unhashed
Nothing -> []
signatureHashedSubpackets :: SignaturePayload -> [SigSubPacket]
signatureHashedSubpackets sigPayload =
maybe [] id (signatureHashedSubpacketsKnown sigPayload)
subkeyPKPFromPkt :: Pkt -> Maybe SomePKPayload
subkeyPKPFromPkt (PublicSubkeyPkt p) = Just p
subkeyPKPFromPkt (SecretSubkeyPkt p _) = Just p
subkeyPKPFromPkt _ = Nothing
verifyAgainstKey' :: SomePKPayload -> Pkt -> Maybe UTCTime -> ByteString -> Either VerificationError Verification
verifyAgainstKey' pkp sig mt payload = do
sigClass <-
either
(verificationError . const NonSignaturePacket)
Right
(fromPktEitherSomeSignatureV sig)
let sigPayload =
case sigClass of
SomeSignatureV typedSig -> signaturePayloadFromSignatureV typedSig
sigHash <-
maybe
(verificationError MissingHashAlgorithm)
Right
(sigHA sigPayload)
sigDetails <- signaturePKAAndMPIsFromClass sigClass
enforcePKACompatibility sigPayload
enforceSignatureHashPolicy sigHash
_ <- isSignatureExpired sig mt
let signedPayload = BL.toStrict (finalPayload sig payload)
enforceLeft16Prefix sigClass sigHash signedPayload
(\verifiedSigner -> Verification verifiedSigner sigPayload []) <$>
verify' sigDetails pkp sigHash signedPayload
where
enforcePKACompatibility sigPayload =
let sigPka = maybe (OtherPKA 0) id (sigPKA sigPayload)
keyPka = _pkalgo pkp
in if pkaCompatible sigPka keyPka
then Right ()
else verificationError (SignaturePolicyPKAMismatch sigPka keyPka)
enforceSignatureHashPolicy sigHash =
case sigHash of
OtherHA {} -> verificationError (SignaturePolicyHashUnsupported sigHash)
_ -> Right ()
enforceLeft16Prefix sigClass sigHash signedPayload = do
expectedLeft16 <-
either
(verificationError . HashComputationFailed)
Right
(left16FromSignedPayload sigHash signedPayload)
actualLeft16 <- signatureLeft16FromClass sigClass
if actualLeft16 == expectedLeft16
then Right ()
else
verificationError
(SignatureMismatch (_pkalgo pkp) (fingerprint pkp))
pkaCompatible RSA keyPka =
keyPka `elem` [RSA, DeprecatedRSAEncryptOnly, DeprecatedRSASignOnly]
pkaCompatible DeprecatedRSASignOnly keyPka =
keyPka `elem` [RSA, DeprecatedRSASignOnly]
pkaCompatible PKA.EdDSA keyPka =
keyPka `elem` [PKA.EdDSA, PKA.Ed25519, PKA.Ed448]
pkaCompatible PKA.Ed25519 keyPka =
keyPka `elem` [PKA.EdDSA, PKA.Ed25519]
pkaCompatible PKA.Ed448 keyPka =
keyPka `elem` [PKA.EdDSA, PKA.Ed448]
pkaCompatible sigPka keyPka = sigPka == keyPka
verify' details pub@(PKPayload V4 _ _ _ pkey) ha pl =
verifyByHash details pub pkey ha pl
verify' details pub@(PKPayload V6 _ _ _ pkey) ha pl =
verifyByHash details pub pkey ha pl
verify' _ _ _ _ =
verificationError UnexpectedKeyVersion
verifyByHash details pub pkey ha pl =
case ha of
SHA1 -> verify'' details CHA.SHA1 pub pkey pl
RIPEMD160 -> verify'' details CHA.RIPEMD160 pub pkey pl
SHA224 -> verify'' details CHA.SHA224 pub pkey pl
SHA256 -> verify'' details CHA.SHA256 pub pkey pl
SHA384 -> verify'' details CHA.SHA384 pub pkey pl
SHA512 -> verify'' details CHA.SHA512 pub pkey pl
SHA3_256 -> verifyNoRSA SHA3_256 details CHA.SHA3_256 pub pkey pl
SHA3_512 -> verifyNoRSA SHA3_512 details CHA.SHA3_512 pub pkey pl
DeprecatedMD5 -> verify'' details CHA.MD5 pub pkey pl
_ ->
verificationError (SignaturePolicyHashUnsupported ha)
verify'' (DSA, mpis) hd pub (DSAPubKey (DSA_PublicKey pkey)) bs =
dsaVerify pub mpis hd pkey bs
verify'' (ECDSA, mpis) hd pub (ECDSAPubKey (ECDSA_PublicKey pkey)) bs =
ecdsaVerify pub mpis hd pkey bs
verify'' (sigPka, mpis) hd pub (EdDSAPubKey Ed25519 pkey) bs
| sigPka `elem` [EdDSA, PKA.Ed25519] =
ed25519Verify sigPka pub mpis hd pkey bs
verify'' (sigPka, mpis) hd pub (EdDSAPubKey Ed448 pkey) bs
| sigPka `elem` [EdDSA, PKA.Ed448] =
ed448Verify sigPka pub mpis hd pkey bs
verify'' (RSA, mpis) hd pub (RSAPubKey (RSA_PublicKey pkey)) bs =
rsaVerify pub mpis hd pkey bs
verify'' (pka, _) _ _ _ _ = verificationError (UnsupportedKeyType pka)
verifyNoRSA ha' (DSA, mpis) hd pub (DSAPubKey (DSA_PublicKey pkey)) bs =
dsaVerify pub mpis hd pkey bs
verifyNoRSA ha' (ECDSA, mpis) hd pub (ECDSAPubKey (ECDSA_PublicKey pkey)) bs =
ecdsaVerify pub mpis hd pkey bs
verifyNoRSA ha' (sigPka, mpis) hd pub (EdDSAPubKey Ed25519 pkey) bs
| sigPka `elem` [EdDSA, PKA.Ed25519] =
ed25519Verify sigPka pub mpis hd pkey bs
verifyNoRSA ha' (sigPka, mpis) hd pub (EdDSAPubKey Ed448 pkey) bs
| sigPka `elem` [EdDSA, PKA.Ed448] =
ed448Verify sigPka pub mpis hd pkey bs
verifyNoRSA ha' (RSA, _) _ _ _ _ =
verificationError (SignatureHashUnsupportedByAlgorithm ha' RSA)
verifyNoRSA _ (pka, _) _ _ _ _ = verificationError (UnsupportedKeyType pka)
dsaVerify pub (r :| [s]) hd pkey bs =
if DSA.verify hd pkey (dsaMPIsToSig r s) bs
then Right pub
else verificationError (SignatureMismatch DSA (fingerprint pub))
dsaVerify _ _ _ _ _ = verificationError (SignatureShapeMismatch DSA)
ecdsaVerify pub (r :| [s]) hd pkey bs =
if ECDSA.verify hd pkey (ecdsaMPIsToSig r s) bs
then Right pub
else verificationError (SignatureMismatch ECDSA (fingerprint pub))
ecdsaVerify _ _ _ _ _ = verificationError (SignatureShapeMismatch ECDSA)
ed25519Verify sigPka pub (r :| [s]) hd pkey bs =
case edPointToRawPublic 32 pkey of
Left err ->
verificationError (SignatureEncodingInvalid sigPka err)
Right rawPub ->
case cf2es (Ed25519.publicKey rawPub) of
Left err ->
verificationError (SignatureEncodingInvalid sigPka err)
Right ep ->
case cf2es (Ed25519.signature (pad32 (i2osp (unMPI r)) <> pad32 (i2osp (unMPI s)))) of
Left err ->
verificationError (SignatureEncodingInvalid sigPka err)
Right es ->
let prehash = crazyHash hd bs :: B.ByteString
in if Ed25519.verify ep prehash es
then Right pub
else verificationError (SignatureMismatch sigPka (fingerprint pub))
ed25519Verify sigPka _ _ _ _ _ =
verificationError (SignatureShapeMismatch sigPka)
ed448Verify sigPka pub (r :| [s]) hd pkey bs =
case edPointToRawPublic 57 pkey of
Left err ->
verificationError (SignatureEncodingInvalid sigPka err)
Right rawPub ->
case cf2es (Ed448.publicKey rawPub) of
Left err ->
verificationError (SignatureEncodingInvalid sigPka err)
Right ep ->
case cf2es (Ed448.signature (padN 57 (i2osp (unMPI r)) <> padN 57 (i2osp (unMPI s)))) of
Left err ->
verificationError (SignatureEncodingInvalid sigPka err)
Right es ->
let prehash = crazyHash hd bs :: B.ByteString
in if Ed448.verify ep prehash es
then Right pub
else verificationError (SignatureMismatch sigPka (fingerprint pub))
ed448Verify sigPka _ _ _ _ _ =
verificationError (SignatureShapeMismatch sigPka)
edPointToRawPublic expectedLen (NativeEPoint (EPoint x)) =
exactLengthPublic expectedLen "native" (i2osp x)
edPointToRawPublic expectedLen (PrefixedNativeEPoint (EPoint x)) = do
prefixed <- exactLengthPublic (expectedLen + 1) "prefixed-native" (i2osp x)
if B.head prefixed /= 0x40
then Left "prefixed-native EdDSA public key is missing the 0x40 prefix"
else Right (B.tail prefixed)
exactLengthPublic expectedLen label bs
| B.length bs == expectedLen = Right bs
| otherwise =
Left
("invalid " ++ label ++ " EdDSA public key length: expected " ++
show expectedLen ++ " octets, got " ++ show (B.length bs))
pad32 bs =
let l = B.length bs
in if l >= 32
then bs
else B.replicate (32 - l) 0 <> bs
padN n bs =
let l = B.length bs
in if l >= n
then bs
else B.replicate (n - l) 0 <> bs
cf2es = either (Left . show) return . eitherCryptoError
rsaVerify pub mpis hd pkey bs =
if P15.verify (Just hd) pkey bs (rsaMPItoSig pkey mpis)
then Right pub
else verificationError (SignatureMismatch RSA (fingerprint pub))
dsaMPIsToSig r s = DSA.Signature (unMPI r) (unMPI s)
ecdsaMPIsToSig r s = ECDSA.Signature (unMPI r) (unMPI s)
rsaMPItoSig pkey (s :| []) =
let sz = RSATypes.public_size pkey
raw = i2osp (unMPI s)
pad = sz - B.length raw
in B.replicate pad 0 <> raw
crazyHash h = BA.convert . hashWith h
isSignatureExpired :: Pkt -> Maybe UTCTime -> Either VerificationError Bool
isSignatureExpired _ Nothing = return False
isSignatureExpired s (Just t) =
do
sigClass <-
either
(verificationError . const NonSignaturePacket)
Right
(fromPktEitherSomeSignatureV s)
if any
(expiredBefore t)
(signatureHashedSubpackets
(case sigClass of
SomeSignatureV typedSig -> signaturePayloadFromSignatureV typedSig))
then verificationError SignatureExpired
else return True
where
expiredBefore :: UTCTime -> SigSubPacket -> Bool
expiredBefore ct (SigSubPacket _ (SigExpirationTime et)) =
fromEnum ((posixSecondsToUTCTime . toEnum . fromEnum) et `diffUTCTime` ct) <
0
expiredBefore _ _ = False
finalPayload :: Pkt -> ByteString -> ByteString
finalPayload s pl = BL.concat [pl, sigbit, trailer s]
where
sigbit = runPut $ putPartialSigforSigning s
trailer :: Pkt -> ByteString
trailer (SignaturePkt sigPayload) =
maybe
BL.empty
(const (runPut $ putSigTrailer s))
(fromSignaturePayloadVerifiableSignatureV sigPayload)
trailer _ = BL.empty
normalizePayloadForSigType :: SigType -> ByteString -> ByteString
normalizePayloadForSigType CanonicalTextSig =
stripTrailingWhitespacePerLine . canonicalizeLineEndings
normalizePayloadForSigType _ = id
normalizePayloadForSigTypeWith :: TextNormalizationMode -> SigType -> ByteString -> ByteString
normalizePayloadForSigTypeWith CleartextCompat st = normalizePayloadForSigType st
normalizePayloadForSigTypeWith RFC9580Strict CanonicalTextSig = canonicalizeLineEndings
normalizePayloadForSigTypeWith RFC9580Strict _ = id
canonicalizeLineEndings :: ByteString -> ByteString
canonicalizeLineEndings = BL.pack . go . BL.unpack
where
go [] = []
go (0x0d:0x0a:rest) = 0x0d : 0x0a : go rest
go (0x0d:rest) = 0x0d : 0x0a : go rest
go (0x0a:rest) = 0x0d : 0x0a : go rest
go (w:rest) = w : go rest
stripTrailingWhitespacePerLine :: ByteString -> ByteString
stripTrailingWhitespacePerLine = BL.pack . go [] . BL.unpack
where
go lineRev [] = reverseTrimmed lineRev
go lineRev (0x0d:0x0a:rest) =
reverseTrimmed lineRev ++ [0x0d, 0x0a] ++ go [] rest
go lineRev (w:rest) = go (w : lineRev) rest
reverseTrimmed :: [Word8] -> [Word8]
reverseTrimmed = reverse . dropWhile isTrailingWhitespace
isTrailingWhitespace :: Word8 -> Bool
isTrailingWhitespace w = w == 0x20 || w == 0x09
hashWithSHA512 :: B.ByteString -> B.ByteString
hashWithSHA512 = BA.convert . hashWith CHA.SHA512
hashForSignatureAlgorithm :: HashAlgorithm -> B.ByteString -> Either String B.ByteString
hashForSignatureAlgorithm ha bs =
case ha of
SHA1 -> Right (BA.convert (hashWith CHA.SHA1 bs))
RIPEMD160 -> Right (BA.convert (hashWith CHA.RIPEMD160 bs))
SHA224 -> Right (BA.convert (hashWith CHA.SHA224 bs))
SHA256 -> Right (BA.convert (hashWith CHA.SHA256 bs))
SHA384 -> Right (BA.convert (hashWith CHA.SHA384 bs))
SHA512 -> Right (BA.convert (hashWith CHA.SHA512 bs))
SHA3_256 -> Right (BA.convert (hashWith CHA.SHA3_256 bs))
SHA3_512 -> Right (BA.convert (hashWith CHA.SHA3_512 bs))
DeprecatedMD5 -> Right (BA.convert (hashWith CHA.MD5 bs))
_ -> Left ("unsupported hash algorithm for left16 derivation: " ++ show ha)
left16FromHashPrefix :: B.ByteString -> Either String Word16
left16FromHashPrefix bs
| B.length bs >= 2 = Right (fromIntegral (os2ip (B.take 2 bs)))
| otherwise = Left "hash output too short to derive left16"
left16FromSignedPayload :: HashAlgorithm -> B.ByteString -> Either String Word16
left16FromSignedPayload ha signedPayload = do
digest <- hashForSignatureAlgorithm ha signedPayload
left16FromHashPrefix digest
left16FromSignedPayloadForSign :: HashAlgorithm -> B.ByteString -> Either SignError Word16
left16FromSignedPayloadForSign ha =
first SignBackendError . left16FromSignedPayload ha
ed25519Signer :: Ed25519.SecretKey -> B.ByteString -> B.ByteString
ed25519Signer sk prehash =
BA.convert (Ed25519.sign sk (Ed25519.toPublic sk) prehash)
ed448Signer :: Ed448.SecretKey -> B.ByteString -> B.ByteString
ed448Signer sk prehash =
BA.convert (Ed448.sign sk (Ed448.toPublic sk) prehash)
rsaPKCS15Sign ::
HashAlgorithm
-> RSATypes.PrivateKey
-> B.ByteString
-> Either SignError B.ByteString
rsaPKCS15Sign ha prv bytes =
case ha of
SHA1 -> first (SignBackendError . show) (P15.sign Nothing (Just CHA.SHA1) prv bytes)
SHA224 -> first (SignBackendError . show) (P15.sign Nothing (Just CHA.SHA224) prv bytes)
SHA256 -> first (SignBackendError . show) (P15.sign Nothing (Just CHA.SHA256) prv bytes)
SHA384 -> first (SignBackendError . show) (P15.sign Nothing (Just CHA.SHA384) prv bytes)
SHA512 -> first (SignBackendError . show) (P15.sign Nothing (Just CHA.SHA512) prv bytes)
_ ->
Left
(SignBackendError
("signature hash algorithm is not supported by RSA PKCS#1 v1.5 backend: " ++
show ha))
validateV6SaltSize :: HashAlgorithm -> SignatureSalt -> Either SignError ()
validateV6SaltSize ha salt =
let saltBytes = BL.toStrict (unSignatureSalt salt)
actualSaltLen = B.length saltBytes
in case signatureV6SaltSizeForHashAlgorithm ha of
Nothing ->
Left
(SignBackendError
("signature hash algorithm does not define a V6 salt size: " ++ show ha))
Just expectedSaltLen ->
if actualSaltLen == fromIntegral expectedSaltLen
then Right ()
else Left (SignV6SaltSizeMismatch ha expectedSaltLen actualSaltLen)
signEdDSAV4 ::
String
-> Int
-> Int
-> (B.ByteString -> B.ByteString)
-> TextNormalizationMode
-> SigType
-> PubKeyAlgorithm
-> HashAlgorithm
-> [SigSubPacket]
-> [SigSubPacket]
-> ByteString
-> Either SignError SignaturePayload
signEdDSAV4 algoName sigLen limbLen signer mode st pka ha has uhas payload = do
let normalizedPayload = normalizePayloadForSigTypeWith mode st payload
sig0 = SigV4 st pka ha has [] 0 (NE.fromList [MPI 0, MPI 0])
prehash =
hashWithSHA512
(BL.toStrict (finalPayload (SignaturePkt sig0) normalizedPayload))
sigBytes = signer prehash
if B.length sigBytes /= sigLen
then Left (SignProducedWrongLength algoName sigLen (B.length sigBytes))
else
let (r, s) = B.splitAt limbLen sigBytes
in (\left16 ->
SigV4
st
pka
ha
has
uhas
left16
(NE.fromList [MPI (os2ip r), MPI (os2ip s)]))
<$> first SignBackendError (left16FromHashPrefix prehash)
signEdDSAV6 ::
String
-> Int
-> Int
-> (B.ByteString -> B.ByteString)
-> TextNormalizationMode
-> SigType
-> PubKeyAlgorithm
-> HashAlgorithm
-> SignatureSalt
-> [SigSubPacket]
-> [SigSubPacket]
-> ByteString
-> Either SignError SignaturePayload
signEdDSAV6 algoName sigLen limbLen signer mode st pka ha salt has uhas payload = do
validateV6SaltSize ha salt
let normalizedPayload = normalizePayloadForSigTypeWith mode st payload
sig0 = SigV6 st pka ha salt has [] 0 (NE.fromList [MPI 0, MPI 0])
prehash =
hashWithSHA512
(BL.toStrict (finalPayload (SignaturePkt sig0) normalizedPayload))
sigBytes = signer prehash
if B.length sigBytes /= sigLen
then Left (SignProducedWrongLength algoName sigLen (B.length sigBytes))
else
let (r, s) = B.splitAt limbLen sigBytes
in (\left16 ->
SigV6
st
pka
ha
salt
has
uhas
left16
(NE.fromList [MPI (os2ip r), MPI (os2ip s)]))
<$> first SignBackendError (left16FromHashPrefix prehash)
signUserIDwithRSA :: SomePKPayload -- ^ public key "payload" of user ID being signed
-> UserId -- ^ user ID being signed
-> [SigSubPacket] -- ^ hashed signature subpackets
-> [SigSubPacket] -- ^ unhashed signature subpackets
-> RSATypes.PrivateKey -- ^ RSA signing key
-> Either SignError SignaturePayload
signUserIDwithRSA = signCertificationWithRSA PositiveCert
signCertificationWithRSA ::
SigType -- ^ certification type (GenericCert, PersonaCert, CasualCert, PositiveCert)
-> SomePKPayload -- ^ public key "payload" of user ID being signed
-> UserId -- ^ user ID being signed
-> [SigSubPacket] -- ^ hashed signature subpackets
-> [SigSubPacket] -- ^ unhashed signature subpackets
-> RSATypes.PrivateKey -- ^ RSA signing key
-> Either SignError SignaturePayload
signCertificationWithRSA st pkp uid hsigsubs usigsubs prv
| st `elem` [GenericCert, PersonaCert, CasualCert, PositiveCert] = do
let payloadToSign = BL.toStrict (finalPayload (SignaturePkt uidsigp) uidpayload)
uidsigp'
<$> left16FromSignedPayloadForSign SHA512 payloadToSign
<*> first
(SignBackendError . show)
(P15.sign
Nothing
(Just CHA.SHA512)
prv
payloadToSign)
| otherwise =
Left (SignUnsupportedCertificationType st)
where
uidpayload =
runPut
(sequence_
[putKeyforSigning (PublicKeyPkt pkp), putUforSigning (toPkt uid)])
uidsigp =
SigV4 st RSA SHA512 hsigsubs usigsubs 0 (NE.fromList [MPI 0])
uidsigp' left16 us =
SigV4
st
RSA
SHA512
hsigsubs
usigsubs
left16
(NE.fromList [MPI (os2ip us)])
signDirectKeyWithRSA ::
SigType -- ^ key-scoped signature type (SignatureDirectlyOnAKey or KeyRevocationSig)
-> SomePKPayload -- ^ primary key "payload" being signed
-> [SigSubPacket] -- ^ hashed signature subpackets
-> [SigSubPacket] -- ^ unhashed signature subpackets
-> RSATypes.PrivateKey -- ^ RSA signing key
-> Either SignError SignaturePayload
signDirectKeyWithRSA st pkp hsigsubs usigsubs prv
| st `elem` [SignatureDirectlyOnAKey, KeyRevocationSig] =
signDataWithRSA st prv hsigsubs usigsubs keypayload
| otherwise =
Left (SignUnsupportedKeySignatureType st)
where
keypayload = runPut (putKeyforSigning (PublicKeyPkt pkp))
signKeyRevocationWithRSA :: SomePKPayload -- ^ primary key "payload" being revoked
-> [SigSubPacket] -- ^ hashed signature subpackets
-> [SigSubPacket] -- ^ unhashed signature subpackets
-> RSATypes.PrivateKey -- ^ RSA signing key
-> Either SignError SignaturePayload
signKeyRevocationWithRSA = signDirectKeyWithRSA KeyRevocationSig
signSubkeyRevocationWithRSA :: SomePKPayload -- ^ primary key "payload"
-> SomePKPayload -- ^ public subkey "payload" being revoked
-> [SigSubPacket] -- ^ hashed signature subpackets
-> [SigSubPacket] -- ^ unhashed signature subpackets
-> RSATypes.PrivateKey -- ^ RSA signing key
-> Either SignError SignaturePayload
signSubkeyRevocationWithRSA pkp subpkp hsigsubs usigsubs prv =
signDataWithRSA SubkeyRevocationSig prv hsigsubs usigsubs subkeypayload
where
subkeypayload =
runPut
(sequence_
[ putKeyforSigning (PublicKeyPkt pkp)
, putKeyforSigning (PublicSubkeyPkt subpkp)
])
signCertRevocationWithRSA :: SomePKPayload -- ^ primary key "payload"
-> UserId -- ^ user ID certification being revoked
-> [SigSubPacket] -- ^ hashed signature subpackets
-> [SigSubPacket] -- ^ unhashed signature subpackets
-> RSATypes.PrivateKey -- ^ RSA signing key
-> Either SignError SignaturePayload
signCertRevocationWithRSA pkp uid hsigsubs usigsubs prv =
signDataWithRSA CertRevocationSig prv hsigsubs usigsubs certpayload
where
certpayload =
runPut
(sequence_
[putKeyforSigning (PublicKeyPkt pkp), putUforSigning (toPkt uid)])
crossSignSubkeyWithRSA :: SomePKPayload -- ^ public key "payload" of key being signed
-> SomePKPayload -- ^ public subkey "payload" of key being signed
-> [SigSubPacket] -- ^ hashed signature subpackets for binding sig
-> [SigSubPacket] -- ^ unhashed signature subpackets for binding sig
-> [SigSubPacket] -- ^ hashed signature subpackets for embedded sig
-> [SigSubPacket] -- ^ unhashed signature subpackets for embedded sig
-> RSATypes.PrivateKey -- ^ RSA signing key
-> RSATypes.PrivateKey -- ^ RSA signing subkey
-> Either SignError SignaturePayload
crossSignSubkeyWithRSA pkp subpkp subhsigsubs subusigsubs embhsigsubs embusigsubs prv ssb = do
let embPayloadToSign = BL.toStrict (finalPayload (SignaturePkt embsigp) subkeypayload)
subPayloadToSign = BL.toStrict (finalPayload (SignaturePkt subsigp) subkeypayload)
(\embleft16 subleft16 embsig subsig ->
subsigp' (embsigp' embleft16 embsig) subleft16 subsig)
<$> left16FromSignedPayloadForSign SHA512 embPayloadToSign
<*> left16FromSignedPayloadForSign SHA512 subPayloadToSign
<*> first
(SignBackendError . show)
(P15.sign
Nothing
(Just CHA.SHA512)
ssb
embPayloadToSign)
<*> first
(SignBackendError . show)
(P15.sign
Nothing
(Just CHA.SHA512)
prv
subPayloadToSign)
where
subkeypayload =
runPut
(sequence_
[ putKeyforSigning (PublicKeyPkt pkp)
, putKeyforSigning (PublicSubkeyPkt subpkp)
])
embsigp =
SigV4
PrimaryKeyBindingSig
RSA
SHA512
embhsigsubs
embusigsubs
0
(NE.fromList [MPI 0])
embsigp' left16 es =
SigV4
PrimaryKeyBindingSig
RSA
SHA512
embhsigsubs
embusigsubs
left16
(NE.fromList [MPI (os2ip es)])
subsigp =
SigV4 SubkeyBindingSig RSA SHA512 subhsigsubs [] 0 (NE.fromList [MPI 0])
sspes es = SigSubPacket False (EmbeddedSignature es)
subsigp' es left16 ss =
SigV4
SubkeyBindingSig
RSA
SHA512
subhsigsubs
(sspes es : subusigsubs)
left16
(NE.fromList [MPI (os2ip ss)])
signRSAV4Core ::
TextNormalizationMode
-> SigType
-> HashAlgorithm
-> [SigSubPacket]
-> [SigSubPacket]
-> RSATypes.PrivateKey
-> ByteString
-> Either SignError SignaturePayload
signRSAV4Core mode st ha has uhas prv payload =
(\left16 ss -> SigV4 st RSA ha has uhas left16 (NE.fromList [MPI (os2ip ss)]))
<$> left16FromSignedPayloadForSign ha payloadToSign
<*> rsaPKCS15Sign ha prv payloadToSign
where
sig0 = SigV4 st RSA ha has [] 0 (NE.fromList [MPI 0])
payloadToSign = BL.toStrict (finalPayload (SignaturePkt sig0) (normalizePayloadForSigTypeWith mode st payload))
signRSAV6Core ::
TextNormalizationMode
-> SigType
-> HashAlgorithm
-> SignatureSalt
-> [SigSubPacket]
-> [SigSubPacket]
-> RSATypes.PrivateKey
-> ByteString
-> Either SignError SignaturePayload
signRSAV6Core mode st ha salt has uhas prv payload = do
validateV6SaltSize ha salt
(\left16 sigBytes -> SigV6 st RSA ha salt has uhas left16 (NE.fromList [MPI (os2ip sigBytes)]))
<$> left16FromSignedPayloadForSign ha payloadToSign
<*> rsaPKCS15Sign ha prv payloadToSign
where
sig0 = SigV6 st RSA ha salt has [] 0 (NE.fromList [MPI 0])
payloadToSign = BL.toStrict (finalPayload (SignaturePkt sig0) (normalizePayloadForSigTypeWith mode st payload))
signDataWithRSA ::
SigType
-> RSATypes.PrivateKey
-> [SigSubPacket]
-> [SigSubPacket]
-> ByteString
-> Either SignError SignaturePayload
signDataWithRSA st prv has uhas payload =
signRSAV4Core CleartextCompat st SHA512 has uhas prv payload
signDataWithRSAV6 ::
SigType
-> SignatureSalt
-> RSATypes.PrivateKey
-> [SigSubPacket]
-> [SigSubPacket]
-> ByteString
-> Either SignError SignaturePayload
signDataWithRSAV6 st salt prv has uhas payload =
signRSAV6Core CleartextCompat st SHA512 salt has uhas prv payload
-- FIXME: clean this up
ed25519Params, ed25519LegacyParams, ed448Params :: (String, Int, Int, PubKeyAlgorithm)
ed25519Params = ("Ed25519", 64, 32, PKA.Ed25519)
ed25519LegacyParams = ("Ed25519Legacy", 64, 32, PKA.EdDSA)
ed448Params = ("Ed448", 114, 57, PKA.Ed448)
signDataWithEdDSAV4Generic ::
(String, Int, Int, PubKeyAlgorithm)
-> (B.ByteString -> B.ByteString)
-> TextNormalizationMode
-> HashAlgorithm
-> SigType
-> [SigSubPacket]
-> [SigSubPacket]
-> ByteString
-> Either SignError SignaturePayload
signDataWithEdDSAV4Generic (algoName, sigLen, limbLen, pka) signer mode ha st has uhas payload =
signEdDSAV4 algoName sigLen limbLen signer mode st pka ha has uhas payload
signDataWithEdDSAV6Generic ::
(String, Int, Int, PubKeyAlgorithm)
-> (B.ByteString -> B.ByteString)
-> TextNormalizationMode
-> HashAlgorithm
-> SigType
-> SignatureSalt
-> [SigSubPacket]
-> [SigSubPacket]
-> ByteString
-> Either SignError SignaturePayload
signDataWithEdDSAV6Generic (algoName, sigLen, limbLen, pka) signer mode ha st salt has uhas payload =
signEdDSAV6 algoName sigLen limbLen signer mode st pka ha salt has uhas payload
signDataWithEd25519 ::
SigType
-> Ed25519.SecretKey
-> [SigSubPacket]
-> [SigSubPacket]
-> ByteString
-> Either SignError SignaturePayload
signDataWithEd25519 st sk has uhas payload =
signDataWithEdDSAV4Generic ed25519Params (ed25519Signer sk) CleartextCompat SHA512 st has uhas payload
signDataWithEd25519Legacy ::
SigType
-> Ed25519.SecretKey
-> [SigSubPacket]
-> [SigSubPacket]
-> ByteString
-> Either SignError SignaturePayload
signDataWithEd25519Legacy st sk has uhas payload =
signDataWithEdDSAV4Generic ed25519LegacyParams (ed25519Signer sk) CleartextCompat SHA512 st has uhas payload
signDataWithEd25519V6 ::
SigType
-> SignatureSalt
-> Ed25519.SecretKey
-> [SigSubPacket]
-> [SigSubPacket]
-> ByteString
-> Either SignError SignaturePayload
signDataWithEd25519V6 st salt sk has uhas payload =
signDataWithEdDSAV6Generic ed25519Params (ed25519Signer sk) CleartextCompat SHA512 st salt has uhas payload
signDataWithEd448 ::
SigType
-> Ed448.SecretKey
-> [SigSubPacket]
-> [SigSubPacket]
-> ByteString
-> Either SignError SignaturePayload
signDataWithEd448 st sk has uhas payload =
signDataWithEdDSAV4Generic ed448Params (ed448Signer sk) CleartextCompat SHA512 st has uhas payload
signDataWithEd448V6 ::
SigType
-> SignatureSalt
-> Ed448.SecretKey
-> [SigSubPacket]
-> [SigSubPacket]
-> ByteString
-> Either SignError SignaturePayload
signDataWithEd448V6 st salt sk has uhas payload =
signDataWithEdDSAV6Generic ed448Params (ed448Signer sk) CleartextCompat SHA512 st salt has uhas payload
-- | Builder-based signature creation for RSA
--
-- Example usage:
-- builder <- sigBuilderInit BinarySig RSA SHA512
-- builder' <- addHashedSubs hashedSubpackets builder
-- builder'' <- addUnhashedSubs unhashedSubpackets builder'
-- sig <- signDataWithRSABuilder builder'' rsaPrivateKey payload
signDataWithRSABuilder ::
SigBuilder Codec.Encryption.OpenPGP.Types.Unhashed Codec.Encryption.OpenPGP.Types.V4Sig 'PKA.RSA
-> RSATypes.PrivateKey
-> ByteString
-> Either SignError SignaturePayload
signDataWithRSABuilder builder prv payload =
signRSAV4Core
(sbTextNormMode builder)
(sbSigType builder)
(sbHashAlgo builder)
(sbHashedSubs builder)
(sbUnhashedSubs builder)
prv
payload
-- | Builder-based signature creation for RSA (v6)
signDataWithRSAV6Builder ::
SigBuilder Codec.Encryption.OpenPGP.Types.Unhashed Codec.Encryption.OpenPGP.Types.V6Sig 'PKA.RSA
-> RSATypes.PrivateKey
-> ByteString
-> Either SignError SignaturePayload
signDataWithRSAV6Builder builder prv payload =
signRSAV6Core
(sbTextNormMode builder)
(sbSigType builder)
(sbHashAlgo builder)
(sbSalt builder)
(sbHashedSubs builder)
(sbUnhashedSubs builder)
prv
payload
-- | Builder-based signature creation for Ed25519 (v4)
--
-- Example usage:
-- builder <- sigBuilderInit BinarySig Ed25519 SHA512
-- builder' <- addHashedSubs hashedSubpackets builder
-- builder'' <- addUnhashedSubs unhashedSubpackets builder'
-- sig <- signDataWithEd25519Builder builder'' ed25519PrivateKey payload
signDataWithEd25519Builder ::
SigBuilder Codec.Encryption.OpenPGP.Types.Unhashed Codec.Encryption.OpenPGP.Types.V4Sig 'PKA.Ed25519
-> Ed25519.SecretKey
-> ByteString
-> Either SignError SignaturePayload
signDataWithEd25519Builder builder sk payload =
signDataWithEdDSAV4Generic ed25519Params (ed25519Signer sk)
(sbTextNormMode builder) (sbHashAlgo builder) (sbSigType builder)
(sbHashedSubs builder) (sbUnhashedSubs builder) payload
-- | Builder-based signature creation for Ed25519 (v6)
--
-- Example usage:
-- builder <- sigBuilderInitV6 BinarySig Ed25519 SHA512 salt
-- builder' <- addHashedSubs hashedSubpackets builder
-- builder'' <- addUnhashedSubs unhashedSubpackets builder'
-- sig <- signDataWithEd25519V6Builder builder'' ed25519PrivateKey payload
signDataWithEd25519V6Builder ::
SigBuilder Codec.Encryption.OpenPGP.Types.Unhashed Codec.Encryption.OpenPGP.Types.V6Sig 'PKA.Ed25519
-> Ed25519.SecretKey
-> ByteString
-> Either SignError SignaturePayload
signDataWithEd25519V6Builder builder sk payload =
signDataWithEdDSAV6Generic ed25519Params (ed25519Signer sk)
(sbTextNormMode builder) (sbHashAlgo builder) (sbSigType builder)
(sbSalt builder) (sbHashedSubs builder) (sbUnhashedSubs builder) payload
-- | Builder-based signature creation for Ed448 (v4)
--
-- Example usage:
-- builder <- sigBuilderInit BinarySig Ed448 SHA512
-- builder' <- addHashedSubs hashedSubpackets builder
-- builder'' <- addUnhashedSubs unhashedSubpackets builder'
-- sig <- signDataWithEd448Builder builder'' ed448PrivateKey payload
signDataWithEd448Builder ::
SigBuilder Codec.Encryption.OpenPGP.Types.Unhashed Codec.Encryption.OpenPGP.Types.V4Sig 'PKA.Ed448
-> Ed448.SecretKey
-> ByteString
-> Either SignError SignaturePayload
signDataWithEd448Builder builder sk payload =
signDataWithEdDSAV4Generic ed448Params (ed448Signer sk)
(sbTextNormMode builder) (sbHashAlgo builder) (sbSigType builder)
(sbHashedSubs builder) (sbUnhashedSubs builder) payload
-- | Builder-based signature creation for Ed448 (v6)
signDataWithEd448V6Builder ::
SigBuilder Codec.Encryption.OpenPGP.Types.Unhashed Codec.Encryption.OpenPGP.Types.V6Sig 'PKA.Ed448
-> Ed448.SecretKey
-> ByteString
-> Either SignError SignaturePayload
signDataWithEd448V6Builder builder sk payload =
signDataWithEdDSAV6Generic ed448Params (ed448Signer sk)
(sbTextNormMode builder) (sbHashAlgo builder) (sbSigType builder)
(sbSalt builder) (sbHashedSubs builder) (sbUnhashedSubs builder) payload
-- | Algorithm-agnostic signature builder dispatcher (Phase 2)
--
-- Dispatches to the appropriate signing function based on the private key type.
-- The private key type (PrivateKeyFor algo) encodes the algorithm at the type level,
-- allowing compile-time verification that the key and builder algorithm match.
--
-- Example usage:
class BuilderSigningAlgorithm (algo :: PKA.PubKeyAlgorithm) where
signDataWithAlgorithmicBuilderImpl
:: SigBuilder Codec.Encryption.OpenPGP.Types.Unhashed Codec.Encryption.OpenPGP.Types.V4Sig algo
-> PrivateKeyFor algo
-> ByteString
-> Either SignError SignaturePayload
instance BuilderSigningAlgorithm 'PKA.RSA where
signDataWithAlgorithmicBuilderImpl builder (SP.RSAPrivateKey prv) payload =
signDataWithRSABuilder builder prv payload
instance BuilderSigningAlgorithm 'PKA.Ed25519 where
signDataWithAlgorithmicBuilderImpl builder (SP.Ed25519PrivateKey sk) payload =
signDataWithEd25519Builder builder sk payload
instance BuilderSigningAlgorithm 'PKA.Ed448 where
signDataWithAlgorithmicBuilderImpl builder (SP.Ed448PrivateKey sk) payload =
signDataWithEd448Builder builder sk payload
-- | Catch-all instance that produces a compile-time error for any algorithm
-- that is not supported by the algorithmic builder (e.g. DSA, ECDSA).
instance {-# OVERLAPPABLE #-}
TypeError
( 'Text "signDataWithAlgorithmicBuilder does not support this algorithm."
':$$: 'Text "Supported algorithms: RSA, Ed25519, Ed448."
':$$: 'Text "For DSA or ECDSA, use signDataWith{DSA,ECDSA}Builder directly."
)
=> BuilderSigningAlgorithm algo where
signDataWithAlgorithmicBuilderImpl = error "unreachable: TypeError fires at compile time"
signDataWithAlgorithmicBuilder
:: forall (algo :: PKA.PubKeyAlgorithm)
. BuilderSigningAlgorithm algo
=> SigBuilder Codec.Encryption.OpenPGP.Types.Unhashed Codec.Encryption.OpenPGP.Types.V4Sig algo
-> PrivateKeyFor algo
-> ByteString
-> Either SignError SignaturePayload
signDataWithAlgorithmicBuilder =
signDataWithAlgorithmicBuilderImpl