hOpenPGP 3.1 → 3.1.1
raw patch · 20 files changed
+4165/−3479 lines, 20 filesdep ~basedep ~bytestringdep ~containers
Dependency ranges changed: base, bytestring, containers, monad-loops, resourcet
Files
- Codec/Encryption/OpenPGP/Encrypt.hs +28/−18
- Codec/Encryption/OpenPGP/Internal/RFC7253OCB.hs +197/−171
- Codec/Encryption/OpenPGP/Internal/Whitespace.hs +163/−0
- Codec/Encryption/OpenPGP/KeyringParser.hs +2/−1
- Codec/Encryption/OpenPGP/Message.hs +4/−4
- Codec/Encryption/OpenPGP/Ontology.hs +36/−61
- Codec/Encryption/OpenPGP/S2K.hs +203/−146
- Codec/Encryption/OpenPGP/Serialize.hs +2808/−2520
- Codec/Encryption/OpenPGP/SerializeForSigs.hs +174/−154
- Codec/Encryption/OpenPGP/SignatureQualities.hs +47/−63
- Codec/Encryption/OpenPGP/Signatures.hs +7/−24
- Codec/Encryption/OpenPGP/Subpackets.hs +2/−0
- Codec/Encryption/OpenPGP/Types/Internal/Base.hs +7/−2
- Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs +1/−0
- Data/Conduit/OpenPGP/Filter.hs +40/−16
- Data/Conduit/OpenPGP/Keyring.hs +38/−21
- hOpenPGP.cabal +8/−7
- tests/Tests/Encryption.hs +0/−39
- tests/Tests/MessageAndArmor.hs +88/−0
- tests/Tests/Properties.hs +312/−232
Codec/Encryption/OpenPGP/Encrypt.hs view
@@ -108,6 +108,7 @@ import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL+import Data.Containers.ListUtils (nubOrd) import Data.Int (Int64) import Data.List (find, foldl', maximumBy) import Data.List.NonEmpty (NonEmpty (..))@@ -401,26 +402,16 @@ preferredAEADAlgorithmsFromCiphersuites :: BL.ByteString -> [AEADAlgorithm] preferredAEADAlgorithmsFromCiphersuites =- dedupePreservingOrder . parsePairs . BL.unpack+ nubOrd . parsePairs . BL.unpack where parsePairs (_symAlgo : aeadAlgo : rest) = (toFVal aeadAlgo :: AEADAlgorithm) : parsePairs rest parsePairs _ = [] - dedupePreservingOrder = foldl' addIfMissing []- addIfMissing acc x- | x `elem` acc = acc- | otherwise = acc ++ [x]- preferredAEADAlgorithmsFromCiphersuitePairs :: [(SymmetricAlgorithm, AEADAlgorithm)] -> [AEADAlgorithm] preferredAEADAlgorithmsFromCiphersuitePairs =- dedupePreservingOrder . map snd- where- dedupePreservingOrder = foldl' addIfMissing []- addIfMissing acc x- | x `elem` acc = acc- | otherwise = acc ++ [x]+ nubOrd . map snd recipientCapabilitySupportsEncryption :: RecipientCapabilities -> Bool@@ -442,6 +433,10 @@ recipientCapabilityAdvertisesSEIPDv1Support caps && Set.member FeatureSEIPDv2 (recipientCapabilityFeatures caps) +{-# DEPRECATED+ recipientEncryptionTargetFromTKAtTimestamp+ "Use recipientEncryptionTargetFromTKAtTimestampWithPolicy instead"+ #-} recipientEncryptionTargetFromTKAtTimestamp :: ThirtyTwoBitTimeStamp -> TKUnknown@@ -473,6 +468,10 @@ recipientEncryptionTargetsAccepted (recipientEncryptionTargetsReportFromTKAtTimestamp timestamp tk) +{-# DEPRECATED+ recipientEncryptionTargetFromTK+ "Use recipientEncryptionTargetFromTKWithPolicy instead"+ #-} recipientEncryptionTargetFromTK :: TK 'PublicTK -> Either RecipientCapabilityError RecipientEncryptionTarget@@ -577,6 +576,10 @@ : recipientEncryptionTargetsRejected report } +{-# DEPRECATED+ recipientEncryptionTargetsFromTK+ "Use recipientEncryptionTargetsFromTKAtTimestamp instead"+ #-} recipientEncryptionTargetsFromTK :: TK 'PublicTK -> [RecipientEncryptionTarget] recipientEncryptionTargetsFromTK tk =@@ -938,6 +941,10 @@ recipientEncryptionTarget recipient = RecipientEncryptionTarget recipient Nothing Nothing +{-# DEPRECATED+ recipientEncryptionTargetWithStrategy+ "Use recipientEncryptionTargetWithStrategyTyped instead"+ #-} recipientEncryptionTargetWithStrategy :: SomePKPayload -> RecipientPKESKVersionStrategy@@ -961,6 +968,10 @@ recipient (demoteRecipientStrategy strategyW) +{-# DEPRECATED+ recipientVersionStrategyForProfile+ "Use recipientVersionStrategyForProfileTyped instead"+ #-} recipientVersionStrategyForProfile :: EncryptCompatibilityProfile -> RecipientEncryptionTarget@@ -1276,6 +1287,10 @@ (buildPKESKv3PayloadForRecipient recipient material) -- | Build PKESK packets for all recipients with a single shared session key.+{-# DEPRECATED+ buildPKESKPktsForRecipientTargetsWithSelector+ "Use buildPKESKPktsForRecipientTargetsWithSelectorTyped instead"+ #-} buildPKESKPktsForRecipientTargetsWithSelector :: MonadRandom m => ( RecipientEncryptionTarget@@ -1662,9 +1677,7 @@ ) where policyOrder =- foldl'- addIfMissing- []+ nubOrd (messageDefaultAEADAlgorithm messagePolicy : [OCB, EAX, GCM]) recipientChoices = map choicesForTarget targets choicesForTarget target =@@ -1676,9 +1689,6 @@ then policyOrder else allowed Nothing -> policyOrder- addIfMissing acc x- | x `elem` acc = acc- | otherwise = acc ++ [x] chooseCommonAlgorithm :: Eq a
Codec/Encryption/OpenPGP/Internal/RFC7253OCB.hs view
@@ -6,222 +6,248 @@ {-# LANGUAGE PackageImports #-} module Codec.Encryption.OpenPGP.Internal.RFC7253OCB- ( encryptWithOCBRFC7253- , decryptWithOCBRFC7253- , decryptWithOCBRFC7253With- ) where+ ( encryptWithOCBRFC7253+ , decryptWithOCBRFC7253+ , decryptWithOCBRFC7253With+ ) where import Control.Monad (when)-import qualified "crypton" Crypto.Cipher.Types as CCT-import Data.Bits ((.&.), (.|.), shiftL, shiftR, xor)+import Crypto.Number.Serialize (i2osp, os2ip)+import Data.Bits+ ( countTrailingZeros+ , shiftL+ , shiftR+ , xor+ , (.&.)+ , (.|.)+ ) import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Data.List (foldl')-import Crypto.Number.Serialize (i2osp, os2ip) import Data.Word (Word8)+import qualified "crypton" Crypto.Cipher.Types as CCT -encryptWithOCBRFC7253 ::- CCT.BlockCipher c- => c- -> B.ByteString- -> B.ByteString- -> B.ByteString- -> Either String (CCT.AuthTag, B.ByteString)+encryptWithOCBRFC7253+ :: CCT.BlockCipher c+ => c+ -> B.ByteString+ -> B.ByteString+ -> B.ByteString+ -> Either String (CCT.AuthTag, B.ByteString) encryptWithOCBRFC7253 cipher nonce ad plaintext = do- when (B.length nonce > 15 || B.null nonce) $- Left "invalid nonce size for OCB"- offset0 <- ocbOffset0 cipher nonce- let zeroBlock = B.replicate 16 0- lStar = CCT.ecbEncrypt cipher zeroBlock- lDollar = ocbDouble lStar- lCache = iterate ocbDouble (ocbDouble lDollar)- hashAd = ocbHash cipher lStar lCache ad- (fullBlocks, partial) = splitFullAndPartial plaintext- (cipherBlocks, offsetM, checksum) =- foldl'- (\(accBlocks, offsetPrev, checksumPrev) (idx, pBlock) ->- let offsetI = xorBS offsetPrev (lCache !! ntz idx)- cipherI = xorBS offsetI (CCT.ecbEncrypt cipher (xorBS offsetI pBlock))- checksumI = xorBS checksumPrev pBlock- in (accBlocks ++ [cipherI], offsetI, checksumI))- ([], offset0, zeroBlock)- (zip [1 ..] fullBlocks)- (cipherLast, offsetLast, checksumLast) =- if B.null partial- then (B.empty, offsetM, checksum)- else- let offsetStar = xorBS offsetM lStar- pad = CCT.ecbEncrypt cipher offsetStar- cipherPartial = xorBS partial (B.take (B.length partial) pad)- checksum' = xorBS checksum (ocbPadPartial partial)- in (cipherPartial, offsetStar, checksum')- tagBytes =- xorBS- (CCT.ecbEncrypt cipher (xorBS (xorBS checksumLast offsetLast) lDollar))- hashAd- ciphertext = B.concat cipherBlocks <> cipherLast- in Right (mkAuthTag (B.take 16 tagBytes), ciphertext)+ when (B.length nonce > 15 || B.null nonce) $+ Left "invalid nonce size for OCB"+ offset0 <- ocbOffset0 cipher nonce+ let zeroBlock = B.replicate 16 0+ lStar = CCT.ecbEncrypt cipher zeroBlock+ lDollar = ocbDouble lStar+ lCache = iterate ocbDouble (ocbDouble lDollar)+ hashAd = ocbHash cipher lStar lCache ad+ (fullBlocks, partial) = splitFullAndPartial plaintext+ (cipherBlocks, offsetM, checksum) =+ foldl'+ ( \(accBlocks, offsetPrev, checksumPrev) (idx, pBlock) ->+ let offsetI = xorBS offsetPrev (lCache !! ntz idx)+ cipherI = xorBS offsetI (CCT.ecbEncrypt cipher (xorBS offsetI pBlock))+ checksumI = xorBS checksumPrev pBlock+ in (accBlocks ++ [cipherI], offsetI, checksumI)+ )+ ([], offset0, zeroBlock)+ (zip [1 ..] fullBlocks)+ (cipherLast, offsetLast, checksumLast) =+ if B.null partial+ then (B.empty, offsetM, checksum)+ else+ let offsetStar = xorBS offsetM lStar+ pad = CCT.ecbEncrypt cipher offsetStar+ cipherPartial = xorBS partial (B.take (B.length partial) pad)+ checksum' = xorBS checksum (ocbPadPartial partial)+ in (cipherPartial, offsetStar, checksum')+ tagBytes =+ xorBS+ ( CCT.ecbEncrypt+ cipher+ (xorBS (xorBS checksumLast offsetLast) lDollar)+ )+ hashAd+ ciphertext = B.concat cipherBlocks <> cipherLast+ in Right (mkAuthTag (B.take 16 tagBytes), ciphertext) -decryptWithOCBRFC7253 ::- CCT.BlockCipher c- => c- -> B.ByteString- -> B.ByteString- -> B.ByteString- -> CCT.AuthTag- -> Either String B.ByteString+decryptWithOCBRFC7253+ :: CCT.BlockCipher c+ => c+ -> B.ByteString+ -> B.ByteString+ -> B.ByteString+ -> CCT.AuthTag+ -> Either String B.ByteString decryptWithOCBRFC7253 =- decryptWithOCBRFC7253With (\_ _ _ _ _ _ -> "OCB authentication failed")+ decryptWithOCBRFC7253With+ (\_ _ _ _ _ _ -> "OCB authentication failed") -decryptWithOCBRFC7253With ::- CCT.BlockCipher c- => (B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString -> String)- -> c- -> B.ByteString- -> B.ByteString- -> B.ByteString- -> CCT.AuthTag- -> Either String B.ByteString+decryptWithOCBRFC7253With+ :: CCT.BlockCipher c+ => ( B.ByteString+ -> B.ByteString+ -> B.ByteString+ -> B.ByteString+ -> B.ByteString+ -> B.ByteString+ -> String+ )+ -> c+ -> B.ByteString+ -> B.ByteString+ -> B.ByteString+ -> CCT.AuthTag+ -> Either String B.ByteString decryptWithOCBRFC7253With onAuthFailure cipher nonce ad ciphertext authTag = do- when (B.length nonce > 15 || B.null nonce) $- Left "invalid nonce size for OCB"- when (B.length tagBytes /= 16) $- Left "invalid auth tag size for OCB"- offset0 <- ocbOffset0 cipher nonce- let zeroBlock = B.replicate 16 0- lStar = CCT.ecbEncrypt cipher zeroBlock- lDollar = ocbDouble lStar- lCache = iterate ocbDouble (ocbDouble lDollar)- hashAd = ocbHash cipher lStar lCache ad- (fullBlocks, partial) = splitFullAndPartial ciphertext- (plainBlocks, offsetM, checksum) =- foldl'- (\(accBlocks, offsetPrev, checksumPrev) (idx, cBlock) ->- let offsetI = xorBS offsetPrev (lCache !! ntz idx)- plainI = xorBS offsetI (CCT.ecbDecrypt cipher (xorBS offsetI cBlock))- checksumI = xorBS checksumPrev plainI- in (accBlocks ++ [plainI], offsetI, checksumI))- ([], offset0, zeroBlock)- (zip [1 ..] fullBlocks)- (plainLast, offsetLast, checksumLast) =- if B.null partial- then (B.empty, offsetM, checksum)- else- let offsetStar = xorBS offsetM lStar- pad = CCT.ecbEncrypt cipher offsetStar- plainPartial = xorBS partial (B.take (B.length partial) pad)- checksum' = xorBS checksum (ocbPadPartial plainPartial)- in (plainPartial, offsetStar, checksum')- tagComputed =- xorBS- (CCT.ecbEncrypt cipher (xorBS (xorBS checksumLast offsetLast) lDollar))- hashAd- plaintext = B.concat plainBlocks <> plainLast- computedTag = B.take 16 tagComputed- in if BA.constEq tagBytes computedTag- then Right plaintext- else Left (onAuthFailure tagBytes computedTag nonce ad hashAd plaintext)+ when (B.length nonce > 15 || B.null nonce) $+ Left "invalid nonce size for OCB"+ when (B.length tagBytes /= 16) $+ Left "invalid auth tag size for OCB"+ offset0 <- ocbOffset0 cipher nonce+ let zeroBlock = B.replicate 16 0+ lStar = CCT.ecbEncrypt cipher zeroBlock+ lDollar = ocbDouble lStar+ lCache = iterate ocbDouble (ocbDouble lDollar)+ hashAd = ocbHash cipher lStar lCache ad+ (fullBlocks, partial) = splitFullAndPartial ciphertext+ (plainBlocks, offsetM, checksum) =+ foldl'+ ( \(accBlocks, offsetPrev, checksumPrev) (idx, cBlock) ->+ let offsetI = xorBS offsetPrev (lCache !! ntz idx)+ plainI = xorBS offsetI (CCT.ecbDecrypt cipher (xorBS offsetI cBlock))+ checksumI = xorBS checksumPrev plainI+ in (accBlocks ++ [plainI], offsetI, checksumI)+ )+ ([], offset0, zeroBlock)+ (zip [1 ..] fullBlocks)+ (plainLast, offsetLast, checksumLast) =+ if B.null partial+ then (B.empty, offsetM, checksum)+ else+ let offsetStar = xorBS offsetM lStar+ pad = CCT.ecbEncrypt cipher offsetStar+ plainPartial = xorBS partial (B.take (B.length partial) pad)+ checksum' = xorBS checksum (ocbPadPartial plainPartial)+ in (plainPartial, offsetStar, checksum')+ tagComputed =+ xorBS+ ( CCT.ecbEncrypt+ cipher+ (xorBS (xorBS checksumLast offsetLast) lDollar)+ )+ hashAd+ plaintext = B.concat plainBlocks <> plainLast+ computedTag = B.take 16 tagComputed+ in if BA.constEq tagBytes computedTag+ then Right plaintext+ else+ Left+ (onAuthFailure tagBytes computedTag nonce ad hashAd plaintext) where tagBytes = BA.convert authTag :: B.ByteString mkAuthTag :: B.ByteString -> CCT.AuthTag mkAuthTag = CCT.AuthTag . BA.convert -ocbOffset0 :: CCT.BlockCipher c => c -> B.ByteString -> Either String B.ByteString+ocbOffset0+ :: CCT.BlockCipher c+ => c -> B.ByteString -> Either String B.ByteString ocbOffset0 cipher nonce = do- let nonceLen = B.length nonce- prefixLen = 16 - nonceLen- when (prefixLen <= 0) $- Left "invalid nonce size for OCB"- let prefix = B.pack (replicate (prefixLen - 1) 0 <> [1 :: Word8])- nonceBlock = prefix <> nonce- bottom = fromIntegral (B.last nonceBlock .&. 0x3f) :: Int- nonceTop = B.init nonceBlock <> B.singleton (B.last nonceBlock .&. 0xc0)- kTop = CCT.ecbEncrypt cipher nonceTop- stretch = kTop <> xorBS (B.take 8 kTop) (B.take 8 (B.drop 1 kTop))- Right (ocbBitSlice128 stretch bottom)+ let nonceLen = B.length nonce+ prefixLen = 16 - nonceLen+ when (prefixLen <= 0) $+ Left "invalid nonce size for OCB"+ let prefix = B.pack (replicate (prefixLen - 1) 0 <> [1 :: Word8])+ nonceBlock = prefix <> nonce+ bottom = fromIntegral (B.last nonceBlock .&. 0x3f) :: Int+ nonceTop = B.init nonceBlock <> B.singleton (B.last nonceBlock .&. 0xc0)+ kTop = CCT.ecbEncrypt cipher nonceTop+ stretch = kTop <> xorBS (B.take 8 kTop) (B.take 8 (B.drop 1 kTop))+ Right (ocbBitSlice128 stretch bottom) -ocbHash ::- CCT.BlockCipher c- => c- -> B.ByteString- -> [B.ByteString]- -> B.ByteString- -> B.ByteString+ocbHash+ :: CCT.BlockCipher c+ => c+ -> B.ByteString+ -> [B.ByteString]+ -> B.ByteString+ -> B.ByteString ocbHash cipher lStar lCache ad =- let (fullBlocks, partial) = splitFullAndPartial ad- (sumBlocks, offsetFinal) =- foldl'- (\(acc, offsetPrev) (idx, block) ->- let offsetI = xorBS offsetPrev (lCache !! ntz idx)- sumI = xorBS acc (CCT.ecbEncrypt cipher (xorBS offsetI block))- in (sumI, offsetI))- (B.replicate 16 0, B.replicate 16 0)- (zip [1 ..] fullBlocks)- in if B.null partial- then sumBlocks- else- let offsetStar = xorBS offsetFinal lStar- block = ocbPadPartial partial- in xorBS sumBlocks (CCT.ecbEncrypt cipher (xorBS offsetStar block))+ let (fullBlocks, partial) = splitFullAndPartial ad+ (sumBlocks, offsetFinal) =+ foldl'+ ( \(acc, offsetPrev) (idx, block) ->+ let offsetI = xorBS offsetPrev (lCache !! ntz idx)+ sumI = xorBS acc (CCT.ecbEncrypt cipher (xorBS offsetI block))+ in (sumI, offsetI)+ )+ (B.replicate 16 0, B.replicate 16 0)+ (zip [1 ..] fullBlocks)+ in if B.null partial+ then sumBlocks+ else+ let offsetStar = xorBS offsetFinal lStar+ block = ocbPadPartial partial+ in xorBS sumBlocks (CCT.ecbEncrypt cipher (xorBS offsetStar block)) ocbPadPartial :: B.ByteString -> B.ByteString ocbPadPartial bs = bs <> B.singleton 0x80 <> B.replicate (15 - B.length bs) 0 ocbDouble :: B.ByteString -> B.ByteString ocbDouble bs =- let shifted = shiftLeftOne bs- carry = (B.head bs .&. 0x80) /= 0- in if carry- then B.init shifted <> B.singleton (B.last shifted `xor` 0x87)- else shifted+ let shifted = shiftLeftOne bs+ carry = (B.head bs .&. 0x80) /= 0+ in if carry+ then B.init shifted <> B.singleton (B.last shifted `xor` 0x87)+ else shifted shiftLeftOne :: B.ByteString -> B.ByteString shiftLeftOne bs = B.pack shifted where (shifted, _) =- foldl'- (\(acc, carryIn) x ->- let y = ((x `shiftL` 1) .&. 0xff) .|. carryIn- carryOut = if (x .&. 0x80) /= 0 then 1 else 0- in (y : acc, carryOut))- ([], 0)- (reverse (B.unpack bs))+ foldl'+ ( \(acc, carryIn) x ->+ let y = ((x `shiftL` 1) .&. 0xff) .|. carryIn+ carryOut = if (x .&. 0x80) /= 0 then 1 else 0+ in (y : acc, carryOut)+ )+ ([], 0)+ (reverse (B.unpack bs)) xorBS :: B.ByteString -> B.ByteString -> B.ByteString xorBS a b = B.pack (B.zipWith xor a b) ocbBitSlice128 :: B.ByteString -> Int -> B.ByteString ocbBitSlice128 stretch startBit =- let stretchInt = os2ip stretch- shift = 192 - (startBit + 128)- mask = (1 `shiftL` (128 :: Int)) - 1- slice = (stretchInt `shiftR` shift) .&. mask- in leftPadTo16 (i2osp slice)+ let stretchInt = os2ip stretch+ shift = 192 - (startBit + 128)+ mask = (1 `shiftL` (128 :: Int)) - 1+ slice = (stretchInt `shiftR` shift) .&. mask+ in leftPadTo16 (i2osp slice) leftPadTo16 :: B.ByteString -> B.ByteString leftPadTo16 bs- | B.length bs >= 16 = B.drop (B.length bs - 16) bs- | otherwise = B.replicate (16 - B.length bs) 0 <> bs+ | B.length bs >= 16 = B.drop (B.length bs - 16) bs+ | otherwise = B.replicate (16 - B.length bs) 0 <> bs -splitFullAndPartial :: B.ByteString -> ([B.ByteString], B.ByteString)+splitFullAndPartial+ :: B.ByteString -> ([B.ByteString], B.ByteString) splitFullAndPartial bs- | B.null bs = ([], B.empty)- | otherwise =- let fullLen = (B.length bs `div` 16) * 16- (fullPart, rest) = B.splitAt fullLen bs- in (chunk16 fullPart, rest)+ | B.null bs = ([], B.empty)+ | otherwise =+ let fullLen = (B.length bs `div` 16) * 16+ (fullPart, rest) = B.splitAt fullLen bs+ in (chunk16 fullPart, rest) chunk16 :: B.ByteString -> [B.ByteString] chunk16 bs- | B.null bs = []- | otherwise =- let (h, t) = B.splitAt 16 bs- in h : chunk16 t+ | B.null bs = []+ | otherwise =+ let (h, t) = B.splitAt 16 bs+ in h : chunk16 t ntz :: Int -> Int-ntz i = go i 0- where- go n c- | n .&. 1 == 1 = c- | otherwise = go (n `shiftR` 1) (c + 1)+ntz i = fromIntegral (countTrailingZeros (fromIntegral i :: Word))
+ Codec/Encryption/OpenPGP/Internal/Whitespace.hs view
@@ -0,0 +1,163 @@+-- Whitespace.hs: utility functions involving whitespace+-- Copyright © 2012-2026 Clint Adams+-- This software is released under the terms of the Expat license.+-- (See the LICENSE file).++module Codec.Encryption.OpenPGP.Internal.Whitespace+ ( canonicalizeLineEndings+ , canonicalizeLineEndingsChunk+ , canonicalizeLineEndingsFlush+ , CRState (..)+ , stripTrailingWhitespacePerLine+ , stripTrailingWhitespacePerLineChunk+ , stripTrailingWhitespacePerLineFlush+ , StripWSState (..)+ ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Lazy as BL+import Data.Foldable (foldl')+import Data.Word (Word8)++canonicalizeLineEndings :: BL.ByteString -> BL.ByteString+canonicalizeLineEndings bs = BL.fromStrict (B.unfoldr step (Nothing, BL.toStrict bs))+ where+ step (Nothing, rest)+ | B.null rest = Nothing+ | otherwise =+ case B.uncons rest of+ Just (0x0d, tail') ->+ case B.uncons tail' of+ Just (0x0a, tail'') -> Just (0x0d, (Just 0x0a, tail''))+ _ -> Just (0x0d, (Just 0x0a, tail'))+ Just (0x0a, tail') -> Just (0x0d, (Just 0x0a, tail'))+ Just (w, tail') -> Just (w, (Nothing, tail'))+ step (Just w, rest) = Just (w, (Nothing, rest))++-- | State carried between chunks when canonicalizing line endings.+data CRState = CRState+ { prevCR :: !Bool+ }++{- | Process one strict chunk and return updated state plus emitted bytes.++The returned bytes may end with a standalone @\\r@ if the chunk boundary+falls mid-pair; feed it to 'canonicalizeLineEndingsFlush' at the end.+-}+canonicalizeLineEndingsChunk+ :: CRState+ -> B.ByteString+ -> (CRState, B.ByteString)+canonicalizeLineEndingsChunk (CRState prevWasCR) chunk+ | B.null chunk = (CRState False, B.empty)+ | otherwise =+ ( CRState newPrevCR+ , BL.toStrict $ BB.toLazyByteString bldr+ )+ where+ newPrevCR = B.last chunk == 0x0d+ bldr = snd $ B.foldl' step (prevWasCR, mempty) chunk+ step (prevCR, b) w+ | prevCR && w == 0x0a =+ (False, b <> BB.word8 0x0d <> BB.word8 0x0a)+ | prevCR && w == 0x0d =+ (True, b <> BB.word8 0x0d <> BB.word8 0x0a)+ | prevCR = (False, b <> BB.word8 0x0d <> BB.word8 w)+ | w == 0x0d = (True, b)+ | w == 0x0a = (False, b <> BB.word8 0x0d <> BB.word8 0x0a)+ | otherwise = (False, b <> BB.word8 w)++{- | Emit any pending state as final bytes (a trailing standalone @\\r@+becomes @\\r\\n@).+-}+canonicalizeLineEndingsFlush :: CRState -> B.ByteString+canonicalizeLineEndingsFlush (CRState prevCR)+ | prevCR = B.pack [0x0d, 0x0a]+ | otherwise = B.empty++{- | Strip trailing spaces (0x20) and tabs (0x09) from each line.++Lines are delimited by @\\r\\n@. A line consisting solely of whitespace+collapses to just its terminator. Any trailing partial line (without a+terminator) has its trailing whitespace stripped as well.++Uses 'Data.ByteString.Builder' to concatenate output in O(1) per segment,+avoiding the '++' thunk buildup of the old list-based version.+-}+stripTrailingWhitespacePerLine :: BL.ByteString -> BL.ByteString+stripTrailingWhitespacePerLine = BB.toLazyByteString . go . BL.toStrict+ where+ isTrailingWhitespace :: Word8 -> Bool+ isTrailingWhitespace w = w == 0x20 || w == 0x09++ crlf :: B.ByteString+ crlf = B.pack [0x0d, 0x0a]++ go bs+ | B.null bs = mempty+ | otherwise =+ let (line, rest) = B.span (/= 0x0d) bs+ trimmed = B.dropWhileEnd isTrailingWhitespace line+ in case B.uncons rest of+ Just (0x0d, afterCR) ->+ case B.uncons afterCR of+ Just (0x0a, afterLF) ->+ BB.byteString trimmed <> BB.byteString crlf <> go afterLF+ _ ->+ BB.byteString trimmed <> BB.word8 0x0d <> go afterCR+ _ ->+ BB.byteString trimmed++data StripWSState = StripWSState+ { swsPrevCR :: !Bool+ , swsLine :: !B.ByteString+ }++{- | Process one strict chunk and return updated state plus emitted bytes.++Lines are delimited by @\\r\\n@. A line consisting solely of whitespace+collapses to just its terminator. Any trailing partial line (without a+terminator) has its trailing whitespace stripped as well.+-}+stripTrailingWhitespacePerLineChunk+ :: StripWSState -> B.ByteString -> (StripWSState, B.ByteString)+stripTrailingWhitespacePerLineChunk st chunk = (st', BL.toStrict $ BB.toLazyByteString bldr)+ where+ isTrailingWhitespace :: Word8 -> Bool+ isTrailingWhitespace w = w == 0x20 || w == 0x09++ (st', bldr) = B.foldl' stepByte (st, mempty) chunk++ crlf :: BB.Builder+ crlf = BB.word8 0x0d <> BB.word8 0x0a++ stepByte (StripWSState prevCR line, bldr) w+ | prevCR && w == 0x0a =+ (StripWSState False B.empty, bldr <> trimmedLine <> crlf)+ | prevCR =+ ( StripWSState False (B.singleton w)+ , bldr <> trimmedLine <> BB.word8 0x0d+ )+ | w == 0x0d = (StripWSState True line, bldr)+ | otherwise = (StripWSState False (line <> B.singleton w), bldr)+ where+ trimmedLine = BB.byteString $ B.dropWhileEnd isTrailingWhitespace line++{- | Emit any pending state as final bytes (trailing whitespace stripped from+the last partial line, standalone @\\r@ preserved).+-}+stripTrailingWhitespacePerLineFlush+ :: StripWSState -> B.ByteString+stripTrailingWhitespacePerLineFlush (StripWSState prevCR line) =+ if prevCR+ then+ BL.toStrict $+ BB.toLazyByteString $+ BB.byteString trimmedLine <> BB.word8 0x0d+ else+ BL.toStrict $ BB.toLazyByteString $ BB.byteString trimmedLine+ where+ isTrailingWhitespace :: Word8 -> Bool+ isTrailingWhitespace w = w == 0x20 || w == 0x09+ trimmedLine = B.dropWhileEnd isTrailingWhitespace line
Codec/Encryption/OpenPGP/KeyringParser.hs view
@@ -2,7 +2,6 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).-{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} @@ -397,6 +396,8 @@ where isBroken [BrokenPacketPkt _ a _] = t == fromIntegral a isBroken _ = False++{-# DEPRECATED parseUnknownTKs "Use parsePublicTKs or parseSecretTKs instead" #-} -- | parse TKs from packets parseUnknownTKs :: Bool -> [Pkt] -> [TKUnknown]
Codec/Encryption/OpenPGP/Message.hs view
@@ -52,6 +52,7 @@ , verifySignedMessage ) where +import Control.Monad (foldM) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import qualified Crypto.Hash as CH@@ -1047,14 +1048,13 @@ rejectUnknownCriticalPacketsTyped :: [Pkt] -> Either MessageParseFailure [Pkt] rejectUnknownCriticalPacketsTyped =- go []+ fmap reverse . foldM go [] where- go acc [] = Right (reverse acc)- go acc (pkt : rest) =+ go acc pkt = case pkt of OtherPacketPkt t _ | t < 40 -> Left (UnknownCriticalPacketType t) BrokenPacketPkt err t _ | t < 40 -> Left (BrokenCriticalPacketType t err)- _ -> go (pkt : acc) rest+ _ -> Right (pkt : acc) validateModernMessageS2K :: OpenPGPPolicy -> S2K -> Either String ()
Codec/Encryption/OpenPGP/Ontology.hs view
@@ -3,80 +3,55 @@ -- This software is released under the terms of the Expat license. -- (See the LICENSE file). -{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}- module Codec.Encryption.OpenPGP.Ontology- (- -- * for signature payloads- isCertRevocationSig- , isRevokerP- , isPKBindingSig- , isSKBindingSig- , isSubkeyBindingSig- , isSubkeyRevocation- , isTrustPkt- -- * for signature subpackets- , isCT- , isIssuerSSP- , isIssuerFPSSP- , isKET- , isKUF- , isPHA- , isRevocationKeySSP- , isSigCreationTime- ) where--import Codec.Encryption.OpenPGP.Types--data TrailerCapableSignaturePayload where- TrailerCapableSignaturePayloadV4 ::- SignaturePayloadV 'SigPayloadV4 -> TrailerCapableSignaturePayload- TrailerCapableSignaturePayloadV6 ::- SignaturePayloadV 'SigPayloadV6 -> TrailerCapableSignaturePayload+ ( -- * for signature payloads+ isCertRevocationSig+ , isRevokerP+ , isPKBindingSig+ , isSKBindingSig+ , isSubkeyBindingSig+ , isSubkeyRevocation+ , isTrustPkt -trailerCapableSignaturePayload ::- SignaturePayload -> Maybe TrailerCapableSignaturePayload-trailerCapableSignaturePayload sig =- case toSomeSignaturePayload sig of- SomeSignaturePayload (payload@SigPayloadV4Data {}) ->- Just (TrailerCapableSignaturePayloadV4 payload)- SomeSignaturePayload (payload@SigPayloadV6Data {}) ->- Just (TrailerCapableSignaturePayloadV6 payload)- _ -> Nothing+ -- * for signature subpackets+ , isCT+ , isIssuerSSP+ , isIssuerFPSSP+ , isKET+ , isKUF+ , isPHA+ , isRevocationKeySSP+ , isSigCreationTime+ ) where -trailerCapableSigType :: TrailerCapableSignaturePayload -> SigType-trailerCapableSigType (TrailerCapableSignaturePayloadV4 (SigPayloadV4Data st _ _ _ _ _ _)) = st-trailerCapableSigType (TrailerCapableSignaturePayloadV6 (SigPayloadV6Data st _ _ _ _ _ _ _)) = st+import Control.Applicative ((<|>))+import Control.Lens (preview, _1) -trailerCapableSubpacketLists ::- TrailerCapableSignaturePayload -> ([SigSubPacket], [SigSubPacket])-trailerCapableSubpacketLists (TrailerCapableSignaturePayloadV4 (SigPayloadV4Data _ _ _ h u _ _)) =- (h, u)-trailerCapableSubpacketLists (TrailerCapableSignaturePayloadV6 (SigPayloadV6Data _ _ _ _ h u _ _)) =- (h, u)+import Codec.Encryption.OpenPGP.Types --- | Test whether a 'SignaturePayload' has the given 'SigType'.--- Returns 'False' for V3 and 'SigVOther' payloads; V3 signatures are excluded--- from structural predicate checks since they lack subpacket support and are--- not used in V4/V6 keyring contexts.+{- | Test whether a 'SignaturePayload' has the given 'SigType'.+Returns 'False' for V3 and 'SigVOther' payloads; V3 signatures are excluded+from structural predicate checks since they lack subpacket support and are+not used in V4/V6 keyring contexts.+-} isSigTypeFor :: SigType -> SignaturePayload -> Bool isSigTypeFor expected sig =- case trailerCapableSignaturePayload sig of- Just trailerCapable -> trailerCapableSigType trailerCapable == expected- _ -> False+ maybe False (== expected) $+ preview (_SigV4 . _1) sig <|> preview (_SigV6 . _1) sig isCertRevocationSig :: SignaturePayload -> Bool isCertRevocationSig = isSigTypeFor CertRevocationSig isRevokerP :: SignaturePayload -> Bool isRevokerP sig =- case trailerCapableSignaturePayload sig of- Just trailerCapable- | trailerCapableSigType trailerCapable == SignatureDirectlyOnAKey ->- let (h, u) = trailerCapableSubpacketLists trailerCapable- in hasRevokerSubpackets h u- _ -> False+ case preview _SigV4 sig of+ Just (st, _, _, h, u, _, _) ->+ st == SignatureDirectlyOnAKey && hasRevokerSubpackets h u+ Nothing ->+ case preview _SigV6 sig of+ Just (st, _, _, _, h, u, _, _) ->+ st == SignatureDirectlyOnAKey && hasRevokerSubpackets h u+ Nothing -> False hasRevokerSubpackets :: [SigSubPacket] -> [SigSubPacket] -> Bool hasRevokerSubpackets h u = any isRevocationKeySSP h && any isIssuerSSP u
Codec/Encryption/OpenPGP/S2K.hs view
@@ -2,228 +2,285 @@ -- Copyright © 2013-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} module Codec.Encryption.OpenPGP.S2K- ( EncodedSessionKeyError(..)- , renderEncodedSessionKeyError- , S2KError(..)- , renderS2KError- , decodeOpenPGPEncodedSessionKey- , string2Key- , skesk2Key- , skesk2SessionKey- ) where+ ( EncodedSessionKeyError (..)+ , renderEncodedSessionKeyError+ , S2KError (..)+ , renderS2KError+ , decodeOpenPGPEncodedSessionKey+ , string2Key+ , skesk2Key+ , skesk2SessionKey+ ) where -import Codec.Encryption.OpenPGP.BlockCipher (CipherError(..), keySize, withSymmetricCipher)-import Codec.Encryption.OpenPGP.Internal.HOBlockCipher (HOBlockCipher(..))-import Codec.Encryption.OpenPGP.Types-import Data.Bits (shiftL)-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import Data.Word (Word8, Word16)-import Crypto.Error (CryptoFailable(..))+import Control.Monad.Loops (unfoldrM)+import Crypto.Error (CryptoFailable (..)) import qualified Crypto.Hash as CH import qualified Crypto.KDF.Argon2 as Argon2-import qualified Data.ByteArray as BA import Data.Bifunctor (first)+import Data.Bits (shiftL)+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Word (Word16, Word8) +import Codec.Encryption.OpenPGP.BlockCipher+ ( CipherError (..)+ , keySize+ , withSymmetricCipher+ )+import Codec.Encryption.OpenPGP.Internal.HOBlockCipher+ ( HOBlockCipher (..)+ )+import Codec.Encryption.OpenPGP.Types+ data EncodedSessionKeyError- = EncodedSessionKeyTooShort- | EncodedSessionKeyUnsupportedAlgorithm SymmetricAlgorithm- | EncodedSessionKeyLengthMismatch SymmetricAlgorithm Int Int- | EncodedSessionKeyChecksumMismatch- deriving (Eq, Show)+ = EncodedSessionKeyTooShort+ | EncodedSessionKeyUnsupportedAlgorithm SymmetricAlgorithm+ | EncodedSessionKeyLengthMismatch SymmetricAlgorithm Int Int+ | EncodedSessionKeyChecksumMismatch+ deriving (Eq, Show) renderEncodedSessionKeyError :: EncodedSessionKeyError -> String renderEncodedSessionKeyError EncodedSessionKeyTooShort =- "session key material too short"+ "session key material too short" renderEncodedSessionKeyError (EncodedSessionKeyUnsupportedAlgorithm sa) =- "unsupported symmetric algorithm: " ++ show sa+ "unsupported symmetric algorithm: " ++ show sa renderEncodedSessionKeyError (EncodedSessionKeyLengthMismatch _ _ _) =- "session key material length does not match encoded algorithm"+ "session key material length does not match encoded algorithm" renderEncodedSessionKeyError EncodedSessionKeyChecksumMismatch =- "session key checksum mismatch"+ "session key checksum mismatch" -- | Errors that can arise during string-to-key derivation. data S2KError- = -- | The symmetric algorithm used in the SKESK is not supported.- S2KUnsupportedAlgorithm CipherError- | -- | An unsupported or unknown S2K specifier type was encountered.- S2KUnsupportedSpecifier Word8- | -- | An unsupported SKESK shape (e.g. non-zero ESK).- S2KUnsupportedSKESKShape String- | -- | A required hash algorithm is not supported for S2K.- S2KUnsupportedHashAlgorithm HashAlgorithm- | -- | The Argon2 S2K parameters are invalid.- S2KArgon2ParamError String- | -- | The Argon2 KDF itself failed.- S2KArgon2Failed String- | -- | Decrypting an embedded encrypted session key failed.- S2KEncryptedSessionKeyCipherError CipherError- | -- | Embedded encrypted session key material was malformed.- S2KEncryptedSessionKeyDecodeError EncodedSessionKeyError- deriving (Eq, Show)+ = -- | The symmetric algorithm used in the SKESK is not supported.+ S2KUnsupportedAlgorithm CipherError+ | -- | An unsupported or unknown S2K specifier type was encountered.+ S2KUnsupportedSpecifier Word8+ | -- | An unsupported SKESK shape (e.g. non-zero ESK).+ S2KUnsupportedSKESKShape String+ | -- | A required hash algorithm is not supported for S2K.+ S2KUnsupportedHashAlgorithm HashAlgorithm+ | -- | The Argon2 S2K parameters are invalid.+ S2KArgon2ParamError String+ | -- | The Argon2 KDF itself failed.+ S2KArgon2Failed String+ | -- | Decrypting an embedded encrypted session key failed.+ S2KEncryptedSessionKeyCipherError CipherError+ | -- | Embedded encrypted session key material was malformed.+ S2KEncryptedSessionKeyDecodeError EncodedSessionKeyError+ deriving (Eq, Show) renderS2KError :: S2KError -> String renderS2KError (S2KUnsupportedAlgorithm ce) =- "S2K: " ++ renderCipherError' ce+ "S2K: " ++ renderCipherError' ce where renderCipherError' (UnsupportedAlgorithm sa) = "unsupported symmetric algorithm: " ++ show sa renderCipherError' (CipherInitFailed sa msg) = "cipher init failed for " ++ show sa ++ ": " ++ msg renderCipherError' (CipherOperationFailed msg) = "cipher operation failed: " ++ msg renderS2KError (S2KUnsupportedSpecifier t) =- "S2K: unsupported S2K type " ++ show t+ "S2K: unsupported S2K type " ++ show t renderS2KError (S2KUnsupportedSKESKShape msg) =- "S2K: unsupported SKESK shape: " ++ msg+ "S2K: unsupported SKESK shape: " ++ msg renderS2KError (S2KUnsupportedHashAlgorithm ha) =- "S2K: unsupported hash algorithm for S2K: " ++ show ha+ "S2K: unsupported hash algorithm for S2K: " ++ show ha renderS2KError (S2KArgon2ParamError msg) =- "S2K: Argon2 parameter error: " ++ msg+ "S2K: Argon2 parameter error: " ++ msg renderS2KError (S2KArgon2Failed msg) =- "S2K: Argon2 KDF failed: " ++ msg+ "S2K: Argon2 KDF failed: " ++ msg renderS2KError (S2KEncryptedSessionKeyCipherError ce) =- "S2K: encrypted session key decrypt failed: " ++ renderCipherError' ce+ "S2K: encrypted session key decrypt failed: "+ ++ renderCipherError' ce where renderCipherError' (UnsupportedAlgorithm sa) = "unsupported symmetric algorithm: " ++ show sa renderCipherError' (CipherInitFailed sa msg) = "cipher init failed for " ++ show sa ++ ": " ++ msg renderCipherError' (CipherOperationFailed msg) = "cipher operation failed: " ++ msg renderS2KError (S2KEncryptedSessionKeyDecodeError err) =- "S2K: encrypted session key decode failed: " ++ renderEncodedSessionKeyError err+ "S2K: encrypted session key decode failed: "+ ++ renderEncodedSessionKeyError err -string2Key :: S2K -> Int -> BL.ByteString -> Either S2KError B.ByteString+string2Key+ :: S2K -> Int -> BL.ByteString -> Either S2KError B.ByteString string2Key (Simple ha) ksz bs =- B.take (fromIntegral ksz) <$> hashpp ha ksz bs+ B.take (fromIntegral ksz) <$> hashpp ha ksz bs string2Key (Salted ha salt) ksz bs =- string2Key (Simple ha) ksz (BL.append (BL.fromStrict (unSalt8 salt)) bs)+ string2Key+ (Simple ha)+ ksz+ (BL.append (BL.fromStrict (unSalt8 salt)) bs) string2Key (IteratedSalted ha salt cnt) ksz bs =- string2Key- (Simple ha)- ksz- (BL.take (fromIntegral cnt) . BL.cycle $- BL.append (BL.fromStrict (unSalt8 salt)) bs)+ string2Key+ (Simple ha)+ ksz+ ( BL.take (fromIntegral cnt) . BL.cycle $+ BL.append (BL.fromStrict (unSalt8 salt)) bs+ ) string2Key (Argon2 salt t p encodedM) ksz pass =- argon2String2Key salt t p encodedM ksz pass+ argon2String2Key salt t p encodedM ksz pass string2Key (OtherS2K t _) _ _ =- Left (S2KUnsupportedSpecifier t)+ Left (S2KUnsupportedSpecifier t) -skesk2Key :: SKESK 'SKESKV4 -> BL.ByteString -> Either S2KError B.ByteString+skesk2Key+ :: SKESK 'SKESKV4 -> BL.ByteString -> Either S2KError B.ByteString skesk2Key skesk pass = snd <$> skesk2SessionKey skesk pass -skesk2SessionKey :: SKESK 'SKESKV4 -> BL.ByteString -> Either S2KError (SymmetricAlgorithm, B.ByteString)+skesk2SessionKey+ :: SKESK 'SKESKV4+ -> BL.ByteString+ -> Either S2KError (SymmetricAlgorithm, B.ByteString) skesk2SessionKey (SKESK4Packet sa s2k Nothing) pass = do- keyLen <- first S2KUnsupportedAlgorithm (keySize sa)- sessionKey <- string2Key s2k keyLen pass- pure (sa, sessionKey)+ keyLen <- first S2KUnsupportedAlgorithm (keySize sa)+ sessionKey <- string2Key s2k keyLen pass+ pure (sa, sessionKey) skesk2SessionKey (SKESK4Packet sa s2k (Just esk)) pass = do- keyLen <- first S2KUnsupportedAlgorithm (keySize sa)- kek <- string2Key s2k keyLen pass- decrypted <-- first S2KEncryptedSessionKeyCipherError $- withSymmetricCipher sa kek- (\cipher ->- paddedCfbDecrypt- cipher- (B.replicate (blockSize cipher) 0)- (BL.toStrict esk))- first S2KEncryptedSessionKeyDecodeError (decodeSKESK4EncryptedSessionKey decrypted)+ keyLen <- first S2KUnsupportedAlgorithm (keySize sa)+ kek <- string2Key s2k keyLen pass+ decrypted <-+ first S2KEncryptedSessionKeyCipherError $+ withSymmetricCipher+ sa+ kek+ ( \cipher ->+ paddedCfbDecrypt+ cipher+ (B.replicate (blockSize cipher) 0)+ (BL.toStrict esk)+ )+ first+ S2KEncryptedSessionKeyDecodeError+ (decodeSKESK4EncryptedSessionKey decrypted) -decodeOpenPGPEncodedSessionKey ::- B.ByteString -> Either EncodedSessionKeyError (SymmetricAlgorithm, B.ByteString)+decodeOpenPGPEncodedSessionKey+ :: B.ByteString+ -> Either EncodedSessionKeyError (SymmetricAlgorithm, B.ByteString) decodeOpenPGPEncodedSessionKey encodedSessionKey = do- if B.length encodedSessionKey < 3- then Left EncodedSessionKeyTooShort- else Right ()- let symalgo = toFVal (B.head encodedSessionKey)- rest = B.tail encodedSessionKey- keyLen <- encodedSessionKeyKeyLength symalgo- if B.length rest < keyLen + 2- then Left (EncodedSessionKeyLengthMismatch symalgo keyLen (B.length rest))- else Right ()- let (sessionKey, restAfterKey) = B.splitAt keyLen rest- checksumBytes = B.take 2 restAfterKey- actualChecksum = checksum16 sessionKey- expectedChecksum =- fromIntegral (B.index checksumBytes 0) `shiftL` 8 +- fromIntegral (B.index checksumBytes 1)- if actualChecksum /= expectedChecksum- then Left EncodedSessionKeyChecksumMismatch- else Right (symalgo, sessionKey)+ if B.length encodedSessionKey < 3+ then Left EncodedSessionKeyTooShort+ else Right ()+ let symalgo = toFVal (B.head encodedSessionKey)+ rest = B.tail encodedSessionKey+ keyLen <- encodedSessionKeyKeyLength symalgo+ if B.length rest < keyLen + 2+ then+ Left+ (EncodedSessionKeyLengthMismatch symalgo keyLen (B.length rest))+ else Right ()+ let (sessionKey, restAfterKey) = B.splitAt keyLen rest+ checksumBytes = B.take 2 restAfterKey+ actualChecksum = checksum16 sessionKey+ expectedChecksum =+ fromIntegral (B.index checksumBytes 0) `shiftL` 8+ + fromIntegral (B.index checksumBytes 1)+ if actualChecksum /= expectedChecksum+ then Left EncodedSessionKeyChecksumMismatch+ else Right (symalgo, sessionKey) -decodeSKESK4EncryptedSessionKey ::- B.ByteString -> Either EncodedSessionKeyError (SymmetricAlgorithm, B.ByteString)+decodeSKESK4EncryptedSessionKey+ :: B.ByteString+ -> Either EncodedSessionKeyError (SymmetricAlgorithm, B.ByteString) decodeSKESK4EncryptedSessionKey encodedSessionKey = do- if B.length encodedSessionKey < 1- then Left EncodedSessionKeyTooShort- else Right ()- let symalgo = toFVal (B.head encodedSessionKey)- sessionKey = B.tail encodedSessionKey- keyLen <- encodedSessionKeyKeyLength symalgo- if B.length sessionKey /= keyLen- then Left (EncodedSessionKeyLengthMismatch symalgo keyLen (B.length sessionKey))- else Right (symalgo, sessionKey)+ if B.length encodedSessionKey < 1+ then Left EncodedSessionKeyTooShort+ else Right ()+ let symalgo = toFVal (B.head encodedSessionKey)+ sessionKey = B.tail encodedSessionKey+ keyLen <- encodedSessionKeyKeyLength symalgo+ if B.length sessionKey /= keyLen+ then+ Left+ ( EncodedSessionKeyLengthMismatch+ symalgo+ keyLen+ (B.length sessionKey)+ )+ else Right (symalgo, sessionKey) -encodedSessionKeyKeyLength ::- SymmetricAlgorithm -> Either EncodedSessionKeyError Int+encodedSessionKeyKeyLength+ :: SymmetricAlgorithm -> Either EncodedSessionKeyError Int encodedSessionKeyKeyLength symalgo =- first renderKeySizeError (keySize symalgo)+ first renderKeySizeError (keySize symalgo) where renderKeySizeError :: CipherError -> EncodedSessionKeyError renderKeySizeError (UnsupportedAlgorithm sa) =- EncodedSessionKeyUnsupportedAlgorithm sa+ EncodedSessionKeyUnsupportedAlgorithm sa renderKeySizeError (CipherInitFailed sa _) =- EncodedSessionKeyUnsupportedAlgorithm sa+ EncodedSessionKeyUnsupportedAlgorithm sa renderKeySizeError (CipherOperationFailed _) =- EncodedSessionKeyUnsupportedAlgorithm symalgo+ EncodedSessionKeyUnsupportedAlgorithm symalgo checksum16 :: B.ByteString -> Word16 checksum16 =- fromIntegral .- B.foldl' (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer)) 0+ fromIntegral+ . B.foldl'+ (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer))+ 0 -argon2String2Key :: Salt16 -> Word8 -> Word8 -> Word8 -> Int -> BL.ByteString -> Either S2KError B.ByteString+argon2String2Key+ :: Salt16+ -> Word8+ -> Word8+ -> Word8+ -> Int+ -> BL.ByteString+ -> Either S2KError B.ByteString argon2String2Key salt t p encodedM keyLen pass- | t == 0 = Left (S2KArgon2ParamError "Argon2 S2K pass count must be non-zero")- | p == 0 = Left (S2KArgon2ParamError "Argon2 S2K parallelism must be non-zero")- | encodedM > 31 = Left (S2KArgon2ParamError "Argon2 S2K encoded_m must be <= 31")- | encodedM < minEncodedM = Left (S2KArgon2ParamError "Argon2 S2K encoded_m is too small for parallelism")- | otherwise =- case Argon2.hash opts (BL.toStrict pass) (unSalt16 salt) keyLen of- CryptoPassed k -> Right k- CryptoFailed e -> Left (S2KArgon2Failed (show e))+ | t == 0 =+ Left+ (S2KArgon2ParamError "Argon2 S2K pass count must be non-zero")+ | p == 0 =+ Left+ (S2KArgon2ParamError "Argon2 S2K parallelism must be non-zero")+ | encodedM > 31 =+ Left (S2KArgon2ParamError "Argon2 S2K encoded_m must be <= 31")+ | encodedM < minEncodedM =+ Left+ ( S2KArgon2ParamError+ "Argon2 S2K encoded_m is too small for parallelism"+ )+ | otherwise =+ case Argon2.hash opts (BL.toStrict pass) (unSalt16 salt) keyLen of+ CryptoPassed k -> Right k+ CryptoFailed e -> Left (S2KArgon2Failed (show e)) where opts =- Argon2.defaultOptions- { Argon2.iterations = fromIntegral t- , Argon2.memory = fromIntegral (1 `shiftL` fromIntegral encodedM :: Int)- , Argon2.parallelism = fromIntegral p- , Argon2.variant = Argon2.Argon2id- , Argon2.version = Argon2.Version13- }+ Argon2.defaultOptions+ { Argon2.iterations = fromIntegral t+ , Argon2.memory =+ fromIntegral (1 `shiftL` fromIntegral encodedM :: Int)+ , Argon2.parallelism = fromIntegral p+ , Argon2.variant = Argon2.Argon2id+ , Argon2.version = Argon2.Version13+ } minEncodedM = fromIntegral (3 + ceilLog2 (fromIntegral p :: Int)) ceilLog2 :: Int -> Int ceilLog2 n- | n <= 1 = 0- | otherwise = go 0 1+ | n <= 1 = 0+ | otherwise = go 0 1 where go e v- | v >= n = e- | otherwise = go (e + 1) (v * 2)+ | v >= n = e+ | otherwise = go (e + 1) (v * 2) -hashpp :: HashAlgorithm -> Int -> BL.ByteString -> Either S2KError B.ByteString+hashpp+ :: HashAlgorithm+ -> Int+ -> BL.ByteString+ -> Either S2KError B.ByteString hashpp ha keysize pp =- go 0 B.empty+ B.concat <$> unfoldrM step (0, B.empty) where- go ctr acc- | B.length acc >= keysize = Right acc- | otherwise = do- digest <- hf ha (nulpad ctr `BL.append` pp)- go (ctr + 1) (acc `B.append` digest)+ step (ctr, acc)+ | B.length acc >= keysize = return Nothing+ | otherwise = do+ digest <- hf ha (nulpad ctr `BL.append` pp)+ return (Just (digest, (ctr + 1, acc `B.append` digest))) nulpad = BL.pack . flip replicate 0- hf :: HashAlgorithm -> BL.ByteString -> Either S2KError B.ByteString+ hf+ :: HashAlgorithm -> BL.ByteString -> Either S2KError B.ByteString hf DeprecatedMD5 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.MD5)) hf SHA1 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA1)) hf SHA224 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA224))
Codec/Encryption/OpenPGP/Serialize.hs view
@@ -41,2526 +41,2814 @@ import Control.Arrow ((***)) import Control.Lens ((^.), _1) import Control.Monad (guard, replicateM, replicateM_, when)-import Crypto.Number.Basic (numBits)-import Crypto.Number.ModArithmetic (inverse)-import Crypto.Number.Serialize (i2osp, os2ip)-import qualified Crypto.PubKey.DSA as D-import qualified Crypto.PubKey.ECC.ECDSA as ECDSA-import qualified Crypto.PubKey.ECC.Types as ECCT-import qualified Crypto.PubKey.RSA as R-import Data.Bifunctor (bimap)-import Data.Binary (Binary, get, put)-import Data.Binary.Get- ( ByteOffset- , Get- , bytesRead- , getByteString- , getLazyByteString- , getRemainingLazyByteString- , getWord16be- , getWord16le- , getWord32be- , getWord8- , lookAhead- , runGetOrFail- )-import Data.Binary.Put- ( Put- , putByteString- , putLazyByteString- , putWord16be- , putWord16le- , putWord32be- , putWord8- , runPut- )-import Data.Bits (shiftL, shiftR, testBit, (.&.), (.|.))-import qualified Data.ByteString as B-import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Lazy.Char8 as BLC8-import Data.Conduit (ConduitT, await, yield)-import qualified Data.Foldable as F-import Data.Int (Int64)-import Data.List (mapAccumL)-import qualified Data.List.NonEmpty as NE-import Data.Maybe (fromMaybe)-import Data.Set (Set)-import qualified Data.Set as Set-import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8With, encodeUtf8)-import Data.Text.Encoding.Error (lenientDecode)-import Data.Word (Word16, Word32, Word8)-import Network.URI (nullURI, parseURI, uriToString)--import Codec.Encryption.OpenPGP.Internal- ( curve2Curve- , curveFromCurve- , curveToCurveoidBS- , curveoidBSToCurve- , curveoidBSToEdSigningCurve- , edSigningCurveToCurveoidBS- , leftPadTo- , pubkeyToMPIs- )-import Codec.Encryption.OpenPGP.Policy- ( signatureV6SaltSizeForHashAlgorithm- )-import Codec.Encryption.OpenPGP.Types-import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as BTypes-import qualified Codec.Encryption.OpenPGP.Types.Internal.PKITypes as P--instance Binary SigSubPacket where- get = getSigSubPacket- put = putSigSubPacket---- instance Binary (Set NotationFlag) where--- put = putNotationFlagSet-instance Binary CompressionAlgorithm where- get = toFVal <$> getWord8- put = putWord8 . fromFVal--instance Binary PubKeyAlgorithm where- get = toFVal <$> getWord8- put = putWord8 . fromFVal--instance Binary HashAlgorithm where- get = toFVal <$> getWord8- put = putWord8 . fromFVal--instance Binary SymmetricAlgorithm where- get = toFVal <$> getWord8- put = putWord8 . fromFVal--instance Binary AEADAlgorithm where- get = toFVal <$> getWord8- put = putWord8 . fromFVal--instance Binary MPI where- get = getMPI- put = putMPI--instance Binary SigType where- get = toFVal <$> getWord8- put = putWord8 . fromFVal--instance Binary UserAttrSubPacket where- get = getUserAttrSubPacket- put = putUserAttrSubPacket--instance Binary S2K where- get = getS2K- put = putS2K--instance Binary (PKESK 'PKESKV3) where- get = getPkt >>= either fail pure . fromPktEither- put = putPkt . toPkt--instance Binary (PKESK 'PKESKV6) where- get = getPkt >>= either fail pure . fromPktEither- put = putPkt . toPkt--instance Binary Signature where- get = getPkt >>= either fail pure . fromPktEither- put = putPkt . toPkt--instance Binary (SKESK 'SKESKV4) where- get = getPkt >>= either fail pure . fromPktEither- put = putPkt . toPkt--instance Binary (SKESK 'SKESKV6) where- get = getPkt >>= either fail pure . fromPktEither- put = putPkt . toPkt--instance Binary (OnePassSignature 'OPSV3) where- get = getPkt >>= either fail pure . fromPktEither- put = putPkt . toPkt--instance Binary (OnePassSignature 'OPSV6) where- get = getPkt >>= either fail pure . fromPktEither- put = putPkt . toPkt--instance Binary SecretKey where- get = getPkt >>= either fail pure . fromPktEither- put = putPkt . toPkt--instance Binary PublicKey where- get = getPkt >>= either fail pure . fromPktEither- put = putPkt . toPkt--instance Binary SecretSubkey where- get = getPkt >>= either fail pure . fromPktEither- put = putPkt . toPkt--instance Binary CompressedData where- get = getPkt >>= either fail pure . fromPktEither- put = putPkt . toPkt--instance Binary SymEncData where- get = getPkt >>= either fail pure . fromPktEither- put = putPkt . toPkt--instance Binary Marker where- get = getPkt >>= either fail pure . fromPktEither- put = putPkt . toPkt--instance Binary LiteralData where- get = getPkt >>= either fail pure . fromPktEither- put = putPkt . toPkt--instance Binary Trust where- get = getPkt >>= either fail pure . fromPktEither- put = putPkt . toPkt--instance Binary UserId where- get = getPkt >>= either fail pure . fromPktEither- put = putPkt . toPkt--instance Binary PublicSubkey where- get = getPkt >>= either fail pure . fromPktEither- put = putPkt . toPkt--instance Binary UserAttribute where- get = getPkt >>= either fail pure . fromPktEither- put = putPkt . toPkt--instance Binary SymEncIntegrityProtectedData where- get = getPkt >>= either fail pure . fromPktEither- put = putPkt . toPkt--instance Binary ModificationDetectionCode where- get = getPkt >>= either fail pure . fromPktEither- put = putPkt . toPkt--instance Binary OtherPacket where- get = getPkt >>= either fail pure . fromPktEither- put = putPkt . toPkt--instance Binary Pkt where- get = getPkt- put = putPkt--instance (Binary a) => Binary (Block a) where- get = Block `fmap` many get- put = mapM_ put . unBlock--instance Binary SomePKPayload where- get = getPKPayload- put = putPKPayload--instance Binary SignaturePayload where- get = getSignaturePayload- put = putSignaturePayload--instance Binary TKUnknown where- get = fail "Binary TKUnknown decode is not implemented"- put = putTK--getSigSubPacket :: Get SigSubPacket-getSigSubPacket = do- l <- fmap fromIntegral getSubPacketLength- (crit, pt) <- getSigSubPacketType- getSigSubPacket' pt crit l- where- getSigSubPacket'- :: Word8 -> Bool -> ByteOffset -> Get SigSubPacket- getSigSubPacket' pt crit l- | pt == 2 = do- et <- fmap ThirtyTwoBitTimeStamp getWord32be- return $ SigSubPacket crit (SigCreationTime et)- | pt == 3 = do- et <- fmap ThirtyTwoBitDuration getWord32be- return $ SigSubPacket crit (SigExpirationTime et)- | pt == 4 = do- e <- get- return $ SigSubPacket crit (ExportableCertification e)- | pt == 5 = do- tl <- getWord8- ta <- getWord8- return $ SigSubPacket crit (TrustSignature tl ta)- | pt == 6 = do- apdre <- getLazyByteString (l - 2)- nul <- getWord8- guard (nul == 0)- return $ SigSubPacket crit (RegularExpression (BL.copy apdre))- | pt == 7 = do- r <- get- return $ SigSubPacket crit (Revocable r)- | pt == 9 = do- et <- fmap ThirtyTwoBitDuration getWord32be- return $ SigSubPacket crit (KeyExpirationTime et)- | pt == 11 = do- sa <- replicateM (fromIntegral (l - 1)) get- return $ SigSubPacket crit (PreferredSymmetricAlgorithms sa)- | pt == 12 = do- rclass <- getWord8- guard (testBit rclass 7)- algid <- get- fp <- getLazyByteString (fromIntegral l - 3)- return $- SigSubPacket- crit- ( RevocationKey- (bsToFFSet . BL.singleton $ rclass .&. 0x7f)- algid- (Fingerprint fp)- )- | pt == 16 = do- keyid <- getLazyByteString (l - 1)- return $ SigSubPacket crit (Issuer (EightOctetKeyId keyid))- | pt == 20 = do- flags <- getLazyByteString 4- nl <- getWord16be- vl <- getWord16be- nn <- getLazyByteString (fromIntegral nl)- nv <- getLazyByteString (fromIntegral vl)- return $- SigSubPacket- crit- ( NotationData- (bsToFFSet flags)- (NotationName nn)- (NotationValue nv)- )- | pt == 21 = do- ha <- replicateM (fromIntegral (l - 1)) get- return $ SigSubPacket crit (PreferredHashAlgorithms ha)- | pt == 22 = do- ca <- replicateM (fromIntegral (l - 1)) get- return $ SigSubPacket crit (PreferredCompressionAlgorithms ca)- | pt == 23 = do- ksps <- getLazyByteString (l - 1)- return $- SigSubPacket crit (KeyServerPreferences (bsToFFSet ksps))- | pt == 24 = do- pks <- getLazyByteString (l - 1)- return $ SigSubPacket crit (PreferredKeyServer pks)- | pt == 25 = do- primacy <- get- return $ SigSubPacket crit (PrimaryUserId primacy)- | pt == 26 = do- url <-- fmap- ( URL- . fromMaybe nullURI- . parseURI- . T.unpack- . decodeUtf8With lenientDecode- )- (getByteString (fromIntegral (l - 1)))- return $ SigSubPacket crit (PolicyURL url)- | pt == 27 = do- kfs <- getLazyByteString (l - 1)- return $ SigSubPacket crit (KeyFlags (bsToFFSet kfs))- | pt == 28 = do- uid <- getByteString (fromIntegral (l - 1))- return $- SigSubPacket- crit- (SignersUserId (decodeUtf8With lenientDecode uid))- | pt == 29 = do- rcode <- getWord8- rreason <-- fmap- (decodeUtf8With lenientDecode)- (getByteString (fromIntegral (l - 2)))- return $- SigSubPacket crit (ReasonForRevocation (toFVal rcode) rreason)- | pt == 30 = do- fbs <- getLazyByteString (l - 1)- return $ SigSubPacket crit (Features (bsToFFSet fbs))- | pt == 31 = do- pka <- get- ha <- get- hash <- getLazyByteString (l - 3)- return $ SigSubPacket crit (SignatureTarget pka ha hash)- | pt == 32 = do- spbs <- getLazyByteString (l - 1)- case runGetOrFail get spbs of- Left (_, _, e) -> fail ("embedded signature subpacket " ++ e)- Right (_, _, sp) -> return $ SigSubPacket crit (EmbeddedSignature sp)- | pt == 33 = do- when (l /= 22 && l /= 34) $- fail ("invalid issuer fingerprint subpacket length: " ++ show l)- kv <- getWord8- let fpLen = l - 2- when (fpLen /= 20 && fpLen /= 32) $- fail ("invalid issuer fingerprint length: " ++ show fpLen)- case BTypes.packetVersionToIssuerFingerprintVersion kv of- Nothing ->- fail ("invalid issuer fingerprint version marker: " ++ show kv)- Just ifVersion -> do- fp <-- case kv of- 4 -> getLazyByteString (fromIntegral fpLen)- 6 -> getLazyByteString (fromIntegral fpLen)- _ ->- fail ("invalid issuer fingerprint version marker: " ++ show kv)- return $- SigSubPacket crit (IssuerFingerprint ifVersion (Fingerprint fp))- | pt == 35 = do- kv <- getWord8- fp <- getLazyByteString (l - 2)- when (BL.length fp /= 20 && BL.length fp /= 32) $- fail- ( "invalid intended recipient fingerprint length: "- ++ show (BL.length fp)- )- case BTypes.packetVersionToIssuerFingerprintVersion kv of- Nothing ->- fail- ( "invalid intended recipient fingerprint version marker: "- ++ show kv- )- Just ifVersion ->- return $- SigSubPacket crit (IntendedRecipient ifVersion (Fingerprint fp))- | pt == 39 = do- let payloadLen = fromIntegral (l - 1)- when (payloadLen `mod` 2 /= 0) $- fail "preferred AEAD ciphersuites subpacket length must be even"- pairs <- replicateM (payloadLen `div` 2) $ do- sa <- get- aead <- get- return (sa, aead)- return $ SigSubPacket crit (PreferredAEADCiphersuites pairs)- | pt > 99 && pt < 111 = do- payload <- getLazyByteString (l - 1)- return $ SigSubPacket crit (UserDefinedSigSub pt payload)- | otherwise = do- payload <- getLazyByteString (l - 1)- return $ SigSubPacket crit (OtherSigSub pt payload)--putSigSubPacket :: SigSubPacket -> Put-putSigSubPacket (SigSubPacket crit (SigCreationTime et)) = do- putSubPacketLength 5- putSigSubPacketType crit 2- putWord32be . unThirtyTwoBitTimeStamp $ et-putSigSubPacket (SigSubPacket crit (SigExpirationTime et)) = do- putSubPacketLength 5- putSigSubPacketType crit 3- putWord32be . unThirtyTwoBitDuration $ et-putSigSubPacket (SigSubPacket crit (ExportableCertification e)) = do- putSubPacketLength 2- putSigSubPacketType crit 4- put e-putSigSubPacket (SigSubPacket crit (TrustSignature tl ta)) = do- putSubPacketLength 3- putSigSubPacketType crit 5- put tl- put ta-putSigSubPacket (SigSubPacket crit (RegularExpression apdre)) = do- putSubPacketLength . fromIntegral $ (2 + BL.length apdre)- putSigSubPacketType crit 6- putLazyByteString apdre- putWord8 0-putSigSubPacket (SigSubPacket crit (Revocable r)) = do- putSubPacketLength 2- putSigSubPacketType crit 7- put r-putSigSubPacket (SigSubPacket crit (KeyExpirationTime et)) = do- putSubPacketLength 5- putSigSubPacketType crit 9- putWord32be . unThirtyTwoBitDuration $ et-putSigSubPacket (SigSubPacket crit (PreferredSymmetricAlgorithms ess)) = do- putSubPacketLength . fromIntegral $ (1 + length ess)- putSigSubPacketType crit 11- mapM_ put ess-putSigSubPacket (SigSubPacket crit (RevocationKey rclass algid fp)) = do- let fpLen = BL.length (unFingerprint fp)- putSubPacketLength (fromIntegral (3 + fpLen)) -- type(1) + rclass(1) + algid(1) + fingerprint- putSigSubPacketType crit 12- putLazyByteString . ffSetToFixedLengthBS (1 :: Int) $- Set.insert (RClOther 0) rclass- put algid- putLazyByteString (unFingerprint fp)-putSigSubPacket (SigSubPacket crit (Issuer keyid)) = do- putSubPacketLength 9- putSigSubPacketType crit 16- putLazyByteString (unEOKI keyid) -- 8 octets-putSigSubPacket- ( SigSubPacket- crit- (NotationData nfs (NotationName nn) (NotationValue nv))- ) = do- putSubPacketLength . fromIntegral $- (9 + BL.length nn + BL.length nv)- putSigSubPacketType crit 20- putLazyByteString . ffSetToFixedLengthBS (4 :: Int) $ nfs- putWord16be . fromIntegral . BL.length $ nn- putWord16be . fromIntegral . BL.length $ nv- putLazyByteString nn- putLazyByteString nv-putSigSubPacket (SigSubPacket crit (PreferredHashAlgorithms ehs)) = do- putSubPacketLength . fromIntegral $ (1 + length ehs)- putSigSubPacketType crit 21- mapM_ put ehs-putSigSubPacket (SigSubPacket crit (PreferredCompressionAlgorithms ecs)) = do- putSubPacketLength . fromIntegral $ (1 + length ecs)- putSigSubPacketType crit 22- mapM_ put ecs-putSigSubPacket (SigSubPacket crit (KeyServerPreferences ksps)) = do- let kbs = ffSetToBS ksps- putSubPacketLength . fromIntegral $ (1 + BL.length kbs)- putSigSubPacketType crit 23- putLazyByteString kbs-putSigSubPacket (SigSubPacket crit (PreferredKeyServer ks)) = do- putSubPacketLength . fromIntegral $ (1 + BL.length ks)- putSigSubPacketType crit 24- putLazyByteString ks-putSigSubPacket (SigSubPacket crit (PrimaryUserId primacy)) = do- putSubPacketLength 2- putSigSubPacketType crit 25- put primacy-putSigSubPacket (SigSubPacket crit (PolicyURL (URL uri))) = do- let bs = encodeUtf8 (T.pack (uriToString id uri ""))- putSubPacketLength . fromIntegral $ (1 + B.length bs)- putSigSubPacketType crit 26- putByteString bs-putSigSubPacket (SigSubPacket crit (KeyFlags kfs)) = do- let kbs = ffSetToBS kfs- putSubPacketLength . fromIntegral $ (1 + BL.length kbs)- putSigSubPacketType crit 27- putLazyByteString kbs-putSigSubPacket (SigSubPacket crit (SignersUserId userid)) = do- let bs = encodeUtf8 userid- putSubPacketLength . fromIntegral $ (1 + B.length bs)- putSigSubPacketType crit 28- putByteString bs-putSigSubPacket (SigSubPacket crit (ReasonForRevocation rcode rreason)) = do- let reasonbs = encodeUtf8 rreason- putSubPacketLength . fromIntegral $ (2 + B.length reasonbs)- putSigSubPacketType crit 29- putWord8 . fromFVal $ rcode- putByteString reasonbs-putSigSubPacket (SigSubPacket crit (Features fs)) = do- let fbs = ffSetToBS fs- putSubPacketLength . fromIntegral $ (1 + BL.length fbs)- putSigSubPacketType crit 30- putLazyByteString fbs-putSigSubPacket (SigSubPacket crit (SignatureTarget pka ha hash)) = do- putSubPacketLength . fromIntegral $ (3 + BL.length hash)- putSigSubPacketType crit 31- put pka- put ha- putLazyByteString hash-putSigSubPacket (SigSubPacket crit (EmbeddedSignature sp)) = do- let spb = runPut (put sp)- putSubPacketLength . fromIntegral $ (1 + BL.length spb)- putSigSubPacketType crit 32- putLazyByteString spb-putSigSubPacket (SigSubPacket crit (IssuerFingerprint kv fp)) = do- let kv' = BTypes.issuerFingerprintVersionToPacketVersion kv- let fpb = unFingerprint fp- when (BL.length fpb /= 20 && BL.length fpb /= 32) $- error- ("invalid issuer fingerprint length: " ++ show (BL.length fpb))- putSubPacketLength . fromIntegral $ (2 + BL.length fpb)- putSigSubPacketType crit 33- putWord8 kv'- putLazyByteString fpb-putSigSubPacket (SigSubPacket crit (IntendedRecipient kv irf)) = do- let kv' = BTypes.issuerFingerprintVersionToPacketVersion kv- let fpb = unFingerprint irf- when (BL.length fpb /= 20 && BL.length fpb /= 32) $- error- ( "invalid intended-recipient fingerprint length: "- ++ show (BL.length fpb)- )- putSubPacketLength . fromIntegral $ (2 + BL.length fpb)- putSigSubPacketType crit 35- putWord8 kv'- putLazyByteString fpb-putSigSubPacket (SigSubPacket crit (PreferredAEADCiphersuites ps)) = do- putSubPacketLength . fromIntegral $ (1 + 2 * length ps)- putSigSubPacketType crit 39- mapM_ (\(sa, aead) -> put sa >> put aead) ps-putSigSubPacket (SigSubPacket crit (UserDefinedSigSub ptype payload)) =- putSigSubPacket (SigSubPacket crit (OtherSigSub ptype payload))-putSigSubPacket (SigSubPacket crit (OtherSigSub ptype payload)) = do- putSubPacketLength . fromIntegral $ (1 + BL.length payload)- putSigSubPacketType crit ptype- putLazyByteString payload--getSubPacketLength :: Get Word32-getSubPacketLength = getSubPacketLength' =<< getWord8- where- getSubPacketLength' :: (Integral a) => Word8 -> Get a- getSubPacketLength' f- | f < 192 = return . fromIntegral $ f- | f < 224 = do- secondOctet <- getWord8- return . fromIntegral $- shiftL (fromIntegral (f - 192) :: Int) 8- + (fromIntegral secondOctet :: Int)- + 192- | f == 255 = do- len <- getWord32be- return . fromIntegral $ len- | otherwise = fail "Partial body length invalid."--putSubPacketLength :: Word32 -> Put-putSubPacketLength l- | l < 192 = putWord8 (fromIntegral l)- | l < 8384 =- putWord8- (fromIntegral ((fromIntegral (l - 192) `shiftR` 8) + 192 :: Int))- >> putWord8 (fromIntegral (l - 192) .&. 0xff)- | l <= 0xffffffff = putWord8 255 >> putWord32be (fromIntegral l)- | otherwise = error ("too big (" ++ show l ++ ")")--getSigSubPacketType :: Get (Bool, Word8)-getSigSubPacketType = do- x <- getWord8- return- ( if x .&. 128 == 128- then (True, x .&. 127)- else (False, x)- )--putSigSubPacketType :: Bool -> Word8 -> Put-putSigSubPacketType False sst = putWord8 sst-putSigSubPacketType True sst = putWord8 (sst .|. 0x80)--bsToFFSet :: (FutureFlag a) => ByteString -> Set a-bsToFFSet bs =- Set.fromAscList . concat . snd $- mapAccumL- (\acc y -> (acc + 8, concatMap (shifty acc y) [0 .. 7]))- 0- (BL.unpack bs)- where- shifty acc y x = [toFFlag (acc + x) | y .&. shiftR 128 x == shiftR 128 x]--ffSetToFixedLengthBS- :: (FutureFlag b, Integral a) => a -> Set b -> ByteString-ffSetToFixedLengthBS len ffs =- BL.take- (fromIntegral len)- (BL.append (ffSetToBS ffs) (BL.pack (replicate 5 0)))--ffSetToBS :: (FutureFlag a) => Set a -> ByteString-ffSetToBS = BL.pack . ffSetToBS'- where- ffSetToBS' :: (FutureFlag a) => Set a -> [Word8]- ffSetToBS' ks- -- Emit a single zero octet for an empty flag set so encoded flag- -- subpackets always carry an explicit flags byte.- | Set.null ks = [0]- | otherwise =- map- ( ( foldl (.|.) 0- . map (shiftR 128 . flip mod 8 . fromFFlag)- . Set.toAscList- )- . (\x -> Set.filter (\y -> fromFFlag y `div` 8 == x) ks)- )- [0 .. fromFFlag (Set.findMax ks) `div` 8]--fromS2K :: S2K -> ByteString-fromS2K (Simple hashalgo) = BL.pack [0, fromIntegral . fromFVal $ hashalgo]-fromS2K (Salted hashalgo salt) =- BL.pack [1, fromIntegral . fromFVal $ hashalgo]- `BL.append` (BL.fromStrict . unSalt8) salt-fromS2K (IteratedSalted hashalgo salt count) =- BL.pack [3, fromIntegral . fromFVal $ hashalgo]- `BL.append` (BL.fromStrict . unSalt8) salt- `BL.snoc` encodeIterationCount count-fromS2K (Argon2 salt t p encodedM) =- BL.pack [4]- `BL.append` (BL.fromStrict . unSalt16) salt- `BL.append` BL.pack [t, p, encodedM]-fromS2K (OtherS2K _ bs) = bs--getPacketLength :: Get Integer-getPacketLength = do- firstOctet <- getWord8- lenOrPartial <- lengthOctetToLength firstOctet- case lenOrPartial of- Left _ ->- fail "Partial body length is invalid in this context"- Right len -> return len- where- lengthOctetToLength :: Word8 -> Get (Either Integer Integer)- lengthOctetToLength f- | f < 192 = return . Right . fromIntegral $ f- | f < 224 = do- secondOctet <- getWord8- return . Right . fromIntegral $- shiftL (fromIntegral (f - 192) :: Int) 8- + (fromIntegral secondOctet :: Int)- + 192- | f < 255 =- return . Left . fromIntegral $- (1 :: Integer) `shiftL` fromIntegral (f .&. 0x1f)- | otherwise = do- len <- getWord32be- return . Right . fromIntegral $ len--putPacketLength :: Integer -> Put-putPacketLength l- | l < 192 = putWord8 (fromIntegral l)- | l < 8384 =- putWord8- (fromIntegral ((fromIntegral (l - 192) `shiftR` 8) + 192 :: Int))- >> putWord8 (fromIntegral (l - 192) .&. 0xff)- | l < 0x100000000 = putWord8 255 >> putWord32be (fromIntegral l)- | otherwise =- error "packet length exceeds 32-bit definite length encoding"--putPartialLength :: Word8 -> Put-putPartialLength n = putWord8 (224 + n)--getPacketLengthFromOctet :: Word8 -> Get (Either Int64 Int64)-getPacketLengthFromOctet f- | f < 192 = return . Right . fromIntegral $ f- | f < 224 = do- secondOctet <- getWord8- return . Right . fromIntegral $- shiftL (fromIntegral (f - 192) :: Int) 8- + (fromIntegral secondOctet :: Int)- + 192- | f < 255 =- return . Left . fromIntegral $- (1 :: Integer) `shiftL` fromIntegral (f .&. 0x1f)- | otherwise = do- len <- getWord32be- return . Right . fromIntegral $ len--getS2K :: Get S2K-getS2K = getS2K' =<< getWord8- where- getS2K' :: Word8 -> Get S2K- getS2K' t- | t == 0 = do- ha <- getWord8- return $ Simple (toFVal ha)- | t == 1 = do- ha <- getWord8- salt <- getByteString 8- return $ Salted (toFVal ha) (Salt8 salt)- | t == 3 = do- ha <- getWord8- salt <- getByteString 8- count <- getWord8- return $- IteratedSalted- (toFVal ha)- (Salt8 salt)- (decodeIterationCount count)- | t == 4 = do- salt <- getByteString 16- passes <- getWord8- parallelism <- getWord8- encodedM <- getWord8- return $ Argon2 (Salt16 salt) passes parallelism encodedM- | otherwise = do- bs <- getRemainingLazyByteString- return $ OtherS2K t bs--putS2K :: S2K -> Put-putS2K (Simple hashalgo) = error ("confused by simple" ++ show hashalgo)-putS2K (Salted hashalgo salt) =- error- ("confused by salted" ++ show hashalgo ++ " by " ++ show salt)-putS2K (IteratedSalted ha salt count) = do- putWord8 3- put ha- putByteString (unSalt8 salt)- putWord8 $ encodeIterationCount count-putS2K (Argon2 salt t p encodedM) = do- putWord8 4- putByteString (unSalt16 salt)- putWord8 t- putWord8 p- putWord8 encodedM-putS2K (OtherS2K t bs) = putWord8 t >> putLazyByteString bs--v6SaltSizeForHashAlgorithm :: HashAlgorithm -> Maybe Word8-v6SaltSizeForHashAlgorithm = signatureV6SaltSizeForHashAlgorithm--getPacketTypeAndPayload :: Get (Word8, ByteString)-getPacketTypeAndPayload = do- tag <- getWord8- guard (testBit tag 7)- case tag .&. 0x40 of- 0x00 -> do- let t = shiftR (tag .&. 0x3c) 2- case tag .&. 0x03 of- 0 -> do- len <- getWord8- bs <- getLazyByteString (fromIntegral len)- return (t, bs)- 1 -> do- len <- getWord16be- bs <- getLazyByteString (fromIntegral len)- return (t, bs)- 2 -> do- len <- getWord32be- bs <- getLazyByteString (fromIntegral len)- return (t, bs)- 3 -> do- bs <- getRemainingLazyByteString- return (t, bs)- _ ->- error "This should never happen (getPacketTypeAndPayload/0x00)."- 0x40 -> do- firstLenOctet <- getWord8- bs <- getPacketPayloadFromLengthOctet firstLenOctet- return (tag .&. 0x3f, bs)- _ ->- error "This should never happen (getPacketTypeAndPayload/???)."- where- getPacketPayloadFromLengthOctet :: Word8 -> Get ByteString- getPacketPayloadFromLengthOctet lenOctet = do- lenOrPartial <- getPacketLengthFromOctet lenOctet- case lenOrPartial of- Right len -> getLazyByteString len- Left partialLen -> do- chunk <- getLazyByteString partialLen- rest <- getRemainingPartialPayload- return (chunk <> rest)- getRemainingPartialPayload :: Get ByteString- getRemainingPartialPayload = do- lenOctet <- getWord8- lenOrPartial <- getPacketLengthFromOctet lenOctet- case lenOrPartial of- Right len -> getLazyByteString len- Left partialLen -> do- chunk <- getLazyByteString partialLen- (chunk <>) <$> getRemainingPartialPayload--getPkt :: Get Pkt-getPkt = do- (t, pl) <- getPacketTypeAndPayload- case runGetOrFail (getPkt' t (BL.length pl)) pl of- Left (_, _, e) -> return $! BrokenPacketPkt e t pl- Right (_, _, p) -> return p- where- parseLegacyPKESK- :: PacketVersion -> BL.ByteString -> Either String Pkt- parseLegacyPKESK pv body = do- (_, _, (eokeyid, pkaRaw, mpib)) <-- bimap (\(_, _, e) -> e) id $- runGetOrFail- ( do- eokeyid <- getLazyByteString 8- pka <- getWord8- mpib <- getRemainingLazyByteString- pure (eokeyid, pka, mpib)- )- body- let pka = toFVal pkaRaw- sk <- parseLegacyPKESKMPIs pka mpib- pure $- PKESKPkt- ( PKESKPayloadV3Packet- (PKESKPayloadV3 pv (EightOctetKeyId eokeyid) pka sk)- )-- parseLegacyPKESKMPIs- :: PubKeyAlgorithm- -> BL.ByteString- -> Either String (NE.NonEmpty MPI)- parseLegacyPKESKMPIs pka mpib = do- case parseLegacyPKESKMPIsStrict pka mpib of- Right sk -> pure sk- Left strictErr- | pka == X25519 ->- case parseLegacyPKESKX25519V3Octets mpib of- Right sk -> Right sk- Left octetErr ->- Left- ( strictErr- ++ "; also failed to parse RFC9580 X25519 v3 octet layout: "- ++ octetErr- )- | pka == ECDH ->- case parseLegacyPKESKECDHOctets mpib of- Right sk -> Right sk- Left octetErr ->- Left- ( strictErr- ++ "; also failed to parse RFC6637 ECDH v3 octet layout: "- ++ octetErr- )- | otherwise -> Left strictErr-- parseLegacyPKESKMPIsStrict- :: PubKeyAlgorithm- -> BL.ByteString- -> Either String (NE.NonEmpty MPI)- parseLegacyPKESKMPIsStrict pka mpib = do- (rest, _, sk) <-- bimap (\(_, _, e) -> e) id $- runGetOrFail (parserForLegacyPKESKMPIs pka) mpib- if BL.null rest- then pure (NE.fromList sk)- else- Left- ("unexpected trailing PKESK MPI data for algorithm " ++ show pka)-- parseLegacyPKESKX25519V3Octets- :: BL.ByteString -> Either String (NE.NonEmpty MPI)- parseLegacyPKESKX25519V3Octets mpib = do- if BL.length mpib < 33- then Left "X25519 v3 PKESK octet layout is too short"- else Right ()- let ephemeral = BL.toStrict (BL.take 32 mpib)- eskLen = fromIntegral (BL.index mpib 32) :: Int- eskWithAlgo = BL.toStrict (BL.drop 33 mpib)- if eskLen /= B.length eskWithAlgo- then- Left "X25519 v3 PKESK octet layout has inconsistent ESK length"- else Right ()- if B.null eskWithAlgo- then- Left- "X25519 v3 PKESK octet layout must include a symmetric algorithm octet"- else Right ()- let symAlgo = B.head eskWithAlgo- if symAlgo- `elem` [ fromIntegral (fromFVal AES128)- , fromIntegral (fromFVal AES192)- , fromIntegral (fromFVal AES256)- ]- then- pure- (NE.fromList [MPI (os2ip ephemeral), MPI (os2ip eskWithAlgo)])- else- Left- ( "X25519 v3 PKESK octet layout has unsupported symmetric algorithm octet "- ++ show symAlgo- )-- -- \| Parse an RFC 6637 §8 ECDH PKESKv3 body as MPI(ephemeral) || 1-octet-count || C.- -- This is the interoperable wire format produced by GnuPG and other RFC-compliant- -- implementations. hOpenPGP previously wrote both fields as MPIs; this fallback- -- allows reading RFC-compliant packets when the strict two-MPI path fails.- parseLegacyPKESKECDHOctets- :: BL.ByteString -> Either String (NE.NonEmpty MPI)- parseLegacyPKESKECDHOctets mpib = do- (rest, _, ephMPI) <-- bimap (\(_, _, e) -> e) id $ runGetOrFail getMPI mpib- let restBS = BL.toStrict rest- when (B.null restBS) $- Left- "ECDH v3 PKESK RFC6637 octet layout: missing wrapped-key length octet after ephemeral MPI"- let wrappedLen = fromIntegral (B.head restBS) :: Int- wrapped = B.tail restBS- when (wrappedLen /= B.length wrapped) $- Left- ( "ECDH v3 PKESK RFC6637 octet layout: wrapped key length field "- ++ show wrappedLen- ++ " does not match body length "- ++ show (B.length wrapped)- )- when (wrappedLen < 24 || wrappedLen `mod` 8 /= 0) $- Left- ( "ECDH v3 PKESK RFC6637 octet layout: wrapped key length "- ++ show wrappedLen- ++ " is not a valid RFC 3394 wrapped key size"- )- pure (ephMPI NE.:| [MPI (os2ip wrapped)])-- parserForLegacyPKESKMPIs :: PubKeyAlgorithm -> Get [MPI]- parserForLegacyPKESKMPIs pka =- case expectedLegacyPKESKMPIArity pka of- Just mpiCount -> replicateM mpiCount getMPI- Nothing -> some getMPI-- expectedLegacyPKESKMPIArity :: PubKeyAlgorithm -> Maybe Int- expectedLegacyPKESKMPIArity pka- | pka `elem` [RSA, DeprecatedRSAEncryptOnly] = Just 1- | pka `elem` [ElgamalEncryptOnly, ForbiddenElgamal, ECDH, X25519] =- Just 2- | otherwise = Nothing-- validateV4SKESKEncryptedSessionKeyS2K- :: S2K -> Maybe BL.ByteString -> Get ()- validateV4SKESKEncryptedSessionKeyS2K _ Nothing = pure ()- validateV4SKESKEncryptedSessionKeyS2K Simple {} (Just _) =- fail- "v4 SKESK packets with encrypted session keys must not use Simple S2K"- validateV4SKESKEncryptedSessionKeyS2K _ (Just _) = pure ()-- parseV6PKESK :: BL.ByteString -> Either String Pkt- parseV6PKESK body = do- (_, _, (recipientKeyIdentifier, pka, esk)) <-- bimap (\(_, _, e) -> e) id $- runGetOrFail- ( do- keyIdentifierLen <- getWord8- recipientKeyIdentifier <-- getLazyByteString (fromIntegral keyIdentifierLen)- pka <- getWord8- esk <- getRemainingLazyByteString- pure (recipientKeyIdentifier, pka, esk)- )- body- validateV6PKESKRecipientIdentifier recipientKeyIdentifier- pure $- PKESKPkt- ( PKESKPayloadV6Packet- (PKESKPayloadV6 recipientKeyIdentifier (toFVal pka) esk)- )- where- validateV6PKESKRecipientIdentifier- :: BL.ByteString -> Either String ()- validateV6PKESKRecipientIdentifier rid =- case BL.length rid of- 0 -> Right ()- 20 -> Right ()- 32 -> Right ()- 21 -> validateVersionedFingerprint rid- 33 -> validateVersionedFingerprint rid- ridLen ->- Left- ( "invalid PKESK v6 recipient identifier length: "- ++ show ridLen- ++ " (expected 0, 20, 21, 32, or 33)"- )-- validateVersionedFingerprint :: BL.ByteString -> Either String ()- validateVersionedFingerprint rid =- let keyVersion = BL.head rid- fingerprintLen = BL.length (BL.tail rid)- in case keyVersion of- 4 ->- if fingerprintLen == 20- then Right ()- else- Left- ( "PKESK v6 recipient identifier length/version mismatch: key version 4 requires fingerprint length 20, got "- ++ show fingerprintLen- )- 6 ->- if fingerprintLen == 32- then Right ()- else- Left- ( "PKESK v6 recipient identifier length/version mismatch: key version 6 requires fingerprint length 32, got "- ++ show fingerprintLen- )- _ ->- Left- ( "invalid PKESK v6 recipient key version: "- ++ show keyVersion- ++ " (expected 4 or 6)"- )-- getPkt' :: Word8 -> ByteOffset -> Get Pkt- getPkt' t len- | t == 1 = do- pv <- getWord8- body <- getRemainingLazyByteString- if pv == 6- then case parseV6PKESK body of- Right pkt -> return pkt- Left v6Err -> fail ("PKESK v6 parse failed: " ++ v6Err)- else case parseLegacyPKESK pv body of- Right pkt -> return pkt- Left legacyErr -> fail ("PKESK MPIs " ++ legacyErr)- | t == 2 = do- bs <- getRemainingLazyByteString- case runGetOrFail get bs of- Left (_, _, e) -> fail ("signature packet " ++ e)- Right (_, _, sp) -> return $ SignaturePkt sp- | t == 3 = do- pv <- getWord8- let getV6SKESKParams = do- symalgoWord <- getWord8- aeadWord <- getWord8- s2kLen <- getWord8- s2kBytes <- getLazyByteString (fromIntegral s2kLen)- s2k <-- case runGetOrFail getS2K s2kBytes of- Left (_, _, err) -> fail err- Right (rest, _, parsed)- | not (BL.null rest) ->- fail "unexpected trailing bytes in v6 SKESK S2K specifier"- | otherwise -> pure parsed- let symalgo = toFVal symalgoWord- aead = toFVal aeadWord- ivLen = fromIntegral (aeadNonceSize aead)- iv <- getLazyByteString ivLen- pure (symalgo, aead, s2k, iv)- case pv of- 6 -> do- paramsLen <- getWord8- params <- getLazyByteString (fromIntegral paramsLen)- (symalgo, aead, s2k, iv) <-- case runGetOrFail getV6SKESKParams params of- Left (_, _, err) -> fail err- Right (rest, _, parsed)- | not (BL.null rest) ->- fail "unexpected trailing v6 SKESK parameters"- | otherwise -> pure parsed- payload <- getRemainingLazyByteString- when (BL.length payload < 16) $- fail- "v6 SKESK payload must include encrypted session key and authentication tag"- let (esk, tag) = BL.splitAt (BL.length payload - 16) payload- return $- SKESKPkt- ( SKESKPayloadV6Packet- ( SKESKPayloadV6- symalgo- aead- s2k- iv- esk- tag- )- )- 4 -> do- symalgo <- getWord8- s2k <- getS2K- esk <- getRemainingLazyByteString- let mesk = if BL.null esk then Nothing else Just esk- validateV4SKESKEncryptedSessionKeyS2K s2k mesk- return $- SKESKPkt- ( SKESKPayloadV4Packet- ( SKESKPayloadV4- (toFVal symalgo)- s2k- mesk- )- )- _ -> fail ("unsupported SKESK packet version " ++ show pv)- | t == 4 = do- pv <- getWord8- sigtype <- toFVal <$> getWord8- ha <- toFVal <$> getWord8- pka <- toFVal <$> getWord8- case pv of- 3 -> do- skeyid <- getLazyByteString 8- nested <- getWord8 >>= parseOPSNestedFlag- return $- OnePassSignaturePkt- ( OPSPayloadV3Packet- ( OPSPayloadV3- pv- sigtype- ha- pka- (EightOctetKeyId skeyid)- nested- )- )- 6 -> do- saltSize <- getWord8- expectedSaltSize <-- maybe- ( fail- ( "signature hash algorithm does not define a V6 salt size: "- ++ show ha- )- )- pure- (v6SaltSizeForHashAlgorithm ha)- when (saltSize /= expectedSaltSize) $- fail- ( "OPS v6 salt size mismatch for "- ++ show ha- ++ ": expected "- ++ show expectedSaltSize- ++ ", got "- ++ show saltSize- )- salt <-- SignatureSalt <$> getLazyByteString (fromIntegral saltSize)- signerFingerprint <- getLazyByteString 32- nested <- getWord8 >>= parseOPSNestedFlag- return $- OnePassSignaturePkt- ( OPSPayloadV6Packet- ( OPSPayloadV6- sigtype- ha- pka- salt- signerFingerprint- nested- )- )- _ -> fail ("Unsupported OPS version: " ++ show pv)- | t == 5 = do- bs <- getLazyByteString len- let ps =- flip runGetOrFail bs $ do- pkp <- getPKPayload- ska <- getSKAddendum pkp- return $ SecretKeyPkt pkp ska- case ps of- Left (_, _, err) -> fail ("secret key " ++ err)- Right (_, _, pkt) -> return pkt- | t == 6 = do- pkp <- getPKPayload- return $ PublicKeyPkt pkp- | t == 7 = do- bs <- getLazyByteString len- let ps =- flip runGetOrFail bs $ do- pkp <- getPKPayload- ska <- getSKAddendum pkp- return $ SecretSubkeyPkt pkp ska- case ps of- Left (_, _, err) -> fail ("secret subkey " ++ err)- Right (_, _, pkt) -> return pkt- | t == 8 = do- ca <- getWord8- cdata <- getLazyByteString (len - 1)- return $ CompressedDataPkt (toFVal ca) cdata- | t == 9 = do- sdata <- getLazyByteString len- return $ SymEncDataPkt sdata- | t == 10 = do- marker <- getLazyByteString len- return $ MarkerPkt marker- | t == 11 = do- dt <- getWord8- flen <- getWord8- fn <- getLazyByteString (fromIntegral flen)- ts <- fmap ThirtyTwoBitTimeStamp getWord32be- ldata <- getLazyByteString (len - (6 + fromIntegral flen))- return $ LiteralDataPkt (toFVal dt) fn ts ldata- | t == 12 = do- tdata <- getLazyByteString len- return $ TrustPkt tdata- | t == 13 = do- udata <- getByteString (fromIntegral len)- return . UserIdPkt . decodeUtf8With lenientDecode $ udata- | t == 14 = do- bs <- getLazyByteString len- let ps =- flip runGetOrFail bs $ do- pkp <- getPKPayload- return $ PublicSubkeyPkt pkp- case ps of- Left (_, _, err) -> fail ("public subkey " ++ err)- Right (_, _, pkt) -> return pkt- | t == 17 = do- bs <- getLazyByteString len- case runGetOrFail (many getUserAttrSubPacket) bs of- Left (_, _, err) -> fail ("user attribute " ++ err)- Right (_, _, uas) -> return $ UserAttributePkt uas- | t == 18 = do- pv <- getWord8- case pv of- 1 -> do- b <- getLazyByteString (len - 1)- return $ SymEncIntegrityProtectedDataPkt (SEIPD1 pv b)- 2 -> do- when (len < 36) $- fail "SEIPD v2 packet too short"- symalgo <- toFVal <$> getWord8- aeadalgo <- toFVal <$> getWord8- chunkSize <- getWord8- salt <- Salt <$> getByteString 32- encrypted <- getLazyByteString (len - 36)- validateSEIPDv2Header symalgo aeadalgo chunkSize encrypted- return $- SymEncIntegrityProtectedDataPkt- ( SEIPD2- symalgo- aeadalgo- chunkSize- salt- encrypted- )- _ -> fail ("Unsupported SEIPD version: " ++ show pv)- | t == 19 = do- hash <- getLazyByteString 20- return $ ModificationDetectionCodePkt hash- | t == 21 = do- payload <- getLazyByteString len- return $ PaddingPkt payload- | otherwise = do- payload <- getLazyByteString len- return $ OtherPacketPkt t payload--getUserAttrSubPacket :: Get UserAttrSubPacket-getUserAttrSubPacket = do- l <- fmap fromIntegral getSubPacketLength- t <- getWord8- getUserAttrSubPacket' t l- where- getUserAttrSubPacket'- :: Word8 -> ByteOffset -> Get UserAttrSubPacket- getUserAttrSubPacket' t l- | t == 1 = do- _ <- getWord16le -- ihlen- hver <- getWord8 -- should be 1- iformat <- getWord8- nuls <- getLazyByteString 12 -- should be NULs- bs <- getLazyByteString (l - 17)- if hver /= 1 || nuls /= BL.pack (replicate 12 0)- then fail "Corrupt UAt subpacket"- else return $ ImageAttribute (ImageHV1 (toFVal iformat)) bs- | otherwise = do- bs <- getLazyByteString (l - 1)- return $ OtherUASub t bs--putUserAttrSubPacket :: UserAttrSubPacket -> Put-putUserAttrSubPacket ua = do- let sp = runPut $ putUserAttrSubPacket' ua- putSubPacketLength . fromIntegral . BL.length $ sp- putLazyByteString sp- where- putUserAttrSubPacket' (ImageAttribute (ImageHV1 iformat) idata) = do- putWord8 1- putWord16le 16- putWord8 1- putWord8 (fromFVal iformat)- replicateM_ 12 $ putWord8 0- putLazyByteString idata- putUserAttrSubPacket' (OtherUASub t bs) = do- putWord8 t- putLazyByteString bs--{- | Serialize PKESKv3 session-key material.-For ECDH and X25519 the RFC 6637 §8 / RFC 9580 §5.1.6 wire format is used:-MPI(ephemeral_key) || 1-octet-count || wrapped_session_key_bytes.-All other algorithms use the standard MPI sequence.--}-putPKESKv3SessionKeyMaterial- :: PubKeyAlgorithm -> NE.NonEmpty MPI -> Put-putPKESKv3SessionKeyMaterial pka mpis- | pka `elem` [ECDH, X25519]- , (ephMPI NE.:| [wrappedMPI]) <- mpis = do- put ephMPI- let rawWrapped = i2osp (unMPI wrappedMPI)- -- Left-pad to the nearest valid RFC 3394 wrapped-key length so that- -- leading-zero bytes stripped by i2osp are restored.- targetLen =- headDef- (B.length rawWrapped)- (filter (>= B.length rawWrapped) [32, 40, 48])- paddedWrapped = leftPadTo targetLen rawWrapped- putWord8 (fromIntegral (B.length paddedWrapped))- putByteString paddedWrapped- | otherwise = F.mapM_ put mpis- where- headDef d [] = d- headDef _ (x : _) = x--putPkt :: Pkt -> Put-putPkt- ( PKESKPkt- (PKESKPayloadV3Packet (PKESKPayloadV3 pv eokeyid pka mpis))- ) = do- putWord8 (0xc0 .|. 1)- let bsk = runPut $ putPKESKv3SessionKeyMaterial pka mpis- putPacketLength . fromIntegral $ 10 + BL.length bsk- putWord8 pv -- must be 3- putLazyByteString (unEOKI eokeyid) -- must be 8 octets- putWord8 $ fromIntegral . fromFVal $ pka- putLazyByteString bsk-putPkt- ( PKESKPkt- ( PKESKPayloadV6Packet- (PKESKPayloadV6 recipientKeyIdentifier pka esk)- )- ) = do- putWord8 (0xc0 .|. 1)- let keyIdentifierLen = BL.length recipientKeyIdentifier- when (keyIdentifierLen > 255) $- error "PKESK v6 recipient key identifier must fit in one octet"- putPacketLength . fromIntegral $- 3 + keyIdentifierLen + BL.length esk- putWord8 6- putWord8 (fromIntegral keyIdentifierLen)- putLazyByteString recipientKeyIdentifier- putWord8 $ fromIntegral . fromFVal $ pka- putLazyByteString esk-putPkt (SignaturePkt sp) = do- putWord8 (0xc0 .|. 2)- let bs = runPut $ put sp- putLengthThenPayload bs-putPkt (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 symalgo s2k mesk))) = do- putWord8 (0xc0 .|. 3)- let bs2k = fromS2K s2k- let bsk = fromMaybe BL.empty mesk- putPacketLength . fromIntegral $- 2 + BL.length bs2k + BL.length bsk- putWord8 4- putWord8 $ fromIntegral . fromFVal $ symalgo- putLazyByteString bs2k- putLazyByteString bsk-putPkt- ( SKESKPkt- (SKESKPayloadV6Packet (SKESKPayloadV6 symalgo aead s2k iv esk tag))- ) = do- putWord8 (0xc0 .|. 3)- let bs2k = fromS2K s2k- let params =- BL.pack- [ fromIntegral (fromFVal symalgo)- , fromIntegral (fromFVal aead)- , fromIntegral (BL.length bs2k)- ]- <> bs2k- <> iv- putPacketLength . fromIntegral $- 2 + BL.length params + BL.length esk + BL.length tag- putWord8 6- putWord8 (fromIntegral (BL.length params))- putLazyByteString params- putLazyByteString esk- putLazyByteString tag-putPkt- ( OnePassSignaturePkt- (OPSPayloadV3Packet (OPSPayloadV3 pv sigtype ha pka skeyid nested))- ) = do- putWord8 (0xc0 .|. 4)- let bs =- runPut $ do- putWord8 pv -- should be 3- putWord8 $ fromIntegral . fromFVal $ sigtype- putWord8 $ fromIntegral . fromFVal $ ha- putWord8 $ fromIntegral . fromFVal $ pka- putLazyByteString (unEOKI skeyid)- putWord8 . fromIntegral . fromEnum $ not nested- putLengthThenPayload bs-putPkt- ( OnePassSignaturePkt- ( OPSPayloadV6Packet- (OPSPayloadV6 sigtype ha pka salt signerFingerprint nested)- )- ) = do- putWord8 (0xc0 .|. 4)- let saltBytes = unSignatureSalt salt- saltSize = BL.length saltBytes- expectedSaltSize =- maybe- ( error- ( "signature hash algorithm does not define a V6 salt size: "- ++ show ha- )- )- id- (v6SaltSizeForHashAlgorithm ha)- when (fromIntegral saltSize /= expectedSaltSize) $- error- ( "OPS v6 salt size mismatch for "- ++ show ha- ++ ": expected "- ++ show expectedSaltSize- ++ ", got "- ++ show saltSize- )- when (BL.length signerFingerprint /= 32) $- error "OPS v6 signer fingerprint must be exactly 32 octets"- let bs =- runPut $ do- putWord8 6- putWord8 $ fromIntegral . fromFVal $ sigtype- putWord8 $ fromIntegral . fromFVal $ ha- putWord8 $ fromIntegral . fromFVal $ pka- putWord8 (fromIntegral saltSize)- putLazyByteString saltBytes- putLazyByteString signerFingerprint- putWord8 . fromIntegral . fromEnum $ not nested- putLengthThenPayload bs-putPkt (SecretKeyPkt pkp ska) = do- putWord8 (0xc0 .|. 5)- let bs = runPut (putPKPayload pkp >> putSKAddendumForPKPayload pkp ska)- putLengthThenPayload bs-putPkt (PublicKeyPkt pkp) = do- putWord8 (0xc0 .|. 6)- let bs = runPut $ putPKPayload pkp- putLengthThenPayload bs-putPkt (SecretSubkeyPkt pkp ska) = do- putWord8 (0xc0 .|. 7)- let bs = runPut (putPKPayload pkp >> putSKAddendumForPKPayload pkp ska)- putLengthThenPayload bs-putPkt (CompressedDataPkt ca cdata) = do- putWord8 (0xc0 .|. 8)- let bs =- runPut $ do- putWord8 $ fromIntegral . fromFVal $ ca- putLazyByteString cdata- putLengthThenPayload bs-putPkt (SymEncDataPkt b) = do- putWord8 (0xc0 .|. 9)- putLengthThenPayload b-putPkt (MarkerPkt b) = do- putWord8 (0xc0 .|. 10)- putLengthThenPayload b-putPkt (LiteralDataPkt dt fn ts b) = do- putWord8 (0xc0 .|. 11)- let bs =- runPut $ do- putWord8 $ fromIntegral . fromFVal $ dt- putWord8 $ fromIntegral . BL.length $ fn- putLazyByteString fn- putWord32be . unThirtyTwoBitTimeStamp $ ts- putLazyByteString b- putLengthThenPayload bs-putPkt (TrustPkt b) = do- putWord8 (0xc0 .|. 12)- putLengthThenPayload b-putPkt (UserIdPkt u) = do- putWord8 (0xc0 .|. 13)- let bs = encodeUtf8 u- putPacketLength . fromIntegral $ B.length bs- putByteString bs-putPkt (PublicSubkeyPkt pkp) = do- putWord8 (0xc0 .|. 14)- let bs = runPut $ putPKPayload pkp- putLengthThenPayload bs-putPkt (UserAttributePkt us) = do- putWord8 (0xc0 .|. 17)- let bs = runPut $ mapM_ put us- putLengthThenPayload bs-putPkt (SymEncIntegrityProtectedDataPkt (SEIPD1 pv b)) = do- putWord8 (0xc0 .|. 18)- putPacketLength . fromIntegral $ BL.length b + 1- putWord8 pv -- should be 1- putLazyByteString b-putPkt- ( SymEncIntegrityProtectedDataPkt- (SEIPD2 symalgo aeadalgo chunkSize salt b)- ) = do- when (B.length (unSalt salt) /= 32) $- error "SEIPD v2 salt must be exactly 32 octets"- when (chunkSize > 16) $- error "SEIPD v2 chunk size octet must be between 0 and 16"- case symalgo of- OtherSA _ -> error "SEIPD v2 requires a known symmetric algorithm"- Plaintext -> error "SEIPD v2 cannot use plaintext cipher"- _ -> return ()- case aeadalgo of- OtherAEADAlgo _ -> error "SEIPD v2 requires a known AEAD algorithm"- _ -> return ()- putWord8 (0xc0 .|. 18)- putPacketLength . fromIntegral $ BL.length b + 36- putWord8 2- putWord8 (fromFVal symalgo)- putWord8 (fromFVal aeadalgo)- putWord8 chunkSize- putByteString (unSalt salt)- putLazyByteString b-putPkt (ModificationDetectionCodePkt hash) = do- putWord8 (0xc0 .|. 19)- putLengthThenPayload hash-putPkt (PaddingPkt padding) = do- putWord8 (0xc0 .|. 21)- putLengthThenPayload padding-putPkt (OtherPacketPkt t payload) = do- when (t > 63) $- error- ("cannot serialize OtherPacket packet tag > 63: " ++ show t)- putWord8 (0xc0 .|. t)- putLengthThenPayload payload-putPkt (BrokenPacketPkt _ t payload) = putPkt (OtherPacketPkt t payload)--{- | Validate a packet before serialization to catch constraint violations early.-Returns Left with descriptive error if validation fails.--}-validatePkt :: Pkt -> Either String ()-validatePkt- ( PKESKPkt- (PKESKPayloadV6Packet (PKESKPayloadV6 recipientKeyIdentifier _ _))- ) = do- let keyIdentifierLen = BL.length recipientKeyIdentifier- when (keyIdentifierLen > 255) $- Left- "PKESK v6 recipient key identifier must fit in one octet (max 255 bytes)"- Right ()-validatePkt- ( OnePassSignaturePkt- (OPSPayloadV6Packet (OPSPayloadV6 _ ha _ salt signerFingerprint _))- ) = do- let saltBytes = unSignatureSalt salt- saltSize = BL.length saltBytes- expectedSaltSize <-- case v6SaltSizeForHashAlgorithm ha of- Nothing ->- Left $- "signature hash algorithm does not define a V6 salt size: "- ++ show ha- Just sz -> Right sz- when (fromIntegral saltSize /= expectedSaltSize) $- Left- ( "OPS v6 salt size mismatch for "- ++ show ha- ++ ": expected "- ++ show expectedSaltSize- ++ ", got "- ++ show saltSize- )- when (BL.length signerFingerprint /= 32) $- Left "OPS v6 signer fingerprint must be exactly 32 octets"- Right ()-validatePkt- ( SymEncIntegrityProtectedDataPkt- (SEIPD2 symalgo aeadalgo chunkSize salt _)- ) = do- when (B.length (unSalt salt) /= 32) $- Left "SEIPD v2 salt must be exactly 32 octets"- when (chunkSize > 16) $- Left "SEIPD v2 chunk size octet must be between 0 and 16"- case symalgo of- OtherSA _ -> Left "SEIPD v2 requires a known symmetric algorithm"- Plaintext -> Left "SEIPD v2 cannot use plaintext cipher"- _ -> Right ()- case aeadalgo of- OtherAEADAlgo _ -> Left "SEIPD v2 requires a known AEAD algorithm"- _ -> Right ()-validatePkt (OtherPacketPkt t _) = do- when (t > 63) $- Left ("cannot serialize OtherPacket packet tag > 63: " ++ show t)- Right ()-validatePkt _ = Right ()--{- | Serialize a packet with explicit validation and error handling.-Validates constraints before calling putPkt to ensure errors are caught early.--}-putPktEither :: Pkt -> Either String Put-putPktEither pkt = case validatePkt pkt of- Left err -> Left err- Right () -> Right (putPkt pkt)--putLengthThenPayload :: ByteString -> Put-putLengthThenPayload bs = do- let len = BL.length bs- if len < fromIntegral (0x100000000 :: Integer)- then do- putPacketLength (fromIntegral len)- putLazyByteString bs- else putPartialLengthPayload bs- where- maxPartialChunkSize :: Int64- maxPartialChunkSize = 1 `shiftL` (30 :: Int)- putPartialLengthPayload :: ByteString -> Put- putPartialLengthPayload payload- | BL.length payload > maxPartialChunkSize = do- let (chunk, rest) = BL.splitAt maxPartialChunkSize payload- putPartialLength 30- putLazyByteString chunk- putPartialLengthPayload rest- | otherwise = do- putPacketLength (fromIntegral (BL.length payload))- putLazyByteString payload--validateSEIPDv2Header- :: SymmetricAlgorithm- -> AEADAlgorithm- -> Word8- -> ByteString- -> Get ()-validateSEIPDv2Header symalgo aeadalgo chunkSize encrypted = do- when (chunkSize > 16) $- fail "SEIPD v2 chunk size octet must be between 0 and 16"- when (BL.null encrypted) $- fail- "SEIPD v2 payload is missing encrypted data and final authentication tag"- case symalgo of- OtherSA _ -> fail "SEIPD v2 requires a known symmetric algorithm"- Plaintext -> fail "SEIPD v2 cannot use plaintext cipher"- _ -> return ()- case aeadalgo of- OtherAEADAlgo _ -> fail "SEIPD v2 requires a known AEAD algorithm"- _ -> return ()--getMPI :: Get MPI-getMPI = do- mpilen <- getWord16be- bs <- getByteString (fromIntegral (mpilen + 7) `div` 8)- return $ MPI (os2ip bs)--getPubkey :: PubKeyAlgorithm -> Get PKey-getPubkey RSA = do- MPI n <- get- MPI e <- get- return $- RSAPubKey- ( RSA_PublicKey- (R.PublicKey (fromIntegral . B.length . i2osp $ n) n e)- )-getPubkey DeprecatedRSAEncryptOnly = getPubkey RSA-getPubkey DeprecatedRSASignOnly = getPubkey RSA-getPubkey DSA = do- MPI p <- get- MPI q <- get- MPI g <- get- MPI y <- get- return $- DSAPubKey (DSA_PublicKey (D.PublicKey (D.Params p g q) y))-getPubkey ElgamalEncryptOnly = getPubkey ForbiddenElgamal-getPubkey ForbiddenElgamal = do- MPI p <- get- MPI g <- get- MPI y <- get- return $ ElGamalPubKey p g y-getPubkey ECDSA = do- curvelength <- getWord8- when (curvelength == 0 || curvelength == 0xff) $- fail "invalid ECC curve OID length octet (reserved value)"- curveoid <- getByteString (fromIntegral curvelength)- MPI mpi <- getMPI- case curveoidBSToCurve curveoid of- Left e -> fail e- Right Curve25519 ->- EdDSAPubKey P.EdSigningCurve25519- <$> ( PrefixedNativeEPoint- <$> validatePrefixedNativePoint 32 "Curve25519Legacy" mpi- )- Right curve ->- case bs2Point (i2osp mpi) of- Left e -> fail e- Right point ->- return- . ECDSAPubKey- . ECDSA_PublicKey- . ECDSA.PublicKey (curve2Curve curve)- $ point-getPubkey ECDH = do- ed <- getPubkey ECDSA -- could be an ECDSA or an EdDSA- kdflen <- getWord8- when (kdflen == 0 || kdflen == 0xff) $- fail "invalid ECDH KDF field length octet (reserved value)"- when (kdflen /= 3) $- fail ("invalid ECDH KDF field length: " ++ show kdflen)- one <- getWord8- when (one /= 1) $- fail ("invalid ECDH KDF reserved octet: " ++ show one)- kdfHA <- get- kdfSA <- get- return $ ECDHPubKey ed kdfHA kdfSA-getPubkey EdDSA = do- curvelength <- getWord8- when (curvelength == 0 || curvelength == 0xff) $- fail "invalid EdDSA curve OID length octet (reserved value)"- curveoid <- getByteString (fromIntegral curvelength)- MPI mpi <- getMPI- case curveoidBSToEdSigningCurve curveoid of- Left e -> fail e- Right P.EdSigningCurve25519 ->- EdDSAPubKey P.EdSigningCurve25519- <$> ( PrefixedNativeEPoint- <$> validatePrefixedNativePoint 32 "Ed25519Legacy" mpi- )- Right P.EdSigningCurve448 ->- EdDSAPubKey P.EdSigningCurve448- <$> ( PrefixedNativeEPoint- <$> validatePrefixedNativePoint 57 "Ed448Legacy" mpi- )-getPubkey pka- | pka == BTypes.Ed25519 =- parseFixedLengthOrLegacyPubkey- 32- ( EdDSAPubKey P.EdSigningCurve25519- . NativeEPoint- . EPoint- . os2ip- . BL.toStrict- )- (getPubkey EdDSA)-getPubkey pka- | pka == BTypes.Ed448 =- parseFixedLengthOrLegacyPubkey- 57- ( EdDSAPubKey P.EdSigningCurve448- . NativeEPoint- . EPoint- . os2ip- . BL.toStrict- )- (getPubkey EdDSA)-getPubkey X25519 =- parseFixedLengthOrLegacyPubkey- 32- ( EdDSAPubKey P.EdSigningCurve25519- . NativeEPoint- . EPoint- . os2ip- . BL.toStrict- )- (getPubkey ECDH)-getPubkey X448 =- parseFixedLengthOrLegacyPubkey- 56- ( EdDSAPubKey P.EdSigningCurve448- . NativeEPoint- . EPoint- . os2ip- . BL.toStrict- )- (getPubkey ECDH)-getPubkey MLKEM768X25519 = MLKEMPubKey . BL.toStrict <$> getRemainingLazyByteString-getPubkey MLKEM1024X448 = MLKEMPubKey . BL.toStrict <$> getRemainingLazyByteString-getPubkey MLDSA65Ed25519 = MLDSAPubKey . BL.toStrict <$> getRemainingLazyByteString-getPubkey MLDSA87Ed448 = MLDSAPubKey . BL.toStrict <$> getRemainingLazyByteString-getPubkey SLHDSASHAKE128s = SLHDSAPubKey . BL.toStrict <$> getRemainingLazyByteString-getPubkey SLHDSASHAKE128f = SLHDSAPubKey . BL.toStrict <$> getRemainingLazyByteString-getPubkey SLHDSASHAKE256s = SLHDSAPubKey . BL.toStrict <$> getRemainingLazyByteString-getPubkey _ = UnknownPKey <$> getRemainingLazyByteString--parseFixedLengthOrLegacyPubkey- :: Int64 -> (BL.ByteString -> PKey) -> Get PKey -> Get PKey-parseFixedLengthOrLegacyPubkey expectedLen decodeFixed legacyParser = do- remaining <- lookAhead getRemainingLazyByteString- if BL.length remaining == expectedLen- then decodeFixed <$> getLazyByteString expectedLen- else legacyParser--getPubkeyV6 :: PubKeyAlgorithm -> Get PKey-getPubkeyV6 pka- | pka == BTypes.Ed25519 = do- len <- getWord32be- bs <- getByteString (fromIntegral len)- when (B.length bs /= 32) $- fail "invalid v6 Ed25519 public key length"- return $- EdDSAPubKey- P.EdSigningCurve25519- (NativeEPoint (EPoint (os2ip bs)))- | pka == BTypes.Ed448 = do- len <- getWord32be- bs <- getByteString (fromIntegral len)- when (B.length bs /= 57) $- fail "invalid v6 Ed448 public key length"- return $- EdDSAPubKey- P.EdSigningCurve448- (NativeEPoint (EPoint (os2ip bs)))- | pka == BTypes.X25519 = do- len <- getWord32be- bs <- getByteString (fromIntegral len)- when (B.length bs /= 32) $- fail "invalid v6 X25519 public key length"- return $- EdDSAPubKey- P.EdSigningCurve25519- (NativeEPoint (EPoint (os2ip bs)))- | pka == BTypes.X448 = do- len <- getWord32be- bs <- getByteString (fromIntegral len)- when (B.length bs /= 56) $- fail "invalid v6 X448 public key length"- return $- EdDSAPubKey- P.EdSigningCurve448- (NativeEPoint (EPoint (os2ip bs)))- | pka == MLKEM768X25519 = do- len <- getWord32be- bs <- getByteString (fromIntegral len)- return $ MLKEMPubKey bs- | pka == MLKEM1024X448 = do- len <- getWord32be- bs <- getByteString (fromIntegral len)- return $ MLKEMPubKey bs- | pka == MLDSA65Ed25519 = do- len <- getWord32be- bs <- getByteString (fromIntegral len)- return $ MLDSAPubKey bs- | pka == MLDSA87Ed448 = do- len <- getWord32be- bs <- getByteString (fromIntegral len)- return $ MLDSAPubKey bs- | pka == SLHDSASHAKE128s = do- len <- getWord32be- bs <- getByteString (fromIntegral len)- return $ SLHDSAPubKey bs- | pka == SLHDSASHAKE128f = do- len <- getWord32be- bs <- getByteString (fromIntegral len)- return $ SLHDSAPubKey bs- | pka == SLHDSASHAKE256s = do- len <- getWord32be- bs <- getByteString (fromIntegral len)- return $ SLHDSAPubKey bs- | otherwise = getPubkey pka--bs2Point :: B.ByteString -> Either String ECDSA.PublicPoint-bs2Point bs =- if B.null bs- then Left "empty EC point encoding"- else- let xy = B.drop 1 bs- l = B.length xy- in if B.head bs /= 0x04- then Left $ "unknown type of point: " ++ show (B.unpack bs)- else- if odd l- then- Left "malformed EC point encoding: odd coordinate payload length"- else- return- ( uncurry- ECCT.Point- ((os2ip *** os2ip) (B.splitAt (div l 2) xy))- )--putPubkey :: PKey -> Put-putPubkey (UnknownPKey bs) = putLazyByteString bs-putPubkey (MLKEMPubKey bs) = putLazyByteString (BL.fromStrict bs)-putPubkey (MLDSAPubKey bs) = putLazyByteString (BL.fromStrict bs)-putPubkey (SLHDSAPubKey bs) = putLazyByteString (BL.fromStrict bs)-putPubkey p@(ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) =- let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve)- in putCurveOID curveoidbs- >> mapM_ put (pubkeyToMPIs p)-putPubkey- p@( ECDHPubKey- (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)))- kha- ksa- ) =- let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve)- in putCurveOID curveoidbs- >> mapM_ put (pubkeyToMPIs p)- >> putECDHKDFParams kha ksa-putPubkey p@(ECDHPubKey (EdDSAPubKey curve (PrefixedNativeEPoint _)) kha ksa) =- let Right curveoidbs = curveToCurveoidBS (ed2ec curve)- in putCurveOID curveoidbs- >> mapM_ put (pubkeyToMPIs p)- >> putECDHKDFParams kha ksa- where- ed2ec P.EdSigningCurve25519 = Curve25519- ed2ec P.EdSigningCurve448 = Curve448-putPubkey p@(EdDSAPubKey curve (PrefixedNativeEPoint _)) =- let Right curveoidbs = edSigningCurveToCurveoidBS curve- in putCurveOID curveoidbs- >> mapM_ put (pubkeyToMPIs p)-putPubkey (ECDHPubKey (EdDSAPubKey curve (NativeEPoint _)) _ _) =- error- ( "legacy ECDH serialization requires a prefixed-native "- ++ show curve- ++ " point"- )-putPubkey (EdDSAPubKey curve (NativeEPoint _)) =- error- ( "legacy EdDSA serialization requires a prefixed-native "- ++ show curve- ++ " point"- )-putPubkey p = mapM_ put (pubkeyToMPIs p)--putPubkeyV6 :: PKey -> Put-putPubkeyV6 (EdDSAPubKey P.EdSigningCurve25519 (NativeEPoint (EPoint x))) = do- let bs = fixedLengthOctets 32 x- putWord32be . fromIntegral . B.length $ bs- putByteString bs-putPubkeyV6 (EdDSAPubKey P.EdSigningCurve448 (NativeEPoint (EPoint x))) = do- let bs = fixedLengthOctets 57 x- putWord32be . fromIntegral . B.length $ bs- putByteString bs-putPubkeyV6- ( ECDHPubKey- (EdDSAPubKey P.EdSigningCurve25519 (NativeEPoint (EPoint x)))- kha- ksa- ) = do- let bs = fixedLengthOctets 32 x- putWord32be . fromIntegral . B.length $ bs- putByteString bs- put kha- put ksa-putPubkeyV6- ( ECDHPubKey- (EdDSAPubKey P.EdSigningCurve448 (NativeEPoint (EPoint x)))- kha- ksa- ) = do- let bs = fixedLengthOctets 56 x- putWord32be . fromIntegral . B.length $ bs- putByteString bs- put kha- put ksa-putPubkeyV6 (MLKEMPubKey bs) = do- putWord32be . fromIntegral . B.length $ bs- putByteString bs-putPubkeyV6 (MLDSAPubKey bs) = do- putWord32be . fromIntegral . B.length $ bs- putByteString bs-putPubkeyV6 (SLHDSAPubKey bs) = do- putWord32be . fromIntegral . B.length $ bs- putByteString bs-putPubkeyV6 p = putPubkey p--fixedLengthOctets :: Int -> Integer -> B.ByteString-fixedLengthOctets targetLen x =- let bs = i2osp x- in if B.length bs > targetLen- then- error- ( "public key element does not fit in "- ++ show targetLen- ++ " octets"- )- else B.replicate (targetLen - B.length bs) 0 <> bs--validatePrefixedNativePoint- :: Int -> String -> Integer -> Get EPoint-validatePrefixedNativePoint targetLen label i =- let bs = i2osp i- in if B.length bs /= targetLen + 1- then- fail- ( "invalid "- ++ label- ++ " public key length: expected "- ++ show (targetLen + 1)- ++ " octets with 0x40 prefix, got "- ++ show (B.length bs)- )- else- if B.head bs /= 0x40- then- fail ("invalid " ++ label ++ " public key: missing 0x40 prefix")- else pure (EPoint i)--putCurveOID :: B.ByteString -> Put-putCurveOID oid = do- let oidLength = B.length oid- when (oidLength == 0 || oidLength == 0xff) $- error "curve OID length cannot use reserved values 0 or 255"- putWord8 (fromIntegral oidLength)- putByteString oid--putECDHKDFParams :: HashAlgorithm -> SymmetricAlgorithm -> Put-putECDHKDFParams kdfHA kdfSA = do- let kdfLengthOctet = 0x03- when (kdfLengthOctet == 0 || kdfLengthOctet == 0xff) $- error "ECDH KDF field length cannot use reserved values 0 or 255"- putWord8 kdfLengthOctet- putWord8 0x01- put kdfHA- put kdfSA--parseOPSNestedFlag :: Word8 -> Get NestedFlag-parseOPSNestedFlag 0 = pure True-parseOPSNestedFlag 1 = pure False-parseOPSNestedFlag other =- fail ("invalid OPS nested flag octet: " ++ show other)--getSecretKey :: SomePKPayload -> Get SKey-getSecretKey pkp- | _pkalgo pkp- `elem` [RSA, DeprecatedRSAEncryptOnly, DeprecatedRSASignOnly] = do- MPI d <- get- MPI p <- get- MPI q <- get- MPI _ <- get -- u- case inverse q p of- Nothing -> fail "invalid RSA secret key: q has no inverse modulo p"- Just qinv -> do- let dP = d `mod` (p - 1)- dQ = d `mod` (q - 1)- pub = (\(RSAPubKey (RSA_PublicKey x)) -> x) (_pubkey pkp)- return $- RSAPrivateKey- (RSA_PrivateKey (R.PrivateKey pub d p q dP dQ qinv))- | _pkalgo pkp == DSA = do- MPI x <- get- return $- DSAPrivateKey (DSA_PrivateKey (D.PrivateKey (D.Params 0 0 0) x))- | _pkalgo pkp `elem` [ElgamalEncryptOnly, ForbiddenElgamal] = do- MPI x <- get- return $ ElGamalPrivateKey x- | _pkalgo pkp == ECDSA = do- let pubcurve =- (\(ECDSAPubKey (ECDSA_PublicKey p)) -> ECDSA.public_curve p)- (_pubkey pkp)- getECDSAScalarPrivateKey pubcurve- | _pkalgo pkp == ECDH =- do- pubcurve <- ecdhPrivateCurveFromPKPayload pkp- getECDHScalarPrivateKey pubcurve- | _pkalgo pkp == X25519 = do- if _keyVersion pkp == V6- then do- sk <- getByteString 32- return $ X25519PrivateKey sk- else do- pubcurve <- ecdhPrivateCurveFromPKPayload pkp- getECDHScalarPrivateKey pubcurve- | _pkalgo pkp == X448 = do- if _keyVersion pkp == V6- then do- sk <- getByteString 56- return $ X448PrivateKey sk- else UnknownSKey <$> getRemainingLazyByteString- | _pkalgo pkp == EdDSA = do- if _keyVersion pkp == V6- then do- case _pubkey pkp of- EdDSAPubKey P.EdSigningCurve25519 _ -> EdDSAPrivateKey P.EdSigningCurve25519 <$> getByteString 32- EdDSAPubKey P.EdSigningCurve448 _ -> EdDSAPrivateKey P.EdSigningCurve448 <$> getByteString 57- _ -> UnknownSKey <$> getRemainingLazyByteString- else do- MPI x <- get- case _pubkey pkp of- EdDSAPubKey P.EdSigningCurve25519 _ ->- return $- EdDSAPrivateKey P.EdSigningCurve25519 (leftPadTo 32 (i2osp x))- EdDSAPubKey P.EdSigningCurve448 _ ->- return $- EdDSAPrivateKey P.EdSigningCurve448 (leftPadTo 57 (i2osp x))- _ -> return $ UnknownSKey (BL.fromStrict (i2osp x))- | _pkalgo pkp `elem` [MLKEM768X25519, MLKEM1024X448] = do- if _keyVersion pkp == V6- then do- len <- getWord32be- bs <- getByteString (fromIntegral len)- return $ MLKEMPrivateKey bs- else UnknownSKey <$> getRemainingLazyByteString- | _pkalgo pkp `elem` [MLDSA65Ed25519, MLDSA87Ed448] = do- if _keyVersion pkp == V6- then do- len <- getWord32be- bs <- getByteString (fromIntegral len)- return $ MLDSAPrivateKey bs- else UnknownSKey <$> getRemainingLazyByteString- | _pkalgo pkp- `elem` [SLHDSASHAKE128s, SLHDSASHAKE128f, SLHDSASHAKE256s] = do- if _keyVersion pkp == V6- then do- len <- getWord32be- bs <- getByteString (fromIntegral len)- return $ SLHDSAPrivateKey bs- else UnknownSKey <$> getRemainingLazyByteString- | otherwise = UnknownSKey <$> getRemainingLazyByteString--getECDSAScalarPrivateKey :: ECCT.Curve -> Get SKey-getECDSAScalarPrivateKey curve = do- MPI pn <- get- pure $- ECDSAPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey curve pn))--getECDHScalarPrivateKey :: ECCT.Curve -> Get SKey-getECDHScalarPrivateKey curve = do- MPI pn <- get- pure $- ECDHPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey curve pn))--ecdhPrivateCurveFromPKPayload :: SomePKPayload -> Get ECCT.Curve-ecdhPrivateCurveFromPKPayload pkp =- case _pubkey pkp of- ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey p)) _ _ ->- pure (ECDSA.public_curve p)- ECDHPubKey (EdDSAPubKey P.EdSigningCurve25519 _) _ _ ->- pure (curve2Curve Curve25519)- ECDHPubKey (EdDSAPubKey P.EdSigningCurve448 _) _ _ ->- pure (curve2Curve Curve448)- other ->- fail- ( "ECDH/X25519 secret key requires an ECDH public key packet, got "- ++ show other- )--putSKey :: SKey -> Either String Put-putSKey (RSAPrivateKey (RSA_PrivateKey (R.PrivateKey _ d p q _ _ _))) =- case inverse q p of- Just u ->- Right (put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u))- Nothing ->- Left- "putSKey: invalid RSA key — q has no multiplicative inverse mod p (key is mathematically broken)"-putSKey (DSAPrivateKey (DSA_PrivateKey (D.PrivateKey _ x))) =- Right (put (MPI x))-putSKey (ElGamalPrivateKey x) =- Right (put (MPI x))-putSKey (ECDHPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey _ d))) =- Right (put (MPI d))-putSKey (ECDSAPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey _ d))) =- Right (put (MPI d))-putSKey (EdDSAPrivateKey P.EdSigningCurve25519 sk) = Right (putByteString sk)-putSKey (EdDSAPrivateKey P.EdSigningCurve448 sk) = Right (putByteString sk)-putSKey (X25519PrivateKey sk) = Right (putByteString sk)-putSKey (X448PrivateKey sk) = Right (putByteString sk)-putSKey (MLKEMPrivateKey sk) = Right (putLazyByteString (BL.fromStrict sk))-putSKey (MLDSAPrivateKey sk) = Right (putLazyByteString (BL.fromStrict sk))-putSKey (SLHDSAPrivateKey sk) = Right (putLazyByteString (BL.fromStrict sk))-putSKey (UnknownSKey bs) = Right (putLazyByteString bs)--putSKeyForPKPayload :: SomePKPayload -> SKey -> Either String Put-putSKeyForPKPayload pkp sk@(EdDSAPrivateKey _ bs)- | _keyVersion pkp == V6 = putSKey sk- | otherwise = Right (put (MPI (os2ip bs)))-putSKeyForPKPayload _ sk = putSKey sk--putMPI :: MPI -> Put-putMPI (MPI i) = do- let bs = i2osp i- putWord16be . fromIntegral . numBits $ i- putByteString bs--data PKPayloadReadCase where- PKPayloadReadCaseV3- :: V3Expiration -> PubKeyAlgorithm -> PKPayloadReadCase- PKPayloadReadCaseV4 :: PubKeyAlgorithm -> PKPayloadReadCase- PKPayloadReadCaseV6 :: PubKeyAlgorithm -> PKPayloadReadCase--pkPayloadReadCase :: Word8 -> Get PKPayloadReadCase-pkPayloadReadCase version =- case version of- 2 -> do- v3e <- getWord16be- pka <- get- pure (PKPayloadReadCaseV3 v3e pka)- 3 -> do- v3e <- getWord16be- pka <- get- pure (PKPayloadReadCaseV3 v3e pka)- 4 -> PKPayloadReadCaseV4 <$> get- 6 -> PKPayloadReadCaseV6 <$> get- _ -> fail ("unsupported key packet version " ++ show version)--getPKPayload :: Get SomePKPayload-getPKPayload = do- version <- getWord8- ctime <- fmap ThirtyTwoBitTimeStamp getWord32be- readCase <- pkPayloadReadCase version- case readCase of- PKPayloadReadCaseV3 v3e pka -> do- pk <- getPubkey pka- pure $! PKPayload DeprecatedV3 ctime v3e pka pk- PKPayloadReadCaseV4 pka -> do- pk <- getPubkey pka- pure $! PKPayload V4 ctime 0 pka pk- PKPayloadReadCaseV6 pka -> do- pk <- getPubkeyV6 pka- pure $! PKPayload V6 ctime 0 pka pk--data PKPayloadWriteCase where- PKPayloadWriteCaseV3- :: PKPayload 'DeprecatedV3 -> PKPayloadWriteCase- PKPayloadWriteCaseV4 :: PKPayload 'V4 -> PKPayloadWriteCase- PKPayloadWriteCaseV6 :: PKPayload 'V6 -> PKPayloadWriteCase--pkPayloadWriteCase :: SomePKPayload -> PKPayloadWriteCase-pkPayloadWriteCase (SomePKPayload pkp) =- case pkp of- PKPayloadV3 {} -> PKPayloadWriteCaseV3 pkp- PKPayloadV4 {} -> PKPayloadWriteCaseV4 pkp- PKPayloadV6 {} -> PKPayloadWriteCaseV6 pkp--putPKPayload :: SomePKPayload -> Put-putPKPayload pkpSome =- case pkPayloadWriteCase pkpSome of- PKPayloadWriteCaseV3 (PKPayloadV3 ctime v3e pka pk) -> do- putWord8 3- putWord32be . unThirtyTwoBitTimeStamp $ ctime- putWord16be v3e- put pka- putPubkey pk- PKPayloadWriteCaseV4 (PKPayloadV4 ctime pka pk) -> do- putWord8 4- putWord32be . unThirtyTwoBitTimeStamp $ ctime- put pka- putPubkeyV4ForAlgorithm pka pk- PKPayloadWriteCaseV6 (PKPayloadV6 ctime pka pk) -> do- putWord8 6- putWord32be . unThirtyTwoBitTimeStamp $ ctime- put pka- putPubkeyV6 pk--putPubkeyV4ForAlgorithm :: PubKeyAlgorithm -> PKey -> Put-putPubkeyV4ForAlgorithm pka pk- | pka == BTypes.Ed25519 =- putPubkeyV4Fixed 32 P.EdSigningCurve25519 pk- | pka == BTypes.Ed448 =- putPubkeyV4Fixed 57 P.EdSigningCurve448 pk- | pka == BTypes.X25519 =- putPubkeyV4Fixed 32 P.EdSigningCurve25519 pk- | pka == BTypes.X448 = putPubkeyV4Fixed 56 P.EdSigningCurve448 pk- | otherwise = putPubkey pk--putPubkeyV4Fixed :: Int -> P.EdSigningCurve -> PKey -> Put-putPubkeyV4Fixed targetLen expectedCurve (EdDSAPubKey curve (NativeEPoint (EPoint x)))- | curve == expectedCurve =- putByteString (fixedLengthOctets targetLen x)-putPubkeyV4Fixed _ _ pk = putPubkey pk--getSKAddendum :: SomePKPayload -> Get SKAddendum-getSKAddendum (SomePKPayload pkp) =- toSKAddendum <$> getSKAddendumTyped pkp--getSKAddendumTyped :: PKPayload v -> Get (SKAddendumV v)-getSKAddendumTyped pkp = do- s2kusage <- getWord8- let pkpSome = SomePKPayload pkp- getLegacyS2KProtected constructor = do- symencWord <- getWord8- s2k <- getS2K- let symenc = toFVal symencWord- case s2k of- OtherS2K _ _ -> return $ constructor symenc s2k mempty BL.empty- _ -> do- blockSize <- either fail pure (symEncBlockSize symenc)- iv <- IV <$> getByteString blockSize- encryptedblock <- getRemainingLazyByteString- return $ constructor symenc s2k iv encryptedblock- case s2kusage of- 0 ->- case pkp of- PKPayloadV6 {} -> do- sk <- getSecretKey pkpSome- return (SKAUnencryptedV6 sk)- PKPayloadV3 {} -> do- rest <- lookAhead getRemainingLazyByteString- secretLen <-- case runGetOrFail- ( do- start <- bytesRead- _ <- getSecretKey pkpSome- end <- bytesRead- pure (end - start)- )- rest of- Left (_, _, err) -> fail err- Right (_, _, len) -> pure len- sk <- getSecretKey pkpSome- checksum <- getWord16be- let expectedChecksum =- checksum16Bytes (BL.toStrict (BL.take secretLen rest))- when (checksum /= expectedChecksum) $- fail- ( "legacy unencrypted secret-key checksum mismatch: expected "- ++ show expectedChecksum- ++ ", got "- ++ show checksum- )- return (SKAUnencryptedLegacy sk checksum)- PKPayloadV4 {} -> do- rest <- lookAhead getRemainingLazyByteString- secretLen <-- case runGetOrFail- ( do- start <- bytesRead- _ <- getSecretKey pkpSome- end <- bytesRead- pure (end - start)- )- rest of- Left (_, _, err) -> fail err- Right (_, _, len) -> pure len- sk <- getSecretKey pkpSome- checksum <- getWord16be- let expectedChecksum =- checksum16Bytes (BL.toStrict (BL.take secretLen rest))- when (checksum /= expectedChecksum) $- fail- ( "legacy unencrypted secret-key checksum mismatch: expected "- ++ show expectedChecksum- ++ ", got "- ++ show checksum- )- return (SKAUnencryptedLegacy sk checksum)- 255 ->- case pkp of- PKPayloadV6 {} ->- fail "v6 secret key packets MUST NOT use s2k usage 255"- PKPayloadV3 {} ->- getLegacyS2KProtected SKA16bit- PKPayloadV4 {} ->- getLegacyS2KProtected SKA16bit- 254 ->- case pkp of- PKPayloadV6 {} -> do- paramsLen <- getWord8- params <- getLazyByteString (fromIntegral paramsLen)- (symenc, s2k, iv) <-- case runGetOrFail getV6CFBParams params of- Left (_, _, err) -> fail err- Right (rest, _, parsed)- | not (BL.null rest) ->- fail "unexpected trailing v6 CFB parameters"- | otherwise -> pure parsed- encryptedblock <- getRemainingLazyByteString- return (SKASHA1V6 symenc s2k (IV iv) encryptedblock)- PKPayloadV3 {} ->- getLegacyS2KProtected SKASHA1Legacy- PKPayloadV4 {} ->- getLegacyS2KProtected SKASHA1Legacy- where- getV6CFBParams = do- symencWord <- getWord8- s2kLen <- getWord8- s2kBytes <- getLazyByteString (fromIntegral s2kLen)- s2k <-- case runGetOrFail getS2K s2kBytes of- Left (_, _, err) -> fail err- Right (rest, _, parsed)- | not (BL.null rest) ->- fail "unexpected trailing bytes in v6 S2K specifier"- | otherwise -> pure parsed- iv <- getRemainingLazyByteString- let symenc = toFVal symencWord- blockSize <- either fail pure (symEncBlockSize symenc)- when (BL.length iv /= fromIntegral blockSize) $- fail "invalid v6 CFB IV length"- pure (symenc, s2k, BL.toStrict iv)- 253 ->- case pkp of- PKPayloadV6 {} -> do- paramsLen <- getWord8- params <- getLazyByteString (fromIntegral paramsLen)- (symenc, aead, s2k, iv) <-- case runGetOrFail getV6AEADParams params of- Left (_, _, err) -> fail err- Right (rest, _, parsed)- | not (BL.null rest) ->- fail "unexpected trailing v6 AEAD parameters"- | otherwise -> pure parsed- encryptedblock <- getRemainingLazyByteString- return (SKAAEADV6 symenc aead s2k (IV iv) encryptedblock)- PKPayloadV3 {} -> do- (symenc, aead, s2k, iv) <- getLegacyAEADParams- encryptedblock <- getRemainingLazyByteString- return (SKAAEADLegacy symenc aead s2k (IV iv) encryptedblock)- PKPayloadV4 {} -> do- (symenc, aead, s2k, iv) <- getLegacyAEADParams- encryptedblock <- getRemainingLazyByteString- return (SKAAEADLegacy symenc aead s2k (IV iv) encryptedblock)- where- getV6AEADParams- :: Get (SymmetricAlgorithm, AEADAlgorithm, S2K, B.ByteString)- getV6AEADParams = do- symencWord <- getWord8- aeadWord <- getWord8- s2kLen <- getWord8- s2kBytes <- getLazyByteString (fromIntegral s2kLen)- s2k <-- case runGetOrFail getS2K s2kBytes of- Left (_, _, err) -> fail err- Right (rest, _, parsed)- | not (BL.null rest) ->- fail "unexpected trailing bytes in v6 S2K specifier"- | otherwise -> pure parsed- iv <- getRemainingLazyByteString- let symenc = toFVal symencWord- aead = toFVal aeadWord- when (BL.length iv /= fromIntegral (aeadNonceSize aead)) $- fail "invalid v6 AEAD IV length"- pure (symenc, aead, s2k, BL.toStrict iv)- -- v3/v4: no cumulative-params-length octet, no S2K-size octet- getLegacyAEADParams- :: Get (SymmetricAlgorithm, AEADAlgorithm, S2K, B.ByteString)- getLegacyAEADParams = do- symencWord <- getWord8- aeadWord <- getWord8- s2k <- getS2K- let aead = toFVal aeadWord- iv <-- BL.toStrict- <$> getLazyByteString (fromIntegral (aeadNonceSize aead))- pure (toFVal symencWord, aead, s2k, iv)- symenc ->- case pkp of- PKPayloadV6 {} -> do- paramsLen <- getWord8- iv <- getByteString (fromIntegral paramsLen)- let symencAlg = toFVal symenc- blockSize <- either fail pure (symEncBlockSize symencAlg)- when (B.length iv /= blockSize) $- fail "invalid v6 CFB IV length"- encryptedblock <- getRemainingLazyByteString- return (SKASymV6 symencAlg (IV iv) encryptedblock)- PKPayloadV3 {} -> do- blockSize <- either fail pure (symEncBlockSize (toFVal symenc))- iv <- getByteString blockSize- encryptedblock <- getRemainingLazyByteString- return (SKASymLegacy (toFVal symenc) (IV iv) encryptedblock)- PKPayloadV4 {} -> do- blockSize <- either fail pure (symEncBlockSize (toFVal symenc))- iv <- getByteString blockSize- encryptedblock <- getRemainingLazyByteString- return (SKASymLegacy (toFVal symenc) (IV iv) encryptedblock)--putSKAddendum :: SKAddendum -> Either String Put-putSKAddendum (SUS16bit symenc s2k iv encryptedblock) =- Right $ do- putWord8 255- put symenc- put s2k- putByteString (unIV iv)- putLazyByteString encryptedblock-putSKAddendum (SUSSHA1 symenc s2k iv encryptedblock) =- Right $ do- putWord8 254- put symenc- put s2k- putByteString (unIV iv)- putLazyByteString encryptedblock-putSKAddendum (SUSAEAD symenc aead s2k iv encryptedblock) =- Right $ do- putWord8 253- put symenc- putWord8 (fromFVal aead)- put s2k- putByteString (unIV iv)- putLazyByteString encryptedblock-putSKAddendum (SUSym symenc iv encryptedblock) =- Right $ do- put symenc- putByteString (unIV iv)- putLazyByteString encryptedblock-putSKAddendum (SUUnencrypted sk checksum) =- do- putSecret <- putSKey sk- Right $ do- putWord8 0- let skb = runPut putSecret- putLazyByteString skb- putWord16be- ( if checksum == 0- then checksum16Bytes (BL.toStrict skb)- else checksum- )--checksum16Bytes :: B.ByteString -> Word16-checksum16Bytes =- B.foldl'- ( \a b ->- fromIntegral- ((fromIntegral a + fromIntegral b) `mod` (65536 :: Integer))- )- 0--putSKAddendumForPKPayload :: SomePKPayload -> SKAddendum -> Put-putSKAddendumForPKPayload pkp ska =- case fromSKAddendumForPKPayload pkp ska of- Left e -> error e- Right (SomeSKAddendumV skaV) ->- putSKAddendumForPKPayloadTyped pkp skaV--putSKAddendumForPKPayloadTyped- :: SomePKPayload- -> SKAddendumV v- -> Put-putSKAddendumForPKPayloadTyped pkp (SKAUnencryptedLegacy sk checksum) = do- putWord8 0- let putSecret =- case putSKeyForPKPayload pkp sk of- Left err -> error err- Right p -> p- skb = runPut putSecret- putLazyByteString skb- putWord16be- ( if checksum == 0- then- BL.foldl- (\a b -> mod (a + fromIntegral b) 0xffff)- (0 :: Word16)- skb- else checksum- )-putSKAddendumForPKPayloadTyped pkp (SKAUnencryptedV6 sk) = do- putWord8 0- let putSecret =- case putSKeyForPKPayload pkp sk of- Left err -> error err- Right p -> p- skb = runPut putSecret- putLazyByteString skb+import Control.Monad.Loops (iterateUntilM)+import Crypto.Number.Basic (numBits)+import Crypto.Number.ModArithmetic (inverse)+import Crypto.Number.Serialize (i2osp, os2ip)+import qualified Crypto.PubKey.DSA as D+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA+import qualified Crypto.PubKey.ECC.Types as ECCT+import qualified Crypto.PubKey.RSA as R+import Data.Bifunctor (bimap)+import Data.Binary (Binary, get, put)+import Data.Binary.Get+ ( ByteOffset+ , Get+ , bytesRead+ , getByteString+ , getLazyByteString+ , getRemainingLazyByteString+ , getWord16be+ , getWord16le+ , getWord32be+ , getWord8+ , lookAhead+ , runGetOrFail+ )+import Data.Binary.Put+ ( Put+ , putByteString+ , putLazyByteString+ , putWord16be+ , putWord16le+ , putWord32be+ , putWord8+ , runPut+ )+import Data.Bits (shiftL, shiftR, testBit, (.&.), (.|.))+import qualified Data.ByteString as B+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BLC8+import Data.Conduit (ConduitT, await, yield)+import qualified Data.Foldable as F+import Data.Int (Int64)+import Data.List (mapAccumL)+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as M+import Data.Maybe (fromMaybe)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8With, encodeUtf8)+import Data.Text.Encoding.Error (lenientDecode)+import Data.Word (Word16, Word32, Word8)+import Network.URI (nullURI, parseURI, uriToString)++import Codec.Encryption.OpenPGP.Internal+ ( curve2Curve+ , curveFromCurve+ , curveToCurveoidBS+ , curveoidBSToCurve+ , curveoidBSToEdSigningCurve+ , edSigningCurveToCurveoidBS+ , leftPadTo+ , pubkeyToMPIs+ )+import Codec.Encryption.OpenPGP.Policy+ ( signatureV6SaltSizeForHashAlgorithm+ )+import Codec.Encryption.OpenPGP.Types+import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as BTypes+import qualified Codec.Encryption.OpenPGP.Types.Internal.PKITypes as P++instance Binary SigSubPacket where+ get = getSigSubPacket+ put = putSigSubPacket++-- instance Binary (Set NotationFlag) where+-- put = putNotationFlagSet+instance Binary CompressionAlgorithm where+ get = toFVal <$> getWord8+ put = putWord8 . fromFVal++instance Binary PubKeyAlgorithm where+ get = toFVal <$> getWord8+ put = putWord8 . fromFVal++instance Binary HashAlgorithm where+ get = toFVal <$> getWord8+ put = putWord8 . fromFVal++instance Binary SymmetricAlgorithm where+ get = toFVal <$> getWord8+ put = putWord8 . fromFVal++instance Binary AEADAlgorithm where+ get = toFVal <$> getWord8+ put = putWord8 . fromFVal++instance Binary MPI where+ get = getMPI+ put = putMPI++instance Binary SigType where+ get = toFVal <$> getWord8+ put = putWord8 . fromFVal++instance Binary UserAttrSubPacket where+ get = getUserAttrSubPacket+ put = putUserAttrSubPacket++instance Binary S2K where+ get = getS2K+ put = putS2K++instance Binary (PKESK 'PKESKV3) where+ get = getPkt >>= either fail pure . fromPktEither+ put = putPkt . toPkt++instance Binary (PKESK 'PKESKV6) where+ get = getPkt >>= either fail pure . fromPktEither+ put = putPkt . toPkt++instance Binary Signature where+ get = getPkt >>= either fail pure . fromPktEither+ put = putPkt . toPkt++instance Binary (SKESK 'SKESKV4) where+ get = getPkt >>= either fail pure . fromPktEither+ put = putPkt . toPkt++instance Binary (SKESK 'SKESKV6) where+ get = getPkt >>= either fail pure . fromPktEither+ put = putPkt . toPkt++instance Binary (OnePassSignature 'OPSV3) where+ get = getPkt >>= either fail pure . fromPktEither+ put = putPkt . toPkt++instance Binary (OnePassSignature 'OPSV6) where+ get = getPkt >>= either fail pure . fromPktEither+ put = putPkt . toPkt++instance Binary SecretKey where+ get = getPkt >>= either fail pure . fromPktEither+ put = putPkt . toPkt++instance Binary PublicKey where+ get = getPkt >>= either fail pure . fromPktEither+ put = putPkt . toPkt++instance Binary SecretSubkey where+ get = getPkt >>= either fail pure . fromPktEither+ put = putPkt . toPkt++instance Binary CompressedData where+ get = getPkt >>= either fail pure . fromPktEither+ put = putPkt . toPkt++instance Binary SymEncData where+ get = getPkt >>= either fail pure . fromPktEither+ put = putPkt . toPkt++instance Binary Marker where+ get = getPkt >>= either fail pure . fromPktEither+ put = putPkt . toPkt++instance Binary LiteralData where+ get = getPkt >>= either fail pure . fromPktEither+ put = putPkt . toPkt++instance Binary Trust where+ get = getPkt >>= either fail pure . fromPktEither+ put = putPkt . toPkt++instance Binary UserId where+ get = getPkt >>= either fail pure . fromPktEither+ put = putPkt . toPkt++instance Binary PublicSubkey where+ get = getPkt >>= either fail pure . fromPktEither+ put = putPkt . toPkt++instance Binary UserAttribute where+ get = getPkt >>= either fail pure . fromPktEither+ put = putPkt . toPkt++instance Binary SymEncIntegrityProtectedData where+ get = getPkt >>= either fail pure . fromPktEither+ put = putPkt . toPkt++instance Binary ModificationDetectionCode where+ get = getPkt >>= either fail pure . fromPktEither+ put = putPkt . toPkt++instance Binary Padding where+ get = getPkt >>= either fail pure . fromPktEither+ put = putPkt . toPkt++instance Binary OtherPacket where+ get = getPkt >>= either fail pure . fromPktEither+ put = putPkt . toPkt++instance Binary Pkt where+ get = getPkt+ put = putPkt++instance (Binary a) => Binary (Block a) where+ get = Block `fmap` many get+ put = mapM_ put . unBlock++instance Binary SomePKPayload where+ get = getPKPayload+ put = putPKPayload++instance Binary SignaturePayload where+ get = getSignaturePayload+ put = putSignaturePayload++instance Binary TKUnknown where+ get = fail "Binary TKUnknown decode is not implemented"+ put = putTK++getSigSubPacket :: Get SigSubPacket+getSigSubPacket = do+ l <- fmap fromIntegral getSubPacketLength+ (crit, pt) <- getSigSubPacketType+ getSigSubPacket' pt crit l+ where+ getSigSubPacket' pt crit l+ | pt > 99 && pt < 111 = getUserDefinedSigSub pt crit l+ | otherwise =+ case M.lookup pt sigSubPacketParsers of+ Just parser -> parser pt crit l+ Nothing -> getOtherSigSub pt crit l++ getOtherSigSub pt crit l = do+ payload <- getLazyByteString (l - 1)+ return $ SigSubPacket crit (OtherSigSub pt payload)++type SigSubPacketParser =+ Word8 -> Bool -> ByteOffset -> Get SigSubPacket++sigSubPacketParsers :: M.Map Word8 SigSubPacketParser+sigSubPacketParsers =+ M.fromList+ [ (2, getSigCreationTime)+ , (3, getSigExpirationTime)+ , (4, getExportableCertification)+ , (5, getTrustSignature)+ , (6, getRegularExpression)+ , (7, getRevocable)+ , (9, getKeyExpirationTime)+ , (11, getPreferredSymmetricAlgorithms)+ , (12, getRevocationKey)+ , (16, getIssuer)+ , (20, getNotationData)+ , (21, getPreferredHashAlgorithms)+ , (22, getPreferredCompressionAlgorithms)+ , (23, getKeyServerPreferences)+ , (24, getPreferredKeyServer)+ , (25, getPrimaryUserId)+ , (26, getPolicyURL)+ , (27, getKeyFlags)+ , (28, getSignersUserId)+ , (29, getReasonForRevocation)+ , (30, getFeatures)+ , (31, getSignatureTarget)+ , (32, getEmbeddedSignature)+ , (33, getIssuerFingerprint)+ , (35, getIntendedRecipient)+ , (39, getPreferredAEADCiphersuites)+ ]++getSigCreationTime :: SigSubPacketParser+getSigCreationTime _pt crit _l =+ SigSubPacket crit . SigCreationTime+ <$> fmap ThirtyTwoBitTimeStamp getWord32be++getSigExpirationTime :: SigSubPacketParser+getSigExpirationTime _pt crit _l =+ SigSubPacket crit . SigExpirationTime+ <$> fmap ThirtyTwoBitDuration getWord32be++getExportableCertification :: SigSubPacketParser+getExportableCertification _pt crit _l = SigSubPacket crit . ExportableCertification <$> get++getTrustSignature :: SigSubPacketParser+getTrustSignature _pt crit _l = do+ tl <- getWord8+ ta <- getWord8+ return $ SigSubPacket crit (TrustSignature tl ta)++getRegularExpression :: SigSubPacketParser+getRegularExpression _pt crit l = do+ apdre <- getLazyByteString (l - 2)+ nul <- getWord8+ guard (nul == 0)+ return $ SigSubPacket crit (RegularExpression (BL.copy apdre))++getRevocable :: SigSubPacketParser+getRevocable _pt crit _l = SigSubPacket crit . Revocable <$> get++getKeyExpirationTime :: SigSubPacketParser+getKeyExpirationTime _pt crit _l =+ SigSubPacket crit . KeyExpirationTime+ <$> fmap ThirtyTwoBitDuration getWord32be++getPreferredSymmetricAlgorithms :: SigSubPacketParser+getPreferredSymmetricAlgorithms _pt crit l = do+ sa <- replicateM (fromIntegral (l - 1)) get+ return $ SigSubPacket crit (PreferredSymmetricAlgorithms sa)++getRevocationKey :: SigSubPacketParser+getRevocationKey _pt crit l = do+ rclass <- getWord8+ guard (testBit rclass 7)+ algid <- get+ fp <- getLazyByteString (fromIntegral l - 3)+ return $+ SigSubPacket+ crit+ ( RevocationKey+ (bsToFFSet . BL.singleton $ rclass .&. 0x7f)+ algid+ (Fingerprint fp)+ )++getIssuer :: SigSubPacketParser+getIssuer _pt crit l = do+ keyid <- getLazyByteString (l - 1)+ return $ SigSubPacket crit (Issuer (EightOctetKeyId keyid))++getNotationData :: SigSubPacketParser+getNotationData _pt crit l = do+ flags <- getLazyByteString 4+ nl <- getWord16be+ vl <- getWord16be+ nn <- getLazyByteString (fromIntegral nl)+ nv <- getLazyByteString (fromIntegral vl)+ return $+ SigSubPacket+ crit+ ( NotationData+ (bsToFFSet flags)+ (NotationName nn)+ (NotationValue nv)+ )++getPreferredHashAlgorithms :: SigSubPacketParser+getPreferredHashAlgorithms _pt crit l = do+ ha <- replicateM (fromIntegral (l - 1)) get+ return $ SigSubPacket crit (PreferredHashAlgorithms ha)++getPreferredCompressionAlgorithms :: SigSubPacketParser+getPreferredCompressionAlgorithms _pt crit l = do+ ca <- replicateM (fromIntegral (l - 1)) get+ return $ SigSubPacket crit (PreferredCompressionAlgorithms ca)++getKeyServerPreferences :: SigSubPacketParser+getKeyServerPreferences _pt crit l = do+ ksps <- getLazyByteString (l - 1)+ return $+ SigSubPacket crit (KeyServerPreferences (bsToFFSet ksps))++getPreferredKeyServer :: SigSubPacketParser+getPreferredKeyServer _pt crit l = do+ pks <- getLazyByteString (l - 1)+ return $ SigSubPacket crit (PreferredKeyServer pks)++getPrimaryUserId :: SigSubPacketParser+getPrimaryUserId _pt crit _l = do+ primacy <- get+ return $ SigSubPacket crit (PrimaryUserId primacy)++getPolicyURL :: SigSubPacketParser+getPolicyURL _pt crit l = do+ url <-+ fmap+ ( URL+ . fromMaybe nullURI+ . parseURI+ . T.unpack+ . decodeUtf8With lenientDecode+ )+ (getByteString (fromIntegral (l - 1)))+ return $ SigSubPacket crit (PolicyURL url)++getKeyFlags :: SigSubPacketParser+getKeyFlags _pt crit l = do+ kfs <- getLazyByteString (l - 1)+ return $ SigSubPacket crit (KeyFlags (bsToFFSet kfs))++getSignersUserId :: SigSubPacketParser+getSignersUserId _pt crit l = do+ uid <- getByteString (fromIntegral (l - 1))+ return $+ SigSubPacket+ crit+ (SignersUserId (decodeUtf8With lenientDecode uid))++getReasonForRevocation :: SigSubPacketParser+getReasonForRevocation _pt crit l = do+ rcode <- getWord8+ rreason <-+ fmap+ (decodeUtf8With lenientDecode)+ (getByteString (fromIntegral (l - 2)))+ return $+ SigSubPacket crit (ReasonForRevocation (toFVal rcode) rreason)++getFeatures :: SigSubPacketParser+getFeatures _pt crit l = do+ fbs <- getLazyByteString (l - 1)+ return $ SigSubPacket crit (Features (bsToFFSet fbs))++getSignatureTarget :: SigSubPacketParser+getSignatureTarget _pt crit l = do+ pka <- get+ ha <- get+ hash <- getLazyByteString (l - 3)+ return $ SigSubPacket crit (SignatureTarget pka ha hash)++getEmbeddedSignature :: SigSubPacketParser+getEmbeddedSignature _pt crit l = do+ spbs <- getLazyByteString (l - 1)+ case runGetOrFail get spbs of+ Left (_, _, e) -> fail ("embedded signature subpacket " ++ e)+ Right (_, _, sp) -> return $ SigSubPacket crit (EmbeddedSignature sp)++getIssuerFingerprint :: SigSubPacketParser+getIssuerFingerprint _pt crit l = do+ when (l /= 22 && l /= 34) $+ fail ("invalid issuer fingerprint subpacket length: " ++ show l)+ kv <- getWord8+ let fpLen = l - 2+ when (fpLen /= 20 && fpLen /= 32) $+ fail ("invalid issuer fingerprint length: " ++ show fpLen)+ case BTypes.packetVersionToIssuerFingerprintVersion kv of+ Nothing ->+ fail ("invalid issuer fingerprint version marker: " ++ show kv)+ Just ifVersion -> do+ fp <-+ case kv of+ 4 -> getLazyByteString (fromIntegral fpLen)+ 6 -> getLazyByteString (fromIntegral fpLen)+ _ ->+ fail ("invalid issuer fingerprint version marker: " ++ show kv)+ return $+ SigSubPacket crit (IssuerFingerprint ifVersion (Fingerprint fp))++getIntendedRecipient :: SigSubPacketParser+getIntendedRecipient _pt crit l = do+ kv <- getWord8+ fp <- getLazyByteString (l - 2)+ when (BL.length fp /= 20 && BL.length fp /= 32) $+ fail+ ( "invalid intended recipient fingerprint length: "+ ++ show (BL.length fp)+ )+ case BTypes.packetVersionToIssuerFingerprintVersion kv of+ Nothing ->+ fail+ ( "invalid intended recipient fingerprint version marker: "+ ++ show kv+ )+ Just ifVersion ->+ return $+ SigSubPacket crit (IntendedRecipient ifVersion (Fingerprint fp))++getPreferredAEADCiphersuites :: SigSubPacketParser+getPreferredAEADCiphersuites _pt crit l = do+ let payloadLen = fromIntegral (l - 1)+ when (payloadLen `mod` 2 /= 0) $+ fail "preferred AEAD ciphersuites subpacket length must be even"+ pairs <- replicateM (payloadLen `div` 2) $ do+ sa <- get+ aead <- get+ return (sa, aead)+ return $ SigSubPacket crit (PreferredAEADCiphersuites pairs)++getUserDefinedSigSub :: SigSubPacketParser+getUserDefinedSigSub pt crit l = do+ payload <- getLazyByteString (l - 1)+ return $ SigSubPacket crit (UserDefinedSigSub pt payload)++putSigSubPacket :: SigSubPacket -> Put+putSigSubPacket (SigSubPacket crit payload) = case payload of+ SigCreationTime et -> putSigCreationTime crit et+ SigExpirationTime et -> putSigExpirationTime crit et+ ExportableCertification e -> putExportableCertification crit e+ TrustSignature tl ta -> putTrustSignature crit tl ta+ RegularExpression apdre -> putRegularExpression crit apdre+ Revocable r -> putRevocable crit r+ KeyExpirationTime et -> putKeyExpirationTime crit et+ PreferredSymmetricAlgorithms ess -> putPreferredSymmetricAlgorithms crit ess+ RevocationKey rclass algid fp -> putRevocationKey crit rclass algid fp+ Issuer keyid -> putIssuer crit keyid+ NotationData nfs nn nv -> putNotationData crit nfs nn nv+ PreferredHashAlgorithms ehs -> putPreferredHashAlgorithms crit ehs+ PreferredCompressionAlgorithms ecs -> putPreferredCompressionAlgorithms crit ecs+ KeyServerPreferences ksps -> putKeyServerPreferences crit ksps+ PreferredKeyServer ks -> putPreferredKeyServer crit ks+ PrimaryUserId primacy -> putPrimaryUserId crit primacy+ PolicyURL url -> putPolicyURL crit url+ KeyFlags kfs -> putKeyFlags crit kfs+ SignersUserId userid -> putSignersUserId crit userid+ ReasonForRevocation rcode rreason -> putReasonForRevocation crit rcode rreason+ Features fs -> putFeatures crit fs+ SignatureTarget pka ha hash -> putSignatureTarget crit pka ha hash+ EmbeddedSignature sp -> putEmbeddedSignature crit sp+ IssuerFingerprint kv fp -> putIssuerFingerprint crit kv fp+ IntendedRecipient kv irf -> putIntendedRecipient crit kv irf+ PreferredAEADCiphersuites ps -> putPreferredAEADCiphersuites crit ps+ UserDefinedSigSub ptype payload -> putOtherSigSub crit ptype payload+ OtherSigSub ptype payload -> putOtherSigSub crit ptype payload++putSigCreationTime :: Bool -> ThirtyTwoBitTimeStamp -> Put+putSigCreationTime crit et = do+ putSubPacketLength 5+ putSigSubPacketType crit 2+ putWord32be . unThirtyTwoBitTimeStamp $ et++putSigExpirationTime :: Bool -> ThirtyTwoBitDuration -> Put+putSigExpirationTime crit et = do+ putSubPacketLength 5+ putSigSubPacketType crit 3+ putWord32be . unThirtyTwoBitDuration $ et++putExportableCertification :: Bool -> Bool -> Put+putExportableCertification crit e = do+ putSubPacketLength 2+ putSigSubPacketType crit 4+ put e++putTrustSignature :: Bool -> Word8 -> Word8 -> Put+putTrustSignature crit tl ta = do+ putSubPacketLength 3+ putSigSubPacketType crit 5+ put tl+ put ta++putRegularExpression :: Bool -> BL.ByteString -> Put+putRegularExpression crit apdre = do+ putSubPacketLength . fromIntegral $ (2 + BL.length apdre)+ putSigSubPacketType crit 6+ putLazyByteString apdre+ putWord8 0++putRevocable :: Bool -> Bool -> Put+putRevocable crit r = do+ putSubPacketLength 2+ putSigSubPacketType crit 7+ put r++putKeyExpirationTime :: Bool -> ThirtyTwoBitDuration -> Put+putKeyExpirationTime crit et = do+ putSubPacketLength 5+ putSigSubPacketType crit 9+ putWord32be . unThirtyTwoBitDuration $ et++putPreferredSymmetricAlgorithms+ :: Bool -> [SymmetricAlgorithm] -> Put+putPreferredSymmetricAlgorithms crit ess = do+ putSubPacketLength . fromIntegral $ (1 + length ess)+ putSigSubPacketType crit 11+ mapM_ put ess++putRevocationKey+ :: Bool+ -> Set RevocationClass+ -> PubKeyAlgorithm+ -> Fingerprint+ -> Put+putRevocationKey crit rclass algid fp = do+ let fpLen = BL.length (unFingerprint fp)+ putSubPacketLength (fromIntegral (3 + fpLen))+ putSigSubPacketType crit 12+ putLazyByteString . ffSetToFixedLengthBS (1 :: Int) $+ Set.insert (RClOther 0) rclass+ put algid+ putLazyByteString (unFingerprint fp)++putIssuer :: Bool -> EightOctetKeyId -> Put+putIssuer crit keyid = do+ putSubPacketLength 9+ putSigSubPacketType crit 16+ putLazyByteString (unEOKI keyid)++putNotationData+ :: Bool+ -> Set NotationFlag+ -> NotationName+ -> NotationValue+ -> Put+putNotationData crit nfs (NotationName nn) (NotationValue nv) = do+ putSubPacketLength . fromIntegral $+ (9 + BL.length nn + BL.length nv)+ putSigSubPacketType crit 20+ putLazyByteString . ffSetToFixedLengthBS (4 :: Int) $ nfs+ putWord16be . fromIntegral . BL.length $ nn+ putWord16be . fromIntegral . BL.length $ nv+ putLazyByteString nn+ putLazyByteString nv++putPreferredHashAlgorithms :: Bool -> [HashAlgorithm] -> Put+putPreferredHashAlgorithms crit ehs = do+ putSubPacketLength . fromIntegral $ (1 + length ehs)+ putSigSubPacketType crit 21+ mapM_ put ehs++putPreferredCompressionAlgorithms+ :: Bool -> [CompressionAlgorithm] -> Put+putPreferredCompressionAlgorithms crit ecs = do+ putSubPacketLength . fromIntegral $ (1 + length ecs)+ putSigSubPacketType crit 22+ mapM_ put ecs++putKeyServerPreferences :: Bool -> Set KSPFlag -> Put+putKeyServerPreferences crit ksps = do+ let kbs = ffSetToBS ksps+ putSubPacketLength . fromIntegral $ (1 + BL.length kbs)+ putSigSubPacketType crit 23+ putLazyByteString kbs++putPreferredKeyServer :: Bool -> BL.ByteString -> Put+putPreferredKeyServer crit ks = do+ putSubPacketLength . fromIntegral $ (1 + BL.length ks)+ putSigSubPacketType crit 24+ putLazyByteString ks++putPrimaryUserId :: Bool -> Bool -> Put+putPrimaryUserId crit primacy = do+ putSubPacketLength 2+ putSigSubPacketType crit 25+ put primacy++putPolicyURL :: Bool -> URL -> Put+putPolicyURL crit (URL uri) = do+ let bs = encodeUtf8 (T.pack (uriToString id uri ""))+ putSubPacketLength . fromIntegral $ (1 + B.length bs)+ putSigSubPacketType crit 26+ putByteString bs++putKeyFlags :: Bool -> Set KeyFlag -> Put+putKeyFlags crit kfs = do+ let kbs = ffSetToBS kfs+ putSubPacketLength . fromIntegral $ (1 + BL.length kbs)+ putSigSubPacketType crit 27+ putLazyByteString kbs++putSignersUserId :: Bool -> Text -> Put+putSignersUserId crit userid = do+ let bs = encodeUtf8 userid+ putSubPacketLength . fromIntegral $ (1 + B.length bs)+ putSigSubPacketType crit 28+ putByteString bs++putReasonForRevocation+ :: Bool -> RevocationCode -> RevocationReason -> Put+putReasonForRevocation crit rcode rreason = do+ let reasonbs = encodeUtf8 rreason+ putSubPacketLength . fromIntegral $ (2 + B.length reasonbs)+ putSigSubPacketType crit 29+ putWord8 . fromFVal $ rcode+ putByteString reasonbs++putFeatures :: Bool -> Set FeatureFlag -> Put+putFeatures crit fs = do+ let fbs = ffSetToBS fs+ putSubPacketLength . fromIntegral $ (1 + BL.length fbs)+ putSigSubPacketType crit 30+ putLazyByteString fbs++putSignatureTarget+ :: Bool -> PubKeyAlgorithm -> HashAlgorithm -> BL.ByteString -> Put+putSignatureTarget crit pka ha hash = do+ putSubPacketLength . fromIntegral $ (3 + BL.length hash)+ putSigSubPacketType crit 31+ put pka+ put ha+ putLazyByteString hash++putEmbeddedSignature :: Bool -> SignaturePayload -> Put+putEmbeddedSignature crit sp = do+ let spb = runPut (put sp)+ putSubPacketLength . fromIntegral $ (1 + BL.length spb)+ putSigSubPacketType crit 32+ putLazyByteString spb++putIssuerFingerprint+ :: Bool -> IssuerFingerprintVersion -> Fingerprint -> Put+putIssuerFingerprint crit kv fp = do+ let kv' = BTypes.issuerFingerprintVersionToPacketVersion kv+ let fpb = unFingerprint fp+ when (BL.length fpb /= 20 && BL.length fpb /= 32) $+ error+ ("invalid issuer fingerprint length: " ++ show (BL.length fpb))+ putSubPacketLength . fromIntegral $ (2 + BL.length fpb)+ putSigSubPacketType crit 33+ putWord8 kv'+ putLazyByteString fpb++putIntendedRecipient+ :: Bool -> IssuerFingerprintVersion -> Fingerprint -> Put+putIntendedRecipient crit kv irf = do+ let kv' = BTypes.issuerFingerprintVersionToPacketVersion kv+ let fpb = unFingerprint irf+ when (BL.length fpb /= 20 && BL.length fpb /= 32) $+ error+ ( "invalid intended-recipient fingerprint length: "+ ++ show (BL.length fpb)+ )+ putSubPacketLength . fromIntegral $ (2 + BL.length fpb)+ putSigSubPacketType crit 35+ putWord8 kv'+ putLazyByteString fpb++putPreferredAEADCiphersuites+ :: Bool -> [(SymmetricAlgorithm, AEADAlgorithm)] -> Put+putPreferredAEADCiphersuites crit ps = do+ putSubPacketLength . fromIntegral $ (1 + 2 * length ps)+ putSigSubPacketType crit 39+ mapM_ (\(sa, aead) -> put sa >> put aead) ps++putOtherSigSub :: Bool -> Word8 -> BL.ByteString -> Put+putOtherSigSub crit ptype payload = do+ putSubPacketLength . fromIntegral $ (1 + BL.length payload)+ putSigSubPacketType crit ptype+ putLazyByteString payload++getSubPacketLength :: Get Word32+getSubPacketLength = getSubPacketLength' =<< getWord8+ where+ getSubPacketLength' :: (Integral a) => Word8 -> Get a+ getSubPacketLength' f+ | f < 192 = return . fromIntegral $ f+ | f < 224 = do+ secondOctet <- getWord8+ return . fromIntegral $+ shiftL (fromIntegral (f - 192) :: Int) 8+ + (fromIntegral secondOctet :: Int)+ + 192+ | f == 255 = do+ len <- getWord32be+ return . fromIntegral $ len+ | otherwise = fail "Partial body length invalid."++putSubPacketLength :: Word32 -> Put+putSubPacketLength l+ | l < 192 = putWord8 (fromIntegral l)+ | l < 8384 =+ putWord8+ (fromIntegral ((fromIntegral (l - 192) `shiftR` 8) + 192 :: Int))+ >> putWord8 (fromIntegral (l - 192) .&. 0xff)+ | l <= 0xffffffff = putWord8 255 >> putWord32be (fromIntegral l)+ | otherwise = error ("too big (" ++ show l ++ ")")++getSigSubPacketType :: Get (Bool, Word8)+getSigSubPacketType = do+ x <- getWord8+ return+ ( if x .&. 128 == 128+ then (True, x .&. 127)+ else (False, x)+ )++putSigSubPacketType :: Bool -> Word8 -> Put+putSigSubPacketType False sst = putWord8 sst+putSigSubPacketType True sst = putWord8 (sst .|. 0x80)++bsToFFSet :: (FutureFlag a) => ByteString -> Set a+bsToFFSet bs =+ Set.fromAscList . concat . snd $+ mapAccumL+ (\acc y -> (acc + 8, concatMap (shifty acc y) [0 .. 7]))+ 0+ (BL.unpack bs)+ where+ shifty acc y x = [toFFlag (acc + x) | y .&. shiftR 128 x == shiftR 128 x]++ffSetToFixedLengthBS+ :: (FutureFlag b, Integral a) => a -> Set b -> ByteString+ffSetToFixedLengthBS len ffs =+ BL.take+ (fromIntegral len)+ (BL.append (ffSetToBS ffs) (BL.pack (replicate 5 0)))++ffSetToBS :: (FutureFlag a) => Set a -> ByteString+ffSetToBS = BL.pack . ffSetToBS'+ where+ ffSetToBS' :: (FutureFlag a) => Set a -> [Word8]+ ffSetToBS' ks+ -- Emit a single zero octet for an empty flag set so encoded flag+ -- subpackets always carry an explicit flags byte.+ | Set.null ks = [0]+ | otherwise =+ map+ ( ( foldl (.|.) 0+ . map (shiftR 128 . flip mod 8 . fromFFlag)+ . Set.toAscList+ )+ . (\x -> Set.filter (\y -> fromFFlag y `div` 8 == x) ks)+ )+ [0 .. fromFFlag (Set.findMax ks) `div` 8]++fromS2K :: S2K -> ByteString+fromS2K (Simple hashalgo) = BL.pack [0, fromIntegral . fromFVal $ hashalgo]+fromS2K (Salted hashalgo salt) =+ BL.pack [1, fromIntegral . fromFVal $ hashalgo]+ `BL.append` (BL.fromStrict . unSalt8) salt+fromS2K (IteratedSalted hashalgo salt count) =+ BL.pack [3, fromIntegral . fromFVal $ hashalgo]+ `BL.append` (BL.fromStrict . unSalt8) salt+ `BL.snoc` encodeIterationCount count+fromS2K (Argon2 salt t p encodedM) =+ BL.pack [4]+ `BL.append` (BL.fromStrict . unSalt16) salt+ `BL.append` BL.pack [t, p, encodedM]+fromS2K (OtherS2K _ bs) = bs++getPacketLength :: Get Integer+getPacketLength = do+ firstOctet <- getWord8+ lenOrPartial <- lengthOctetToLength firstOctet+ case lenOrPartial of+ Left _ ->+ fail "Partial body length is invalid in this context"+ Right len -> return len+ where+ lengthOctetToLength :: Word8 -> Get (Either Integer Integer)+ lengthOctetToLength f+ | f < 192 = return . Right . fromIntegral $ f+ | f < 224 = do+ secondOctet <- getWord8+ return . Right . fromIntegral $+ shiftL (fromIntegral (f - 192) :: Int) 8+ + (fromIntegral secondOctet :: Int)+ + 192+ | f < 255 =+ return . Left . fromIntegral $+ (1 :: Integer) `shiftL` fromIntegral (f .&. 0x1f)+ | otherwise = do+ len <- getWord32be+ return . Right . fromIntegral $ len++putPacketLength :: Integer -> Put+putPacketLength l+ | l < 192 = putWord8 (fromIntegral l)+ | l < 8384 =+ putWord8+ (fromIntegral ((fromIntegral (l - 192) `shiftR` 8) + 192 :: Int))+ >> putWord8 (fromIntegral (l - 192) .&. 0xff)+ | l < 0x100000000 = putWord8 255 >> putWord32be (fromIntegral l)+ | otherwise =+ error "packet length exceeds 32-bit definite length encoding"++putPartialLength :: Word8 -> Put+putPartialLength n = putWord8 (224 + n)++getPacketLengthFromOctet :: Word8 -> Get (Either Int64 Int64)+getPacketLengthFromOctet f+ | f < 192 = return . Right . fromIntegral $ f+ | f < 224 = do+ secondOctet <- getWord8+ return . Right . fromIntegral $+ shiftL (fromIntegral (f - 192) :: Int) 8+ + (fromIntegral secondOctet :: Int)+ + 192+ | f < 255 =+ return . Left . fromIntegral $+ (1 :: Integer) `shiftL` fromIntegral (f .&. 0x1f)+ | otherwise = do+ len <- getWord32be+ return . Right . fromIntegral $ len++getS2K :: Get S2K+getS2K = getS2K' =<< getWord8+ where+ getS2K' :: Word8 -> Get S2K+ getS2K' t+ | t == 0 = do+ ha <- getWord8+ return $ Simple (toFVal ha)+ | t == 1 = do+ ha <- getWord8+ salt <- getByteString 8+ return $ Salted (toFVal ha) (Salt8 salt)+ | t == 3 = do+ ha <- getWord8+ salt <- getByteString 8+ count <- getWord8+ return $+ IteratedSalted+ (toFVal ha)+ (Salt8 salt)+ (decodeIterationCount count)+ | t == 4 = do+ salt <- getByteString 16+ passes <- getWord8+ parallelism <- getWord8+ encodedM <- getWord8+ return $ Argon2 (Salt16 salt) passes parallelism encodedM+ | otherwise = do+ bs <- getRemainingLazyByteString+ return $ OtherS2K t bs++putS2K :: S2K -> Put+putS2K (Simple hashalgo) = error ("confused by simple" ++ show hashalgo)+putS2K (Salted hashalgo salt) =+ error+ ("confused by salted" ++ show hashalgo ++ " by " ++ show salt)+putS2K (IteratedSalted ha salt count) = do+ putWord8 3+ put ha+ putByteString (unSalt8 salt)+ putWord8 $ encodeIterationCount count+putS2K (Argon2 salt t p encodedM) = do+ putWord8 4+ putByteString (unSalt16 salt)+ putWord8 t+ putWord8 p+ putWord8 encodedM+putS2K (OtherS2K t bs) = putWord8 t >> putLazyByteString bs++v6SaltSizeForHashAlgorithm :: HashAlgorithm -> Maybe Word8+v6SaltSizeForHashAlgorithm = signatureV6SaltSizeForHashAlgorithm++getPacketTypeAndPayload :: Get (Word8, ByteString)+getPacketTypeAndPayload = do+ tag <- getWord8+ guard (testBit tag 7)+ case tag .&. 0x40 of+ 0x00 -> do+ let t = shiftR (tag .&. 0x3c) 2+ case tag .&. 0x03 of+ 0 -> do+ len <- getWord8+ bs <- getLazyByteString (fromIntegral len)+ return (t, bs)+ 1 -> do+ len <- getWord16be+ bs <- getLazyByteString (fromIntegral len)+ return (t, bs)+ 2 -> do+ len <- getWord32be+ bs <- getLazyByteString (fromIntegral len)+ return (t, bs)+ 3 -> do+ bs <- getRemainingLazyByteString+ return (t, bs)+ _ ->+ error "This should never happen (getPacketTypeAndPayload/0x00)."+ 0x40 -> do+ firstLenOctet <- getWord8+ bs <- getPacketPayloadFromLengthOctet firstLenOctet+ return (tag .&. 0x3f, bs)+ _ ->+ error "This should never happen (getPacketTypeAndPayload/???)."+ where+ getPacketPayloadFromLengthOctet :: Word8 -> Get ByteString+ getPacketPayloadFromLengthOctet lenOctet = do+ lenOrPartial <- getPacketLengthFromOctet lenOctet+ case lenOrPartial of+ Right len -> getLazyByteString len+ Left partialLen -> do+ chunk <- getLazyByteString partialLen+ rest <- getRemainingPartialPayload+ return (chunk <> rest)+ getRemainingPartialPayload :: Get ByteString+ getRemainingPartialPayload = do+ lenOctet <- getWord8+ lenOrPartial <- getPacketLengthFromOctet lenOctet+ case lenOrPartial of+ Right len -> getLazyByteString len+ Left partialLen -> do+ chunk <- getLazyByteString partialLen+ (chunk <>) <$> getRemainingPartialPayload++getPkt :: Get Pkt+getPkt = do+ (t, pl) <- getPacketTypeAndPayload+ case runGetOrFail (getPkt' t (BL.length pl)) pl of+ Left (_, _, e) -> return $! BrokenPacketPkt e t pl+ Right (_, _, p) -> return p+ where+ parseLegacyPKESK+ :: PacketVersion -> BL.ByteString -> Either String Pkt+ parseLegacyPKESK pv body = do+ (_, _, (eokeyid, pkaRaw, mpib)) <-+ bimap (\(_, _, e) -> e) id $+ runGetOrFail+ ( do+ eokeyid <- getLazyByteString 8+ pka <- getWord8+ mpib <- getRemainingLazyByteString+ pure (eokeyid, pka, mpib)+ )+ body+ let pka = toFVal pkaRaw+ sk <- parseLegacyPKESKMPIs pka mpib+ pure $+ PKESKPkt+ ( PKESKPayloadV3Packet+ (PKESKPayloadV3 pv (EightOctetKeyId eokeyid) pka sk)+ )++ parseLegacyPKESKMPIs+ :: PubKeyAlgorithm+ -> BL.ByteString+ -> Either String (NE.NonEmpty MPI)+ parseLegacyPKESKMPIs pka mpib = do+ case parseLegacyPKESKMPIsStrict pka mpib of+ Right sk -> pure sk+ Left strictErr+ | pka == X25519 ->+ case parseLegacyPKESKX25519V3Octets mpib of+ Right sk -> Right sk+ Left octetErr ->+ Left+ ( strictErr+ ++ "; also failed to parse RFC9580 X25519 v3 octet layout: "+ ++ octetErr+ )+ | pka == ECDH ->+ case parseLegacyPKESKECDHOctets mpib of+ Right sk -> Right sk+ Left octetErr ->+ Left+ ( strictErr+ ++ "; also failed to parse RFC6637 ECDH v3 octet layout: "+ ++ octetErr+ )+ | otherwise -> Left strictErr++ parseLegacyPKESKMPIsStrict+ :: PubKeyAlgorithm+ -> BL.ByteString+ -> Either String (NE.NonEmpty MPI)+ parseLegacyPKESKMPIsStrict pka mpib = do+ (rest, _, sk) <-+ bimap (\(_, _, e) -> e) id $+ runGetOrFail (parserForLegacyPKESKMPIs pka) mpib+ if BL.null rest+ then pure (NE.fromList sk)+ else+ Left+ ("unexpected trailing PKESK MPI data for algorithm " ++ show pka)++ parseLegacyPKESKX25519V3Octets+ :: BL.ByteString -> Either String (NE.NonEmpty MPI)+ parseLegacyPKESKX25519V3Octets mpib = do+ if BL.length mpib < 33+ then Left "X25519 v3 PKESK octet layout is too short"+ else Right ()+ let ephemeral = BL.toStrict (BL.take 32 mpib)+ eskLen = fromIntegral (BL.index mpib 32) :: Int+ eskWithAlgo = BL.toStrict (BL.drop 33 mpib)+ if eskLen /= B.length eskWithAlgo+ then+ Left "X25519 v3 PKESK octet layout has inconsistent ESK length"+ else Right ()+ if B.null eskWithAlgo+ then+ Left+ "X25519 v3 PKESK octet layout must include a symmetric algorithm octet"+ else Right ()+ let symAlgo = B.head eskWithAlgo+ if symAlgo+ `elem` [ fromIntegral (fromFVal AES128)+ , fromIntegral (fromFVal AES192)+ , fromIntegral (fromFVal AES256)+ ]+ then+ pure+ (NE.fromList [MPI (os2ip ephemeral), MPI (os2ip eskWithAlgo)])+ else+ Left+ ( "X25519 v3 PKESK octet layout has unsupported symmetric algorithm octet "+ ++ show symAlgo+ )++ -- \| Parse an RFC 6637 §8 ECDH PKESKv3 body as MPI(ephemeral) || 1-octet-count || C.+ -- This is the interoperable wire format produced by GnuPG and other RFC-compliant+ -- implementations. hOpenPGP previously wrote both fields as MPIs; this fallback+ -- allows reading RFC-compliant packets when the strict two-MPI path fails.+ parseLegacyPKESKECDHOctets+ :: BL.ByteString -> Either String (NE.NonEmpty MPI)+ parseLegacyPKESKECDHOctets mpib = do+ (rest, _, ephMPI) <-+ bimap (\(_, _, e) -> e) id $ runGetOrFail getMPI mpib+ let restBS = BL.toStrict rest+ when (B.null restBS) $+ Left+ "ECDH v3 PKESK RFC6637 octet layout: missing wrapped-key length octet after ephemeral MPI"+ let wrappedLen = fromIntegral (B.head restBS) :: Int+ wrapped = B.tail restBS+ when (wrappedLen /= B.length wrapped) $+ Left+ ( "ECDH v3 PKESK RFC6637 octet layout: wrapped key length field "+ ++ show wrappedLen+ ++ " does not match body length "+ ++ show (B.length wrapped)+ )+ when (wrappedLen < 24 || wrappedLen `mod` 8 /= 0) $+ Left+ ( "ECDH v3 PKESK RFC6637 octet layout: wrapped key length "+ ++ show wrappedLen+ ++ " is not a valid RFC 3394 wrapped key size"+ )+ pure (ephMPI NE.:| [MPI (os2ip wrapped)])++ parserForLegacyPKESKMPIs :: PubKeyAlgorithm -> Get [MPI]+ parserForLegacyPKESKMPIs pka =+ case expectedLegacyPKESKMPIArity pka of+ Just mpiCount -> replicateM mpiCount getMPI+ Nothing -> some getMPI++ expectedLegacyPKESKMPIArity :: PubKeyAlgorithm -> Maybe Int+ expectedLegacyPKESKMPIArity pka+ | pka `elem` [RSA, DeprecatedRSAEncryptOnly] = Just 1+ | pka `elem` [ElgamalEncryptOnly, ForbiddenElgamal, ECDH, X25519] =+ Just 2+ | otherwise = Nothing++ validateV4SKESKEncryptedSessionKeyS2K+ :: S2K -> Maybe BL.ByteString -> Get ()+ validateV4SKESKEncryptedSessionKeyS2K _ Nothing = pure ()+ validateV4SKESKEncryptedSessionKeyS2K Simple {} (Just _) =+ fail+ "v4 SKESK packets with encrypted session keys must not use Simple S2K"+ validateV4SKESKEncryptedSessionKeyS2K _ (Just _) = pure ()++ parseV6PKESK :: BL.ByteString -> Either String Pkt+ parseV6PKESK body = do+ (_, _, (recipientKeyIdentifier, pka, esk)) <-+ bimap (\(_, _, e) -> e) id $+ runGetOrFail+ ( do+ keyIdentifierLen <- getWord8+ recipientKeyIdentifier <-+ getLazyByteString (fromIntegral keyIdentifierLen)+ pka <- getWord8+ esk <- getRemainingLazyByteString+ pure (recipientKeyIdentifier, pka, esk)+ )+ body+ validateV6PKESKRecipientIdentifier recipientKeyIdentifier+ pure $+ PKESKPkt+ ( PKESKPayloadV6Packet+ (PKESKPayloadV6 recipientKeyIdentifier (toFVal pka) esk)+ )+ where+ validateV6PKESKRecipientIdentifier+ :: BL.ByteString -> Either String ()+ validateV6PKESKRecipientIdentifier rid =+ case BL.length rid of+ 0 -> Right ()+ 20 -> Right ()+ 32 -> Right ()+ 21 -> validateVersionedFingerprint rid+ 33 -> validateVersionedFingerprint rid+ ridLen ->+ Left+ ( "invalid PKESK v6 recipient identifier length: "+ ++ show ridLen+ ++ " (expected 0, 20, 21, 32, or 33)"+ )++ validateVersionedFingerprint :: BL.ByteString -> Either String ()+ validateVersionedFingerprint rid =+ let keyVersion = BL.head rid+ fingerprintLen = BL.length (BL.tail rid)+ in case keyVersion of+ 4 ->+ if fingerprintLen == 20+ then Right ()+ else+ Left+ ( "PKESK v6 recipient identifier length/version mismatch: key version 4 requires fingerprint length 20, got "+ ++ show fingerprintLen+ )+ 6 ->+ if fingerprintLen == 32+ then Right ()+ else+ Left+ ( "PKESK v6 recipient identifier length/version mismatch: key version 6 requires fingerprint length 32, got "+ ++ show fingerprintLen+ )+ _ ->+ Left+ ( "invalid PKESK v6 recipient key version: "+ ++ show keyVersion+ ++ " (expected 4 or 6)"+ )++ getPkt' :: Word8 -> ByteOffset -> Get Pkt+ getPkt' t len = case t of+ 1 -> getPKESK+ 2 -> SignaturePkt <$> get+ 3 -> getSKESK+ 4 -> getOPS+ 5 -> getSecretKey len+ 6 -> PublicKeyPkt <$> getPKPayload+ 7 -> getSecretSubkey len+ 8 -> getCompressedData len+ 9 -> SymEncDataPkt <$> getLazyByteString len+ 10 -> MarkerPkt <$> getLazyByteString len+ 11 -> getLiteralData len+ 12 -> TrustPkt <$> getLazyByteString len+ 13 ->+ UserIdPkt . decodeUtf8With lenientDecode+ <$> getByteString (fromIntegral len)+ 14 -> getPublicSubkey len+ 17 -> getPublicAttribute len+ 18 -> getSEIPD len+ 19 -> ModificationDetectionCodePkt <$> getLazyByteString 20+ 21 -> PaddingPkt <$> getLazyByteString len+ _ -> OtherPacketPkt t <$> getLazyByteString len++ getPKESK :: Get Pkt+ getPKESK = do+ pv <- getWord8+ body <- getRemainingLazyByteString+ if pv == 6+ then case parseV6PKESK body of+ Right pkt -> return pkt+ Left err -> fail err+ else case parseLegacyPKESK pv body of+ Right pkt -> return pkt+ Left err -> fail err++ getSKESK :: Get Pkt+ getSKESK = do+ pv <- getWord8+ if pv == 6+ then getSKESKV6+ else+ if pv == 4+ then getSKESKV4+ else fail ("unsupported SKESK packet version " ++ show pv)+ where+ getSKESKV6 = do+ let getV6SKESKParams = do+ symalgoWord <- getWord8+ aeadWord <- getWord8+ s2kLen <- getWord8+ s2kBytes <- getLazyByteString (fromIntegral s2kLen)+ s2k <-+ case runGetOrFail getS2K s2kBytes of+ Left (_, _, err) -> fail err+ Right (rest, _, parsed)+ | not (BL.null rest) ->+ fail "unexpected trailing bytes in v6 SKESK S2K specifier"+ | otherwise -> pure parsed+ let symalgo = toFVal symalgoWord+ aead = toFVal aeadWord+ ivLen = fromIntegral (aeadNonceSize aead)+ iv <- getLazyByteString ivLen+ pure (symalgo, aead, s2k, iv)+ paramsLen <- getWord8+ params <- getLazyByteString (fromIntegral paramsLen)+ (symalgo, aead, s2k, iv) <-+ case runGetOrFail getV6SKESKParams params of+ Left (_, _, err) -> fail err+ Right (rest, _, parsed)+ | not (BL.null rest) ->+ fail "unexpected trailing v6 SKESK parameters"+ | otherwise -> pure parsed+ payload <- getRemainingLazyByteString+ when (BL.length payload < 16) $+ fail+ "v6 SKESK payload must include encrypted session key and authentication tag"+ let (esk, tag) = BL.splitAt (BL.length payload - 16) payload+ return $+ SKESKPkt+ ( SKESKPayloadV6Packet+ ( SKESKPayloadV6+ symalgo+ aead+ s2k+ iv+ esk+ tag+ )+ )+ getSKESKV4 = do+ symalgo <- getWord8+ s2k <- getS2K+ esk <- getRemainingLazyByteString+ let mesk = if BL.null esk then Nothing else Just esk+ validateV4SKESKEncryptedSessionKeyS2K s2k mesk+ return $+ SKESKPkt+ ( SKESKPayloadV4Packet+ ( SKESKPayloadV4+ (toFVal symalgo)+ s2k+ mesk+ )+ )++ getOPS :: Get Pkt+ getOPS = do+ pv <- getWord8+ sigtype <- toFVal <$> getWord8+ ha <- toFVal <$> getWord8+ pka <- toFVal <$> getWord8+ case pv of+ 3 -> getOPSV3 pv sigtype ha pka+ 6 -> getOPSV6 pv sigtype ha pka+ _ -> fail ("Unsupported OPS version: " ++ show pv)+ where+ getOPSV3+ :: PacketVersion+ -> SigType+ -> HashAlgorithm+ -> PubKeyAlgorithm+ -> Get Pkt+ getOPSV3 pv sigtype ha pka = do+ skeyid <- getLazyByteString 8+ nested <- getWord8 >>= parseOPSNestedFlag+ return $+ OnePassSignaturePkt+ ( OPSPayloadV3Packet+ ( OPSPayloadV3+ pv+ sigtype+ ha+ pka+ (EightOctetKeyId skeyid)+ nested+ )+ )+ getOPSV6+ :: PacketVersion+ -> SigType+ -> HashAlgorithm+ -> PubKeyAlgorithm+ -> Get Pkt+ getOPSV6 pv sigtype ha pka = do+ saltSize <- getWord8+ expectedSaltSize <-+ maybe+ ( fail+ ( "signature hash algorithm does not define a V6 salt size: "+ ++ show ha+ )+ )+ pure+ (v6SaltSizeForHashAlgorithm ha)+ when (saltSize /= expectedSaltSize) $+ fail+ ( "OPS v6 salt size mismatch for "+ ++ show ha+ ++ ": expected "+ ++ show expectedSaltSize+ ++ ", got "+ ++ show saltSize+ )+ salt <-+ SignatureSalt <$> getLazyByteString (fromIntegral saltSize)+ signerFingerprint <- getLazyByteString 32+ nested <- getWord8 >>= parseOPSNestedFlag+ return $+ OnePassSignaturePkt+ ( OPSPayloadV6Packet+ ( OPSPayloadV6+ sigtype+ ha+ pka+ salt+ signerFingerprint+ nested+ )+ )++ getSecretKey :: ByteOffset -> Get Pkt+ getSecretKey len = do+ bs <- getLazyByteString len+ case runGetOrFail getSecretKeyParser bs of+ Left (_, _, err) -> fail ("secret key " ++ err)+ Right (_, _, pkt) -> return pkt+ where+ getSecretKeyParser = do+ pkp <- getPKPayload+ ska <- getSKAddendum pkp+ return $ SecretKeyPkt pkp ska++ getSecretSubkey :: ByteOffset -> Get Pkt+ getSecretSubkey len = do+ bs <- getLazyByteString len+ case runGetOrFail getSecretSubkeyParser bs of+ Left (_, _, err) -> fail ("secret subkey " ++ err)+ Right (_, _, pkt) -> return pkt+ where+ getSecretSubkeyParser = do+ pkp <- getPKPayload+ ska <- getSKAddendum pkp+ return $ SecretSubkeyPkt pkp ska++ getCompressedData :: ByteOffset -> Get Pkt+ getCompressedData len = do+ ca <- getWord8+ cdata <- getLazyByteString (len - 1)+ return $ CompressedDataPkt (toFVal ca) cdata++ getLiteralData :: ByteOffset -> Get Pkt+ getLiteralData len = do+ dt <- getWord8+ flen <- getWord8+ fn <- getLazyByteString (fromIntegral flen)+ ts <- fmap ThirtyTwoBitTimeStamp getWord32be+ ldata <- getLazyByteString (len - (6 + fromIntegral flen))+ return $ LiteralDataPkt (toFVal dt) fn ts ldata++ getPublicSubkey :: ByteOffset -> Get Pkt+ getPublicSubkey len = do+ bs <- getLazyByteString len+ case runGetOrFail getPublicSubkeyParser bs of+ Left (_, _, err) -> fail ("public subkey " ++ err)+ Right (_, _, pkt) -> return pkt+ where+ getPublicSubkeyParser = do+ pkp <- getPKPayload+ return $ PublicSubkeyPkt pkp++ getPublicAttribute :: ByteOffset -> Get Pkt+ getPublicAttribute len = do+ bs <- getLazyByteString len+ case runGetOrFail (many getUserAttrSubPacket) bs of+ Left (_, _, err) -> fail ("user attribute " ++ err)+ Right (_, _, uas) -> return $ UserAttributePkt uas++ getSEIPD :: ByteOffset -> Get Pkt+ getSEIPD len = do+ pv <- getWord8+ case pv of+ 1 -> do+ b <- getLazyByteString (len - 1)+ return $ SymEncIntegrityProtectedDataPkt (SEIPD1 pv b)+ 2 -> do+ when (len < 36) $+ fail "SEIPD v2 packet too short"+ symalgo <- toFVal <$> getWord8+ aeadalgo <- toFVal <$> getWord8+ chunkSize <- getWord8+ salt <- Salt <$> getByteString 32+ encrypted <- getLazyByteString (len - 36)+ validateSEIPDv2Header symalgo aeadalgo chunkSize encrypted+ return $+ SymEncIntegrityProtectedDataPkt+ ( SEIPD2+ symalgo+ aeadalgo+ chunkSize+ salt+ encrypted+ )+ _ -> fail ("Unsupported SEIPD version: " ++ show pv)++getUserAttrSubPacket :: Get UserAttrSubPacket+getUserAttrSubPacket = do+ l <- fmap fromIntegral getSubPacketLength+ t <- getWord8+ getUserAttrSubPacket' t l+ where+ getUserAttrSubPacket'+ :: Word8 -> ByteOffset -> Get UserAttrSubPacket+ getUserAttrSubPacket' t l+ | t == 1 = do+ _ <- getWord16le -- ihlen+ hver <- getWord8 -- should be 1+ iformat <- getWord8+ nuls <- getLazyByteString 12 -- should be NULs+ bs <- getLazyByteString (l - 17)+ if hver /= 1 || nuls /= BL.pack (replicate 12 0)+ then fail "Corrupt UAt subpacket"+ else return $ ImageAttribute (ImageHV1 (toFVal iformat)) bs+ | otherwise = do+ bs <- getLazyByteString (l - 1)+ return $ OtherUASub t bs++putUserAttrSubPacket :: UserAttrSubPacket -> Put+putUserAttrSubPacket ua = do+ let sp = runPut $ putUserAttrSubPacket' ua+ putSubPacketLength . fromIntegral . BL.length $ sp+ putLazyByteString sp+ where+ putUserAttrSubPacket' (ImageAttribute (ImageHV1 iformat) idata) = do+ putWord8 1+ putWord16le 16+ putWord8 1+ putWord8 (fromFVal iformat)+ replicateM_ 12 $ putWord8 0+ putLazyByteString idata+ putUserAttrSubPacket' (OtherUASub t bs) = do+ putWord8 t+ putLazyByteString bs++{- | Serialize PKESKv3 session-key material.+For ECDH and X25519 the RFC 6637 §8 / RFC 9580 §5.1.6 wire format is used:+MPI(ephemeral_key) || 1-octet-count || wrapped_session_key_bytes.+All other algorithms use the standard MPI sequence.+-}+putPKESKv3SessionKeyMaterial+ :: PubKeyAlgorithm -> NE.NonEmpty MPI -> Put+putPKESKv3SessionKeyMaterial pka mpis+ | pka `elem` [ECDH, X25519]+ , (ephMPI NE.:| [wrappedMPI]) <- mpis = do+ put ephMPI+ let rawWrapped = i2osp (unMPI wrappedMPI)+ -- Left-pad to the nearest valid RFC 3394 wrapped-key length so that+ -- leading-zero bytes stripped by i2osp are restored.+ targetLen =+ headDef+ (B.length rawWrapped)+ (filter (>= B.length rawWrapped) [32, 40, 48])+ paddedWrapped = leftPadTo targetLen rawWrapped+ putWord8 (fromIntegral (B.length paddedWrapped))+ putByteString paddedWrapped+ | otherwise = F.mapM_ put mpis+ where+ headDef d [] = d+ headDef _ (x : _) = x++putPkt :: Pkt -> Put+putPkt pkt = case pkt of+ PKESKPkt (PKESKPayloadV3Packet payload) -> putPKESKV3 payload+ PKESKPkt (PKESKPayloadV6Packet payload) -> putPKESKV6 payload+ SignaturePkt sp -> putSignature sp+ SKESKPkt (SKESKPayloadV4Packet payload) -> putSKESKV4 payload+ SKESKPkt (SKESKPayloadV6Packet payload) -> putSKESKV6 payload+ OnePassSignaturePkt (OPSPayloadV3Packet payload) -> putOPSV3 payload+ OnePassSignaturePkt (OPSPayloadV6Packet payload) -> putOPSV6 payload+ SecretKeyPkt pkp ska -> putSecretKey pkp ska+ PublicKeyPkt pkp -> putPublicKey pkp+ SecretSubkeyPkt pkp ska -> putSecretSubkey pkp ska+ CompressedDataPkt ca cdata -> putCompressedData ca cdata+ SymEncDataPkt b -> putSymEncData b+ MarkerPkt b -> putMarker b+ LiteralDataPkt dt fn ts b -> putLiteralData dt fn ts b+ TrustPkt b -> putTrust b+ UserIdPkt u -> putUserId u+ PublicSubkeyPkt pkp -> putPublicSubkey pkp+ UserAttributePkt us -> putUserAttribute us+ SymEncIntegrityProtectedDataPkt (SEIPD1 pv b) -> putSEIPDV1 pv b+ SymEncIntegrityProtectedDataPkt+ (SEIPD2 symalgo aeadalgo chunkSize salt b) -> putSEIPDV2 symalgo aeadalgo chunkSize salt b+ ModificationDetectionCodePkt hash -> putModificationDetectionCode hash+ PaddingPkt padding -> putPadding padding+ OtherPacketPkt t payload -> putOtherPacket t payload+ BrokenPacketPkt _ t payload -> putOtherPacket t payload++putPKESKV3 :: PKESKPayloadV3 -> Put+putPKESKV3 (PKESKPayloadV3 _pv eokeyid pka mpis) = do+ putWord8 (0xc0 .|. 1)+ let bsk = runPut $ putPKESKv3SessionKeyMaterial pka mpis+ putPacketLength . fromIntegral $ 10 + BL.length bsk+ putWord8 3+ putLazyByteString (unEOKI eokeyid)+ putWord8 $ fromIntegral . fromFVal $ pka+ putLazyByteString bsk++putPKESKV6 :: PKESKPayloadV6 -> Put+putPKESKV6 (PKESKPayloadV6 recipientKeyIdentifier pka esk) = do+ putWord8 (0xc0 .|. 1)+ let keyIdentifierLen = BL.length recipientKeyIdentifier+ when (keyIdentifierLen > 255) $+ error "PKESK v6 recipient key identifier must fit in one octet"+ putPacketLength . fromIntegral $+ 3 + keyIdentifierLen + BL.length esk+ putWord8 6+ putWord8 (fromIntegral keyIdentifierLen)+ putLazyByteString recipientKeyIdentifier+ putWord8 $ fromIntegral . fromFVal $ pka+ putLazyByteString esk++putSignature :: SignaturePayload -> Put+putSignature sp = do+ putWord8 (0xc0 .|. 2)+ let bs = runPut $ put sp+ putLengthThenPayload bs++putSKESKV4 :: SKESKPayloadV4 -> Put+putSKESKV4 (SKESKPayloadV4 symalgo s2k mesk) = do+ putWord8 (0xc0 .|. 3)+ let bs2k = fromS2K s2k+ let bsk = fromMaybe BL.empty mesk+ putPacketLength . fromIntegral $+ 2 + BL.length bs2k + BL.length bsk+ putWord8 4+ putWord8 $ fromIntegral . fromFVal $ symalgo+ putLazyByteString bs2k+ putLazyByteString bsk++putSKESKV6 :: SKESKPayloadV6 -> Put+putSKESKV6 (SKESKPayloadV6 symalgo aead s2k iv esk tag) = do+ putWord8 (0xc0 .|. 3)+ let bs2k = fromS2K s2k+ let params =+ BL.pack+ [ fromIntegral (fromFVal symalgo)+ , fromIntegral (fromFVal aead)+ , fromIntegral (BL.length bs2k)+ ]+ <> bs2k+ <> iv+ putPacketLength . fromIntegral $+ 2 + BL.length params + BL.length esk + BL.length tag+ putWord8 6+ putWord8 (fromIntegral (BL.length params))+ putLazyByteString params+ putLazyByteString esk+ putLazyByteString tag++putOPSV3 :: OPSPayloadV3 -> Put+putOPSV3 (OPSPayloadV3 pv sigtype ha pka skeyid nested) = do+ putWord8 (0xc0 .|. 4)+ let bs =+ runPut $ do+ putWord8 pv+ putWord8 $ fromIntegral . fromFVal $ sigtype+ putWord8 $ fromIntegral . fromFVal $ ha+ putWord8 $ fromIntegral . fromFVal $ pka+ putLazyByteString (unEOKI skeyid)+ putWord8 . fromIntegral . fromEnum $ not nested+ putLengthThenPayload bs++putOPSV6 :: OPSPayloadV6 -> Put+putOPSV6 (OPSPayloadV6 sigtype ha pka salt signerFingerprint nested) = do+ putWord8 (0xc0 .|. 4)+ let saltBytes = unSignatureSalt salt+ saltSize = BL.length saltBytes+ expectedSaltSize =+ maybe+ ( error+ ( "signature hash algorithm does not define a V6 salt size: "+ ++ show ha+ )+ )+ id+ (v6SaltSizeForHashAlgorithm ha)+ when (fromIntegral saltSize /= expectedSaltSize) $+ error+ ( "OPS v6 salt size mismatch for "+ ++ show ha+ ++ ": expected "+ ++ show expectedSaltSize+ ++ ", got "+ ++ show saltSize+ )+ when (BL.length signerFingerprint /= 32) $+ error "OPS v6 signer fingerprint must be exactly 32 octets"+ let bs =+ runPut $ do+ putWord8 6+ putWord8 $ fromIntegral . fromFVal $ sigtype+ putWord8 $ fromIntegral . fromFVal $ ha+ putWord8 $ fromIntegral . fromFVal $ pka+ putWord8 (fromIntegral saltSize)+ putLazyByteString saltBytes+ putLazyByteString signerFingerprint+ putWord8 . fromIntegral . fromEnum $ not nested+ putLengthThenPayload bs++putSecretKey :: SomePKPayload -> SKAddendum -> Put+putSecretKey pkp ska = do+ putWord8 (0xc0 .|. 5)+ let bs = runPut (putPKPayload pkp >> putSKAddendumForPKPayload pkp ska)+ putLengthThenPayload bs++putPublicKey :: SomePKPayload -> Put+putPublicKey pkp = do+ putWord8 (0xc0 .|. 6)+ let bs = runPut $ putPKPayload pkp+ putLengthThenPayload bs++putSecretSubkey :: SomePKPayload -> SKAddendum -> Put+putSecretSubkey pkp ska = do+ putWord8 (0xc0 .|. 7)+ let bs = runPut (putPKPayload pkp >> putSKAddendumForPKPayload pkp ska)+ putLengthThenPayload bs++putCompressedData :: CompressionAlgorithm -> BL.ByteString -> Put+putCompressedData ca cdata = do+ putWord8 (0xc0 .|. 8)+ let bs =+ runPut $ do+ putWord8 $ fromIntegral . fromFVal $ ca+ putLazyByteString cdata+ putLengthThenPayload bs++putSymEncData :: BL.ByteString -> Put+putSymEncData b = do+ putWord8 (0xc0 .|. 9)+ putLengthThenPayload b++putMarker :: BL.ByteString -> Put+putMarker b = do+ putWord8 (0xc0 .|. 10)+ putLengthThenPayload b++putLiteralData+ :: LiteralDataType+ -> FileName+ -> ThirtyTwoBitTimeStamp+ -> BL.ByteString+ -> Put+putLiteralData dt fn ts b = do+ putWord8 (0xc0 .|. 11)+ let bs =+ runPut $ do+ putWord8 $ fromIntegral . fromFVal $ dt+ putWord8 $ fromIntegral . BL.length $ fn+ putLazyByteString fn+ putWord32be . unThirtyTwoBitTimeStamp $ ts+ putLazyByteString b+ putLengthThenPayload bs++putTrust :: BL.ByteString -> Put+putTrust b = do+ putWord8 (0xc0 .|. 12)+ putLengthThenPayload b++putUserId :: Text -> Put+putUserId u = do+ putWord8 (0xc0 .|. 13)+ let bs = encodeUtf8 u+ putPacketLength . fromIntegral $ B.length bs+ putByteString bs++putPublicSubkey :: SomePKPayload -> Put+putPublicSubkey pkp = do+ putWord8 (0xc0 .|. 14)+ let bs = runPut $ putPKPayload pkp+ putLengthThenPayload bs++putUserAttribute :: [UserAttrSubPacket] -> Put+putUserAttribute us = do+ putWord8 (0xc0 .|. 17)+ let bs = runPut $ mapM_ put us+ putLengthThenPayload bs++putSEIPDV1 :: Word8 -> BL.ByteString -> Put+putSEIPDV1 pv b = do+ putWord8 (0xc0 .|. 18)+ putPacketLength . fromIntegral $ BL.length b + 1+ putWord8 pv+ putLazyByteString b++putSEIPDV2+ :: SymmetricAlgorithm+ -> AEADAlgorithm+ -> Word8+ -> Salt+ -> BL.ByteString+ -> Put+putSEIPDV2 symalgo aeadalgo chunkSize salt b = do+ when (B.length (unSalt salt) /= 32) $+ error "SEIPD v2 salt must be exactly 32 octets"+ when (chunkSize > 16) $+ error "SEIPD v2 chunk size octet must be between 0 and 16"+ case symalgo of+ OtherSA _ -> error "SEIPD v2 requires a known symmetric algorithm"+ Plaintext -> error "SEIPD v2 cannot use plaintext cipher"+ _ -> return ()+ case aeadalgo of+ OtherAEADAlgo _ -> error "SEIPD v2 requires a known AEAD algorithm"+ _ -> return ()+ putWord8 (0xc0 .|. 18)+ putPacketLength . fromIntegral $ BL.length b + 36+ putWord8 2+ putWord8 (fromFVal symalgo)+ putWord8 (fromFVal aeadalgo)+ putWord8 chunkSize+ putByteString (unSalt salt)+ putLazyByteString b++putModificationDetectionCode :: BL.ByteString -> Put+putModificationDetectionCode hash = do+ putWord8 (0xc0 .|. 19)+ putLengthThenPayload hash++putPadding :: BL.ByteString -> Put+putPadding padding = do+ putWord8 (0xc0 .|. 21)+ putLengthThenPayload padding++putOtherPacket :: Word8 -> BL.ByteString -> Put+putOtherPacket t payload = do+ when (t > 63) $+ error+ ("cannot serialize OtherPacket packet tag > 63: " ++ show t)+ putWord8 (0xc0 .|. t)+ putLengthThenPayload payload++{- | Validate a packet before serialization to catch constraint violations early.+Returns Left with descriptive error if validation fails.+-}+validatePkt :: Pkt -> Either String ()+validatePkt+ ( PKESKPkt+ (PKESKPayloadV6Packet (PKESKPayloadV6 recipientKeyIdentifier _ _))+ ) = do+ let keyIdentifierLen = BL.length recipientKeyIdentifier+ when (keyIdentifierLen > 255) $+ Left+ "PKESK v6 recipient key identifier must fit in one octet (max 255 bytes)"+ Right ()+validatePkt+ ( OnePassSignaturePkt+ (OPSPayloadV6Packet (OPSPayloadV6 _ ha _ salt signerFingerprint _))+ ) = do+ let saltBytes = unSignatureSalt salt+ saltSize = BL.length saltBytes+ expectedSaltSize <-+ case v6SaltSizeForHashAlgorithm ha of+ Nothing ->+ Left $+ "signature hash algorithm does not define a V6 salt size: "+ ++ show ha+ Just sz -> Right sz+ when (fromIntegral saltSize /= expectedSaltSize) $+ Left+ ( "OPS v6 salt size mismatch for "+ ++ show ha+ ++ ": expected "+ ++ show expectedSaltSize+ ++ ", got "+ ++ show saltSize+ )+ when (BL.length signerFingerprint /= 32) $+ Left "OPS v6 signer fingerprint must be exactly 32 octets"+ Right ()+validatePkt+ ( SymEncIntegrityProtectedDataPkt+ (SEIPD2 symalgo aeadalgo chunkSize salt _)+ ) = do+ when (B.length (unSalt salt) /= 32) $+ Left "SEIPD v2 salt must be exactly 32 octets"+ when (chunkSize > 16) $+ Left "SEIPD v2 chunk size octet must be between 0 and 16"+ case symalgo of+ OtherSA _ -> Left "SEIPD v2 requires a known symmetric algorithm"+ Plaintext -> Left "SEIPD v2 cannot use plaintext cipher"+ _ -> Right ()+ case aeadalgo of+ OtherAEADAlgo _ -> Left "SEIPD v2 requires a known AEAD algorithm"+ _ -> Right ()+validatePkt (OtherPacketPkt t _) = do+ when (t > 63) $+ Left ("cannot serialize OtherPacket packet tag > 63: " ++ show t)+ Right ()+validatePkt _ = Right ()++{- | Serialize a packet with explicit validation and error handling.+Validates constraints before calling putPkt to ensure errors are caught early.+-}+putPktEither :: Pkt -> Either String Put+putPktEither pkt = case validatePkt pkt of+ Left err -> Left err+ Right () -> Right (putPkt pkt)++putLengthThenPayload :: ByteString -> Put+putLengthThenPayload bs = do+ let len = BL.length bs+ if len < fromIntegral (0x100000000 :: Integer)+ then do+ putPacketLength (fromIntegral len)+ putLazyByteString bs+ else putPartialLengthPayload bs+ where+ putPartialLengthPayload :: ByteString -> Put+ putPartialLengthPayload payload = do+ leftover <- iterateUntilM done emitChunk payload+ putPacketLength (fromIntegral (BL.length leftover))+ putLazyByteString leftover+ where+ maxPartialChunkSize :: Int64+ maxPartialChunkSize = 1 `shiftL` (30 :: Int)+ done :: ByteString -> Bool+ done p = BL.length p <= maxPartialChunkSize+ emitChunk p = do+ let (chunk, rest) = BL.splitAt maxPartialChunkSize p+ putPartialLength 30+ putLazyByteString chunk+ return rest++validateSEIPDv2Header+ :: SymmetricAlgorithm+ -> AEADAlgorithm+ -> Word8+ -> ByteString+ -> Get ()+validateSEIPDv2Header symalgo aeadalgo chunkSize encrypted = do+ when (chunkSize > 16) $+ fail "SEIPD v2 chunk size octet must be between 0 and 16"+ when (BL.null encrypted) $+ fail+ "SEIPD v2 payload is missing encrypted data and final authentication tag"+ case symalgo of+ OtherSA _ -> fail "SEIPD v2 requires a known symmetric algorithm"+ Plaintext -> fail "SEIPD v2 cannot use plaintext cipher"+ _ -> return ()+ case aeadalgo of+ OtherAEADAlgo _ -> fail "SEIPD v2 requires a known AEAD algorithm"+ _ -> return ()++getMPI :: Get MPI+getMPI = do+ mpilen <- getWord16be+ bs <- getByteString (fromIntegral (mpilen + 7) `div` 8)+ return $ MPI (os2ip bs)++getPubkey :: PubKeyAlgorithm -> Get PKey+getPubkey RSA = do+ MPI n <- get+ MPI e <- get+ return $+ RSAPubKey+ ( RSA_PublicKey+ (R.PublicKey (fromIntegral . B.length . i2osp $ n) n e)+ )+getPubkey DeprecatedRSAEncryptOnly = getPubkey RSA+getPubkey DeprecatedRSASignOnly = getPubkey RSA+getPubkey DSA = do+ MPI p <- get+ MPI q <- get+ MPI g <- get+ MPI y <- get+ return $+ DSAPubKey (DSA_PublicKey (D.PublicKey (D.Params p g q) y))+getPubkey ElgamalEncryptOnly = getPubkey ForbiddenElgamal+getPubkey ForbiddenElgamal = do+ MPI p <- get+ MPI g <- get+ MPI y <- get+ return $ ElGamalPubKey p g y+getPubkey ECDSA = do+ curvelength <- getWord8+ when (curvelength == 0 || curvelength == 0xff) $+ fail "invalid ECC curve OID length octet (reserved value)"+ curveoid <- getByteString (fromIntegral curvelength)+ MPI mpi <- getMPI+ case curveoidBSToCurve curveoid of+ Left e -> fail e+ Right Curve25519 ->+ EdDSAPubKey P.EdSigningCurve25519+ <$> ( PrefixedNativeEPoint+ <$> validatePrefixedNativePoint 32 "Curve25519Legacy" mpi+ )+ Right curve ->+ case bs2Point (i2osp mpi) of+ Left e -> fail e+ Right point ->+ return+ . ECDSAPubKey+ . ECDSA_PublicKey+ . ECDSA.PublicKey (curve2Curve curve)+ $ point+getPubkey ECDH = do+ ed <- getPubkey ECDSA -- could be an ECDSA or an EdDSA+ kdflen <- getWord8+ when (kdflen == 0 || kdflen == 0xff) $+ fail "invalid ECDH KDF field length octet (reserved value)"+ when (kdflen /= 3) $+ fail ("invalid ECDH KDF field length: " ++ show kdflen)+ one <- getWord8+ when (one /= 1) $+ fail ("invalid ECDH KDF reserved octet: " ++ show one)+ kdfHA <- get+ kdfSA <- get+ return $ ECDHPubKey ed kdfHA kdfSA+getPubkey EdDSA = do+ curvelength <- getWord8+ when (curvelength == 0 || curvelength == 0xff) $+ fail "invalid EdDSA curve OID length octet (reserved value)"+ curveoid <- getByteString (fromIntegral curvelength)+ MPI mpi <- getMPI+ case curveoidBSToEdSigningCurve curveoid of+ Left e -> fail e+ Right P.EdSigningCurve25519 ->+ EdDSAPubKey P.EdSigningCurve25519+ <$> ( PrefixedNativeEPoint+ <$> validatePrefixedNativePoint 32 "Ed25519Legacy" mpi+ )+ Right P.EdSigningCurve448 ->+ EdDSAPubKey P.EdSigningCurve448+ <$> ( PrefixedNativeEPoint+ <$> validatePrefixedNativePoint 57 "Ed448Legacy" mpi+ )+getPubkey pka+ | pka == BTypes.Ed25519 =+ parseFixedLengthOrLegacyPubkey+ 32+ ( EdDSAPubKey P.EdSigningCurve25519+ . NativeEPoint+ . EPoint+ . os2ip+ . BL.toStrict+ )+ (getPubkey EdDSA)+getPubkey pka+ | pka == BTypes.Ed448 =+ parseFixedLengthOrLegacyPubkey+ 57+ ( EdDSAPubKey P.EdSigningCurve448+ . NativeEPoint+ . EPoint+ . os2ip+ . BL.toStrict+ )+ (getPubkey EdDSA)+getPubkey X25519 =+ parseFixedLengthOrLegacyPubkey+ 32+ ( EdDSAPubKey P.EdSigningCurve25519+ . NativeEPoint+ . EPoint+ . os2ip+ . BL.toStrict+ )+ (getPubkey ECDH)+getPubkey X448 =+ parseFixedLengthOrLegacyPubkey+ 56+ ( EdDSAPubKey P.EdSigningCurve448+ . NativeEPoint+ . EPoint+ . os2ip+ . BL.toStrict+ )+ (getPubkey ECDH)+getPubkey MLKEM768X25519 = MLKEMPubKey . BL.toStrict <$> getRemainingLazyByteString+getPubkey MLKEM1024X448 = MLKEMPubKey . BL.toStrict <$> getRemainingLazyByteString+getPubkey MLDSA65Ed25519 = MLDSAPubKey . BL.toStrict <$> getRemainingLazyByteString+getPubkey MLDSA87Ed448 = MLDSAPubKey . BL.toStrict <$> getRemainingLazyByteString+getPubkey SLHDSASHAKE128s = SLHDSAPubKey . BL.toStrict <$> getRemainingLazyByteString+getPubkey SLHDSASHAKE128f = SLHDSAPubKey . BL.toStrict <$> getRemainingLazyByteString+getPubkey SLHDSASHAKE256s = SLHDSAPubKey . BL.toStrict <$> getRemainingLazyByteString+getPubkey _ = UnknownPKey <$> getRemainingLazyByteString++parseFixedLengthOrLegacyPubkey+ :: Int64 -> (BL.ByteString -> PKey) -> Get PKey -> Get PKey+parseFixedLengthOrLegacyPubkey expectedLen decodeFixed legacyParser = do+ remaining <- lookAhead getRemainingLazyByteString+ if BL.length remaining == expectedLen+ then decodeFixed <$> getLazyByteString expectedLen+ else legacyParser++getPubkeyV6 :: PubKeyAlgorithm -> Get PKey+getPubkeyV6 pka+ | pka == BTypes.Ed25519 = do+ len <- getWord32be+ bs <- getByteString (fromIntegral len)+ when (B.length bs /= 32) $+ fail "invalid v6 Ed25519 public key length"+ return $+ EdDSAPubKey+ P.EdSigningCurve25519+ (NativeEPoint (EPoint (os2ip bs)))+ | pka == BTypes.Ed448 = do+ len <- getWord32be+ bs <- getByteString (fromIntegral len)+ when (B.length bs /= 57) $+ fail "invalid v6 Ed448 public key length"+ return $+ EdDSAPubKey+ P.EdSigningCurve448+ (NativeEPoint (EPoint (os2ip bs)))+ | pka == BTypes.X25519 = do+ len <- getWord32be+ bs <- getByteString (fromIntegral len)+ when (B.length bs /= 32) $+ fail "invalid v6 X25519 public key length"+ return $+ EdDSAPubKey+ P.EdSigningCurve25519+ (NativeEPoint (EPoint (os2ip bs)))+ | pka == BTypes.X448 = do+ len <- getWord32be+ bs <- getByteString (fromIntegral len)+ when (B.length bs /= 56) $+ fail "invalid v6 X448 public key length"+ return $+ EdDSAPubKey+ P.EdSigningCurve448+ (NativeEPoint (EPoint (os2ip bs)))+ | pka == MLKEM768X25519 = do+ len <- getWord32be+ bs <- getByteString (fromIntegral len)+ return $ MLKEMPubKey bs+ | pka == MLKEM1024X448 = do+ len <- getWord32be+ bs <- getByteString (fromIntegral len)+ return $ MLKEMPubKey bs+ | pka == MLDSA65Ed25519 = do+ len <- getWord32be+ bs <- getByteString (fromIntegral len)+ return $ MLDSAPubKey bs+ | pka == MLDSA87Ed448 = do+ len <- getWord32be+ bs <- getByteString (fromIntegral len)+ return $ MLDSAPubKey bs+ | pka == SLHDSASHAKE128s = do+ len <- getWord32be+ bs <- getByteString (fromIntegral len)+ return $ SLHDSAPubKey bs+ | pka == SLHDSASHAKE128f = do+ len <- getWord32be+ bs <- getByteString (fromIntegral len)+ return $ SLHDSAPubKey bs+ | pka == SLHDSASHAKE256s = do+ len <- getWord32be+ bs <- getByteString (fromIntegral len)+ return $ SLHDSAPubKey bs+ | otherwise = getPubkey pka++bs2Point :: B.ByteString -> Either String ECDSA.PublicPoint+bs2Point bs =+ if B.null bs+ then Left "empty EC point encoding"+ else+ let xy = B.drop 1 bs+ l = B.length xy+ in if B.head bs /= 0x04+ then Left $ "unknown type of point: " ++ show (B.unpack bs)+ else+ if odd l+ then+ Left "malformed EC point encoding: odd coordinate payload length"+ else+ return+ ( uncurry+ ECCT.Point+ ((os2ip *** os2ip) (B.splitAt (div l 2) xy))+ )++putPubkey :: PKey -> Put+putPubkey (UnknownPKey bs) = putLazyByteString bs+putPubkey (MLKEMPubKey bs) = putLazyByteString (BL.fromStrict bs)+putPubkey (MLDSAPubKey bs) = putLazyByteString (BL.fromStrict bs)+putPubkey (SLHDSAPubKey bs) = putLazyByteString (BL.fromStrict bs)+putPubkey p@(ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) =+ let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve)+ in putCurveOID curveoidbs+ >> mapM_ put (pubkeyToMPIs p)+putPubkey+ p@( ECDHPubKey+ (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)))+ kha+ ksa+ ) =+ let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve)+ in putCurveOID curveoidbs+ >> mapM_ put (pubkeyToMPIs p)+ >> putECDHKDFParams kha ksa+putPubkey p@(ECDHPubKey (EdDSAPubKey curve (PrefixedNativeEPoint _)) kha ksa) =+ let Right curveoidbs = curveToCurveoidBS (ed2ec curve)+ in putCurveOID curveoidbs+ >> mapM_ put (pubkeyToMPIs p)+ >> putECDHKDFParams kha ksa+ where+ ed2ec P.EdSigningCurve25519 = Curve25519+ ed2ec P.EdSigningCurve448 = Curve448+putPubkey p@(EdDSAPubKey curve (PrefixedNativeEPoint _)) =+ let Right curveoidbs = edSigningCurveToCurveoidBS curve+ in putCurveOID curveoidbs+ >> mapM_ put (pubkeyToMPIs p)+putPubkey (ECDHPubKey (EdDSAPubKey curve (NativeEPoint _)) _ _) =+ error+ ( "legacy ECDH serialization requires a prefixed-native "+ ++ show curve+ ++ " point"+ )+putPubkey (EdDSAPubKey curve (NativeEPoint _)) =+ error+ ( "legacy EdDSA serialization requires a prefixed-native "+ ++ show curve+ ++ " point"+ )+putPubkey p = mapM_ put (pubkeyToMPIs p)++putPubkeyV6 :: PKey -> Put+putPubkeyV6 (EdDSAPubKey P.EdSigningCurve25519 (NativeEPoint (EPoint x))) = do+ let bs = fixedLengthOctets 32 x+ putWord32be . fromIntegral . B.length $ bs+ putByteString bs+putPubkeyV6 (EdDSAPubKey P.EdSigningCurve448 (NativeEPoint (EPoint x))) = do+ let bs = fixedLengthOctets 57 x+ putWord32be . fromIntegral . B.length $ bs+ putByteString bs+putPubkeyV6+ ( ECDHPubKey+ (EdDSAPubKey P.EdSigningCurve25519 (NativeEPoint (EPoint x)))+ kha+ ksa+ ) = do+ let bs = fixedLengthOctets 32 x+ putWord32be . fromIntegral . B.length $ bs+ putByteString bs+ put kha+ put ksa+putPubkeyV6+ ( ECDHPubKey+ (EdDSAPubKey P.EdSigningCurve448 (NativeEPoint (EPoint x)))+ kha+ ksa+ ) = do+ let bs = fixedLengthOctets 56 x+ putWord32be . fromIntegral . B.length $ bs+ putByteString bs+ put kha+ put ksa+putPubkeyV6 (MLKEMPubKey bs) = do+ putWord32be . fromIntegral . B.length $ bs+ putByteString bs+putPubkeyV6 (MLDSAPubKey bs) = do+ putWord32be . fromIntegral . B.length $ bs+ putByteString bs+putPubkeyV6 (SLHDSAPubKey bs) = do+ putWord32be . fromIntegral . B.length $ bs+ putByteString bs+putPubkeyV6 p = putPubkey p++fixedLengthOctets :: Int -> Integer -> B.ByteString+fixedLengthOctets targetLen x =+ let bs = i2osp x+ in if B.length bs > targetLen+ then+ error+ ( "public key element does not fit in "+ ++ show targetLen+ ++ " octets"+ )+ else B.replicate (targetLen - B.length bs) 0 <> bs++validatePrefixedNativePoint+ :: Int -> String -> Integer -> Get EPoint+validatePrefixedNativePoint targetLen label i =+ let bs = i2osp i+ in if B.length bs /= targetLen + 1+ then+ fail+ ( "invalid "+ ++ label+ ++ " public key length: expected "+ ++ show (targetLen + 1)+ ++ " octets with 0x40 prefix, got "+ ++ show (B.length bs)+ )+ else+ if B.head bs /= 0x40+ then+ fail ("invalid " ++ label ++ " public key: missing 0x40 prefix")+ else pure (EPoint i)++putCurveOID :: B.ByteString -> Put+putCurveOID oid = do+ let oidLength = B.length oid+ when (oidLength == 0 || oidLength == 0xff) $+ error "curve OID length cannot use reserved values 0 or 255"+ putWord8 (fromIntegral oidLength)+ putByteString oid++putECDHKDFParams :: HashAlgorithm -> SymmetricAlgorithm -> Put+putECDHKDFParams kdfHA kdfSA = do+ let kdfLengthOctet = 0x03+ when (kdfLengthOctet == 0 || kdfLengthOctet == 0xff) $+ error "ECDH KDF field length cannot use reserved values 0 or 255"+ putWord8 kdfLengthOctet+ putWord8 0x01+ put kdfHA+ put kdfSA++parseOPSNestedFlag :: Word8 -> Get NestedFlag+parseOPSNestedFlag 0 = pure True+parseOPSNestedFlag 1 = pure False+parseOPSNestedFlag other =+ fail ("invalid OPS nested flag octet: " ++ show other)++getSecretKey :: SomePKPayload -> Get SKey+getSecretKey pkp+ | _pkalgo pkp+ `elem` [RSA, DeprecatedRSAEncryptOnly, DeprecatedRSASignOnly] = do+ MPI d <- get+ MPI p <- get+ MPI q <- get+ MPI _ <- get -- u+ case inverse q p of+ Nothing -> fail "invalid RSA secret key: q has no inverse modulo p"+ Just qinv -> do+ let dP = d `mod` (p - 1)+ dQ = d `mod` (q - 1)+ pub = (\(RSAPubKey (RSA_PublicKey x)) -> x) (_pubkey pkp)+ return $+ RSAPrivateKey+ (RSA_PrivateKey (R.PrivateKey pub d p q dP dQ qinv))+ | _pkalgo pkp == DSA = do+ MPI x <- get+ return $+ DSAPrivateKey (DSA_PrivateKey (D.PrivateKey (D.Params 0 0 0) x))+ | _pkalgo pkp `elem` [ElgamalEncryptOnly, ForbiddenElgamal] = do+ MPI x <- get+ return $ ElGamalPrivateKey x+ | _pkalgo pkp == ECDSA = do+ let pubcurve =+ (\(ECDSAPubKey (ECDSA_PublicKey p)) -> ECDSA.public_curve p)+ (_pubkey pkp)+ getECDSAScalarPrivateKey pubcurve+ | _pkalgo pkp == ECDH =+ do+ pubcurve <- ecdhPrivateCurveFromPKPayload pkp+ getECDHScalarPrivateKey pubcurve+ | _pkalgo pkp == X25519 = do+ if _keyVersion pkp == V6+ then do+ sk <- getByteString 32+ return $ X25519PrivateKey sk+ else do+ pubcurve <- ecdhPrivateCurveFromPKPayload pkp+ getECDHScalarPrivateKey pubcurve+ | _pkalgo pkp == X448 = do+ if _keyVersion pkp == V6+ then do+ sk <- getByteString 56+ return $ X448PrivateKey sk+ else UnknownSKey <$> getRemainingLazyByteString+ | _pkalgo pkp == EdDSA = do+ if _keyVersion pkp == V6+ then do+ case _pubkey pkp of+ EdDSAPubKey P.EdSigningCurve25519 _ -> EdDSAPrivateKey P.EdSigningCurve25519 <$> getByteString 32+ EdDSAPubKey P.EdSigningCurve448 _ -> EdDSAPrivateKey P.EdSigningCurve448 <$> getByteString 57+ _ -> UnknownSKey <$> getRemainingLazyByteString+ else do+ MPI x <- get+ case _pubkey pkp of+ EdDSAPubKey P.EdSigningCurve25519 _ ->+ return $+ EdDSAPrivateKey P.EdSigningCurve25519 (leftPadTo 32 (i2osp x))+ EdDSAPubKey P.EdSigningCurve448 _ ->+ return $+ EdDSAPrivateKey P.EdSigningCurve448 (leftPadTo 57 (i2osp x))+ _ -> return $ UnknownSKey (BL.fromStrict (i2osp x))+ | _pkalgo pkp `elem` [MLKEM768X25519, MLKEM1024X448] = do+ if _keyVersion pkp == V6+ then do+ len <- getWord32be+ bs <- getByteString (fromIntegral len)+ return $ MLKEMPrivateKey bs+ else UnknownSKey <$> getRemainingLazyByteString+ | _pkalgo pkp `elem` [MLDSA65Ed25519, MLDSA87Ed448] = do+ if _keyVersion pkp == V6+ then do+ len <- getWord32be+ bs <- getByteString (fromIntegral len)+ return $ MLDSAPrivateKey bs+ else UnknownSKey <$> getRemainingLazyByteString+ | _pkalgo pkp+ `elem` [SLHDSASHAKE128s, SLHDSASHAKE128f, SLHDSASHAKE256s] = do+ if _keyVersion pkp == V6+ then do+ len <- getWord32be+ bs <- getByteString (fromIntegral len)+ return $ SLHDSAPrivateKey bs+ else UnknownSKey <$> getRemainingLazyByteString+ | otherwise = UnknownSKey <$> getRemainingLazyByteString++getECDSAScalarPrivateKey :: ECCT.Curve -> Get SKey+getECDSAScalarPrivateKey curve = do+ MPI pn <- get+ pure $+ ECDSAPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey curve pn))++getECDHScalarPrivateKey :: ECCT.Curve -> Get SKey+getECDHScalarPrivateKey curve = do+ MPI pn <- get+ pure $+ ECDHPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey curve pn))++ecdhPrivateCurveFromPKPayload :: SomePKPayload -> Get ECCT.Curve+ecdhPrivateCurveFromPKPayload pkp =+ case _pubkey pkp of+ ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey p)) _ _ ->+ pure (ECDSA.public_curve p)+ ECDHPubKey (EdDSAPubKey P.EdSigningCurve25519 _) _ _ ->+ pure (curve2Curve Curve25519)+ ECDHPubKey (EdDSAPubKey P.EdSigningCurve448 _) _ _ ->+ pure (curve2Curve Curve448)+ other ->+ fail+ ( "ECDH/X25519 secret key requires an ECDH public key packet, got "+ ++ show other+ )++putSKey :: SKey -> Either String Put+putSKey (RSAPrivateKey (RSA_PrivateKey (R.PrivateKey _ d p q _ _ _))) =+ case inverse q p of+ Just u ->+ Right (put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u))+ Nothing ->+ Left+ "putSKey: invalid RSA key — q has no multiplicative inverse mod p (key is mathematically broken)"+putSKey (DSAPrivateKey (DSA_PrivateKey (D.PrivateKey _ x))) =+ Right (put (MPI x))+putSKey (ElGamalPrivateKey x) =+ Right (put (MPI x))+putSKey (ECDHPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey _ d))) =+ Right (put (MPI d))+putSKey (ECDSAPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey _ d))) =+ Right (put (MPI d))+putSKey (EdDSAPrivateKey P.EdSigningCurve25519 sk) = Right (putByteString sk)+putSKey (EdDSAPrivateKey P.EdSigningCurve448 sk) = Right (putByteString sk)+putSKey (X25519PrivateKey sk) = Right (putByteString sk)+putSKey (X448PrivateKey sk) = Right (putByteString sk)+putSKey (MLKEMPrivateKey sk) = Right (putLazyByteString (BL.fromStrict sk))+putSKey (MLDSAPrivateKey sk) = Right (putLazyByteString (BL.fromStrict sk))+putSKey (SLHDSAPrivateKey sk) = Right (putLazyByteString (BL.fromStrict sk))+putSKey (UnknownSKey bs) = Right (putLazyByteString bs)++putSKeyForPKPayload :: SomePKPayload -> SKey -> Either String Put+putSKeyForPKPayload pkp sk@(EdDSAPrivateKey _ bs)+ | _keyVersion pkp == V6 = putSKey sk+ | otherwise = Right (put (MPI (os2ip bs)))+putSKeyForPKPayload _ sk = putSKey sk++putMPI :: MPI -> Put+putMPI (MPI i) = do+ let bs = i2osp i+ putWord16be . fromIntegral . numBits $ i+ putByteString bs++data PKPayloadReadCase where+ PKPayloadReadCaseV3+ :: V3Expiration -> PubKeyAlgorithm -> PKPayloadReadCase+ PKPayloadReadCaseV4 :: PubKeyAlgorithm -> PKPayloadReadCase+ PKPayloadReadCaseV6 :: PubKeyAlgorithm -> PKPayloadReadCase++pkPayloadReadCase :: Word8 -> Get PKPayloadReadCase+pkPayloadReadCase version =+ case version of+ 2 -> do+ v3e <- getWord16be+ pka <- get+ pure (PKPayloadReadCaseV3 v3e pka)+ 3 -> do+ v3e <- getWord16be+ pka <- get+ pure (PKPayloadReadCaseV3 v3e pka)+ 4 -> PKPayloadReadCaseV4 <$> get+ 6 -> PKPayloadReadCaseV6 <$> get+ _ -> fail ("unsupported key packet version " ++ show version)++getPKPayload :: Get SomePKPayload+getPKPayload = do+ version <- getWord8+ ctime <- fmap ThirtyTwoBitTimeStamp getWord32be+ readCase <- pkPayloadReadCase version+ case readCase of+ PKPayloadReadCaseV3 v3e pka -> do+ pk <- getPubkey pka+ pure $! PKPayload DeprecatedV3 ctime v3e pka pk+ PKPayloadReadCaseV4 pka -> do+ pk <- getPubkey pka+ pure $! PKPayload V4 ctime 0 pka pk+ PKPayloadReadCaseV6 pka -> do+ pk <- getPubkeyV6 pka+ pure $! PKPayload V6 ctime 0 pka pk++data PKPayloadWriteCase where+ PKPayloadWriteCaseV3+ :: PKPayload 'DeprecatedV3 -> PKPayloadWriteCase+ PKPayloadWriteCaseV4 :: PKPayload 'V4 -> PKPayloadWriteCase+ PKPayloadWriteCaseV6 :: PKPayload 'V6 -> PKPayloadWriteCase++pkPayloadWriteCase :: SomePKPayload -> PKPayloadWriteCase+pkPayloadWriteCase (SomePKPayload pkp) =+ case pkp of+ PKPayloadV3 {} -> PKPayloadWriteCaseV3 pkp+ PKPayloadV4 {} -> PKPayloadWriteCaseV4 pkp+ PKPayloadV6 {} -> PKPayloadWriteCaseV6 pkp++putPKPayload :: SomePKPayload -> Put+putPKPayload pkpSome =+ case pkPayloadWriteCase pkpSome of+ PKPayloadWriteCaseV3 (PKPayloadV3 ctime v3e pka pk) -> do+ putWord8 3+ putWord32be . unThirtyTwoBitTimeStamp $ ctime+ putWord16be v3e+ put pka+ putPubkey pk+ PKPayloadWriteCaseV4 (PKPayloadV4 ctime pka pk) -> do+ putWord8 4+ putWord32be . unThirtyTwoBitTimeStamp $ ctime+ put pka+ putPubkeyV4ForAlgorithm pka pk+ PKPayloadWriteCaseV6 (PKPayloadV6 ctime pka pk) -> do+ putWord8 6+ putWord32be . unThirtyTwoBitTimeStamp $ ctime+ put pka+ putPubkeyV6 pk++putPubkeyV4ForAlgorithm :: PubKeyAlgorithm -> PKey -> Put+putPubkeyV4ForAlgorithm pka pk+ | pka == BTypes.Ed25519 =+ putPubkeyV4Fixed 32 P.EdSigningCurve25519 pk+ | pka == BTypes.Ed448 =+ putPubkeyV4Fixed 57 P.EdSigningCurve448 pk+ | pka == BTypes.X25519 =+ putPubkeyV4Fixed 32 P.EdSigningCurve25519 pk+ | pka == BTypes.X448 = putPubkeyV4Fixed 56 P.EdSigningCurve448 pk+ | otherwise = putPubkey pk++putPubkeyV4Fixed :: Int -> P.EdSigningCurve -> PKey -> Put+putPubkeyV4Fixed targetLen expectedCurve (EdDSAPubKey curve (NativeEPoint (EPoint x)))+ | curve == expectedCurve =+ putByteString (fixedLengthOctets targetLen x)+putPubkeyV4Fixed _ _ pk = putPubkey pk++getSKAddendum :: SomePKPayload -> Get SKAddendum+getSKAddendum (SomePKPayload pkp) =+ toSKAddendum <$> getSKAddendumTyped pkp++getSKAddendumTyped :: PKPayload v -> Get (SKAddendumV v)+getSKAddendumTyped pkp = do+ s2kusage <- getWord8+ let pkpSome = SomePKPayload pkp+ getLegacyS2KProtected constructor = do+ symencWord <- getWord8+ s2k <- getS2K+ let symenc = toFVal symencWord+ case s2k of+ OtherS2K _ _ -> return $ constructor symenc s2k mempty BL.empty+ _ -> do+ blockSize <- either fail pure (symEncBlockSize symenc)+ iv <- IV <$> getByteString blockSize+ encryptedblock <- getRemainingLazyByteString+ return $ constructor symenc s2k iv encryptedblock+ case s2kusage of+ 0 ->+ case pkp of+ PKPayloadV6 {} -> do+ sk <- getSecretKey pkpSome+ return (SKAUnencryptedV6 sk)+ PKPayloadV3 {} -> do+ rest <- lookAhead getRemainingLazyByteString+ secretLen <-+ case runGetOrFail+ ( do+ start <- bytesRead+ _ <- getSecretKey pkpSome+ end <- bytesRead+ pure (end - start)+ )+ rest of+ Left (_, _, err) -> fail err+ Right (_, _, len) -> pure len+ sk <- getSecretKey pkpSome+ checksum <- getWord16be+ let expectedChecksum =+ checksum16Bytes (BL.toStrict (BL.take secretLen rest))+ when (checksum /= expectedChecksum) $+ fail+ ( "legacy unencrypted secret-key checksum mismatch: expected "+ ++ show expectedChecksum+ ++ ", got "+ ++ show checksum+ )+ return (SKAUnencryptedLegacy sk checksum)+ PKPayloadV4 {} -> do+ rest <- lookAhead getRemainingLazyByteString+ secretLen <-+ case runGetOrFail+ ( do+ start <- bytesRead+ _ <- getSecretKey pkpSome+ end <- bytesRead+ pure (end - start)+ )+ rest of+ Left (_, _, err) -> fail err+ Right (_, _, len) -> pure len+ sk <- getSecretKey pkpSome+ checksum <- getWord16be+ let expectedChecksum =+ checksum16Bytes (BL.toStrict (BL.take secretLen rest))+ when (checksum /= expectedChecksum) $+ fail+ ( "legacy unencrypted secret-key checksum mismatch: expected "+ ++ show expectedChecksum+ ++ ", got "+ ++ show checksum+ )+ return (SKAUnencryptedLegacy sk checksum)+ 255 ->+ case pkp of+ PKPayloadV6 {} ->+ fail "v6 secret key packets MUST NOT use s2k usage 255"+ PKPayloadV3 {} ->+ getLegacyS2KProtected SKA16bit+ PKPayloadV4 {} ->+ getLegacyS2KProtected SKA16bit+ 254 ->+ case pkp of+ PKPayloadV6 {} -> do+ paramsLen <- getWord8+ params <- getLazyByteString (fromIntegral paramsLen)+ (symenc, s2k, iv) <-+ case runGetOrFail getV6CFBParams params of+ Left (_, _, err) -> fail err+ Right (rest, _, parsed)+ | not (BL.null rest) ->+ fail "unexpected trailing v6 CFB parameters"+ | otherwise -> pure parsed+ encryptedblock <- getRemainingLazyByteString+ return (SKASHA1V6 symenc s2k (IV iv) encryptedblock)+ PKPayloadV3 {} ->+ getLegacyS2KProtected SKASHA1Legacy+ PKPayloadV4 {} ->+ getLegacyS2KProtected SKASHA1Legacy+ where+ getV6CFBParams = do+ symencWord <- getWord8+ s2kLen <- getWord8+ s2kBytes <- getLazyByteString (fromIntegral s2kLen)+ s2k <-+ case runGetOrFail getS2K s2kBytes of+ Left (_, _, err) -> fail err+ Right (rest, _, parsed)+ | not (BL.null rest) ->+ fail "unexpected trailing bytes in v6 S2K specifier"+ | otherwise -> pure parsed+ iv <- getRemainingLazyByteString+ let symenc = toFVal symencWord+ blockSize <- either fail pure (symEncBlockSize symenc)+ when (BL.length iv /= fromIntegral blockSize) $+ fail "invalid v6 CFB IV length"+ pure (symenc, s2k, BL.toStrict iv)+ 253 ->+ case pkp of+ PKPayloadV6 {} -> do+ paramsLen <- getWord8+ params <- getLazyByteString (fromIntegral paramsLen)+ (symenc, aead, s2k, iv) <-+ case runGetOrFail getV6AEADParams params of+ Left (_, _, err) -> fail err+ Right (rest, _, parsed)+ | not (BL.null rest) ->+ fail "unexpected trailing v6 AEAD parameters"+ | otherwise -> pure parsed+ encryptedblock <- getRemainingLazyByteString+ return (SKAAEADV6 symenc aead s2k (IV iv) encryptedblock)+ PKPayloadV3 {} -> do+ (symenc, aead, s2k, iv) <- getLegacyAEADParams+ encryptedblock <- getRemainingLazyByteString+ return (SKAAEADLegacy symenc aead s2k (IV iv) encryptedblock)+ PKPayloadV4 {} -> do+ (symenc, aead, s2k, iv) <- getLegacyAEADParams+ encryptedblock <- getRemainingLazyByteString+ return (SKAAEADLegacy symenc aead s2k (IV iv) encryptedblock)+ where+ getV6AEADParams+ :: Get (SymmetricAlgorithm, AEADAlgorithm, S2K, B.ByteString)+ getV6AEADParams = do+ symencWord <- getWord8+ aeadWord <- getWord8+ s2kLen <- getWord8+ s2kBytes <- getLazyByteString (fromIntegral s2kLen)+ s2k <-+ case runGetOrFail getS2K s2kBytes of+ Left (_, _, err) -> fail err+ Right (rest, _, parsed)+ | not (BL.null rest) ->+ fail "unexpected trailing bytes in v6 S2K specifier"+ | otherwise -> pure parsed+ iv <- getRemainingLazyByteString+ let symenc = toFVal symencWord+ aead = toFVal aeadWord+ when (BL.length iv /= fromIntegral (aeadNonceSize aead)) $+ fail "invalid v6 AEAD IV length"+ pure (symenc, aead, s2k, BL.toStrict iv)+ -- v3/v4: no cumulative-params-length octet, no S2K-size octet+ getLegacyAEADParams+ :: Get (SymmetricAlgorithm, AEADAlgorithm, S2K, B.ByteString)+ getLegacyAEADParams = do+ symencWord <- getWord8+ aeadWord <- getWord8+ s2k <- getS2K+ let aead = toFVal aeadWord+ iv <-+ BL.toStrict+ <$> getLazyByteString (fromIntegral (aeadNonceSize aead))+ pure (toFVal symencWord, aead, s2k, iv)+ symenc ->+ case pkp of+ PKPayloadV6 {} -> do+ paramsLen <- getWord8+ iv <- getByteString (fromIntegral paramsLen)+ let symencAlg = toFVal symenc+ blockSize <- either fail pure (symEncBlockSize symencAlg)+ when (B.length iv /= blockSize) $+ fail "invalid v6 CFB IV length"+ encryptedblock <- getRemainingLazyByteString+ return (SKASymV6 symencAlg (IV iv) encryptedblock)+ PKPayloadV3 {} -> do+ blockSize <- either fail pure (symEncBlockSize (toFVal symenc))+ iv <- getByteString blockSize+ encryptedblock <- getRemainingLazyByteString+ return (SKASymLegacy (toFVal symenc) (IV iv) encryptedblock)+ PKPayloadV4 {} -> do+ blockSize <- either fail pure (symEncBlockSize (toFVal symenc))+ iv <- getByteString blockSize+ encryptedblock <- getRemainingLazyByteString+ return (SKASymLegacy (toFVal symenc) (IV iv) encryptedblock)++putSKAddendum :: SKAddendum -> Either String Put+putSKAddendum (SUS16bit symenc s2k iv encryptedblock) =+ Right $ do+ putWord8 255+ put symenc+ put s2k+ putByteString (unIV iv)+ putLazyByteString encryptedblock+putSKAddendum (SUSSHA1 symenc s2k iv encryptedblock) =+ Right $ do+ putWord8 254+ put symenc+ put s2k+ putByteString (unIV iv)+ putLazyByteString encryptedblock+putSKAddendum (SUSAEAD symenc aead s2k iv encryptedblock) =+ Right $ do+ putWord8 253+ put symenc+ putWord8 (fromFVal aead)+ put s2k+ putByteString (unIV iv)+ putLazyByteString encryptedblock+putSKAddendum (SUSym symenc iv encryptedblock) =+ Right $ do+ put symenc+ putByteString (unIV iv)+ putLazyByteString encryptedblock+putSKAddendum (SUUnencrypted sk checksum) =+ do+ putSecret <- putSKey sk+ Right $ do+ putWord8 0+ let skb = runPut putSecret+ putLazyByteString skb+ putWord16be+ ( if checksum == 0+ then checksum16Bytes (BL.toStrict skb)+ else checksum+ )++checksum16Bytes :: B.ByteString -> Word16+checksum16Bytes =+ B.foldl'+ ( \a b ->+ fromIntegral+ ((fromIntegral a + fromIntegral b) `mod` (65536 :: Integer))+ )+ 0++putSKAddendumForPKPayload :: SomePKPayload -> SKAddendum -> Put+putSKAddendumForPKPayload pkp ska =+ case fromSKAddendumForPKPayload pkp ska of+ Left e -> error e+ Right (SomeSKAddendumV skaV) ->+ putSKAddendumForPKPayloadTyped pkp skaV++putUnencryptedSKAddendum :: SomePKPayload -> SKey -> Put+putUnencryptedSKAddendum pkp sk = do+ putWord8 0+ let putSecret =+ case putSKeyForPKPayload pkp sk of+ Left err -> error err+ Right p -> p+ skb = runPut putSecret+ putLazyByteString skb++putSKAddendumForPKPayloadTyped+ :: SomePKPayload+ -> SKAddendumV v+ -> Put+putSKAddendumForPKPayloadTyped pkp (SKAUnencryptedLegacy sk checksum) = do+ let skb =+ runPut+ ( case putSKeyForPKPayload pkp sk of+ Left err -> error err+ Right p -> p+ )+ putUnencryptedSKAddendum pkp sk+ putWord16be+ ( if checksum == 0+ then+ BL.foldl+ (\a b -> mod (a + fromIntegral b) 0xffff)+ (0 :: Word16)+ skb+ else checksum+ )+putSKAddendumForPKPayloadTyped pkp (SKAUnencryptedV6 sk) =+ putUnencryptedSKAddendum pkp sk putSKAddendumForPKPayloadTyped _ (SKASHA1V6 symenc s2k iv encryptedblock) = do let s2kbs = runPut (put s2k) paramsLen = 1 + 1 + BL.length s2kbs + fromIntegral (B.length (unIV iv))
Codec/Encryption/OpenPGP/SerializeForSigs.hs view
@@ -2,134 +2,162 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} module Codec.Encryption.OpenPGP.SerializeForSigs- ( putPKPforFingerprinting- , putPartialSigforSigning- , putSigTrailer- , putUforSigning- , putUIDforSigning- , putUAtforSigning- , putKeyforSigning- , putSigforSigning- , payloadForSig- , payloadForSigWith- ) where+ ( putPKPforFingerprinting+ , putPartialSigforSigning+ , putSigTrailer+ , putUforSigning+ , putUIDforSigning+ , putUAtforSigning+ , putKeyforSigning+ , putSigforSigning+ , payloadForSig+ , payloadForSigWith+ ) where import Control.Lens ((^.)) import Crypto.Number.Serialize (i2osp) import Data.Binary (put) import Data.Binary.Put- ( Put- , putByteString- , putLazyByteString- , putWord16be- , putWord32be- , putWord8- , runPut- )+ ( Put+ , putByteString+ , putLazyByteString+ , putWord16be+ , putWord32be+ , putWord8+ , runPut+ ) import qualified Data.ByteString as B import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import Data.Text.Encoding (encodeUtf8) import Data.Word (Word8) -import Codec.Encryption.OpenPGP.Internal (PktStreamContext(..), pubkeyToMPIs)+import Codec.Encryption.OpenPGP.Internal+ ( PktStreamContext (..)+ , pubkeyToMPIs+ )+import Codec.Encryption.OpenPGP.Internal.Whitespace+ ( canonicalizeLineEndings+ , stripTrailingWhitespacePerLine+ ) import Codec.Encryption.OpenPGP.Serialize ()-import Codec.Encryption.OpenPGP.Subpackets (TextNormalizationMode(..))+import Codec.Encryption.OpenPGP.Subpackets+ ( TextNormalizationMode (..)+ ) import Codec.Encryption.OpenPGP.Types data SignatureSerializationCase where- SignatureSerializationCaseV4 ::- SignaturePayloadV 'SigPayloadV4 -> SignatureSerializationCase- SignatureSerializationCaseV6 ::- SignaturePayloadV 'SigPayloadV6 -> SignatureSerializationCase+ SignatureSerializationCaseV4+ :: SignaturePayloadV 'SigPayloadV4 -> SignatureSerializationCase+ SignatureSerializationCaseV6+ :: SignaturePayloadV 'SigPayloadV6 -> SignatureSerializationCase -fromPktSignatureSerializationCase :: Pkt -> Maybe SignatureSerializationCase+fromPktSignatureSerializationCase+ :: Pkt -> Maybe SignatureSerializationCase fromPktSignatureSerializationCase pkt =- case fromPktEitherSomeSignatureV pkt of- Right (SomeSignatureV (SignatureV4Packet payload)) ->- Just (SignatureSerializationCaseV4 payload)- Right (SomeSignatureV (SignatureV6Packet payload)) ->- Just (SignatureSerializationCaseV6 payload)- _ -> Nothing+ case fromPktEitherSomeSignatureV pkt of+ Right (SomeSignatureV (SignatureV4Packet payload)) ->+ Just (SignatureSerializationCaseV4 payload)+ Right (SomeSignatureV (SignatureV6Packet payload)) ->+ Just (SignatureSerializationCaseV6 payload)+ _ -> Nothing putPartialSigforSigningCase :: SignatureSerializationCase -> Put-putPartialSigforSigningCase (SignatureSerializationCaseV4 (SigPayloadV4Data st pka ha hashed _ _ _)) = do- putWord8 4- put st- put pka- put ha- let hb = runPut $ mapM_ put hashed- putWord16be . fromIntegral . BL.length $ hb- putLazyByteString hb-putPartialSigforSigningCase (SignatureSerializationCaseV6 (SigPayloadV6Data st pka ha _salt hashed _ _ _)) = do- putWord8 6- put st- put pka- put ha- let hb = runPut $ mapM_ put hashed- putWord32be . fromIntegral . BL.length $ hb- putLazyByteString hb+putPartialSigforSigningCase+ ( SignatureSerializationCaseV4+ (SigPayloadV4Data st pka ha hashed _ _ _)+ ) = do+ putWord8 4+ put st+ put pka+ put ha+ let hb = runPut $ mapM_ put hashed+ putWord16be . fromIntegral . BL.length $ hb+ putLazyByteString hb+putPartialSigforSigningCase+ ( SignatureSerializationCaseV6+ (SigPayloadV6Data st pka ha _salt hashed _ _ _)+ ) = do+ putWord8 6+ put st+ put pka+ put ha+ let hb = runPut $ mapM_ put hashed+ putWord32be . fromIntegral . BL.length $ hb+ putLazyByteString hb putSigTrailerCase :: SignatureSerializationCase -> Put putSigTrailerCase (SignatureSerializationCaseV4 (SigPayloadV4Data _ _ _ hs _ _ _)) = do- putWord8 0x04- putWord8 0xff- putWord32be . fromIntegral . (+ 6) . BL.length $ runPut $ mapM_ put hs- -- this +6 seems like a bug in RFC4880+ putWord8 0x04+ putWord8 0xff+ putWord32be . fromIntegral . (+ 6) . BL.length $+ runPut $+ mapM_ put hs+-- this +6 seems like a bug in RFC4880 putSigTrailerCase signatureCase@(SignatureSerializationCaseV6 _) = do- putWord8 0x06- putWord8 0xff- putWord32be . fromIntegral . (+ 6) . BL.length $ runPut (putPartialSigforSigningCase signatureCase)+ putWord8 0x06+ putWord8 0xff+ putWord32be . fromIntegral . (+ 6) . BL.length $+ runPut (putPartialSigforSigningCase signatureCase) putSigforSigningCase :: SignatureSerializationCase -> Put-putSigforSigningCase (SignatureSerializationCaseV4 (SigPayloadV4Data st pka ha hashed _ left16 mpis)) = do- putWord8 0x88- let bs = runPut $ put (SigV4 st pka ha hashed [] left16 mpis)- putWord32be . fromIntegral . BL.length $ bs- putLazyByteString bs-putSigforSigningCase (SignatureSerializationCaseV6 (SigPayloadV6Data st pka ha salt hashed _ left16 mpis)) = do- putWord8 0xC2- let bs = runPut $ put (SigV6 st pka ha salt hashed [] left16 mpis)- putWord32be . fromIntegral . BL.length $ bs- putLazyByteString bs+putSigforSigningCase+ ( SignatureSerializationCaseV4+ (SigPayloadV4Data st pka ha hashed _ left16 mpis)+ ) = do+ putWord8 0x88+ let bs = runPut $ put (SigV4 st pka ha hashed [] left16 mpis)+ putWord32be . fromIntegral . BL.length $ bs+ putLazyByteString bs+putSigforSigningCase+ ( SignatureSerializationCaseV6+ (SigPayloadV6Data st pka ha salt hashed _ left16 mpis)+ ) = do+ putWord8 0xC2+ let bs = runPut $ put (SigV6 st pka ha salt hashed [] left16 mpis)+ putWord32be . fromIntegral . BL.length $ bs+ putLazyByteString bs putPKPforFingerprinting :: Pkt -> Put putPKPforFingerprinting (PublicKeyPkt (PKPayload DeprecatedV3 _ _ _ pk)) =- mapM_ putMPIforFingerprinting (pubkeyToMPIs pk)+ mapM_ putMPIforFingerprinting (pubkeyToMPIs pk) putPKPforFingerprinting (PublicKeyPkt pkp@(PKPayload V4 _ _ _ _)) = do- putWord8 0x99- let bs = runPut $ put pkp- putWord16be . fromIntegral $ BL.length bs- putLazyByteString bs+ putWord8 0x99+ let bs = runPut $ put pkp+ putWord16be . fromIntegral $ BL.length bs+ putLazyByteString bs putPKPforFingerprinting (PublicKeyPkt pkp@(PKPayload V6 _ _ _ _)) = do- putWord8 0x9B- let bs = runPut $ put pkp- putWord32be . fromIntegral $ BL.length bs- putLazyByteString bs+ putWord8 0x9B+ let bs = runPut $ put pkp+ putWord32be . fromIntegral $ BL.length bs+ putLazyByteString bs putPKPforFingerprinting _ =- error "This should never happen (putPKPforFingerprinting)"+ error "This should never happen (putPKPforFingerprinting)" putMPIforFingerprinting :: MPI -> Put putMPIforFingerprinting (MPI i) =- let bs = i2osp i- in putByteString bs+ let bs = i2osp i+ in putByteString bs putPartialSigforSigning :: Pkt -> Put putPartialSigforSigning pkt =- case fromPktSignatureSerializationCase pkt of- Just signatureCase -> putPartialSigforSigningCase signatureCase- Nothing -> error ("putPartialSigforSigning: unsupported signature packet version: " ++ show (pktTag pkt))+ case fromPktSignatureSerializationCase pkt of+ Just signatureCase -> putPartialSigforSigningCase signatureCase+ Nothing ->+ error+ ( "putPartialSigforSigning: unsupported signature packet version: "+ ++ show (pktTag pkt)+ ) putSigTrailer :: Pkt -> Put putSigTrailer pkt =- case fromPktSignatureSerializationCase pkt of- Just signatureCase -> putSigTrailerCase signatureCase- Nothing -> error "This should never happen (putSigTrailer)"+ case fromPktSignatureSerializationCase pkt of+ Just signatureCase -> putSigTrailerCase signatureCase+ Nothing -> error "This should never happen (putSigTrailer)" putUforSigning :: Pkt -> Put putUforSigning u@(UserIdPkt _) = putUIDforSigning u@@ -138,25 +166,29 @@ putUIDforSigning :: Pkt -> Put putUIDforSigning (UserIdPkt u) = do- putWord8 0xB4- let bs = encodeUtf8 u- putWord32be . fromIntegral . B.length $ bs- putByteString bs+ putWord8 0xB4+ let bs = encodeUtf8 u+ putWord32be . fromIntegral . B.length $ bs+ putByteString bs putUIDforSigning _ = error "This should never happen (putUIDforSigning)" putUAtforSigning :: Pkt -> Put putUAtforSigning (UserAttributePkt us) = do- putWord8 0xD1- let bs = runPut (mapM_ put us)- putWord32be . fromIntegral . BL.length $ bs- putLazyByteString bs+ putWord8 0xD1+ let bs = runPut (mapM_ put us)+ putWord32be . fromIntegral . BL.length $ bs+ putLazyByteString bs putUAtforSigning _ = error "This should never happen (putUAtforSigning)" putSigforSigning :: Pkt -> Put putSigforSigning pkt =- case fromPktSignatureSerializationCase pkt of- Just signatureCase -> putSigforSigningCase signatureCase- Nothing -> error ("putSigforSigning: unsupported signature packet version: " ++ show (pktTag pkt))+ case fromPktSignatureSerializationCase pkt of+ Just signatureCase -> putSigforSigningCase signatureCase+ Nothing ->+ error+ ( "putSigforSigning: unsupported signature packet version: "+ ++ show (pktTag pkt)+ ) putKeyforSigning :: Pkt -> Put putKeyforSigning (PublicKeyPkt pkp) = putKeyForSigning' pkp@@ -164,91 +196,79 @@ putKeyforSigning (SecretKeyPkt pkp _) = putKeyForSigning' pkp putKeyforSigning (SecretSubkeyPkt pkp _) = putKeyForSigning' pkp putKeyforSigning x =- error- ("This should never happen (putKeyforSigning) " ++- show (pktTag x) ++ "/" ++ show x)+ error+ ( "This should never happen (putKeyforSigning) "+ ++ show (pktTag x)+ ++ "/"+ ++ show x+ ) putKeyForSigning' :: SomePKPayload -> Put putKeyForSigning' pkp@(PKPayload V6 _ _ _ _) = do- putWord8 0x9B- let bs = runPut $ put pkp- putWord32be . fromIntegral . BL.length $ bs- putLazyByteString bs+ putWord8 0x9B+ let bs = runPut $ put pkp+ putWord32be . fromIntegral . BL.length $ bs+ putLazyByteString bs putKeyForSigning' pkp = do- putWord8 0x99- let bs = runPut $ put pkp- putWord16be . fromIntegral . BL.length $ bs- putLazyByteString bs+ putWord8 0x99+ let bs = runPut $ put pkp+ putWord16be . fromIntegral . BL.length $ bs+ putLazyByteString bs payloadForSig :: SigType -> PktStreamContext -> ByteString payloadForSig BinarySig state =- case (fromPktEither (lastLD state) :: Either String LiteralData) of- Right ld -> ld ^. literalDataPayload- Left err -> error ("payloadForSig expected literal data packet: " ++ err)+ case (fromPktEither (lastLD state) :: Either String LiteralData) of+ Right ld -> ld ^. literalDataPayload+ Left err -> error ("payloadForSig expected literal data packet: " ++ err) payloadForSig CanonicalTextSig state =- stripTrailingWhitespacePerLine (canonicalizeLineEndings (payloadForSig BinarySig state))+ stripTrailingWhitespacePerLine+ (canonicalizeLineEndings (payloadForSig BinarySig state)) payloadForSig StandaloneSig _ = BL.empty payloadForSig GenericCert state =- kandUPayload (lastPrimaryKey state) (lastUIDorUAt state)+ kandUPayload (lastPrimaryKey state) (lastUIDorUAt state) payloadForSig PersonaCert state = payloadForSig GenericCert state payloadForSig CasualCert state = payloadForSig GenericCert state payloadForSig PositiveCert state = payloadForSig GenericCert state payloadForSig SubkeyBindingSig state =- kandKPayload (lastPrimaryKey state) (lastSubkey state)+ kandKPayload (lastPrimaryKey state) (lastSubkey state) payloadForSig PrimaryKeyBindingSig state =- kandKPayload (lastPrimaryKey state) (lastSubkey state)+ kandKPayload (lastPrimaryKey state) (lastSubkey state) payloadForSig SignatureDirectlyOnAKey state =- runPut (putKeyforSigning (lastPrimaryKey state))+ runPut (putKeyforSigning (lastPrimaryKey state)) payloadForSig KeyRevocationSig state =- payloadForSig SignatureDirectlyOnAKey state+ payloadForSig SignatureDirectlyOnAKey state payloadForSig SubkeyRevocationSig state =- kandKPayload (lastPrimaryKey state) (lastSubkey state)+ kandKPayload (lastPrimaryKey state) (lastSubkey state) payloadForSig CertRevocationSig state =- -- RFC 9580 §5.2.1: 0x30 revokes a UID certification when a UID/UAt is in- -- scope, but when there is no UID/UAt in scope it revokes a direct-key sig- -- (0x1F) and the payload is just the primary key material.- case lastUIDorUAt state of- UserIdPkt _ -> kandUPayload (lastPrimaryKey state) (lastUIDorUAt state)- UserAttributePkt _ -> kandUPayload (lastPrimaryKey state) (lastUIDorUAt state)- _ -> runPut (putKeyforSigning (lastPrimaryKey state))+ -- RFC 9580 §5.2.1: 0x30 revokes a UID certification when a UID/UAt is in+ -- scope, but when there is no UID/UAt in scope it revokes a direct-key sig+ -- (0x1F) and the payload is just the primary key material.+ case lastUIDorUAt state of+ UserIdPkt _ ->+ kandUPayload (lastPrimaryKey state) (lastUIDorUAt state)+ UserAttributePkt _ -> kandUPayload (lastPrimaryKey state) (lastUIDorUAt state)+ _ ->+ runPut (putKeyforSigning (lastPrimaryKey state)) payloadForSig st _ = error ("payloadForSig: unhandled signature type " ++ show st) --- | Like 'payloadForSig' but accepts an explicit 'TextNormalizationMode'--- that controls whether trailing whitespace is stripped for CanonicalTextSig.------ Use 'RFC9580Strict' for inline type 0x01 document signatures.--- Use 'CleartextCompat' (or 'payloadForSig') for cleartext-armored messages.-payloadForSigWith :: TextNormalizationMode -> SigType -> PktStreamContext -> ByteString+{- | Like 'payloadForSig' but accepts an explicit 'TextNormalizationMode'+that controls whether trailing whitespace is stripped for CanonicalTextSig.++Use 'RFC9580Strict' for inline type 0x01 document signatures.+Use 'CleartextCompat' (or 'payloadForSig') for cleartext-armored messages.+-}+payloadForSigWith+ :: TextNormalizationMode+ -> SigType+ -> PktStreamContext+ -> ByteString payloadForSigWith RFC9580Strict CanonicalTextSig state =- canonicalizeLineEndings (payloadForSig BinarySig state)+ canonicalizeLineEndings (payloadForSig BinarySig state) payloadForSigWith _ st state = payloadForSig st state -canonicalizeLineEndings :: ByteString -> ByteString-canonicalizeLineEndings = BL.pack . go . BL.unpack- where- go [] = []- go (0x0d:0x0a:rest) = 0x0d : 0x0a : go rest- go (0x0d:rest) = 0x0d : 0x0a : go rest- go (0x0a:rest) = 0x0d : 0x0a : go rest- go (w:rest) = w : go rest--stripTrailingWhitespacePerLine :: ByteString -> ByteString-stripTrailingWhitespacePerLine = BL.pack . go [] . BL.unpack- where- go lineRev [] = reverseTrimmed lineRev- go lineRev (0x0d:0x0a:rest) =- reverseTrimmed lineRev ++ [0x0d, 0x0a] ++ go [] rest- go lineRev (w:rest) = go (w : lineRev) rest-- reverseTrimmed :: [Word8] -> [Word8]- reverseTrimmed = reverse . dropWhile isTrailingWhitespace-- isTrailingWhitespace :: Word8 -> Bool- isTrailingWhitespace w = w == 0x20 || w == 0x09- kandUPayload :: Pkt -> Pkt -> ByteString kandUPayload k u = runPut (sequence_ [putKeyforSigning k, putUforSigning u]) kandKPayload :: Pkt -> Pkt -> ByteString kandKPayload k1 k2 =- runPut (sequence_ [putKeyforSigning k1, putKeyforSigning k2])+ runPut (sequence_ [putKeyforSigning k1, putKeyforSigning k2])
Codec/Encryption/OpenPGP/SignatureQualities.hs view
@@ -3,87 +3,71 @@ -- This software is released under the terms of the Expat license. -- (See the LICENSE file). -{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}- module Codec.Encryption.OpenPGP.SignatureQualities- ( sigType- , sigPKA- , sigHA- , sigCT- , signatureSubpacketListsKnown- , signatureHashedSubpacketsKnown- ) where+ ( sigType+ , sigPKA+ , sigHA+ , sigCT+ , signatureSubpacketListsKnown+ , signatureHashedSubpacketsKnown+ ) where +import Control.Applicative ((<|>))+import Control.Lens (preview, _1) import Data.List (find) import Codec.Encryption.OpenPGP.Ontology (isSigCreationTime) import Codec.Encryption.OpenPGP.Types -data KnownSignaturePayload where- KnownSignaturePayloadV3 :: SignaturePayloadV 'SigPayloadV3 -> KnownSignaturePayload- KnownSignaturePayloadV4 :: SignaturePayloadV 'SigPayloadV4 -> KnownSignaturePayload- KnownSignaturePayloadV6 :: SignaturePayloadV 'SigPayloadV6 -> KnownSignaturePayload--knownSignaturePayload :: SignaturePayload -> Maybe KnownSignaturePayload-knownSignaturePayload sig =- case toSomeSignaturePayload sig of- SomeSignaturePayload (payload@SigPayloadV3Data {}) ->- Just (KnownSignaturePayloadV3 payload)- SomeSignaturePayload (payload@SigPayloadV4Data {}) ->- Just (KnownSignaturePayloadV4 payload)- SomeSignaturePayload (payload@SigPayloadV6Data {}) ->- Just (KnownSignaturePayloadV6 payload)- SomeSignaturePayload (SigPayloadOtherData _ _) -> Nothing- sigType :: SignaturePayload -> Maybe SigType sigType sig =- case knownSignaturePayload sig of- Just (KnownSignaturePayloadV3 (SigPayloadV3Data st _ _ _ _ _ _)) -> Just st- Just (KnownSignaturePayloadV4 (SigPayloadV4Data st _ _ _ _ _ _)) -> Just st- Just (KnownSignaturePayloadV6 (SigPayloadV6Data st _ _ _ _ _ _ _)) -> Just st- Nothing -> Nothing+ preview (_SigV3 . _1) sig+ <|> preview (_SigV4 . _1) sig+ <|> preview (_SigV6 . _1) sig sigPKA :: SignaturePayload -> Maybe PubKeyAlgorithm sigPKA sig =- case knownSignaturePayload sig of- Just (KnownSignaturePayloadV3 (SigPayloadV3Data _ _ _ pka _ _ _)) -> Just pka- Just (KnownSignaturePayloadV4 (SigPayloadV4Data _ pka _ _ _ _ _)) -> Just pka- Just (KnownSignaturePayloadV6 (SigPayloadV6Data _ pka _ _ _ _ _ _)) -> Just pka- Nothing -> Nothing+ case preview _SigV3 sig of+ Just (_st, _ts, _ekid, pka, _ha, _w16, _mpis) -> Just pka+ _ -> case preview _SigV4 sig of+ Just (_st, pka, _ha, _hsps, _usps, _w16, _mpis) -> Just pka+ _ -> case preview _SigV6 sig of+ Just (_st, pka, _ha, _salt, _hsps, _usps, _w16, _mpis) -> Just pka+ _ -> Nothing sigHA :: SignaturePayload -> Maybe HashAlgorithm sigHA sig =- case knownSignaturePayload sig of- Just (KnownSignaturePayloadV3 (SigPayloadV3Data _ _ _ _ ha _ _)) -> Just ha- Just (KnownSignaturePayloadV4 (SigPayloadV4Data _ _ ha _ _ _ _)) -> Just ha- Just (KnownSignaturePayloadV6 (SigPayloadV6Data _ _ ha _ _ _ _ _)) -> Just ha- Nothing -> Nothing+ case preview _SigV3 sig of+ Just (_st, _ts, _ekid, _pka, ha, _w16, _mpis) -> Just ha+ _ -> case preview _SigV4 sig of+ Just (_st, _pka, ha, _hsps, _usps, _w16, _mpis) -> Just ha+ _ -> case preview _SigV6 sig of+ Just (_st, _pka, ha, _salt, _hsps, _usps, _w16, _mpis) -> Just ha+ _ -> Nothing sigCT :: SignaturePayload -> Maybe ThirtyTwoBitTimeStamp sigCT sig =- case knownSignaturePayload sig of- Just (KnownSignaturePayloadV3 (SigPayloadV3Data _ ct _ _ _ _ _)) -> Just ct- Just (KnownSignaturePayloadV4 (SigPayloadV4Data _ _ _ hsubs _ _ _)) ->- fmap- (\(SigSubPacket _ (SigCreationTime i)) -> i)- (find isSigCreationTime hsubs)- Just (KnownSignaturePayloadV6 (SigPayloadV6Data _ _ _ _ hsubs _ _ _)) ->- fmap- (\(SigSubPacket _ (SigCreationTime i)) -> i)- (find isSigCreationTime hsubs)- Nothing -> Nothing+ case preview _SigV3 sig of+ Just (_st, ct, _ekid, _pka, _ha, _w16, _mpis) -> Just ct+ _ -> case preview _SigV4 sig of+ Just (_st, _pka, _ha, hsubs, _usps, _w16, _mpis) ->+ fmap+ (\(SigSubPacket _ (SigCreationTime i)) -> i)+ (find isSigCreationTime hsubs)+ _ -> case preview _SigV6 sig of+ Just (_st, _pka, _ha, _salt, hsubs, _usps, _w16, _mpis) ->+ fmap+ (\(SigSubPacket _ (SigCreationTime i)) -> i)+ (find isSigCreationTime hsubs)+ _ -> Nothing -signatureSubpacketListsKnown ::- SignaturePayload -> Maybe ([SigSubPacket], [SigSubPacket])-signatureSubpacketListsKnown sigPayload =- case knownSignaturePayload sigPayload of- Just (KnownSignaturePayloadV4 (SigPayloadV4Data _ _ _ hashed unhashed _ _)) ->- Just (hashed, unhashed)- Just (KnownSignaturePayloadV6 (SigPayloadV6Data _ _ _ _ hashed unhashed _ _)) ->- Just (hashed, unhashed)- _ -> Nothing+signatureSubpacketListsKnown+ :: SignaturePayload -> Maybe ([SigSubPacket], [SigSubPacket])+signatureSubpacketListsKnown sig =+ (preview _SigV4 sig >>= \(_, _, _, h, u, _, _) -> Just (h, u))+ <|> (preview _SigV6 sig >>= \(_, _, _, _, h, u, _, _) -> Just (h, u)) -signatureHashedSubpacketsKnown :: SignaturePayload -> Maybe [SigSubPacket]+signatureHashedSubpacketsKnown+ :: SignaturePayload -> Maybe [SigSubPacket] signatureHashedSubpacketsKnown sigPayload =- fst <$> signatureSubpacketListsKnown sigPayload+ fst <$> signatureSubpacketListsKnown sigPayload
Codec/Encryption/OpenPGP/Signatures.hs view
@@ -13,7 +13,8 @@ {-# LANGUAGE UndecidableInstances #-} module Codec.Encryption.OpenPGP.Signatures- ( SignError (..)+ ( -- * Verification+ SignError (..) , renderSignError , CertificationState (..) , certificationStateAt@@ -106,6 +107,10 @@ , issuer , issuerFP )+import Codec.Encryption.OpenPGP.Internal.Whitespace+ ( canonicalizeLineEndings+ , stripTrailingWhitespacePerLine+ ) import Codec.Encryption.OpenPGP.Ontology ( isCertRevocationSig , isRevocationKeySSP@@ -672,6 +677,7 @@ , _tkSubs = verifiedTypedSubkeys } +{-# DEPRECATED verifyUnknownTKWith "Use verifyTKWith instead" #-} verifyUnknownTKWith :: ( Pkt -> PktStreamContext@@ -1523,29 +1529,6 @@ normalizePayloadForSigTypeWith CleartextCompat st = normalizePayloadForSigType st normalizePayloadForSigTypeWith RFC9580Strict CanonicalTextSig = canonicalizeLineEndings normalizePayloadForSigTypeWith RFC9580Strict _ = id--canonicalizeLineEndings :: ByteString -> ByteString-canonicalizeLineEndings = BL.pack . go . BL.unpack- where- go [] = []- go (0x0d : 0x0a : rest) = 0x0d : 0x0a : go rest- go (0x0d : rest) = 0x0d : 0x0a : go rest- go (0x0a : rest) = 0x0d : 0x0a : go rest- go (w : rest) = w : go rest--stripTrailingWhitespacePerLine :: ByteString -> ByteString-stripTrailingWhitespacePerLine = BL.pack . go [] . BL.unpack- where- go lineRev [] = reverseTrimmed lineRev- go lineRev (0x0d : 0x0a : rest) =- reverseTrimmed lineRev ++ [0x0d, 0x0a] ++ go [] rest- go lineRev (w : rest) = go (w : lineRev) rest-- reverseTrimmed :: [Word8] -> [Word8]- reverseTrimmed = reverse . dropWhile isTrailingWhitespace-- isTrailingWhitespace :: Word8 -> Bool- isTrailingWhitespace w = w == 0x20 || w == 0x09 hashWithSHA512 :: B.ByteString -> B.ByteString hashWithSHA512 = BA.convert . hashWith CHA.SHA512
Codec/Encryption/OpenPGP/Subpackets.hs view
@@ -179,6 +179,8 @@ payloadType (IssuerFingerprint {}) = "IssuerFingerprint" payloadType (UserDefinedSigSub _ _) = "UserDefinedSigSub" payloadType (OtherSigSub _ _) = "OtherSigSub"+ payloadType (IntendedRecipient _ _) = "IntendedRecipient"+ payloadType (PreferredAEADCiphersuites _) = "PreferredAEADCiphersuites" -- | RFC9580 §5.2.3.5 lists which subpacket types can be marked critical canBeCritical :: SigSubPacketPayload -> Bool
Codec/Encryption/OpenPGP/Types/Internal/Base.hs view
@@ -3,7 +3,6 @@ -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}@@ -54,6 +53,10 @@ , mkWireRepRefWithLength , mkWireRepRef , SignaturePayload (..)+ , _SigV3+ , _SigV4+ , _SigV6+ , _SigVOther , Fingerprint (..) , SessionKey (..) , SigType (..)@@ -117,7 +120,7 @@ import Control.Applicative ((<|>)) import Control.Arrow ((***))-import Control.Lens (Wrapped, makeLenses, op)+import Control.Lens (Wrapped, makeLenses, makePrisms, op) import Control.Monad (mzero) import Data.Aeson (object, (.=)) import qualified Data.Aeson as A@@ -1671,6 +1674,8 @@ instance A.FromJSON SigSubPacket $(makeLenses ''SigSubPacket)++$(makePrisms ''SignaturePayload) -- FIXME: the SubpacketList type and associated functions should be moved into a separate module
Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs view
@@ -273,6 +273,7 @@ compareFields (UserAttributePkt us1) (UserAttributePkt us2) = compare us1 us2 compareFields (SymEncIntegrityProtectedDataPkt seipd1) (SymEncIntegrityProtectedDataPkt seipd2) = compare seipd1 seipd2 compareFields (ModificationDetectionCodePkt bs1) (ModificationDetectionCodePkt bs2) = compare bs1 bs2+ compareFields (PaddingPkt bs1) (PaddingPkt bs2) = compare bs1 bs2 compareFields (OtherPacketPkt t1 bs1) (OtherPacketPkt t2 bs2) = compare t1 t2 <> compare bs1 bs2 compareFields (BrokenPacketPkt s1 t1 bs1) (BrokenPacketPkt s2 t2 bs2) = compare s1 s2 <> compare t1 t2 <> compare bs1 bs2
Data/Conduit/OpenPGP/Filter.hs view
@@ -2,31 +2,47 @@ -- Copyright © 2014-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} module Data.Conduit.OpenPGP.Filter- ( conduitPktFilter- , conduitPktWithExtraFilter- , conduitTKFilter- , FilterPredicates(..)- ) where+ ( conduitPktFilter+ , conduitPktWithExtraFilter+ , conduitTKFilter+ , FilterPredicates (..)+ , runPredicate+ ) where import Control.Monad.Trans.Reader (Reader, runReader) import Data.Conduit (ConduitT) import qualified Data.Conduit.List as CL+import Data.Typeable (Typeable, eqT, (:~:) (Refl)) import Data.Void (Void) import Codec.Encryption.OpenPGP.Types data FilterPredicates r a- = RTKFilterPredicate (Reader TKUnknown Bool) -- ^ fp for transferable keys- | RPFilterPredicate (Reader Pkt Bool) -- ^ fp for context-less packets- | RFilterPredicate (Reader a Bool) -- ^ generic filter predicate- | RPairFilterPredicate (Reader (r, a) Bool) -- ^ generic filter predicate with additional context+ = -- | fp for transferable keys+ RTKFilterPredicate (Reader TKUnknown Bool)+ | -- | fp for context-less packets+ RPFilterPredicate (Reader Pkt Bool)+ | -- | generic filter predicate+ RFilterPredicate (Reader a Bool)+ | -- | generic filter predicate with additional context+ RPairFilterPredicate (Reader (r, a) Bool)+{-# DEPRECATED RTKFilterPredicate "Use RFilterPredicate with SomeTK instead" #-} -conduitPktFilter ::- Monad m => FilterPredicates Void Pkt -> ConduitT Pkt Pkt m ()+runPredicate+ :: forall r a. Typeable a => FilterPredicates r a -> a -> Bool+runPredicate (RTKFilterPredicate e) = case eqT @a @TKUnknown of+ Just Refl -> runReader e+ Nothing -> const False+runPredicate (RFilterPredicate e) = runReader e+runPredicate _ = const False++conduitPktFilter+ :: Monad m => FilterPredicates Void Pkt -> ConduitT Pkt Pkt m () conduitPktFilter = CL.filter . superPredicate superPredicate :: FilterPredicates Void Pkt -> Pkt -> Bool@@ -34,15 +50,23 @@ superPredicate (RFilterPredicate e) p = runReader e p superPredicate _ _ = False -- do not match incorrect type of packet -conduitTKFilter :: Monad m => FilterPredicates Void TKUnknown -> ConduitT TKUnknown TKUnknown m ()+{-# DEPRECATED+ conduitTKFilter+ "Use (CL.filter . runPredicate) with RFilterPredicate instead"+ #-}+conduitTKFilter+ :: Monad m+ => FilterPredicates Void TKUnknown+ -> ConduitT TKUnknown TKUnknown m () conduitTKFilter = CL.filter . superTKPredicate -superTKPredicate :: FilterPredicates Void TKUnknown -> TKUnknown -> Bool+superTKPredicate+ :: FilterPredicates Void TKUnknown -> TKUnknown -> Bool superTKPredicate (RTKFilterPredicate e) = runReader e superTKPredicate (RFilterPredicate e) = runReader e -conduitPktWithExtraFilter ::- Monad m => r -> FilterPredicates r Pkt -> ConduitT Pkt Pkt m ()+conduitPktWithExtraFilter+ :: Monad m => r -> FilterPredicates r Pkt -> ConduitT Pkt Pkt m () conduitPktWithExtraFilter extra = CL.filter . superPairPredicate extra superPairPredicate :: r -> FilterPredicates r a -> a -> Bool
Data/Conduit/OpenPGP/Keyring.hs view
@@ -4,6 +4,7 @@ -- (See the LICENSE file). {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} module Data.Conduit.OpenPGP.Keyring ( TypedTKConduitError (..)@@ -36,7 +37,7 @@ import qualified Data.Conduit.List as CL import Data.IxSet.Typed (empty, insert) import Data.List (find)-import Data.Maybe (maybeToList)+import Data.Maybe (mapMaybe, maybeToList) import qualified Data.Set as Set import Data.Text (Text) import Data.Time.Clock (UTCTime)@@ -340,34 +341,48 @@ signatureHasAuthKeyFlag (latestEffectiveBindingSignatureAt validationTime sigs) -latestEffectiveBindingSignatureAt- :: UTCTime -> [SignaturePayload] -> Maybe SignaturePayload-latestEffectiveBindingSignatureAt validationTime sigs =+latestEffectiveSignatureAt+ :: (SignaturePayload -> Bool)+ -> UTCTime+ -> [SignaturePayload]+ -> Maybe SignaturePayload+latestEffectiveSignatureAt typePred validationTime sigs = snd <$> newestByCreationTime [ (createdAt, sig) | sig <- sigs- , isSubkeyBindingSig sig+ , typePred sig , signatureEffectiveAt validationTime sig , createdAt <- maybeToList (signatureCreationTime sig) ] +latestEffectiveBindingSignatureAt+ :: UTCTime -> [SignaturePayload] -> Maybe SignaturePayload+latestEffectiveBindingSignatureAt =+ latestEffectiveSignatureAt isSubkeyBindingSig+ latestEffectiveCertificationAt :: UTCTime -> [SignaturePayload] -> Maybe SignaturePayload-latestEffectiveCertificationAt validationTime sigs =- snd- <$> newestByCreationTime- [ (createdAt, sig)- | sig <- sigs- , isCertificationSig sig- , signatureEffectiveAt validationTime sig- , createdAt <- maybeToList (signatureCreationTime sig)- ]+latestEffectiveCertificationAt =+ latestEffectiveSignatureAt isCertificationSig signatureHasAuthKeyFlag :: SignaturePayload -> Bool signatureHasAuthKeyFlag sig = Set.member AuthKey (signatureKeyFlags sig) +foldHasSubPacket+ :: (SigSubPacket -> Maybe b)+ -> (b -> Bool)+ -> SignaturePayload+ -> Bool+foldHasSubPacket extract predicate sig =+ any+ predicate+ ( mapMaybe+ extract+ (maybe [] id (signatureHashedSubpacketsKnown sig))+ )+ signatureKeyFlags :: SignaturePayload -> Set.Set KeyFlag signatureKeyFlags sig = foldr@@ -381,14 +396,12 @@ signatureMarksPrimaryUID :: SignaturePayload -> Bool signatureMarksPrimaryUID sig =- any- ( \sp ->- case sp of- SigSubPacket _ (PrimaryUserId True) -> True- _ -> False- )- (maybe [] id (signatureHashedSubpacketsKnown sig))+ foldHasSubPacket+ (\case SigSubPacket _ (PrimaryUserId p) -> Just p; _ -> Nothing)+ id+ sig +{-# DEPRECATED conduitToTKsEither "Use conduitToSomeTKsEither instead" #-} conduitToTKsEither :: Monad m => ConduitT@@ -398,6 +411,10 @@ () conduitToTKsEither = conduitToTKsEither' True +{-# DEPRECATED+ conduitToTKsDroppingEither+ "Use conduitToSomeTKsDroppingEither instead"+ #-} conduitToTKsDroppingEither :: Monad m => ConduitT
hOpenPGP.cabal view
@@ -1,6 +1,6 @@ Cabal-version: 3.4 Name: hOpenPGP-Version: 3.1+Version: 3.1.1 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@@ -178,27 +178,27 @@ common deps build-depends: aeson >= 2.0 && < 3 , attoparsec- , base > 4.9 && < 5+ , base >= 4.9 && < 5 , base16-bytestring , bifunctors- , bytestring+ , bytestring >= 0.11.3.0 , binary >= 0.6.4.0 , binary-conduit >= 1.3 , bz2 , conduit >= 1.3.0 , conduit-extra >= 1.1- , containers+ , containers >= 0.6.0.1 , crypto-cipher-types , errors , hashable >= 1.3.4 && <1.6 , incremental-parser >= 0.5.1 , ixset-typed , lens >= 3.0- , monad-loops+ , monad-loops >= 0.4 , nettle , network-uri >= 2.6 , prettyprinter >= 1.7.0- , resourcet > 0.4+ , resourcet >= 0.4 , split , text , time >= 1.1@@ -248,6 +248,7 @@ , Codec.Encryption.OpenPGP.Internal.Crypton , Codec.Encryption.OpenPGP.Internal.HOBlockCipher , Codec.Encryption.OpenPGP.Internal.RFC7253OCB+ , Codec.Encryption.OpenPGP.Internal.Whitespace , Codec.Encryption.OpenPGP.Types.Internal.Base , Codec.Encryption.OpenPGP.Types.Internal.CryptonNewtypes , Codec.Encryption.OpenPGP.Types.Internal.PKITypes@@ -332,4 +333,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hOpenPGP.git- tag: v3.1+ tag: v3.1.1
tests/Tests/Encryption.hs view
@@ -162,8 +162,6 @@ import Data.Conduit.OpenPGP.Keyring ( conduitToSomeTKsDroppingEither , conduitToSomeTKsEither- , conduitToTKsDroppingEither- , conduitToTKsEither ) import Tests.Common ( aesKeyWrapRFC3394ForTest@@ -531,13 +529,6 @@ 1 ) , testCase- "conduitToTKsDroppingEither"- ( testConduitOutputLength- "pubring.gpg"- (cgp DC..| conduitToTKsDroppingEither)- 4- )- , testCase "conduitToSomeTKsDroppingEither" ( testConduitOutputLength "pubring.gpg"@@ -545,15 +536,9 @@ 4 ) , testCase- "conduitToTKsEither reports parse failures"- testConduitToTKsEitherReportsParseFailure- , testCase "conduitToSomeTKsEither reports parse failures" testConduitToSomeTKsEitherReportsParseFailure , testCase- "conduitToTKsDroppingEither reports parse failures"- testConduitToTKsDroppingEitherReportsParseFailure- , testCase "conduitToSomeTKsDroppingEither reports parse failures" testConduitToSomeTKsDroppingEitherReportsParseFailure ]@@ -951,30 +936,6 @@ DC.runConduitRes $ CB.sourceFile ("tests/data/" ++ fpr) DC..| c DC..| counter assertEqual ("expected length " ++ show target) target len--testConduitToTKsEitherReportsParseFailure :: Assertion-testConduitToTKsEitherReportsParseFailure = do- results <-- DC.runConduitRes $- CB.sourceFile "tests/data/uncompressed-ops-rsa.gpg"- DC..| conduitGet get- DC..| conduitToTKsEither- DC..| CL.consume- assertBool- "conduitToTKsEither should report parse failures for non-key packet streams"- (any (either (const True) (const False)) results)--testConduitToTKsDroppingEitherReportsParseFailure :: Assertion-testConduitToTKsDroppingEitherReportsParseFailure = do- results <-- DC.runConduitRes $- CB.sourceFile "tests/data/uncompressed-ops-rsa.gpg"- DC..| conduitGet get- DC..| conduitToTKsDroppingEither- DC..| CL.consume- assertBool- "conduitToTKsDroppingEither should report parse failures for non-key packet streams"- (any (either (const True) (const False)) results) testConduitToSomeTKsEitherReportsParseFailure :: Assertion testConduitToSomeTKsEitherReportsParseFailure = do
tests/Tests/MessageAndArmor.hs view
@@ -27,6 +27,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Either (isLeft, isRight)+import Data.Foldable (forM_) import Data.List (isInfixOf) import qualified Data.List.NonEmpty as NE import Test.Tasty (TestTree, testGroup)@@ -51,6 +52,7 @@ , fingerprint ) 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.Message import Codec.Encryption.OpenPGP.Policy@@ -251,6 +253,9 @@ , testCase "text normalization modes (RFC9580Strict vs CleartextCompat)" testTextNormalizationModes+ , testCase+ "streaming whitespace functions match strict variants"+ testStreamingWhitespaceMatchesStrict ] , testGroup "ASCII armor fixture group"@@ -1772,6 +1777,89 @@ assertBool "CleartextCompat and RFC9580Strict produce different signatures for payloads with trailing whitespace" (sigCompat /= sigStrict)++testStreamingWhitespaceMatchesStrict :: Assertion+testStreamingWhitespaceMatchesStrict = do+ let inputs =+ [ BL.pack [0x0d, 0x0a, 0x0a, 0x0d, 0x0d, 0x0a]+ , BL.pack [0x0a, 0x0d, 0x0d, 0x0a]+ , BL.pack [0x20, 0x09, 0x0d, 0x0a, 0x20, 0x09]+ , BL.empty+ , BL.singleton 0x0d+ , BL.singleton 0x0a+ , BL.fromChunks [B.pack [0x0a], B.pack [0x0d], B.pack [0x0d, 0x0a]]+ , BL.fromChunks [B.pack [0x0d], B.pack [0x0a], B.pack [0x0a]]+ , BL.fromChunks+ [B.pack [0x0d, 0x0a], B.pack [0x20, 0x09, 0x0d, 0x0a]]+ , BL.fromChunks [B.pack [0x20, 0x09, 0x0d], B.pack [0x0a]]+ ]+ forM_ inputs $ \bs -> do+ let chunks = BL.toChunks bs+ go (st, acc) c =+ let (st', out) = WS.canonicalizeLineEndingsChunk st c+ in (st', out : acc)+ (st1, out1) = foldl' go (WS.CRState False, []) chunks+ finalOut = WS.canonicalizeLineEndingsFlush st1+ chunkResult = BL.fromChunks $ reverse $ finalOut : out1+ assertEqual+ ( "canonicalizeLineEndingsChunk+Flush matches canonicalizeLineEndings for "+ ++ show (BL.unpack bs)+ )+ (WS.canonicalizeLineEndings bs)+ chunkResult++ let go2 (st, acc) c =+ let (st', out) = WS.stripTrailingWhitespacePerLineChunk st c+ in (st', out : acc)+ (st2, out2) = foldl' go2 (WS.StripWSState False B.empty, []) chunks+ wsFinalOut = WS.stripTrailingWhitespacePerLineFlush st2+ wsChunkResult = BL.fromChunks $ reverse $ wsFinalOut : out2+ assertEqual+ ( "stripTrailingWhitespacePerLineChunk+Flush matches stripTrailingWhitespacePerLine for "+ ++ show (BL.unpack bs)+ )+ (WS.stripTrailingWhitespacePerLine bs)+ wsChunkResult++ let chunks = BL.toChunks $ BL.pack [0x0d, 0x0a, 0x0a, 0x0d, 0x0d, 0x0a]+ go (st, acc) c =+ let (st', out) = WS.canonicalizeLineEndingsChunk st c+ in (st', out : acc)+ (st1, out1) = foldl' go (WS.CRState False, []) chunks+ finalOut = WS.canonicalizeLineEndingsFlush st1+ chunkResult = BL.fromChunks $ reverse $ finalOut : out1+ assertEqual+ "canonicalizeLineEndingsChunk+Flush matches canonicalizeLineEndings"+ ( WS.canonicalizeLineEndings $+ BL.pack [0x0d, 0x0a, 0x0a, 0x0d, 0x0d, 0x0a]+ )+ chunkResult++ let wsInput = BL.pack [0x20, 0x09, 0x0d, 0x0a, 0x20, 0x09, 0x0d, 0x0a]+ wsChunks = BL.toChunks wsInput+ go2 (st, acc) c =+ let (st', out) = WS.stripTrailingWhitespacePerLineChunk st c+ in (st', out : acc)+ (st2, out2) = foldl' go2 (WS.StripWSState False B.empty, []) wsChunks+ wsFinalOut = WS.stripTrailingWhitespacePerLineFlush st2+ wsChunkResult = BL.fromChunks $ reverse $ wsFinalOut : out2+ assertEqual+ "stripTrailingWhitespacePerLineChunk+Flush matches stripTrailingWhitespacePerLine"+ (WS.stripTrailingWhitespacePerLine wsInput)+ wsChunkResult++ let wsInput2 = BL.pack [0x20, 0x09, 0x0d, 0x0a, 0x20, 0x09, 0x0d, 0x0a]+ wsChunks2 = BL.toChunks wsInput2+ go3 (st, acc) c =+ let (st', out) = WS.stripTrailingWhitespacePerLineChunk st c+ in (st', out : acc)+ (st3, out3) = foldl' go3 (WS.StripWSState False B.empty, []) wsChunks2+ wsFinalOut3 = WS.stripTrailingWhitespacePerLineFlush st3+ wsChunkResult3 = BL.fromChunks $ reverse $ wsFinalOut3 : out3+ assertEqual+ "stripTrailingWhitespacePerLineChunk+Flush matches stripTrailingWhitespacePerLine on combined input"+ (WS.stripTrailingWhitespacePerLine wsInput2)+ wsChunkResult3 testCanonicalTextSignatureSigningPaths :: Assertion testCanonicalTextSignatureSigningPaths = do
tests/Tests/Properties.hs view
@@ -2,273 +2,353 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} module Tests.Properties (propertiesTests) where -import Codec.Encryption.OpenPGP.Encrypt (canonicalizePKESKRecipientId)-import Codec.Encryption.OpenPGP.Policy (OpenPGPPolicy(..), OpenPGPRFC(RFC4880), defaultPolicy, policyForRFC)-import Codec.Encryption.OpenPGP.KeyringParser (parseTKsWithWireRep)-import Codec.Encryption.OpenPGP.SecretKey (decryptPrivateKey, encryptPrivateKey)-import Codec.Encryption.OpenPGP.Serialize (parsePktsEither, parsePktsWithWireRep)-import Codec.Encryption.OpenPGP.Types import Control.Exception (SomeException, try)+import Control.Lens (preview) import Data.Binary (get, put) import Data.Binary.Put (runPut) import qualified Data.ByteString.Lazy as BL import qualified Data.Conduit as DC import qualified Data.Conduit.List as CL+import Data.Maybe (isNothing) import Data.Word (Word8) import Test.Tasty (TestTree, localOption, testGroup) import qualified Test.Tasty.QuickCheck as QC++import Codec.Encryption.OpenPGP.Encrypt+ ( canonicalizePKESKRecipientId+ )+import Codec.Encryption.OpenPGP.KeyringParser+ ( parseTKsWithWireRep+ )+import Codec.Encryption.OpenPGP.Policy+ ( OpenPGPPolicy (..)+ , OpenPGPRFC (RFC4880)+ , defaultPolicy+ , policyForRFC+ )+import Codec.Encryption.OpenPGP.SecretKey+ ( decryptPrivateKey+ , encryptPrivateKey+ )+import Codec.Encryption.OpenPGP.Serialize+ ( parsePktsEither+ , parsePktsWithWireRep+ )+import Codec.Encryption.OpenPGP.Types import Tests.Common- ( collectSecretKeyInfos- , conduitDecryptWithPKESKContext- , loadSEIPDv2FixtureWithV4Secret- , loadV4EncryptedSecretKeyFixtureForProperty- , loadV6UnencryptedSecretKeyFixtureForProperty- , prependUnusableLatestPKESK- , readFixtureLazy- , reorderPrecedingPKESKs- , reverseIf- , runGet- , selectRecipientKeyInfo- )+ ( collectSecretKeyInfos+ , conduitDecryptWithPKESKContext+ , loadSEIPDv2FixtureWithV4Secret+ , loadV4EncryptedSecretKeyFixtureForProperty+ , loadV6UnencryptedSecretKeyFixtureForProperty+ , prependUnusableLatestPKESK+ , readFixtureLazy+ , reorderPrecedingPKESKs+ , reverseIf+ , runGet+ , selectRecipientKeyInfo+ ) propertiesTests :: TestTree propertiesTests = testGroup "Properties" [qcProps] qcProps :: TestTree qcProps =- testGroup- "(checked by QuickCheck)"- [ QC.testProperty "PKESKv3 packet serialization-deserialization" $ \pkesk ->- Right (pkesk :: PKESK 'PKESKV3) == runGet get (runPut (put pkesk))- , QC.testProperty "PKESKv6 packet serialization-deserialization" $ \pkesk ->- Right (pkesk :: PKESK 'PKESKV6) == runGet get (runPut (put pkesk))- , QC.testProperty "Signature packet serialization-deserialization" $ \sig ->- (case _signaturePayload (sig :: Signature) of- SigVOther _ _ -> False- _ -> True) QC.==>- Right (sig :: Signature) == runGet get (runPut (put sig))- , QC.testProperty "UserId packet serialization-deserialization" $ \uid ->- Right (uid :: UserId) == runGet get (runPut (put uid))- , QC.testProperty "decryptPrivateKey (encryptPrivateKey sk pw) pw equivalence" $ \passphraseNE ->- QC.ioProperty $ do- fixture <- loadV6UnencryptedSecretKeyFixtureForProperty- case fixture of- Left err -> pure (QC.counterexample err False)- Right (pkp, ska, expectedSKey) -> do- let passphraseChars = (QC.getNonEmpty passphraseNE :: String)- passphrase = BL.pack (map (fromIntegral . fromEnum) passphraseChars)- encryptedResult <- encryptPrivateKey defaultPolicy pkp ska passphrase- pure $- case encryptedResult of- Left err ->- QC.counterexample ("encryptPrivateKey failed: " ++ err) False- Right encryptedSKA ->- case decryptPrivateKey (pkp, encryptedSKA) passphrase of- Left err ->- QC.counterexample ("decryptPrivateKey failed: " ++ err) False- Right (SUUnencrypted skey _) ->- QC.counterexample- "secret key material changed across encrypt/decrypt roundtrip"- (skey == expectedSKey)- Right other ->- QC.counterexample- ("expected SUUnencrypted after decrypting encrypted key, got: " ++- show other)- False- , localOption- (QC.QuickCheckTests 5)- (QC.testProperty "decryptPrivateKey (encryptPrivateKey v4sk pw) pw equivalence" $- QC.ioProperty $ do- fixture <- loadV4EncryptedSecretKeyFixtureForProperty- case fixture of- Left err -> pure (QC.counterexample err False)- Right (pkp, ska, expectedSKey, passphrase) -> do- let legacyOverridePolicy :: OpenPGPPolicy- legacyOverridePolicy =- (policyForRFC RFC4880)- { policySecretKeyProtection = policySecretKeyProtection defaultPolicy- }- encryptedResult <- encryptPrivateKey legacyOverridePolicy pkp ska passphrase- pure $- case encryptedResult of- Left err ->- QC.counterexample ("encryptPrivateKey failed under legacy override policy: " ++ err) False- Right encryptedSKA ->- case decryptPrivateKey (pkp, encryptedSKA) passphrase of- Left err ->- QC.counterexample ("decryptPrivateKey failed: " ++ err) False- Right (SUUnencrypted skey _) ->- QC.counterexample- "v4 secret key material changed across encrypt/decrypt roundtrip"- (skey == expectedSKey)- Right other ->- QC.counterexample- ("expected SUUnencrypted after decrypting v4 encrypted key, got: " ++- show other)- False)- , QC.testProperty- "canonicalizePKESKRecipientId idempotence on valid v4/v6 recipient ids"- propertyCanonicalizePKESKRecipientIdIdempotent- , localOption- (QC.QuickCheckTests 10)- (QC.testProperty- "canonicalizeTKStructuredWithWireRep is stable across packet/sig reordering"- propertyCanonicalizeTKStructuredStableAcrossReordering)- , localOption- (QC.QuickCheckTests 1)- (QC.testProperty- "recipient selection remains decryptable with extra unusable PKESK candidates"- propertyRecipientSelectionMonotonicWithUnusableCandidates)- , QC.testProperty- "parsePktsEither does not accept truncated packet streams as intact packets"- propertyParsePktsEitherRejectsTruncatedPacketStream- ]+ testGroup+ "(checked by QuickCheck)"+ [ QC.testProperty "PKESKv3 packet serialization-deserialization" $ \pkesk ->+ Right (pkesk :: PKESK 'PKESKV3)+ == runGet get (runPut (put pkesk))+ , QC.testProperty "PKESKv6 packet serialization-deserialization" $ \pkesk ->+ Right (pkesk :: PKESK 'PKESKV6)+ == runGet get (runPut (put pkesk))+ , QC.testProperty "Signature packet serialization-deserialization" $ \sig ->+ ( isNothing+ (preview _SigVOther (_signaturePayload (sig :: Signature)))+ )+ QC.==> Right (sig :: Signature) == runGet get (runPut (put sig))+ , QC.testProperty "UserId packet serialization-deserialization" $ \uid ->+ Right (uid :: UserId) == runGet get (runPut (put uid))+ , QC.testProperty+ "decryptPrivateKey (encryptPrivateKey sk pw) pw equivalence"+ $ \passphraseNE ->+ QC.ioProperty $ do+ fixture <- loadV6UnencryptedSecretKeyFixtureForProperty+ case fixture of+ Left err -> pure (QC.counterexample err False)+ Right (pkp, ska, expectedSKey) -> do+ let passphraseChars = (QC.getNonEmpty passphraseNE :: String)+ passphrase = BL.pack (map (fromIntegral . fromEnum) passphraseChars)+ encryptedResult <-+ encryptPrivateKey defaultPolicy pkp ska passphrase+ pure $+ case encryptedResult of+ Left err ->+ QC.counterexample ("encryptPrivateKey failed: " ++ err) False+ Right encryptedSKA ->+ case decryptPrivateKey (pkp, encryptedSKA) passphrase of+ Left err ->+ QC.counterexample ("decryptPrivateKey failed: " ++ err) False+ Right (SUUnencrypted skey _) ->+ QC.counterexample+ "secret key material changed across encrypt/decrypt roundtrip"+ (skey == expectedSKey)+ Right other ->+ QC.counterexample+ ( "expected SUUnencrypted after decrypting encrypted key, got: "+ ++ show other+ )+ False+ , localOption+ (QC.QuickCheckTests 5)+ ( QC.testProperty+ "decryptPrivateKey (encryptPrivateKey v4sk pw) pw equivalence"+ $ QC.ioProperty+ $ do+ fixture <- loadV4EncryptedSecretKeyFixtureForProperty+ case fixture of+ Left err -> pure (QC.counterexample err False)+ Right (pkp, ska, expectedSKey, passphrase) -> do+ let legacyOverridePolicy :: OpenPGPPolicy+ legacyOverridePolicy =+ (policyForRFC RFC4880)+ { policySecretKeyProtection =+ policySecretKeyProtection defaultPolicy+ }+ encryptedResult <-+ encryptPrivateKey legacyOverridePolicy pkp ska passphrase+ pure $+ case encryptedResult of+ Left err ->+ QC.counterexample+ ("encryptPrivateKey failed under legacy override policy: " ++ err)+ False+ Right encryptedSKA ->+ case decryptPrivateKey (pkp, encryptedSKA) passphrase of+ Left err ->+ QC.counterexample ("decryptPrivateKey failed: " ++ err) False+ Right (SUUnencrypted skey _) ->+ QC.counterexample+ "v4 secret key material changed across encrypt/decrypt roundtrip"+ (skey == expectedSKey)+ Right other ->+ QC.counterexample+ ( "expected SUUnencrypted after decrypting v4 encrypted key, got: "+ ++ show other+ )+ False+ )+ , QC.testProperty+ "canonicalizePKESKRecipientId idempotence on valid v4/v6 recipient ids"+ propertyCanonicalizePKESKRecipientIdIdempotent+ , localOption+ (QC.QuickCheckTests 10)+ ( QC.testProperty+ "canonicalizeTKStructuredWithWireRep is stable across packet/sig reordering"+ propertyCanonicalizeTKStructuredStableAcrossReordering+ )+ , localOption+ (QC.QuickCheckTests 1)+ ( QC.testProperty+ "recipient selection remains decryptable with extra unusable PKESK candidates"+ propertyRecipientSelectionMonotonicWithUnusableCandidates+ )+ , QC.testProperty+ "parsePktsEither does not accept truncated packet streams as intact packets"+ propertyParsePktsEitherRejectsTruncatedPacketStream+ ] -propertyCanonicalizePKESKRecipientIdIdempotent :: Bool -> Bool -> [Word8] -> QC.Property+propertyCanonicalizePKESKRecipientIdIdempotent+ :: Bool -> Bool -> [Word8] -> QC.Property propertyCanonicalizePKESKRecipientIdIdempotent useV6 prefixed seedBytes =- case canonicalizePKESKRecipientId payload of- Left err ->- QC.counterexample ("canonicalizePKESKRecipientId unexpectedly failed: " ++ show err) False- Right canonical ->- QC.counterexample- "canonicalizePKESKRecipientId should be idempotent"- (canonicalizePKESKRecipientId canonical == Right canonical)+ case canonicalizePKESKRecipientId payload of+ Left err ->+ QC.counterexample+ ("canonicalizePKESKRecipientId unexpectedly failed: " ++ show err)+ False+ Right canonical ->+ QC.counterexample+ "canonicalizePKESKRecipientId should be idempotent"+ (canonicalizePKESKRecipientId canonical == Right canonical) where targetLen = if useV6 then 32 else 20 versionOctet = if useV6 then 0x06 else 0x04 ridBody = BL.pack (take targetLen (seedBytes ++ repeat 0x00)) rid- | prefixed = BL.cons versionOctet ridBody- | otherwise = ridBody+ | prefixed = BL.cons versionOctet ridBody+ | otherwise = ridBody payload = PKESKPayloadV6Packet (PKESKPayloadV6 rid RSA "esk") -propertyCanonicalizeTKStructuredStableAcrossReordering ::- QC.NonNegative Int- -> Bool- -> Bool- -> Bool- -> Bool- -> Bool- -> Bool- -> Bool- -> QC.Property propertyCanonicalizeTKStructuredStableAcrossReordering- (QC.NonNegative indexSeed)- reverseDirect- reverseUIDs- reverseUIDSigs- reverseUATs- reverseUATSigs- reverseSubs- reverseSubSigs =- QC.ioProperty $ do- lbs <- readFixtureLazy "pubring.gpg"- let src = wireRepRef lbs- parsed = parseTKsWithWireRep True (parsePktsWithWireRep src lbs)- if null parsed- then pure (QC.counterexample "pubring.gpg parsed to no TKWithWireRep values" False)- else do- let tk = parsed !! (indexSeed `mod` length parsed)- pure $- case toStructuredTKWithWireRep tk of- Left err ->- QC.counterexample ("toStructuredTKWithWireRep failed: " ++ err) False- Right structured ->- let shuffled =- structured- { _tkStructuredDirectSignatures =- reverseIf reverseDirect (_tkStructuredDirectSignatures structured)- , _tkStructuredUIDs =- reverseIf reverseUIDs- (map- (\uid ->- uid- { _uidWithWireRefsSignatures =- reverseIf reverseUIDSigs (_uidWithWireRefsSignatures uid)- })- (_tkStructuredUIDs structured))- , _tkStructuredUAts =- reverseIf reverseUATs- (map- (\uat ->- uat- { _uatWithWireRefsSignatures =- reverseIf reverseUATSigs (_uatWithWireRefsSignatures uat)- })- (_tkStructuredUAts structured))- , _tkStructuredSubkeys =- reverseIf reverseSubs- (map- (\sub ->- sub- { _subkeyWithWireRefsSignatures =- reverseIf reverseSubSigs (_subkeyWithWireRefsSignatures sub)- })- (_tkStructuredSubkeys structured))- }- in case (canonicalizeTKStructuredWithWireRep structured, canonicalizeTKStructuredWithWireRep shuffled) of- (Right canonicalBase, Right canonicalShuffled) ->- QC.counterexample- "canonicalization should be stable under packet/sig reordering"- (canonicalBase == canonicalShuffled)- (Left err, _) ->- QC.counterexample ("canonicalizeTKStructuredWithWireRep failed on base: " ++ show err) False- (_, Left err) ->- QC.counterexample ("canonicalizeTKStructuredWithWireRep failed on shuffled: " ++ show err) False+ :: QC.NonNegative Int+ -> Bool+ -> Bool+ -> Bool+ -> Bool+ -> Bool+ -> Bool+ -> Bool+ -> QC.Property+propertyCanonicalizeTKStructuredStableAcrossReordering+ (QC.NonNegative indexSeed)+ reverseDirect+ reverseUIDs+ reverseUIDSigs+ reverseUATs+ reverseUATSigs+ reverseSubs+ reverseSubSigs =+ QC.ioProperty $ do+ lbs <- readFixtureLazy "pubring.gpg"+ let src = wireRepRef lbs+ parsed = parseTKsWithWireRep True (parsePktsWithWireRep src lbs)+ if null parsed+ then+ pure+ ( QC.counterexample+ "pubring.gpg parsed to no TKWithWireRep values"+ False+ )+ else do+ let tk = parsed !! (indexSeed `mod` length parsed)+ pure $+ case toStructuredTKWithWireRep tk of+ Left err ->+ QC.counterexample+ ("toStructuredTKWithWireRep failed: " ++ err)+ False+ Right structured ->+ let shuffled =+ structured+ { _tkStructuredDirectSignatures =+ reverseIf+ reverseDirect+ (_tkStructuredDirectSignatures structured)+ , _tkStructuredUIDs =+ reverseIf+ reverseUIDs+ ( map+ ( \uid ->+ uid+ { _uidWithWireRefsSignatures =+ reverseIf reverseUIDSigs (_uidWithWireRefsSignatures uid)+ }+ )+ (_tkStructuredUIDs structured)+ )+ , _tkStructuredUAts =+ reverseIf+ reverseUATs+ ( map+ ( \uat ->+ uat+ { _uatWithWireRefsSignatures =+ reverseIf reverseUATSigs (_uatWithWireRefsSignatures uat)+ }+ )+ (_tkStructuredUAts structured)+ )+ , _tkStructuredSubkeys =+ reverseIf+ reverseSubs+ ( map+ ( \sub ->+ sub+ { _subkeyWithWireRefsSignatures =+ reverseIf reverseSubSigs (_subkeyWithWireRefsSignatures sub)+ }+ )+ (_tkStructuredSubkeys structured)+ )+ }+ in case ( canonicalizeTKStructuredWithWireRep structured+ , canonicalizeTKStructuredWithWireRep shuffled+ ) of+ (Right canonicalBase, Right canonicalShuffled) ->+ QC.counterexample+ "canonicalization should be stable under packet/sig reordering"+ (canonicalBase == canonicalShuffled)+ (Left err, _) ->+ QC.counterexample+ ( "canonicalizeTKStructuredWithWireRep failed on base: "+ ++ show err+ )+ False+ (_, Left err) ->+ QC.counterexample+ ( "canonicalizeTKStructuredWithWireRep failed on shuffled: "+ ++ show err+ )+ False -propertyRecipientSelectionMonotonicWithUnusableCandidates ::- QC.NonNegative Int -> Bool -> QC.Property+propertyRecipientSelectionMonotonicWithUnusableCandidates+ :: QC.NonNegative Int -> Bool -> QC.Property propertyRecipientSelectionMonotonicWithUnusableCandidates (QC.NonNegative extraBogus) reorderPKESKs =- QC.ioProperty $ do- let applyBogus = foldr (.) id (replicate (extraBogus `mod` 5) prependUnusableLatestPKESK)- transformPackets- | reorderPKESKs = applyBogus . reorderPrecedingPKESKs- | otherwise = applyBogus- result <-- (try $ do- (messagePacketsRaw, encryptedSecretPackets, passphrase) <-- loadSEIPDv2FixtureWithV4Secret "seipdv2-three-recipients.pgp.aa"- keyInfos <- collectSecretKeyInfos encryptedSecretPackets passphrase- let messagePackets = transformPackets messagePacketsRaw- passphraseCallback _ = pure BL.empty- keyContextCallback pkt = pure (selectRecipientKeyInfo pkt keyInfos)- decrypted <-- DC.runConduitRes $- CL.sourceList messagePackets DC..|- conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..|- CL.consume- pure (any (not . BL.null) [payload | LiteralDataPkt _ _ _ payload <- decrypted]))- :: IO (Either SomeException Bool)- case result of- Left e ->- pure $- QC.counterexample- ("recipient selection should remain decryptable despite added unusable candidates: " ++ show e)- False- Right didDecrypt ->- pure $- QC.counterexample- "recipient selection should still yield a non-empty decrypted literal payload"- didDecrypt+ QC.ioProperty $ do+ let applyBogus =+ foldr+ (.)+ id+ (replicate (extraBogus `mod` 5) prependUnusableLatestPKESK)+ transformPackets+ | reorderPKESKs = applyBogus . reorderPrecedingPKESKs+ | otherwise = applyBogus+ result <-+ ( try $ do+ (messagePacketsRaw, encryptedSecretPackets, passphrase) <-+ loadSEIPDv2FixtureWithV4Secret "seipdv2-three-recipients.pgp.aa"+ keyInfos <-+ collectSecretKeyInfos encryptedSecretPackets passphrase+ let messagePackets = transformPackets messagePacketsRaw+ passphraseCallback _ = pure BL.empty+ keyContextCallback pkt = pure (selectRecipientKeyInfo pkt keyInfos)+ decrypted <-+ DC.runConduitRes $+ CL.sourceList messagePackets+ DC..| conduitDecryptWithPKESKContext+ keyContextCallback+ passphraseCallback+ DC..| CL.consume+ pure+ ( any+ (not . BL.null)+ [payload | LiteralDataPkt _ _ _ payload <- decrypted]+ )+ )+ :: IO (Either SomeException Bool)+ case result of+ Left e ->+ pure $+ QC.counterexample+ ( "recipient selection should remain decryptable despite added unusable candidates: "+ ++ show e+ )+ False+ Right didDecrypt ->+ pure $+ QC.counterexample+ "recipient selection should still yield a non-empty decrypted literal payload"+ didDecrypt -propertyParsePktsEitherRejectsTruncatedPacketStream ::- PKESK 'PKESKV6 -> QC.Positive Int -> QC.Property+propertyParsePktsEitherRejectsTruncatedPacketStream+ :: PKESK 'PKESKV6 -> QC.Positive Int -> QC.Property propertyParsePktsEitherRejectsTruncatedPacketStream pkesk (QC.Positive cutSeed) =- case parsePktsEither truncated of- Left _ -> QC.property True- Right parsed ->- QC.counterexample- ("parsePktsEither unexpectedly treated truncated packet stream as original packet: " ++- show parsed)- (parsed /= [toPkt pkesk])+ case parsePktsEither truncated of+ Left _ -> QC.property True+ Right parsed ->+ QC.counterexample+ ( "parsePktsEither unexpectedly treated truncated packet stream as original packet: "+ ++ show parsed+ )+ (parsed /= [toPkt pkesk]) where encoded = runPut (put (toPkt pkesk))- cut = fromIntegral (1 + (cutSeed `mod` fromIntegral (BL.length encoded)))+ cut =+ fromIntegral+ (1 + (cutSeed `mod` fromIntegral (BL.length encoded))) truncated = BL.take (BL.length encoded - cut) encoded-