diff --git a/Codec/Encryption/OpenPGP/KeyInfo.hs b/Codec/Encryption/OpenPGP/KeyInfo.hs --- a/Codec/Encryption/OpenPGP/KeyInfo.hs +++ b/Codec/Encryption/OpenPGP/KeyInfo.hs @@ -1,5 +1,5 @@ -- KeyInfo.hs: OpenPGP (RFC4880) fingerprinting methods --- Copyright © 2012-2015 Clint Adams +-- Copyright © 2012-2016 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -10,19 +10,22 @@ import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.DSA as DSA -import qualified Data.ByteString as B import Data.Bits (shiftR) import Data.List (unfoldr) import Codec.Encryption.OpenPGP.Types +pubkeySize :: PKey -> Either String Int pubkeySize (RSAPubKey (RSA_PublicKey x)) = Right (RSA.public_size x * 8) pubkeySize (DSAPubKey (DSA_PublicKey x)) = Right (bitcount . DSA.params_p . DSA.public_params $ x) pubkeySize (ElGamalPubKey p _ _) = Right (bitcount p) pubkeySize x = Left $ "Unable to calculate size of " ++ show x +bitcount :: Integer -> Int bitcount = (*8) . length . unfoldr (\x -> if x == 0 then Nothing else Just (True, x `shiftR` 8)) +-- FIXME: redo these for hOpenPGP 3 +pkalgoAbbrev :: PubKeyAlgorithm -> String pkalgoAbbrev RSA = "R" pkalgoAbbrev DSA = "D" pkalgoAbbrev ElgamalEncryptOnly = "g" diff --git a/Codec/Encryption/OpenPGP/Types/Internal/Base.hs b/Codec/Encryption/OpenPGP/Types/Internal/Base.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/Base.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/Base.hs @@ -29,9 +29,11 @@ import qualified Data.Aeson.TH as ATH import Data.Byteable (Byteable) import Data.ByteArray (ByteArrayAccess) +import Data.ByteString.Builder (lazyByteStringHex, toLazyByteString) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BLC8 import Data.Char (toLower, toUpper) import Data.Data (Data) import Data.Hashable (Hashable(..)) @@ -54,7 +56,7 @@ import Data.Typeable (Typeable) import Data.Word (Word8, Word16, Word32) import Network.URI (URI(..), uriToString, nullURI, parseURI) -import Numeric (readHex, showHex) +import Numeric (readHex) import Data.Time.Locale.Compat (defaultTimeLocale) import Text.PrettyPrint.Free (Pretty(..), (<+>), char, hsep, punctuate, space, text) @@ -153,7 +155,7 @@ pretty Camellia128 = text "Camellia-128" pretty Camellia192 = text "Camellia-192" pretty Camellia256 = text "Camellia-256" - pretty (OtherSA sa) = text "unknown symmetric algorithm" <+> (text . show) sa + pretty (OtherSA sa) = text "unknown symmetric algorithm" <+> pretty sa $(ATH.deriveJSON ATH.defaultOptions ''SymmetricAlgorithm) @@ -291,7 +293,7 @@ pretty ECDSA = text "ECDSA" pretty ForbiddenElgamal = text "(forbidden) Elgamal" pretty DH = text "DH" - pretty pka = text "unknown pubkey algorithm type" <+> (text . show) pka + pretty (OtherPKA pka) = text "unknown pubkey algorithm type" <+> pretty pka $(ATH.deriveJSON ATH.defaultOptions ''PubKeyAlgorithm) @@ -309,7 +311,7 @@ instance Hashable TwentyOctetFingerprint instance Pretty TwentyOctetFingerprint where - pretty = text . take 40 . w8sToHex . BL.unpack . unTOF + pretty = pretty . take 40 . bsToHexUpper . unTOF instance A.ToJSON TwentyOctetFingerprint where toJSON e = object [T.pack "fpr" .= (A.toJSON . show . pretty) e] @@ -325,10 +327,10 @@ unpack (SpacedFingerprint o) = o instance Pretty SpacedFingerprint where - pretty = hsep . punctuate space . map hsep . chunksOf 5 . map text . chunksOf 4 . take 40 . w8sToHex . BL.unpack . unTOF . unpack + pretty = hsep . punctuate space . map hsep . chunksOf 5 . map text . chunksOf 4 . take 40 . bsToHexUpper . unTOF . unpack -w8sToHex :: [Word8] -> String -w8sToHex = map toUpper . concatMap ((\x -> if length x == 1 then '0':x else x) . flip showHex "") +bsToHexUpper :: ByteString -> String +bsToHexUpper = map toUpper . BLC8.unpack . toLazyByteString . lazyByteStringHex hexToW8s :: ReadS Word8 hexToW8s = concatMap readHex . chunksOf 2 . map toLower @@ -341,7 +343,7 @@ unpack (EightOctetKeyId o) = o instance Pretty EightOctetKeyId where - pretty = text . w8sToHex . BL.unpack . unpack + pretty = pretty . bsToHexUpper . unpack -- FIXME: read-show instance Read EightOctetKeyId where @@ -350,7 +352,7 @@ instance Hashable EightOctetKeyId instance A.ToJSON EightOctetKeyId where - toJSON e = object [T.pack "eoki" .= (w8sToHex . BL.unpack . unpack) e] + toJSON e = object [T.pack "eoki" .= (bsToHexUpper . unpack) e] instance A.FromJSON EightOctetKeyId where parseJSON (A.Object v) = EightOctetKeyId . read <$> @@ -429,7 +431,7 @@ pretty SHA384 = text "SHA-384" pretty SHA512 = text "SHA-512" pretty SHA224 = text "SHA-224" - pretty (OtherHA ha) = text "unknown hash algorithm type" <+> (text . show) ha + pretty (OtherHA ha) = text "unknown hash algorithm type" <+> pretty ha $(ATH.deriveJSON ATH.defaultOptions ''HashAlgorithm) @@ -465,7 +467,7 @@ pretty ZIP = text "ZIP" pretty ZLIB = text "zlib" pretty BZip2 = text "bzip2" - pretty (OtherCA ca) = text "unknown compression algorithm type" <+> (text . show) ca + pretty (OtherCA ca) = text "unknown compression algorithm type" <+> pretty ca $(ATH.deriveJSON ATH.defaultOptions ''CompressionAlgorithm) @@ -733,8 +735,8 @@ instance Hashable SignaturePayload instance Pretty SignaturePayload where - pretty (SigV3 st ts eoki pka ha w16 mpis) = text "signature v3" <> char ':' <+> pretty st <+> pretty ts <+> pretty eoki <+> pretty pka <+> pretty ha <+> pretty w16 <+> (prettyList . NE.toList) mpis - pretty (SigV4 st pka ha hsps usps w16 mpis) = text "signature v4" <> char ':' <+> pretty st <+> pretty pka <+> pretty ha <+> prettyList hsps <+> prettyList usps <+> pretty w16 <+> (prettyList . NE.toList) mpis + pretty (SigV3 st ts eoki pka ha w16 mpis) = text "signature v3" <> char ':' <+> pretty st <+> pretty ts <+> pretty eoki <+> pretty pka <+> pretty ha <+> pretty w16 <+> (pretty . NE.toList) mpis + pretty (SigV4 st pka ha hsps usps w16 mpis) = text "signature v4" <> char ':' <+> pretty st <+> pretty pka <+> pretty ha <+> pretty hsps <+> pretty usps <+> pretty w16 <+> (pretty . NE.toList) mpis pretty (SigVOther t bs) = text "unknown signature v" <> pretty t <> char ':' <+> pretty (BL.unpack bs) instance A.ToJSON SignaturePayload where @@ -779,20 +781,20 @@ pretty (RegularExpression apdre) = text "regular expression" <+> pretty apdre pretty (Revocable r) = text "revocable" <+> pretty r pretty (KeyExpirationTime d) = text "key expiration time" <+> pretty d - pretty (PreferredSymmetricAlgorithms sas) = text "preferred symmetric algorithms" <+> prettyList sas - pretty (RevocationKey rcs pka tof) = text "revocation key" <+> prettyList (Set.toList rcs) <+> pretty pka <+> pretty tof + pretty (PreferredSymmetricAlgorithms sas) = text "preferred symmetric algorithms" <+> pretty sas + pretty (RevocationKey rcs pka tof) = text "revocation key" <+> pretty (Set.toList rcs) <+> pretty pka <+> pretty tof pretty (Issuer eoki) = text "issuer" <+> pretty eoki - pretty (NotationData nfs nn nv) = text "notation data" <+> prettyList (Set.toList nfs) <+> pretty nn <+> pretty nv - pretty (PreferredHashAlgorithms phas) = text "preferred hash algorithms" <+> prettyList phas + pretty (NotationData nfs nn nv) = text "notation data" <+> pretty (Set.toList nfs) <+> pretty nn <+> pretty nv + pretty (PreferredHashAlgorithms phas) = text "preferred hash algorithms" <+> pretty phas pretty (PreferredCompressionAlgorithms pcas) = text "preferred compression algorithms" <+> pretty pcas - pretty (KeyServerPreferences kspfs) = text "keyserver preferences" <+> prettyList (Set.toList kspfs) + pretty (KeyServerPreferences kspfs) = text "keyserver preferences" <+> pretty (Set.toList kspfs) pretty (PreferredKeyServer ks) = text "preferred keyserver" <+> pretty ks pretty (PrimaryUserId p) = (if p then mempty else text "NOT ") <> text "primary user-ID" pretty (PolicyURL u) = text "policy URL" <+> pretty u - pretty (KeyFlags kfs) = text "key flags" <+> prettyList (Set.toList kfs) + pretty (KeyFlags kfs) = text "key flags" <+> pretty (Set.toList kfs) pretty (SignersUserId u) = text "signer's user-ID" <+> pretty u pretty (ReasonForRevocation rc rr) = text "reason for revocation" <+> pretty rc <+> pretty rr - pretty (Features ffs) = text "features" <+> prettyList (Set.toList ffs) + pretty (Features ffs) = text "features" <+> pretty (Set.toList ffs) pretty (SignatureTarget pka ha sh) = text "signature target" <+> pretty pka <+> pretty ha <+> pretty sh pretty (EmbeddedSignature sp) = text "embedded signature" <+> pretty sp pretty (UserDefinedSigSub t bs) = text "user-defined signature subpacket type" <+> pretty t <+> pretty (BL.unpack bs) @@ -908,7 +910,7 @@ pretty BinaryData = text "binary" pretty TextData = text "text" pretty UTF8Data = text "UTF-8" - pretty (OtherData o) = text "other data type " <+> (text . show) o + pretty (OtherData o) = text "other data type " <+> pretty o $(ATH.deriveJSON ATH.defaultOptions ''DataType) @@ -1009,7 +1011,7 @@ instance Pretty UserAttrSubPacket where pretty (ImageAttribute ih d) = text "image-attribute" <+> pretty ih <+> pretty (BL.unpack d) - pretty (OtherUASub t bs) = text "unknown attribute type" <> (text . show) t <+> pretty (BL.unpack bs) + pretty (OtherUASub t bs) = text "unknown attribute type" <> pretty t <+> pretty (BL.unpack bs) instance A.ToJSON UserAttrSubPacket where toJSON (ImageAttribute ih d) = A.toJSON (ih, BL.unpack d) diff --git a/Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs b/Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs @@ -44,7 +44,7 @@ pretty (ElGamalPubKey p g y) = text "Elgamal" <+> pretty p <+> pretty g <+> pretty y pretty (ECDHPubKey p ha sa) = text "ECDH" <+> pretty p <+> pretty ha <+> pretty sa pretty (ECDSAPubKey p) = text "ECDSA" <+> pretty p - pretty (UnknownPKey bs) = text "unknown" <+> pretty bs + pretty (UnknownPKey bs) = text "" <+> pretty (bsToHexUpper bs) instance A.ToJSON PKey where toJSON (RSAPubKey p) = A.toJSON p @@ -70,7 +70,7 @@ pretty (ElGamalPrivateKey p) = text "Elgamal" <+> pretty p pretty (ECDHPrivateKey p) = text "ECDH" <+> pretty p pretty (ECDSAPrivateKey p) = text "ECDSA" <+> pretty p - pretty (UnknownSKey bs) = text "unknown" <+> pretty bs + pretty (UnknownSKey bs) = text "" <+> pretty (bsToHexUpper bs) instance A.ToJSON SKey where toJSON (RSAPrivateKey k) = A.toJSON k diff --git a/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs b/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs @@ -67,10 +67,10 @@ compare = comparing pktTag <> comparing hash -- FIXME: is there something saner? instance Pretty Pkt where - pretty (PKESKPkt pv eoki pka mpis) = text "PKESK v" <> (text . show) pv <> char ':' <+> pretty eoki <+> pretty pka <+> (prettyList . NE.toList) mpis + pretty (PKESKPkt pv eoki pka mpis) = text "PKESK v" <> pretty pv <> char ':' <+> pretty eoki <+> pretty pka <+> (pretty . NE.toList) mpis pretty (SignaturePkt sp) = pretty sp - pretty (SKESKPkt pv sa s2k mbs) = text "SKESK v" <> (text . show) pv <> char ':' <+> pretty sa <+> pretty s2k <+> pretty mbs - pretty (OnePassSignaturePkt pv st ha pka eoki nestedflag) = text "one-pass signature v" <> (text . show) pv <> char ':' <+> pretty st <+> pretty ha <+> pretty pka <+> pretty eoki <+> pretty nestedflag + pretty (SKESKPkt pv sa s2k mbs) = text "SKESK v" <> pretty pv <> char ':' <+> pretty sa <+> pretty s2k <+> pretty mbs + pretty (OnePassSignaturePkt pv st ha pka eoki nestedflag) = text "one-pass signature v" <> pretty pv <> char ':' <+> pretty st <+> pretty ha <+> pretty pka <+> pretty eoki <+> pretty nestedflag pretty (SecretKeyPkt pkp ska) = text "secret key:" <+> pretty pkp <+> pretty ska pretty (PublicKeyPkt pkp) = text "public key:" <+> pretty pkp pretty (SecretSubkeyPkt pkp ska) = text "secret subkey:" <+> pretty pkp <+> pretty ska @@ -81,8 +81,8 @@ pretty (TrustPkt bs) = text "trust:" <+> pretty (BL.unpack bs) pretty (UserIdPkt u) = text "user-ID:" <+> pretty u pretty (PublicSubkeyPkt pkp) = text "public subkey:" <+> pretty pkp - pretty (UserAttributePkt us) = text "user-attribute:" <+> prettyList us - pretty (SymEncIntegrityProtectedDataPkt pv bs) = text "symmetrically-encrypted-integrity-protected-data v" <> (text . show) pv <> char ':' <+> pretty bs + pretty (UserAttributePkt us) = text "user-attribute:" <+> pretty us + pretty (SymEncIntegrityProtectedDataPkt pv bs) = text "symmetrically-encrypted-integrity-protected-data v" <> pretty pv <> char ':' <+> pretty bs pretty (ModificationDetectionCodePkt bs) = text "MDC:" <+> pretty bs pretty (OtherPacketPkt t bs) = text "unknown packet type" <+> pretty t <> char ':' <+> pretty bs pretty (BrokenPacketPkt s t bs) = text "BROKEN packet (" <> pretty s <> char ')' <+> pretty t <> char ':' <+> pretty bs diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,5 +1,5 @@ Name: hOpenPGP -Version: 2.5.2 +Version: 2.5.3 Synopsis: native Haskell implementation of OpenPGP (RFC4880) Description: native Haskell implementation of OpenPGP (RFC4880), plus Camellia (RFC5581) Homepage: http://floss.scru.org/hOpenPGP/ @@ -191,7 +191,7 @@ , base64-bytestring , bifunctors , byteable - , bytestring + , bytestring >= 0.10.0.0 , bzlib , binary >= 0.6.4.0 , binary-conduit @@ -240,7 +240,7 @@ , base > 4 && < 5 , bifunctors , byteable - , bytestring + , bytestring >= 0.10.0.0 , bzlib , binary >= 0.6.4.0 , binary-conduit @@ -291,7 +291,7 @@ , base64-bytestring , bifunctors , byteable - , bytestring + , bytestring >= 0.10.0.0 , bzlib , binary >= 0.6.4.0 , binary-conduit @@ -336,4 +336,4 @@ source-repository this type: git location: git://git.debian.org/users/clint/hOpenPGP.git - tag: v2.5.2 + tag: v2.5.3 diff --git a/tests/suite.hs b/tests/suite.hs --- a/tests/suite.hs +++ b/tests/suite.hs @@ -16,6 +16,7 @@ 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) @@ -83,14 +84,15 @@ len <- runResourceT $ CB.sourceFile ("tests/data/" ++ fpr) DC.$= c DC.$$ counter assertEqual ("expected length " ++ show target) target len -testKeyIDandFingerprint :: FilePath -> String -> Assertion -testKeyIDandFingerprint fpr kf = do +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 - assertEqual ("for " ++ fpr ++ " (spaceless)") (spaceless kf) (either (const "unknown") (show . pretty) (eightOctetKeyID pkp) ++ "/" ++ show (pretty (fingerprint pkp))) - assertEqual ("for " ++ fpr ++ " (spaced)") kf (either (const "unknown") (show . pretty) (eightOctetKeyID pkp) ++ "/" ++ show (pretty (SpacedFingerprint (fingerprint pkp)))) + 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 (/=' ') @@ -276,9 +278,9 @@ , testCase "gnu-dummy-s2k-101-secret-key.gpg" (testSerialization "gnu-dummy-s2k-101-secret-key.gpg") , testCase "anibal-ed25519.gpg" (testSerialization "anibal-ed25519.gpg") ], - testGroup "KeyID/fingerprint group" [ - testCase "v3 key" (testKeyIDandFingerprint "v3.key" "C7261095/CBD9 F412 6807 E405 CC2D 2712 1DF5 E86E") - , testCase "v4 key" (testKeyIDandFingerprint "000001-006.public_key" "D4D54EA16F87040E/421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E") + 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") ], testGroup "Keyring group" [ testCase "pubring 7732CF988A63EA86" (testKeyringLookup "pubring.gpg" "7732CF988A63EA86" True)