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 @@ -58,27 +58,31 @@ return (SigSubPacket crit pl) instance Arbitrary SigSubPacketPayload where - arbitrary = oneof [sct, set, ec, ts, {- re, -} ket, psa, {- rk, -} i, {- nd, -} phas, pcas {-, ksps -}, pks, puid, purl, kfs, suid] + arbitrary = oneof [sct, set, ec, ts, re, ket, psa, rk, i, nd, phas, pcas, ksps, pks, puid, purl, kfs, suid, rfr, fs, st {-, es -}] 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 + re = arbitrary >>= return . RegularExpression ket = arbitrary >>= return . KeyExpirationTime psa = arbitrary >>= return . PreferredSymmetricAlgorithms - rk = arbitrary >>= \rcs -> arbitrary >>= \pka -> arbitrary >>= \tof -> return (RevocationKey rcs pka tof) -- FIXME: figure out why RevocationClass fails to serialize properly + rk = arbitrary >>= \rcs -> arbitrary >>= \pka -> arbitrary >>= \tof -> return (RevocationKey rcs pka tof) i = arbitrary >>= return . Issuer - nd = arbitrary >>= \nfs -> arbitrary >>= \nn -> arbitrary >>= \nv -> return (NotationData nfs nn nv) -- FIXME: figure out why NotationData fails to serialize properly + nd = arbitrary >>= \nfs -> arbitrary >>= \nn -> arbitrary >>= \nv -> return (NotationData nfs nn nv) phas = arbitrary >>= return . PreferredHashAlgorithms pcas = arbitrary >>= return . PreferredCompressionAlgorithms - ksps = arbitrary >>= return . KeyServerPreferences -- FIXME: figure out why KeyServerPreferences fails to serialize properly + ksps = arbitrary >>= return . KeyServerPreferences pks = arbitrary >>= return . PreferredKeyServer - puid = arbitrary >>= return . PrimaryUserId - purl = arbitrary >>= return . PolicyURL - kfs = arbitrary >>= return . KeyFlags - suid = arbitrary >>= return . SignersUserId - -- FIXME: finish this + puid = arbitrary >>= return . PrimaryUserId + purl = arbitrary >>= return . PolicyURL + kfs = arbitrary >>= return . KeyFlags + suid = arbitrary >>= return . SignersUserId + rfr = arbitrary >>= \rc -> arbitrary >>= \rr -> return (ReasonForRevocation rc rr) + fs = arbitrary >>= return . Features + st = arbitrary >>= \pka -> arbitrary >>= \ha -> arbitrary >>= \sh -> return (SignatureTarget pka ha sh) + es = arbitrary >>= return . EmbeddedSignature -- FIXME: figure out why EmbeddedSignature fails to serialize properly + -- FIXME: finish this -- @@ -107,13 +111,13 @@ arbitrary = frequency [(9,srk),(1,rco)] where srk = return SensitiveRK - rco = arbitrary >>= return . RClOther + rco = choose (2,7) >>= return . RClOther instance Arbitrary NotationFlag where arbitrary = frequency [(9,hr),(1,onf)] where hr = return HumanReadable - onf = arbitrary >>= return . OtherNF + onf = choose (1,31) >>= return . OtherNF instance Arbitrary CompressionAlgorithm where arbitrary = elements [Uncompressed,ZIP,ZLIB,BZip2] @@ -122,7 +126,16 @@ arbitrary = frequency [(9,nm),(1,kspo)] where nm = return NoModify - kspo = arbitrary >>= return . KSPOther + kspo = choose (2,63) >>= return . KSPOther instance Arbitrary KeyFlag where arbitrary = elements [GroupKey, AuthKey, SplitKey, EncryptStorageKey, EncryptCommunicationsKey, SignDataKey, CertifyKeysKey] + +instance Arbitrary RevocationCode where + arbitrary = elements [NoReason, KeySuperseded, KeyMaterialCompromised, KeyRetiredAndNoLongerUsed, UserIdInfoNoLongerValid] + +instance Arbitrary FeatureFlag where + arbitrary = frequency [(9,md),(1,fo)] + where + md = return ModificationDetection + fo = choose (8,63) >>= return . FeatureOther diff --git a/Codec/Encryption/OpenPGP/Fingerprint.hs b/Codec/Encryption/OpenPGP/Fingerprint.hs --- a/Codec/Encryption/OpenPGP/Fingerprint.hs +++ b/Codec/Encryption/OpenPGP/Fingerprint.hs @@ -18,12 +18,12 @@ import Codec.Encryption.OpenPGP.Internal (integerToBEBS) import Codec.Encryption.OpenPGP.Types -eightOctetKeyID :: PKPayload -> EightOctetKeyId -eightOctetKeyID (PKPayload DeprecatedV3 _ _ RSA (RSAPubKey rp)) = (EightOctetKeyId . B.reverse . B.take 4 . B.reverse . integerToBEBS . RSA.public_n) rp -eightOctetKeyID (PKPayload DeprecatedV3 _ _ DeprecatedRSAEncryptOnly (RSAPubKey rp)) = (EightOctetKeyId . B.reverse . B.take 4 . B.reverse . integerToBEBS . RSA.public_n) rp -eightOctetKeyID (PKPayload DeprecatedV3 _ _ DeprecatedRSASignOnly (RSAPubKey rp)) = (EightOctetKeyId . B.reverse . B.take 4 . B.reverse . integerToBEBS . RSA.public_n) rp -eightOctetKeyID p4@(PKPayload V4 _ _ _ _) = (EightOctetKeyId . B.drop 12 . unTOF . fingerprint) p4 -eightOctetKeyID _ = error "This should never happen (eightOctetKeyID)." +eightOctetKeyID :: PKPayload -> Either String EightOctetKeyId +eightOctetKeyID (PKPayload DeprecatedV3 _ _ RSA (RSAPubKey rp)) = (Right . EightOctetKeyId . B.reverse . B.take 4 . B.reverse . integerToBEBS . RSA.public_n) rp +eightOctetKeyID (PKPayload DeprecatedV3 _ _ DeprecatedRSAEncryptOnly (RSAPubKey rp)) = (Right . EightOctetKeyId . B.reverse . B.take 4 . B.reverse . integerToBEBS . RSA.public_n) rp +eightOctetKeyID (PKPayload DeprecatedV3 _ _ DeprecatedRSASignOnly (RSAPubKey rp)) = (Right . EightOctetKeyId . B.reverse . B.take 4 . B.reverse . integerToBEBS . RSA.public_n) rp +eightOctetKeyID (PKPayload DeprecatedV3 _ _ _ _) = Left "Cannot calculate the key ID of a non-RSA V3 key" +eightOctetKeyID p4@(PKPayload V4 _ _ _ _) = (Right . EightOctetKeyId . B.drop 12 . unTOF . fingerprint) p4 fingerprint :: PKPayload -> TwentyOctetFingerprint fingerprint p3@(PKPayload DeprecatedV3 _ _ _ _) = (TwentyOctetFingerprint . MD5.hash) (runPut $ putPKPforFingerprinting (PublicKeyPkt p3)) diff --git a/Codec/Encryption/OpenPGP/Serialize.hs b/Codec/Encryption/OpenPGP/Serialize.hs --- a/Codec/Encryption/OpenPGP/Serialize.hs +++ b/Codec/Encryption/OpenPGP/Serialize.hs @@ -181,6 +181,8 @@ return $ SigSubPacket crit (TrustSignature tl ta) | pt == 6 = do apdre <- getByteString (l - 2) + nul <- getWord8 + guard (nul == 0) return $ SigSubPacket crit (RegularExpression (B.copy apdre)) | pt == 7 = do r <- get 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 @@ -10,6 +10,8 @@ , verifyTKWith ) where +import Control.Applicative ((<$>),(<*>)) +import Control.Error.Util (hush) import Control.Lens ((^.), _1) import Control.Monad (liftM2) @@ -38,8 +40,9 @@ _ <- mapM_ (checkIssuer (eightOctetKeyID (v^.verificationSigner)) . _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 :: Either String EightOctetKeyId -> SigSubPacketPayload -> Either String Bool + checkIssuer (Right signer) (Issuer i) = if signer == i then Right True else Left "issuer subpacket does not match" + checkIssuer (Left err) (Issuer _) = Left $ "issuer subpacket cannot be checked (" ++ err ++ ")" checkIssuer _ _ = Right True verifySigWith _ _ _ _ = Left "This should never happen (verifySigWith)." @@ -108,7 +111,7 @@ 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 -> (x ^. tkKey._1):map subPKP (_tkSubs x)) ks) + let allrelevantpkps = filter (\x -> ((==) <$> issuer sig <*> hush (eightOctetKeyID x)) == Just True) (concatMap (\x -> (x ^. tkKey._1):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/Codec/Encryption/OpenPGP/Types.hs b/Codec/Encryption/OpenPGP/Types.hs --- a/Codec/Encryption/OpenPGP/Types.hs +++ b/Codec/Encryption/OpenPGP/Types.hs @@ -94,7 +94,7 @@ toFVal o = OtherSA o data NotationFlag = HumanReadable - | OtherNF Word32 + | OtherNF Word8 -- FIXME: this should be constrained to 4 bits? deriving (Data, Show, Typeable) instance Eq NotationFlag where @@ -305,7 +305,7 @@ toFFlag i = KFOther (fromIntegral i) data RevocationClass = SensitiveRK - | RClOther Word8 + | RClOther Word8 -- FIXME: this should be constrained to 3 bits deriving (Data, Show, Typeable) instance Eq RevocationClass where diff --git a/Data/Conduit/OpenPGP/Keyring/Instances.hs b/Data/Conduit/OpenPGP/Keyring/Instances.hs --- a/Data/Conduit/OpenPGP/Keyring/Instances.hs +++ b/Data/Conduit/OpenPGP/Keyring/Instances.hs @@ -13,6 +13,7 @@ import Control.Lens ((^.), (^..), _1, folded) import Data.Data.Lens (biplate) +import Data.Either (rights) instance Indexable TK where empty = ixSet @@ -23,7 +24,7 @@ ] getEOKIs :: TK -> [EightOctetKeyId] -getEOKIs tk = map eightOctetKeyID (tk ^.. biplate :: [PKPayload]) +getEOKIs tk = rights (map eightOctetKeyID (tk ^.. biplate :: [PKPayload])) getTOFs :: TK -> [TwentyOctetFingerprint] getTOFs tk = map fingerprint (tk ^.. biplate :: [PKPayload]) getUIDs :: TK -> [String] diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,5 +1,5 @@ Name: hOpenPGP -Version: 1.1 +Version: 1.2 Synopsis: native Haskell implementation of OpenPGP (RFC4880) Description: native Haskell implementation of OpenPGP (RFC4880) Homepage: http://floss.scru.org/hOpenPGP/ @@ -139,6 +139,7 @@ , tests/data/v3-genericcert.sig , tests/data/revoked.pubkey , tests/data/expired.pubkey + , tests/data/sigs-with-regexes Cabal-version: >= 1.10 @@ -244,4 +245,4 @@ source-repository this type: git location: git://git.debian.org/users/clint/hOpenPGP.git - tag: v1.1 + tag: v1.2 diff --git a/tests/data/sigs-with-regexes b/tests/data/sigs-with-regexes new file mode 100644 Binary files /dev/null and b/tests/data/sigs-with-regexes differ diff --git a/tests/suite.hs b/tests/suite.hs --- a/tests/suite.hs +++ b/tests/suite.hs @@ -80,7 +80,7 @@ bs <- B.readFile $ "tests/data/" ++ fpr case runGet (get :: Get Pkt) bs of Left _ -> assertFailure $ "Decoding of " ++ fpr ++ " broke." - Right (PublicKeyPkt pkp) -> assertEqual ("for " ++ fpr) kf (show (eightOctetKeyID pkp) ++ "/" ++ show (fingerprint pkp)) + Right (PublicKeyPkt pkp) -> assertEqual ("for " ++ fpr) kf (either (const "unknown") show (eightOctetKeyID pkp) ++ "/" ++ show (fingerprint pkp)) _ -> assertFailure "Expected public key, got something else." testKeyringLookup :: FilePath -> String -> Bool -> Assertion @@ -246,6 +246,7 @@ , 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") ], testGroup "KeyID/fingerprint group" [ testCase "v3 key" (testKeyIDandFingerprint "v3.key" "C7261095/CBD9 F412 6807 E405 CC2D 2712 1DF5 E86E ")