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 @@ -18,6 +18,7 @@ , sigType , sigPKA , sigHA + , sigCT ) where import Crypto.PubKey.HashDescr (HashDescr(..), hashDescrMD5, hashDescrSHA1, hashDescrSHA224, hashDescrSHA256, hashDescrSHA384, hashDescrSHA512, hashDescrRIPEMD160) @@ -105,3 +106,13 @@ sigHA (SigV3 _ _ _ _ ha _ _) = Just ha sigHA (SigV4 _ _ ha _ _ _ _) = Just ha sigHA _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild + +sigCT :: SignaturePayload -> Maybe TimeStamp +sigCT (SigV3 _ ct _ _ _ _ _) = Just ct +sigCT (SigV4 _ _ _ hsubs _ _ _) = fmap (\(SigSubPacket _ (SigCreationTime i)) -> i) (find isSigCreationTime hsubs) + where + isSigCreationTime (SigSubPacket _ (SigCreationTime _)) = True + isSigCreationTime _ = False +sigCT _ = Nothing + + 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 @@ -3,24 +3,27 @@ -- This software is released under the terms of the Expat license. -- (See the LICENSE file). -{-# LANGUAGE DeriveDataTypeable, ExistentialQuantification, TemplateHaskell, TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, ExistentialQuantification, TemplateHaskell, TypeFamilies #-} module Codec.Encryption.OpenPGP.Types where -import qualified Crypto.PubKey.RSA as RSA -import qualified Crypto.PubKey.DSA as DSA +import GHC.Generics (Generic) import Control.Arrow ((***)) import Control.Lens (makeLenses) +import qualified Crypto.PubKey.RSA as RSA +import qualified Crypto.PubKey.DSA as DSA import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.Char (toLower, toUpper) import Data.Data (Data) +import Data.Hashable (Hashable(..)) import Data.IxSet (IxSet) import Data.List.Split (chunksOf) import Data.Monoid ((<>)) import Data.Ord (comparing) import Data.Set (Set) +import qualified Data.Set as Set import Data.Typeable (Typeable) import Data.Word (Word8, Word16, Word32) import Numeric (readHex, showHex) @@ -59,7 +62,7 @@ | AES256 | Twofish | OtherSA Word8 - deriving (Data, Show, Typeable) + deriving (Data, Generic, Show, Typeable) instance Eq SymmetricAlgorithm where (==) a b = fromFVal a == fromFVal b @@ -93,9 +96,11 @@ toFVal 10 = Twofish toFVal o = OtherSA o +instance Hashable SymmetricAlgorithm + data NotationFlag = HumanReadable | OtherNF Word8 -- FIXME: this should be constrained to 4 bits? - deriving (Data, Show, Typeable) + deriving (Data, Generic, Show, Typeable) instance Eq NotationFlag where (==) a b = fromFFlag a == fromFFlag b @@ -110,14 +115,18 @@ toFFlag 0 = HumanReadable toFFlag o = OtherNF (fromIntegral o) +instance Hashable NotationFlag + data SigSubPacket = SigSubPacket { _sspCriticality :: Bool , _sspPayload :: SigSubPacketPayload - } deriving (Data, Eq, Typeable) + } deriving (Data, Eq, Generic, Typeable) instance Show SigSubPacket where show x = (if _sspCriticality x then "*" else "") ++ (show . _sspPayload) x +instance Hashable SigSubPacket + data SigSubPacketPayload = SigCreationTime TimeStamp | SigExpirationTime TimeStamp | ExportableCertification Exportability @@ -143,8 +152,10 @@ | EmbeddedSignature SignaturePayload | UserDefinedSigSub Word8 ByteString | OtherSigSub Word8 ByteString - deriving (Data, Eq, Show, Typeable) -- FIXME + deriving (Data, Eq, Generic, Show, Typeable) -- FIXME +instance Hashable SigSubPacketPayload + data HashAlgorithm = DeprecatedMD5 | SHA1 | RIPEMD160 @@ -153,7 +164,7 @@ | SHA512 | SHA224 | OtherHA Word8 - deriving (Data, Show, Typeable) + deriving (Data, Generic, Show, Typeable) instance Eq HashAlgorithm where (==) a b = fromFVal a == fromFVal b @@ -179,12 +190,14 @@ toFVal 11 = SHA224 toFVal o = OtherHA o +instance Hashable HashAlgorithm + data CompressionAlgorithm = Uncompressed | ZIP | ZLIB | BZip2 | OtherCA Word8 - deriving (Show, Data, Typeable) + deriving (Show, Data, Generic, Typeable) instance Eq CompressionAlgorithm where (==) a b = fromFVal a == fromFVal b @@ -204,6 +217,8 @@ toFVal 3 = BZip2 toFVal o = OtherCA o +instance Hashable CompressionAlgorithm + class (Eq a, Ord a) => FutureVal a where fromFVal :: a -> Word8 toFVal :: Word8 -> a @@ -218,7 +233,7 @@ | ForbiddenElgamal | DH | OtherPKA Word8 - deriving (Show, Data, Typeable) + deriving (Show, Data, Generic, Typeable) instance Eq PubKeyAlgorithm where (==) a b = fromFVal a == fromFVal b @@ -248,13 +263,15 @@ toFVal 21 = DH toFVal o = OtherPKA o +instance Hashable PubKeyAlgorithm + class (Eq a, Ord a) => FutureFlag a where fromFFlag :: a -> Int toFFlag :: Int -> a data KSPFlag = NoModify | KSPOther Int - deriving (Data, Show, Typeable) + deriving (Data, Generic, Show, Typeable) instance Eq KSPFlag where (==) a b = fromFFlag a == fromFFlag b @@ -269,6 +286,8 @@ toFFlag 0 = NoModify toFFlag i = KSPOther (fromIntegral i) +instance Hashable KSPFlag + data KeyFlag = GroupKey | AuthKey | SplitKey @@ -277,7 +296,7 @@ | SignDataKey | CertifyKeysKey | KFOther Int - deriving (Data, Show, Typeable) + deriving (Data, Generic, Show, Typeable) instance Eq KeyFlag where (==) a b = fromFFlag a == fromFFlag b @@ -304,9 +323,11 @@ toFFlag 7 = CertifyKeysKey toFFlag i = KFOther (fromIntegral i) +instance Hashable KeyFlag + data RevocationClass = SensitiveRK | RClOther Word8 -- FIXME: this should be constrained to 3 bits - deriving (Data, Show, Typeable) + deriving (Data, Generic, Show, Typeable) instance Eq RevocationClass where (==) a b = fromFFlag a == fromFFlag b @@ -321,13 +342,15 @@ toFFlag 1 = SensitiveRK toFFlag i = RClOther (fromIntegral i) +instance Hashable RevocationClass + data RevocationCode = NoReason | KeySuperseded | KeyMaterialCompromised | KeyRetiredAndNoLongerUsed | UserIdInfoNoLongerValid | RCoOther Word8 - deriving (Show, Data, Typeable) + deriving (Data, Generic, Show, Typeable) instance Eq RevocationCode where (==) a b = fromFVal a == fromFVal b @@ -349,9 +372,11 @@ toFVal 32 = UserIdInfoNoLongerValid toFVal o = RCoOther o +instance Hashable RevocationCode + data FeatureFlag = ModificationDetection | FeatureOther Int - deriving (Show, Data, Typeable) + deriving (Data, Generic, Show, Typeable) instance Eq FeatureFlag where (==) a b = fromFFlag a == fromFFlag b @@ -366,43 +391,59 @@ toFFlag 7 = ModificationDetection toFFlag i = FeatureOther (fromIntegral i) +instance Hashable FeatureFlag +instance Hashable a => Hashable (Set a) where + hashWithSalt salt = hashWithSalt salt . Set.toList + newtype MPI = MPI {unMPI :: Integer} - deriving (Data, Eq, Show, Typeable) + deriving (Data, Eq, Generic, Show, Typeable) +instance Hashable MPI + data SignaturePayload = SigV3 SigType Word32 EightOctetKeyId PubKeyAlgorithm HashAlgorithm Word16 [MPI] | SigV4 SigType PubKeyAlgorithm HashAlgorithm [SigSubPacket] [SigSubPacket] Word16 [MPI] | SigVOther Word8 ByteString - deriving (Data, Eq, Show, Typeable) -- FIXME + deriving (Data, Eq, Generic, Show, Typeable) -- FIXME +instance Hashable SignaturePayload + data KeyVersion = DeprecatedV3 | V4 - deriving (Data, Eq, Ord, Show, Typeable) + deriving (Data, Eq, Generic, Ord, Show, Typeable) +instance Hashable KeyVersion + data PKPayload = PKPayload { _keyVersion :: KeyVersion , _timestamp :: TimeStamp , _v3exp :: V3Expiration , _pkalgo :: PubKeyAlgorithm , _pubkey :: PKey - } deriving (Data, Eq, Show, Typeable) + } deriving (Data, Eq, Generic, Show, Typeable) instance Ord PKPayload where - compare a b = show a `compare` show b -- FIXME: this is ridiculous + compare = comparing _keyVersion <> comparing _timestamp <> comparing _v3exp <> comparing _pkalgo <> comparing (show . _pubkey) -- FIXME: this is suboptimal +instance Hashable PKPayload + data SKAddendum = SUS16bit SymmetricAlgorithm S2K IV ByteString | SUSSHA1 SymmetricAlgorithm S2K IV ByteString | SUSym SymmetricAlgorithm IV ByteString | SUUnencrypted SKey Word16 - deriving (Data, Eq, Show, Typeable) + deriving (Data, Eq, Generic, Show, Typeable) instance Ord SKAddendum where compare a b = show a `compare` show b -- FIXME: this is ridiculous +instance Hashable SKAddendum + data DataType = BinaryData | TextData | UTF8Data | OtherData Word8 - deriving (Show, Data, Typeable) + deriving (Show, Data, Generic, Typeable) +instance Hashable DataType + instance Eq DataType where (==) a b = fromFVal a == fromFVal b @@ -424,18 +465,33 @@ | Salted HashAlgorithm Salt | IteratedSalted HashAlgorithm Salt Count | OtherS2K Word8 ByteString - deriving (Data, Eq, Show, Typeable) -- FIXME + deriving (Data, Eq, Generic, Show, Typeable) -- FIXME +instance Hashable S2K + data UserAttrSubPacket = ImageAttribute ImageHeader ImageData | OtherUASub Word8 ByteString - deriving (Data, Eq, Show, Typeable) -- FIXME + deriving (Data, Eq, Generic, Show, Typeable) -- FIXME +instance Hashable UserAttrSubPacket + +instance Ord UserAttrSubPacket where + compare (ImageAttribute h1 d1) (ImageAttribute h2 d2) = compare h1 h2 <> compare d1 d2 + compare (ImageAttribute _ _) (OtherUASub _ _) = LT + compare (OtherUASub _ _) (ImageAttribute _ _) = GT + compare (OtherUASub t1 b1) (OtherUASub t2 b2) = compare t1 t2 <> compare b1 b2 + data ImageHeader = ImageHV1 ImageFormat - deriving (Data, Eq, Show, Typeable) + deriving (Data, Eq, Generic, Show, Typeable) +instance Ord ImageHeader where + compare (ImageHV1 a) (ImageHV1 b) = compare a b + +instance Hashable ImageHeader + data ImageFormat = JPEG | OtherImage Word8 - deriving (Data, Show, Typeable) + deriving (Data, Generic, Show, Typeable) instance Eq ImageFormat where (==) a b = fromFVal a == fromFVal b @@ -450,6 +506,8 @@ toFVal 1 = JPEG toFVal o = OtherImage o +instance Hashable ImageFormat + data SigType = BinarySig | CanonicalTextSig | StandaloneSig @@ -466,7 +524,7 @@ | TimestampSig | ThirdPartyConfirmationSig | OtherSig Word8 - deriving (Data, Show, Typeable) + deriving (Data, Generic, Show, Typeable) instance Eq SigType where (==) a b = fromFVal a == fromFVal b @@ -509,26 +567,45 @@ toFVal 0x50 = ThirdPartyConfirmationSig toFVal o = OtherSig o +instance Hashable SigType + instance Ord DSA.PublicKey instance Ord RSA.PublicKey +instance Ord DSA.PrivateKey +instance Ord RSA.PrivateKey +instance Hashable DSA.Params where + hashWithSalt s (DSA.Params p g q) = s `hashWithSalt` p `hashWithSalt` g `hashWithSalt` q +instance Hashable DSA.PublicKey where + hashWithSalt s (DSA.PublicKey p y) = s `hashWithSalt` p `hashWithSalt` y +instance Hashable DSA.PrivateKey where + hashWithSalt s (DSA.PrivateKey p x) = s `hashWithSalt` p `hashWithSalt` x +instance Hashable RSA.PublicKey where + hashWithSalt s (RSA.PublicKey size n e) = s `hashWithSalt` size `hashWithSalt` n `hashWithSalt` e +instance Hashable RSA.PrivateKey where + hashWithSalt s (RSA.PrivateKey pub d p q dP dQ qinv) = s `hashWithSalt` pub `hashWithSalt` d `hashWithSalt` p `hashWithSalt` q `hashWithSalt` dP `hashWithSalt` dQ `hashWithSalt` qinv + data PKey = RSAPubKey RSA.PublicKey | DSAPubKey DSA.PublicKey | ElGamalPubKey [Integer] | UnknownPKey ByteString - deriving (Data, Eq, Ord, Show, Typeable) + deriving (Data, Eq, Generic, Ord, Show, Typeable) +instance Hashable PKey + data SKey = RSAPrivateKey RSA.PrivateKey | DSAPrivateKey DSA.PrivateKey | ElGamalPrivateKey [Integer] | UnknownSKey ByteString - deriving (Data, Eq, Show, Typeable) + deriving (Data, Eq, Generic, Show, Typeable) +instance Hashable SKey + newtype Block a = Block {unBlock :: [a]} -- so we can override cereal instance deriving (Show, Eq) newtype EightOctetKeyId = EightOctetKeyId {unEOKI :: ByteString} - deriving (Eq, Ord, Data, Typeable) -- FIXME + deriving (Eq, Ord, Data, Generic, Typeable) -- FIXME instance Show EightOctetKeyId where show = w8sToHex . B.unpack . unEOKI @@ -536,8 +613,10 @@ instance Read EightOctetKeyId where readsPrec _ = map ((EightOctetKeyId . B.pack *** concat) . unzip) . chunksOf 8 . hexToW8s +instance Hashable EightOctetKeyId + newtype TwentyOctetFingerprint = TwentyOctetFingerprint {unTOF :: ByteString} - deriving (Eq, Ord, Data, Typeable) + deriving (Data, Eq, Generic, Ord, Typeable) instance Show TwentyOctetFingerprint where show = take 50 . concatMap (++" ") . concatMap (++[""]) . chunksOf 5 . chunksOf 4 . w8sToHex . B.unpack . unTOF @@ -545,6 +624,8 @@ instance Read TwentyOctetFingerprint where readsPrec _ = map ((TwentyOctetFingerprint . B.pack *** concat) . unzip) . chunksOf 20 . hexToW8s . filter (/= ' ') +instance Hashable TwentyOctetFingerprint + w8sToHex :: [Word8] -> String w8sToHex = map toUpper . concatMap ((\x -> if length x == 1 then '0':x else x) . flip showHex "") @@ -591,7 +672,9 @@ | ModificationDetectionCodePkt ByteString | OtherPacketPkt Word8 ByteString | BrokenPacketPkt String Word8 ByteString - deriving (Data, Eq, Show, Typeable) -- FIXME + deriving (Data, Eq, Generic, Show, Typeable) -- FIXME + +instance Hashable Pkt pktTag :: Pkt -> Word8 pktTag (PKESKPkt {}) = 1 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 @@ -6,14 +6,18 @@ module Data.Conduit.OpenPGP.Keyring.Instances ( ) where -import Data.IxSet (Proxy(..), Indexable(..), ixSet, ixGen, ixFun) - import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) +import Codec.Encryption.OpenPGP.Internal (issuer, sigCT) import Codec.Encryption.OpenPGP.Types - import Control.Lens ((^.), (^..), _1, folded) import Data.Data.Lens (biplate) import Data.Either (rights) +import Data.Function (on) +import qualified Data.HashMap.Lazy as HashMap +import Data.IxSet (Proxy(..), Indexable(..), ixSet, ixGen, ixFun) +import Data.List (nub, sort) +import qualified Data.Map as Map +import Data.Semigroup ((<>), Semigroup) instance Indexable TK where empty = ixSet @@ -29,3 +33,21 @@ getTOFs tk = map fingerprint (tk ^.. biplate :: [PKPayload]) getUIDs :: TK -> [String] getUIDs tk = (tk^.tkUIDs)^..folded._1 + +instance Ord SignaturePayload where + compare s1@(SigV3 st1 ct1 eoki1 pka1 ha1 left16_1 mpis1) s2@(SigV3 st2 ct2 eoki2 pka2 ha2 left16_2 mpis2) = compare ct1 ct2 <> compare st1 st2 <> compare eoki1 eoki2 -- FIXME: nondeterministic + compare s1@(SigV4 st1 pka1 ha1 has1 uhas1 left16_1 mpis1) s2@(SigV4 st2 pka2 ha2 has2 uhas2 left16_2 mpis2) = compare (sigCT s1) (sigCT s2) <> compare st1 st2 <> compare (issuer (SignaturePkt s1)) (issuer (SignaturePkt s2)) -- FIXME: nondeterministic + compare s1@(SigVOther sv1 bs1) s2@(SigVOther sv2 bs2) = compare sv1 sv2 <> compare bs1 bs2 + compare (SigV3 {}) (SigV4 {}) = LT + compare (SigV3 {}) (SigVOther {}) = LT + compare (SigV4 {}) (SigV3 {}) = GT + compare (SigV4 {}) (SigVOther {}) = LT + compare (SigVOther {}) (SigV3 {}) = GT + compare (SigVOther {}) (SigV4 {}) = GT + +instance Semigroup TK where + (<>) a b = TK (_tkKey a) (nub . sort $ _tkRevs a ++ _tkRevs b) ((kvmerge `on` _tkUIDs) a b) ((kvmerge `on` _tkUAts) a b) ((ukvmerge `on` _tkSubs) a b) + where + kvmerge x y = Map.toList (Map.unionWith nsa (Map.fromList x) (Map.fromList y)) + ukvmerge x y = HashMap.toList (HashMap.unionWith nsa (HashMap.fromList x) (HashMap.fromList y)) + nsa x y = nub . sort $ x ++ y diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,5 +1,5 @@ Name: hOpenPGP -Version: 1.3 +Version: 1.4 Synopsis: native Haskell implementation of OpenPGP (RFC4880) Description: native Haskell implementation of OpenPGP (RFC4880) Homepage: http://floss.scru.org/hOpenPGP/ @@ -183,6 +183,7 @@ , cryptohash , data-default , errors + , hashable , incremental-parser , ixset >= 1.0 , lens >= 3.0 @@ -192,10 +193,12 @@ , openpgp-asciiarmor >= 0.1 , resourcet > 0.4 , securemem + , semigroups , split , text , time >= 1.1 , transformers + , unordered-containers , zlib default-language: Haskell2010 @@ -222,6 +225,7 @@ , cryptohash , data-default , errors + , hashable , incremental-parser , ixset >= 1.0 , lens >= 3.0 @@ -229,10 +233,12 @@ , mtl , nettle , securemem + , semigroups , split , text , time >= 1.1 , transformers + , unordered-containers , zlib , tasty , tasty-hunit @@ -249,4 +255,4 @@ source-repository this type: git location: git://git.debian.org/users/clint/hOpenPGP.git - tag: v1.3 + tag: v1.4