diff --git a/Codec/Encryption/OpenPGP/Arbitrary.hs b/Codec/Encryption/OpenPGP/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/OpenPGP/Arbitrary.hs @@ -0,0 +1,90 @@ +-- Arbitrary.hs: QuickCheck instances +-- Copyright © 2014 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). + +module Codec.Encryption.OpenPGP.Arbitrary () where + +import Codec.Encryption.OpenPGP.Types +import qualified Data.ByteString as B +import Test.QuickCheck (Arbitrary(..), choose, elements, frequency, getPositive, oneof, vector) +import Test.QuickCheck.Instances () + +instance Arbitrary PKESK where + arbitrary = do pv <- arbitrary + eoki <- arbitrary + pka <- arbitrary + mpis <- arbitrary + return $ PKESK pv eoki pka mpis + +instance Arbitrary Signature where + arbitrary = arbitrary >>= return . Signature + +instance Arbitrary UserId where + arbitrary = arbitrary >>= return . UserId + +-- + +instance Arbitrary SignaturePayload where + arbitrary = frequency [(2,three),(3,four),(1,other)] + where + three = do + st <- arbitrary + w32 <- arbitrary + eoki <- arbitrary + pka <- arbitrary + ha <- arbitrary + w16 <- arbitrary + mpis <- arbitrary + return (SigV3 st w32 eoki pka ha w16 mpis) + four = do + st <- arbitrary + pka <- arbitrary + ha <- arbitrary + has <- arbitrary + uhas <- arbitrary + w16 <- arbitrary + mpis <- arbitrary + return (SigV4 st pka ha has uhas w16 mpis) + other = do + v <- choose (5, maxBound) + bs <- arbitrary + return (SigVOther v bs) + +instance Arbitrary SigSubPacket where + arbitrary = do + crit <- arbitrary + pl <- arbitrary + return (SigSubPacket crit pl) + +instance Arbitrary SigSubPacketPayload where + arbitrary = oneof [sct, set, ec, ts, {- re, -} ket, psa] + where + sct = arbitrary >>= return . SigCreationTime + set = arbitrary >>= return . SigExpirationTime + ec = arbitrary >>= return . ExportableCertification + ts = arbitrary >>= \tl -> arbitrary >>= \ta -> return (TrustSignature tl ta) + re = arbitrary >>= return . RegularExpression -- FIXME: figure out why RegularExpression fails to serialize properly + ket = arbitrary >>= return . KeyExpirationTime + psa = arbitrary >>= return . PreferredSymmetricAlgorithms + -- FIXME: finish this + +-- + +instance Arbitrary PubKeyAlgorithm where + arbitrary = elements [RSA, DSA, EC, ECDSA, DH] + +instance Arbitrary EightOctetKeyId where + arbitrary = vector 8 >>= return . EightOctetKeyId . B.pack + +instance Arbitrary MPI where + arbitrary = arbitrary >>= return . MPI . getPositive + +instance Arbitrary SigType where + arbitrary = elements [BinarySig, CanonicalTextSig, StandaloneSig, GenericCert, PersonaCert, CasualCert, PositiveCert, SubkeyBindingSig, PrimaryKeyBindingSig, SignatureDirectlyOnAKey, KeyRevocationSig, SubkeyRevocationSig, CertRevocationSig, TimestampSig, ThirdPartyConfirmationSig] + +instance Arbitrary HashAlgorithm where + arbitrary = elements [DeprecatedMD5, SHA1, RIPEMD160, SHA256, SHA384, SHA512, SHA224] + +instance Arbitrary SymmetricAlgorithm where + arbitrary = elements [Plaintext, IDEA, TripleDES, CAST5, Blowfish, ReservedSAFER, ReservedDES, AES128, AES192, AES256, Twofish] 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 @@ -1,12 +1,16 @@ -- Verify.hs: OpenPGP (RFC4880) signature verification --- Copyright © 2012-2013 Clint Adams +-- Copyright © 2012-2014 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). module Codec.Encryption.OpenPGP.Signatures ( verifySig + , verifySigWith , verify + , verifyAgainstKeyring + , verifyAgainstKeys , verifyTK + , verifyTKWith ) where import Control.Monad (guard, liftM2) @@ -15,7 +19,6 @@ import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.RSA.PKCS15 as P15 -import Control.Lens ((^.)) import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.Either (lefts, rights) @@ -31,19 +34,27 @@ import Codec.Encryption.OpenPGP.Types import Data.Conduit.OpenPGP.Keyring.Instances () +{-# DEPRECATED verifySig "This function will be removed in favor of verifySigWith verifyAgainstKeyring" #-} verifySig :: Keyring -> Pkt -> PktStreamContext -> Maybe UTCTime -> Either String Verification -- FIXME: check expiration here? -verifySig kr sig@(SignaturePkt (SigV4 st _ _ hs _ _ _)) state mt = do - v <- verify kr sig mt (payloadForSig st state) +verifySig = verifySigWith . verifyAgainstKeyring + +verifySigWith :: (Pkt -> Maybe UTCTime -> ByteString -> Either String Verification) -> Pkt -> PktStreamContext -> Maybe UTCTime -> Either String Verification -- FIXME: check expiration here? +verifySigWith vf sig@(SignaturePkt (SigV4 st _ _ hs _ _ _)) state mt = do + v <- vf sig mt (payloadForSig st state) _ <- mapM_ (checkIssuer (eightOctetKeyID (_verificationSigner v)) . _sspPayload) hs return v where checkIssuer :: EightOctetKeyId -> SigSubPacketPayload -> Either String Bool checkIssuer signer (Issuer i) = if signer == i then Right True else Left "issuer subpacket does not match" checkIssuer _ _ = Right True -verifySig _ _ _ _ = Left "This should never happen." +verifySigWith _ _ _ _ = Left "This should never happen." +{-# DEPRECATED verifyTK "This function will be removed in favor of verifyTKWith verifyAgainstKeyring" #-} verifyTK :: Keyring -> Maybe UTCTime -> TK -> Either String TK -verifyTK kr mt key = do +verifyTK = verifyTKWith . verifySigWith . verifyAgainstKeyring + +verifyTKWith :: (Pkt -> PktStreamContext -> Maybe UTCTime -> Either String Verification) -> Maybe UTCTime -> TK -> Either String TK +verifyTKWith vsf mt key = do revokers <- checkRevokers key revs <- checkKeyRevocations revokers key let uids = filter (\(_, sps) -> sps /= []) . checkUidSigs $ _tkUIDs key -- FIXME: check revocations here? @@ -53,18 +64,18 @@ where checkRevokers = Right . concat . rights . map verifyRevoker . filter isRevokerP . _tkRevs checkKeyRevocations :: [(PubKeyAlgorithm, TwentyOctetFingerprint)] -> TK -> Either String [SignaturePayload] - checkKeyRevocations rs k = Prelude.sequence . concatMap (filterRevs rs) . rights . map (liftM2 fmap (,) (vSig kr)) . _tkRevs $ k + checkKeyRevocations rs k = Prelude.sequence . concatMap (filterRevs rs) . rights . map (liftM2 fmap (,) vSig) . _tkRevs $ k checkUidSigs :: [(String, [SignaturePayload])] -> [(String, [SignaturePayload])] - checkUidSigs = map (\(uid, sps) -> (uid, (rights . map (\sp -> fmap (const sp) (vUid kr (uid, sp)))) sps)) + checkUidSigs = map (\(uid, sps) -> (uid, (rights . map (\sp -> fmap (const sp) (vUid (uid, sp)))) sps)) checkUAtSigs :: [([UserAttrSubPacket], [SignaturePayload])] -> [([UserAttrSubPacket], [SignaturePayload])] - checkUAtSigs = map (\(uat, sps) -> (uat, (rights . map (\sp -> fmap (const sp) (vUAt kr (uat, sp)))) sps)) + checkUAtSigs = map (\(uat, sps) -> (uat, (rights . map (\sp -> fmap (const sp) (vUAt (uat, sp)))) sps)) checkSub :: (Pkt, SignaturePayload, Maybe SignaturePayload) -> [(Pkt, SignaturePayload, Maybe SignaturePayload)] checkSub (pkt, sp, mrp) = if revokedSub pkt mrp then [] else checkSub' pkt sp revokedSub :: Pkt -> Maybe SignaturePayload -> Bool revokedSub _ Nothing = False - revokedSub p (Just rp) = vSubSig kr p rp + revokedSub p (Just rp) = vSubSig p rp checkSub' :: Pkt -> SignaturePayload -> [(Pkt, SignaturePayload, Maybe SignaturePayload)] - checkSub' p sp = guard (vSubSig kr p sp) >> return (p, sp, Nothing) + checkSub' p sp = guard (vSubSig p sp) >> return (p, sp, Nothing) getHasheds (SigV4 _ _ _ ha _ _ _) = ha getHasheds _ = [] filterRevs :: [(PubKeyAlgorithm, TwentyOctetFingerprint)] -> (SignaturePayload, Verification) -> [Either String SignaturePayload] @@ -80,26 +91,34 @@ isRevocationKeySSP _ = False isIssuerSSP (SigSubPacket _ (Issuer _)) = True isIssuerSSP _ = False - vUid :: Keyring -> (String, SignaturePayload) -> Either String Verification - vUid keyring (uid, sp) = verifySig keyring (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (_tkPKP key), lastUIDorUAt = UserIdPkt uid } mt - vUAt :: Keyring -> ([UserAttrSubPacket], SignaturePayload) -> Either String Verification - vUAt keyring (uat, sp) = verifySig keyring (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (_tkPKP key), lastUIDorUAt = UserAttributePkt uat } mt - vSig :: Keyring -> SignaturePayload -> Either String Verification - vSig keyring sp = verifySig keyring (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (_tkPKP key) } mt - vSubSig :: Keyring -> Pkt -> SignaturePayload -> Bool - vSubSig keyring sk sp = case verifySig keyring (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (_tkPKP key), lastSubkey = sk} mt of + vUid :: (String, SignaturePayload) -> Either String Verification + vUid (uid, sp) = vsf (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (_tkPKP key), lastUIDorUAt = UserIdPkt uid } mt + vUAt :: ([UserAttrSubPacket], SignaturePayload) -> Either String Verification + vUAt (uat, sp) = vsf (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (_tkPKP key), lastUIDorUAt = UserAttributePkt uat } mt + vSig :: SignaturePayload -> Either String Verification + vSig sp = vsf (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (_tkPKP key) } mt + vSubSig :: Pkt -> SignaturePayload -> Bool + vSubSig sk sp = case vsf (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (_tkPKP key), lastSubkey = sk} mt of Left _ -> False Right _ -> True verifyRevoker :: SignaturePayload -> Either String [(PubKeyAlgorithm, TwentyOctetFingerprint)] verifyRevoker sp = do - _ <- vSig kr sp + _ <- vSig sp return (map (\(SigSubPacket _ (RevocationKey _ pka fp)) -> (pka, fp)) . filter isRevocationKeySSP $ getHasheds sp) +{-# DEPRECATED verify "This function will be removed in favor of verifyAgainstKeyring" #-} verify :: Keyring -> Pkt -> Maybe UTCTime -> ByteString -> Either String Verification -verify kr sig mt payload = do +verify = verifyAgainstKeyring + +verifyAgainstKeyring :: Keyring -> Pkt -> Maybe UTCTime -> ByteString -> Either String Verification +verifyAgainstKeyring kr sig mt payload = do i <- maybe (Left "issuer not found") Right (issuer sig) potentialmatches <- if IxSet.null (kr @= i) then Left "pubkey not found" else Right (kr @= i) - let allrelevantpkps = filter (\x -> issuer sig == Just (eightOctetKeyID x)) (concatMap (\x -> _tkPKP x:map subPKP (_tkSubs x)) (IxSet.toList potentialmatches)) + verifyAgainstKeys (IxSet.toList potentialmatches) sig mt payload + +verifyAgainstKeys :: [TK] -> Pkt -> Maybe UTCTime -> ByteString -> Either String Verification +verifyAgainstKeys ks sig mt payload = do + let allrelevantpkps = filter (\x -> issuer sig == Just (eightOctetKeyID x)) (concatMap (\x -> _tkPKP x:map subPKP (_tkSubs x)) ks) let results = map (\pkp -> verify' sig pkp (hashalgo sig) (finalPayload sig payload)) allrelevantpkps case rights results of [] -> Left (concatMap (++"/") (lefts results)) diff --git a/Data/Conduit/OpenPGP/Verify.hs b/Data/Conduit/OpenPGP/Verify.hs --- a/Data/Conduit/OpenPGP/Verify.hs +++ b/Data/Conduit/OpenPGP/Verify.hs @@ -1,5 +1,5 @@ -- Verify.hs: OpenPGP (RFC4880) signature verification --- Copyright © 2012-2013 Clint Adams +-- Copyright © 2012-2014 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -12,7 +12,7 @@ import Codec.Encryption.OpenPGP.Internal (PktStreamContext(..), emptyPSC) import Codec.Encryption.OpenPGP.Types -import Codec.Encryption.OpenPGP.Signatures (verifySig) +import Codec.Encryption.OpenPGP.Signatures (verifySigWith, verifyAgainstKeyring) import qualified Data.Conduit.List as CL conduitVerify :: MonadResource m => Keyring -> Maybe UTCTime -> Conduit Pkt m (Either String Verification) @@ -25,7 +25,7 @@ push state pk@(PublicSubkeyPkt _) = (state { lastSubkey = pk }, []) push state sk@(SecretKeyPkt _ _) = (state { lastPrimaryKey = sk }, []) push state sk@(SecretSubkeyPkt _ _) = (state { lastSubkey = sk }, []) - push state sig@(SignaturePkt (SigV4 {})) = (state { lastSig = sig }, [verifySig kr sig state mt]) + push state sig@(SignaturePkt (SigV4 {})) = (state { lastSig = sig }, [verifySigWith (verifyAgainstKeyring kr) sig state mt]) push state (OnePassSignaturePkt _ _ _ _ _ False) = (state, []) push state _ = (state, []) normLineEndings = id -- FIXME diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,5 +1,5 @@ Name: hOpenPGP -Version: 0.11.2 +Version: 0.12 Synopsis: native Haskell implementation of OpenPGP (RFC4880) Description: native Haskell implementation of OpenPGP (RFC4880) Homepage: http://floss.scru.org/hOpenPGP/ @@ -195,6 +195,7 @@ Test-Suite tests type: exitcode-stdio-1.0 main-is: tests/suite.hs + other-modules: Codec.Encryption.OpenPGP.Arbitrary Ghc-options: -Wall Build-depends: hOpenPGP , base > 4 && < 5 @@ -225,6 +226,9 @@ , zlib , tasty , tasty-hunit + , tasty-quickcheck + , QuickCheck + , quickcheck-instances , resourcet > 0.4 && < 0.5 default-language: Haskell2010 @@ -235,4 +239,4 @@ source-repository this type: git location: git://git.debian.org/users/clint/hOpenPGP.git - tag: v0.11.2 + tag: v0.12 diff --git a/tests/suite.hs b/tests/suite.hs --- a/tests/suite.hs +++ b/tests/suite.hs @@ -7,12 +7,14 @@ import Test.Tasty (defaultMain, testGroup, TestTree) import Test.Tasty.HUnit (testCase, Assertion, assertFailure, assertEqual) +import Test.Tasty.QuickCheck as QC -import Codec.Encryption.OpenPGP.Serialize () +import Codec.Encryption.OpenPGP.Arbitrary () import Codec.Encryption.OpenPGP.Compression (decompressPkt, compressPkts) import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) import Codec.Encryption.OpenPGP.KeySelection (parseFingerprint) import Codec.Encryption.OpenPGP.SecretKey (decryptPrivateKey, encryptPrivateKey) +import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.Types import Crypto.PubKey.RSA (PrivateKey(private_pub)) import Data.Conduit.Cereal (conduitGet) @@ -136,7 +138,10 @@ tests :: TestTree -tests = testGroup "unit tests" [ +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") @@ -302,6 +307,19 @@ testCase "SUSSHA1 AES256 IteratedSalted SHA512 RSA" (testSecretKeyEncryption "unencrypted.seckey" "pki-password.txt") ] ] + +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.Conduit B.ByteString (DC.ResourceT IO) Pkt cgp = conduitGet (get :: Get Pkt)