diff --git a/Codec/Encryption/OpenPGP/Arbitrary.hs b/Codec/Encryption/OpenPGP/Arbitrary.hs --- a/Codec/Encryption/OpenPGP/Arbitrary.hs +++ b/Codec/Encryption/OpenPGP/Arbitrary.hs @@ -1,5 +1,5 @@ -- Arbitrary.hs: QuickCheck instances --- Copyright © 2014-2018 Clint Adams +-- Copyright © 2014-2019 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). module Codec.Encryption.OpenPGP.Arbitrary @@ -28,8 +28,7 @@ pv <- arbitrary eoki <- arbitrary pka <- arbitrary - mpis <- arbitrary - return $ PKESK pv eoki pka mpis + PKESK pv eoki pka <$> arbitrary instance Arbitrary Signature where arbitrary = fmap Signature arbitrary @@ -48,8 +47,7 @@ pka <- arbitrary ha <- arbitrary w16 <- arbitrary - mpis <- arbitrary - return (SigV3 st w32 eoki pka ha w16 mpis) + SigV3 st w32 eoki pka ha w16 <$> arbitrary four = do st <- arbitrary pka <- arbitrary @@ -57,18 +55,15 @@ has <- arbitrary uhas <- arbitrary w16 <- arbitrary - mpis <- arbitrary - return (SigV4 st pka ha has uhas w16 mpis) + SigV4 st pka ha has uhas w16 <$> arbitrary other = do v <- choose (5, maxBound) - bs <- arbitrary - return (SigVOther v bs) + SigVOther v <$> arbitrary instance Arbitrary SigSubPacket where arbitrary = do crit <- arbitrary - pl <- arbitrary - return (SigSubPacket crit pl) + SigSubPacket crit <$> arbitrary instance Arbitrary SigSubPacketPayload where arbitrary = diff --git a/Codec/Encryption/OpenPGP/Internal.hs b/Codec/Encryption/OpenPGP/Internal.hs --- a/Codec/Encryption/OpenPGP/Internal.hs +++ b/Codec/Encryption/OpenPGP/Internal.hs @@ -8,6 +8,7 @@ ( countBits , PktStreamContext(..) , issuer + , issuerFP , emptyPSC , pubkeyToMPIs , multiplicativeInverse @@ -33,7 +34,7 @@ import Data.List (find) import Data.Word (Word16, Word8) -import Codec.Encryption.OpenPGP.Ontology (isIssuerSSP, isSigCreationTime) +import Codec.Encryption.OpenPGP.Ontology (isIssuerSSP, isIssuerFPSSP, isSigCreationTime) import Codec.Encryption.OpenPGP.Types countBits :: ByteString -> Word16 @@ -71,6 +72,11 @@ issuer (SignaturePkt (SigV4 _ _ _ _ usubs _ _)) = fmap (\(SigSubPacket _ (Issuer i)) -> i) (find isIssuerSSP usubs) issuer _ = Nothing + +issuerFP :: Pkt -> Maybe TwentyOctetFingerprint +issuerFP (SignaturePkt (SigV4 _ _ _ hsubs _ _ _)) = + fmap (\(SigSubPacket _ (IssuerFingerprint _ i)) -> i) (find isIssuerFPSSP hsubs) +issuerFP _ = Nothing pubkeyToMPIs :: PKey -> [MPI] pubkeyToMPIs (RSAPubKey (RSA_PublicKey k)) = 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 @@ -15,6 +15,7 @@ -- * for signature subpackets , isCT , isIssuerSSP + , isIssuerFPSSP , isKET , isKUF , isPHA @@ -60,6 +61,10 @@ isIssuerSSP :: SigSubPacket -> Bool isIssuerSSP (SigSubPacket _ (Issuer _)) = True isIssuerSSP _ = False + +isIssuerFPSSP :: SigSubPacket -> Bool +isIssuerFPSSP (SigSubPacket _ (IssuerFingerprint _ _)) = True +isIssuerFPSSP _ = False isKET :: SigSubPacket -> Bool isKET (SigSubPacket _ (KeyExpirationTime _)) = True 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 @@ -12,6 +12,7 @@ , signDataWithRSA ) where +import Control.Applicative ((<|>)) import Control.Error.Util (hush) import Control.Lens ((^.), _1) import Control.Monad (liftM2) @@ -47,6 +48,7 @@ ( PktStreamContext(..) , emptyPSC , issuer + , issuerFP ) import Codec.Encryption.OpenPGP.Ontology ( isRevocationKeySSP @@ -73,12 +75,12 @@ -> 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 (v ^. verificationSigner)) . _sspPayload) - hs + mapM_ (checkI (v ^. verificationSigner) . _sspPayload) hs return v where + checkI s i@Issuer {} = checkIssuer (eightOctetKeyID s) i + checkI s i@IssuerFingerprint {} = checkIssuerFP (fingerprint s) i + checkI _ _ = Right True checkIssuer :: Either String EightOctetKeyId -> SigSubPacketPayload @@ -90,6 +92,13 @@ checkIssuer (Left err) (Issuer _) = Left $ "issuer subpacket cannot be checked (" ++ err ++ ")" checkIssuer _ _ = Right True + checkIssuerFP :: + TwentyOctetFingerprint -> SigSubPacketPayload -> Either String Bool + checkIssuerFP signer (IssuerFingerprint _ i) = + if signer == i + then Right True + else Left "issuer fingerprint subpacket does not match" + checkIssuerFP _ _ = Right True verifySigWith _ _ _ _ = Left "This should never happen (verifySigWith)." verifyTKWith :: @@ -208,11 +217,13 @@ verifyAgainstKeyring :: Keyring -> Pkt -> Maybe UTCTime -> ByteString -> Either String Verification verifyAgainstKeyring kr sig mt payload = do - i <- maybe (Left "issuer not found") Right (issuer sig) + let ikeys = (kr @=) <$> issuer sig + ifpkeys = (kr @=) <$> issuerFP sig + keyset <- maybe (Left "issuer not found") Right (ifpkeys <|> ikeys) potentialmatches <- - if IxSet.null (kr @= i) + if IxSet.null keyset then Left "pubkey not found" - else Right (kr @= i) + else Right keyset verifyAgainstKeys (IxSet.toList potentialmatches) sig mt payload verifyAgainstKeys :: @@ -220,7 +231,10 @@ verifyAgainstKeys ks sig mt payload = do let allrelevantpkps = filter - (\x -> ((==) <$> issuer sig <*> hush (eightOctetKeyID x)) == Just True) + (\x -> + (((fingerprint x ==) <$> issuerFP sig) == Just True) || + ((==) <$> issuer sig <*> hush (eightOctetKeyID x)) == + Just True) (concatMap (\x -> (x ^. tkKey . _1) : map subPKP (_tkSubs x)) ks) let results = map @@ -242,19 +256,19 @@ subPKP' (PublicSubkeyPkt p) = p subPKP' (SecretSubkeyPkt p _) = p subPKP' _ = error "This should never happen (subPKP')" - verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ pkey)) SHA1 pl = + verify' (SignaturePkt s) pub@(PKPayload V4 _ _ _ pkey) SHA1 pl = verify'' (pkaAndMPIs s) CHA.SHA1 pub pkey pl - verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ pkey)) RIPEMD160 pl = + verify' (SignaturePkt s) pub@(PKPayload V4 _ _ _ pkey) RIPEMD160 pl = verify'' (pkaAndMPIs s) CHA.RIPEMD160 pub pkey pl - verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ pkey)) SHA256 pl = + verify' (SignaturePkt s) pub@(PKPayload V4 _ _ _ pkey) SHA256 pl = verify'' (pkaAndMPIs s) CHA.SHA256 pub pkey pl - verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ pkey)) SHA384 pl = + verify' (SignaturePkt s) pub@(PKPayload V4 _ _ _ pkey) SHA384 pl = verify'' (pkaAndMPIs s) CHA.SHA384 pub pkey pl - verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ pkey)) SHA512 pl = + verify' (SignaturePkt s) pub@(PKPayload V4 _ _ _ pkey) SHA512 pl = verify'' (pkaAndMPIs s) CHA.SHA512 pub pkey pl - verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ pkey)) SHA224 pl = + verify' (SignaturePkt s) pub@(PKPayload V4 _ _ _ pkey) SHA224 pl = verify'' (pkaAndMPIs s) CHA.SHA224 pub pkey pl - verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ pkey)) DeprecatedMD5 pl = + verify' (SignaturePkt s) pub@(PKPayload V4 _ _ _ pkey) DeprecatedMD5 pl = verify'' (pkaAndMPIs s) CHA.MD5 pub pkey pl verify' _ _ _ _ = error "This should never happen (verify')." verify'' (DSA, mpis) hd pub (DSAPubKey (DSA_PublicKey pkey)) bs = @@ -287,7 +301,7 @@ let prehash = crazyHash hd bs :: B.ByteString if Ed25519.verify ep prehash es then Right pub - else Left ("does not verify") + else Left "does not verify" ed25519Verify _ _ _ _ _ = Left "cannot verify Ed25519 signature of wrong shape" cf2es = either (Left . show) return . eitherCryptoError diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,5 +1,5 @@ Name: hOpenPGP -Version: 2.8.5 +Version: 2.9 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 @@ -343,4 +343,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hOpenPGP.git - tag: v2.8.5 + tag: v2.9