diff --git a/Codec/Encryption/OpenPGP/Encrypt.hs b/Codec/Encryption/OpenPGP/Encrypt.hs --- a/Codec/Encryption/OpenPGP/Encrypt.hs +++ b/Codec/Encryption/OpenPGP/Encrypt.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Internal/RFC7253OCB.hs b/Codec/Encryption/OpenPGP/Internal/RFC7253OCB.hs --- a/Codec/Encryption/OpenPGP/Internal/RFC7253OCB.hs +++ b/Codec/Encryption/OpenPGP/Internal/RFC7253OCB.hs @@ -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)) diff --git a/Codec/Encryption/OpenPGP/Internal/Whitespace.hs b/Codec/Encryption/OpenPGP/Internal/Whitespace.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/OpenPGP/Internal/Whitespace.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/KeyringParser.hs b/Codec/Encryption/OpenPGP/KeyringParser.hs --- a/Codec/Encryption/OpenPGP/KeyringParser.hs +++ b/Codec/Encryption/OpenPGP/KeyringParser.hs @@ -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] diff --git a/Codec/Encryption/OpenPGP/Message.hs b/Codec/Encryption/OpenPGP/Message.hs --- a/Codec/Encryption/OpenPGP/Message.hs +++ b/Codec/Encryption/OpenPGP/Message.hs @@ -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 () diff --git a/Codec/Encryption/OpenPGP/Ontology.hs b/Codec/Encryption/OpenPGP/Ontology.hs --- a/Codec/Encryption/OpenPGP/Ontology.hs +++ b/Codec/Encryption/OpenPGP/Ontology.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/S2K.hs b/Codec/Encryption/OpenPGP/S2K.hs --- a/Codec/Encryption/OpenPGP/S2K.hs +++ b/Codec/Encryption/OpenPGP/S2K.hs @@ -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)) diff --git a/Codec/Encryption/OpenPGP/Serialize.hs b/Codec/Encryption/OpenPGP/Serialize.hs --- a/Codec/Encryption/OpenPGP/Serialize.hs +++ b/Codec/Encryption/OpenPGP/Serialize.hs @@ -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)) diff --git a/Codec/Encryption/OpenPGP/SerializeForSigs.hs b/Codec/Encryption/OpenPGP/SerializeForSigs.hs --- a/Codec/Encryption/OpenPGP/SerializeForSigs.hs +++ b/Codec/Encryption/OpenPGP/SerializeForSigs.hs @@ -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]) diff --git a/Codec/Encryption/OpenPGP/SignatureQualities.hs b/Codec/Encryption/OpenPGP/SignatureQualities.hs --- a/Codec/Encryption/OpenPGP/SignatureQualities.hs +++ b/Codec/Encryption/OpenPGP/SignatureQualities.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Signatures.hs b/Codec/Encryption/OpenPGP/Signatures.hs --- a/Codec/Encryption/OpenPGP/Signatures.hs +++ b/Codec/Encryption/OpenPGP/Signatures.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Subpackets.hs b/Codec/Encryption/OpenPGP/Subpackets.hs --- a/Codec/Encryption/OpenPGP/Subpackets.hs +++ b/Codec/Encryption/OpenPGP/Subpackets.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Types/Internal/Base.hs b/Codec/Encryption/OpenPGP/Types/Internal/Base.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/Base.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/Base.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs b/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs @@ -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 diff --git a/Data/Conduit/OpenPGP/Filter.hs b/Data/Conduit/OpenPGP/Filter.hs --- a/Data/Conduit/OpenPGP/Filter.hs +++ b/Data/Conduit/OpenPGP/Filter.hs @@ -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 diff --git a/Data/Conduit/OpenPGP/Keyring.hs b/Data/Conduit/OpenPGP/Keyring.hs --- a/Data/Conduit/OpenPGP/Keyring.hs +++ b/Data/Conduit/OpenPGP/Keyring.hs @@ -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 diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,6 +1,6 @@ Cabal-version: 3.4 Name: hOpenPGP -Version: 3.1 +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 diff --git a/tests/Tests/Encryption.hs b/tests/Tests/Encryption.hs --- a/tests/Tests/Encryption.hs +++ b/tests/Tests/Encryption.hs @@ -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 diff --git a/tests/Tests/MessageAndArmor.hs b/tests/Tests/MessageAndArmor.hs --- a/tests/Tests/MessageAndArmor.hs +++ b/tests/Tests/MessageAndArmor.hs @@ -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 diff --git a/tests/Tests/Properties.hs b/tests/Tests/Properties.hs --- a/tests/Tests/Properties.hs +++ b/tests/Tests/Properties.hs @@ -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 -