diff --git a/Codec/Encryption/OpenPGP/Arbitrary.hs b/Codec/Encryption/OpenPGP/Arbitrary.hs --- a/Codec/Encryption/OpenPGP/Arbitrary.hs +++ b/Codec/Encryption/OpenPGP/Arbitrary.hs @@ -178,7 +178,8 @@ set = fmap SigExpirationTime arbitrary ec = fmap ExportableCertification arbitrary ts = - arbitrary >>= \tl -> arbitrary >>= \ta -> return (TrustSignature tl ta) + arbitrary >>= \tl -> + arbitrary >>= \ta -> return (TrustSignature (TrustLevel tl) (TrustAmount ta)) re = fmap RegularExpression arbitrary ket = fmap KeyExpirationTime arbitrary psa = fmap PreferredSymmetricAlgorithms arbitrary @@ -202,12 +203,12 @@ suid = fmap SignersUserId arbitrary rfr = arbitrary >>= \rc -> - arbitrary >>= \rr -> return (ReasonForRevocation rc rr) + arbitrary >>= \rr -> return (ReasonForRevocation rc (RevocationReason rr)) fs = fmap Features arbitrary st = arbitrary >>= \pka -> arbitrary >>= \ha -> - arbitrary >>= \sh -> return (SignatureTarget pka ha sh) + arbitrary >>= \sh -> return (SignatureTarget pka ha (SignatureHash sh)) es _ = pure (EmbeddedSignature (SigVOther 5 BL.empty)) ifp = elements [IssuerFingerprintV4, IssuerFingerprintV6] >>= \v -> @@ -294,7 +295,7 @@ , PositiveCert , SubkeyBindingSig , PrimaryKeyBindingSig - , SignatureDirectlyOnAKey + , DirectKeySignature , KeyRevocationSig , SubkeyRevocationSig , CertRevocationSig @@ -403,3 +404,12 @@ instance Arbitrary Padding where arbitrary = fmap Padding arbitrary + +instance Arbitrary Exportability where + arbitrary = fmap Exportability arbitrary + +instance Arbitrary Revocability where + arbitrary = fmap Revocability arbitrary + +instance Arbitrary NestedFlag where + arbitrary = fmap NestedFlag arbitrary diff --git a/Codec/Encryption/OpenPGP/Encrypt.hs b/Codec/Encryption/OpenPGP/Encrypt.hs --- a/Codec/Encryption/OpenPGP/Encrypt.hs +++ b/Codec/Encryption/OpenPGP/Encrypt.hs @@ -1023,7 +1023,7 @@ defaultRecipientPayloadShape = RecipientPayloadShape { recipientPayloadDataType = BinaryData - , recipientPayloadFileName = BL.empty + , recipientPayloadFileName = FileName B.empty , recipientPayloadTimestamp = 0 , recipientPayloadUseOnePassSignatures = False , recipientPayloadSignatures = [] @@ -1769,7 +1769,9 @@ (zipWith buildOnePassSignature nestedFlags (reverse signatures)) where signatures = recipientPayloadSignatures payloadShape - nestedFlags = replicate (length signatures - 1) True ++ [False] + nestedFlags = + replicate (length signatures - 1) (NestedFlag True) + ++ [NestedFlag False] data OnePassSignatureBuildCase where OnePassSignatureBuildCaseV3 @@ -2658,7 +2660,7 @@ ( Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) (BL.fromStrict payload) ] @@ -2790,14 +2792,14 @@ Nothing -> [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) (BL.fromStrict payload) ] Just sigs -> LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) (BL.fromStrict payload) : sigs diff --git a/Codec/Encryption/OpenPGP/Expirations.hs b/Codec/Encryption/OpenPGP/Expirations.hs --- a/Codec/Encryption/OpenPGP/Expirations.hs +++ b/Codec/Encryption/OpenPGP/Expirations.hs @@ -73,7 +73,7 @@ relevantSelfSignatures relevantSelfSignatures = concat - [ filter (isDirectKeySelfSigFor primaryKey) (tk ^. tkRevs) + [ filter (isDirectKeySelfSigFor primaryKey) (tk ^. tkDirectKeySigs) , filter (isSelfCertificationFor primaryKey) (concatMap snd (tk ^. tkUIDs)) @@ -310,7 +310,7 @@ isDirectKeySelfSigFor primaryKey sig && signatureEffectiveAt ct sig ) - (tk ^. tkRevs) + (tk ^. tkDirectKeySigs) uidSelfCerts = mapMaybe ( latestActiveSelfCertificationAt ct @@ -377,7 +377,7 @@ isDirectKeySelfSigFor :: SomePKPayload -> SignaturePayload -> Bool isDirectKeySelfSigFor pkp sig = - sigType sig == Just SignatureDirectlyOnAKey + sigType sig == Just DirectKeySignature && isSelfSignatureFor pkp sig isSelfCertificationFor diff --git a/Codec/Encryption/OpenPGP/Internal.hs b/Codec/Encryption/OpenPGP/Internal.hs --- a/Codec/Encryption/OpenPGP/Internal.hs +++ b/Codec/Encryption/OpenPGP/Internal.hs @@ -7,26 +7,24 @@ {-# LANGUAGE OverloadedStrings #-} module Codec.Encryption.OpenPGP.Internal - ( countBits - , PktStreamContext (..) - , issuer - , issuerFP - , emptyPSC - , leftPadTo - , checksum16 + ( checksum16 , checksum16Bytes - , edPointBytes - , encodeWord64be , chunksOf8 - , pubkeyToMPIs - , multiplicativeInverse - , curveoidBSToCurve + , curve2Curve + , curveFromCurve , curveToCurveoidBS - , point2MBS + , curveoidBSToCurve , curveoidBSToEdSigningCurve + , edPointBytes , edSigningCurveToCurveoidBS - , curve2Curve - , curveFromCurve + , emptyPSC + , encodeWord64be + , issuer + , issuerFP + , leftPadTo + , PktStreamContext (..) + , point2MBS + , pubkeyToMPIs , xorBS ) where diff --git a/Codec/Encryption/OpenPGP/KeyGeneration.hs b/Codec/Encryption/OpenPGP/KeyGeneration.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/OpenPGP/KeyGeneration.hs @@ -0,0 +1,134 @@ +-- KeyGeneration.hs: OpenPGP (RFC9580) key generation +-- Copyright © 2026 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Codec.Encryption.OpenPGP.KeyGeneration + ( KeyGenSpec (..) + , generateSecretKey + ) where + +import Control.Monad (unless) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT (..), throwE) +import qualified Crypto.Error as CE +import Crypto.Number.Serialize (os2ip) +import qualified Crypto.PubKey.Curve25519 as C25519 +import qualified Crypto.PubKey.Curve448 as C448 +import qualified Crypto.PubKey.Ed25519 as Ed25519 +import qualified Crypto.PubKey.Ed448 as Ed448 +import qualified Crypto.PubKey.RSA as RSA +import Crypto.Random.Types (MonadRandom, getRandomBytes) +import qualified Data.ByteArray as BA +import qualified Data.ByteString as B + +import Codec.Encryption.OpenPGP.Types + +class RSAKeyVersion (v :: KeyVersion) where + rsaKeyVersion :: KeyVersion + +instance RSAKeyVersion 'V4 where + rsaKeyVersion = V4 + +instance RSAKeyVersion 'V6 where + rsaKeyVersion = V6 + +data KeyGenSpec (v :: KeyVersion) where + KeyGenRSA + :: RSAKeyVersion v => ThirtyTwoBitTimeStamp -> Int -> KeyGenSpec v + KeyGenEd25519 :: ThirtyTwoBitTimeStamp -> KeyGenSpec 'V6 + KeyGenEd448 :: ThirtyTwoBitTimeStamp -> KeyGenSpec 'V6 + KeyGenX25519 :: ThirtyTwoBitTimeStamp -> KeyGenSpec 'V6 + KeyGenX448 :: ThirtyTwoBitTimeStamp -> KeyGenSpec 'V6 + +generateSecretKey + :: forall v m + . MonadRandom m + => KeyGenSpec v + -> ExceptT String m (SomePKPayload, SKey) +generateSecretKey spec = case spec of + KeyGenRSA ts keySizeBits -> rsaGenerate (rsaKeyVersion @v) ts keySizeBits + KeyGenEd25519 ts -> ed25519Generate ts + KeyGenEd448 ts -> ed448Generate ts + KeyGenX25519 ts -> x25519Generate ts + KeyGenX448 ts -> x448Generate ts + where + rsaGenerate kv ts keySizeBits = do + unless (keySizeBits `mod` 8 == 0) $ + throwE "RSA key size must be a multiple of 8" + let keySizeBytes = keySizeBits `div` 8 + (publicKey, privateKey) <- lift $ RSA.generate keySizeBytes 65537 + let pkey = RSAPubKey (RSA_PublicKey publicKey) + skey = RSAPrivateKey (RSA_PrivateKey privateKey) + pkp = case kv of + DeprecatedV3 -> PKPayload DeprecatedV3 ts 0 RSA pkey + V4 -> PKPayload V4 ts 0 RSA pkey + V6 -> PKPayload V6 ts 0 RSA pkey + pure (pkp, skey) + ed25519Generate ts = do + seed <- lift $ getRandomBytes 32 + secretKey <- + either + (throwE . ("Ed25519 key generation failed: " ++) . show) + pure + (CE.eitherCryptoError (Ed25519.secretKey seed)) + let pubBytes = BA.convert (Ed25519.toPublic secretKey) :: B.ByteString + pkey = + EdDSAPubKey + EdSigningCurve25519 + (NativeEPoint (EPoint (os2ip pubBytes))) + skey = Ed25519PrivateKey seed + pkp = PKPayload V6 ts 0 Ed25519 pkey + pure (pkp, skey) + ed448Generate ts = do + seed <- lift $ getRandomBytes 57 + secretKey <- + either + (throwE . ("Ed448 key generation failed: " ++) . show) + pure + (CE.eitherCryptoError (Ed448.secretKey seed)) + let pubBytes = BA.convert (Ed448.toPublic secretKey) :: B.ByteString + pkey = + EdDSAPubKey + EdSigningCurve448 + (NativeEPoint (EPoint (os2ip pubBytes))) + skey = Ed448PrivateKey seed + pkp = PKPayload V6 ts 0 Ed448 pkey + pure (pkp, skey) + x25519Generate ts = do + secretRaw <- lift $ getRandomBytes 32 + secretKey <- + either + (throwE . ("X25519 key generation failed: " ++) . show) + pure + (CE.eitherCryptoError (C25519.secretKey secretRaw)) + let pubRaw = BA.convert (C25519.toPublic secretKey) :: B.ByteString + pkey = + EdDSAPubKey + EdSigningCurve25519 + (NativeEPoint (EPoint (os2ip pubRaw))) + skey = X25519PrivateKey secretRaw + pkp = PKPayload V6 ts 0 X25519 pkey + pure (pkp, skey) + x448Generate ts = do + secretRaw <- lift $ getRandomBytes 56 + secretKey <- + either + (throwE . ("X448 key generation failed: " ++) . show) + pure + (CE.eitherCryptoError (C448.secretKey secretRaw)) + let pubRaw = BA.convert (C448.toPublic secretKey) :: B.ByteString + pkey = + EdDSAPubKey + EdSigningCurve448 + (NativeEPoint (EPoint (os2ip pubRaw))) + skey = X448PrivateKey secretRaw + pkp = PKPayload V6 ts 0 X448 pkey + pure (pkp, skey) diff --git a/Codec/Encryption/OpenPGP/KeyringParser.hs b/Codec/Encryption/OpenPGP/KeyringParser.hs --- a/Codec/Encryption/OpenPGP/KeyringParser.hs +++ b/Codec/Encryption/OpenPGP/KeyringParser.hs @@ -201,7 +201,9 @@ splitUs (many (signedUID intolerant <|> signedUAt intolerant)) subs <- concatMany (pubsub intolerant) - return $ Just (TKUnknown pkp pkpsigs uids uats subs) + let revs = filter ((== Just KeyRevocationSig) . sigType) pkpsigs + directKeySigs = filter ((== Just DirectKeySignature) . sigType) pkpsigs + return $ Just (TKUnknown pkp revs directKeySigs uids uats subs) where pubsub True = signedOrRevokedPubSubkey True pubsub False = signedOrRevokedPubSubkey False <|> brokenPubSubkey @@ -215,7 +217,9 @@ splitUs (many (signedUID intolerant <|> signedUAt intolerant)) subs <- concatMany (secsub intolerant) - return $ Just (TKUnknown skp skpsigs uids uats subs) + let revs = filter ((== Just KeyRevocationSig) . sigType) skpsigs + directKeySigs = filter ((== Just DirectKeySignature) . sigType) skpsigs + return $ Just (TKUnknown skp revs directKeySigs uids uats subs) where secsub True = rawOrSignedOrRevokedSecSubkey True secsub False = rawOrSignedOrRevokedSecSubkey False <|> brokenSecSubkey @@ -225,7 +229,7 @@ _ <- broken 6 _ <- many - (signature False [KeyRevocationSig, SignatureDirectlyOnAKey]) + (signature False [KeyRevocationSig, DirectKeySignature]) _ <- many (signedUID False <|> signedUAt False) _ <- concatMany (signedOrRevokedPubSubkey False <|> brokenPubSubkey) @@ -234,7 +238,7 @@ _ <- broken 5 _ <- many - (signature False [KeyRevocationSig, SignatureDirectlyOnAKey]) + (signature False [KeyRevocationSig, DirectKeySignature]) _ <- many (signedUID False <|> signedUAt False) _ <- concatMany @@ -452,7 +456,9 @@ uidrefs = concatMap snd uidResults subs = fmap fst subResults subrefs = concatMap snd subResults - tk = TKUnknown pkp pkpsigs uids uats subs + revs = filter ((== Just KeyRevocationSig) . sigType) pkpsigs + directKeySigs = filter ((== Just DirectKeySignature) . sigType) pkpsigs + tk = TKUnknown pkp revs directKeySigs uids uats subs refs = pkps ++ pkpsigrefs ++ uidrefs ++ subrefs return $ Just (mkTKWithWireRep tk refs) where @@ -479,7 +485,9 @@ uidrefs = concatMap snd uidResults subs = fmap fst subResults subrefs = concatMap snd subResults - tk = TKUnknown skp skpsigs uids uats subs + revs = filter ((== Just KeyRevocationSig) . sigType) skpsigs + directKeySigs = filter ((== Just DirectKeySignature) . sigType) skpsigs + tk = TKUnknown skp revs directKeySigs uids uats subs refs = skps ++ skpsigrefs ++ uidrefs ++ subrefs return $ Just (mkTKWithWireRep tk refs) where diff --git a/Codec/Encryption/OpenPGP/Message.hs b/Codec/Encryption/OpenPGP/Message.hs --- a/Codec/Encryption/OpenPGP/Message.hs +++ b/Codec/Encryption/OpenPGP/Message.hs @@ -495,7 +495,12 @@ s2k (unPassphrase passphrase) ( Block - [LiteralDataPkt BinaryData BL.empty 0 (unClearPayload payload)] + [ LiteralDataPkt + BinaryData + (FileName B.empty) + 0 + (unClearPayload payload) + ] ) sessionKeyMaterial <- deriveSessionMaterial sa s2k passphrase pure @@ -529,7 +534,11 @@ WrappedSessionMaterial <$> string2Key s2k keyLen (unPassphrase passphrase) let literal = - LiteralDataPkt BinaryData BL.empty 0 (unClearPayload payload) + LiteralDataPkt + BinaryData + (FileName B.empty) + 0 + (unClearPayload payload) cleartext = BL.toStrict (runPut (put (Block [literal]))) cleartextWithMDC = cleartext <> mdcTrailerForSEIPDv1 iv cleartext encrypted <- @@ -803,7 +812,7 @@ -> Either SignError BL.ByteString signWithSubpackets hashed unhashed signingFn payload = do let clear = unClearPayload payload - literal = LiteralDataPkt BinaryData BL.empty 0 clear + literal = LiteralDataPkt BinaryData (FileName B.empty) 0 clear signature <- signingFn hashed unhashed clear let sigPkt = SignaturePkt signature bimap @@ -811,7 +820,7 @@ ( \ops -> runPut . put $ Block [OnePassSignaturePkt ops, literal, sigPkt] ) - (buildOnePassSignature False signature) + (buildOnePassSignature (NestedFlag False) signature) extractEncryptedPayload :: [Pkt] -> Either MessageParseFailure SomeParsedEncryptedPayload diff --git a/Codec/Encryption/OpenPGP/Ontology.hs b/Codec/Encryption/OpenPGP/Ontology.hs --- a/Codec/Encryption/OpenPGP/Ontology.hs +++ b/Codec/Encryption/OpenPGP/Ontology.hs @@ -46,11 +46,11 @@ isRevokerP sig = case preview _SigV4 sig of Just (st, _, _, h, u, _, _) -> - st == SignatureDirectlyOnAKey && hasRevokerSubpackets h u + st == DirectKeySignature && hasRevokerSubpackets h u Nothing -> case preview _SigV6 sig of Just (st, _, _, _, h, u, _, _) -> - st == SignatureDirectlyOnAKey && hasRevokerSubpackets h u + st == DirectKeySignature && hasRevokerSubpackets h u Nothing -> False hasRevokerSubpackets :: [SigSubPacket] -> [SigSubPacket] -> Bool diff --git a/Codec/Encryption/OpenPGP/Policy.hs b/Codec/Encryption/OpenPGP/Policy.hs --- a/Codec/Encryption/OpenPGP/Policy.hs +++ b/Codec/Encryption/OpenPGP/Policy.hs @@ -614,7 +614,7 @@ -- RFC9580/RFC4880 signature context validation predicates -- These enforce which signature types are allowed in which structural contexts --- | RFC9580 §3.2: Primary key can only have KeyRevocationSig or SignatureDirectlyOnAKey +-- | RFC9580 §3.2: Primary key can only have KeyRevocationSig or DirectKeySignature isAllowedPrimaryKeySig :: SignaturePayload -> Bool isAllowedPrimaryKeySig = maybe False isAllowedPrimaryKeySigType . sigType @@ -629,7 +629,7 @@ -- | Test if a SigType is allowed on a primary key isAllowedPrimaryKeySigType :: SigType -> Bool isAllowedPrimaryKeySigType KeyRevocationSig = True -isAllowedPrimaryKeySigType SignatureDirectlyOnAKey = True +isAllowedPrimaryKeySigType DirectKeySignature = True isAllowedPrimaryKeySigType _ = False -- | Test if a SigType is allowed on a subkey diff --git a/Codec/Encryption/OpenPGP/SecretKey.hs b/Codec/Encryption/OpenPGP/SecretKey.hs --- a/Codec/Encryption/OpenPGP/SecretKey.hs +++ b/Codec/Encryption/OpenPGP/SecretKey.hs @@ -11,11 +11,9 @@ ( decryptPrivateKey , mkUnencryptedSKAddendum , encryptPrivateKeyWithPolicyAndSaltAndIV - , encryptPrivateKey - , changePrivateKeyPassphrase - , changePrivateKeyPassphraseRandom - , reencryptSecretKeyRandomEither , reencryptPrivateKeyTyped + , reencryptPrivateKeyTypedWithPolicy + , reencryptPrivateKeyWithSaltAndIV , SecretKeyError (..) , renderSecretKeyError , SecretKeyEncryptOptions (..) @@ -25,7 +23,6 @@ , encryptSecretKeyWithPolicy , reencryptSecretKey , reencryptSecretKeyRandom - , changeSecretKeyPassphrase ) where import Control.Error.Util (note) @@ -311,28 +308,6 @@ , skeoIV = Nothing } -{-# DEPRECATED - changeSecretKeyPassphrase - "Use reencryptSecretKey or reencryptSecretKeyRandom instead" - #-} -changeSecretKeyPassphrase - :: MonadRandom m - => SecretKey - -> Passphrase - -> Passphrase - -> m (Either SecretKeyError SecretKey) -changeSecretKeyPassphrase sk oldPassphrase newPassphrase = - reencryptSecretKey - sk - oldPassphrase - newPassphrase - SecretKeyEncryptOptions - { skeoPolicy = defaultPolicy - , skeoGenerateSaltAndIV = True - , skeoSalt = Nothing - , skeoIV = Nothing - } - decryptPrivateKeyTyped :: SomePKPayload -> SKAddendumV v @@ -642,24 +617,6 @@ keyVersionByte V4 = 4 keyVersionByte V6 = 6 -{-# DEPRECATED encryptPrivateKey "Use encryptSecretKeyWithPolicy instead" #-} - --- | generates pseudo-random salt and IV -encryptPrivateKey - :: MonadRandom m - => OpenPGPPolicy - -> SomePKPayload - -> SKAddendum - -> BL.ByteString - -> m (Either String SKAddendum) -encryptPrivateKey policy pkp ska pp = do - nextMaterial <- generateSecretKeyProtectionMaterial policy pkp - case nextMaterial of - Left err -> pure $ Left err - Right (salt, iv) -> - pure $ - encryptPrivateKeyWithPolicyAndSaltAndIV policy pkp salt iv ska pp - encryptPrivateKeyWithPolicyAndSaltAndIV :: OpenPGPPolicy -> SomePKPayload @@ -693,53 +650,6 @@ (\payload -> SUSAEAD sa aa s2k iv (BL.fromStrict payload)) <$> encryptV6SKey pkp skey sa aa s2k iv pp -{-# DEPRECATED changePrivateKeyPassphrase "Use reencryptSecretKey instead" #-} -changePrivateKeyPassphrase - :: (SomePKPayload, SKAddendum) - -> BL.ByteString - -> Salt - -> IV - -> BL.ByteString - -> Either String SKAddendum -changePrivateKeyPassphrase (pkp, ska) oldPassphrase salt iv newPassphrase = do - decrypted <- decryptPrivateKey (pkp, ska) oldPassphrase - case decrypted of - SUUnencrypted skey _ -> - reencryptPrivateKeyWithSaltAndIV - pkp - ska - salt - iv - skey - newPassphrase - _ -> - Left - "Unexpected codepath: decrypted private key material was not in unencrypted form" - -{-# DEPRECATED - changePrivateKeyPassphraseRandom - "Use reencryptSecretKeyRandom instead" - #-} -changePrivateKeyPassphraseRandom - :: MonadRandom m - => (SomePKPayload, SKAddendum) - -> BL.ByteString - -> BL.ByteString - -> m (Either String SKAddendum) -changePrivateKeyPassphraseRandom (pkp, ska) oldPassphrase newPassphrase = do - nextMaterial <- - generateSecretKeyProtectionMaterial defaultPolicy pkp - case nextMaterial of - Left err -> pure $ Left err - Right (salt, iv) -> - pure $ - changePrivateKeyPassphrase - (pkp, ska) - oldPassphrase - salt - iv - newPassphrase - encodeSKeyMaterial :: SKey -> Either String BL.ByteString encodeSKeyMaterial keyMaterial = case keyMaterial of @@ -887,32 +797,6 @@ >>= \aead -> pure (CCT.aeadSimpleEncrypt aead ad plaintext 16) -{-# DEPRECATED - reencryptSecretKeyRandomEither - "Use changeSecretKeyPassphrase or reencryptSecretKeyRandom instead" - #-} -reencryptSecretKeyRandomEither - :: MonadRandom m - => SecretKey -> BL.ByteString -> m (Either String SecretKey) -reencryptSecretKeyRandomEither sk pp = - reencryptSecretKeyRandom - sk - (Passphrase pp) - (Passphrase pp) - defaultPolicy - >>= \case - Left err -> pure $ Left $ show err - Right sk' -> pure $ Right sk' - -{- | Version-preserving re-encryption of a typed secret-key addendum. - -Each constructor family is re-encrypted in kind: - * V6 variants (AEAD, SHA1, Sym, Unencrypted) → SKAAEADV6 (default v6 policy) - * SKA16bit / SKASHA1Legacy → same S2K family with updated salt - * SKAAEADLegacy → re-protected as SKASHA1Legacy (standard v3\/v4 S2K) - * SKASymLegacy → legacy CFB re-encryption as SKASymLegacy - * SKAUnencryptedLegacy → Left (cannot re-encrypt unencrypted legacy keys) --} reencryptPrivateKeyTyped :: SomePKPayload -> SKAddendumV v diff --git a/Codec/Encryption/OpenPGP/Serialize.hs b/Codec/Encryption/OpenPGP/Serialize.hs --- a/Codec/Encryption/OpenPGP/Serialize.hs +++ b/Codec/Encryption/OpenPGP/Serialize.hs @@ -39,7 +39,7 @@ ) import Control.Applicative (many, some) import Control.Arrow ((***)) -import Control.Lens ((^.), _1) +import Control.Lens (op, (^.), _1) import Control.Monad (guard, replicateM, replicateM_, when) import Control.Monad.Loops (iterateUntilM) import Crypto.Number.Basic (numBits) @@ -333,13 +333,18 @@ <$> fmap ThirtyTwoBitDuration getWord32be getExportableCertification :: SigSubPacketParser -getExportableCertification _pt crit _l = SigSubPacket crit . ExportableCertification <$> get +getExportableCertification _pt crit _l = + SigSubPacket crit . ExportableCertification . Exportability + <$> get getTrustSignature :: SigSubPacketParser getTrustSignature _pt crit _l = do tl <- getWord8 ta <- getWord8 - return $ SigSubPacket crit (TrustSignature tl ta) + return $ + SigSubPacket + crit + (TrustSignature (TrustLevel tl) (TrustAmount ta)) getRegularExpression :: SigSubPacketParser getRegularExpression _pt crit l = do @@ -349,7 +354,7 @@ return $ SigSubPacket crit (RegularExpression (BL.copy apdre)) getRevocable :: SigSubPacketParser -getRevocable _pt crit _l = SigSubPacket crit . Revocable <$> get +getRevocable _pt crit _l = SigSubPacket crit . Revocable . Revocability <$> get getKeyExpirationTime :: SigSubPacketParser getKeyExpirationTime _pt crit _l = @@ -457,7 +462,9 @@ (decodeUtf8With lenientDecode) (getByteString (fromIntegral (l - 2))) return $ - SigSubPacket crit (ReasonForRevocation (toFVal rcode) rreason) + SigSubPacket + crit + (ReasonForRevocation (toFVal rcode) (RevocationReason rreason)) getFeatures :: SigSubPacketParser getFeatures _pt crit l = do @@ -469,7 +476,10 @@ pka <- get ha <- get hash <- getLazyByteString (l - 3) - return $ SigSubPacket crit (SignatureTarget pka ha hash) + return $ + SigSubPacket + crit + (SignatureTarget pka ha (SignatureHash (BL.toStrict hash))) getEmbeddedSignature :: SigSubPacketParser getEmbeddedSignature _pt crit l = do @@ -539,7 +549,7 @@ SigCreationTime et -> putSigCreationTime crit et SigExpirationTime et -> putSigExpirationTime crit et ExportableCertification e -> putExportableCertification crit e - TrustSignature tl ta -> putTrustSignature crit tl ta + TrustSignature tl ta -> putTrustSignature crit (unTrustLevel tl) (unTrustAmount ta) RegularExpression apdre -> putRegularExpression crit apdre Revocable r -> putRevocable crit r KeyExpirationTime et -> putKeyExpirationTime crit et @@ -557,7 +567,7 @@ SignersUserId userid -> putSignersUserId crit userid ReasonForRevocation rcode rreason -> putReasonForRevocation crit rcode rreason Features fs -> putFeatures crit fs - SignatureTarget pka ha hash -> putSignatureTarget crit pka ha hash + SignatureTarget pka ha hash -> putSignatureTarget crit pka ha (op SignatureHash hash) EmbeddedSignature sp -> putEmbeddedSignature crit sp IssuerFingerprint kv fp -> putIssuerFingerprint crit kv fp IntendedRecipient kv irf -> putIntendedRecipient crit kv irf @@ -577,11 +587,11 @@ putSigSubPacketType crit 3 putWord32be . unThirtyTwoBitDuration $ et -putExportableCertification :: Bool -> Bool -> Put +putExportableCertification :: Bool -> Exportability -> Put putExportableCertification crit e = do putSubPacketLength 2 putSigSubPacketType crit 4 - put e + put (unExportability e) putTrustSignature :: Bool -> Word8 -> Word8 -> Put putTrustSignature crit tl ta = do @@ -597,11 +607,11 @@ putLazyByteString apdre putWord8 0 -putRevocable :: Bool -> Bool -> Put +putRevocable :: Bool -> Revocability -> Put putRevocable crit r = do putSubPacketLength 2 putSigSubPacketType crit 7 - put r + put (unRevocability r) putKeyExpirationTime :: Bool -> ThirtyTwoBitDuration -> Put putKeyExpirationTime crit et = do @@ -709,7 +719,7 @@ putReasonForRevocation :: Bool -> RevocationCode -> RevocationReason -> Put putReasonForRevocation crit rcode rreason = do - let reasonbs = encodeUtf8 rreason + let reasonbs = encodeUtf8 (unRevocationReason rreason) putSubPacketLength . fromIntegral $ (2 + B.length reasonbs) putSigSubPacketType crit 29 putWord8 . fromFVal $ rcode @@ -723,13 +733,13 @@ putLazyByteString fbs putSignatureTarget - :: Bool -> PubKeyAlgorithm -> HashAlgorithm -> BL.ByteString -> Put + :: Bool -> PubKeyAlgorithm -> HashAlgorithm -> B.ByteString -> Put putSignatureTarget crit pka ha hash = do - putSubPacketLength . fromIntegral $ (3 + BL.length hash) + putSubPacketLength . fromIntegral $ (3 + B.length hash) putSigSubPacketType crit 31 put pka put ha - putLazyByteString hash + putByteString hash putEmbeddedSignature :: Bool -> SignaturePayload -> Put putEmbeddedSignature crit sp = do @@ -1439,7 +1449,8 @@ fn <- getLazyByteString (fromIntegral flen) ts <- fmap ThirtyTwoBitTimeStamp getWord32be ldata <- getLazyByteString (len - (6 + fromIntegral flen)) - return $ LiteralDataPkt (toFVal dt) fn ts ldata + return $ + LiteralDataPkt (toFVal dt) (FileName (BL.toStrict fn)) ts ldata getPublicSubkey :: ByteOffset -> Get Pkt getPublicSubkey len = do @@ -1503,7 +1514,9 @@ bs <- getLazyByteString (l - 17) if hver /= 1 || nuls /= BL.pack (replicate 12 0) then fail "Corrupt UAt subpacket" - else return $ ImageAttribute (ImageHV1 (toFVal iformat)) bs + else + return $ + ImageAttribute (ImageHV1 (toFVal iformat)) (ImageData bs) | otherwise = do bs <- getLazyByteString (l - 1) return $ OtherUASub t bs @@ -1520,7 +1533,7 @@ putWord8 1 putWord8 (fromFVal iformat) replicateM_ 12 $ putWord8 0 - putLazyByteString idata + putLazyByteString (op ImageData idata) putUserAttrSubPacket' (OtherUASub t bs) = do putWord8 t putLazyByteString bs @@ -1651,7 +1664,7 @@ putWord8 $ fromIntegral . fromFVal $ ha putWord8 $ fromIntegral . fromFVal $ pka putLazyByteString (unEOKI skeyid) - putWord8 . fromIntegral . fromEnum $ not nested + putWord8 . fromIntegral . fromEnum $ not (unNestedFlag nested) putLengthThenPayload bs putOPSV6 :: OPSPayloadV6 -> Put @@ -1688,7 +1701,7 @@ putWord8 (fromIntegral saltSize) putLazyByteString saltBytes putLazyByteString signerFingerprint - putWord8 . fromIntegral . fromEnum $ not nested + putWord8 . fromIntegral . fromEnum $ not (unNestedFlag nested) putLengthThenPayload bs putSecretKey :: SomePKPayload -> SKAddendum -> Put @@ -1739,8 +1752,8 @@ let bs = runPut $ do putWord8 $ fromIntegral . fromFVal $ dt - putWord8 $ fromIntegral . BL.length $ fn - putLazyByteString fn + putWord8 $ fromIntegral . B.length . op FileName $ fn + putByteString (op FileName fn) putWord32be . unThirtyTwoBitTimeStamp $ ts putLazyByteString b putLengthThenPayload bs @@ -2308,8 +2321,8 @@ put kdfSA parseOPSNestedFlag :: Word8 -> Get NestedFlag -parseOPSNestedFlag 0 = pure True -parseOPSNestedFlag 1 = pure False +parseOPSNestedFlag 0 = pure (NestedFlag True) +parseOPSNestedFlag 1 = pure (NestedFlag False) parseOPSNestedFlag other = fail ("invalid OPS nested flag octet: " ++ show other) @@ -3502,6 +3515,7 @@ (\ska -> put (SecretKey pkp ska)) (snd (tk ^. tkuKey)) mapM_ (put . Signature) (_tkuRevs tk) + mapM_ (put . Signature) (_tkuDirectKeySigs tk) mapM_ putUid' (_tkuUIDs tk) mapM_ putUat' (_tkuUAts tk) mapM_ putSub' (_tkuSubs tk) diff --git a/Codec/Encryption/OpenPGP/SerializeForSigs.hs b/Codec/Encryption/OpenPGP/SerializeForSigs.hs --- a/Codec/Encryption/OpenPGP/SerializeForSigs.hs +++ b/Codec/Encryption/OpenPGP/SerializeForSigs.hs @@ -231,10 +231,10 @@ kandKPayload (lastPrimaryKey state) (lastSubkey state) payloadForSig PrimaryKeyBindingSig state = kandKPayload (lastPrimaryKey state) (lastSubkey state) -payloadForSig SignatureDirectlyOnAKey state = +payloadForSig DirectKeySignature state = runPut (putKeyforSigning (lastPrimaryKey state)) payloadForSig KeyRevocationSig state = - payloadForSig SignatureDirectlyOnAKey state + payloadForSig DirectKeySignature state payloadForSig SubkeyRevocationSig state = kandKPayload (lastPrimaryKey state) (lastSubkey state) payloadForSig CertRevocationSig state = diff --git a/Codec/Encryption/OpenPGP/Signatures.hs b/Codec/Encryption/OpenPGP/Signatures.hs --- a/Codec/Encryption/OpenPGP/Signatures.hs +++ b/Codec/Encryption/OpenPGP/Signatures.hs @@ -320,7 +320,7 @@ renderSignError (SignUnsupportedKeySignatureType st) = "unsupported key signature type: " ++ show st - ++ " (expected SignatureDirectlyOnAKey or KeyRevocationSig)" + ++ " (expected DirectKeySignature or KeyRevocationSig)" renderSignError (SignV6SaltSizeMismatch ha expected actual) = "v6 signature salt size mismatch for " ++ show ha @@ -640,6 +640,7 @@ verifyTKWith vsf mt tk = do revokers <- checkRevokers tk revs <- checkKeyRevocations revokers tk + directKeySigs <- checkDirectKeySigs tk let uids = filter (not . null . snd) . checkUidSigs $ tk ^. tkUIDs let uats = filter (not . null . snd) . checkUAtSigs $ tk ^. tkUAts let subs = concatMap checkSub $ tk ^. tkSubs @@ -647,6 +648,7 @@ TK { _tkPrimaryKey = tk ^. tkPrimaryKey , _tkRevs = revs + , _tkDirectKeySigs = directKeySigs , _tkUIDs = uids , _tkUAts = uats , _tkSubs = subs @@ -658,7 +660,7 @@ . rights . map verifyRevoker . filter isRevokerP - $ tk ^. tkRevs + $ tk ^. tkDirectKeySigs checkKeyRevocations :: [(PubKeyAlgorithm, Fingerprint)] -> TK k @@ -670,6 +672,20 @@ . map (liftM2 fmap (,) vSig) $ k ^. tkRevs + checkDirectKeySigs + :: TK k + -> Either VerificationError [SignaturePayload] + checkDirectKeySigs k = + map fst + <$> sequence + ( concatMap + ( \sp -> + case vSig sp of + Left err -> [Left err] + Right verification -> [Right (sp, verification)] + ) + (k ^. tkDirectKeySigs) + ) checkUidSigs :: [(Text, [SignaturePayload])] -> [(Text, [SignaturePayload])] checkUidSigs = @@ -718,9 +734,6 @@ -> [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 @@ -1714,7 +1727,7 @@ signDirectKeyWithRSA :: SigType - -- ^ key-scoped signature type (SignatureDirectlyOnAKey or KeyRevocationSig) + -- ^ key-scoped signature type (DirectKeySignature or KeyRevocationSig) -> SomePKPayload -- ^ primary key "payload" being signed -> [SigSubPacket] @@ -1725,7 +1738,7 @@ -- ^ RSA signing key -> Either SignError SignaturePayload signDirectKeyWithRSA st pkp hsigsubs usigsubs prv - | st `elem` [SignatureDirectlyOnAKey, KeyRevocationSig] = + | st `elem` [DirectKeySignature, KeyRevocationSig] = signDataWithRSA st prv hsigsubs usigsubs keypayload | otherwise = Left (SignUnsupportedKeySignatureType st) diff --git a/Codec/Encryption/OpenPGP/Types/Internal/Base.hs b/Codec/Encryption/OpenPGP/Types/Internal/Base.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/Base.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/Base.hs @@ -24,20 +24,20 @@ , PubKeyAlgorithm (..) , ThirtyTwoBitTimeStamp (..) , ThirtyTwoBitDuration (..) - , Exportability - , TrustLevel - , TrustAmount + , Exportability (..) + , TrustLevel (..) + , TrustAmount (..) , AlmostPublicDomainRegex - , Revocability - , RevocationReason + , Revocability (..) + , RevocationReason (..) , KeyServer - , SignatureHash + , SignatureHash (..) , PacketVersion , V3Expiration , CompressedDataPayload - , FileName - , ImageData - , NestedFlag + , FileName (..) + , ImageData (..) + , NestedFlag (..) , HashAlgorithm (..) , bsToHexUpper , Hashed @@ -137,6 +137,11 @@ import qualified Data.Aeson.TH as ATH import Data.Bits ((.&.)) import Data.ByteArray (ByteArrayAccess) +import Data.ByteArray.Encoding + ( Base (..) + , convertFromBase + , convertToBase + ) import qualified Data.ByteString as B import qualified Data.ByteString.Base16.Lazy as B16L import Data.ByteString.Lazy (ByteString) @@ -157,6 +162,8 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8With, encodeUtf8) +import Data.Text.Encoding.Error (lenientDecode) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Time.Format (formatTime) import Data.Time.Locale.Compat (defaultTimeLocale) @@ -169,37 +176,92 @@ import System.IO.Unsafe (unsafePerformIO) import Codec.Encryption.OpenPGP.Types.Internal.PrettyUtils - ( prettyLBS + ( prettyBS + , prettyLBS ) -type Exportability = Bool +newtype Exportability = Exportability {unExportability :: Bool} + deriving (Data, Eq, Generic, Ord, Show, Typeable) -type TrustLevel = Word8 +instance Wrapped Exportability -type TrustAmount = Word8 +instance Hashable Exportability +instance Pretty Exportability where + pretty = pretty . op Exportability + +$(ATH.deriveJSON ATH.defaultOptions ''Exportability) + +newtype TrustLevel = TrustLevel {unTrustLevel :: Word8} + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +instance Wrapped TrustLevel + +instance Hashable TrustLevel + +instance Pretty TrustLevel where + pretty = pretty . op TrustLevel + +$(ATH.deriveJSON ATH.defaultOptions ''TrustLevel) + +newtype TrustAmount = TrustAmount {unTrustAmount :: Word8} + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +instance Wrapped TrustAmount + +instance Hashable TrustAmount + +instance Pretty TrustAmount where + pretty = pretty . op TrustAmount + +$(ATH.deriveJSON ATH.defaultOptions ''TrustAmount) + type AlmostPublicDomainRegex = ByteString -type Revocability = Bool +newtype Revocability = Revocability {unRevocability :: Bool} + deriving (Data, Eq, Generic, Ord, Show, Typeable) -type RevocationReason = Text +instance Wrapped Revocability -type KeyServer = ByteString +instance Hashable Revocability -type SignatureHash = ByteString +instance Pretty Revocability where + pretty = pretty . op Revocability +$(ATH.deriveJSON ATH.defaultOptions ''Revocability) + +newtype RevocationReason = RevocationReason {unRevocationReason :: Text} + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +instance Wrapped RevocationReason + +instance Hashable RevocationReason + +instance Pretty RevocationReason where + pretty = pretty . op RevocationReason + +$(ATH.deriveJSON ATH.defaultOptions ''RevocationReason) + +type KeyServer = ByteString + type PacketVersion = Word8 type V3Expiration = Word16 type CompressedDataPayload = ByteString -type FileName = ByteString +newtype NestedFlag = NestedFlag {unNestedFlag :: Bool} + deriving (Data, Eq, Generic, Ord, Show, Typeable) -type ImageData = ByteString +instance Wrapped NestedFlag -type NestedFlag = Bool +instance Hashable NestedFlag +instance Pretty NestedFlag where + pretty = pretty . op NestedFlag + +$(ATH.deriveJSON ATH.defaultOptions ''NestedFlag) + {- | Phantom types for tracking subpacket classification and signature version These types are never instantiated; they exist purely for compile-time type safety. -} @@ -671,6 +733,74 @@ hexToW8s :: ReadS Word8 hexToW8s = concatMap readHex . chunksOf 2 . map toLower +newtype SignatureHash = SignatureHash {unSignatureHash :: B.ByteString} + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +instance Wrapped SignatureHash + +instance Hashable SignatureHash + +instance Pretty SignatureHash where + pretty = prettyBS . op SignatureHash + +instance A.ToJSON SignatureHash where + toJSON = + A.toJSON + . BLC8.unpack + . BL.fromStrict + . convertToBase Base64 + . op SignatureHash + +instance A.FromJSON SignatureHash where + parseJSON = A.withText "SignatureHash" $ \t -> + either + fail + (pure . SignatureHash) + (convertFromBase Base64 (encodeUtf8 t)) + +newtype FileName = FileName {unFileName :: B.ByteString} + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +instance Wrapped FileName + +instance Hashable FileName + +instance Pretty FileName where + pretty = prettyBS . op FileName + +instance A.ToJSON FileName where + toJSON = A.toJSON . decodeUtf8With lenientDecode . op FileName + +instance A.FromJSON FileName where + parseJSON = A.withText "FileName" $ \t -> + pure (FileName (encodeUtf8 t)) + +newtype ImageData = ImageData {unImageData :: ByteString} + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +instance Wrapped ImageData + +instance Hashable ImageData + +instance Pretty ImageData where + pretty = prettyLBS . op ImageData + +instance A.ToJSON ImageData where + toJSON = + A.toJSON + . BLC8.unpack + . BL.fromStrict + . convertToBase Base64 + . BL.toStrict + . op ImageData + +instance A.FromJSON ImageData where + parseJSON = A.withText "ImageData" $ \t -> + either + fail + (pure . ImageData . BL.fromStrict) + (convertFromBase Base64 (encodeUtf8 t)) + newtype EightOctetKeyId = EightOctetKeyId { unEOKI :: ByteString @@ -1088,7 +1218,7 @@ | PositiveCert | SubkeyBindingSig | PrimaryKeyBindingSig - | SignatureDirectlyOnAKey + | DirectKeySignature | KeyRevocationSig | SubkeyRevocationSig | CertRevocationSig @@ -1113,7 +1243,7 @@ fromFVal PositiveCert = 0x13 fromFVal SubkeyBindingSig = 0x18 fromFVal PrimaryKeyBindingSig = 0x19 - fromFVal SignatureDirectlyOnAKey = 0x1F + fromFVal DirectKeySignature = 0x1F fromFVal KeyRevocationSig = 0x20 fromFVal SubkeyRevocationSig = 0x28 fromFVal CertRevocationSig = 0x30 @@ -1129,7 +1259,7 @@ toFVal 0x13 = PositiveCert toFVal 0x18 = SubkeyBindingSig toFVal 0x19 = PrimaryKeyBindingSig - toFVal 0x1F = SignatureDirectlyOnAKey + toFVal 0x1F = DirectKeySignature toFVal 0x20 = KeyRevocationSig toFVal 0x28 = SubkeyRevocationSig toFVal 0x30 = CertRevocationSig @@ -1149,7 +1279,7 @@ pretty PositiveCert = pretty "positive" pretty SubkeyBindingSig = pretty "subkey-binding" pretty PrimaryKeyBindingSig = pretty "primary-key-binding" - pretty SignatureDirectlyOnAKey = pretty "signature directly on a key" + pretty DirectKeySignature = pretty "signature directly on a key" pretty KeyRevocationSig = pretty "key-revocation" pretty SubkeyRevocationSig = pretty "subkey-revocation" pretty CertRevocationSig = pretty "cert-revocation" @@ -1554,7 +1684,7 @@ pretty "signature target" <+> pretty pka <+> pretty ha - <+> prettyLBS sh + <+> prettyBS (op SignatureHash sh) pretty (EmbeddedSignature sp) = pretty "embedded signature" <+> pretty sp pretty (IssuerFingerprint kv ifp) = pretty "issuer fingerprint (v" @@ -1610,7 +1740,9 @@ toJSON (Features ffs) = object [AK.fromString "features" .= ffs] toJSON (SignatureTarget pka ha sh) = object - [AK.fromString "signatureTarget" .= (pka, ha, BL.unpack sh)] + [ AK.fromString "signatureTarget" + .= (pka, ha, B.unpack (op SignatureHash sh)) + ] toJSON (EmbeddedSignature sp) = object [AK.fromString "embeddedSignature" .= sp] toJSON (IssuerFingerprint kv ifp) = @@ -2032,14 +2164,16 @@ instance Pretty UserAttrSubPacket where pretty (ImageAttribute ih d) = - pretty "image-attribute" <+> pretty ih <+> pretty (BL.unpack d) + pretty "image-attribute" + <+> pretty ih + <+> pretty (BL.unpack (op ImageData d)) pretty (OtherUASub t bs) = pretty "unknown attribute type" <> pretty t <+> pretty (BL.unpack bs) instance A.ToJSON UserAttrSubPacket where - toJSON (ImageAttribute ih d) = A.toJSON (ih, BL.unpack d) + toJSON (ImageAttribute ih d) = A.toJSON (ih, BL.unpack (op ImageData d)) toJSON (OtherUASub t bs) = A.toJSON (t, BL.unpack bs) -- FIXME: should this be merged with EdSigningCurve somehow? diff --git a/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs b/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs @@ -17,10 +17,11 @@ module Codec.Encryption.OpenPGP.Types.Internal.Pkt where import Control.Error.Util (hush) -import Control.Lens (makeLenses) +import Control.Lens (makeLenses, op) import Data.Aeson (object, (.=)) import qualified Data.Aeson as A import qualified Data.Aeson.Key as AK +import qualified Data.ByteString as B import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import Data.Data @@ -45,7 +46,8 @@ import Codec.Encryption.OpenPGP.Types.Internal.Base import Codec.Encryption.OpenPGP.Types.Internal.PKITypes import Codec.Encryption.OpenPGP.Types.Internal.PrettyUtils - ( prettyLBS + ( prettyBS + , prettyLBS ) data PKESKPayloadVersion = PKESKV3 | PKESKV6 @@ -381,7 +383,7 @@ pretty (LiteralDataPkt dt fn ts bs) = pretty "literal-data" <+> pretty dt - <+> prettyLBS fn + <+> prettyBS (op FileName fn) <+> pretty ts <+> pretty (bsToHexUpper bs) pretty (TrustPkt bs) = pretty "trust:" <+> pretty (BL.unpack bs) @@ -532,7 +534,7 @@ [ AK.fromString "literaldata" .= object [ AK.fromString "dt" .= dt - , AK.fromString "filename" .= BL.unpack fn + , AK.fromString "filename" .= B.unpack (op FileName fn) , AK.fromString "ts" .= ts , AK.fromString "data" .= BL.unpack bs ] diff --git a/Codec/Encryption/OpenPGP/Types/Internal/TK.hs b/Codec/Encryption/OpenPGP/Types/Internal/TK.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/TK.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/TK.hs @@ -14,8 +14,132 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -module Codec.Encryption.OpenPGP.Types.Internal.TK where +module Codec.Encryption.OpenPGP.Types.Internal.TK + ( -- * Types + TKUnknown (..) + , TK (..) + , SomeTK (..) + , TKKind (..) + , TKConversionError (..) + , PacketZipper (..) + , TKKindToKeyPktKind + , KeyringIxs + , PublicKeyring + , SecretKeyring + , KeyringOf + -- * Structured types + , TKWithWireRep (..) + , PacketRefId (..) + , SignatureWithWireRef (..) + , UIDWithWireRefs (..) + , UATWithWireRefs (..) + , SubkeyWithWireRefs (..) + , TKStructuredWithWireRep (..) + , CanonicalizeTKWithWireRepError (..) + + -- * Constructors + , mkTKUnknown + , fromPrimaryKeyPktToSomeTK + + -- * Conversions + , tkToUnknown + , someTKToUnknown + , someTKToPublicTK + , someTKToSecretTK + , someTKToPublicViewTK + , publicViewTK + , fromUnknownToTK + , fromUnknownToTKEither + , tkSecretKeyPairs + , modifyTKSecretKeys + + -- * Canonicalization + , canonicalizeTKStructuredWithWireRep + , canonicalizeTKWithWireRep + , toStructuredTKWithWireRep + + -- * Wire representation + , wireRepOfTK + , wireRepsOfTK + , packetRefsOfTK + , packetRefIdOf + , lookupPacketRef + , packetWireBytesForRef + , tksFromWireRep + , tksContainingPacket + + -- * Sorting/comparison + , signatureWireSortKey + , uidWireSortKey + , uatWireSortKey + , subkeyWireSortKey + , compareSignatureWithWireRefCanonical + , compareUIDWithWireRefsCanonical + , compareUATWithWireRefsCanonical + , compareSubkeyWithWireRefsCanonical + , sortCanonicalByKey + , sortSignatureWithWireRefsCanonical + , sortUIDWithWireRefsCanonical + , sortUATWithWireRefsCanonical + , sortSubkeyWithWireRefsCanonical + + -- * Instances + , Eq (..) + , Ord (..) + , Show (..) + + -- * Lenses + , tkuKey + , tkuRevs + , tkuDirectKeySigs + , tkuUIDs + , tkuUAts + , tkuSubs + , tkPrimaryKey + , tkRevs + , tkDirectKeySigs + , tkUIDs + , tkUAts + , tkSubs + , tkWireRepRefs + , tkWireRepRange + , tkPackets + , tkStructuredWireRepRefs + , tkStructuredWireRepRange + , tkStructuredPrimaryKey + , tkStructuredPrimaryKeyRef + , tkStructuredRevs + , tkStructuredDirectKeySigs + , tkStructuredUIDs + , tkStructuredUAts + , tkStructuredSubkeys + , tkStructuredPacketRefs + , signatureWithWireRefRef + , signatureWithWireRefValue + , uidWithWireRefsRef + , uidWithWireRefsValue + , uidWithWireRefsSignatures + , uatWithWireRefsRef + , uatWithWireRefsValue + , uatWithWireRefsSignatures + , subkeyWithWireRefsRef + , subkeyWithWireRefsValue + , subkeyWithWireRefsSignatures + , pktWireRep + , pktValue + , pktIndex + , pktRange + , pktWireRepRef + , zpBefore + , zpCurrent + , zpAfter + , packetRefWireRepRef + , packetRefIndex + , rangeOffset + , rangeLength + ) where + import Control.Arrow ((&&&)) import Control.Comonad (Comonad (..)) import Control.Error.Util (note) @@ -108,6 +232,7 @@ = TKUnknown { _tkuKey :: (SomePKPayload, Maybe SKAddendum) , _tkuRevs :: [SignaturePayload] + , _tkuDirectKeySigs :: [SignaturePayload] , _tkuUIDs :: [(Text, [SignaturePayload])] , _tkuUAts :: [([UserAttrSubPacket], [SignaturePayload])] , _tkuSubs :: [(Pkt, [SignaturePayload])] @@ -127,6 +252,7 @@ = TK { _tkPrimaryKey :: KeyPkt (TKKindToKeyPktKind k) , _tkRevs :: [SignaturePayload] + , _tkDirectKeySigs :: [SignaturePayload] , _tkUIDs :: [(Text, [SignaturePayload])] , _tkUAts :: [([UserAttrSubPacket], [SignaturePayload])] , _tkSubs :: [(KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])] @@ -153,6 +279,8 @@ | SecretSubkeyHasPrimaryRole | ExpectedPublicSubkeyPacket Word8 | ExpectedSecretSubkeyPacket Word8 + | ExpectedPublicPrimaryKeyPacket Word8 + | ExpectedSecretPrimaryKeyPacket Word8 deriving (Eq, Show) renderTKConversionError :: TKConversionError -> String @@ -162,12 +290,17 @@ "expected public subkey, got packet tag " ++ show tagValue renderTKConversionError (ExpectedSecretSubkeyPacket tagValue) = "expected secret subkey, got packet tag " ++ show tagValue +renderTKConversionError (ExpectedPublicPrimaryKeyPacket tagValue) = + "expected primary key packet, got packet tag " ++ show tagValue +renderTKConversionError (ExpectedSecretPrimaryKeyPacket tagValue) = + "expected primary key packet, got packet tag " ++ show tagValue tkToUnknown :: TK k -> TKUnknown tkToUnknown tk = TKUnknown { _tkuKey = keyPktTKKey (_tkPrimaryKey tk) , _tkuRevs = _tkRevs tk + , _tkuDirectKeySigs = _tkDirectKeySigs tk , _tkuUIDs = _tkUIDs tk , _tkuUAts = _tkUAts tk , _tkuSubs = @@ -183,18 +316,21 @@ TKUnknown { _tkuKey = (pkp, maybeSka) , _tkuRevs = [] + , _tkuDirectKeySigs = [] , _tkuUIDs = [] , _tkuUAts = [] , _tkuSubs = [] } -fromPrimaryKeyPktToSomeTK :: Pkt -> Either String SomeTK +fromPrimaryKeyPktToSomeTK + :: Pkt -> Either TKConversionError SomeTK fromPrimaryKeyPktToSomeTK (PublicKeyPkt pkp) = Right ( SomePublicTK ( TK { _tkPrimaryKey = KeyPktPublicPrimary pkp , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -207,17 +343,19 @@ ( TK { _tkPrimaryKey = KeyPktSecretPrimary pkp ska , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] } ) ) +fromPrimaryKeyPktToSomeTK (PublicSubkeyPkt _) = + Left PublicSubkeyHasPrimaryRole +fromPrimaryKeyPktToSomeTK (SecretSubkeyPkt _ _) = + Left SecretSubkeyHasPrimaryRole fromPrimaryKeyPktToSomeTK pkt = - Left - ( "expected primary key packet, got packet tag " - ++ show (pktTag pkt) - ) + Left (ExpectedPublicPrimaryKeyPacket (pktTag pkt)) someTKToPublicTK :: SomeTK -> Maybe (TK 'PublicTK) someTKToPublicTK (SomePublicTK tk) = Just tk @@ -236,6 +374,7 @@ TK { _tkPrimaryKey = keyPktToPublicView (_tkPrimaryKey tk) , _tkRevs = _tkRevs tk + , _tkDirectKeySigs = _tkDirectKeySigs tk , _tkUIDs = _tkUIDs tk , _tkUAts = _tkUAts tk , _tkSubs = @@ -247,6 +386,35 @@ let xs = view (to _tkSubs) tk in xs ^.. (folded . _1 . to SomeKeyPkt) +tkSecretKeyPairs :: TK 'SecretTK -> [(SomePKPayload, SKAddendum)] +tkSecretKeyPairs tk = + [ (keyPktPKPayload kp, secretKeyPktSKAddendum kp) + | kp <- _tkPrimaryKey tk : map fst (_tkSubs tk) + ] + +modifyTKSecretKeys + :: TK 'SecretTK + -> (SomePKPayload -> SKAddendum -> (SomePKPayload, SKAddendum)) + -> TK 'SecretTK +modifyTKSecretKeys tk f = + tk + { _tkPrimaryKey = go (_tkPrimaryKey tk) + , _tkSubs = + map + ( \(kp, sigs) -> + (go kp, sigs) + ) + (_tkSubs tk) + } + where + go :: KeyPkt 'SecretPkt -> KeyPkt 'SecretPkt + go (KeyPktSecretPrimary pkp ska) = + let (pkp', ska') = f pkp ska + in KeyPktSecretPrimary pkp' ska' + go (KeyPktSecretSubkey pkp ska) = + let (pkp', ska') = f pkp ska + in KeyPktSecretSubkey pkp' ska' + fromUnknownToTKEither :: TKUnknown -> Either TKConversionError SomeTK fromUnknownToTKEither tk = @@ -258,6 +426,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary pkp , _tkRevs = _tkuRevs tk + , _tkDirectKeySigs = _tkuDirectKeySigs tk , _tkUIDs = _tkuUIDs tk , _tkUAts = _tkuUAts tk , _tkSubs = subs @@ -271,6 +440,7 @@ TK { _tkPrimaryKey = KeyPktSecretPrimary pkp ska , _tkRevs = _tkuRevs tk + , _tkDirectKeySigs = _tkuDirectKeySigs tk , _tkUIDs = _tkuUIDs tk , _tkUAts = _tkuUAts tk , _tkSubs = subs @@ -314,6 +484,11 @@ ( Set.toList $ Set.union (Set.fromList (_tkuRevs a)) (Set.fromList (_tkuRevs b)) ) + ( Set.toList $ + Set.union + (Set.fromList (_tkuDirectKeySigs a)) + (Set.fromList (_tkuDirectKeySigs b)) + ) ((kvmerge `on` _tkuUIDs) a b) ((kvmerge `on` _tkuUAts) a b) ((ukvmerge `on` _tkuSubs) a b) @@ -332,6 +507,11 @@ ( Set.toList $ Set.union (Set.fromList (_tkRevs a)) (Set.fromList (_tkRevs b)) ) + ( Set.toList $ + Set.union + (Set.fromList (_tkDirectKeySigs a)) + (Set.fromList (_tkDirectKeySigs b)) + ) ((kvmerge `on` _tkUIDs) a b) ((kvmerge `on` _tkUAts) a b) ((ukvmerge `on` _tkSubs) a b) @@ -409,7 +589,8 @@ , _tkStructuredWireRepRange :: Maybe ByteRange , _tkStructuredPrimaryKey :: (SomePKPayload, Maybe SKAddendum) , _tkStructuredPrimaryKeyRef :: PacketRefId - , _tkStructuredDirectSignatures :: [SignatureWithWireRef] + , _tkStructuredRevs :: [SignatureWithWireRef] + , _tkStructuredDirectKeySigs :: [SignatureWithWireRef] , _tkStructuredUIDs :: [UIDWithWireRefs] , _tkStructuredUAts :: [UATWithWireRefs] , _tkStructuredSubkeys :: [SubkeyWithWireRefs] @@ -606,7 +787,10 @@ buildTK <$> sortSignatureWithWireRefsCanonical structured - (_tkStructuredDirectSignatures structured) + (_tkStructuredRevs structured) + <*> sortSignatureWithWireRefsCanonical + structured + (_tkStructuredDirectKeySigs structured) <*> sortUIDWithWireRefsCanonical structured (_tkStructuredUIDs structured) @@ -617,10 +801,11 @@ structured (_tkStructuredSubkeys structured) where - buildTK directSigs uids uats subs = + buildTK revs directKeySigs uids uats subs = TKUnknown { _tkuKey = _tkStructuredPrimaryKey structured - , _tkuRevs = map _signatureWithWireRefValue directSigs + , _tkuRevs = map _signatureWithWireRefValue revs + , _tkuDirectKeySigs = map _signatureWithWireRefValue directKeySigs , _tkuUIDs = map ( _uidWithWireRefsValue @@ -669,19 +854,22 @@ Nothing -> -- Primary key is the only packet; only valid if no revisions, UIDs, UATs, or subkeys if null (_tkuRevs tk) + && null (_tkuDirectKeySigs tk) && null (_tkuUIDs tk) && null (_tkuUAts tk) && null (_tkuSubs tk) then Right z1' else Left "missing signatures/UIDs/subkeys after primary key packet" - (directSigs, z2) <- - consumeSigsZ "direct-key signatures" (_tkuRevs tk) z1 - (uids, z3) <- consumeUIDsZ (_tkuUIDs tk) z2 - (uats, z4) <- consumeUATsZ (_tkuUAts tk) z3 - (subs, z5) <- consumeSubsZ (_tkuSubs tk) z4 + (revs, z2) <- + consumeSigsZ "key-revocation signatures" (_tkuRevs tk) z1 + (directKeySigs, z3) <- + consumeSigsZ "direct-key signatures" (_tkuDirectKeySigs tk) z2 + (uids, z4) <- consumeUIDsZ (_tkuUIDs tk) z3 + (uats, z5) <- consumeUATsZ (_tkuUAts tk) z4 + (subs, z6) <- consumeSubsZ (_tkuSubs tk) z5 -- Check if there are trailing packets AFTER the current focus (not including it) - case _zpAfter z5 of + case _zpAfter z6 of [] -> Right ( TKStructuredWithWireRep @@ -689,7 +877,8 @@ (_tkWireRepRange tkWithRefs) (_tkuKey tk) (packetRefIdOf primaryRef) - directSigs + revs + directKeySigs uids uats subs diff --git a/Data/Conduit/OpenPGP/Keyring/Instances.hs b/Data/Conduit/OpenPGP/Keyring/Instances.hs --- a/Data/Conduit/OpenPGP/Keyring/Instances.hs +++ b/Data/Conduit/OpenPGP/Keyring/Instances.hs @@ -56,6 +56,7 @@ flattenTKPackets tk = [someKeyPktToPkt (mkPrimaryKeyPkt pkp mska)] ++ map SignaturePkt (_tkuRevs tk) + ++ map SignaturePkt (_tkuDirectKeySigs tk) ++ concatMap flattenUID (_tkuUIDs tk) ++ concatMap flattenUAT (_tkuUAts tk) ++ concatMap flattenSub (_tkuSubs tk) diff --git a/Data/Conduit/OpenPGP/Verify.hs b/Data/Conduit/OpenPGP/Verify.hs --- a/Data/Conduit/OpenPGP/Verify.hs +++ b/Data/Conduit/OpenPGP/Verify.hs @@ -151,12 +151,12 @@ isOpeningOnePassSignature :: Pkt -> Bool isOpeningOnePassSignature ( OnePassSignaturePkt - (OPSPayloadV3Packet (OPSPayloadV3 _ _ _ _ _ False)) + (OPSPayloadV3Packet (OPSPayloadV3 _ _ _ _ _ (NestedFlag False))) ) = True isOpeningOnePassSignature ( OnePassSignaturePkt - (OPSPayloadV6Packet (OPSPayloadV6 _ _ _ _ _ False)) + (OPSPayloadV6Packet (OPSPayloadV6 _ _ _ _ _ (NestedFlag False))) ) = True isOpeningOnePassSignature _ = False diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,6 +1,6 @@ Cabal-version: 3.4 Name: hOpenPGP -Version: 3.3 +Version: 3.4 Synopsis: native Haskell implementation of OpenPGP (RFC9580) Description: native Haskell implementation of OpenPGP (RFC9580), with some backwards compatibility Homepage: https://salsa.debian.org/clint/hOpenPGP @@ -224,6 +224,7 @@ , Codec.Encryption.OpenPGP.Encrypt , Codec.Encryption.OpenPGP.Expirations , Codec.Encryption.OpenPGP.Fingerprint + , Codec.Encryption.OpenPGP.KeyGeneration , Codec.Encryption.OpenPGP.KeyInfo , Codec.Encryption.OpenPGP.KeyringParser , Codec.Encryption.OpenPGP.KeySelection @@ -275,6 +276,7 @@ , Codec.Encryption.OpenPGP.Encrypt , Codec.Encryption.OpenPGP.Expirations , Codec.Encryption.OpenPGP.Fingerprint + , Codec.Encryption.OpenPGP.KeyGeneration , Codec.Encryption.OpenPGP.KeyInfo , Codec.Encryption.OpenPGP.KeyringParser , Codec.Encryption.OpenPGP.KeySelection @@ -308,6 +310,7 @@ other-modules: Codec.Encryption.OpenPGP.Arbitrary , Tests.Common , Tests.Encryption + , Tests.KeyGeneration , Tests.Keys , Tests.MessageAndArmor , Tests.Properties @@ -340,4 +343,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hOpenPGP.git - tag: v3.3 + tag: v3.4 diff --git a/tests/Tests/Common.hs b/tests/Tests/Common.hs --- a/tests/Tests/Common.hs +++ b/tests/Tests/Common.hs @@ -1604,7 +1604,7 @@ (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime case signDirectKeyWithRSA - SignatureDirectlyOnAKey + DirectKeySignature signer (hashedExtras ++ hashed) unhashed @@ -1658,7 +1658,7 @@ , verificationMode = VerificationBatch } keyring - [ LiteralDataPkt BinaryData BL.empty 0 payload + [ LiteralDataPkt BinaryData (FileName B.empty) 0 payload , SignaturePkt sigPayload ] @@ -1785,7 +1785,9 @@ messageIssuerSubpacketsAt signer creationTime case signKeyRevocationWithRSA signer - ( SigSubPacket False (ReasonForRevocation reasonCode "") + ( SigSubPacket + False + (ReasonForRevocation reasonCode (RevocationReason "")) : hashedExtras ++ hashed ) diff --git a/tests/Tests/Encryption.hs b/tests/Tests/Encryption.hs --- a/tests/Tests/Encryption.hs +++ b/tests/Tests/Encryption.hs @@ -1389,7 +1389,7 @@ [ esk , LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) "not-encrypted" ] @@ -1830,7 +1830,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] @@ -1915,7 +1915,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] @@ -2033,7 +2033,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] @@ -2251,7 +2251,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] @@ -3086,6 +3086,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary signingPrimary , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = @@ -3126,6 +3127,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary primary , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [(KeyPktPublicSubkey subkey, [])] @@ -3153,6 +3155,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary signingPrimary , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -3188,6 +3191,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary primary , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])] @@ -3223,6 +3227,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary signingPrimary , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -3262,6 +3267,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary primary , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])] @@ -3307,6 +3313,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary primary , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = @@ -3353,7 +3360,8 @@ let tk = TK { _tkPrimaryKey = KeyPktPublicPrimary primary - , _tkRevs = [directKeySig] + , _tkRevs = [] + , _tkDirectKeySigs = [directKeySig] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])] @@ -3402,6 +3410,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary primary , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])] @@ -3447,6 +3456,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary primary , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])] @@ -3487,6 +3497,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary primary , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])] @@ -3524,6 +3535,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary primary , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])] @@ -3557,6 +3569,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary primary , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])] @@ -3637,7 +3650,9 @@ DC..| CL.consume case decrypted of [ OnePassSignaturePkt - (OPSPayloadV3Packet (OPSPayloadV3 3 BinarySig SHA256 RSA _ False)) + ( OPSPayloadV3Packet + (OPSPayloadV3 3 BinarySig SHA256 RSA _ (NestedFlag False)) + ) , LiteralDataPkt _ _ _ gotPayload , SignaturePkt _ ] -> @@ -4177,7 +4192,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] @@ -4232,7 +4247,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) "payload" ] @@ -4307,7 +4322,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] @@ -4395,7 +4410,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] @@ -4509,7 +4524,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] @@ -4629,7 +4644,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] @@ -4740,7 +4755,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] @@ -4855,7 +4870,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] @@ -4987,7 +5002,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] @@ -5088,7 +5103,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] @@ -5216,7 +5231,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] @@ -5377,7 +5392,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] @@ -5513,7 +5528,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] @@ -5650,7 +5665,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] @@ -5810,7 +5825,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] @@ -5932,7 +5947,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] @@ -6029,7 +6044,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] @@ -6164,7 +6179,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] @@ -6300,7 +6315,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] @@ -6446,7 +6461,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] @@ -6574,7 +6589,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] @@ -6680,7 +6695,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] @@ -6786,7 +6801,7 @@ Block [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ] diff --git a/tests/Tests/KeyGeneration.hs b/tests/Tests/KeyGeneration.hs new file mode 100644 --- /dev/null +++ b/tests/Tests/KeyGeneration.hs @@ -0,0 +1,143 @@ +-- KeyGeneration.hs: hOpenPGP key generation tests +-- Copyright © 2012-2026 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Tests.KeyGeneration (keyGenerationTests) where + +import Control.Monad.Trans.Except (runExceptT) +import Crypto.Random.Types (getRandomBytes) +import Data.Binary.Get (Get, runGetOrFail) +import Data.Binary.Put (runPut) +import qualified Data.ByteString.Lazy as BL +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit + ( Assertion + , assertEqual + , assertFailure + , testCase + ) + +import Codec.Encryption.OpenPGP.KeyGeneration + ( KeyGenSpec (..) + , generateSecretKey + ) +import Codec.Encryption.OpenPGP.Serialize + ( getSecretKey + , putSKeyForPKPayload + ) +import Codec.Encryption.OpenPGP.Types + +keyGenerationTests :: TestTree +keyGenerationTests = + testGroup + "Key generation" + [ testGroup + "RSA" + [ testCase "V4 RSA 1024-bit round-trip" testRSAV4RoundTrip + , testCase "V6 RSA 1024-bit round-trip" testRSAV6RoundTrip + , testCase "RSA key size must be multiple of 8" testRSAMultipleOf8 + ] + , testGroup + "Ed25519" + [ testCase "V6 Ed25519 round-trip" testEd25519V6RoundTrip + ] + , testGroup + "Ed448" + [ testCase "V6 Ed448 round-trip" testEd448V6RoundTrip + ] + , testGroup + "X25519" + [ testCase "V6 X25519 round-trip" testX25519V6RoundTrip + ] + , testGroup + "X448" + [ testCase "V6 X448 round-trip" testX448V6RoundTrip + ] + ] + +roundTripAssertion + :: String + -> SomePKPayload + -> SKey + -> Assertion +roundTripAssertion label pkp skey = do + put <- + either + (assertFailure . ("serialize failed: " ++)) + pure + (putSKeyForPKPayload pkp skey) + let bs = runPut put + case runGetOrFail (getSecretKey pkp) bs of + Left (_, _, err) -> assertFailure ("getSecretKey failed: " ++ err) + Right (_, _, parsedSkey) -> + assertEqual (label ++ " secret key round-trip") skey parsedSkey + +testRSAV4RoundTrip :: Assertion +testRSAV4RoundTrip = do + result <- + runExceptT $ + generateSecretKey (KeyGenRSA @V4 (ThirtyTwoBitTimeStamp 0) 1024) + case result of + Left err -> assertFailure ("generateSecretKey failed: " ++ err) + Right (pkp, skey) -> roundTripAssertion "RSA V4" pkp skey + +testRSAV6RoundTrip :: Assertion +testRSAV6RoundTrip = do + result <- + runExceptT $ + generateSecretKey (KeyGenRSA @V6 (ThirtyTwoBitTimeStamp 0) 1024) + case result of + Left err -> assertFailure ("generateSecretKey failed: " ++ err) + Right (pkp, skey) -> roundTripAssertion "RSA V6" pkp skey + +testRSAMultipleOf8 :: Assertion +testRSAMultipleOf8 = do + result <- + runExceptT $ + generateSecretKey (KeyGenRSA @V4 (ThirtyTwoBitTimeStamp 0) 1023) + case result of + Left _ -> pure () + Right _ -> + assertFailure + "expected failure for non-multiple-of-8 RSA key size" + +testEd25519V6RoundTrip :: Assertion +testEd25519V6RoundTrip = do + result <- + runExceptT $ + generateSecretKey (KeyGenEd25519 (ThirtyTwoBitTimeStamp 0)) + case result of + Left err -> assertFailure ("generateSecretKey failed: " ++ err) + Right (pkp, skey) -> roundTripAssertion "Ed25519 V6" pkp skey + +testEd448V6RoundTrip :: Assertion +testEd448V6RoundTrip = do + result <- + runExceptT $ + generateSecretKey (KeyGenEd448 (ThirtyTwoBitTimeStamp 0)) + case result of + Left err -> assertFailure ("generateSecretKey failed: " ++ err) + Right (pkp, skey) -> roundTripAssertion "Ed448 V6" pkp skey + +testX25519V6RoundTrip :: Assertion +testX25519V6RoundTrip = do + result <- + runExceptT $ + generateSecretKey (KeyGenX25519 (ThirtyTwoBitTimeStamp 0)) + case result of + Left err -> assertFailure ("generateSecretKey failed: " ++ err) + Right (pkp, skey) -> roundTripAssertion "X25519 V6" pkp skey + +testX448V6RoundTrip :: Assertion +testX448V6RoundTrip = do + result <- + runExceptT $ + generateSecretKey (KeyGenX448 (ThirtyTwoBitTimeStamp 0)) + case result of + Left err -> assertFailure ("generateSecretKey failed: " ++ err) + Right (pkp, skey) -> roundTripAssertion "X448 V6" pkp skey diff --git a/tests/Tests/Keys.hs b/tests/Tests/Keys.hs --- a/tests/Tests/Keys.hs +++ b/tests/Tests/Keys.hs @@ -593,7 +593,7 @@ packets = [ LiteralDataPkt BinaryData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) "payload" , SignaturePkt sigPayload @@ -633,6 +633,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary primarySigner , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -683,6 +684,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary primarySigner , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -1072,6 +1074,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [(uidText, [longValidityCert, temporaryValidityCert])] , _tkUAts = [] , _tkSubs = [] @@ -1137,6 +1140,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [(uidText, [firstCertification, secondCertification])] , _tkUAts = [] , _tkSubs = [] @@ -1193,6 +1197,7 @@ TK (KeyPktPublicPrimary signer) [] + [] [(uidText, [certification])] [] [] @@ -1256,6 +1261,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [(uidText, [certification, temporaryRevocation])] , _tkUAts = [] , _tkSubs = [] @@ -1314,6 +1320,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [(uidText, [firstCertification, secondCertification])] , _tkUAts = [] , _tkSubs = [] @@ -1345,12 +1352,13 @@ revocationTime [ SigSubPacket False - (ReasonForRevocation UserIdInfoNoLongerValid "") + (ReasonForRevocation UserIdInfoNoLongerValid (RevocationReason "")) ] let tk :: TK 'PublicTK = TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [(uidText, [certification, retirementRevocation])] , _tkUAts = [] , _tkSubs = [] @@ -1410,6 +1418,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary targetSigner , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [(uidText, [thirdPartyCertification])] , _tkUAts = [] , _tkSubs = [] @@ -1418,6 +1427,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary thirdPartySigner , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -1483,6 +1493,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary targetSigner , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [ ( uidText @@ -1500,6 +1511,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary thirdPartySigner , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -1583,6 +1595,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [ ( uidText @@ -1793,7 +1806,7 @@ testPolicySignatureContextValidation :: Assertion testPolicySignatureContextValidation = do let pkSigV4PK = SigV4 KeyRevocationSig RSA SHA512 [] [] 0 (MPI 0 :| []) - pkSigV4Direct = SigV4 SignatureDirectlyOnAKey RSA SHA512 [] [] 0 (MPI 0 :| []) + pkSigV4Direct = SigV4 DirectKeySignature RSA SHA512 [] [] 0 (MPI 0 :| []) pkSigV4Binding = SigV4 SubkeyBindingSig RSA SHA512 [] [] 0 (MPI 0 :| []) pkSigV6PK = SigV6 @@ -1807,7 +1820,7 @@ (MPI 0 :| []) pkSigV6Direct = SigV6 - SignatureDirectlyOnAKey + DirectKeySignature EdDSALegacy SHA512 (SignatureSalt (BL.replicate 32 0x12)) @@ -1827,7 +1840,7 @@ (MPI 0 :| []) skSigV4Binding = SigV4 SubkeyBindingSig RSA SHA512 [] [] 0 (MPI 0 :| []) skSigV4Revocation = SigV4 SubkeyRevocationSig RSA SHA512 [] [] 0 (MPI 0 :| []) - skSigV4Direct = SigV4 SignatureDirectlyOnAKey RSA SHA512 [] [] 0 (MPI 0 :| []) + skSigV4Direct = SigV4 DirectKeySignature RSA SHA512 [] [] 0 (MPI 0 :| []) skSigV6Binding = SigV6 SubkeyBindingSig @@ -1850,7 +1863,7 @@ (MPI 0 :| []) skSigV6Direct = SigV6 - SignatureDirectlyOnAKey + DirectKeySignature EdDSALegacy SHA512 (SignatureSalt (BL.replicate 32 0x16)) @@ -1928,7 +1941,7 @@ "KeyRevocationSig allowed on primary key" (isAllowedPrimaryKeySig pkSigV4PK) assertTrue - "SignatureDirectlyOnAKey allowed on primary key" + "DirectKeySignature allowed on primary key" (isAllowedPrimaryKeySig pkSigV4Direct) assertFalse "SubkeyBindingSig not allowed on primary key" @@ -1937,7 +1950,7 @@ "v6 KeyRevocationSig allowed on primary key" (isAllowedPrimaryKeySig pkSigV6PK) assertTrue - "v6 SignatureDirectlyOnAKey allowed on primary key" + "v6 DirectKeySignature allowed on primary key" (isAllowedPrimaryKeySig pkSigV6Direct) assertFalse "v6 SubkeyBindingSig not allowed on primary key" @@ -1949,7 +1962,7 @@ "SubkeyRevocationSig allowed on subkey" (isAllowedSubkeySig skSigV4Revocation) assertFalse - "SignatureDirectlyOnAKey not allowed on subkey" + "DirectKeySignature not allowed on subkey" (isAllowedSubkeySig skSigV4Direct) assertTrue "v6 SubkeyBindingSig allowed on subkey" @@ -1958,7 +1971,7 @@ "v6 SubkeyRevocationSig allowed on subkey" (isAllowedSubkeySig skSigV6Revocation) assertFalse - "v6 SignatureDirectlyOnAKey not allowed on subkey" + "v6 DirectKeySignature not allowed on subkey" (isAllowedSubkeySig skSigV6Direct) assertTrue "GenericCert allowed on UID" @@ -2291,10 +2304,13 @@ case packets of (SecretKeyPkt pkp _ : _) -> case fromPrimaryKeyPktToSomeTK (PublicSubkeyPkt pkp) of - Left err -> + Left PublicSubkeyHasPrimaryRole -> assertBool - "fromPrimaryKeyPktToSomeTK should report non-primary packet tags" - ("expected primary key packet" `isInfixOf` err) + "fromPrimaryKeyPktToSomeTK should reject subkey packets" + True + Left _ -> + assertFailure + "fromPrimaryKeyPktToSomeTK should report PublicSubkeyHasPrimaryRole" Right _ -> assertFailure "fromPrimaryKeyPktToSomeTK should reject subkey packets" diff --git a/tests/Tests/MessageAndArmor.hs b/tests/Tests/MessageAndArmor.hs --- a/tests/Tests/MessageAndArmor.hs +++ b/tests/Tests/MessageAndArmor.hs @@ -971,7 +971,11 @@ salt = Salt (B.pack [0x20 .. 0x3f]) block = Block - [ LiteralDataPkt BinaryData BL.empty 0 (clearPayloadBytes payload) + [ LiteralDataPkt + BinaryData + (FileName B.empty) + 0 + (clearPayloadBytes payload) ] packets <- case encryptSEIPDv2WithSKESKBlock @@ -1042,7 +1046,9 @@ let passphraseBytes = "roundtrip-EAX" s2k = Argon2 (Salt16 (B.pack [0x10 .. 0x1f])) 1 4 15 salt = Salt (B.pack [0x20 .. 0x3f]) - block = Block [LiteralDataPkt BinaryData BL.empty 0 "hello from EAX"] + block = + Block + [LiteralDataPkt BinaryData (FileName B.empty) 0 "hello from EAX"] case encryptSEIPDv2WithSKESKBlock AES128 EAX @@ -1208,16 +1214,22 @@ >> fail "validateSEIPD1MDC failed" Right out -> pure out case parsePktsEither (BL.fromStrict cleartext) of - Right [LiteralDataPkt BinaryData filename timestamp clearPayload] -> do - assertEqual - "RFC4880 decrypted literal filename" - BL.empty - filename - assertEqual "RFC4880 decrypted literal timestamp" 0 timestamp - assertEqual - "RFC4880 decrypted literal payload" - (clearPayloadBytes payload) - clearPayload + Right + [ LiteralDataPkt + BinaryData + (FileName filename) + timestamp + clearPayload + ] -> do + assertEqual + "RFC4880 decrypted literal filename" + B.empty + filename + assertEqual "RFC4880 decrypted literal timestamp" 0 timestamp + assertEqual + "RFC4880 decrypted literal payload" + (clearPayloadBytes payload) + clearPayload Right other -> assertFailure ( "RFC4880 decrypted cleartext should contain exactly one literal packet, got " @@ -1387,11 +1399,14 @@ ) >> fail "unexpected RSA SigV6 signMessage output shape" let state = - emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + emptyPSC + { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload + } keyring = [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -1439,11 +1454,14 @@ ) >> fail "unexpected Ed25519 signMessage output shape" let state = - emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + emptyPSC + { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload + } keyring = [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -1498,11 +1516,14 @@ case signaturePkt of SignaturePkt (SigV6 BinarySig PKA.Ed25519 SHA512 _ _ _ _ _) -> do let state = - emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + emptyPSC + { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload + } keyring = [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -1573,11 +1594,14 @@ ) >> fail "unexpected Ed448 signMessage output shape" let state = - emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + emptyPSC + { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload + } keyring = [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -1696,12 +1720,15 @@ (signer, signingKey) <- loadDeterministicEd25519Signer let payload = "detached v4 eddsa payload without issuer hints" state = - emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + emptyPSC + { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload + } keyring = mkTestKeyring [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -1732,12 +1759,15 @@ (signer, signingKey) <- loadDeterministicEd25519Signer let payload = "detached v4 eddsa payload with fake issuer hint" state = - emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + emptyPSC + { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload + } keyring = mkTestKeyring [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -1772,11 +1802,14 @@ let payload = "detached v4 eddsa payload without issuer hints (verifyAgainstKeys)" state = - emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + emptyPSC + { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload + } keys = [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -1809,11 +1842,14 @@ let payload = "detached v4 eddsa payload with fake issuer hint (verifyAgainstKeys)" state = - emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + emptyPSC + { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload + } keys = [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -1848,7 +1884,7 @@ { lastLD = LiteralDataPkt TextData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) "line1 \t\nline2\t \rline3\t \r\nline4 \t" } @@ -1868,7 +1904,7 @@ { lastLD = LiteralDataPkt TextData - BL.empty + (FileName B.empty) (ThirtyTwoBitTimeStamp 0) "line1 \t\nline2\t \r\nline3" } @@ -2130,6 +2166,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -2385,7 +2422,9 @@ "fromPktEitherSomeSignatureV rejects non-signature packets" ( not ( isRight - (fromPktEitherSomeSignatureV (LiteralDataPkt BinaryData "" 0 "")) + ( fromPktEitherSomeSignatureV + (LiteralDataPkt BinaryData (FileName "") 0 "") + ) ) ) @@ -2456,7 +2495,9 @@ assertEqual "recommendedArmorType defaults non-key/signature packets to message armor" (Just ArmorMessage) - (recommendedArmorType [LiteralDataPkt BinaryData "" 0 "payload"]) + ( recommendedArmorType + [LiteralDataPkt BinaryData (FileName "") 0 "payload"] + ) testSingleClearSignedBlock :: Assertion testSingleClearSignedBlock = do let clearSigned = @@ -2518,6 +2559,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [revocation] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -2556,6 +2598,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [revocation] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -2590,6 +2633,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [revocation] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -2624,6 +2668,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [revocation] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -2662,6 +2707,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [revocation] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -2711,6 +2757,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [revocation] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -2770,6 +2817,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary primarySigner , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [(subkeyPacket, [bindingSig, revocationSig])] @@ -2893,12 +2941,15 @@ signerWithEd25519Pka let payload = "v4 eddsa signature with Ed25519 key algorithm" state = - emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + emptyPSC + { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload + } keyring = mkTestKeyring [ TK { _tkPrimaryKey = KeyPktPublicPrimary signerWithEd25519Pka , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -3006,7 +3057,11 @@ state = emptyPSC { lastLD = - LiteralDataPkt BinaryData BL.empty 0 (BL.fromStrict fileContents) + LiteralDataPkt + BinaryData + (FileName B.empty) + 0 + (BL.fromStrict fileContents) } case verifySigWith defaultVerificationPolicy @@ -3059,6 +3114,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary pkp , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -3066,7 +3122,7 @@ ] state = emptyPSC - { lastLD = LiteralDataPkt BinaryData BL.empty 0 payload + { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload } case verifySigWith defaultVerificationPolicy @@ -3118,6 +3174,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary pkp , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -3125,7 +3182,7 @@ ] state = emptyPSC - { lastLD = LiteralDataPkt BinaryData BL.empty 0 payload + { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload } case verifySigWith defaultVerificationPolicy @@ -3160,7 +3217,7 @@ keypayload = runPut (putKeyforSigning (PublicKeyPkt pkp)) sigPayload <- case signDataWithEd25519V6 - SignatureDirectlyOnAKey + DirectKeySignature salt edSecretKey hashed @@ -3177,6 +3234,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary pkp , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -3214,7 +3272,10 @@ [ SigSubPacket False (SigCreationTime 0) , SigSubPacket False - (ReasonForRevocation KeySuperseded "v6 fixture test") + ( ReasonForRevocation + KeySuperseded + (RevocationReason "v6 fixture test") + ) ] unhashed = [ SigSubPacket @@ -3241,6 +3302,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary pkp , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -3310,6 +3372,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary pkp , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [(uidText, [])] , _tkUAts = [] , _tkSubs = [] diff --git a/tests/Tests/Properties.hs b/tests/Tests/Properties.hs --- a/tests/Tests/Properties.hs +++ b/tests/Tests/Properties.hs @@ -237,10 +237,14 @@ Right structured -> let shuffled = structured - { _tkStructuredDirectSignatures = + { _tkStructuredRevs = reverseIf reverseDirect - (_tkStructuredDirectSignatures structured) + (_tkStructuredRevs structured) + , _tkStructuredDirectKeySigs = + reverseIf + reverseDirect + (_tkStructuredDirectKeySigs structured) , _tkStructuredUIDs = reverseIf reverseUIDs diff --git a/tests/Tests/Serialization.hs b/tests/Tests/Serialization.hs --- a/tests/Tests/Serialization.hs +++ b/tests/Tests/Serialization.hs @@ -1224,6 +1224,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary pkp , _tkRevs = [] + , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] @@ -1231,7 +1232,7 @@ ] state = emptyPSC - { lastLD = LiteralDataPkt BinaryData BL.empty 0 payload + { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload } testHash ha = do salt <- case signatureV6SaltSizeForHashAlgorithm ha of diff --git a/tests/Tests/Utilities.hs b/tests/Tests/Utilities.hs --- a/tests/Tests/Utilities.hs +++ b/tests/Tests/Utilities.hs @@ -225,7 +225,7 @@ (not (null images)) assertBool "uat.gpg should embed the uat.jpg payload" - (expectedImage `elem` images) + (ImageData expectedImage `elem` images) testParsePktsUtil :: FilePath -> Assertion testParsePktsUtil fn = do @@ -439,6 +439,7 @@ TKUnknown (signer, Just secretAddendum) [] + [] [(uidText, [uidCertification])] [] [ @@ -554,6 +555,7 @@ TKUnknown (signer, Just secretAddendum) [] + [] [(uidAText, [uidACert]), (uidBText, [uidBCert])] [] [(SecretSubkeyPkt authSubkey secretAddendum, [authBinding])] @@ -678,6 +680,7 @@ TKUnknown (signer, Just secretAddendum) [] + [] [(uidText, [uidCertification])] [] [ @@ -966,7 +969,8 @@ (_tkStructuredSubkeys structured) refIds = _tkStructuredPrimaryKeyRef structured - : collectSigRefs (_tkStructuredDirectSignatures structured) + : collectSigRefs (_tkStructuredRevs structured) + ++ collectSigRefs (_tkStructuredDirectKeySigs structured) ++ uidRefs ++ uatRefs ++ subRefs @@ -994,8 +998,10 @@ Right structured -> do let shuffled = structured - { _tkStructuredDirectSignatures = - reverse (_tkStructuredDirectSignatures structured) + { _tkStructuredRevs = + reverse (_tkStructuredRevs structured) + , _tkStructuredDirectKeySigs = + reverse (_tkStructuredDirectKeySigs structured) , _tkStructuredUIDs = reverse ( map @@ -1071,7 +1077,8 @@ manualCanonicalizeStructured :: TKStructuredWithWireRep -> Either String TKUnknown manualCanonicalizeStructured structured = do - direct <- sortSigs (_tkStructuredDirectSignatures structured) + revs <- sortSigs (_tkStructuredRevs structured) + directKeySigs <- sortSigs (_tkStructuredDirectKeySigs structured) uids <- sortByRef _uidWithWireRefsRef =<< mapM @@ -1099,7 +1106,8 @@ Right $ TKUnknown { _tkuKey = _tkStructuredPrimaryKey structured - , _tkuRevs = map _signatureWithWireRefValue direct + , _tkuRevs = map _signatureWithWireRefValue revs + , _tkuDirectKeySigs = map _signatureWithWireRefValue directKeySigs , _tkuUIDs = map ( \(uid, sigs) -> @@ -1161,38 +1169,46 @@ Right structured -> do let badRef = PacketRefId src 999999 brokenWithBadRef = - case _tkStructuredDirectSignatures structured of + case _tkStructuredRevs structured of (sig : rest) -> Just structured - { _tkStructuredDirectSignatures = + { _tkStructuredRevs = sig {_signatureWithWireRefRef = badRef} : rest } [] -> - case _tkStructuredUIDs structured of - (uid : restUIDs) -> + case _tkStructuredDirectKeySigs structured of + (sig : rest) -> Just structured - { _tkStructuredUIDs = - uid {_uidWithWireRefsRef = badRef} : restUIDs + { _tkStructuredDirectKeySigs = + sig {_signatureWithWireRefRef = badRef} : rest } [] -> - case _tkStructuredUAts structured of - (uat : restUATs) -> + case _tkStructuredUIDs structured of + (uid : restUIDs) -> Just structured - { _tkStructuredUAts = - uat {_uatWithWireRefsRef = badRef} : restUATs + { _tkStructuredUIDs = + uid {_uidWithWireRefsRef = badRef} : restUIDs } [] -> - case _tkStructuredSubkeys structured of - (sub : restSubs) -> + case _tkStructuredUAts structured of + (uat : restUATs) -> Just structured - { _tkStructuredSubkeys = - sub {_subkeyWithWireRefsRef = badRef} : restSubs + { _tkStructuredUAts = + uat {_uatWithWireRefsRef = badRef} : restUATs } - [] -> Nothing + [] -> + case _tkStructuredSubkeys structured of + (sub : restSubs) -> + Just + structured + { _tkStructuredSubkeys = + sub {_subkeyWithWireRefsRef = badRef} : restSubs + } + [] -> Nothing case brokenWithBadRef of Nothing -> assertFailure @@ -1542,6 +1558,7 @@ flattenTK tk = [someKeyPktToPkt (mkPrimaryKeyPkt pkp mska)] ++ map SignaturePkt (_tkuRevs tk) + ++ map SignaturePkt (_tkuDirectKeySigs tk) ++ concatMap flattenUID (_tkuUIDs tk) ++ concatMap flattenUAt (_tkuUAts tk) ++ concatMap flattenSub (_tkuSubs tk) diff --git a/tests/suite.hs b/tests/suite.hs --- a/tests/suite.hs +++ b/tests/suite.hs @@ -5,8 +5,10 @@ import Test.Tasty (TestTree, defaultMain, localOption, testGroup) import qualified Test.Tasty.QuickCheck as QC -import Test.Tasty.Runners (NumThreads(..)) +import Test.Tasty.Runners (NumThreads (..)) + import Tests.Encryption (encryptionAndCompressionTests) +import Tests.KeyGeneration (keyGenerationTests) import Tests.Keys (keyAndVerificationTests) import Tests.MessageAndArmor (messageAndArmorTests) import Tests.Properties (propertiesTests) @@ -15,24 +17,26 @@ tests :: TestTree tests = - localOption - (NumThreads 4) - (testGroup - "Tests" - [ localOption (QC.QuickCheckTests 20) propertiesTests - , unitTests - ]) + localOption + (NumThreads 4) + ( testGroup + "Tests" + [ localOption (QC.QuickCheckTests 20) propertiesTests + , unitTests + ] + ) unitTests :: TestTree unitTests = - testGroup - "Unit Tests" - [ serializationTests - , keyAndVerificationTests - , encryptionAndCompressionTests - , messageAndArmorTests - , utilityTests - ] + testGroup + "Unit Tests" + [ keyGenerationTests + , serializationTests + , keyAndVerificationTests + , encryptionAndCompressionTests + , messageAndArmorTests + , utilityTests + ] main :: IO () main = defaultMain tests