packages feed

hOpenPGP 3.1.1 → 3.2

raw patch · 19 files changed

+2986/−1821 lines, 19 filesdep +comonad

Dependencies added: comonad

Files

Codec/Encryption/OpenPGP/Encrypt.hs view
@@ -439,7 +439,7 @@     #-} recipientEncryptionTargetFromTKAtTimestamp     :: ThirtyTwoBitTimeStamp-    -> TKUnknown+    -> TK 'PublicTK     -> Either RecipientCapabilityError RecipientEncryptionTarget recipientEncryptionTargetFromTKAtTimestamp timestamp tk =     recipientEncryptionTargetFromTKAtTimestampWithPolicy@@ -457,7 +457,7 @@ recipientEncryptionTargetFromTKAtTimestampWithPolicy     :: RecipientTargetSelectionPolicy     -> ThirtyTwoBitTimeStamp-    -> TKUnknown+    -> TK 'PublicTK     -> Either RecipientCapabilityError RecipientEncryptionTarget recipientEncryptionTargetFromTKAtTimestampWithPolicy policy timestamp tk =     case chooseRecipientTarget policy tk acceptedTargets of@@ -479,7 +479,7 @@     recipientEncryptionTargetFromTKAtTimestampWithPolicy         RecipientTargetSelectionFirstValid         (_timestamp (keyPktPKPayload (_tkPrimaryKey tk)))-        (tkToUnknown tk)+        tk  recipientEncryptionTargetFromTKWithPolicy     :: RecipientTargetSelectionPolicy@@ -489,11 +489,11 @@     recipientEncryptionTargetFromTKAtTimestampWithPolicy         policy         (_timestamp (keyPktPKPayload (_tkPrimaryKey tk)))-        (tkToUnknown tk)+        tk  recipientEncryptionTargetsFromTKAtTimestamp     :: ThirtyTwoBitTimeStamp-    -> TKUnknown+    -> TK 'PublicTK     -> [RecipientEncryptionTarget] recipientEncryptionTargetsFromTKAtTimestamp timestamp tk =     recipientEncryptionTargetsAccepted@@ -501,7 +501,7 @@  recipientEncryptionTargetsReportFromTKAtTimestamp     :: ThirtyTwoBitTimeStamp-    -> TKUnknown+    -> TK 'PublicTK     -> RecipientEncryptionTargetsReport recipientEncryptionTargetsReportFromTKAtTimestamp timestamp tk =     foldr@@ -510,18 +510,11 @@         (subkeyCandidates ++ [primaryCandidate])   where     emptyReport = RecipientEncryptionTargetsReport [] []-    primaryCandidate = fst (_tkuKey tk)+    primaryCandidate = keyPktPKPayload (_tkPrimaryKey tk)     primaryPreferencePayloads =         fromMaybe [] (effectiveKeyPreferencesAtTimestamp timestamp tk)     subkeyCandidates =-        mapMaybe-            ( \(pkt, _) ->-                case pkt of-                    PublicSubkeyPkt pkp -> Just pkp-                    SecretSubkeyPkt pkp _ -> Just pkp-                    _ -> Nothing-            )-            (_tkuSubs tk)+        map (keyPktPKPayload . fst) (_tkSubs tk)     classifyCandidate key report =         let caps =                 recipientCapabilitiesFromSubpacketPayloads@@ -585,18 +578,18 @@ recipientEncryptionTargetsFromTK tk =     recipientEncryptionTargetsFromTKAtTimestamp         (_timestamp (keyPktPKPayload (_tkPrimaryKey tk)))-        (tkToUnknown tk)+        tk  recipientEncryptionTargetsReportFromTK     :: TK 'PublicTK -> RecipientEncryptionTargetsReport recipientEncryptionTargetsReportFromTK tk =     recipientEncryptionTargetsReportFromTKAtTimestamp         (_timestamp (keyPktPKPayload (_tkPrimaryKey tk)))-        (tkToUnknown tk)+        tk  subkeyBindingCapabilityPayloads     :: ThirtyTwoBitTimeStamp-    -> TKUnknown+    -> TK 'PublicTK     -> SomePKPayload     -> [SigSubPacketPayload] subkeyBindingCapabilityPayloads timestamp tk recipient =@@ -604,13 +597,9 @@   where     matchingSubkey =         find-            ( \(pkt, _) ->-                case pkt of-                    PublicSubkeyPkt pkp -> fingerprint pkp == fingerprint recipient-                    SecretSubkeyPkt pkp _ -> fingerprint pkp == fingerprint recipient-                    _ -> False+            ( \(kp, _) -> fingerprint (keyPktPKPayload kp) == fingerprint recipient             )-            (_tkuSubs tk)+            (_tkSubs tk)     latestEffectiveBindingPayloads (_, sigs) =         maybe             []@@ -682,11 +671,12 @@  recipientValidityRejectionReason     :: ThirtyTwoBitTimeStamp-    -> TKUnknown+    -> TK 'PublicTK     -> SomePKPayload     -> Maybe RecipientTargetRejectionReason recipientValidityRejectionReason timestamp tk key-    | fingerprint key == fingerprint (fst (_tkuKey tk)) =+    | fingerprint key+        == fingerprint (keyPktPKPayload (_tkPrimaryKey tk)) =         if keyStateValid (keyStateAt (timestampToUTC timestamp) tk)             then Nothing             else Just (RecipientTargetNotValidAtTimestamp key timestamp)@@ -705,17 +695,13 @@                     Just (RecipientTargetNotValidAtTimestamp key timestamp)  findMatchingSubkeySignatures-    :: TKUnknown -> SomePKPayload -> Maybe [SignaturePayload]+    :: TK 'PublicTK -> SomePKPayload -> Maybe [SignaturePayload] findMatchingSubkeySignatures tk recipient =     snd         <$> find-            ( \(pkt, _) ->-                case pkt of-                    PublicSubkeyPkt pkp -> fingerprint pkp == fingerprint recipient-                    SecretSubkeyPkt pkp _ -> fingerprint pkp == fingerprint recipient-                    _ -> False+            ( \(kp, _) -> fingerprint (keyPktPKPayload kp) == fingerprint recipient             )-            (_tkuSubs tk)+            (_tkSubs tk)  subkeyRevokedAtTimestamp     :: ThirtyTwoBitTimeStamp -> [SignaturePayload] -> Bool@@ -742,7 +728,7 @@  chooseRecipientTarget     :: RecipientTargetSelectionPolicy-    -> TKUnknown+    -> TK 'PublicTK     -> [RecipientEncryptionTarget]     -> Maybe RecipientEncryptionTarget chooseRecipientTarget policy tk targets =@@ -772,7 +758,7 @@   where     isPrimaryTarget currentTK target =         fingerprint (recipientEncryptionTargetKey target)-            == fingerprint (fst (_tkuKey currentTK))+            == fingerprint (keyPktPKPayload (_tkPrimaryKey currentTK))  -- | Session-key bundle for PKESK/SKESK packet construction. newtype PKESKV3SessionMaterial
Codec/Encryption/OpenPGP/Expirations.hs view
@@ -2,28 +2,27 @@ -- Copyright © 2014-2026  Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE GADTs #-}  module Codec.Encryption.OpenPGP.Expirations-  ( KeyState(..)-  , keyStateAt-  , effectiveKeyPreferencesAt-  , effectiveUIDPreferencesAt-  , effectiveKeyPreferencesAtTimestamp-  , effectiveUIDPreferencesAtTimestamp-  , isTKTimeValid-  , isPKTimeValidWithSelfSignatures-  , getKeyExpirationTimesFromSignature-  , isCertificationSig-  , signatureCreationTime-  , signatureExpirationTime-  , signatureExpirationDuration-  , firstSignatureExpirationDuration-  , signatureEffectiveAt-  , addDurationToTime-  , newestByCreationTime-  ) where+    ( KeyState (..)+    , keyStateAt+    , effectiveKeyPreferencesAt+    , effectiveUIDPreferencesAt+    , effectiveKeyPreferencesAtTimestamp+    , effectiveUIDPreferencesAtTimestamp+    , isTKTimeValid+    , isPKTimeValidWithSelfSignatures+    , getKeyExpirationTimesFromSignature+    , isCertificationSig+    , signatureCreationTime+    , signatureExpirationTime+    , signatureExpirationDuration+    , firstSignatureExpirationDuration+    , signatureEffectiveAt+    , addDurationToTime+    , newestByCreationTime+    ) where  import Control.Error.Util (hush) import Control.Lens ((&), (^.), _1)@@ -34,235 +33,310 @@ import Data.Time.Clock (UTCTime, addUTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)+import Codec.Encryption.OpenPGP.Fingerprint+    ( eightOctetKeyID+    , fingerprint+    ) import Codec.Encryption.OpenPGP.Internal (issuer, issuerFP) import Codec.Encryption.OpenPGP.Ontology (isKET) import Codec.Encryption.OpenPGP.SignatureQualities-  ( sigCT-  , sigType-  , signatureHashedSubpacketsKnown-  )+    ( sigCT+    , sigType+    , signatureHashedSubpacketsKnown+    ) import Codec.Encryption.OpenPGP.Types+import Codec.Encryption.OpenPGP.Types.Internal.Pkt+    ( keyPktPKPayload+    ) -data KeyState =-  KeyState+data KeyState+    = KeyState     { keyStateValid :: Bool     , keyStateSelfSignaturesKnown :: Bool     , keyStateHasEffectiveSelfSignature :: Bool     , keyStateExpirationTime :: Maybe UTCTime     }-  deriving (Eq, Show)+    deriving (Eq, Show)  -- this assumes that all key expiration time subpackets are valid-isTKTimeValid :: UTCTime -> TKUnknown -> Bool+isTKTimeValid :: UTCTime -> TK k -> Bool isTKTimeValid ct = keyStateValid . keyStateAt ct -keyStateAt :: UTCTime -> TKUnknown -> KeyState+keyStateAt :: UTCTime -> TK k -> KeyState keyStateAt ct tk =-  baseState {keyStateValid = keyStateValid baseState && bindingStateAllowsValidation}+    baseState+        { keyStateValid =+            keyStateValid baseState && bindingStateAllowsValidation+        }   where     baseState =-      keyStateFromSelfSignaturesAt ct (tk ^. tkuKey . _1) relevantSelfSignatures+        keyStateFromSelfSignaturesAt+            ct+            (keyPktPKPayload (tk ^. tkPrimaryKey))+            relevantSelfSignatures     relevantSelfSignatures =-      filter (isDirectKeySelfSigFor primaryKey) (tk ^. tkuRevs) ++-      filter (isSelfCertificationFor primaryKey) (concatMap snd (tk ^. tkuUIDs)) ++-      filter (isSelfCertificationFor primaryKey) (concatMap snd (tk ^. tkuUAts))+        filter (isDirectKeySelfSigFor primaryKey) (tk ^. tkRevs)+            ++ filter+                (isSelfCertificationFor primaryKey)+                (concatMap snd (tk ^. tkUIDs))+            ++ filter+                (isSelfCertificationFor primaryKey)+                (concatMap snd (tk ^. tkUAts))     selfCertificationGroups =-      map (filter (isSelfSignatureFor primaryKey) . snd) (tk ^. tkuUIDs) ++-      map (filter (isSelfSignatureFor primaryKey) . snd) (tk ^. tkuUAts)+        map (filter (isSelfSignatureFor primaryKey) . snd) (tk ^. tkUIDs)+            ++ map (filter (isSelfSignatureFor primaryKey) . snd) (tk ^. tkUAts)     hasAnySelfCertification = any (any isCertificationSig) selfCertificationGroups     hasAnyActiveSelfCertification =-      any (selfCertificationGroupActiveAt ct) selfCertificationGroups+        any (selfCertificationGroupActiveAt ct) selfCertificationGroups     bindingStateAllowsValidation =-      not hasAnySelfCertification || hasAnyActiveSelfCertification-    primaryKey = tk ^. tkuKey . _1+        not hasAnySelfCertification || hasAnyActiveSelfCertification+    primaryKey = keyPktPKPayload (tk ^. tkPrimaryKey) -effectiveKeyPreferencesAt :: UTCTime -> TKUnknown -> Maybe [SigSubPacketPayload]+effectiveKeyPreferencesAt+    :: UTCTime -> TK k -> Maybe [SigSubPacketPayload] effectiveKeyPreferencesAt ct tk-  | not (keyStateValid (keyStateAt ct tk)) = Nothing-  | otherwise = do-      sig <- latestEffectivePreferenceCarrierAt ct tk-      let prefs = preferencePayloadsFromSignature sig-      if null prefs-        then Nothing-        else Just prefs+    | not (keyStateValid (keyStateAt ct tk)) = Nothing+    | otherwise = do+        sig <- latestEffectivePreferenceCarrierAt ct tk+        let prefs = preferencePayloadsFromSignature sig+        if null prefs+            then Nothing+            else Just prefs -effectiveUIDPreferencesAt :: UTCTime -> Text -> TKUnknown -> Maybe [SigSubPacketPayload]+effectiveUIDPreferencesAt+    :: UTCTime -> Text -> TK k -> Maybe [SigSubPacketPayload] effectiveUIDPreferencesAt ct uid tk-  | not (keyStateValid (keyStateAt ct tk)) = Nothing-  | otherwise = do-      sigs <- lookup uid (tk ^. tkuUIDs)-      cert <- latestActiveSelfCertificationAt ct (filter (isSelfSignatureFor primaryKey) sigs)-      let prefs = preferencePayloadsFromSignature cert-      if null prefs-        then Nothing-        else Just prefs+    | not (keyStateValid (keyStateAt ct tk)) = Nothing+    | otherwise = do+        sigs <- lookup uid (tk ^. tkUIDs)+        cert <-+            latestActiveSelfCertificationAt+                ct+                (filter (isSelfSignatureFor primaryKey) sigs)+        let prefs = preferencePayloadsFromSignature cert+        if null prefs+            then Nothing+            else Just prefs   where-    primaryKey = tk ^. tkuKey . _1+    primaryKey = keyPktPKPayload (tk ^. tkPrimaryKey) -effectiveKeyPreferencesAtTimestamp ::-     ThirtyTwoBitTimeStamp -> TKUnknown -> Maybe [SigSubPacketPayload]+effectiveKeyPreferencesAtTimestamp+    :: ThirtyTwoBitTimeStamp -> TK k -> Maybe [SigSubPacketPayload] effectiveKeyPreferencesAtTimestamp ts =-  effectiveKeyPreferencesAt (posixSecondsToUTCTime (realToFrac (unThirtyTwoBitTimeStamp ts)))+    effectiveKeyPreferencesAt+        (posixSecondsToUTCTime (realToFrac (unThirtyTwoBitTimeStamp ts))) -effectiveUIDPreferencesAtTimestamp ::-     ThirtyTwoBitTimeStamp -> Text -> TKUnknown -> Maybe [SigSubPacketPayload]+effectiveUIDPreferencesAtTimestamp+    :: ThirtyTwoBitTimeStamp+    -> Text+    -> TK k+    -> Maybe [SigSubPacketPayload] effectiveUIDPreferencesAtTimestamp ts uid =-  effectiveUIDPreferencesAt-    (posixSecondsToUTCTime (realToFrac (unThirtyTwoBitTimeStamp ts)))-    uid+    effectiveUIDPreferencesAt+        (posixSecondsToUTCTime (realToFrac (unThirtyTwoBitTimeStamp ts)))+        uid -isPKTimeValidWithSelfSignatures ::-     UTCTime -> SomePKPayload -> [SignaturePayload] -> Bool+isPKTimeValidWithSelfSignatures+    :: UTCTime -> SomePKPayload -> [SignaturePayload] -> Bool isPKTimeValidWithSelfSignatures ct pkp sigs =-  keyStateValid (keyStateFromSelfSignaturesAt ct pkp sigs)+    keyStateValid (keyStateFromSelfSignaturesAt ct pkp sigs) -keyStateFromSelfSignaturesAt ::-     UTCTime -> SomePKPayload -> [SignaturePayload] -> KeyState+keyStateFromSelfSignaturesAt+    :: UTCTime -> SomePKPayload -> [SignaturePayload] -> KeyState keyStateFromSelfSignaturesAt ct pkp sigs =-  KeyState-    { keyStateValid =-        ct >= keyCreationTime &&-        selfSignatureStateAllowsValidation &&-        maybe True (ct <) keyExpirationTime-    , keyStateSelfSignaturesKnown = maybe False (const True) latestKnownSelfSignature-    , keyStateHasEffectiveSelfSignature =-        maybe False (signatureEffectiveAt ct) latestKnownSelfSignature-    , keyStateExpirationTime = keyExpirationTime-    }+    KeyState+        { keyStateValid =+            ct >= keyCreationTime+                && selfSignatureStateAllowsValidation+                && maybe True (ct <) keyExpirationTime+        , keyStateSelfSignaturesKnown =+            maybe False (const True) latestKnownSelfSignature+        , keyStateHasEffectiveSelfSignature =+            maybe False (signatureEffectiveAt ct) latestKnownSelfSignature+        , keyStateExpirationTime = keyExpirationTime+        }   where     keyCreationTime = _timestamp pkp & posixSecondsToUTCTime . realToFrac     knownSelfSignatures = filter (signatureCreatedAtOrBefore ct) sigs     selfSignatureStateAllowsValidation =-      maybe (null sigs) (signatureEffectiveAt ct) latestKnownSelfSignature-    latestKnownSelfSignature = snd <$> newestByCreationTime (mapMaybeSignatureCreationTime knownSelfSignatures)+        maybe+            (null sigs)+            (signatureEffectiveAt ct)+            latestKnownSelfSignature+    latestKnownSelfSignature =+        snd+            <$> newestByCreationTime+                (mapMaybeSignatureCreationTime knownSelfSignatures)     keyExpirationTime = effectiveKeyExpirationTime ct pkp sigs -effectiveKeyExpirationTime ::-     UTCTime -> SomePKPayload -> [SignaturePayload] -> Maybe UTCTime+effectiveKeyExpirationTime+    :: UTCTime -> SomePKPayload -> [SignaturePayload] -> Maybe UTCTime effectiveKeyExpirationTime ct pkp sigs =-  signatureExpirationDurationToUTCTime pkp =<< latestKnownExpirationDuration ct sigs+    signatureExpirationDurationToUTCTime pkp+        =<< latestKnownExpirationDuration ct sigs -latestKnownExpirationDuration ::-     UTCTime -> [SignaturePayload] -> Maybe ThirtyTwoBitDuration+latestKnownExpirationDuration+    :: UTCTime -> [SignaturePayload] -> Maybe ThirtyTwoBitDuration latestKnownExpirationDuration ct sigs =-  latestKnownSelfSignatureExpirationDuration ct =<<-  (snd <$> newestByCreationTime (mapMaybeSignatureCreationTime (filter (signatureCreatedAtOrBefore ct) sigs)))+    latestKnownSelfSignatureExpirationDuration ct+        =<< ( snd+                <$> newestByCreationTime+                    ( mapMaybeSignatureCreationTime+                        (filter (signatureCreatedAtOrBefore ct) sigs)+                    )+            ) -latestKnownSelfSignatureExpirationDuration ::-     UTCTime -> SignaturePayload -> Maybe ThirtyTwoBitDuration+latestKnownSelfSignatureExpirationDuration+    :: UTCTime -> SignaturePayload -> Maybe ThirtyTwoBitDuration latestKnownSelfSignatureExpirationDuration ct sig-  | signatureEffectiveAt ct sig = listToMaybe (getKeyExpirationTimesFromSignature sig)-  | otherwise = Nothing+    | signatureEffectiveAt ct sig =+        listToMaybe (getKeyExpirationTimesFromSignature sig)+    | otherwise = Nothing  signatureEffectiveAt :: UTCTime -> SignaturePayload -> Bool signatureEffectiveAt ct sig =-  maybe False (<= ct) (signatureCreationTime sig) &&-  maybe True (ct <) (signatureExpirationTime sig)+    maybe False (<= ct) (signatureCreationTime sig)+        && maybe True (ct <) (signatureExpirationTime sig)  signatureCreatedAtOrBefore :: UTCTime -> SignaturePayload -> Bool signatureCreatedAtOrBefore ct sig =-  maybe False (<= ct) (signatureCreationTime sig)+    maybe False (<= ct) (signatureCreationTime sig)  signatureCreationTime :: SignaturePayload -> Maybe UTCTime signatureCreationTime =-  fmap (posixSecondsToUTCTime . realToFrac . unThirtyTwoBitTimeStamp) . sigCT+    fmap+        (posixSecondsToUTCTime . realToFrac . unThirtyTwoBitTimeStamp)+        . sigCT  signatureExpirationTime :: SignaturePayload -> Maybe UTCTime signatureExpirationTime sig =-  addDurationToTime <$>-  signatureCreationTime sig <*>-  signatureExpirationDuration sig+    addDurationToTime+        <$> signatureCreationTime sig+        <*> signatureExpirationDuration sig -signatureExpirationDuration :: SignaturePayload -> Maybe ThirtyTwoBitDuration+signatureExpirationDuration+    :: SignaturePayload -> Maybe ThirtyTwoBitDuration signatureExpirationDuration sig =-  signatureHashedSubpacketsKnown sig >>= firstSignatureExpirationDuration+    signatureHashedSubpacketsKnown sig+        >>= firstSignatureExpirationDuration -firstSignatureExpirationDuration :: [SigSubPacket] -> Maybe ThirtyTwoBitDuration+firstSignatureExpirationDuration+    :: [SigSubPacket] -> Maybe ThirtyTwoBitDuration firstSignatureExpirationDuration =-  foldr-    (\subpacket acc ->-       case subpacket of-         SigSubPacket _ (SigExpirationTime duration) -> Just duration-         _ -> acc)-    Nothing+    foldr+        ( \subpacket acc ->+            case subpacket of+                SigSubPacket _ (SigExpirationTime duration) -> Just duration+                _ -> acc+        )+        Nothing -signatureExpirationDurationToUTCTime ::-     SomePKPayload -> ThirtyTwoBitDuration -> Maybe UTCTime+signatureExpirationDurationToUTCTime+    :: SomePKPayload -> ThirtyTwoBitDuration -> Maybe UTCTime signatureExpirationDurationToUTCTime _ (ThirtyTwoBitDuration 0) = Nothing signatureExpirationDurationToUTCTime pkp duration =-  Just $-  addDurationToTime-    (_timestamp pkp & posixSecondsToUTCTime . realToFrac)-    duration+    Just $+        addDurationToTime+            (_timestamp pkp & posixSecondsToUTCTime . realToFrac)+            duration  addDurationToTime :: UTCTime -> ThirtyTwoBitDuration -> UTCTime addDurationToTime baseTime duration =-  addUTCTime (fromIntegral (unThirtyTwoBitDuration duration)) baseTime+    addUTCTime+        (fromIntegral (unThirtyTwoBitDuration duration))+        baseTime  newestByCreationTime :: [(UTCTime, a)] -> Maybe (UTCTime, a) newestByCreationTime [] = Nothing newestByCreationTime xs = Just (maximumBy (comparing fst) xs) -mapMaybeSignatureCreationTime :: [SignaturePayload] -> [(UTCTime, SignaturePayload)]+mapMaybeSignatureCreationTime+    :: [SignaturePayload] -> [(UTCTime, SignaturePayload)] mapMaybeSignatureCreationTime =-  foldr-    (\sig acc ->-       case signatureCreationTime sig of-         Just ct -> (ct, sig) : acc-         Nothing -> acc)-    []+    foldr+        ( \sig acc ->+            case signatureCreationTime sig of+                Just ct -> (ct, sig) : acc+                Nothing -> acc+        )+        [] -selfCertificationGroupActiveAt :: UTCTime -> [SignaturePayload] -> Bool+selfCertificationGroupActiveAt+    :: UTCTime -> [SignaturePayload] -> Bool selfCertificationGroupActiveAt ct sigs =-  maybe False (const True) (latestActiveSelfCertificationAt ct sigs)+    maybe+        False+        (const True)+        (latestActiveSelfCertificationAt ct sigs) -latestActiveSelfCertificationAt :: UTCTime -> [SignaturePayload] -> Maybe SignaturePayload+latestActiveSelfCertificationAt+    :: UTCTime -> [SignaturePayload] -> Maybe SignaturePayload latestActiveSelfCertificationAt ct sigs =-  case latestKnownSelfCertification of-    Nothing -> Nothing-    Just certification ->-      if signatureEffectiveAt ct certification &&-         not (any (\revocation -> revokesCertificationAt ct revocation certification) certRevocations)-        then Just certification-        else Nothing+    case latestKnownSelfCertification of+        Nothing -> Nothing+        Just certification ->+            if signatureEffectiveAt ct certification+                && not+                    ( any+                        (\revocation -> revokesCertificationAt ct revocation certification)+                        certRevocations+                    )+                then Just certification+                else Nothing   where     latestKnownSelfCertification =-      snd <$> newestByCreationTime (mapMaybeSignatureCreationTime knownCertifications)+        snd+            <$> newestByCreationTime+                (mapMaybeSignatureCreationTime knownCertifications)     knownCertifications =-      filter (\sig -> isCertificationSig sig && signatureCreatedAtOrBefore ct sig) sigs+        filter+            ( \sig -> isCertificationSig sig && signatureCreatedAtOrBefore ct sig+            )+            sigs     certRevocations =-      filter (\sig -> isCertRevocationForTime ct sig) sigs+        filter (\sig -> isCertRevocationForTime ct sig) sigs -latestEffectivePreferenceCarrierAt :: UTCTime -> TKUnknown -> Maybe SignaturePayload+latestEffectivePreferenceCarrierAt+    :: UTCTime -> TK k -> Maybe SignaturePayload latestEffectivePreferenceCarrierAt ct tk =-  snd <$> newestByCreationTime (mapMaybeSignatureCreationTime candidates)+    snd+        <$> newestByCreationTime (mapMaybeSignatureCreationTime candidates)   where-    primaryKey = tk ^. tkuKey . _1+    primaryKey = keyPktPKPayload (tk ^. tkPrimaryKey)     directKeySigs =-      filter-        (\sig -> isDirectKeySelfSigFor primaryKey sig && signatureEffectiveAt ct sig)-        (tk ^. tkuRevs)+        filter+            ( \sig ->+                isDirectKeySelfSigFor primaryKey sig+                    && signatureEffectiveAt ct sig+            )+            (tk ^. tkRevs)     uidSelfCerts =-      mapMaybe-        (latestActiveSelfCertificationAt ct . filter (isSelfSignatureFor primaryKey) . snd)-        (tk ^. tkuUIDs)+        mapMaybe+            ( latestActiveSelfCertificationAt ct+                . filter (isSelfSignatureFor primaryKey)+                . snd+            )+            (tk ^. tkUIDs)     uatSelfCerts =-      mapMaybe-        (latestActiveSelfCertificationAt ct . filter (isSelfSignatureFor primaryKey) . snd)-        (tk ^. tkuUAts)+        mapMaybe+            ( latestActiveSelfCertificationAt ct+                . filter (isSelfSignatureFor primaryKey)+                . snd+            )+            (tk ^. tkUAts)     candidates = directKeySigs ++ uidSelfCerts ++ uatSelfCerts -preferencePayloadsFromSignature :: SignaturePayload -> [SigSubPacketPayload]+preferencePayloadsFromSignature+    :: SignaturePayload -> [SigSubPacketPayload] preferencePayloadsFromSignature =-  map-    (\(SigSubPacket _ payload) -> payload) .-  filter isPreferenceSubpacket .-  signatureHashedSubpackets+    map+        (\(SigSubPacket _ payload) -> payload)+        . filter isPreferenceSubpacket+        . signatureHashedSubpackets  signatureHashedSubpackets :: SignaturePayload -> [SigSubPacket] signatureHashedSubpackets sig =-  maybe [] id (signatureHashedSubpacketsKnown sig)+    maybe [] id (signatureHashedSubpacketsKnown sig)  isPreferenceSubpacket :: SigSubPacket -> Bool isPreferenceSubpacket (SigSubPacket _ (PreferredSymmetricAlgorithms _)) = True@@ -272,39 +346,55 @@ isPreferenceSubpacket (SigSubPacket _ (PreferredKeyServer _)) = True isPreferenceSubpacket (SigSubPacket _ (Features _)) = True isPreferenceSubpacket (SigSubPacket _ (OtherSigSub subpacketType _)) =-  subpacketType == 39+    subpacketType == 39 isPreferenceSubpacket _ = False -revokesCertificationAt :: UTCTime -> SignaturePayload -> SignaturePayload -> Bool+revokesCertificationAt+    :: UTCTime -> SignaturePayload -> SignaturePayload -> Bool revokesCertificationAt ct revocation certification =-  signatureEffectiveAt ct revocation &&-  case (signatureCreationTime certification, signatureCreationTime revocation) of-    (Just certificationTime, Just revocationTime) -> certificationTime < revocationTime-    _ -> False+    signatureEffectiveAt ct revocation+        && case ( signatureCreationTime certification+                , signatureCreationTime revocation+                ) of+            (Just certificationTime, Just revocationTime) -> certificationTime < revocationTime+            _ -> False  isCertRevocationForTime :: UTCTime -> SignaturePayload -> Bool isCertRevocationForTime ct sig =-  sigType sig == Just CertRevocationSig &&-  signatureCreatedAtOrBefore ct sig+    sigType sig == Just CertRevocationSig+        && signatureCreatedAtOrBefore ct sig  isCertificationSig :: SignaturePayload -> Bool isCertificationSig sig =-  sigType sig `elem` [Just GenericCert, Just PersonaCert, Just CasualCert, Just PositiveCert]+    sigType sig+        `elem` [ Just GenericCert+               , Just PersonaCert+               , Just CasualCert+               , Just PositiveCert+               ] -isDirectKeySelfSigFor :: SomePKPayload -> SignaturePayload -> Bool+isDirectKeySelfSigFor+    :: SomePKPayload -> SignaturePayload -> Bool isDirectKeySelfSigFor pkp sig =-  sigType sig == Just SignatureDirectlyOnAKey && isSelfSignatureFor pkp sig+    sigType sig == Just SignatureDirectlyOnAKey+        && isSelfSignatureFor pkp sig -isSelfCertificationFor :: SomePKPayload -> SignaturePayload -> Bool+isSelfCertificationFor+    :: SomePKPayload -> SignaturePayload -> Bool isSelfCertificationFor pkp sig =-  isCertificationSig sig && isSelfSignatureFor pkp sig+    isCertificationSig sig && isSelfSignatureFor pkp sig  isSelfSignatureFor :: SomePKPayload -> SignaturePayload -> Bool isSelfSignatureFor pkp sig =-  (((== fingerprint pkp) <$> issuerFP (SignaturePkt sig)) == Just True) ||-  (((==) <$> issuer (SignaturePkt sig) <*> hush (eightOctetKeyID pkp)) == Just True)+    ( ((== fingerprint pkp) <$> issuerFP (SignaturePkt sig))+        == Just True+    )+        || ( ((==) <$> issuer (SignaturePkt sig) <*> hush (eightOctetKeyID pkp))+                == Just True+           ) -getKeyExpirationTimesFromSignature :: SignaturePayload -> [ThirtyTwoBitDuration]+getKeyExpirationTimesFromSignature+    :: SignaturePayload -> [ThirtyTwoBitDuration] getKeyExpirationTimesFromSignature sig =-  map (\(SigSubPacket _ (KeyExpirationTime x)) -> x) $-  filter isKET (signatureHashedSubpackets sig)+    map (\(SigSubPacket _ (KeyExpirationTime x)) -> x) $+        filter isKET (signatureHashedSubpackets sig)
Codec/Encryption/OpenPGP/KeyringParser.hs view
@@ -53,6 +53,7 @@     ) where  import Control.Applicative (many, (<|>))+import Control.Lens ((^.)) import Data.Either (rights) import qualified Data.List.NonEmpty as NE import Data.Maybe (catMaybes, mapMaybe)@@ -530,7 +531,7 @@     pkpkts <- satisfy isPKPWS     case pkpkts of         [pktWithSource] ->-            case pktToPublicKeyPkt (_pktValue pktWithSource) of+            case pktToPublicKeyPkt (pktWithSource ^. pktWireRep . pktValue) of                 Just keyPkt                     | keyPktRole keyPkt == KeyPktPrimary ->                         return (keyPktTKKey keyPkt, [pktWithSource])@@ -538,7 +539,7 @@         _ -> failure   where     isPKPWS [pktWithSource] =-        case pktToPublicKeyPkt (_pktValue pktWithSource) of+        case pktToPublicKeyPkt (pktWithSource ^. pktWireRep . pktValue) of             Just keyPkt -> keyPktRole keyPkt == KeyPktPrimary             _ -> False     isPKPWS _ = False@@ -564,7 +565,7 @@         spks <- satisfy (isSPWS intolerant)         case spks of             [pktWithSource] ->-                case _pktValue pktWithSource of+                case pktWithSource ^. pktWireRep . pktValue of                     SignaturePkt sp ->                         let sigs =                                 ( if intolerant@@ -577,11 +578,11 @@             _ -> failure     brokensig' = const ([], []) <$> brokenWithWireRep 2     isSPWS True [pktWithSource] =-        case _pktValue pktWithSource of+        case pktWithSource ^. pktWireRep . pktValue of             SignaturePkt sp -> isSP' sp             _ -> False     isSPWS False [pktWithSource] =-        case _pktValue pktWithSource of+        case pktWithSource ^. pktWireRep . pktValue of             SignaturePkt _ -> True             _ -> False     isSPWS _ _ = False@@ -596,7 +597,7 @@     upkts <- satisfy isUIDWS     case upkts of         [pktWithSource] ->-            case _pktValue pktWithSource of+            case pktWithSource ^. pktWireRep . pktValue of                 UserIdPkt u -> do                     (sigs, sigrefs) <-                         concatMany@@ -606,7 +607,7 @@         _ -> failure   where     isUIDWS [pktWithSource] =-        case _pktValue pktWithSource of+        case pktWithSource ^. pktWireRep . pktValue of             UserIdPkt _ -> True             _ -> False     isUIDWS _ = False@@ -620,7 +621,7 @@     uapkts <- satisfy isUAtWS     case uapkts of         [pktWithSource] ->-            case _pktValue pktWithSource of+            case pktWithSource ^. pktWireRep . pktValue of                 UserAttributePkt us -> do                     (sigs, sigrefs) <-                         concatMany@@ -630,7 +631,7 @@         _ -> failure   where     isUAtWS [pktWithSource] =-        case _pktValue pktWithSource of+        case pktWithSource ^. pktWireRep . pktValue of             UserAttributePkt _ -> True             _ -> False     isUAtWS _ = False@@ -648,11 +649,15 @@                 concatMany                     (signatureWithWireRepPredicate intolerant isAllowedSubkeySigType)             return-                [((_pktValue pktWithSource, sigs), pktWithSource : sigrefs)]+                [+                    ( (pktWithSource ^. pktWireRep . pktValue, sigs)+                    , pktWithSource : sigrefs+                    )+                ]         _ -> failure   where     isPSKPWS [pktWithSource] =-        case pktToPublicKeyPkt (_pktValue pktWithSource) of+        case pktToPublicKeyPkt (pktWithSource ^. pktWireRep . pktValue) of             Just keyPkt -> keyPktRole keyPkt == KeyPktSubkey             _ -> False     isPSKPWS _ = False@@ -681,11 +686,15 @@                 concatMany                     (signatureWithWireRepPredicate intolerant isAllowedSubkeySigType)             return-                [((_pktValue pktWithSource, sigs), pktWithSource : sigrefs)]+                [+                    ( (pktWithSource ^. pktWireRep . pktValue, sigs)+                    , pktWithSource : sigrefs+                    )+                ]         _ -> failure   where     isSSKPWS [pktWithSource] =-        case pktToSecretKeyPkt (_pktValue pktWithSource) of+        case pktToSecretKeyPkt (pktWithSource ^. pktWireRep . pktValue) of             Just keyPkt -> keyPktRole keyPkt == KeyPktSubkey             _ -> False     isSSKPWS _ = False@@ -709,7 +718,7 @@     spkts <- satisfy isSKPWS     case spkts of         [pktWithSource] ->-            case pktToSecretKeyPkt (_pktValue pktWithSource) of+            case pktToSecretKeyPkt (pktWithSource ^. pktWireRep . pktValue) of                 Just keyPkt                     | keyPktRole keyPkt == KeyPktPrimary ->                         return (keyPktTKKey keyPkt, [pktWithSource])@@ -717,7 +726,7 @@         _ -> failure   where     isSKPWS [pktWithSource] =-        case pktToSecretKeyPkt (_pktValue pktWithSource) of+        case pktToSecretKeyPkt (pktWithSource ^. pktWireRep . pktValue) of             Just keyPkt -> keyPktRole keyPkt == KeyPktPrimary             _ -> False     isSKPWS _ = False@@ -731,7 +740,7 @@         _ -> failure   where     isBrokenWS [pktWithSource] =-        case _pktValue pktWithSource of+        case pktWithSource ^. pktWireRep . pktValue of             BrokenPacketPkt _ a _ -> t == fromIntegral a             _ -> False     isBrokenWS _ = False@@ -744,7 +753,7 @@             (anyTKWithWireRep intolerant)             (map (: []) (filter notTrustPacketWithWireRep ps))   where-    notTrustPacketWithWireRep = not . isTrustPkt . _pktValue+    notTrustPacketWithWireRep = not . isTrustPkt . (^. pktWireRep . pktValue)  runIncrementalParser     :: (Monoid s, Show s)
Codec/Encryption/OpenPGP/Message.hs view
@@ -13,8 +13,6 @@  module Codec.Encryption.OpenPGP.Message     ( Passphrase-    , mkPassphrase-    , passphraseBytes     , EncryptedPayload     , mkEncryptedPayload     , encryptedPayloadBytes@@ -137,13 +135,13 @@     , sigBuilderInitV6Typed     ) import Codec.Encryption.OpenPGP.Types+import Codec.Encryption.OpenPGP.Types.Internal.Base+    ( Passphrase (..)+    ) import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA import Data.Conduit.OpenPGP.Decrypt (decryptSEIPDv2Payload) import qualified Data.Conduit.OpenPGP.Message as ConduitMessage -newtype Passphrase = Passphrase {unPassphrase :: BL.ByteString}-    deriving (Eq, Ord, Show)- newtype EncryptedPayload = EncryptedPayload {unEncryptedPayload :: BL.ByteString}     deriving (Eq, Ord, Show) @@ -358,12 +356,6 @@ renderMessageDecryptFailure :: MessageDecryptFailure -> String renderMessageDecryptFailure (SessionMaterialDerivationFailed err) = renderS2KError err renderMessageDecryptFailure (PayloadDecryptFailed err) = err--mkPassphrase :: BL.ByteString -> Passphrase-mkPassphrase = Passphrase--passphraseBytes :: Passphrase -> BL.ByteString-passphraseBytes = unPassphrase  mkEncryptedPayload :: BL.ByteString -> EncryptedPayload mkEncryptedPayload = EncryptedPayload
Codec/Encryption/OpenPGP/SecretKey.hs view
@@ -2,725 +2,1149 @@ -- Copyright © 2013-2026  Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).--{-# LANGUAGE GADTs #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE TypeApplications #-}--module Codec.Encryption.OpenPGP.SecretKey-  ( decryptPrivateKey-  , reinterpretUnknownSKeyForPKPayload-  , mkUnencryptedSKAddendum-  , encryptPrivateKeyWithPolicyAndSaltAndIV-  , encryptPrivateKey-  , changePrivateKeyPassphrase-  , changePrivateKeyPassphraseRandom-  , changeSecretKeyPassphrase-  , changeSecretKeyPassphraseRandom-  , reencryptSecretKeyRandomEither-  , reencryptPrivateKeyTyped-  ) where--import Codec.Encryption.OpenPGP.BlockCipher (renderCipherError, keySize)-import Codec.Encryption.OpenPGP.CFB (decryptNoNonce, encryptNoNonce)-import Codec.Encryption.OpenPGP.Internal.RFC7253OCB-  ( decryptWithOCBRFC7253With-  , encryptWithOCBRFC7253-  )-import Codec.Encryption.OpenPGP.Internal.CryptoAES (withAESCipher)-import Codec.Encryption.OpenPGP.Policy-  ( OpenPGPPolicy(..)-  , OpenPGPRFC(..)-  , SecretKeyProtectionPolicy-  , defaultPolicy-  , legacySecretKeyProtectionErrorMessage-  , secretKeyAEADNonceOctets-  , secretKeyDefaultAEADAlgorithm-  , secretKeyDefaultS2KForSalt-  , secretKeyDefaultSymmetricAlgorithm-  , secretKeyProtectionPolicyForKeyVersion-  , secretKeyS2KSaltOctets-  )-import Codec.Encryption.OpenPGP.S2K-  ( renderS2KError-  , skesk2Key-  , string2Key-  )-import Codec.Encryption.OpenPGP.Serialize (getSecretKey, putSKeyForPKPayload)-import Codec.Encryption.OpenPGP.Types-import qualified "crypton" Crypto.Cipher.Types as CCT-import qualified Crypto.Error as CE-import qualified Crypto.Hash as CH-import qualified Crypto.Hash.Algorithms as CHA-import Crypto.KDF.HKDF (expand, extract)-import Crypto.Number.ModArithmetic (inverse)-import Crypto.Number.Serialize (os2ip)-import qualified Crypto.PubKey.DSA as DSA-import qualified Crypto.PubKey.ECC.ECDSA as ECDSA-import qualified Crypto.PubKey.RSA as R-import Crypto.Random.Types (MonadRandom, getRandomBytes)-import Control.Monad (when)-import Data.Bifunctor (bimap, first)-import Data.Binary (put)-import Data.Binary.Get (getRemainingLazyByteString, getWord16be, runGetOrFail)-import Data.Binary.Put (Put, putByteString, putLazyByteString, putWord16be, runPut)-import qualified Data.ByteArray as BA-import qualified Data.ByteString.Base16 as B16-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy as BL-import Data.List (nub)-import Data.Word (Word8, Word16)--decryptPrivateKey ::-     (SomePKPayload, SKAddendum) -> BL.ByteString -> Either String SKAddendum-decryptPrivateKey (pkp, ska) pp =-  case fromSKAddendumForPKPayload pkp ska of-    Left err -> Left err-    Right (SomeSKAddendumV skaV) -> toSKAddendum <$> decryptPrivateKeyTyped pkp skaV pp--decryptPrivateKeyTyped ::-     SomePKPayload-  -> SKAddendumV v-  -> BL.ByteString-  -> Either String (SKAddendumV v)-decryptPrivateKeyTyped pkp (SKA16bit sa s2k iv payload) pp = do-  (sk, cksum) <- decryptS2KProtectedPayload pkp sa s2k iv payload pp parse16BitProtectedSecretKey-  pure (SKAUnencryptedLegacy sk cksum)-decryptPrivateKeyTyped pkp (SKASHA1Legacy sa s2k iv payload) pp = do-  (sk, cksum) <- decryptS2KProtectedPayload pkp sa s2k iv payload pp parseSHA1ProtectedSecretKey-  pure (SKAUnencryptedLegacy sk cksum)-decryptPrivateKeyTyped pkp (SKASHA1V6 sa s2k iv payload) pp = do-  (sk, _) <- decryptS2KProtectedPayload pkp sa s2k iv payload pp parseSHA1ProtectedSecretKey-  pure (SKAUnencryptedV6 sk)-decryptPrivateKeyTyped pkp (SKAAEADV6 sa aa s2k iv payload) pp = do-  sk <- decryptAEADPayloadCore pkp sa aa s2k iv payload pp-  pure (SKAUnencryptedV6 sk)-decryptPrivateKeyTyped pkp (SKAAEADLegacy sa aa s2k iv payload) pp = do-  sk <- decryptAEADPayloadCore pkp sa aa s2k iv payload pp-  pure (SKAUnencryptedLegacy sk 0)-decryptPrivateKeyTyped pkp (SKASymLegacy sa iv payload) pp = do-  keyLen <- first renderCipherError (keySize sa)-  dek <- first renderS2KError (string2Key (Simple DeprecatedMD5) keyLen pp)-  p <- first renderCipherError (decryptNoNonce sa iv (BL.toStrict payload) dek)-  (sk, cksum) <- parse16BitProtectedSecretKey pkp p-  pure (SKAUnencryptedLegacy sk cksum)-decryptPrivateKeyTyped pkp (SKASymV6 sa iv payload) pp = do-  keyLen <- first renderCipherError (keySize sa)-  dek <- first renderS2KError (string2Key (Simple DeprecatedMD5) keyLen pp)-  p <- first renderCipherError (decryptNoNonce sa iv (BL.toStrict payload) dek)-  (sk, _) <- parse16BitProtectedSecretKey pkp p-  pure (SKAUnencryptedV6 sk)-decryptPrivateKeyTyped _ ska@(SKAUnencryptedLegacy {}) _ = Right ska-decryptPrivateKeyTyped _ ska@(SKAUnencryptedV6 {}) _ = Right ska--reinterpretUnknownSKeyForPKPayload :: SomePKPayload -> SKey -> Either String SKey-reinterpretUnknownSKeyForPKPayload _ sk@RSAPrivateKey {} = Right sk-reinterpretUnknownSKeyForPKPayload _ sk@DSAPrivateKey {} = Right sk-reinterpretUnknownSKeyForPKPayload _ sk@ElGamalPrivateKey {} = Right sk-reinterpretUnknownSKeyForPKPayload _ sk@ECDHPrivateKey {} = Right sk-reinterpretUnknownSKeyForPKPayload _ sk@ECDSAPrivateKey {} = Right sk-reinterpretUnknownSKeyForPKPayload _ sk@EdDSAPrivateKey {} = Right sk-reinterpretUnknownSKeyForPKPayload _ sk@X25519PrivateKey {} = Right sk-reinterpretUnknownSKeyForPKPayload _ sk@X448PrivateKey {} = Right sk-reinterpretUnknownSKeyForPKPayload pkp (UnknownSKey payload) =-  case runGetOrFail ((,) <$> getSecretKey pkp <*> getRemainingLazyByteString) payload of-    Left (_, _, err) -> Left err-    Right (_, _, (skey, trailing))-      | BL.null trailing -> Right skey-      | otherwise -> Left "decoded secret key material has trailing bytes"--mkUnencryptedSKAddendum :: SomePKPayload -> SKey -> Either String SKAddendum-mkUnencryptedSKAddendum pkp skey = do-  payload <- legacySecretKeyPayload pkp skey-  let checksum =-        case _keyVersion pkp of-          V6 -> 0-          _ -> checksum16 (BL.toStrict payload)-  pure (SUUnencrypted skey checksum)--decryptS2KProtectedPayload ::-     SomePKPayload-  -> SymmetricAlgorithm-  -> S2K-  -> IV-  -> BL.ByteString-  -> BL.ByteString-  -> (SomePKPayload -> B.ByteString -> Either String (SKey, Word16))-  -> Either String (SKey, Word16)-decryptS2KProtectedPayload pkp sa s2k iv payload pp parser = do-  dek <- first renderS2KError (skesk2Key (SKESK4Packet sa s2k Nothing) pp)-  decrypted <- first renderCipherError (decryptNoNonce sa iv (BL.toStrict payload) dek)-  parser pkp decrypted-parse16BitProtectedSecretKey :: SomePKPayload -> B.ByteString -> Either String (SKey, Word16)-parse16BitProtectedSecretKey pkp p-  | B.length p < 2 = Left "secret key payload is too short for a 16-bit checksum"-  | otherwise = do-      let (skeyPayload, checksumPayload) = B.splitAt (B.length p - 2) p-      sk <- decodeSecretKey pkp skeyPayload-      cksum <- decodeChecksum checksumPayload-      let expected = checksum16 skeyPayload-      if cksum == expected-        then Right (sk, cksum)-        else-          Left-            ("16-bit secret key checksum mismatch (expected " ++-             show expected ++ ", got " ++ show cksum ++ ")")--parseSHA1ProtectedSecretKey :: SomePKPayload -> B.ByteString -> Either String (SKey, Word16)-parseSHA1ProtectedSecretKey pkp p-  | B.length p < 20 = Left "secret key payload is too short for a SHA1 checksum"-  | otherwise = do-      let (skeyPayload, hashPayload) = B.splitAt (B.length p - 20) p-          expected = BA.convert (CH.hash skeyPayload :: CH.Digest CH.SHA1)-      sk <- decodeSecretKey pkp skeyPayload-      if hashPayload == expected-        then Right (sk, checksum16 skeyPayload)-        else Left "SHA1 secret key checksum mismatch"--decodeSecretKey :: SomePKPayload -> B.ByteString -> Either String SKey-decodeSecretKey pkp payloadBytes =-  bimap-    (\(_, _, x) -> x)-    (\(_, _, x) -> x)-    (runGetOrFail (getSecretKey pkp) (BL.fromStrict payloadBytes))--decodeChecksum :: B.ByteString -> Either String Word16-decodeChecksum checksumBytes =-  bimap-    (\(_, _, x) -> x)-    (\(_, _, x) -> x)-    (runGetOrFail getWord16be (BL.fromStrict checksumBytes))-decryptAEADPayloadCore ::-     SomePKPayload-  -> SymmetricAlgorithm-  -> AEADAlgorithm-  -> S2K-  -> IV-  -> BL.ByteString-  -> BL.ByteString-  -> Either String SKey-decryptAEADPayloadCore pkp sa aa s2k iv payload pp = do-  keyLen <- first renderCipherError (keySize sa)-  keyMaterial <- first renderS2KError (string2Key s2k keyLen pp)-  let keyCandidates = [keyMaterial]-      tagCandidates = [0xC5, 0xC7, 0x94, 0x95, 0x96, 0x97, 0x9C, 0x9D, 0x9E, 0x9F]-      infoCandidates =-        nub-          [ B.pack [tag, keyVersionByte (_keyVersion pkp), fromFVal sa, fromFVal aa]-          | tag <- tagCandidates-          ]-      pkpBytes = BL.toStrict (runPut (put pkp))-      adCandidates =-        nub-          [B.cons tagByte pkpBytes | tagByte <- tagCandidates]-      aaCandidates = [aa]-      nonce = unIV iv-      payloadStrict = BL.toStrict payload-      tagLen = 16-      tryDecrypt candidateKeyMaterial info ad aaTry = do-        when (B.length payloadStrict < tagLen) $-          Left "v6 AEAD secret key payload too short"-        let (ciphertext, tagBytes) = B.splitAt (B.length payloadStrict - tagLen) payloadStrict-            authTag = CCT.AuthTag (BA.convert tagBytes)-            prk = extract @CHA.SHA256 B.empty candidateKeyMaterial-            kekCandidates =-              nub-                [ B.take keyLen candidateKeyMaterial-                , (expand @CHA.SHA256 prk info keyLen :: B.ByteString)-                , (expand @CHA.SHA256 prk B.empty keyLen :: B.ByteString)-                ]-            tryKeks = go Nothing-              where-                go merr [] =-                  Left $-                  "could not decrypt using any KEK candidate" ++-                  maybe "" (\e -> " (last error: " ++ e ++ ")") merr-                go merr (kek:ks) =-                  case decryptWithKey sa aaTry kek ad nonce ciphertext authTag of-                    Right cleartext -> Right cleartext-                    Left err -> go (Just (maybe err id merr)) ks-        tryKeks kekCandidates-      tryAll = go Nothing-        where-          go merr [] =-            Left $-            "could not decrypt v6 AEAD secret key payload" ++-            maybe "" (\e -> " (last error: " ++ e ++ ")") merr-          go merr ((keyMaterialCandidate, info, ad, aaTry):xs) =-            case tryDecrypt keyMaterialCandidate info ad aaTry of-              Right cleartext -> Right cleartext-              Left err -> go (Just (maybe err id merr)) xs-  cleartext <--    tryAll-      [ (k, i, a, m)-      | k <- keyCandidates-      , i <- infoCandidates-      , a <- adCandidates-      , m <- aaCandidates-      ]-  parseSecretKeyExact pkp cleartext--checksum16 :: B.ByteString -> Word16-checksum16 =-  fromIntegral .-  B.foldl' (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer)) 0--decryptWithKey ::-     SymmetricAlgorithm-  -> AEADAlgorithm-  -> B.ByteString-  -> B.ByteString-  -> B.ByteString-  -> B.ByteString-  -> CCT.AuthTag-  -> Either String B.ByteString-decryptWithKey sa aa kek ad nonce ciphertext authTag = do-  let toHex = BC.unpack . B16.encode-      authFailure expectedTag computedTag n a hashAd plaintext =-        "failed to authenticate v6 AEAD secret key payload (expected tag=" ++-        toHex expectedTag ++-        ", computed tag=" ++-        toHex computedTag ++-        ", nonce=" ++-        toHex n ++-        ", ad=" ++-        toHex a ++-        ", hashAd=" ++-        toHex hashAd ++-        ", plaintext=" ++-        toHex plaintext ++-        ")"-      unsupportedSecretKeyAEADError = "unsupported secret-key AEAD symmetric algorithm"-  case aa of-    OCB ->-      withAESCipher-        unsupportedSecretKeyAEADError-        sa-        kek-        (\cipher -> decryptWithOCBRFC7253With authFailure cipher nonce ad ciphertext authTag)-    _ -> do-      mode <- aeadMode aa-      expectedNonceLen <- aeadNonceSize aa-      when (B.length nonce /= expectedNonceLen) $-        Left "invalid nonce size for v6 AEAD secret key payload"-      withAESCipher unsupportedSecretKeyAEADError sa kek $ \cipher ->-        first show (CE.eitherCryptoError (CCT.aeadInit mode cipher nonce)) >>= \aead ->-        maybe (Left "failed to authenticate v6 AEAD secret key payload") Right-          (CCT.aeadSimpleDecrypt aead ad ciphertext authTag)--aeadMode :: AEADAlgorithm -> Either String CCT.AEADMode-aeadMode EAX = Right CCT.AEAD_EAX-aeadMode OCB = Right CCT.AEAD_OCB-aeadMode GCM = Right CCT.AEAD_GCM-aeadMode (OtherAEADAlgo _) = Left "unknown AEAD mode"--aeadNonceSize :: AEADAlgorithm -> Either String Int-aeadNonceSize EAX = Right 16-aeadNonceSize OCB = Right 15-aeadNonceSize GCM = Right 12-aeadNonceSize (OtherAEADAlgo _) = Left "unknown AEAD nonce size"--parseSecretKeyExact :: SomePKPayload -> B.ByteString -> Either String SKey-parseSecretKeyExact pkp cleartext =-  case runGetOrFail ((,) <$> getSecretKey pkp <*> getRemainingLazyByteString) (BL.fromStrict cleartext) of-    Left (_, _, err) -> Left err-    Right (_, _, (sk, trailing))-      | BL.null trailing -> Right sk-      | otherwise -> Left "v6 AEAD secret key cleartext has trailing bytes"--keyVersionByte :: KeyVersion -> Word8-keyVersionByte DeprecatedV3 = 3-keyVersionByte V4 = 4-keyVersionByte V6 = 6---- |generates pseudo-random salt and IV-encryptPrivateKey ::-     MonadRandom m-  => OpenPGPPolicy-  -> SomePKPayload-  -> SKAddendum-  -> BL.ByteString-  -> m (Either String SKAddendum)-encryptPrivateKey policy pkp ska pp = do-  nextMaterial <- generateSecretKeyProtectionMaterial policy pkp-  pure $ do-    (salt, iv) <- nextMaterial-    encryptPrivateKeyWithPolicyAndSaltAndIV policy pkp salt iv ska pp--encryptPrivateKeyWithPolicyAndSaltAndIV ::-     OpenPGPPolicy-  -> SomePKPayload-  -> Salt-  -> IV-  -> SKAddendum-  -> BL.ByteString-  -> Either String SKAddendum-encryptPrivateKeyWithPolicyAndSaltAndIV policy pkp salt iv ska pp =-  case ska of-    SUUnencrypted skey _ ->-      encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV policy pkp salt iv skey pp-    _ -> Right ska--encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV ::-     OpenPGPPolicy-  -> SomePKPayload-  -> Salt-  -> IV-  -> SKey-  -> BL.ByteString-  -> Either String SKAddendum-encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV policy pkp salt iv skey pp = do-  (sa, aa, s2k) <- secretKeyProtectionDefaults policy pkp salt iv-  (\payload -> SUSAEAD sa aa s2k iv (BL.fromStrict payload)) <$>-    encryptV6SKey pkp skey sa aa s2k iv pp--changePrivateKeyPassphrase ::-     (SomePKPayload, SKAddendum)-  -> BL.ByteString-  -> Salt-  -> IV-  -> BL.ByteString-  -> Either String SKAddendum-changePrivateKeyPassphrase (pkp, ska) oldPassphrase salt iv newPassphrase = do-  decrypted <- decryptPrivateKey (pkp, ska) oldPassphrase-  case decrypted of-    SUUnencrypted skey _ ->-      reencryptPrivateKeyWithSaltAndIV pkp ska salt iv skey newPassphrase-    _ ->-      Left-        "Unexpected codepath: decrypted private key material was not in unencrypted form"--changePrivateKeyPassphraseRandom ::-     MonadRandom m-  => (SomePKPayload, SKAddendum)-  -> BL.ByteString-  -> BL.ByteString-  -> m (Either String SKAddendum)-changePrivateKeyPassphraseRandom (pkp, ska) oldPassphrase newPassphrase = do-  nextMaterial <- generateSecretKeyProtectionMaterial defaultPolicy pkp-  pure $ do-    (salt, iv) <- nextMaterial-    changePrivateKeyPassphrase-      (pkp, ska)-      oldPassphrase-      salt-      iv-      newPassphrase--changeSecretKeyPassphrase ::-     SecretKey-  -> BL.ByteString-  -> Salt-  -> IV-  -> BL.ByteString-  -> Either String SecretKey-changeSecretKeyPassphrase sk oldPassphrase salt iv newPassphrase = do-  ska <--    changePrivateKeyPassphrase-      (_secretKeyPKPayload sk, _secretKeySKAddendum sk)-      oldPassphrase-      salt-      iv-      newPassphrase-  return sk {_secretKeySKAddendum = ska}--changeSecretKeyPassphraseRandom ::-     MonadRandom m-  => SecretKey-  -> BL.ByteString-  -> BL.ByteString-  -> m (Either String SecretKey)-changeSecretKeyPassphraseRandom sk oldPassphrase newPassphrase = do-  nextSKA <--    changePrivateKeyPassphraseRandom-      (_secretKeyPKPayload sk, _secretKeySKAddendum sk)-      oldPassphrase-      newPassphrase-  pure ((\ska -> sk {_secretKeySKAddendum = ska}) <$> nextSKA)--encodeSKeyMaterial :: SKey -> Either String BL.ByteString-encodeSKeyMaterial keyMaterial =-  case keyMaterial of-    RSAPrivateKey (RSA_PrivateKey (R.PrivateKey _ d p q _ _ _)) ->-      case inverse p q of-        Nothing ->-          Left-            "could not derive RSA multiplicative inverse while encrypting secret key"-        Just u -> Right (runPut (put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u)))-    DSAPrivateKey (DSA_PrivateKey (DSA.PrivateKey _ x)) ->-      Right (runPut (put (MPI x)))-    ElGamalPrivateKey x ->-      Right (runPut (put (MPI x)))-    ECDHPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey _ d)) ->-      Right (runPut (put (MPI d)))-    ECDSAPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey _ d)) ->-      Right (runPut (put (MPI d)))-    EdDSAPrivateKey _ bs ->-      Right (runPut (put (MPI (os2ip bs))))-    X25519PrivateKey bs ->-      Right (runPut (putByteString bs))-    X448PrivateKey bs ->-      Right (runPut (putByteString bs))-    UnknownSKey bs ->-      Right (runPut (putLazyByteString bs))--encryptV6SKey :: SomePKPayload-  -> SKey-  -> SymmetricAlgorithm-  -> AEADAlgorithm-  -> S2K-  -> IV-  -> BL.ByteString-  -> Either String B.ByteString-encryptV6SKey pkp skey sa aa s2k iv pp = do-  keyLen <- first renderCipherError (keySize sa)-  keyMaterial <- first renderS2KError (string2Key s2k keyLen pp)-  payload <- encodeSKeyMaterial skey-  let info = B.pack [0xC5, keyVersionByte (_keyVersion pkp), fromFVal sa, fromFVal aa]-      ad = B.cons 0xC5 (BL.toStrict (runPut (put pkp)))-      prk = extract @CHA.SHA256 B.empty keyMaterial-      kek = expand @CHA.SHA256 prk info keyLen :: B.ByteString-  (tag, ciphertext) <- encryptWithKey sa aa kek ad (unIV iv) (BL.toStrict payload)-  pure (ciphertext <> BA.convert (CCT.unAuthTag tag))--secretKeyProtectionMaterialLengths :: OpenPGPPolicy -> SomePKPayload -> Either String (Int, Int)-secretKeyProtectionMaterialLengths policy pkp =-  case secretKeyProtectionPolicyForEncryption policy (_keyVersion pkp) of-    Just policy ->-      Right (secretKeyS2KSaltOctets policy, secretKeyAEADNonceOctets policy)-    Nothing -> Left legacySecretKeyProtectionErrorMessage--generateSecretKeyProtectionMaterial ::-     MonadRandom m-  => OpenPGPPolicy-  -> SomePKPayload-  -> m (Either String (Salt, IV))-generateSecretKeyProtectionMaterial policy pkp =-  case secretKeyProtectionMaterialLengths policy pkp of-    Left err -> pure (Left err)-    Right (saltLen, nonceLen) -> do-      entropy <- getRandomBytes (saltLen + nonceLen)-      let (saltBytes, ivBytes) = B.splitAt saltLen entropy-      pure (Right (Salt saltBytes, IV ivBytes))--secretKeyProtectionDefaults ::-     OpenPGPPolicy-  -> SomePKPayload-  -> Salt-  -> IV-  -> Either String (SymmetricAlgorithm, AEADAlgorithm, S2K)-secretKeyProtectionDefaults policy pkp salt iv =-  case secretKeyProtectionPolicyForEncryption policy (_keyVersion pkp) of-    Just policy -> do-      when (B.length (unSalt salt) /= secretKeyS2KSaltOctets policy) $-        Left-          ("v6 secret key S2K salt must be " ++-           show (secretKeyS2KSaltOctets policy) ++ " octets")-      when (B.length (unIV iv) /= secretKeyAEADNonceOctets policy) $-        Left-          ("v6 secret key AEAD nonce must be " ++-           show (secretKeyAEADNonceOctets policy) ++ " octets")-      pure-        ( secretKeyDefaultSymmetricAlgorithm policy-        , secretKeyDefaultAEADAlgorithm policy-        , secretKeyDefaultS2KForSalt policy salt-        )-    Nothing -> Left legacySecretKeyProtectionErrorMessage--secretKeyProtectionPolicyForEncryption ::-     OpenPGPPolicy -> KeyVersion -> Maybe SecretKeyProtectionPolicy-secretKeyProtectionPolicyForEncryption policy V6 =-  secretKeyProtectionPolicyForKeyVersion policy V6-secretKeyProtectionPolicyForEncryption policy _-  | policyRFC policy == RFC9580 = Nothing-  | otherwise = policySecretKeyProtection policy--encryptWithKey ::-     SymmetricAlgorithm-  -> AEADAlgorithm-  -> B.ByteString-  -> B.ByteString-  -> B.ByteString-  -> B.ByteString-  -> Either String (CCT.AuthTag, B.ByteString)-encryptWithKey sa aa kek ad nonce plaintext = do-  expectedNonceLen <- aeadNonceSize aa-  when (B.length nonce /= expectedNonceLen) $-    Left "invalid nonce size for v6 AEAD secret key payload"-  let unsupportedSecretKeyAEADError = "unsupported secret-key AEAD symmetric algorithm"-  case aa of-    OCB ->-      withAESCipher-        unsupportedSecretKeyAEADError-        sa-        kek-        (\cipher -> encryptWithOCBRFC7253 cipher nonce ad plaintext)-    _ -> do-      mode <- aeadMode aa-      withAESCipher unsupportedSecretKeyAEADError sa kek $ \cipher ->-        first show (CE.eitherCryptoError (CCT.aeadInit mode cipher nonce)) >>= \aead ->-        pure (CCT.aeadSimpleEncrypt aead ad plaintext 16)--reencryptSecretKeyRandomEither ::-     MonadRandom m => SecretKey -> BL.ByteString -> m (Either String SecretKey)-reencryptSecretKeyRandomEither sk pp =-  changeSecretKeyPassphraseRandom sk pp pp---- | Version-preserving re-encryption of a typed secret-key addendum.------ Each constructor family is re-encrypted in kind:---   * V6 variants (AEAD, SHA1, Sym, Unencrypted) → SKAAEADV6 (default v6 policy)---   * SKA16bit / SKASHA1Legacy → same S2K family with updated salt---   * SKAAEADLegacy → re-protected as SKASHA1Legacy (standard v3\/v4 S2K)---   * SKASymLegacy → legacy CFB re-encryption as SKASymLegacy---   * SKAUnencryptedLegacy → Left (cannot re-encrypt unencrypted legacy keys)-reencryptPrivateKeyTyped-  :: SomePKPayload-  -> SKAddendumV v-  -> Salt-  -> IV-  -> SKey-  -> BL.ByteString-  -> Either String (SKAddendumV v)-reencryptPrivateKeyTyped pkp skaV salt iv skey pp =-  case skaV of-    SKAAEADV6 {}        -> reencryptV6-    SKASHA1V6 {}        -> reencryptV6-    SKASymV6 {}         -> reencryptV6-    SKAUnencryptedV6 {} -> reencryptV6-    SKA16bit sa s2k _ _ ->-      reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k $ \sa' s2k' iv' ct km ->-        encryptProtectedSecretKey sa' s2k' iv' ct km checksum16Trailer (SKA16bit sa' s2k' iv')-    SKASHA1Legacy sa s2k _ _ ->-      reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k $ \sa' s2k' iv' ct km ->-        encryptProtectedSecretKey sa' s2k' iv' ct km sha1Trailer (SKASHA1Legacy sa' s2k' iv')-    SKAAEADLegacy sa _aa s2k _ _ ->-      reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k $ \sa' s2k' iv' ct km ->-        encryptProtectedSecretKey sa' s2k' iv' ct km sha1Trailer (SKASHA1Legacy sa' s2k' iv')-    SKASymLegacy sa _ _ -> do-      keyLen <- first renderCipherError (keySize sa)-      keyMaterial <- first renderS2KError (string2Key (Simple DeprecatedMD5) keyLen pp)-      cleartext <- legacySecretKeyPayload pkp skey-      let clearWithChecksum =-            BL.toStrict-              (cleartext <> runPut (putWord16be (checksum16 (BL.toStrict cleartext))))-      (\encrypted -> SKASymLegacy sa iv (BL.fromStrict encrypted)) <$>-        first renderCipherError (encryptNoNonce sa (Simple DeprecatedMD5) iv clearWithChecksum keyMaterial)-    SKAUnencryptedLegacy _ _ -> Left legacySecretKeyProtectionErrorMessage-  where-    reencryptV6 = do-      (sa, aa, s2k) <- secretKeyProtectionDefaults defaultPolicy pkp salt iv-      (\payload -> SKAAEADV6 sa aa s2k iv (BL.fromStrict payload)) <$>-        encryptV6SKey pkp skey sa aa s2k iv pp--reencryptPrivateKeyWithSaltAndIV :: SomePKPayload-  -> SKAddendum-  -> Salt-  -> IV-  -> SKey-  -> BL.ByteString-  -> Either String SKAddendum-reencryptPrivateKeyWithSaltAndIV pkp originalSka salt iv skey pp =-  case fromSKAddendumForPKPayload pkp originalSka of-    Left err -> Left err-    Right (SomeSKAddendumV skaV) ->-      toSKAddendum <$> reencryptPrivateKeyTyped pkp skaV salt iv skey pp--reencryptS2KProtectedSecretKey :: SomePKPayload-  -> Salt-  -> IV-  -> SKey-  -> BL.ByteString-  -> SymmetricAlgorithm-  -> S2K-  -> (SymmetricAlgorithm -> S2K -> IV -> BL.ByteString -> B.ByteString -> Either String r)-  -> Either String r-reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k encryptFn = do-  keyLen <- first renderCipherError (keySize sa)-  let retargetedS2K = retargetS2K salt s2k-  keyMaterial <- first renderS2KError (string2Key retargetedS2K keyLen pp)-  cleartext <- legacySecretKeyPayload pkp skey-  encryptFn sa retargetedS2K iv cleartext keyMaterial--encryptLegacyCFBSecretKey :: SomePKPayload-  -> SymmetricAlgorithm-  -> IV-  -> SKey-  -> BL.ByteString-  -> Either String SKAddendum-encryptLegacyCFBSecretKey pkp sa iv skey pp = do-  keyLen <- first renderCipherError (keySize sa)-  keyMaterial <- first renderS2KError (string2Key (Simple DeprecatedMD5) keyLen pp)-  cleartext <- legacySecretKeyPayload pkp skey-  let clearWithChecksum =-        BL.toStrict (cleartext <> runPut (putWord16be (checksum16 (BL.toStrict cleartext))))-  (\encrypted -> SUSym sa iv (BL.fromStrict encrypted)) <$>-    first renderCipherError (encryptNoNonce sa (Simple DeprecatedMD5) iv clearWithChecksum keyMaterial)--encrypt16BitProtectedSecretKey ::-     SymmetricAlgorithm-  -> S2K-  -> IV-  -> BL.ByteString-  -> B.ByteString-  -> Either String SKAddendum-encrypt16BitProtectedSecretKey sa s2k iv cleartext keyMaterial =-  encryptProtectedSecretKey-    sa-    s2k-    iv-    cleartext-    keyMaterial-    checksum16Trailer-    (\payload -> SUS16bit sa s2k iv payload)--encryptSHA1ProtectedSecretKey ::-     SymmetricAlgorithm-  -> S2K-  -> IV-  -> BL.ByteString-  -> B.ByteString-  -> Either String SKAddendum-encryptSHA1ProtectedSecretKey sa s2k iv cleartext keyMaterial =-  encryptProtectedSecretKey-    sa-    s2k-    iv-    cleartext-    keyMaterial-    sha1Trailer-    (\payload -> SUSSHA1 sa s2k iv payload)--encryptProtectedSecretKey ::-     SymmetricAlgorithm-  -> S2K-  -> IV-  -> BL.ByteString-  -> B.ByteString-  -> (BL.ByteString -> BL.ByteString)-  -> (BL.ByteString -> r)-  -> Either String r-encryptProtectedSecretKey sa s2k iv cleartext keyMaterial checksumTrailer mkAddendum = do-  let clearWithChecksum = BL.toStrict (cleartext <> checksumTrailer cleartext)-  encrypted <- first renderCipherError (encryptNoNonce sa s2k iv clearWithChecksum keyMaterial)-  pure (mkAddendum (BL.fromStrict encrypted))--checksum16Trailer :: BL.ByteString -> BL.ByteString-checksum16Trailer cleartext =-  runPut (putWord16be (checksum16 (BL.toStrict cleartext)))--sha1Trailer :: BL.ByteString -> BL.ByteString-sha1Trailer cleartext =-  BL.fromStrict (BA.convert (CH.hash (BL.toStrict cleartext) :: CH.Digest CH.SHA1))--legacySecretKeyPayload :: SomePKPayload -> SKey -> Either String BL.ByteString-legacySecretKeyPayload pkp skey =-  runPut <$> putSKeyForPKPayload pkp skey--retargetS2K :: Salt -> S2K -> S2K-retargetS2K salt (Salted ha oldSalt) =-  maybe (Salted ha oldSalt) (Salted ha) (salt8FromSalt salt)-retargetS2K salt (IteratedSalted ha oldSalt cnt) =-  maybe (IteratedSalted ha oldSalt cnt) (\salt8 -> IteratedSalted ha salt8 cnt) (salt8FromSalt salt)+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE TypeApplications #-}++module Codec.Encryption.OpenPGP.SecretKey+    ( decryptPrivateKey+    , reinterpretUnknownSKeyForPKPayload+    , mkUnencryptedSKAddendum+    , encryptPrivateKeyWithPolicyAndSaltAndIV+    , encryptPrivateKey+    , changePrivateKeyPassphrase+    , changePrivateKeyPassphraseRandom+    , reencryptSecretKeyRandomEither+    , reencryptPrivateKeyTyped+    , SecretKeyError (..)+    , SecretKeyEncryptOptions (..)+    , decryptSecretKey+    , decryptSecretKeyAddendum+    , encryptSecretKey+    , encryptSecretKeyWithPolicy+    , reencryptSecretKey+    , reencryptSecretKeyRandom+    , changeSecretKeyPassphrase+    ) where++import Control.Monad (when)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except+    ( ExceptT+    , except+    , runExceptT+    , throwE+    )+import qualified Crypto.Error as CE+import qualified Crypto.Hash as CH+import qualified Crypto.Hash.Algorithms as CHA+import Crypto.KDF.HKDF (expand, extract)+import Crypto.Number.ModArithmetic (inverse)+import Crypto.Number.Serialize (os2ip)+import qualified Crypto.PubKey.DSA as DSA+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA+import qualified Crypto.PubKey.RSA as R+import Crypto.Random.Types (MonadRandom, getRandomBytes)+import Data.Bifunctor (bimap, first)+import Data.Binary (put)+import Data.Binary.Get+    ( getRemainingLazyByteString+    , getWord16be+    , runGetOrFail+    )+import Data.Binary.Put+    ( Put+    , putByteString+    , putLazyByteString+    , putWord16be+    , runPut+    )+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B+import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL+import Data.List (nub)+import Data.Word (Word16, Word8)+import qualified "crypton" Crypto.Cipher.Types as CCT++import Codec.Encryption.OpenPGP.BlockCipher+    ( keySize+    , renderCipherError+    )+import Codec.Encryption.OpenPGP.CFB+    ( decryptNoNonce+    , encryptNoNonce+    )+import Codec.Encryption.OpenPGP.Internal.CryptoAES+    ( withAESCipher+    )+import Codec.Encryption.OpenPGP.Internal.RFC7253OCB+    ( decryptWithOCBRFC7253With+    , encryptWithOCBRFC7253+    )+import Codec.Encryption.OpenPGP.Policy+    ( OpenPGPPolicy (..)+    , OpenPGPRFC (..)+    , SecretKeyProtectionPolicy+    , defaultPolicy+    , legacySecretKeyProtectionErrorMessage+    , secretKeyAEADNonceOctets+    , secretKeyDefaultAEADAlgorithm+    , secretKeyDefaultS2KForSalt+    , secretKeyDefaultSymmetricAlgorithm+    , secretKeyProtectionPolicyForKeyVersion+    , secretKeyS2KSaltOctets+    )+import Codec.Encryption.OpenPGP.S2K+    ( renderS2KError+    , skesk2Key+    , string2Key+    )+import Codec.Encryption.OpenPGP.Serialize+    ( getSecretKey+    , putSKeyForPKPayload+    )+import Codec.Encryption.OpenPGP.Types+import Codec.Encryption.OpenPGP.Types.Internal.Base+    ( Passphrase (..)+    )++data SecretKeyError+    = SecretKeyDecryptError String+    | SecretKeyEncryptError String+    | SecretKeyPolicyError String+    | SecretKeyUnsupportedLegacyProtection+    deriving (Eq, Show)++data SecretKeyEncryptOptions = SecretKeyEncryptOptions+    { skeoPolicy :: OpenPGPPolicy+    , skeoGenerateSaltAndIV :: Bool+    , skeoSalt :: Maybe Salt+    , skeoIV :: Maybe IV+    }++decryptPrivateKey+    :: (SomePKPayload, SKAddendum)+    -> BL.ByteString+    -> Either String SKAddendum+decryptPrivateKey (pkp, ska) pp =+    fromSKAddendumForPKPayload pkp ska >>= \case+        SomeSKAddendumV skaV -> toSKAddendum <$> decryptPrivateKeyTyped pkp skaV pp++decryptSecretKey+    :: SecretKey+    -> Passphrase+    -> Either SecretKeyError SKey+decryptSecretKey sk pp =+    decryptSecretKeyAddendum+        (_secretKeyPKPayload sk)+        (_secretKeySKAddendum sk)+        pp >>= \(skey, _) ->+        Right skey++decryptSecretKeyAddendum+    :: SomePKPayload+    -> SKAddendum+    -> Passphrase+    -> Either SecretKeyError (SKey, SKAddendum)+decryptSecretKeyAddendum pkp ska pp =+    case decryptPrivateKey (pkp, ska) (unPassphrase pp) of+        Left err -> Left $ SecretKeyDecryptError err+        Right decrypted ->+            case decrypted of+                SUUnencrypted skey _ -> Right (skey, decrypted)+                _ ->+                    Left $+                        SecretKeyDecryptError+                            "decrypted secret key material was not in unencrypted form"++encryptSecretKey+    :: MonadRandom m+    => SomePKPayload+    -> SKey+    -> Passphrase+    -> SecretKeyEncryptOptions+    -> m (Either SecretKeyError SKAddendum)+encryptSecretKey pkp skey newPassphrase opts = do+    result <- runExceptT $ do+        (salt, iv) <-+            if skeoGenerateSaltAndIV opts+                then do+                    nextMaterial <-+                        lift $ generateSecretKeyProtectionMaterial (skeoPolicy opts) pkp+                    except $ first SecretKeyPolicyError nextMaterial+                else case (skeoSalt opts, skeoIV opts) of+                    (Just salt, Just iv) -> return (salt, iv)+                    _ ->+                        throwE $+                            SecretKeyEncryptError+                                "skeoGenerateSaltAndIV is False but skeoSalt or skeoIV are Nothing"+        ska <-+            except+                (first SecretKeyEncryptError $ mkUnencryptedSKAddendum pkp skey)+        except+            ( first SecretKeyEncryptError $+                encryptPrivateKeyWithPolicyAndSaltAndIV+                    (skeoPolicy opts)+                    pkp+                    salt+                    iv+                    ska+                    (unPassphrase newPassphrase)+            )+    return result++encryptSecretKeyWithPolicy+    :: MonadRandom m+    => OpenPGPPolicy+    -> SomePKPayload+    -> SKey+    -> Passphrase+    -> m (Either SecretKeyError SKAddendum)+encryptSecretKeyWithPolicy policy pkp skey pp = do+    encryptSecretKey+        pkp+        skey+        pp+        SecretKeyEncryptOptions+            { skeoPolicy = policy+            , skeoGenerateSaltAndIV = True+            , skeoSalt = Nothing+            , skeoIV = Nothing+            }++reencryptSecretKey+    :: MonadRandom m+    => SecretKey+    -> Passphrase+    -> Passphrase+    -> SecretKeyEncryptOptions+    -> m (Either SecretKeyError SecretKey)+reencryptSecretKey sk oldPassphrase newPassphrase opts = do+    result <- runExceptT $ do+        let pkp = _secretKeyPKPayload sk+            originalSka = _secretKeySKAddendum sk+        decrypted <-+            except $+                first SecretKeyDecryptError $+                    decryptPrivateKey (pkp, originalSka) (unPassphrase oldPassphrase)+        case decrypted of+            SUUnencrypted skey _ -> do+                let pp = unPassphrase newPassphrase+                (salt, iv) <-+                    if skeoGenerateSaltAndIV opts+                        then do+                            nextMaterial <-+                                lift $ generateSecretKeyProtectionMaterial (skeoPolicy opts) pkp+                            except $ first SecretKeyPolicyError nextMaterial+                        else case (skeoSalt opts, skeoIV opts) of+                            (Just salt, Just iv) -> return (salt, iv)+                            _ ->+                                throwE $+                                    SecretKeyEncryptError+                                        "skeoGenerateSaltAndIV is False but skeoSalt or skeoIV are Nothing"+                newSka <-+                    except $+                        reencryptWithPolicyAndSaltAndIV+                            pkp+                            originalSka+                            salt+                            iv+                            skey+                            pp+                            (skeoPolicy opts)+                return $ sk {_secretKeySKAddendum = newSka}+            _ ->+                throwE $+                    SecretKeyDecryptError+                        "decrypted secret key material was not in unencrypted form"+    return result++reencryptWithPolicyAndSaltAndIV+    :: SomePKPayload+    -> SKAddendum+    -> Salt+    -> IV+    -> SKey+    -> BL.ByteString+    -> OpenPGPPolicy+    -> Either SecretKeyError SKAddendum+reencryptWithPolicyAndSaltAndIV pkp originalSka salt iv skey pp policy =+    first+        SecretKeyEncryptError+        (fromSKAddendumForPKPayload pkp originalSka) >>= \case+        SomeSKAddendumV skaV ->+            first SecretKeyEncryptError $+                toSKAddendum+                    <$> reencryptPrivateKeyTypedWithPolicy+                        policy+                        pkp+                        skaV+                        salt+                        iv+                        skey+                        pp++reencryptSecretKeyRandom+    :: MonadRandom m+    => SecretKey+    -> Passphrase+    -> Passphrase+    -> OpenPGPPolicy+    -> m (Either SecretKeyError SecretKey)+reencryptSecretKeyRandom sk oldPassphrase newPassphrase policy = do+    reencryptSecretKey+        sk+        oldPassphrase+        newPassphrase+        SecretKeyEncryptOptions+            { skeoPolicy = policy+            , skeoGenerateSaltAndIV = True+            , skeoSalt = Nothing+            , skeoIV = Nothing+            }++{-# DEPRECATED+    changeSecretKeyPassphrase+    "Use reencryptSecretKey or reencryptSecretKeyRandom instead"+    #-}+changeSecretKeyPassphrase+    :: MonadRandom m+    => SecretKey+    -> Passphrase+    -> Passphrase+    -> m (Either SecretKeyError SecretKey)+changeSecretKeyPassphrase sk oldPassphrase newPassphrase =+    reencryptSecretKey+        sk+        oldPassphrase+        newPassphrase+        SecretKeyEncryptOptions+            { skeoPolicy = defaultPolicy+            , skeoGenerateSaltAndIV = True+            , skeoSalt = Nothing+            , skeoIV = Nothing+            }++decryptPrivateKeyTyped+    :: SomePKPayload+    -> SKAddendumV v+    -> BL.ByteString+    -> Either String (SKAddendumV v)+decryptPrivateKeyTyped pkp (SKA16bit sa s2k iv payload) pp = do+    (sk, cksum) <-+        decryptS2KProtectedPayload+            pkp+            sa+            s2k+            iv+            payload+            pp+            parse16BitProtectedSecretKey+    pure (SKAUnencryptedLegacy sk cksum)+decryptPrivateKeyTyped pkp (SKASHA1Legacy sa s2k iv payload) pp = do+    (sk, cksum) <-+        decryptS2KProtectedPayload+            pkp+            sa+            s2k+            iv+            payload+            pp+            parseSHA1ProtectedSecretKey+    pure (SKAUnencryptedLegacy sk cksum)+decryptPrivateKeyTyped pkp (SKASHA1V6 sa s2k iv payload) pp = do+    (sk, _) <-+        decryptS2KProtectedPayload+            pkp+            sa+            s2k+            iv+            payload+            pp+            parseSHA1ProtectedSecretKey+    pure (SKAUnencryptedV6 sk)+decryptPrivateKeyTyped pkp (SKAAEADV6 sa aa s2k iv payload) pp = do+    sk <- decryptAEADPayloadCore pkp sa aa s2k iv payload pp+    pure (SKAUnencryptedV6 sk)+decryptPrivateKeyTyped pkp (SKAAEADLegacy sa aa s2k iv payload) pp = do+    sk <- decryptAEADPayloadCore pkp sa aa s2k iv payload pp+    pure (SKAUnencryptedLegacy sk 0)+decryptPrivateKeyTyped pkp (SKASymLegacy sa iv payload) pp = do+    keyLen <- first renderCipherError (keySize sa)+    dek <-+        first+            renderS2KError+            (string2Key (Simple DeprecatedMD5) keyLen pp)+    p <-+        first+            renderCipherError+            (decryptNoNonce sa iv (BL.toStrict payload) dek)+    (sk, cksum) <- parse16BitProtectedSecretKey pkp p+    pure (SKAUnencryptedLegacy sk cksum)+decryptPrivateKeyTyped pkp (SKASymV6 sa iv payload) pp = do+    keyLen <- first renderCipherError (keySize sa)+    dek <-+        first+            renderS2KError+            (string2Key (Simple DeprecatedMD5) keyLen pp)+    p <-+        first+            renderCipherError+            (decryptNoNonce sa iv (BL.toStrict payload) dek)+    (sk, _) <- parse16BitProtectedSecretKey pkp p+    pure (SKAUnencryptedV6 sk)+decryptPrivateKeyTyped _ ska@(SKAUnencryptedLegacy {}) _ = Right ska+decryptPrivateKeyTyped _ ska@(SKAUnencryptedV6 {}) _ = Right ska++reinterpretUnknownSKeyForPKPayload+    :: SomePKPayload -> SKey -> Either String SKey+reinterpretUnknownSKeyForPKPayload _ sk@RSAPrivateKey {} = Right sk+reinterpretUnknownSKeyForPKPayload _ sk@DSAPrivateKey {} = Right sk+reinterpretUnknownSKeyForPKPayload _ sk@ElGamalPrivateKey {} = Right sk+reinterpretUnknownSKeyForPKPayload _ sk@ECDHPrivateKey {} = Right sk+reinterpretUnknownSKeyForPKPayload _ sk@ECDSAPrivateKey {} = Right sk+reinterpretUnknownSKeyForPKPayload _ sk@EdDSAPrivateKey {} = Right sk+reinterpretUnknownSKeyForPKPayload _ sk@X25519PrivateKey {} = Right sk+reinterpretUnknownSKeyForPKPayload _ sk@X448PrivateKey {} = Right sk+reinterpretUnknownSKeyForPKPayload pkp (UnknownSKey payload) =+    case runGetOrFail+        ((,) <$> getSecretKey pkp <*> getRemainingLazyByteString)+        payload of+        Left (_, _, err) -> Left err+        Right (_, _, (skey, trailing))+            | BL.null trailing -> Right skey+            | otherwise ->+                Left "decoded secret key material has trailing bytes"++mkUnencryptedSKAddendum+    :: SomePKPayload -> SKey -> Either String SKAddendum+mkUnencryptedSKAddendum pkp skey = do+    payload <- legacySecretKeyPayload pkp skey+    let checksum =+            case _keyVersion pkp of+                V6 -> 0+                _ -> checksum16 (BL.toStrict payload)+    pure (SUUnencrypted skey checksum)++decryptS2KProtectedPayload+    :: SomePKPayload+    -> SymmetricAlgorithm+    -> S2K+    -> IV+    -> BL.ByteString+    -> BL.ByteString+    -> (SomePKPayload -> B.ByteString -> Either String (SKey, Word16))+    -> Either String (SKey, Word16)+decryptS2KProtectedPayload pkp sa s2k iv payload pp parser = do+    dek <-+        first renderS2KError (skesk2Key (SKESK4Packet sa s2k Nothing) pp)+    decrypted <-+        first+            renderCipherError+            (decryptNoNonce sa iv (BL.toStrict payload) dek)+    parser pkp decrypted+parse16BitProtectedSecretKey+    :: SomePKPayload -> B.ByteString -> Either String (SKey, Word16)+parse16BitProtectedSecretKey pkp p+    | B.length p < 2 =+        Left "secret key payload is too short for a 16-bit checksum"+    | otherwise = do+        let (skeyPayload, checksumPayload) = B.splitAt (B.length p - 2) p+        sk <- decodeSecretKey pkp skeyPayload+        cksum <- decodeChecksum checksumPayload+        let expected = checksum16 skeyPayload+        if cksum == expected+            then Right (sk, cksum)+            else+                Left+                    ( "16-bit secret key checksum mismatch (expected "+                        ++ show expected+                        ++ ", got "+                        ++ show cksum+                        ++ ")"+                    )++parseSHA1ProtectedSecretKey+    :: SomePKPayload -> B.ByteString -> Either String (SKey, Word16)+parseSHA1ProtectedSecretKey pkp p+    | B.length p < 20 =+        Left "secret key payload is too short for a SHA1 checksum"+    | otherwise = do+        let (skeyPayload, hashPayload) = B.splitAt (B.length p - 20) p+            expected = BA.convert (CH.hash skeyPayload :: CH.Digest CH.SHA1)+        sk <- decodeSecretKey pkp skeyPayload+        if hashPayload == expected+            then Right (sk, checksum16 skeyPayload)+            else Left "SHA1 secret key checksum mismatch"++decodeSecretKey+    :: SomePKPayload -> B.ByteString -> Either String SKey+decodeSecretKey pkp payloadBytes =+    bimap+        (\(_, _, x) -> x)+        (\(_, _, x) -> x)+        (runGetOrFail (getSecretKey pkp) (BL.fromStrict payloadBytes))++decodeChecksum :: B.ByteString -> Either String Word16+decodeChecksum checksumBytes =+    bimap+        (\(_, _, x) -> x)+        (\(_, _, x) -> x)+        (runGetOrFail getWord16be (BL.fromStrict checksumBytes))+decryptAEADPayloadCore+    :: SomePKPayload+    -> SymmetricAlgorithm+    -> AEADAlgorithm+    -> S2K+    -> IV+    -> BL.ByteString+    -> BL.ByteString+    -> Either String SKey+decryptAEADPayloadCore pkp sa aa s2k iv payload pp = do+    keyLen <- first renderCipherError (keySize sa)+    keyMaterial <- first renderS2KError (string2Key s2k keyLen pp)+    let keyCandidates = [keyMaterial]+        tagCandidates = [0xC5, 0xC7, 0x94, 0x95, 0x96, 0x97, 0x9C, 0x9D, 0x9E, 0x9F]+        infoCandidates =+            nub+                [ B.pack+                    [tag, keyVersionByte (_keyVersion pkp), fromFVal sa, fromFVal aa]+                | tag <- tagCandidates+                ]+        pkpBytes = BL.toStrict (runPut (put pkp))+        adCandidates =+            nub+                [B.cons tagByte pkpBytes | tagByte <- tagCandidates]+        aaCandidates = [aa]+        nonce = unIV iv+        payloadStrict = BL.toStrict payload+        tagLen = 16+        tryDecrypt candidateKeyMaterial info ad aaTry = do+            when (B.length payloadStrict < tagLen) $+                Left "v6 AEAD secret key payload too short"+            let (ciphertext, tagBytes) = B.splitAt (B.length payloadStrict - tagLen) payloadStrict+                authTag = CCT.AuthTag (BA.convert tagBytes)+                prk = extract @CHA.SHA256 B.empty candidateKeyMaterial+                kekCandidates =+                    nub+                        [ B.take keyLen candidateKeyMaterial+                        , (expand @CHA.SHA256 prk info keyLen :: B.ByteString)+                        , (expand @CHA.SHA256 prk B.empty keyLen :: B.ByteString)+                        ]+                tryKeks = go Nothing+                  where+                    go merr [] =+                        Left $+                            "could not decrypt using any KEK candidate"+                                ++ maybe "" (\e -> " (last error: " ++ e ++ ")") merr+                    go merr (kek : ks) =+                        case decryptWithKey sa aaTry kek ad nonce ciphertext authTag of+                            Right cleartext -> Right cleartext+                            Left err -> go (Just (maybe err id merr)) ks+            tryKeks kekCandidates+        tryAll = go Nothing+          where+            go merr [] =+                Left $+                    "could not decrypt v6 AEAD secret key payload"+                        ++ maybe "" (\e -> " (last error: " ++ e ++ ")") merr+            go merr ((keyMaterialCandidate, info, ad, aaTry) : xs) =+                case tryDecrypt keyMaterialCandidate info ad aaTry of+                    Right cleartext -> Right cleartext+                    Left err -> go (Just (maybe err id merr)) xs+    cleartext <-+        tryAll+            [ (k, i, a, m)+            | k <- keyCandidates+            , i <- infoCandidates+            , a <- adCandidates+            , m <- aaCandidates+            ]+    parseSecretKeyExact pkp cleartext++checksum16 :: B.ByteString -> Word16+checksum16 =+    fromIntegral+        . B.foldl'+            (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer))+            0++decryptWithKey+    :: SymmetricAlgorithm+    -> AEADAlgorithm+    -> B.ByteString+    -> B.ByteString+    -> B.ByteString+    -> B.ByteString+    -> CCT.AuthTag+    -> Either String B.ByteString+decryptWithKey sa aa kek ad nonce ciphertext authTag = do+    let toHex = BC.unpack . B16.encode+        authFailure expectedTag computedTag n a hashAd plaintext =+            "failed to authenticate v6 AEAD secret key payload (expected tag="+                ++ toHex expectedTag+                ++ ", computed tag="+                ++ toHex computedTag+                ++ ", nonce="+                ++ toHex n+                ++ ", ad="+                ++ toHex a+                ++ ", hashAd="+                ++ toHex hashAd+                ++ ", plaintext="+                ++ toHex plaintext+                ++ ")"+        unsupportedSecretKeyAEADError = "unsupported secret-key AEAD symmetric algorithm"+    case aa of+        OCB ->+            withAESCipher+                unsupportedSecretKeyAEADError+                sa+                kek+                ( \cipher ->+                    decryptWithOCBRFC7253With+                        authFailure+                        cipher+                        nonce+                        ad+                        ciphertext+                        authTag+                )+        _ -> do+            mode <- aeadMode aa+            expectedNonceLen <- aeadNonceSize aa+            when (B.length nonce /= expectedNonceLen) $+                Left "invalid nonce size for v6 AEAD secret key payload"+            withAESCipher unsupportedSecretKeyAEADError sa kek $ \cipher ->+                first+                    show+                    (CE.eitherCryptoError (CCT.aeadInit mode cipher nonce)) >>= \aead ->+                    maybe+                        (Left "failed to authenticate v6 AEAD secret key payload")+                        Right+                        (CCT.aeadSimpleDecrypt aead ad ciphertext authTag)++aeadMode :: AEADAlgorithm -> Either String CCT.AEADMode+aeadMode EAX = Right CCT.AEAD_EAX+aeadMode OCB = Right CCT.AEAD_OCB+aeadMode GCM = Right CCT.AEAD_GCM+aeadMode (OtherAEADAlgo _) = Left "unknown AEAD mode"++aeadNonceSize :: AEADAlgorithm -> Either String Int+aeadNonceSize EAX = Right 16+aeadNonceSize OCB = Right 15+aeadNonceSize GCM = Right 12+aeadNonceSize (OtherAEADAlgo _) = Left "unknown AEAD nonce size"++parseSecretKeyExact+    :: SomePKPayload -> B.ByteString -> Either String SKey+parseSecretKeyExact pkp cleartext =+    case runGetOrFail+        ((,) <$> getSecretKey pkp <*> getRemainingLazyByteString)+        (BL.fromStrict cleartext) of+        Left (_, _, err) -> Left err+        Right (_, _, (sk, trailing))+            | BL.null trailing -> Right sk+            | otherwise ->+                Left "v6 AEAD secret key cleartext has trailing bytes"++keyVersionByte :: KeyVersion -> Word8+keyVersionByte DeprecatedV3 = 3+keyVersionByte V4 = 4+keyVersionByte V6 = 6++{-# DEPRECATED encryptPrivateKey "Use encryptSecretKeyWithPolicy instead" #-}++-- | generates pseudo-random salt and IV+encryptPrivateKey+    :: MonadRandom m+    => OpenPGPPolicy+    -> SomePKPayload+    -> SKAddendum+    -> BL.ByteString+    -> m (Either String SKAddendum)+encryptPrivateKey policy pkp ska pp = do+    nextMaterial <- generateSecretKeyProtectionMaterial policy pkp+    case nextMaterial of+        Left err -> pure $ Left err+        Right (salt, iv) ->+            pure $+                encryptPrivateKeyWithPolicyAndSaltAndIV policy pkp salt iv ska pp++encryptPrivateKeyWithPolicyAndSaltAndIV+    :: OpenPGPPolicy+    -> SomePKPayload+    -> Salt+    -> IV+    -> SKAddendum+    -> BL.ByteString+    -> Either String SKAddendum+encryptPrivateKeyWithPolicyAndSaltAndIV policy pkp salt iv ska pp =+    case ska of+        SUUnencrypted skey _ ->+            encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV+                policy+                pkp+                salt+                iv+                skey+                pp+        _ -> Right ska++encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV+    :: OpenPGPPolicy+    -> SomePKPayload+    -> Salt+    -> IV+    -> SKey+    -> BL.ByteString+    -> Either String SKAddendum+encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV policy pkp salt iv skey pp = do+    (sa, aa, s2k) <- secretKeyProtectionDefaults policy pkp salt iv+    (\payload -> SUSAEAD sa aa s2k iv (BL.fromStrict payload))+        <$> encryptV6SKey pkp skey sa aa s2k iv pp++{-# DEPRECATED changePrivateKeyPassphrase "Use reencryptSecretKey instead" #-}+changePrivateKeyPassphrase+    :: (SomePKPayload, SKAddendum)+    -> BL.ByteString+    -> Salt+    -> IV+    -> BL.ByteString+    -> Either String SKAddendum+changePrivateKeyPassphrase (pkp, ska) oldPassphrase salt iv newPassphrase = do+    decrypted <- decryptPrivateKey (pkp, ska) oldPassphrase+    case decrypted of+        SUUnencrypted skey _ ->+            reencryptPrivateKeyWithSaltAndIV+                pkp+                ska+                salt+                iv+                skey+                newPassphrase+        _ ->+            Left+                "Unexpected codepath: decrypted private key material was not in unencrypted form"++{-# DEPRECATED+    changePrivateKeyPassphraseRandom+    "Use reencryptSecretKeyRandom instead"+    #-}+changePrivateKeyPassphraseRandom+    :: MonadRandom m+    => (SomePKPayload, SKAddendum)+    -> BL.ByteString+    -> BL.ByteString+    -> m (Either String SKAddendum)+changePrivateKeyPassphraseRandom (pkp, ska) oldPassphrase newPassphrase = do+    nextMaterial <-+        generateSecretKeyProtectionMaterial defaultPolicy pkp+    case nextMaterial of+        Left err -> pure $ Left err+        Right (salt, iv) ->+            pure $+                changePrivateKeyPassphrase+                    (pkp, ska)+                    oldPassphrase+                    salt+                    iv+                    newPassphrase++encodeSKeyMaterial :: SKey -> Either String BL.ByteString+encodeSKeyMaterial keyMaterial =+    case keyMaterial of+        RSAPrivateKey (RSA_PrivateKey (R.PrivateKey _ d p q _ _ _)) ->+            case inverse p q of+                Nothing ->+                    Left+                        "could not derive RSA multiplicative inverse while encrypting secret key"+                Just u ->+                    Right+                        (runPut (put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u)))+        DSAPrivateKey (DSA_PrivateKey (DSA.PrivateKey _ x)) ->+            Right (runPut (put (MPI x)))+        ElGamalPrivateKey x ->+            Right (runPut (put (MPI x)))+        ECDHPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey _ d)) ->+            Right (runPut (put (MPI d)))+        ECDSAPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey _ d)) ->+            Right (runPut (put (MPI d)))+        EdDSAPrivateKey _ bs ->+            Right (runPut (put (MPI (os2ip bs))))+        X25519PrivateKey bs ->+            Right (runPut (putByteString bs))+        X448PrivateKey bs ->+            Right (runPut (putByteString bs))+        UnknownSKey bs ->+            Right (runPut (putLazyByteString bs))++encryptV6SKey+    :: SomePKPayload+    -> SKey+    -> SymmetricAlgorithm+    -> AEADAlgorithm+    -> S2K+    -> IV+    -> BL.ByteString+    -> Either String B.ByteString+encryptV6SKey pkp skey sa aa s2k iv pp = do+    keyLen <- first renderCipherError (keySize sa)+    keyMaterial <- first renderS2KError (string2Key s2k keyLen pp)+    payload <- encodeSKeyMaterial skey+    let info =+            B.pack+                [ 0xC5+                , keyVersionByte (_keyVersion pkp)+                , fromFVal sa+                , fromFVal aa+                ]+        ad = B.cons 0xC5 (BL.toStrict (runPut (put pkp)))+        prk = extract @CHA.SHA256 B.empty keyMaterial+        kek = expand @CHA.SHA256 prk info keyLen :: B.ByteString+    (tag, ciphertext) <-+        encryptWithKey sa aa kek ad (unIV iv) (BL.toStrict payload)+    pure (ciphertext <> BA.convert (CCT.unAuthTag tag))++secretKeyProtectionMaterialLengths+    :: OpenPGPPolicy -> SomePKPayload -> Either String (Int, Int)+secretKeyProtectionMaterialLengths policy pkp =+    case secretKeyProtectionPolicyForEncryption policy (_keyVersion pkp) of+        Just policy ->+            Right+                (secretKeyS2KSaltOctets policy, secretKeyAEADNonceOctets policy)+        Nothing -> Left legacySecretKeyProtectionErrorMessage++generateSecretKeyProtectionMaterial+    :: MonadRandom m+    => OpenPGPPolicy+    -> SomePKPayload+    -> m (Either String (Salt, IV))+generateSecretKeyProtectionMaterial policy pkp =+    case secretKeyProtectionMaterialLengths policy pkp of+        Left err -> pure (Left err)+        Right (saltLen, nonceLen) -> do+            entropy <- getRandomBytes (saltLen + nonceLen)+            let (saltBytes, ivBytes) = B.splitAt saltLen entropy+            pure (Right (Salt saltBytes, IV ivBytes))++secretKeyProtectionDefaults+    :: OpenPGPPolicy+    -> SomePKPayload+    -> Salt+    -> IV+    -> Either String (SymmetricAlgorithm, AEADAlgorithm, S2K)+secretKeyProtectionDefaults policy pkp salt iv =+    case secretKeyProtectionPolicyForEncryption policy (_keyVersion pkp) of+        Just policy -> do+            when (B.length (unSalt salt) /= secretKeyS2KSaltOctets policy) $+                Left+                    ( "v6 secret key S2K salt must be "+                        ++ show (secretKeyS2KSaltOctets policy)+                        ++ " octets"+                    )+            when (B.length (unIV iv) /= secretKeyAEADNonceOctets policy) $+                Left+                    ( "v6 secret key AEAD nonce must be "+                        ++ show (secretKeyAEADNonceOctets policy)+                        ++ " octets"+                    )+            pure+                ( secretKeyDefaultSymmetricAlgorithm policy+                , secretKeyDefaultAEADAlgorithm policy+                , secretKeyDefaultS2KForSalt policy salt+                )+        Nothing -> Left legacySecretKeyProtectionErrorMessage++secretKeyProtectionPolicyForEncryption+    :: OpenPGPPolicy -> KeyVersion -> Maybe SecretKeyProtectionPolicy+secretKeyProtectionPolicyForEncryption policy V6 =+    secretKeyProtectionPolicyForKeyVersion policy V6+secretKeyProtectionPolicyForEncryption policy _+    | policyRFC policy == RFC9580 = Nothing+    | otherwise = policySecretKeyProtection policy++encryptWithKey+    :: SymmetricAlgorithm+    -> AEADAlgorithm+    -> B.ByteString+    -> B.ByteString+    -> B.ByteString+    -> B.ByteString+    -> Either String (CCT.AuthTag, B.ByteString)+encryptWithKey sa aa kek ad nonce plaintext = do+    expectedNonceLen <- aeadNonceSize aa+    when (B.length nonce /= expectedNonceLen) $+        Left "invalid nonce size for v6 AEAD secret key payload"+    let unsupportedSecretKeyAEADError = "unsupported secret-key AEAD symmetric algorithm"+    case aa of+        OCB ->+            withAESCipher+                unsupportedSecretKeyAEADError+                sa+                kek+                (\cipher -> encryptWithOCBRFC7253 cipher nonce ad plaintext)+        _ -> do+            mode <- aeadMode aa+            withAESCipher unsupportedSecretKeyAEADError sa kek $ \cipher ->+                first+                    show+                    (CE.eitherCryptoError (CCT.aeadInit mode cipher nonce)) >>= \aead ->+                    pure (CCT.aeadSimpleEncrypt aead ad plaintext 16)++{-# DEPRECATED+    reencryptSecretKeyRandomEither+    "Use changeSecretKeyPassphrase or reencryptSecretKeyRandom instead"+    #-}+reencryptSecretKeyRandomEither+    :: MonadRandom m+    => SecretKey -> BL.ByteString -> m (Either String SecretKey)+reencryptSecretKeyRandomEither sk pp =+    reencryptSecretKeyRandom+        sk+        (Passphrase pp)+        (Passphrase pp)+        defaultPolicy+        >>= \case+            Left err -> pure $ Left $ show err+            Right sk' -> pure $ Right sk'++{- | Version-preserving re-encryption of a typed secret-key addendum.++Each constructor family is re-encrypted in kind:+  * V6 variants (AEAD, SHA1, Sym, Unencrypted) → SKAAEADV6 (default v6 policy)+  * SKA16bit / SKASHA1Legacy → same S2K family with updated salt+  * SKAAEADLegacy → re-protected as SKASHA1Legacy (standard v3\/v4 S2K)+  * SKASymLegacy → legacy CFB re-encryption as SKASymLegacy+  * SKAUnencryptedLegacy → Left (cannot re-encrypt unencrypted legacy keys)+-}+reencryptPrivateKeyTyped+    :: SomePKPayload+    -> SKAddendumV v+    -> Salt+    -> IV+    -> SKey+    -> BL.ByteString+    -> Either String (SKAddendumV v)+reencryptPrivateKeyTyped = reencryptPrivateKeyTypedWithPolicy defaultPolicy++reencryptPrivateKeyTypedWithPolicy+    :: OpenPGPPolicy+    -> SomePKPayload+    -> SKAddendumV v+    -> Salt+    -> IV+    -> SKey+    -> BL.ByteString+    -> Either String (SKAddendumV v)+reencryptPrivateKeyTypedWithPolicy policy pkp skaV salt iv skey pp =+    case skaV of+        SKAAEADV6 {} -> reencryptV6 policy+        SKASHA1V6 {} -> reencryptV6 policy+        SKASymV6 {} -> reencryptV6 policy+        SKAUnencryptedV6 {} -> reencryptV6 policy+        SKA16bit sa s2k _ _ ->+            reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k $ \sa' s2k' iv' ct km ->+                encryptProtectedSecretKey+                    sa'+                    s2k'+                    iv'+                    ct+                    km+                    checksum16Trailer+                    (SKA16bit sa' s2k' iv')+        SKASHA1Legacy sa s2k _ _ ->+            reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k $ \sa' s2k' iv' ct km ->+                encryptProtectedSecretKey+                    sa'+                    s2k'+                    iv'+                    ct+                    km+                    sha1Trailer+                    (SKASHA1Legacy sa' s2k' iv')+        SKAAEADLegacy sa _aa s2k _ _ ->+            reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k $ \sa' s2k' iv' ct km ->+                encryptProtectedSecretKey+                    sa'+                    s2k'+                    iv'+                    ct+                    km+                    sha1Trailer+                    (SKASHA1Legacy sa' s2k' iv')+        SKASymLegacy sa _ _ -> do+            keyLen <- first renderCipherError (keySize sa)+            keyMaterial <-+                first+                    renderS2KError+                    (string2Key (Simple DeprecatedMD5) keyLen pp)+            cleartext <- legacySecretKeyPayload pkp skey+            let clearWithChecksum =+                    BL.toStrict+                        ( cleartext+                            <> runPut (putWord16be (checksum16 (BL.toStrict cleartext)))+                        )+            (\encrypted -> SKASymLegacy sa iv (BL.fromStrict encrypted))+                <$> first+                    renderCipherError+                    ( encryptNoNonce+                        sa+                        (Simple DeprecatedMD5)+                        iv+                        clearWithChecksum+                        keyMaterial+                    )+        SKAUnencryptedLegacy _ _ -> Left legacySecretKeyProtectionErrorMessage+  where+    reencryptV6 pol = do+        (sa, aa, s2k) <- secretKeyProtectionDefaults pol pkp salt iv+        (\payload -> SKAAEADV6 sa aa s2k iv (BL.fromStrict payload))+            <$> encryptV6SKey pkp skey sa aa s2k iv pp++reencryptPrivateKeyWithSaltAndIV+    :: SomePKPayload+    -> SKAddendum+    -> Salt+    -> IV+    -> SKey+    -> BL.ByteString+    -> Either String SKAddendum+reencryptPrivateKeyWithSaltAndIV pkp originalSka salt iv skey pp =+    case fromSKAddendumForPKPayload pkp originalSka of+        Left err -> Left err+        Right (SomeSKAddendumV skaV) ->+            toSKAddendum+                <$> reencryptPrivateKeyTyped pkp skaV salt iv skey pp++reencryptS2KProtectedSecretKey+    :: SomePKPayload+    -> Salt+    -> IV+    -> SKey+    -> BL.ByteString+    -> SymmetricAlgorithm+    -> S2K+    -> ( SymmetricAlgorithm+         -> S2K+         -> IV+         -> BL.ByteString+         -> B.ByteString+         -> Either String r+       )+    -> Either String r+reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k encryptFn = do+    keyLen <- first renderCipherError (keySize sa)+    let retargetedS2K = retargetS2K salt s2k+    keyMaterial <-+        first renderS2KError (string2Key retargetedS2K keyLen pp)+    cleartext <- legacySecretKeyPayload pkp skey+    encryptFn sa retargetedS2K iv cleartext keyMaterial++encryptLegacyCFBSecretKey+    :: SomePKPayload+    -> SymmetricAlgorithm+    -> IV+    -> SKey+    -> BL.ByteString+    -> Either String SKAddendum+encryptLegacyCFBSecretKey pkp sa iv skey pp = do+    keyLen <- first renderCipherError (keySize sa)+    keyMaterial <-+        first+            renderS2KError+            (string2Key (Simple DeprecatedMD5) keyLen pp)+    cleartext <- legacySecretKeyPayload pkp skey+    let clearWithChecksum =+            BL.toStrict+                ( cleartext+                    <> runPut (putWord16be (checksum16 (BL.toStrict cleartext)))+                )+    (\encrypted -> SUSym sa iv (BL.fromStrict encrypted))+        <$> first+            renderCipherError+            ( encryptNoNonce+                sa+                (Simple DeprecatedMD5)+                iv+                clearWithChecksum+                keyMaterial+            )++encrypt16BitProtectedSecretKey+    :: SymmetricAlgorithm+    -> S2K+    -> IV+    -> BL.ByteString+    -> B.ByteString+    -> Either String SKAddendum+encrypt16BitProtectedSecretKey sa s2k iv cleartext keyMaterial =+    encryptProtectedSecretKey+        sa+        s2k+        iv+        cleartext+        keyMaterial+        checksum16Trailer+        (\payload -> SUS16bit sa s2k iv payload)++encryptSHA1ProtectedSecretKey+    :: SymmetricAlgorithm+    -> S2K+    -> IV+    -> BL.ByteString+    -> B.ByteString+    -> Either String SKAddendum+encryptSHA1ProtectedSecretKey sa s2k iv cleartext keyMaterial =+    encryptProtectedSecretKey+        sa+        s2k+        iv+        cleartext+        keyMaterial+        sha1Trailer+        (\payload -> SUSSHA1 sa s2k iv payload)++encryptProtectedSecretKey+    :: SymmetricAlgorithm+    -> S2K+    -> IV+    -> BL.ByteString+    -> B.ByteString+    -> (BL.ByteString -> BL.ByteString)+    -> (BL.ByteString -> r)+    -> Either String r+encryptProtectedSecretKey sa s2k iv cleartext keyMaterial checksumTrailer mkAddendum = do+    let clearWithChecksum = BL.toStrict (cleartext <> checksumTrailer cleartext)+    encrypted <-+        first+            renderCipherError+            (encryptNoNonce sa s2k iv clearWithChecksum keyMaterial)+    pure (mkAddendum (BL.fromStrict encrypted))++checksum16Trailer :: BL.ByteString -> BL.ByteString+checksum16Trailer cleartext =+    runPut (putWord16be (checksum16 (BL.toStrict cleartext)))++sha1Trailer :: BL.ByteString -> BL.ByteString+sha1Trailer cleartext =+    BL.fromStrict+        (BA.convert (CH.hash (BL.toStrict cleartext) :: CH.Digest CH.SHA1))++legacySecretKeyPayload+    :: SomePKPayload -> SKey -> Either String BL.ByteString+legacySecretKeyPayload pkp skey =+    runPut <$> putSKeyForPKPayload pkp skey++retargetS2K :: Salt -> S2K -> S2K+retargetS2K salt (Salted ha oldSalt) =+    maybe (Salted ha oldSalt) (Salted ha) (salt8FromSalt salt)+retargetS2K salt (IteratedSalted ha oldSalt cnt) =+    maybe+        (IteratedSalted ha oldSalt cnt)+        (\salt8 -> IteratedSalted ha salt8 cnt)+        (salt8FromSalt salt) retargetS2K _ s2k = s2k
Codec/Encryption/OpenPGP/Serialize.hs view
@@ -263,6 +263,14 @@     get = fail "Binary TKUnknown decode is not implemented"     put = putTK +instance Binary (TK k) where+    get = fail "Binary TK decode is not implemented"+    put = putTK . tkToUnknown++instance Binary SomeTK where+    get = fail "Binary SomeTK decode is not implemented"+    put = putTK . someTKToUnknown+ getSigSubPacket :: Get SigSubPacket getSigSubPacket = do     l <- fmap fromIntegral getSubPacketLength@@ -3707,11 +3715,10 @@                                 }                         pktWithSource =                             PktWithWireRep+                                (PktWithBytes raw pkt)                                 (psSource state)                                 (ByteRange (psOffset state) consumed)-                                raw                                 (psIndex state)-                                pkt                      in pktWithSource : go newState  conduitParsePktsWithWireRep@@ -3873,11 +3880,10 @@     :: WireRepRef -> ParsedPacketChunk -> PktWithWireRep toPktWithWireRep src ppc =     PktWithWireRep+        (PktWithBytes (ppcRaw ppc) (ppcValue ppc))         src         (ppcRange ppc)-        (ppcRaw ppc)         (ppcIndex ppc)-        (ppcValue ppc)  drainParsedPackets     :: Int64
Codec/Encryption/OpenPGP/Signatures.hs view
@@ -659,23 +659,8 @@     -> Maybe UTCTime     -> TK k     -> Either VerificationError (TK k)-verifyTKWith vsf mt tk = do-    verifiedUnknown <- verifyUnknownTKWith vsf mt (tkToUnknown tk)-    let typedSubkeys =-            Map.fromList [(keyPktToPkt kp, kp) | (kp, _) <- tk ^. tkSubs]-        verifiedTypedSubkeys =-            mapMaybe-                ( \(pkt, sigs) -> (\kp -> (kp, sigs)) <$> Map.lookup pkt typedSubkeys-                )-                (verifiedUnknown ^. tkuSubs)-    pure-        TK-            { _tkPrimaryKey = tk ^. tkPrimaryKey-            , _tkRevs = verifiedUnknown ^. tkuRevs-            , _tkUIDs = verifiedUnknown ^. tkuUIDs-            , _tkUAts = verifiedUnknown ^. tkuUAts-            , _tkSubs = verifiedTypedSubkeys-            }+verifyTKWith vsf mt tk =+    verifyUnknownTKWith vsf mt tk  {-# DEPRECATED verifyUnknownTKWith "Use verifyTKWith instead" #-} verifyUnknownTKWith@@ -685,26 +670,33 @@          -> Either VerificationError Verification        )     -> Maybe UTCTime-    -> TKUnknown-    -> Either VerificationError TKUnknown+    -> TK k+    -> Either VerificationError (TK k) verifyUnknownTKWith vsf mt tk = do     revokers <- checkRevokers tk     revs <- checkKeyRevocations revokers tk-    let uids = filter (not . null . snd) . checkUidSigs $ tk ^. tkuUIDs-    let uats = filter (not . null . snd) . checkUAtSigs $ tk ^. tkuUAts-    let subs = concatMap checkSub $ tk ^. tkuSubs-    return (TKUnknown (tk ^. tkuKey) revs uids uats subs)+    let uids = filter (not . null . snd) . checkUidSigs $ tk ^. tkUIDs+    let uats = filter (not . null . snd) . checkUAtSigs $ tk ^. tkUAts+    let subs = concatMap checkSub $ tk ^. tkSubs+    return+        TK+            { _tkPrimaryKey = tk ^. tkPrimaryKey+            , _tkRevs = revs+            , _tkUIDs = uids+            , _tkUAts = uats+            , _tkSubs = subs+            }   where-    checkRevokers =+    checkRevokers tk =         Right             . concat             . rights             . map verifyRevoker             . filter isRevokerP-            . _tkuRevs+            $ tk ^. tkRevs     checkKeyRevocations         :: [(PubKeyAlgorithm, Fingerprint)]-        -> TKUnknown+        -> TK k         -> Either VerificationError [SignaturePayload]     checkKeyRevocations rs k =         Prelude.sequence@@ -712,7 +704,7 @@             . rights             . map (liftM2 fmap (,) vSig)             $ k-                ^. tkuRevs+                ^. tkRevs     checkUidSigs         :: [(Text, [SignaturePayload])] -> [(Text, [SignaturePayload])]     checkUidSigs =@@ -731,17 +723,20 @@                  in (uat, retainNonRevokedCertifications mt verified)             )     checkSub-        :: (Pkt, [SignaturePayload]) -> [(Pkt, [SignaturePayload])]+        :: (KeyPkt k, [SignaturePayload])+        -> [(KeyPkt k, [SignaturePayload])]     checkSub (pkt, sps) =         if revokedSub pkt sps             then []             else checkSub' pkt sps-    revokedSub :: Pkt -> [SignaturePayload] -> Bool+    revokedSub :: KeyPkt k -> [SignaturePayload] -> Bool     revokedSub _ [] = False     revokedSub p sigs =         any (vSubSig p) (filter subkeyRevocationEffective sigs)     checkSub'-        :: Pkt -> [SignaturePayload] -> [(Pkt, [SignaturePayload])]+        :: KeyPkt k+        -> [SignaturePayload]+        -> [(KeyPkt k, [SignaturePayload])]     checkSub' p sps =         let goodsigs =                 filter (vSubSig p)@@ -765,7 +760,7 @@                 | isV4OrV6Sig s                 , sigType s == Just KeyRevocationSig                 , Just pka <- sigPKA s ->-                    if (v ^. verificationSigner == tk ^. tkuKey . _1)+                    if (v ^. verificationSigner == keyPktPKPayload (tk ^. tkPrimaryKey))                         || any                             ( \(p, f) ->                                 p == pka && f == fingerprint (v ^. verificationSigner)@@ -784,7 +779,7 @@         vsf             (SignaturePkt sp)             emptyPSC-                { lastPrimaryKey = PublicKeyPkt (tk ^. tkuKey . _1)+                { lastPrimaryKey = keyPktToPkt (tk ^. tkPrimaryKey)                 , lastUIDorUAt = UserIdPkt uid                 }             Nothing@@ -795,7 +790,7 @@         vsf             (SignaturePkt sp)             emptyPSC-                { lastPrimaryKey = PublicKeyPkt (tk ^. tkuKey . _1)+                { lastPrimaryKey = keyPktToPkt (tk ^. tkPrimaryKey)                 , lastUIDorUAt = UserAttributePkt uat                 }             Nothing@@ -803,16 +798,16 @@     vSig sp =         vsf             (SignaturePkt sp)-            emptyPSC {lastPrimaryKey = PublicKeyPkt (tk ^. tkuKey . _1)}+            emptyPSC {lastPrimaryKey = keyPktToPkt (tk ^. tkPrimaryKey)}             Nothing-    vSubSig :: Pkt -> SignaturePayload -> Bool+    vSubSig :: KeyPkt k -> SignaturePayload -> Bool     vSubSig sk sp =         isRight             ( vsf                 (SignaturePkt sp)                 emptyPSC-                    { lastPrimaryKey = PublicKeyPkt (tk ^. tkuKey . _1)-                    , lastSubkey = sk+                    { lastPrimaryKey = keyPktToPkt (tk ^. tkPrimaryKey)+                    , lastSubkey = keyPktToPkt sk                     }                 mt             )@@ -852,11 +847,11 @@     -> ByteString     -> Either VerificationError Verification verifyAgainstKeyring kr sig mt payload = do-    let allKeys = map tkToUnknown (IxSet.toList kr)+    let allKeys = IxSet.toList kr         signerValidationTime = signatureCreationTimeFromPacket sig         ikeys = (kr @=) <$> issuer sig         ifpkeys = (kr @=) <$> issuerFP sig-        hintedKeys = maybe [] (map tkToUnknown . IxSet.toList) (ifpkeys <|> ikeys)+        hintedKeys = maybe [] IxSet.toList (ifpkeys <|> ikeys)         hintedResult =             if null hintedKeys                 then Left MissingIssuer@@ -890,8 +885,8 @@                             Left _ -> Left hintedErr  verifyFromCandidates-    :: [TKUnknown]-    -> [TKUnknown]+    :: [TK 'PublicTK]+    -> [TK 'PublicTK]     -> Pkt     -> Maybe UTCTime     -> Maybe UTCTime@@ -924,7 +919,7 @@                 other -> other  verifyAgainstKeys-    :: [TKUnknown]+    :: [TK 'PublicTK]     -> Pkt     -> Maybe UTCTime     -> ByteString@@ -940,7 +935,7 @@ -- | Verify a signature against a list of keys with a custom verification policy. verifyAgainstKeysWithPolicy     :: VerificationPolicy-    -> [TKUnknown]+    -> [TK 'PublicTK]     -> Pkt     -> Maybe UTCTime     -> ByteString@@ -955,16 +950,16 @@                 )                 ( concatMap                     ( \x ->-                        (x ^. tkuKey . _1)-                            : mapMaybe (subkeyPKPFromPkt . fst) (_tkuSubs x)+                        keyPktPKPayload (_tkPrimaryKey x)+                            : map (keyPktPKPayload . fst) (_tkSubs x)                     )                     ks                 )         allCandidatePkps =             concatMap                 ( \x ->-                    (x ^. tkuKey . _1)-                        : mapMaybe (subkeyPKPFromPkt . fst) (_tkuSubs x)+                    keyPktPKPayload (_tkPrimaryKey x)+                        : map (keyPktPKPayload . fst) (_tkSubs x)                 )                 ks         normalizedCandidates@@ -1011,11 +1006,11 @@             pkps  resolveCandidateSignerPKPs-    :: [TKUnknown]+    :: [TK 'PublicTK]     -> Pkt     -> Maybe UTCTime     -> (SomePKPayload -> Bool)-    -> TKUnknown+    -> TK 'PublicTK     -> ([VerificationError], [SomePKPayload]) resolveCandidateSignerPKPs _ _ Nothing matchesP tk =     ([], filter matchesP (candidatePKPs tk))@@ -1044,41 +1039,41 @@                  in (lefts verifiedMatches, rights verifiedMatches)   where     timelineValidationTK pkp verifiedTK'-        | fingerprint pkp == fingerprint (tk ^. tkuKey . _1) = tk+        | fingerprint pkp+            == fingerprint (keyPktPKPayload (_tkPrimaryKey tk)) =+            tk         | otherwise = verifiedTK' -candidatePKPs :: TKUnknown -> [SomePKPayload]+candidatePKPs :: TK 'PublicTK -> [SomePKPayload] candidatePKPs tk =-    (tk ^. tkuKey . _1)-        : mapMaybe (subkeyPKPFromPkt . fst) (tk ^. tkuSubs)+    keyPktPKPayload (_tkPrimaryKey tk)+        : map (keyPktPKPayload . fst) (_tkSubs tk)  historicallyValidSigner     :: UTCTime-    -> TKUnknown+    -> TK 'PublicTK     -> SomePKPayload     -> Either VerificationError () historicallyValidSigner validationTime tk pkp-    | fingerprint pkp == fingerprint (tk ^. tkuKey . _1) =+    | fingerprint pkp+        == fingerprint (keyPktPKPayload (_tkPrimaryKey tk)) =         if keyStateValid (keyStateAt validationTime tk)             then Right ()             else verificationError SigningKeyUnavailableAtSignatureTime     | otherwise =         case find-            ( \(pkt, _) ->-                maybe-                    False-                    ((== fingerprint pkp) . fingerprint)-                    (subkeyPKPFromPkt pkt)+            ( \(kp, _) ->+                fingerprint (keyPktPKPayload kp) == fingerprint pkp             )-            (tk ^. tkuSubs) of+            (_tkSubs tk) of             Nothing -> verificationError SigningKeyUnavailableAtSignatureTime-            Just (subPkt, sigs) ->-                case subkeyPKPFromPkt subPkt of-                    Nothing -> verificationError SigningKeyUnavailableAtSignatureTime-                    Just subPKP ->-                        if isPKTimeValidWithSelfSignatures validationTime subPKP sigs-                            then Right ()-                            else verificationError SigningKeyUnavailableAtSignatureTime+            Just (subKp, sigs) ->+                if isPKTimeValidWithSelfSignatures+                    validationTime+                    (keyPktPKPayload subKp)+                    sigs+                    then Right ()+                    else verificationError SigningKeyUnavailableAtSignatureTime  signatureCreationTimeFromPacket :: Pkt -> Maybe UTCTime signatureCreationTimeFromPacket (SignaturePkt sigPayload) = signatureCreationTime sigPayload
Codec/Encryption/OpenPGP/Types/Internal/Base.hs view
@@ -116,6 +116,7 @@     , mkNotationFlag     , SpacedFingerprint (..)     , ImageFormat (..)+    , Passphrase (..)     ) where  import Control.Applicative ((<|>))@@ -2057,3 +2058,6 @@     { unBlock :: [a]     } -- intentionally not encoded as a list length prefix     deriving (Eq, Show)++newtype Passphrase = Passphrase {unPassphrase :: BL.ByteString}+    deriving (Eq, Ord, Show)
Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs view
@@ -234,16 +234,42 @@     | BrokenPacketPkt String Word8 ByteString     deriving (Data, Eq, Generic, Show, Typeable) +data PktWithBytes+    = PktWithBytes+    { _pktRaw :: ByteString+    , _pktValue :: Pkt+    }+    deriving (Data, Eq, Generic, Show, Typeable)++instance Ord PktWithBytes where+    compare p1 p2 = comparing _pktValue p1 p2 <> comparing _pktRaw p1 p2++instance Hashable PktWithBytes+ data PktWithWireRep     = PktWithWireRep-    { _pktWireRepRef :: WireRepRef+    { _pktWireRep :: PktWithBytes+    , _pktWireRepRef :: WireRepRef     , _pktRange :: ByteRange-    , _pktRaw :: ByteString     , _pktIndex :: Int-    , _pktValue :: Pkt     }     deriving (Data, Eq, Generic, Show, Typeable) +instance Ord PktWithWireRep where+    compare p1 p2 =+        comparing (\p -> _pktValue (_pktWireRep p)) p1 p2+            <> comparing (\p -> _pktRaw (_pktWireRep p)) p1 p2+            <> comparing _pktWireRepRef p1 p2+            <> comparing _pktRange p1 p2+            <> comparing _pktIndex p1 p2++wireRepOfPkt :: PktWithWireRep -> WireRepRef+wireRepOfPkt = _pktWireRepRef++packetsFromWireRep+    :: WireRepRef -> [PktWithWireRep] -> [PktWithWireRep]+packetsFromWireRep src = filter ((== src) . wireRepOfPkt)+ instance Hashable Pkt  instance Ord Pkt where@@ -279,21 +305,6 @@             compare s1 s2 <> compare t1 t2 <> compare bs1 bs2         compareFields _ _ = EQ -instance Ord PktWithWireRep where-    compare p1 p2 =-        comparing _pktValue p1 p2-            <> comparing _pktRaw p1 p2-            <> comparing _pktWireRepRef p1 p2-            <> comparing _pktRange p1 p2-            <> comparing _pktIndex p1 p2--wireRepOfPkt :: PktWithWireRep -> WireRepRef-wireRepOfPkt = _pktWireRepRef--packetsFromWireRep-    :: WireRepRef -> [PktWithWireRep] -> [PktWithWireRep]-packetsFromWireRep src = filter ((== src) . wireRepOfPkt)- instance Pretty Pkt where     pretty (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 pv eoki pka mpis))) =         pretty "PKESK v"@@ -714,4 +725,5 @@  $(makeLenses ''Verification) $(makeLenses ''SOPVVerification)+$(makeLenses ''PktWithBytes) $(makeLenses ''PktWithWireRep)
Codec/Encryption/OpenPGP/Types/Internal/TK.hs view
@@ -2,13 +2,13 @@ -- Copyright © 2012-2026  Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}@@ -16,127 +16,163 @@  module Codec.Encryption.OpenPGP.Types.Internal.TK where -import GHC.Generics (Generic)--import Codec.Encryption.OpenPGP.Types.Internal.Base-import Codec.Encryption.OpenPGP.Types.Internal.PKITypes-import Codec.Encryption.OpenPGP.Types.Internal.Pkt- import Control.Arrow ((&&&))-import Data.Bifunctor (first)-import Control.Lens (makeLenses)+import Control.Comonad (Comonad (..))+import Control.Lens+    ( folded+    , makeLenses+    , to+    , view+    , (^.)+    , (^..)+    , _1+    ) import qualified Data.Aeson.TH as ATH+import Data.Bifunctor (first) import qualified Data.ByteString.Lazy as BL import Data.Data (Data)+import Data.Function (on)+import qualified Data.HashMap.Lazy as HashMap import Data.IxSet.Typed (IxSet) import qualified Data.IxSet.Typed as IxSet import Data.Kind (Type)-import Data.List (sortOn)+import Data.List (find, nub, sort, sortOn) import qualified Data.List.NonEmpty as NE+import qualified Data.Map as Map import Data.Ord (comparing)+import Data.Semigroup (Semigroup (..)) import Data.Text (Text) import Data.Typeable (Typeable) import Data.Word (Word8)+import GHC.Generics (Generic) +import Codec.Encryption.OpenPGP.Types.Internal.Base+import Codec.Encryption.OpenPGP.Types.Internal.PKITypes+import Codec.Encryption.OpenPGP.Types.Internal.Pkt+ -- | Zipper for navigating a list of packets with position context-data PacketZipper =-  PacketZipper-    { _zpBefore :: [PktWithWireRep]  -- packets consumed before focus-    , _zpCurrent :: PktWithWireRep    -- current packet under focus-    , _zpAfter :: [PktWithWireRep]   -- packets remaining after focus+data PacketZipper a+    = PacketZipper+    { _zpBefore :: [a] -- packets consumed before focus+    , _zpCurrent :: a -- current packet under focus+    , _zpAfter :: [a] -- packets remaining after focus     }-  deriving (Data, Eq, Generic, Ord, Show, Typeable)+    deriving (Data, Eq, Functor, Generic, Show, Typeable) +instance Comonad PacketZipper where+    -- Extract: read the packet currently under focus+    extract (PacketZipper _ cur _) = cur++    -- Duplicate: produce a zipper-of-zippers,+    -- each focused on a different position in the original stream.+    duplicate z@(PacketZipper before cur after) =+        PacketZipper+            [ PacketZipper+                (take i before)+                (before !! i)+                (drop (i + 1) before ++ [cur] ++ after)+            | i <- [0 .. length before - 1]+            ]+            z+            [ PacketZipper+                (before ++ [cur] ++ take i after)+                (after !! i)+                (drop (i + 1) after)+            | i <- [0 .. length after - 1]+            ]+ -- | Create a zipper from a list, starting at the first element-zFromList :: [PktWithWireRep] -> Maybe PacketZipper+zFromList :: [a] -> Maybe (PacketZipper a) zFromList [] = Nothing-zFromList (x:xs) = Just (PacketZipper [] x xs)+zFromList (x : xs) = Just (PacketZipper [] x xs)  -- | Extract position in packet sequence-zPosition :: PacketZipper -> Int+zPosition :: PacketZipper a -> Int zPosition (PacketZipper before _ _) = length before  -- | Move to the next packet in the sequence-zMoveNext :: PacketZipper -> Maybe PacketZipper+zMoveNext :: PacketZipper a -> Maybe (PacketZipper a) zMoveNext (PacketZipper before current []) = Nothing-zMoveNext (PacketZipper before current (x:xs)) =-  Just (PacketZipper (before ++ [current]) x xs)+zMoveNext (PacketZipper before current (x : xs)) =+    Just (PacketZipper (before ++ [current]) x xs)  -- | Get the remaining packets (current + after)-zRemaining :: PacketZipper -> [PktWithWireRep]+zRemaining :: PacketZipper a -> [a] zRemaining (PacketZipper _ current after) = current : after  -- | Reconstruct the full list from a zipper-zToList :: PacketZipper -> [PktWithWireRep]+zToList :: PacketZipper a -> [a] zToList (PacketZipper before current after) = before ++ [current] ++ after -data TKUnknown =-  TKUnknown+data TKUnknown+    = TKUnknown     { _tkuKey :: (SomePKPayload, Maybe SKAddendum)     , _tkuRevs :: [SignaturePayload]     , _tkuUIDs :: [(Text, [SignaturePayload])]     , _tkuUAts :: [([UserAttrSubPacket], [SignaturePayload])]     , _tkuSubs :: [(Pkt, [SignaturePayload])]     }-  deriving (Data, Eq, Generic, Show, Typeable)+    deriving (Data, Eq, Generic, Show, Typeable)  data TKKind-  = PublicTK-  | SecretTK-  deriving (Data, Eq, Generic, Ord, Show, Typeable)+    = PublicTK+    | SecretTK+    deriving (Data, Eq, Generic, Ord, Show, Typeable)  type family TKKindToKeyPktKind (k :: TKKind) :: KeyPktKind where-  TKKindToKeyPktKind 'PublicTK = 'PublicPkt-  TKKindToKeyPktKind 'SecretTK = 'SecretPkt+    TKKindToKeyPktKind 'PublicTK = 'PublicPkt+    TKKindToKeyPktKind 'SecretTK = 'SecretPkt -data TK (k :: TKKind) =-  TK+data TK (k :: TKKind)+    = TK     { _tkPrimaryKey :: KeyPkt (TKKindToKeyPktKind k)     , _tkRevs :: [SignaturePayload]     , _tkUIDs :: [(Text, [SignaturePayload])]     , _tkUAts :: [([UserAttrSubPacket], [SignaturePayload])]     , _tkSubs :: [(KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])]     }-  deriving (Eq, Show)+    deriving (Eq, Show) -deriving instance (Typeable k, Data (KeyPkt (TKKindToKeyPktKind k))) => Data (TK k)+deriving instance+    (Data (KeyPkt (TKKindToKeyPktKind k)), Typeable k) => Data (TK k)  instance Ord (TK k) where-  compare = comparing _tkPrimaryKey+    compare = comparing _tkPrimaryKey  data SomeTK where-  SomePublicTK :: TK 'PublicTK -> SomeTK-  SomeSecretTK :: TK 'SecretTK -> SomeTK+    SomePublicTK :: TK 'PublicTK -> SomeTK+    SomeSecretTK :: TK 'SecretTK -> SomeTK  deriving instance Show SomeTK  instance Eq SomeTK where-  left == right = someTKToUnknown left == someTKToUnknown right+    left == right = someTKToUnknown left == someTKToUnknown right  data TKConversionError-  = PublicSubkeyHasPrimaryRole-  | SecretSubkeyHasPrimaryRole-  | ExpectedPublicSubkeyPacket Word8-  | ExpectedSecretSubkeyPacket Word8-  deriving (Eq, Show)+    = PublicSubkeyHasPrimaryRole+    | SecretSubkeyHasPrimaryRole+    | ExpectedPublicSubkeyPacket Word8+    | ExpectedSecretSubkeyPacket Word8+    deriving (Eq, Show)  renderTKConversionError :: TKConversionError -> String renderTKConversionError PublicSubkeyHasPrimaryRole = "public subkey has primary-key role" renderTKConversionError SecretSubkeyHasPrimaryRole = "secret subkey has primary-key role" renderTKConversionError (ExpectedPublicSubkeyPacket tagValue) =-  "expected public subkey, got packet tag " ++ show tagValue+    "expected public subkey, got packet tag " ++ show tagValue renderTKConversionError (ExpectedSecretSubkeyPacket tagValue) =-  "expected secret subkey, got packet tag " ++ show tagValue+    "expected secret subkey, got packet tag " ++ show tagValue  tkToUnknown :: TK k -> TKUnknown tkToUnknown tk =-  TKUnknown-    { _tkuKey = keyPktTKKey (_tkPrimaryKey tk)-    , _tkuRevs = _tkRevs tk-    , _tkuUIDs = _tkUIDs tk-    , _tkuUAts = _tkUAts tk-    , _tkuSubs = map (\(kp, sigs) -> (keyPktToPkt kp, sigs)) (_tkSubs tk)-    }+    TKUnknown+        { _tkuKey = keyPktTKKey (_tkPrimaryKey tk)+        , _tkuRevs = _tkRevs tk+        , _tkuUIDs = _tkUIDs tk+        , _tkuUAts = _tkUAts tk+        , _tkuSubs =+            map (\(kp, sigs) -> (keyPktToPkt kp, sigs)) (_tkSubs tk)+        }  someTKToUnknown :: SomeTK -> TKUnknown someTKToUnknown (SomePublicTK tk) = tkToUnknown tk@@ -144,21 +180,44 @@  mkTKUnknown :: SomePKPayload -> Maybe SKAddendum -> TKUnknown mkTKUnknown pkp maybeSka =-  TKUnknown-    { _tkuKey = (pkp, maybeSka)-    , _tkuRevs = []-    , _tkuUIDs = []-    , _tkuUAts = []-    , _tkuSubs = []-    }+    TKUnknown+        { _tkuKey = (pkp, maybeSka)+        , _tkuRevs = []+        , _tkuUIDs = []+        , _tkuUAts = []+        , _tkuSubs = []+        } -fromPrimaryKeyPktToTKUnknown :: Pkt -> Either String TKUnknown-fromPrimaryKeyPktToTKUnknown (PublicKeyPkt pkp) =-  Right (mkTKUnknown pkp Nothing)-fromPrimaryKeyPktToTKUnknown (SecretKeyPkt pkp ska) =-  Right (mkTKUnknown pkp (Just ska))-fromPrimaryKeyPktToTKUnknown pkt =-  Left ("expected primary key packet, got packet tag " ++ show (pktTag pkt))+fromPrimaryKeyPktToSomeTK :: Pkt -> Either String SomeTK+fromPrimaryKeyPktToSomeTK (PublicKeyPkt pkp) =+    Right+        ( SomePublicTK+            ( TK+                { _tkPrimaryKey = KeyPktPublicPrimary pkp+                , _tkRevs = []+                , _tkUIDs = []+                , _tkUAts = []+                , _tkSubs = []+                }+            )+        )+fromPrimaryKeyPktToSomeTK (SecretKeyPkt pkp ska) =+    Right+        ( SomeSecretTK+            ( TK+                { _tkPrimaryKey = KeyPktSecretPrimary pkp ska+                , _tkRevs = []+                , _tkUIDs = []+                , _tkUAts = []+                , _tkSubs = []+                }+            )+        )+fromPrimaryKeyPktToSomeTK pkt =+    Left+        ( "expected primary key packet, got packet tag "+            ++ show (pktTag pkt)+        )  someTKToPublicTK :: SomeTK -> Maybe (TK 'PublicTK) someTKToPublicTK (SomePublicTK tk) = Just tk@@ -174,122 +233,174 @@  publicViewTK :: TK 'SecretTK -> TK 'PublicTK publicViewTK tk =-  TK-    { _tkPrimaryKey = keyPktToPublicView (_tkPrimaryKey tk)-    , _tkRevs = _tkRevs tk-    , _tkUIDs = _tkUIDs tk-    , _tkUAts = _tkUAts tk-    , _tkSubs = map (\(kp, sigs) -> (keyPktToPublicView kp, sigs)) (_tkSubs tk)-    }+    TK+        { _tkPrimaryKey = keyPktToPublicView (_tkPrimaryKey tk)+        , _tkRevs = _tkRevs tk+        , _tkUIDs = _tkUIDs tk+        , _tkUAts = _tkUAts tk+        , _tkSubs =+            map (\(kp, sigs) -> (keyPktToPublicView kp, sigs)) (_tkSubs tk)+        } -fromUnknownToTKEither :: TKUnknown -> Either TKConversionError SomeTK+tkSomeSubs :: TK k -> [SomeKeyPkt]+tkSomeSubs tk =+    let xs = view (to _tkSubs) tk+     in xs ^.. (folded . _1 . to SomeKeyPkt)++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-              , _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-              , _tkUIDs = _tkuUIDs tk-              , _tkUAts = _tkuUAts tk-              , _tkSubs = subs-              }-      Right-        (SomeSecretTK typed)+    case _tkuKey tk of+        (pkp, Nothing) -> do+            subs <- traverse liftPublicSubkey (_tkuSubs tk)+            let typed :: TK 'PublicTK+                typed =+                    TK+                        { _tkPrimaryKey = KeyPktPublicPrimary pkp+                        , _tkRevs = _tkuRevs 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+                        , _tkUIDs = _tkuUIDs tk+                        , _tkUAts = _tkuUAts tk+                        , _tkSubs = subs+                        }+            Right+                (SomeSecretTK typed)   where-    liftPublicSubkey ::-         (Pkt, [SignaturePayload])-      -> Either TKConversionError (KeyPkt 'PublicPkt, [SignaturePayload])+    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))+        case pktToPublicKeyPkt pkt of+            Just keyPkt+                | keyPktRole keyPkt == KeyPktSubkey ->+                    Right (keyPkt, sigs)+                | otherwise ->+                    Left PublicSubkeyHasPrimaryRole+            Nothing ->+                Left (ExpectedPublicSubkeyPacket (pktTag pkt)) -    liftSecretSubkey ::-         (Pkt, [SignaturePayload])-      -> Either TKConversionError (KeyPkt 'SecretPkt, [SignaturePayload])+    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))+        case pktToSecretKeyPkt pkt of+            Just keyPkt+                | keyPktRole keyPkt == KeyPktSubkey ->+                    Right (keyPkt, sigs)+                | otherwise ->+                    Left SecretSubkeyHasPrimaryRole+            Nothing ->+                Left (ExpectedSecretSubkeyPacket (pktTag pkt))  fromUnknownToTK :: TKUnknown -> Either String SomeTK fromUnknownToTK = first renderTKConversionError . fromUnknownToTKEither -data TKWithWireRep =-  TKWithWireRep+instance Semigroup TKUnknown where+    a <> b =+        TKUnknown+            (_tkuKey a)+            (nub . sort $ _tkuRevs a ++ _tkuRevs 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 = nub . sort $ x ++ y++instance Semigroup (TK k) where+    a <> b =+        TK+            (_tkPrimaryKey a)+            (nub . sort $ _tkRevs a ++ _tkRevs b)+            ((kvmerge `on` _tkUIDs) a b)+            ((kvmerge `on` _tkUAts) a b)+            ((ukvmerge `on` _tkSubs) 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 = nub . sort $ x ++ 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     }-  deriving (Data, Eq, Generic, Ord, Show, Typeable)+    deriving (Data, Eq, Generic, Ord, Show, Typeable) -data PacketRefId =-  PacketRefId+data PacketRefId+    = PacketRefId     { _packetRefWireRepRef :: WireRepRef     , _packetRefIndex :: Int     }-  deriving (Data, Eq, Generic, Ord, Show, Typeable)+    deriving (Data, Eq, Generic, Ord, Show, Typeable) -data SignatureWithWireRef =-  SignatureWithWireRef+data SignatureWithWireRef+    = SignatureWithWireRef     { _signatureWithWireRefValue :: SignaturePayload     , _signatureWithWireRefRef :: PacketRefId     }-  deriving (Data, Eq, Generic, Ord, Show, Typeable)+    deriving (Data, Eq, Generic, Ord, Show, Typeable) -data UIDWithWireRefs =-  UIDWithWireRefs+data UIDWithWireRefs+    = UIDWithWireRefs     { _uidWithWireRefsValue :: Text     , _uidWithWireRefsRef :: PacketRefId     , _uidWithWireRefsSignatures :: [SignatureWithWireRef]     }-  deriving (Data, Eq, Generic, Ord, Show, Typeable)+    deriving (Data, Eq, Generic, Ord, Show, Typeable) -data UATWithWireRefs =-  UATWithWireRefs+data UATWithWireRefs+    = UATWithWireRefs     { _uatWithWireRefsValue :: [UserAttrSubPacket]     , _uatWithWireRefsRef :: PacketRefId     , _uatWithWireRefsSignatures :: [SignatureWithWireRef]     }-  deriving (Data, Eq, Generic, Ord, Show, Typeable)+    deriving (Data, Eq, Generic, Ord, Show, Typeable) -data SubkeyWithWireRefs =-  SubkeyWithWireRefs+data SubkeyWithWireRefs+    = SubkeyWithWireRefs     { _subkeyWithWireRefsValue :: Pkt     , _subkeyWithWireRefsRef :: PacketRefId     , _subkeyWithWireRefsSignatures :: [SignatureWithWireRef]     }-  deriving (Data, Eq, Generic, Ord, Show, Typeable)+    deriving (Data, Eq, Generic, Ord, Show, Typeable) -data TKStructuredWithWireRep =-  TKStructuredWithWireRep+data TKStructuredWithWireRep+    = TKStructuredWithWireRep     { _tkStructuredWireRepRefs :: WireRepRefs     , _tkStructuredWireRepRange :: Maybe ByteRange     , _tkStructuredPrimaryKey :: (SomePKPayload, Maybe SKAddendum)@@ -300,17 +411,17 @@     , _tkStructuredSubkeys :: [SubkeyWithWireRefs]     , _tkStructuredPacketRefs :: [PktWithWireRep]     }-  deriving (Data, Eq, Generic, Ord, Show, Typeable)+    deriving (Data, Eq, Generic, Ord, Show, Typeable)  data CanonicalizeTKWithWireRepError-  = CanonicalizeStructuringError String-  | CanonicalizeMissingPacketRef PacketRefId-  deriving (Data, Eq, Generic, Ord, Show, Typeable)+    = CanonicalizeStructuringError String+    | 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+    -- 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@@ -324,314 +435,394 @@ packetRefIdOf :: PktWithWireRep -> PacketRefId packetRefIdOf pkt = PacketRefId (_pktWireRepRef pkt) (_pktIndex pkt) -lookupPacketRef :: TKStructuredWithWireRep -> PacketRefId -> Maybe PktWithWireRep+lookupPacketRef+    :: TKStructuredWithWireRep -> PacketRefId -> Maybe PktWithWireRep lookupPacketRef structured target =-  go (_tkStructuredPacketRefs structured)-  where-    go [] = Nothing-    go (pkt:rest)-      | packetRefIdOf pkt == target = Just pkt-      | otherwise = go rest+    find+        ((== target) . packetRefIdOf)+        (_tkStructuredPacketRefs structured) -packetWireBytesForRef ::-     TKStructuredWithWireRep-  -> PacketRefId-  -> Either CanonicalizeTKWithWireRepError BL.ByteString+packetWireBytesForRef+    :: TKStructuredWithWireRep+    -> PacketRefId+    -> Either CanonicalizeTKWithWireRepError BL.ByteString packetWireBytesForRef structured refId =-  case lookupPacketRef structured refId of-    Just pkt -> Right (_pktRaw pkt)-    Nothing -> Left (CanonicalizeMissingPacketRef refId)+    case lookupPacketRef structured refId of+        Just pkt -> Right (pkt ^. pktWireRep . pktRaw)+        Nothing -> Left (CanonicalizeMissingPacketRef refId) -signatureWireSortKey ::-     TKStructuredWithWireRep-  -> SignatureWithWireRef-  -> Either CanonicalizeTKWithWireRepError (BL.ByteString, PacketRefId)+signatureWireSortKey+    :: TKStructuredWithWireRep+    -> SignatureWithWireRef+    -> Either+        CanonicalizeTKWithWireRepError+        (BL.ByteString, PacketRefId) signatureWireSortKey structured sig =-  (\raw -> (raw, _signatureWithWireRefRef sig)) <$>-  packetWireBytesForRef structured (_signatureWithWireRefRef sig)+    (\raw -> (raw, _signatureWithWireRefRef sig))+        <$> packetWireBytesForRef structured (_signatureWithWireRefRef sig) -uidWireSortKey ::-     TKStructuredWithWireRep-  -> UIDWithWireRefs-  -> Either CanonicalizeTKWithWireRepError (BL.ByteString, PacketRefId)+uidWireSortKey+    :: TKStructuredWithWireRep+    -> UIDWithWireRefs+    -> Either+        CanonicalizeTKWithWireRepError+        (BL.ByteString, PacketRefId) uidWireSortKey structured uid =-  (\raw -> (raw, _uidWithWireRefsRef uid)) <$>-  packetWireBytesForRef structured (_uidWithWireRefsRef uid)+    (\raw -> (raw, _uidWithWireRefsRef uid))+        <$> packetWireBytesForRef structured (_uidWithWireRefsRef uid) -uatWireSortKey ::-     TKStructuredWithWireRep-  -> UATWithWireRefs-  -> Either CanonicalizeTKWithWireRepError (BL.ByteString, PacketRefId)+uatWireSortKey+    :: TKStructuredWithWireRep+    -> UATWithWireRefs+    -> Either+        CanonicalizeTKWithWireRepError+        (BL.ByteString, PacketRefId) uatWireSortKey structured uat =-  (\raw -> (raw, _uatWithWireRefsRef uat)) <$>-  packetWireBytesForRef structured (_uatWithWireRefsRef uat)+    (\raw -> (raw, _uatWithWireRefsRef uat))+        <$> packetWireBytesForRef structured (_uatWithWireRefsRef uat) -subkeyWireSortKey ::-     TKStructuredWithWireRep-  -> SubkeyWithWireRefs-  -> Either CanonicalizeTKWithWireRepError (BL.ByteString, PacketRefId)+subkeyWireSortKey+    :: TKStructuredWithWireRep+    -> SubkeyWithWireRefs+    -> Either+        CanonicalizeTKWithWireRepError+        (BL.ByteString, PacketRefId) subkeyWireSortKey structured sub =-  (\raw -> (raw, _subkeyWithWireRefsRef sub)) <$>-  packetWireBytesForRef structured (_subkeyWithWireRefsRef sub)+    (\raw -> (raw, _subkeyWithWireRefsRef sub))+        <$> packetWireBytesForRef structured (_subkeyWithWireRefsRef sub) -compareSignatureWithWireRefCanonical ::-     TKStructuredWithWireRep-  -> SignatureWithWireRef-  -> SignatureWithWireRef-  -> Either CanonicalizeTKWithWireRepError Ordering+compareSignatureWithWireRefCanonical+    :: TKStructuredWithWireRep+    -> SignatureWithWireRef+    -> SignatureWithWireRef+    -> Either CanonicalizeTKWithWireRepError Ordering compareSignatureWithWireRefCanonical structured a b =-  compare <$> signatureWireSortKey structured a <*> signatureWireSortKey structured b+    compare+        <$> signatureWireSortKey structured a+        <*> signatureWireSortKey structured b -compareUIDWithWireRefsCanonical ::-     TKStructuredWithWireRep-  -> UIDWithWireRefs-  -> UIDWithWireRefs-  -> Either CanonicalizeTKWithWireRepError Ordering+compareUIDWithWireRefsCanonical+    :: TKStructuredWithWireRep+    -> UIDWithWireRefs+    -> UIDWithWireRefs+    -> Either CanonicalizeTKWithWireRepError Ordering compareUIDWithWireRefsCanonical structured a b =-  compare <$> uidWireSortKey structured a <*> uidWireSortKey structured b+    compare+        <$> uidWireSortKey structured a+        <*> uidWireSortKey structured b -compareUATWithWireRefsCanonical ::-     TKStructuredWithWireRep-  -> UATWithWireRefs-  -> UATWithWireRefs-  -> Either CanonicalizeTKWithWireRepError Ordering+compareUATWithWireRefsCanonical+    :: TKStructuredWithWireRep+    -> UATWithWireRefs+    -> UATWithWireRefs+    -> Either CanonicalizeTKWithWireRepError Ordering compareUATWithWireRefsCanonical structured a b =-  compare <$> uatWireSortKey structured a <*> uatWireSortKey structured b+    compare+        <$> uatWireSortKey structured a+        <*> uatWireSortKey structured b -compareSubkeyWithWireRefsCanonical ::-     TKStructuredWithWireRep-  -> SubkeyWithWireRefs-  -> SubkeyWithWireRefs-  -> Either CanonicalizeTKWithWireRepError Ordering+compareSubkeyWithWireRefsCanonical+    :: TKStructuredWithWireRep+    -> SubkeyWithWireRefs+    -> SubkeyWithWireRefs+    -> Either CanonicalizeTKWithWireRepError Ordering compareSubkeyWithWireRefsCanonical structured a b =-  compare <$> subkeyWireSortKey structured a <*> subkeyWireSortKey structured b+    compare+        <$> subkeyWireSortKey structured a+        <*> subkeyWireSortKey structured b -sortCanonicalByKey ::-     Ord key-  => (a -> Either CanonicalizeTKWithWireRepError key)-  -> [a]-  -> Either CanonicalizeTKWithWireRepError [a]+sortCanonicalByKey+    :: Ord key+    => (a -> Either CanonicalizeTKWithWireRepError key)+    -> [a]+    -> Either CanonicalizeTKWithWireRepError [a] sortCanonicalByKey keyFn xs =-  map snd . sortOn fst <$> traverse (\x -> (\k -> (k, x)) <$> keyFn x) xs+    map snd . sortOn fst+        <$> traverse (\x -> (\k -> (k, x)) <$> keyFn x) xs -sortSignatureWithWireRefsCanonical ::-     TKStructuredWithWireRep-  -> [SignatureWithWireRef]-  -> Either CanonicalizeTKWithWireRepError [SignatureWithWireRef]+sortSignatureWithWireRefsCanonical+    :: TKStructuredWithWireRep+    -> [SignatureWithWireRef]+    -> Either CanonicalizeTKWithWireRepError [SignatureWithWireRef] sortSignatureWithWireRefsCanonical structured =-  sortCanonicalByKey (signatureWireSortKey structured)+    sortCanonicalByKey (signatureWireSortKey structured) -sortUIDWithWireRefsCanonical ::-     TKStructuredWithWireRep-  -> [UIDWithWireRefs]-  -> Either CanonicalizeTKWithWireRepError [UIDWithWireRefs]+sortUIDWithWireRefsCanonical+    :: TKStructuredWithWireRep+    -> [UIDWithWireRefs]+    -> Either CanonicalizeTKWithWireRepError [UIDWithWireRefs] sortUIDWithWireRefsCanonical structured uids = do-  normalized <--    traverse-      (\uid ->-         (\sigs -> uid {_uidWithWireRefsSignatures = sigs}) <$>-         sortSignatureWithWireRefsCanonical structured (_uidWithWireRefsSignatures uid))-      uids-  sortCanonicalByKey (uidWireSortKey structured) normalized+    normalized <-+        traverse+            ( \uid ->+                (\sigs -> uid {_uidWithWireRefsSignatures = sigs})+                    <$> sortSignatureWithWireRefsCanonical+                        structured+                        (_uidWithWireRefsSignatures uid)+            )+            uids+    sortCanonicalByKey (uidWireSortKey structured) normalized -sortUATWithWireRefsCanonical ::-     TKStructuredWithWireRep-  -> [UATWithWireRefs]-  -> Either CanonicalizeTKWithWireRepError [UATWithWireRefs]+sortUATWithWireRefsCanonical+    :: TKStructuredWithWireRep+    -> [UATWithWireRefs]+    -> Either CanonicalizeTKWithWireRepError [UATWithWireRefs] sortUATWithWireRefsCanonical structured uats = do-  normalized <--    traverse-      (\uat ->-         (\sigs -> uat {_uatWithWireRefsSignatures = sigs}) <$>-         sortSignatureWithWireRefsCanonical structured (_uatWithWireRefsSignatures uat))-      uats-  sortCanonicalByKey (uatWireSortKey structured) normalized+    normalized <-+        traverse+            ( \uat ->+                (\sigs -> uat {_uatWithWireRefsSignatures = sigs})+                    <$> sortSignatureWithWireRefsCanonical+                        structured+                        (_uatWithWireRefsSignatures uat)+            )+            uats+    sortCanonicalByKey (uatWireSortKey structured) normalized -sortSubkeyWithWireRefsCanonical ::-     TKStructuredWithWireRep-  -> [SubkeyWithWireRefs]-  -> Either CanonicalizeTKWithWireRepError [SubkeyWithWireRefs]+sortSubkeyWithWireRefsCanonical+    :: TKStructuredWithWireRep+    -> [SubkeyWithWireRefs]+    -> Either CanonicalizeTKWithWireRepError [SubkeyWithWireRefs] sortSubkeyWithWireRefsCanonical structured subs = do-  normalized <--    traverse-      (\sub ->-         (\sigs -> sub {_subkeyWithWireRefsSignatures = sigs}) <$>-         sortSignatureWithWireRefsCanonical structured (_subkeyWithWireRefsSignatures sub))-      subs-  sortCanonicalByKey (subkeyWireSortKey structured) normalized+    normalized <-+        traverse+            ( \sub ->+                (\sigs -> sub {_subkeyWithWireRefsSignatures = sigs})+                    <$> sortSignatureWithWireRefsCanonical+                        structured+                        (_subkeyWithWireRefsSignatures sub)+            )+            subs+    sortCanonicalByKey (subkeyWireSortKey structured) normalized -canonicalizeTKStructuredWithWireRep ::-     TKStructuredWithWireRep -> Either CanonicalizeTKWithWireRepError TKUnknown+canonicalizeTKStructuredWithWireRep+    :: TKStructuredWithWireRep+    -> Either CanonicalizeTKWithWireRepError TKUnknown canonicalizeTKStructuredWithWireRep structured =-  buildTK <$>-  sortSignatureWithWireRefsCanonical structured (_tkStructuredDirectSignatures structured) <*>-  sortUIDWithWireRefsCanonical structured (_tkStructuredUIDs structured) <*>-  sortUATWithWireRefsCanonical structured (_tkStructuredUAts structured) <*>-  sortSubkeyWithWireRefsCanonical structured (_tkStructuredSubkeys structured)+    buildTK+        <$> sortSignatureWithWireRefsCanonical+            structured+            (_tkStructuredDirectSignatures structured)+        <*> sortUIDWithWireRefsCanonical+            structured+            (_tkStructuredUIDs structured)+        <*> sortUATWithWireRefsCanonical+            structured+            (_tkStructuredUAts structured)+        <*> sortSubkeyWithWireRefsCanonical+            structured+            (_tkStructuredSubkeys structured)   where     buildTK directSigs uids uats subs =-      TKUnknown-        { _tkuKey = _tkStructuredPrimaryKey structured-        , _tkuRevs = map _signatureWithWireRefValue directSigs-        , _tkuUIDs =-            map-             (_uidWithWireRefsValue &&&-              (map _signatureWithWireRefValue . _uidWithWireRefsSignatures))-             uids-        , _tkuUAts =-            map-             (_uatWithWireRefsValue &&&-              (map _signatureWithWireRefValue . _uatWithWireRefsSignatures))-             uats-        , _tkuSubs =-            map-             (_subkeyWithWireRefsValue &&&-              (map _signatureWithWireRefValue . _subkeyWithWireRefsSignatures))-             subs-        }+        TKUnknown+            { _tkuKey = _tkStructuredPrimaryKey structured+            , _tkuRevs = map _signatureWithWireRefValue directSigs+            , _tkuUIDs =+                map+                    ( _uidWithWireRefsValue+                        &&& (map _signatureWithWireRefValue . _uidWithWireRefsSignatures)+                    )+                    uids+            , _tkuUAts =+                map+                    ( _uatWithWireRefsValue+                        &&& (map _signatureWithWireRefValue . _uatWithWireRefsSignatures)+                    )+                    uats+            , _tkuSubs =+                map+                    ( _subkeyWithWireRefsValue+                        &&& (map _signatureWithWireRefValue . _subkeyWithWireRefsSignatures)+                    )+                    subs+            } -canonicalizeTKWithWireRep ::-     TKWithWireRep -> Either CanonicalizeTKWithWireRepError TKUnknown+canonicalizeTKWithWireRep+    :: TKWithWireRep -> Either CanonicalizeTKWithWireRepError TKUnknown canonicalizeTKWithWireRep tk = do-  structured <--    case toStructuredTKWithWireRep tk of-      Left err -> Left (CanonicalizeStructuringError err)-      Right s -> Right s-  canonicalizeTKStructuredWithWireRep structured+    structured <-+        case toStructuredTKWithWireRep tk of+            Left err -> Left (CanonicalizeStructuringError err)+            Right s -> Right s+    canonicalizeTKStructuredWithWireRep structured -toStructuredTKWithWireRep :: TKWithWireRep -> Either String TKStructuredWithWireRep+toStructuredTKWithWireRep+    :: TKWithWireRep -> Either String TKStructuredWithWireRep toStructuredTKWithWireRep tkWithRefs = do-  let tk = _tkValue tkWithRefs-      refs = _tkPackets tkWithRefs-      (pkp, mska) = _tkuKey tk-      primaryPkt = someKeyPktToPkt (mkPrimaryKeyPkt pkp mska)-  zipper <- case zFromList refs of-    Just z -> Right z-    Nothing -> Left "no packet references available for TKUnknown structuring"-  (primaryRef, z1') <- consumePktZ "primary key packet" primaryPkt zipper-  -- Move past the primary key to process its signatures and following packets-  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 (_tkuUIDs tk) && null (_tkuUAts tk) && null (_tkuSubs tk)-        then Right z1'-        else Left "missing signatures/UIDs/subkeys after primary key packet"-  (directSigs, z2) <- consumeSigsZ "direct-key signatures" (_tkuRevs tk) z1-  (uids, z3) <- consumeUIDsZ (_tkuUIDs tk) z2-  (uats, z4) <- consumeUATsZ (_tkuUAts tk) z3-  (subs, z5) <- consumeSubsZ (_tkuSubs tk) z4-  -- Check if there are trailing packets AFTER the current focus (not including it)-  case _zpAfter z5 of-    [] ->-      Right-       (TKStructuredWithWireRep-          (_tkWireRepRefs tkWithRefs)-          (_tkWireRepRange tkWithRefs)-          (_tkuKey tk)-          (packetRefIdOf primaryRef)-          directSigs-          uids-          uats-          subs-          (_tkPackets tkWithRefs))-    (unexpected:_) ->-      Left-       ("unexpected trailing packet reference at position " ++-        show (zPosition z5 + 1) ++ " while structuring TKUnknown provenance (tag " ++-        show (pktTag (_pktValue unexpected)) ++ ")")+    let tk = _tkValue tkWithRefs+        refs = _tkPackets tkWithRefs+        (pkp, mska) = _tkuKey tk+        primaryPkt = someKeyPktToPkt (mkPrimaryKeyPkt pkp mska)+    zipper <- case zFromList refs of+        Just z -> Right z+        Nothing ->+            Left "no packet references available for TKUnknown structuring"+    (primaryRef, z1') <-+        consumePktZ "primary key packet" primaryPkt zipper+    -- Move past the primary key to process its signatures and following packets+    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 (_tkuUIDs tk)+                && null (_tkuUAts tk)+                && null (_tkuSubs tk)+                then Right z1'+                else+                    Left "missing signatures/UIDs/subkeys after primary key packet"+    (directSigs, z2) <-+        consumeSigsZ "direct-key signatures" (_tkuRevs tk) z1+    (uids, z3) <- consumeUIDsZ (_tkuUIDs tk) z2+    (uats, z4) <- consumeUATsZ (_tkuUAts tk) z3+    (subs, z5) <- consumeSubsZ (_tkuSubs tk) z4+    -- Check if there are trailing packets AFTER the current focus (not including it)+    case _zpAfter z5 of+        [] ->+            Right+                ( TKStructuredWithWireRep+                    (_tkWireRepRefs tkWithRefs)+                    (_tkWireRepRange tkWithRefs)+                    (_tkuKey tk)+                    (packetRefIdOf primaryRef)+                    directSigs+                    uids+                    uats+                    subs+                    (_tkPackets tkWithRefs)+                )+        (unexpected : _) ->+            Left+                ( "unexpected trailing packet reference at position "+                    ++ show (zPosition z5 + 1)+                    ++ " while structuring TKUnknown provenance (tag "+                    ++ show (pktTag (unexpected ^. pktWireRep . pktValue))+                    ++ ")"+                )   where-    consumePktZ :: String -> Pkt -> PacketZipper -> Either String (PktWithWireRep, PacketZipper)+    consumePktZ+        :: String+        -> Pkt+        -> PacketZipper PktWithWireRep+        -> Either String (PktWithWireRep, PacketZipper PktWithWireRep)     consumePktZ context expected z-      | _pktValue (_zpCurrent z) == expected = Right (_zpCurrent z, z)-      | otherwise =-         Left-           ("packet/reference mismatch for " ++ context ++-            " at position " ++ show (zPosition z) ++-            ": expected tag " ++ show (pktTag expected) ++-            ", got tag " ++ show (pktTag (_pktValue (_zpCurrent z))))+        | (extract z) ^. pktWireRep . pktValue == expected =+            Right (extract z, z)+        | otherwise =+            Left+                ( "packet/reference mismatch for "+                    ++ context+                    ++ " at position "+                    ++ show (zPosition z)+                    ++ ": expected tag "+                    ++ show (pktTag expected)+                    ++ ", got tag "+                    ++ show (pktTag ((extract z) ^. pktWireRep . pktValue))+                ) -    consumeSigsZ ::-        String-      -> [SignaturePayload]-      -> PacketZipper-      -> Either String ([SignatureWithWireRef], PacketZipper)+    tryMoveNext+        :: String+        -> PacketZipper PktWithWireRep+        -> Bool+        -> Either String (PacketZipper PktWithWireRep)+    tryMoveNext errorPrefix z isLastItem =+        case zMoveNext z of+            Just z' -> Right z'+            Nothing ->+                if isLastItem+                    then Right z+                    else+                        Left+                            ( errorPrefix+                                ++ " at position "+                                ++ show (zPosition z)+                            )++    consumeSigsZ+        :: String+        -> [SignaturePayload]+        -> PacketZipper PktWithWireRep+        -> Either+            String+            ([SignatureWithWireRef], PacketZipper PktWithWireRep)     consumeSigsZ context sigs z = go [] sigs z       where-       go acc [] zipper = Right (reverse acc, zipper)-       go acc (sig:sigRest) zipper = do-         (sigPkt, z') <- consumePktZ context (SignaturePkt sig) zipper-         z'' <- case zMoveNext z' of-           Just z -> Right z-           Nothing -> if null sigRest then Right z' else Left ("missing signature packet at position " ++ show (zPosition z'))-         go-           (SignatureWithWireRef sig (packetRefIdOf sigPkt) : acc)-           sigRest-           z''+        go acc [] zipper = Right (reverse acc, zipper)+        go acc (sig : sigRest) zipper = do+            (sigPkt, z') <- consumePktZ context (SignaturePkt sig) zipper+            z'' <- tryMoveNext "missing signature packet" z' (null sigRest)+            go+                (SignatureWithWireRef sig (packetRefIdOf sigPkt) : acc)+                sigRest+                z'' -    consumeUIDsZ ::-        [(Text, [SignaturePayload])]-      -> PacketZipper-      -> Either String ([UIDWithWireRefs], PacketZipper)+    consumeUIDsZ+        :: [(Text, [SignaturePayload])]+        -> PacketZipper PktWithWireRep+        -> Either String ([UIDWithWireRefs], PacketZipper PktWithWireRep)     consumeUIDsZ [] z = Right ([], z)-    consumeUIDsZ ((uid, sigs):rest) z = do-      (uidPkt, z1) <- consumePktZ "UID packet" (UserIdPkt uid) z-      z2 <- case zMoveNext z1 of-       Just z -> Right z-       Nothing -> if null rest && null sigs then Right z1 else Left ("missing UID at position " ++ show (zPosition z1))-      (uidSigs, z3) <- consumeSigsZ "UID signature" sigs z2-      (tailUIDs, z4) <- consumeUIDsZ rest z3-      Right-       (UIDWithWireRefs uid (packetRefIdOf uidPkt) uidSigs : tailUIDs, z4)+    consumeUIDsZ ((uid, sigs) : rest) z = do+        (uidPkt, z1) <- consumePktZ "UID packet" (UserIdPkt uid) z+        z2 <- tryMoveNext "missing UID" z1 (null rest && null sigs)+        (uidSigs, z3) <- consumeSigsZ "UID signature" sigs z2+        (tailUIDs, z4) <- consumeUIDsZ rest z3+        Right+            ( UIDWithWireRefs uid (packetRefIdOf uidPkt) uidSigs : tailUIDs+            , z4+            ) -    consumeUATsZ ::-        [([UserAttrSubPacket], [SignaturePayload])]-      -> PacketZipper-      -> Either String ([UATWithWireRefs], PacketZipper)+    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 <- case zMoveNext z1 of-       Just z -> Right z-       Nothing -> if null rest && null sigs then Right z1 else Left ("missing UAT at position " ++ show (zPosition z1))-      (uatSigs, z3) <- consumeSigsZ "UAT signature" sigs z2-      (tailUats, z4) <- consumeUATsZ rest z3-      Right-       (UATWithWireRefs uat (packetRefIdOf uatPkt) uatSigs : tailUats, z4)+    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+            , z4+            ) -    consumeSubsZ ::-        [(Pkt, [SignaturePayload])]-      -> PacketZipper-      -> Either String ([SubkeyWithWireRefs], PacketZipper)+    consumeSubsZ+        :: [(Pkt, [SignaturePayload])]+        -> PacketZipper PktWithWireRep+        -> Either String ([SubkeyWithWireRefs], PacketZipper PktWithWireRep)     consumeSubsZ [] z = Right ([], z)-    consumeSubsZ ((subPkt, sigs):rest) z = do-      (subRef, z1) <- consumePktZ "subkey packet" subPkt z-      z2 <- case zMoveNext z1 of-       Just z -> Right z-       Nothing -> if null rest && null sigs then Right z1 else Left ("missing subkey at position " ++ show (zPosition z1))-      (subSigs, z3) <- consumeSigsZ "subkey signature" sigs z2-      (tailSubs, z4) <- consumeSubsZ rest z3-      Right-       (SubkeyWithWireRefs subPkt (packetRefIdOf subRef) subSigs : tailSubs, z4)+    consumeSubsZ ((subPkt, sigs) : rest) z = do+        (subRef, z1) <- consumePktZ "subkey packet" subPkt z+        z2 <- tryMoveNext "missing subkey" z1 (null rest && null sigs)+        (subSigs, z3) <- consumeSigsZ "subkey signature" sigs z2+        (tailSubs, z4) <- consumeSubsZ rest z3+        Right+            ( SubkeyWithWireRefs subPkt (packetRefIdOf subRef) subSigs+                : tailSubs+            , z4+            ) -tksFromWireRep :: WireRepRef -> [TKWithWireRep] -> [TKWithWireRep]+tksFromWireRep+    :: WireRepRef -> [TKWithWireRep] -> [TKWithWireRep] tksFromWireRep src = filter (elem src . NE.toList . wireRepsOfTK) -tksContainingPacket :: PktWithWireRep -> [TKWithWireRep] -> [TKWithWireRep]+tksContainingPacket+    :: PktWithWireRep -> [TKWithWireRep] -> [TKWithWireRep] tksContainingPacket pkt = filter (elem pkt . packetRefsOfTK)  $(ATH.deriveToJSON ATH.defaultOptions ''TKUnknown) -type KeyringIxs = '[ EightOctetKeyId, Fingerprint, Text]+type KeyringIxs = '[EightOctetKeyId, Fingerprint, Text]  -- | Kinded keyrings: homogeneous collections of public or secret TKs type PublicKeyring = IxSet KeyringIxs (TK 'PublicTK)+ type SecretKeyring = IxSet KeyringIxs (TK 'SecretTK)  -- | Parameterized kinded keyring for generic operations type family KeyringOf (k :: TKKind) :: Type where-  KeyringOf 'PublicTK = PublicKeyring-  KeyringOf 'SecretTK = SecretKeyring+    KeyringOf 'PublicTK = PublicKeyring+    KeyringOf 'SecretTK = SecretKeyring  $(makeLenses ''TKUnknown) $(makeLenses ''TK)
Data/Conduit/OpenPGP/Keyring.hs view
@@ -32,6 +32,9 @@     , partitionSomeTKs     ) 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@@ -210,8 +213,8 @@                     }                 ]         Right verifiedTk-            | not (isTKTimeValid validationTime (tkToUnknown verifiedTk)) ->-                let uids = uidContextsAt validationTime (tkToUnknown verifiedTk)+            | not (isTKTimeValid validationTime verifiedTk) ->+                let uids = uidContextsAt validationTime verifiedTk                     primaryUid =                         authSecretSubkeyUIDValue                             <$> find authSecretSubkeyUIDIsPrimary uids@@ -227,7 +230,7 @@                             }                         ]             | otherwise ->-                let uids = uidContextsAt validationTime (tkToUnknown verifiedTk)+                let uids = uidContextsAt validationTime verifiedTk                     primaryUid =                         authSecretSubkeyUIDValue                             <$> find authSecretSubkeyUIDIsPrimary uids@@ -253,7 +256,7 @@                         (AuthSecretSubkeysAtReport [] [])                         (_tkSubs verifiedTk)   where-    untyped = tkToUnknown typedTk+    untyped = publicViewTK typedTk     primaryKey = _tkPrimaryKey typedTk  classifySecretSubkeyAtTime@@ -307,7 +310,7 @@                 , authSecretSubkeyPrimaryUID = primaryUid                 } -uidContextsAt :: UTCTime -> TKUnknown -> [AuthSecretSubkeyUID]+uidContextsAt :: UTCTime -> TK k -> [AuthSecretSubkeyUID] uidContextsAt validationTime tk =     map         ( \(uid, _) ->@@ -316,9 +319,9 @@                 , authSecretSubkeyUIDIsPrimary = Just uid == primaryUid                 }         )-        (_tkuUIDs tk)+        (tk ^. tkUIDs)   where-    primaryUid = primaryUIDAt validationTime (_tkuUIDs tk)+    primaryUid = primaryUIDAt validationTime (tk ^. tkUIDs)  primaryUIDAt     :: UTCTime -> [(Text, [SignaturePayload])] -> Maybe Text@@ -471,7 +474,7 @@ conduitDropErrorsAndNothings     :: Monad m => ConduitT (Either e (Maybe a)) a m () conduitDropErrorsAndNothings =-    CL.mapMaybe (either (const Nothing) id)+    CL.mapMaybe (join . hush)  conduitToTKsEither'     :: Monad m@@ -507,7 +510,7 @@             (parseAChunkEither (anyTKWithWireRep intolerant))             ([], Just (Nothing, anyTKWithWireRep intolerant))   where-    notTrustPacket = not . isTrustPkt . _pktValue+    notTrustPacket = not . isTrustPkt . (^. pktWireRep . pktValue)  sinkPublicKeyringMap     :: Monad m => ConduitT (TK 'PublicTK) Void m PublicKeyring
Data/Conduit/OpenPGP/Keyring/Instances.hs view
@@ -2,38 +2,43 @@ -- Copyright © 2012-2026  Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-}  module Data.Conduit.OpenPGP.Keyring.Instances-  (-  ) where+    (+    ) where -import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)-import Codec.Encryption.OpenPGP.Internal (issuer)-import Codec.Encryption.OpenPGP.SignatureQualities (sigCT)-import Codec.Encryption.OpenPGP.Types import Control.Arrow (second)-import Control.Lens ((^.), (^..), _1, folded)+import Control.Lens (folded, (^.), (^..), _1) import Data.Data.Lens (biplate) import Data.Either (rights) import Data.Function (on) import qualified Data.HashMap.Lazy as HashMap-import Data.IxSet.Typed (Indexable(..), ixFun, ixList)+import Data.IxSet.Typed (Indexable (..), ixFun, ixList) import Data.List (nub, sort) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import Data.Semigroup (Semigroup, (<>)) import Data.Text (Text) +import Codec.Encryption.OpenPGP.Fingerprint+    ( eightOctetKeyID+    , fingerprint+    )+import Codec.Encryption.OpenPGP.Internal (issuer)+import Codec.Encryption.OpenPGP.SignatureQualities (sigCT)+import Codec.Encryption.OpenPGP.Types+ instance Indexable KeyringIxs TKUnknown where-  indices = ixList (ixFun getEOKIs) (ixFun getFingerprints) (ixFun getUIDs)+    indices =+        ixList (ixFun getEOKIs) (ixFun getFingerprints) (ixFun getUIDs)  getEOKIs :: TKUnknown -> [EightOctetKeyId]-getEOKIs tk = rights (map eightOctetKeyID (tk ^.. biplate :: [SomePKPayload]))+getEOKIs tk =+    rights (map eightOctetKeyID (tk ^.. biplate :: [SomePKPayload]))  getFingerprints :: TKUnknown -> [Fingerprint] getFingerprints tk = map fingerprint (tk ^.. biplate :: [SomePKPayload])@@ -41,42 +46,26 @@ getUIDs :: TKUnknown -> [Text] getUIDs tk = (tk ^. tkuUIDs) ^.. folded . _1 -instance Semigroup TKUnknown where-  (<>) a b =-    TKUnknown-      (_tkuKey a)-      (nub . sort $ _tkuRevs a ++ _tkuRevs 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 = nub . sort $ x ++ y- instance Semigroup TKWithWireRep where-  (<>) a b =-    let mergedTK = _tkValue a <> _tkValue b-        mergedPackets =-          selectPacketRefsByValue-            (flattenTKPackets mergedTK)-            (dedupePacketRefsById (_tkPackets a ++ _tkPackets b))-     in TKWithWireRep-          (mergeWireRepRefs (_tkWireRepRefs a) (_tkWireRepRefs b))-          (mergedWireRepRange mergedPackets)-          mergedPackets-          mergedTK+    (<>) a b =+        let mergedTK = _tkValue a <> _tkValue b+            mergedPackets =+                selectPacketRefsByValue+                    (flattenTKPackets mergedTK)+                    (dedupePacketRefsById (_tkPackets a ++ _tkPackets b))+         in TKWithWireRep+                (mergeWireRepRefs (_tkWireRepRefs a) (_tkWireRepRefs b))+                (mergedWireRepRange mergedPackets)+                mergedPackets+                mergedTK  flattenTKPackets :: TKUnknown -> [Pkt] flattenTKPackets tk =-  [someKeyPktToPkt (mkPrimaryKeyPkt pkp mska)] ++-  map SignaturePkt (_tkuRevs tk) ++-  concatMap flattenUID (_tkuUIDs tk) ++-  concatMap flattenUAT (_tkuUAts tk) ++-  concatMap flattenSub (_tkuSubs tk)+    [someKeyPktToPkt (mkPrimaryKeyPkt pkp mska)]+        ++ map SignaturePkt (_tkuRevs 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@@ -85,57 +74,69 @@  mergeWireRepRefs :: WireRepRefs -> WireRepRefs -> WireRepRefs mergeWireRepRefs left right =-  case dedupe (NE.toList left ++ NE.toList right) of-    [] -> left-    (x:xs) -> x NE.:| xs+    case dedupe (NE.toList left ++ NE.toList right) of+        [] -> left+        (x : xs) -> x NE.:| xs   where     dedupe [] = []-    dedupe (x:xs) = x : dedupe (filter (/= x) xs)+    dedupe (x : xs) = x : dedupe (filter (/= x) xs)  mergedWireRepRange :: [PktWithWireRep] -> Maybe ByteRange mergedWireRepRange [] = Nothing-mergedWireRepRange (pkt:rest)-  | all ((== _pktWireRepRef pkt) . _pktWireRepRef) rest =-      spanByteRanges (map _pktRange (pkt : rest))-  | otherwise = Nothing+mergedWireRepRange (pkt : rest)+    | all ((== _pktWireRepRef pkt) . _pktWireRepRef) rest =+        spanByteRanges (map _pktRange (pkt : rest))+    | otherwise = Nothing  dedupePacketRefsById :: [PktWithWireRep] -> [PktWithWireRep] dedupePacketRefsById = go []   where     go _ [] = []-    go seen (pkt:rest) =-      let packetRefId = packetRefIdOf pkt-       in if packetRefId `elem` seen-            then go seen rest-            else pkt : go (packetRefId : seen) rest+    go seen (pkt : rest) =+        let packetRefId = packetRefIdOf pkt+         in if packetRefId `elem` seen+                then go seen rest+                else pkt : go (packetRefId : seen) rest -selectPacketRefsByValue :: [Pkt] -> [PktWithWireRep] -> [PktWithWireRep]+selectPacketRefsByValue+    :: [Pkt] -> [PktWithWireRep] -> [PktWithWireRep] selectPacketRefsByValue expected available = go expected available []   where     go [] _ acc = reverse acc-    go (pkt:pktRest) refs acc =-      case extractFirstByValue pkt refs of-        Nothing ->-          error-            ("TKWithWireRep Semigroup merge missing packet reference for tag " ++-             show (pktTag pkt))-        Just (matched, remaining) -> go pktRest remaining (matched : acc)+    go (pkt : pktRest) refs acc =+        case extractFirstByValue pkt refs of+            Nothing ->+                error+                    ( "TKWithWireRep Semigroup merge missing packet reference for tag "+                        ++ show (pktTag pkt)+                    )+            Just (matched, remaining) -> go pktRest remaining (matched : acc) -extractFirstByValue :: Pkt -> [PktWithWireRep] -> Maybe (PktWithWireRep, [PktWithWireRep])-extractFirstByValue _ [] = Nothing-extractFirstByValue expected (pkt:rest)-  | _pktValue pkt == expected = Just (pkt, rest)-  | otherwise = second (pkt :) <$> extractFirstByValue expected rest+extractFirstByValue+    :: Pkt+    -> [PktWithWireRep]+    -> Maybe (PktWithWireRep, [PktWithWireRep])+extractFirstByValue expected = go []+  where+    go _ [] = Nothing+    go seen (pkt : rest)+        | pkt ^. pktWireRep . pktValue == expected =+            Just (pkt, seen ++ rest)+        | 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)+    keyPktPKPayload (_tkPrimaryKey tk)+        : map (keyPktPKPayload . fst) (_tkSubs tk)  -- | Index public TKs by key ID, fingerprint, and UID instance Indexable KeyringIxs (TK 'PublicTK) where-  indices = ixList (ixFun getEOKIsPublic) (ixFun getFingerprintsPublic) (ixFun getUIDsPublic)+    indices =+        ixList+            (ixFun getEOKIsPublic)+            (ixFun getFingerprintsPublic)+            (ixFun getUIDsPublic)  getEOKIsPublic :: TK 'PublicTK -> [EightOctetKeyId] getEOKIsPublic tk = rights (map eightOctetKeyID (tkPKPayloads tk))@@ -148,7 +149,11 @@  -- | Index secret TKs by key ID, fingerprint, and UID instance Indexable KeyringIxs (TK 'SecretTK) where-  indices = ixList (ixFun getEOKIsSecret) (ixFun getFingerprintsSecret) (ixFun getUIDsSecret)+    indices =+        ixList+            (ixFun getEOKIsSecret)+            (ixFun getFingerprintsSecret)+            (ixFun getUIDsSecret)  getEOKIsSecret :: TK 'SecretTK -> [EightOctetKeyId] getEOKIsSecret tk = rights (map eightOctetKeyID (tkPKPayloads tk))@@ -158,20 +163,3 @@  getUIDsSecret :: TK 'SecretTK -> [Text] getUIDsSecret tk = (tk ^. tkUIDs) ^.. folded . _1---instance Semigroup (TK k) where-  a <> b =-    TK-      (_tkPrimaryKey a)-      (nub . sort $ _tkRevs a ++ _tkRevs b)-      ((kvmerge `on` _tkUIDs) a b)-      ((kvmerge `on` _tkUAts) a b)-      ((ukvmerge `on` _tkSubs) 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 = nub . sort $ x ++ y
hOpenPGP.cabal view
@@ -1,6 +1,6 @@ Cabal-version:       3.4 Name:                hOpenPGP-Version:             3.1.1+Version:             3.2 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@@ -185,6 +185,7 @@                , binary                >= 0.6.4.0                , binary-conduit        >= 1.3                , bz2+               , comonad               >= 5.0                , conduit               >= 1.3.0                , conduit-extra         >= 1.1                , containers            >= 0.6.0.1@@ -333,4 +334,4 @@ source-repository this   type:     git   location: https://salsa.debian.org/clint/hOpenPGP.git-  tag:      v3.1.1+  tag:      v3.2
tests/Tests/Common.hs view
@@ -843,9 +843,9 @@         passphrase         payload -mkTestKeyring :: [TKUnknown] -> PublicKeyring+mkTestKeyring :: [TK 'PublicTK] -> PublicKeyring mkTestKeyring tks =-    let someTKs = [stk | Right stk <- map fromUnknownToTKEither tks]+    let someTKs = [SomePublicTK tk | tk <- tks]      in fst (partitionSomeTKs someTKs)  addTimestampSeconds
tests/Tests/Encryption.hs view
@@ -127,7 +127,6 @@     ( SessionMaterialExposure (..)     , encryptedPayloadBytes     , mkClearPayload-    , mkPassphrase     ) import Codec.Encryption.OpenPGP.Policy     ( OpenPGPPolicy (..)@@ -1290,7 +1289,7 @@ encryptedSEIPDv2Packets :: IO [Pkt] encryptedSEIPDv2Packets = do     let passphrase =-            mkPassphrase+            Passphrase                 (BL.pack (map (fromIntegral . fromEnum) ("test" :: String)))         payload =             mkClearPayload@@ -3156,25 +3155,20 @@ testRecipientEncryptionTargetsFromTKIncludesOnlyEncryptionCapableKeys = do     (signingPrimary, _signingKey) <- loadDeterministicEd25519Signer     (baseEncryptingSubkey, _privateKey) <- loadUnencryptedRsaSigner-    let tkUnknown =-            TKUnknown-                { _tkuKey = (signingPrimary, Nothing)-                , _tkuRevs = []-                , _tkuUIDs = []-                , _tkuUAts = []-                , _tkuSubs =+    let tk =+            TK+                { _tkPrimaryKey = KeyPktPublicPrimary signingPrimary+                , _tkRevs = []+                , _tkUIDs = []+                , _tkUAts = []+                , _tkSubs =                     [-                        ( PublicSubkeyPkt+                        ( KeyPktPublicSubkey                             (setKeyTimestamp (_timestamp signingPrimary) baseEncryptingSubkey)                         , []                         )                     ]                 }-        tk =-            case fromUnknownToTK tkUnknown of-                Right (SomePublicTK publicTk) -> publicTk-                Right (SomeSecretTK _) -> error "expected public TK for recipient target test"-                Left err -> error err         encryptingSubkey =             setKeyTimestamp (_timestamp signingPrimary) baseEncryptingSubkey         targets = recipientEncryptionTargetsFromTK tk@@ -3197,20 +3191,14 @@     (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner     let primary = setKeyVersion V4 baseRecipient         subkey = setKeyVersion V6 baseRecipient-        tkUnknown =-            TKUnknown-                { _tkuKey = (primary, Nothing)-                , _tkuRevs = []-                , _tkuUIDs = []-                , _tkuUAts = []-                , _tkuSubs = [(PublicSubkeyPkt subkey, [])]-                }         tk =-            case fromUnknownToTK tkUnknown of-                Right (SomePublicTK publicTk) -> publicTk-                Right (SomeSecretTK _) ->-                    error "expected public TK for recipient target selection test"-                Left err -> error err+            TK+                { _tkPrimaryKey = KeyPktPublicPrimary primary+                , _tkRevs = []+                , _tkUIDs = []+                , _tkUAts = []+                , _tkSubs = [(KeyPktPublicSubkey subkey, [])]+                }     case recipientEncryptionTargetFromTK tk of         Right target ->             assertEqual@@ -3227,19 +3215,14 @@     :: Assertion testRecipientEncryptionTargetFromTKRejectsTKWithoutEncryptableKeys = do     (signingPrimary, _signingKey) <- loadDeterministicEd25519Signer-    let tkUnknown =-            TKUnknown-                { _tkuKey = (signingPrimary, Nothing)-                , _tkuRevs = []-                , _tkuUIDs = []-                , _tkuUAts = []-                , _tkuSubs = []+    let tk =+            TK+                { _tkPrimaryKey = KeyPktPublicPrimary signingPrimary+                , _tkRevs = []+                , _tkUIDs = []+                , _tkUAts = []+                , _tkSubs = []                 }-        tk =-            case fromUnknownToTK tkUnknown of-                Right (SomePublicTK publicTk) -> publicTk-                Right (SomeSecretTK _) -> error "expected public TK for recipient rejection test"-                Left err -> error err     case recipientEncryptionTargetFromTK tk of         Left RecipientCapabilityNoEncryptableKeyMaterialInTK -> pure ()         Left other ->@@ -3266,12 +3249,12 @@             signatureTime             [SigSubPacket False (KeyFlags (Set.fromList [SignDataKey]))]     let tk =-            TKUnknown-                { _tkuKey = (primary, Nothing)-                , _tkuRevs = []-                , _tkuUIDs = []-                , _tkuUAts = []-                , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])]+            TK+                { _tkPrimaryKey = KeyPktPublicPrimary primary+                , _tkRevs = []+                , _tkUIDs = []+                , _tkUAts = []+                , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])]                 }         report =             recipientEncryptionTargetsReportFromTKAtTimestamp@@ -3301,12 +3284,12 @@ testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsUnsupportedAlgorithms = do     (signingPrimary, _signingKey) <- loadDeterministicEd25519Signer     let tk =-            TKUnknown-                { _tkuKey = (signingPrimary, Nothing)-                , _tkuRevs = []-                , _tkuUIDs = []-                , _tkuUAts = []-                , _tkuSubs = []+            TK+                { _tkPrimaryKey = KeyPktPublicPrimary signingPrimary+                , _tkRevs = []+                , _tkUIDs = []+                , _tkUAts = []+                , _tkSubs = []                 }         report =             recipientEncryptionTargetsReportFromTKAtTimestamp@@ -3340,12 +3323,12 @@             , SigSubPacket False (KeyExpirationTime (ThirtyTwoBitDuration 5))             ]     let tk =-            TKUnknown-                { _tkuKey = (primary, Nothing)-                , _tkuRevs = []-                , _tkuUIDs = []-                , _tkuUAts = []-                , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])]+            TK+                { _tkPrimaryKey = KeyPktPublicPrimary primary+                , _tkRevs = []+                , _tkUIDs = []+                , _tkUAts = []+                , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])]                 }         report =             recipientEncryptionTargetsReportFromTKAtTimestamp targetTime tk@@ -3385,13 +3368,16 @@             signingKey             revocationTime     let tk =-            TKUnknown-                { _tkuKey = (primary, Nothing)-                , _tkuRevs = []-                , _tkuUIDs = []-                , _tkuUAts = []-                , _tkuSubs =-                    [ (PublicSubkeyPkt subkey, [subkeyBindingSig, subkeyRevocationSig])+            TK+                { _tkPrimaryKey = KeyPktPublicPrimary primary+                , _tkRevs = []+                , _tkUIDs = []+                , _tkUAts = []+                , _tkSubs =+                    [+                        ( KeyPktPublicSubkey subkey+                        , [subkeyBindingSig, subkeyRevocationSig]+                        )                     ]                 }         report =@@ -3429,12 +3415,12 @@                 (KeyFlags (Set.fromList [EncryptCommunicationsKey]))             ]     let tk =-            TKUnknown-                { _tkuKey = (primary, Nothing)-                , _tkuRevs = [directKeySig]-                , _tkuUIDs = []-                , _tkuUAts = []-                , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])]+            TK+                { _tkPrimaryKey = KeyPktPublicPrimary primary+                , _tkRevs = [directKeySig]+                , _tkUIDs = []+                , _tkUAts = []+                , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])]                 }         targets = recipientEncryptionTargetsFromTKAtTimestamp signatureTime tk     case targets of@@ -3477,12 +3463,12 @@                 (KeyFlags (Set.fromList [EncryptCommunicationsKey]))             ]     let tk =-            TKUnknown-                { _tkuKey = (primary, Nothing)-                , _tkuRevs = []-                , _tkuUIDs = []-                , _tkuUAts = []-                , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])]+            TK+                { _tkPrimaryKey = KeyPktPublicPrimary primary+                , _tkRevs = []+                , _tkUIDs = []+                , _tkUAts = []+                , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])]                 }     case recipientEncryptionTargetFromTKAtTimestamp beforeSignature tk of         Left err ->@@ -3519,12 +3505,12 @@                 (KeyFlags (Set.fromList [EncryptCommunicationsKey]))             ]     let tk =-            TKUnknown-                { _tkuKey = (primary, Nothing)-                , _tkuRevs = []-                , _tkuUIDs = []-                , _tkuUAts = []-                , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])]+            TK+                { _tkPrimaryKey = KeyPktPublicPrimary primary+                , _tkRevs = []+                , _tkUIDs = []+                , _tkUAts = []+                , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])]                 }     case recipientEncryptionTargetFromTKAtTimestampWithPolicy         RecipientTargetSelectionPreferPrimary@@ -3559,12 +3545,12 @@                 (KeyFlags (Set.fromList [EncryptCommunicationsKey]))             ]     let tk =-            TKUnknown-                { _tkuKey = (primary, Nothing)-                , _tkuRevs = []-                , _tkuUIDs = []-                , _tkuUAts = []-                , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])]+            TK+                { _tkPrimaryKey = KeyPktPublicPrimary primary+                , _tkRevs = []+                , _tkUIDs = []+                , _tkUAts = []+                , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])]                 }     case recipientEncryptionTargetFromTKAtTimestampWithPolicy         RecipientTargetSelectionPreferNewestCreationTime@@ -3596,12 +3582,12 @@             signatureTime             [SigSubPacket False (KeyFlags (Set.fromList [SignDataKey]))]     let tk =-            TKUnknown-                { _tkuKey = (primary, Nothing)-                , _tkuRevs = []-                , _tkuUIDs = []-                , _tkuUAts = []-                , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])]+            TK+                { _tkPrimaryKey = KeyPktPublicPrimary primary+                , _tkRevs = []+                , _tkUIDs = []+                , _tkUAts = []+                , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])]                 }         targets = recipientEncryptionTargetsFromTKAtTimestamp signatureTime tk     let subkeyFp = fingerprint subkey@@ -3629,12 +3615,12 @@             signatureTime             []     let tk =-            TKUnknown-                { _tkuKey = (primary, Nothing)-                , _tkuRevs = []-                , _tkuUIDs = []-                , _tkuUAts = []-                , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])]+            TK+                { _tkPrimaryKey = KeyPktPublicPrimary primary+                , _tkRevs = []+                , _tkUIDs = []+                , _tkUAts = []+                , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])]                 }         targets = recipientEncryptionTargetsFromTKAtTimestamp signatureTime tk     let subkeyFp = fingerprint subkey
tests/Tests/Keys.hs view
@@ -4,6 +4,7 @@ -- (See the LICENSE file). {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}  module Tests.Keys (keyAndVerificationTests) where@@ -24,7 +25,7 @@ import Data.IxSet.Typed (getOne, size, (@=)) import Data.List (find, isInfixOf) import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (isJust)+import Data.Maybe (isJust, mapMaybe) import qualified Data.Set as Set import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Prettyprinter (pretty)@@ -62,15 +63,24 @@     ) import Codec.Encryption.OpenPGP.Policy     ( OpenPGPRFC (..)+    , defaultPolicy     , defaultVerificationPolicy     , isAllowedPrimaryKeySig     , isAllowedSubkeySig     , isAllowedUIDSig     ) import Codec.Encryption.OpenPGP.SecretKey-    ( changePrivateKeyPassphrase+    ( SecretKeyEncryptOptions (..)+    , changePrivateKeyPassphrase+    , changeSecretKeyPassphrase     , decryptPrivateKey+    , decryptSecretKey+    , decryptSecretKeyAddendum+    , encryptSecretKey+    , encryptSecretKeyWithPolicy     , mkUnencryptedSKAddendum+    , reencryptSecretKey+    , reencryptSecretKeyRandom     , reinterpretUnknownSKeyForPKPayload     ) import Codec.Encryption.OpenPGP.Serialize@@ -97,7 +107,7 @@ import Data.Conduit.OpenPGP.Compression (conduitDecompress) import Data.Conduit.OpenPGP.Keyring     ( conduitDropErrorsAndNothings-    , conduitToTKsEither+    , conduitToSomeTKsEither     ) import Data.Conduit.OpenPGP.Verify (conduitVerify) import Tests.Common@@ -309,6 +319,21 @@                 "change private key passphrase"                 testChangePrivateKeyPassphraseV6             , testCase+                "high-level decrypt secret key (legacy)"+                testHighLevelDecryptSecretKeyLegacy+            , testCase+                "high-level decrypt secret key (v6)"+                testHighLevelDecryptSecretKeyV6+            , testCase+                "high-level re-encrypt secret key (legacy)"+                testHighLevelReencryptSecretKeyLegacy+            , testCase+                "high-level re-encrypt secret key (v6)"+                testHighLevelReencryptSecretKeyV6+            , testCase+                "high-level deterministic re-encrypt"+                testHighLevelReencryptDeterministic+            , testCase                 "getSecretKey parses v4 X25519 ECDH key material"                 testGetSecretKeyHandlesV4X25519ECDHPubkey             , testCase@@ -327,8 +352,8 @@                 "reinterpretUnknownSKeyForPKPayload decodes EdDSA unknown key material"                 testReinterpretUnknownSKeyForPKPayloadDecodesEdDSA             , testCase-                "fromPrimaryKeyPktToTKUnknown rejects subkey packets"-                testFromPrimaryKeyPktToTKUnknownRejectsSubkey+                "fromPrimaryKeyPktToSomeTK rejects subkey packets"+                testFromPrimaryKeyPktToSomeTKRejectsSubkey             , testCase                 "policy signature context validation (RFC9580)"                 testPolicySignatureContextValidation@@ -486,17 +511,21 @@         DC.runConduitRes $             CB.sourceFile ("tests/data/" ++ keyfile)                 DC..| conduitGet get-                DC..| conduitToTKsEither+                DC..| conduitToSomeTKsEither                 DC..| conduitDropErrorsAndNothings                 DC..| CL.consume+    let publicKs = mapMaybe someTKToPublicTK ks     assertLeftContains         "signing key is revoked"         ( mapM-            ( verifyUnknownTKWith-                (verifySigWith defaultVerificationPolicy (verifyAgainstKeys ks))+            ( verifyTKWith+                ( verifySigWith+                    defaultVerificationPolicy+                    (verifyAgainstKeys publicKs)+                )                 Nothing             )-            ks+            publicKs         )  testKeysSelfVerification :: Bool -> FilePath -> Assertion@@ -505,16 +534,20 @@         DC.runConduitRes $             CB.sourceFile ("tests/data/" ++ keyfile)                 DC..| conduitGet get-                DC..| conduitToTKsEither+                DC..| conduitToSomeTKsEither                 DC..| conduitDropErrorsAndNothings                 DC..| CL.consume-    let verifieds =+    let publicKs = mapMaybe someTKToPublicTK ks+        verifieds =             mapM-                ( verifyUnknownTKWith-                    (verifySigWith defaultVerificationPolicy (verifyAgainstKeys ks))+                ( verifyTKWith+                    ( verifySigWith+                        defaultVerificationPolicy+                        (verifyAgainstKeys publicKs)+                    )                     Nothing                 )-                ks+                publicKs     assertEqual         (keyfile ++ " self-verification")         expectsuccess@@ -526,15 +559,19 @@         DC.runConduitRes $             CB.sourceFile (fixturePath keyfile)                 DC..| conduitGet get-                DC..| conduitToTKsEither+                DC..| conduitToSomeTKsEither                 DC..| conduitDropErrorsAndNothings                 DC..| CL.consume+    let publicKs = mapMaybe someTKToPublicTK ks     case mapM-        ( verifyUnknownTKWith-            (verifySigWith defaultVerificationPolicy (verifyAgainstKeys ks))+        ( verifyTKWith+            ( verifySigWith+                defaultVerificationPolicy+                (verifyAgainstKeys publicKs)+            )             Nothing         )-        ks of+        publicKs of         Left err ->             assertFailure                 ( keyfile@@ -602,7 +639,15 @@         hashedWithUnsupportedCritical =             SigSubPacket True (OtherSigSub 111 "unsupported-critical")                 : hashed-        keyring = [TKUnknown (primarySigner, Nothing) [] [] [] []]+        keyring =+            [ TK+                { _tkPrimaryKey = KeyPktPublicPrimary primarySigner+                , _tkRevs = []+                , _tkUIDs = []+                , _tkUAts = []+                , _tkSubs = []+                }+            ]         state =             emptyPSC                 { lastPrimaryKey = PublicKeyPkt primarySigner@@ -644,7 +689,15 @@     (subkeySignerRaw, _) <- loadDeterministicEd25519Signer     let subkeySigner = setKeyVersion V6 subkeySignerRaw         creationTime = addTimestampSeconds (_timestamp primarySigner) 10-        keyring = [TKUnknown (primarySigner, Nothing) [] [] [] []]+        keyring =+            [ TK+                { _tkPrimaryKey = KeyPktPublicPrimary primarySigner+                , _tkRevs = []+                , _tkUIDs = []+                , _tkUAts = []+                , _tkSubs = []+                }+            ]         state =             emptyPSC                 { lastPrimaryKey = PublicKeyPkt primarySigner@@ -1025,13 +1078,14 @@             signingKey             postExpirySignatureTime             payload-    let tk =-            TKUnknown-                (signer, Nothing)-                []-                [(uidText, [longValidityCert, temporaryValidityCert])]-                []-                []+    let tk :: TK 'PublicTK =+            TK+                { _tkPrimaryKey = KeyPktPublicPrimary signer+                , _tkRevs = []+                , _tkUIDs = [(uidText, [longValidityCert, temporaryValidityCert])]+                , _tkUAts = []+                , _tkSubs = []+                }         keyring = mkTestKeyring [tk]     assertBool         "latest effective self-signature should keep key valid before temporary expiration"@@ -1089,13 +1143,14 @@             signingKey             renewedSignatureTime             payload-    let tk =-            TKUnknown-                (signer, Nothing)-                []-                [(uidText, [firstCertification, secondCertification])]-                []-                []+    let tk :: TK 'PublicTK =+            TK+                { _tkPrimaryKey = KeyPktPublicPrimary signer+                , _tkRevs = []+                , _tkUIDs = [(uidText, [firstCertification, secondCertification])]+                , _tkUAts = []+                , _tkSubs = []+                }         keyring = mkTestKeyring [tk]     assertBool         "a gap with no effective self-signature should make the key temporarily invalid"@@ -1145,7 +1200,12 @@             validSignatureTime             payload     let tk =-            TKUnknown (signer, Nothing) [] [(uidText, [certification])] [] []+            TK+                (KeyPktPublicPrimary signer)+                []+                [(uidText, [certification])]+                []+                []         keyring = mkTestKeyring [tk]     assertBool         "a key should be invalid before its first self-signature becomes effective"@@ -1202,13 +1262,14 @@             signingKey             restoredSignatureTime             payload-    let tk =-            TKUnknown-                (signer, Nothing)-                []-                [(uidText, [certification, temporaryRevocation])]-                []-                []+    let tk :: TK 'PublicTK =+            TK+                { _tkPrimaryKey = KeyPktPublicPrimary signer+                , _tkRevs = []+                , _tkUIDs = [(uidText, [certification, temporaryRevocation])]+                , _tkUAts = []+                , _tkSubs = []+                }         keyring = mkTestKeyring [tk]     assertBool         "a temporary self-revocation should disable signing while it is effective"@@ -1259,13 +1320,14 @@             signingKey             invalidSignatureTime             payload-    let tk =-            TKUnknown-                (signer, Nothing)-                []-                [(uidText, [firstCertification, secondCertification])]-                []-                []+    let tk :: TK 'PublicTK =+            TK+                { _tkPrimaryKey = KeyPktPublicPrimary signer+                , _tkRevs = []+                , _tkUIDs = [(uidText, [firstCertification, secondCertification])]+                , _tkUAts = []+                , _tkSubs = []+                }         keyring = mkTestKeyring [tk]     assertBool         "an expired newer self-signature should not revive an older certification"@@ -1295,15 +1357,16 @@                 False                 (ReasonForRevocation UserIdInfoNoLongerValid "")             ]-    let tk =-            TKUnknown-                (signer, Nothing)-                []-                [(uidText, [certification, retirementRevocation])]-                []-                []+    let tk :: TK 'PublicTK =+            TK+                { _tkPrimaryKey = KeyPktPublicPrimary signer+                , _tkRevs = []+                , _tkUIDs = [(uidText, [certification, retirementRevocation])]+                , _tkUAts = []+                , _tkSubs = []+                }         verifyAt ts =-            verifyUnknownTKWith+            verifyTKWith                 (verifySigWith defaultVerificationPolicy (verifyAgainstKeys [tk]))                 (Just (timestampToUTCTime ts))                 tk@@ -1328,11 +1391,11 @@     assertEqual         "uid-retired revocation should preserve the UID before it becomes effective"         1-        (length (_tkuUIDs beforeRetirement))+        (length (_tkUIDs beforeRetirement))     assertEqual         "uid-retired revocation should retire the UID once effective"         0-        (length (_tkuUIDs afterRetirement))+        (length (_tkUIDs afterRetirement))  testThirdPartyCertificationDoesNotAffectKeyValidityWindow     :: Assertion@@ -1353,16 +1416,24 @@             uid             certificationTime             [SigSubPacket False (KeyExpirationTime 30)]-    let targetTK =-            TKUnknown-                (targetSigner, Nothing)-                []-                [(uidText, [thirdPartyCertification])]-                []-                []-        certifierTK = TKUnknown (thirdPartySigner, Nothing) [] [] [] []+    let targetTK :: TK 'PublicTK =+            TK+                { _tkPrimaryKey = KeyPktPublicPrimary targetSigner+                , _tkRevs = []+                , _tkUIDs = [(uidText, [thirdPartyCertification])]+                , _tkUAts = []+                , _tkSubs = []+                }+        certifierTK =+            TK+                { _tkPrimaryKey = KeyPktPublicPrimary thirdPartySigner+                , _tkRevs = []+                , _tkUIDs = []+                , _tkUAts = []+                , _tkSubs = []+                }         verifyAt =-            verifyUnknownTKWith+            verifyTKWith                 ( verifySigWith                     defaultVerificationPolicy                     (verifyAgainstKeys [targetTK, certifierTK])@@ -1418,24 +1489,33 @@             uid             thirdPartyRevocationTime             []-    let targetTK =-            TKUnknown-                (targetSigner, Nothing)-                []-                [-                    ( uidText-                    ,-                        [ selfCertification-                        , thirdPartyCertification-                        , thirdPartyRevocation-                        ]-                    )-                ]-                []-                []-        certifierTK = TKUnknown (thirdPartySigner, Nothing) [] [] [] []+    let targetTK :: TK 'PublicTK =+            TK+                { _tkPrimaryKey = KeyPktPublicPrimary targetSigner+                , _tkRevs = []+                , _tkUIDs =+                    [+                        ( uidText+                        ,+                            [ selfCertification+                            , thirdPartyCertification+                            , thirdPartyRevocation+                            ]+                        )+                    ]+                , _tkUAts = []+                , _tkSubs = []+                }+        certifierTK =+            TK+                { _tkPrimaryKey = KeyPktPublicPrimary thirdPartySigner+                , _tkRevs = []+                , _tkUIDs = []+                , _tkUAts = []+                , _tkSubs = []+                }         verifyAt ts =-            verifyUnknownTKWith+            verifyTKWith                 ( verifySigWith                     defaultVerificationPolicy                     (verifyAgainstKeys [targetTK, certifierTK])@@ -1466,12 +1546,12 @@             maybe                 []                 snd-                (find ((== uidText) . fst) (_tkuUIDs beforeRevocation))+                (find ((== uidText) . fst) (_tkUIDs beforeRevocation))         afterSigs =             maybe                 []                 snd-                (find ((== uidText) . fst) (_tkuUIDs afterRevocation))+                (find ((== uidText) . fst) (_tkUIDs afterRevocation))     assertEqual         "certification revocations should not apply before they become effective"         [selfCertification, thirdPartyCertification]@@ -1509,21 +1589,23 @@     certificationRevocation <-         signCertificationRevocationAt signer signingKey uid t3 [] -    let tk =-            TKUnknown-                (signer, Nothing)-                []-                [-                    ( uidText-                    ,-                        [ initialCertification-                        , updatedCertification-                        , certificationRevocation-                        ]-                    )-                ]-                []-                []+    let tk :: TK 'PublicTK =+            TK+                { _tkPrimaryKey = KeyPktPublicPrimary signer+                , _tkRevs = []+                , _tkUIDs =+                    [+                        ( uidText+                        ,+                            [ initialCertification+                            , updatedCertification+                            , certificationRevocation+                            ]+                        )+                    ]+                , _tkUAts = []+                , _tkSubs = []+                }      assertEqual         "key preferences at timestamp should use the latest active self-certification"@@ -2227,8 +2309,8 @@                 (EdDSAPrivateKey EdSigningCurve25519 secretBytes)                 skey -testFromPrimaryKeyPktToTKUnknownRejectsSubkey :: Assertion-testFromPrimaryKeyPktToTKUnknownRejectsSubkey = do+testFromPrimaryKeyPktToSomeTKRejectsSubkey :: Assertion+testFromPrimaryKeyPktToSomeTKRejectsSubkey = do     packets <-         DC.runConduitRes $             CB.sourceFile "tests/data/unencrypted.seckey"@@ -2236,14 +2318,261 @@                 DC..| CL.consume     case packets of         (SecretKeyPkt pkp _ : _) ->-            case fromPrimaryKeyPktToTKUnknown (PublicSubkeyPkt pkp) of+            case fromPrimaryKeyPktToSomeTK (PublicSubkeyPkt pkp) of                 Left err ->                     assertBool-                        "fromPrimaryKeyPktToTKUnknown should report non-primary packet tags"+                        "fromPrimaryKeyPktToSomeTK should report non-primary packet tags"                         ("expected primary key packet" `isInfixOf` err)                 Right _ ->                     assertFailure-                        "fromPrimaryKeyPktToTKUnknown should reject subkey packets"+                        "fromPrimaryKeyPktToSomeTK should reject subkey packets"         _ ->             assertFailure                 "unencrypted.seckey did not begin with a secret key packet"++testHighLevelDecryptSecretKeyLegacy :: Assertion+testHighLevelDecryptSecretKeyLegacy = do+    passphrase <- readPKIPassphrase+    packets <-+        DC.runConduitRes $+            CB.sourceFile "tests/data/aes256-sha512.seckey"+                DC..| conduitGet get+                DC..| CL.consume+    (SecretKey pkp ska) <-+        case packets of+            (SecretKeyPkt pkpayload skaddendum : _) -> pure (SecretKey pkpayload skaddendum)+            _ ->+                assertFailure+                    "aes256-sha512.seckey did not begin with a secret key packet"+                    >> fail "expected secret key packet"+    skey <-+        case decryptSecretKey (SecretKey pkp ska) (Passphrase passphrase) of+            Left err ->+                assertFailure+                    ("high-level decrypt of legacy key failed: " ++ show err)+                    >> fail "high-level decrypt failed"+            Right x -> pure x+    originalSKey <-+        case decryptPrivateKey+            (pkp, ska)+            (unPassphrase (Passphrase passphrase)) of+            Right (SUUnencrypted skey' _) -> pure skey'+            _ -> fail "expected unencrypted secret key"+    assertEqual+        "high-level decrypt should preserve secret key material"+        originalSKey+        skey++testHighLevelDecryptSecretKeyV6 :: Assertion+testHighLevelDecryptSecretKeyV6 = do+    oldPassphrase <- readPKIPassphrase+    armors <- loadArmor "v6-encrypted-secret.pgp.aa"+    armor <-+        case armors of+            (a : _) -> pure a+            [] ->+                assertFailure+                    "v6-encrypted-secret.pgp.aa should contain one armored payload"+                    >> fail "expected one armored payload"+    let packets = parsePkts (armorPayload armor)+    SecretKey pkp ska <-+        case packets of+            (SecretKeyPkt pkpayload skaddendum : _) -> pure (SecretKey pkpayload skaddendum)+            _ ->+                assertFailure+                    "v6-encrypted-secret.pgp.aa did not begin with a secret key packet"+                    >> fail "expected secret key packet"+    skey <-+        case decryptSecretKey (SecretKey pkp ska) (Passphrase oldPassphrase) of+            Left err ->+                assertFailure+                    ("high-level decrypt of v6 key failed: " ++ show err)+                    >> fail "high-level decrypt failed"+            Right x -> pure x+    originalSKey <-+        case decryptPrivateKey+            (pkp, ska)+            (unPassphrase (Passphrase oldPassphrase)) of+            Right (SUUnencrypted skey' _) -> pure skey'+            _ -> fail "expected unencrypted secret key"+    assertEqual+        "high-level decrypt should preserve v6 secret key material"+        originalSKey+        skey++testHighLevelReencryptSecretKeyLegacy :: Assertion+testHighLevelReencryptSecretKeyLegacy = do+    passphrase <- readPKIPassphrase+    packets <-+        DC.runConduitRes $+            CB.sourceFile "tests/data/aes256-sha512.seckey"+                DC..| conduitGet get+                DC..| CL.consume+    SecretKey pkp ska <-+        case packets of+            (SecretKeyPkt pkpayload skaddendum : _) -> pure (SecretKey pkpayload skaddendum)+            _ ->+                assertFailure+                    "aes256-sha512.seckey did not begin with a secret key packet"+                    >> fail "expected secret key packet"+    let salt = Salt "12345678"+        iv = IV "1234567890ABCDEF"+        opts =+            SecretKeyEncryptOptions+                { skeoPolicy = defaultPolicy+                , skeoGenerateSaltAndIV = False+                , skeoSalt = Just salt+                , skeoIV = Just iv+                }+    result <-+        reencryptSecretKey+            (SecretKey pkp ska)+            (Passphrase passphrase)+            (Passphrase "changed-pki-password")+            opts+    changed <-+        case result of+            Left err ->+                assertFailure+                    ( "high-level legacy passphrase change failed: "+                        ++ show err+                    )+                    >> fail "high-level passphrase change failed"+            Right sk' -> pure sk'+    decrypted <-+        case decryptSecretKey changed (Passphrase "changed-pki-password") of+            Left err ->+                assertFailure+                    ("decryption with changed legacy passphrase failed: " ++ show err)+                    >> fail "decryption with changed legacy passphrase failed"+            Right x -> pure x+    originalSKey <-+        case decryptPrivateKey+            (pkp, ska)+            (unPassphrase (Passphrase passphrase)) of+            Right (SUUnencrypted skey' _) -> pure skey'+            _ -> fail "expected unencrypted secret key"+    assertEqual+        "high-level legacy passphrase change should preserve secret key material"+        originalSKey+        decrypted+    case decryptSecretKey changed (Passphrase passphrase) of+        Right _ ->+            assertFailure+                "decryption with old legacy passphrase should fail after passphrase change"+        Left _ -> pure ()++testHighLevelReencryptSecretKeyV6 :: Assertion+testHighLevelReencryptSecretKeyV6 = do+    oldPassphrase <- readPKIPassphrase+    armors <- loadArmor "v6-encrypted-secret.pgp.aa"+    armor <-+        case armors of+            (a : _) -> pure a+            [] ->+                assertFailure+                    "v6-encrypted-secret.pgp.aa should contain one armored payload"+                    >> fail "expected one armored payload"+    let packets = parsePkts (armorPayload armor)+    SecretKey pkp ska <-+        case packets of+            (SecretKeyPkt pkpayload skaddendum : _) -> pure (SecretKey pkpayload skaddendum)+            _ ->+                assertFailure+                    "v6-encrypted-secret.pgp.aa did not begin with a secret key packet"+                    >> fail "expected secret key packet"+    result <-+        changeSecretKeyPassphrase+            (SecretKey pkp ska)+            (Passphrase oldPassphrase)+            (Passphrase "changed-pki-password")+    changed <-+        case result of+            Left err ->+                assertFailure+                    ( "high-level v6 passphrase change failed: "+                        ++ show err+                    )+                    >> fail "high-level v6 passphrase change failed"+            Right sk' -> pure sk'+    decrypted <-+        case decryptSecretKey changed (Passphrase "changed-pki-password") of+            Left err ->+                assertFailure+                    ("decryption with changed v6 passphrase failed: " ++ show err)+                    >> fail "decryption with changed v6 passphrase failed"+            Right x -> pure x+    originalSKey <-+        case decryptPrivateKey+            (pkp, ska)+            (unPassphrase (Passphrase oldPassphrase)) of+            Right (SUUnencrypted skey' _) -> pure skey'+            _ -> fail "expected unencrypted secret key"+    assertEqual+        "high-level v6 passphrase change should preserve secret key material"+        originalSKey+        decrypted+    case decryptSecretKey changed (Passphrase oldPassphrase) of+        Right _ ->+            assertFailure+                "decryption with old v6 passphrase should fail after passphrase change"+        Left _ -> pure ()++testHighLevelReencryptDeterministic :: Assertion+testHighLevelReencryptDeterministic = do+    passphrase <- readPKIPassphrase+    packets <-+        DC.runConduitRes $+            CB.sourceFile "tests/data/aes256-sha512.seckey"+                DC..| conduitGet get+                DC..| CL.consume+    SecretKey pkp ska <-+        case packets of+            (SecretKeyPkt pkpayload skaddendum : _) -> pure (SecretKey pkpayload skaddendum)+            _ ->+                assertFailure+                    "aes256-sha512.seckey did not begin with a secret key packet"+                    >> fail "expected secret key packet"+    let salt = Salt "12345678"+        iv = IV "1234567890ABCDEF"+        opts =+            SecretKeyEncryptOptions+                { skeoPolicy = defaultPolicy+                , skeoGenerateSaltAndIV = False+                , skeoSalt = Just salt+                , skeoIV = Just iv+                }+    result1 <-+        reencryptSecretKey+            (SecretKey pkp ska)+            (Passphrase passphrase)+            (Passphrase passphrase)+            opts+    changed1 <-+        case result1 of+            Left err ->+                assertFailure+                    ( "deterministic re-encrypt #1 failed: "+                        ++ show err+                    )+                    >> fail "deterministic re-encrypt #1 failed"+            Right sk' -> pure sk'+    result2 <-+        reencryptSecretKey+            (SecretKey pkp ska)+            (Passphrase passphrase)+            (Passphrase passphrase)+            opts+    changed2 <-+        case result2 of+            Left err ->+                assertFailure+                    ( "deterministic re-encrypt #2 failed: "+                        ++ show err+                    )+                    >> fail "deterministic re-encrypt #2 failed"+            Right sk' -> pure sk'+    assertEqual+        "deterministic salt/IV should produce identical re-encrypted keys"+        (_secretKeySKAddendum changed1)+        (_secretKeySKAddendum changed2)
tests/Tests/MessageAndArmor.hs view
@@ -12,6 +12,7 @@     ( Armor (..)     , ArmorType (..)     )+import Control.Lens ((^.)) import qualified Crypto.PubKey.Ed25519 as Ed25519 import qualified Crypto.PubKey.RSA as RSA import Data.Binary (get, put)@@ -53,7 +54,7 @@     ) import Codec.Encryption.OpenPGP.Internal (emptyPSC, lastLD) import qualified Codec.Encryption.OpenPGP.Internal.Whitespace as WS-import Codec.Encryption.OpenPGP.KeyringParser (parseUnknownTKs)+import Codec.Encryption.OpenPGP.KeyringParser (parsePublicTKs) import Codec.Encryption.OpenPGP.Message import Codec.Encryption.OpenPGP.Policy     ( defaultVerificationPolicy@@ -105,6 +106,9 @@     ) import Codec.Encryption.OpenPGP.Types import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA+import Codec.Encryption.OpenPGP.Types.Internal.TK+    ( someTKToPublicTK+    ) import Data.Conduit.OpenPGP.Message     ( verifyMessage     , verifyMessagePackets@@ -269,7 +273,7 @@                 "v4-encrypted.rev.aa SigV4 key-revocation semantics"                 testV4RevocationSignatureSemantics             , testCase-                "v4-encrypted.rev.aa parses as single revocation TKUnknown"+                "v4-encrypted.rev.aa parses as single revocation TK"                 ( testRevocationArmorParsesAsSingleTransferableKey                     "v4-encrypted.rev.aa"                     True@@ -284,7 +288,7 @@                 "v6.rev.aa forbids legacy Issuer key-id subpackets"                 (testV6RevocationSignatureRejectsLegacyIssuerKeyID "v6.rev.aa")             , testCase-                "v6.rev.aa parses as single revocation TKUnknown"+                "v6.rev.aa parses as single revocation TK"                 (testRevocationArmorParsesAsSingleTransferableKey "v6.rev.aa" True)             , testCase                 "v6-encrypted.rev.aa decodes as a v6 revocation certificate"@@ -298,7 +302,7 @@                     "v6-encrypted.rev.aa"                 )             , testCase-                "v6-encrypted.rev.aa parses as single revocation TKUnknown"+                "v6-encrypted.rev.aa parses as single revocation TK"                 ( testRevocationArmorParsesAsSingleTransferableKey                     "v6-encrypted.rev.aa"                     True@@ -649,7 +653,7 @@                 assertFailure                     (fixture ++ " should contain one armored public-key payload")                     >> fail "expected one armored payload"-    let tks = parseUnknownTKs True (parsePkts payload)+    let tks = parsePublicTKs True (parsePkts payload)     case tks of         [tk] -> do             if expectDirectRevs@@ -658,22 +662,22 @@                         ( fixture                             ++ " transferable key should contain at least one direct-key revocation signature"                         )-                        (not (null (_tkuRevs tk)))+                        (not (null (tk ^. tkRevs)))                 else pure ()             assertEqual                 (fixture ++ " revocation certificate should not carry user IDs")                 []-                (_tkuUIDs tk)+                (tk ^. tkUIDs)             assertEqual                 ( fixture                     ++ " revocation certificate should not carry user attributes"                 )                 []-                (_tkuUAts tk)+                (tk ^. tkUAts)             assertEqual                 (fixture ++ " revocation certificate should not carry subkeys")                 []-                (_tkuSubs tk)+                (tk ^. tkSubs)         _ ->             assertFailure                 (fixture ++ " should parse into exactly one transferable key")@@ -708,7 +712,7 @@  testDefaultedEncryptDecrypt :: Assertion testDefaultedEncryptDecrypt = do-    let passphrase = mkPassphrase "roundtrip1"+    let passphrase = Passphrase "roundtrip1"         payload = mkClearPayload "hello from a balloon farm on Mars"         encryptedResult =             encryptMessageDefault@@ -751,7 +755,7 @@  testExplicitEncryptDecrypt :: Assertion testExplicitEncryptDecrypt = do-    let passphrase = mkPassphrase "roundtrip2"+    let passphrase = Passphrase "roundtrip2"         payload = mkClearPayload "hello from nonsenseville"         s2k = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15         iv = IV "1234567890ABCDEF"@@ -803,7 +807,7 @@ testExplicitEncryptExposesEffectiveSessionMaterial :: Assertion testExplicitEncryptExposesEffectiveSessionMaterial = do     let passphraseBytes = "roundtrip2-session-material"-        passphrase = mkPassphrase passphraseBytes+        passphrase = Passphrase passphraseBytes         payload = mkClearPayload "hello from session material town"         sa = AES128         s2k = Argon2 (Salt16 (B.pack [0x40 .. 0x4f])) 1 4 15@@ -862,7 +866,7 @@  testDefaultEncryptDoesNotExposeSessionMaterial :: Assertion testDefaultEncryptDoesNotExposeSessionMaterial = do-    let passphrase = mkPassphrase "roundtrip-default-no-session-material"+    let passphrase = Passphrase "roundtrip-default-no-session-material"         payload = mkClearPayload "hello from hidden-session-material town"     (_, recovered) <-         do@@ -889,7 +893,7 @@     let passphraseBytes =             "roundtrip-"                 <> BL.fromStrict (B.pack (map (fromIntegral . fromEnum) label))-        passphrase = mkPassphrase passphraseBytes+        passphrase = Passphrase passphraseBytes         payload =             mkClearPayload                 ( "hello from "@@ -994,7 +998,7 @@  testExplicitEncryptRejectsDeprecatedS2KHash :: Assertion testExplicitEncryptRejectsDeprecatedS2KHash = do-    let passphrase = mkPassphrase "roundtrip2b"+    let passphrase = Passphrase "roundtrip2b"         payload = mkClearPayload "modern-path deprecated s2k hash rejection"         s2k = Salted SHA1 (Salt8 "12345678")         iv = IV "1234567890ABCDEF"@@ -1026,7 +1030,7 @@  testLegacyFallbackEncryptDecrypt :: Assertion testLegacyFallbackEncryptDecrypt = do-    let passphrase = mkPassphrase "roundtrip3"+    let passphrase = Passphrase "roundtrip3"         payload = mkClearPayload "hello from legacy town"         s2k = Salted SHA1 (Salt8 "12345678")         iv = IV mempty@@ -1069,7 +1073,7 @@ testRFC4880EncryptMessageSEIPDv1ParsesCleanly :: Assertion testRFC4880EncryptMessageSEIPDv1ParsesCleanly = do     let passphraseBytes = "legacy-clean-parse" :: BL.ByteString-        passphrase = mkPassphrase passphraseBytes+        passphrase = Passphrase passphraseBytes         payload = mkClearPayload "hello from clean legacy town"         s2k =             IteratedSalted SHA256 (Salt8 "saltxyz!") (IterationCount 65536)@@ -1158,7 +1162,7 @@  testDecryptMessageTypedParseFailure :: Assertion testDecryptMessageTypedParseFailure = do-    let passphrase = mkPassphrase "unused"+    let passphrase = Passphrase "unused"         encrypted = mkEncryptedPayload BL.empty     case decryptMessage passphrase encrypted of         Left (MessageParseFailureError MissingEncryptedMessage) -> pure ()@@ -1173,7 +1177,7 @@  testDecryptMessageRejectsUnknownCriticalPacket :: Assertion testDecryptMessageRejectsUnknownCriticalPacket = do-    let passphrase = mkPassphrase "unused"+    let passphrase = Passphrase "unused"         encrypted =             mkEncryptedPayload . runPut . put $                 Block [OtherPacketPkt 39 "unknown-critical"]@@ -1192,8 +1196,8 @@  testDecryptMessageTypedDecryptFailure :: Assertion testDecryptMessageTypedDecryptFailure = do-    let correctPassphrase = mkPassphrase "correct passphrase"-        wrongPassphrase = mkPassphrase "wrong passphrase"+    let correctPassphrase = Passphrase "correct passphrase"+        wrongPassphrase = Passphrase "wrong passphrase"         payload = mkClearPayload "typed decrypt failure payload"         encryptedResult =             encryptMessageDefault@@ -1219,7 +1223,7 @@  testDecryptMessageSEIPDv1MDCTampering :: Assertion testDecryptMessageSEIPDv1MDCTampering = do-    let passphrase = mkPassphrase "mdc-tamper-test"+    let passphrase = Passphrase "mdc-tamper-test"         payload = mkClearPayload "payload for MDC tampering test"         s2k =             IteratedSalted SHA256 (Salt8 "saltxyz!") (IterationCount 65536)@@ -1313,7 +1317,15 @@                     >> fail "unexpected RSA SigV6 signMessage output shape"     let state =             emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}-        keyring = [TKUnknown (signer, Nothing) [] [] [] []]+        keyring =+            [ TK+                { _tkPrimaryKey = KeyPktPublicPrimary signer+                , _tkRevs = []+                , _tkUIDs = []+                , _tkUAts = []+                , _tkSubs = []+                }+            ]     case verifySigWith         defaultVerificationPolicy         (verifyAgainstKeys keyring)@@ -1356,7 +1368,15 @@                     >> fail "unexpected Ed25519 signMessage output shape"     let state =             emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}-        keyring = [TKUnknown (signer, Nothing) [] [] [] []]+        keyring =+            [ TK+                { _tkPrimaryKey = KeyPktPublicPrimary signer+                , _tkRevs = []+                , _tkUIDs = []+                , _tkUAts = []+                , _tkSubs = []+                }+            ]     case verifySigWith         defaultVerificationPolicy         (verifyAgainstKeys keyring)@@ -1406,7 +1426,15 @@         SignaturePkt (SigV6 BinarySig PKA.Ed25519 SHA512 _ _ _ _ _) -> do             let state =                     emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}-                keyring = [TKUnknown (signer, Nothing) [] [] [] []]+                keyring =+                    [ TK+                        { _tkPrimaryKey = KeyPktPublicPrimary signer+                        , _tkRevs = []+                        , _tkUIDs = []+                        , _tkUAts = []+                        , _tkSubs = []+                        }+                    ]             case verifySigWith                 defaultVerificationPolicy                 (verifyAgainstKeys keyring)@@ -1472,7 +1500,15 @@                     >> fail "unexpected Ed448 signMessage output shape"     let state =             emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}-        keyring = [TKUnknown (signer, Nothing) [] [] [] []]+        keyring =+            [ TK+                { _tkPrimaryKey = KeyPktPublicPrimary signer+                , _tkRevs = []+                , _tkUIDs = []+                , _tkUAts = []+                , _tkSubs = []+                }+            ]     case verifySigWith         defaultVerificationPolicy         (verifyAgainstKeys keyring)@@ -1586,7 +1622,16 @@     let payload = "detached v4 eddsa payload without issuer hints"         state =             emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}-        keyring = mkTestKeyring [TKUnknown (signer, Nothing) [] [] [] []]+        keyring =+            mkTestKeyring+                [ TK+                    { _tkPrimaryKey = KeyPktPublicPrimary signer+                    , _tkRevs = []+                    , _tkUIDs = []+                    , _tkUAts = []+                    , _tkSubs = []+                    }+                ]     sigPayload <-         case signDataWithEd25519 BinarySig signingKey [] [] payload of             Left err ->@@ -1613,7 +1658,16 @@     let payload = "detached v4 eddsa payload with fake issuer hint"         state =             emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}-        keyring = mkTestKeyring [TKUnknown (signer, Nothing) [] [] [] []]+        keyring =+            mkTestKeyring+                [ TK+                    { _tkPrimaryKey = KeyPktPublicPrimary signer+                    , _tkRevs = []+                    , _tkUIDs = []+                    , _tkUAts = []+                    , _tkSubs = []+                    }+                ]         fakeIssuer = EightOctetKeyId "\x01\x23\x45\x67\x89\xab\xcd\xef"         unhashed = [SigSubPacket False (Issuer fakeIssuer)]     sigPayload <-@@ -1644,7 +1698,15 @@             "detached v4 eddsa payload without issuer hints (verifyAgainstKeys)"         state =             emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}-        keys = [TKUnknown (signer, Nothing) [] [] [] []]+        keys =+            [ TK+                { _tkPrimaryKey = KeyPktPublicPrimary signer+                , _tkRevs = []+                , _tkUIDs = []+                , _tkUAts = []+                , _tkSubs = []+                }+            ]     sigPayload <-         case signDataWithEd25519 BinarySig signingKey [] [] payload of             Left err ->@@ -1673,7 +1735,15 @@             "detached v4 eddsa payload with fake issuer hint (verifyAgainstKeys)"         state =             emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}-        keys = [TKUnknown (signer, Nothing) [] [] [] []]+        keys =+            [ TK+                { _tkPrimaryKey = KeyPktPublicPrimary signer+                , _tkRevs = []+                , _tkUIDs = []+                , _tkUAts = []+                , _tkSubs = []+                }+            ]         fakeIssuer = EightOctetKeyId "\x01\x23\x45\x67\x89\xab\xcd\xef"         unhashed = [SigSubPacket False (Issuer fakeIssuer)]     sigPayload <-@@ -1980,7 +2050,16 @@         CertRevocationSig         (signCertRevocationWithRSA signer userId [] [] signingKey)     let left16Payload = "left16 primitive payload"-        left16Keyring = mkTestKeyring [TKUnknown (signer, Nothing) [] [] [] []]+        left16Keyring =+            mkTestKeyring+                [ TK+                    { _tkPrimaryKey = KeyPktPublicPrimary signer+                    , _tkRevs = []+                    , _tkUIDs = []+                    , _tkUAts = []+                    , _tkSubs = []+                    }+                ]     left16Sig <-         case signDataWithRSA BinarySig signingKey [] [] left16Payload of             Left err ->@@ -2360,7 +2439,15 @@     sigAfter <-         signBinaryMessageWithRSAAt signer signingKey sigAfterTime payload     let keyring =-            mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []]+            mkTestKeyring+                [ TK+                    { _tkPrimaryKey = KeyPktPublicPrimary signer+                    , _tkRevs = [revocation]+                    , _tkUIDs = []+                    , _tkUAts = []+                    , _tkSubs = []+                    }+                ]     assertSingleSignerFingerprint         "soft primary revocation should preserve pre-revocation signatures"         (fingerprint signer)@@ -2390,7 +2477,15 @@             revocationTime             KeyMaterialCompromised     let keyring =-            mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []]+            mkTestKeyring+                [ TK+                    { _tkPrimaryKey = KeyPktPublicPrimary signer+                    , _tkRevs = [revocation]+                    , _tkUIDs = []+                    , _tkUAts = []+                    , _tkSubs = []+                    }+                ]     assertSingleFailureContainsTimeline         "hard primary revocation should reject even pre-revocation signatures"         "signing key is revoked"@@ -2416,7 +2511,15 @@             revocationTime             NoReason     let keyring =-            mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []]+            mkTestKeyring+                [ TK+                    { _tkPrimaryKey = KeyPktPublicPrimary signer+                    , _tkRevs = [revocation]+                    , _tkUIDs = []+                    , _tkUAts = []+                    , _tkSubs = []+                    }+                ]     assertSingleFailureContainsTimeline         "no-reason primary revocation should reject even pre-revocation signatures"         "signing key is revoked"@@ -2442,7 +2545,15 @@             revocationTime             (RCoOther 100)     let keyring =-            mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []]+            mkTestKeyring+                [ TK+                    { _tkPrimaryKey = KeyPktPublicPrimary signer+                    , _tkRevs = [revocation]+                    , _tkUIDs = []+                    , _tkUAts = []+                    , _tkSubs = []+                    }+                ]     assertSingleFailureContainsTimeline         "unknown-reason primary revocation should reject even pre-revocation signatures"         "signing key is revoked"@@ -2472,7 +2583,15 @@     sigAfter <-         signBinaryMessageWithRSAAt signer signingKey sigAfterTime payload     let keyring =-            mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []]+            mkTestKeyring+                [ TK+                    { _tkPrimaryKey = KeyPktPublicPrimary signer+                    , _tkRevs = [revocation]+                    , _tkUIDs = []+                    , _tkUAts = []+                    , _tkSubs = []+                    }+                ]     assertSingleSignerFingerprint         "non-compromise primary revocation should preserve pre-revocation signatures"         (fingerprint signer)@@ -2513,7 +2632,15 @@     sigAfter <-         signBinaryMessageWithRSAAt signer signingKey sigAfterTime payload     let keyring =-            mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []]+            mkTestKeyring+                [ TK+                    { _tkPrimaryKey = KeyPktPublicPrimary signer+                    , _tkRevs = [revocation]+                    , _tkUIDs = []+                    , _tkUAts = []+                    , _tkSubs = []+                    }+                ]     assertSingleSignerFingerprint         "temporary primary revocation should preserve pre-revocation signatures"         (fingerprint signer)@@ -2538,7 +2665,7 @@         sigBeforeTime = addTimestampSeconds keyCreated 20         revocationTime = addTimestampSeconds keyCreated 30         sigAfterTime = addTimestampSeconds keyCreated 40-        subkeyPacket = PublicSubkeyPkt subkeySigner+        subkeyPacket = KeyPktPublicSubkey subkeySigner     bindingSig <-         signSubkeyBindingWithRSAAt             primarySigner@@ -2565,12 +2692,13 @@             payload     let keyring =             mkTestKeyring-                [ TKUnknown-                    (primarySigner, Nothing)-                    []-                    []-                    []-                    [(subkeyPacket, [bindingSig, revocationSig])]+                [ TK+                    { _tkPrimaryKey = KeyPktPublicPrimary primarySigner+                    , _tkRevs = []+                    , _tkUIDs = []+                    , _tkUAts = []+                    , _tkSubs = [(subkeyPacket, [bindingSig, revocationSig])]+                    }                 ]     assertSingleSignerFingerprint         "subkey revocation should preserve pre-revocation signatures"@@ -2693,7 +2821,14 @@             emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}         keyring =             mkTestKeyring-                [TKUnknown (signerWithEd25519Pka, Nothing) [] [] [] []]+                [ TK+                    { _tkPrimaryKey = KeyPktPublicPrimary signerWithEd25519Pka+                    , _tkRevs = []+                    , _tkUIDs = []+                    , _tkUAts = []+                    , _tkSubs = []+                    }+                ]     signedResult <-         signMessageWith             (mkEd25519SignerV4 signerV4 signingKey)
tests/Tests/Serialization.hs view
@@ -7,6 +7,7 @@ module Tests.Serialization (serializationTests) where  import Control.Applicative ((<|>))+import Control.Lens ((^.)) import Control.Monad (forM_) import Crypto.Number.Serialize (os2ip) import qualified Crypto.PubKey.ECC.ECDSA as ECDSA@@ -432,7 +433,9 @@ testTKRoundtrip :: FilePath -> TKWithWireRep -> Assertion testTKRoundtrip fpr tk = do     let packets = _tkPackets tk-        encoded = runPut (put (Block (map _pktValue packets)))+        encoded =+            runPut+                (put (Block (map (\p -> p ^. pktWireRep . pktValue) packets)))     case runGet (get :: Get (Block Pkt)) encoded of         Left err ->             assertFailure $@@ -440,7 +443,7 @@         Right reparsedBlock ->             assertEqual                 ("TKUnknown packet re-serialization roundtrip for " ++ fpr)-                (Block (map _pktValue packets))+                (Block (map (\p -> p ^. pktWireRep . pktValue) packets))                 reparsedBlock     case toStructuredTKWithWireRep tk of         Left err ->
tests/Tests/Utilities.hs view
@@ -7,6 +7,7 @@ module Tests.Utilities (utilityTests) where  import Control.Error.Util (hush)+import Control.Lens (view, (^.)) import Control.Monad (join) import Crypto.Number.Serialize (os2ip) import Data.Binary (get)@@ -754,22 +755,23 @@     let src = wireRepRef "src"         pktA =             PktWithWireRep+                (PktWithBytes "a" (OtherPacketPkt 42 "a"))                 src                 (ByteRange 0 1)-                "a"                 0-                (OtherPacketPkt 42 "a")         pktB =             PktWithWireRep+                (PktWithBytes "b" (BrokenPacketPkt "broken" 42 "b"))                 src                 (ByteRange 1 1)-                "b"                 1-                (BrokenPacketPkt "broken" 42 "b")     assertEqual         "base packet ordering can tie on tag-only fallback"         EQ-        (compare (_pktValue pktA) (_pktValue pktB))+        ( compare+            (pktA ^. pktWireRep . pktValue)+            (pktB ^. pktWireRep . pktValue)+        )     assertEqual         "PktWithWireRep ordering should break ties using packet bytes"         LT@@ -807,7 +809,7 @@     assertEqual         "provenance-aware parsePkts preserves packet semantics"         (parsePkts lbs)-        (map _pktValue parsed)+        (map (\p -> view (pktWireRep . pktValue) p) parsed)     assertEqual         "conduit and pure provenance-aware packet parsing agree"         parsed@@ -847,7 +849,10 @@                     (wireRepRefFromInput Nothing lbs)         packets = parsePktsWithWireRep src srcBytes         parsed = parseTKsWithWireRep True packets-        plain = parseUnknownTKs True (map _pktValue packets)+        plain =+            parseUnknownTKs+                True+                (map (\p -> view (pktWireRep . pktValue) p) packets)     conduitParsed <-         DC.runConduitRes $             CL.sourceList packets@@ -874,8 +879,8 @@ assertPktProvenance src srcBytes pkt = do     assertEqual         "packet raw bytes round-trip back to the same packet"-        (Right (_pktValue pkt))-        (runGet (get :: Get Pkt) (_pktRaw pkt))+        (Right (pkt ^. pktWireRep . pktValue))+        (runGet (get :: Get Pkt) (pkt ^. pktWireRep . pktRaw))     assertEqual         "packet source reference is preserved"         src@@ -883,7 +888,7 @@     let ByteRange offset len = _pktRange pkt     assertEqual         "packet raw bytes match the source bytestream slice"-        (_pktRaw pkt)+        (pkt ^. pktWireRep . pktRaw)         (BL.take len (BL.drop offset srcBytes))  assertTKProvenance@@ -899,7 +904,7 @@     assertEqual         "TKUnknown packet references reconstruct the semantic TKUnknown packet sequence"         (flattenTK (_tkValue tk))-        (map _pktValue (packetRefsOfTK tk))+        (map (\p -> view (pktWireRep . pktValue) p) (packetRefsOfTK tk))     assertEqual         "TKUnknown source span matches the span of its packet references"         (spanByteRanges (map _pktRange (packetRefsOfTK tk)))@@ -926,8 +931,8 @@             resolved <- resolveStructuredPacketRefs structured             assertEqual                 "structured provenance resolves packet refs in TKUnknown packet order"-                (map _pktValue (packetRefsOfTK tk))-                (map _pktValue resolved)+                (map (\p -> view (pktWireRep . pktValue) p) (packetRefsOfTK tk))+                (map (\p -> view (pktWireRep . pktValue) p) resolved)             assertEqual                 "structured provenance keeps stable packet ref ids"                 (map packetRefIdOf (packetRefsOfTK tk))@@ -1119,7 +1124,7 @@         wireBytes refId =             maybe                 (Left ("lookupPacketRef failed for ref id " ++ show refId))-                (Right . _pktRaw)+                (Right . (\p -> p ^. pktWireRep . pktRaw))                 (lookupPacketRef structured refId)          sortSigs sigs = do@@ -1338,7 +1343,10 @@             assertEqual                 "Semigroup result packet refs match merged TKUnknown packet sequence"                 (flattenTK (_tkValue merged))-                (map _pktValue (packetRefsOfTK merged))+                ( map+                    (\p -> view (pktWireRep . pktValue) p)+                    (packetRefsOfTK merged)+                )             assertEqual                 "Semigroup result keeps packet refs unique by source-aware PacketRefId"                 (length mergedRefIds)@@ -1351,8 +1359,11 @@                     resolved <- resolveStructuredPacketRefs structured                     assertEqual                         "Semigroup result structured refs resolve in packet order"-                        (map _pktValue (packetRefsOfTK merged))-                        (map _pktValue resolved)+                        ( map+                            (\p -> view (pktWireRep . pktValue) p)+                            (packetRefsOfTK merged)+                        )+                        (map (\p -> view (pktWireRep . pktValue) p) resolved)         [] ->             assertFailure                 "pubring.gpg should parse to at least one provenance-aware TKUnknown"