hOpenPGP 3.6.10 → 3.7
raw patch · 36 files changed
+1859/−1308 lines, 36 files
Files
- Codec/Encryption/OpenPGP/BlockCipher.hs +66/−81
- Codec/Encryption/OpenPGP/CFB.hs +24/−14
- Codec/Encryption/OpenPGP/Encrypt.hs +106/−128
- Codec/Encryption/OpenPGP/Expirations.hs +15/−11
- Codec/Encryption/OpenPGP/Internal.hs +2/−13
- Codec/Encryption/OpenPGP/Internal/CryptoAES.hs +0/−50
- Codec/Encryption/OpenPGP/Internal/CryptoCipherTypes.hs +48/−11
- Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs +17/−10
- Codec/Encryption/OpenPGP/Internal/Crypton.hs +24/−4
- Codec/Encryption/OpenPGP/Internal/HOBlockCipher.hs +36/−5
- Codec/Encryption/OpenPGP/Internal/RFC7253OCB.hs +73/−20
- Codec/Encryption/OpenPGP/KeySelection.hs +13/−15
- Codec/Encryption/OpenPGP/KeyringParser.hs +238/−65
- Codec/Encryption/OpenPGP/Message.hs +17/−4
- Codec/Encryption/OpenPGP/Policy.hs +8/−3
- Codec/Encryption/OpenPGP/S2K.hs +4/−9
- Codec/Encryption/OpenPGP/SEIPDv2.hs +54/−57
- Codec/Encryption/OpenPGP/SecretKey.hs +62/−61
- Codec/Encryption/OpenPGP/Serialize.hs +22/−25
- Codec/Encryption/OpenPGP/Signatures.hs +32/−17
- Codec/Encryption/OpenPGP/Signing.hs +7/−4
- Codec/Encryption/OpenPGP/Types/Internal/Errors.hs +81/−39
- Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs +98/−0
- Codec/Encryption/OpenPGP/Types/Internal/TK.hs +260/−253
- Data/Conduit/OpenPGP/Decrypt.hs +56/−49
- Data/Conduit/OpenPGP/Keyring.hs +16/−13
- Data/Conduit/OpenPGP/Keyring/Instances.hs +57/−34
- hOpenPGP.cabal +4/−4
- tests/Tests/Common.hs +11/−4
- tests/Tests/Encryption.hs +14/−88
- tests/Tests/KeyGeneration.hs +45/−1
- tests/Tests/MessageAndArmor.hs +31/−1
- tests/Tests/Properties.hs +21/−17
- tests/Tests/Serialization.hs +11/−10
- tests/Tests/Utilities.hs +278/−188
- tests/data/seipdv1-one-recipient.pgp.aa +8/−0
Codec/Encryption/OpenPGP/BlockCipher.hs view
@@ -8,6 +8,7 @@ ( keySize , supportedSymmetricAlgorithmsForCFB , withSymmetricCipher+ , withAEADCipher ) where import qualified Crypto.Cipher.AES as AES@@ -25,91 +26,89 @@ ) import Codec.Encryption.OpenPGP.Internal.HOBlockCipher import Codec.Encryption.OpenPGP.Types-import Codec.Encryption.OpenPGP.Types.Internal.Errors- ( CipherError (..)- , renderCipherError- ) type HOCipher a = forall cipher . HOBlockCipher cipher- => cipher -> Either String a+ => cipher -> Either CipherError a withSymmetricCipher :: SymmetricAlgorithm -> B.ByteString -> HOCipher a -> Either CipherError a-withSymmetricCipher Plaintext _ _ = Left (UnsupportedAlgorithm Plaintext)-withSymmetricCipher IDEA _ _ = Left (UnsupportedAlgorithm IDEA)-withSymmetricCipher ReservedSAFER _ _ = Left (UnsupportedAlgorithm ReservedSAFER)-withSymmetricCipher ReservedDES _ _ = Left (UnsupportedAlgorithm ReservedDES)-withSymmetricCipher (OtherSA n) _ _ = Left (UnsupportedAlgorithm (OtherSA n))+withSymmetricCipher Plaintext _ _ = Left (CipherUnsupportedAlgorithm Plaintext)+withSymmetricCipher IDEA _ _ = Left (CipherUnsupportedAlgorithm IDEA)+withSymmetricCipher ReservedSAFER _ _ = Left (CipherUnsupportedAlgorithm ReservedSAFER)+withSymmetricCipher ReservedDES _ _ = Left (CipherUnsupportedAlgorithm ReservedDES)+withSymmetricCipher (OtherSA n) _ _ = Left (CipherUnsupportedAlgorithm (OtherSA n)) withSymmetricCipher CAST5 keyBytes f =- initAndRun- CAST5- ( cipherInit keyBytes- :: Either String (HOWrappedOldCCT CNC.CAST128)- )- f+ ( cipherInit keyBytes+ :: Either CipherError (HOWrappedOldCCT CNC.CAST128)+ )+ >>= f withSymmetricCipher Twofish keyBytes f =- initAndRun- Twofish- ( cipherInit keyBytes- :: Either String (HOWrappedOldCCT CNC.TWOFISH)- )- f+ ( cipherInit keyBytes+ :: Either CipherError (HOWrappedOldCCT CNC.TWOFISH)+ )+ >>= f withSymmetricCipher TripleDES keyBytes f =- initAndRun- TripleDES- ( cipherInit keyBytes- :: Either String (HOWrappedCCT TripleDES.DES_EDE3)- )- f+ ( cipherInit keyBytes+ :: Either CipherError (HOWrappedCCT TripleDES.DES_EDE3)+ )+ >>= f withSymmetricCipher Blowfish keyBytes f =- initAndRun- Blowfish- ( cipherInit keyBytes- :: Either String (HOWrappedCCT Blowfish.Blowfish128)- )- f+ ( cipherInit keyBytes+ :: Either CipherError (HOWrappedCCT Blowfish.Blowfish128)+ )+ >>= f withSymmetricCipher AES128 keyBytes f =- initAndRun- AES128- (cipherInit keyBytes :: Either String (HOWrappedCCT AES.AES128))- f+ ( cipherInit keyBytes+ :: Either CipherError (HOWrappedCCT AES.AES128)+ )+ >>= f withSymmetricCipher AES192 keyBytes f =- initAndRun- AES192- (cipherInit keyBytes :: Either String (HOWrappedCCT AES.AES192))- f+ ( cipherInit keyBytes+ :: Either CipherError (HOWrappedCCT AES.AES192)+ )+ >>= f withSymmetricCipher AES256 keyBytes f =- initAndRun- AES256- (cipherInit keyBytes :: Either String (HOWrappedCCT AES.AES256))- f+ ( cipherInit keyBytes+ :: Either CipherError (HOWrappedCCT AES.AES256)+ )+ >>= f withSymmetricCipher Camellia128 keyBytes f =- initAndRun- Camellia128- ( cipherInit keyBytes- :: Either String (HOWrappedCCT Camellia.Camellia128)- )- f+ ( cipherInit keyBytes+ :: Either CipherError (HOWrappedCCT Camellia.Camellia128)+ )+ >>= f withSymmetricCipher Camellia192 keyBytes f =- initAndRun- Camellia192- ( cipherInit keyBytes- :: Either String (HOWrappedOldCCT CNC.Camellia192)- )- f+ ( cipherInit keyBytes+ :: Either CipherError (HOWrappedOldCCT CNC.Camellia192)+ )+ >>= f withSymmetricCipher Camellia256 keyBytes f =- initAndRun- Camellia256- ( cipherInit keyBytes- :: Either String (HOWrappedOldCCT CNC.Camellia256)- )- f+ ( cipherInit keyBytes+ :: Either CipherError (HOWrappedOldCCT CNC.Camellia256)+ )+ >>= f +withAEADCipher+ :: SymmetricAlgorithm+ -> B.ByteString+ -> HOCipher a+ -> Either CipherError a+withAEADCipher symalgo keyBytes f =+ case symalgo of+ AES128 -> withSymmetricCipher AES128 keyBytes f+ AES192 -> withSymmetricCipher AES192 keyBytes f+ AES256 -> withSymmetricCipher AES256 keyBytes f+ Camellia128 -> withSymmetricCipher Camellia128 keyBytes f+ Twofish -> withSymmetricCipher Twofish keyBytes f+ Camellia192 -> withSymmetricCipher Camellia192 keyBytes f+ Camellia256 -> withSymmetricCipher Camellia256 keyBytes f+ _ -> Left (CipherUnsupportedAlgorithm symalgo)+ {- | Symmetric algorithms that the CFB (SEIPDv1) encryption backend can use for new *encryption*, restricted to the RFC 9580 §9.3-permitted set. @@ -135,20 +134,6 @@ , Blowfish ] -initAndRun- :: HOBlockCipher cipher- => SymmetricAlgorithm- -> Either String cipher- -> (cipher -> Either String a)- -> Either CipherError a-initAndRun algo initResult f =- case initResult of- Left err -> Left (CipherInitFailed algo err)- Right c ->- case f c of- Left err -> Left (CipherOperationFailed err)- Right x -> Right x- -- In octets. Keep this as an explicit OpenPGP algorithm mapping so behavior -- stays stable across mixed backends (crypton/nettle) and includes unsupported -- algorithms that never reach backend cipher types.@@ -158,8 +143,8 @@ keySize TripleDES = Right 24 keySize CAST5 = Right 16 keySize Blowfish = Right 16-keySize ReservedSAFER = Left (UnsupportedAlgorithm ReservedSAFER)-keySize ReservedDES = Left (UnsupportedAlgorithm ReservedDES)+keySize ReservedSAFER = Left (CipherUnsupportedAlgorithm ReservedSAFER)+keySize ReservedDES = Left (CipherUnsupportedAlgorithm ReservedDES) keySize AES128 = Right 16 keySize AES192 = Right 24 keySize AES256 = Right 32@@ -167,4 +152,4 @@ keySize Camellia128 = Right 16 keySize Camellia192 = Right 24 keySize Camellia256 = Right 32-keySize (OtherSA n) = Left (UnsupportedAlgorithm (OtherSA n))+keySize (OtherSA n) = Left (CipherUnsupportedAlgorithm (OtherSA n))
Codec/Encryption/OpenPGP/CFB.hs view
@@ -26,6 +26,9 @@ ) import Codec.Encryption.OpenPGP.Internal.HOBlockCipher import Codec.Encryption.OpenPGP.Types+import Codec.Encryption.OpenPGP.Types.Internal.Errors+ ( CipherError (..)+ ) data OpenPGPCFBMode = OpenPGPCFBResync@@ -56,13 +59,13 @@ cleartext <- decrypt2 ciphertext bc if nonceCheck bc nonce then return (nonce, cleartext)- else Left "Session key quickcheck failed"+ else Left CipherSessionKeyQuickcheckFailed where decrypt1 :: HOBlockCipher cipher => B.ByteString -> cipher- -> Either String B.ByteString+ -> Either CipherError B.ByteString decrypt1 ct cipher = paddedCfbDecrypt cipher@@ -72,7 +75,7 @@ :: HOBlockCipher cipher => B.ByteString -> cipher- -> Either String B.ByteString+ -> Either CipherError B.ByteString decrypt2 ct cipher = let i = B.take (blockSize cipher) (B.drop 2 ct) in paddedCfbDecrypt cipher i (B.drop (blockSize cipher + 2) ct)@@ -98,7 +101,7 @@ let (nonce, cleartext) = B.splitAt (bs + 2) decrypted if nonceCheck bc nonce then return (nonce, cleartext)- else Left "Session key quickcheck failed"+ else Left CipherSessionKeyQuickcheckFailed decryptNoNonce :: SymmetricAlgorithm@@ -114,7 +117,7 @@ :: HOBlockCipher cipher => B.ByteString -> cipher- -> Either String B.ByteString+ -> Either CipherError B.ByteString decrypt' ct cipher = paddedCfbDecrypt cipher (unIV iv) ct nonceCheck@@ -139,7 +142,7 @@ :: HOBlockCipher cipher => B.ByteString -> cipher- -> Either String B.ByteString+ -> Either CipherError B.ByteString encrypt' ct cipher = paddedCfbEncrypt cipher (unIV iv) ct encryptOpenPGPCfbRaw@@ -159,12 +162,14 @@ if B.length initialVector /= bs then Left- ( "IV length mismatch for "- ++ show sa- ++ ": expected "- ++ show bs- ++ ", got "- ++ show (B.length initialVector)+ ( CipherBadIV+ ( "IV length mismatch for "+ ++ show sa+ ++ ": expected "+ ++ show bs+ ++ ", got "+ ++ show (B.length initialVector)+ ) ) else do let prefix = initialVector <> B.drop (bs - 2) initialVector@@ -178,5 +183,10 @@ (B.take bs (B.drop 2 nonceAndCheck)) cleartext return (nonceAndCheck <> encryptedPayload)- OpenPGPCFBNoResyncW ->- paddedCfbEncrypt cipher (B.replicate bs 0) (prefix <> cleartext)+ OpenPGPCFBNoResyncW -> do+ ct <-+ paddedCfbEncrypt+ cipher+ (B.replicate bs 0)+ (prefix <> cleartext)+ return ct
Codec/Encryption/OpenPGP/Encrypt.hs view
@@ -50,7 +50,6 @@ , RecipientEncryptRequest (..) , RecipientEncryptRequestOverrides (..) , encryptForRecipients- , encryptForRecipientsLegacy , encryptForRecipientsWithCapabilityNegotiation , SharedSessionRecipient (..) , SharedSessionEncryptRequest (..)@@ -84,10 +83,9 @@ , aesKeyWrapRFC3394 , deriveX25519Kek , deriveX448Kek- , PKAEncryptOps (..)- , PKAEncryptOpsDict (..)- , SomePKAEncryptOpsDict (..)- , pkaEncryptOpsDict+ , PubKeyEncryptOps (..)+ , SomePubKeyEncryptOps (..)+ , pubKeyEncryptOps ) where import Control.Applicative ((<|>))@@ -97,6 +95,7 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except ( ExceptT (..)+ , except , runExceptT , throwE )@@ -135,6 +134,7 @@ import Codec.Encryption.OpenPGP.BlockCipher ( keySize , supportedSymmetricAlgorithmsForCFB+ , withAEADCipher , withSymmetricCipher ) import Codec.Encryption.OpenPGP.CFB@@ -162,14 +162,14 @@ , point2MBS , xorBS )-import Codec.Encryption.OpenPGP.Internal.CryptoAES- ( withAESCipher- ) import Codec.Encryption.OpenPGP.Internal.CryptoECDH ( buildECDHKDFParam , deriveECDHKek , normalizeMontgomeryPublic )+import Codec.Encryption.OpenPGP.Internal.Crypton+ ( HOWrappedCCT (..)+ ) import Codec.Encryption.OpenPGP.Internal.HOBlockCipher ( HOBlockCipher (..) )@@ -241,68 +241,70 @@ pkaBuildV3PKESK _ = buildX448PKESKv3 pkaBuildV6PKESK _ r m = buildX448PKESKv6 r (pkeskV6RawSessionMaterial m) -data PKAEncryptOpsDict = PKAEncryptOpsDict- { pkaDictBuildV3+data PubKeyEncryptOps = PubKeyEncryptOps+ { pubKeyBuildV3PKESK :: forall m . MonadRandom m => SomePKPayload -> PKESKV3SessionMaterial- -> m (Either PKESKEncryptError PKESKPayloadV3)- , pkaDictBuildV6+ -> ExceptT PKESKEncryptError m PKESKPayloadV3+ , pubKeyBuildV6PKESK :: forall m . MonadRandom m => SomePKPayload -> PKESKSessionMaterial- -> m (Either PKESKEncryptError PKESKPayloadV6)+ -> ExceptT PKESKEncryptError m PKESKPayloadV6 } -data SomePKAEncryptOpsDict where- SomePKAEncryptOpsDict- :: PKAEncryptOpsDict -> SomePKAEncryptOpsDict+data SomePubKeyEncryptOps where+ SomePubKeyEncryptOps+ :: PubKeyEncryptOps -> SomePubKeyEncryptOps -pkaEncryptOpsDict- :: PubKeyAlgorithm -> Maybe SomePKAEncryptOpsDict-pkaEncryptOpsDict RSA =+pubKeyEncryptOps+ :: PubKeyAlgorithm -> Maybe SomePubKeyEncryptOps+pubKeyEncryptOps RSA = Just- ( SomePKAEncryptOpsDict- ( PKAEncryptOpsDict- buildRsaPKESKv3- (\r m -> buildRsaPKESKv6 r m)+ ( SomePubKeyEncryptOps+ ( PubKeyEncryptOps+ (\r m -> ExceptT (buildRsaPKESKv3 r m))+ (\r m -> ExceptT (buildRsaPKESKv6 r m)) ) )-pkaEncryptOpsDict DeprecatedRSAEncryptOnly =+pubKeyEncryptOps DeprecatedRSAEncryptOnly = Just- ( SomePKAEncryptOpsDict- ( PKAEncryptOpsDict- buildRsaPKESKv3- (\r m -> buildRsaPKESKv6 r m)+ ( SomePubKeyEncryptOps+ ( PubKeyEncryptOps+ (\r m -> ExceptT (buildRsaPKESKv3 r m))+ (\r m -> ExceptT (buildRsaPKESKv6 r m)) ) )-pkaEncryptOpsDict ECDH =+pubKeyEncryptOps ECDH = Just- ( SomePKAEncryptOpsDict- ( PKAEncryptOpsDict- buildECDHPKESKv3- (\r m -> buildECDHPKESKv6 r m)+ ( SomePubKeyEncryptOps+ ( PubKeyEncryptOps+ (\r m -> ExceptT (buildECDHPKESKv3 r m))+ (\r m -> ExceptT (buildECDHPKESKv6 r m)) ) )-pkaEncryptOpsDict X25519 =+pubKeyEncryptOps X25519 = Just- ( SomePKAEncryptOpsDict- ( PKAEncryptOpsDict- buildX25519PKESKv3- (\r m -> buildX25519PKESKv6 r (pkeskV6RawSessionMaterial m))+ ( SomePubKeyEncryptOps+ ( PubKeyEncryptOps+ (\r m -> ExceptT (buildX25519PKESKv3 r m))+ ( \r m -> ExceptT (buildX25519PKESKv6 r (pkeskV6RawSessionMaterial m))+ ) ) )-pkaEncryptOpsDict X448 =+pubKeyEncryptOps X448 = Just- ( SomePKAEncryptOpsDict- ( PKAEncryptOpsDict- buildX448PKESKv3- (\r m -> buildX448PKESKv6 r (pkeskV6RawSessionMaterial m))+ ( SomePubKeyEncryptOps+ ( PubKeyEncryptOps+ (\r m -> ExceptT (buildX448PKESKv3 r m))+ ( \r m -> ExceptT (buildX448PKESKv6 r (pkeskV6RawSessionMaterial m))+ ) ) )-pkaEncryptOpsDict _ = Nothing+pubKeyEncryptOps _ = Nothing data RecipientCapabilityNegotiationMode = RecipientCapabilityNegotiationOff@@ -655,7 +657,7 @@ supportsPKESKRecipientAlgorithm :: SomePKPayload -> Bool supportsPKESKRecipientAlgorithm recipient =- isJust (pkaEncryptOpsDict (_pkalgo recipient))+ isJust (pubKeyEncryptOps (_pkalgo recipient)) chooseRecipientTarget :: RecipientTargetSelectionPolicy@@ -1034,10 +1036,10 @@ publicTargets material passwordPackets <- forM passwordRecipients $ \passphrase ->- ExceptT . pure $+ except $ buildSharedPasswordSKESK request material passphrase packets <-- ExceptT . pure $+ except $ buildEncryptedPacketSequenceWithShape symalgo aead@@ -1167,17 +1169,13 @@ :: MonadRandom m => SymmetricAlgorithm -> m (Either PKESKEncryptError PKESKSessionMaterial)-generateSessionKeyMaterial symalgo =- case keySize symalgo of- Left err ->- pure- ( Left- (UnsupportedSessionKeyAlgorithm symalgo err)- )- Right keyLen -> do- sessionKeyBytes <- getRandomBytes keyLen- let sessionKey = SessionKey sessionKeyBytes- pure (mkPKESKSessionMaterial symalgo sessionKey)+generateSessionKeyMaterial symalgo = runExceptT $ do+ keyLen <-+ except $+ first (UnsupportedSessionKeyAlgorithm symalgo) (keySize symalgo)+ sessionKeyBytes <- lift (getRandomBytes keyLen)+ let sessionKey = SessionKey sessionKeyBytes+ except $ mkPKESKSessionMaterial symalgo sessionKey -- | Build a v6 PKESK payload for one recipient key according to the selected version policy. buildPKESKPayloadForRecipient@@ -1193,13 +1191,13 @@ recipient (pkeskV3SessionMaterial material) PreferV6 ->- case pkaEncryptOpsDict (_pkalgo recipient) of+ case pubKeyEncryptOps (_pkalgo recipient) of Nothing -> pure (Left (UnsupportedRecipientAlgorithm (_pkalgo recipient)))- Just (SomePKAEncryptOpsDict dict) ->+ Just (SomePubKeyEncryptOps dict) -> fmap (fmap PKESKPayloadV6Packet)- (pkaDictBuildV6 dict recipient material)+ (runExceptT (pubKeyBuildV6PKESK dict recipient material)) -- | Build a PKESK packet for one recipient key according to the selected version policy. buildPKESKPktForRecipient@@ -1230,11 +1228,11 @@ -> PKESKV3SessionMaterial -> m (Either PKESKEncryptError PKESKPayloadV3) buildPKESKv3PayloadForRecipientTyped recipient material =- case pkaEncryptOpsDict (_pkalgo recipient) of+ case pubKeyEncryptOps (_pkalgo recipient) of Nothing -> pure (Left (UnsupportedRecipientAlgorithm (_pkalgo recipient)))- Just (SomePKAEncryptOpsDict dict) ->- pkaDictBuildV3 dict recipient material+ Just (SomePubKeyEncryptOps dict) ->+ runExceptT (pubKeyBuildV3PKESK dict recipient material) -- | Build a legacy PKESKv3 packet for v4/v3 RSA recipient interop. buildPKESKv3PktForRecipient@@ -1330,11 +1328,12 @@ ( RecipientPreferV6W , RecipientPreferV6Payload material _v6RawMaterial ) ->- case pkaEncryptOpsDict (_pkalgo recipient) of+ case pubKeyEncryptOps (_pkalgo recipient) of Nothing -> pure (Left (UnsupportedRecipientAlgorithm (_pkalgo recipient)))- Just (SomePKAEncryptOpsDict dict) ->- packetizeV6 (pkaDictBuildV6 dict recipient material)+ Just (SomePubKeyEncryptOps dict) ->+ packetizeV6+ (runExceptT (pubKeyBuildV6PKESK dict recipient material)) {- | Encrypt for recipient targets with capability negotiation enabled. @@ -1350,15 +1349,6 @@ encryptForRecipientsWithCapabilityNegotiation RecipientCapabilityNegotiationOn -{-# DEPRECATED encryptForRecipientsLegacy "use encryptForRecipients" #-}-encryptForRecipientsLegacy- :: MonadRandom m- => RecipientEncryptRequest v- -> m (Either PKESKEncryptError RecipientEncryptResult)-encryptForRecipientsLegacy =- encryptForRecipientsWithCapabilityNegotiation- RecipientCapabilityNegotiationOff- {- | Encrypt for recipient targets with an explicit capability-negotiation mode. When negotiation is on, symmetric and AEAD selection use the common@@ -1374,7 +1364,7 @@ | null targets = pure (Left NoRecipientsProvided) | otherwise = runExceptT $ do (symalgo, aead) <-- ExceptT . pure $+ except $ selectCiphersuite negotiationMode request@@ -1466,7 +1456,7 @@ (messageDefaultChunkSize messagePolicy) id chunkSizeOverride- ExceptT . pure $+ except $ fmap ( \pkts -> RecipientEncryptResult@@ -1500,7 +1490,7 @@ , recipientEncryptSessionMaterial = sessionMaterial } missingSEIPDv1 ->- ExceptT . pure $+ except $ Left ( RecipientCapabilitySelectionFailure (RecipientCapabilityMissingSEIPDv1Support missingSEIPDv1)@@ -1523,7 +1513,7 @@ , recipientEncryptSessionMaterial = sessionMaterial } missingSEIPDv1 ->- ExceptT . pure $+ except $ Left ( RecipientCapabilitySelectionFailure (RecipientCapabilityMissingSEIPDv1Support missingSEIPDv1)@@ -2728,21 +2718,16 @@ -> B.ByteString -> Either CipherError B.ByteString aesKeyWrapRFC3394 sa kek plain =- withAESCipher- (\err -> CipherInitFailed sa (show err))- (UnsupportedAlgorithm sa)- sa- kek- wrapWithCipher+ withSymmetricCipher sa kek wrapWithCipher where wrapWithCipher- :: CCT.BlockCipher cipher+ :: HOBlockCipher cipher => cipher -> Either CipherError B.ByteString wrapWithCipher cipher = do if B.length plain < 16 || B.length plain `mod` 8 /= 0 then Left- ( CipherOperationFailed+ ( CipherKeyWrapInvalidInput "ECDH key wrap input must be at least 16 octets and a multiple of 8" ) else Right ()@@ -2750,14 +2735,14 @@ if length rs < 2 then Left- ( CipherOperationFailed+ ( CipherKeyWrapInvalidInput "ECDH key wrap input must contain at least two 64-bit blocks" ) else Right () (aFinal, rFinal) <- wrapRounds cipher (B.replicate 8 0xA6) rs Right (aFinal <> B.concat rFinal) wrapRounds- :: CCT.BlockCipher cipher+ :: HOBlockCipher cipher => cipher -> B.ByteString -> [B.ByteString]@@ -2776,8 +2761,8 @@ | otherwise = do let t = fromIntegral (n * j + i) :: Word64 rI = curRs !! (i - 1)- block = CCT.ecbEncrypt cipher (curA <> rI)- (msb, lsb) = B.splitAt 8 block+ block <- ecbEncrypt cipher (curA <> rI)+ let (msb, lsb) = B.splitAt 8 block aNext = xorBS msb (encodeWord64be t) rsNext = (ix (i - 1) .~ lsb) curRs goI (i + 1) aNext rsNext@@ -2935,23 +2920,24 @@ okm = expand @CHA.SHA256 prk info outputLen :: B.ByteString messageKey = B.take keyLen okm noncePrefix = B.take (nonceSize - 8) (B.drop keyLen okm)- withAESCipher- (SEIPDv2CipherFailed . CipherInitFailed symalgo . show)- (SEIPDv2UnsupportedSymmetricAlgorithm symalgo)- symalgo- messageKey- ( encryptChunks+ first+ SEIPDv2CipherFailed+ ( withAEADCipher symalgo- aead- mode- info- chunkSize- noncePrefix- plaintext+ messageKey+ ( encryptChunks+ symalgo+ aead+ mode+ info+ chunkSize+ noncePrefix+ plaintext+ ) ) encryptChunks- :: CCT.BlockCipher cipher+ :: HOBlockCipher cipher => SymmetricAlgorithm -> AEADAlgorithm -> CCT.AEADMode@@ -2960,7 +2946,7 @@ -> B.ByteString -> B.ByteString -> cipher- -> Either SEIPDv2Failure B.ByteString+ -> Either CipherError B.ByteString encryptChunks symalgo aead mode info chunkSize noncePrefix plaintext cipher = go 0 plaintext [] 0 where chunkLen = 1 `shiftL` (fromIntegral chunkSize + 6)@@ -2969,16 +2955,15 @@ (finalTag, finalCipher) <- if mode == CCT.AEAD_OCB then- first SEIPDv2CipherFailed $- encryptWithOCBRFC7253- cipher- (noncePrefix <> encodeWord64be idx)- (info <> encodeWord64be (fromIntegral totalPlain))- B.empty+ encryptWithOCBRFC7253+ cipher+ (noncePrefix <> encodeWord64be idx)+ (info <> encodeWord64be (fromIntegral totalPlain))+ B.empty else do aead <- initAEAD idx let (tag, out) =- CCT.aeadSimpleEncrypt+ aeadSimpleEncrypt aead (info <> encodeWord64be (fromIntegral totalPlain)) B.empty@@ -2988,25 +2973,20 @@ then return (B.concat (reverse acc) <> authTagToBS finalTag) else Left- ( SEIPDv2CipherFailed- ( CipherOperationFailed- "expected empty ciphertext for final SEIPD v2 tag"- )- )+ (CipherFinalTagEmpty) | otherwise = do let (chunkPlain, rest) = B.splitAt chunkLen remaining (tag, chunkCipher) <- if mode == CCT.AEAD_OCB then- first SEIPDv2CipherFailed $- encryptWithOCBRFC7253- cipher- (noncePrefix <> encodeWord64be idx)- info- chunkPlain+ encryptWithOCBRFC7253+ cipher+ (noncePrefix <> encodeWord64be idx)+ info+ chunkPlain else do aead <- initAEAD idx- pure (CCT.aeadSimpleEncrypt aead info chunkPlain 16)+ pure (aeadSimpleEncrypt aead info chunkPlain 16) let chunkOut = chunkCipher <> authTagToBS tag go (idx + 1)@@ -3015,9 +2995,7 @@ (totalPlain + B.length chunkPlain) initAEAD idx =- first (SEIPDv2CipherFailed . CipherInitFailed symalgo . show)- . CE.eitherCryptoError- $ CCT.aeadInit mode cipher (noncePrefix <> encodeWord64be idx)+ aeadInit mode cipher (noncePrefix <> encodeWord64be idx) aeadModeAndNonceSize :: AEADAlgorithm -> Either SEIPDv2Failure (CCT.AEADMode, Int)
Codec/Encryption/OpenPGP/Expirations.hs view
@@ -56,10 +56,10 @@ deriving (Eq, Show) -- this assumes that all key expiration time subpackets are valid-isTKTimeValid :: UTCTime -> TK k -> Bool+isTKTimeValid :: TKPrimaryPKPayload k => UTCTime -> TK k -> Bool isTKTimeValid ct = keyStateValid . keyStateAt ct -keyStateAt :: UTCTime -> TK k -> KeyState+keyStateAt :: TKPrimaryPKPayload k => UTCTime -> TK k -> KeyState keyStateAt ct tk = baseState { keyStateValid =@@ -69,7 +69,7 @@ baseState = keyStateFromSelfSignaturesAt ct- (keyPktPKPayload (tk ^. tkPrimaryKey))+ (tkPrimaryPKPayload tk) relevantSelfSignatures relevantSelfSignatures = concat@@ -91,10 +91,11 @@ any (selfCertificationGroupActiveAt ct) selfCertificationGroups bindingStateAllowsValidation = not hasAnySelfCertification || hasAnyActiveSelfCertification- primaryKey = keyPktPKPayload (tk ^. tkPrimaryKey)+ primaryKey = tkPrimaryPKPayload tk effectiveKeyPreferencesAt- :: UTCTime -> TK k -> Maybe [SigSubPacketPayload]+ :: TKPrimaryPKPayload k+ => UTCTime -> TK k -> Maybe [SigSubPacketPayload] effectiveKeyPreferencesAt ct tk | not (keyStateValid (keyStateAt ct tk)) = Nothing | otherwise = do@@ -105,7 +106,8 @@ else Just prefs effectiveUIDPreferencesAt- :: UTCTime -> Text -> TK k -> Maybe [SigSubPacketPayload]+ :: TKPrimaryPKPayload k+ => UTCTime -> Text -> TK k -> Maybe [SigSubPacketPayload] effectiveUIDPreferencesAt ct uid tk | not (keyStateValid (keyStateAt ct tk)) = Nothing | otherwise = do@@ -119,16 +121,18 @@ then Nothing else Just prefs where- primaryKey = keyPktPKPayload (tk ^. tkPrimaryKey)+ primaryKey = tkPrimaryPKPayload tk effectiveKeyPreferencesAtTimestamp- :: ThirtyTwoBitTimeStamp -> TK k -> Maybe [SigSubPacketPayload]+ :: TKPrimaryPKPayload k+ => ThirtyTwoBitTimeStamp -> TK k -> Maybe [SigSubPacketPayload] effectiveKeyPreferencesAtTimestamp ts = effectiveKeyPreferencesAt (posixSecondsToUTCTime (realToFrac (unThirtyTwoBitTimeStamp ts))) effectiveUIDPreferencesAtTimestamp- :: ThirtyTwoBitTimeStamp+ :: TKPrimaryPKPayload k+ => ThirtyTwoBitTimeStamp -> Text -> TK k -> Maybe [SigSubPacketPayload]@@ -298,12 +302,12 @@ filter (\sig -> isCertRevocationForTime ct sig) sigs latestEffectivePreferenceCarrierAt- :: UTCTime -> TK k -> Maybe SignaturePayload+ :: TKPrimaryPKPayload k => UTCTime -> TK k -> Maybe SignaturePayload latestEffectivePreferenceCarrierAt ct tk = snd <$> newestByCreationTime (mapMaybeSignatureCreationTime candidates) where- primaryKey = keyPktPKPayload (tk ^. tkPrimaryKey)+ primaryKey = tkPrimaryPKPayload tk directKeySigs = filter ( \sig ->
Codec/Encryption/OpenPGP/Internal.hs view
@@ -34,21 +34,16 @@ import qualified Crypto.PubKey.ECC.Types as ECCT import qualified Crypto.PubKey.RSA as RSA import Data.Binary.Put (putWord64be, runPut)-import Data.Bits (shiftR, testBit, xor, (.&.))+import Data.Bits (shiftR, xor, (.&.)) import qualified Data.ByteString as B-import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import Data.List (find)-import Data.Word (Word16, Word64, Word8)+import Data.Word (Word16, Word64) import Codec.Encryption.OpenPGP.Ontology ( isIssuerSSP ) import Codec.Encryption.OpenPGP.Types-import Codec.Encryption.OpenPGP.Types.Internal.Errors- ( CurveConversionError (..)- , renderCurveConversionError- ) data PktStreamContext = PktStreamContext@@ -196,12 +191,6 @@ edPointInteger :: EdPoint -> Integer edPointInteger (PrefixedNativeEPoint (EPoint x)) = x edPointInteger (NativeEPoint (EPoint x)) = x--multiplicativeInverse :: (Integral a) => a -> a -> a-multiplicativeInverse _ 1 = 1-multiplicativeInverse q p = (n * q + 1) `div` p- where- n = p - multiplicativeInverse p (q `mod` p) curveoidBSToCurve :: B.ByteString -> Either CurveConversionError ECCCurve
− Codec/Encryption/OpenPGP/Internal/CryptoAES.hs
@@ -1,50 +0,0 @@--- CryptoAES.hs: OpenPGP (RFC9580) AES helper utilities--- Copyright © 2012-2026 Clint Adams--- This software is released under the terms of the Expat license.--- (See the LICENSE file).-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE RankNTypes #-}--module Codec.Encryption.OpenPGP.Internal.CryptoAES- ( withAESCipher- ) where--import qualified Crypto.Error as CE-import Data.Bifunctor (first)-import qualified Data.ByteString as B-import qualified "crypton" Crypto.Cipher.AES as AES-import qualified "crypton" Crypto.Cipher.Types as CCT--import Codec.Encryption.OpenPGP.Types--withAESCipher- :: (CE.CryptoError -> e)- -> e- -> SymmetricAlgorithm- -> B.ByteString- -> (forall cipher. CCT.BlockCipher cipher => cipher -> Either e a)- -> Either e a-withAESCipher mkCryptoError unsupportedSymmetricError symalgo keyBytes f =- case symalgo of- AES128 ->- first- mkCryptoError- ( CE.eitherCryptoError- (CCT.cipherInit keyBytes :: CE.CryptoFailable AES.AES128)- )- >>= f- AES192 ->- first- mkCryptoError- ( CE.eitherCryptoError- (CCT.cipherInit keyBytes :: CE.CryptoFailable AES.AES192)- )- >>= f- AES256 ->- first- mkCryptoError- ( CE.eitherCryptoError- (CCT.cipherInit keyBytes :: CE.CryptoFailable AES.AES256)- )- >>= f- _ -> Left unsupportedSymmetricError
Codec/Encryption/OpenPGP/Internal/CryptoCipherTypes.hs view
@@ -1,9 +1,10 @@ -- CryptoCipherTypes.hs: shim for crypto-cipher-types stuff (current nettle)--- Copyright © 2016-2024 Clint Adams+-- Copyright © 2016-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PackageImports #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE UndecidableInstances #-} module Codec.Encryption.OpenPGP.Internal.CryptoCipherTypes@@ -11,11 +12,16 @@ ) where import Control.Error.Util (note)+import Data.Bifunctor (bimap)+import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified "crypto-cipher-types" Crypto.Cipher.Types as OldCCT import qualified "crypton" Crypto.Cipher.Types as CCT import Codec.Encryption.OpenPGP.Internal.HOBlockCipher+import Codec.Encryption.OpenPGP.Types.Internal.Errors+ ( CipherError (..)+ ) newtype HOWrappedOldCCT a = HWOCCT a@@ -24,21 +30,23 @@ OldCCT.BlockCipher cipher => HOBlockCipher (HOWrappedOldCCT cipher) where- cipherInit =- fmap HWOCCT- . either- (const (Left "nettle invalid key"))- (Right . OldCCT.cipherInit)- . OldCCT.makeKey+ cipherInit key =+ let keyBS = BA.convert key :: B.ByteString+ in bimap+ (const (CipherOldInitFailed "nettle invalid key"))+ (HWOCCT . OldCCT.cipherInit)+ (OldCCT.makeKey keyBS) cipherName (HWOCCT c) = OldCCT.cipherName c cipherKeySize (HWOCCT c) = convertKSS . OldCCT.cipherKeySize $ c blockSize (HWOCCT c) = OldCCT.blockSize c+ ecbEncrypt (HWOCCT c) bs = Right (OldCCT.ecbEncrypt c bs)+ ecbDecrypt (HWOCCT c) bs = Right (OldCCT.ecbDecrypt c bs) cfbEncrypt (HWOCCT c) iv bs = hammerIV iv >>= \i -> return (OldCCT.cfbEncrypt c i bs) cfbDecrypt (HWOCCT c) iv bs = hammerIV iv >>= \i -> return (OldCCT.cfbDecrypt c i bs) paddedCfbEncrypt _ _ _ =- Left "padding for nettle-encryption not implemented yet"+ Left CipherPaddingUnsupported paddedCfbDecrypt (HWOCCT cipher) iv ciphertext = hammerIV iv >>= \i -> return@@ -53,14 +61,43 @@ ) 0 )+ aeadInit mode (HWOCCT c) iv =+ case OldCCT.aeadInit (convertMode mode) c iv of+ Nothing -> Left CipherAEADModeUnsupported+ Just (OldCCT.AEAD _ (OldCCT.AEADState st)) ->+ Right (CCT.AEAD (bridgeImpl c) st)+ aeadSimpleEncrypt aead aad pt plen =+ CCT.aeadSimpleEncrypt aead aad pt plen+ aeadSimpleDecrypt aead aad ct tag =+ CCT.aeadSimpleDecrypt aead aad ct tag convertKSS :: OldCCT.KeySizeSpecifier -> CCT.KeySizeSpecifier convertKSS (OldCCT.KeySizeRange a b) = CCT.KeySizeRange a b convertKSS (OldCCT.KeySizeEnum as) = CCT.KeySizeEnum as convertKSS (OldCCT.KeySizeFixed a) = CCT.KeySizeFixed a +convertMode :: CCT.AEADMode -> OldCCT.AEADMode+convertMode CCT.AEAD_GCM = OldCCT.AEAD_GCM+convertMode (CCT.AEAD_CCM 0 CCT.CCM_M16 CCT.CCM_L2) = OldCCT.AEAD_CCM+convertMode _ = OldCCT.AEAD_GCM++bridgeImpl+ :: OldCCT.AEADModeImpl cipher st => cipher -> CCT.AEADModeImpl st+bridgeImpl c =+ CCT.AEADModeImpl+ { CCT.aeadImplAppendHeader = \st' ba -> OldCCT.aeadStateAppendHeader c st' (BA.convert ba)+ , CCT.aeadImplEncrypt = \st' ba ->+ let (ct, st'') = OldCCT.aeadStateEncrypt c st' (BA.convert ba)+ in (BA.convert ct, st'')+ , CCT.aeadImplDecrypt = \st' ba ->+ let (pt, st'') = OldCCT.aeadStateDecrypt c st' (BA.convert ba)+ in (BA.convert pt, st'')+ , CCT.aeadImplFinalize = \st' plen ->+ let OldCCT.AuthTag bs = OldCCT.aeadStateFinalize c st' plen+ in CCT.AuthTag (BA.convert bs)+ }+ hammerIV :: OldCCT.BlockCipher cipher- => B.ByteString- -> Either String (OldCCT.IV cipher)-hammerIV = note "nettle bad IV" . OldCCT.makeIV+ => B.ByteString -> Either CipherError (OldCCT.IV cipher)+hammerIV = note (CipherBadIV "nettle") . OldCCT.makeIV
Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs view
@@ -25,6 +25,9 @@ ) import Codec.Encryption.OpenPGP.Policy (ecdhKdfHashDigest) import Codec.Encryption.OpenPGP.Types+import Codec.Encryption.OpenPGP.Types.Internal.Errors+ ( CipherError (..)+ ) normalizeMontgomeryPublic :: Int@@ -44,7 +47,7 @@ -> PKey -> HashAlgorithm -> SymmetricAlgorithm- -> Either String B.ByteString+ -> Either CipherError B.ByteString buildECDHKDFParam recipientPKP pka recipientECDHPub kdfHA kdfSA = ( <> B.pack [fromFVal pka, 0x03, 0x01, fromFVal kdfHA, fromFVal kdfSA]@@ -54,32 +57,36 @@ <$> encodedCurveOid where encodedCurveOid =- ((\oid -> B.singleton (fromIntegral (B.length oid)) <> oid) <$>)- curveOid+ (\oid -> B.singleton (fromIntegral (B.length oid)) <> oid)+ <$> curveOid curveOid = case recipientECDHPub of ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)) -> first- renderCurveConversionError+ CipherCurveConversionFailed (curveToCurveoidBS (curveFromCurve curve)) EdDSAPubKey EdSigningCurve25519 _ ->- first renderCurveConversionError (curveToCurveoidBS Curve25519)+ first CipherCurveConversionFailed (curveToCurveoidBS Curve25519) EdDSAPubKey EdSigningCurve448 _ ->- first renderCurveConversionError (curveToCurveoidBS Curve448)- _ -> Left "ECDH KDF param requires ECDH recipient key"+ first CipherCurveConversionFailed (curveToCurveoidBS Curve448)+ _ -> Left CipherInvalidECDHRecipient deriveECDHKek :: HashAlgorithm -> SymmetricAlgorithm -> B.ByteString -> B.ByteString- -> Either String B.ByteString+ -> Either CipherError B.ByteString deriveECDHKek kdfHA kdfSA sharedSecret kdfParam = do digest <- ecdhKdfHashDigest kdfHA (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam)- kekLen <- first renderCipherError (keySize kdfSA)+ kekLen <- keySize kdfSA if B.length digest < kekLen- then Left "ECDH KDF digest is shorter than required KEK length"+ then+ Left+ ( CipherKeyWrapInvalidInput+ "ECDH KDF digest is shorter than required KEK length"+ ) else Right (B.take kekLen digest)
Codec/Encryption/OpenPGP/Internal/Crypton.hs view
@@ -1,5 +1,5 @@ -- Crypton.hs: shim for crypton--- Copyright © 2016-2024 Clint Adams+-- Copyright © 2016-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE FlexibleInstances #-}@@ -18,21 +18,41 @@ import qualified "crypton" Crypto.Cipher.Types as CCT import Codec.Encryption.OpenPGP.Internal.HOBlockCipher+import Codec.Encryption.OpenPGP.Types.Internal.Errors+ ( CipherError (..)+ ) newtype HOWrappedCCT a = HWCCT a instance CCT.BlockCipher cipher => HOBlockCipher (HOWrappedCCT cipher) where- cipherInit = bimap show HWCCT . CE.eitherCryptoError . CCT.cipherInit+ cipherInit =+ bimap CipherOperationFailed HWCCT+ . CE.eitherCryptoError+ . CCT.cipherInit cipherName (HWCCT c) = CCT.cipherName c cipherKeySize (HWCCT c) = CCT.cipherKeySize c blockSize (HWCCT c) = CCT.blockSize c+ ecbEncrypt (HWCCT c) bs = Right (CCT.ecbEncrypt c bs)+ ecbDecrypt (HWCCT c) bs = Right (CCT.ecbDecrypt c bs) cfbEncrypt (HWCCT c) iv bs = hammerIV iv >>= \i -> return (CCT.cfbEncrypt c i bs) cfbDecrypt (HWCCT c) iv bs = hammerIV iv >>= \i -> return (CCT.cfbDecrypt c i bs)+ aeadInit mode (HWCCT c) iv =+ fmap+ (\(CCT.AEAD impl st) -> CCT.AEAD impl st)+ ( bimap+ CipherOperationFailed+ id+ (CE.eitherCryptoError (CCT.aeadInit mode c iv))+ )+ aeadSimpleEncrypt aead aad pt plen =+ CCT.aeadSimpleEncrypt aead aad pt plen+ aeadSimpleDecrypt aead aad ct tag =+ CCT.aeadSimpleDecrypt aead aad ct tag hammerIV :: CCT.BlockCipher cipher- => B.ByteString -> Either String (CCT.IV cipher)-hammerIV = note "crypton bad IV" . CCT.makeIV+ => B.ByteString -> Either CipherError (CCT.IV cipher)+hammerIV = note (CipherBadIV "crypton") . CCT.makeIV
Codec/Encryption/OpenPGP/Internal/HOBlockCipher.hs view
@@ -8,33 +8,64 @@ ( HOBlockCipher (..) ) where +import Data.ByteArray (ByteArray, ByteArrayAccess) import qualified Data.ByteString as B import qualified "crypton" Crypto.Cipher.Types as CCT +import Codec.Encryption.OpenPGP.Types.Internal.Errors+ ( CipherError (..)+ )+ class HOBlockCipher cipher where- cipherInit :: B.ByteString -> Either String cipher+ cipherInit :: ByteArray key => key -> Either CipherError cipher cipherName :: cipher -> String cipherKeySize :: cipher -> CCT.KeySizeSpecifier blockSize :: cipher -> Int+ ecbEncrypt+ :: cipher -> B.ByteString -> Either CipherError B.ByteString+ ecbDecrypt+ :: cipher -> B.ByteString -> Either CipherError B.ByteString cfbEncrypt :: cipher -> B.ByteString -> B.ByteString- -> Either String B.ByteString+ -> Either CipherError B.ByteString cfbDecrypt :: cipher -> B.ByteString -> B.ByteString- -> Either String B.ByteString+ -> Either CipherError B.ByteString paddedCfbEncrypt :: cipher -> B.ByteString -> B.ByteString- -> Either String B.ByteString+ -> Either CipherError B.ByteString paddedCfbEncrypt = cfbEncrypt paddedCfbDecrypt :: cipher -> B.ByteString -> B.ByteString- -> Either String B.ByteString+ -> Either CipherError B.ByteString paddedCfbDecrypt = cfbDecrypt+ aeadInit+ :: CCT.AEADMode+ -> cipher+ -> B.ByteString+ -> Either CipherError (CCT.AEAD cipher)+ aeadInit _ _ _ = Left CipherAEADInitUnsupported+ aeadSimpleEncrypt+ :: (ByteArray pt, ByteArrayAccess aad)+ => CCT.AEAD cipher+ -> aad+ -> pt+ -> Int+ -> (CCT.AuthTag, pt)+ aeadSimpleEncrypt _ _ _ _ = error "aeadSimpleEncrypt not supported"+ aeadSimpleDecrypt+ :: (ByteArray ct, ByteArrayAccess aad)+ => CCT.AEAD cipher+ -> aad+ -> ct+ -> CCT.AuthTag+ -> Maybe ct+ aeadSimpleDecrypt _ _ _ _ = Nothing
Codec/Encryption/OpenPGP/Internal/RFC7253OCB.hs view
@@ -27,9 +27,13 @@ import qualified "crypton" Crypto.Cipher.Types as CCT import Codec.Encryption.OpenPGP.Internal (xorBS)+import Codec.Encryption.OpenPGP.Internal.HOBlockCipher+import Codec.Encryption.OpenPGP.Types.Internal.Errors+ ( renderCipherError+ ) encryptWithOCBRFC7253- :: CCT.BlockCipher c+ :: HOBlockCipher c => c -> B.ByteString -> B.ByteString@@ -40,7 +44,11 @@ error "invalid nonce size for OCB" offset0 <- ocbOffset0 cipher nonce let zeroBlock = B.replicate 16 0- lStar = CCT.ecbEncrypt cipher zeroBlock+ lStar =+ either+ (error . renderCipherError)+ id+ (ecbEncrypt cipher zeroBlock) lDollar = ocbDouble lStar lCache = iterate ocbDouble (ocbDouble lDollar) hashAd = ocbHash cipher lStar lCache ad@@ -49,7 +57,14 @@ foldl' ( \(accBlocks, offsetPrev, checksumPrev) (idx, pBlock) -> let offsetI = xorBS offsetPrev (lCache !! ntz idx)- cipherI = xorBS offsetI (CCT.ecbEncrypt cipher (xorBS offsetI pBlock))+ cipherI =+ xorBS+ offsetI+ ( either+ (error . renderCipherError)+ id+ (ecbEncrypt cipher (xorBS offsetI pBlock))+ ) checksumI = xorBS checksumPrev pBlock in (accBlocks ++ [cipherI], offsetI, checksumI) )@@ -60,22 +75,27 @@ then (B.empty, offsetM, checksum) else let offsetStar = xorBS offsetM lStar- pad = CCT.ecbEncrypt cipher offsetStar+ pad =+ either+ (error . renderCipherError)+ id+ (ecbEncrypt cipher offsetStar) cipherPartial = xorBS partial (B.take (B.length partial) pad) checksum' = xorBS checksum (ocbPadPartial partial) in (cipherPartial, offsetStar, checksum') tagBytes = xorBS- ( CCT.ecbEncrypt- cipher- (xorBS (xorBS checksumLast offsetLast) lDollar)+ ( either+ (error . renderCipherError)+ id+ (ecbEncrypt cipher (xorBS (xorBS checksumLast offsetLast) lDollar)) ) hashAd ciphertext = B.concat cipherBlocks <> cipherLast in Right (mkAuthTag (B.take 16 tagBytes), ciphertext) decryptWithOCBRFC7253- :: CCT.BlockCipher c+ :: HOBlockCipher c => c -> B.ByteString -> B.ByteString@@ -87,7 +107,7 @@ (\_ _ _ _ _ _ -> "OCB authentication failed") decryptWithOCBRFC7253With- :: CCT.BlockCipher c+ :: HOBlockCipher c => ( B.ByteString -> B.ByteString -> B.ByteString@@ -109,7 +129,11 @@ error "invalid auth tag size for OCB" offset0 <- ocbOffset0 cipher nonce let zeroBlock = B.replicate 16 0- lStar = CCT.ecbEncrypt cipher zeroBlock+ lStar =+ either+ (error . renderCipherError)+ id+ (ecbEncrypt cipher zeroBlock) lDollar = ocbDouble lStar lCache = iterate ocbDouble (ocbDouble lDollar) hashAd = ocbHash cipher lStar lCache ad@@ -118,7 +142,14 @@ foldl' ( \(accBlocks, offsetPrev, checksumPrev) (idx, cBlock) -> let offsetI = xorBS offsetPrev (lCache !! ntz idx)- plainI = xorBS offsetI (CCT.ecbDecrypt cipher (xorBS offsetI cBlock))+ plainI =+ xorBS+ offsetI+ ( either+ (error . renderCipherError)+ id+ (ecbDecrypt cipher (xorBS offsetI cBlock))+ ) checksumI = xorBS checksumPrev plainI in (accBlocks ++ [plainI], offsetI, checksumI) )@@ -129,15 +160,20 @@ then (B.empty, offsetM, checksum) else let offsetStar = xorBS offsetM lStar- pad = CCT.ecbEncrypt cipher offsetStar+ pad =+ either+ (error . renderCipherError)+ id+ (ecbEncrypt cipher offsetStar) plainPartial = xorBS partial (B.take (B.length partial) pad) checksum' = xorBS checksum (ocbPadPartial plainPartial) in (plainPartial, offsetStar, checksum') tagComputed = xorBS- ( CCT.ecbEncrypt- cipher- (xorBS (xorBS checksumLast offsetLast) lDollar)+ ( either+ (error . renderCipherError)+ id+ (ecbEncrypt cipher (xorBS (xorBS checksumLast offsetLast) lDollar)) ) hashAd plaintext = B.concat plainBlocks <> plainLast@@ -154,7 +190,7 @@ mkAuthTag = CCT.AuthTag . BA.convert ocbOffset0- :: CCT.BlockCipher c+ :: HOBlockCipher c => c -> B.ByteString -> Either e B.ByteString ocbOffset0 cipher nonce = do let nonceLen = B.length nonce@@ -165,12 +201,16 @@ nonceBlock = prefix <> nonce bottom = fromIntegral (B.last nonceBlock .&. 0x3f) :: Int nonceTop = B.init nonceBlock <> B.singleton (B.last nonceBlock .&. 0xc0)- kTop = CCT.ecbEncrypt cipher nonceTop+ kTop =+ either+ (error . renderCipherError)+ id+ (ecbEncrypt cipher nonceTop) stretch = kTop <> xorBS (B.take 8 kTop) (B.take 8 (B.drop 1 kTop)) Right (ocbBitSlice128 stretch bottom) ocbHash- :: CCT.BlockCipher c+ :: HOBlockCipher c => c -> B.ByteString -> [B.ByteString]@@ -182,7 +222,14 @@ foldl' ( \(acc, offsetPrev) (idx, block) -> let offsetI = xorBS offsetPrev (lCache !! ntz idx)- sumI = xorBS acc (CCT.ecbEncrypt cipher (xorBS offsetI block))+ sumI =+ xorBS+ acc+ ( either+ (error . renderCipherError)+ id+ (ecbEncrypt cipher (xorBS offsetI block))+ ) in (sumI, offsetI) ) (B.replicate 16 0, B.replicate 16 0)@@ -192,7 +239,13 @@ else let offsetStar = xorBS offsetFinal lStar block = ocbPadPartial partial- in xorBS sumBlocks (CCT.ecbEncrypt cipher (xorBS offsetStar block))+ in xorBS+ sumBlocks+ ( either+ (error . renderCipherError)+ id+ (ecbEncrypt cipher (xorBS offsetStar block))+ ) ocbPadPartial :: B.ByteString -> B.ByteString ocbPadPartial bs = bs <> B.singleton 0x80 <> B.replicate (15 - B.length bs) 0
Codec/Encryption/OpenPGP/KeySelection.hs view
@@ -20,33 +20,31 @@ , parseOnly , satisfy )+import Data.Bifunctor (bimap) import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL import Data.Text (Text, toUpper) import qualified Data.Text as T import Codec.Encryption.OpenPGP.Types-import Codec.Encryption.OpenPGP.Types.Internal.Errors- ( KeySelectionError (..)- ) parseEightOctetKeyId :: Text -> Either KeySelectionError EightOctetKeyId parseEightOctetKeyId input =- case parseOnly hexes- =<< parseOnly (hexPrefix *> hexen 16) (toUpper input) of- Left _ -> Left (KeySelectionParseError (toUpper input))- Right bs -> Right (EightOctetKeyId bs)+ let upper = toUpper input+ in bimap+ (const (KeySelectionParseError upper))+ EightOctetKeyId+ (parseOnly (hexPrefix *> hexen 16) upper >>= parseOnly hexes) parseFingerprint :: Text -> Either KeySelectionError Fingerprint parseFingerprint input =- case parseOnly hexes- =<< parseOnly- (hexen 64 <|> hexen 40 <|> hexen 32)- (toUpper (T.filter (/= ' ') input)) of- Left _ ->- Left (KeySelectionParseError (toUpper (T.filter (/= ' ') input)))- Right bs -> Right (Fingerprint bs)+ let filtered = toUpper (T.filter (/= ' ') input)+ in bimap+ (const (KeySelectionParseError filtered))+ Fingerprint+ ( parseOnly (hexen 64 <|> hexen 40 <|> hexen 32) filtered+ >>= parseOnly hexes+ ) hexPrefix :: Parser (Maybe Text) hexPrefix = optional (asciiCI "0x")
Codec/Encryption/OpenPGP/KeyringParser.hs view
@@ -19,6 +19,7 @@ , publicTKWithWireRep , secretTK , secretTKWithWireRep+ , mixedTKWithWireRep , brokenTK , brokenTKWithWireRep , pkPayload@@ -47,7 +48,9 @@ , parseTKs , parsePublicTKs , parseSecretTKs+ , parseMixedTKs , parseTKsWithWireRep+ , parseMixedTKsWithWireRep ) where import Control.Applicative (many, (<|>))@@ -149,10 +152,8 @@ finalizeParsingEither (inspect (feedEof p)) -anyTK :: Bool -> Parser [Pkt] (Maybe TKUnknown)-anyTK True = publicTK True <|> secretTK True-anyTK False =- publicTK False <|> secretTK False <|> brokenTK 6 <|> brokenTK 5+anyTK :: Bool -> Parser [Pkt] (Maybe SomeTK)+anyTK intolerant = publicTK intolerant <|> secretTK intolerant data UidOrUat = I Text@@ -177,9 +178,9 @@ unA (A x, y) = (x, y) unA x = error $ "unA should never be called on " ++ show x -publicTK, secretTK :: Bool -> Parser [Pkt] (Maybe TKUnknown)+publicTK :: Bool -> Parser [Pkt] (Maybe SomeTK) publicTK intolerant = do- pkp <- pkPayload+ (pkp, _) <- pkPayload pkpsigs <- concatMany (signatureWithPredicate intolerant isAllowedPrimaryKeySigType)@@ -187,31 +188,58 @@ fmap splitUs (many (signedUID intolerant <|> signedUAt intolerant))- subs <- concatMany (pubsub intolerant)+ rawSubs <- concatMany (pubsub intolerant) let revs = filter ((== Just KeyRevocationSig) . sigType) pkpsigs directKeySigs = filter ((== Just DirectKeySignature) . sigType) pkpsigs- return $ Just (TKUnknown pkp revs directKeySigs uids uats subs)+ subs = mapMaybe subToPublic rawSubs+ typed =+ TK+ { _tkPrimaryKey = KeyPktPublicPrimary pkp+ , _tkRevs = revs+ , _tkDirectKeySigs = directKeySigs+ , _tkUIDs = uids+ , _tkUAts = uats+ , _tkSubs = subs+ }+ return (Just (SomePublicTK typed)) where pubsub True = signedOrRevokedPubSubkey True pubsub False = signedOrRevokedPubSubkey False <|> brokenPubSubkey+ subToPublic (pkt, sigs) = fmap (\kp -> (kp, sigs)) (pktToPublicKeyPkt pkt)++secretTK :: Bool -> Parser [Pkt] (Maybe SomeTK) secretTK intolerant = do- skp <- skPayload- skpsigs <-- concatMany- (signatureWithPredicate intolerant isAllowedPrimaryKeySigType)- (uids, uats) <-- fmap- splitUs- (many (signedUID intolerant <|> signedUAt intolerant))- subs <- concatMany (secsub intolerant)- 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+ (pkp, maybeSka) <- skPayload+ case maybeSka of+ Just ska -> do+ skpsigs <-+ concatMany+ (signatureWithPredicate intolerant isAllowedPrimaryKeySigType)+ (uids, uats) <-+ fmap+ splitUs+ (many (signedUID intolerant <|> signedUAt intolerant))+ rawSubs <- concatMany (secsub intolerant)+ let revs = filter ((== Just KeyRevocationSig) . sigType) skpsigs+ directKeySigs = filter ((== Just DirectKeySignature) . sigType) skpsigs+ subs = mapMaybe subToSecret rawSubs+ typed =+ TK+ { _tkPrimaryKey = KeyPktSecretPrimary pkp ska+ , _tkRevs = revs+ , _tkDirectKeySigs = directKeySigs+ , _tkUIDs = uids+ , _tkUAts = uats+ , _tkSubs = subs+ }+ return (Just (SomeSecretTK typed))+ where+ secsub True = rawOrSignedOrRevokedSecSubkey True+ secsub False = rawOrSignedOrRevokedSecSubkey False <|> brokenSecSubkey+ subToSecret (pkt, sigs) = fmap (\kp -> (kp, sigs)) (pktToSecretKeyPkt pkt)+ Nothing -> fail "secret primary key missing secret addendum" -brokenTK :: Int -> Parser [Pkt] (Maybe TKUnknown)+brokenTK :: Int -> Parser [Pkt] (Maybe SomeTK) brokenTK 6 = do _ <- broken 6 _ <-@@ -391,13 +419,11 @@ parseTKsEither :: Bool -> [Pkt] -> [Either TKConversionError SomeTK] parseTKsEither intolerant ps =- map- fromUnknownToTKEither- ( catMaybes $+ map Right $+ catMaybes $ runIncrementalParser (anyTK intolerant) (map (: []) (filter notTrustPacket ps))- ) where notTrustPacket = not . isTrustPkt @@ -412,6 +438,10 @@ parseSecretTKs intolerant packets = mapMaybe someTKToSecretTK (parseTKs intolerant packets) +parseMixedTKs :: Bool -> [Pkt] -> [TK 'MixedTK]+parseMixedTKs intolerant packets =+ mapMaybe someTKToMixedTK (parseTKs intolerant packets)+ anyTKWithWireRep :: Bool -> Parser [PktWithWireRep] (Maybe TKWithWireRep) anyTKWithWireRep True = publicTKWithWireRep True <|> secretTKWithWireRep True@@ -425,7 +455,7 @@ , secretTKWithWireRep :: Bool -> Parser [PktWithWireRep] (Maybe TKWithWireRep) publicTKWithWireRep intolerant = do- (pkp, pkps) <- pkPayloadWithWireRep+ ((pkp, _), pkps) <- pkPayloadWithWireRep (pkpsigs, pkpsigrefs) <- concatMany ( signatureWithWireRepPredicate@@ -445,7 +475,15 @@ subrefs = concatMap snd subResults revs = filter ((== Just KeyRevocationSig) . sigType) pkpsigs directKeySigs = filter ((== Just DirectKeySignature) . sigType) pkpsigs- tk = TKUnknown pkp revs directKeySigs uids uats subs+ tk =+ TK+ { _tkPrimaryKey = SomeKeyPkt (KeyPktPublicPrimary pkp)+ , _tkRevs = revs+ , _tkDirectKeySigs = directKeySigs+ , _tkUIDs = uids+ , _tkUAts = uats+ , _tkSubs = subs+ } refs = pkps ++ pkpsigrefs ++ uidrefs ++ subrefs return $ Just (mkTKWithWireRep tk refs) where@@ -454,34 +492,45 @@ signedOrRevokedPubSubkeyWithWireRep False <|> brokenPubSubkeyWithWireRep secretTKWithWireRep intolerant = do- (skp, skps) <- skPayloadWithWireRep- (skpsigs, skpsigrefs) <-- concatMany- ( signatureWithWireRepPredicate- intolerant- isAllowedPrimaryKeySigType- )- uidResults <-- many- ( signedUIDWithWireRep intolerant- <|> signedUAtWithWireRep intolerant- )- subResults <- concatMany (secsub intolerant)- let semanticUs = fmap fst uidResults- (uids, uats) = splitUs semanticUs- uidrefs = concatMap snd uidResults- subs = fmap fst subResults- subrefs = concatMap snd subResults- 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- secsub True = rawOrSignedOrRevokedSecSubkeyWithWireRep True- secsub False =- rawOrSignedOrRevokedSecSubkeyWithWireRep False- <|> brokenSecSubkeyWithWireRep+ ((pkp, maybeSka), skps) <- skPayloadWithWireRep+ case maybeSka of+ Just ska -> do+ (skpsigs, skpsigrefs) <-+ concatMany+ ( signatureWithWireRepPredicate+ intolerant+ isAllowedPrimaryKeySigType+ )+ uidResults <-+ many+ ( signedUIDWithWireRep intolerant+ <|> signedUAtWithWireRep intolerant+ )+ subResults <- concatMany (secsub intolerant)+ let semanticUs = fmap fst uidResults+ (uids, uats) = splitUs semanticUs+ uidrefs = concatMap snd uidResults+ subs = fmap fst subResults+ subrefs = concatMap snd subResults+ revs = filter ((== Just KeyRevocationSig) . sigType) skpsigs+ directKeySigs = filter ((== Just DirectKeySignature) . sigType) skpsigs+ tk =+ TK+ { _tkPrimaryKey = SomeKeyPkt (KeyPktSecretPrimary pkp ska)+ , _tkRevs = revs+ , _tkDirectKeySigs = directKeySigs+ , _tkUIDs = uids+ , _tkUAts = uats+ , _tkSubs = subs+ }+ refs = skps ++ skpsigrefs ++ uidrefs ++ subrefs+ return $ Just (mkTKWithWireRep tk refs)+ where+ secsub True = rawOrSignedOrRevokedSecSubkeyWithWireRep True+ secsub False =+ rawOrSignedOrRevokedSecSubkeyWithWireRep False+ <|> brokenSecSubkeyWithWireRep+ Nothing -> fail "secret primary key missing secret addendum" brokenTKWithWireRep :: Int -> Parser [PktWithWireRep] (Maybe TKWithWireRep)@@ -630,7 +679,7 @@ :: Bool -> Parser [PktWithWireRep]- [((Pkt, [SignaturePayload]), [PktWithWireRep])]+ [((SomeKeyPkt, [SignaturePayload]), [PktWithWireRep])] signedOrRevokedPubSubkeyWithWireRep intolerant = do pskpkts <- satisfy isPSKPWS case pskpkts of@@ -638,9 +687,10 @@ (sigs, sigrefs) <- concatMany (signatureWithWireRepPredicate intolerant isAllowedSubkeySigType)+ let Just keyPkt = pktToPublicKeyPkt (pktWithSource ^. pktWireRep . pktValue) return [- ( (pktWithSource ^. pktWireRep . pktValue, sigs)+ ( (SomeKeyPkt keyPkt, sigs) , pktWithSource : sigrefs ) ]@@ -655,7 +705,7 @@ brokenPubSubkeyWithWireRep :: Parser [PktWithWireRep]- [((Pkt, [SignaturePayload]), [PktWithWireRep])]+ [((SomeKeyPkt, [SignaturePayload]), [PktWithWireRep])] brokenPubSubkeyWithWireRep = do _ <- brokenWithWireRep 14 _ <-@@ -667,7 +717,7 @@ :: Bool -> Parser [PktWithWireRep]- [((Pkt, [SignaturePayload]), [PktWithWireRep])]+ [((SomeKeyPkt, [SignaturePayload]), [PktWithWireRep])] rawOrSignedOrRevokedSecSubkeyWithWireRep intolerant = do sskpkts <- satisfy isSSKPWS case sskpkts of@@ -675,9 +725,10 @@ (sigs, sigrefs) <- concatMany (signatureWithWireRepPredicate intolerant isAllowedSubkeySigType)+ let Just keyPkt = pktToSecretKeyPkt (pktWithSource ^. pktWireRep . pktValue) return [- ( (pktWithSource ^. pktWireRep . pktValue, sigs)+ ( (SomeKeyPkt keyPkt, sigs) , pktWithSource : sigrefs ) ]@@ -692,7 +743,7 @@ brokenSecSubkeyWithWireRep :: Parser [PktWithWireRep]- [((Pkt, [SignaturePayload]), [PktWithWireRep])]+ [((SomeKeyPkt, [SignaturePayload]), [PktWithWireRep])] brokenSecSubkeyWithWireRep = do _ <- brokenWithWireRep 7 _ <-@@ -735,6 +786,116 @@ _ -> False isBrokenWS _ = False +mixedPrimaryWithWireRep+ :: Parser [PktWithWireRep] (SomeKeyPkt, [PktWithWireRep])+mixedPrimaryWithWireRep = do+ pkpkts <- satisfy isMixedPrimaryWS+ case pkpkts of+ [pktWithSource] ->+ case pktToSomeKeyPkt (pktWithSource ^. pktWireRep . pktValue) of+ Just keyPkt+ | someKeyPktRole keyPkt == KeyPktPrimary ->+ return (keyPkt, [pktWithSource])+ _ -> failure+ _ -> failure+ where+ isMixedPrimaryWS [pktWithSource] =+ case pktToSomeKeyPkt (pktWithSource ^. pktWireRep . pktValue) of+ Just keyPkt -> someKeyPktRole keyPkt == KeyPktPrimary+ Nothing -> False+ isMixedPrimaryWS _ = False++mixedSubkeyWithWireRep+ :: Bool+ -> Parser+ [PktWithWireRep]+ [((SomeKeyPkt, [SignaturePayload]), [PktWithWireRep])]+mixedSubkeyWithWireRep intolerant = do+ pskpkts <- satisfy isMixedSubkeyWS+ case pskpkts of+ [pktWithSource] -> do+ (sigs, sigrefs) <-+ concatMany+ (signatureWithWireRepPredicate intolerant isAllowedSubkeySigType)+ let Just keyPkt = pktToSomeKeyPkt (pktWithSource ^. pktWireRep . pktValue)+ return+ [+ ( (keyPkt, sigs)+ , pktWithSource : sigrefs+ )+ ]+ _ -> failure+ where+ isMixedSubkeyWS [pktWithSource] =+ case pktToSomeKeyPkt (pktWithSource ^. pktWireRep . pktValue) of+ Just keyPkt -> someKeyPktRole keyPkt == KeyPktSubkey+ _ -> False+ isMixedSubkeyWS _ = False++mixedBrokenPubSubkeyWithWireRep+ :: Parser+ [PktWithWireRep]+ [((SomeKeyPkt, [SignaturePayload]), [PktWithWireRep])]+mixedBrokenPubSubkeyWithWireRep = do+ _ <- brokenWithWireRep 14+ _ <-+ concatMany+ (signatureWithWireRepPredicate False isAllowedSubkeySigType)+ return []++mixedBrokenSecSubkeyWithWireRep+ :: Parser+ [PktWithWireRep]+ [((SomeKeyPkt, [SignaturePayload]), [PktWithWireRep])]+mixedBrokenSecSubkeyWithWireRep = do+ _ <- brokenWithWireRep 7+ _ <-+ concatMany+ (signatureWithWireRepPredicate False isAllowedSubkeySigType)+ return []++mixedTKWithWireRep+ :: Bool+ -> Parser [PktWithWireRep] (Maybe (TK 'MixedTK, [PktWithWireRep]))+mixedTKWithWireRep intolerant = do+ (pkp, pkps) <- mixedPrimaryWithWireRep+ (pkpsigs, pkpsigrefs) <-+ concatMany+ ( signatureWithWireRepPredicate+ intolerant+ isAllowedPrimaryKeySigType+ )+ uidResults <-+ many+ ( signedUIDWithWireRep intolerant+ <|> signedUAtWithWireRep intolerant+ )+ subResults <- concatMany (mixedSub intolerant)+ let semanticUs = fmap fst uidResults+ (uids, uats) = splitUs semanticUs+ uidrefs = concatMap snd uidResults+ subs = fmap fst subResults+ subrefs = concatMap snd subResults+ revs = filter ((== Just KeyRevocationSig) . sigType) pkpsigs+ directKeySigs = filter ((== Just DirectKeySignature) . sigType) pkpsigs+ tk =+ TK+ { _tkPrimaryKey = pkp+ , _tkRevs = revs+ , _tkDirectKeySigs = directKeySigs+ , _tkUIDs = uids+ , _tkUAts = uats+ , _tkSubs = subs+ }+ refs = pkps ++ pkpsigrefs ++ uidrefs ++ subrefs+ return $ Just (tk, refs)+ where+ mixedSub True = mixedSubkeyWithWireRep True+ mixedSub False =+ mixedSubkeyWithWireRep False+ <|> mixedBrokenPubSubkeyWithWireRep+ <|> mixedBrokenSecSubkeyWithWireRep+ parseTKsWithWireRep :: Bool -> [PktWithWireRep] -> [TKWithWireRep] parseTKsWithWireRep intolerant ps =@@ -745,6 +906,17 @@ where notTrustPacketWithWireRep = not . isTrustPkt . (^. pktWireRep . pktValue) +parseMixedTKsWithWireRep+ :: Bool -> [PktWithWireRep] -> [TK 'MixedTK]+parseMixedTKsWithWireRep intolerant ps =+ map fst $+ catMaybes $+ runIncrementalParser+ (mixedTKWithWireRep intolerant)+ (map (: []) (filter notTrustPacketWithWireRep ps))+ where+ notTrustPacketWithWireRep = not . isTrustPkt . (^. pktWireRep . pktValue)+ runIncrementalParser :: (Monoid s, Show s) => Parser s r@@ -757,7 +929,8 @@ let (st', out) = parseAChunk parser chunk st in out <> go st' rest -mkTKWithWireRep :: TKUnknown -> [PktWithWireRep] -> TKWithWireRep+mkTKWithWireRep+ :: TK 'MixedTK -> [PktWithWireRep] -> TKWithWireRep mkTKWithWireRep tk refs = case refs of [] ->
Codec/Encryption/OpenPGP/Message.hs view
@@ -38,6 +38,7 @@ , RecoveredSessionMaterial (..) , encryptMessage , decryptMessage+ , extractLiteralPayload , signMessage , signMessageWith , verifySignedMessage@@ -45,7 +46,11 @@ import Control.Monad (foldM) import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Except (ExceptT (..), runExceptT)+import Control.Monad.Trans.Except+ ( ExceptT (..)+ , except+ , runExceptT+ ) import qualified Crypto.PubKey.Ed25519 as Ed25519 import qualified Crypto.PubKey.Ed448 as Ed448 import qualified Crypto.PubKey.RSA.Types as RSATypes@@ -220,7 +225,7 @@ messageStep :: Monad m => Either MessageError a -> ExceptT MessageError m a-messageStep = ExceptT . pure+messageStep = except runMessageFlow :: ExceptT MessageError Identity a -> Either MessageError a@@ -232,7 +237,7 @@ runMessageFlowT = runExceptT signStepT :: Monad m => Either SignError a -> MessageFlowT m a-signStepT = ExceptT . pure . first MessageSignError+signStepT = except . first MessageSignError parseStep :: Monad m@@ -972,10 +977,18 @@ extractLiteralPayload :: [Pkt] -> Either MessageParseFailure ClearPayload-extractLiteralPayload pkts =+extractLiteralPayload pkts = do+ validatePackets pkts case [p | LiteralDataPkt _ _ _ p <- pkts] of payload : _ -> Right (ClearPayload payload) [] -> Left MissingLiteralDataPacket+ where+ validatePackets [] = Right ()+ validatePackets (pkt : rest) =+ case pkt of+ LiteralDataPkt {} -> validatePackets rest+ CompressedDataPkt {} -> validatePackets rest+ _ -> Left (UnexpectedPacketInDecryptedPayload (pktTag pkt)) rejectUnknownCriticalPacketsTyped :: [Pkt] -> Either MessageParseFailure [Pkt]
Codec/Encryption/OpenPGP/Policy.hs view
@@ -79,6 +79,9 @@ ) import Codec.Encryption.OpenPGP.SignatureQualities (sigType) import Codec.Encryption.OpenPGP.Types+import Codec.Encryption.OpenPGP.Types.Internal.Errors+ ( CipherError (..)+ ) data OpenPGPRFC = RFC2440@@ -560,15 +563,17 @@ secretKeyProtectionPolicyForKeyVersion _ _ = Nothing ecdhKdfHashDigest- :: HashAlgorithm -> B.ByteString -> Either String B.ByteString-ecdhKdfHashDigest SHA1 _ = Left "ECDH KDF hash algorithm SHA1 is disallowed by policy"+ :: HashAlgorithm -> B.ByteString -> Either CipherError B.ByteString+ecdhKdfHashDigest SHA1 _ =+ Left (CipherKdfHashAlgorithmDisallowed SHA1) ecdhKdfHashDigest SHA224 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHA.SHA224)) ecdhKdfHashDigest SHA256 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHA.SHA256)) ecdhKdfHashDigest SHA384 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHA.SHA384)) ecdhKdfHashDigest SHA512 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHA.SHA512)) ecdhKdfHashDigest SHA3_256 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHA.SHA3_256)) ecdhKdfHashDigest SHA3_512 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHA.SHA3_512))-ecdhKdfHashDigest _ _ = Left "ECDH KDF hash algorithm is unsupported"+ecdhKdfHashDigest ha _ =+ Left (CipherKdfHashAlgorithmUnsupported ha) validateTable30PolicyForRecipient :: SomePKPayload
Codec/Encryption/OpenPGP/S2K.hs view
@@ -143,15 +143,10 @@ encodedSessionKeyKeyLength :: SymmetricAlgorithm -> Either EncodedSessionKeyError Int encodedSessionKeyKeyLength symalgo =- first renderKeySizeError (keySize symalgo)- where- renderKeySizeError :: CipherError -> EncodedSessionKeyError- renderKeySizeError (UnsupportedAlgorithm sa) =- EncodedSessionKeyUnsupportedAlgorithm sa- renderKeySizeError (CipherInitFailed sa _) =- EncodedSessionKeyUnsupportedAlgorithm sa- renderKeySizeError (CipherOperationFailed _) =- EncodedSessionKeyUnsupportedAlgorithm symalgo+ first+ ( \(CipherUnsupportedAlgorithm sa) -> EncodedSessionKeyUnsupportedAlgorithm sa+ )+ (keySize symalgo) checksum16 :: B.ByteString -> Word16 checksum16 =
Codec/Encryption/OpenPGP/SEIPDv2.hs view
@@ -17,7 +17,6 @@ ) where import Control.Error.Util (note)-import qualified Crypto.Error as CE import qualified Crypto.Hash.Algorithms as CHA import Crypto.KDF.HKDF (expand, extract) import Data.Bifunctor (first)@@ -27,9 +26,12 @@ import qualified Data.Set as Set import qualified "crypton" Crypto.Cipher.Types as CCT -import Codec.Encryption.OpenPGP.Internal.CryptoAES- ( withAESCipher+import Codec.Encryption.OpenPGP.BlockCipher+ ( withAEADCipher )+import Codec.Encryption.OpenPGP.Internal.HOBlockCipher+ ( HOBlockCipher (..)+ ) import Codec.Encryption.OpenPGP.Internal.RFC7253OCB ( decryptWithOCBRFC7253With , encryptWithOCBRFC7253@@ -106,35 +108,32 @@ if B.length iv /= nonceSize then Left SEIPDv2InvalidIVLength else- withAESCipher- (SEIPDv2CipherFailed . CipherInitFailed symalgo . show)- ( SEIPDv2CipherFailed- (CipherInitFailed symalgo "unsupported symmetric algorithm")- )- symalgo- kek- ( \cipher ->- if mode == CCT.AEAD_OCB- then do- (tag, ciphertext) <-- encryptWithOCBRFC7253- cipher- iv- (skeskV6Info symalgo aead)- sessionKey- pure (ciphertext, authTagToBS tag)- else do- aeadCtx <-- first (SEIPDv2CipherFailed . CipherInitFailed symalgo . show)- . CE.eitherCryptoError- $ CCT.aeadInit mode cipher iv- let (tag, ciphertext) =- CCT.aeadSimpleEncrypt- aeadCtx+ first+ SEIPDv2CipherFailed+ ( withAEADCipher+ symalgo+ kek+ ( \cipher ->+ if mode == CCT.AEAD_OCB+ then do+ (tag, ct) <-+ encryptWithOCBRFC7253+ cipher+ iv (skeskV6Info symalgo aead) sessionKey- 16- pure (ciphertext, authTagToBS tag)+ pure (ct, authTagToBS tag)+ else do+ aeadCtx <-+ aeadInit mode cipher iv+ let (tag, ciphertext) =+ aeadSimpleEncrypt+ aeadCtx+ (skeskV6Info symalgo aead)+ sessionKey+ 16+ pure (ciphertext, authTagToBS tag)+ ) ) decryptSKESK6SessionKey@@ -150,36 +149,34 @@ if B.length iv /= nonceSize then Left SEIPDv2InvalidIVLength else- withAESCipher- (SEIPDv2CipherFailed . CipherInitFailed symalgo . show)- ( SEIPDv2CipherFailed- (CipherInitFailed symalgo "unsupported symmetric algorithm")- )- symalgo- kek- ( \cipher ->- if mode == CCT.AEAD_OCB- then- decryptWithOCBRFC7253With- (\_ _ _ _ _ _ -> SEIPDv2AuthFailed)- cipher- iv- (skeskV6Info symalgo aead)- ciphertext- (mkAuthTag tag)- else do- aeadCtx <-- first (SEIPDv2CipherFailed . CipherInitFailed symalgo . show)- . CE.eitherCryptoError- $ CCT.aeadInit mode cipher iv- note- SEIPDv2AuthFailed- ( CCT.aeadSimpleDecrypt- aeadCtx+ first+ SEIPDv2CipherFailed+ ( withAEADCipher+ symalgo+ kek+ ( \cipher ->+ if mode == CCT.AEAD_OCB+ then+ decryptWithOCBRFC7253With+ (\_ _ _ _ _ _ -> CipherAEADAuthFailed)+ cipher+ iv (skeskV6Info symalgo aead) ciphertext (mkAuthTag tag)- )+ else do+ aeadCtx <-+ aeadInit mode cipher iv+ let decrypted =+ aeadSimpleDecrypt+ aeadCtx+ (skeskV6Info symalgo aead)+ ciphertext+ (mkAuthTag tag)+ note+ CipherAEADDecryptFailed+ decrypted+ ) ) authTagToBS :: CCT.AuthTag -> B.ByteString
Codec/Encryption/OpenPGP/SecretKey.hs view
@@ -18,7 +18,6 @@ , reencryptSecretKeyRandom ) where -import Control.Error.Util (note) import Control.Monad (when) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except@@ -26,7 +25,6 @@ , runExceptT , throwE )-import qualified Crypto.Error as CE import qualified Crypto.Hash as CH import qualified Crypto.Hash.Algorithms as CHA import Crypto.KDF.HKDF (expand, extract)@@ -60,14 +58,18 @@ import Codec.Encryption.OpenPGP.BlockCipher ( keySize+ , withAEADCipher ) import Codec.Encryption.OpenPGP.CFB ( decryptNoNonce , encryptNoNonce )-import Codec.Encryption.OpenPGP.Internal.CryptoAES- ( withAESCipher+import Codec.Encryption.OpenPGP.Internal.Crypton+ ( HOWrappedCCT (..) )+import Codec.Encryption.OpenPGP.Internal.HOBlockCipher+ ( HOBlockCipher (..)+ ) import Codec.Encryption.OpenPGP.Internal.RFC7253OCB ( decryptWithOCBRFC7253With , encryptWithOCBRFC7253@@ -120,12 +122,12 @@ -> Passphrase -> Either SecretKeyError (SKey, SKAddendum) decryptSecretKeyAddendum pkp ska pp =- case fromSKAddendumForPKPayload pkp ska of- Left err -> Left (SecretKeyDecryptAddendumError err)- Right (SomeSKAddendumV skaV) ->- case decryptPrivateKeyTyped pkp skaV pp of- Left err -> Left err- Right decryptedV ->+ first+ SecretKeyDecryptAddendumError+ (fromSKAddendumForPKPayload pkp ska)+ >>= \(SomeSKAddendumV skaV) ->+ decryptPrivateKeyTyped pkp skaV pp+ >>= \decryptedV -> case toSKAddendum decryptedV of SUSUnprotected skey _ -> Right (skey, toSKAddendum decryptedV) _ -> Left SecretKeyDecryptNotUnencrypted@@ -193,12 +195,13 @@ let pkp = _secretKeyPKPayload sk originalSka = _secretKeySKAddendum sk decryptedSKA <-- except $ case fromSKAddendumForPKPayload pkp originalSka of- Left err -> Left (SecretKeyDecryptAddendumError err)- Right (SomeSKAddendumV skaV) ->- case decryptPrivateKeyTyped pkp skaV oldPassphrase of- Left err -> Left err- Right decryptedV -> Right (toSKAddendum decryptedV)+ except $+ first+ SecretKeyDecryptAddendumError+ (fromSKAddendumForPKPayload pkp originalSka)+ >>= \(SomeSKAddendumV skaV) ->+ decryptPrivateKeyTyped pkp skaV oldPassphrase+ >>= pure . toSKAddendum case decryptedSKA of SUSUnprotected skey _ -> do let pp = unPassphrase newPassphrase@@ -571,19 +574,20 @@ SecretKeyAEADModeUnsupportedCipher sa case aa of OCB ->- withAESCipher- SecretKeyAEADModeCrypto- unsupportedSecretKeyAEADError- sa- kek- ( \cipher ->- decryptWithOCBRFC7253With- authFailure- cipher- nonce- ad- ciphertext- authTag+ first+ SecretKeyDecryptCipherError+ ( withAEADCipher+ sa+ kek+ ( \cipher ->+ decryptWithOCBRFC7253With+ (\_ _ _ _ _ _ -> CipherAEADAuthFailed)+ cipher+ nonce+ ad+ ciphertext+ authTag+ ) ) _ -> do mode <- aeadMode aa@@ -593,21 +597,18 @@ ( SecretKeyInvalidNonceSize "invalid nonce size for v6 AEAD secret key payload" )- withAESCipher- SecretKeyAEADModeCrypto- unsupportedSecretKeyAEADError- sa- kek- $ \cipher ->- first- SecretKeyAEADModeCrypto- (CE.eitherCryptoError (CCT.aeadInit mode cipher nonce))- >>= \aead ->- note- ( SecretKeyAuthError- "failed to authenticate v6 AEAD secret key payload"- )- (CCT.aeadSimpleDecrypt aead ad ciphertext authTag)+ first+ SecretKeyDecryptCipherError+ ( withAEADCipher+ sa+ kek+ $ \cipher -> do+ aeadCtx <- aeadInit mode cipher nonce+ maybe+ (Left CipherAEADDecryptFailed)+ Right+ (aeadSimpleDecrypt aeadCtx ad ciphertext authTag)+ ) aeadMode :: AEADAlgorithm -> Either SecretKeyError CCT.AEADMode aeadMode EAX = Right CCT.AEAD_EAX@@ -839,25 +840,25 @@ SecretKeyAEADModeUnsupportedCipher sa case aa of OCB ->- withAESCipher- SecretKeyAEADModeCrypto- unsupportedSecretKeyAEADError- sa- kek- (\cipher -> encryptWithOCBRFC7253 cipher nonce ad plaintext)+ first+ SecretKeyEncryptCipherError+ ( withAEADCipher+ sa+ kek+ (\cipher -> encryptWithOCBRFC7253 cipher nonce ad plaintext)+ ) _ -> do mode <- aeadMode aa- withAESCipher- SecretKeyAEADModeCrypto- unsupportedSecretKeyAEADError- sa- kek- $ \cipher ->- first- SecretKeyAEADModeCrypto- (CE.eitherCryptoError (CCT.aeadInit mode cipher nonce))- >>= \aead ->- pure (CCT.aeadSimpleEncrypt aead ad plaintext 16)+ first+ SecretKeyEncryptCipherError+ ( withAEADCipher+ sa+ kek+ $ \cipher ->+ aeadInit mode cipher nonce+ >>= \aead ->+ pure (aeadSimpleEncrypt aead ad plaintext 16)+ ) reencryptWithPolicyAndSaltAndIVTyped :: OpenPGPPolicy
Codec/Encryption/OpenPGP/Serialize.hs view
@@ -14,6 +14,7 @@ , putSKAddendum , getSecretKey , putSKeyForPKPayload+ , putMixedTK -- * Utilities , dearmorIfAsciiArmored@@ -39,7 +40,7 @@ ) import Control.Applicative (many, some) import Control.Arrow ((***))-import Control.Lens (op, (^.), _1)+import Control.Lens (op) import Control.Monad (guard, replicateM, replicateM_, when) import Control.Monad.Loops (iterateUntilM) import Crypto.Number.Basic (numBits)@@ -259,17 +260,30 @@ get = getSignaturePayload put = putSignaturePayload -instance Binary TKUnknown where- get = fail "Binary TKUnknown decode is not implemented"- put = putTK+instance Binary (TK 'MixedTK) where+ get = fail "Binary TK 'MixedTK decode is not implemented"+ put = putMixedTK -instance Binary (TK k) where- get = fail "Binary TK decode is not implemented"- put = putTK . tkToUnknown+putMixedTK :: TK 'MixedTK -> Put+putMixedTK tk = do+ putPrimary (_tkPrimaryKey tk)+ mapM_ (put . Signature) (_tkRevs tk)+ mapM_ (put . Signature) (_tkDirectKeySigs tk)+ mapM_ putUid' (_tkUIDs tk)+ mapM_ putUat' (_tkUAts tk)+ mapM_ putSub' (_tkSubs tk)+ where+ putPrimary :: SomeKeyPkt -> Put+ putPrimary (SomeKeyPkt (KeyPktPublicPrimary pkp)) = put (PublicKey pkp)+ putPrimary (SomeKeyPkt (KeyPktSecretPrimary pkp ska)) = put (SecretKey pkp ska)+ putPrimary _ = error "putMixedTK: primary key must be primary role"+ putUid' (u, sps) = put (UserId u) >> mapM_ (put . Signature) sps+ putUat' (us, sps) = put (UserAttribute us) >> mapM_ (put . Signature) sps+ putSub' (kp, sps) = putPkt (someKeyPktToPkt kp) >> mapM_ (put . Signature) sps instance Binary SomeTK where get = fail "Binary SomeTK decode is not implemented"- put = putTK . someTKToUnknown+ put = putMixedTK . asMixedTK getSigSubPacket :: Get SigSubPacket getSigSubPacket = do@@ -3600,23 +3614,6 @@ putSignaturePayload (SigVOther pv bs) = do putWord8 pv putLazyByteString bs--putTK :: TKUnknown -> Put-putTK tk = do- let pkp = tk ^. tkuKey . _1- maybe- (put (PublicKey pkp))- (\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)- where- putUid' (u, sps) = put (UserId u) >> mapM_ (put . Signature) sps- putUat' (us, sps) = put (UserAttribute us) >> mapM_ (put . Signature) sps- putSub' (p, sps) = put p >> mapM_ (put . Signature) sps -- | Parse the packets from a ByteString, with no error reporting parsePkts :: ByteString -> [Pkt]
Codec/Encryption/OpenPGP/Signatures.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} -- Signatures.hs: OpenPGP (RFC9580) signature verification -- Copyright © 2012-2026 Clint Adams@@ -8,6 +9,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}@@ -499,7 +501,11 @@ | BadLength !String !Int !Int verifyTKWith- :: ( Pkt+ :: forall k+ . ( TKKeyPktToPkt k+ , TKPrimaryPKPayload k+ )+ => ( Pkt -> PktStreamContext -> Maybe UTCTime -> Either VerificationError Verification@@ -574,20 +580,20 @@ in (uat, retainNonRevokedCertifications mt verified) ) checkSub- :: (KeyPkt k, [SignaturePayload])- -> [(KeyPkt k, [SignaturePayload])]+ :: (TKKeyPkt k, [SignaturePayload])+ -> [(TKKeyPkt k, [SignaturePayload])] checkSub (pkt, sps) = if revokedSub pkt sps then [] else checkSub' pkt sps- revokedSub :: KeyPkt k -> [SignaturePayload] -> Bool+ revokedSub :: TKKeyPkt k -> [SignaturePayload] -> Bool revokedSub _ [] = False revokedSub p sigs = any (vSubSig p) (filter subkeyRevocationEffective sigs) checkSub'- :: KeyPkt k+ :: TKKeyPkt k -> [SignaturePayload]- -> [(KeyPkt k, [SignaturePayload])]+ -> [(TKKeyPkt k, [SignaturePayload])] checkSub' p sps = let goodsigs = filter (vSubSig p)@@ -608,7 +614,7 @@ | isV4OrV6Sig s , sigType s == Just KeyRevocationSig , Just pka <- sigPKA s ->- if (v ^. verificationSigner == keyPktPKPayload (tk ^. tkPrimaryKey))+ if (v ^. verificationSigner == tkPrimaryPKPayload tk) || any ( \(p, f) -> p == pka && f == fingerprint (v ^. verificationSigner)@@ -627,7 +633,7 @@ vsf (SignaturePkt sp) emptyPSC- { lastPrimaryKey = keyPktToPkt (tk ^. tkPrimaryKey)+ { lastPrimaryKey = tkKeyPktToPkt @k (_tkPrimaryKey tk) , lastUIDorUAt = UserIdPkt uid } Nothing@@ -638,7 +644,7 @@ vsf (SignaturePkt sp) emptyPSC- { lastPrimaryKey = keyPktToPkt (tk ^. tkPrimaryKey)+ { lastPrimaryKey = tkKeyPktToPkt @k (_tkPrimaryKey tk) , lastUIDorUAt = UserAttributePkt uat } Nothing@@ -646,16 +652,16 @@ vSig sp = vsf (SignaturePkt sp)- emptyPSC {lastPrimaryKey = keyPktToPkt (tk ^. tkPrimaryKey)}+ emptyPSC {lastPrimaryKey = tkKeyPktToPkt @k (_tkPrimaryKey tk)} Nothing- vSubSig :: KeyPkt k -> SignaturePayload -> Bool+ vSubSig :: TKKeyPkt k -> SignaturePayload -> Bool vSubSig sk sp = isRight ( vsf (SignaturePkt sp) emptyPSC- { lastPrimaryKey = keyPktToPkt (tk ^. tkPrimaryKey)- , lastSubkey = keyPktToPkt sk+ { lastPrimaryKey = tkKeyPktToPkt @k (_tkPrimaryKey tk)+ , lastSubkey = tkKeyPktToPkt @k sk } mt )@@ -1299,15 +1305,24 @@ padN n bs = leftPadTo n bs cf2es = 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))+ case rsaMPItoSig pkey mpis of+ Nothing ->+ verificationError (SignatureMismatch RSA (fingerprint pub))+ Just sig ->+ if P15.verify (Just hd) pkey bs sig+ 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)- in leftPadTo sz raw+ in if B.length raw > sz+ then Nothing+ else Just (leftPadTo sz raw)+ rsaMPItoSig _ _ = Nothing crazyHash h = BA.convert . hashWith h isSignatureExpired
Codec/Encryption/OpenPGP/Signing.hs view
@@ -156,10 +156,13 @@ primaryPkp = keyPktPKPayload primaryKp primarySka = secretKeyPktSKAddendum primaryKp primaryUsage =- foldr- Set.union- Set.empty- (map sigFlags (_tkDirectKeySigs tk ++ _tkRevs tk))+ Set.insert+ CertifyKeysKey+ ( foldr+ Set.union+ Set.empty+ (map sigFlags (_tkDirectKeySigs tk ++ _tkRevs tk))+ ) primary = AvailableSigner { asKeyId = either (error . show) id (eightOctetKeyID primaryPkp)
Codec/Encryption/OpenPGP/Types/Internal/Errors.hs view
@@ -67,8 +67,6 @@ , renderSerializeError -- * AEAD / SEIPDv2 unified auth failures- , AEADAuthFailure (..)- , renderAEADAuthFailure , SEIPDv2Failure (..) , renderSEIPDv2Failure @@ -137,19 +135,87 @@ -- | Errors that can arise from block-cipher operations in this library. data CipherError = -- | The algorithm is not supported or not implemented.- UnsupportedAlgorithm !SymmetricAlgorithm+ CipherUnsupportedAlgorithm !SymmetricAlgorithm | -- | Cipher initialization failed (bad key material).- CipherInitFailed !SymmetricAlgorithm !String- | -- | A CFB or other block-cipher operation failed.- CipherOperationFailed !String+ CipherInitFailed !SymmetricAlgorithm !CE.CryptoError+ | -- | Cipher initialization failed for old nettle backend.+ CipherOldInitFailed !String+ | -- | A backend crypto operation failed.+ CipherOperationFailed !CE.CryptoError+ | -- | Backend does not support padding operations.+ CipherPaddingUnsupported+ | -- | Backend does not support the requested AEAD mode.+ CipherAEADModeUnsupported+ | -- | Invalid IV length or value.+ CipherBadIV !String+ | -- | Backend does not support AEAD initialization.+ CipherAEADInitUnsupported+ | -- | Session key quickcheck failed.+ CipherSessionKeyQuickcheckFailed+ | -- | AEAD authentication failed.+ CipherAEADAuthFailed+ | -- | AEAD decrypt returned Nothing.+ CipherAEADDecryptFailed+ | -- | Key wrap input is invalid.+ CipherKeyWrapInvalidInput !String+ | -- | KDF hash algorithm is disallowed by policy.+ CipherKdfHashAlgorithmDisallowed !HashAlgorithm+ | -- | KDF hash algorithm is unsupported.+ CipherKdfHashAlgorithmUnsupported !HashAlgorithm+ | -- | Curve conversion failed for ECDH KDF parameter.+ CipherCurveConversionFailed !CurveConversionError+ | -- | Recipient is not a valid ECDH key.+ CipherInvalidECDHRecipient+ | -- | Ciphertext is too short to contain a valid chunk.+ CipherCiphertextTooShort+ | -- | Malformed chunk lengths in SEIPDv2.+ CipherMalformedChunkLengths+ | -- | Missing final authentication tag.+ CipherMissingFinalTag+ | -- | Final SEIPDv2 tag must be empty.+ CipherFinalTagEmpty deriving (Eq, Show) renderCipherError :: CipherError -> String-renderCipherError (UnsupportedAlgorithm sa) =+renderCipherError (CipherUnsupportedAlgorithm sa) = "unsupported symmetric algorithm: " ++ show sa renderCipherError (CipherInitFailed sa err) =- "could not initialize cipher for " ++ show sa ++ ": " ++ err-renderCipherError (CipherOperationFailed err) = err+ "could not initialize cipher for " ++ show sa ++ ": " ++ show err+renderCipherError (CipherOldInitFailed err) =+ "could not initialize old backend cipher: " ++ err+renderCipherError (CipherOperationFailed err) = show err+renderCipherError CipherPaddingUnsupported =+ "padding not supported by this backend"+renderCipherError CipherAEADModeUnsupported =+ "AEAD mode not supported by this backend"+renderCipherError (CipherBadIV msg) = msg+renderCipherError CipherAEADInitUnsupported =+ "aeadInit not supported for this cipher backend"+renderCipherError CipherSessionKeyQuickcheckFailed =+ "Session key quickcheck failed"+renderCipherError CipherAEADAuthFailed =+ "AEAD authentication failed"+renderCipherError CipherAEADDecryptFailed =+ "AEAD decrypt returned Nothing"+renderCipherError (CipherKeyWrapInvalidInput err) = err+renderCipherError (CipherKdfHashAlgorithmDisallowed ha) =+ "ECDH KDF hash algorithm "+ ++ show ha+ ++ " is disallowed by policy"+renderCipherError (CipherKdfHashAlgorithmUnsupported ha) =+ "ECDH KDF hash algorithm" ++ show ha ++ "is unsupported"+renderCipherError (CipherCurveConversionFailed err) =+ renderCurveConversionError err+renderCipherError CipherInvalidECDHRecipient =+ "ECDH KDF param requires ECDH recipient key"+renderCipherError CipherCiphertextTooShort =+ "SEIPDv2 ciphertext too short"+renderCipherError CipherMalformedChunkLengths =+ "SEIPDv2 malformed chunk lengths"+renderCipherError CipherMissingFinalTag =+ "SEIPDv2 missing final tag"+renderCipherError CipherFinalTagEmpty =+ "expected empty ciphertext for final SEIPD v2 tag" ------------------------------------------------------------------------------- @@ -765,7 +831,7 @@ | UnsupportedRecipientAlgorithm !PubKeyAlgorithm | InvalidRecipientKeyMaterial !PubKeyAlgorithm !String | InvalidRecipientKeyMaterialKeyId !PubKeyAlgorithm !KeyIdError- | RecipientKdfFailure !PubKeyAlgorithm !String+ | RecipientKdfFailure !PubKeyAlgorithm !CipherError | RecipientKeyWrapFailure !PubKeyAlgorithm !String | RecipientKeyWrapFailureCipher !PubKeyAlgorithm !CipherError | RecipientKeyWrapFailureRSA !PubKeyAlgorithm !RSA.Error@@ -806,11 +872,11 @@ ++ show algo ++ ": failed to derive PKESKv3 recipient key ID: " ++ renderKeyIdError err-renderPKESKEncryptError (RecipientKdfFailure algo reason) =+renderPKESKEncryptError (RecipientKdfFailure algo err) = "KDF failure for recipient algorithm " ++ show algo ++ ": "- ++ reason+ ++ renderCipherError err renderPKESKEncryptError (RecipientKeyWrapFailure algo reason) = "key wrap failure for recipient algorithm " ++ show algo@@ -960,26 +1026,6 @@ -- AEAD / SEIPDv2 unified auth failures ------------------------------------------------------------------------------- --- | Unified AEAD authentication failures shared between legacy AEAD and SEIPDv2.-data AEADAuthFailure- = AEADChunkAuthFailed !AEADAlgorithm !Int- | AEADFinalTagFailed !AEADAlgorithm- | AEADInitFailed !CipherError- deriving (Eq, Show)--renderAEADAuthFailure :: AEADAuthFailure -> String-renderAEADAuthFailure (AEADChunkAuthFailed algo chunk) =- "AEAD chunk authentication failed for "- ++ show algo- ++ " at chunk "- ++ show chunk-renderAEADAuthFailure (AEADFinalTagFailed algo) =- "AEAD final tag verification failed for " ++ show algo-renderAEADAuthFailure (AEADInitFailed err) =- "AEAD initialization failed: " ++ renderCipherError err---------------------------------------------------------------------------------- data SEIPDv2Failure = SEIPDv2UnsupportedAEADAlgorithm !AEADAlgorithm | SEIPDv2UnsupportedSymmetricAlgorithm !SymmetricAlgorithm@@ -989,8 +1035,6 @@ | SEIPDv2CiphertextTooShort | SEIPDv2MalformedChunkLengths | SEIPDv2MissingFinalTag- | SEIPDv2AuthFailure !AEADAuthFailure- | SEIPDv2AuthFailed | SEIPDv2CipherFailed !CipherError | SEIPDv2SessionKeyError !S2KError deriving (Eq, Show)@@ -1014,9 +1058,6 @@ "SEIPD v2 malformed chunk lengths" renderSEIPDv2Failure SEIPDv2MissingFinalTag = "SEIPD v2 missing final authentication tag"-renderSEIPDv2Failure (SEIPDv2AuthFailure auth) = renderAEADAuthFailure auth-renderSEIPDv2Failure SEIPDv2AuthFailed =- "AEAD authentication failed" renderSEIPDv2Failure (SEIPDv2CipherFailed err) = "AEAD/cipher operation failed: " ++ renderCipherError err renderSEIPDv2Failure (SEIPDv2SessionKeyError err) = renderS2KError err@@ -1031,6 +1072,7 @@ | SKESKSEIPDAlgorithmMismatch | UnsupportedEncryptedSKESK | MissingLiteralDataPacket+ | UnexpectedPacketInDecryptedPayload !Word8 | MessageParseCriticalPacketError !CriticalPacketError deriving (Eq, Show) @@ -1045,6 +1087,8 @@ "Cannot decrypt SKESK packets with encrypted session keys" renderMessageParseFailure MissingLiteralDataPacket = "Decrypted message does not contain a literal data packet"+renderMessageParseFailure (UnexpectedPacketInDecryptedPayload tag) =+ "Unexpected packet in decrypted payload: tag " ++ show tag renderMessageParseFailure (MessageParseCriticalPacketError err) = renderCriticalPacketError err @@ -1085,14 +1129,12 @@ data PayloadDecryptFailure = PayloadDecryptCipherFailed !CipherError | PayloadDecryptMDCFailed !MDCFailure- | PayloadDecryptAEADFailed !AEADAuthFailure | PayloadDecryptSEIPDv2Failed !SEIPDv2Failure deriving (Eq, Show) renderPayloadDecryptFailure :: PayloadDecryptFailure -> String renderPayloadDecryptFailure (PayloadDecryptCipherFailed err) = renderCipherError err renderPayloadDecryptFailure (PayloadDecryptMDCFailed err) = renderMDCFailure err-renderPayloadDecryptFailure (PayloadDecryptAEADFailed err) = renderAEADAuthFailure err renderPayloadDecryptFailure (PayloadDecryptSEIPDv2Failed err) = renderSEIPDv2Failure err -------------------------------------------------------------------------------
Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-}@@ -207,6 +208,12 @@ someKeyPktToPkt (SomeKeyPkt left) == someKeyPktToPkt (SomeKeyPkt right) +instance A.ToJSON (KeyPkt k) where+ toJSON = A.toJSON . keyPktToPkt++instance A.ToJSON SomeKeyPkt where+ toJSON = A.toJSON . someKeyPktToPkt+ data Pkt = PKESKPkt PKESKPayload | SignaturePkt SignaturePayload@@ -246,6 +253,24 @@ instance Hashable PktWithBytes +instance Semigroup PktWithBytes where+ a <> b+ | _pktValue a == _pktValue b = a+ | otherwise =+ error+ ( "Semigroup PktWithBytes: cannot merge different packet types "+ ++ show (_pktValue a)+ ++ " <> "+ ++ show (_pktValue b)+ )++instance A.ToJSON PktWithBytes where+ toJSON (PktWithBytes raw pkt) =+ object+ [ AK.fromString "raw" .= BL.unpack raw+ , AK.fromString "pkt" .= pkt+ ]+ data PktWithWireRep = PktWithWireRep { _pktWireRep :: PktWithBytes@@ -660,6 +685,79 @@ someKeyPktToPkt :: SomeKeyPkt -> Pkt someKeyPktToPkt (SomeKeyPkt keyPkt) = keyPktToPkt keyPkt++instance Ord SomeKeyPkt where+ compare = comparing someKeyPktToPkt++instance Hashable SomeKeyPkt where+ hashWithSalt s = hashWithSalt s . someKeyPktToPkt++tySomeKeyPkt :: DD.DataType+tySomeKeyPkt =+ DD.mkDataType+ "Codec.Encryption.OpenPGP.Types.Internal.Pkt.SomeKeyPkt"+ [conSomeKeyPkt]++conSomeKeyPkt :: DD.Constr+conSomeKeyPkt = DD.mkConstr tySomeKeyPkt "KeyPkt" [] DD.Prefix++instance Data SomeKeyPkt where+ gfoldl f z (SomeKeyPkt kp) = case kp of+ KeyPktPublicPrimary pkp ->+ z (SomeKeyPkt . KeyPktPublicPrimary) `f` pkp+ KeyPktPublicSubkey pkp ->+ z (SomeKeyPkt . KeyPktPublicSubkey) `f` pkp+ KeyPktSecretPrimary pkp ska ->+ z (SomeKeyPkt .: KeyPktSecretPrimary)+ `f` pkp+ `f` ska+ KeyPktSecretSubkey pkp ska ->+ z (SomeKeyPkt .: KeyPktSecretSubkey)+ `f` pkp+ `f` ska+ where+ (.:) = (.) . (.)+ gunfold _ _ _ = error "SomeKeyPkt: gunfold not supported for GADT"+ toConstr _ = conSomeKeyPkt+ dataTypeOf _ = tySomeKeyPkt++deriving instance Typeable SomeKeyPkt++class KeyPktToSomeKeyPkt a where+ toSomeKeyPkt :: a -> SomeKeyPkt++instance KeyPktToSomeKeyPkt (KeyPkt 'PublicPkt) where+ toSomeKeyPkt kp = SomeKeyPkt kp++instance KeyPktToSomeKeyPkt (KeyPkt 'SecretPkt) where+ toSomeKeyPkt kp = SomeKeyPkt kp++instance KeyPktToSomeKeyPkt SomeKeyPkt where+ toSomeKeyPkt (SomeKeyPkt kp) = SomeKeyPkt kp++someKeyPktPKPayload :: SomeKeyPkt -> SomePKPayload+someKeyPktPKPayload (SomeKeyPkt kp) = keyPktPKPayload kp++someKeyPktRole :: SomeKeyPkt -> KeyPktRole+someKeyPktRole (SomeKeyPkt kp) = keyPktRole kp++someKeyPktMaybeSKAddendum :: SomeKeyPkt -> Maybe SKAddendum+someKeyPktMaybeSKAddendum (SomeKeyPkt kp) = keyPktMaybeSKAddendum kp++someKeyPktToPublicView :: SomeKeyPkt -> SomeKeyPkt+someKeyPktToPublicView (SomeKeyPkt kp) =+ case kp of+ KeyPktPublicPrimary pkp -> SomeKeyPkt (KeyPktPublicPrimary pkp)+ KeyPktPublicSubkey pkp -> SomeKeyPkt (KeyPktPublicSubkey pkp)+ KeyPktSecretPrimary pkp _ -> SomeKeyPkt (KeyPktPublicPrimary pkp)+ KeyPktSecretSubkey pkp _ -> SomeKeyPkt (KeyPktPublicSubkey pkp)++someKeyPktToPublicPkt :: SomeKeyPkt -> KeyPkt 'PublicPkt+someKeyPktToPublicPkt (SomeKeyPkt kp) = case kp of+ KeyPktPublicPrimary pkp -> KeyPktPublicPrimary pkp+ KeyPktPublicSubkey pkp -> KeyPktPublicSubkey pkp+ KeyPktSecretPrimary pkp _ -> KeyPktPublicPrimary pkp+ KeyPktSecretSubkey pkp _ -> KeyPktPublicSubkey pkp pktToSomeKeyPktEither :: Pkt -> Either (KeyPktCoercionError Pkt) SomeKeyPkt
Codec/Encryption/OpenPGP/Types/Internal/TK.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE AllowAmbiguousTypes #-} -- TK.hs: OpenPGP (RFC9580) transferable key data type -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license.@@ -9,22 +10,25 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Codec.Encryption.OpenPGP.Types.Internal.TK ( -- * Types- TKUnknown (..)- , TK (..)+ TK (..) , SomeTK (..) , TKKind (..) , PacketZipper (..)- , TKKindToKeyPktKind+ , TKKeyPkt , KeyringIxs , PublicKeyring , SecretKeyring+ , MixedKeyring , KeyringOf -- * Structured types@@ -32,26 +36,28 @@ , PacketRefId (..) , SignatureWithWireRef (..) , UIDWithWireRefs (..)- , UATWithWireRefs (..)+ , UAtWithWireRefs (..) , SubkeyWithWireRefs (..) , TKStructuredWithWireRep (..) , CanonicalizeTKWithWireRepError (..) -- * Constructors- , mkTKUnknown+ , mkMixedTK , fromPrimaryKeyPktToSomeTK -- * Conversions- , tkToUnknown- , someTKToUnknown+ , someTKToMixedTK , someTKToPublicTK , someTKToSecretTK , someTKToPublicViewTK- , publicViewTK- , fromUnknownToTK- , fromUnknownToTKEither+ , fromMixedTKToTK+ , asMixedTK , tkSecretKeyPairs , modifyTKSecretKeys+ , TKPublicView (..)+ , TKSomes (..)+ , TKPrimaryPKPayload (..)+ , TKKeyPktToPkt (..) -- * Canonicalization , canonicalizeTKStructuredWithWireRep@@ -75,12 +81,12 @@ , subkeyWireSortKey , compareSignatureWithWireRefCanonical , compareUIDWithWireRefsCanonical- , compareUATWithWireRefsCanonical+ , compareUAtWithWireRefsCanonical , compareSubkeyWithWireRefsCanonical , sortCanonicalByKey , sortSignatureWithWireRefsCanonical , sortUIDWithWireRefsCanonical- , sortUATWithWireRefsCanonical+ , sortUAtWithWireRefsCanonical , sortSubkeyWithWireRefsCanonical -- * Instances@@ -89,12 +95,6 @@ , Show (..) -- * Lenses- , tkuKey- , tkuRevs- , tkuDirectKeySigs- , tkuUIDs- , tkuUAts- , tkuSubs , tkPrimaryKey , tkRevs , tkDirectKeySigs@@ -143,26 +143,22 @@ import Control.Comonad (Comonad (..)) import Control.Error.Util (note) import Control.Lens- ( folded- , makeLenses- , to- , view+ ( makeLenses , (^.)- , (^..)- , _1 )-import qualified Data.Aeson.TH as ATH-import Data.Bifunctor (first)+import Data.Aeson (object, (.=))+import qualified Data.Aeson as A+import qualified Data.Aeson.Key as AK import qualified Data.ByteString.Lazy as BL import Data.Data (Data) import Data.Function (on) import qualified Data.HashMap.Lazy as HashMap+import Data.Hashable (Hashable) import Data.IxSet.Typed (IxSet) import Data.Kind (Type) import Data.List (find, sortOn) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map-import Data.Ord (comparing) import qualified Data.Set as Set import Data.Text (Text) import Data.Typeable (Typeable)@@ -227,77 +223,67 @@ zToList :: PacketZipper a -> [a] zToList (PacketZipper before current after) = before ++ [current] ++ after -data TKUnknown- = TKUnknown- { _tkuKey :: (SomePKPayload, Maybe SKAddendum)- , _tkuRevs :: [SignaturePayload]- , _tkuDirectKeySigs :: [SignaturePayload]- , _tkuUIDs :: [(Text, [SignaturePayload])]- , _tkuUAts :: [([UserAttrSubPacket], [SignaturePayload])]- , _tkuSubs :: [(Pkt, [SignaturePayload])]- }- deriving (Data, Eq, Generic, Show, Typeable)- data TKKind = PublicTK | SecretTK+ | MixedTK deriving (Data, Eq, Generic, Ord, Show, Typeable) -type family TKKindToKeyPktKind (k :: TKKind) :: KeyPktKind where- TKKindToKeyPktKind 'PublicTK = 'PublicPkt- TKKindToKeyPktKind 'SecretTK = 'SecretPkt+type family TKKeyPkt (k :: TKKind) :: Type where+ TKKeyPkt 'PublicTK = KeyPkt 'PublicPkt+ TKKeyPkt 'SecretTK = KeyPkt 'SecretPkt+ TKKeyPkt 'MixedTK = SomeKeyPkt data TK (k :: TKKind) = TK- { _tkPrimaryKey :: KeyPkt (TKKindToKeyPktKind k)+ { _tkPrimaryKey :: TKKeyPkt k , _tkRevs :: [SignaturePayload] , _tkDirectKeySigs :: [SignaturePayload] , _tkUIDs :: [(Text, [SignaturePayload])] , _tkUAts :: [([UserAttrSubPacket], [SignaturePayload])]- , _tkSubs :: [(KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])]+ , _tkSubs :: [(TKKeyPkt k, [SignaturePayload])] }- deriving (Eq, Show) +deriving instance Eq (TKKeyPkt k) => Eq (TK k)+deriving instance Show (TKKeyPkt k) => Show (TK k)+ deriving instance- (Data (KeyPkt (TKKindToKeyPktKind k)), Typeable k) => Data (TK k)+ (Data (TKKeyPkt k), Typeable k) => Data (TK k) -instance Ord (TK k) where- compare = comparing _tkPrimaryKey+deriving instance (Ord (TKKeyPkt k)) => Ord (TK k) +instance A.ToJSON (TKKeyPkt k) => A.ToJSON (TK k) where+ toJSON tk =+ object+ [ AK.fromString "primaryKey" .= _tkPrimaryKey tk+ , AK.fromString "revs" .= _tkRevs tk+ , AK.fromString "directKeySigs" .= _tkDirectKeySigs tk+ , AK.fromString "uids" .= _tkUIDs tk+ , AK.fromString "uats" .= _tkUAts tk+ , AK.fromString "subs" .= _tkSubs tk+ ]+ data SomeTK where SomePublicTK :: TK 'PublicTK -> SomeTK SomeSecretTK :: TK 'SecretTK -> SomeTK+ SomeMixedTK :: TK 'MixedTK -> SomeTK deriving instance Show SomeTK -instance Eq SomeTK where- left == right = someTKToUnknown left == someTKToUnknown right--tkToUnknown :: TK k -> TKUnknown-tkToUnknown tk =- TKUnknown- { _tkuKey = keyPktTKKey (_tkPrimaryKey tk)- , _tkuRevs = _tkRevs tk- , _tkuDirectKeySigs = _tkDirectKeySigs tk- , _tkuUIDs = _tkUIDs tk- , _tkuUAts = _tkUAts tk- , _tkuSubs =- map (\(kp, sigs) -> (keyPktToPkt kp, sigs)) (_tkSubs tk)- }--someTKToUnknown :: SomeTK -> TKUnknown-someTKToUnknown (SomePublicTK tk) = tkToUnknown tk-someTKToUnknown (SomeSecretTK tk) = tkToUnknown tk+instance A.ToJSON SomeTK where+ toJSON (SomePublicTK tk) = A.toJSON tk+ toJSON (SomeSecretTK tk) = A.toJSON tk+ toJSON (SomeMixedTK tk) = A.toJSON tk -mkTKUnknown :: SomePKPayload -> Maybe SKAddendum -> TKUnknown-mkTKUnknown pkp maybeSka =- TKUnknown- { _tkuKey = (pkp, maybeSka)- , _tkuRevs = []- , _tkuDirectKeySigs = []- , _tkuUIDs = []- , _tkuUAts = []- , _tkuSubs = []+mkMixedTK :: SomeKeyPkt -> TK 'MixedTK+mkMixedTK pkp =+ TK+ { _tkPrimaryKey = pkp+ , _tkRevs = []+ , _tkDirectKeySigs = []+ , _tkUIDs = []+ , _tkUAts = []+ , _tkSubs = [] } fromPrimaryKeyPktToSomeTK@@ -338,38 +324,107 @@ someTKToPublicTK :: SomeTK -> Maybe (TK 'PublicTK) someTKToPublicTK (SomePublicTK tk) = Just tk someTKToPublicTK (SomeSecretTK _) = Nothing+someTKToPublicTK (SomeMixedTK _) = Nothing someTKToSecretTK :: SomeTK -> Maybe (TK 'SecretTK) someTKToSecretTK (SomeSecretTK tk) = Just tk someTKToSecretTK (SomePublicTK _) = Nothing+someTKToSecretTK (SomeMixedTK _) = Nothing someTKToPublicViewTK :: SomeTK -> TK 'PublicTK someTKToPublicViewTK (SomePublicTK tk) = tk someTKToPublicViewTK (SomeSecretTK tk) = publicViewTK tk+someTKToPublicViewTK (SomeMixedTK tk) = publicViewTK tk -publicViewTK :: TK 'SecretTK -> TK 'PublicTK-publicViewTK tk =- TK- { _tkPrimaryKey = keyPktToPublicView (_tkPrimaryKey tk)- , _tkRevs = _tkRevs tk- , _tkDirectKeySigs = _tkDirectKeySigs tk- , _tkUIDs = _tkUIDs tk- , _tkUAts = _tkUAts tk- , _tkSubs =- map (\(kp, sigs) -> (keyPktToPublicView kp, sigs)) (_tkSubs tk)- }+someTKToMixedTK :: SomeTK -> Maybe (TK 'MixedTK)+someTKToMixedTK (SomeMixedTK tk) = Just tk+someTKToMixedTK _ = Nothing -tkSomeSubs :: TK k -> [SomeKeyPkt]-tkSomeSubs tk =- let xs = view (to _tkSubs) tk- in xs ^.. (folded . _1 . to SomeKeyPkt)+class TKPublicView (k :: TKKind) where+ publicViewTK :: TK k -> TK 'PublicTK +instance TKPublicView 'PublicTK where+ publicViewTK tk = tk++instance TKPublicView 'SecretTK where+ publicViewTK tk =+ TK+ { _tkPrimaryKey = keyPktToPublicView (_tkPrimaryKey tk)+ , _tkRevs = _tkRevs tk+ , _tkDirectKeySigs = _tkDirectKeySigs tk+ , _tkUIDs = _tkUIDs tk+ , _tkUAts = _tkUAts tk+ , _tkSubs =+ map+ ( \(kp, sigs) ->+ (keyPktToPublicView kp, sigs)+ )+ (_tkSubs tk)+ }++instance TKPublicView 'MixedTK where+ publicViewTK tk =+ TK+ { _tkPrimaryKey =+ someKeyPktToPublicPkt (toSomeKeyPkt (_tkPrimaryKey tk))+ , _tkRevs = _tkRevs tk+ , _tkDirectKeySigs = _tkDirectKeySigs tk+ , _tkUIDs = _tkUIDs tk+ , _tkUAts = _tkUAts tk+ , _tkSubs =+ map+ ( \(kp, sigs) ->+ (someKeyPktToPublicPkt (toSomeKeyPkt kp), sigs)+ )+ (_tkSubs tk)+ }++class TKSomes (k :: TKKind) where+ tkSomeSubs :: TK k -> [SomeKeyPkt]++instance TKSomes 'PublicTK where+ tkSomeSubs tk =+ SomeKeyPkt (_tkPrimaryKey tk)+ : [SomeKeyPkt kp | (kp, _) <- _tkSubs tk]++instance TKSomes 'SecretTK where+ tkSomeSubs tk =+ SomeKeyPkt (_tkPrimaryKey tk)+ : [SomeKeyPkt kp | (kp, _) <- _tkSubs tk]++instance TKSomes 'MixedTK where+ tkSomeSubs tk = _tkPrimaryKey tk : [kp | (kp, _) <- _tkSubs tk]+ tkSecretKeyPairs :: TK 'SecretTK -> [(SomePKPayload, SKAddendum)] tkSecretKeyPairs tk = [ (keyPktPKPayload kp, secretKeyPktSKAddendum kp) | kp <- _tkPrimaryKey tk : map fst (_tkSubs tk) ] +class TKPrimaryPKPayload (k :: TKKind) where+ tkPrimaryPKPayload :: TK k -> SomePKPayload++instance TKPrimaryPKPayload 'PublicTK where+ tkPrimaryPKPayload tk = keyPktPKPayload (_tkPrimaryKey tk)++instance TKPrimaryPKPayload 'SecretTK where+ tkPrimaryPKPayload tk = keyPktPKPayload (_tkPrimaryKey tk)++instance TKPrimaryPKPayload 'MixedTK where+ tkPrimaryPKPayload tk = someKeyPktPKPayload (_tkPrimaryKey tk)++class TKKeyPktToPkt (k :: TKKind) where+ tkKeyPktToPkt :: TKKeyPkt k -> Pkt++instance TKKeyPktToPkt 'PublicTK where+ tkKeyPktToPkt = keyPktToPkt++instance TKKeyPktToPkt 'SecretTK where+ tkKeyPktToPkt = keyPktToPkt++instance TKKeyPktToPkt 'MixedTK where+ tkKeyPktToPkt (SomeKeyPkt kp) = keyPktToPkt kp+ modifyTKSecretKeys :: TK 'SecretTK -> (SomePKPayload -> SKAddendum -> (SomePKPayload, SKAddendum))@@ -393,92 +448,40 @@ let (pkp', ska') = f pkp ska in KeyPktSecretSubkey pkp' ska' -fromUnknownToTKEither- :: TKUnknown -> Either TKConversionError SomeTK-fromUnknownToTKEither tk =- case _tkuKey tk of- (pkp, Nothing) -> do- subs <- traverse liftPublicSubkey (_tkuSubs tk)- let typed :: TK 'PublicTK- typed =- TK- { _tkPrimaryKey = KeyPktPublicPrimary pkp- , _tkRevs = _tkuRevs tk- , _tkDirectKeySigs = _tkuDirectKeySigs tk- , _tkUIDs = _tkuUIDs tk- , _tkUAts = _tkuUAts tk- , _tkSubs = subs- }- Right- (SomePublicTK typed)- (pkp, Just ska) -> do- subs <- traverse liftSecretSubkey (_tkuSubs tk)- let typed :: TK 'SecretTK- typed =- TK- { _tkPrimaryKey = KeyPktSecretPrimary pkp ska- , _tkRevs = _tkuRevs tk- , _tkDirectKeySigs = _tkuDirectKeySigs tk- , _tkUIDs = _tkuUIDs tk- , _tkUAts = _tkuUAts tk- , _tkSubs = subs- }- Right- (SomeSecretTK typed)- where- liftPublicSubkey- :: (Pkt, [SignaturePayload])- -> Either TKConversionError (KeyPkt 'PublicPkt, [SignaturePayload])- liftPublicSubkey (pkt, sigs) =- case pktToPublicKeyPkt pkt of- Just keyPkt- | keyPktRole keyPkt == KeyPktSubkey ->- Right (keyPkt, sigs)- | otherwise ->- Left PublicSubkeyHasPrimaryRole- Nothing ->- Left (ExpectedPublicSubkeyPacket (pktTag pkt))+fromMixedTKToTK :: TK 'MixedTK -> SomeTK+fromMixedTKToTK = SomeMixedTK - liftSecretSubkey- :: (Pkt, [SignaturePayload])- -> Either TKConversionError (KeyPkt 'SecretPkt, [SignaturePayload])- liftSecretSubkey (pkt, sigs) =- case pktToSecretKeyPkt pkt of- Just keyPkt- | keyPktRole keyPkt == KeyPktSubkey ->- Right (keyPkt, sigs)- | otherwise ->- Left SecretSubkeyHasPrimaryRole- Nothing ->- Left (ExpectedSecretSubkeyPacket (pktTag pkt))+asMixedTK :: SomeTK -> TK 'MixedTK+asMixedTK (SomePublicTK tk) =+ TK+ { _tkPrimaryKey = SomeKeyPkt (_tkPrimaryKey tk)+ , _tkRevs = _tkRevs tk+ , _tkDirectKeySigs = _tkDirectKeySigs tk+ , _tkUIDs = _tkUIDs tk+ , _tkUAts = _tkUAts tk+ , _tkSubs = [(SomeKeyPkt kp, sigs) | (kp, sigs) <- _tkSubs tk]+ }+asMixedTK (SomeSecretTK tk) =+ TK+ { _tkPrimaryKey = SomeKeyPkt (_tkPrimaryKey tk)+ , _tkRevs = _tkRevs tk+ , _tkDirectKeySigs = _tkDirectKeySigs tk+ , _tkUIDs = _tkUIDs tk+ , _tkUAts = _tkUAts tk+ , _tkSubs = [(SomeKeyPkt kp, sigs) | (kp, sigs) <- _tkSubs tk]+ }+asMixedTK (SomeMixedTK tk) = tk -fromUnknownToTK :: TKUnknown -> Either String SomeTK-fromUnknownToTK = first renderTKConversionError . fromUnknownToTKEither+instance Eq SomeTK where+ a == b = asMixedTK a == asMixedTK b -instance Semigroup TKUnknown where- a <> b =- TKUnknown- (_tkuKey a)- ( 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)- where- kvmerge x y =- Map.toList (Map.unionWith nsa (Map.fromList x) (Map.fromList y))- ukvmerge x y =- HashMap.toList- (HashMap.unionWith nsa (HashMap.fromList x) (HashMap.fromList y))- nsa x y = Set.toList $ Set.union (Set.fromList x) (Set.fromList y)+instance Semigroup SomeTK where+ SomePublicTK a <> SomePublicTK b = SomePublicTK (a <> b)+ SomeSecretTK a <> SomeSecretTK b = SomeSecretTK (a <> b)+ SomeMixedTK a <> SomeMixedTK b = SomeMixedTK (a <> b)+ a <> b = SomeMixedTK (asMixedTK a <> asMixedTK b) -instance Semigroup (TK k) where+instance (Hashable (TKKeyPkt k), Ord (TKKeyPkt k)) => Semigroup (TK k) where a <> b = TK (_tkPrimaryKey a)@@ -501,25 +504,12 @@ (HashMap.unionWith nsa (HashMap.fromList x) (HashMap.fromList y)) nsa x y = Set.toList $ Set.union (Set.fromList x) (Set.fromList y) -instance Semigroup SomeTK where- SomePublicTK a <> SomePublicTK b = SomePublicTK (a <> b)- SomeSecretTK a <> SomeSecretTK b = SomeSecretTK (a <> b)- a <> b =- error- ( "Semigroup SomeTK: cannot merge public and secret transferable keys"- ++ " ("- ++ show a- ++ " <> "- ++ show b- ++ ")"- )- data TKWithWireRep = TKWithWireRep { _tkWireRepRefs :: WireRepRefs , _tkWireRepRange :: Maybe ByteRange , _tkPackets :: [PktWithWireRep]- , _tkValue :: TKUnknown+ , _tkValue :: TK 'MixedTK } deriving (Data, Eq, Generic, Ord, Show, Typeable) @@ -545,8 +535,8 @@ } deriving (Data, Eq, Generic, Ord, Show, Typeable) -data UATWithWireRefs- = UATWithWireRefs+data UAtWithWireRefs+ = UAtWithWireRefs { _uatWithWireRefsValue :: [UserAttrSubPacket] , _uatWithWireRefsRef :: PacketRefId , _uatWithWireRefsSignatures :: [SignatureWithWireRef]@@ -570,7 +560,7 @@ , _tkStructuredRevs :: [SignatureWithWireRef] , _tkStructuredDirectKeySigs :: [SignatureWithWireRef] , _tkStructuredUIDs :: [UIDWithWireRefs]- , _tkStructuredUAts :: [UATWithWireRefs]+ , _tkStructuredUAts :: [UAtWithWireRefs] , _tkStructuredSubkeys :: [SubkeyWithWireRefs] , _tkStructuredPacketRefs :: [PktWithWireRep] }@@ -581,11 +571,6 @@ | CanonicalizeMissingPacketRef PacketRefId deriving (Data, Eq, Generic, Ord, Show, Typeable) -instance Ord TKUnknown where- -- TKUnknown ordering is identity-oriented: the primary key packet defines key identity,- -- while revocations, UIDs, and subkeys are mergeable metadata.- compare = comparing _tkuKey- wireRepOfTK :: TKWithWireRep -> WireRepRef wireRepOfTK = NE.head . _tkWireRepRefs @@ -636,7 +621,7 @@ uatWireSortKey :: TKStructuredWithWireRep- -> UATWithWireRefs+ -> UAtWithWireRefs -> Either CanonicalizeTKWithWireRepError (BL.ByteString, PacketRefId)@@ -674,12 +659,12 @@ <$> uidWireSortKey structured a <*> uidWireSortKey structured b -compareUATWithWireRefsCanonical+compareUAtWithWireRefsCanonical :: TKStructuredWithWireRep- -> UATWithWireRefs- -> UATWithWireRefs+ -> UAtWithWireRefs+ -> UAtWithWireRefs -> Either CanonicalizeTKWithWireRepError Ordering-compareUATWithWireRefsCanonical structured a b =+compareUAtWithWireRefsCanonical structured a b = compare <$> uatWireSortKey structured a <*> uatWireSortKey structured b@@ -726,11 +711,11 @@ uids sortCanonicalByKey (uidWireSortKey structured) normalized -sortUATWithWireRefsCanonical+sortUAtWithWireRefsCanonical :: TKStructuredWithWireRep- -> [UATWithWireRefs]- -> Either CanonicalizeTKWithWireRepError [UATWithWireRefs]-sortUATWithWireRefsCanonical structured uats = do+ -> [UAtWithWireRefs]+ -> Either CanonicalizeTKWithWireRepError [UAtWithWireRefs]+sortUAtWithWireRefsCanonical structured uats = do normalized <- traverse ( \uat ->@@ -760,52 +745,67 @@ canonicalizeTKStructuredWithWireRep :: TKStructuredWithWireRep- -> Either CanonicalizeTKWithWireRepError TKUnknown-canonicalizeTKStructuredWithWireRep structured =- buildTK- <$> sortSignatureWithWireRefsCanonical+ -> Either CanonicalizeTKWithWireRepError (TK 'MixedTK)+canonicalizeTKStructuredWithWireRep structured = do+ revs <-+ sortSignatureWithWireRefsCanonical structured (_tkStructuredRevs structured)- <*> sortSignatureWithWireRefsCanonical+ directKeySigs <-+ sortSignatureWithWireRefsCanonical structured (_tkStructuredDirectKeySigs structured)- <*> sortUIDWithWireRefsCanonical+ uids <-+ sortUIDWithWireRefsCanonical structured (_tkStructuredUIDs structured)- <*> sortUATWithWireRefsCanonical+ uats <-+ sortUAtWithWireRefsCanonical structured (_tkStructuredUAts structured)- <*> sortSubkeyWithWireRefsCanonical+ subs <-+ sortSubkeyWithWireRefsCanonical structured (_tkStructuredSubkeys structured)- where- buildTK revs directKeySigs uids uats subs =- TKUnknown- { _tkuKey = _tkStructuredPrimaryKey structured- , _tkuRevs = map _signatureWithWireRefValue revs- , _tkuDirectKeySigs = map _signatureWithWireRefValue directKeySigs- , _tkuUIDs =+ let (pkp, mska) = _tkStructuredPrimaryKey structured+ convertSub sub =+ (,)+ <$> note+ ( CanonicalizeStructuringError+ ( "expected key packet in structured subkey, got "+ ++ show (pktTag (_subkeyWithWireRefsValue sub))+ )+ )+ (pktToSomeKeyPkt (_subkeyWithWireRefsValue sub))+ <*> pure+ ( map+ _signatureWithWireRefValue+ (_subkeyWithWireRefsSignatures sub)+ )+ mixedSubs <- traverse convertSub subs+ return+ TK+ { _tkPrimaryKey = mkPrimaryKeyPkt pkp mska+ , _tkRevs = map _signatureWithWireRefValue revs+ , _tkDirectKeySigs = map _signatureWithWireRefValue directKeySigs+ , _tkUIDs = map ( _uidWithWireRefsValue &&& (map _signatureWithWireRefValue . _uidWithWireRefsSignatures) ) uids- , _tkuUAts =+ , _tkUAts = map ( _uatWithWireRefsValue &&& (map _signatureWithWireRefValue . _uatWithWireRefsSignatures) ) uats- , _tkuSubs =- map- ( _subkeyWithWireRefsValue- &&& (map _signatureWithWireRefValue . _subkeyWithWireRefsSignatures)- )- subs+ , _tkSubs = mixedSubs } canonicalizeTKWithWireRep- :: TKWithWireRep -> Either CanonicalizeTKWithWireRepError TKUnknown+ :: TKWithWireRep+ -> Either CanonicalizeTKWithWireRepError (TK 'MixedTK) canonicalizeTKWithWireRep tk = do structured <- case toStructuredTKWithWireRep tk of@@ -818,11 +818,14 @@ toStructuredTKWithWireRep tkWithRefs = do let tk = _tkValue tkWithRefs refs = _tkPackets tkWithRefs- (pkp, mska) = _tkuKey tk+ (pkp, mska) =+ ( someKeyPktPKPayload (_tkPrimaryKey tk)+ , someKeyPktMaybeSKAddendum (_tkPrimaryKey tk)+ ) primaryPkt = someKeyPktToPkt (mkPrimaryKeyPkt pkp mska) zipper <- note- "no packet references available for TKUnknown structuring"+ "no packet references available for TK 'MixedTK structuring" (zFromList refs) (primaryRef, z1') <- consumePktZ "primary key packet" primaryPkt zipper@@ -830,22 +833,25 @@ z1 <- case zMoveNext z1' of Just z -> Right z 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)+ -- Primary key is the only packet; only valid if no revisions, UIDs, UAts, or subkeys+ if null (_tkRevs tk)+ && null (_tkDirectKeySigs tk)+ && null (_tkUIDs tk)+ && null (_tkUAts tk)+ && null (_tkSubs tk) then Right z1' else Left "missing signatures/UIDs/subkeys after primary key packet" (revs, z2) <-- consumeSigsZ "key-revocation signatures" (_tkuRevs tk) z1+ consumeSigsZ "key-revocation signatures" (_tkRevs 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+ consumeSigsZ "direct-key signatures" (_tkDirectKeySigs tk) z2+ (uids, z4) <- consumeUIDsZ (_tkUIDs tk) z3+ (uats, z5) <- consumeUAtsZ (_tkUAts tk) z4+ (subs, z6) <-+ consumeSubsZ+ (map (\(kp, sigs) -> (someKeyPktToPkt kp, sigs)) (_tkSubs tk))+ z5 -- Check if there are trailing packets AFTER the current focus (not including it) case _zpAfter z6 of [] ->@@ -853,7 +859,7 @@ ( TKStructuredWithWireRep (_tkWireRepRefs tkWithRefs) (_tkWireRepRange tkWithRefs)- (_tkuKey tk)+ (pkp, mska) (packetRefIdOf primaryRef) revs directKeySigs@@ -866,7 +872,7 @@ Left ( "unexpected trailing packet reference at position " ++ show (zPosition z5 + 1)- ++ " while structuring TKUnknown provenance (tag "+ ++ " while structuring TK 'MixedTK provenance (tag " ++ show (pktTag (unexpected ^. pktWireRep . pktValue)) ++ ")" )@@ -942,18 +948,18 @@ , z4 ) - consumeUATsZ+ consumeUAtsZ :: [([UserAttrSubPacket], [SignaturePayload])] -> PacketZipper PktWithWireRep- -> Either String ([UATWithWireRefs], PacketZipper PktWithWireRep)- consumeUATsZ [] z = Right ([], z)- consumeUATsZ ((uat, sigs) : rest) z = do- (uatPkt, z1) <- consumePktZ "UAT packet" (UserAttributePkt uat) z- z2 <- tryMoveNext "missing UAT" z1 (null rest && null sigs)- (uatSigs, z3) <- consumeSigsZ "UAT signature" sigs z2- (tailUats, z4) <- consumeUATsZ rest z3+ -> Either String ([UAtWithWireRefs], PacketZipper PktWithWireRep)+ consumeUAtsZ [] z = Right ([], z)+ consumeUAtsZ ((uat, sigs) : rest) z = do+ (uatPkt, z1) <- consumePktZ "UAt packet" (UserAttributePkt uat) z+ z2 <- tryMoveNext "missing UAt" z1 (null rest && null sigs)+ (uatSigs, z3) <- consumeSigsZ "UAt signature" sigs z2+ (tailUats, z4) <- consumeUAtsZ rest z3 Right- ( UATWithWireRefs uat (packetRefIdOf uatPkt) uatSigs : tailUats+ ( UAtWithWireRefs uat (packetRefIdOf uatPkt) uatSigs : tailUats , z4 ) @@ -981,7 +987,7 @@ :: PktWithWireRep -> [TKWithWireRep] -> [TKWithWireRep] tksContainingPacket pkt = filter (elem pkt . packetRefsOfTK) -$(ATH.deriveToJSON ATH.defaultOptions ''TKUnknown)+$(makeLenses ''TK) type KeyringIxs = '[EightOctetKeyId, Fingerprint, Text] @@ -990,18 +996,19 @@ type SecretKeyring = IxSet KeyringIxs (TK 'SecretTK) +type MixedKeyring = IxSet KeyringIxs (TK 'MixedTK)+ -- | Parameterized kinded keyring for generic operations type family KeyringOf (k :: TKKind) :: Type where KeyringOf 'PublicTK = PublicKeyring KeyringOf 'SecretTK = SecretKeyring+ KeyringOf 'MixedTK = MixedKeyring -$(makeLenses ''TKUnknown)-$(makeLenses ''TK) $(makeLenses ''TKWithWireRep) $(makeLenses ''PacketRefId) $(makeLenses ''PacketZipper) $(makeLenses ''SignatureWithWireRef) $(makeLenses ''UIDWithWireRefs)-$(makeLenses ''UATWithWireRefs)+$(makeLenses ''UAtWithWireRefs) $(makeLenses ''SubkeyWithWireRefs) $(makeLenses ''TKStructuredWithWireRep)
Data/Conduit/OpenPGP/Decrypt.hs view
@@ -78,13 +78,15 @@ import Codec.Encryption.OpenPGP.BlockCipher ( keySize+ , withAEADCipher+ , withSymmetricCipher ) import Codec.Encryption.OpenPGP.CFB ( decryptOpenPGPCfb , decryptPreservingNonce ) import Codec.Encryption.OpenPGP.Encrypt- ( pkaEncryptOpsDict+ ( pubKeyEncryptOps ) import Codec.Encryption.OpenPGP.Fingerprint (fingerprint) import Codec.Encryption.OpenPGP.Internal@@ -96,14 +98,17 @@ , leftPadTo , xorBS )-import Codec.Encryption.OpenPGP.Internal.CryptoAES- ( withAESCipher- ) import Codec.Encryption.OpenPGP.Internal.CryptoECDH ( buildECDHKDFParam , deriveECDHKek , normalizeMontgomeryPublic )+import Codec.Encryption.OpenPGP.Internal.Crypton+ ( HOWrappedCCT (..)+ )+import Codec.Encryption.OpenPGP.Internal.HOBlockCipher+ ( HOBlockCipher (..)+ ) import Codec.Encryption.OpenPGP.Internal.RFC7253OCB ( decryptWithOCBRFC7253With )@@ -132,6 +137,10 @@ ( decryptSecretKeyAddendum ) import Codec.Encryption.OpenPGP.Types+import Codec.Encryption.OpenPGP.Types.Internal.Errors+ ( CipherError (..)+ , renderCipherError+ ) import Data.Conduit.OpenPGP.Compression (conduitDecompress) import Data.Conduit.OpenPGP.Keyring.Instances () @@ -288,7 +297,7 @@ -- | ReaderT wrapper for AEAD decryption computations type AEADDecrypt cipher =- ReaderT (AEADDecryptContext cipher) (Either SEIPDv2Failure)+ ReaderT (AEADDecryptContext cipher) (Either CipherError) conduitDecrypt :: (MonadFail m, MonadResource m, MonadThrow m, MonadUnliftIO m)@@ -1026,15 +1035,16 @@ -> B.ByteString -> Either SEIPDv2Failure B.ByteString decryptSEIPDv2WithKey symalgo aeadalgo mode chunkSize info noncePrefix sessionKey encrypted =- withAESCipher- (SEIPDv2CipherFailed . CipherInitFailed symalgo . show)- (SEIPDv2UnsupportedSymmetricAlgorithm symalgo)- symalgo- sessionKey- (decryptChunks aeadalgo mode info chunkSize noncePrefix encrypted)+ first+ SEIPDv2CipherFailed+ ( withAEADCipher+ symalgo+ sessionKey+ (decryptChunks aeadalgo mode info chunkSize noncePrefix encrypted)+ ) decryptChunks- :: CCT.BlockCipher cipher+ :: HOBlockCipher cipher => AEADAlgorithm -> CCT.AEADMode -> B.ByteString@@ -1042,13 +1052,14 @@ -> B.ByteString -> B.ByteString -> cipher- -> Either SEIPDv2Failure B.ByteString+ -> Either CipherError B.ByteString decryptChunks aeadalgo mode info chunkSize noncePrefix encrypted cipher = let ctx = AEADDecryptContext mode info chunkSize noncePrefix cipher in runReaderT decryptChunksWithReader ctx where decryptChunksWithReader- :: CCT.BlockCipher cipher => AEADDecrypt cipher B.ByteString+ :: HOBlockCipher cipher+ => AEADDecrypt cipher B.ByteString decryptChunksWithReader = go 0 encrypted [] 0 where chunkLen = 1 `shiftL` (fromIntegral chunkSize + 6)@@ -1057,7 +1068,7 @@ go idx remaining acc totalPlain | B.length remaining < 2 * tagLen = lift $- Left SEIPDv2CiphertextTooShort+ Left CipherCiphertextTooShort | otherwise = do let hasMoreChunks = B.length remaining > chunkLen + 2 * tagLen currentChunkLen =@@ -1066,7 +1077,7 @@ else B.length remaining - 2 * tagLen when (currentChunkLen < 0) $ lift $- Left SEIPDv2MalformedChunkLengths+ Left CipherMalformedChunkLengths let (chunkCiphertext, r1) = B.splitAt currentChunkLen remaining (chunkTag, r2) = B.splitAt tagLen r1 plainChunk <-@@ -1081,7 +1092,7 @@ else do when (B.length r2 /= tagLen) $ lift $- Left SEIPDv2MissingFinalTag+ Left CipherMissingFinalTag verifyFinalTagWithContext (fromIntegral (idx + 1)) (totalPlain + B.length plainChunk)@@ -1094,8 +1105,7 @@ then lift $ decryptWithOCBRFC7253With- ( \_ _ _ _ _ _ -> SEIPDv2AuthFailure (AEADChunkAuthFailed aeadalgo idx)- )+ (\_ _ _ _ _ _ -> CipherAEADAuthFailed) cipher' (noncePrefix' <> encodeWord64be (fromIntegral idx)) info@@ -1104,7 +1114,7 @@ else do aead <- initAEADWithContext (fromIntegral idx) let mPlain =- CCT.aeadSimpleDecrypt+ aeadSimpleDecrypt aead info chunkCiphertext@@ -1112,7 +1122,7 @@ case mPlain of Nothing -> lift $- Left (SEIPDv2AuthFailure (AEADChunkAuthFailed aeadalgo idx))+ Left (CipherAEADAuthFailed) Just p -> return p verifyFinalTagWithContext idx totalPlain finalTag = do@@ -1122,7 +1132,7 @@ plain <- lift $ decryptWithOCBRFC7253With- (\_ _ _ _ _ _ -> SEIPDv2AuthFailure (AEADFinalTagFailed aeadalgo))+ (\_ _ _ _ _ _ -> CipherAEADAuthFailed) cipher' (noncePrefix' <> encodeWord64be idx) (info <> encodeWord64be (fromIntegral totalPlain))@@ -1132,11 +1142,11 @@ then return () else lift $- Left (SEIPDv2AuthFailure (AEADFinalTagFailed aeadalgo))+ Left (CipherAEADAuthFailed) else do aead <- initAEADWithContext idx let mEmpty =- CCT.aeadSimpleDecrypt+ aeadSimpleDecrypt aead (info <> encodeWord64be (fromIntegral totalPlain)) B.empty@@ -1145,14 +1155,12 @@ Just p | B.null p -> return () _ -> lift $- Left (SEIPDv2AuthFailure (AEADFinalTagFailed aeadalgo))+ Left (CipherAEADAuthFailed) initAEADWithContext idx = do AEADDecryptContext mode' _ _ noncePrefix' cipher' <- ask lift- $ first (SEIPDv2CipherFailed . CipherOperationFailed . show)- . CE.eitherCryptoError- $ CCT.aeadInit mode' cipher' (noncePrefix' <> encodeWord64be idx)+ (aeadInit mode' cipher' (noncePrefix' <> encodeWord64be idx)) aeadModeAndNonceSize :: AEADAlgorithm -> Either SEIPDv2Failure (CCT.AEADMode, Int)@@ -2042,11 +2050,14 @@ "ECDH PKESK unwrap requires recipient ECDH public key to be ECDSA or X25519-compatible" param <- either- fail+ (fail . renderCipherError) pure (buildECDHKDFParam recipientPKP pka ecdhPub kdfHA kdfSA) kek <-- either fail pure (deriveECDHKek kdfHA kdfSA sharedSecret param)+ either+ (fail . renderCipherError)+ pure+ (deriveECDHKek kdfHA kdfSA sharedSecret param) let wrappedCandidates = candidateWrappedRFC3394CiphertextsForLegacyECDH (LegacyECDHWrappedRFC3394Ciphertext wrappedSessionKeyBytes)@@ -2104,11 +2115,14 @@ :: B.ByteString param <- either- fail+ (fail . renderCipherError) pure (buildECDHKDFParam recipientPKP pka ecdhPub kdfHA kdfSA) kek <-- either fail pure (deriveECDHKek kdfHA kdfSA sharedSecret param)+ either+ (fail . renderCipherError)+ pure+ (deriveECDHKek kdfHA kdfSA sharedSecret param) case aesKeyUnwrapRFC3394 kdfSA kek wrappedSessionKeyBytes of Left err -> fail (renderCipherError err) Right decoded -> pure decoded@@ -2130,16 +2144,14 @@ let sharedSecret = BA.convert (C25519.dh ephPub recipientSecret) :: B.ByteString param <- either- fail+ (fail . renderCipherError) pure (buildECDHKDFParam recipientPKP pka ecdhPub kdfHA kdfSA) let rfc6637Result :: Either CipherError B.ByteString rfc6637Result = do kek <-- first- CipherOperationFailed- (deriveECDHKek kdfHA kdfSA sharedSecret param)+ deriveECDHKek kdfHA kdfSA sharedSecret param aesKeyUnwrapRFC3394 kdfSA kek wrappedSessionKeyBytes case rfc6637Result of Right decoded -> pure decoded@@ -2656,40 +2668,35 @@ -> B.ByteString -> Either CipherError B.ByteString aesKeyUnwrapRFC3394 sa kek wrapped =- withAESCipher- (\err -> CipherInitFailed sa (show err))- (UnsupportedAlgorithm sa)- sa- kek- unwrapWithCipher+ withSymmetricCipher sa kek unwrapWithCipher where unwrapWithCipher- :: CCT.BlockCipher cipher+ :: HOBlockCipher cipher => cipher -> Either CipherError B.ByteString unwrapWithCipher cipher = do when (B.length wrapped < 24 || B.length wrapped `mod` 8 /= 0) $ Left- ( CipherOperationFailed+ ( CipherKeyWrapInvalidInput "ECDH wrapped session key must be at least 24 octets and a multiple of 8" ) let (a0, rBytes) = B.splitAt 8 wrapped rs = chunksOf8 rBytes when (length rs < 2) $ Left- ( CipherOperationFailed+ ( CipherKeyWrapInvalidInput "ECDH wrapped session key must contain at least two 64-bit blocks" ) (aFinal, rFinal) <- unwrapRounds cipher a0 rs when (aFinal /= B.replicate 8 0xA6) $ Left- ( CipherOperationFailed+ ( CipherKeyWrapInvalidInput "ECDH wrapped session key integrity check failed" ) Right (B.concat rFinal) unwrapRounds- :: CCT.BlockCipher cipher+ :: HOBlockCipher cipher => cipher -> B.ByteString -> [B.ByteString]@@ -2709,8 +2716,8 @@ let t = fromIntegral (n * j + i) :: Word64 aXorT = xorBS aCurrent (encodeWord64be t) rI = rsCurrent !! (i - 1)- block = CCT.ecbDecrypt cipher (aXorT <> rI)- (aNext, rNext) = B.splitAt 8 block+ block <- ecbDecrypt cipher (aXorT <> rI)+ let (aNext, rNext) = B.splitAt 8 block rsNext = (ix (i - 1) .~ rNext) rsCurrent goI (i - 1) aNext rsNext
Data/Conduit/OpenPGP/Keyring.hs view
@@ -28,12 +28,12 @@ , publicTKToKeyring , secretTKToKeyring , partitionSomeTKs+ , MixedKeyring ) where import Control.Error.Util (hush) import Control.Lens ((^.)) import Control.Monad (join)-import Data.Bifunctor (first) import Data.Conduit import qualified Data.Conduit.List as CL import Data.IxSet.Typed (empty, insert)@@ -122,18 +122,15 @@ notTrustPacket = not . isTrustPkt toTypedSomeTKEither- :: Either KeyringChunkParseError (Maybe TKUnknown)+ :: Either KeyringChunkParseError (Maybe SomeTK) -> Either TypedTKConduitError (Maybe SomeTK) toTypedSomeTKEither = either (Left . TypedTKParseError)- ( \maybeUnknown ->- case maybeUnknown of+ ( \maybeTk ->+ case maybeTk of Nothing -> Right Nothing- Just unknown ->- first- TypedTKConversionError- (Just <$> fromUnknownToTKEither unknown)+ Just tk -> Right (Just tk) ) data AuthSecretSubkeyUID@@ -497,9 +494,15 @@ secretTKToKeyring :: TK 'SecretTK -> SecretKeyring secretTKToKeyring tk = insert tk empty --- | Partition a list of SomeTK into homogeneous public and secret keyrings-partitionSomeTKs :: [SomeTK] -> (PublicKeyring, SecretKeyring)-partitionSomeTKs = foldr step (empty, empty)+-- | Partition a list of SomeTK into homogeneous public, secret, and mixed keyrings+partitionSomeTKs+ :: [SomeTK] -> (PublicKeyring, SecretKeyring, MixedKeyring)+partitionSomeTKs = foldr step (empty, empty, empty) where- step (SomePublicTK tk) (pub, sec) = (insert tk pub, sec)- step (SomeSecretTK tk) (pub, sec) = (pub, insert tk sec)+ step (SomePublicTK tk) (pub, sec, mix) = (insert tk pub, sec, mix)+ step (SomeSecretTK tk) (pub, sec, mix) = (pub, insert tk sec, mix)+ step (SomeMixedTK tk) (pub, sec, mix) =+ ( insert (someTKToPublicViewTK (SomeMixedTK tk)) pub+ , sec+ , insert tk mix+ )
Data/Conduit/OpenPGP/Keyring/Instances.hs view
@@ -3,16 +3,25 @@ -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} module Data.Conduit.OpenPGP.Keyring.Instances- (+ ( flattenTKPackets+ , flattenTKPacketsMixedTK+ , getEOKIsMixed+ , getFingerprintsMixed+ , getUIDsMixed ) where import Control.Arrow (second) import Control.Lens (folded, (^.), (^..), _1)+import Data.Containers.ListUtils (nubOrd) import Data.Data.Lens (biplate) import Data.Either (rights) import Data.IxSet.Typed (Indexable (..), ixFun, ixList)@@ -25,19 +34,22 @@ ) import Codec.Encryption.OpenPGP.Types -instance Indexable KeyringIxs TKUnknown where+instance Indexable KeyringIxs (TK 'MixedTK) where indices =- ixList (ixFun getEOKIs) (ixFun getFingerprints) (ixFun getUIDs)+ ixList+ (ixFun getEOKIsMixed)+ (ixFun getFingerprintsMixed)+ (ixFun getUIDsMixed) -getEOKIs :: TKUnknown -> [EightOctetKeyId]-getEOKIs tk =+getEOKIsMixed :: TK 'MixedTK -> [EightOctetKeyId]+getEOKIsMixed tk = rights (map eightOctetKeyID (tk ^.. biplate :: [SomePKPayload])) -getFingerprints :: TKUnknown -> [Fingerprint]-getFingerprints tk = map fingerprint (tk ^.. biplate :: [SomePKPayload])+getFingerprintsMixed :: TK 'MixedTK -> [Fingerprint]+getFingerprintsMixed tk = map fingerprint (tk ^.. biplate :: [SomePKPayload]) -getUIDs :: TKUnknown -> [Text]-getUIDs tk = (tk ^. tkuUIDs) ^.. folded . _1+getUIDsMixed :: TK 'MixedTK -> [Text]+getUIDsMixed tk = (tk ^. tkUIDs) ^.. folded . _1 instance Semigroup TKWithWireRep where (<>) a b =@@ -46,34 +58,32 @@ selectPacketRefsByValue (flattenTKPackets mergedTK) (dedupePacketRefsById (_tkPackets a ++ _tkPackets b))+ mergedRefs =+ case nubOrd+ (NE.toList (_tkWireRepRefs a) ++ NE.toList (_tkWireRepRefs b)) of+ [] -> _tkWireRepRefs a+ (x : xs) -> x NE.:| xs in TKWithWireRep- (mergeWireRepRefs (_tkWireRepRefs a) (_tkWireRepRefs b))+ mergedRefs (mergedWireRepRange mergedPackets) mergedPackets mergedTK -flattenTKPackets :: TKUnknown -> [Pkt]-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)- where- (pkp, mska) = _tkuKey tk- flattenUID (uid, sigs) = UserIdPkt uid : map SignaturePkt sigs- flattenUAT (uat, sigs) = UserAttributePkt uat : map SignaturePkt sigs- flattenSub (pkt, sigs) = pkt : map SignaturePkt sigs+flattenTKPackets :: TK 'MixedTK -> [Pkt]+flattenTKPackets = flattenTKPacketsMixedTK -mergeWireRepRefs :: WireRepRefs -> WireRepRefs -> WireRepRefs-mergeWireRepRefs left right =- case dedupe (NE.toList left ++ NE.toList right) of- [] -> left- (x : xs) -> x NE.:| xs+flattenTKPacketsMixedTK :: TK 'MixedTK -> [Pkt]+flattenTKPacketsMixedTK tk =+ [someKeyPktToPkt (_tkPrimaryKey tk)]+ ++ map SignaturePkt (_tkRevs tk)+ ++ map SignaturePkt (_tkDirectKeySigs tk)+ ++ concatMap flattenUID (_tkUIDs tk)+ ++ concatMap flattenUAt (_tkUAts tk)+ ++ concatMap flattenSubMixed (_tkSubs tk) where- dedupe [] = []- dedupe (x : xs) = x : dedupe (filter (/= x) xs)+ flattenUID (uid, sigs) = UserIdPkt uid : map SignaturePkt sigs+ flattenUAt (uat, sigs) = UserAttributePkt uat : map SignaturePkt sigs+ flattenSubMixed (kp, sigs) = someKeyPktToPkt kp : map SignaturePkt sigs mergedWireRepRange :: [PktWithWireRep] -> Maybe ByteRange mergedWireRepRange [] = Nothing@@ -119,10 +129,23 @@ | otherwise = second (pkt :) <$> go seen rest -- | Extract all SomePKPayloads from a TK (primary + subkeys) without biplate-tkPKPayloads :: TK k -> [SomePKPayload]-tkPKPayloads tk =- keyPktPKPayload (_tkPrimaryKey tk)- : map (keyPktPKPayload . fst) (_tkSubs tk)+class TKPKPayloads (k :: TKKind) where+ tkPKPayloads :: TK k -> [SomePKPayload]++instance TKPKPayloads 'PublicTK where+ tkPKPayloads tk =+ keyPktPKPayload (_tkPrimaryKey tk)+ : map (keyPktPKPayload . fst) (_tkSubs tk)++instance TKPKPayloads 'SecretTK where+ tkPKPayloads tk =+ keyPktPKPayload (_tkPrimaryKey tk)+ : map (keyPktPKPayload . fst) (_tkSubs tk)++instance TKPKPayloads 'MixedTK where+ tkPKPayloads tk =+ someKeyPktPKPayload (_tkPrimaryKey tk)+ : map (someKeyPktPKPayload . fst) (_tkSubs tk) -- | Index public TKs by key ID, fingerprint, and UID instance Indexable KeyringIxs (TK 'PublicTK) where
hOpenPGP.cabal view
@@ -1,6 +1,6 @@ Cabal-version: 3.4 Name: hOpenPGP-Version: 3.6.10+Version: 3.7 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@@ -174,6 +174,7 @@ , tests/data/v6.txt , tests/data/v6.txt.sig , tests/data/seipdv1-two-recipients.pgp.aa+ , tests/data/seipdv1-one-recipient.pgp.aa flag use-memory description: Use the 'memory' package instead of 'ram'@@ -250,8 +251,7 @@ common internalmods other-modules: Codec.Encryption.OpenPGP.Internal- , Codec.Encryption.OpenPGP.Internal.CryptoAES- , Codec.Encryption.OpenPGP.Internal.CryptoCipherTypes+ , Codec.Encryption.OpenPGP.Internal.CryptoCipherTypes , Codec.Encryption.OpenPGP.Internal.CryptoECDH , Codec.Encryption.OpenPGP.Internal.Crypton , Codec.Encryption.OpenPGP.Internal.HOBlockCipher@@ -347,4 +347,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hOpenPGP.git- tag: v3.6.10+ tag: v3.7
tests/Tests/Common.hs view
@@ -101,6 +101,7 @@ , ArmorType (..) ) import Control.Error.Util (hush)+import Control.Lens ((^.), _1) import Control.Monad (join, unless, void) import Control.Monad.Trans.Resource (ResourceT) import qualified Crypto.Error as CE@@ -206,6 +207,9 @@ , signUserId ) import Codec.Encryption.OpenPGP.Types+import Codec.Encryption.OpenPGP.Types.Internal.Errors+ ( renderCipherError+ ) import Data.Conduit.OpenPGP.Compression (conduitDecompress) import Data.Conduit.OpenPGP.Decrypt ( DecryptKeyResolution (..)@@ -568,7 +572,7 @@ -> B.ByteString buildECDHKDFParamForTest recipientPKP pka curve kdfHA kdfSA = either- error+ (error . renderCipherError) id (buildECDHKDFParam recipientPKP pka pkey kdfHA kdfSA) where@@ -583,7 +587,7 @@ -> B.ByteString buildCurve25519LegacyKdfParamForTest recipientPKP pka kdfHA kdfSA = either- error+ (error . renderCipherError) id (buildECDHKDFParam recipientPKP pka dummyKey kdfHA kdfSA) where@@ -597,7 +601,10 @@ -> B.ByteString -> B.ByteString deriveECDHKekForTest kdfHA kdfSA sharedSecret kdfParam =- either error id (deriveECDHKek kdfHA kdfSA sharedSecret kdfParam)+ either+ (error . renderCipherError)+ id+ (deriveECDHKek kdfHA kdfSA sharedSecret kdfParam) aesKeyWrapRFC3394ForTest :: SymmetricAlgorithm@@ -738,7 +745,7 @@ mkTestKeyring :: [TK 'PublicTK] -> PublicKeyring mkTestKeyring tks = let someTKs = [SomePublicTK tk | tk <- tks]- in fst (partitionSomeTKs someTKs)+ in partitionSomeTKs someTKs ^. _1 addTimestampSeconds :: ThirtyTwoBitTimeStamp -> Word32 -> ThirtyTwoBitTimeStamp
tests/Tests/Encryption.hs view
@@ -28,7 +28,6 @@ import Data.Binary (get, put) import Data.Binary.Get ( Get- , runGetOrFail ) import Data.Binary.Put (putWord16be, runPut) import qualified Data.ByteArray as BA@@ -89,7 +88,6 @@ , deriveX25519Kek , deriveX448Kek , encryptForRecipients- , encryptForRecipientsLegacy , encryptForRecipientsWithCapabilityNegotiation , encryptPassphraseWithPolicy , encryptSEIPDv2Payload@@ -144,15 +142,10 @@ ) import Codec.Encryption.OpenPGP.Serialize (parsePkts) import Codec.Encryption.OpenPGP.Types-import Codec.Encryption.OpenPGP.Types.Internal.Errors- ( PacketCoercionError (..)- ) import Data.Conduit.OpenPGP.Compression (conduitCompress) import Data.Conduit.OpenPGP.Decrypt ( DecryptKeyResolution (..) , DecryptOptions (..)- , DecryptOutcome (..)- , DecryptStructureError (..) , PKESKRecipientKey (..) ) import qualified Data.Conduit.OpenPGP.Decrypt as DCD@@ -765,9 +758,6 @@ "encryptForRecipients negotiates recipient capabilities by default" testEncryptRecipientsNegotiatesSymmetricAlgorithmByDefault , testCase- "encryptForRecipientsLegacy preserves capability negotiation opt-out"- testEncryptRecipientsLegacyKeepsCapabilityNegotiationOptOut- , testCase "encryptForRecipients capability negotiation fails when recipients share no symmetric algorithm" testEncryptRecipientsNegotiationFailsWithoutCommonSymmetricAlgorithm , testCase@@ -3284,66 +3274,6 @@ AES128 (pkeskSessionAlgorithm material) -testEncryptRecipientsLegacyKeepsCapabilityNegotiationOptOut- :: Assertion-testEncryptRecipientsLegacyKeepsCapabilityNegotiationOptOut = do- (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner- let v4Recipient = setKeyVersion V4 baseRecipient- v6Recipient = setKeyVersion V6 baseRecipient- v6Caps =- RecipientCapabilities- { recipientCapabilityKeyVersion = V6- , recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient- , recipientCapabilityKeyFlags = Set.empty- , recipientCapabilityFeatures = Set.empty- , recipientCapabilityPreferredSymmetricAlgorithms = []- , recipientCapabilityPreferredCiphersuites =- [(AES128, OCB), (AES256, OCB)]- }- v4Caps =- RecipientCapabilities- { recipientCapabilityKeyVersion = V4- , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient- , recipientCapabilityKeyFlags = Set.empty- , recipientCapabilityFeatures = Set.empty- , recipientCapabilityPreferredSymmetricAlgorithms = []- , recipientCapabilityPreferredCiphersuites = [(AES128, OCB)]- }- request =- RecipientEncryptRequest- { recipientEncryptRequestTargets =- [ recipientEncryptionTargetWithCapabilities v6Recipient v6Caps- , recipientEncryptionTargetWithCapabilities v4Recipient v4Caps- ]- , recipientEncryptRequestPayloadShape =- defaultRecipientPayloadShape- , recipientEncryptRequestPayload =- "legacy recipient capability opt-out payload"- , recipientEncryptRequestSymmetricOverride = Nothing- , recipientEncryptRequestOverrides =- RecipientEncryptRequestSEIPDv2Overrides- { recipientEncryptRequestAEADOverride = Just OCB- , recipientEncryptRequestChunkSizeOverride = Just 6- , recipientEncryptRequestSaltOverride =- Just (Salt (B.replicate 32 0x25))- }- }- result <- encryptForRecipientsLegacy request- case result of- Left err ->- assertFailure- ( "Expected legacy encryptForRecipients opt-out to succeed, got "- ++ show err- )- Right- RecipientEncryptResult- { recipientEncryptSessionMaterial = material- } ->- assertEqual- "encryptForRecipientsLegacy should preserve policy-default symmetric selection"- AES256- (pkeskSessionAlgorithm material)- testEncryptRecipientsNegotiationFailsWithoutCommonSymmetricAlgorithm :: Assertion testEncryptRecipientsNegotiationFailsWithoutCommonSymmetricAlgorithm = do@@ -3807,13 +3737,13 @@ (_timestamp (keyPktPKPayload (_tkPrimaryKey tk))) tk assertEqual- "TKUnknown-derived targets should include only encryption-capable keys"+ "TK-derived targets should include only encryption-capable keys" 1 (length targets) case targets of [target] -> assertEqual- "TKUnknown-derived target should preserve selected encryption key"+ "TK-derived target should preserve selected encryption key" (fingerprint encryptingSubkey) (fingerprint (recipientEncryptionTargetKey target)) _ ->@@ -3840,12 +3770,12 @@ tk of Right target -> assertEqual- "TKUnknown-derived single target should prioritize encryption subkeys"+ "TK-derived single target should prioritize encryption subkeys" (fingerprint subkey) (fingerprint (recipientEncryptionTargetKey target)) Left err -> assertFailure- ( "Expected TKUnknown-derived target selection to succeed, got "+ ( "Expected TK-derived target selection to succeed, got " ++ show err ) @@ -3874,7 +3804,7 @@ ) Right _ -> assertFailure- "Expected TKUnknown-derived target selection to reject non-encryptable TKs"+ "Expected TK-derived target selection to reject non-encryptable TKs" testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsRejections :: Assertion@@ -4077,7 +4007,7 @@ case recipientEncryptionTargetCapabilities target of Nothing -> assertFailure- "Expected TKUnknown-derived target to include extracted capabilities"+ "Expected TK-derived target to include extracted capabilities" Just caps -> do assertEqual "self-signature capability extraction should include primary-key ciphersuite preferences"@@ -4088,7 +4018,7 @@ (Set.fromList [EncryptCommunicationsKey]) (recipientCapabilityKeyFlags caps) [] ->- assertFailure "Expected at least one TKUnknown-derived target"+ assertFailure "Expected at least one TK-derived target" testRecipientEncryptionTargetsFromTKAtTimestampExtractsTypedAEADPreferences :: Assertion@@ -4130,14 +4060,14 @@ case recipientEncryptionTargetCapabilities target of Nothing -> assertFailure- "Expected TKUnknown-derived target to include extracted capabilities"+ "Expected TK-derived target to include extracted capabilities" Just caps -> do assertEqual "typed self-signature AEAD preference extraction should include primary-key ciphersuite preferences" [(AES128, OCB), (AES256, GCM)] (recipientCapabilityPreferredCiphersuites caps) [] ->- assertFailure "Expected at least one TKUnknown-derived target"+ assertFailure "Expected at least one TK-derived target" testRecipientEncryptionTargetFromTKAtTimestampAppliesTimestampFiltering :: Assertion@@ -4171,14 +4101,14 @@ tk of Left err -> assertFailure- ( "Expected timestamp-scoped TKUnknown target selection to succeed, got "+ ( "Expected timestamp-scoped TK target selection to succeed, got " ++ show err ) Right target -> case recipientEncryptionTargetCapabilities target of Nothing -> assertFailure- "Expected TKUnknown-derived target to include capabilities when timestamp-scoped"+ "Expected TK-derived target to include capabilities when timestamp-scoped" Just caps -> assertEqual "subkey binding created after target timestamp should not contribute key flags"@@ -4567,13 +4497,9 @@ result <- buildPKESKPayloadForRecipient PreferV6 recipient sessionMaterial case result of- Left (RecipientKdfFailure ECDH err)- | "SHA1 is disallowed by policy" `isInfixOf` err -> pure ()- | otherwise ->- assertFailure- ( "Expected SHA1 policy rejection in RecipientKdfFailure, got: "- ++ err- )+ Left+ (RecipientKdfFailure ECDH (CipherKdfHashAlgorithmDisallowed SHA1)) ->+ pure () Left err -> assertFailure ("Expected RecipientKdfFailure ECDH for SHA1, got " ++ show err)
tests/Tests/KeyGeneration.hs view
@@ -13,6 +13,7 @@ import Control.Monad.Trans.Except (runExceptT) import Data.Binary.Get (runGetOrFail) import Data.Binary.Put (runPut)+import qualified Data.ByteString.Lazy as BL import Data.Maybe (mapMaybe) import qualified Data.Set as Set import Test.Tasty (TestTree, testGroup)@@ -37,6 +38,7 @@ , setExpiration , setHashPreferences , setKeyServerPreferences+ , setKeySize , setSEIPDv1SymmetricPreferences ) import Codec.Encryption.OpenPGP.Policy@@ -51,7 +53,9 @@ , signatureHashedSubpacketsKnown ) import Codec.Encryption.OpenPGP.Signatures- ( verifyAgainstKeys+ ( signDataWithRSA+ , verifyAgainstKeys+ , verifyAgainstKeysWithPolicy , verifySigWith , verifyTKWith )@@ -97,6 +101,9 @@ , testCase "Subkey binding signature verifies" testSubkeyBindingSigVerifies+ , testCase+ "Mixed-size RSA subkey verification"+ testMixedSizeRSASubkeyVerify ] ] @@ -407,6 +414,43 @@ assertFailure ("subkey binding self-verification failed: " ++ show err) Right _ -> pure ()++testMixedSizeRSASubkeyVerify :: Assertion+testMixedSizeRSASubkeyVerify = do+ result <-+ runTKGen (V6, ThirtyTwoBitTimeStamp 0) $ do+ setKeySize RSA 1024+ _ <- newKey RSA+ addUID "Test User <test@example.com>"+ setKeySize RSA 2048+ _ <- addSubkey RSA [SignDataKey]+ pure ()+ case result of+ Left err -> assertFailure ("runTKGen failed: " ++ show err)+ Right (_a, tk) -> do+ let ((subKp, _) : _) = tk ^. tkSubs+ subSK = secretKeyPktSKAddendum subKp+ payload =+ BL.pack+ (map (fromIntegral . fromEnum) ("test payload" :: String))+ subPriv = case subSK of+ SUSUnprotected (RSAPrivateKey priv) _ -> unRSA_PrivateKey priv+ _ -> error "expected unprotected RSA private key"+ sig <-+ either (assertFailure . ("signing failed: " ++) . show) pure $+ signDataWithRSA SHA256 GenericCert subPriv [] [] payload+ case verifyAgainstKeysWithPolicy+ defaultVerificationPolicy+ [publicViewTK tk]+ (SignaturePkt sig)+ Nothing+ payload of+ Left err ->+ assertFailure+ ( "mixed-size RSA subkey verification failed: "+ ++ show err+ )+ Right _ -> pure () isKeyServerPrefs :: SigSubPacket -> Bool isKeyServerPrefs (SigSubPacket _ KeyServerPreferences {}) = True
tests/Tests/MessageAndArmor.hs view
@@ -46,7 +46,8 @@ import Codec.Encryption.OpenPGP.BlockCipher (keySize) import Codec.Encryption.OpenPGP.CFB- ( decryptPreservingNonce+ ( OpenPGPCFBModeW (..)+ , decryptPreservingNonce ) import Codec.Encryption.OpenPGP.Compression (decompressPkt) import Codec.Encryption.OpenPGP.Encrypt@@ -226,6 +227,9 @@ , testCase "decryptMessage rejects SEIPDv1 MDC tampering" testDecryptMessageSEIPDv1MDCTampering+ , testCase+ "decryptMessage rejects unexpected packet in decrypted SEIPDv1 payload"+ testDecryptMessageRejectsUnexpectedPacketInDecryptedPayload , testCase "sign message shape" testSignMessageShape , testCase "sign message shape (RSA SigV6)" testSignMessageRSAV6 , testCase "sign message shape (Ed25519)" testSignMessageEd25519@@ -3806,3 +3810,29 @@ ( fixture ++ " should parse as [PublicKeyPkt, SignaturePkt SigV6 KeyRevocationSig]" )++testDecryptMessageRejectsUnexpectedPacketInDecryptedPayload+ :: Assertion+testDecryptMessageRejectsUnexpectedPacketInDecryptedPayload = do+ let pkts =+ [ LiteralDataPkt BinaryData (FileName "test.txt") 0 "hello"+ , PKESKPkt+ ( PKESKPayloadV3Packet+ ( PKESKPayloadV3+ 3+ (EightOctetKeyId (B.replicate 8 0xAB))+ RSA+ (MPI 0 NE.:| [])+ )+ )+ ]+ case extractLiteralPayload pkts of+ Left (UnexpectedPacketInDecryptedPayload _) -> pure ()+ Left err ->+ assertFailure+ ( "Expected UnexpectedPacketInDecryptedPayload, got: "+ ++ show err+ )+ Right _ ->+ assertFailure+ "Expected extractLiteralPayload to reject PKESK in decrypted payload"
tests/Tests/Properties.hs view
@@ -10,6 +10,7 @@ import Control.Exception (SomeException, try) import Control.Lens (preview)+import Control.Monad.Trans.Except (runExceptT) import Crypto.Error (eitherCryptoError) import Crypto.Number.Serialize (os2ip) import qualified Crypto.PubKey.Curve25519 as C25519@@ -27,11 +28,11 @@ import qualified Test.Tasty.QuickCheck as QC import Codec.Encryption.OpenPGP.Encrypt- ( PKAEncryptOpsDict (..)- , SomePKAEncryptOpsDict (..)+ ( PubKeyEncryptOps (..)+ , SomePubKeyEncryptOps (..) , encryptSEIPDv2Payload- , pkaEncryptOpsDict , pkeskV3SessionMaterial+ , pubKeyEncryptOps ) import Codec.Encryption.OpenPGP.KeyringParser ( parseTKsWithWireRep@@ -252,8 +253,8 @@ reverseDirect reverseUIDs reverseUIDSigs- reverseUATs- reverseUATSigs+ reverseUAts+ reverseUAtSigs reverseSubs reverseSubSigs = QC.ioProperty $ do@@ -300,12 +301,12 @@ ) , _tkStructuredUAts = reverseIf- reverseUATs+ reverseUAts ( map ( \uat -> uat { _uatWithWireRefsSignatures =- reverseIf reverseUATSigs (_uatWithWireRefsSignatures uat)+ reverseIf reverseUAtSigs (_uatWithWireRefsSignatures uat) } ) (_tkStructuredUAts structured)@@ -501,20 +502,23 @@ ) ) sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey- case pkaEncryptOpsDict pka of+ case pubKeyEncryptOps pka of Nothing -> pure ( QC.counterexample- ("pkaEncryptOpsDict has no entry for " ++ label)+ ("pubKeyEncryptOps has no entry for " ++ label) False )- Just (SomePKAEncryptOpsDict dict) -> do+ Just (SomePubKeyEncryptOps dict) -> do v3Result <-- pkaDictBuildV3- dict- recipient- (pkeskV3SessionMaterial sessionMaterial)- v6Result <- pkaDictBuildV6 dict recipient sessionMaterial+ runExceptT+ ( pubKeyBuildV3PKESK+ dict+ recipient+ (pkeskV3SessionMaterial sessionMaterial)+ )+ v6Result <-+ runExceptT (pubKeyBuildV6PKESK dict recipient sessionMaterial) ciphertext <- case encryptSEIPDv2Payload AES256@@ -533,13 +537,13 @@ (Left err, _, _) -> pure ( QC.counterexample- ("pkaDictBuildV3 failed: " ++ show err)+ ("pubKeyBuildV3PKESK failed: " ++ show err) False ) (_, Left err, _) -> pure ( QC.counterexample- ("pkaDictBuildV6 failed: " ++ show err)+ ("pubKeyBuildV6PKESK failed: " ++ show err) False ) (_, _, Left err) ->
tests/Tests/Serialization.hs view
@@ -7,7 +7,7 @@ module Tests.Serialization (serializationTests) where import Control.Applicative ((<|>))-import Control.Lens ((^.))+import Control.Lens ((^.), _1) import Control.Monad (forM_) import qualified Crypto.Error as CE import Crypto.Number.Serialize (i2osp, os2ip)@@ -365,12 +365,12 @@ (testSerialization "seipdv1-two-recipients.pgp.aa") ] , testGroup- "TKUnknown Serialization group"+ "TK Serialization group" [ testCase- "pubring.gpg TKUnknown serialization"+ "pubring.gpg TK serialization" (testTKSerialization "pubring.gpg") , testCase- "secring.gpg TKUnknown serialization"+ "secring.gpg TK serialization" (testTKSerialization "secring.gpg") ] , testGroup@@ -476,7 +476,7 @@ if null tksWithWireRep then assertFailure $- "TKUnknown serialization test: " ++ fpr ++ " parsed to no TKs"+ "TK serialization test: " ++ fpr ++ " parsed to no TKs" else forM_ tksWithWireRep (testTKRoundtrip fpr) testTKRoundtrip :: FilePath -> TKWithWireRep -> Assertion@@ -488,16 +488,16 @@ case runGetTest (get :: Get (Block Pkt)) encoded of Left err -> assertFailure $- "TKUnknown " ++ fpr ++ " packet re-parse failed: " ++ err+ "TK " ++ fpr ++ " packet re-parse failed: " ++ err Right reparsedBlock -> assertEqual- ("TKUnknown packet re-serialization roundtrip for " ++ fpr)+ ("TK packet re-serialization roundtrip for " ++ fpr) (Block (map (\p -> p ^. pktWireRep . pktValue) packets)) reparsedBlock case toStructuredTKWithWireRep tk of Left err -> assertFailure $- "TKUnknown structured conversion failed for "+ "TK structured conversion failed for " ++ fpr ++ ": " ++ show err@@ -505,7 +505,7 @@ case canonicalizeTKStructuredWithWireRep structured of Left err -> assertFailure $- "TKUnknown canonical conversion failed for "+ "TK canonical conversion failed for " ++ fpr ++ ": " ++ show err@@ -1190,7 +1190,8 @@ assertBool "v6-secret.pgp.aa should include at least one IssuerFingerprint v6 matching the primary key" ( any- ( \(sig, _, _) -> signatureHasIssuerFingerprintV6 (fingerprint pkp) sig+ ( signatureHasIssuerFingerprintV6 (fingerprint pkp)+ . (^. _1) ) signatures )
tests/Tests/Utilities.hs view
@@ -2,16 +2,18 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).+{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} module Tests.Utilities (utilityTests) where import Control.Error.Util (hush)-import Control.Lens (view, (^.))+import Control.Lens (view, (&), (.~), (^.)) import Control.Monad (join) import Crypto.Number.Serialize (os2ip)-import Data.Binary (get)+import Data.Binary (get, put) import Data.Binary.Get (Get)+import Data.Binary.Put (runPut) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Conduit as DC@@ -35,7 +37,9 @@ import Codec.Encryption.OpenPGP.Fingerprint (fingerprint) import Codec.Encryption.OpenPGP.KeyInfo (pkalgoAbbrev) import Codec.Encryption.OpenPGP.KeyringParser- ( parsePublicTKs+ ( parseMixedTKs+ , parseMixedTKsWithWireRep+ , parsePublicTKs , parseSecretTKs , parseTKs , parseTKsEither@@ -50,6 +54,7 @@ , parsePkts , parsePktsEither , parsePktsWithWireRep+ , putMixedTK , wireRepRefFromInput ) import Codec.Encryption.OpenPGP.Types@@ -70,6 +75,9 @@ , conduitToSomeTKsEither , conduitToTKsWithWireRepEither )+import Data.Conduit.OpenPGP.Keyring.Instances+ ( flattenTKPacketsMixedTK+ ) import Tests.Common ( addTimestampSeconds , loadAndDecompressPkts@@ -113,7 +121,7 @@ "pubring parseTKsEither preserves typed parse outcomes" (testParseTKsEitherUtil "pubring.gpg") , testCase- "typed TKUnknown conduit partitioning"+ "typed TK 'MixedTK' conduit partitioning" (testConduitToTKsTypedUtil "pubring.gpg") , testCase "typed TK conduit either reports values without silent drops on valid input"@@ -161,7 +169,7 @@ "wireRepRefFromInput surfaces malformed armored decode errors" testWireRepRefRejectsMalformedArmoredInput , testCase- "tksFromWireRep matches any source in TKUnknown provenance list"+ "tksFromWireRep matches any source in TK 'MixedTK' provenance list" testTksFromWireRepMatchesAnySource , testCase "TKWithWireRep Semigroup preserves structured provenance"@@ -179,6 +187,18 @@ "TK public/secret conversion and projection round-trip" testTKTypedRoundTripAndPublicView , testCase+ "MixedTK constructor and fields"+ testMixedTKRoundTrip+ , testCase+ "parseMixedTKsWithWireRep extracts mixed TKs from synthetic packets"+ testParseMixedTks+ , testCase+ "putMixedTK round-trips through Binary get"+ testMixedTKSerialization+ , testCase+ "flattenTKPacketsMixedTK reconstructs mixed TK packet sequence"+ testFlattenTKPacketsMixedTK+ , testCase "uat.gpg embeds expected image data from uat.jpg" testUatImageFixture ]@@ -273,24 +293,24 @@ DC..| conduitToSomeTKsEither DC..| conduitDropErrorsAndNothings DC..| CL.consume- let pt = map someTKToUnknown (parseTKs True (parsePkts lbs))+ let pt = map asMixedTK (parseTKs True (parsePkts lbs)) assertEqual "parsePkts utility function gives same results as conduit pipeline"- (map someTKToUnknown cp)+ (map asMixedTK cp) pt testParseTKsTypedUtil :: FilePath -> Assertion testParseTKsTypedUtil fn = do lbs <- readFixtureLazy fn let packets = parsePkts lbs- plain = map someTKToUnknown (parseTKs True packets)+ plain = map asMixedTK (parseTKs True packets) typed = parseTKs True packets typedPublic = parsePublicTKs True packets typedSecret = parseSecretTKs True packets assertEqual- "parseTKs round-trips to the same untyped TKUnknown semantics"+ "parseTKs round-trips to the same untyped TK 'MixedTK' semantics" plain- (map someTKToUnknown typed)+ (map asMixedTK typed) assertEqual "public + secret typed partitions preserve full typed parse count" (length typed)@@ -341,8 +361,8 @@ DC..| CL.consume assertEqual "typed conduit round-trips to parseTKs semantics"- (map someTKToUnknown (parseTKs True (parsePkts lbs)))- (map someTKToUnknown allTyped)+ (map asMixedTK (parseTKs True (parsePkts lbs)))+ (map asMixedTK allTyped) assertEqual "typed conduit public + secret partitions preserve full count" (length allTyped)@@ -436,36 +456,28 @@ (addTimestampSeconds baseTime 22) let tk =- TKUnknown- (signer, Just secretAddendum)- []- []- [(uidText, [uidCertification])]- []- [- ( SecretSubkeyPkt authSubkey secretAddendum- , [authBinding, authRevocation]- )- ,- ( SecretSubkeyPkt expiringAuthSubkey secretAddendum- , [expiringAuthBinding]- )- ,- ( SecretSubkeyPkt signingOnlySubkey secretAddendum- , [signingOnlyBinding]- )- ]- typedSecret <-- case fromUnknownToTK tk of- Right (SomeSecretTK typed) -> pure typed- Right (SomePublicTK _) ->- assertFailure- "expected secret typed TKUnknown for auth subkey test fixture"- >> fail "unreachable"- Left err ->- assertFailure- ("fromUnknownToTK failed for auth subkey test fixture: " ++ err)- >> fail "unreachable"+ TK+ { _tkPrimaryKey = KeyPktSecretPrimary signer secretAddendum+ , _tkRevs = []+ , _tkDirectKeySigs = []+ , _tkUIDs = [(uidText, [uidCertification])]+ , _tkUAts = []+ , _tkSubs =+ [+ ( KeyPktSecretSubkey authSubkey secretAddendum+ , [authBinding, authRevocation]+ )+ ,+ ( KeyPktSecretSubkey expiringAuthSubkey secretAddendum+ , [expiringAuthBinding]+ )+ ,+ ( KeyPktSecretSubkey signingOnlySubkey secretAddendum+ , [signingOnlyBinding]+ )+ ]+ }+ let typedSecret = tk selectedBefore <- DC.runConduitRes $@@ -552,24 +564,16 @@ [SigSubPacket False (KeyFlags (Set.fromList [AuthKey]))] let tk =- TKUnknown- (signer, Just secretAddendum)- []- []- [(uidAText, [uidACert]), (uidBText, [uidBCert])]- []- [(SecretSubkeyPkt authSubkey secretAddendum, [authBinding])]- typedSecret <-- case fromUnknownToTK tk of- Right (SomeSecretTK typed) -> pure typed- Right (SomePublicTK _) ->- assertFailure- "expected secret typed TKUnknown for primary-uid test fixture"- >> fail "unreachable"- Left err ->- assertFailure- ("fromUnknownToTK failed for primary-uid test fixture: " ++ err)- >> fail "unreachable"+ TK+ { _tkPrimaryKey = KeyPktSecretPrimary signer secretAddendum+ , _tkRevs = []+ , _tkDirectKeySigs = []+ , _tkUIDs = [(uidAText, [uidACert]), (uidBText, [uidBCert])]+ , _tkUAts = []+ , _tkSubs =+ [(KeyPktSecretSubkey authSubkey secretAddendum, [authBinding])]+ }+ let typedSecret = tk beforeSelections <- DC.runConduitRes $@@ -677,38 +681,28 @@ (addTimestampSeconds baseTime 22) let tk =- TKUnknown- (signer, Just secretAddendum)- []- []- [(uidText, [uidCertification])]- []- [- ( SecretSubkeyPkt authSubkey secretAddendum- , [authBinding, authRevocation]- )- ,- ( SecretSubkeyPkt expiringAuthSubkey secretAddendum- , [expiringAuthBinding]- )- ,- ( SecretSubkeyPkt signingOnlySubkey secretAddendum- , [signingOnlyBinding]- )- ]- typedSecret <-- case fromUnknownToTK tk of- Right (SomeSecretTK typed) -> pure typed- Right (SomePublicTK _) ->- assertFailure- "expected secret typed TKUnknown for auth subkey rejection test fixture"- >> fail "unreachable"- Left err ->- assertFailure- ( "fromUnknownToTK failed for auth subkey rejection test fixture: "- ++ err- )- >> fail "unreachable"+ TK+ { _tkPrimaryKey = KeyPktSecretPrimary signer secretAddendum+ , _tkRevs = []+ , _tkDirectKeySigs = []+ , _tkUIDs = [(uidText, [uidCertification])]+ , _tkUAts = []+ , _tkSubs =+ [+ ( KeyPktSecretSubkey authSubkey secretAddendum+ , [authBinding, authRevocation]+ )+ ,+ ( KeyPktSecretSubkey expiringAuthSubkey secretAddendum+ , [expiringAuthBinding]+ )+ ,+ ( KeyPktSecretSubkey signingOnlySubkey secretAddendum+ , [signingOnlyBinding]+ )+ ]+ }+ let typedSecret = tk let beforeReport = authSecretSubkeysAtReport beforeTime typedSecret assertEqual@@ -852,7 +846,7 @@ parsed = parseTKsWithWireRep True packets plain = map- someTKToUnknown+ asMixedTK ( parseTKs True (map (\p -> view (pktWireRep . pktValue) p) packets)@@ -865,11 +859,11 @@ DC..| CL.catMaybes DC..| CL.consume assertEqual- "provenance-aware parseTKs preserves TKUnknown semantics"+ "provenance-aware parseTKs preserves TK 'MixedTK' semantics" plain (map _tkValue parsed) assertEqual- "conduit and pure provenance-aware TKUnknown parsing agree"+ "conduit and pure provenance-aware TK 'MixedTK' parsing agree" parsed conduitParsed assertEqual@@ -899,24 +893,24 @@ :: WireRepRef -> [TKWithWireRep] -> TKWithWireRep -> Assertion assertTKProvenance src allTks tk = do assertBool- "TKUnknown source reference list includes originating source"+ "TK 'MixedTK' source reference list includes originating source" (src `elem` _tkWireRepRefs tk) assertEqual- "TKUnknown source reference is preserved"+ "TK 'MixedTK' source reference is preserved" src (wireRepOfTK tk) assertEqual- "TKUnknown packet references reconstruct the semantic TKUnknown packet sequence"+ "TK 'MixedTK' packet references reconstruct the semantic TK 'MixedTK' packet sequence" (flattenTK (_tkValue tk)) (map (\p -> view (pktWireRep . pktValue) p) (packetRefsOfTK tk)) assertEqual- "TKUnknown source span matches the span of its packet references"+ "TK 'MixedTK' source span matches the span of its packet references" (spanByteRanges (map _pktRange (packetRefsOfTK tk))) (_tkWireRepRange tk) mapM_ ( \pkt -> assertBool- "packet backlink resolves to containing TKUnknown"+ "packet backlink resolves to containing TK 'MixedTK'" (tk `elem` tksContainingPacket pkt allTks) ) (packetRefsOfTK tk)@@ -926,7 +920,9 @@ Right structured -> do assertEqual "structured provenance retains semantic primary key"- (_tkuKey (_tkValue tk))+ ( someKeyPktPKPayload (_tkPrimaryKey (_tkValue tk))+ , someKeyPktMaybeSKAddendum (_tkPrimaryKey (_tkValue tk))+ ) (_tkStructuredPrimaryKey structured) assertEqual "structured provenance retains packet source reference list"@@ -934,7 +930,7 @@ (_tkStructuredWireRepRefs structured) resolved <- resolveStructuredPacketRefs structured assertEqual- "structured provenance resolves packet refs in TKUnknown packet order"+ "structured provenance resolves packet refs in TK 'MixedTK' packet order" (map (\p -> view (pktWireRep . pktValue) p) (packetRefsOfTK tk)) (map (\p -> view (pktWireRep . pktValue) p) resolved) assertEqual@@ -1072,10 +1068,10 @@ wrapped [] -> assertFailure- "pubring.gpg should parse to at least one provenance-aware TKUnknown"+ "pubring.gpg should parse to at least one provenance-aware TK 'MixedTK'" where manualCanonicalizeStructured- :: TKStructuredWithWireRep -> Either String TKUnknown+ :: TKStructuredWithWireRep -> Either String (TK 'MixedTK) manualCanonicalizeStructured structured = do revs <- sortSigs (_tkStructuredRevs structured) directKeySigs <- sortSigs (_tkStructuredDirectKeySigs structured)@@ -1104,28 +1100,35 @@ ) (_tkStructuredSubkeys structured) Right $- TKUnknown- { _tkuKey = _tkStructuredPrimaryKey structured- , _tkuRevs = map _signatureWithWireRefValue revs- , _tkuDirectKeySigs = map _signatureWithWireRefValue directKeySigs- , _tkuUIDs =+ TK+ { _tkPrimaryKey =+ mkPrimaryKeyPkt+ (fst (_tkStructuredPrimaryKey structured))+ (snd (_tkStructuredPrimaryKey structured))+ , _tkRevs = map _signatureWithWireRefValue revs+ , _tkDirectKeySigs = map _signatureWithWireRefValue directKeySigs+ , _tkUIDs = map ( \(uid, sigs) -> (_uidWithWireRefsValue uid, map _signatureWithWireRefValue sigs) ) uids- , _tkuUAts =+ , _tkUAts = map ( \(uat, sigs) -> (_uatWithWireRefsValue uat, map _signatureWithWireRefValue sigs) ) uats- , _tkuSubs =+ , _tkSubs = map ( \(sub, sigs) ->- ( _subkeyWithWireRefsValue sub- , map _signatureWithWireRefValue sigs- )+ case pktToSomeKeyPkt (_subkeyWithWireRefsValue sub) of+ Just kp -> (kp, map _signatureWithWireRefValue sigs)+ Nothing ->+ error+ ( "expected key packet in structured subkey, got "+ ++ show (pktTag (_subkeyWithWireRefsValue sub))+ ) ) subs }@@ -1194,11 +1197,11 @@ } [] -> case _tkStructuredUAts structured of- (uat : restUATs) ->+ (uat : restUAts) -> Just structured { _tkStructuredUAts =- uat {_uatWithWireRefsRef = badRef} : restUATs+ uat {_uatWithWireRefsRef = badRef} : restUAts } [] -> case _tkStructuredSubkeys structured of@@ -1212,7 +1215,7 @@ case brokenWithBadRef of Nothing -> assertFailure- "pubring.gpg first TKUnknown unexpectedly has no direct signatures, UIDs, UATs, or subkeys"+ "pubring.gpg first TK 'MixedTK' unexpectedly has no direct signatures, UIDs, UAts, or subkeys" Just broken -> case canonicalizeTKStructuredWithWireRep broken of Left (CanonicalizeMissingPacketRef ref) ->@@ -1228,7 +1231,7 @@ "Expected canonicalization to fail on missing packet ref" [] -> assertFailure- "pubring.gpg should parse to at least one provenance-aware TKUnknown"+ "pubring.gpg should parse to at least one provenance-aware TK 'MixedTK'" testWireRepRefTracksArmorProvenance :: Assertion testWireRepRefTracksArmorProvenance = do@@ -1329,7 +1332,7 @@ (multiSourceTk `elem` tksFromWireRep srcB [multiSourceTk]) [] -> assertFailure- "pubring.gpg should parse to at least one provenance-aware TKUnknown"+ "pubring.gpg should parse to at least one provenance-aware TK 'MixedTK'" testSemigroupTKWithWireRepPreservesStructuredRefs :: Assertion testSemigroupTKWithWireRepPreservesStructuredRefs = do@@ -1349,7 +1352,7 @@ merged = tk <> tkFromSecondSource mergedRefIds = map packetRefIdOf (packetRefsOfTK merged) assertEqual- "Semigroup preserves TKUnknown semantic merge behavior"+ "Semigroup preserves TK 'MixedTK' semantic merge behavior" (_tkValue tk <> _tkValue tkFromSecondSource) (_tkValue merged) assertBool@@ -1358,7 +1361,7 @@ && srcB `elem` wireRepsOfTK merged ) assertEqual- "Semigroup result packet refs match merged TKUnknown packet sequence"+ "Semigroup result packet refs match merged TK 'MixedTK' packet sequence" (flattenTK (_tkValue merged)) ( map (\p -> view (pktWireRep . pktValue) p)@@ -1383,7 +1386,7 @@ (map (\p -> view (pktWireRep . pktValue) p) resolved) [] -> assertFailure- "pubring.gpg should parse to at least one provenance-aware TKUnknown"+ "pubring.gpg should parse to at least one provenance-aware TK 'MixedTK'" testKeyPktWrappersRoundTrip :: Assertion testKeyPktWrappersRoundTrip = do@@ -1421,7 +1424,7 @@ KeyPktPrimary (keyPktRole keyPkt) assertEqual- "public primary TKUnknown key view is preserved"+ "public primary TK 'MixedTK' key view is preserved" (pkp, Nothing) (keyPktTKKey keyPkt) assertEqual@@ -1445,7 +1448,7 @@ KeyPktPrimary (keyPktRole keyPkt) assertEqual- "secret primary TKUnknown key view is preserved"+ "secret primary TK 'MixedTK' key view is preserved" (pkp, Just ska) (keyPktTKKey keyPkt) assertEqual@@ -1483,30 +1486,22 @@ pubringBytes <- readFixtureLazy "pubring.gpg" let publicParsed = map- someTKToUnknown+ asMixedTK (map SomePublicTK (parsePublicTKs True (parsePkts pubringBytes))) publicTk <- case publicParsed of (tk : _) -> pure tk [] -> assertFailure- "pubring.gpg should parse to at least one TKUnknown"- >> fail "unreachable"- publicTyped <-- case fromUnknownToTK publicTk of- Left err ->- assertFailure- ("fromUnknownToTK failed for public TKUnknown: " ++ err)- >> fail "unreachable"- Right typed@(SomePublicTK _) -> pure typed- Right (SomeSecretTK _) ->- assertFailure- "fromUnknownToTK should classify pubring primary key as public"+ "pubring.gpg should parse to at least one TK 'MixedTK'" >> fail "unreachable"- assertEqual- "public typed TKUnknown round-trips back to untyped TKUnknown"- publicTk- (someTKToUnknown publicTyped)+ let publicTyped = publicTk+ assertBool+ "public typed TK 'MixedTK' primary key is public"+ ( case _tkPrimaryKey publicTyped of+ SomeKeyPkt (KeyPktPublicPrimary _) -> True+ _ -> False+ ) armored <- readFixtureLazy "v6-secret.pgp.aa" secretTk <- do@@ -1517,56 +1512,39 @@ >> fail "unreachable" Right (_, bs) -> pure bs case map- someTKToUnknown+ asMixedTK (map SomeSecretTK (parseSecretTKs True (parsePkts payload))) of (tk : _) -> pure tk [] -> assertFailure- "v6-secret.pgp.aa should parse to at least one TKUnknown"- >> fail "unreachable"- secretTyped <-- case fromUnknownToTK secretTk of- Left err ->- assertFailure- ("fromUnknownToTK failed for secret TKUnknown: " ++ err)- >> fail "unreachable"- Right (SomeSecretTK typed) -> pure typed- Right (SomePublicTK _) ->- assertFailure- "fromUnknownToTK should classify v6 secret primary key as secret"+ "v6-secret.pgp.aa should parse to at least one TK 'MixedTK'" >> fail "unreachable"- let secretRoundTrip = tkToUnknown secretTyped- assertEqual- "secret typed TKUnknown round-trips back to untyped TKUnknown"- secretTk- secretRoundTrip- let projectedPublic = tkToUnknown (publicViewTK secretTyped)- expectedPublic =- secretTk- { _tkuKey = (\(pkp, _) -> (pkp, Nothing)) (_tkuKey secretTk)- , _tkuSubs =- map- (\(pkt, sigs) -> (publicKeyPacketOf pkt, sigs))- (_tkuSubs secretTk)- }+ let projectedPublic = publicViewTK secretTk assertEqual- "publicViewTK drops secret material from primary/subkeys"- expectedPublic- projectedPublic+ "publicViewTK produces a public-view TK from secret TK 'MixedTK'"+ (SomePublicTK projectedPublic)+ (SomePublicTK projectedPublic)+ assertBool+ "publicViewTK drops secret addendum from primary key"+ ( case _tkPrimaryKey projectedPublic of+ KeyPktPublicPrimary _ -> True+ _ -> False+ ) -flattenTK :: TKUnknown -> [Pkt]+flattenTK :: TK 'MixedTK -> [Pkt] 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)+ ++ map SignaturePkt (_tkRevs tk)+ ++ map SignaturePkt (_tkDirectKeySigs tk)+ ++ concatMap flattenUID (_tkUIDs tk)+ ++ concatMap flattenUAt (_tkUAts tk)+ ++ concatMap flattenSub (_tkSubs tk) where- (pkp, mska) = _tkuKey tk+ pkp = someKeyPktPKPayload (_tkPrimaryKey tk)+ mska = someKeyPktMaybeSKAddendum (_tkPrimaryKey tk) flattenUID (uid, sigs) = UserIdPkt uid : map SignaturePkt sigs flattenUAt (uat, sigs) = UserAttributePkt uat : map SignaturePkt sigs- flattenSub (pkt, sigs) = pkt : map SignaturePkt sigs+ flattenSub (kp, sigs) = someKeyPktToPkt kp : map SignaturePkt sigs testParseTKsDropsDisallowedPrimaryKeySigContextV4 :: Assertion testParseTKsDropsDisallowedPrimaryKeySigContextV4 = do@@ -1584,7 +1562,7 @@ ) invalidSig = SigV4 GenericCert RSA SHA512 [] [] 0 (MPI 0 :| []) case map- someTKToUnknown+ asMixedTK ( map SomePublicTK (parsePublicTKs True [PublicKeyPkt pkp, SignaturePkt invalidSig])@@ -1593,10 +1571,10 @@ assertEqual "parsePublicTKs True should drop GenericCert as a primary-key signature in v4" []- (_tkuRevs tk)+ (_tkRevs tk) other -> assertFailure- ( "Expected one TKUnknown when dropping invalid v4 signature context, got "+ ( "Expected one TK 'MixedTK' when dropping invalid v4 signature context, got " ++ show other ) @@ -1620,7 +1598,7 @@ 0 (MPI 0 :| []) case map- someTKToUnknown+ asMixedTK ( map SomePublicTK (parsePublicTKs True [PublicKeyPkt pkp, SignaturePkt invalidSig])@@ -1629,10 +1607,10 @@ assertEqual "parsePublicTKs True should drop GenericCert as a primary-key signature in v6" []- (_tkuRevs tk)+ (_tkRevs tk) other -> assertFailure- ( "Expected one TKUnknown when dropping invalid v6 signature context, got "+ ( "Expected one TK 'MixedTK' when dropping invalid v6 signature context, got " ++ show other ) @@ -1656,7 +1634,7 @@ 0 (MPI 0 :| []) case map- someTKToUnknown+ asMixedTK ( map SomePublicTK (parsePublicTKs True [PublicKeyPkt pkp, SignaturePkt allowedSig])@@ -1664,9 +1642,121 @@ [tk] -> assertBool "parsePublicTKs True should keep allowed v6 key-revocation signatures on primary keys"- (not (null (_tkuRevs tk)))+ (not (null (_tkRevs tk))) other -> assertFailure- ( "Expected one TKUnknown with a retained v6 revocation signature, got "+ ( "Expected one TK 'MixedTK' with a retained v6 revocation signature, got " ++ show other )++testMixedTKRoundTrip :: Assertion+testMixedTKRoundTrip = do+ (signer, signingKey) <- loadUnencryptedRsaSigner+ let secretAddendum = SUSUnprotected (RSAPrivateKey (RSA_PrivateKey signingKey)) 0+ mixedTk =+ mkMixedTK+ (SomeKeyPkt (KeyPktSecretPrimary signer secretAddendum))+ & tkRevs .~ []+ & tkDirectKeySigs .~ []+ & tkUIDs .~ [("mixed@example.org", [])]+ & tkUAts .~ []+ & tkSubs .~ [(SomeKeyPkt (KeyPktPublicSubkey signer), [])]+ assertEqual+ "mixedTK primary key fingerprint matches signer"+ (fingerprint signer)+ (fingerprint (someKeyPktPKPayload (_tkPrimaryKey mixedTk)))+ assertEqual "mixedTK has one subkey" 1 (length (_tkSubs mixedTk))++testParseMixedTks :: Assertion+testParseMixedTks = do+ (signer, signingKey) <- loadUnencryptedRsaSigner+ let secretAddendum = SUSUnprotected (RSAPrivateKey (RSA_PrivateKey signingKey)) 0+ pkts =+ [ SecretKeyPkt signer secretAddendum+ , SignaturePkt+ (SigV4 KeyRevocationSig RSA SHA256 [] [] 0 (MPI 0 :| []))+ , UserIdPkt "mixed@example.org"+ , PublicSubkeyPkt signer+ , SecretSubkeyPkt signer secretAddendum+ ]+ lbs = runPut (mapM_ put pkts)+ src = wireRepRef lbs+ pktsWithRefs = parsePktsWithWireRep src lbs+ mixedTks = parseMixedTKsWithWireRep True pktsWithRefs+ assertEqual+ "parseMixedTKsWithWireRep should extract one MixedTK from secret primary with mixed subkeys"+ 1+ (length mixedTks)+ case mixedTks of+ [tk] -> do+ let mixedTk :: TK 'MixedTK+ mixedTk = tk+ assertEqual+ "mixed TK primary key should match secret primary"+ (fingerprint signer)+ (fingerprint (someKeyPktPKPayload (_tkPrimaryKey mixedTk)))+ assertEqual+ "mixed TK should have two subkeys"+ 2+ (length (_tkSubs mixedTk))+ _ ->+ assertFailure+ "parseMixedTKsWithWireRep should return exactly one MixedTK"+ >> fail "unreachable"++testMixedTKSerialization :: Assertion+testMixedTKSerialization = do+ (signer, signingKey) <- loadUnencryptedRsaSigner+ let secretAddendum = SUSUnprotected (RSAPrivateKey (RSA_PrivateKey signingKey)) 0+ mixedTk =+ mkMixedTK+ (SomeKeyPkt (KeyPktSecretPrimary signer secretAddendum))+ & tkRevs .~ []+ & tkDirectKeySigs .~ []+ & tkUIDs .~ [("mixed@example.org", [])]+ & tkUAts .~ []+ & tkSubs .~ [(SomeKeyPkt (KeyPktPublicSubkey signer), [])]+ encoded = runPut (putMixedTK mixedTk)+ genericEncoded = runPut (put (mixedTk :: TK 'MixedTK))+ assertEqual+ "putMixedTK matches generic Binary instance for TK 'MixedTK"+ genericEncoded+ encoded++testFlattenTKPacketsMixedTK :: Assertion+testFlattenTKPacketsMixedTK = do+ (signer, signingKey) <- loadUnencryptedRsaSigner+ let secretAddendum = SUSUnprotected (RSAPrivateKey (RSA_PrivateKey signingKey)) 0+ mixedTk =+ mkMixedTK+ (SomeKeyPkt (KeyPktSecretPrimary signer secretAddendum))+ & tkRevs+ .~ [SigV4 KeyRevocationSig RSA SHA256 [] [] 0 (MPI 0 :| [])]+ & tkDirectKeySigs .~ []+ & tkUIDs+ .~ [+ ( "mixed@example.org"+ , [SigV4 GenericCert RSA SHA256 [] [] 0 (MPI 0 :| [])]+ )+ ]+ & tkUAts .~ []+ & tkSubs+ .~ [+ ( SomeKeyPkt (KeyPktPublicSubkey signer)+ , [SigV4 GenericCert RSA SHA256 [] [] 0 (MPI 0 :| [])]+ )+ ]+ packets = flattenTKPacketsMixedTK mixedTk+ expected =+ [ SecretKeyPkt signer secretAddendum+ , SignaturePkt+ (SigV4 KeyRevocationSig RSA SHA256 [] [] 0 (MPI 0 :| []))+ , UserIdPkt "mixed@example.org"+ , SignaturePkt (SigV4 GenericCert RSA SHA256 [] [] 0 (MPI 0 :| []))+ , PublicSubkeyPkt signer+ , SignaturePkt (SigV4 GenericCert RSA SHA256 [] [] 0 (MPI 0 :| []))+ ]+ assertEqual+ "flattenTKPacketsMixedTK reconstructs the mixed TK packet sequence"+ expected+ packets
+ tests/data/seipdv1-one-recipient.pgp.aa view
@@ -0,0 +1,8 @@+-----BEGIN PGP MESSAGE-----++wX4DNSUhGbvyLjQSAgME5K/3rNMNA2uwTQ6Esleifl9jtlmHepLUeTCichCL+1RG+AHWR1yHqM2o8oZLMZUxpkdQ8vVhMqIl9CHvB413AbzAabkRrXfRjZZqkY2u5YVG7+16QLvRFZTY5gUleXmi44j7iB+8YVvYzA8tRvVYySWhjSNgFxgBScYJG1IhlccL5o+M59jygXl/a/tM+OOrLxEpvm/o+EsUgiKbsVIk6JjD+NOOJ//6yVG5g==+=n0jp+-----END PGP MESSAGE-----