diff --git a/Codec/Encryption/OpenPGP/Encrypt.hs b/Codec/Encryption/OpenPGP/Encrypt.hs --- a/Codec/Encryption/OpenPGP/Encrypt.hs +++ b/Codec/Encryption/OpenPGP/Encrypt.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Expirations.hs b/Codec/Encryption/OpenPGP/Expirations.hs --- a/Codec/Encryption/OpenPGP/Expirations.hs +++ b/Codec/Encryption/OpenPGP/Expirations.hs @@ -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) diff --git a/Codec/Encryption/OpenPGP/KeyringParser.hs b/Codec/Encryption/OpenPGP/KeyringParser.hs --- a/Codec/Encryption/OpenPGP/KeyringParser.hs +++ b/Codec/Encryption/OpenPGP/KeyringParser.hs @@ -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) diff --git a/Codec/Encryption/OpenPGP/Message.hs b/Codec/Encryption/OpenPGP/Message.hs --- a/Codec/Encryption/OpenPGP/Message.hs +++ b/Codec/Encryption/OpenPGP/Message.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/SecretKey.hs b/Codec/Encryption/OpenPGP/SecretKey.hs --- a/Codec/Encryption/OpenPGP/SecretKey.hs +++ b/Codec/Encryption/OpenPGP/SecretKey.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Serialize.hs b/Codec/Encryption/OpenPGP/Serialize.hs --- a/Codec/Encryption/OpenPGP/Serialize.hs +++ b/Codec/Encryption/OpenPGP/Serialize.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Signatures.hs b/Codec/Encryption/OpenPGP/Signatures.hs --- a/Codec/Encryption/OpenPGP/Signatures.hs +++ b/Codec/Encryption/OpenPGP/Signatures.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Types/Internal/Base.hs b/Codec/Encryption/OpenPGP/Types/Internal/Base.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/Base.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/Base.hs @@ -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) diff --git a/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs b/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs @@ -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) diff --git a/Codec/Encryption/OpenPGP/Types/Internal/TK.hs b/Codec/Encryption/OpenPGP/Types/Internal/TK.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/TK.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/TK.hs @@ -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) diff --git a/Data/Conduit/OpenPGP/Keyring.hs b/Data/Conduit/OpenPGP/Keyring.hs --- a/Data/Conduit/OpenPGP/Keyring.hs +++ b/Data/Conduit/OpenPGP/Keyring.hs @@ -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 diff --git a/Data/Conduit/OpenPGP/Keyring/Instances.hs b/Data/Conduit/OpenPGP/Keyring/Instances.hs --- a/Data/Conduit/OpenPGP/Keyring/Instances.hs +++ b/Data/Conduit/OpenPGP/Keyring/Instances.hs @@ -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 diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,6 +1,6 @@ Cabal-version: 3.4 Name: hOpenPGP -Version: 3.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 diff --git a/tests/Tests/Common.hs b/tests/Tests/Common.hs --- a/tests/Tests/Common.hs +++ b/tests/Tests/Common.hs @@ -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 diff --git a/tests/Tests/Encryption.hs b/tests/Tests/Encryption.hs --- a/tests/Tests/Encryption.hs +++ b/tests/Tests/Encryption.hs @@ -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 diff --git a/tests/Tests/Keys.hs b/tests/Tests/Keys.hs --- a/tests/Tests/Keys.hs +++ b/tests/Tests/Keys.hs @@ -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) diff --git a/tests/Tests/MessageAndArmor.hs b/tests/Tests/MessageAndArmor.hs --- a/tests/Tests/MessageAndArmor.hs +++ b/tests/Tests/MessageAndArmor.hs @@ -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) diff --git a/tests/Tests/Serialization.hs b/tests/Tests/Serialization.hs --- a/tests/Tests/Serialization.hs +++ b/tests/Tests/Serialization.hs @@ -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 -> diff --git a/tests/Tests/Utilities.hs b/tests/Tests/Utilities.hs --- a/tests/Tests/Utilities.hs +++ b/tests/Tests/Utilities.hs @@ -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"