hOpenPGP 2.8.2 → 2.8.3
raw patch · 5 files changed
+1145/−517 lines, 5 filesdep +tasty-expected-failuredep −base64-bytestringdep ~conduit
Dependencies added: tasty-expected-failure
Dependencies removed: base64-bytestring
Dependency ranges changed: conduit
Files
- Codec/Encryption/OpenPGP/CFB.hs +99/−35
- Data/Conduit/OpenPGP/Decrypt.hs +114/−54
- Data/Conduit/OpenPGP/Filter.hs +7/−17
- hOpenPGP.cabal +4/−5
- tests/suite.hs +921/−406
Codec/Encryption/OpenPGP/CFB.hs view
@@ -1,55 +1,119 @@ -- CFB.hs: OpenPGP (RFC4880) CFB mode--- Copyright © 2013-2018 Clint Adams+-- Copyright © 2013-2019 Clint Adams -- Copyright © 2013 Daniel Kahn Gillmor -- This software is released under the terms of the Expat license. -- (See the LICENSE file).--module Codec.Encryption.OpenPGP.CFB (- decrypt- , decryptNoNonce- , decryptOpenPGPCfb- , encryptNoNonce-) where+module Codec.Encryption.OpenPGP.CFB+ ( decrypt+ , decryptPreservingNonce+ , decryptNoNonce+ , decryptOpenPGPCfb+ , encryptNoNonce+ ) where import Codec.Encryption.OpenPGP.BlockCipher (withSymmetricCipher) import Codec.Encryption.OpenPGP.Internal.HOBlockCipher import Codec.Encryption.OpenPGP.Types import qualified Data.ByteString as B -decryptOpenPGPCfb :: SymmetricAlgorithm -> B.ByteString -> B.ByteString -> Either String B.ByteString+decryptOpenPGPCfb ::+ SymmetricAlgorithm+ -> B.ByteString+ -> B.ByteString+ -> Either String B.ByteString decryptOpenPGPCfb Plaintext ciphertext _ = return ciphertext-decryptOpenPGPCfb sa ciphertext keydata = withSymmetricCipher sa keydata $ \bc -> do+decryptOpenPGPCfb sa ciphertext keydata =+ withSymmetricCipher sa keydata $ \bc -> do nonce <- decrypt1 ciphertext bc cleartext <- decrypt2 ciphertext bc- if nonceCheck bc nonce then return cleartext else Left "Session key quickcheck failed"- where- decrypt1 :: HOBlockCipher cipher => B.ByteString -> cipher -> Either String B.ByteString- decrypt1 ct cipher = paddedCfbDecrypt cipher (B.replicate (blockSize cipher) 0) (B.take (blockSize cipher + 2) ct)- decrypt2 :: HOBlockCipher cipher => B.ByteString -> cipher -> Either String B.ByteString- decrypt2 ct cipher = let i = B.take (blockSize cipher) (B.drop 2 ct) in paddedCfbDecrypt cipher i (B.drop (blockSize cipher + 2) ct)+ if nonceCheck bc nonce+ then return cleartext+ else Left "Session key quickcheck failed"+ where+ decrypt1 ::+ HOBlockCipher cipher+ => B.ByteString+ -> cipher+ -> Either String B.ByteString+ decrypt1 ct cipher =+ paddedCfbDecrypt+ cipher+ (B.replicate (blockSize cipher) 0)+ (B.take (blockSize cipher + 2) ct)+ decrypt2 ::+ HOBlockCipher cipher+ => B.ByteString+ -> cipher+ -> Either String B.ByteString+ decrypt2 ct cipher =+ let i = B.take (blockSize cipher) (B.drop 2 ct)+ in paddedCfbDecrypt cipher i (B.drop (blockSize cipher + 2) ct) -decrypt :: SymmetricAlgorithm -> B.ByteString -> B.ByteString -> Either String B.ByteString-decrypt Plaintext ciphertext _ = return ciphertext-decrypt sa ciphertext keydata = withSymmetricCipher sa keydata $ \bc -> do- (nonce, cleartext) <- fmap (B.splitAt (blockSize bc + 2)) (decrypt' ciphertext bc)- if nonceCheck bc nonce then return cleartext else Left "Session key quickcheck failed"- where- decrypt' :: HOBlockCipher cipher => B.ByteString -> cipher -> Either String B.ByteString- decrypt' ct cipher = paddedCfbDecrypt cipher (B.replicate (blockSize cipher) 0) ct+-- should deprecate this?+decrypt ::+ SymmetricAlgorithm+ -> B.ByteString+ -> B.ByteString+ -> Either String B.ByteString+decrypt x y z = snd <$> (decryptPreservingNonce x y z) -decryptNoNonce :: SymmetricAlgorithm -> IV -> B.ByteString -> B.ByteString -> Either String B.ByteString+decryptPreservingNonce ::+ SymmetricAlgorithm+ -> B.ByteString+ -> B.ByteString+ -> Either String (B.ByteString, B.ByteString)+decryptPreservingNonce Plaintext ciphertext _ = return (mempty, ciphertext)+decryptPreservingNonce sa ciphertext keydata =+ withSymmetricCipher sa keydata $ \bc -> do+ (nonce, cleartext) <-+ fmap (B.splitAt (blockSize bc + 2)) (decrypt' ciphertext bc)+ if nonceCheck bc nonce+ then return (nonce, cleartext)+ else Left "Session key quickcheck failed"+ where+ decrypt' ::+ HOBlockCipher cipher+ => B.ByteString+ -> cipher+ -> Either String B.ByteString+ decrypt' ct cipher =+ paddedCfbDecrypt cipher (B.replicate (blockSize cipher) 0) ct++decryptNoNonce ::+ SymmetricAlgorithm+ -> IV+ -> B.ByteString+ -> B.ByteString+ -> Either String B.ByteString decryptNoNonce Plaintext _ ciphertext _ = return ciphertext-decryptNoNonce sa iv ciphertext keydata = withSymmetricCipher sa keydata (decrypt' ciphertext)- where- decrypt' :: HOBlockCipher cipher => B.ByteString -> cipher -> Either String B.ByteString- decrypt' ct cipher = paddedCfbDecrypt cipher (unIV iv) ct+decryptNoNonce sa iv ciphertext keydata =+ withSymmetricCipher sa keydata (decrypt' ciphertext)+ where+ decrypt' ::+ HOBlockCipher cipher+ => B.ByteString+ -> cipher+ -> Either String B.ByteString+ decrypt' ct cipher = paddedCfbDecrypt cipher (unIV iv) ct nonceCheck :: HOBlockCipher cipher => cipher -> B.ByteString -> Bool-nonceCheck bc = (==) <$> B.take 2 . B.drop (blockSize bc - 2) <*> B.drop (blockSize bc)+nonceCheck bc =+ (==) <$> B.take 2 . B.drop (blockSize bc - 2) <*> B.drop (blockSize bc) -encryptNoNonce :: SymmetricAlgorithm -> S2K -> IV -> B.ByteString -> B.ByteString -> Either String B.ByteString+encryptNoNonce ::+ SymmetricAlgorithm+ -> S2K+ -> IV+ -> B.ByteString+ -> B.ByteString+ -> Either String B.ByteString encryptNoNonce Plaintext _ _ payload _ = return payload-encryptNoNonce sa s2k iv payload keydata = withSymmetricCipher sa keydata (encrypt' payload)- where- encrypt' :: HOBlockCipher cipher => B.ByteString -> cipher -> Either String B.ByteString- encrypt' ct cipher = paddedCfbEncrypt cipher (unIV iv) ct+encryptNoNonce sa s2k iv payload keydata =+ withSymmetricCipher sa keydata (encrypt' payload)+ where+ encrypt' ::+ HOBlockCipher cipher+ => B.ByteString+ -> cipher+ -> Either String B.ByteString+ encrypt' ct cipher = paddedCfbEncrypt cipher (unIV iv) ct
Data/Conduit/OpenPGP/Decrypt.hs view
@@ -1,84 +1,144 @@ -- Decrypt.hs: OpenPGP (RFC4880) recursive packet decryption--- Copyright © 2013-2018 Clint Adams+-- Copyright © 2013-2019 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE FlexibleContexts #-} -module Data.Conduit.OpenPGP.Decrypt (- conduitDecrypt-) where+module Data.Conduit.OpenPGP.Decrypt+ ( conduitDecrypt+ ) where import Control.Monad (when) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Trans.Resource (MonadResource, MonadThrow)-import qualified Control.Monad.Trans.State.Lazy as S import qualified Crypto.Hash as CH import qualified Crypto.Hash.Algorithms as CHA+import Data.Binary (get) import qualified Data.ByteArray as BA+import qualified Data.ByteString as B+import qualified Data.ByteString.Base16.Lazy as B16L import qualified Data.ByteString.Lazy as BL import Data.Conduit import qualified Data.Conduit.Binary as CB-import Data.Conduit.Serialization.Binary (conduitGet)-import Data.Conduit.OpenPGP.Compression (conduitDecompress)+import qualified Data.Conduit.Combinators as CC import qualified Data.Conduit.List as CL+import Data.Conduit.OpenPGP.Compression (conduitDecompress)+import Data.Conduit.Serialization.Binary (conduitGet) import Data.Maybe (fromJust, isNothing)-import Data.Binary (get) +import Codec.Encryption.OpenPGP.CFB (decryptOpenPGPCfb, decryptPreservingNonce) import Codec.Encryption.OpenPGP.S2K (skesk2Key)-import Codec.Encryption.OpenPGP.CFB (decrypt, decryptOpenPGPCfb) import Codec.Encryption.OpenPGP.Types -data RecursorState = RecursorState {- _depth :: Int- , _lastPKESK :: Maybe PKESK- , _lastSKESK :: Maybe SKESK- , _lastLDP :: Maybe LiteralData-} deriving (Eq, Show)+data RecursorState =+ RecursorState+ { _depth :: Int+ , _lastPKESK :: Maybe PKESK+ , _lastSKESK :: Maybe SKESK+ , _lastNonce :: Maybe B.ByteString+ , _lastClearText :: Maybe B.ByteString+ }+ deriving (Eq, Show) def :: RecursorState-def = RecursorState 0 Nothing Nothing Nothing+def = RecursorState 0 Nothing Nothing Nothing Nothing type InputCallback m = String -> m BL.ByteString -conduitDecrypt :: (MonadUnliftIO m, MonadResource m, MonadThrow m) => InputCallback IO -> ConduitT Pkt Pkt m ()-conduitDecrypt = conduitDecrypt' 0+conduitDecrypt ::+ (MonadUnliftIO m, MonadResource m, MonadThrow m)+ => InputCallback IO+ -> ConduitT Pkt Pkt m ()+conduitDecrypt = conduitDecrypt' def -conduitDecrypt' :: (MonadUnliftIO m, MonadResource m, MonadThrow m) => Int -> InputCallback IO -> ConduitT Pkt Pkt m ()-conduitDecrypt' depth cb = CL.concatMapAccumM push def { _depth = depth } -- FIXME: this depth stuff is convoluted- where- push :: (MonadUnliftIO m, MonadResource m, MonadThrow m) => Pkt -> RecursorState -> m (RecursorState, [Pkt])- push i s- | _depth s > 42 = fail "I think we've been quine-attacked"- | otherwise = case i of- SKESKPkt{} -> return (s { _lastSKESK = Just (fromPkt i) }, [])- (SymEncDataPkt bs) -> do d <- decryptSEDP (_depth s) cb (fromJust . _lastSKESK $ s) bs- return (processLDPs s d, d)- (SymEncIntegrityProtectedDataPkt _ bs) -> do d <- decryptSEIPDP (_depth s) cb (fromJust . _lastSKESK $ s) bs- return (processLDPs s d, d)- m@(ModificationDetectionCodePkt mdc) -> do when (isNothing (_lastLDP s)) $ fail "MDC with no referent"- when (fmap (BL.fromStrict . BA.convert . (CH.hashlazy :: BL.ByteString -> CH.Digest CHA.SHA1) . _literalDataPayload) (_lastLDP s) /= Just mdc) $ fail "MDC indicates tampering"- return (s, [m])- p -> return (s, [p])- processLDPs s ds = S.execState (mapM_ ldpCheck ds) s- ldpCheck l@LiteralDataPkt{} = S.get >>= \o -> S.put o { _lastLDP = Just . fromPkt $ l }- ldpCheck _ = return ()+conduitDecrypt' ::+ (MonadUnliftIO m, MonadResource m, MonadThrow m)+ => RecursorState+ -> InputCallback IO+ -> ConduitT Pkt Pkt m ()+conduitDecrypt' rs cb = CC.concatMapAccumM push rs+ where+ push ::+ (MonadUnliftIO m, MonadResource m, MonadThrow m)+ => Pkt+ -> RecursorState+ -> m (RecursorState, [Pkt])+ push i s+ | _depth s > 42 = fail "I think we've been quine-attacked"+ | otherwise =+ case i of+ SKESKPkt {} -> return (s {_lastSKESK = Just (fromPkt i)}, [])+ (SymEncDataPkt bs) -> do+ d <- decryptSEDP s cb (fromJust . _lastSKESK $ s) bs+ return (s, d)+ (SymEncIntegrityProtectedDataPkt _ bs) -> do+ d <- decryptSEIPDP s cb (fromJust . _lastSKESK $ s) bs+ return (s, d)+ m@(ModificationDetectionCodePkt mdc) -> do+ when (isNothing (_lastClearText s)) $ fail "MDC with no referent"+ let mcalculated =+ calculateMDC <$> _lastNonce s <*> _lastClearText s+ when (mcalculated /= Just mdc) $+ fail $+ "MDC indicates tampering: " +++ show (B16L.encode mdc) +++ " versus " ++ maybe "<empty>" (show . B16L.encode) mcalculated ++ " ... " ++ show (_lastNonce s) ++ " / " ++ show (_lastClearText s)+ return (s, [m])+ p -> return (s, [p]) -decryptSEDP :: (MonadUnliftIO m, MonadIO m, MonadThrow m) => Int -> InputCallback IO -> SKESK -> BL.ByteString -> m [Pkt]-decryptSEDP depth cb skesk bs = do -- FIXME: this shouldn't pass the whole SKESK- passphrase <- liftIO $ cb "Input the passphrase I want"- let key = skesk2Key skesk passphrase- decrypted = case decryptOpenPGPCfb (_skeskSymmetricAlgorithm skesk) (BL.toStrict bs) key of- Left e -> error e- Right x -> x- runConduitRes $ CB.sourceLbs (BL.fromStrict decrypted) .| conduitGet get .| conduitDecompress .| conduitDecrypt' depth cb .| CL.consume+decryptSEDP ::+ (MonadUnliftIO m, MonadIO m, MonadThrow m)+ => RecursorState+ -> InputCallback IO+ -> SKESK+ -> BL.ByteString+ -> m [Pkt]+decryptSEDP rs cb skesk bs -- FIXME: this shouldn't pass the whole SKESK+ = do+ passphrase <- liftIO $ cb "Input the passphrase I want"+ let key = skesk2Key skesk passphrase+ decrypted =+ case decryptOpenPGPCfb+ (_skeskSymmetricAlgorithm skesk)+ (BL.toStrict bs)+ key of+ Left e -> error e+ Right x -> x+ runConduitRes $+ CB.sourceLbs (BL.fromStrict decrypted) .| conduitGet get .|+ conduitDecompress .|+ conduitDecrypt' rs {_depth = _depth rs + 1} cb .|+ CL.consume -decryptSEIPDP :: (MonadUnliftIO m, MonadIO m, MonadThrow m) => Int -> InputCallback IO -> SKESK -> BL.ByteString -> m [Pkt]-decryptSEIPDP depth cb skesk bs = do -- FIXME: this shouldn't pass the whole SKESK- passphrase <- liftIO $ cb "Input the passphrase I want"- let key = skesk2Key skesk passphrase- decrypted = case decrypt (_skeskSymmetricAlgorithm skesk) (BL.toStrict bs) key of- Left e -> error e- Right x -> x- runConduitRes $ CB.sourceLbs (BL.fromStrict decrypted) .| conduitGet get .| conduitDecompress .| conduitDecrypt' depth cb .| CL.consume+decryptSEIPDP ::+ (MonadUnliftIO m, MonadIO m, MonadThrow m)+ => RecursorState+ -> InputCallback IO+ -> SKESK+ -> BL.ByteString+ -> m [Pkt]+decryptSEIPDP rs cb skesk bs -- FIXME: this shouldn't pass the whole SKESK+ = do+ passphrase <- liftIO $ cb "Input the passphrase I want"+ let key = skesk2Key skesk passphrase+ (nonce, decrypted) =+ case decryptPreservingNonce+ (_skeskSymmetricAlgorithm skesk)+ (BL.toStrict bs)+ key of+ Left e -> error e+ Right x -> x+ runConduitRes $+ CB.sourceLbs (BL.fromStrict decrypted) .| conduitGet get .|+ conduitDecompress .|+ conduitDecrypt' rs { _depth = _depth rs + 1, _lastNonce = Just nonce, _lastClearText = Just decrypted } cb .|+ CL.consume++calculateMDC :: B.ByteString -> B.ByteString -> BL.ByteString+calculateMDC nonce garbage+ | B.length garbage < 23 = mempty -- FIXME: this is horrible+ | otherwise =+ BL.fromStrict .+ BA.convert . (CH.hash :: B.ByteString -> CH.Digest CHA.SHA1) $+ nonce <> B.take (B.length garbage - 22) garbage <> B.pack [211,20]
Data/Conduit/OpenPGP/Filter.hs view
@@ -1,5 +1,5 @@ -- Filter.hs: OpenPGP (RFC4880) packet filtering--- Copyright © 2014-2019 Clint Adams+-- Copyright © 2014-2018 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -7,7 +7,6 @@ module Data.Conduit.OpenPGP.Filter ( conduitPktFilter- , conduitPktWithExtraFilter , conduitTKFilter , FilterPredicates(..) ) where@@ -15,33 +14,24 @@ import Control.Monad.Trans.Reader (Reader, runReader) import Data.Conduit (ConduitT) import qualified Data.Conduit.List as CL-import Data.Void (Void) import Codec.Encryption.OpenPGP.Types -data FilterPredicates r a =++data FilterPredicates = RTKFilterPredicate (Reader TK 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 -conduitPktFilter :: Monad m => FilterPredicates Void Pkt -> ConduitT Pkt Pkt m ()+conduitPktFilter :: Monad m => FilterPredicates -> ConduitT Pkt Pkt m () conduitPktFilter = CL.filter . superPredicate -superPredicate :: FilterPredicates Void Pkt -> Pkt -> Bool+superPredicate :: FilterPredicates -> Pkt -> Bool superPredicate (RPFilterPredicate e) p = runReader e p-superPredicate (RFilterPredicate e) p = runReader e p superPredicate _ _ = False -- do not match incorrect type of packet -conduitTKFilter :: Monad m => FilterPredicates Void TK -> ConduitT TK TK m ()+conduitTKFilter :: Monad m => FilterPredicates -> ConduitT TK TK m () conduitTKFilter = CL.filter . superTKPredicate -superTKPredicate :: FilterPredicates Void TK -> TK -> Bool+superTKPredicate :: FilterPredicates -> TK -> Bool superTKPredicate (RTKFilterPredicate e) = runReader e-superTKPredicate (RFilterPredicate e) = runReader e -conduitPktWithExtraFilter :: Monad m => r -> FilterPredicates r Pkt -> ConduitT Pkt Pkt m ()-conduitPktWithExtraFilter extra = CL.filter . superPairPredicate extra--superPairPredicate :: r -> FilterPredicates r a -> a -> Bool-superPairPredicate r (RPairFilterPredicate e) p = runReader e (r, p)
hOpenPGP.cabal view
@@ -1,5 +1,5 @@ Name: hOpenPGP-Version: 2.8.2+Version: 2.8.3 Synopsis: native Haskell implementation of OpenPGP (RFC4880) Description: native Haskell implementation of OpenPGP (RFC4880), plus Camellia (RFC5581), plus ECC (RFC6637) Homepage: https://salsa.debian.org/clint/hOpenPGP@@ -198,13 +198,12 @@ , attoparsec , base > 4.8 && < 5 , base16-bytestring- , base64-bytestring , bifunctors , bytestring , bzlib , binary >= 0.6.4.0 , binary-conduit >= 1.3- , conduit >= 1.2.8+ , conduit >= 1.3.0 , conduit-extra >= 1.1 , containers , cryptonite >= 0.11@@ -278,6 +277,7 @@ , unordered-containers , zlib , tasty+ , tasty-expected-failure , tasty-hunit , tasty-quickcheck , QuickCheck > 2.9@@ -297,7 +297,6 @@ , aeson , base > 4.8 && < 5 , base16-bytestring- , base64-bytestring , bifunctors , bytestring , bzlib@@ -343,4 +342,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hOpenPGP.git- tag: v2.8.2+ tag: v2.8.3
tests/suite.hs view
@@ -1,412 +1,927 @@ {-# LANGUAGE OverloadedStrings #-} -- suite.hs: hOpenPGP test suite--- Copyright © 2012-2018 Clint Adams--- This software is released under the terms of the Expat license.--- (See the LICENSE file).--import Test.Tasty (defaultMain, testGroup, TestTree)-import Test.Tasty.HUnit (testCase, Assertion, assertFailure, assertEqual)-import Test.Tasty.QuickCheck as QC--import Data.Bifunctor (bimap)-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import Codec.Encryption.OpenPGP.Arbitrary ()-import Codec.Encryption.OpenPGP.Compression (decompressPkt, compressPkts)-import Codec.Encryption.OpenPGP.Expirations (isTKTimeValid)-import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)-import Codec.Encryption.OpenPGP.KeyInfo (pkalgoAbbrev, pubkeySize)-import Codec.Encryption.OpenPGP.KeyringParser (parseTKs)-import Codec.Encryption.OpenPGP.KeySelection (parseFingerprint)-import Codec.Encryption.OpenPGP.SecretKey (decryptPrivateKey, encryptPrivateKey)-import Codec.Encryption.OpenPGP.Serialize (parsePkts)-import Codec.Encryption.OpenPGP.Signatures (verifyTKWith, verifySigWith, verifyAgainstKeys)-import Codec.Encryption.OpenPGP.Types-import Control.Error.Util (isRight)-import Control.Monad.Trans.Resource (ResourceT)-import qualified Crypto.PubKey.ECC.ECDSA as ECDSA-import qualified Crypto.PubKey.RSA as RSA-import Data.Conduit.Serialization.Binary (conduitGet)-import Data.Conduit.OpenPGP.Compression (conduitCompress, conduitDecompress)-import Data.Conduit.OpenPGP.Decrypt (conduitDecrypt)-import Data.Conduit.OpenPGP.Keyring (conduitToTKs, conduitToTKsDropping, sinkKeyringMap)-import Data.Conduit.OpenPGP.Verify (conduitVerify)-import Data.IxSet.Typed ((@=), getOne)-import Data.Maybe (isJust)-import Data.Binary (get, put)-import Data.Binary.Get (runGetOrFail, Get)-import Data.Binary.Put (runPut)-import Data.Text (Text)-import Data.Time.Clock.POSIX (posixSecondsToUTCTime)-import Data.Text.Prettyprint.Doc (pretty)--import qualified Data.Conduit as DC-import qualified Data.Conduit.Binary as CB-import qualified Data.Conduit.List as CL---- this needs a better name-runGet :: Get a -> BL.ByteString -> Either String a-runGet g bs = bimap (\(_,_,x) -> x) (\(_,_,x) -> x) (runGetOrFail g bs)---- FIXME: nothing tests serialization of TKs--testSerialization :: FilePath -> Assertion-testSerialization fpr = do- bs <- BL.readFile $ "tests/data/" ++ fpr- let firstpass = runGet get bs- case fmap unBlock firstpass of- Left _ -> assertFailure $ "First pass failed on " ++ fpr- Right [] -> assertFailure $ "First pass of " ++ fpr ++ " decoded to nothing."- Right packs -> do let roundtrip = runPut $ put (Block packs)- let secondpass = runGet (get :: Get (Block Pkt)) roundtrip- if fmap unBlock secondpass == Right [] then- assertFailure $ "Second pass of " ++ fpr ++ " decoded to nothing."- else- assertEqual ("for " ++ fpr) firstpass secondpass--testCompression :: FilePath -> Assertion-testCompression fpr = do- bs <- BL.readFile $ "tests/data/" ++ fpr- let firstpass = fmap (concatMap decompressPkt . unBlock) . runGet get $ bs- case firstpass of- Left _ -> assertFailure $ "First pass failed on " ++ fpr- Right [] -> assertFailure $ "First pass of " ++ fpr ++ " decoded to nothing."- Right packs -> do let roundtrip = runPut $ put . Block $ [compressPkts ZIP packs]- let secondpass = fmap (concatMap decompressPkt . unBlock) . runGet get $ roundtrip- if secondpass == Right [] then- assertFailure $ "Second pass of " ++ fpr ++ " decoded to nothing."- else- assertEqual ("for " ++ fpr) firstpass secondpass--counter :: (Monad m) => DC.ConduitT a DC.Void m Int-counter = CL.fold (const . (1+)) 0--testConduitOutputLength :: FilePath -> DC.ConduitT B.ByteString b (ResourceT IO) () -> Int -> Assertion-testConduitOutputLength fpr c target = do- len <- DC.runConduitRes $ CB.sourceFile ("tests/data/" ++ fpr) DC..| c DC..| counter- assertEqual ("expected length " ++ show target) target len--testPKAandSizeAndKeyIDandFingerprint :: FilePath -> String -> Assertion-testPKAandSizeAndKeyIDandFingerprint fpr kf = do- bs <- BL.readFile $ "tests/data/" ++ fpr- case runGet (get :: Get Pkt) bs of- Left _ -> assertFailure $ "Decoding of " ++ fpr ++ " broke."- Right (PublicKeyPkt pkp) -> do- let pref = concat [pkalgoAbbrev (_pkalgo pkp), either (const "unknown") show (pubkeySize (_pubkey pkp)), ":", either (const "unknown") (show . pretty) (eightOctetKeyID pkp), "/"]- assertEqual ("for " ++ fpr ++ " (spaceless)") (spaceless kf) (pref ++ show (pretty (fingerprint pkp)))- assertEqual ("for " ++ fpr ++ " (spaced)") kf (pref ++ show (pretty (SpacedFingerprint (fingerprint pkp))))- _ -> assertFailure "Expected public key, got something else."- where- spaceless = filter (/=' ')--testKeyringLookup :: FilePath -> String -> Bool -> Assertion-testKeyringLookup fpr eok expected = do- kr <- DC.runConduitRes $ CB.sourceFile ("tests/data/" ++ fpr) DC..| conduitGet get DC..| conduitToTKs DC..| sinkKeyringMap- let key = getOne (kr @= (read eok :: EightOctetKeyId))- assertEqual (eok ++ " in " ++ fpr) expected (isJust key)--testVerifyMessage :: FilePath -> FilePath -> [TwentyOctetFingerprint] -> Assertion-testVerifyMessage keyring message issuers = do- kr <- DC.runConduitRes $ CB.sourceFile ("tests/data/" ++ keyring) DC..| conduitGet get DC..| conduitToTKs DC..| sinkKeyringMap- verification <- DC.runConduitRes $ CB.sourceFile ("tests/data/" ++ message) DC..| conduitGet get DC..| conduitDecompress DC..| conduitVerify kr Nothing DC..| CL.consume- let verification' = map (fmap (fingerprint . _verificationSigner)) verification- assertEqual (keyring ++ " for " ++ message) (map Right issuers) verification'--testKeysSelfVerification :: Bool -> FilePath -> Assertion-testKeysSelfVerification expectsuccess keyfile = do- ks <- DC.runConduitRes $ CB.sourceFile ("tests/data/" ++ keyfile) DC..| conduitGet get DC..| conduitToTKs DC..| CL.consume- let verifieds = mapM (verifyTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks- assertEqual (keyfile ++ " self-verification") expectsuccess (isRight verifieds) -- FIXME:--testKeysExpiration :: Bool -> FilePath -> Assertion-testKeysExpiration expectsuccess keyfile = do- ks <- DC.runConduitRes $ CB.sourceFile ("tests/data/" ++ keyfile) DC..| conduitGet get DC..| conduitToTKs DC..| CL.consume- let Right verifieds = mapM (verifyTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks- tvalid = all (isTKTimeValid (posixSecondsToUTCTime (realToFrac (1400000000 :: Integer)))) verifieds- assertEqual (keyfile ++ " key expiration") expectsuccess tvalid---- This needs a lot of work-testSymmetricEncryption :: FilePath -> FilePath -> BL.ByteString -> Assertion-testSymmetricEncryption encfile passfile cleartext = do- passphrase <- BL.readFile $ "tests/data/" ++ passfile- -- get parse tree- pt <- DC.runConduitRes $ CB.sourceFile ("tests/data/" ++ encfile) DC..| conduitGet get DC..| CL.consume- -- assert parse tree has exactly two packets: skesk, encdata- assertEqual "wrong number of packets" 2 (length pt)- let skesk = fromPkt.head $ pt- d = fromPkt.last $ pt- -- FIXME: these assertions don't currently do anything properly,- -- because haskell notices the _-prefixed accessor invocations below- -- and the type system chokes before we hit them:- assertEqual "first packet should be SKESK" SKESKType (packetType skesk)- assertEqual "second packet should be encrypted data" SymEncIntegrityProtectedDataType (packetType d)- decrypted <- DC.runConduitRes $ CL.sourceList pt DC..| conduitDecrypt (fakeCallback passphrase) DC..| CL.consume- let payload = _literalDataPayload . fromPkt . head $ decrypted- assertEqual ("cleartext for " ++ encfile) cleartext payload- where- fakeCallback :: BL.ByteString -> String -> IO BL.ByteString- fakeCallback = const . return--testSecretKeyDecryption :: FilePath -> FilePath -> Assertion-testSecretKeyDecryption keyfile passfile = do- passphrase <- BL.readFile $ "tests/data/" ++ passfile- kr <- DC.runConduitRes $ CB.sourceFile ("tests/data/" ++ keyfile) DC..| conduitGet get DC..| CL.consume- let SecretKey pkp ska = fromPkt . head $ kr- SUUnencrypted skey _ = decryptPrivateKey (pkp, ska) passphrase- doPkeyAndSkeyMatch (_pubkey pkp) skey---- FIXME: this should be reworked either with tasty-golden or some other form of sanity-testSecretKeyEncryption :: FilePath -> FilePath -> Assertion-testSecretKeyEncryption keyfile passfile = do- passphrase <- BL.readFile $ "tests/data/" ++ passfile- kr <- DC.runConduitRes $ CB.sourceFile ("tests/data/" ++ keyfile) DC..| conduitGet get DC..| CL.consume- gkr <- DC.runConduitRes $ CB.sourceFile ("tests/data/" ++ "aes256-sha512.seckey") DC..| conduitGet get DC..| CL.consume- let SecretKey pkp ska = fromPkt . head $ kr- newska = encryptPrivateKey "\226~\197\a\202#\"G" (IV "\187\219\253I\236\204\t5D\196\NAK>;\202\185\t") ska passphrase- newtruck = toPkt (SecretKey pkp newska):tail kr- assertEqual "encrypted private key matches golden file" gkr newtruck--testParsePktsUtil :: FilePath -> Assertion-testParsePktsUtil fn = do- let fpath = "tests/data/" ++ fn- cp <- DC.runConduitRes $ CB.sourceFile fpath DC..| conduitGet get DC..| CL.consume- pp <- parsePkts `fmap` BL.readFile fpath- assertEqual "parsePkts utility function gives same results as conduit pipeline" cp pp--testParseTKsUtil :: FilePath -> Assertion-testParseTKsUtil fn = do- let fpath = "tests/data/" ++ fn- lbs <- BL.readFile fpath- cp <- DC.runConduitRes $ CB.sourceLbs lbs DC..| conduitGet get DC..| conduitToTKs DC..| CL.consume- let pt = parseTKs True . parsePkts $ lbs- assertEqual "parsePkts utility function gives same results as conduit pipeline" cp pt--tests :: TestTree-tests = testGroup "Tests" [properties, unitTests]--unitTests :: TestTree-unitTests = testGroup "Unit Tests" [- testGroup "Serialization group" [- testCase "000001-006.public_key" (testSerialization "000001-006.public_key")- , testCase "000002-013.user_id" (testSerialization "000002-013.user_id")- , testCase "000003-002.sig" (testSerialization "000003-002.sig")- , testCase "000004-012.ring_trust" (testSerialization "000004-012.ring_trust")- , testCase "000005-002.sig" (testSerialization "000005-002.sig")- , testCase "000006-012.ring_trust" (testSerialization "000006-012.ring_trust")- , testCase "000007-002.sig" (testSerialization "000007-002.sig")- , testCase "000008-012.ring_trust" (testSerialization "000008-012.ring_trust")- , testCase "000009-002.sig" (testSerialization "000009-002.sig")- , testCase "000010-012.ring_trust" (testSerialization "000010-012.ring_trust")- , testCase "000011-002.sig" (testSerialization "000011-002.sig")- , testCase "000012-012.ring_trust" (testSerialization "000012-012.ring_trust")- , testCase "000013-014.public_subkey" (testSerialization "000013-014.public_subkey")- , testCase "000014-002.sig" (testSerialization "000014-002.sig")- , testCase "000015-012.ring_trust" (testSerialization "000015-012.ring_trust")- , testCase "000016-006.public_key" (testSerialization "000016-006.public_key")- , testCase "000017-002.sig" (testSerialization "000017-002.sig")- , testCase "000018-012.ring_trust" (testSerialization "000018-012.ring_trust")- , testCase "000019-013.user_id" (testSerialization "000019-013.user_id")- , testCase "000020-002.sig" (testSerialization "000020-002.sig")- , testCase "000021-012.ring_trust" (testSerialization "000021-012.ring_trust")- , testCase "000022-002.sig" (testSerialization "000022-002.sig")- , testCase "000023-012.ring_trust" (testSerialization "000023-012.ring_trust")- , testCase "000024-014.public_subkey" (testSerialization "000024-014.public_subkey")- , testCase "000025-002.sig" (testSerialization "000025-002.sig")- , testCase "000026-012.ring_trust" (testSerialization "000026-012.ring_trust")- , testCase "000027-006.public_key" (testSerialization "000027-006.public_key")- , testCase "000028-002.sig" (testSerialization "000028-002.sig")- , testCase "000029-012.ring_trust" (testSerialization "000029-012.ring_trust")- , testCase "000030-013.user_id" (testSerialization "000030-013.user_id")- , testCase "000031-002.sig" (testSerialization "000031-002.sig")- , testCase "000032-012.ring_trust" (testSerialization "000032-012.ring_trust")- , testCase "000033-002.sig" (testSerialization "000033-002.sig")- , testCase "000034-012.ring_trust" (testSerialization "000034-012.ring_trust")- , testCase "000035-006.public_key" (testSerialization "000035-006.public_key")- , testCase "000036-013.user_id" (testSerialization "000036-013.user_id")- , testCase "000037-002.sig" (testSerialization "000037-002.sig")- , testCase "000038-012.ring_trust" (testSerialization "000038-012.ring_trust")- , testCase "000039-002.sig" (testSerialization "000039-002.sig")- , testCase "000040-012.ring_trust" (testSerialization "000040-012.ring_trust")- , testCase "000041-017.attribute" (testSerialization "000041-017.attribute")- , testCase "000042-002.sig" (testSerialization "000042-002.sig")- , testCase "000043-012.ring_trust" (testSerialization "000043-012.ring_trust")- , testCase "000044-014.public_subkey" (testSerialization "000044-014.public_subkey")- , testCase "000045-002.sig" (testSerialization "000045-002.sig")- , testCase "000046-012.ring_trust" (testSerialization "000046-012.ring_trust")- , testCase "000047-005.secret_key" (testSerialization "000047-005.secret_key")- , testCase "000048-013.user_id" (testSerialization "000048-013.user_id")- , testCase "000049-002.sig" (testSerialization "000049-002.sig")- , testCase "000050-012.ring_trust" (testSerialization "000050-012.ring_trust")- , testCase "000051-007.secret_subkey" (testSerialization "000051-007.secret_subkey")- , testCase "000052-002.sig" (testSerialization "000052-002.sig")- , testCase "000053-012.ring_trust" (testSerialization "000053-012.ring_trust")- , testCase "000054-005.secret_key" (testSerialization "000054-005.secret_key")- , testCase "000055-002.sig" (testSerialization "000055-002.sig")- , testCase "000056-012.ring_trust" (testSerialization "000056-012.ring_trust")- , testCase "000057-013.user_id" (testSerialization "000057-013.user_id")- , testCase "000058-002.sig" (testSerialization "000058-002.sig")- , testCase "000059-012.ring_trust" (testSerialization "000059-012.ring_trust")- , testCase "000060-007.secret_subkey" (testSerialization "000060-007.secret_subkey")- , testCase "000061-002.sig" (testSerialization "000061-002.sig")- , testCase "000062-012.ring_trust" (testSerialization "000062-012.ring_trust")- , testCase "000063-005.secret_key" (testSerialization "000063-005.secret_key")- , testCase "000064-002.sig" (testSerialization "000064-002.sig")- , testCase "000065-012.ring_trust" (testSerialization "000065-012.ring_trust")- , testCase "000066-013.user_id" (testSerialization "000066-013.user_id")- , testCase "000067-002.sig" (testSerialization "000067-002.sig")- , testCase "000068-012.ring_trust" (testSerialization "000068-012.ring_trust")- , testCase "000069-005.secret_key" (testSerialization "000069-005.secret_key")- , testCase "000070-013.user_id" (testSerialization "000070-013.user_id")- , testCase "000071-002.sig" (testSerialization "000071-002.sig")- , testCase "000072-012.ring_trust" (testSerialization "000072-012.ring_trust")- , testCase "000073-017.attribute" (testSerialization "000073-017.attribute")- , testCase "000074-002.sig" (testSerialization "000074-002.sig")- , testCase "000075-012.ring_trust" (testSerialization "000075-012.ring_trust")- , testCase "000076-007.secret_subkey" (testSerialization "000076-007.secret_subkey")- , testCase "000077-002.sig" (testSerialization "000077-002.sig")- , testCase "000078-012.ring_trust" (testSerialization "000078-012.ring_trust")- , testCase "pubring.gpg" (testSerialization "pubring.gpg")- , testCase "secring.gpg" (testSerialization "secring.gpg")- , testCase "compressedsig.gpg" (testSerialization "compressedsig.gpg")- , testCase "compressedsig-zlib.gpg" (testSerialization "compressedsig-zlib.gpg")- , testCase "compressedsig-bzip2.gpg" (testSerialization "compressedsig-bzip2.gpg")- , testCase "onepass_sig" (testSerialization "onepass_sig")- , testCase "uncompressed-ops-dsa.gpg" (testSerialization "uncompressed-ops-dsa.gpg")- , testCase "uncompressed-ops-rsa.gpg" (testSerialization "uncompressed-ops-rsa.gpg")- , testCase "simple.seckey" (testSerialization "simple.seckey")- , testCase "v3-genericcert.sig" (testSerialization "v3-genericcert.sig")- , testCase "sigs-with-regexes" (testSerialization "sigs-with-regexes")- , testCase "gnu-dummy-s2k-101-secret-key.gpg" (testSerialization "gnu-dummy-s2k-101-secret-key.gpg")- , testCase "anibal-ed25519.gpg" (testSerialization "anibal-ed25519.gpg")- , testCase "nist_p-256_key.gpg" (testSerialization "nist_p-256_key.gpg")- , testCase "nist_p-256_secretkey.gpg" (testSerialization "nist_p-256_secretkey.gpg")- , testCase "sample-eddsa.pubkey" (testSerialization "sample-eddsa.pubkey")- ],- testGroup "PKA/Size/KeyID/fingerprint group" [- testCase "v3 key" (testPKAandSizeAndKeyIDandFingerprint "v3.key" "R1024:C7261095/CBD9 F412 6807 E405 CC2D 2712 1DF5 E86E")- , testCase "v4 key" (testPKAandSizeAndKeyIDandFingerprint "000001-006.public_key" "R1248:D4D54EA16F87040E/421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E")- , testCase "ECDSA key" (testPKAandSizeAndKeyIDandFingerprint "nist_p-256_key.gpg" "E256:F7708BADD6063224/174C CF12 C571 6D0E 527F B50E F770 8BAD D606 3224")- , testCase "EdDSA key" (testPKAandSizeAndKeyIDandFingerprint "sample-eddsa.pubkey" "w256:8CFDE12197965A9A/C959 BDBA FA32 A2F8 9A15 3B67 8CFD E121 9796 5A9A")- ],- testGroup "Keyring group" [- testCase "pubring 7732CF988A63EA86" (testKeyringLookup "pubring.gpg" "7732CF988A63EA86" True)- , testCase "pubring 123456789ABCDEF0" (testKeyringLookup "pubring.gpg" "123456789ABCDEF0" False)- , testCase "pubsub AD992E9C24399832" (testKeyringLookup "pubring.gpg" "AD992E9C24399832" True)- , testCase "secring 7732CF988A63EA86" (testKeyringLookup "secring.gpg" "7732CF988A63EA86" True)- , testCase "secring 123456789ABCDEF0" (testKeyringLookup "secring.gpg" "123456789ABCDEF0" False)- , testCase "secsub AD992E9C24399832" (testKeyringLookup "secring.gpg" "AD992E9C24399832" True)- -- FIXME: should count keys in rings- ],- testGroup "Message verification group" [- testCase "uncompressed-ops-dsa" (testVerifyMessage "pubring.gpg" "uncompressed-ops-dsa.gpg" [fp "1EB2 0B2F 5A5C C3BE AFD6 E5CB 7732 CF98 8A63 EA86"])- , testCase "uncompressed-ops-dsa-sha384" (testVerifyMessage "pubring.gpg" "uncompressed-ops-dsa-sha384.txt.gpg" [fp "1EB2 0B2F 5A5C C3BE AFD6 E5CB 7732 CF98 8A63 EA86"])- , testCase "uncompressed-ops-rsa" (testVerifyMessage "pubring.gpg" "uncompressed-ops-rsa.gpg" [fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D"])- , testCase "compressedsig" (testVerifyMessage "pubring.gpg" "compressedsig.gpg" [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])- , testCase "compressedsig-zlib" (testVerifyMessage "pubring.gpg" "compressedsig-zlib.gpg" [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])- , testCase "compressedsig-bzip2" (testVerifyMessage "pubring.gpg" "compressedsig-bzip2.gpg" [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])- ],- testGroup "Certificate verification group" [- testCase "userid" (testVerifyMessage "pubring.gpg" "minimized.gpg" [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])- , testCase "subkey" (testVerifyMessage "pubring.gpg" "subkey.gpg" [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])- , testCase "primary key binding" (testVerifyMessage "signing-subkey.gpg" "primary-binding.gpg" [fp "ED1B D216 F70E 5D5F 4444 48F9 B830 F2C4 83A9 9AE5"])- , testCase "attribute" (testVerifyMessage "pubring.gpg" "uat.gpg" [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])- , testCase "primary key revocation" (testVerifyMessage "pubring.gpg" "prikey-rev.gpg" [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])- , testCase "subkey revocation" (testVerifyMessage "pubring.gpg" "subkey-rev.gpg" [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])- , testCase "6F87040E" (testVerifyMessage "pubring.gpg" "6F87040E.pubkey" [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E", fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D", fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC"])- , testCase "6F87040E-cr" (testVerifyMessage "pubring.gpg" "6F87040E-cr.pubkey" [fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC", fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC", fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E", fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D", fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC"])- , testCase "simple RSA secret key" (testVerifyMessage "pubring.gpg" "simple.seckey" [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])- , testCase "simple ECDSA public key" (testVerifyMessage "ecdsa-key-without-ecdh.pubkey" "ecdsa-key-without-ecdh.pubkey" [fp "174C CF12 C571 6D0E 527F B50E F770 8BAD D606 3224"])- ],- testGroup "Key verification group" [- testCase "6F87040E pubkey" (testKeysSelfVerification True "6F87040E.pubkey")- , testCase "revoked pubkey" (testKeysSelfVerification False "revoked.pubkey")- , testCase "expired pubkey" (testKeysSelfVerification True "expired.pubkey")- , testCase "nist_p-256 pubkey" (testKeysSelfVerification True "nist_p-256_key.gpg")- , testCase "ed25519 pubkey" (testKeysSelfVerification True "ed25519.pubkey")- ],- testGroup "Key expiration group" [- testCase "6F87040E pubkey" (testKeysExpiration True "6F87040E.pubkey")- , testCase "expired pubkey" (testKeysExpiration False "expired.pubkey")- , testCase "nist_p-256 pubkey" (testKeysExpiration True "nist_p-256_key.gpg")- , testCase "ed25519-without-curve25519.pubkey" (testKeysExpiration True "ed25519-without-curve25519.pubkey")- , testCase "ed25519.pubkey" (testKeysExpiration True "ed25519.pubkey")- ],- testGroup "Compression group" [- testCase "compressedsig.gpg" (testCompression "compressedsig.gpg")- , testCase "compressedsig-zlib.gpg" (testCompression "compressedsig-zlib.gpg")- , testCase "compressedsig-bzip2.gpg" (testCompression "compressedsig-bzip2.gpg")- ],- testGroup "Conduit length group" [- testCase "conduitCompress (ZIP)" (testConduitOutputLength "pubring.gpg" (cgp DC..| conduitCompress ZIP) 1)- , testCase "conduitCompress (Zlib)" (testConduitOutputLength "pubring.gpg" (cgp DC..| conduitCompress ZLIB) 1)- , testCase "conduitCompress (BZip2)" (testConduitOutputLength "pubring.gpg" (cgp DC..| conduitCompress BZip2) 1)- , testCase "conduitToTKs" (testConduitOutputLength "pubring.gpg" (cgp DC..| conduitToTKs) 4)- , testCase "conduitToTKsDropping" (testConduitOutputLength "pubring.gpg" (cgp DC..| conduitToTKsDropping) 4)- ],- testGroup "Encrypted data" [- testCase "Symmetric Encryption simple S2K SHA1 3DES, no MDC" (testSymmetricEncryption "encryption-sym-3des-s2k0.gpg" "symmetric-password.txt" "test\n")- , testCase "Symmetric Encryption iterated-salted S2K SHA1 3DES, no MDC" (testSymmetricEncryption "encryption-sym-3des.gpg" "symmetric-password.txt" "test\n")- , testCase "Symmetric Encryption simple S2K SHA1 3DES" (testSymmetricEncryption "encryption-sym-3des-mdc-s2k0.gpg" "symmetric-password.txt" "test\n")- , testCase "Symmetric Encryption iterated-salted S2K SHA1 3DES" (testSymmetricEncryption "encryption-sym-3des-mdc.gpg" "symmetric-password.txt" "test\n")- , testCase "Symmetric Encryption simple S2K SHA1 CAST5, no MDC" (testSymmetricEncryption "encryption-sym-cast5-s2k0.gpg" "symmetric-password.txt" "test\n")- , testCase "Symmetric Encryption iterated-salted S2K SHA1 CAST5, no MDC" (testSymmetricEncryption "encryption-sym-cast5.gpg" "symmetric-password.txt" "test\n")- , testCase "Symmetric Encryption simple S2K SHA1 CAST5" (testSymmetricEncryption "encryption-sym-cast5-mdc-s2k0.gpg" "symmetric-password.txt" "test\n")- , testCase "Symmetric Encryption iterated-salted S2K SHA1 CAST5" (testSymmetricEncryption "encryption-sym-cast5-mdc.gpg" "symmetric-password.txt" "test\n")- , testCase "Symmetric Encryption simple S2K SHA1 Blowfish, no MDC" (testSymmetricEncryption "encryption-sym-blowfish-s2k0.gpg" "symmetric-password.txt" "test\n")- , testCase "Symmetric Encryption iterated-salted S2K SHA1 Blowfish, no MDC" (testSymmetricEncryption "encryption-sym-blowfish.gpg" "symmetric-password.txt" "test\n")- , testCase "Symmetric Encryption simple S2K SHA1 Blowfish" (testSymmetricEncryption "encryption-sym-blowfish-mdc-s2k0.gpg" "symmetric-password.txt" "test\n")- , testCase "Symmetric Encryption iterated-salted S2K SHA1 Blowfish" (testSymmetricEncryption "encryption-sym-blowfish-mdc.gpg" "symmetric-password.txt" "test\n")- , testCase "Symmetric Encryption simple S2K SHA1 AES128" (testSymmetricEncryption "encryption-sym-aes128-s2k0.gpg" "symmetric-password.txt" "test\n")- , testCase "Symmetric Encryption iterated-salted S2K SHA1 AES128" (testSymmetricEncryption "encryption-sym-aes128.gpg" "symmetric-password.txt" "test\n")- , testCase "Symmetric Encryption simple S2K SHA1 AES192" (testSymmetricEncryption "encryption-sym-aes192-s2k0.gpg" "symmetric-password.txt" "test\n")- , testCase "Symmetric Encryption iterated-salted S2K SHA1 AES192" (testSymmetricEncryption "encryption-sym-aes192.gpg" "symmetric-password.txt" "test\n")- , testCase "Symmetric Encryption simple S2K SHA1 AES256" (testSymmetricEncryption "encryption-sym-aes256-s2k0.gpg" "symmetric-password.txt" "test\n")- , testCase "Symmetric Encryption iterated-salted S2K SHA1 AES256" (testSymmetricEncryption "encryption-sym-aes256.gpg" "symmetric-password.txt" "test\n")- , testCase "Symmetric Encryption simple S2K SHA1 Twofish" (testSymmetricEncryption "encryption-sym-twofish-s2k0.gpg" "symmetric-password.txt" "test\n")- , testCase "Symmetric Encryption iterated-salted S2K SHA1 Twofish" (testSymmetricEncryption "encryption-sym-twofish.gpg" "symmetric-password.txt" "test\n")- , testCase "Symmetric Encryption simple Camellia128" (testSymmetricEncryption "encryption-sym-camellia128-s2k0.gpg" "symmetric-password.txt" "test\n")- , testCase "Symmetric Encryption iterated-salted Camellia128" (testSymmetricEncryption "encryption-sym-camellia128.gpg" "symmetric-password.txt" "test\n")- , testCase "Symmetric Encryption iterated-salted Camellia192" (testSymmetricEncryption "encryption-sym-camellia192.gpg" "symmetric-password.txt" "test\n")- , testCase "Symmetric Encryption iterated-salted Camellia256" (testSymmetricEncryption "encryption-sym-camellia256.gpg" "symmetric-password.txt" "test\n")- ],- testGroup "Encrypted secret keys" [- testCase "SUSSHA1 CAST5 IteratedSalted SHA1 RSA" (testSecretKeyDecryption "simple.seckey" "pki-password.txt")- , testCase "SUS16bit CAST5 IteratedSalted SHA1 RSA" (testSecretKeyDecryption "16bitcksum.seckey" "pki-password.txt")- , testCase "SUSSHA1 AES256 IteratedSalted SHA512 RSA" (testSecretKeyDecryption "aes256-sha512.seckey" "pki-password.txt")- , testCase "SUSSHA1 AES128 IteratedSalted SHA256 ECDSA" (testSecretKeyDecryption "nist_p-256_secretkey.gpg" "pki-password.txt")- ],- testGroup "Encrypting secret keys" [- testCase "SUSSHA1 AES256 IteratedSalted SHA512 RSA" (testSecretKeyEncryption "unencrypted.seckey" "pki-password.txt")- ],- testGroup "Utility function group" [- testCase "pubring as packets" (testParsePktsUtil "pubring.gpg")- , testCase "pubring as TKs" (testParseTKsUtil "pubring.gpg")- ]- ]--properties :: TestTree-properties = testGroup "Properties" [qcProps]--qcProps :: TestTree-qcProps = testGroup "(checked by QuickCheck)"- [ QC.testProperty "PKESK packet serialization-deserialization" $- \pkesk -> Right (pkesk :: PKESK) == runGet get (runPut (put pkesk))- , QC.testProperty "Signature packet serialization-deserialization" $- \sig -> Right (sig :: Signature) == runGet get (runPut (put sig))- , QC.testProperty "UserId packet serialization-deserialization" $- \uid -> Right (uid :: UserId) == runGet get (runPut (put uid))- ]--cgp :: DC.ConduitT B.ByteString Pkt (ResourceT IO) ()-cgp = conduitGet (get :: Get Pkt)--fp :: Text -> TwentyOctetFingerprint-fp = either error id . parseFingerprint--doPkeyAndSkeyMatch :: PKey -> SKey -> Assertion-doPkeyAndSkeyMatch (RSAPubKey (RSA_PublicKey rpub)) (RSAPrivateKey (RSA_PrivateKey rpriv)) = assertEqual "RSA private key matches RSA public key" rpub (RSA.private_pub rpriv)-doPkeyAndSkeyMatch (ECDSAPubKey (ECDSA_PublicKey ecpub)) (ECDSAPrivateKey (ECDSA_PrivateKey ecpriv)) = assertEqual "ECDSA private key curve matches ECDSA public key curve" (ECDSA.public_curve ecpub) (ECDSA.private_curve ecpriv)+-- Copyright © 2012-2019 Clint Adams+-- This software is released under the terms of the Expat license.+-- (See the LICENSE file).+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit (Assertion, assertEqual, assertFailure, testCase)+import Test.Tasty.QuickCheck as QC++import Codec.Encryption.OpenPGP.Arbitrary ()+import Codec.Encryption.OpenPGP.Compression (compressPkts, decompressPkt)+import Codec.Encryption.OpenPGP.Expirations (isTKTimeValid)+import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)+import Codec.Encryption.OpenPGP.KeyInfo (pkalgoAbbrev, pubkeySize)+import Codec.Encryption.OpenPGP.KeySelection (parseFingerprint)+import Codec.Encryption.OpenPGP.KeyringParser (parseTKs)+import Codec.Encryption.OpenPGP.SecretKey (decryptPrivateKey, encryptPrivateKey)+import Codec.Encryption.OpenPGP.Serialize (parsePkts)+import Codec.Encryption.OpenPGP.Signatures+ ( verifyAgainstKeys+ , verifySigWith+ , verifyTKWith+ )+import Codec.Encryption.OpenPGP.Types+import Control.Exception.Base (catch, SomeException)+import Control.Error.Util (isRight)+import Control.Monad.Trans.Resource (ResourceT)+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA+import qualified Crypto.PubKey.RSA as RSA+import Data.Bifunctor (bimap)+import Data.Binary (get, put)+import Data.Binary.Get (Get, runGetOrFail)+import Data.Binary.Put (runPut)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Conduit.OpenPGP.Compression (conduitCompress, conduitDecompress)+import Data.Conduit.OpenPGP.Decrypt (conduitDecrypt)+import Data.Conduit.OpenPGP.Keyring+ ( conduitToTKs+ , conduitToTKsDropping+ , sinkKeyringMap+ )+import Data.Conduit.OpenPGP.Verify (conduitVerify)+import Data.Conduit.Serialization.Binary (conduitGet)+import Data.IxSet.Typed ((@=), getOne)+import Data.Maybe (isJust)+import Data.Text (Text)+import Data.Text.Prettyprint.Doc (pretty)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)++import qualified Data.Conduit as DC+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.List as CL++-- this needs a better name+runGet :: Get a -> BL.ByteString -> Either String a+runGet g bs = bimap (\(_, _, x) -> x) (\(_, _, x) -> x) (runGetOrFail g bs)++-- FIXME: nothing tests serialization of TKs+testSerialization :: FilePath -> Assertion+testSerialization fpr = do+ bs <- BL.readFile $ "tests/data/" ++ fpr+ let firstpass = runGet get bs+ case fmap unBlock firstpass of+ Left _ -> assertFailure $ "First pass failed on " ++ fpr+ Right [] ->+ assertFailure $ "First pass of " ++ fpr ++ " decoded to nothing."+ Right packs -> do+ let roundtrip = runPut $ put (Block packs)+ let secondpass = runGet (get :: Get (Block Pkt)) roundtrip+ if fmap unBlock secondpass == Right []+ then assertFailure $ "Second pass of " ++ fpr ++ " decoded to nothing."+ else assertEqual ("for " ++ fpr) firstpass secondpass++testCompression :: FilePath -> Assertion+testCompression fpr = do+ bs <- BL.readFile $ "tests/data/" ++ fpr+ let firstpass = fmap (concatMap decompressPkt . unBlock) . runGet get $ bs+ case firstpass of+ Left _ -> assertFailure $ "First pass failed on " ++ fpr+ Right [] ->+ assertFailure $ "First pass of " ++ fpr ++ " decoded to nothing."+ Right packs -> do+ let roundtrip = runPut $ put . Block $ [compressPkts ZIP packs]+ let secondpass =+ fmap (concatMap decompressPkt . unBlock) . runGet get $ roundtrip+ if secondpass == Right []+ then assertFailure $ "Second pass of " ++ fpr ++ " decoded to nothing."+ else assertEqual ("for " ++ fpr) firstpass secondpass++counter :: (Monad m) => DC.ConduitT a DC.Void m Int+counter = CL.fold (const . (1 +)) 0++testConduitOutputLength ::+ FilePath+ -> DC.ConduitT B.ByteString b (ResourceT IO) ()+ -> Int+ -> Assertion+testConduitOutputLength fpr c target = do+ len <-+ DC.runConduitRes $+ CB.sourceFile ("tests/data/" ++ fpr) DC..| c DC..| counter+ assertEqual ("expected length " ++ show target) target len++testPKAandSizeAndKeyIDandFingerprint :: FilePath -> String -> Assertion+testPKAandSizeAndKeyIDandFingerprint fpr kf = do+ bs <- BL.readFile $ "tests/data/" ++ fpr+ case runGet (get :: Get Pkt) bs of+ Left _ -> assertFailure $ "Decoding of " ++ fpr ++ " broke."+ Right (PublicKeyPkt pkp) -> do+ let pref =+ concat+ [ pkalgoAbbrev (_pkalgo pkp)+ , either (const "unknown") show (pubkeySize (_pubkey pkp))+ , ":"+ , either (const "unknown") (show . pretty) (eightOctetKeyID pkp)+ , "/"+ ]+ assertEqual+ ("for " ++ fpr ++ " (spaceless)")+ (spaceless kf)+ (pref ++ show (pretty (fingerprint pkp)))+ assertEqual+ ("for " ++ fpr ++ " (spaced)")+ kf+ (pref ++ show (pretty (SpacedFingerprint (fingerprint pkp))))+ _ -> assertFailure "Expected public key, got something else."+ where+ spaceless = filter (/= ' ')++testKeyringLookup :: FilePath -> String -> Bool -> Assertion+testKeyringLookup fpr eok expected = do+ kr <-+ DC.runConduitRes $+ CB.sourceFile ("tests/data/" ++ fpr) DC..| conduitGet get DC..| conduitToTKs DC..|+ sinkKeyringMap+ let key = getOne (kr @= (read eok :: EightOctetKeyId))+ assertEqual (eok ++ " in " ++ fpr) expected (isJust key)++testVerifyMessage ::+ FilePath -> FilePath -> [TwentyOctetFingerprint] -> Assertion+testVerifyMessage keyring message issuers = do+ kr <-+ DC.runConduitRes $+ CB.sourceFile ("tests/data/" ++ keyring) DC..| conduitGet get DC..|+ conduitToTKs DC..|+ sinkKeyringMap+ verification <-+ DC.runConduitRes $+ CB.sourceFile ("tests/data/" ++ message) DC..| conduitGet get DC..|+ conduitDecompress DC..|+ conduitVerify kr Nothing DC..|+ CL.consume+ let verification' =+ map (fmap (fingerprint . _verificationSigner)) verification+ assertEqual (keyring ++ " for " ++ message) (map Right issuers) verification'++testKeysSelfVerification :: Bool -> FilePath -> Assertion+testKeysSelfVerification expectsuccess keyfile = do+ ks <-+ DC.runConduitRes $+ CB.sourceFile ("tests/data/" ++ keyfile) DC..| conduitGet get DC..|+ conduitToTKs DC..|+ CL.consume+ let verifieds =+ mapM (verifyTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks+ assertEqual+ (keyfile ++ " self-verification")+ expectsuccess+ (isRight verifieds) -- FIXME:++testKeysExpiration :: Bool -> FilePath -> Assertion+testKeysExpiration expectsuccess keyfile = do+ ks <-+ DC.runConduitRes $+ CB.sourceFile ("tests/data/" ++ keyfile) DC..| conduitGet get DC..|+ conduitToTKs DC..|+ CL.consume+ let Right verifieds =+ mapM (verifyTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks+ tvalid =+ all+ (isTKTimeValid+ (posixSecondsToUTCTime (realToFrac (1400000000 :: Integer))))+ verifieds+ assertEqual (keyfile ++ " key expiration") expectsuccess tvalid++-- This needs a lot of work+testSymmetricEncryption :: FilePath -> FilePath -> BL.ByteString -> Assertion+testSymmetricEncryption encfile passfile cleartext = do+ passphrase <- BL.readFile $ "tests/data/" ++ passfile+ -- get parse tree+ pt <-+ DC.runConduitRes $+ CB.sourceFile ("tests/data/" ++ encfile) DC..| conduitGet get DC..|+ CL.consume+ -- assert parse tree has exactly two packets: skesk, encdata+ assertEqual "wrong number of packets" 2 (length pt)+ let skesk = fromPkt . head $ pt+ d = fromPkt . last $ pt+ -- FIXME: these assertions don't currently do anything properly,+ -- because haskell notices the _-prefixed accessor invocations below+ -- and the type system chokes before we hit them:+ assertEqual "first packet should be SKESK" SKESKType (packetType skesk)+ assertEqual+ "second packet should be encrypted data"+ SymEncIntegrityProtectedDataType+ (packetType d)+ decrypted <-+ catch+ (DC.runConduitRes $+ CL.sourceList pt DC..| conduitDecrypt (fakeCallback passphrase) DC..|+ CL.consume)+ (\e -> do+ let err = show (e :: SomeException)+ assertFailure ("decryption threw exception: " ++ err))+ let payload = _literalDataPayload . fromPkt . head $ decrypted+ assertEqual ("cleartext for " ++ encfile) cleartext payload+ where+ fakeCallback :: BL.ByteString -> String -> IO BL.ByteString+ fakeCallback = const . return++testSecretKeyDecryption :: FilePath -> FilePath -> Assertion+testSecretKeyDecryption keyfile passfile = do+ passphrase <- BL.readFile $ "tests/data/" ++ passfile+ kr <-+ DC.runConduitRes $+ CB.sourceFile ("tests/data/" ++ keyfile) DC..| conduitGet get DC..|+ CL.consume+ let SecretKey pkp ska = fromPkt . head $ kr+ SUUnencrypted skey _ = decryptPrivateKey (pkp, ska) passphrase+ doPkeyAndSkeyMatch (_pubkey pkp) skey++-- FIXME: this should be reworked either with tasty-golden or some other form of sanity+testSecretKeyEncryption :: FilePath -> FilePath -> Assertion+testSecretKeyEncryption keyfile passfile = do+ passphrase <- BL.readFile $ "tests/data/" ++ passfile+ kr <-+ DC.runConduitRes $+ CB.sourceFile ("tests/data/" ++ keyfile) DC..| conduitGet get DC..|+ CL.consume+ gkr <-+ DC.runConduitRes $+ CB.sourceFile ("tests/data/" ++ "aes256-sha512.seckey") DC..| conduitGet get DC..|+ CL.consume+ let SecretKey pkp ska = fromPkt . head $ kr+ newska =+ encryptPrivateKey+ "\226~\197\a\202#\"G"+ (IV "\187\219\253I\236\204\t5D\196\NAK>;\202\185\t")+ ska+ passphrase+ newtruck = toPkt (SecretKey pkp newska) : tail kr+ assertEqual "encrypted private key matches golden file" gkr newtruck++testParsePktsUtil :: FilePath -> Assertion+testParsePktsUtil fn = do+ let fpath = "tests/data/" ++ fn+ cp <-+ DC.runConduitRes $ CB.sourceFile fpath DC..| conduitGet get DC..| CL.consume+ pp <- parsePkts `fmap` BL.readFile fpath+ assertEqual+ "parsePkts utility function gives same results as conduit pipeline"+ cp+ pp++testParseTKsUtil :: FilePath -> Assertion+testParseTKsUtil fn = do+ let fpath = "tests/data/" ++ fn+ lbs <- BL.readFile fpath+ cp <-+ DC.runConduitRes $+ CB.sourceLbs lbs DC..| conduitGet get DC..| conduitToTKs DC..| CL.consume+ let pt = parseTKs True . parsePkts $ lbs+ assertEqual+ "parsePkts utility function gives same results as conduit pipeline"+ cp+ pt++tests :: TestTree+tests = testGroup "Tests" [properties, unitTests]++unitTests :: TestTree+unitTests =+ testGroup+ "Unit Tests"+ [ testGroup+ "Serialization group"+ [ testCase+ "000001-006.public_key"+ (testSerialization "000001-006.public_key")+ , testCase "000002-013.user_id" (testSerialization "000002-013.user_id")+ , testCase "000003-002.sig" (testSerialization "000003-002.sig")+ , testCase+ "000004-012.ring_trust"+ (testSerialization "000004-012.ring_trust")+ , testCase "000005-002.sig" (testSerialization "000005-002.sig")+ , testCase+ "000006-012.ring_trust"+ (testSerialization "000006-012.ring_trust")+ , testCase "000007-002.sig" (testSerialization "000007-002.sig")+ , testCase+ "000008-012.ring_trust"+ (testSerialization "000008-012.ring_trust")+ , testCase "000009-002.sig" (testSerialization "000009-002.sig")+ , testCase+ "000010-012.ring_trust"+ (testSerialization "000010-012.ring_trust")+ , testCase "000011-002.sig" (testSerialization "000011-002.sig")+ , testCase+ "000012-012.ring_trust"+ (testSerialization "000012-012.ring_trust")+ , testCase+ "000013-014.public_subkey"+ (testSerialization "000013-014.public_subkey")+ , testCase "000014-002.sig" (testSerialization "000014-002.sig")+ , testCase+ "000015-012.ring_trust"+ (testSerialization "000015-012.ring_trust")+ , testCase+ "000016-006.public_key"+ (testSerialization "000016-006.public_key")+ , testCase "000017-002.sig" (testSerialization "000017-002.sig")+ , testCase+ "000018-012.ring_trust"+ (testSerialization "000018-012.ring_trust")+ , testCase "000019-013.user_id" (testSerialization "000019-013.user_id")+ , testCase "000020-002.sig" (testSerialization "000020-002.sig")+ , testCase+ "000021-012.ring_trust"+ (testSerialization "000021-012.ring_trust")+ , testCase "000022-002.sig" (testSerialization "000022-002.sig")+ , testCase+ "000023-012.ring_trust"+ (testSerialization "000023-012.ring_trust")+ , testCase+ "000024-014.public_subkey"+ (testSerialization "000024-014.public_subkey")+ , testCase "000025-002.sig" (testSerialization "000025-002.sig")+ , testCase+ "000026-012.ring_trust"+ (testSerialization "000026-012.ring_trust")+ , testCase+ "000027-006.public_key"+ (testSerialization "000027-006.public_key")+ , testCase "000028-002.sig" (testSerialization "000028-002.sig")+ , testCase+ "000029-012.ring_trust"+ (testSerialization "000029-012.ring_trust")+ , testCase "000030-013.user_id" (testSerialization "000030-013.user_id")+ , testCase "000031-002.sig" (testSerialization "000031-002.sig")+ , testCase+ "000032-012.ring_trust"+ (testSerialization "000032-012.ring_trust")+ , testCase "000033-002.sig" (testSerialization "000033-002.sig")+ , testCase+ "000034-012.ring_trust"+ (testSerialization "000034-012.ring_trust")+ , testCase+ "000035-006.public_key"+ (testSerialization "000035-006.public_key")+ , testCase "000036-013.user_id" (testSerialization "000036-013.user_id")+ , testCase "000037-002.sig" (testSerialization "000037-002.sig")+ , testCase+ "000038-012.ring_trust"+ (testSerialization "000038-012.ring_trust")+ , testCase "000039-002.sig" (testSerialization "000039-002.sig")+ , testCase+ "000040-012.ring_trust"+ (testSerialization "000040-012.ring_trust")+ , testCase+ "000041-017.attribute"+ (testSerialization "000041-017.attribute")+ , testCase "000042-002.sig" (testSerialization "000042-002.sig")+ , testCase+ "000043-012.ring_trust"+ (testSerialization "000043-012.ring_trust")+ , testCase+ "000044-014.public_subkey"+ (testSerialization "000044-014.public_subkey")+ , testCase "000045-002.sig" (testSerialization "000045-002.sig")+ , testCase+ "000046-012.ring_trust"+ (testSerialization "000046-012.ring_trust")+ , testCase+ "000047-005.secret_key"+ (testSerialization "000047-005.secret_key")+ , testCase "000048-013.user_id" (testSerialization "000048-013.user_id")+ , testCase "000049-002.sig" (testSerialization "000049-002.sig")+ , testCase+ "000050-012.ring_trust"+ (testSerialization "000050-012.ring_trust")+ , testCase+ "000051-007.secret_subkey"+ (testSerialization "000051-007.secret_subkey")+ , testCase "000052-002.sig" (testSerialization "000052-002.sig")+ , testCase+ "000053-012.ring_trust"+ (testSerialization "000053-012.ring_trust")+ , testCase+ "000054-005.secret_key"+ (testSerialization "000054-005.secret_key")+ , testCase "000055-002.sig" (testSerialization "000055-002.sig")+ , testCase+ "000056-012.ring_trust"+ (testSerialization "000056-012.ring_trust")+ , testCase "000057-013.user_id" (testSerialization "000057-013.user_id")+ , testCase "000058-002.sig" (testSerialization "000058-002.sig")+ , testCase+ "000059-012.ring_trust"+ (testSerialization "000059-012.ring_trust")+ , testCase+ "000060-007.secret_subkey"+ (testSerialization "000060-007.secret_subkey")+ , testCase "000061-002.sig" (testSerialization "000061-002.sig")+ , testCase+ "000062-012.ring_trust"+ (testSerialization "000062-012.ring_trust")+ , testCase+ "000063-005.secret_key"+ (testSerialization "000063-005.secret_key")+ , testCase "000064-002.sig" (testSerialization "000064-002.sig")+ , testCase+ "000065-012.ring_trust"+ (testSerialization "000065-012.ring_trust")+ , testCase "000066-013.user_id" (testSerialization "000066-013.user_id")+ , testCase "000067-002.sig" (testSerialization "000067-002.sig")+ , testCase+ "000068-012.ring_trust"+ (testSerialization "000068-012.ring_trust")+ , testCase+ "000069-005.secret_key"+ (testSerialization "000069-005.secret_key")+ , testCase "000070-013.user_id" (testSerialization "000070-013.user_id")+ , testCase "000071-002.sig" (testSerialization "000071-002.sig")+ , testCase+ "000072-012.ring_trust"+ (testSerialization "000072-012.ring_trust")+ , testCase+ "000073-017.attribute"+ (testSerialization "000073-017.attribute")+ , testCase "000074-002.sig" (testSerialization "000074-002.sig")+ , testCase+ "000075-012.ring_trust"+ (testSerialization "000075-012.ring_trust")+ , testCase+ "000076-007.secret_subkey"+ (testSerialization "000076-007.secret_subkey")+ , testCase "000077-002.sig" (testSerialization "000077-002.sig")+ , testCase+ "000078-012.ring_trust"+ (testSerialization "000078-012.ring_trust")+ , testCase "pubring.gpg" (testSerialization "pubring.gpg")+ , testCase "secring.gpg" (testSerialization "secring.gpg")+ , testCase "compressedsig.gpg" (testSerialization "compressedsig.gpg")+ , testCase+ "compressedsig-zlib.gpg"+ (testSerialization "compressedsig-zlib.gpg")+ , testCase+ "compressedsig-bzip2.gpg"+ (testSerialization "compressedsig-bzip2.gpg")+ , testCase "onepass_sig" (testSerialization "onepass_sig")+ , testCase+ "uncompressed-ops-dsa.gpg"+ (testSerialization "uncompressed-ops-dsa.gpg")+ , testCase+ "uncompressed-ops-rsa.gpg"+ (testSerialization "uncompressed-ops-rsa.gpg")+ , testCase "simple.seckey" (testSerialization "simple.seckey")+ , testCase "v3-genericcert.sig" (testSerialization "v3-genericcert.sig")+ , testCase "sigs-with-regexes" (testSerialization "sigs-with-regexes")+ , testCase+ "gnu-dummy-s2k-101-secret-key.gpg"+ (testSerialization "gnu-dummy-s2k-101-secret-key.gpg")+ , testCase "anibal-ed25519.gpg" (testSerialization "anibal-ed25519.gpg")+ , testCase "nist_p-256_key.gpg" (testSerialization "nist_p-256_key.gpg")+ , testCase+ "nist_p-256_secretkey.gpg"+ (testSerialization "nist_p-256_secretkey.gpg")+ , testCase+ "sample-eddsa.pubkey"+ (testSerialization "sample-eddsa.pubkey")+ ]+ , testGroup+ "PKA/Size/KeyID/fingerprint group"+ [ testCase+ "v3 key"+ (testPKAandSizeAndKeyIDandFingerprint+ "v3.key"+ "R1024:C7261095/CBD9 F412 6807 E405 CC2D 2712 1DF5 E86E")+ , testCase+ "v4 key"+ (testPKAandSizeAndKeyIDandFingerprint+ "000001-006.public_key"+ "R1248:D4D54EA16F87040E/421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E")+ , testCase+ "ECDSA key"+ (testPKAandSizeAndKeyIDandFingerprint+ "nist_p-256_key.gpg"+ "E256:F7708BADD6063224/174C CF12 C571 6D0E 527F B50E F770 8BAD D606 3224")+ , testCase+ "EdDSA key"+ (testPKAandSizeAndKeyIDandFingerprint+ "sample-eddsa.pubkey"+ "w256:8CFDE12197965A9A/C959 BDBA FA32 A2F8 9A15 3B67 8CFD E121 9796 5A9A")+ ]+ , testGroup+ "Keyring group"+ [ testCase+ "pubring 7732CF988A63EA86"+ (testKeyringLookup "pubring.gpg" "7732CF988A63EA86" True)+ , testCase+ "pubring 123456789ABCDEF0"+ (testKeyringLookup "pubring.gpg" "123456789ABCDEF0" False)+ , testCase+ "pubsub AD992E9C24399832"+ (testKeyringLookup "pubring.gpg" "AD992E9C24399832" True)+ , testCase+ "secring 7732CF988A63EA86"+ (testKeyringLookup "secring.gpg" "7732CF988A63EA86" True)+ , testCase+ "secring 123456789ABCDEF0"+ (testKeyringLookup "secring.gpg" "123456789ABCDEF0" False)+ , testCase+ "secsub AD992E9C24399832"+ (testKeyringLookup "secring.gpg" "AD992E9C24399832" True)+ -- FIXME: should count keys in rings+ ]+ , testGroup+ "Message verification group"+ [ testCase+ "uncompressed-ops-dsa"+ (testVerifyMessage+ "pubring.gpg"+ "uncompressed-ops-dsa.gpg"+ [fp "1EB2 0B2F 5A5C C3BE AFD6 E5CB 7732 CF98 8A63 EA86"])+ , testCase+ "uncompressed-ops-dsa-sha384"+ (testVerifyMessage+ "pubring.gpg"+ "uncompressed-ops-dsa-sha384.txt.gpg"+ [fp "1EB2 0B2F 5A5C C3BE AFD6 E5CB 7732 CF98 8A63 EA86"])+ , testCase+ "uncompressed-ops-rsa"+ (testVerifyMessage+ "pubring.gpg"+ "uncompressed-ops-rsa.gpg"+ [fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D"])+ , testCase+ "compressedsig"+ (testVerifyMessage+ "pubring.gpg"+ "compressedsig.gpg"+ [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])+ , testCase+ "compressedsig-zlib"+ (testVerifyMessage+ "pubring.gpg"+ "compressedsig-zlib.gpg"+ [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])+ , testCase+ "compressedsig-bzip2"+ (testVerifyMessage+ "pubring.gpg"+ "compressedsig-bzip2.gpg"+ [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])+ ]+ , testGroup+ "Certificate verification group"+ [ testCase+ "userid"+ (testVerifyMessage+ "pubring.gpg"+ "minimized.gpg"+ [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])+ , testCase+ "subkey"+ (testVerifyMessage+ "pubring.gpg"+ "subkey.gpg"+ [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])+ , testCase+ "primary key binding"+ (testVerifyMessage+ "signing-subkey.gpg"+ "primary-binding.gpg"+ [fp "ED1B D216 F70E 5D5F 4444 48F9 B830 F2C4 83A9 9AE5"])+ , testCase+ "attribute"+ (testVerifyMessage+ "pubring.gpg"+ "uat.gpg"+ [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])+ , testCase+ "primary key revocation"+ (testVerifyMessage+ "pubring.gpg"+ "prikey-rev.gpg"+ [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])+ , testCase+ "subkey revocation"+ (testVerifyMessage+ "pubring.gpg"+ "subkey-rev.gpg"+ [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])+ , testCase+ "6F87040E"+ (testVerifyMessage+ "pubring.gpg"+ "6F87040E.pubkey"+ [ fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"+ , fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D"+ , fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC"+ ])+ , testCase+ "6F87040E-cr"+ (testVerifyMessage+ "pubring.gpg"+ "6F87040E-cr.pubkey"+ [ fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC"+ , fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC"+ , fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"+ , fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D"+ , fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC"+ ])+ , testCase+ "simple RSA secret key"+ (testVerifyMessage+ "pubring.gpg"+ "simple.seckey"+ [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])+ , testCase+ "simple ECDSA public key"+ (testVerifyMessage+ "ecdsa-key-without-ecdh.pubkey"+ "ecdsa-key-without-ecdh.pubkey"+ [fp "174C CF12 C571 6D0E 527F B50E F770 8BAD D606 3224"])+ ]+ , testGroup+ "Key verification group"+ [ testCase+ "6F87040E pubkey"+ (testKeysSelfVerification True "6F87040E.pubkey")+ , testCase+ "revoked pubkey"+ (testKeysSelfVerification False "revoked.pubkey")+ , testCase+ "expired pubkey"+ (testKeysSelfVerification True "expired.pubkey")+ , testCase+ "nist_p-256 pubkey"+ (testKeysSelfVerification True "nist_p-256_key.gpg")+ , testCase+ "ed25519 pubkey"+ (testKeysSelfVerification True "ed25519.pubkey")+ ]+ , testGroup+ "Key expiration group"+ [ testCase "6F87040E pubkey" (testKeysExpiration True "6F87040E.pubkey")+ , testCase "expired pubkey" (testKeysExpiration False "expired.pubkey")+ , testCase+ "nist_p-256 pubkey"+ (testKeysExpiration True "nist_p-256_key.gpg")+ , testCase+ "ed25519-without-curve25519.pubkey"+ (testKeysExpiration True "ed25519-without-curve25519.pubkey")+ , testCase "ed25519.pubkey" (testKeysExpiration True "ed25519.pubkey")+ ]+ , testGroup+ "Compression group"+ [ testCase "compressedsig.gpg" (testCompression "compressedsig.gpg")+ , testCase+ "compressedsig-zlib.gpg"+ (testCompression "compressedsig-zlib.gpg")+ , testCase+ "compressedsig-bzip2.gpg"+ (testCompression "compressedsig-bzip2.gpg")+ ]+ , testGroup+ "Conduit length group"+ [ testCase+ "conduitCompress (ZIP)"+ (testConduitOutputLength+ "pubring.gpg"+ (cgp DC..| conduitCompress ZIP)+ 1)+ , testCase+ "conduitCompress (Zlib)"+ (testConduitOutputLength+ "pubring.gpg"+ (cgp DC..| conduitCompress ZLIB)+ 1)+ , testCase+ "conduitCompress (BZip2)"+ (testConduitOutputLength+ "pubring.gpg"+ (cgp DC..| conduitCompress BZip2)+ 1)+ , testCase+ "conduitToTKs"+ (testConduitOutputLength "pubring.gpg" (cgp DC..| conduitToTKs) 4)+ , testCase+ "conduitToTKsDropping"+ (testConduitOutputLength+ "pubring.gpg"+ (cgp DC..| conduitToTKsDropping)+ 4)+ ]+ , testGroup+ "Encrypted data"+ [ testCase+ "Symmetric Encryption simple S2K SHA1 3DES, no MDC"+ (testSymmetricEncryption+ "encryption-sym-3des-s2k0.gpg"+ "symmetric-password.txt"+ "test\n")+ , testCase+ "Symmetric Encryption iterated-salted S2K SHA1 3DES, no MDC"+ (testSymmetricEncryption+ "encryption-sym-3des.gpg"+ "symmetric-password.txt"+ "test\n")+ , testCase+ "Symmetric Encryption simple S2K SHA1 3DES"+ (testSymmetricEncryption+ "encryption-sym-3des-mdc-s2k0.gpg"+ "symmetric-password.txt"+ "test\n")+ , testCase+ "Symmetric Encryption iterated-salted S2K SHA1 3DES"+ (testSymmetricEncryption+ "encryption-sym-3des-mdc.gpg"+ "symmetric-password.txt"+ "test\n")+ , testCase+ "Symmetric Encryption simple S2K SHA1 CAST5, no MDC"+ (testSymmetricEncryption+ "encryption-sym-cast5-s2k0.gpg"+ "symmetric-password.txt"+ "test\n")+ , testCase+ "Symmetric Encryption iterated-salted S2K SHA1 CAST5, no MDC"+ (testSymmetricEncryption+ "encryption-sym-cast5.gpg"+ "symmetric-password.txt"+ "test\n")+ , testCase+ "Symmetric Encryption simple S2K SHA1 CAST5"+ (testSymmetricEncryption+ "encryption-sym-cast5-mdc-s2k0.gpg"+ "symmetric-password.txt"+ "test\n")+ , testCase+ "Symmetric Encryption iterated-salted S2K SHA1 CAST5"+ (testSymmetricEncryption+ "encryption-sym-cast5-mdc.gpg"+ "symmetric-password.txt"+ "test\n")+ , testCase+ "Symmetric Encryption simple S2K SHA1 Blowfish, no MDC"+ (testSymmetricEncryption+ "encryption-sym-blowfish-s2k0.gpg"+ "symmetric-password.txt"+ "test\n")+ , testCase+ "Symmetric Encryption iterated-salted S2K SHA1 Blowfish, no MDC"+ (testSymmetricEncryption+ "encryption-sym-blowfish.gpg"+ "symmetric-password.txt"+ "test\n")+ , testCase+ "Symmetric Encryption simple S2K SHA1 Blowfish"+ (testSymmetricEncryption+ "encryption-sym-blowfish-mdc-s2k0.gpg"+ "symmetric-password.txt"+ "test\n")+ , testCase+ "Symmetric Encryption iterated-salted S2K SHA1 Blowfish"+ (testSymmetricEncryption+ "encryption-sym-blowfish-mdc.gpg"+ "symmetric-password.txt"+ "test\n")+ , testCase+ "Symmetric Encryption simple S2K SHA1 AES128"+ (testSymmetricEncryption+ "encryption-sym-aes128-s2k0.gpg"+ "symmetric-password.txt"+ "test\n")+ , testCase+ "Symmetric Encryption iterated-salted S2K SHA1 AES128"+ (testSymmetricEncryption+ "encryption-sym-aes128.gpg"+ "symmetric-password.txt"+ "test\n")+ , testCase+ "Symmetric Encryption simple S2K SHA1 AES192"+ (testSymmetricEncryption+ "encryption-sym-aes192-s2k0.gpg"+ "symmetric-password.txt"+ "test\n")+ , testCase+ "Symmetric Encryption iterated-salted S2K SHA1 AES192"+ (testSymmetricEncryption+ "encryption-sym-aes192.gpg"+ "symmetric-password.txt"+ "test\n")+ , testCase+ "Symmetric Encryption simple S2K SHA1 AES256"+ (testSymmetricEncryption+ "encryption-sym-aes256-s2k0.gpg"+ "symmetric-password.txt"+ "test\n")+ , testCase+ "Symmetric Encryption iterated-salted S2K SHA1 AES256"+ (testSymmetricEncryption+ "encryption-sym-aes256.gpg"+ "symmetric-password.txt"+ "test\n")+ , testCase+ "Symmetric Encryption simple S2K SHA1 Twofish"+ (testSymmetricEncryption+ "encryption-sym-twofish-s2k0.gpg"+ "symmetric-password.txt"+ "test\n")+ , testCase+ "Symmetric Encryption iterated-salted S2K SHA1 Twofish"+ (testSymmetricEncryption+ "encryption-sym-twofish.gpg"+ "symmetric-password.txt"+ "test\n")+ , testCase+ "Symmetric Encryption simple Camellia128"+ (testSymmetricEncryption+ "encryption-sym-camellia128-s2k0.gpg"+ "symmetric-password.txt"+ "test\n")+ , testCase+ "Symmetric Encryption iterated-salted Camellia128"+ (testSymmetricEncryption+ "encryption-sym-camellia128.gpg"+ "symmetric-password.txt"+ "test\n")+ , testCase+ "Symmetric Encryption iterated-salted Camellia192"+ (testSymmetricEncryption+ "encryption-sym-camellia192.gpg"+ "symmetric-password.txt"+ "test\n")+ , testCase+ "Symmetric Encryption iterated-salted Camellia256"+ (testSymmetricEncryption+ "encryption-sym-camellia256.gpg"+ "symmetric-password.txt"+ "test\n")+ , testCase+ "Symmetric Encryption pgcrypto"+ (testSymmetricEncryption+ "encryption-sym-pgcrypto.pgp"+ "pgcrypto-passphrase.txt"+ "{\"t\":\"plus\"}")+ ]+ , testGroup+ "Encrypted secret keys"+ [ testCase+ "SUSSHA1 CAST5 IteratedSalted SHA1 RSA"+ (testSecretKeyDecryption "simple.seckey" "pki-password.txt")+ , testCase+ "SUS16bit CAST5 IteratedSalted SHA1 RSA"+ (testSecretKeyDecryption "16bitcksum.seckey" "pki-password.txt")+ , testCase+ "SUSSHA1 AES256 IteratedSalted SHA512 RSA"+ (testSecretKeyDecryption "aes256-sha512.seckey" "pki-password.txt")+ , testCase+ "SUSSHA1 AES128 IteratedSalted SHA256 ECDSA"+ (testSecretKeyDecryption+ "nist_p-256_secretkey.gpg"+ "pki-password.txt")+ ]+ , testGroup+ "Encrypting secret keys"+ [ testCase+ "SUSSHA1 AES256 IteratedSalted SHA512 RSA"+ (testSecretKeyEncryption "unencrypted.seckey" "pki-password.txt")+ ]+ , testGroup+ "Utility function group"+ [ testCase "pubring as packets" (testParsePktsUtil "pubring.gpg")+ , testCase "pubring as TKs" (testParseTKsUtil "pubring.gpg")+ ]+ ]++properties :: TestTree+properties = testGroup "Properties" [qcProps]++qcProps :: TestTree+qcProps =+ testGroup+ "(checked by QuickCheck)"+ [ QC.testProperty "PKESK packet serialization-deserialization" $ \pkesk ->+ Right (pkesk :: PKESK) == runGet get (runPut (put pkesk))+ , QC.testProperty "Signature packet serialization-deserialization" $ \sig ->+ Right (sig :: Signature) == runGet get (runPut (put sig))+ , QC.testProperty "UserId packet serialization-deserialization" $ \uid ->+ Right (uid :: UserId) == runGet get (runPut (put uid))+ ]++cgp :: DC.ConduitT B.ByteString Pkt (ResourceT IO) ()+cgp = conduitGet (get :: Get Pkt)++fp :: Text -> TwentyOctetFingerprint+fp = either error id . parseFingerprint++doPkeyAndSkeyMatch :: PKey -> SKey -> Assertion+doPkeyAndSkeyMatch (RSAPubKey (RSA_PublicKey rpub)) (RSAPrivateKey (RSA_PrivateKey rpriv)) =+ assertEqual+ "RSA private key matches RSA public key"+ rpub+ (RSA.private_pub rpriv)+doPkeyAndSkeyMatch (ECDSAPubKey (ECDSA_PublicKey ecpub)) (ECDSAPrivateKey (ECDSA_PrivateKey ecpriv)) =+ assertEqual+ "ECDSA private key curve matches ECDSA public key curve"+ (ECDSA.public_curve ecpub)+ (ECDSA.private_curve ecpriv) doPkeyAndSkeyMatch _ _ = assertFailure "matching unimplemented" main :: IO ()