hOpenPGP 2.8.3 → 2.8.4
raw patch · 38 files changed
+4924/−3612 lines, 38 filesdep −tasty-expected-failure
Dependencies removed: tasty-expected-failure
Files
- Codec/Encryption/OpenPGP/Arbitrary.hs +203/−111
- Codec/Encryption/OpenPGP/BlockCipher.hs +32/−19
- Codec/Encryption/OpenPGP/Compression.hs +20/−21
- Codec/Encryption/OpenPGP/Expirations.hs +19/−12
- Codec/Encryption/OpenPGP/Fingerprint.hs +34/−15
- Codec/Encryption/OpenPGP/Internal.hs +83/−59
- Codec/Encryption/OpenPGP/Internal/CryptoCipherTypes.hs +35/−19
- Codec/Encryption/OpenPGP/Internal/Cryptonite.hs +15/−12
- Codec/Encryption/OpenPGP/Internal/HOBlockCipher.hs +17/−14
- Codec/Encryption/OpenPGP/KeyInfo.hs +18/−9
- Codec/Encryption/OpenPGP/KeySelection.hs +19/−8
- Codec/Encryption/OpenPGP/KeyringParser.hs +223/−150
- Codec/Encryption/OpenPGP/Ontology.hs +19/−20
- Codec/Encryption/OpenPGP/S2K.hs +24/−17
- Codec/Encryption/OpenPGP/SecretKey.hs +82/−57
- Codec/Encryption/OpenPGP/Serialize.hs +1488/−1300
- Codec/Encryption/OpenPGP/SerializeForSigs.hs +83/−60
- Codec/Encryption/OpenPGP/SignatureQualities.hs +10/−8
- Codec/Encryption/OpenPGP/Signatures.hs +400/−162
- Codec/Encryption/OpenPGP/Types.hs +4/−3
- Codec/Encryption/OpenPGP/Types/Internal/Base.hs +1246/−1039
- Codec/Encryption/OpenPGP/Types/Internal/CryptoniteNewtypes.hs +120/−45
- Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs +97/−71
- Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs +275/−178
- Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs +166/−72
- Codec/Encryption/OpenPGP/Types/Internal/PrettyUtils.hs +1/−2
- Codec/Encryption/OpenPGP/Types/Internal/TK.hs +12/−10
- Data/Conduit/OpenPGP/Compression.hs +5/−6
- Data/Conduit/OpenPGP/Decrypt.hs +16/−9
- Data/Conduit/OpenPGP/Filter.hs +9/−12
- Data/Conduit/OpenPGP/Keyring.hs +39/−21
- Data/Conduit/OpenPGP/Keyring/Instances.hs +36/−28
- Data/Conduit/OpenPGP/Verify.hs +23/−18
- bench/mark.hs +39/−16
- hOpenPGP.cabal +4/−3
- tests/data/encryption-sym-pgcrypto.pgp +1/−0
- tests/data/pgcrypto-passphrase.txt +1/−0
- tests/suite.hs +6/−6
Codec/Encryption/OpenPGP/Arbitrary.hs view
@@ -2,171 +2,263 @@ -- Copyright © 2014-2018 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).--module Codec.Encryption.OpenPGP.Arbitrary () where+module Codec.Encryption.OpenPGP.Arbitrary+ (+ ) where import Codec.Encryption.OpenPGP.Types import qualified Data.ByteString.Lazy as BL import qualified Data.List.NonEmpty as NE import Data.Maybe (fromMaybe) import Network.URI (nullURI, parseURI)-import Test.QuickCheck (Arbitrary(..), choose, elements, frequency, getPositive, listOf1, oneof, vector)+import Test.QuickCheck+ ( Arbitrary(..)+ , choose+ , elements+ , frequency+ , getPositive+ , listOf1+ , 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+ arbitrary = do+ pv <- arbitrary+ eoki <- arbitrary+ pka <- arbitrary+ mpis <- arbitrary+ return $ PKESK pv eoki pka mpis instance Arbitrary Signature where- arbitrary = fmap Signature arbitrary+ arbitrary = fmap Signature arbitrary instance Arbitrary UserId where- arbitrary = fmap UserId arbitrary+ arbitrary = fmap UserId arbitrary --- 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)+ 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)+ arbitrary = do+ crit <- arbitrary+ pl <- arbitrary+ 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, rfr, fs, st {-, es -}, udss, oss, ifp]- where- sct = fmap SigCreationTime arbitrary- set = fmap SigExpirationTime arbitrary- ec = fmap ExportableCertification arbitrary- ts = arbitrary >>= \tl -> arbitrary >>= \ta -> return (TrustSignature tl ta)- re = fmap RegularExpression arbitrary- ket = fmap KeyExpirationTime arbitrary- psa = fmap PreferredSymmetricAlgorithms arbitrary- rk = arbitrary >>= \rcs -> arbitrary >>= \pka -> arbitrary >>= \tof -> return (RevocationKey rcs pka tof)- i = fmap Issuer arbitrary- nd = arbitrary >>= \nfs -> arbitrary >>= \nn -> arbitrary >>= \nv -> return (NotationData nfs nn nv)- phas = fmap PreferredHashAlgorithms arbitrary- pcas = fmap PreferredCompressionAlgorithms arbitrary- ksps = fmap KeyServerPreferences arbitrary- pks = fmap PreferredKeyServer arbitrary- puid = fmap PrimaryUserId arbitrary- purl = fmap (PolicyURL . URL . fromMaybe nullURI . parseURI) arbitrary- kfs = fmap KeyFlags arbitrary- suid = fmap SignersUserId arbitrary- rfr = arbitrary >>= \rc -> arbitrary >>= \rr -> return (ReasonForRevocation rc rr)- fs = fmap Features arbitrary- st = arbitrary >>= \pka -> arbitrary >>= \ha -> arbitrary >>= \sh -> return (SignatureTarget pka ha sh)- es = fmap EmbeddedSignature arbitrary -- FIXME: figure out why EmbeddedSignature fails to serialize properly- ifp = choose (4,5) >>= \v -> fmap (IssuerFingerprint v) (if v == 4 then arbitrary else fmap (TwentyOctetFingerprint . BL.pack) (vector 32))- udss = choose (100,110) >>= \a -> arbitrary >>= \b -> return (UserDefinedSigSub a b)- oss = choose (111,127) >>= \a -> arbitrary >>= \b -> return (OtherSigSub a b) -- FIXME: more comprehensive range+ arbitrary =+ oneof+ [ sct+ , set+ , ec+ , ts+ , re+ , ket+ , psa+ , rk+ , i+ , nd+ , phas+ , pcas+ , ksps+ , pks+ , puid+ , purl+ , kfs+ , suid+ , rfr+ , fs+ , st+ , udss+ , oss+ , ifp+ ] {-, es -}+ where+ sct = fmap SigCreationTime arbitrary+ set = fmap SigExpirationTime arbitrary+ ec = fmap ExportableCertification arbitrary+ ts =+ arbitrary >>= \tl -> arbitrary >>= \ta -> return (TrustSignature tl ta)+ re = fmap RegularExpression arbitrary+ ket = fmap KeyExpirationTime arbitrary+ psa = fmap PreferredSymmetricAlgorithms arbitrary+ rk =+ arbitrary >>= \rcs ->+ arbitrary >>= \pka ->+ arbitrary >>= \tof -> return (RevocationKey rcs pka tof)+ i = fmap Issuer arbitrary+ nd =+ arbitrary >>= \nfs ->+ arbitrary >>= \nn ->+ arbitrary >>= \nv -> return (NotationData nfs nn nv)+ phas = fmap PreferredHashAlgorithms arbitrary+ pcas = fmap PreferredCompressionAlgorithms arbitrary+ ksps = fmap KeyServerPreferences arbitrary+ pks = fmap PreferredKeyServer arbitrary+ puid = fmap PrimaryUserId arbitrary+ purl = fmap (PolicyURL . URL . fromMaybe nullURI . parseURI) arbitrary+ kfs = fmap KeyFlags arbitrary+ suid = fmap SignersUserId arbitrary+ rfr =+ arbitrary >>= \rc ->+ arbitrary >>= \rr -> return (ReasonForRevocation rc rr)+ fs = fmap Features arbitrary+ st =+ arbitrary >>= \pka ->+ arbitrary >>= \ha ->+ arbitrary >>= \sh -> return (SignatureTarget pka ha sh)+ es = fmap EmbeddedSignature arbitrary -- FIXME: figure out why EmbeddedSignature fails to serialize properly+ ifp =+ choose (4, 5) >>= \v ->+ fmap+ (IssuerFingerprint v)+ (if v == 4+ then arbitrary+ else fmap (TwentyOctetFingerprint . BL.pack) (vector 32))+ udss =+ choose (100, 110) >>= \a ->+ arbitrary >>= \b -> return (UserDefinedSigSub a b)+ oss =+ choose (111, 127) >>= \a -> arbitrary >>= \b -> return (OtherSigSub a b) -- FIXME: more comprehensive range --- instance Arbitrary PubKeyAlgorithm where- arbitrary = elements [RSA, DSA, ECDH, ECDSA, DH, EdDSA]+ arbitrary = elements [RSA, DSA, ECDH, ECDSA, DH, EdDSA] instance Arbitrary EightOctetKeyId where- arbitrary = fmap (EightOctetKeyId . BL.pack) (vector 8)+ arbitrary = fmap (EightOctetKeyId . BL.pack) (vector 8) instance Arbitrary TwentyOctetFingerprint where- arbitrary = fmap (TwentyOctetFingerprint . BL.pack) (vector 20)+ arbitrary = fmap (TwentyOctetFingerprint . BL.pack) (vector 20) instance Arbitrary MPI where- arbitrary = fmap (MPI . getPositive) arbitrary+ arbitrary = fmap (MPI . getPositive) arbitrary instance Arbitrary SigType where- arbitrary = elements [BinarySig, CanonicalTextSig, StandaloneSig, GenericCert, PersonaCert, CasualCert, PositiveCert, SubkeyBindingSig, PrimaryKeyBindingSig, SignatureDirectlyOnAKey, KeyRevocationSig, SubkeyRevocationSig, CertRevocationSig, TimestampSig, ThirdPartyConfirmationSig]+ 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]+ 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- , Camellia128- , Camellia192- , Camellia256- ]+ arbitrary =+ elements+ [ Plaintext+ , IDEA+ , TripleDES+ , CAST5+ , Blowfish+ , ReservedSAFER+ , ReservedDES+ , AES128+ , AES192+ , AES256+ , Twofish+ , Camellia128+ , Camellia192+ , Camellia256+ ] instance Arbitrary RevocationClass where- arbitrary = frequency [(9,srk),(1,rco)]- where- srk = return SensitiveRK- rco = fmap RClOther (choose (2,7))+ arbitrary = frequency [(9, srk), (1, rco)]+ where+ srk = return SensitiveRK+ rco = fmap RClOther (choose (2, 7)) instance Arbitrary NotationFlag where- arbitrary = frequency [(9,hr),(1,onf)]- where- hr = return HumanReadable- onf = fmap OtherNF (choose (1,31))+ arbitrary = frequency [(9, hr), (1, onf)]+ where+ hr = return HumanReadable+ onf = fmap OtherNF (choose (1, 31)) instance Arbitrary CompressionAlgorithm where- arbitrary = elements [Uncompressed,ZIP,ZLIB,BZip2]+ arbitrary = elements [Uncompressed, ZIP, ZLIB, BZip2] instance Arbitrary KSPFlag where- arbitrary = frequency [(9,nm),(1,kspo)]- where- nm = return NoModify- kspo = fmap KSPOther (choose (2,63))+ arbitrary = frequency [(9, nm), (1, kspo)]+ where+ nm = return NoModify+ kspo = fmap KSPOther (choose (2, 63)) instance Arbitrary KeyFlag where- arbitrary = elements [GroupKey, AuthKey, SplitKey, EncryptStorageKey, EncryptCommunicationsKey, SignDataKey, CertifyKeysKey]+ arbitrary =+ elements+ [ GroupKey+ , AuthKey+ , SplitKey+ , EncryptStorageKey+ , EncryptCommunicationsKey+ , SignDataKey+ , CertifyKeysKey+ ] instance Arbitrary RevocationCode where- arbitrary = elements [NoReason, KeySuperseded, KeyMaterialCompromised, KeyRetiredAndNoLongerUsed, UserIdInfoNoLongerValid]+ arbitrary =+ elements+ [ NoReason+ , KeySuperseded+ , KeyMaterialCompromised+ , KeyRetiredAndNoLongerUsed+ , UserIdInfoNoLongerValid+ ] instance Arbitrary FeatureFlag where- arbitrary = frequency [(9,md),(1,fo)]- where- md = return ModificationDetection- fo = fmap FeatureOther (choose (8,63))+ arbitrary = frequency [(9, md), (1, fo)]+ where+ md = return ModificationDetection+ fo = fmap FeatureOther (choose (8, 63)) instance Arbitrary ThirtyTwoBitTimeStamp where- arbitrary = fmap ThirtyTwoBitTimeStamp arbitrary+ arbitrary = fmap ThirtyTwoBitTimeStamp arbitrary instance Arbitrary ThirtyTwoBitDuration where- arbitrary = fmap ThirtyTwoBitDuration arbitrary+ arbitrary = fmap ThirtyTwoBitDuration arbitrary instance Arbitrary NotationName where- arbitrary = fmap NotationName arbitrary+ arbitrary = fmap NotationName arbitrary instance Arbitrary NotationValue where- arbitrary = fmap NotationValue arbitrary+ arbitrary = fmap NotationValue arbitrary
Codec/Encryption/OpenPGP/BlockCipher.hs view
@@ -2,44 +2,57 @@ -- Copyright © 2013-2016 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE RankNTypes #-} -module Codec.Encryption.OpenPGP.BlockCipher (- keySize+module Codec.Encryption.OpenPGP.BlockCipher+ ( keySize , withSymmetricCipher-) where+ ) where import Codec.Encryption.OpenPGP.Internal.CryptoCipherTypes (HOWrappedOldCCT(..)) import Codec.Encryption.OpenPGP.Internal.Cryptonite (HOWrappedCCT(..)) import Codec.Encryption.OpenPGP.Internal.HOBlockCipher import Codec.Encryption.OpenPGP.Types -import qualified Crypto.Cipher.Blowfish as Blowfish-import qualified Crypto.Cipher.TripleDES as TripleDES import qualified Crypto.Cipher.AES as AES+import qualified Crypto.Cipher.Blowfish as Blowfish import qualified Crypto.Cipher.Camellia as Camellia+import qualified Crypto.Cipher.TripleDES as TripleDES import qualified Crypto.Nettle.Ciphers as CNC import qualified Data.ByteString as B -type HOCipher a = forall cipher. HOBlockCipher cipher => cipher -> Either String a+type HOCipher a+ = forall cipher. HOBlockCipher cipher =>+ cipher -> Either String a -withSymmetricCipher :: SymmetricAlgorithm -> B.ByteString -> HOCipher a -> Either String a+withSymmetricCipher ::+ SymmetricAlgorithm -> B.ByteString -> HOCipher a -> Either String a withSymmetricCipher Plaintext _ _ = Left "this shouldn't have happened" -- FIXME: orphan instance? withSymmetricCipher IDEA _ _ = Left "IDEA not yet implemented" -- FIXME: IDEA withSymmetricCipher ReservedSAFER _ _ = Left "SAFER not implemented" -- FIXME: or not? withSymmetricCipher ReservedDES _ _ = Left "DES not implemented" -- FIXME: or not?-withSymmetricCipher (OtherSA _) _ _ = Left "Unknown, unimplemented symmetric algorithm"-withSymmetricCipher CAST5 key f = (cipherInit key :: Either String (HOWrappedOldCCT CNC.CAST128)) >>= f-withSymmetricCipher Twofish key f = (cipherInit key :: Either String (HOWrappedOldCCT CNC.TWOFISH)) >>= f-withSymmetricCipher TripleDES key f = (cipherInit key :: Either String (HOWrappedCCT TripleDES.DES_EDE3)) >>= f-withSymmetricCipher Blowfish key f = (cipherInit key :: Either String (HOWrappedCCT Blowfish.Blowfish128)) >>= f-withSymmetricCipher AES128 key f = (cipherInit key :: Either String (HOWrappedCCT AES.AES128)) >>= f-withSymmetricCipher AES192 key f = (cipherInit key :: Either String (HOWrappedCCT AES.AES192)) >>= f-withSymmetricCipher AES256 key f = (cipherInit key :: Either String (HOWrappedCCT AES.AES256)) >>= f-withSymmetricCipher Camellia128 key f = (cipherInit key :: Either String (HOWrappedCCT Camellia.Camellia128)) >>= f-withSymmetricCipher Camellia192 key f = (cipherInit key :: Either String (HOWrappedOldCCT CNC.Camellia192)) >>= f-withSymmetricCipher Camellia256 key f = (cipherInit key :: Either String (HOWrappedOldCCT CNC.Camellia256)) >>= f+withSymmetricCipher (OtherSA _) _ _ =+ Left "Unknown, unimplemented symmetric algorithm"+withSymmetricCipher CAST5 key f =+ (cipherInit key :: Either String (HOWrappedOldCCT CNC.CAST128)) >>= f+withSymmetricCipher Twofish key f =+ (cipherInit key :: Either String (HOWrappedOldCCT CNC.TWOFISH)) >>= f+withSymmetricCipher TripleDES key f =+ (cipherInit key :: Either String (HOWrappedCCT TripleDES.DES_EDE3)) >>= f+withSymmetricCipher Blowfish key f =+ (cipherInit key :: Either String (HOWrappedCCT Blowfish.Blowfish128)) >>= f+withSymmetricCipher AES128 key f =+ (cipherInit key :: Either String (HOWrappedCCT AES.AES128)) >>= f+withSymmetricCipher AES192 key f =+ (cipherInit key :: Either String (HOWrappedCCT AES.AES192)) >>= f+withSymmetricCipher AES256 key f =+ (cipherInit key :: Either String (HOWrappedCCT AES.AES256)) >>= f+withSymmetricCipher Camellia128 key f =+ (cipherInit key :: Either String (HOWrappedCCT Camellia.Camellia128)) >>= f+withSymmetricCipher Camellia192 key f =+ (cipherInit key :: Either String (HOWrappedOldCCT CNC.Camellia192)) >>= f+withSymmetricCipher Camellia256 key f =+ (cipherInit key :: Either String (HOWrappedOldCCT CNC.Camellia256)) >>= f -- in octets; FIXME: co-opt Cipher's cipherKeySize or not? keySize :: SymmetricAlgorithm -> Int
Codec/Encryption/OpenPGP/Compression.hs view
@@ -2,11 +2,10 @@ -- Copyright © 2012-2015 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).--module Codec.Encryption.OpenPGP.Compression (- decompressPkt- , compressPkts-) where+module Codec.Encryption.OpenPGP.Compression+ ( decompressPkt+ , compressPkts+ ) where import qualified Codec.Compression.BZip as BZip import qualified Codec.Compression.Zlib as Zlib@@ -19,23 +18,23 @@ decompressPkt :: Pkt -> [Pkt] decompressPkt (CompressedDataPkt algo bs) =- case runGetOrFail get (dfunc algo bs) of- Left _ -> []- Right (_, _, packs) -> unBlock packs- where- dfunc ZIP = ZlibRaw.decompress- dfunc ZLIB = Zlib.decompress- dfunc BZip2 = BZip.decompress- dfunc _ = error "Compression algorithm not supported"+ case runGetOrFail get (dfunc algo bs) of+ Left _ -> []+ Right (_, _, packs) -> unBlock packs+ where+ dfunc ZIP = ZlibRaw.decompress+ dfunc ZLIB = Zlib.decompress+ dfunc BZip2 = BZip.decompress+ dfunc _ = error "Compression algorithm not supported" decompressPkt p = [p] compressPkts :: CompressionAlgorithm -> [Pkt] -> Pkt compressPkts ca packs =- let bs = runPut $ put (Block packs)- cbs = cfunc ca bs- in CompressedDataPkt ca cbs- where- cfunc ZIP = ZlibRaw.compress- cfunc ZLIB = Zlib.compress- cfunc BZip2 = BZip.compress- cfunc _ = error "Compression algorithm not supported"+ let bs = runPut $ put (Block packs)+ cbs = cfunc ca bs+ in CompressedDataPkt ca cbs+ where+ cfunc ZIP = ZlibRaw.compress+ cfunc ZLIB = Zlib.compress+ cfunc BZip2 = BZip.compress+ cfunc _ = error "Compression algorithm not supported"
Codec/Encryption/OpenPGP/Expirations.hs view
@@ -2,27 +2,34 @@ -- Copyright © 2014-2015 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).--module Codec.Encryption.OpenPGP.Expirations (- isTKTimeValid- , getKeyExpirationTimesFromSignature-) where+module Codec.Encryption.OpenPGP.Expirations+ ( isTKTimeValid+ , getKeyExpirationTimesFromSignature+ ) where import Control.Lens ((&), (^.), _1) import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Codec.Encryption.OpenPGP.Types import Codec.Encryption.OpenPGP.Ontology (isKET)+import Codec.Encryption.OpenPGP.Types -- this assumes that all key expiration time subpackets are valid isTKTimeValid :: UTCTime -> TK -> Bool isTKTimeValid ct key = ct >= keyCreationTime && ct < keyExpirationTime- where- keyCreationTime = key^.tkKey._1.timestamp & posixSecondsToUTCTime . realToFrac- keyExpirationTime = posixSecondsToUTCTime . realToFrac . ((key^.tkKey._1.timestamp & unThirtyTwoBitTimeStamp) +) . unThirtyTwoBitDuration . newest . concatMap getKeyExpirationTimesFromSignature $ (concatMap snd (key^.tkUIDs) ++ concatMap snd (key^.tkUAts))- newest [] = maxBound- newest xs = maximum xs+ where+ keyCreationTime =+ key ^. tkKey . _1 . timestamp & posixSecondsToUTCTime . realToFrac+ keyExpirationTime =+ posixSecondsToUTCTime . realToFrac .+ ((key ^. tkKey . _1 . timestamp & unThirtyTwoBitTimeStamp) +) .+ unThirtyTwoBitDuration .+ newest .+ concatMap getKeyExpirationTimesFromSignature $+ (concatMap snd (key ^. tkUIDs) ++ concatMap snd (key ^. tkUAts))+ newest [] = maxBound+ newest xs = maximum xs getKeyExpirationTimesFromSignature :: SignaturePayload -> [ThirtyTwoBitDuration]-getKeyExpirationTimesFromSignature (SigV4 _ _ _ xs _ _ _) = map (\(SigSubPacket _ (KeyExpirationTime x)) -> x) $ filter isKET xs+getKeyExpirationTimesFromSignature (SigV4 _ _ _ xs _ _ _) =+ map (\(SigSubPacket _ (KeyExpirationTime x)) -> x) $ filter isKET xs
Codec/Encryption/OpenPGP/Fingerprint.hs view
@@ -2,30 +2,49 @@ -- Copyright © 2012-2016 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).--module Codec.Encryption.OpenPGP.Fingerprint (- eightOctetKeyID- , fingerprint-) where+module Codec.Encryption.OpenPGP.Fingerprint+ ( eightOctetKeyID+ , fingerprint+ ) where -import qualified Crypto.PubKey.RSA as RSA-import Crypto.Hash (hashlazy, Digest)+import Crypto.Hash (Digest, hashlazy) import Crypto.Hash.Algorithms (MD5, SHA1) import Crypto.Number.Serialize (i2osp)+import qualified Crypto.PubKey.RSA as RSA+import Data.Binary.Put (runPut) import qualified Data.ByteArray as BA import qualified Data.ByteString.Lazy as BL-import Data.Binary.Put (runPut) import Codec.Encryption.OpenPGP.SerializeForSigs (putPKPforFingerprinting) import Codec.Encryption.OpenPGP.Types eightOctetKeyID :: PKPayload -> Either String EightOctetKeyId-eightOctetKeyID (PKPayload DeprecatedV3 _ _ RSA (RSAPubKey (RSA_PublicKey rp))) = (Right . EightOctetKeyId . BL.reverse . BL.take 4 . BL.reverse . BL.fromStrict . i2osp . RSA.public_n) rp-eightOctetKeyID (PKPayload DeprecatedV3 _ _ DeprecatedRSAEncryptOnly (RSAPubKey (RSA_PublicKey rp))) = (Right . EightOctetKeyId . BL.reverse . BL.take 4 . BL.reverse . BL.fromStrict . i2osp . RSA.public_n) rp-eightOctetKeyID (PKPayload DeprecatedV3 _ _ DeprecatedRSASignOnly (RSAPubKey (RSA_PublicKey rp))) = (Right . EightOctetKeyId . BL.reverse . BL.take 4 . BL.reverse . BL.fromStrict . i2osp . 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 . BL.drop 12 . unTOF . fingerprint) p4+eightOctetKeyID (PKPayload DeprecatedV3 _ _ RSA (RSAPubKey (RSA_PublicKey rp))) =+ (Right .+ EightOctetKeyId .+ BL.reverse . BL.take 4 . BL.reverse . BL.fromStrict . i2osp . RSA.public_n)+ rp+eightOctetKeyID (PKPayload DeprecatedV3 _ _ DeprecatedRSAEncryptOnly (RSAPubKey (RSA_PublicKey rp))) =+ (Right .+ EightOctetKeyId .+ BL.reverse . BL.take 4 . BL.reverse . BL.fromStrict . i2osp . RSA.public_n)+ rp+eightOctetKeyID (PKPayload DeprecatedV3 _ _ DeprecatedRSASignOnly (RSAPubKey (RSA_PublicKey rp))) =+ (Right .+ EightOctetKeyId .+ BL.reverse . BL.take 4 . BL.reverse . BL.fromStrict . i2osp . 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 . BL.drop 12 . unTOF . fingerprint) p4 fingerprint :: PKPayload -> TwentyOctetFingerprint-fingerprint p3@(PKPayload DeprecatedV3 _ _ _ _) = (TwentyOctetFingerprint . BL.fromStrict . BA.convert . (hashlazy :: BL.ByteString -> Digest MD5)) (runPut $ putPKPforFingerprinting (PublicKeyPkt p3))-fingerprint p4@(PKPayload V4 _ _ _ _) = (TwentyOctetFingerprint . BL.fromStrict . BA.convert . (hashlazy :: BL.ByteString -> Digest SHA1)) (runPut $ putPKPforFingerprinting (PublicKeyPkt p4))+fingerprint p3@(PKPayload DeprecatedV3 _ _ _ _) =+ (TwentyOctetFingerprint .+ BL.fromStrict . BA.convert . (hashlazy :: BL.ByteString -> Digest MD5))+ (runPut $ putPKPforFingerprinting (PublicKeyPkt p3))+fingerprint p4@(PKPayload V4 _ _ _ _) =+ (TwentyOctetFingerprint .+ BL.fromStrict . BA.convert . (hashlazy :: BL.ByteString -> Digest SHA1))+ (runPut $ putPKPforFingerprinting (PublicKeyPkt p4))
Codec/Encryption/OpenPGP/Internal.hs view
@@ -2,24 +2,23 @@ -- Copyright © 2012-2019 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE OverloadedStrings #-} -module Codec.Encryption.OpenPGP.Internal (- countBits- , PktStreamContext(..)- , issuer- , emptyPSC- , pubkeyToMPIs- , multiplicativeInverse- , curveoidBSToCurve- , curveToCurveoidBS- , point2BS- , curveoidBSToEdSigningCurve- , edSigningCurveToCurveoidBS- , curve2Curve- , curveFromCurve-) where+module Codec.Encryption.OpenPGP.Internal+ ( countBits+ , PktStreamContext(..)+ , issuer+ , emptyPSC+ , pubkeyToMPIs+ , multiplicativeInverse+ , curveoidBSToCurve+ , curveToCurveoidBS+ , point2BS+ , curveoidBSToEdSigningCurve+ , edSigningCurveToCurveoidBS+ , curve2Curve+ , curveFromCurve+ ) where import Crypto.Number.Serialize (i2osp, os2ip) import qualified Crypto.PubKey.DSA as DSA@@ -32,68 +31,89 @@ import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import Data.List (find)-import Data.Word (Word8, Word16)+import Data.Word (Word16, Word8) -import Codec.Encryption.OpenPGP.Types import Codec.Encryption.OpenPGP.Ontology (isIssuerSSP, isSigCreationTime)+import Codec.Encryption.OpenPGP.Types countBits :: ByteString -> Word16 countBits bs- | BL.null bs = 0- | otherwise = fromIntegral (BL.length bs * 8) - fromIntegral (go (BL.head bs) 7)- where- go :: Word8 -> Int -> Word8- go _ 0 = 7- go n b = if testBit n b then 7 - fromIntegral b else go n (b-1)+ | BL.null bs = 0+ | otherwise =+ fromIntegral (BL.length bs * 8) - fromIntegral (go (BL.head bs) 7)+ where+ go :: Word8 -> Int -> Word8+ go _ 0 = 7+ go n b =+ if testBit n b+ then 7 - fromIntegral b+ else go n (b - 1) -data PktStreamContext = PktStreamContext { lastLD :: Pkt- , lastUIDorUAt :: Pkt- , lastSig :: Pkt- , lastPrimaryKey :: Pkt- , lastSubkey :: Pkt- }+data PktStreamContext =+ PktStreamContext+ { lastLD :: Pkt+ , lastUIDorUAt :: Pkt+ , lastSig :: Pkt+ , lastPrimaryKey :: Pkt+ , lastSubkey :: Pkt+ } emptyPSC :: PktStreamContext-emptyPSC = PktStreamContext (OtherPacketPkt 0 "lastLD placeholder") (OtherPacketPkt 0 "lastUIDorUAt placeholder") (OtherPacketPkt 0 "lastSig placeholder") (OtherPacketPkt 0 "lastPrimaryKey placeholder") (OtherPacketPkt 0 "lastSubkey placeholder")+emptyPSC =+ PktStreamContext+ (OtherPacketPkt 0 "lastLD placeholder")+ (OtherPacketPkt 0 "lastUIDorUAt placeholder")+ (OtherPacketPkt 0 "lastSig placeholder")+ (OtherPacketPkt 0 "lastPrimaryKey placeholder")+ (OtherPacketPkt 0 "lastSubkey placeholder") issuer :: Pkt -> Maybe EightOctetKeyId-issuer (SignaturePkt (SigV4 _ _ _ _ usubs _ _)) = fmap (\(SigSubPacket _ (Issuer i)) -> i) (find isIssuerSSP usubs)+issuer (SignaturePkt (SigV4 _ _ _ _ usubs _ _)) =+ fmap (\(SigSubPacket _ (Issuer i)) -> i) (find isIssuerSSP usubs) issuer _ = Nothing pubkeyToMPIs :: PKey -> [MPI]-pubkeyToMPIs (RSAPubKey (RSA_PublicKey k)) = [MPI (RSA.public_n k), MPI (RSA.public_e k)]-pubkeyToMPIs (DSAPubKey (DSA_PublicKey k)) = [- pkParams DSA.params_p- , pkParams DSA.params_q- , pkParams DSA.params_g- , MPI . DSA.public_y $ k- ]- where pkParams f = MPI . f . DSA.public_params $ k-+pubkeyToMPIs (RSAPubKey (RSA_PublicKey k)) =+ [MPI (RSA.public_n k), MPI (RSA.public_e k)]+pubkeyToMPIs (DSAPubKey (DSA_PublicKey k)) =+ [ pkParams DSA.params_p+ , pkParams DSA.params_q+ , pkParams DSA.params_g+ , MPI . DSA.public_y $ k+ ]+ where+ pkParams f = MPI . f . DSA.public_params $ k pubkeyToMPIs (ElGamalPubKey p g y) = [MPI p, MPI g, MPI y]-pubkeyToMPIs (ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey _ q))) _ _) = [MPI (os2ip (point2BS q))]+pubkeyToMPIs (ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey _ q))) _ _) =+ [MPI (os2ip (point2BS q))] pubkeyToMPIs (ECDHPubKey (EdDSAPubKey _ (EPoint x)) _ _) = [MPI x]-pubkeyToMPIs (ECDSAPubKey ((ECDSA_PublicKey (ECDSA.PublicKey _ q)))) = [MPI (os2ip (point2BS q))]+pubkeyToMPIs (ECDSAPubKey ((ECDSA_PublicKey (ECDSA.PublicKey _ q)))) =+ [MPI (os2ip (point2BS q))] pubkeyToMPIs (EdDSAPubKey _ (EPoint x)) = [MPI x] multiplicativeInverse :: Integral a => a -> a -> a multiplicativeInverse _ 1 = 1 multiplicativeInverse q p = (n * q + 1) `div` p- where n = p - multiplicativeInverse p (q `mod` p)+ where+ n = p - multiplicativeInverse p (q `mod` p) curveoidBSToCurve :: B.ByteString -> Either String ECCCurve curveoidBSToCurve oidbs- | B.pack [0x2A,0x86,0x48,0xCE,0x3D,0x03,0x01,0x07] == oidbs = Right $ NISTP256 -- ECCT.getCurveByName ECCT.SEC_p256r1- | B.pack [0x2B,0x81,0x04,0x00,0x22] == oidbs = Right $ NISTP384 -- ECCT.getCurveByName ECCT.SEC_p384r1- | B.pack [0x2B,0x81,0x04,0x00,0x23] == oidbs = Right $ NISTP521 -- ECCT.getCurveByName ECCT.SEC_p521r1- | B.pack [0x2B,0x06,0x01,0x04,0x01,0x97,0x55,0x01,0x05,0x01] == oidbs = Right Curve25519- | otherwise = Left $ concat ["unknown curve (...", show (B.unpack oidbs) ,")"]+ | B.pack [0x2A, 0x86, 0x48, 0xCE, 0x3D, 0x03, 0x01, 0x07] == oidbs =+ Right $ NISTP256 -- ECCT.getCurveByName ECCT.SEC_p256r1+ | B.pack [0x2B, 0x81, 0x04, 0x00, 0x22] == oidbs = Right $ NISTP384 -- ECCT.getCurveByName ECCT.SEC_p384r1+ | B.pack [0x2B, 0x81, 0x04, 0x00, 0x23] == oidbs = Right $ NISTP521 -- ECCT.getCurveByName ECCT.SEC_p521r1+ | B.pack [0x2B, 0x06, 0x01, 0x04, 0x01, 0x97, 0x55, 0x01, 0x05, 0x01] == oidbs =+ Right Curve25519+ | otherwise = Left $ concat ["unknown curve (...", show (B.unpack oidbs), ")"] curveToCurveoidBS :: ECCCurve -> Either String B.ByteString-curveToCurveoidBS NISTP256 = Right $ B.pack [0x2A,0x86,0x48,0xCE,0x3D,0x03,0x01,0x07]-curveToCurveoidBS NISTP384 = Right $ B.pack [0x2B,0x81,0x04,0x00,0x22]-curveToCurveoidBS NISTP521 = Right $ B.pack [0x2B,0x81,0x04,0x00,0x23]-curveToCurveoidBS Curve25519 = Right $ B.pack [0x2B,0x06,0x01,0x04,0x01,0x97,0x55,0x01,0x05,0x01]+curveToCurveoidBS NISTP256 =+ Right $ B.pack [0x2A, 0x86, 0x48, 0xCE, 0x3D, 0x03, 0x01, 0x07]+curveToCurveoidBS NISTP384 = Right $ B.pack [0x2B, 0x81, 0x04, 0x00, 0x22]+curveToCurveoidBS NISTP521 = Right $ B.pack [0x2B, 0x81, 0x04, 0x00, 0x23]+curveToCurveoidBS Curve25519 =+ Right $ B.pack [0x2B, 0x06, 0x01, 0x04, 0x01, 0x97, 0x55, 0x01, 0x05, 0x01] curveToCurveoidBS _ = Left "unknown curve" point2BS :: ECCT.PublicPoint -> B.ByteString@@ -102,11 +122,15 @@ curveoidBSToEdSigningCurve :: B.ByteString -> Either String EdSigningCurve curveoidBSToEdSigningCurve oidbs- | B.pack [0x2B,0x06,0x01,0x04,0x01,0xDA,0x47,0x0F,0x01] == oidbs = Right Ed25519- | otherwise = Left $ concat ["unknown Edwards signing curve (...", show (B.unpack oidbs) ,")"]+ | B.pack [0x2B, 0x06, 0x01, 0x04, 0x01, 0xDA, 0x47, 0x0F, 0x01] == oidbs =+ Right Ed25519+ | otherwise =+ Left $+ concat ["unknown Edwards signing curve (...", show (B.unpack oidbs), ")"] edSigningCurveToCurveoidBS :: EdSigningCurve -> Either String B.ByteString-edSigningCurveToCurveoidBS Ed25519 = Right $ B.pack [0x2B,0x06,0x01,0x04,0x01,0xDA,0x47,0x0F,0x01]+edSigningCurveToCurveoidBS Ed25519 =+ Right $ B.pack [0x2B, 0x06, 0x01, 0x04, 0x01, 0xDA, 0x47, 0x0F, 0x01] curve2Curve :: ECCCurve -> ECCT.Curve curve2Curve NISTP256 = ECCT.getCurveByName ECCT.SEC_p256r1@@ -115,6 +139,6 @@ curveFromCurve :: ECCT.Curve -> ECCCurve curveFromCurve c- | c == ECCT.getCurveByName ECCT.SEC_p256r1 = NISTP256- | c == ECCT.getCurveByName ECCT.SEC_p384r1 = NISTP384- | c == ECCT.getCurveByName ECCT.SEC_p521r1 = NISTP521+ | c == ECCT.getCurveByName ECCT.SEC_p256r1 = NISTP256+ | c == ECCT.getCurveByName ECCT.SEC_p384r1 = NISTP384+ | c == ECCT.getCurveByName ECCT.SEC_p521r1 = NISTP521
Codec/Encryption/OpenPGP/Internal/CryptoCipherTypes.hs view
@@ -2,14 +2,13 @@ -- Copyright © 2016 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE UndecidableInstances #-} -module Codec.Encryption.OpenPGP.Internal.CryptoCipherTypes (- HOWrappedOldCCT(..)-) where+module Codec.Encryption.OpenPGP.Internal.CryptoCipherTypes+ ( HOWrappedOldCCT(..)+ ) where import Control.Error.Util (note) import qualified "crypto-cipher-types" Crypto.Cipher.Types as OldCCT@@ -18,26 +17,43 @@ import Codec.Encryption.OpenPGP.Internal.HOBlockCipher -newtype HOWrappedOldCCT a = HWOCCT a+newtype HOWrappedOldCCT a =+ HWOCCT a -instance OldCCT.BlockCipher cipher => HOBlockCipher (HOWrappedOldCCT cipher) where- cipherInit = fmap HWOCCT . either (const (Left "nettle invalid key"))- (Right . OldCCT.cipherInit) . OldCCT.makeKey- cipherName (HWOCCT c) = OldCCT.cipherName c- cipherKeySize (HWOCCT c) = convertKSS . OldCCT.cipherKeySize $ c- blockSize (HWOCCT c) = OldCCT.blockSize c- cfbEncrypt (HWOCCT c) iv bs = hammerIV iv >>= \i -> return (OldCCT.cfbEncrypt c i bs)- cfbDecrypt (HWOCCT c) iv bs = hammerIV iv >>= \i -> return (OldCCT.cfbDecrypt c i bs)- paddedCfbEncrypt _ _ _ = Left "padding for nettle-encryption not implemented yet"- paddedCfbDecrypt (HWOCCT cipher) iv ciphertext = hammerIV iv >>= \i -> return (B.take (B.length ciphertext) (OldCCT.cfbDecrypt cipher i padded))- where- padded = ciphertext `B.append`- B.pack (replicate (OldCCT.blockSize cipher - (B.length ciphertext `mod` OldCCT.blockSize cipher)) 0)+instance OldCCT.BlockCipher cipher =>+ HOBlockCipher (HOWrappedOldCCT cipher) where+ cipherInit =+ fmap HWOCCT .+ either (const (Left "nettle invalid key")) (Right . OldCCT.cipherInit) .+ OldCCT.makeKey+ cipherName (HWOCCT c) = OldCCT.cipherName c+ cipherKeySize (HWOCCT c) = convertKSS . OldCCT.cipherKeySize $ c+ blockSize (HWOCCT c) = OldCCT.blockSize c+ cfbEncrypt (HWOCCT c) iv bs =+ hammerIV iv >>= \i -> return (OldCCT.cfbEncrypt c i bs)+ cfbDecrypt (HWOCCT c) iv bs =+ hammerIV iv >>= \i -> return (OldCCT.cfbDecrypt c i bs)+ paddedCfbEncrypt _ _ _ =+ Left "padding for nettle-encryption not implemented yet"+ paddedCfbDecrypt (HWOCCT cipher) iv ciphertext =+ hammerIV iv >>= \i ->+ return (B.take (B.length ciphertext) (OldCCT.cfbDecrypt cipher i padded))+ where+ padded =+ ciphertext `B.append`+ B.pack+ (replicate+ (OldCCT.blockSize cipher -+ (B.length ciphertext `mod` OldCCT.blockSize cipher))+ 0) convertKSS :: OldCCT.KeySizeSpecifier -> CCT.KeySizeSpecifier convertKSS (OldCCT.KeySizeRange a b) = CCT.KeySizeRange a b convertKSS (OldCCT.KeySizeEnum as) = CCT.KeySizeEnum as convertKSS (OldCCT.KeySizeFixed a) = CCT.KeySizeFixed a -hammerIV :: OldCCT.BlockCipher cipher => B.ByteString -> Either String (OldCCT.IV cipher)+hammerIV ::+ OldCCT.BlockCipher cipher+ => B.ByteString+ -> Either String (OldCCT.IV cipher) hammerIV = note "nettle bad IV" . OldCCT.makeIV
Codec/Encryption/OpenPGP/Internal/Cryptonite.hs view
@@ -2,15 +2,14 @@ -- Copyright © 2016 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE UndecidableInstances #-} -module Codec.Encryption.OpenPGP.Internal.Cryptonite (- HOWrappedCCT(..)-) where+module Codec.Encryption.OpenPGP.Internal.Cryptonite+ ( HOWrappedCCT(..)+ ) where import Control.Error.Util (note) import qualified "cryptonite" Crypto.Cipher.Types as CCT@@ -20,15 +19,19 @@ import Codec.Encryption.OpenPGP.Internal.HOBlockCipher -newtype HOWrappedCCT a = HWCCT a+newtype HOWrappedCCT a =+ HWCCT a instance CCT.BlockCipher cipher => HOBlockCipher (HOWrappedCCT cipher) where- cipherInit = bimap show HWCCT . CE.eitherCryptoError . CCT.cipherInit- cipherName (HWCCT c) = CCT.cipherName c- cipherKeySize (HWCCT c) = CCT.cipherKeySize c- blockSize (HWCCT c) = CCT.blockSize c- cfbEncrypt (HWCCT c) iv bs = hammerIV iv >>= \i -> return (CCT.cfbEncrypt c i bs)- cfbDecrypt (HWCCT c) iv bs = hammerIV iv >>= \i -> return (CCT.cfbDecrypt c i bs)+ cipherInit = bimap show HWCCT . CE.eitherCryptoError . CCT.cipherInit+ cipherName (HWCCT c) = CCT.cipherName c+ cipherKeySize (HWCCT c) = CCT.cipherKeySize c+ blockSize (HWCCT c) = CCT.blockSize c+ cfbEncrypt (HWCCT c) iv bs =+ hammerIV iv >>= \i -> return (CCT.cfbEncrypt c i bs)+ cfbDecrypt (HWCCT c) iv bs =+ hammerIV iv >>= \i -> return (CCT.cfbDecrypt c i bs) -hammerIV :: CCT.BlockCipher cipher => B.ByteString -> Either String (CCT.IV cipher)+hammerIV ::+ CCT.BlockCipher cipher => B.ByteString -> Either String (CCT.IV cipher) hammerIV = note "cryptonite bad IV" . CCT.makeIV
Codec/Encryption/OpenPGP/Internal/HOBlockCipher.hs view
@@ -2,25 +2,28 @@ -- Copyright © 2016 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE PackageImports #-} -module Codec.Encryption.OpenPGP.Internal.HOBlockCipher (- HOBlockCipher(..)-) where+module Codec.Encryption.OpenPGP.Internal.HOBlockCipher+ ( HOBlockCipher(..)+ ) where import qualified "cryptonite" Crypto.Cipher.Types as CCT import qualified Data.ByteString as B class HOBlockCipher cipher where- cipherInit :: B.ByteString -> Either String cipher- cipherName :: cipher -> String- cipherKeySize :: cipher -> CCT.KeySizeSpecifier- blockSize :: cipher -> Int- cfbEncrypt :: cipher -> B.ByteString -> B.ByteString -> Either String B.ByteString- cfbDecrypt :: cipher -> B.ByteString -> B.ByteString -> Either String B.ByteString- paddedCfbEncrypt :: cipher -> B.ByteString -> B.ByteString -> Either String B.ByteString- paddedCfbEncrypt = cfbEncrypt- paddedCfbDecrypt :: cipher -> B.ByteString -> B.ByteString -> Either String B.ByteString- paddedCfbDecrypt = cfbDecrypt+ cipherInit :: B.ByteString -> Either String cipher+ cipherName :: cipher -> String+ cipherKeySize :: cipher -> CCT.KeySizeSpecifier+ blockSize :: cipher -> Int+ cfbEncrypt ::+ cipher -> B.ByteString -> B.ByteString -> Either String B.ByteString+ cfbDecrypt ::+ cipher -> B.ByteString -> B.ByteString -> Either String B.ByteString+ paddedCfbEncrypt ::+ cipher -> B.ByteString -> B.ByteString -> Either String B.ByteString+ paddedCfbEncrypt = cfbEncrypt+ paddedCfbDecrypt ::+ cipher -> B.ByteString -> B.ByteString -> Either String B.ByteString+ paddedCfbDecrypt = cfbDecrypt
Codec/Encryption/OpenPGP/KeyInfo.hs view
@@ -2,11 +2,10 @@ -- Copyright © 2012-2018 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).--module Codec.Encryption.OpenPGP.KeyInfo (- pubkeySize- , pkalgoAbbrev-) where+module Codec.Encryption.OpenPGP.KeyInfo+ ( pubkeySize+ , pkalgoAbbrev+ ) where import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA@@ -19,16 +18,26 @@ 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 (DSAPubKey (DSA_PublicKey x)) =+ Right (bitcount . DSA.params_p . DSA.public_params $ x) pubkeySize (ElGamalPubKey p _ _) = Right (bitcount p)-pubkeySize (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) = Right (fromIntegral (ECCT.curveSizeBits curve))-pubkeySize (ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) _ _) = Right (fromIntegral (ECCT.curveSizeBits curve))+pubkeySize (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) =+ Right (fromIntegral (ECCT.curveSizeBits curve))+pubkeySize (ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) _ _) =+ Right (fromIntegral (ECCT.curveSizeBits curve)) pubkeySize (ECDHPubKey (EdDSAPubKey Ed25519 _) _ _) = Right 256 pubkeySize (EdDSAPubKey Ed25519 _) = Right 256 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))+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
Codec/Encryption/OpenPGP/KeySelection.hs view
@@ -2,28 +2,39 @@ -- Copyright © 2014-2018 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE OverloadedStrings #-} -module Codec.Encryption.OpenPGP.KeySelection (- parseEightOctetKeyId- , parseFingerprint-) where+module Codec.Encryption.OpenPGP.KeySelection+ ( parseEightOctetKeyId+ , parseFingerprint+ ) where import Codec.Encryption.OpenPGP.Types import Control.Applicative (optional) import Control.Monad ((<=<)) import Crypto.Number.Serialize (i2osp)-import Data.Attoparsec.Text (asciiCI, count, hexadecimal, inClass, parseOnly, Parser, satisfy)+import Data.Attoparsec.Text+ ( Parser+ , asciiCI+ , count+ , hexadecimal+ , inClass+ , parseOnly+ , satisfy+ ) import qualified Data.ByteString.Lazy as BL import Data.Text (Text, toUpper) import qualified Data.Text as T parseEightOctetKeyId :: Text -> Either String EightOctetKeyId-parseEightOctetKeyId = fmap EightOctetKeyId . (parseOnly hexes <=< parseOnly (hexPrefix *> hexen 16)) . toUpper+parseEightOctetKeyId =+ fmap EightOctetKeyId .+ (parseOnly hexes <=< parseOnly (hexPrefix *> hexen 16)) . toUpper parseFingerprint :: Text -> Either String TwentyOctetFingerprint-parseFingerprint = fmap TwentyOctetFingerprint . (parseOnly hexes <=< parseOnly (hexen 40)) . toUpper . T.filter (/=' ')+parseFingerprint =+ fmap TwentyOctetFingerprint .+ (parseOnly hexes <=< parseOnly (hexen 40)) . toUpper . T.filter (/= ' ') hexPrefix :: Parser (Maybe Text) hexPrefix = optional (asciiCI "0x")
Codec/Encryption/OpenPGP/KeyringParser.hs view
@@ -2,48 +2,65 @@ -- Copyright © 2012-2018 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).--module Codec.Encryption.OpenPGP.KeyringParser (+module Codec.Encryption.OpenPGP.KeyringParser -- * Parsers- parseAChunk- , finalizeParsing- , anyTK- , UidOrUat(..)- , splitUs- , publicTK- , secretTK- , brokenTK- , pkPayload- , signature- , signedUID- , signedUAt- , signedOrRevokedPubSubkey- , brokenPubSubkey- , rawOrSignedOrRevokedSecSubkey- , brokenSecSubkey- , skPayload- , broken+ ( parseAChunk+ , finalizeParsing+ , anyTK+ , UidOrUat(..)+ , splitUs+ , publicTK+ , secretTK+ , brokenTK+ , pkPayload+ , signature+ , signedUID+ , signedUAt+ , signedOrRevokedPubSubkey+ , brokenPubSubkey+ , rawOrSignedOrRevokedSecSubkey+ , brokenSecSubkey+ , skPayload+ , broken -- * Utilities- , parseTKs-) where+ , parseTKs+ ) where -import Control.Applicative (many, (<|>))+import Control.Applicative ((<|>), many) import Data.Maybe (catMaybes) import Data.Monoid ((<>)) import Data.Text (Text) -import Codec.Encryption.OpenPGP.Types import Codec.Encryption.OpenPGP.Ontology (isTrustPkt)+import Codec.Encryption.OpenPGP.Types import Data.Conduit.OpenPGP.Keyring.Instances ()-import Text.ParserCombinators.Incremental.LeftBiasedLocal (concatMany, completeResults, failure, feed, feedEof, inspect, Parser, satisfy)+import Text.ParserCombinators.Incremental.LeftBiasedLocal+ ( Parser+ , completeResults+ , concatMany+ , failure+ , feed+ , feedEof+ , inspect+ , satisfy+ ) -parseAChunk :: (Monoid s, Show s) => Parser s r -> s -> ([(r, s)], Maybe (Maybe (r -> r), Parser s r)) -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r])+parseAChunk ::+ (Monoid s, Show s)+ => Parser s r+ -> s+ -> ([(r, s)], Maybe (Maybe (r -> r), Parser s r))+ -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r]) parseAChunk _ a ([], Nothing) = error $ "Failure before " ++ show a-parseAChunk op a (cr, Nothing) = (inspect (feed (mconcat (map snd cr) <> a) op), map fst cr)+parseAChunk op a (cr, Nothing) =+ (inspect (feed (mconcat (map snd cr) <> a) op), map fst cr) parseAChunk _ a (_, Just (_, p)) = (inspect (feed a p), []) -finalizeParsing :: Monoid s => ([(r, s)], Maybe (Maybe (r -> r), Parser s r)) -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r])+finalizeParsing ::+ Monoid s+ => ([(r, s)], Maybe (Maybe (r -> r), Parser s r))+ -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r]) finalizeParsing ([], Nothing) = error "Unexpected finalization failure" finalizeParsing (cr, Nothing) = (([], Nothing), map fst cr) finalizeParsing (_, Just (_, p)) = finalizeParsing (inspect (feedEof p))@@ -52,158 +69,214 @@ anyTK True = publicTK True <|> secretTK True anyTK False = publicTK False <|> secretTK False <|> brokenTK 6 <|> brokenTK 5 -data UidOrUat = I Text | A [UserAttrSubPacket]- deriving Show+data UidOrUat+ = I Text+ | A [UserAttrSubPacket]+ deriving (Show) -splitUs :: [(UidOrUat, [SignaturePayload])] -> ([(Text, [SignaturePayload])], [([UserAttrSubPacket], [SignaturePayload])])+splitUs ::+ [(UidOrUat, [SignaturePayload])]+ -> ([(Text, [SignaturePayload])], [([UserAttrSubPacket], [SignaturePayload])]) splitUs us = (is, as)- where- is = map unI (filter isI us)- as = map unA (filter isA us)- isI (I _, _) = True- isI _ = False- isA (A _, _) = True- isA _ = False- unI (I x, y) = (x, y)- unI x = error $ "unI should never be called on " ++ show x- unA (A x, y) = (x, y)- unA x = error $ "unA should never be called on " ++ show x+ where+ is = map unI (filter isI us)+ as = map unA (filter isA us)+ isI (I _, _) = True+ isI _ = False+ isA (A _, _) = True+ isA _ = False+ unI (I x, y) = (x, y)+ unI x = error $ "unI should never be called on " ++ show x+ unA (A x, y) = (x, y)+ unA x = error $ "unA should never be called on " ++ show x publicTK, secretTK :: Bool -> Parser [Pkt] (Maybe TK) publicTK intolerant = do- pkp <- pkPayload- pkpsigs <- concatMany (signature intolerant [KeyRevocationSig,SignatureDirectlyOnAKey])- (uids, uats) <- fmap splitUs (many (signedUID intolerant <|> signedUAt intolerant)) -- FIXME: require >=1 uid if intolerant- subs <- concatMany (pubsub intolerant)- return $ Just (TK pkp pkpsigs uids uats subs)- where- pubsub True = signedOrRevokedPubSubkey True- pubsub False = signedOrRevokedPubSubkey False <|> brokenPubSubkey+ pkp <- pkPayload+ pkpsigs <-+ concatMany+ (signature intolerant [KeyRevocationSig, SignatureDirectlyOnAKey])+ (uids, uats) <-+ fmap splitUs (many (signedUID intolerant <|> signedUAt intolerant)) -- FIXME: require >=1 uid if intolerant+ subs <- concatMany (pubsub intolerant)+ return $ Just (TK pkp pkpsigs uids uats subs)+ where+ pubsub True = signedOrRevokedPubSubkey True+ pubsub False = signedOrRevokedPubSubkey False <|> brokenPubSubkey+ secretTK intolerant = do- skp <- skPayload- skpsigs <- concatMany (signature intolerant [KeyRevocationSig,SignatureDirectlyOnAKey])- (uids, uats) <- fmap splitUs (many (signedUID intolerant <|> signedUAt intolerant)) -- FIXME: require >=1 uid if intolerant?- subs <- concatMany (secsub intolerant)- return $ Just (TK skp skpsigs uids uats subs)- where- secsub True = rawOrSignedOrRevokedSecSubkey True- secsub False = rawOrSignedOrRevokedSecSubkey False <|> brokenSecSubkey+ skp <- skPayload+ skpsigs <-+ concatMany+ (signature intolerant [KeyRevocationSig, SignatureDirectlyOnAKey])+ (uids, uats) <-+ fmap splitUs (many (signedUID intolerant <|> signedUAt intolerant)) -- FIXME: require >=1 uid if intolerant?+ subs <- concatMany (secsub intolerant)+ return $ Just (TK skp skpsigs uids uats subs)+ where+ secsub True = rawOrSignedOrRevokedSecSubkey True+ secsub False = rawOrSignedOrRevokedSecSubkey False <|> brokenSecSubkey brokenTK :: Int -> Parser [Pkt] (Maybe TK) brokenTK 6 = do- _ <- broken 6- _ <- many (signature False [KeyRevocationSig,SignatureDirectlyOnAKey])- _ <- many (signedUID False <|> signedUAt False)- _ <- concatMany (signedOrRevokedPubSubkey False <|> brokenPubSubkey)- return Nothing+ _ <- broken 6+ _ <- many (signature False [KeyRevocationSig, SignatureDirectlyOnAKey])+ _ <- many (signedUID False <|> signedUAt False)+ _ <- concatMany (signedOrRevokedPubSubkey False <|> brokenPubSubkey)+ return Nothing brokenTK 5 = do- _ <- broken 5- _ <- many (signature False [KeyRevocationSig,SignatureDirectlyOnAKey])- _ <- many (signedUID False <|> signedUAt False)- _ <- concatMany (rawOrSignedOrRevokedSecSubkey False <|> brokenSecSubkey)- return Nothing+ _ <- broken 5+ _ <- many (signature False [KeyRevocationSig, SignatureDirectlyOnAKey])+ _ <- many (signedUID False <|> signedUAt False)+ _ <- concatMany (rawOrSignedOrRevokedSecSubkey False <|> brokenSecSubkey)+ return Nothing brokenTK _ = fail "Unexpected broken packet type" pkPayload :: Parser [Pkt] (PKPayload, Maybe SKAddendum)-pkPayload = do pkpkts <- satisfy isPKP- case pkpkts of- [PublicKeyPkt p] -> return (p, Nothing)- _ -> failure- where- isPKP [PublicKeyPkt _] = True- isPKP _ = False+pkPayload = do+ pkpkts <- satisfy isPKP+ case pkpkts of+ [PublicKeyPkt p] -> return (p, Nothing)+ _ -> failure+ where+ isPKP [PublicKeyPkt _] = True+ isPKP _ = False signature :: Bool -> [SigType] -> Parser [Pkt] [SignaturePayload]-signature intolerant rts = if intolerant then signature' else signature' <|> brokensig'- where- signature' = do- spks <- satisfy (isSP intolerant)- case spks of- [SignaturePkt sp] -> return $! (if intolerant then id else filter isSP') [sp]- _ -> failure- brokensig' = const [] <$> broken 2- isSP True [SignaturePkt sp@SigV3{}] = isSP' sp- isSP True [SignaturePkt sp@SigV4{}] = isSP' sp- isSP False [SignaturePkt _] = True- isSP _ _ = False- isSP' (SigV3 st _ _ _ _ _ _) = st `elem` rts- isSP' (SigV4 st _ _ _ _ _ _) = st `elem` rts- isSP' _ = False+signature intolerant rts =+ if intolerant+ then signature'+ else signature' <|> brokensig'+ where+ signature' = do+ spks <- satisfy (isSP intolerant)+ case spks of+ [SignaturePkt sp] ->+ return $!+ (if intolerant+ then id+ else filter isSP')+ [sp]+ _ -> failure+ brokensig' = const [] <$> broken 2+ isSP True [SignaturePkt sp@SigV3 {}] = isSP' sp+ isSP True [SignaturePkt sp@SigV4 {}] = isSP' sp+ isSP False [SignaturePkt _] = True+ isSP _ _ = False+ isSP' (SigV3 st _ _ _ _ _ _) = st `elem` rts+ isSP' (SigV4 st _ _ _ _ _ _) = st `elem` rts+ isSP' _ = False signedUID :: Bool -> Parser [Pkt] (UidOrUat, [SignaturePayload])-signedUID intolerant = do upkts <- satisfy isUID- case upkts of- [UserIdPkt u] -> do- sigs <- concatMany (signature intolerant [GenericCert, PersonaCert, CasualCert, PositiveCert, CertRevocationSig])- return (I u, sigs)- _ -> failure- where- isUID [UserIdPkt _] = True- isUID _ = False+signedUID intolerant = do+ upkts <- satisfy isUID+ case upkts of+ [UserIdPkt u] -> do+ sigs <-+ concatMany+ (signature+ intolerant+ [ GenericCert+ , PersonaCert+ , CasualCert+ , PositiveCert+ , CertRevocationSig+ ])+ return (I u, sigs)+ _ -> failure+ where+ isUID [UserIdPkt _] = True+ isUID _ = False signedUAt :: Bool -> Parser [Pkt] (UidOrUat, [SignaturePayload])-signedUAt intolerant = do uapkts <- satisfy isUAt- case uapkts of- [UserAttributePkt us] -> do- sigs <- concatMany (signature intolerant [GenericCert, PersonaCert, CasualCert, PositiveCert, CertRevocationSig])- return (A us, sigs)- _ -> failure- where- isUAt [UserAttributePkt _] = True- isUAt _ = False+signedUAt intolerant = do+ uapkts <- satisfy isUAt+ case uapkts of+ [UserAttributePkt us] -> do+ sigs <-+ concatMany+ (signature+ intolerant+ [ GenericCert+ , PersonaCert+ , CasualCert+ , PositiveCert+ , CertRevocationSig+ ])+ return (A us, sigs)+ _ -> failure+ where+ isUAt [UserAttributePkt _] = True+ isUAt _ = False signedOrRevokedPubSubkey :: Bool -> Parser [Pkt] [(Pkt, [SignaturePayload])]-signedOrRevokedPubSubkey intolerant = do pskpkts <- satisfy isPSKP- case pskpkts of- [p] -> do- sigs <- concatMany (signature intolerant [SubkeyBindingSig, SubkeyRevocationSig])- return [(p, sigs)]- _ -> failure- where- isPSKP [PublicSubkeyPkt _] = True- isPSKP _ = False+signedOrRevokedPubSubkey intolerant = do+ pskpkts <- satisfy isPSKP+ case pskpkts of+ [p] -> do+ sigs <-+ concatMany+ (signature intolerant [SubkeyBindingSig, SubkeyRevocationSig])+ return [(p, sigs)]+ _ -> failure+ where+ isPSKP [PublicSubkeyPkt _] = True+ isPSKP _ = False brokenPubSubkey :: Parser [Pkt] [(Pkt, [SignaturePayload])]-brokenPubSubkey = do _ <- broken 14- _ <- concatMany (signature False [SubkeyBindingSig, SubkeyRevocationSig])- return []+brokenPubSubkey = do+ _ <- broken 14+ _ <- concatMany (signature False [SubkeyBindingSig, SubkeyRevocationSig])+ return [] -rawOrSignedOrRevokedSecSubkey :: Bool -> Parser [Pkt] [(Pkt, [SignaturePayload])]-rawOrSignedOrRevokedSecSubkey intolerant = do sskpkts <- satisfy isSSKP- case sskpkts of- [p] -> do- sigs <- concatMany (signature intolerant [SubkeyBindingSig, SubkeyRevocationSig])- return [(p, sigs)]- _ -> failure- where- isSSKP [SecretSubkeyPkt _ _] = True- isSSKP _ = False+rawOrSignedOrRevokedSecSubkey ::+ Bool -> Parser [Pkt] [(Pkt, [SignaturePayload])]+rawOrSignedOrRevokedSecSubkey intolerant = do+ sskpkts <- satisfy isSSKP+ case sskpkts of+ [p] -> do+ sigs <-+ concatMany+ (signature intolerant [SubkeyBindingSig, SubkeyRevocationSig])+ return [(p, sigs)]+ _ -> failure+ where+ isSSKP [SecretSubkeyPkt _ _] = True+ isSSKP _ = False brokenSecSubkey :: Parser [Pkt] [(Pkt, [SignaturePayload])]-brokenSecSubkey = do _ <- broken 7- _ <- concatMany (signature False [SubkeyBindingSig, SubkeyRevocationSig])- return []+brokenSecSubkey = do+ _ <- broken 7+ _ <- concatMany (signature False [SubkeyBindingSig, SubkeyRevocationSig])+ return [] skPayload :: Parser [Pkt] (PKPayload, Maybe SKAddendum)-skPayload = do spkts <- satisfy isSKP- case spkts of- [SecretKeyPkt p ska] -> return (p, Just ska)- _ -> failure- where- isSKP [SecretKeyPkt _ _] = True- isSKP _ = False+skPayload = do+ spkts <- satisfy isSKP+ case spkts of+ [SecretKeyPkt p ska] -> return (p, Just ska)+ _ -> failure+ where+ isSKP [SecretKeyPkt _ _] = True+ isSKP _ = False broken :: Int -> Parser [Pkt] Pkt-broken t = do bpkts <- satisfy isBroken- case bpkts of- [bp] -> return bp- _ -> failure- where- isBroken [BrokenPacketPkt _ a _] = t == fromIntegral a- isBroken _ = False+broken t = do+ bpkts <- satisfy isBroken+ case bpkts of+ [bp] -> return bp+ _ -> failure+ where+ isBroken [BrokenPacketPkt _ a _] = t == fromIntegral a+ isBroken _ = False -- | parse TKs from packets parseTKs :: Bool -> [Pkt] -> [TK]-parseTKs intolerant ps = catMaybes (concatMap fst (completeResults (feedEof (feed (filter notTrustPacket ps) (many (anyTK intolerant))))))- where- notTrustPacket = not . isTrustPkt+parseTKs intolerant ps =+ catMaybes+ (concatMap+ fst+ (completeResults+ (feedEof (feed (filter notTrustPacket ps) (many (anyTK intolerant))))))+ where+ notTrustPacket = not . isTrustPkt
Codec/Encryption/OpenPGP/Ontology.hs view
@@ -2,25 +2,24 @@ -- Copyright © 2012-2016 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).--module Codec.Encryption.OpenPGP.Ontology (+module Codec.Encryption.OpenPGP.Ontology -- * for signature payloads- isCertRevocationSig- , isRevokerP- , isPKBindingSig- , isSKBindingSig- , isSubkeyBindingSig- , isSubkeyRevocation- , isTrustPkt+ ( isCertRevocationSig+ , isRevokerP+ , isPKBindingSig+ , isSKBindingSig+ , isSubkeyBindingSig+ , isSubkeyRevocation+ , isTrustPkt -- * for signature subpackets- , isCT- , isIssuerSSP- , isKET- , isKUF- , isPHA- , isRevocationKeySSP- , isSigCreationTime-) where+ , isCT+ , isIssuerSSP+ , isKET+ , isKUF+ , isPHA+ , isRevocationKeySSP+ , isSigCreationTime+ ) where import Codec.Encryption.OpenPGP.Types @@ -29,7 +28,8 @@ isCertRevocationSig _ = False isRevokerP :: SignaturePayload -> Bool-isRevokerP (SigV4 SignatureDirectlyOnAKey _ _ h u _ _) = any isRevocationKeySSP h && any isIssuerSSP u+isRevokerP (SigV4 SignatureDirectlyOnAKey _ _ h u _ _) =+ any isRevocationKeySSP h && any isIssuerSSP u isRevokerP _ = False isPKBindingSig :: SignaturePayload -> Bool@@ -52,7 +52,6 @@ isTrustPkt (TrustPkt _) = True isTrustPkt _ = False - isCT :: SigSubPacket -> Bool isCT (SigSubPacket _ (SigCreationTime _)) = True isCT _ = False@@ -74,7 +73,7 @@ isPHA _ = False isRevocationKeySSP :: SigSubPacket -> Bool-isRevocationKeySSP (SigSubPacket _ RevocationKey{}) = True+isRevocationKeySSP (SigSubPacket _ RevocationKey {}) = True isRevocationKeySSP _ = False isSigCreationTime :: SigSubPacket -> Bool
Codec/Encryption/OpenPGP/S2K.hs view
@@ -2,11 +2,10 @@ -- Copyright © 2013-2016 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).--module Codec.Encryption.OpenPGP.S2K (- string2Key- ,skesk2Key-) where+module Codec.Encryption.OpenPGP.S2K+ ( string2Key+ , skesk2Key+ ) where import Codec.Encryption.OpenPGP.BlockCipher (keySize) import Codec.Encryption.OpenPGP.Types@@ -19,8 +18,14 @@ string2Key :: S2K -> Int -> BL.ByteString -> B.ByteString string2Key (Simple ha) ksz bs = B.take (fromIntegral ksz) $ hashpp ha ksz bs-string2Key (Salted ha salt) ksz bs = string2Key (Simple ha) ksz (BL.append (BL.fromStrict (unSalt salt)) bs)-string2Key (IteratedSalted ha salt cnt) ksz bs = string2Key (Simple ha) ksz (BL.take (fromIntegral cnt) . BL.cycle $ BL.append (BL.fromStrict (unSalt salt)) bs)+string2Key (Salted ha salt) ksz bs =+ string2Key (Simple ha) ksz (BL.append (BL.fromStrict (unSalt salt)) bs)+string2Key (IteratedSalted ha salt cnt) ksz bs =+ string2Key+ (Simple ha)+ ksz+ (BL.take (fromIntegral cnt) . BL.cycle $+ BL.append (BL.fromStrict (unSalt salt)) bs) string2Key _ _ _ = error "FIXME: unimplemented S2K type" skesk2Key :: SKESK -> BL.ByteString -> B.ByteString@@ -28,13 +33,15 @@ skesk2Key _ _ = error "FIXME" hashpp :: HashAlgorithm -> Int -> BL.ByteString -> B.ByteString-hashpp ha keysize pp = snd (execState (hashround `untilM_` bigEnough) (0, B.empty))- where- hashround = get >>= \(ctr, bs) -> put (ctr + 1, bs `B.append` hf ha (nulpad ctr `BL.append` pp))- nulpad = BL.pack . flip replicate 0- bigEnough = get >>= \(_, bs) -> return (B.length bs >= keysize)- hf :: HashAlgorithm -> BL.ByteString -> B.ByteString- hf SHA1 bs = BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA1)- hf SHA512 bs = BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA512)- hf _ _ = error "FIXME: unimplemented S2K hash"-+hashpp ha keysize pp =+ snd (execState (hashround `untilM_` bigEnough) (0, B.empty))+ where+ hashround =+ get >>= \(ctr, bs) ->+ put (ctr + 1, bs `B.append` hf ha (nulpad ctr `BL.append` pp))+ nulpad = BL.pack . flip replicate 0+ bigEnough = get >>= \(_, bs) -> return (B.length bs >= keysize)+ hf :: HashAlgorithm -> BL.ByteString -> B.ByteString+ hf SHA1 bs = BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA1)+ hf SHA512 bs = BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA512)+ hf _ _ = error "FIXME: unimplemented S2K hash"
Codec/Encryption/OpenPGP/SecretKey.hs view
@@ -2,87 +2,112 @@ -- Copyright © 2013-2018 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).--module Codec.Encryption.OpenPGP.SecretKey (- decryptPrivateKey- , encryptPrivateKey- , encryptPrivateKeyIO- , reencryptSecretKeyIO-) where+module Codec.Encryption.OpenPGP.SecretKey+ ( decryptPrivateKey+ , encryptPrivateKey+ , encryptPrivateKeyIO+ , reencryptSecretKeyIO+ ) where -import Codec.Encryption.OpenPGP.Internal.HOBlockCipher-import Codec.Encryption.OpenPGP.Types-import Codec.Encryption.OpenPGP.BlockCipher (withSymmetricCipher, keySize)+import Codec.Encryption.OpenPGP.BlockCipher (keySize, withSymmetricCipher) import Codec.Encryption.OpenPGP.CFB (decryptNoNonce, encryptNoNonce)-import Codec.Encryption.OpenPGP.Serialize (getSecretKey)+import Codec.Encryption.OpenPGP.Internal.HOBlockCipher import Codec.Encryption.OpenPGP.S2K (skesk2Key, string2Key)+import Codec.Encryption.OpenPGP.Serialize (getSecretKey)+import Codec.Encryption.OpenPGP.Types import qualified Crypto.Hash as CH import Crypto.Number.ModArithmetic (inverse)+import qualified Crypto.PubKey.RSA as R import Crypto.Random.EntropyPool (createEntropyPool, getEntropyFrom)-import qualified Data.ByteArray as BA-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL+import Data.Bifunctor (bimap) import Data.Binary (put) import Data.Binary.Get (getRemainingLazyByteString, getWord16be, runGetOrFail) import Data.Binary.Put (runPut)-import Data.Bifunctor (bimap)-import qualified Crypto.PubKey.RSA as R+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL saBlockSize :: SymmetricAlgorithm -> Int-saBlockSize sa = either (const 0) id (withSymmetricCipher sa B.empty (Right . blockSize))+saBlockSize sa =+ either (const 0) id (withSymmetricCipher sa B.empty (Right . blockSize)) decryptPrivateKey :: (PKPayload, SKAddendum) -> BL.ByteString -> SKAddendum-decryptPrivateKey (pkp, ska@SUS16bit{}) pp = either (error "could not decrypt SUS16bit") id (decryptSKA (pkp, ska) pp)-decryptPrivateKey (pkp, ska@SUSSHA1{}) pp = either (error "could not decrypt SUSSHA1") id (decryptSKA (pkp, ska) pp)-decryptPrivateKey (_, SUSym{}) _ = error "SUSym key decryption not implemented"-decryptPrivateKey (_, ska@SUUnencrypted{}) _ = ska+decryptPrivateKey (pkp, ska@SUS16bit {}) pp =+ either (error "could not decrypt SUS16bit") id (decryptSKA (pkp, ska) pp)+decryptPrivateKey (pkp, ska@SUSSHA1 {}) pp =+ either (error "could not decrypt SUSSHA1") id (decryptSKA (pkp, ska) pp)+decryptPrivateKey (_, SUSym {}) _ = error "SUSym key decryption not implemented"+decryptPrivateKey (_, ska@SUUnencrypted {}) _ = ska -decryptSKA :: (PKPayload, SKAddendum) -> BL.ByteString -> Either String SKAddendum+decryptSKA ::+ (PKPayload, SKAddendum) -> BL.ByteString -> Either String SKAddendum decryptSKA (pkp, SUS16bit sa s2k iv payload) pp = do- let key = skesk2Key (SKESK 4 sa s2k Nothing) pp- p <- decryptNoNonce sa iv (BL.toStrict payload) key- (s, cksum) <- getSecretKeyAndChecksum p -- FIXME: check the 16bit hash- let checksum = cksum- return $ SUUnencrypted s checksum -- FIXME: is this the correct checksum?- where- getSecretKeyAndChecksum p = bimap (\(_,_,x) -> x) (\(_,_,x) -> x) (runGetOrFail (getSecretKey pkp >>= \sk -> getWord16be >>= \csum -> return (sk, csum)) (BL.fromStrict p)) -- FIXME: check the 16bit hash+ let key = skesk2Key (SKESK 4 sa s2k Nothing) pp+ p <- decryptNoNonce sa iv (BL.toStrict payload) key+ (s, cksum) <- getSecretKeyAndChecksum p -- FIXME: check the 16bit hash+ let checksum = cksum+ return $ SUUnencrypted s checksum -- FIXME: is this the correct checksum?+ where+ getSecretKeyAndChecksum p =+ bimap+ (\(_, _, x) -> x)+ (\(_, _, x) -> x)+ (runGetOrFail+ (getSecretKey pkp >>= \sk ->+ getWord16be >>= \csum -> return (sk, csum))+ (BL.fromStrict p)) -- FIXME: check the 16bit hash decryptSKA (pkp, SUSSHA1 sa s2k iv payload) pp = do- let key = skesk2Key (SKESK 4 sa s2k Nothing) pp- p <- decryptNoNonce sa iv (BL.toStrict payload) key- (s, cksum) <- getSecretKeyAndChecksum p -- FIXME: check the SHA1 hash- let checksum = sum . map fromIntegral . B.unpack . B.take (B.length p - 20) $ p- return $ SUUnencrypted s checksum -- FIXME: is this the correct checksum?- where- getSecretKeyAndChecksum p = bimap (\(_,_,x) -> x) (\(_,_,x) -> x) (runGetOrFail (getSecretKey pkp >>= \sk -> getRemainingLazyByteString >>= \csum -> return (sk, csum)) (BL.fromStrict p))+ let key = skesk2Key (SKESK 4 sa s2k Nothing) pp+ p <- decryptNoNonce sa iv (BL.toStrict payload) key+ (s, cksum) <- getSecretKeyAndChecksum p -- FIXME: check the SHA1 hash+ let checksum =+ sum . map fromIntegral . B.unpack . B.take (B.length p - 20) $ p+ return $ SUUnencrypted s checksum -- FIXME: is this the correct checksum?+ where+ getSecretKeyAndChecksum p =+ bimap+ (\(_, _, x) -> x)+ (\(_, _, x) -> x)+ (runGetOrFail+ (getSecretKey pkp >>= \sk ->+ getRemainingLazyByteString >>= \csum -> return (sk, csum))+ (BL.fromStrict p)) decryptSKA _ _ = Left "Unexpected codepath" -- |generates pseudo-random salt and IV encryptPrivateKeyIO :: SKAddendum -> BL.ByteString -> IO SKAddendum-encryptPrivateKeyIO ska pp = saltiv >>= \(s,i) -> return (encryptPrivateKey s (IV i) ska pp)- where- saltiv = do- ep <- createEntropyPool- bb <- getEntropyFrom ep (8 + saBlockSize AES256)- return $ B.splitAt 8 bb+encryptPrivateKeyIO ska pp =+ saltiv >>= \(s, i) -> return (encryptPrivateKey s (IV i) ska pp)+ where+ saltiv = do+ ep <- createEntropyPool+ bb <- getEntropyFrom ep (8 + saBlockSize AES256)+ return $ B.splitAt 8 bb -- |8-octet salt, IV must be length of cipher blocksize-encryptPrivateKey :: B.ByteString -> IV -> SKAddendum -> BL.ByteString -> SKAddendum-encryptPrivateKey _ _ ska@SUS16bit{} _ = ska-encryptPrivateKey _ _ ska@SUSSHA1{} _ = ska-encryptPrivateKey _ _ ska@SUSym{} _ = ska-encryptPrivateKey salt iv (SUUnencrypted skey _) pp = SUSSHA1 AES256 s2k iv (BL.fromStrict (encryptSKey skey s2k iv pp))- where- s2k = IteratedSalted SHA512 (Salt salt) 12058624+encryptPrivateKey ::+ B.ByteString -> IV -> SKAddendum -> BL.ByteString -> SKAddendum+encryptPrivateKey _ _ ska@SUS16bit {} _ = ska+encryptPrivateKey _ _ ska@SUSSHA1 {} _ = ska+encryptPrivateKey _ _ ska@SUSym {} _ = ska+encryptPrivateKey salt iv (SUUnencrypted skey _) pp =+ SUSSHA1 AES256 s2k iv (BL.fromStrict (encryptSKey skey s2k iv pp))+ where+ s2k = IteratedSalted SHA512 (Salt salt) 12058624 encryptSKey :: SKey -> S2K -> IV -> BL.ByteString -> B.ByteString-encryptSKey (RSAPrivateKey (RSA_PrivateKey (R.PrivateKey _ d p q _ _ _))) s2k iv pp = either error id (encryptNoNonce AES256 s2k iv (BL.toStrict payload) key)- where- key = string2Key s2k (keySize AES256) pp- algospecific = runPut $ put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u)- cksum = CH.hashlazy algospecific :: CH.Digest CH.SHA1- payload = algospecific `BL.append` BL.fromStrict (BA.convert cksum)- Just u = inverse p q+encryptSKey (RSAPrivateKey (RSA_PrivateKey (R.PrivateKey _ d p q _ _ _))) s2k iv pp =+ either error id (encryptNoNonce AES256 s2k iv (BL.toStrict payload) key)+ where+ key = string2Key s2k (keySize AES256) pp+ algospecific =+ runPut $ put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u)+ cksum = CH.hashlazy algospecific :: CH.Digest CH.SHA1+ payload = algospecific `BL.append` BL.fromStrict (BA.convert cksum)+ Just u = inverse p q encryptSKey _ _ _ _ = error "Non-RSA keytypes not handled yet" -- FIXME: do DSA and ElGamal reencryptSecretKeyIO :: SecretKey -> BL.ByteString -> IO SecretKey-reencryptSecretKeyIO sk pp = encryptPrivateKeyIO (_secretKeySKAddendum sk) pp >>= \n -> return sk { _secretKeySKAddendum = n }+reencryptSecretKeyIO sk pp =+ encryptPrivateKeyIO (_secretKeySKAddendum sk) pp >>= \n ->+ return sk {_secretKeySKAddendum = n}
Codec/Encryption/OpenPGP/Serialize.hs view
@@ -2,1303 +2,1491 @@ -- Copyright © 2012-2018 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).--module Codec.Encryption.OpenPGP.Serialize (- -- * Serialization functions- putSKAddendum- , getSecretKey- -- * Utilities- , parsePkts-) where--import Control.Applicative (many, some)-import Control.Lens ((^.), _1)-import Control.Monad (guard, replicateM, replicateM_)-import Crypto.Number.Basic (numBits)-import Crypto.Number.Serialize (i2osp, os2ip)-import qualified Crypto.PubKey.RSA as R-import qualified Crypto.PubKey.DSA as D-import qualified Crypto.PubKey.ECC.Types as ECCT-import qualified Crypto.PubKey.ECC.ECDSA as ECDSA-import Data.Bifunctor (bimap)-import Data.Bits ((.&.), (.|.), shiftL, shiftR, testBit)-import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import Data.List (mapAccumL)-import qualified Data.List.NonEmpty as NE-import Data.Binary (Binary, get, put)-import Data.Binary.Get (Get, getByteString, getLazyByteString, getRemainingLazyByteString, getWord8, getWord16be, getWord32be, getWord16le, runGetOrFail, ByteOffset)-import Data.Binary.Put (Put, putWord8, putWord16be, putWord32be, putByteString, putLazyByteString, putWord16le, runPut)-import qualified Data.Foldable as F-import Data.Set (Set)-import qualified Data.Set as Set-import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8With, encodeUtf8)-import Data.Text.Encoding.Error (lenientDecode)-import Data.Word (Word8, Word16, Word32)-import Data.Maybe (fromMaybe)-import Network.URI (nullURI, parseURI, uriToString)--import Codec.Encryption.OpenPGP.Internal (curveoidBSToCurve, curveoidBSToEdSigningCurve, curveToCurveoidBS, edSigningCurveToCurveoidBS, pubkeyToMPIs, multiplicativeInverse, curve2Curve, curveFromCurve)-import Codec.Encryption.OpenPGP.Types--instance Binary SigSubPacket where- get = getSigSubPacket- put = putSigSubPacket---- instance Binary (Set NotationFlag) where--- put = putNotationFlagSet--instance Binary CompressionAlgorithm where- get = toFVal <$> getWord8- put = putWord8 . fromFVal--instance Binary PubKeyAlgorithm where- get = toFVal <$> getWord8- put = putWord8 . fromFVal--instance Binary HashAlgorithm where- get = toFVal <$> getWord8- put = putWord8 . fromFVal--instance Binary SymmetricAlgorithm where- get = toFVal <$> getWord8- put = putWord8 . fromFVal--instance Binary MPI where- get = getMPI- put = putMPI--instance Binary SigType where- get = toFVal <$> getWord8- put = putWord8 . fromFVal--instance Binary UserAttrSubPacket where- get = getUserAttrSubPacket- put = putUserAttrSubPacket--instance Binary S2K where- get = getS2K- put = putS2K--instance Binary PKESK where- get = fmap fromPkt getPkt- put = putPkt . toPkt--instance Binary Signature where- get = fmap fromPkt getPkt- put = putPkt . toPkt--instance Binary SKESK where- get = fmap fromPkt getPkt- put = putPkt . toPkt--instance Binary OnePassSignature where- get = fmap fromPkt getPkt- put = putPkt . toPkt--instance Binary SecretKey where- get = fmap fromPkt getPkt- put = putPkt . toPkt--instance Binary PublicKey where- get = fmap fromPkt getPkt- put = putPkt . toPkt--instance Binary SecretSubkey where- get = fmap fromPkt getPkt- put = putPkt . toPkt--instance Binary CompressedData where- get = fmap fromPkt getPkt- put = putPkt . toPkt--instance Binary SymEncData where- get = fmap fromPkt getPkt- put = putPkt . toPkt--instance Binary Marker where- get = fmap fromPkt getPkt- put = putPkt . toPkt--instance Binary LiteralData where- get = fmap fromPkt getPkt- put = putPkt . toPkt--instance Binary Trust where- get = fmap fromPkt getPkt- put = putPkt . toPkt--instance Binary UserId where- get = fmap fromPkt getPkt- put = putPkt . toPkt--instance Binary PublicSubkey where- get = fmap fromPkt getPkt- put = putPkt . toPkt--instance Binary UserAttribute where- get = fmap fromPkt getPkt- put = putPkt . toPkt--instance Binary SymEncIntegrityProtectedData where- get = fmap fromPkt getPkt- put = putPkt . toPkt--instance Binary ModificationDetectionCode where- get = fmap fromPkt getPkt- put = putPkt . toPkt--instance Binary OtherPacket where- get = fmap fromPkt getPkt- put = putPkt . toPkt--instance Binary Pkt where- get = getPkt- put = putPkt--instance Binary a => Binary (Block a) where- get = Block `fmap` many get- put = mapM_ put . unBlock--instance Binary PKPayload where- get = getPKPayload- put = putPKPayload--instance Binary SignaturePayload where- get = getSignaturePayload- put = putSignaturePayload--instance Binary TK where- get = undefined- put = putTK--getSigSubPacket :: Get SigSubPacket-getSigSubPacket = do- l <- fmap fromIntegral getSubPacketLength- (crit, pt) <- getSigSubPacketType- getSigSubPacket' pt crit l- where- getSigSubPacket' :: Word8 -> Bool -> ByteOffset -> Get SigSubPacket- getSigSubPacket' pt crit l- | pt == 2 = do- et <- fmap ThirtyTwoBitTimeStamp getWord32be- return $ SigSubPacket crit (SigCreationTime et)- | pt == 3 = do- et <- fmap ThirtyTwoBitDuration getWord32be- return $ SigSubPacket crit (SigExpirationTime et)- | pt == 4 = do- e <- get- return $ SigSubPacket crit (ExportableCertification e)- | pt == 5 = do- tl <- getWord8- ta <- getWord8- return $ SigSubPacket crit (TrustSignature tl ta)- | pt == 6 = do- apdre <- getLazyByteString (l - 2)- nul <- getWord8- guard (nul == 0)- return $ SigSubPacket crit (RegularExpression (BL.copy apdre))- | pt == 7 = do- r <- get- return $ SigSubPacket crit (Revocable r)- | pt == 9 = do- et <- fmap ThirtyTwoBitDuration getWord32be- return $ SigSubPacket crit (KeyExpirationTime et)- | pt == 11 = do- sa <- replicateM (fromIntegral (l - 1)) get- return $ SigSubPacket crit (PreferredSymmetricAlgorithms sa)- | pt == 12 = do- rclass <- getWord8- guard (testBit rclass 7)- algid <- get- fp <- getLazyByteString 20- return $ SigSubPacket crit (RevocationKey (bsToFFSet . BL.singleton $ rclass .&. 0x7f) algid (TwentyOctetFingerprint fp))- | pt == 16 = do- keyid <- getLazyByteString (l - 1)- return $ SigSubPacket crit (Issuer (EightOctetKeyId keyid))- | pt == 20 = do- flags <- getLazyByteString 4- nl <- getWord16be- vl <- getWord16be- nn <- getLazyByteString (fromIntegral nl)- nv <- getLazyByteString (fromIntegral vl)- return $ SigSubPacket crit (NotationData (bsToFFSet flags) (NotationName nn) (NotationValue nv))- | pt == 21 = do- ha <- replicateM (fromIntegral (l - 1)) get- return $ SigSubPacket crit (PreferredHashAlgorithms ha)- | pt == 22 = do- ca <- replicateM (fromIntegral (l - 1)) get- return $ SigSubPacket crit (PreferredCompressionAlgorithms ca)- | pt == 23 = do- ksps <- getLazyByteString (l - 1)- return $ SigSubPacket crit (KeyServerPreferences (bsToFFSet ksps))- | pt == 24 = do- pks <- getLazyByteString (l - 1)- return $ SigSubPacket crit (PreferredKeyServer pks)- | pt == 25 = do- primacy <- get- return $ SigSubPacket crit (PrimaryUserId primacy)- | pt == 26 = do- url <- fmap (URL . fromMaybe nullURI . parseURI . T.unpack . decodeUtf8With lenientDecode) (getByteString (fromIntegral (l - 1)))- return $ SigSubPacket crit (PolicyURL url)- | pt == 27 = do- kfs <- getLazyByteString (l - 1)- return $ SigSubPacket crit (KeyFlags (bsToFFSet kfs))- | pt == 28 = do- uid <- getByteString (fromIntegral (l - 1))- return $ SigSubPacket crit (SignersUserId (decodeUtf8With lenientDecode uid))- | pt == 29 = do- rcode <- getWord8- rreason <- fmap (decodeUtf8With lenientDecode) (getByteString (fromIntegral (l - 2)))- return $ SigSubPacket crit (ReasonForRevocation (toFVal rcode) rreason)- | pt == 30 = do- fbs <- getLazyByteString (l - 1)- return $ SigSubPacket crit (Features (bsToFFSet fbs))- | pt == 31 = do- pka <- get- ha <- get- hash <- getLazyByteString (l - 3)- return $ SigSubPacket crit (SignatureTarget pka ha hash)- | pt == 32 = do- sp <- get :: Get SignaturePayload- return $ SigSubPacket crit (EmbeddedSignature sp)- | pt == 33 = do- kv <- getWord8- fp <- getLazyByteString (if kv == 4 then 20 else 32)- return $ SigSubPacket crit (IssuerFingerprint kv (TwentyOctetFingerprint fp))- | pt > 99 && pt < 111 = do- payload <- getLazyByteString (l - 1)- return $ SigSubPacket crit (UserDefinedSigSub pt payload)- | otherwise = do- payload <- getLazyByteString (l - 1)- return $ SigSubPacket crit (OtherSigSub pt payload)--putSigSubPacket :: SigSubPacket -> Put-putSigSubPacket (SigSubPacket crit (SigCreationTime et)) = do- putSubPacketLength 5- putSigSubPacketType crit 2- putWord32be . unThirtyTwoBitTimeStamp $ et-putSigSubPacket (SigSubPacket crit (SigExpirationTime et)) = do- putSubPacketLength 5- putSigSubPacketType crit 3- putWord32be . unThirtyTwoBitDuration $ et-putSigSubPacket (SigSubPacket crit (ExportableCertification e)) = do- putSubPacketLength 2- putSigSubPacketType crit 4- put e-putSigSubPacket (SigSubPacket crit (TrustSignature tl ta)) = do- putSubPacketLength 3- putSigSubPacketType crit 5- put tl- put ta-putSigSubPacket (SigSubPacket crit (RegularExpression apdre)) = do- putSubPacketLength . fromIntegral $ (2 + BL.length apdre)- putSigSubPacketType crit 6- putLazyByteString apdre- putWord8 0-putSigSubPacket (SigSubPacket crit (Revocable r)) = do- putSubPacketLength 2- putSigSubPacketType crit 7- put r-putSigSubPacket (SigSubPacket crit (KeyExpirationTime et)) = do- putSubPacketLength 5- putSigSubPacketType crit 9- putWord32be . unThirtyTwoBitDuration $ et-putSigSubPacket (SigSubPacket crit (PreferredSymmetricAlgorithms ess)) = do- putSubPacketLength . fromIntegral $ (1 + length ess)- putSigSubPacketType crit 11- mapM_ put ess-putSigSubPacket (SigSubPacket crit (RevocationKey rclass algid fp)) = do- putSubPacketLength 23- putSigSubPacketType crit 12- putLazyByteString . ffSetToFixedLengthBS (1 :: Int) $ Set.insert (RClOther 0) rclass- put algid- putLazyByteString (unTOF fp) -- 20 octets-putSigSubPacket (SigSubPacket crit (Issuer keyid)) = do- putSubPacketLength 9- putSigSubPacketType crit 16- putLazyByteString (unEOKI keyid) -- 8 octets-putSigSubPacket (SigSubPacket crit (NotationData nfs (NotationName nn) (NotationValue nv))) = do- putSubPacketLength . fromIntegral $ (9 + BL.length nn + BL.length nv)- putSigSubPacketType crit 20- putLazyByteString . ffSetToFixedLengthBS (4 :: Int) $ nfs- putWord16be . fromIntegral . BL.length $ nn- putWord16be . fromIntegral . BL.length $ nv- putLazyByteString nn- putLazyByteString nv-putSigSubPacket (SigSubPacket crit (PreferredHashAlgorithms ehs)) = do- putSubPacketLength . fromIntegral $ (1 + length ehs)- putSigSubPacketType crit 21- mapM_ put ehs-putSigSubPacket (SigSubPacket crit (PreferredCompressionAlgorithms ecs)) = do- putSubPacketLength . fromIntegral $ (1 + length ecs)- putSigSubPacketType crit 22- mapM_ put ecs-putSigSubPacket (SigSubPacket crit (KeyServerPreferences ksps)) = do- let kbs = ffSetToBS ksps- putSubPacketLength . fromIntegral $ (1 + BL.length kbs)- putSigSubPacketType crit 23- putLazyByteString kbs-putSigSubPacket (SigSubPacket crit (PreferredKeyServer ks)) = do- putSubPacketLength . fromIntegral $ (1 + BL.length ks)- putSigSubPacketType crit 24- putLazyByteString ks-putSigSubPacket (SigSubPacket crit (PrimaryUserId primacy)) = do- putSubPacketLength 2- putSigSubPacketType crit 25- put primacy-putSigSubPacket (SigSubPacket crit (PolicyURL (URL uri))) = do- let bs = encodeUtf8 (T.pack (uriToString id uri ""))- putSubPacketLength . fromIntegral $ (1 + B.length bs)- putSigSubPacketType crit 26- putByteString bs-putSigSubPacket (SigSubPacket crit (KeyFlags kfs)) = do- let kbs = ffSetToBS kfs- putSubPacketLength . fromIntegral $ (1 + BL.length kbs)- putSigSubPacketType crit 27- putLazyByteString kbs-putSigSubPacket (SigSubPacket crit (SignersUserId userid)) = do- let bs = encodeUtf8 userid- putSubPacketLength . fromIntegral $ (1 + B.length bs)- putSigSubPacketType crit 28- putByteString bs-putSigSubPacket (SigSubPacket crit (ReasonForRevocation rcode rreason)) = do- let reasonbs = encodeUtf8 rreason- putSubPacketLength . fromIntegral $ (2 + B.length reasonbs)- putSigSubPacketType crit 29- putWord8 . fromFVal $ rcode- putByteString reasonbs-putSigSubPacket (SigSubPacket crit (Features fs)) = do- let fbs = ffSetToBS fs- putSubPacketLength . fromIntegral $ (1 + BL.length fbs)- putSigSubPacketType crit 30- putLazyByteString fbs-putSigSubPacket (SigSubPacket crit (SignatureTarget pka ha hash)) = do- putSubPacketLength . fromIntegral $ (3 + BL.length hash)- putSigSubPacketType crit 31- put pka- put ha- putLazyByteString hash-putSigSubPacket (SigSubPacket crit (EmbeddedSignature sp)) = do- let spb = runPut (put sp)- putSubPacketLength . fromIntegral $ (1 + BL.length spb)- putSigSubPacketType crit 32- putLazyByteString spb-putSigSubPacket (SigSubPacket crit (IssuerFingerprint kv fp)) = do- let fpb = unTOF fp- putSubPacketLength . fromIntegral $ (2 + BL.length fpb)- putSigSubPacketType crit 33- putWord8 kv- putLazyByteString fpb-putSigSubPacket (SigSubPacket crit (UserDefinedSigSub ptype payload)) = putSigSubPacket (SigSubPacket crit (OtherSigSub ptype payload))-putSigSubPacket (SigSubPacket crit (OtherSigSub ptype payload)) = do- putSubPacketLength . fromIntegral $ (1 + BL.length payload)- putSigSubPacketType crit ptype- putLazyByteString payload--getSubPacketLength :: Get Word32-getSubPacketLength = getSubPacketLength' =<< getWord8- where- getSubPacketLength' :: Integral a => Word8 -> Get a- getSubPacketLength' f- | f < 192 = return . fromIntegral $ f- | f < 224 = do- secondOctet <- getWord8- return . fromIntegral $ shiftL (fromIntegral (f - 192) :: Int) 8 + (fromIntegral secondOctet :: Int) + 192- | f == 255 = do- len <- getWord32be- return . fromIntegral $ len- | otherwise = fail "Partial body length invalid."--putSubPacketLength :: Word32 -> Put-putSubPacketLength l- | l < 192 = putWord8 (fromIntegral l)- | l < 8384 = putWord8 (fromIntegral ((fromIntegral (l - 192) `shiftR` 8) + 192 :: Int)) >> putWord8 (fromIntegral (l - 192) .&. 0xff)- | l <= 0xffffffff = putWord8 255 >> putWord32be (fromIntegral l)- | otherwise = fail ("too big (" ++ show l ++ ")")--getSigSubPacketType :: Get (Bool, Word8)-getSigSubPacketType = do- x <- getWord8- return (if x .&. 128 == 128 then (True, x .&. 127) else (False, x))--putSigSubPacketType :: Bool -> Word8 -> Put-putSigSubPacketType False sst = putWord8 sst-putSigSubPacketType True sst = putWord8 (sst .|. 0x80)--bsToFFSet :: FutureFlag a => ByteString -> Set a-bsToFFSet bs = Set.fromAscList . concat . snd $ mapAccumL (\acc y -> (acc+8, concatMap (shifty acc y) [0..7])) 0 (BL.unpack bs)- where- shifty acc y x = [toFFlag (acc + x) | y .&. shiftR 128 x == shiftR 128 x]--ffSetToFixedLengthBS :: (Integral a, FutureFlag b) => a -> Set b -> ByteString-ffSetToFixedLengthBS len ffs = BL.take (fromIntegral len) (BL.append (ffSetToBS ffs) (BL.pack (replicate 5 0)))--ffSetToBS :: FutureFlag a => Set a -> ByteString-ffSetToBS = BL.pack . ffSetToBS'- where- ffSetToBS' :: FutureFlag a => Set a -> [Word8]- ffSetToBS' ks- | Set.null ks = [] -- FIXME: should this be [0]?- | otherwise = map ((foldl (.|.) 0 . map (shiftR 128 . flip mod 8 . fromFFlag) . Set.toAscList) . (\ x -> Set.filter (\ y -> fromFFlag y `div` 8 == x) ks)) [0 .. fromFFlag (Set.findMax ks) `div` 8]--fromS2K :: S2K -> ByteString-fromS2K (Simple hashalgo) = BL.pack [0, fromIntegral . fromFVal $ hashalgo]-fromS2K (Salted hashalgo salt)- | B.length (unSalt salt) == 8 = BL.pack [1, fromIntegral . fromFVal $ hashalgo] `BL.append` (BL.fromStrict . unSalt) salt- | otherwise = error "Confusing salt size"-fromS2K (IteratedSalted hashalgo salt count)- | B.length (unSalt salt) == 8 = BL.pack [3, fromIntegral . fromFVal $ hashalgo] `BL.append` (BL.fromStrict . unSalt) salt `BL.snoc` encodeIterationCount count- | otherwise = error "Confusing salt size"-fromS2K (OtherS2K _ bs) = bs---getPacketLength :: Get Integer-getPacketLength = do- firstOctet <- getWord8- getPacketLength' firstOctet- where- getPacketLength' :: Integral a => Word8 -> Get a- getPacketLength' f- | f < 192 = return . fromIntegral $ f- | f < 224 = do- secondOctet <- getWord8- return . fromIntegral $ shiftL (fromIntegral (f - 192) :: Int) 8 + (fromIntegral secondOctet :: Int) + 192- | f == 255 = do- len <- getWord32be- return . fromIntegral $ len- | otherwise = fail "Partial body length support missing." --FIXME--putPacketLength :: Integer -> Put-putPacketLength l- | l < 192 = putWord8 (fromIntegral l)- | l < 8384 = putWord8 (fromIntegral ((fromIntegral (l - 192) `shiftR` 8) + 192 :: Int)) >> putWord8 (fromIntegral (l - 192) .&. 0xff)- | l < 0x100000000 = putWord8 255 >> putWord32be (fromIntegral l)- | otherwise = fail "partial body length support needed" -- FIXME--getS2K :: Get S2K-getS2K = getS2K' =<< getWord8- where- getS2K' :: Word8 -> Get S2K- getS2K' t- | t == 0 = do- ha <- getWord8- return $ Simple (toFVal ha)- | t == 1 = do- ha <- getWord8- salt <- getByteString 8- return $ Salted (toFVal ha) (Salt salt)- | t == 3 = do- ha <- getWord8- salt <- getByteString 8- count <- getWord8- return $ IteratedSalted (toFVal ha) (Salt salt) (decodeIterationCount count)- | otherwise = do- bs <- getRemainingLazyByteString- return $ OtherS2K t bs--putS2K :: S2K -> Put-putS2K (Simple hashalgo) = error ("confused by simple" ++ show hashalgo)-putS2K (Salted hashalgo salt) = error ("confused by salted" ++ show hashalgo ++ " by " ++ show salt)-putS2K (IteratedSalted ha salt count) = do- putWord8 3- put ha- putByteString (unSalt salt)- putWord8 $ encodeIterationCount count-putS2K (OtherS2K t bs) = putWord8 t >> putLazyByteString bs--getPacketTypeAndPayload :: Get (Word8, ByteString)-getPacketTypeAndPayload = do- tag <- getWord8- guard (testBit tag 7)- case tag .&. 0x40 of- 0x00 -> do- let t = shiftR (tag .&. 0x3c) 2- case tag .&. 0x03 of- 0 -> do len <- getWord8- bs <- getLazyByteString (fromIntegral len)- return (t, bs)- 1 -> do len <- getWord16be- bs <- getLazyByteString (fromIntegral len)- return (t, bs)- 2 -> do len <- getWord32be- bs <- getLazyByteString (fromIntegral len)- return (t, bs)- 3 -> do bs <- getRemainingLazyByteString- return (t, bs)- _ -> error "This should never happen (getPacketTypeAndPayload/0x00)."- 0x40 -> do- len <- fmap fromIntegral getPacketLength- bs <- getLazyByteString len- return (tag .&. 0x3f, bs)- _ -> error "This should never happen (getPacketTypeAndPayload/???)."--getPkt :: Get Pkt-getPkt = do- (t, pl) <- getPacketTypeAndPayload- case runGetOrFail (getPkt' t (BL.length pl)) pl of- Left (_, _, e) -> return $! BrokenPacketPkt e t pl- Right (_, _, p) -> return p- where- getPkt' :: Word8 -> ByteOffset -> Get Pkt- getPkt' t len- | t == 1 = do- pv <- getWord8- eokeyid <- getLazyByteString 8- pka <- getWord8- mpib <- getRemainingLazyByteString- case runGetOrFail (some getMPI) mpib of- Left (_, _, e) -> fail ("PKESK MPIs " ++ e)- Right (_, _, sk) -> return $ PKESKPkt pv (EightOctetKeyId eokeyid) (toFVal pka) (NE.fromList sk)- | t == 2 = do- bs <- getRemainingLazyByteString- case runGetOrFail get bs of- Left (_, _, e) -> fail ("signature packet " ++ e)- Right (_, _, sp) -> return $ SignaturePkt sp- | t == 3 = do- pv <- getWord8- symalgo <- getWord8- s2k <- getS2K- esk <- getRemainingLazyByteString- return $ SKESKPkt pv (toFVal symalgo) s2k (if BL.null esk then Nothing else Just esk)- | t == 4 = do- pv <- getWord8- sigtype <- getWord8- ha <- getWord8- pka <- getWord8- skeyid <- getLazyByteString 8- nested <- getWord8- return $ OnePassSignaturePkt pv (toFVal sigtype) (toFVal ha) (toFVal pka) (EightOctetKeyId skeyid) (nested == 0)- | t == 5 = do- bs <- getLazyByteString len- let ps = flip runGetOrFail bs $ do pkp <- getPKPayload- ska <- getSKAddendum pkp- return $ SecretKeyPkt pkp ska- case ps of- Left (_, _, err) -> fail ("secret key " ++ err)- Right (_, _, key) -> return key- | t == 6 = do- pkp <- getPKPayload- return $ PublicKeyPkt pkp- | t == 7 = do- bs <- getLazyByteString len- let ps = flip runGetOrFail bs $ do pkp <- getPKPayload- ska <- getSKAddendum pkp- return $ SecretSubkeyPkt pkp ska- case ps of- Left (_, _, err) -> fail ("secret subkey " ++ err)- Right (_, _, key) -> return key- | t == 8 = do- ca <- getWord8- cdata <- getLazyByteString (len - 1)- return $ CompressedDataPkt (toFVal ca) cdata- | t == 9 = do- sdata <- getLazyByteString len- return $ SymEncDataPkt sdata- | t == 10 = do- marker <- getLazyByteString len- return $ MarkerPkt marker- | t == 11 = do- dt <- getWord8- flen <- getWord8- fn <- getLazyByteString (fromIntegral flen)- ts <- fmap ThirtyTwoBitTimeStamp getWord32be- ldata <- getLazyByteString (len - (6 + fromIntegral flen))- return $ LiteralDataPkt (toFVal dt) fn ts ldata- | t == 12 = do- tdata <- getLazyByteString len- return $ TrustPkt tdata- | t == 13 = do- udata <- getByteString (fromIntegral len)- return . UserIdPkt . decodeUtf8With lenientDecode $ udata- | t == 14 = do- bs <- getLazyByteString len- let ps = flip runGetOrFail bs $ do pkp <- getPKPayload- return $ PublicSubkeyPkt pkp- case ps of- Left (_, _, err) -> fail ("public subkey " ++ err)- Right (_, _, key) -> return key- | t == 17 = do- bs <- getLazyByteString len- case runGetOrFail (many getUserAttrSubPacket) bs of- Left (_, _, err) -> fail ("user attribute " ++ err)- Right (_, _, uas) -> return $ UserAttributePkt uas- | t == 18 = do- pv <- getWord8 -- should be 1- b <- getLazyByteString (len - 1)- return $ SymEncIntegrityProtectedDataPkt pv b- | t == 19 = do- hash <- getLazyByteString 20- return $ ModificationDetectionCodePkt hash- | otherwise = do- payload <- getLazyByteString len- return $ OtherPacketPkt t payload--getUserAttrSubPacket :: Get UserAttrSubPacket-getUserAttrSubPacket = do- l <- fmap fromIntegral getSubPacketLength- t <- getWord8- getUserAttrSubPacket' t l- where- getUserAttrSubPacket' :: Word8 -> ByteOffset -> Get UserAttrSubPacket- getUserAttrSubPacket' t l- | t == 1 = do- _ <- getWord16le -- ihlen- hver <- getWord8 -- should be 1- iformat <- getWord8- nuls <- getLazyByteString 12 -- should be NULs- bs <- getLazyByteString (l - 17)- if hver /= 1 || nuls /= BL.pack (replicate 12 0) then fail "Corrupt UAt subpacket" else return $ ImageAttribute (ImageHV1 (toFVal iformat)) bs- | otherwise = do- bs <- getLazyByteString (l - 1)- return $ OtherUASub t bs--putUserAttrSubPacket :: UserAttrSubPacket -> Put-putUserAttrSubPacket ua = do- let sp = runPut $ putUserAttrSubPacket' ua- putSubPacketLength . fromIntegral . BL.length $ sp- putLazyByteString sp- where- putUserAttrSubPacket' (ImageAttribute (ImageHV1 iformat) idata) = do- putWord8 1- putWord16le 16- putWord8 1- putWord8 (fromFVal iformat)- replicateM_ 12 $ putWord8 0- putLazyByteString idata- putUserAttrSubPacket' (OtherUASub t bs) = do- putWord8 t- putLazyByteString bs--putPkt :: Pkt -> Put-putPkt (PKESKPkt pv eokeyid pka mpis) = do- putWord8 (0xc0 .|. 1)- let bsk = runPut $ F.mapM_ put mpis- putPacketLength . fromIntegral $ 10 + BL.length bsk- putWord8 pv -- must be 3- putLazyByteString (unEOKI eokeyid) -- must be 8 octets- putWord8 $ fromIntegral . fromFVal $ pka- putLazyByteString bsk-putPkt (SignaturePkt sp) = do- putWord8 (0xc0 .|. 2)- let bs = runPut $ put sp- putLengthThenPayload bs-putPkt (SKESKPkt pv symalgo s2k mesk) = do- putWord8 (0xc0 .|. 3)- let bs2k = fromS2K s2k- let bsk = fromMaybe BL.empty mesk- putPacketLength . fromIntegral $ 2 + BL.length bs2k + BL.length bsk- putWord8 pv -- should be 4- putWord8 $ fromIntegral . fromFVal $ symalgo- putLazyByteString bs2k- putLazyByteString bsk-putPkt (OnePassSignaturePkt pv sigtype ha pka skeyid nested) = do- putWord8 (0xc0 .|. 4)- let bs = runPut $ do- putWord8 pv -- should be 3- putWord8 $ fromIntegral . fromFVal $ sigtype- putWord8 $ fromIntegral . fromFVal $ ha- putWord8 $ fromIntegral . fromFVal $ pka- putLazyByteString (unEOKI skeyid)- putWord8 . fromIntegral . fromEnum $ not nested -- FIXME: what do other values mean?- putLengthThenPayload bs-putPkt (SecretKeyPkt pkp ska) = do- putWord8 (0xc0 .|. 5)- let bs = runPut (putPKPayload pkp >> putSKAddendum ska)- putLengthThenPayload bs-putPkt (PublicKeyPkt pkp) = do- putWord8 (0xc0 .|. 6)- let bs = runPut $ putPKPayload pkp- putLengthThenPayload bs-putPkt (SecretSubkeyPkt pkp ska) = do- putWord8 (0xc0 .|. 7)- let bs = runPut (putPKPayload pkp >> putSKAddendum ska)- putLengthThenPayload bs-putPkt (CompressedDataPkt ca cdata) = do- putWord8 (0xc0 .|. 8)- let bs = runPut $ do- putWord8 $ fromIntegral . fromFVal $ ca- putLazyByteString cdata- putLengthThenPayload bs-putPkt (SymEncDataPkt b) = do- putWord8 (0xc0 .|. 9)- putLengthThenPayload b-putPkt (MarkerPkt b) = do- putWord8 (0xc0 .|. 10)- putLengthThenPayload b-putPkt (LiteralDataPkt dt fn ts b) = do- putWord8 (0xc0 .|. 11)- let bs = runPut $ do- putWord8 $ fromIntegral . fromFVal $ dt- putWord8 $ fromIntegral . BL.length $ fn- putLazyByteString fn- putWord32be . unThirtyTwoBitTimeStamp $ ts- putLazyByteString b- putLengthThenPayload bs-putPkt (TrustPkt b) = do- putWord8 (0xc0 .|. 12)- putLengthThenPayload b-putPkt (UserIdPkt u) = do- putWord8 (0xc0 .|. 13)- let bs = encodeUtf8 u- putPacketLength . fromIntegral $ B.length bs- putByteString bs-putPkt (PublicSubkeyPkt pkp) = do- putWord8 (0xc0 .|. 14)- let bs = runPut $ putPKPayload pkp- putLengthThenPayload bs-putPkt (UserAttributePkt us) = do- putWord8 (0xc0 .|. 17)- let bs = runPut $ mapM_ put us- putLengthThenPayload bs-putPkt (SymEncIntegrityProtectedDataPkt pv b) = do- putWord8 (0xc0 .|. 18)- putPacketLength . fromIntegral $ BL.length b + 1- putWord8 pv -- should be 1- putLazyByteString b-putPkt (ModificationDetectionCodePkt hash) = do- putWord8 (0xc0 .|. 19)- putLengthThenPayload hash-putPkt (OtherPacketPkt t payload) = do- putWord8 (0xc0 .|. t) -- FIXME: restrict t- putLengthThenPayload payload-putPkt (BrokenPacketPkt _ t payload) = putPkt (OtherPacketPkt t payload)--putLengthThenPayload :: ByteString -> Put-putLengthThenPayload bs = do- putPacketLength . fromIntegral $ BL.length bs- putLazyByteString bs--getMPI :: Get MPI-getMPI = do mpilen <- getWord16be- bs <- getByteString (fromIntegral (mpilen + 7) `div` 8)- return $ MPI (os2ip bs)--getPubkey :: PubKeyAlgorithm -> Get PKey-getPubkey RSA = do MPI n <- get- MPI e <- get- return $ RSAPubKey (RSA_PublicKey (R.PublicKey (fromIntegral . B.length . i2osp $ n) n e))-getPubkey DeprecatedRSAEncryptOnly = getPubkey RSA-getPubkey DeprecatedRSASignOnly = getPubkey RSA-getPubkey DSA = do MPI p <- get- MPI q <- get- MPI g <- get- MPI y <- get- return $ DSAPubKey (DSA_PublicKey (D.PublicKey (D.Params p g q) y))-getPubkey ElgamalEncryptOnly = getPubkey ForbiddenElgamal-getPubkey ForbiddenElgamal = do MPI p <- get- MPI g <- get- MPI y <- get- return $ ElGamalPubKey p g y-getPubkey ECDSA = do- curvelength <- getWord8 -- FIXME: test for 0 or 0xFF as they are reserved- curveoid <- getByteString (fromIntegral curvelength)- MPI mpi <- getMPI -- FIXME: check length against curve type?- case curveoidBSToCurve curveoid of- Left e -> fail e- Right Curve25519 -> return $ EdDSAPubKey Ed25519 (EPoint mpi)- Right curve -> case bs2Point (i2osp mpi) of- Left e -> fail e- Right point -> return . ECDSAPubKey . ECDSA_PublicKey . ECDSA.PublicKey (curve2Curve curve) $ point-getPubkey ECDH = do- ed <- getPubkey ECDSA -- could be an ECDSA or an EdDSA- kdflen <- getWord8 -- FIXME: should be 3, test for 0 or 0xFF as they are reserved- one <- getWord8 -- FIXME: should be 1- kdfHA <- get- kdfSA <- get- return $ ECDHPubKey ed kdfHA kdfSA-getPubkey EdDSA = do- curvelength <- getWord8 -- FIXME: test for 0 or 0xFF as they are reserved- curveoid <- getByteString (fromIntegral curvelength)- MPI mpi <- getMPI -- FIXME: check length against curve type?- case curveoidBSToEdSigningCurve curveoid of- Left e -> fail e- Right Ed25519 -> return . EdDSAPubKey Ed25519 $ EPoint mpi--getPubkey _ = UnknownPKey <$> getRemainingLazyByteString--bs2Point :: B.ByteString -> Either String ECDSA.PublicPoint-bs2Point bs = let xy = B.drop 1 bs in- let l = B.length xy in- if B.head bs == 0x04- then return (uncurry ECCT.Point (bimap os2ip os2ip (B.splitAt (div l 2) xy)))- else fail $ "unknown type of point: " ++ show (B.unpack bs)--putPubkey :: PKey -> Put-putPubkey (UnknownPKey bs) = putLazyByteString bs-putPubkey p@(ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) = let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve) in putWord8 (fromIntegral (B.length curveoidbs)) >> putByteString curveoidbs >> mapM_ put (pubkeyToMPIs p) -- FIXME: do not output length 0 or 0xff-putPubkey p@(ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) kha ksa) = let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve) in putWord8 (fromIntegral (B.length curveoidbs)) >> putByteString curveoidbs >> mapM_ put (pubkeyToMPIs p) >> putWord8 0x03 >> putWord8 0x01 >> put kha >> put ksa -- FIXME: do not output length 0 or 0xff-putPubkey p@(ECDHPubKey (EdDSAPubKey curve _) kha ksa) = let Right curveoidbs = curveToCurveoidBS (ed2ec curve) in putWord8 (fromIntegral (B.length curveoidbs)) >> putByteString curveoidbs >> mapM_ put (pubkeyToMPIs p) >> putWord8 0x03 >> putWord8 0x01 >> put kha >> put ksa -- FIXME: do not output length 0 or 0xff- where- ed2ec Ed25519 = Curve25519-putPubkey p@(EdDSAPubKey curve _) = let Right curveoidbs = edSigningCurveToCurveoidBS curve in putWord8 (fromIntegral (B.length curveoidbs)) >> putByteString curveoidbs >> mapM_ put (pubkeyToMPIs p) -- FIXME: do not output length 0 or 0xff-putPubkey p = mapM_ put (pubkeyToMPIs p)--getSecretKey :: PKPayload -> Get SKey-getSecretKey pkp- | _pkalgo pkp `elem` [RSA, DeprecatedRSAEncryptOnly, DeprecatedRSASignOnly] =- do MPI d <- get- MPI p <- get- MPI q <- get- MPI _ <- get -- u- let dP = 0- dQ = 0- qinv = 0- pub = (\(RSAPubKey (RSA_PublicKey x)) -> x) (pkp^.pubkey)- return $ RSAPrivateKey (RSA_PrivateKey (R.PrivateKey pub d p q dP dQ qinv))- | _pkalgo pkp == DSA = do MPI x <- get- return $ DSAPrivateKey (DSA_PrivateKey (D.PrivateKey (D.Params 0 0 0) x))- | _pkalgo pkp `elem` [ElgamalEncryptOnly,ForbiddenElgamal] =- do MPI x <- get- return $ ElGamalPrivateKey x- | _pkalgo pkp == ECDSA =- do MPI pn <- get- let pubcurve = (\(ECDSAPubKey (ECDSA_PublicKey p)) -> ECDSA.public_curve p) (pkp^.pubkey)- return $ ECDSAPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey pubcurve pn))- | _pkalgo pkp == ECDH = -- FIXME: deduplicate this and above- do MPI pn <- get- let pubcurve = (\(ECDSAPubKey (ECDSA_PublicKey p)) -> ECDSA.public_curve p) (pkp^.pubkey)- return $ ECDHPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey pubcurve pn))--putSKey :: SKey -> Put-putSKey (RSAPrivateKey (RSA_PrivateKey (R.PrivateKey _ d p q _ _ _))) = put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u)- where- u = multiplicativeInverse q p--putMPI :: MPI -> Put-putMPI (MPI i) = do let bs = i2osp i- putWord16be . fromIntegral . numBits $ i- putByteString bs--getPKPayload :: Get PKPayload-getPKPayload = do- version <- getWord8- ctime <- fmap ThirtyTwoBitTimeStamp getWord32be- if version `elem` [2,3] then- do v3e <- getWord16be- pka <- get- pk <- getPubkey pka- return $! PKPayload DeprecatedV3 ctime v3e pka pk- else- do pka <- get- pk <- getPubkey pka- return $! PKPayload V4 ctime 0 pka pk--putPKPayload :: PKPayload -> Put-putPKPayload (PKPayload DeprecatedV3 ctime v3e pka pk) = do- putWord8 3- putWord32be . unThirtyTwoBitTimeStamp $ ctime- putWord16be v3e- put pka- putPubkey pk-putPKPayload (PKPayload V4 ctime _ pka pk) = do- putWord8 4- putWord32be . unThirtyTwoBitTimeStamp $ ctime- put pka- putPubkey pk--getSKAddendum :: PKPayload -> Get SKAddendum-getSKAddendum pkp = do- s2kusage <- getWord8- case s2kusage of- 0 -> do sk <- getSecretKey pkp- checksum <- getWord16be -- FIXME: validate checksum?- return $ SUUnencrypted sk checksum- 255 -> do symenc <- getWord8- s2k <- getS2K- case s2k of -- FIXME: this is a mess- OtherS2K _ _ -> return $ SUS16bit (toFVal symenc) s2k mempty BL.empty- _ -> do- iv <- getByteString (symEncBlockSize . toFVal $ symenc)- encryptedblock <- getRemainingLazyByteString- return $ SUS16bit (toFVal symenc) s2k (IV iv) encryptedblock- 254 -> do symenc <- getWord8- s2k <- getS2K- case s2k of -- FIXME: this is a mess- OtherS2K _ _ -> return $ SUSSHA1 (toFVal symenc) s2k mempty BL.empty- _ -> do- iv <- getByteString (symEncBlockSize . toFVal $ symenc)- encryptedblock <- getRemainingLazyByteString- return $ SUSSHA1 (toFVal symenc) s2k (IV iv) encryptedblock- symenc -> do iv <- getByteString (symEncBlockSize . toFVal $ symenc)- encryptedblock <- getRemainingLazyByteString- return $ SUSym (toFVal symenc) (IV iv) encryptedblock--putSKAddendum :: SKAddendum -> Put-putSKAddendum (SUSSHA1 symenc s2k iv encryptedblock) = do- putWord8 254- put symenc- put s2k- putByteString (unIV iv)- putLazyByteString encryptedblock-putSKAddendum (SUUnencrypted sk checksum) = do- putWord8 0- let skb = runPut (putSKey sk)- putLazyByteString skb- putWord16be (if checksum == 0 then BL.foldl (\a b -> mod (a+fromIntegral b) 0xffff) (0 :: Word16) skb else checksum) -- FIXME: be saner-putSKAddendum _ = fail "Type not supported"--symEncBlockSize :: SymmetricAlgorithm -> Int-symEncBlockSize Plaintext = 0-symEncBlockSize IDEA = 8-symEncBlockSize TripleDES = 8-symEncBlockSize CAST5 = 8-symEncBlockSize Blowfish = 8-symEncBlockSize AES128 = 16-symEncBlockSize AES192 = 16-symEncBlockSize AES256 = 16-symEncBlockSize Twofish = 16-symEncBlockSize Camellia128 = 16-symEncBlockSize _ = 8 -- FIXME--decodeIterationCount :: Word8 -> IterationCount-decodeIterationCount c = IterationCount ((16 + (fromIntegral c .&. 15)) `shiftL` ((fromIntegral c `shiftR` 4) + 6))--encodeIterationCount :: IterationCount -> Word8 -- should this really be a lookup table?-encodeIterationCount 1024 = 0-encodeIterationCount 1088 = 1-encodeIterationCount 1152 = 2-encodeIterationCount 1216 = 3-encodeIterationCount 1280 = 4-encodeIterationCount 1344 = 5-encodeIterationCount 1408 = 6-encodeIterationCount 1472 = 7-encodeIterationCount 1536 = 8-encodeIterationCount 1600 = 9-encodeIterationCount 1664 = 10-encodeIterationCount 1728 = 11-encodeIterationCount 1792 = 12-encodeIterationCount 1856 = 13-encodeIterationCount 1920 = 14-encodeIterationCount 1984 = 15-encodeIterationCount 2048 = 16-encodeIterationCount 2176 = 17-encodeIterationCount 2304 = 18-encodeIterationCount 2432 = 19-encodeIterationCount 2560 = 20-encodeIterationCount 2688 = 21-encodeIterationCount 2816 = 22-encodeIterationCount 2944 = 23-encodeIterationCount 3072 = 24-encodeIterationCount 3200 = 25-encodeIterationCount 3328 = 26-encodeIterationCount 3456 = 27-encodeIterationCount 3584 = 28-encodeIterationCount 3712 = 29-encodeIterationCount 3840 = 30-encodeIterationCount 3968 = 31-encodeIterationCount 4096 = 32-encodeIterationCount 4352 = 33-encodeIterationCount 4608 = 34-encodeIterationCount 4864 = 35-encodeIterationCount 5120 = 36-encodeIterationCount 5376 = 37-encodeIterationCount 5632 = 38-encodeIterationCount 5888 = 39-encodeIterationCount 6144 = 40-encodeIterationCount 6400 = 41-encodeIterationCount 6656 = 42-encodeIterationCount 6912 = 43-encodeIterationCount 7168 = 44-encodeIterationCount 7424 = 45-encodeIterationCount 7680 = 46-encodeIterationCount 7936 = 47-encodeIterationCount 8192 = 48-encodeIterationCount 8704 = 49-encodeIterationCount 9216 = 50-encodeIterationCount 9728 = 51-encodeIterationCount 10240 = 52-encodeIterationCount 10752 = 53-encodeIterationCount 11264 = 54-encodeIterationCount 11776 = 55-encodeIterationCount 12288 = 56-encodeIterationCount 12800 = 57-encodeIterationCount 13312 = 58-encodeIterationCount 13824 = 59-encodeIterationCount 14336 = 60-encodeIterationCount 14848 = 61-encodeIterationCount 15360 = 62-encodeIterationCount 15872 = 63-encodeIterationCount 16384 = 64-encodeIterationCount 17408 = 65-encodeIterationCount 18432 = 66-encodeIterationCount 19456 = 67-encodeIterationCount 20480 = 68-encodeIterationCount 21504 = 69-encodeIterationCount 22528 = 70-encodeIterationCount 23552 = 71-encodeIterationCount 24576 = 72-encodeIterationCount 25600 = 73-encodeIterationCount 26624 = 74-encodeIterationCount 27648 = 75-encodeIterationCount 28672 = 76-encodeIterationCount 29696 = 77-encodeIterationCount 30720 = 78-encodeIterationCount 31744 = 79-encodeIterationCount 32768 = 80-encodeIterationCount 34816 = 81-encodeIterationCount 36864 = 82-encodeIterationCount 38912 = 83-encodeIterationCount 40960 = 84-encodeIterationCount 43008 = 85-encodeIterationCount 45056 = 86-encodeIterationCount 47104 = 87-encodeIterationCount 49152 = 88-encodeIterationCount 51200 = 89-encodeIterationCount 53248 = 90-encodeIterationCount 55296 = 91-encodeIterationCount 57344 = 92-encodeIterationCount 59392 = 93-encodeIterationCount 61440 = 94-encodeIterationCount 63488 = 95-encodeIterationCount 65536 = 96-encodeIterationCount 69632 = 97-encodeIterationCount 73728 = 98-encodeIterationCount 77824 = 99-encodeIterationCount 81920 = 100-encodeIterationCount 86016 = 101-encodeIterationCount 90112 = 102-encodeIterationCount 94208 = 103-encodeIterationCount 98304 = 104-encodeIterationCount 102400 = 105-encodeIterationCount 106496 = 106-encodeIterationCount 110592 = 107-encodeIterationCount 114688 = 108-encodeIterationCount 118784 = 109-encodeIterationCount 122880 = 110-encodeIterationCount 126976 = 111-encodeIterationCount 131072 = 112-encodeIterationCount 139264 = 113-encodeIterationCount 147456 = 114-encodeIterationCount 155648 = 115-encodeIterationCount 163840 = 116-encodeIterationCount 172032 = 117-encodeIterationCount 180224 = 118-encodeIterationCount 188416 = 119-encodeIterationCount 196608 = 120-encodeIterationCount 204800 = 121-encodeIterationCount 212992 = 122-encodeIterationCount 221184 = 123-encodeIterationCount 229376 = 124-encodeIterationCount 237568 = 125-encodeIterationCount 245760 = 126-encodeIterationCount 253952 = 127-encodeIterationCount 262144 = 128-encodeIterationCount 278528 = 129-encodeIterationCount 294912 = 130-encodeIterationCount 311296 = 131-encodeIterationCount 327680 = 132-encodeIterationCount 344064 = 133-encodeIterationCount 360448 = 134-encodeIterationCount 376832 = 135-encodeIterationCount 393216 = 136-encodeIterationCount 409600 = 137-encodeIterationCount 425984 = 138-encodeIterationCount 442368 = 139-encodeIterationCount 458752 = 140-encodeIterationCount 475136 = 141-encodeIterationCount 491520 = 142-encodeIterationCount 507904 = 143-encodeIterationCount 524288 = 144-encodeIterationCount 557056 = 145-encodeIterationCount 589824 = 146-encodeIterationCount 622592 = 147-encodeIterationCount 655360 = 148-encodeIterationCount 688128 = 149-encodeIterationCount 720896 = 150-encodeIterationCount 753664 = 151-encodeIterationCount 786432 = 152-encodeIterationCount 819200 = 153-encodeIterationCount 851968 = 154-encodeIterationCount 884736 = 155-encodeIterationCount 917504 = 156-encodeIterationCount 950272 = 157-encodeIterationCount 983040 = 158-encodeIterationCount 1015808 = 159-encodeIterationCount 1048576 = 160-encodeIterationCount 1114112 = 161-encodeIterationCount 1179648 = 162-encodeIterationCount 1245184 = 163-encodeIterationCount 1310720 = 164-encodeIterationCount 1376256 = 165-encodeIterationCount 1441792 = 166-encodeIterationCount 1507328 = 167-encodeIterationCount 1572864 = 168-encodeIterationCount 1638400 = 169-encodeIterationCount 1703936 = 170-encodeIterationCount 1769472 = 171-encodeIterationCount 1835008 = 172-encodeIterationCount 1900544 = 173-encodeIterationCount 1966080 = 174-encodeIterationCount 2031616 = 175-encodeIterationCount 2097152 = 176-encodeIterationCount 2228224 = 177-encodeIterationCount 2359296 = 178-encodeIterationCount 2490368 = 179-encodeIterationCount 2621440 = 180-encodeIterationCount 2752512 = 181-encodeIterationCount 2883584 = 182-encodeIterationCount 3014656 = 183-encodeIterationCount 3145728 = 184-encodeIterationCount 3276800 = 185-encodeIterationCount 3407872 = 186-encodeIterationCount 3538944 = 187-encodeIterationCount 3670016 = 188-encodeIterationCount 3801088 = 189-encodeIterationCount 3932160 = 190-encodeIterationCount 4063232 = 191-encodeIterationCount 4194304 = 192-encodeIterationCount 4456448 = 193-encodeIterationCount 4718592 = 194-encodeIterationCount 4980736 = 195-encodeIterationCount 5242880 = 196-encodeIterationCount 5505024 = 197-encodeIterationCount 5767168 = 198-encodeIterationCount 6029312 = 199-encodeIterationCount 6291456 = 200-encodeIterationCount 6553600 = 201-encodeIterationCount 6815744 = 202-encodeIterationCount 7077888 = 203-encodeIterationCount 7340032 = 204-encodeIterationCount 7602176 = 205-encodeIterationCount 7864320 = 206-encodeIterationCount 8126464 = 207-encodeIterationCount 8388608 = 208-encodeIterationCount 8912896 = 209-encodeIterationCount 9437184 = 210-encodeIterationCount 9961472 = 211-encodeIterationCount 10485760 = 212-encodeIterationCount 11010048 = 213-encodeIterationCount 11534336 = 214-encodeIterationCount 12058624 = 215-encodeIterationCount 12582912 = 216-encodeIterationCount 13107200 = 217-encodeIterationCount 13631488 = 218-encodeIterationCount 14155776 = 219-encodeIterationCount 14680064 = 220-encodeIterationCount 15204352 = 221-encodeIterationCount 15728640 = 222-encodeIterationCount 16252928 = 223-encodeIterationCount 16777216 = 224-encodeIterationCount 17825792 = 225-encodeIterationCount 18874368 = 226-encodeIterationCount 19922944 = 227-encodeIterationCount 20971520 = 228-encodeIterationCount 22020096 = 229-encodeIterationCount 23068672 = 230-encodeIterationCount 24117248 = 231-encodeIterationCount 25165824 = 232-encodeIterationCount 26214400 = 233-encodeIterationCount 27262976 = 234-encodeIterationCount 28311552 = 235-encodeIterationCount 29360128 = 236-encodeIterationCount 30408704 = 237-encodeIterationCount 31457280 = 238-encodeIterationCount 32505856 = 239-encodeIterationCount 33554432 = 240-encodeIterationCount 35651584 = 241-encodeIterationCount 37748736 = 242-encodeIterationCount 39845888 = 243-encodeIterationCount 41943040 = 244-encodeIterationCount 44040192 = 245-encodeIterationCount 46137344 = 246-encodeIterationCount 48234496 = 247-encodeIterationCount 50331648 = 248-encodeIterationCount 52428800 = 249-encodeIterationCount 54525952 = 250-encodeIterationCount 56623104 = 251-encodeIterationCount 58720256 = 252-encodeIterationCount 60817408 = 253-encodeIterationCount 62914560 = 254-encodeIterationCount 65011712 = 255-encodeIterationCount n = error ("invalid iteration count" ++ show n)--getSignaturePayload :: Get SignaturePayload-getSignaturePayload = do- pv <- getWord8- case pv of- 3 -> do- hashlen <- getWord8- guard (hashlen == 5)- st <- getWord8- ctime <- fmap ThirtyTwoBitTimeStamp getWord32be- eok <- getLazyByteString 8- pka <- get- ha <- get- left16 <- getWord16be- mpib <- getRemainingLazyByteString- case runGetOrFail (some getMPI) mpib of- Left (_, _, e) -> fail ("v3 sig MPIs " ++ e)- Right (_, _, mpis) -> return $ SigV3 (toFVal st) ctime (EightOctetKeyId eok) (toFVal pka) (toFVal ha) left16 (NE.fromList mpis)- 4 -> do- st <- getWord8- pka <- get- ha <- get- hlen <- getWord16be- hb <- getLazyByteString (fromIntegral hlen)- let hashed = case runGetOrFail (many getSigSubPacket) hb of- Left (_, _, err) -> fail ("v4 sig hasheds " ++ err)- Right (_, _, h) -> h- ulen <- getWord16be- ub <- getLazyByteString (fromIntegral ulen)- let unhashed = case runGetOrFail (many getSigSubPacket) ub of- Left (_, _, err) -> fail ("v4 sig unhasheds " ++ err)- Right (_, _, u) -> u- left16 <- getWord16be- mpib <- getRemainingLazyByteString- case runGetOrFail (some getMPI) mpib of- Left (_, _, e) -> fail ("v4 sig MPIs " ++ e)- Right (_, _, mpis) -> return $ SigV4 (toFVal st) (toFVal pka) (toFVal ha) hashed unhashed left16 (NE.fromList mpis)- _ -> do- bs <- getRemainingLazyByteString- return $ SigVOther pv bs--putSignaturePayload :: SignaturePayload -> Put-putSignaturePayload (SigV3 st ctime eok pka ha left16 mpis) = do- putWord8 3- putWord8 5 -- hashlen- put st- putWord32be . unThirtyTwoBitTimeStamp $ ctime- putLazyByteString (unEOKI eok)- put pka- put ha- putWord16be left16- F.mapM_ put mpis-putSignaturePayload (SigV4 st pka ha hashed unhashed left16 mpis) = do- putWord8 4- put st- put pka- put ha- let hb = runPut $ mapM_ put hashed- putWord16be . fromIntegral . BL.length $ hb- putLazyByteString hb- let ub = runPut $ mapM_ put unhashed- putWord16be . fromIntegral . BL.length $ ub- putLazyByteString ub- putWord16be left16- F.mapM_ put mpis-putSignaturePayload (SigVOther pv bs) = do- putWord8 pv- putLazyByteString bs--putTK :: TK -> Put-putTK key = do- let pkp = key^.tkKey._1- maybe (put (PublicKey pkp)) (\ska -> put (SecretKey pkp ska)) (snd (key^.tkKey))- mapM_ (put . Signature) (_tkRevs key)- mapM_ putUid' (_tkUIDs key)- mapM_ putUat' (_tkUAts key)- mapM_ putSub' (_tkSubs key)- where- putUid' (u, sps) = put (UserId u) >> mapM_ (put . Signature) sps- putUat' (us, sps) = put (UserAttribute us) >> mapM_ (put . Signature) sps- putSub' (p, sps) = put p >> mapM_ (put . Signature) sps---- | Parse the packets from a ByteString, with no error reporting-parsePkts :: ByteString -> [Pkt]-parsePkts lbs =- case runGetOrFail (some getPkt) lbs of- Left (_, _, e) -> []- Right (_, _, p) -> p+module Codec.Encryption.OpenPGP.Serialize+ -- * Serialization functions+ ( putSKAddendum+ , getSecretKey+ -- * Utilities+ , parsePkts+ ) where++import Control.Applicative (many, some)+import Control.Lens ((^.), _1)+import Control.Monad (guard, replicateM, replicateM_)+import Crypto.Number.Basic (numBits)+import Crypto.Number.Serialize (i2osp, os2ip)+import qualified Crypto.PubKey.DSA as D+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA+import qualified Crypto.PubKey.ECC.Types as ECCT+import qualified Crypto.PubKey.RSA as R+import Data.Bifunctor (bimap)+import Data.Binary (Binary, get, put)+import Data.Binary.Get+ ( ByteOffset+ , Get+ , getByteString+ , getLazyByteString+ , getRemainingLazyByteString+ , getWord16be+ , getWord16le+ , getWord32be+ , getWord8+ , runGetOrFail+ )+import Data.Binary.Put+ ( Put+ , putByteString+ , putLazyByteString+ , putWord16be+ , putWord16le+ , putWord32be+ , putWord8+ , runPut+ )+import Data.Bits ((.&.), (.|.), shiftL, shiftR, testBit)+import qualified Data.ByteString as B+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as BL+import qualified Data.Foldable as F+import Data.List (mapAccumL)+import qualified Data.List.NonEmpty as NE+import Data.Maybe (fromMaybe)+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8With, encodeUtf8)+import Data.Text.Encoding.Error (lenientDecode)+import Data.Word (Word16, Word32, Word8)+import Network.URI (nullURI, parseURI, uriToString)++import Codec.Encryption.OpenPGP.Internal+ ( curve2Curve+ , curveFromCurve+ , curveToCurveoidBS+ , curveoidBSToCurve+ , curveoidBSToEdSigningCurve+ , edSigningCurveToCurveoidBS+ , multiplicativeInverse+ , pubkeyToMPIs+ )+import Codec.Encryption.OpenPGP.Types++instance Binary SigSubPacket where+ get = getSigSubPacket+ put = putSigSubPacket++-- instance Binary (Set NotationFlag) where+-- put = putNotationFlagSet+instance Binary CompressionAlgorithm where+ get = toFVal <$> getWord8+ put = putWord8 . fromFVal++instance Binary PubKeyAlgorithm where+ get = toFVal <$> getWord8+ put = putWord8 . fromFVal++instance Binary HashAlgorithm where+ get = toFVal <$> getWord8+ put = putWord8 . fromFVal++instance Binary SymmetricAlgorithm where+ get = toFVal <$> getWord8+ put = putWord8 . fromFVal++instance Binary MPI where+ get = getMPI+ put = putMPI++instance Binary SigType where+ get = toFVal <$> getWord8+ put = putWord8 . fromFVal++instance Binary UserAttrSubPacket where+ get = getUserAttrSubPacket+ put = putUserAttrSubPacket++instance Binary S2K where+ get = getS2K+ put = putS2K++instance Binary PKESK where+ get = fmap fromPkt getPkt+ put = putPkt . toPkt++instance Binary Signature where+ get = fmap fromPkt getPkt+ put = putPkt . toPkt++instance Binary SKESK where+ get = fmap fromPkt getPkt+ put = putPkt . toPkt++instance Binary OnePassSignature where+ get = fmap fromPkt getPkt+ put = putPkt . toPkt++instance Binary SecretKey where+ get = fmap fromPkt getPkt+ put = putPkt . toPkt++instance Binary PublicKey where+ get = fmap fromPkt getPkt+ put = putPkt . toPkt++instance Binary SecretSubkey where+ get = fmap fromPkt getPkt+ put = putPkt . toPkt++instance Binary CompressedData where+ get = fmap fromPkt getPkt+ put = putPkt . toPkt++instance Binary SymEncData where+ get = fmap fromPkt getPkt+ put = putPkt . toPkt++instance Binary Marker where+ get = fmap fromPkt getPkt+ put = putPkt . toPkt++instance Binary LiteralData where+ get = fmap fromPkt getPkt+ put = putPkt . toPkt++instance Binary Trust where+ get = fmap fromPkt getPkt+ put = putPkt . toPkt++instance Binary UserId where+ get = fmap fromPkt getPkt+ put = putPkt . toPkt++instance Binary PublicSubkey where+ get = fmap fromPkt getPkt+ put = putPkt . toPkt++instance Binary UserAttribute where+ get = fmap fromPkt getPkt+ put = putPkt . toPkt++instance Binary SymEncIntegrityProtectedData where+ get = fmap fromPkt getPkt+ put = putPkt . toPkt++instance Binary ModificationDetectionCode where+ get = fmap fromPkt getPkt+ put = putPkt . toPkt++instance Binary OtherPacket where+ get = fmap fromPkt getPkt+ put = putPkt . toPkt++instance Binary Pkt where+ get = getPkt+ put = putPkt++instance Binary a => Binary (Block a) where+ get = Block `fmap` many get+ put = mapM_ put . unBlock++instance Binary PKPayload where+ get = getPKPayload+ put = putPKPayload++instance Binary SignaturePayload where+ get = getSignaturePayload+ put = putSignaturePayload++instance Binary TK where+ get = undefined+ put = putTK++getSigSubPacket :: Get SigSubPacket+getSigSubPacket = do+ l <- fmap fromIntegral getSubPacketLength+ (crit, pt) <- getSigSubPacketType+ getSigSubPacket' pt crit l+ where+ getSigSubPacket' :: Word8 -> Bool -> ByteOffset -> Get SigSubPacket+ getSigSubPacket' pt crit l+ | pt == 2 = do+ et <- fmap ThirtyTwoBitTimeStamp getWord32be+ return $ SigSubPacket crit (SigCreationTime et)+ | pt == 3 = do+ et <- fmap ThirtyTwoBitDuration getWord32be+ return $ SigSubPacket crit (SigExpirationTime et)+ | pt == 4 = do+ e <- get+ return $ SigSubPacket crit (ExportableCertification e)+ | pt == 5 = do+ tl <- getWord8+ ta <- getWord8+ return $ SigSubPacket crit (TrustSignature tl ta)+ | pt == 6 = do+ apdre <- getLazyByteString (l - 2)+ nul <- getWord8+ guard (nul == 0)+ return $ SigSubPacket crit (RegularExpression (BL.copy apdre))+ | pt == 7 = do+ r <- get+ return $ SigSubPacket crit (Revocable r)+ | pt == 9 = do+ et <- fmap ThirtyTwoBitDuration getWord32be+ return $ SigSubPacket crit (KeyExpirationTime et)+ | pt == 11 = do+ sa <- replicateM (fromIntegral (l - 1)) get+ return $ SigSubPacket crit (PreferredSymmetricAlgorithms sa)+ | pt == 12 = do+ rclass <- getWord8+ guard (testBit rclass 7)+ algid <- get+ fp <- getLazyByteString 20+ return $+ SigSubPacket+ crit+ (RevocationKey+ (bsToFFSet . BL.singleton $ rclass .&. 0x7f)+ algid+ (TwentyOctetFingerprint fp))+ | pt == 16 = do+ keyid <- getLazyByteString (l - 1)+ return $ SigSubPacket crit (Issuer (EightOctetKeyId keyid))+ | pt == 20 = do+ flags <- getLazyByteString 4+ nl <- getWord16be+ vl <- getWord16be+ nn <- getLazyByteString (fromIntegral nl)+ nv <- getLazyByteString (fromIntegral vl)+ return $+ SigSubPacket+ crit+ (NotationData (bsToFFSet flags) (NotationName nn) (NotationValue nv))+ | pt == 21 = do+ ha <- replicateM (fromIntegral (l - 1)) get+ return $ SigSubPacket crit (PreferredHashAlgorithms ha)+ | pt == 22 = do+ ca <- replicateM (fromIntegral (l - 1)) get+ return $ SigSubPacket crit (PreferredCompressionAlgorithms ca)+ | pt == 23 = do+ ksps <- getLazyByteString (l - 1)+ return $ SigSubPacket crit (KeyServerPreferences (bsToFFSet ksps))+ | pt == 24 = do+ pks <- getLazyByteString (l - 1)+ return $ SigSubPacket crit (PreferredKeyServer pks)+ | pt == 25 = do+ primacy <- get+ return $ SigSubPacket crit (PrimaryUserId primacy)+ | pt == 26 = do+ url <-+ fmap+ (URL . fromMaybe nullURI . parseURI . T.unpack .+ decodeUtf8With lenientDecode)+ (getByteString (fromIntegral (l - 1)))+ return $ SigSubPacket crit (PolicyURL url)+ | pt == 27 = do+ kfs <- getLazyByteString (l - 1)+ return $ SigSubPacket crit (KeyFlags (bsToFFSet kfs))+ | pt == 28 = do+ uid <- getByteString (fromIntegral (l - 1))+ return $+ SigSubPacket crit (SignersUserId (decodeUtf8With lenientDecode uid))+ | pt == 29 = do+ rcode <- getWord8+ rreason <-+ fmap+ (decodeUtf8With lenientDecode)+ (getByteString (fromIntegral (l - 2)))+ return $ SigSubPacket crit (ReasonForRevocation (toFVal rcode) rreason)+ | pt == 30 = do+ fbs <- getLazyByteString (l - 1)+ return $ SigSubPacket crit (Features (bsToFFSet fbs))+ | pt == 31 = do+ pka <- get+ ha <- get+ hash <- getLazyByteString (l - 3)+ return $ SigSubPacket crit (SignatureTarget pka ha hash)+ | pt == 32 = do+ sp <- get :: Get SignaturePayload+ return $ SigSubPacket crit (EmbeddedSignature sp)+ | pt == 33 = do+ kv <- getWord8+ fp <-+ getLazyByteString+ (if kv == 4+ then 20+ else 32)+ return $+ SigSubPacket crit (IssuerFingerprint kv (TwentyOctetFingerprint fp))+ | pt > 99 && pt < 111 = do+ payload <- getLazyByteString (l - 1)+ return $ SigSubPacket crit (UserDefinedSigSub pt payload)+ | otherwise = do+ payload <- getLazyByteString (l - 1)+ return $ SigSubPacket crit (OtherSigSub pt payload)++putSigSubPacket :: SigSubPacket -> Put+putSigSubPacket (SigSubPacket crit (SigCreationTime et)) = do+ putSubPacketLength 5+ putSigSubPacketType crit 2+ putWord32be . unThirtyTwoBitTimeStamp $ et+putSigSubPacket (SigSubPacket crit (SigExpirationTime et)) = do+ putSubPacketLength 5+ putSigSubPacketType crit 3+ putWord32be . unThirtyTwoBitDuration $ et+putSigSubPacket (SigSubPacket crit (ExportableCertification e)) = do+ putSubPacketLength 2+ putSigSubPacketType crit 4+ put e+putSigSubPacket (SigSubPacket crit (TrustSignature tl ta)) = do+ putSubPacketLength 3+ putSigSubPacketType crit 5+ put tl+ put ta+putSigSubPacket (SigSubPacket crit (RegularExpression apdre)) = do+ putSubPacketLength . fromIntegral $ (2 + BL.length apdre)+ putSigSubPacketType crit 6+ putLazyByteString apdre+ putWord8 0+putSigSubPacket (SigSubPacket crit (Revocable r)) = do+ putSubPacketLength 2+ putSigSubPacketType crit 7+ put r+putSigSubPacket (SigSubPacket crit (KeyExpirationTime et)) = do+ putSubPacketLength 5+ putSigSubPacketType crit 9+ putWord32be . unThirtyTwoBitDuration $ et+putSigSubPacket (SigSubPacket crit (PreferredSymmetricAlgorithms ess)) = do+ putSubPacketLength . fromIntegral $ (1 + length ess)+ putSigSubPacketType crit 11+ mapM_ put ess+putSigSubPacket (SigSubPacket crit (RevocationKey rclass algid fp)) = do+ putSubPacketLength 23+ putSigSubPacketType crit 12+ putLazyByteString . ffSetToFixedLengthBS (1 :: Int) $+ Set.insert (RClOther 0) rclass+ put algid+ putLazyByteString (unTOF fp) -- 20 octets+putSigSubPacket (SigSubPacket crit (Issuer keyid)) = do+ putSubPacketLength 9+ putSigSubPacketType crit 16+ putLazyByteString (unEOKI keyid) -- 8 octets+putSigSubPacket (SigSubPacket crit (NotationData nfs (NotationName nn) (NotationValue nv))) = do+ putSubPacketLength . fromIntegral $ (9 + BL.length nn + BL.length nv)+ putSigSubPacketType crit 20+ putLazyByteString . ffSetToFixedLengthBS (4 :: Int) $ nfs+ putWord16be . fromIntegral . BL.length $ nn+ putWord16be . fromIntegral . BL.length $ nv+ putLazyByteString nn+ putLazyByteString nv+putSigSubPacket (SigSubPacket crit (PreferredHashAlgorithms ehs)) = do+ putSubPacketLength . fromIntegral $ (1 + length ehs)+ putSigSubPacketType crit 21+ mapM_ put ehs+putSigSubPacket (SigSubPacket crit (PreferredCompressionAlgorithms ecs)) = do+ putSubPacketLength . fromIntegral $ (1 + length ecs)+ putSigSubPacketType crit 22+ mapM_ put ecs+putSigSubPacket (SigSubPacket crit (KeyServerPreferences ksps)) = do+ let kbs = ffSetToBS ksps+ putSubPacketLength . fromIntegral $ (1 + BL.length kbs)+ putSigSubPacketType crit 23+ putLazyByteString kbs+putSigSubPacket (SigSubPacket crit (PreferredKeyServer ks)) = do+ putSubPacketLength . fromIntegral $ (1 + BL.length ks)+ putSigSubPacketType crit 24+ putLazyByteString ks+putSigSubPacket (SigSubPacket crit (PrimaryUserId primacy)) = do+ putSubPacketLength 2+ putSigSubPacketType crit 25+ put primacy+putSigSubPacket (SigSubPacket crit (PolicyURL (URL uri))) = do+ let bs = encodeUtf8 (T.pack (uriToString id uri ""))+ putSubPacketLength . fromIntegral $ (1 + B.length bs)+ putSigSubPacketType crit 26+ putByteString bs+putSigSubPacket (SigSubPacket crit (KeyFlags kfs)) = do+ let kbs = ffSetToBS kfs+ putSubPacketLength . fromIntegral $ (1 + BL.length kbs)+ putSigSubPacketType crit 27+ putLazyByteString kbs+putSigSubPacket (SigSubPacket crit (SignersUserId userid)) = do+ let bs = encodeUtf8 userid+ putSubPacketLength . fromIntegral $ (1 + B.length bs)+ putSigSubPacketType crit 28+ putByteString bs+putSigSubPacket (SigSubPacket crit (ReasonForRevocation rcode rreason)) = do+ let reasonbs = encodeUtf8 rreason+ putSubPacketLength . fromIntegral $ (2 + B.length reasonbs)+ putSigSubPacketType crit 29+ putWord8 . fromFVal $ rcode+ putByteString reasonbs+putSigSubPacket (SigSubPacket crit (Features fs)) = do+ let fbs = ffSetToBS fs+ putSubPacketLength . fromIntegral $ (1 + BL.length fbs)+ putSigSubPacketType crit 30+ putLazyByteString fbs+putSigSubPacket (SigSubPacket crit (SignatureTarget pka ha hash)) = do+ putSubPacketLength . fromIntegral $ (3 + BL.length hash)+ putSigSubPacketType crit 31+ put pka+ put ha+ putLazyByteString hash+putSigSubPacket (SigSubPacket crit (EmbeddedSignature sp)) = do+ let spb = runPut (put sp)+ putSubPacketLength . fromIntegral $ (1 + BL.length spb)+ putSigSubPacketType crit 32+ putLazyByteString spb+putSigSubPacket (SigSubPacket crit (IssuerFingerprint kv fp)) = do+ let fpb = unTOF fp+ putSubPacketLength . fromIntegral $ (2 + BL.length fpb)+ putSigSubPacketType crit 33+ putWord8 kv+ putLazyByteString fpb+putSigSubPacket (SigSubPacket crit (UserDefinedSigSub ptype payload)) =+ putSigSubPacket (SigSubPacket crit (OtherSigSub ptype payload))+putSigSubPacket (SigSubPacket crit (OtherSigSub ptype payload)) = do+ putSubPacketLength . fromIntegral $ (1 + BL.length payload)+ putSigSubPacketType crit ptype+ putLazyByteString payload++getSubPacketLength :: Get Word32+getSubPacketLength = getSubPacketLength' =<< getWord8+ where+ getSubPacketLength' :: Integral a => Word8 -> Get a+ getSubPacketLength' f+ | f < 192 = return . fromIntegral $ f+ | f < 224 = do+ secondOctet <- getWord8+ return . fromIntegral $ shiftL (fromIntegral (f - 192) :: Int) 8 ++ (fromIntegral secondOctet :: Int) ++ 192+ | f == 255 = do+ len <- getWord32be+ return . fromIntegral $ len+ | otherwise = fail "Partial body length invalid."++putSubPacketLength :: Word32 -> Put+putSubPacketLength l+ | l < 192 = putWord8 (fromIntegral l)+ | l < 8384 =+ putWord8 (fromIntegral ((fromIntegral (l - 192) `shiftR` 8) + 192 :: Int)) >>+ putWord8 (fromIntegral (l - 192) .&. 0xff)+ | l <= 0xffffffff = putWord8 255 >> putWord32be (fromIntegral l)+ | otherwise = fail ("too big (" ++ show l ++ ")")++getSigSubPacketType :: Get (Bool, Word8)+getSigSubPacketType = do+ x <- getWord8+ return+ (if x .&. 128 == 128+ then (True, x .&. 127)+ else (False, x))++putSigSubPacketType :: Bool -> Word8 -> Put+putSigSubPacketType False sst = putWord8 sst+putSigSubPacketType True sst = putWord8 (sst .|. 0x80)++bsToFFSet :: FutureFlag a => ByteString -> Set a+bsToFFSet bs =+ Set.fromAscList . concat . snd $+ mapAccumL+ (\acc y -> (acc + 8, concatMap (shifty acc y) [0 .. 7]))+ 0+ (BL.unpack bs)+ where+ shifty acc y x = [toFFlag (acc + x) | y .&. shiftR 128 x == shiftR 128 x]++ffSetToFixedLengthBS :: (Integral a, FutureFlag b) => a -> Set b -> ByteString+ffSetToFixedLengthBS len ffs =+ BL.take+ (fromIntegral len)+ (BL.append (ffSetToBS ffs) (BL.pack (replicate 5 0)))++ffSetToBS :: FutureFlag a => Set a -> ByteString+ffSetToBS = BL.pack . ffSetToBS'+ where+ ffSetToBS' :: FutureFlag a => Set a -> [Word8]+ ffSetToBS' ks+ | Set.null ks = [] -- FIXME: should this be [0]?+ | otherwise =+ map+ ((foldl (.|.) 0 . map (shiftR 128 . flip mod 8 . fromFFlag) .+ Set.toAscList) .+ (\x -> Set.filter (\y -> fromFFlag y `div` 8 == x) ks))+ [0 .. fromFFlag (Set.findMax ks) `div` 8]++fromS2K :: S2K -> ByteString+fromS2K (Simple hashalgo) = BL.pack [0, fromIntegral . fromFVal $ hashalgo]+fromS2K (Salted hashalgo salt)+ | B.length (unSalt salt) == 8 =+ BL.pack [1, fromIntegral . fromFVal $ hashalgo] `BL.append`+ (BL.fromStrict . unSalt) salt+ | otherwise = error "Confusing salt size"+fromS2K (IteratedSalted hashalgo salt count)+ | B.length (unSalt salt) == 8 =+ BL.pack [3, fromIntegral . fromFVal $ hashalgo] `BL.append`+ (BL.fromStrict . unSalt) salt `BL.snoc`+ encodeIterationCount count+ | otherwise = error "Confusing salt size"+fromS2K (OtherS2K _ bs) = bs++getPacketLength :: Get Integer+getPacketLength = do+ firstOctet <- getWord8+ getPacketLength' firstOctet+ where+ getPacketLength' :: Integral a => Word8 -> Get a+ getPacketLength' f+ | f < 192 = return . fromIntegral $ f+ | f < 224 = do+ secondOctet <- getWord8+ return . fromIntegral $ shiftL (fromIntegral (f - 192) :: Int) 8 ++ (fromIntegral secondOctet :: Int) ++ 192+ | f == 255 = do+ len <- getWord32be+ return . fromIntegral $ len+ | otherwise = fail "Partial body length support missing." --FIXME++putPacketLength :: Integer -> Put+putPacketLength l+ | l < 192 = putWord8 (fromIntegral l)+ | l < 8384 =+ putWord8 (fromIntegral ((fromIntegral (l - 192) `shiftR` 8) + 192 :: Int)) >>+ putWord8 (fromIntegral (l - 192) .&. 0xff)+ | l < 0x100000000 = putWord8 255 >> putWord32be (fromIntegral l)+ | otherwise = fail "partial body length support needed" -- FIXME++getS2K :: Get S2K+getS2K = getS2K' =<< getWord8+ where+ getS2K' :: Word8 -> Get S2K+ getS2K' t+ | t == 0 = do+ ha <- getWord8+ return $ Simple (toFVal ha)+ | t == 1 = do+ ha <- getWord8+ salt <- getByteString 8+ return $ Salted (toFVal ha) (Salt salt)+ | t == 3 = do+ ha <- getWord8+ salt <- getByteString 8+ count <- getWord8+ return $+ IteratedSalted (toFVal ha) (Salt salt) (decodeIterationCount count)+ | otherwise = do+ bs <- getRemainingLazyByteString+ return $ OtherS2K t bs++putS2K :: S2K -> Put+putS2K (Simple hashalgo) = error ("confused by simple" ++ show hashalgo)+putS2K (Salted hashalgo salt) =+ error ("confused by salted" ++ show hashalgo ++ " by " ++ show salt)+putS2K (IteratedSalted ha salt count) = do+ putWord8 3+ put ha+ putByteString (unSalt salt)+ putWord8 $ encodeIterationCount count+putS2K (OtherS2K t bs) = putWord8 t >> putLazyByteString bs++getPacketTypeAndPayload :: Get (Word8, ByteString)+getPacketTypeAndPayload = do+ tag <- getWord8+ guard (testBit tag 7)+ case tag .&. 0x40 of+ 0x00 -> do+ let t = shiftR (tag .&. 0x3c) 2+ case tag .&. 0x03 of+ 0 -> do+ len <- getWord8+ bs <- getLazyByteString (fromIntegral len)+ return (t, bs)+ 1 -> do+ len <- getWord16be+ bs <- getLazyByteString (fromIntegral len)+ return (t, bs)+ 2 -> do+ len <- getWord32be+ bs <- getLazyByteString (fromIntegral len)+ return (t, bs)+ 3 -> do+ bs <- getRemainingLazyByteString+ return (t, bs)+ _ -> error "This should never happen (getPacketTypeAndPayload/0x00)."+ 0x40 -> do+ len <- fmap fromIntegral getPacketLength+ bs <- getLazyByteString len+ return (tag .&. 0x3f, bs)+ _ -> error "This should never happen (getPacketTypeAndPayload/???)."++getPkt :: Get Pkt+getPkt = do+ (t, pl) <- getPacketTypeAndPayload+ case runGetOrFail (getPkt' t (BL.length pl)) pl of+ Left (_, _, e) -> return $! BrokenPacketPkt e t pl+ Right (_, _, p) -> return p+ where+ getPkt' :: Word8 -> ByteOffset -> Get Pkt+ getPkt' t len+ | t == 1 = do+ pv <- getWord8+ eokeyid <- getLazyByteString 8+ pka <- getWord8+ mpib <- getRemainingLazyByteString+ case runGetOrFail (some getMPI) mpib of+ Left (_, _, e) -> fail ("PKESK MPIs " ++ e)+ Right (_, _, sk) ->+ return $+ PKESKPkt pv (EightOctetKeyId eokeyid) (toFVal pka) (NE.fromList sk)+ | t == 2 = do+ bs <- getRemainingLazyByteString+ case runGetOrFail get bs of+ Left (_, _, e) -> fail ("signature packet " ++ e)+ Right (_, _, sp) -> return $ SignaturePkt sp+ | t == 3 = do+ pv <- getWord8+ symalgo <- getWord8+ s2k <- getS2K+ esk <- getRemainingLazyByteString+ return $+ SKESKPkt+ pv+ (toFVal symalgo)+ s2k+ (if BL.null esk+ then Nothing+ else Just esk)+ | t == 4 = do+ pv <- getWord8+ sigtype <- getWord8+ ha <- getWord8+ pka <- getWord8+ skeyid <- getLazyByteString 8+ nested <- getWord8+ return $+ OnePassSignaturePkt+ pv+ (toFVal sigtype)+ (toFVal ha)+ (toFVal pka)+ (EightOctetKeyId skeyid)+ (nested == 0)+ | t == 5 = do+ bs <- getLazyByteString len+ let ps =+ flip runGetOrFail bs $ do+ pkp <- getPKPayload+ ska <- getSKAddendum pkp+ return $ SecretKeyPkt pkp ska+ case ps of+ Left (_, _, err) -> fail ("secret key " ++ err)+ Right (_, _, key) -> return key+ | t == 6 = do+ pkp <- getPKPayload+ return $ PublicKeyPkt pkp+ | t == 7 = do+ bs <- getLazyByteString len+ let ps =+ flip runGetOrFail bs $ do+ pkp <- getPKPayload+ ska <- getSKAddendum pkp+ return $ SecretSubkeyPkt pkp ska+ case ps of+ Left (_, _, err) -> fail ("secret subkey " ++ err)+ Right (_, _, key) -> return key+ | t == 8 = do+ ca <- getWord8+ cdata <- getLazyByteString (len - 1)+ return $ CompressedDataPkt (toFVal ca) cdata+ | t == 9 = do+ sdata <- getLazyByteString len+ return $ SymEncDataPkt sdata+ | t == 10 = do+ marker <- getLazyByteString len+ return $ MarkerPkt marker+ | t == 11 = do+ dt <- getWord8+ flen <- getWord8+ fn <- getLazyByteString (fromIntegral flen)+ ts <- fmap ThirtyTwoBitTimeStamp getWord32be+ ldata <- getLazyByteString (len - (6 + fromIntegral flen))+ return $ LiteralDataPkt (toFVal dt) fn ts ldata+ | t == 12 = do+ tdata <- getLazyByteString len+ return $ TrustPkt tdata+ | t == 13 = do+ udata <- getByteString (fromIntegral len)+ return . UserIdPkt . decodeUtf8With lenientDecode $ udata+ | t == 14 = do+ bs <- getLazyByteString len+ let ps =+ flip runGetOrFail bs $ do+ pkp <- getPKPayload+ return $ PublicSubkeyPkt pkp+ case ps of+ Left (_, _, err) -> fail ("public subkey " ++ err)+ Right (_, _, key) -> return key+ | t == 17 = do+ bs <- getLazyByteString len+ case runGetOrFail (many getUserAttrSubPacket) bs of+ Left (_, _, err) -> fail ("user attribute " ++ err)+ Right (_, _, uas) -> return $ UserAttributePkt uas+ | t == 18 = do+ pv <- getWord8 -- should be 1+ b <- getLazyByteString (len - 1)+ return $ SymEncIntegrityProtectedDataPkt pv b+ | t == 19 = do+ hash <- getLazyByteString 20+ return $ ModificationDetectionCodePkt hash+ | otherwise = do+ payload <- getLazyByteString len+ return $ OtherPacketPkt t payload++getUserAttrSubPacket :: Get UserAttrSubPacket+getUserAttrSubPacket = do+ l <- fmap fromIntegral getSubPacketLength+ t <- getWord8+ getUserAttrSubPacket' t l+ where+ getUserAttrSubPacket' :: Word8 -> ByteOffset -> Get UserAttrSubPacket+ getUserAttrSubPacket' t l+ | t == 1 = do+ _ <- getWord16le -- ihlen+ hver <- getWord8 -- should be 1+ iformat <- getWord8+ nuls <- getLazyByteString 12 -- should be NULs+ bs <- getLazyByteString (l - 17)+ if hver /= 1 || nuls /= BL.pack (replicate 12 0)+ then fail "Corrupt UAt subpacket"+ else return $ ImageAttribute (ImageHV1 (toFVal iformat)) bs+ | otherwise = do+ bs <- getLazyByteString (l - 1)+ return $ OtherUASub t bs++putUserAttrSubPacket :: UserAttrSubPacket -> Put+putUserAttrSubPacket ua = do+ let sp = runPut $ putUserAttrSubPacket' ua+ putSubPacketLength . fromIntegral . BL.length $ sp+ putLazyByteString sp+ where+ putUserAttrSubPacket' (ImageAttribute (ImageHV1 iformat) idata) = do+ putWord8 1+ putWord16le 16+ putWord8 1+ putWord8 (fromFVal iformat)+ replicateM_ 12 $ putWord8 0+ putLazyByteString idata+ putUserAttrSubPacket' (OtherUASub t bs) = do+ putWord8 t+ putLazyByteString bs++putPkt :: Pkt -> Put+putPkt (PKESKPkt pv eokeyid pka mpis) = do+ putWord8 (0xc0 .|. 1)+ let bsk = runPut $ F.mapM_ put mpis+ putPacketLength . fromIntegral $ 10 + BL.length bsk+ putWord8 pv -- must be 3+ putLazyByteString (unEOKI eokeyid) -- must be 8 octets+ putWord8 $ fromIntegral . fromFVal $ pka+ putLazyByteString bsk+putPkt (SignaturePkt sp) = do+ putWord8 (0xc0 .|. 2)+ let bs = runPut $ put sp+ putLengthThenPayload bs+putPkt (SKESKPkt pv symalgo s2k mesk) = do+ putWord8 (0xc0 .|. 3)+ let bs2k = fromS2K s2k+ let bsk = fromMaybe BL.empty mesk+ putPacketLength . fromIntegral $ 2 + BL.length bs2k + BL.length bsk+ putWord8 pv -- should be 4+ putWord8 $ fromIntegral . fromFVal $ symalgo+ putLazyByteString bs2k+ putLazyByteString bsk+putPkt (OnePassSignaturePkt pv sigtype ha pka skeyid nested) = do+ putWord8 (0xc0 .|. 4)+ let bs =+ runPut $ do+ putWord8 pv -- should be 3+ putWord8 $ fromIntegral . fromFVal $ sigtype+ putWord8 $ fromIntegral . fromFVal $ ha+ putWord8 $ fromIntegral . fromFVal $ pka+ putLazyByteString (unEOKI skeyid)+ putWord8 . fromIntegral . fromEnum $ not nested -- FIXME: what do other values mean?+ putLengthThenPayload bs+putPkt (SecretKeyPkt pkp ska) = do+ putWord8 (0xc0 .|. 5)+ let bs = runPut (putPKPayload pkp >> putSKAddendum ska)+ putLengthThenPayload bs+putPkt (PublicKeyPkt pkp) = do+ putWord8 (0xc0 .|. 6)+ let bs = runPut $ putPKPayload pkp+ putLengthThenPayload bs+putPkt (SecretSubkeyPkt pkp ska) = do+ putWord8 (0xc0 .|. 7)+ let bs = runPut (putPKPayload pkp >> putSKAddendum ska)+ putLengthThenPayload bs+putPkt (CompressedDataPkt ca cdata) = do+ putWord8 (0xc0 .|. 8)+ let bs =+ runPut $ do+ putWord8 $ fromIntegral . fromFVal $ ca+ putLazyByteString cdata+ putLengthThenPayload bs+putPkt (SymEncDataPkt b) = do+ putWord8 (0xc0 .|. 9)+ putLengthThenPayload b+putPkt (MarkerPkt b) = do+ putWord8 (0xc0 .|. 10)+ putLengthThenPayload b+putPkt (LiteralDataPkt dt fn ts b) = do+ putWord8 (0xc0 .|. 11)+ let bs =+ runPut $ do+ putWord8 $ fromIntegral . fromFVal $ dt+ putWord8 $ fromIntegral . BL.length $ fn+ putLazyByteString fn+ putWord32be . unThirtyTwoBitTimeStamp $ ts+ putLazyByteString b+ putLengthThenPayload bs+putPkt (TrustPkt b) = do+ putWord8 (0xc0 .|. 12)+ putLengthThenPayload b+putPkt (UserIdPkt u) = do+ putWord8 (0xc0 .|. 13)+ let bs = encodeUtf8 u+ putPacketLength . fromIntegral $ B.length bs+ putByteString bs+putPkt (PublicSubkeyPkt pkp) = do+ putWord8 (0xc0 .|. 14)+ let bs = runPut $ putPKPayload pkp+ putLengthThenPayload bs+putPkt (UserAttributePkt us) = do+ putWord8 (0xc0 .|. 17)+ let bs = runPut $ mapM_ put us+ putLengthThenPayload bs+putPkt (SymEncIntegrityProtectedDataPkt pv b) = do+ putWord8 (0xc0 .|. 18)+ putPacketLength . fromIntegral $ BL.length b + 1+ putWord8 pv -- should be 1+ putLazyByteString b+putPkt (ModificationDetectionCodePkt hash) = do+ putWord8 (0xc0 .|. 19)+ putLengthThenPayload hash+putPkt (OtherPacketPkt t payload) = do+ putWord8 (0xc0 .|. t) -- FIXME: restrict t+ putLengthThenPayload payload+putPkt (BrokenPacketPkt _ t payload) = putPkt (OtherPacketPkt t payload)++putLengthThenPayload :: ByteString -> Put+putLengthThenPayload bs = do+ putPacketLength . fromIntegral $ BL.length bs+ putLazyByteString bs++getMPI :: Get MPI+getMPI = do+ mpilen <- getWord16be+ bs <- getByteString (fromIntegral (mpilen + 7) `div` 8)+ return $ MPI (os2ip bs)++getPubkey :: PubKeyAlgorithm -> Get PKey+getPubkey RSA = do+ MPI n <- get+ MPI e <- get+ return $+ RSAPubKey+ (RSA_PublicKey (R.PublicKey (fromIntegral . B.length . i2osp $ n) n e))+getPubkey DeprecatedRSAEncryptOnly = getPubkey RSA+getPubkey DeprecatedRSASignOnly = getPubkey RSA+getPubkey DSA = do+ MPI p <- get+ MPI q <- get+ MPI g <- get+ MPI y <- get+ return $ DSAPubKey (DSA_PublicKey (D.PublicKey (D.Params p g q) y))+getPubkey ElgamalEncryptOnly = getPubkey ForbiddenElgamal+getPubkey ForbiddenElgamal = do+ MPI p <- get+ MPI g <- get+ MPI y <- get+ return $ ElGamalPubKey p g y+getPubkey ECDSA = do+ curvelength <- getWord8 -- FIXME: test for 0 or 0xFF as they are reserved+ curveoid <- getByteString (fromIntegral curvelength)+ MPI mpi <- getMPI -- FIXME: check length against curve type?+ case curveoidBSToCurve curveoid of+ Left e -> fail e+ Right Curve25519 -> return $ EdDSAPubKey Ed25519 (EPoint mpi)+ Right curve ->+ case bs2Point (i2osp mpi) of+ Left e -> fail e+ Right point ->+ return . ECDSAPubKey . ECDSA_PublicKey .+ ECDSA.PublicKey (curve2Curve curve) $+ point+getPubkey ECDH = do+ ed <- getPubkey ECDSA -- could be an ECDSA or an EdDSA+ kdflen <- getWord8 -- FIXME: should be 3, test for 0 or 0xFF as they are reserved+ one <- getWord8 -- FIXME: should be 1+ kdfHA <- get+ kdfSA <- get+ return $ ECDHPubKey ed kdfHA kdfSA+getPubkey EdDSA = do+ curvelength <- getWord8 -- FIXME: test for 0 or 0xFF as they are reserved+ curveoid <- getByteString (fromIntegral curvelength)+ MPI mpi <- getMPI -- FIXME: check length against curve type?+ case curveoidBSToEdSigningCurve curveoid of+ Left e -> fail e+ Right Ed25519 -> return . EdDSAPubKey Ed25519 $ EPoint mpi+getPubkey _ = UnknownPKey <$> getRemainingLazyByteString++bs2Point :: B.ByteString -> Either String ECDSA.PublicPoint+bs2Point bs =+ let xy = B.drop 1 bs+ in let l = B.length xy+ in if B.head bs == 0x04+ then return+ (uncurry+ ECCT.Point+ (bimap os2ip os2ip (B.splitAt (div l 2) xy)))+ else fail $ "unknown type of point: " ++ show (B.unpack bs)++putPubkey :: PKey -> Put+putPubkey (UnknownPKey bs) = putLazyByteString bs+putPubkey p@(ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) =+ let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve)+ in putWord8 (fromIntegral (B.length curveoidbs)) >> putByteString curveoidbs >>+ mapM_ put (pubkeyToMPIs p) -- FIXME: do not output length 0 or 0xff+putPubkey p@(ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) kha ksa) =+ let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve)+ in putWord8 (fromIntegral (B.length curveoidbs)) >> putByteString curveoidbs >>+ mapM_ put (pubkeyToMPIs p) >>+ putWord8 0x03 >>+ putWord8 0x01 >>+ put kha >>+ put ksa -- FIXME: do not output length 0 or 0xff+putPubkey p@(ECDHPubKey (EdDSAPubKey curve _) kha ksa) =+ let Right curveoidbs = curveToCurveoidBS (ed2ec curve)+ in putWord8 (fromIntegral (B.length curveoidbs)) >> putByteString curveoidbs >>+ mapM_ put (pubkeyToMPIs p) >>+ putWord8 0x03 >>+ putWord8 0x01 >>+ put kha >>+ put ksa -- FIXME: do not output length 0 or 0xff+ where+ ed2ec Ed25519 = Curve25519+putPubkey p@(EdDSAPubKey curve _) =+ let Right curveoidbs = edSigningCurveToCurveoidBS curve+ in putWord8 (fromIntegral (B.length curveoidbs)) >> putByteString curveoidbs >>+ mapM_ put (pubkeyToMPIs p) -- FIXME: do not output length 0 or 0xff+putPubkey p = mapM_ put (pubkeyToMPIs p)++getSecretKey :: PKPayload -> Get SKey+getSecretKey pkp+ | _pkalgo pkp `elem` [RSA, DeprecatedRSAEncryptOnly, DeprecatedRSASignOnly] = do+ MPI d <- get+ MPI p <- get+ MPI q <- get+ MPI _ <- get -- u+ let dP = 0+ dQ = 0+ qinv = 0+ pub = (\(RSAPubKey (RSA_PublicKey x)) -> x) (pkp ^. pubkey)+ return $ RSAPrivateKey (RSA_PrivateKey (R.PrivateKey pub d p q dP dQ qinv))+ | _pkalgo pkp == DSA = do+ MPI x <- get+ return $ DSAPrivateKey (DSA_PrivateKey (D.PrivateKey (D.Params 0 0 0) x))+ | _pkalgo pkp `elem` [ElgamalEncryptOnly, ForbiddenElgamal] = do+ MPI x <- get+ return $ ElGamalPrivateKey x+ | _pkalgo pkp == ECDSA = do+ MPI pn <- get+ let pubcurve =+ (\(ECDSAPubKey (ECDSA_PublicKey p)) -> ECDSA.public_curve p)+ (pkp ^. pubkey)+ return $ ECDSAPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey pubcurve pn))+ | _pkalgo pkp == ECDH -- FIXME: deduplicate this and above+ = do+ MPI pn <- get+ let pubcurve =+ (\(ECDSAPubKey (ECDSA_PublicKey p)) -> ECDSA.public_curve p)+ (pkp ^. pubkey)+ return $ ECDHPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey pubcurve pn))++putSKey :: SKey -> Put+putSKey (RSAPrivateKey (RSA_PrivateKey (R.PrivateKey _ d p q _ _ _))) =+ put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u)+ where+ u = multiplicativeInverse q p++putMPI :: MPI -> Put+putMPI (MPI i) = do+ let bs = i2osp i+ putWord16be . fromIntegral . numBits $ i+ putByteString bs++getPKPayload :: Get PKPayload+getPKPayload = do+ version <- getWord8+ ctime <- fmap ThirtyTwoBitTimeStamp getWord32be+ if version `elem` [2, 3]+ then do+ v3e <- getWord16be+ pka <- get+ pk <- getPubkey pka+ return $! PKPayload DeprecatedV3 ctime v3e pka pk+ else do+ pka <- get+ pk <- getPubkey pka+ return $! PKPayload V4 ctime 0 pka pk++putPKPayload :: PKPayload -> Put+putPKPayload (PKPayload DeprecatedV3 ctime v3e pka pk) = do+ putWord8 3+ putWord32be . unThirtyTwoBitTimeStamp $ ctime+ putWord16be v3e+ put pka+ putPubkey pk+putPKPayload (PKPayload V4 ctime _ pka pk) = do+ putWord8 4+ putWord32be . unThirtyTwoBitTimeStamp $ ctime+ put pka+ putPubkey pk++getSKAddendum :: PKPayload -> Get SKAddendum+getSKAddendum pkp = do+ s2kusage <- getWord8+ case s2kusage of+ 0 -> do+ sk <- getSecretKey pkp+ checksum <- getWord16be -- FIXME: validate checksum?+ return $ SUUnencrypted sk checksum+ 255 -> do+ symenc <- getWord8+ s2k <- getS2K+ case s2k -- FIXME: this is a mess+ of+ OtherS2K _ _ -> return $ SUS16bit (toFVal symenc) s2k mempty BL.empty+ _ -> do+ iv <- getByteString (symEncBlockSize . toFVal $ symenc)+ encryptedblock <- getRemainingLazyByteString+ return $ SUS16bit (toFVal symenc) s2k (IV iv) encryptedblock+ 254 -> do+ symenc <- getWord8+ s2k <- getS2K+ case s2k -- FIXME: this is a mess+ of+ OtherS2K _ _ -> return $ SUSSHA1 (toFVal symenc) s2k mempty BL.empty+ _ -> do+ iv <- getByteString (symEncBlockSize . toFVal $ symenc)+ encryptedblock <- getRemainingLazyByteString+ return $ SUSSHA1 (toFVal symenc) s2k (IV iv) encryptedblock+ symenc -> do+ iv <- getByteString (symEncBlockSize . toFVal $ symenc)+ encryptedblock <- getRemainingLazyByteString+ return $ SUSym (toFVal symenc) (IV iv) encryptedblock++putSKAddendum :: SKAddendum -> Put+putSKAddendum (SUSSHA1 symenc s2k iv encryptedblock) = do+ putWord8 254+ put symenc+ put s2k+ putByteString (unIV iv)+ putLazyByteString encryptedblock+putSKAddendum (SUUnencrypted sk checksum) = do+ putWord8 0+ let skb = runPut (putSKey sk)+ putLazyByteString skb+ putWord16be+ (if checksum == 0+ then BL.foldl (\a b -> mod (a + fromIntegral b) 0xffff) (0 :: Word16) skb+ else checksum) -- FIXME: be saner+putSKAddendum _ = fail "Type not supported"++symEncBlockSize :: SymmetricAlgorithm -> Int+symEncBlockSize Plaintext = 0+symEncBlockSize IDEA = 8+symEncBlockSize TripleDES = 8+symEncBlockSize CAST5 = 8+symEncBlockSize Blowfish = 8+symEncBlockSize AES128 = 16+symEncBlockSize AES192 = 16+symEncBlockSize AES256 = 16+symEncBlockSize Twofish = 16+symEncBlockSize Camellia128 = 16+symEncBlockSize _ = 8 -- FIXME++decodeIterationCount :: Word8 -> IterationCount+decodeIterationCount c =+ IterationCount+ ((16 + (fromIntegral c .&. 15)) `shiftL` ((fromIntegral c `shiftR` 4) + 6))++encodeIterationCount :: IterationCount -> Word8 -- should this really be a lookup table?+encodeIterationCount 1024 = 0+encodeIterationCount 1088 = 1+encodeIterationCount 1152 = 2+encodeIterationCount 1216 = 3+encodeIterationCount 1280 = 4+encodeIterationCount 1344 = 5+encodeIterationCount 1408 = 6+encodeIterationCount 1472 = 7+encodeIterationCount 1536 = 8+encodeIterationCount 1600 = 9+encodeIterationCount 1664 = 10+encodeIterationCount 1728 = 11+encodeIterationCount 1792 = 12+encodeIterationCount 1856 = 13+encodeIterationCount 1920 = 14+encodeIterationCount 1984 = 15+encodeIterationCount 2048 = 16+encodeIterationCount 2176 = 17+encodeIterationCount 2304 = 18+encodeIterationCount 2432 = 19+encodeIterationCount 2560 = 20+encodeIterationCount 2688 = 21+encodeIterationCount 2816 = 22+encodeIterationCount 2944 = 23+encodeIterationCount 3072 = 24+encodeIterationCount 3200 = 25+encodeIterationCount 3328 = 26+encodeIterationCount 3456 = 27+encodeIterationCount 3584 = 28+encodeIterationCount 3712 = 29+encodeIterationCount 3840 = 30+encodeIterationCount 3968 = 31+encodeIterationCount 4096 = 32+encodeIterationCount 4352 = 33+encodeIterationCount 4608 = 34+encodeIterationCount 4864 = 35+encodeIterationCount 5120 = 36+encodeIterationCount 5376 = 37+encodeIterationCount 5632 = 38+encodeIterationCount 5888 = 39+encodeIterationCount 6144 = 40+encodeIterationCount 6400 = 41+encodeIterationCount 6656 = 42+encodeIterationCount 6912 = 43+encodeIterationCount 7168 = 44+encodeIterationCount 7424 = 45+encodeIterationCount 7680 = 46+encodeIterationCount 7936 = 47+encodeIterationCount 8192 = 48+encodeIterationCount 8704 = 49+encodeIterationCount 9216 = 50+encodeIterationCount 9728 = 51+encodeIterationCount 10240 = 52+encodeIterationCount 10752 = 53+encodeIterationCount 11264 = 54+encodeIterationCount 11776 = 55+encodeIterationCount 12288 = 56+encodeIterationCount 12800 = 57+encodeIterationCount 13312 = 58+encodeIterationCount 13824 = 59+encodeIterationCount 14336 = 60+encodeIterationCount 14848 = 61+encodeIterationCount 15360 = 62+encodeIterationCount 15872 = 63+encodeIterationCount 16384 = 64+encodeIterationCount 17408 = 65+encodeIterationCount 18432 = 66+encodeIterationCount 19456 = 67+encodeIterationCount 20480 = 68+encodeIterationCount 21504 = 69+encodeIterationCount 22528 = 70+encodeIterationCount 23552 = 71+encodeIterationCount 24576 = 72+encodeIterationCount 25600 = 73+encodeIterationCount 26624 = 74+encodeIterationCount 27648 = 75+encodeIterationCount 28672 = 76+encodeIterationCount 29696 = 77+encodeIterationCount 30720 = 78+encodeIterationCount 31744 = 79+encodeIterationCount 32768 = 80+encodeIterationCount 34816 = 81+encodeIterationCount 36864 = 82+encodeIterationCount 38912 = 83+encodeIterationCount 40960 = 84+encodeIterationCount 43008 = 85+encodeIterationCount 45056 = 86+encodeIterationCount 47104 = 87+encodeIterationCount 49152 = 88+encodeIterationCount 51200 = 89+encodeIterationCount 53248 = 90+encodeIterationCount 55296 = 91+encodeIterationCount 57344 = 92+encodeIterationCount 59392 = 93+encodeIterationCount 61440 = 94+encodeIterationCount 63488 = 95+encodeIterationCount 65536 = 96+encodeIterationCount 69632 = 97+encodeIterationCount 73728 = 98+encodeIterationCount 77824 = 99+encodeIterationCount 81920 = 100+encodeIterationCount 86016 = 101+encodeIterationCount 90112 = 102+encodeIterationCount 94208 = 103+encodeIterationCount 98304 = 104+encodeIterationCount 102400 = 105+encodeIterationCount 106496 = 106+encodeIterationCount 110592 = 107+encodeIterationCount 114688 = 108+encodeIterationCount 118784 = 109+encodeIterationCount 122880 = 110+encodeIterationCount 126976 = 111+encodeIterationCount 131072 = 112+encodeIterationCount 139264 = 113+encodeIterationCount 147456 = 114+encodeIterationCount 155648 = 115+encodeIterationCount 163840 = 116+encodeIterationCount 172032 = 117+encodeIterationCount 180224 = 118+encodeIterationCount 188416 = 119+encodeIterationCount 196608 = 120+encodeIterationCount 204800 = 121+encodeIterationCount 212992 = 122+encodeIterationCount 221184 = 123+encodeIterationCount 229376 = 124+encodeIterationCount 237568 = 125+encodeIterationCount 245760 = 126+encodeIterationCount 253952 = 127+encodeIterationCount 262144 = 128+encodeIterationCount 278528 = 129+encodeIterationCount 294912 = 130+encodeIterationCount 311296 = 131+encodeIterationCount 327680 = 132+encodeIterationCount 344064 = 133+encodeIterationCount 360448 = 134+encodeIterationCount 376832 = 135+encodeIterationCount 393216 = 136+encodeIterationCount 409600 = 137+encodeIterationCount 425984 = 138+encodeIterationCount 442368 = 139+encodeIterationCount 458752 = 140+encodeIterationCount 475136 = 141+encodeIterationCount 491520 = 142+encodeIterationCount 507904 = 143+encodeIterationCount 524288 = 144+encodeIterationCount 557056 = 145+encodeIterationCount 589824 = 146+encodeIterationCount 622592 = 147+encodeIterationCount 655360 = 148+encodeIterationCount 688128 = 149+encodeIterationCount 720896 = 150+encodeIterationCount 753664 = 151+encodeIterationCount 786432 = 152+encodeIterationCount 819200 = 153+encodeIterationCount 851968 = 154+encodeIterationCount 884736 = 155+encodeIterationCount 917504 = 156+encodeIterationCount 950272 = 157+encodeIterationCount 983040 = 158+encodeIterationCount 1015808 = 159+encodeIterationCount 1048576 = 160+encodeIterationCount 1114112 = 161+encodeIterationCount 1179648 = 162+encodeIterationCount 1245184 = 163+encodeIterationCount 1310720 = 164+encodeIterationCount 1376256 = 165+encodeIterationCount 1441792 = 166+encodeIterationCount 1507328 = 167+encodeIterationCount 1572864 = 168+encodeIterationCount 1638400 = 169+encodeIterationCount 1703936 = 170+encodeIterationCount 1769472 = 171+encodeIterationCount 1835008 = 172+encodeIterationCount 1900544 = 173+encodeIterationCount 1966080 = 174+encodeIterationCount 2031616 = 175+encodeIterationCount 2097152 = 176+encodeIterationCount 2228224 = 177+encodeIterationCount 2359296 = 178+encodeIterationCount 2490368 = 179+encodeIterationCount 2621440 = 180+encodeIterationCount 2752512 = 181+encodeIterationCount 2883584 = 182+encodeIterationCount 3014656 = 183+encodeIterationCount 3145728 = 184+encodeIterationCount 3276800 = 185+encodeIterationCount 3407872 = 186+encodeIterationCount 3538944 = 187+encodeIterationCount 3670016 = 188+encodeIterationCount 3801088 = 189+encodeIterationCount 3932160 = 190+encodeIterationCount 4063232 = 191+encodeIterationCount 4194304 = 192+encodeIterationCount 4456448 = 193+encodeIterationCount 4718592 = 194+encodeIterationCount 4980736 = 195+encodeIterationCount 5242880 = 196+encodeIterationCount 5505024 = 197+encodeIterationCount 5767168 = 198+encodeIterationCount 6029312 = 199+encodeIterationCount 6291456 = 200+encodeIterationCount 6553600 = 201+encodeIterationCount 6815744 = 202+encodeIterationCount 7077888 = 203+encodeIterationCount 7340032 = 204+encodeIterationCount 7602176 = 205+encodeIterationCount 7864320 = 206+encodeIterationCount 8126464 = 207+encodeIterationCount 8388608 = 208+encodeIterationCount 8912896 = 209+encodeIterationCount 9437184 = 210+encodeIterationCount 9961472 = 211+encodeIterationCount 10485760 = 212+encodeIterationCount 11010048 = 213+encodeIterationCount 11534336 = 214+encodeIterationCount 12058624 = 215+encodeIterationCount 12582912 = 216+encodeIterationCount 13107200 = 217+encodeIterationCount 13631488 = 218+encodeIterationCount 14155776 = 219+encodeIterationCount 14680064 = 220+encodeIterationCount 15204352 = 221+encodeIterationCount 15728640 = 222+encodeIterationCount 16252928 = 223+encodeIterationCount 16777216 = 224+encodeIterationCount 17825792 = 225+encodeIterationCount 18874368 = 226+encodeIterationCount 19922944 = 227+encodeIterationCount 20971520 = 228+encodeIterationCount 22020096 = 229+encodeIterationCount 23068672 = 230+encodeIterationCount 24117248 = 231+encodeIterationCount 25165824 = 232+encodeIterationCount 26214400 = 233+encodeIterationCount 27262976 = 234+encodeIterationCount 28311552 = 235+encodeIterationCount 29360128 = 236+encodeIterationCount 30408704 = 237+encodeIterationCount 31457280 = 238+encodeIterationCount 32505856 = 239+encodeIterationCount 33554432 = 240+encodeIterationCount 35651584 = 241+encodeIterationCount 37748736 = 242+encodeIterationCount 39845888 = 243+encodeIterationCount 41943040 = 244+encodeIterationCount 44040192 = 245+encodeIterationCount 46137344 = 246+encodeIterationCount 48234496 = 247+encodeIterationCount 50331648 = 248+encodeIterationCount 52428800 = 249+encodeIterationCount 54525952 = 250+encodeIterationCount 56623104 = 251+encodeIterationCount 58720256 = 252+encodeIterationCount 60817408 = 253+encodeIterationCount 62914560 = 254+encodeIterationCount 65011712 = 255+encodeIterationCount n = error ("invalid iteration count" ++ show n)++getSignaturePayload :: Get SignaturePayload+getSignaturePayload = do+ pv <- getWord8+ case pv of+ 3 -> do+ hashlen <- getWord8+ guard (hashlen == 5)+ st <- getWord8+ ctime <- fmap ThirtyTwoBitTimeStamp getWord32be+ eok <- getLazyByteString 8+ pka <- get+ ha <- get+ left16 <- getWord16be+ mpib <- getRemainingLazyByteString+ case runGetOrFail (some getMPI) mpib of+ Left (_, _, e) -> fail ("v3 sig MPIs " ++ e)+ Right (_, _, mpis) ->+ return $+ SigV3+ (toFVal st)+ ctime+ (EightOctetKeyId eok)+ (toFVal pka)+ (toFVal ha)+ left16+ (NE.fromList mpis)+ 4 -> do+ st <- getWord8+ pka <- get+ ha <- get+ hlen <- getWord16be+ hb <- getLazyByteString (fromIntegral hlen)+ let hashed =+ case runGetOrFail (many getSigSubPacket) hb of+ Left (_, _, err) -> fail ("v4 sig hasheds " ++ err)+ Right (_, _, h) -> h+ ulen <- getWord16be+ ub <- getLazyByteString (fromIntegral ulen)+ let unhashed =+ case runGetOrFail (many getSigSubPacket) ub of+ Left (_, _, err) -> fail ("v4 sig unhasheds " ++ err)+ Right (_, _, u) -> u+ left16 <- getWord16be+ mpib <- getRemainingLazyByteString+ case runGetOrFail (some getMPI) mpib of+ Left (_, _, e) -> fail ("v4 sig MPIs " ++ e)+ Right (_, _, mpis) ->+ return $+ SigV4+ (toFVal st)+ (toFVal pka)+ (toFVal ha)+ hashed+ unhashed+ left16+ (NE.fromList mpis)+ _ -> do+ bs <- getRemainingLazyByteString+ return $ SigVOther pv bs++putSignaturePayload :: SignaturePayload -> Put+putSignaturePayload (SigV3 st ctime eok pka ha left16 mpis) = do+ putWord8 3+ putWord8 5 -- hashlen+ put st+ putWord32be . unThirtyTwoBitTimeStamp $ ctime+ putLazyByteString (unEOKI eok)+ put pka+ put ha+ putWord16be left16+ F.mapM_ put mpis+putSignaturePayload (SigV4 st pka ha hashed unhashed left16 mpis) = do+ putWord8 4+ put st+ put pka+ put ha+ let hb = runPut $ mapM_ put hashed+ putWord16be . fromIntegral . BL.length $ hb+ putLazyByteString hb+ let ub = runPut $ mapM_ put unhashed+ putWord16be . fromIntegral . BL.length $ ub+ putLazyByteString ub+ putWord16be left16+ F.mapM_ put mpis+putSignaturePayload (SigVOther pv bs) = do+ putWord8 pv+ putLazyByteString bs++putTK :: TK -> Put+putTK key = do+ let pkp = key ^. tkKey . _1+ maybe+ (put (PublicKey pkp))+ (\ska -> put (SecretKey pkp ska))+ (snd (key ^. tkKey))+ mapM_ (put . Signature) (_tkRevs key)+ mapM_ putUid' (_tkUIDs key)+ mapM_ putUat' (_tkUAts key)+ mapM_ putSub' (_tkSubs key)+ where+ putUid' (u, sps) = put (UserId u) >> mapM_ (put . Signature) sps+ putUat' (us, sps) = put (UserAttribute us) >> mapM_ (put . Signature) sps+ putSub' (p, sps) = put p >> mapM_ (put . Signature) sps++-- | Parse the packets from a ByteString, with no error reporting+parsePkts :: ByteString -> [Pkt]+parsePkts lbs =+ case runGetOrFail (some getPkt) lbs of+ Left (_, _, e) -> []+ Right (_, _, p) -> p
Codec/Encryption/OpenPGP/SerializeForSigs.hs view
@@ -2,26 +2,33 @@ -- Copyright © 2012-2016 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).--module Codec.Encryption.OpenPGP.SerializeForSigs (- putPKPforFingerprinting- , putPartialSigforSigning- , putSigTrailer- , putUforSigning- , putUIDforSigning- , putUAtforSigning- , putKeyforSigning- , putSigforSigning- , payloadForSig-) where+module Codec.Encryption.OpenPGP.SerializeForSigs+ ( putPKPforFingerprinting+ , putPartialSigforSigning+ , putSigTrailer+ , putUforSigning+ , putUIDforSigning+ , putUAtforSigning+ , putKeyforSigning+ , putSigforSigning+ , payloadForSig+ ) where import Control.Lens ((^.)) import Crypto.Number.Serialize (i2osp)-import Data.ByteString.Lazy (ByteString)+import Data.Binary (put)+import Data.Binary.Put+ ( Put+ , putByteString+ , putLazyByteString+ , putWord16be+ , putWord32be+ , putWord8+ , runPut+ ) import qualified Data.ByteString as B+import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL-import Data.Binary (put)-import Data.Binary.Put (Put, putWord8, putWord16be, putWord32be, putByteString, putLazyByteString, runPut) import Data.Text.Encoding (encodeUtf8) import Codec.Encryption.OpenPGP.Internal (PktStreamContext(..), pubkeyToMPIs)@@ -29,33 +36,38 @@ import Codec.Encryption.OpenPGP.Types putPKPforFingerprinting :: Pkt -> Put-putPKPforFingerprinting (PublicKeyPkt (PKPayload DeprecatedV3 _ _ _ pk)) = mapM_ putMPIforFingerprinting (pubkeyToMPIs pk)+putPKPforFingerprinting (PublicKeyPkt (PKPayload DeprecatedV3 _ _ _ pk)) =+ mapM_ putMPIforFingerprinting (pubkeyToMPIs pk) putPKPforFingerprinting (PublicKeyPkt pkp@(PKPayload V4 _ _ _ _)) = do- putWord8 0x99- let bs = runPut $ put pkp- putWord16be . fromIntegral $ BL.length bs- putLazyByteString bs-putPKPforFingerprinting _ = fail "This should never happen (putPKPforFingerprinting)"+ putWord8 0x99+ let bs = runPut $ put pkp+ putWord16be . fromIntegral $ BL.length bs+ putLazyByteString bs+putPKPforFingerprinting _ =+ fail "This should never happen (putPKPforFingerprinting)" -putMPIforFingerprinting:: MPI -> Put-putMPIforFingerprinting (MPI i) = let bs = i2osp i in putByteString bs+putMPIforFingerprinting :: MPI -> Put+putMPIforFingerprinting (MPI i) =+ let bs = i2osp i+ in putByteString bs putPartialSigforSigning :: Pkt -> Put putPartialSigforSigning (SignaturePkt (SigV4 st pka ha hashed _ _ _)) = do- putWord8 4- put st- put pka- put ha- let hb = runPut $ mapM_ put hashed- putWord16be . fromIntegral . BL.length $ hb- putLazyByteString hb-putPartialSigforSigning _ = fail "This should never happen (putPartialSigforSigning)"+ putWord8 4+ put st+ put pka+ put ha+ let hb = runPut $ mapM_ put hashed+ putWord16be . fromIntegral . BL.length $ hb+ putLazyByteString hb+putPartialSigforSigning _ =+ fail "This should never happen (putPartialSigforSigning)" putSigTrailer :: Pkt -> Put putSigTrailer (SignaturePkt (SigV4 _ _ _ hs _ _ _)) = do- putWord8 0x04- putWord8 0xff- putWord32be . fromIntegral . (+6) . BL.length $ runPut $ mapM_ put hs+ putWord8 0x04+ putWord8 0xff+ putWord32be . fromIntegral . (+ 6) . BL.length $ runPut $ mapM_ put hs -- this +6 seems like a bug in RFC4880 putSigTrailer _ = fail "This should never happen (putSigTrailer)" @@ -66,26 +78,26 @@ putUIDforSigning :: Pkt -> Put putUIDforSigning (UserIdPkt u) = do- putWord8 0xB4- let bs = encodeUtf8 u- putWord32be . fromIntegral . B.length $ bs- putByteString bs+ putWord8 0xB4+ let bs = encodeUtf8 u+ putWord32be . fromIntegral . B.length $ bs+ putByteString bs putUIDforSigning _ = fail "This should never happen (putUIDforSigning)" putUAtforSigning :: Pkt -> Put putUAtforSigning (UserAttributePkt us) = do- putWord8 0xD1- let bs = runPut (mapM_ put us)- putWord32be . fromIntegral . BL.length $ bs- putLazyByteString bs+ putWord8 0xD1+ let bs = runPut (mapM_ put us)+ putWord32be . fromIntegral . BL.length $ bs+ putLazyByteString bs putUAtforSigning _ = fail "This should never happen (putUAtforSigning)" putSigforSigning :: Pkt -> Put putSigforSigning (SignaturePkt (SigV4 st pka ha hashed _ left16 mpis)) = do- putWord8 0x88- let bs = runPut $ put (SigV4 st pka ha hashed [] left16 mpis)- putWord32be . fromIntegral . BL.length $ bs- putLazyByteString bs+ putWord8 0x88+ let bs = runPut $ put (SigV4 st pka ha hashed [] left16 mpis)+ putWord32be . fromIntegral . BL.length $ bs+ putLazyByteString bs putSigforSigning _ = fail "Non-V4 not implemented." putKeyforSigning :: Pkt -> Put@@ -93,33 +105,44 @@ putKeyforSigning (PublicSubkeyPkt pkp) = putKeyForSigning' pkp putKeyforSigning (SecretKeyPkt pkp _) = putKeyForSigning' pkp putKeyforSigning (SecretSubkeyPkt pkp _) = putKeyForSigning' pkp-putKeyforSigning x = fail ("This should never happen (putKeyforSigning) " ++ show (pktTag x) ++ "/" ++ show x)+putKeyforSigning x =+ fail+ ("This should never happen (putKeyforSigning) " +++ show (pktTag x) ++ "/" ++ show x) putKeyForSigning' :: PKPayload -> Put putKeyForSigning' pkp = do- putWord8 0x99- let bs = runPut $ put pkp- putWord16be . fromIntegral . BL.length $ bs- putLazyByteString bs+ putWord8 0x99+ let bs = runPut $ put pkp+ putWord16be . fromIntegral . BL.length $ bs+ putLazyByteString bs payloadForSig :: SigType -> PktStreamContext -> ByteString-payloadForSig BinarySig state = fromPkt (lastLD state)^.literalDataPayload+payloadForSig BinarySig state = fromPkt (lastLD state) ^. literalDataPayload payloadForSig CanonicalTextSig state = payloadForSig BinarySig state payloadForSig StandaloneSig _ = BL.empty-payloadForSig GenericCert state = kandUPayload (lastPrimaryKey state) (lastUIDorUAt state)+payloadForSig GenericCert state =+ kandUPayload (lastPrimaryKey state) (lastUIDorUAt state) payloadForSig PersonaCert state = payloadForSig GenericCert state payloadForSig CasualCert state = payloadForSig GenericCert state payloadForSig PositiveCert state = payloadForSig GenericCert state-payloadForSig SubkeyBindingSig state = kandKPayload (lastPrimaryKey state) (lastSubkey state) -- FIXME: embedded primary key binding sig should be verified as well-payloadForSig PrimaryKeyBindingSig state = kandKPayload (lastPrimaryKey state) (lastSubkey state)-payloadForSig SignatureDirectlyOnAKey state = runPut (putKeyforSigning (lastPrimaryKey state))-payloadForSig KeyRevocationSig state = payloadForSig SignatureDirectlyOnAKey state-payloadForSig SubkeyRevocationSig state = kandKPayload (lastPrimaryKey state) (lastSubkey state)-payloadForSig CertRevocationSig state = kandUPayload (lastPrimaryKey state) (lastUIDorUAt state) -- FIXME: this doesn't handle revocation of direct key signatures+payloadForSig SubkeyBindingSig state =+ kandKPayload (lastPrimaryKey state) (lastSubkey state) -- FIXME: embedded primary key binding sig should be verified as well+payloadForSig PrimaryKeyBindingSig state =+ kandKPayload (lastPrimaryKey state) (lastSubkey state)+payloadForSig SignatureDirectlyOnAKey state =+ runPut (putKeyforSigning (lastPrimaryKey state))+payloadForSig KeyRevocationSig state =+ payloadForSig SignatureDirectlyOnAKey state+payloadForSig SubkeyRevocationSig state =+ kandKPayload (lastPrimaryKey state) (lastSubkey state)+payloadForSig CertRevocationSig state =+ kandUPayload (lastPrimaryKey state) (lastUIDorUAt state) -- FIXME: this doesn't handle revocation of direct key signatures payloadForSig st _ = error ("I dunno how to " ++ show st) kandUPayload :: Pkt -> Pkt -> ByteString kandUPayload k u = runPut (sequence_ [putKeyforSigning k, putUforSigning u]) kandKPayload :: Pkt -> Pkt -> ByteString-kandKPayload k1 k2 = runPut (sequence_ [putKeyforSigning k1, putKeyforSigning k2])+kandKPayload k1 k2 =+ runPut (sequence_ [putKeyforSigning k1, putKeyforSigning k2])
Codec/Encryption/OpenPGP/SignatureQualities.hs view
@@ -2,13 +2,12 @@ -- Copyright © 2012-2019 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).--module Codec.Encryption.OpenPGP.SignatureQualities (- sigType- , sigPKA- , sigHA- , sigCT-) where+module Codec.Encryption.OpenPGP.SignatureQualities+ ( sigType+ , sigPKA+ , sigHA+ , sigCT+ ) where import Data.List (find) @@ -32,5 +31,8 @@ sigCT :: SignaturePayload -> Maybe ThirtyTwoBitTimeStamp sigCT (SigV3 _ ct _ _ _ _ _) = Just ct-sigCT (SigV4 _ _ _ hsubs _ _ _) = fmap (\(SigSubPacket _ (SigCreationTime i)) -> i) (find isSigCreationTime hsubs)+sigCT (SigV4 _ _ _ hsubs _ _ _) =+ fmap+ (\(SigSubPacket _ (SigCreationTime i)) -> i)+ (find isSigCreationTime hsubs) sigCT _ = Nothing
Codec/Encryption/OpenPGP/Signatures.hs view
@@ -2,16 +2,15 @@ -- Copyright © 2012-2019 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).--module Codec.Encryption.OpenPGP.Signatures (- verifySigWith- , verifyAgainstKeyring- , verifyAgainstKeys- , verifyTKWith- , signUserIDwithRSA- , crossSignSubkeyWithRSA- , signDataWithRSA-) where+module Codec.Encryption.OpenPGP.Signatures+ ( verifySigWith+ , verifyAgainstKeyring+ , verifyAgainstKeys+ , verifyTKWith+ , signUserIDwithRSA+ , crossSignSubkeyWithRSA+ , signDataWithRSA+ ) where import Control.Error.Util (hush) import Control.Lens ((^.), _1)@@ -28,6 +27,7 @@ import qualified Crypto.PubKey.RSA.Types as RSATypes import Data.Bifunctor (first)+import Data.Binary.Put (runPut) import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Data.ByteString.Lazy (ByteString)@@ -41,177 +41,415 @@ import Data.Text (Text) import Data.Time.Clock (UTCTime(..), diffUTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime)-import Data.Binary.Put (runPut) import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)-import Codec.Encryption.OpenPGP.Internal (PktStreamContext(..), issuer, emptyPSC)-import Codec.Encryption.OpenPGP.Ontology (isRevokerP, isRevocationKeySSP, isSubkeyBindingSig, isSubkeyRevocation)+import Codec.Encryption.OpenPGP.Internal+ ( PktStreamContext(..)+ , emptyPSC+ , issuer+ )+import Codec.Encryption.OpenPGP.Ontology+ ( isRevocationKeySSP+ , isRevokerP+ , isSubkeyBindingSig+ , isSubkeyRevocation+ ) -import Codec.Encryption.OpenPGP.SerializeForSigs (putPartialSigforSigning, putSigTrailer, payloadForSig, putKeyforSigning, putUforSigning)+import Codec.Encryption.OpenPGP.SerializeForSigs+ ( payloadForSig+ , putKeyforSigning+ , putPartialSigforSigning+ , putSigTrailer+ , putUforSigning+ ) import Codec.Encryption.OpenPGP.Types import Data.Conduit.OpenPGP.Keyring.Instances () -verifySigWith :: (Pkt -> Maybe UTCTime -> ByteString -> Either String Verification) -> Pkt -> PktStreamContext -> Maybe UTCTime -> Either String Verification -- FIXME: check expiration here?+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 (v^.verificationSigner)) . _sspPayload) hs- return v- where- 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+ v <- vf sig mt (payloadForSig st state)+ _ <-+ mapM_+ (checkIssuer (eightOctetKeyID (v ^. verificationSigner)) . _sspPayload)+ hs+ return v+ where+ 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)." -verifyTKWith :: (Pkt -> PktStreamContext -> Maybe UTCTime -> Either String Verification) -> Maybe UTCTime -> TK -> Either String TK+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 (not . null . snd) . checkUidSigs $ key^.tkUIDs -- FIXME: check revocations here?- let uats = filter (not . null . snd) . checkUAtSigs $ key^.tkUAts -- FIXME: check revocations here?- let subs = concatMap checkSub $ key^.tkSubs -- FIXME: check revocations here?- return (TK (key^.tkKey) revs uids uats subs)- 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) $ k^.tkRevs- checkUidSigs :: [(Text, [SignaturePayload])] -> [(Text, [SignaturePayload])]- 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 (uat, sp)))) sps))- checkSub :: (Pkt, [SignaturePayload]) -> [(Pkt, [SignaturePayload])]- checkSub (pkt, sps) = if revokedSub pkt sps then [] else checkSub' pkt sps- revokedSub :: Pkt -> [SignaturePayload] -> Bool- revokedSub _ [] = False- revokedSub p sigs = any (vSubSig p) (filter isSubkeyRevocation sigs)- checkSub' :: Pkt -> [SignaturePayload] -> [(Pkt, [SignaturePayload])]- checkSub' p sps = let goodsigs = filter (vSubSig p) (filter isSubkeyBindingSig sps) in if null goodsigs then [] else [(p, goodsigs)]- getHasheds (SigV4 _ _ _ ha _ _ _) = ha- getHasheds _ = []- filterRevs :: [(PubKeyAlgorithm, TwentyOctetFingerprint)] -> (SignaturePayload, Verification) -> [Either String SignaturePayload]- filterRevs vokers spv = case spv of- (s@(SigV4 SignatureDirectlyOnAKey _ _ _ _ _ _), _) -> [Right s]- (s@(SigV4 KeyRevocationSig pka _ _ _ _ _), v) -> if (v^.verificationSigner == key ^. tkKey._1) || any (\(p,f) -> p == pka && f == fingerprint (v^.verificationSigner)) vokers then [Left "Key revoked"] else [Right s]- _ -> []- vUid :: (Text, SignaturePayload) -> Either String Verification- vUid (uid, sp) = vsf (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (key ^. tkKey._1), lastUIDorUAt = UserIdPkt uid } mt- vUAt :: ([UserAttrSubPacket], SignaturePayload) -> Either String Verification- vUAt (uat, sp) = vsf (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (key ^. tkKey._1), lastUIDorUAt = UserAttributePkt uat } mt- vSig :: SignaturePayload -> Either String Verification- vSig sp = vsf (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (key ^. tkKey._1) } mt- vSubSig :: Pkt -> SignaturePayload -> Bool- vSubSig sk sp = isRight (vsf (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (key ^. tkKey._1), lastSubkey = sk} mt)- verifyRevoker :: SignaturePayload -> Either String [(PubKeyAlgorithm, TwentyOctetFingerprint)]- verifyRevoker sp = do- _ <- vSig sp- return (map (\(SigSubPacket _ (RevocationKey _ pka fp)) -> (pka, fp)) . filter isRevocationKeySSP $ getHasheds sp)+ revokers <- checkRevokers key+ revs <- checkKeyRevocations revokers key+ let uids = filter (not . null . snd) . checkUidSigs $ key ^. tkUIDs -- FIXME: check revocations here?+ let uats = filter (not . null . snd) . checkUAtSigs $ key ^. tkUAts -- FIXME: check revocations here?+ let subs = concatMap checkSub $ key ^. tkSubs -- FIXME: check revocations here?+ return (TK (key ^. tkKey) revs uids uats subs)+ 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) $+ k ^.+ tkRevs+ checkUidSigs :: [(Text, [SignaturePayload])] -> [(Text, [SignaturePayload])]+ 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 (uat, sp)))) sps))+ checkSub :: (Pkt, [SignaturePayload]) -> [(Pkt, [SignaturePayload])]+ checkSub (pkt, sps) =+ if revokedSub pkt sps+ then []+ else checkSub' pkt sps+ revokedSub :: Pkt -> [SignaturePayload] -> Bool+ revokedSub _ [] = False+ revokedSub p sigs = any (vSubSig p) (filter isSubkeyRevocation sigs)+ checkSub' :: Pkt -> [SignaturePayload] -> [(Pkt, [SignaturePayload])]+ checkSub' p sps =+ let goodsigs = filter (vSubSig p) (filter isSubkeyBindingSig sps)+ in if null goodsigs+ then []+ else [(p, goodsigs)]+ getHasheds (SigV4 _ _ _ ha _ _ _) = ha+ getHasheds _ = []+ filterRevs ::+ [(PubKeyAlgorithm, TwentyOctetFingerprint)]+ -> (SignaturePayload, Verification)+ -> [Either String SignaturePayload]+ filterRevs vokers spv =+ case spv of+ (s@(SigV4 SignatureDirectlyOnAKey _ _ _ _ _ _), _) -> [Right s]+ (s@(SigV4 KeyRevocationSig pka _ _ _ _ _), v) ->+ if (v ^. verificationSigner == key ^. tkKey . _1) ||+ any+ (\(p, f) ->+ p == pka && f == fingerprint (v ^. verificationSigner))+ vokers+ then [Left "Key revoked"]+ else [Right s]+ _ -> []+ vUid :: (Text, SignaturePayload) -> Either String Verification+ vUid (uid, sp) =+ vsf+ (SignaturePkt sp)+ emptyPSC+ { lastPrimaryKey = PublicKeyPkt (key ^. tkKey . _1)+ , lastUIDorUAt = UserIdPkt uid+ }+ mt+ vUAt ::+ ([UserAttrSubPacket], SignaturePayload) -> Either String Verification+ vUAt (uat, sp) =+ vsf+ (SignaturePkt sp)+ emptyPSC+ { lastPrimaryKey = PublicKeyPkt (key ^. tkKey . _1)+ , lastUIDorUAt = UserAttributePkt uat+ }+ mt+ vSig :: SignaturePayload -> Either String Verification+ vSig sp =+ vsf+ (SignaturePkt sp)+ emptyPSC {lastPrimaryKey = PublicKeyPkt (key ^. tkKey . _1)}+ mt+ vSubSig :: Pkt -> SignaturePayload -> Bool+ vSubSig sk sp =+ isRight+ (vsf+ (SignaturePkt sp)+ emptyPSC+ { lastPrimaryKey = PublicKeyPkt (key ^. tkKey . _1)+ , lastSubkey = sk+ }+ mt)+ verifyRevoker ::+ SignaturePayload+ -> Either String [(PubKeyAlgorithm, TwentyOctetFingerprint)]+ verifyRevoker sp = do+ _ <- vSig sp+ return+ (map (\(SigSubPacket _ (RevocationKey _ pka fp)) -> (pka, fp)) .+ filter isRevocationKeySSP $+ getHasheds sp) -verifyAgainstKeyring :: Keyring -> Pkt -> Maybe UTCTime -> ByteString -> Either String Verification+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)- verifyAgainstKeys (IxSet.toList potentialmatches) sig mt payload+ i <- maybe (Left "issuer not found") Right (issuer sig)+ potentialmatches <-+ if IxSet.null (kr @= i)+ then Left "pubkey not found"+ else Right (kr @= i)+ verifyAgainstKeys (IxSet.toList potentialmatches) sig mt payload -verifyAgainstKeys :: [TK] -> Pkt -> Maybe UTCTime -> ByteString -> Either String Verification+verifyAgainstKeys ::+ [TK] -> Pkt -> Maybe UTCTime -> ByteString -> Either String Verification verifyAgainstKeys ks sig mt payload = do- 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) (BL.toStrict (finalPayload sig payload))) allrelevantpkps- case rights results of- [] -> Left (concatMap (++"/") (lefts results))- [r] -> do _ <- isSignatureExpired sig mt- return (Verification r ((_signaturePayload . fromPkt) sig)) -- FIXME: this should also check expiration time and flags of the signing key- _ -> Left "multiple successes; unexpected condition"- where- subPKP (pack, _) = subPKP' pack- 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'' (pkaAndMPIs s) CHA.SHA1 pub pkey 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'' (pkaAndMPIs s) CHA.SHA256 pub pkey 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'' (pkaAndMPIs s) CHA.SHA512 pub pkey 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'' (pkaAndMPIs s) CHA.MD5 pub pkey pl- verify' _ _ _ _ = error "This should never happen (verify')."- verify'' (DSA,mpis) hd pub (DSAPubKey (DSA_PublicKey pkey)) bs = dsaVerify pub mpis hd pkey bs- verify'' (ECDSA,mpis) hd pub (ECDSAPubKey (ECDSA_PublicKey pkey)) bs = ecdsaVerify pub mpis hd pkey bs- verify'' (EdDSA,mpis) hd pub (EdDSAPubKey Ed25519 pkey) bs = ed25519Verify pub mpis hd (i2osp (unEPoint pkey)) bs- verify'' (RSA,mpis) hd pub (RSAPubKey (RSA_PublicKey pkey)) bs = rsaVerify pub mpis hd pkey bs- verify'' _ _ _ _ _ = Left "unimplemented key type"- dsaVerify pub (r:|[s]) hd pkey bs = if DSA.verify hd pkey (dsaMPIsToSig r s) bs then Right pub else Left ("DSA verification failed: " ++ show (hd,pkey,r,s,bs))- dsaVerify _ _ _ _ _ = Left "cannot verify DSA signature of wrong shape"- ecdsaVerify pub (r:|[s]) hd pkey bs = if ECDSA.verify hd pkey (ecdsaMPIsToSig r s) bs then Right pub else Left ("ECDSA verification failed: " ++ show (hd,pkey,r,s,bs))- ecdsaVerify _ _ _ _ _ = Left "cannot verify ECDSA signature of wrong shape"- ed25519Verify pub (r:|[s]) hd pkey bs = either (Left . (("Ed25519 verification failed: " ++ show (hd,pkey,r,s,bs) ++ ": ")++) . show) return $ do- ep <- cf2es (Ed25519.publicKey (B.drop 1 pkey)) -- drop the 0x40- es <- cf2es (Ed25519.signature ((B.append `on` i2osp . unMPI) r s))- let prehash = crazyHash hd bs :: B.ByteString- if Ed25519.verify ep prehash es then Right pub else Left ("does not verify")- ed25519Verify _ _ _ _ _ = Left "cannot verify Ed25519 signature of wrong shape"- cf2es = either (Left . show) return . eitherCryptoError- rsaVerify pub mpis hd pkey bs = if P15.verify (Just hd) pkey bs (rsaMPItoSig mpis) then Right pub else Left ("DSA verification failed: " ++ show (hd,pkey,mpis,bs))- dsaMPIsToSig r s = DSA.Signature (unMPI r) (unMPI s)- ecdsaMPIsToSig r s = ECDSA.Signature (unMPI r) (unMPI s)- rsaMPItoSig (s:|[]) = i2osp (unMPI s)- hashalgo :: Pkt -> HashAlgorithm- hashalgo (SignaturePkt (SigV4 _ _ ha _ _ _ _)) = ha- hashalgo _ = error "This should never happen (hashalgo)."- pkaAndMPIs (SigV4 _ pka _ _ _ _ mpis) = (pka,mpis)- pkaAndMPIs _ = error "This should never happen (pkaAndMPIs)."- isSignatureExpired :: Pkt -> Maybe UTCTime -> Either String Bool- isSignatureExpired _ Nothing = return False- isSignatureExpired s (Just t) = if any (expiredBefore t) ((\(SigV4 _ _ _ h _ _ _) -> h) . _signaturePayload . fromPkt $ s) then Left "signature expired" else return True- expiredBefore :: UTCTime -> SigSubPacket -> Bool- expiredBefore ct (SigSubPacket _ (SigExpirationTime et)) = fromEnum ((posixSecondsToUTCTime . toEnum . fromEnum) et `diffUTCTime` ct) < 0- expiredBefore _ _ = False- crazyHash h = BA.convert . hashWith h+ 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)+ (BL.toStrict (finalPayload sig payload)))+ allrelevantpkps+ case rights results of+ [] -> Left (concatMap (++ "/") (lefts results))+ [r] -> do+ _ <- isSignatureExpired sig mt+ return (Verification r ((_signaturePayload . fromPkt) sig)) -- FIXME: this should also check expiration time and flags of the signing key+ _ -> Left "multiple successes; unexpected condition"+ where+ subPKP (pack, _) = subPKP' pack+ 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'' (pkaAndMPIs s) CHA.SHA1 pub pkey 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'' (pkaAndMPIs s) CHA.SHA256 pub pkey 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'' (pkaAndMPIs s) CHA.SHA512 pub pkey 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'' (pkaAndMPIs s) CHA.MD5 pub pkey pl+ verify' _ _ _ _ = error "This should never happen (verify')."+ verify'' (DSA, mpis) hd pub (DSAPubKey (DSA_PublicKey pkey)) bs =+ dsaVerify pub mpis hd pkey bs+ verify'' (ECDSA, mpis) hd pub (ECDSAPubKey (ECDSA_PublicKey pkey)) bs =+ ecdsaVerify pub mpis hd pkey bs+ verify'' (EdDSA, mpis) hd pub (EdDSAPubKey Ed25519 pkey) bs =+ ed25519Verify pub mpis hd (i2osp (unEPoint pkey)) bs+ verify'' (RSA, mpis) hd pub (RSAPubKey (RSA_PublicKey pkey)) bs =+ rsaVerify pub mpis hd pkey bs+ verify'' _ _ _ _ _ = Left "unimplemented key type"+ dsaVerify pub (r :| [s]) hd pkey bs =+ if DSA.verify hd pkey (dsaMPIsToSig r s) bs+ then Right pub+ else Left ("DSA verification failed: " ++ show (hd, pkey, r, s, bs))+ dsaVerify _ _ _ _ _ = Left "cannot verify DSA signature of wrong shape"+ ecdsaVerify pub (r :| [s]) hd pkey bs =+ if ECDSA.verify hd pkey (ecdsaMPIsToSig r s) bs+ then Right pub+ else Left ("ECDSA verification failed: " ++ show (hd, pkey, r, s, bs))+ ecdsaVerify _ _ _ _ _ = Left "cannot verify ECDSA signature of wrong shape"+ ed25519Verify pub (r :| [s]) hd pkey bs =+ either+ (Left .+ (("Ed25519 verification failed: " ++ show (hd, pkey, r, s, bs) ++ ": ") ++) .+ show)+ return $ do+ ep <- cf2es (Ed25519.publicKey (B.drop 1 pkey)) -- drop the 0x40+ es <- cf2es (Ed25519.signature ((B.append `on` i2osp . unMPI) r s))+ let prehash = crazyHash hd bs :: B.ByteString+ if Ed25519.verify ep prehash es+ then Right pub+ else Left ("does not verify")+ ed25519Verify _ _ _ _ _ =+ Left "cannot verify Ed25519 signature of wrong shape"+ cf2es = either (Left . show) return . eitherCryptoError+ rsaVerify pub mpis hd pkey bs =+ if P15.verify (Just hd) pkey bs (rsaMPItoSig mpis)+ then Right pub+ else Left ("DSA verification failed: " ++ show (hd, pkey, mpis, bs))+ dsaMPIsToSig r s = DSA.Signature (unMPI r) (unMPI s)+ ecdsaMPIsToSig r s = ECDSA.Signature (unMPI r) (unMPI s)+ rsaMPItoSig (s :| []) = i2osp (unMPI s)+ hashalgo :: Pkt -> HashAlgorithm+ hashalgo (SignaturePkt (SigV4 _ _ ha _ _ _ _)) = ha+ hashalgo _ = error "This should never happen (hashalgo)."+ pkaAndMPIs (SigV4 _ pka _ _ _ _ mpis) = (pka, mpis)+ pkaAndMPIs _ = error "This should never happen (pkaAndMPIs)."+ isSignatureExpired :: Pkt -> Maybe UTCTime -> Either String Bool+ isSignatureExpired _ Nothing = return False+ isSignatureExpired s (Just t) =+ if any+ (expiredBefore t)+ ((\(SigV4 _ _ _ h _ _ _) -> h) . _signaturePayload . fromPkt $ s)+ then Left "signature expired"+ else return True+ expiredBefore :: UTCTime -> SigSubPacket -> Bool+ expiredBefore ct (SigSubPacket _ (SigExpirationTime et)) =+ fromEnum ((posixSecondsToUTCTime . toEnum . fromEnum) et `diffUTCTime` ct) <+ 0+ expiredBefore _ _ = False+ crazyHash h = BA.convert . hashWith h finalPayload :: Pkt -> ByteString -> ByteString finalPayload s pl = BL.concat [pl, sigbit, trailer s]- where- sigbit = runPut $ putPartialSigforSigning s- trailer :: Pkt -> ByteString- trailer (SignaturePkt SigV4{}) = runPut $ putSigTrailer s- trailer _ = BL.empty+ where+ sigbit = runPut $ putPartialSigforSigning s+ trailer :: Pkt -> ByteString+ trailer (SignaturePkt SigV4 {}) = runPut $ putSigTrailer s+ trailer _ = BL.empty -signUserIDwithRSA :: PKPayload -- ^ public key "payload" of user ID being signed- -> UserId -- ^ user ID being signed- -> [SigSubPacket] -- ^ hashed signature subpackets- -> [SigSubPacket] -- ^ unhashed signature subpackets- -> RSATypes.PrivateKey -- ^ RSA signing key- -> Either String SignaturePayload+signUserIDwithRSA ::+ PKPayload -- ^ public key "payload" of user ID being signed+ -> UserId -- ^ user ID being signed+ -> [SigSubPacket] -- ^ hashed signature subpackets+ -> [SigSubPacket] -- ^ unhashed signature subpackets+ -> RSATypes.PrivateKey -- ^ RSA signing key+ -> Either String SignaturePayload signUserIDwithRSA pkp uid hsigsubs usigsubs prv = do- uidsig <- first show (P15.sign Nothing (Just CHA.SHA512) prv (BL.toStrict (finalPayload (SignaturePkt uidsigp) uidpayload)))- return (uidsigp' uidsig)- where- uidpayload = runPut (sequence_ [putKeyforSigning (PublicKeyPkt pkp), putUforSigning (toPkt uid)])- uidsigp = SigV4 PositiveCert RSA SHA512 hsigsubs usigsubs 0 (NE.fromList [MPI 0])- uidsigp' us = SigV4 PositiveCert RSA SHA512 hsigsubs usigsubs (fromIntegral (os2ip (B.take 2 us))) (NE.fromList [MPI (os2ip us)])+ uidsig <-+ first+ show+ (P15.sign+ Nothing+ (Just CHA.SHA512)+ prv+ (BL.toStrict (finalPayload (SignaturePkt uidsigp) uidpayload)))+ return (uidsigp' uidsig)+ where+ uidpayload =+ runPut+ (sequence_+ [putKeyforSigning (PublicKeyPkt pkp), putUforSigning (toPkt uid)])+ uidsigp =+ SigV4 PositiveCert RSA SHA512 hsigsubs usigsubs 0 (NE.fromList [MPI 0])+ uidsigp' us =+ SigV4+ PositiveCert+ RSA+ SHA512+ hsigsubs+ usigsubs+ (fromIntegral (os2ip (B.take 2 us)))+ (NE.fromList [MPI (os2ip us)]) -crossSignSubkeyWithRSA :: PKPayload -- ^ public key "payload" of key being signed- -> PKPayload -- ^ public subkey "payload" of key being signed- -> [SigSubPacket] -- ^ hashed signature subpackets for binding sig- -> [SigSubPacket] -- ^ unhashed signature subpackets for binding sig- -> [SigSubPacket] -- ^ hashed signature subpackets for embedded sig- -> [SigSubPacket] -- ^ unhashed signature subpackets for embedded sig- -> RSATypes.PrivateKey -- ^ RSA signing key- -> RSATypes.PrivateKey -- ^ RSA signing subkey- -> Either String SignaturePayload+crossSignSubkeyWithRSA ::+ PKPayload -- ^ public key "payload" of key being signed+ -> PKPayload -- ^ public subkey "payload" of key being signed+ -> [SigSubPacket] -- ^ hashed signature subpackets for binding sig+ -> [SigSubPacket] -- ^ unhashed signature subpackets for binding sig+ -> [SigSubPacket] -- ^ hashed signature subpackets for embedded sig+ -> [SigSubPacket] -- ^ unhashed signature subpackets for embedded sig+ -> RSATypes.PrivateKey -- ^ RSA signing key+ -> RSATypes.PrivateKey -- ^ RSA signing subkey+ -> Either String SignaturePayload crossSignSubkeyWithRSA pkp subpkp subhsigsubs subusigsubs embhsigsubs embusigsubs prv ssb = do- embsig <- first show (P15.sign Nothing (Just CHA.SHA512) ssb (BL.toStrict (finalPayload (SignaturePkt embsigp) subkeypayload)))- subsig <- first show (P15.sign Nothing (Just CHA.SHA512) prv (BL.toStrict (finalPayload (SignaturePkt subsigp) subkeypayload)))- return (subsigp' (embsigp' embsig) subsig)- where- subkeypayload = runPut (sequence_ [putKeyforSigning (PublicKeyPkt pkp), putKeyforSigning (PublicSubkeyPkt subpkp)])- embsigp = SigV4 PrimaryKeyBindingSig RSA SHA512 embhsigsubs embusigsubs 0 (NE.fromList [MPI 0])- embsigp' es = SigV4 PrimaryKeyBindingSig RSA SHA512 embhsigsubs embusigsubs (fromIntegral (os2ip (B.take 2 es))) (NE.fromList [MPI (os2ip es)])- subsigp = SigV4 SubkeyBindingSig RSA SHA512 subhsigsubs [] 0 (NE.fromList [MPI 0])- sspes es = SigSubPacket False (EmbeddedSignature es)- subsigp' es ss = SigV4 SubkeyBindingSig RSA SHA512 subhsigsubs (sspes es:subusigsubs) (fromIntegral (os2ip (B.take 2 ss))) (NE.fromList [MPI (os2ip ss)])+ embsig <-+ first+ show+ (P15.sign+ Nothing+ (Just CHA.SHA512)+ ssb+ (BL.toStrict (finalPayload (SignaturePkt embsigp) subkeypayload)))+ subsig <-+ first+ show+ (P15.sign+ Nothing+ (Just CHA.SHA512)+ prv+ (BL.toStrict (finalPayload (SignaturePkt subsigp) subkeypayload)))+ return (subsigp' (embsigp' embsig) subsig)+ where+ subkeypayload =+ runPut+ (sequence_+ [ putKeyforSigning (PublicKeyPkt pkp)+ , putKeyforSigning (PublicSubkeyPkt subpkp)+ ])+ embsigp =+ SigV4+ PrimaryKeyBindingSig+ RSA+ SHA512+ embhsigsubs+ embusigsubs+ 0+ (NE.fromList [MPI 0])+ embsigp' es =+ SigV4+ PrimaryKeyBindingSig+ RSA+ SHA512+ embhsigsubs+ embusigsubs+ (fromIntegral (os2ip (B.take 2 es)))+ (NE.fromList [MPI (os2ip es)])+ subsigp =+ SigV4 SubkeyBindingSig RSA SHA512 subhsigsubs [] 0 (NE.fromList [MPI 0])+ sspes es = SigSubPacket False (EmbeddedSignature es)+ subsigp' es ss =+ SigV4+ SubkeyBindingSig+ RSA+ SHA512+ subhsigsubs+ (sspes es : subusigsubs)+ (fromIntegral (os2ip (B.take 2 ss)))+ (NE.fromList [MPI (os2ip ss)]) -signDataWithRSA :: SigType -> RSATypes.PrivateKey -> [SigSubPacket] -> [SigSubPacket] -> ByteString -> Either String SignaturePayload-signDataWithRSA st prv has uhas payload = sp st <$> first show (P15.sign Nothing (Just CHA.SHA512) prv (BL.toStrict (finalPayload (SignaturePkt (sp0 st)) payload)))- where- sp0 st = SigV4 st RSA SHA512 has [] 0 (NE.fromList [MPI 0])- sp st ss = SigV4 st RSA SHA512 has uhas (fromIntegral (os2ip (B.take 2 ss))) (NE.fromList [MPI (os2ip ss)])+signDataWithRSA ::+ SigType+ -> RSATypes.PrivateKey+ -> [SigSubPacket]+ -> [SigSubPacket]+ -> ByteString+ -> Either String SignaturePayload+signDataWithRSA st prv has uhas payload =+ sp st <$>+ first+ show+ (P15.sign+ Nothing+ (Just CHA.SHA512)+ prv+ (BL.toStrict (finalPayload (SignaturePkt (sp0 st)) payload)))+ where+ sp0 st = SigV4 st RSA SHA512 has [] 0 (NE.fromList [MPI 0])+ sp st ss =+ SigV4+ st+ RSA+ SHA512+ has+ uhas+ (fromIntegral (os2ip (B.take 2 ss)))+ (NE.fromList [MPI (os2ip ss)])
Codec/Encryption/OpenPGP/Types.hs view
@@ -2,12 +2,13 @@ -- Copyright © 2012-2016 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).--module Codec.Encryption.OpenPGP.Types (module X) where+module Codec.Encryption.OpenPGP.Types+ ( module X+ ) where import Codec.Encryption.OpenPGP.Types.Internal.Base as X import Codec.Encryption.OpenPGP.Types.Internal.CryptoniteNewtypes as X-import Codec.Encryption.OpenPGP.Types.Internal.PacketClass as X import Codec.Encryption.OpenPGP.Types.Internal.PKITypes as X+import Codec.Encryption.OpenPGP.Types.Internal.PacketClass as X import Codec.Encryption.OpenPGP.Types.Internal.Pkt as X import Codec.Encryption.OpenPGP.Types.Internal.TK as X
Codec/Encryption/OpenPGP/Types/Internal/Base.hs view
@@ -2,1042 +2,1249 @@ -- Copyright © 2012-2018 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).--{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TemplateHaskell #-}--module Codec.Encryption.OpenPGP.Types.Internal.Base where--import GHC.Generics (Generic)--import Control.Applicative ((<|>))-import Control.Arrow ((***))-import Control.Lens (makeLenses)-import Control.Monad (mzero)-import Control.Newtype (Newtype(..))-import Data.Aeson ((.=), object)-import qualified Data.Aeson as A-import qualified Data.Aeson.TH as ATH-import Data.ByteArray (ByteArrayAccess)-import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString as B-import qualified Data.ByteString.Base16.Lazy as B16L-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(..))-import Data.List (unfoldr)-import Data.List.NonEmpty (NonEmpty)-import qualified Data.List.NonEmpty as NE-import Data.List.Split (chunksOf)-import Data.Maybe (fromMaybe)-import Data.Monoid ((<>))-import Data.Ord (comparing)-import Data.Semigroup (Semigroup)-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Text (Text)-import qualified Data.Text as T-import Data.Time.Clock.POSIX (posixSecondsToUTCTime)-import Data.Time.Format (formatTime)-import Data.Typeable (Typeable)-import Data.Word (Word8, Word16, Word32)-import Network.URI (URI(..), uriToString, nullURI, parseURI)-import Numeric (readHex)-import Data.Time.Locale.Compat (defaultTimeLocale)-import Data.Text.Prettyprint.Doc (Pretty(..), (<+>), hsep, punctuate, space)-import Codec.Encryption.OpenPGP.Types.Internal.PrettyUtils (prettyLBS)---type Exportability = Bool-type TrustLevel = Word8-type TrustAmount = Word8-type AlmostPublicDomainRegex = ByteString-type Revocability = Bool-type RevocationReason = Text-type KeyServer = ByteString-type SignatureHash = ByteString-type PacketVersion = Word8-type V3Expiration = Word16-type CompressedDataPayload = ByteString-type FileName = ByteString-type ImageData = ByteString-type NestedFlag = Bool--class (Eq a, Ord a) => FutureFlag a where- fromFFlag :: a -> Int- toFFlag :: Int -> a--class (Eq a, Ord a) => FutureVal a where- fromFVal :: a -> Word8- toFVal :: Word8 -> a--data SymmetricAlgorithm = Plaintext- | IDEA- | TripleDES- | CAST5- | Blowfish- | ReservedSAFER- | ReservedDES- | AES128- | AES192- | AES256- | Twofish- | Camellia128- | Camellia192- | Camellia256- | OtherSA Word8- deriving (Data, Generic, Show, Typeable)--instance Eq SymmetricAlgorithm where- (==) a b = fromFVal a == fromFVal b--instance Ord SymmetricAlgorithm where- compare = comparing fromFVal--instance FutureVal SymmetricAlgorithm where- fromFVal Plaintext = 0- fromFVal IDEA = 1- fromFVal TripleDES = 2- fromFVal CAST5 = 3- fromFVal Blowfish = 4- fromFVal ReservedSAFER = 5- fromFVal ReservedDES = 6- fromFVal AES128 = 7- fromFVal AES192 = 8- fromFVal AES256 = 9- fromFVal Twofish = 10- fromFVal Camellia128 = 11- fromFVal Camellia192 = 12- fromFVal Camellia256 = 13- fromFVal (OtherSA o) = o- toFVal 0 = Plaintext- toFVal 1 = IDEA- toFVal 2 = TripleDES- toFVal 3 = CAST5- toFVal 4 = Blowfish- toFVal 5 = ReservedSAFER- toFVal 6 = ReservedDES- toFVal 7 = AES128- toFVal 8 = AES192- toFVal 9 = AES256- toFVal 10 = Twofish- toFVal 11 = Camellia128- toFVal 12 = Camellia192- toFVal 13 = Camellia256- toFVal o = OtherSA o--instance Hashable SymmetricAlgorithm--instance Pretty SymmetricAlgorithm where- pretty Plaintext = pretty "plaintext"- pretty IDEA = pretty "IDEA"- pretty TripleDES = pretty "3DES"- pretty CAST5 = pretty "CAST-128"- pretty Blowfish = pretty "Blowfish"- pretty ReservedSAFER = pretty "(reserved) SAFER"- pretty ReservedDES = pretty "(reserved) DES"- pretty AES128 = pretty "AES-128"- pretty AES192 = pretty "AES-192"- pretty AES256 = pretty "AES-256"- pretty Twofish = pretty "Twofish"- pretty Camellia128 = pretty "Camellia-128"- pretty Camellia192 = pretty "Camellia-192"- pretty Camellia256 = pretty "Camellia-256"- pretty (OtherSA sa) = pretty "unknown symmetric algorithm" <+> pretty sa--$(ATH.deriveJSON ATH.defaultOptions ''SymmetricAlgorithm)--data NotationFlag = HumanReadable- | OtherNF Word8 -- FIXME: this should be constrained to 4 bits?- deriving (Data, Generic, Show, Typeable)--instance Eq NotationFlag where- (==) a b = fromFFlag a == fromFFlag b--instance Ord NotationFlag where- compare = comparing fromFFlag--instance FutureFlag NotationFlag where- fromFFlag HumanReadable = 0- fromFFlag (OtherNF o) = fromIntegral o-- toFFlag 0 = HumanReadable- toFFlag o = OtherNF (fromIntegral o)--instance Hashable NotationFlag--instance Pretty NotationFlag where- pretty HumanReadable = pretty "human-readable"- pretty (OtherNF o) = pretty "unknown notation flag type" <+> pretty o--$(ATH.deriveJSON ATH.defaultOptions ''NotationFlag)--newtype ThirtyTwoBitTimeStamp = ThirtyTwoBitTimeStamp {unThirtyTwoBitTimeStamp :: Word32}- deriving (Bounded, Data, Enum, Eq, Generic, Hashable, Integral, Num, Ord, Real, Show, Typeable)--instance Newtype ThirtyTwoBitTimeStamp Word32 where- pack = ThirtyTwoBitTimeStamp- unpack (ThirtyTwoBitTimeStamp o) = o--instance Pretty ThirtyTwoBitTimeStamp where- pretty = pretty . formatTime defaultTimeLocale "%Y%m%d-%H%M%S" . posixSecondsToUTCTime . realToFrac--$(ATH.deriveJSON ATH.defaultOptions ''ThirtyTwoBitTimeStamp)--durU :: (Integral a, Show a) => a -> Maybe (String, a)-durU x- | x >= 31557600 = Just ((++"y") . show $ x `div` 31557600, x `mod` 31557600)- | x >= 2629800 = Just ((++"m") . show $ x `div` 2629800, x `mod` 2629800)- | x >= 86400 = Just ((++"d") . show $ x `div` 86400, x `mod` 86400)- | x > 0 = Just ((++"s") . show $ x, 0)- | otherwise = Nothing--newtype ThirtyTwoBitDuration = ThirtyTwoBitDuration {unThirtyTwoBitDuration :: Word32}- deriving (Bounded, Data, Enum, Eq, Generic, Hashable, Integral, Num, Ord, Real, Show, Typeable)--instance Newtype ThirtyTwoBitDuration Word32 where- pack = ThirtyTwoBitDuration- unpack (ThirtyTwoBitDuration o) = o--instance Pretty ThirtyTwoBitDuration where- pretty = pretty . concat . unfoldr durU . unpack--$(ATH.deriveJSON ATH.defaultOptions ''ThirtyTwoBitDuration)--data RevocationClass = SensitiveRK- | RClOther Word8 -- FIXME: this should be constrained to 3 bits- deriving (Data, Generic, Show, Typeable)--instance Eq RevocationClass where- (==) a b = fromFFlag a == fromFFlag b--instance Ord RevocationClass where- compare = comparing fromFFlag--instance FutureFlag RevocationClass where- fromFFlag SensitiveRK = 1- fromFFlag (RClOther i) = fromIntegral i-- toFFlag 1 = SensitiveRK- toFFlag i = RClOther (fromIntegral i)--instance Hashable RevocationClass--instance Pretty RevocationClass where- pretty SensitiveRK = pretty "sensitive"- pretty (RClOther o) = pretty "unknown revocation class" <+> pretty o--$(ATH.deriveJSON ATH.defaultOptions ''RevocationClass)--data PubKeyAlgorithm = RSA- | DeprecatedRSAEncryptOnly- | DeprecatedRSASignOnly- | ElgamalEncryptOnly- | DSA- | ECDH- | ECDSA- | ForbiddenElgamal- | DH- | EdDSA- | OtherPKA Word8- deriving (Show, Data, Generic, Typeable)--instance Eq PubKeyAlgorithm where- (==) a b = fromFVal a == fromFVal b--instance Ord PubKeyAlgorithm where- compare = comparing fromFVal--instance FutureVal PubKeyAlgorithm where- fromFVal RSA = 1- fromFVal DeprecatedRSAEncryptOnly = 2- fromFVal DeprecatedRSASignOnly = 3- fromFVal ElgamalEncryptOnly = 16- fromFVal DSA = 17- fromFVal ECDH = 18- fromFVal ECDSA = 19- fromFVal ForbiddenElgamal = 20- fromFVal DH = 21- fromFVal EdDSA = 22- fromFVal (OtherPKA o) = o- toFVal 1 = RSA- toFVal 2 = DeprecatedRSAEncryptOnly- toFVal 3 = DeprecatedRSASignOnly- toFVal 16 = ElgamalEncryptOnly- toFVal 17 = DSA- toFVal 18 = ECDH- toFVal 19 = ECDSA- toFVal 20 = ForbiddenElgamal- toFVal 21 = DH- toFVal 22 = EdDSA- toFVal o = OtherPKA o--instance Hashable PubKeyAlgorithm--instance Pretty PubKeyAlgorithm where- pretty RSA = pretty "RSA"- pretty DeprecatedRSAEncryptOnly = pretty "(deprecated) RSA encrypt-only"- pretty DeprecatedRSASignOnly = pretty "(deprecated) RSA sign-only"- pretty ElgamalEncryptOnly = pretty "Elgamal encrypt-only"- pretty DSA = pretty "DSA"- pretty ECDH = pretty "ECDH"- pretty ECDSA = pretty "ECDSA"- pretty ForbiddenElgamal = pretty "(forbidden) Elgamal"- pretty DH = pretty "DH"- pretty EdDSA = pretty "EdDSA"- pretty (OtherPKA pka) = pretty "unknown pubkey algorithm type" <+> pretty pka--$(ATH.deriveJSON ATH.defaultOptions ''PubKeyAlgorithm)--newtype TwentyOctetFingerprint = TwentyOctetFingerprint {unTOF :: ByteString}- deriving (Data, Eq, Generic, Ord, Show, Typeable)--instance Newtype TwentyOctetFingerprint ByteString where- pack = TwentyOctetFingerprint- unpack (TwentyOctetFingerprint o) = o---- FIXME: read-show-instance Read TwentyOctetFingerprint where- readsPrec _ = map ((TwentyOctetFingerprint . BL.pack *** concat) . unzip) . chunksOf 20 . hexToW8s . filter (/= ' ')--instance Hashable TwentyOctetFingerprint--instance Pretty TwentyOctetFingerprint where- pretty = pretty . take 40 . bsToHexUpper . unTOF--instance A.ToJSON TwentyOctetFingerprint where- toJSON e = object [T.pack "fpr" .= (A.toJSON . show . pretty) e]-instance A.FromJSON TwentyOctetFingerprint where- parseJSON (A.Object v) = TwentyOctetFingerprint . read <$>- v A..: T.pack "fpr"- parseJSON _ = mzero--newtype SpacedFingerprint = SpacedFingerprint { unSpacedFingerprint :: TwentyOctetFingerprint }--instance Newtype SpacedFingerprint TwentyOctetFingerprint where- pack = SpacedFingerprint- unpack (SpacedFingerprint o) = o--instance Pretty SpacedFingerprint where- pretty = hsep . punctuate space . map hsep . chunksOf 5 . map pretty . chunksOf 4 . take 40 . bsToHexUpper . unTOF . unpack--bsToHexUpper :: ByteString -> String-bsToHexUpper = map toUpper . BLC8.unpack . B16L.encode--hexToW8s :: ReadS Word8-hexToW8s = concatMap readHex . chunksOf 2 . map toLower--newtype EightOctetKeyId = EightOctetKeyId {unEOKI :: ByteString}- deriving (Data, Eq, Generic, Ord, Show, Typeable)--instance Newtype EightOctetKeyId ByteString where- pack = EightOctetKeyId- unpack (EightOctetKeyId o) = o--instance Pretty EightOctetKeyId where- pretty = pretty . bsToHexUpper . unpack---- FIXME: read-show-instance Read EightOctetKeyId where- readsPrec _ = map ((EightOctetKeyId . BL.pack *** concat) . unzip) . chunksOf 8 . hexToW8s--instance Hashable EightOctetKeyId--instance A.ToJSON EightOctetKeyId where- toJSON e = object [T.pack "eoki" .= (bsToHexUpper . unpack) e]--instance A.FromJSON EightOctetKeyId where- parseJSON (A.Object v) = EightOctetKeyId . read <$>- v A..: T.pack "eoki"- parseJSON _ = mzero--newtype NotationName = NotationName {unNotationName :: ByteString}- deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable)--instance Pretty NotationName where- pretty = prettyLBS . unNotationName--instance Newtype NotationName ByteString where- pack = NotationName- unpack (NotationName nn) = nn--instance A.ToJSON NotationName where- toJSON nn = object [T.pack "notationname" .= show (unpack nn)]-instance A.FromJSON NotationName where- parseJSON (A.Object v) = NotationName . read <$>- v A..: T.pack "notationname"- parseJSON _ = mzero--newtype NotationValue = NotationValue {unNotationValue :: ByteString}- deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable)--instance Pretty NotationValue where- pretty = prettyLBS . unNotationValue--instance Newtype NotationValue ByteString where- pack = NotationValue- unpack (NotationValue nv) = nv--instance A.ToJSON NotationValue where- toJSON nv = object [T.pack "notationvalue" .= show (unpack nv)]-instance A.FromJSON NotationValue where- parseJSON (A.Object v) = NotationValue . read <$>- v A..: T.pack "notationvalue"- parseJSON _ = mzero--data HashAlgorithm = DeprecatedMD5- | SHA1- | RIPEMD160- | SHA256- | SHA384- | SHA512- | SHA224- | OtherHA Word8- deriving (Data, Generic, Show, Typeable)--instance Eq HashAlgorithm where- (==) a b = fromFVal a == fromFVal b--instance Ord HashAlgorithm where- compare = comparing fromFVal--instance FutureVal HashAlgorithm where- fromFVal DeprecatedMD5 = 1- fromFVal SHA1 = 2- fromFVal RIPEMD160 = 3- fromFVal SHA256 = 8- fromFVal SHA384 = 9- fromFVal SHA512 = 10- fromFVal SHA224 = 11- fromFVal (OtherHA o) = o- toFVal 1 = DeprecatedMD5- toFVal 2 = SHA1- toFVal 3 = RIPEMD160- toFVal 8 = SHA256- toFVal 9 = SHA384- toFVal 10 = SHA512- toFVal 11 = SHA224- toFVal o = OtherHA o--instance Hashable HashAlgorithm--instance Pretty HashAlgorithm where- pretty DeprecatedMD5 = pretty "(deprecated) MD5"- pretty SHA1 = pretty "SHA-1"- pretty RIPEMD160 = pretty "RIPEMD-160"- pretty SHA256 = pretty "SHA-256"- pretty SHA384 = pretty "SHA-384"- pretty SHA512 = pretty "SHA-512"- pretty SHA224 = pretty "SHA-224"- pretty (OtherHA ha) = pretty "unknown hash algorithm type" <+> pretty ha--$(ATH.deriveJSON ATH.defaultOptions ''HashAlgorithm)--data CompressionAlgorithm = Uncompressed- | ZIP- | ZLIB- | BZip2- | OtherCA Word8- deriving (Show, Data, Generic, Typeable)--instance Eq CompressionAlgorithm where- (==) a b = fromFVal a == fromFVal b--instance Ord CompressionAlgorithm where- compare = comparing fromFVal--instance FutureVal CompressionAlgorithm where- fromFVal Uncompressed = 0- fromFVal ZIP = 1- fromFVal ZLIB = 2- fromFVal BZip2 = 3- fromFVal (OtherCA o) = o- toFVal 0 = Uncompressed- toFVal 1 = ZIP- toFVal 2 = ZLIB- toFVal 3 = BZip2- toFVal o = OtherCA o--instance Hashable CompressionAlgorithm--instance Pretty CompressionAlgorithm where- pretty Uncompressed = pretty "uncompressed"- pretty ZIP = pretty "ZIP"- pretty ZLIB = pretty "zlib"- pretty BZip2 = pretty "bzip2"- pretty (OtherCA ca) = pretty "unknown compression algorithm type" <+> pretty ca--$(ATH.deriveJSON ATH.defaultOptions ''CompressionAlgorithm)--data KSPFlag = NoModify- | KSPOther Int- deriving (Data, Generic, Show, Typeable)--instance Eq KSPFlag where- (==) a b = fromFFlag a == fromFFlag b--instance Ord KSPFlag where- compare = comparing fromFFlag--instance FutureFlag KSPFlag where- fromFFlag NoModify = 0- fromFFlag (KSPOther i) = fromIntegral i-- toFFlag 0 = NoModify- toFFlag i = KSPOther (fromIntegral i)--instance Hashable KSPFlag--instance Pretty KSPFlag where- pretty NoModify = pretty "no-modify"- pretty (KSPOther o) = pretty "unknown keyserver preference flag type" <+> pretty o--$(ATH.deriveJSON ATH.defaultOptions ''KSPFlag)--data KeyFlag = GroupKey- | AuthKey- | SplitKey- | EncryptStorageKey- | EncryptCommunicationsKey- | SignDataKey- | CertifyKeysKey- | KFOther Int- deriving (Data, Generic, Show, Typeable)--instance Eq KeyFlag where- (==) a b = fromFFlag a == fromFFlag b--instance Ord KeyFlag where- compare = comparing fromFFlag--instance FutureFlag KeyFlag where- fromFFlag GroupKey = 0- fromFFlag AuthKey = 2- fromFFlag SplitKey = 3- fromFFlag EncryptStorageKey = 4- fromFFlag EncryptCommunicationsKey = 5- fromFFlag SignDataKey = 6- fromFFlag CertifyKeysKey = 7- fromFFlag (KFOther i) = fromIntegral i-- toFFlag 0 = GroupKey- toFFlag 2 = AuthKey- toFFlag 3 = SplitKey- toFFlag 4 = EncryptStorageKey- toFFlag 5 = EncryptCommunicationsKey- toFFlag 6 = SignDataKey- toFFlag 7 = CertifyKeysKey- toFFlag i = KFOther (fromIntegral i)--instance Hashable KeyFlag--instance Pretty KeyFlag where- pretty GroupKey = pretty "group"- pretty AuthKey = pretty "auth"- pretty SplitKey = pretty "split"- pretty EncryptStorageKey = pretty "encrypt-storage"- pretty EncryptCommunicationsKey = pretty "encrypt-communications"- pretty SignDataKey = pretty "sign-data"- pretty CertifyKeysKey = pretty "certify-keys"- pretty (KFOther o) = pretty "unknown key flag type" <+> pretty o--$(ATH.deriveJSON ATH.defaultOptions ''KeyFlag)--data RevocationCode = NoReason- | KeySuperseded- | KeyMaterialCompromised- | KeyRetiredAndNoLongerUsed- | UserIdInfoNoLongerValid- | RCoOther Word8- deriving (Data, Generic, Show, Typeable)--instance Eq RevocationCode where- (==) a b = fromFVal a == fromFVal b--instance Ord RevocationCode where- compare = comparing fromFVal--instance FutureVal RevocationCode where- fromFVal NoReason = 0- fromFVal KeySuperseded = 1- fromFVal KeyMaterialCompromised = 2- fromFVal KeyRetiredAndNoLongerUsed = 3- fromFVal UserIdInfoNoLongerValid = 32- fromFVal (RCoOther o) = o- toFVal 0 = NoReason- toFVal 1 = KeySuperseded- toFVal 2 = KeyMaterialCompromised- toFVal 3 = KeyRetiredAndNoLongerUsed- toFVal 32 = UserIdInfoNoLongerValid- toFVal o = RCoOther o--instance Hashable RevocationCode--instance Pretty RevocationCode where- pretty NoReason = pretty "no reason"- pretty KeySuperseded = pretty "key superseded"- pretty KeyMaterialCompromised = pretty "key material compromised"- pretty KeyRetiredAndNoLongerUsed = pretty "key retired and no longer used"- pretty UserIdInfoNoLongerValid = pretty "user-ID info no longer valid"- pretty (RCoOther o) = pretty "unknown revocation code" <+> pretty o--$(ATH.deriveJSON ATH.defaultOptions ''RevocationCode)--data FeatureFlag = ModificationDetection- | FeatureOther Int- deriving (Data, Generic, Show, Typeable)--instance Eq FeatureFlag where- (==) a b = fromFFlag a == fromFFlag b--instance Ord FeatureFlag where- compare = comparing fromFFlag--instance FutureFlag FeatureFlag where- fromFFlag ModificationDetection = 7- fromFFlag (FeatureOther i) = fromIntegral i-- toFFlag 7 = ModificationDetection- toFFlag i = FeatureOther (fromIntegral i)--instance Hashable FeatureFlag-instance Hashable a => Hashable (Set a) where- hashWithSalt salt = hashWithSalt salt . Set.toList--instance Pretty FeatureFlag where- pretty ModificationDetection = pretty "modification-detection"- pretty (FeatureOther o) = pretty "unknown feature flag type" <+> pretty o--$(ATH.deriveJSON ATH.defaultOptions ''FeatureFlag)--newtype URL = URL {unURL :: URI}- deriving (Data, Eq, Generic, Ord, Show, Typeable)--instance Newtype URL URI where- pack = URL- unpack (URL o) = o--instance Hashable URL where- hashWithSalt salt (URL (URI s a p q f)) = salt `hashWithSalt` s `hashWithSalt` show a `hashWithSalt` p `hashWithSalt` q `hashWithSalt` f--instance Pretty URL where- pretty = pretty . (\uri -> uriToString id uri "") . unpack--instance A.ToJSON URL where- toJSON u = object [T.pack "uri" .= (\uri -> uriToString id uri "") (unpack u)]-instance A.FromJSON URL where- parseJSON (A.Object v) = URL . fromMaybe nullURI . parseURI <$>- v A..: T.pack "uri"- parseJSON _ = mzero--data SigType = BinarySig- | CanonicalTextSig- | StandaloneSig- | GenericCert- | PersonaCert- | CasualCert- | PositiveCert- | SubkeyBindingSig- | PrimaryKeyBindingSig- | SignatureDirectlyOnAKey- | KeyRevocationSig- | SubkeyRevocationSig- | CertRevocationSig- | TimestampSig- | ThirdPartyConfirmationSig- | OtherSig Word8- deriving (Data, Generic, Show, Typeable)--instance Eq SigType where- (==) a b = fromFVal a == fromFVal b--instance Ord SigType where- compare = comparing fromFVal--instance FutureVal SigType where- fromFVal BinarySig = 0x00- fromFVal CanonicalTextSig = 0x01- fromFVal StandaloneSig = 0x02- fromFVal GenericCert = 0x10- fromFVal PersonaCert = 0x11- fromFVal CasualCert = 0x12- fromFVal PositiveCert = 0x13- fromFVal SubkeyBindingSig = 0x18- fromFVal PrimaryKeyBindingSig = 0x19- fromFVal SignatureDirectlyOnAKey = 0x1F- fromFVal KeyRevocationSig = 0x20- fromFVal SubkeyRevocationSig = 0x28- fromFVal CertRevocationSig = 0x30- fromFVal TimestampSig = 0x40- fromFVal ThirdPartyConfirmationSig = 0x50- fromFVal (OtherSig o) = o-- toFVal 0x00 = BinarySig- toFVal 0x01 = CanonicalTextSig- toFVal 0x02 = StandaloneSig- toFVal 0x10 = GenericCert- toFVal 0x11 = PersonaCert- toFVal 0x12 = CasualCert- toFVal 0x13 = PositiveCert- toFVal 0x18 = SubkeyBindingSig- toFVal 0x19 = PrimaryKeyBindingSig- toFVal 0x1F = SignatureDirectlyOnAKey- toFVal 0x20 = KeyRevocationSig- toFVal 0x28 = SubkeyRevocationSig- toFVal 0x30 = CertRevocationSig- toFVal 0x40 = TimestampSig- toFVal 0x50 = ThirdPartyConfirmationSig- toFVal o = OtherSig o--instance Hashable SigType--instance Pretty SigType where- pretty BinarySig = pretty "binary"- pretty CanonicalTextSig = pretty "canonical-pretty"- pretty StandaloneSig = pretty "standalone"- pretty GenericCert = pretty "generic"- pretty PersonaCert = pretty "persona"- pretty CasualCert = pretty "casual"- pretty PositiveCert = pretty "positive"- pretty SubkeyBindingSig = pretty "subkey-binding"- pretty PrimaryKeyBindingSig = pretty "primary-key-binding"- pretty SignatureDirectlyOnAKey = pretty "signature directly on a key"- pretty KeyRevocationSig = pretty "key-revocation"- pretty SubkeyRevocationSig = pretty "subkey-revocation"- pretty CertRevocationSig = pretty "cert-revocation"- pretty TimestampSig = pretty "timestamp"- pretty ThirdPartyConfirmationSig = pretty "third-party-confirmation"- pretty (OtherSig o) = pretty "unknown signature type" <+> pretty o--$(ATH.deriveJSON ATH.defaultOptions ''SigType)--newtype MPI = MPI {unMPI :: Integer}- deriving (Data, Eq, Generic, Show, Typeable)--instance Newtype MPI Integer where- pack = MPI- unpack (MPI o) = o--instance Hashable MPI--instance Pretty MPI where- pretty = pretty . unpack--$(ATH.deriveJSON ATH.defaultOptions ''MPI)--data SignaturePayload = SigV3 SigType ThirtyTwoBitTimeStamp EightOctetKeyId PubKeyAlgorithm HashAlgorithm Word16 (NonEmpty MPI)- | SigV4 SigType PubKeyAlgorithm HashAlgorithm [SigSubPacket] [SigSubPacket] Word16 (NonEmpty MPI)- | SigVOther Word8 ByteString- deriving (Data, Eq, Generic, Show, Typeable)--instance Hashable SignaturePayload--instance Pretty SignaturePayload where- pretty (SigV3 st ts eoki pka ha w16 mpis) = pretty "signature v3" <> pretty ':' <+> 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) = pretty "signature v4" <> pretty ':' <+> pretty st <+> pretty pka <+> pretty ha <+> pretty hsps <+> pretty usps <+> pretty w16 <+> (pretty . NE.toList) mpis- pretty (SigVOther t bs) = pretty "unknown signature v" <> pretty t <> pretty ':' <+> pretty (BL.unpack bs)--instance A.ToJSON SignaturePayload where- toJSON (SigV3 st ts eoki pka ha w16 mpis) = A.toJSON (st, ts, eoki, pka, ha, w16, NE.toList mpis)- toJSON (SigV4 st pka ha hsps usps w16 mpis) = A.toJSON (st, pka, ha, hsps, usps, w16, NE.toList mpis)- toJSON (SigVOther t bs) = A.toJSON (t, BL.unpack bs)--data SigSubPacketPayload = SigCreationTime ThirtyTwoBitTimeStamp- | SigExpirationTime ThirtyTwoBitDuration- | ExportableCertification Exportability- | TrustSignature TrustLevel TrustAmount- | RegularExpression AlmostPublicDomainRegex- | Revocable Revocability- | KeyExpirationTime ThirtyTwoBitDuration- | PreferredSymmetricAlgorithms [SymmetricAlgorithm]- | RevocationKey (Set RevocationClass) PubKeyAlgorithm TwentyOctetFingerprint- | Issuer EightOctetKeyId- | NotationData (Set NotationFlag) NotationName NotationValue- | PreferredHashAlgorithms [HashAlgorithm]- | PreferredCompressionAlgorithms [CompressionAlgorithm]- | KeyServerPreferences (Set KSPFlag)- | PreferredKeyServer KeyServer- | PrimaryUserId Bool- | PolicyURL URL- | KeyFlags (Set KeyFlag)- | SignersUserId Text- | ReasonForRevocation RevocationCode RevocationReason- | Features (Set FeatureFlag)- | SignatureTarget PubKeyAlgorithm HashAlgorithm SignatureHash- | EmbeddedSignature SignaturePayload- | IssuerFingerprint Word8 TwentyOctetFingerprint- | UserDefinedSigSub Word8 ByteString- | OtherSigSub Word8 ByteString- deriving (Data, Eq, Generic, Show, Typeable) -- FIXME--instance Hashable SigSubPacketPayload--instance Pretty SigSubPacketPayload where- pretty (SigCreationTime ts) = pretty "creation-time" <+> pretty ts- pretty (SigExpirationTime d) = pretty "sig expiration time" <+> pretty d- pretty (ExportableCertification e) = pretty "exportable certification" <+> pretty e- pretty (TrustSignature tl ta) = pretty "trust signature" <+> pretty tl <+> pretty ta- pretty (RegularExpression apdre) = pretty "regular expression" <+> prettyLBS apdre- pretty (Revocable r) = pretty "revocable" <+> pretty r- pretty (KeyExpirationTime d) = pretty "key expiration time" <+> pretty d- pretty (PreferredSymmetricAlgorithms sas) = pretty "preferred symmetric algorithms" <+> pretty sas- pretty (RevocationKey rcs pka tof) = pretty "revocation key" <+> pretty (Set.toList rcs) <+> pretty pka <+> pretty tof- pretty (Issuer eoki) = pretty "issuer" <+> pretty eoki- pretty (NotationData nfs nn nv) = pretty "notation data" <+> pretty (Set.toList nfs) <+> pretty nn <+> pretty nv- pretty (PreferredHashAlgorithms phas) = pretty "preferred hash algorithms" <+> pretty phas- pretty (PreferredCompressionAlgorithms pcas) = pretty "preferred compression algorithms" <+> pretty pcas- pretty (KeyServerPreferences kspfs) = pretty "keyserver preferences" <+> pretty (Set.toList kspfs)- pretty (PreferredKeyServer ks) = pretty "preferred keyserver" <+> prettyLBS ks- pretty (PrimaryUserId p) = (if p then mempty else pretty "NOT ") <> pretty "primary user-ID"- pretty (PolicyURL u) = pretty "policy URL" <+> pretty u- pretty (KeyFlags kfs) = pretty "key flags" <+> pretty (Set.toList kfs)- pretty (SignersUserId u) = pretty "signer's user-ID" <+> pretty u- pretty (ReasonForRevocation rc rr) = pretty "reason for revocation" <+> pretty rc <+> pretty rr- pretty (Features ffs) = pretty "features" <+> pretty (Set.toList ffs)- pretty (SignatureTarget pka ha sh) = pretty "signature target" <+> pretty pka <+> pretty ha <+> prettyLBS sh- pretty (EmbeddedSignature sp) = pretty "embedded signature" <+> pretty sp- pretty (IssuerFingerprint kv ifp) = pretty "issuer fingerprint (v" <> pretty kv <> pretty ")" <+> pretty ifp- pretty (UserDefinedSigSub t bs) = pretty "user-defined signature subpacket type" <+> pretty t <+> pretty (BL.unpack bs)- pretty (OtherSigSub t bs) = pretty "unknown signature subpacket type" <+> pretty t <+> prettyLBS bs--instance A.ToJSON SigSubPacketPayload where- toJSON (SigCreationTime ts) = object [T.pack "sigCreationTime" .= ts]- toJSON (SigExpirationTime d) = object [T.pack "sigExpirationTime" .= d]- toJSON (ExportableCertification e) = object [T.pack "exportableCertification" .= e]- toJSON (TrustSignature tl ta) = object [T.pack "trustSignature" .= (tl, ta)]- toJSON (RegularExpression apdre) = object [T.pack "regularExpression" .= BL.unpack apdre]- toJSON (Revocable r) = object [T.pack "revocable" .= r]- toJSON (KeyExpirationTime d) = object [T.pack "keyExpirationTime" .= d]- toJSON (PreferredSymmetricAlgorithms sas) = object [T.pack "preferredSymmetricAlgorithms" .= sas]- toJSON (RevocationKey rcs pka tof) = object [T.pack "revocationKey" .= (rcs, pka, tof)]- toJSON (Issuer eoki) = object [T.pack "issuer" .= eoki]- toJSON (NotationData nfs (NotationName nn) (NotationValue nv)) = object [T.pack "notationData" .= (nfs, BL.unpack nn, BL.unpack nv)]- toJSON (PreferredHashAlgorithms phas) = object [T.pack "preferredHashAlgorithms" .= phas]- toJSON (PreferredCompressionAlgorithms pcas) = object [T.pack "preferredCompressionAlgorithms" .= pcas]- toJSON (KeyServerPreferences kspfs) = object [T.pack "keyServerPreferences" .= kspfs]- toJSON (PreferredKeyServer ks) = object [T.pack "preferredKeyServer" .= show ks]- toJSON (PrimaryUserId p) = object [T.pack "primaryUserId" .= p]- toJSON (PolicyURL u) = object [T.pack "policyURL" .= u]- toJSON (KeyFlags kfs) = object [T.pack "keyFlags" .= kfs]- toJSON (SignersUserId u) = object [T.pack "signersUserId" .= u]- toJSON (ReasonForRevocation rc rr) = object [T.pack "reasonForRevocation" .= (rc, rr)]- toJSON (Features ffs) = object [T.pack "features" .= ffs]- toJSON (SignatureTarget pka ha sh) = object [T.pack "signatureTarget" .= (pka, ha, BL.unpack sh)]- toJSON (EmbeddedSignature sp) = object [T.pack "embeddedSignature" .= sp]- toJSON (IssuerFingerprint kv ifp) = object [T.pack "issuerFingerprint" .= (kv, ifp)]- toJSON (UserDefinedSigSub t bs) = object [T.pack "userDefinedSigSub" .= (t, BL.unpack bs)]- toJSON (OtherSigSub t bs) = object [T.pack "otherSigSub" .= (t, BL.unpack bs)]--uc3 :: (a -> b -> c -> d) -> (a, b, c) -> d-uc3 f ~(a,b,c) = f a b c--instance A.FromJSON SigSubPacketPayload where- parseJSON (A.Object v) = (SigCreationTime <$> v A..: T.pack "sigCreationTime")- <|> (SigExpirationTime <$> v A..: T.pack "sigExpirationTime")- <|> (ExportableCertification <$> v A..: T.pack "exportableCertification")- <|> (uncurry TrustSignature <$> v A..: T.pack "trustSignature")- <|> (RegularExpression . BL.pack <$> v A..: T.pack "regularExpression")- <|> (Revocable <$> v A..: T.pack "revocable")- <|> (KeyExpirationTime <$> v A..: T.pack "keyExpirationTime")- <|> (PreferredSymmetricAlgorithms <$> v A..: T.pack "preferredSymmetricAlgorithms")- <|> (uc3 RevocationKey <$> v A..: T.pack "revocationKey")- <|> (Issuer <$> v A..: T.pack "issuer")- <|> (uc3 NotationData <$> v A..: T.pack "notationData")- parseJSON _ = mzero--data SigSubPacket = SigSubPacket {- _sspCriticality :: Bool- , _sspPayload :: SigSubPacketPayload- } deriving (Data, Eq, Generic, Show, Typeable)--instance Pretty SigSubPacket where- pretty x = (if _sspCriticality x then pretty '*' else mempty) <> (pretty . _sspPayload) x--instance Hashable SigSubPacket--$(ATH.deriveJSON ATH.defaultOptions ''SigSubPacket)-$(makeLenses ''SigSubPacket)--data KeyVersion = DeprecatedV3 | V4- deriving (Data, Eq, Generic, Ord, Show, Typeable)--instance Hashable KeyVersion--instance Pretty KeyVersion where- pretty DeprecatedV3 = pretty "(deprecated) v3"- pretty V4 = pretty "v4"--$(ATH.deriveJSON ATH.defaultOptions ''KeyVersion)--newtype IV = IV {unIV :: B.ByteString}- deriving (ByteArrayAccess, Data, Eq, Generic, Hashable, Semigroup, Monoid, Show, Typeable)--instance Newtype IV B.ByteString where- pack = IV- unpack (IV o) = o--instance Pretty IV where- pretty = pretty . ("iv:"++) . bsToHexUpper . BL.fromStrict . unpack--instance A.ToJSON IV where- toJSON = A.toJSON . show . unpack--data DataType = BinaryData- | TextData- | UTF8Data- | OtherData Word8- deriving (Show, Data, Generic, Typeable)--instance Hashable DataType--instance Eq DataType where- (==) a b = fromFVal a == fromFVal b--instance Ord DataType where- compare = comparing fromFVal--instance FutureVal DataType where- fromFVal BinaryData = fromIntegral . fromEnum $ 'b'- fromFVal TextData = fromIntegral . fromEnum $ 't'- fromFVal UTF8Data = fromIntegral . fromEnum $ 'u'- fromFVal (OtherData o) = o-- toFVal 0x62 = BinaryData- toFVal 0x74 = TextData- toFVal 0x75 = UTF8Data- toFVal o = OtherData o--instance Pretty DataType where- pretty BinaryData = pretty "binary"- pretty TextData = pretty "text"- pretty UTF8Data = pretty "UTF-8"- pretty (OtherData o) = pretty "other data type " <+> pretty o--$(ATH.deriveJSON ATH.defaultOptions ''DataType)--newtype Salt = Salt {unSalt :: B.ByteString}- deriving (Data, Eq, Generic, Hashable, Show, Typeable)--instance Newtype Salt B.ByteString where- pack = Salt- unpack (Salt o) = o--instance Pretty Salt where- pretty = pretty . ("salt:"++) . bsToHexUpper . BL.fromStrict . unpack--instance A.ToJSON Salt where- toJSON = A.toJSON . show . unpack--newtype IterationCount = IterationCount {unIterationCount :: Int}- deriving (Bounded, Data, Enum, Eq, Generic, Hashable, Integral, Num, Ord, Real, Show, Typeable)--instance Newtype IterationCount Int where- pack = IterationCount- unpack (IterationCount o) = o--instance Pretty IterationCount where- pretty = pretty . unpack--$(ATH.deriveJSON ATH.defaultOptions ''IterationCount)--data S2K = Simple HashAlgorithm- | Salted HashAlgorithm Salt- | IteratedSalted HashAlgorithm Salt IterationCount- | OtherS2K Word8 ByteString- deriving (Data, Eq, Generic, Show, Typeable)--instance Hashable S2K--instance Pretty S2K where- pretty (Simple ha) = pretty "simple S2K," <+> pretty ha- pretty (Salted ha salt) = pretty "salted S2K," <+> pretty ha <+> pretty salt- pretty (IteratedSalted ha salt icount) = pretty "iterated-salted S2K," <+> pretty ha <+> pretty salt <+> pretty icount- pretty (OtherS2K t bs) = pretty "unknown S2K type" <+> pretty t <+> pretty (bsToHexUpper bs)--instance A.ToJSON S2K where- toJSON (Simple ha) = A.toJSON ha- toJSON (Salted ha salt) = A.toJSON (ha, salt)- toJSON (IteratedSalted ha salt icount) = A.toJSON (ha, salt, icount)- toJSON (OtherS2K t bs) = A.toJSON (t, BL.unpack bs)--data ImageFormat = JPEG- | OtherImage Word8- deriving (Data, Generic, Show, Typeable)--instance Eq ImageFormat where- (==) a b = fromFVal a == fromFVal b--instance Ord ImageFormat where- compare = comparing fromFVal--instance FutureVal ImageFormat where- fromFVal JPEG = 1- fromFVal (OtherImage o) = o-- toFVal 1 = JPEG- toFVal o = OtherImage o--instance Hashable ImageFormat--instance Pretty ImageFormat where- pretty JPEG = pretty "JPEG"- pretty (OtherImage o) = pretty "unknown image format" <+> pretty o--$(ATH.deriveJSON ATH.defaultOptions ''ImageFormat)--newtype ImageHeader = ImageHV1 ImageFormat- deriving (Data, Eq, Generic, Show, Typeable)--instance Ord ImageHeader where- compare (ImageHV1 a) (ImageHV1 b) = compare a b--instance Hashable ImageHeader--instance Pretty ImageHeader where- pretty (ImageHV1 f) = pretty "imghdr v1" <+> pretty f--$(ATH.deriveJSON ATH.defaultOptions ''ImageHeader)--data UserAttrSubPacket = ImageAttribute ImageHeader ImageData- | OtherUASub Word8 ByteString- deriving (Data, Eq, Generic, Show, Typeable)--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--instance Pretty UserAttrSubPacket where- pretty (ImageAttribute ih d) = pretty "image-attribute" <+> pretty ih <+> pretty (BL.unpack d)- pretty (OtherUASub t bs) = pretty "unknown attribute type" <> pretty t <+> pretty (BL.unpack bs)--instance A.ToJSON UserAttrSubPacket where- toJSON (ImageAttribute ih d) = A.toJSON (ih, BL.unpack d)- toJSON (OtherUASub t bs) = A.toJSON (t, BL.unpack bs)--data ECCCurve = NISTP256- | NISTP384- | NISTP521- | Curve25519- deriving (Data, Eq, Generic, Ord, Show, Typeable)--instance Pretty ECCCurve where- pretty NISTP256 = pretty "NIST P-256"- pretty NISTP384 = pretty "NIST P-384"- pretty NISTP521 = pretty "NIST P-521"- pretty Curve25519 = pretty "Curve25519"--instance Hashable ECCCurve--newtype Block a = Block {unBlock :: [a]} -- so we can override cereal instance- deriving (Show, Eq)+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}++module Codec.Encryption.OpenPGP.Types.Internal.Base where++import GHC.Generics (Generic)++import Codec.Encryption.OpenPGP.Types.Internal.PrettyUtils (prettyLBS)+import Control.Applicative ((<|>))+import Control.Arrow ((***))+import Control.Lens (makeLenses)+import Control.Monad (mzero)+import Control.Newtype (Newtype(..))+import Data.Aeson ((.=), object)+import qualified Data.Aeson as A+import qualified Data.Aeson.TH as ATH+import Data.ByteArray (ByteArrayAccess)+import qualified Data.ByteString as B+import qualified Data.ByteString.Base16.Lazy as B16L+import Data.ByteString.Lazy (ByteString)+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(..))+import Data.List (unfoldr)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NE+import Data.List.Split (chunksOf)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.Ord (comparing)+import Data.Semigroup (Semigroup)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Prettyprint.Doc (Pretty(..), (<+>), hsep, punctuate, space)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Data.Time.Format (formatTime)+import Data.Time.Locale.Compat (defaultTimeLocale)+import Data.Typeable (Typeable)+import Data.Word (Word16, Word32, Word8)+import Network.URI (URI(..), nullURI, parseURI, uriToString)+import Numeric (readHex)++type Exportability = Bool++type TrustLevel = Word8++type TrustAmount = Word8++type AlmostPublicDomainRegex = ByteString++type Revocability = Bool++type RevocationReason = Text++type KeyServer = ByteString++type SignatureHash = ByteString++type PacketVersion = Word8++type V3Expiration = Word16++type CompressedDataPayload = ByteString++type FileName = ByteString++type ImageData = ByteString++type NestedFlag = Bool++class (Eq a, Ord a) =>+ FutureFlag a+ where+ fromFFlag :: a -> Int+ toFFlag :: Int -> a++class (Eq a, Ord a) =>+ FutureVal a+ where+ fromFVal :: a -> Word8+ toFVal :: Word8 -> a++data SymmetricAlgorithm+ = Plaintext+ | IDEA+ | TripleDES+ | CAST5+ | Blowfish+ | ReservedSAFER+ | ReservedDES+ | AES128+ | AES192+ | AES256+ | Twofish+ | Camellia128+ | Camellia192+ | Camellia256+ | OtherSA Word8+ deriving (Data, Generic, Show, Typeable)++instance Eq SymmetricAlgorithm where+ (==) a b = fromFVal a == fromFVal b++instance Ord SymmetricAlgorithm where+ compare = comparing fromFVal++instance FutureVal SymmetricAlgorithm where+ fromFVal Plaintext = 0+ fromFVal IDEA = 1+ fromFVal TripleDES = 2+ fromFVal CAST5 = 3+ fromFVal Blowfish = 4+ fromFVal ReservedSAFER = 5+ fromFVal ReservedDES = 6+ fromFVal AES128 = 7+ fromFVal AES192 = 8+ fromFVal AES256 = 9+ fromFVal Twofish = 10+ fromFVal Camellia128 = 11+ fromFVal Camellia192 = 12+ fromFVal Camellia256 = 13+ fromFVal (OtherSA o) = o+ toFVal 0 = Plaintext+ toFVal 1 = IDEA+ toFVal 2 = TripleDES+ toFVal 3 = CAST5+ toFVal 4 = Blowfish+ toFVal 5 = ReservedSAFER+ toFVal 6 = ReservedDES+ toFVal 7 = AES128+ toFVal 8 = AES192+ toFVal 9 = AES256+ toFVal 10 = Twofish+ toFVal 11 = Camellia128+ toFVal 12 = Camellia192+ toFVal 13 = Camellia256+ toFVal o = OtherSA o++instance Hashable SymmetricAlgorithm++instance Pretty SymmetricAlgorithm where+ pretty Plaintext = pretty "plaintext"+ pretty IDEA = pretty "IDEA"+ pretty TripleDES = pretty "3DES"+ pretty CAST5 = pretty "CAST-128"+ pretty Blowfish = pretty "Blowfish"+ pretty ReservedSAFER = pretty "(reserved) SAFER"+ pretty ReservedDES = pretty "(reserved) DES"+ pretty AES128 = pretty "AES-128"+ pretty AES192 = pretty "AES-192"+ pretty AES256 = pretty "AES-256"+ pretty Twofish = pretty "Twofish"+ pretty Camellia128 = pretty "Camellia-128"+ pretty Camellia192 = pretty "Camellia-192"+ pretty Camellia256 = pretty "Camellia-256"+ pretty (OtherSA sa) = pretty "unknown symmetric algorithm" <+> pretty sa++$(ATH.deriveJSON ATH.defaultOptions ''SymmetricAlgorithm)++data NotationFlag+ = HumanReadable+ | OtherNF Word8 -- FIXME: this should be constrained to 4 bits?+ deriving (Data, Generic, Show, Typeable)++instance Eq NotationFlag where+ (==) a b = fromFFlag a == fromFFlag b++instance Ord NotationFlag where+ compare = comparing fromFFlag++instance FutureFlag NotationFlag where+ fromFFlag HumanReadable = 0+ fromFFlag (OtherNF o) = fromIntegral o+ toFFlag 0 = HumanReadable+ toFFlag o = OtherNF (fromIntegral o)++instance Hashable NotationFlag++instance Pretty NotationFlag where+ pretty HumanReadable = pretty "human-readable"+ pretty (OtherNF o) = pretty "unknown notation flag type" <+> pretty o++$(ATH.deriveJSON ATH.defaultOptions ''NotationFlag)++newtype ThirtyTwoBitTimeStamp =+ ThirtyTwoBitTimeStamp+ { unThirtyTwoBitTimeStamp :: Word32+ }+ deriving ( Bounded+ , Data+ , Enum+ , Eq+ , Generic+ , Hashable+ , Integral+ , Num+ , Ord+ , Real+ , Show+ , Typeable+ )++instance Newtype ThirtyTwoBitTimeStamp Word32 where+ pack = ThirtyTwoBitTimeStamp+ unpack (ThirtyTwoBitTimeStamp o) = o++instance Pretty ThirtyTwoBitTimeStamp where+ pretty =+ pretty .+ formatTime defaultTimeLocale "%Y%m%d-%H%M%S" .+ posixSecondsToUTCTime . realToFrac++$(ATH.deriveJSON ATH.defaultOptions ''ThirtyTwoBitTimeStamp)++durU :: (Integral a, Show a) => a -> Maybe (String, a)+durU x+ | x >= 31557600 = Just ((++ "y") . show $ x `div` 31557600, x `mod` 31557600)+ | x >= 2629800 = Just ((++ "m") . show $ x `div` 2629800, x `mod` 2629800)+ | x >= 86400 = Just ((++ "d") . show $ x `div` 86400, x `mod` 86400)+ | x > 0 = Just ((++ "s") . show $ x, 0)+ | otherwise = Nothing++newtype ThirtyTwoBitDuration =+ ThirtyTwoBitDuration+ { unThirtyTwoBitDuration :: Word32+ }+ deriving ( Bounded+ , Data+ , Enum+ , Eq+ , Generic+ , Hashable+ , Integral+ , Num+ , Ord+ , Real+ , Show+ , Typeable+ )++instance Newtype ThirtyTwoBitDuration Word32 where+ pack = ThirtyTwoBitDuration+ unpack (ThirtyTwoBitDuration o) = o++instance Pretty ThirtyTwoBitDuration where+ pretty = pretty . concat . unfoldr durU . unpack++$(ATH.deriveJSON ATH.defaultOptions ''ThirtyTwoBitDuration)++data RevocationClass+ = SensitiveRK+ | RClOther Word8 -- FIXME: this should be constrained to 3 bits+ deriving (Data, Generic, Show, Typeable)++instance Eq RevocationClass where+ (==) a b = fromFFlag a == fromFFlag b++instance Ord RevocationClass where+ compare = comparing fromFFlag++instance FutureFlag RevocationClass where+ fromFFlag SensitiveRK = 1+ fromFFlag (RClOther i) = fromIntegral i+ toFFlag 1 = SensitiveRK+ toFFlag i = RClOther (fromIntegral i)++instance Hashable RevocationClass++instance Pretty RevocationClass where+ pretty SensitiveRK = pretty "sensitive"+ pretty (RClOther o) = pretty "unknown revocation class" <+> pretty o++$(ATH.deriveJSON ATH.defaultOptions ''RevocationClass)++data PubKeyAlgorithm+ = RSA+ | DeprecatedRSAEncryptOnly+ | DeprecatedRSASignOnly+ | ElgamalEncryptOnly+ | DSA+ | ECDH+ | ECDSA+ | ForbiddenElgamal+ | DH+ | EdDSA+ | OtherPKA Word8+ deriving (Show, Data, Generic, Typeable)++instance Eq PubKeyAlgorithm where+ (==) a b = fromFVal a == fromFVal b++instance Ord PubKeyAlgorithm where+ compare = comparing fromFVal++instance FutureVal PubKeyAlgorithm where+ fromFVal RSA = 1+ fromFVal DeprecatedRSAEncryptOnly = 2+ fromFVal DeprecatedRSASignOnly = 3+ fromFVal ElgamalEncryptOnly = 16+ fromFVal DSA = 17+ fromFVal ECDH = 18+ fromFVal ECDSA = 19+ fromFVal ForbiddenElgamal = 20+ fromFVal DH = 21+ fromFVal EdDSA = 22+ fromFVal (OtherPKA o) = o+ toFVal 1 = RSA+ toFVal 2 = DeprecatedRSAEncryptOnly+ toFVal 3 = DeprecatedRSASignOnly+ toFVal 16 = ElgamalEncryptOnly+ toFVal 17 = DSA+ toFVal 18 = ECDH+ toFVal 19 = ECDSA+ toFVal 20 = ForbiddenElgamal+ toFVal 21 = DH+ toFVal 22 = EdDSA+ toFVal o = OtherPKA o++instance Hashable PubKeyAlgorithm++instance Pretty PubKeyAlgorithm where+ pretty RSA = pretty "RSA"+ pretty DeprecatedRSAEncryptOnly = pretty "(deprecated) RSA encrypt-only"+ pretty DeprecatedRSASignOnly = pretty "(deprecated) RSA sign-only"+ pretty ElgamalEncryptOnly = pretty "Elgamal encrypt-only"+ pretty DSA = pretty "DSA"+ pretty ECDH = pretty "ECDH"+ pretty ECDSA = pretty "ECDSA"+ pretty ForbiddenElgamal = pretty "(forbidden) Elgamal"+ pretty DH = pretty "DH"+ pretty EdDSA = pretty "EdDSA"+ pretty (OtherPKA pka) = pretty "unknown pubkey algorithm type" <+> pretty pka++$(ATH.deriveJSON ATH.defaultOptions ''PubKeyAlgorithm)++newtype TwentyOctetFingerprint =+ TwentyOctetFingerprint+ { unTOF :: ByteString+ }+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++instance Newtype TwentyOctetFingerprint ByteString where+ pack = TwentyOctetFingerprint+ unpack (TwentyOctetFingerprint o) = o++-- FIXME: read-show+instance Read TwentyOctetFingerprint where+ readsPrec _ =+ map ((TwentyOctetFingerprint . BL.pack *** concat) . unzip) .+ chunksOf 20 . hexToW8s . filter (/= ' ')++instance Hashable TwentyOctetFingerprint++instance Pretty TwentyOctetFingerprint where+ pretty = pretty . take 40 . bsToHexUpper . unTOF++instance A.ToJSON TwentyOctetFingerprint where+ toJSON e = object [T.pack "fpr" .= (A.toJSON . show . pretty) e]++instance A.FromJSON TwentyOctetFingerprint where+ parseJSON (A.Object v) = TwentyOctetFingerprint . read <$> v A..: T.pack "fpr"+ parseJSON _ = mzero++newtype SpacedFingerprint =+ SpacedFingerprint+ { unSpacedFingerprint :: TwentyOctetFingerprint+ }++instance Newtype SpacedFingerprint TwentyOctetFingerprint where+ pack = SpacedFingerprint+ unpack (SpacedFingerprint o) = o++instance Pretty SpacedFingerprint where+ pretty =+ hsep .+ punctuate space .+ map hsep .+ chunksOf 5 .+ map pretty . chunksOf 4 . take 40 . bsToHexUpper . unTOF . unpack++bsToHexUpper :: ByteString -> String+bsToHexUpper = map toUpper . BLC8.unpack . B16L.encode++hexToW8s :: ReadS Word8+hexToW8s = concatMap readHex . chunksOf 2 . map toLower++newtype EightOctetKeyId =+ EightOctetKeyId+ { unEOKI :: ByteString+ }+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++instance Newtype EightOctetKeyId ByteString where+ pack = EightOctetKeyId+ unpack (EightOctetKeyId o) = o++instance Pretty EightOctetKeyId where+ pretty = pretty . bsToHexUpper . unpack++-- FIXME: read-show+instance Read EightOctetKeyId where+ readsPrec _ =+ map ((EightOctetKeyId . BL.pack *** concat) . unzip) . chunksOf 8 . hexToW8s++instance Hashable EightOctetKeyId++instance A.ToJSON EightOctetKeyId where+ toJSON e = object [T.pack "eoki" .= (bsToHexUpper . unpack) e]++instance A.FromJSON EightOctetKeyId where+ parseJSON (A.Object v) = EightOctetKeyId . read <$> v A..: T.pack "eoki"+ parseJSON _ = mzero++newtype NotationName =+ NotationName+ { unNotationName :: ByteString+ }+ deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable)++instance Pretty NotationName where+ pretty = prettyLBS . unNotationName++instance Newtype NotationName ByteString where+ pack = NotationName+ unpack (NotationName nn) = nn++instance A.ToJSON NotationName where+ toJSON nn = object [T.pack "notationname" .= show (unpack nn)]++instance A.FromJSON NotationName where+ parseJSON (A.Object v) = NotationName . read <$> v A..: T.pack "notationname"+ parseJSON _ = mzero++newtype NotationValue =+ NotationValue+ { unNotationValue :: ByteString+ }+ deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable)++instance Pretty NotationValue where+ pretty = prettyLBS . unNotationValue++instance Newtype NotationValue ByteString where+ pack = NotationValue+ unpack (NotationValue nv) = nv++instance A.ToJSON NotationValue where+ toJSON nv = object [T.pack "notationvalue" .= show (unpack nv)]++instance A.FromJSON NotationValue where+ parseJSON (A.Object v) =+ NotationValue . read <$> v A..: T.pack "notationvalue"+ parseJSON _ = mzero++data HashAlgorithm+ = DeprecatedMD5+ | SHA1+ | RIPEMD160+ | SHA256+ | SHA384+ | SHA512+ | SHA224+ | OtherHA Word8+ deriving (Data, Generic, Show, Typeable)++instance Eq HashAlgorithm where+ (==) a b = fromFVal a == fromFVal b++instance Ord HashAlgorithm where+ compare = comparing fromFVal++instance FutureVal HashAlgorithm where+ fromFVal DeprecatedMD5 = 1+ fromFVal SHA1 = 2+ fromFVal RIPEMD160 = 3+ fromFVal SHA256 = 8+ fromFVal SHA384 = 9+ fromFVal SHA512 = 10+ fromFVal SHA224 = 11+ fromFVal (OtherHA o) = o+ toFVal 1 = DeprecatedMD5+ toFVal 2 = SHA1+ toFVal 3 = RIPEMD160+ toFVal 8 = SHA256+ toFVal 9 = SHA384+ toFVal 10 = SHA512+ toFVal 11 = SHA224+ toFVal o = OtherHA o++instance Hashable HashAlgorithm++instance Pretty HashAlgorithm where+ pretty DeprecatedMD5 = pretty "(deprecated) MD5"+ pretty SHA1 = pretty "SHA-1"+ pretty RIPEMD160 = pretty "RIPEMD-160"+ pretty SHA256 = pretty "SHA-256"+ pretty SHA384 = pretty "SHA-384"+ pretty SHA512 = pretty "SHA-512"+ pretty SHA224 = pretty "SHA-224"+ pretty (OtherHA ha) = pretty "unknown hash algorithm type" <+> pretty ha++$(ATH.deriveJSON ATH.defaultOptions ''HashAlgorithm)++data CompressionAlgorithm+ = Uncompressed+ | ZIP+ | ZLIB+ | BZip2+ | OtherCA Word8+ deriving (Show, Data, Generic, Typeable)++instance Eq CompressionAlgorithm where+ (==) a b = fromFVal a == fromFVal b++instance Ord CompressionAlgorithm where+ compare = comparing fromFVal++instance FutureVal CompressionAlgorithm where+ fromFVal Uncompressed = 0+ fromFVal ZIP = 1+ fromFVal ZLIB = 2+ fromFVal BZip2 = 3+ fromFVal (OtherCA o) = o+ toFVal 0 = Uncompressed+ toFVal 1 = ZIP+ toFVal 2 = ZLIB+ toFVal 3 = BZip2+ toFVal o = OtherCA o++instance Hashable CompressionAlgorithm++instance Pretty CompressionAlgorithm where+ pretty Uncompressed = pretty "uncompressed"+ pretty ZIP = pretty "ZIP"+ pretty ZLIB = pretty "zlib"+ pretty BZip2 = pretty "bzip2"+ pretty (OtherCA ca) =+ pretty "unknown compression algorithm type" <+> pretty ca++$(ATH.deriveJSON ATH.defaultOptions ''CompressionAlgorithm)++data KSPFlag+ = NoModify+ | KSPOther Int+ deriving (Data, Generic, Show, Typeable)++instance Eq KSPFlag where+ (==) a b = fromFFlag a == fromFFlag b++instance Ord KSPFlag where+ compare = comparing fromFFlag++instance FutureFlag KSPFlag where+ fromFFlag NoModify = 0+ fromFFlag (KSPOther i) = fromIntegral i+ toFFlag 0 = NoModify+ toFFlag i = KSPOther (fromIntegral i)++instance Hashable KSPFlag++instance Pretty KSPFlag where+ pretty NoModify = pretty "no-modify"+ pretty (KSPOther o) =+ pretty "unknown keyserver preference flag type" <+> pretty o++$(ATH.deriveJSON ATH.defaultOptions ''KSPFlag)++data KeyFlag+ = GroupKey+ | AuthKey+ | SplitKey+ | EncryptStorageKey+ | EncryptCommunicationsKey+ | SignDataKey+ | CertifyKeysKey+ | KFOther Int+ deriving (Data, Generic, Show, Typeable)++instance Eq KeyFlag where+ (==) a b = fromFFlag a == fromFFlag b++instance Ord KeyFlag where+ compare = comparing fromFFlag++instance FutureFlag KeyFlag where+ fromFFlag GroupKey = 0+ fromFFlag AuthKey = 2+ fromFFlag SplitKey = 3+ fromFFlag EncryptStorageKey = 4+ fromFFlag EncryptCommunicationsKey = 5+ fromFFlag SignDataKey = 6+ fromFFlag CertifyKeysKey = 7+ fromFFlag (KFOther i) = fromIntegral i+ toFFlag 0 = GroupKey+ toFFlag 2 = AuthKey+ toFFlag 3 = SplitKey+ toFFlag 4 = EncryptStorageKey+ toFFlag 5 = EncryptCommunicationsKey+ toFFlag 6 = SignDataKey+ toFFlag 7 = CertifyKeysKey+ toFFlag i = KFOther (fromIntegral i)++instance Hashable KeyFlag++instance Pretty KeyFlag where+ pretty GroupKey = pretty "group"+ pretty AuthKey = pretty "auth"+ pretty SplitKey = pretty "split"+ pretty EncryptStorageKey = pretty "encrypt-storage"+ pretty EncryptCommunicationsKey = pretty "encrypt-communications"+ pretty SignDataKey = pretty "sign-data"+ pretty CertifyKeysKey = pretty "certify-keys"+ pretty (KFOther o) = pretty "unknown key flag type" <+> pretty o++$(ATH.deriveJSON ATH.defaultOptions ''KeyFlag)++data RevocationCode+ = NoReason+ | KeySuperseded+ | KeyMaterialCompromised+ | KeyRetiredAndNoLongerUsed+ | UserIdInfoNoLongerValid+ | RCoOther Word8+ deriving (Data, Generic, Show, Typeable)++instance Eq RevocationCode where+ (==) a b = fromFVal a == fromFVal b++instance Ord RevocationCode where+ compare = comparing fromFVal++instance FutureVal RevocationCode where+ fromFVal NoReason = 0+ fromFVal KeySuperseded = 1+ fromFVal KeyMaterialCompromised = 2+ fromFVal KeyRetiredAndNoLongerUsed = 3+ fromFVal UserIdInfoNoLongerValid = 32+ fromFVal (RCoOther o) = o+ toFVal 0 = NoReason+ toFVal 1 = KeySuperseded+ toFVal 2 = KeyMaterialCompromised+ toFVal 3 = KeyRetiredAndNoLongerUsed+ toFVal 32 = UserIdInfoNoLongerValid+ toFVal o = RCoOther o++instance Hashable RevocationCode++instance Pretty RevocationCode where+ pretty NoReason = pretty "no reason"+ pretty KeySuperseded = pretty "key superseded"+ pretty KeyMaterialCompromised = pretty "key material compromised"+ pretty KeyRetiredAndNoLongerUsed = pretty "key retired and no longer used"+ pretty UserIdInfoNoLongerValid = pretty "user-ID info no longer valid"+ pretty (RCoOther o) = pretty "unknown revocation code" <+> pretty o++$(ATH.deriveJSON ATH.defaultOptions ''RevocationCode)++data FeatureFlag+ = ModificationDetection+ | FeatureOther Int+ deriving (Data, Generic, Show, Typeable)++instance Eq FeatureFlag where+ (==) a b = fromFFlag a == fromFFlag b++instance Ord FeatureFlag where+ compare = comparing fromFFlag++instance FutureFlag FeatureFlag where+ fromFFlag ModificationDetection = 7+ fromFFlag (FeatureOther i) = fromIntegral i+ toFFlag 7 = ModificationDetection+ toFFlag i = FeatureOther (fromIntegral i)++instance Hashable FeatureFlag++instance Hashable a => Hashable (Set a) where+ hashWithSalt salt = hashWithSalt salt . Set.toList++instance Pretty FeatureFlag where+ pretty ModificationDetection = pretty "modification-detection"+ pretty (FeatureOther o) = pretty "unknown feature flag type" <+> pretty o++$(ATH.deriveJSON ATH.defaultOptions ''FeatureFlag)++newtype URL =+ URL+ { unURL :: URI+ }+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++instance Newtype URL URI where+ pack = URL+ unpack (URL o) = o++instance Hashable URL where+ hashWithSalt salt (URL (URI s a p q f)) =+ salt `hashWithSalt` s `hashWithSalt` show a `hashWithSalt` p `hashWithSalt`+ q `hashWithSalt`+ f++instance Pretty URL where+ pretty = pretty . (\uri -> uriToString id uri "") . unpack++instance A.ToJSON URL where+ toJSON u = object [T.pack "uri" .= (\uri -> uriToString id uri "") (unpack u)]++instance A.FromJSON URL where+ parseJSON (A.Object v) =+ URL . fromMaybe nullURI . parseURI <$> v A..: T.pack "uri"+ parseJSON _ = mzero++data SigType+ = BinarySig+ | CanonicalTextSig+ | StandaloneSig+ | GenericCert+ | PersonaCert+ | CasualCert+ | PositiveCert+ | SubkeyBindingSig+ | PrimaryKeyBindingSig+ | SignatureDirectlyOnAKey+ | KeyRevocationSig+ | SubkeyRevocationSig+ | CertRevocationSig+ | TimestampSig+ | ThirdPartyConfirmationSig+ | OtherSig Word8+ deriving (Data, Generic, Show, Typeable)++instance Eq SigType where+ (==) a b = fromFVal a == fromFVal b++instance Ord SigType where+ compare = comparing fromFVal++instance FutureVal SigType where+ fromFVal BinarySig = 0x00+ fromFVal CanonicalTextSig = 0x01+ fromFVal StandaloneSig = 0x02+ fromFVal GenericCert = 0x10+ fromFVal PersonaCert = 0x11+ fromFVal CasualCert = 0x12+ fromFVal PositiveCert = 0x13+ fromFVal SubkeyBindingSig = 0x18+ fromFVal PrimaryKeyBindingSig = 0x19+ fromFVal SignatureDirectlyOnAKey = 0x1F+ fromFVal KeyRevocationSig = 0x20+ fromFVal SubkeyRevocationSig = 0x28+ fromFVal CertRevocationSig = 0x30+ fromFVal TimestampSig = 0x40+ fromFVal ThirdPartyConfirmationSig = 0x50+ fromFVal (OtherSig o) = o+ toFVal 0x00 = BinarySig+ toFVal 0x01 = CanonicalTextSig+ toFVal 0x02 = StandaloneSig+ toFVal 0x10 = GenericCert+ toFVal 0x11 = PersonaCert+ toFVal 0x12 = CasualCert+ toFVal 0x13 = PositiveCert+ toFVal 0x18 = SubkeyBindingSig+ toFVal 0x19 = PrimaryKeyBindingSig+ toFVal 0x1F = SignatureDirectlyOnAKey+ toFVal 0x20 = KeyRevocationSig+ toFVal 0x28 = SubkeyRevocationSig+ toFVal 0x30 = CertRevocationSig+ toFVal 0x40 = TimestampSig+ toFVal 0x50 = ThirdPartyConfirmationSig+ toFVal o = OtherSig o++instance Hashable SigType++instance Pretty SigType where+ pretty BinarySig = pretty "binary"+ pretty CanonicalTextSig = pretty "canonical-pretty"+ pretty StandaloneSig = pretty "standalone"+ pretty GenericCert = pretty "generic"+ pretty PersonaCert = pretty "persona"+ pretty CasualCert = pretty "casual"+ pretty PositiveCert = pretty "positive"+ pretty SubkeyBindingSig = pretty "subkey-binding"+ pretty PrimaryKeyBindingSig = pretty "primary-key-binding"+ pretty SignatureDirectlyOnAKey = pretty "signature directly on a key"+ pretty KeyRevocationSig = pretty "key-revocation"+ pretty SubkeyRevocationSig = pretty "subkey-revocation"+ pretty CertRevocationSig = pretty "cert-revocation"+ pretty TimestampSig = pretty "timestamp"+ pretty ThirdPartyConfirmationSig = pretty "third-party-confirmation"+ pretty (OtherSig o) = pretty "unknown signature type" <+> pretty o++$(ATH.deriveJSON ATH.defaultOptions ''SigType)++newtype MPI =+ MPI+ { unMPI :: Integer+ }+ deriving (Data, Eq, Generic, Show, Typeable)++instance Newtype MPI Integer where+ pack = MPI+ unpack (MPI o) = o++instance Hashable MPI++instance Pretty MPI where+ pretty = pretty . unpack++$(ATH.deriveJSON ATH.defaultOptions ''MPI)++data SignaturePayload+ = SigV3+ SigType+ ThirtyTwoBitTimeStamp+ EightOctetKeyId+ PubKeyAlgorithm+ HashAlgorithm+ Word16+ (NonEmpty MPI)+ | SigV4+ SigType+ PubKeyAlgorithm+ HashAlgorithm+ [SigSubPacket]+ [SigSubPacket]+ Word16+ (NonEmpty MPI)+ | SigVOther Word8 ByteString+ deriving (Data, Eq, Generic, Show, Typeable)++instance Hashable SignaturePayload++instance Pretty SignaturePayload where+ pretty (SigV3 st ts eoki pka ha w16 mpis) =+ pretty "signature v3" <> pretty ':' <+>+ 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) =+ pretty "signature v4" <> pretty ':' <+>+ pretty st <+>+ pretty pka <+>+ pretty ha <+>+ pretty hsps <+> pretty usps <+> pretty w16 <+> (pretty . NE.toList) mpis+ pretty (SigVOther t bs) =+ pretty "unknown signature v" <> pretty t <> pretty ':' <+>+ pretty (BL.unpack bs)++instance A.ToJSON SignaturePayload where+ toJSON (SigV3 st ts eoki pka ha w16 mpis) =+ A.toJSON (st, ts, eoki, pka, ha, w16, NE.toList mpis)+ toJSON (SigV4 st pka ha hsps usps w16 mpis) =+ A.toJSON (st, pka, ha, hsps, usps, w16, NE.toList mpis)+ toJSON (SigVOther t bs) = A.toJSON (t, BL.unpack bs)++data SigSubPacketPayload+ = SigCreationTime ThirtyTwoBitTimeStamp+ | SigExpirationTime ThirtyTwoBitDuration+ | ExportableCertification Exportability+ | TrustSignature TrustLevel TrustAmount+ | RegularExpression AlmostPublicDomainRegex+ | Revocable Revocability+ | KeyExpirationTime ThirtyTwoBitDuration+ | PreferredSymmetricAlgorithms [SymmetricAlgorithm]+ | RevocationKey (Set RevocationClass) PubKeyAlgorithm TwentyOctetFingerprint+ | Issuer EightOctetKeyId+ | NotationData (Set NotationFlag) NotationName NotationValue+ | PreferredHashAlgorithms [HashAlgorithm]+ | PreferredCompressionAlgorithms [CompressionAlgorithm]+ | KeyServerPreferences (Set KSPFlag)+ | PreferredKeyServer KeyServer+ | PrimaryUserId Bool+ | PolicyURL URL+ | KeyFlags (Set KeyFlag)+ | SignersUserId Text+ | ReasonForRevocation RevocationCode RevocationReason+ | Features (Set FeatureFlag)+ | SignatureTarget PubKeyAlgorithm HashAlgorithm SignatureHash+ | EmbeddedSignature SignaturePayload+ | IssuerFingerprint Word8 TwentyOctetFingerprint+ | UserDefinedSigSub Word8 ByteString+ | OtherSigSub Word8 ByteString+ deriving (Data, Eq, Generic, Show, Typeable) -- FIXME++instance Hashable SigSubPacketPayload++instance Pretty SigSubPacketPayload where+ pretty (SigCreationTime ts) = pretty "creation-time" <+> pretty ts+ pretty (SigExpirationTime d) = pretty "sig expiration time" <+> pretty d+ pretty (ExportableCertification e) =+ pretty "exportable certification" <+> pretty e+ pretty (TrustSignature tl ta) =+ pretty "trust signature" <+> pretty tl <+> pretty ta+ pretty (RegularExpression apdre) =+ pretty "regular expression" <+> prettyLBS apdre+ pretty (Revocable r) = pretty "revocable" <+> pretty r+ pretty (KeyExpirationTime d) = pretty "key expiration time" <+> pretty d+ pretty (PreferredSymmetricAlgorithms sas) =+ pretty "preferred symmetric algorithms" <+> pretty sas+ pretty (RevocationKey rcs pka tof) =+ pretty "revocation key" <+>+ pretty (Set.toList rcs) <+> pretty pka <+> pretty tof+ pretty (Issuer eoki) = pretty "issuer" <+> pretty eoki+ pretty (NotationData nfs nn nv) =+ pretty "notation data" <+>+ pretty (Set.toList nfs) <+> pretty nn <+> pretty nv+ pretty (PreferredHashAlgorithms phas) =+ pretty "preferred hash algorithms" <+> pretty phas+ pretty (PreferredCompressionAlgorithms pcas) =+ pretty "preferred compression algorithms" <+> pretty pcas+ pretty (KeyServerPreferences kspfs) =+ pretty "keyserver preferences" <+> pretty (Set.toList kspfs)+ pretty (PreferredKeyServer ks) = pretty "preferred keyserver" <+> prettyLBS ks+ pretty (PrimaryUserId p) =+ (if p+ then mempty+ else pretty "NOT ") <>+ pretty "primary user-ID"+ pretty (PolicyURL u) = pretty "policy URL" <+> pretty u+ pretty (KeyFlags kfs) = pretty "key flags" <+> pretty (Set.toList kfs)+ pretty (SignersUserId u) = pretty "signer's user-ID" <+> pretty u+ pretty (ReasonForRevocation rc rr) =+ pretty "reason for revocation" <+> pretty rc <+> pretty rr+ pretty (Features ffs) = pretty "features" <+> pretty (Set.toList ffs)+ pretty (SignatureTarget pka ha sh) =+ pretty "signature target" <+> pretty pka <+> pretty ha <+> prettyLBS sh+ pretty (EmbeddedSignature sp) = pretty "embedded signature" <+> pretty sp+ pretty (IssuerFingerprint kv ifp) =+ pretty "issuer fingerprint (v" <> pretty kv <> pretty ")" <+> pretty ifp+ pretty (UserDefinedSigSub t bs) =+ pretty "user-defined signature subpacket type" <+>+ pretty t <+> pretty (BL.unpack bs)+ pretty (OtherSigSub t bs) =+ pretty "unknown signature subpacket type" <+> pretty t <+> prettyLBS bs++instance A.ToJSON SigSubPacketPayload where+ toJSON (SigCreationTime ts) = object [T.pack "sigCreationTime" .= ts]+ toJSON (SigExpirationTime d) = object [T.pack "sigExpirationTime" .= d]+ toJSON (ExportableCertification e) =+ object [T.pack "exportableCertification" .= e]+ toJSON (TrustSignature tl ta) = object [T.pack "trustSignature" .= (tl, ta)]+ toJSON (RegularExpression apdre) =+ object [T.pack "regularExpression" .= BL.unpack apdre]+ toJSON (Revocable r) = object [T.pack "revocable" .= r]+ toJSON (KeyExpirationTime d) = object [T.pack "keyExpirationTime" .= d]+ toJSON (PreferredSymmetricAlgorithms sas) =+ object [T.pack "preferredSymmetricAlgorithms" .= sas]+ toJSON (RevocationKey rcs pka tof) =+ object [T.pack "revocationKey" .= (rcs, pka, tof)]+ toJSON (Issuer eoki) = object [T.pack "issuer" .= eoki]+ toJSON (NotationData nfs (NotationName nn) (NotationValue nv)) =+ object [T.pack "notationData" .= (nfs, BL.unpack nn, BL.unpack nv)]+ toJSON (PreferredHashAlgorithms phas) =+ object [T.pack "preferredHashAlgorithms" .= phas]+ toJSON (PreferredCompressionAlgorithms pcas) =+ object [T.pack "preferredCompressionAlgorithms" .= pcas]+ toJSON (KeyServerPreferences kspfs) =+ object [T.pack "keyServerPreferences" .= kspfs]+ toJSON (PreferredKeyServer ks) =+ object [T.pack "preferredKeyServer" .= show ks]+ toJSON (PrimaryUserId p) = object [T.pack "primaryUserId" .= p]+ toJSON (PolicyURL u) = object [T.pack "policyURL" .= u]+ toJSON (KeyFlags kfs) = object [T.pack "keyFlags" .= kfs]+ toJSON (SignersUserId u) = object [T.pack "signersUserId" .= u]+ toJSON (ReasonForRevocation rc rr) =+ object [T.pack "reasonForRevocation" .= (rc, rr)]+ toJSON (Features ffs) = object [T.pack "features" .= ffs]+ toJSON (SignatureTarget pka ha sh) =+ object [T.pack "signatureTarget" .= (pka, ha, BL.unpack sh)]+ toJSON (EmbeddedSignature sp) = object [T.pack "embeddedSignature" .= sp]+ toJSON (IssuerFingerprint kv ifp) =+ object [T.pack "issuerFingerprint" .= (kv, ifp)]+ toJSON (UserDefinedSigSub t bs) =+ object [T.pack "userDefinedSigSub" .= (t, BL.unpack bs)]+ toJSON (OtherSigSub t bs) = object [T.pack "otherSigSub" .= (t, BL.unpack bs)]++uc3 :: (a -> b -> c -> d) -> (a, b, c) -> d+uc3 f ~(a, b, c) = f a b c++instance A.FromJSON SigSubPacketPayload where+ parseJSON (A.Object v) =+ (SigCreationTime <$> v A..: T.pack "sigCreationTime") <|>+ (SigExpirationTime <$> v A..: T.pack "sigExpirationTime") <|>+ (ExportableCertification <$> v A..: T.pack "exportableCertification") <|>+ (uncurry TrustSignature <$> v A..: T.pack "trustSignature") <|>+ (RegularExpression . BL.pack <$> v A..: T.pack "regularExpression") <|>+ (Revocable <$> v A..: T.pack "revocable") <|>+ (KeyExpirationTime <$> v A..: T.pack "keyExpirationTime") <|>+ (PreferredSymmetricAlgorithms <$>+ v A..: T.pack "preferredSymmetricAlgorithms") <|>+ (uc3 RevocationKey <$> v A..: T.pack "revocationKey") <|>+ (Issuer <$> v A..: T.pack "issuer") <|>+ (uc3 NotationData <$> v A..: T.pack "notationData")+ parseJSON _ = mzero++data SigSubPacket =+ SigSubPacket+ { _sspCriticality :: Bool+ , _sspPayload :: SigSubPacketPayload+ }+ deriving (Data, Eq, Generic, Show, Typeable)++instance Pretty SigSubPacket where+ pretty x =+ (if _sspCriticality x+ then pretty '*'+ else mempty) <>+ (pretty . _sspPayload) x++instance Hashable SigSubPacket++$(ATH.deriveJSON ATH.defaultOptions ''SigSubPacket)++$(makeLenses ''SigSubPacket)++data KeyVersion+ = DeprecatedV3+ | V4+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++instance Hashable KeyVersion++instance Pretty KeyVersion where+ pretty DeprecatedV3 = pretty "(deprecated) v3"+ pretty V4 = pretty "v4"++$(ATH.deriveJSON ATH.defaultOptions ''KeyVersion)++newtype IV =+ IV+ { unIV :: B.ByteString+ }+ deriving ( ByteArrayAccess+ , Data+ , Eq+ , Generic+ , Hashable+ , Semigroup+ , Monoid+ , Show+ , Typeable+ )++instance Newtype IV B.ByteString where+ pack = IV+ unpack (IV o) = o++instance Pretty IV where+ pretty = pretty . ("iv:" ++) . bsToHexUpper . BL.fromStrict . unpack++instance A.ToJSON IV where+ toJSON = A.toJSON . show . unpack++data DataType+ = BinaryData+ | TextData+ | UTF8Data+ | OtherData Word8+ deriving (Show, Data, Generic, Typeable)++instance Hashable DataType++instance Eq DataType where+ (==) a b = fromFVal a == fromFVal b++instance Ord DataType where+ compare = comparing fromFVal++instance FutureVal DataType where+ fromFVal BinaryData = fromIntegral . fromEnum $ 'b'+ fromFVal TextData = fromIntegral . fromEnum $ 't'+ fromFVal UTF8Data = fromIntegral . fromEnum $ 'u'+ fromFVal (OtherData o) = o+ toFVal 0x62 = BinaryData+ toFVal 0x74 = TextData+ toFVal 0x75 = UTF8Data+ toFVal o = OtherData o++instance Pretty DataType where+ pretty BinaryData = pretty "binary"+ pretty TextData = pretty "text"+ pretty UTF8Data = pretty "UTF-8"+ pretty (OtherData o) = pretty "other data type " <+> pretty o++$(ATH.deriveJSON ATH.defaultOptions ''DataType)++newtype Salt =+ Salt+ { unSalt :: B.ByteString+ }+ deriving (Data, Eq, Generic, Hashable, Show, Typeable)++instance Newtype Salt B.ByteString where+ pack = Salt+ unpack (Salt o) = o++instance Pretty Salt where+ pretty = pretty . ("salt:" ++) . bsToHexUpper . BL.fromStrict . unpack++instance A.ToJSON Salt where+ toJSON = A.toJSON . show . unpack++newtype IterationCount =+ IterationCount+ { unIterationCount :: Int+ }+ deriving ( Bounded+ , Data+ , Enum+ , Eq+ , Generic+ , Hashable+ , Integral+ , Num+ , Ord+ , Real+ , Show+ , Typeable+ )++instance Newtype IterationCount Int where+ pack = IterationCount+ unpack (IterationCount o) = o++instance Pretty IterationCount where+ pretty = pretty . unpack++$(ATH.deriveJSON ATH.defaultOptions ''IterationCount)++data S2K+ = Simple HashAlgorithm+ | Salted HashAlgorithm Salt+ | IteratedSalted HashAlgorithm Salt IterationCount+ | OtherS2K Word8 ByteString+ deriving (Data, Eq, Generic, Show, Typeable)++instance Hashable S2K++instance Pretty S2K where+ pretty (Simple ha) = pretty "simple S2K," <+> pretty ha+ pretty (Salted ha salt) = pretty "salted S2K," <+> pretty ha <+> pretty salt+ pretty (IteratedSalted ha salt icount) =+ pretty "iterated-salted S2K," <+>+ pretty ha <+> pretty salt <+> pretty icount+ pretty (OtherS2K t bs) =+ pretty "unknown S2K type" <+> pretty t <+> pretty (bsToHexUpper bs)++instance A.ToJSON S2K where+ toJSON (Simple ha) = A.toJSON ha+ toJSON (Salted ha salt) = A.toJSON (ha, salt)+ toJSON (IteratedSalted ha salt icount) = A.toJSON (ha, salt, icount)+ toJSON (OtherS2K t bs) = A.toJSON (t, BL.unpack bs)++data ImageFormat+ = JPEG+ | OtherImage Word8+ deriving (Data, Generic, Show, Typeable)++instance Eq ImageFormat where+ (==) a b = fromFVal a == fromFVal b++instance Ord ImageFormat where+ compare = comparing fromFVal++instance FutureVal ImageFormat where+ fromFVal JPEG = 1+ fromFVal (OtherImage o) = o+ toFVal 1 = JPEG+ toFVal o = OtherImage o++instance Hashable ImageFormat++instance Pretty ImageFormat where+ pretty JPEG = pretty "JPEG"+ pretty (OtherImage o) = pretty "unknown image format" <+> pretty o++$(ATH.deriveJSON ATH.defaultOptions ''ImageFormat)++newtype ImageHeader =+ ImageHV1 ImageFormat+ deriving (Data, Eq, Generic, Show, Typeable)++instance Ord ImageHeader where+ compare (ImageHV1 a) (ImageHV1 b) = compare a b++instance Hashable ImageHeader++instance Pretty ImageHeader where+ pretty (ImageHV1 f) = pretty "imghdr v1" <+> pretty f++$(ATH.deriveJSON ATH.defaultOptions ''ImageHeader)++data UserAttrSubPacket+ = ImageAttribute ImageHeader ImageData+ | OtherUASub Word8 ByteString+ deriving (Data, Eq, Generic, Show, Typeable)++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++instance Pretty UserAttrSubPacket where+ pretty (ImageAttribute ih d) =+ pretty "image-attribute" <+> pretty ih <+> pretty (BL.unpack d)+ pretty (OtherUASub t bs) =+ pretty "unknown attribute type" <> pretty t <+> pretty (BL.unpack bs)++instance A.ToJSON UserAttrSubPacket where+ toJSON (ImageAttribute ih d) = A.toJSON (ih, BL.unpack d)+ toJSON (OtherUASub t bs) = A.toJSON (t, BL.unpack bs)++data ECCCurve+ = NISTP256+ | NISTP384+ | NISTP521+ | Curve25519+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++instance Pretty ECCCurve where+ pretty NISTP256 = pretty "NIST P-256"+ pretty NISTP384 = pretty "NIST P-384"+ pretty NISTP521 = pretty "NIST P-521"+ pretty Curve25519 = pretty "Curve25519"++instance Hashable ECCCurve++newtype Block a =+ Block+ { unBlock :: [a]+ } -- so we can override cereal instance+ deriving (Show, Eq)
Codec/Encryption/OpenPGP/Types/Internal/CryptoniteNewtypes.hs view
@@ -2,7 +2,6 @@ -- Copyright © 2012-2018 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} @@ -11,86 +10,162 @@ import GHC.Generics (Generic) import Control.Monad (mzero)-import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import qualified Crypto.PubKey.ECC.Types as ECCT+import qualified Crypto.PubKey.RSA as RSA import qualified Data.Aeson as A import Data.Data (Data) import Data.Hashable (Hashable(..))-import Data.Typeable (Typeable) import Data.Text.Prettyprint.Doc (Pretty(..), (<+>), tupled)+import Data.Typeable (Typeable) -newtype DSA_PublicKey = DSA_PublicKey {unDSA_PublicKey :: DSA.PublicKey}- deriving (Data, Eq, Generic, Show, Typeable)+newtype DSA_PublicKey =+ DSA_PublicKey+ { unDSA_PublicKey :: DSA.PublicKey+ }+ deriving (Data, Eq, Generic, Show, Typeable)+ instance Ord DSA_PublicKey+ instance A.ToJSON DSA_PublicKey where- toJSON (DSA_PublicKey (DSA.PublicKey p y)) = A.toJSON (DSA_Params p, y)+ toJSON (DSA_PublicKey (DSA.PublicKey p y)) = A.toJSON (DSA_Params p, y)+ instance Pretty DSA_PublicKey where- pretty (DSA_PublicKey (DSA.PublicKey p y)) = pretty (DSA_Params p) <+> pretty y-newtype RSA_PublicKey = RSA_PublicKey {unRSA_PublicKey :: RSA.PublicKey}- deriving (Data, Eq, Generic, Show, Typeable)+ pretty (DSA_PublicKey (DSA.PublicKey p y)) =+ pretty (DSA_Params p) <+> pretty y++newtype RSA_PublicKey =+ RSA_PublicKey+ { unRSA_PublicKey :: RSA.PublicKey+ }+ deriving (Data, Eq, Generic, Show, Typeable)+ instance Ord RSA_PublicKey+ instance A.ToJSON RSA_PublicKey where- toJSON (RSA_PublicKey (RSA.PublicKey size n e)) = A.toJSON (size, n, e)+ toJSON (RSA_PublicKey (RSA.PublicKey size n e)) = A.toJSON (size, n, e)+ instance Pretty RSA_PublicKey where- pretty (RSA_PublicKey (RSA.PublicKey size n e)) = pretty size <+> pretty n <+> pretty e-newtype ECDSA_PublicKey = ECDSA_PublicKey {unECDSA_PublicKey :: ECDSA.PublicKey}- deriving (Data, Eq, Generic, Show, Typeable)+ pretty (RSA_PublicKey (RSA.PublicKey size n e)) =+ pretty size <+> pretty n <+> pretty e++newtype ECDSA_PublicKey =+ ECDSA_PublicKey+ { unECDSA_PublicKey :: ECDSA.PublicKey+ }+ deriving (Data, Eq, Generic, Show, Typeable)+ instance Ord ECDSA_PublicKey+ instance A.ToJSON ECDSA_PublicKey where- toJSON (ECDSA_PublicKey (ECDSA.PublicKey curve q)) = A.toJSON (show curve, show q)+ toJSON (ECDSA_PublicKey (ECDSA.PublicKey curve q)) =+ A.toJSON (show curve, show q)+ instance Pretty ECDSA_PublicKey where- pretty (ECDSA_PublicKey (ECDSA.PublicKey curve q)) = pretty (show curve, show q)-newtype DSA_PrivateKey = DSA_PrivateKey {unDSA_PrivateKey :: DSA.PrivateKey}- deriving (Data, Eq, Generic, Show, Typeable)+ pretty (ECDSA_PublicKey (ECDSA.PublicKey curve q)) =+ pretty (show curve, show q)++newtype DSA_PrivateKey =+ DSA_PrivateKey+ { unDSA_PrivateKey :: DSA.PrivateKey+ }+ deriving (Data, Eq, Generic, Show, Typeable)+ instance Ord DSA_PrivateKey+ instance A.ToJSON DSA_PrivateKey where- toJSON (DSA_PrivateKey (DSA.PrivateKey p x)) = A.toJSON (DSA_Params p, x)+ toJSON (DSA_PrivateKey (DSA.PrivateKey p x)) = A.toJSON (DSA_Params p, x)+ instance Pretty DSA_PrivateKey where- pretty (DSA_PrivateKey (DSA.PrivateKey p x)) = pretty (DSA_Params p, x)-newtype RSA_PrivateKey = RSA_PrivateKey {unRSA_PrivateKey :: RSA.PrivateKey}- deriving (Data, Eq, Generic, Show, Typeable)+ pretty (DSA_PrivateKey (DSA.PrivateKey p x)) = pretty (DSA_Params p, x)++newtype RSA_PrivateKey =+ RSA_PrivateKey+ { unRSA_PrivateKey :: RSA.PrivateKey+ }+ deriving (Data, Eq, Generic, Show, Typeable)+ instance Ord RSA_PrivateKey+ instance A.ToJSON RSA_PrivateKey where- toJSON (RSA_PrivateKey (RSA.PrivateKey pub d p q dP dQ qinv)) = A.toJSON (RSA_PublicKey pub, d, p, q, dP, dQ, qinv)+ toJSON (RSA_PrivateKey (RSA.PrivateKey pub d p q dP dQ qinv)) =+ A.toJSON (RSA_PublicKey pub, d, p, q, dP, dQ, qinv)+ instance Pretty RSA_PrivateKey where- pretty (RSA_PrivateKey (RSA.PrivateKey pub d p q dP dQ qinv)) = pretty (RSA_PublicKey pub) <+> tupled (map pretty [d, p, q, dP, dQ, qinv])-newtype ECDSA_PrivateKey = ECDSA_PrivateKey {unECDSA_PrivateKey :: ECDSA.PrivateKey}- deriving (Data, Eq, Generic, Show, Typeable)+ pretty (RSA_PrivateKey (RSA.PrivateKey pub d p q dP dQ qinv)) =+ pretty (RSA_PublicKey pub) <+> tupled (map pretty [d, p, q, dP, dQ, qinv])++newtype ECDSA_PrivateKey =+ ECDSA_PrivateKey+ { unECDSA_PrivateKey :: ECDSA.PrivateKey+ }+ deriving (Data, Eq, Generic, Show, Typeable)+ instance Ord ECDSA_PrivateKey+ instance A.ToJSON ECDSA_PrivateKey where- toJSON (ECDSA_PrivateKey (ECDSA.PrivateKey curve d)) = A.toJSON (show curve, show d)+ toJSON (ECDSA_PrivateKey (ECDSA.PrivateKey curve d)) =+ A.toJSON (show curve, show d)+ instance Pretty ECDSA_PrivateKey where- pretty (ECDSA_PrivateKey (ECDSA.PrivateKey curve d)) = pretty (show curve, show d)+ pretty (ECDSA_PrivateKey (ECDSA.PrivateKey curve d)) =+ pretty (show curve, show d) -newtype DSA_Params = DSA_Params {unDSA_Params :: DSA.Params}- deriving (Data, Eq, Generic, Show, Typeable)+newtype DSA_Params =+ DSA_Params+ { unDSA_Params :: DSA.Params+ }+ deriving (Data, Eq, Generic, Show, Typeable)+ instance A.ToJSON DSA_Params where- toJSON (DSA_Params (DSA.Params p g q)) = A.toJSON (p, g, q)+ toJSON (DSA_Params (DSA.Params p g q)) = A.toJSON (p, g, q)+ instance Pretty DSA_Params where- pretty (DSA_Params (DSA.Params p g q)) = pretty (p, g, q)+ pretty (DSA_Params (DSA.Params p g q)) = pretty (p, g, q)+ instance Hashable DSA_Params where- hashWithSalt s (DSA_Params (DSA.Params p g q)) = s `hashWithSalt` p `hashWithSalt` g `hashWithSalt` q+ hashWithSalt s (DSA_Params (DSA.Params p g q)) =+ s `hashWithSalt` p `hashWithSalt` g `hashWithSalt` q+ instance Hashable DSA_PublicKey where- hashWithSalt s (DSA_PublicKey (DSA.PublicKey p y)) = s `hashWithSalt` DSA_Params p `hashWithSalt` y+ hashWithSalt s (DSA_PublicKey (DSA.PublicKey p y)) =+ s `hashWithSalt` DSA_Params p `hashWithSalt` y+ instance Hashable DSA_PrivateKey where- hashWithSalt s (DSA_PrivateKey (DSA.PrivateKey p x)) = s `hashWithSalt` DSA_Params p `hashWithSalt` x+ hashWithSalt s (DSA_PrivateKey (DSA.PrivateKey p x)) =+ s `hashWithSalt` DSA_Params p `hashWithSalt` x+ instance Hashable RSA_PublicKey where- hashWithSalt s (RSA_PublicKey (RSA.PublicKey size n e)) = s `hashWithSalt` size `hashWithSalt` n `hashWithSalt` e+ hashWithSalt s (RSA_PublicKey (RSA.PublicKey size n e)) =+ s `hashWithSalt` size `hashWithSalt` n `hashWithSalt` e+ instance Hashable RSA_PrivateKey where- hashWithSalt s (RSA_PrivateKey (RSA.PrivateKey pub d p q dP dQ qinv)) = s `hashWithSalt` RSA_PublicKey pub `hashWithSalt` d `hashWithSalt` p `hashWithSalt` q `hashWithSalt` dP `hashWithSalt` dQ `hashWithSalt` qinv+ hashWithSalt s (RSA_PrivateKey (RSA.PrivateKey pub d p q dP dQ qinv)) =+ s `hashWithSalt` RSA_PublicKey pub `hashWithSalt` d `hashWithSalt` p `hashWithSalt`+ q `hashWithSalt`+ dP `hashWithSalt`+ dQ `hashWithSalt`+ qinv+ instance Hashable ECDSA_PublicKey where- hashWithSalt s (ECDSA_PublicKey (ECDSA.PublicKey curve q)) = s `hashWithSalt` show curve `hashWithSalt` show q -- FIXME: don't use show+ hashWithSalt s (ECDSA_PublicKey (ECDSA.PublicKey curve q)) =+ s `hashWithSalt` show curve `hashWithSalt` show q -- FIXME: don't use show+ instance Hashable ECDSA_PrivateKey where- hashWithSalt s (ECDSA_PrivateKey (ECDSA.PrivateKey curve d)) = s `hashWithSalt` show curve `hashWithSalt` show d -- FIXME: don't use show+ hashWithSalt s (ECDSA_PrivateKey (ECDSA.PrivateKey curve d)) =+ s `hashWithSalt` show curve `hashWithSalt` show d -- FIXME: don't use show -newtype ECurvePoint = ECurvePoint { unECurvepoint :: ECCT.Point }- deriving (Data, Eq, Generic, Show, Typeable)+newtype ECurvePoint =+ ECurvePoint+ { unECurvepoint :: ECCT.Point+ }+ deriving (Data, Eq, Generic, Show, Typeable)+ instance A.ToJSON ECurvePoint where- toJSON (ECurvePoint (ECCT.Point x y)) = A.toJSON (x, y)- toJSON (ECurvePoint ECCT.PointO) = A.toJSON "point at infinity"-instance A.FromJSON ECurvePoint where- parseJSON (A.Object v) = error "FIXME: whatsit"- parseJSON _ = mzero+ toJSON (ECurvePoint (ECCT.Point x y)) = A.toJSON (x, y)+ toJSON (ECurvePoint ECCT.PointO) = A.toJSON "point at infinity" +instance A.FromJSON ECurvePoint where+ parseJSON (A.Object v) = error "FIXME: whatsit"+ parseJSON _ = mzero
Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs view
@@ -2,7 +2,6 @@ -- Copyright © 2012-2019 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}@@ -18,128 +17,155 @@ import qualified Data.Aeson as A import qualified Data.Aeson.TH as ATH-import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString as B+import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import Data.Data (Data) import Data.Hashable (Hashable(..)) import Data.Monoid ((<>)) import Data.Ord (comparing)+import Data.Text.Prettyprint.Doc (Pretty(..), (<+>)) import Data.Typeable (Typeable) import Data.Word (Word16)-import Data.Text.Prettyprint.Doc (Pretty(..), (<+>)) -data EdSigningCurve = Ed25519- deriving (Data, Eq, Generic, Ord, Show, Typeable)+data EdSigningCurve =+ Ed25519+ deriving (Data, Eq, Generic, Ord, Show, Typeable) instance Hashable EdSigningCurve+ instance Pretty EdSigningCurve where- pretty Ed25519 = pretty "Ed25519"+ pretty Ed25519 = pretty "Ed25519"+ instance A.FromJSON EdSigningCurve+ instance A.ToJSON EdSigningCurve -newtype EPoint = EPoint { unEPoint :: Integer }- deriving (Data, Eq, Generic, Ord, Pretty, Show, Typeable)+newtype EPoint =+ EPoint+ { unEPoint :: Integer+ }+ deriving (Data, Eq, Generic, Ord, Pretty, Show, Typeable)+ instance Hashable EPoint instance A.FromJSON EPoint+ instance A.ToJSON EPoint -data PKey = RSAPubKey RSA_PublicKey- | DSAPubKey DSA_PublicKey- | ElGamalPubKey Integer Integer Integer- | ECDHPubKey PKey HashAlgorithm SymmetricAlgorithm- | ECDSAPubKey ECDSA_PublicKey- | EdDSAPubKey EdSigningCurve EPoint- | UnknownPKey ByteString- deriving (Data, Eq, Generic, Ord, Show, Typeable)+data PKey+ = RSAPubKey RSA_PublicKey+ | DSAPubKey DSA_PublicKey+ | ElGamalPubKey Integer Integer Integer+ | ECDHPubKey PKey HashAlgorithm SymmetricAlgorithm+ | ECDSAPubKey ECDSA_PublicKey+ | EdDSAPubKey EdSigningCurve EPoint+ | UnknownPKey ByteString+ deriving (Data, Eq, Generic, Ord, Show, Typeable) instance Hashable PKey instance Pretty PKey where- pretty (RSAPubKey p) = pretty "RSA" <+> pretty p- pretty (DSAPubKey p) = pretty "DSA" <+> pretty p- pretty (ElGamalPubKey p g y) = pretty "Elgamal" <+> pretty p <+> pretty g <+> pretty y- pretty (ECDHPubKey p ha sa) = pretty "ECDH" <+> pretty p <+> pretty ha <+> pretty sa- pretty (ECDSAPubKey p) = pretty "ECDSA" <+> pretty p- pretty (EdDSAPubKey c ep) = pretty c <+> pretty ep- pretty (UnknownPKey bs) = pretty "<unknown>" <+> pretty (bsToHexUpper bs)+ pretty (RSAPubKey p) = pretty "RSA" <+> pretty p+ pretty (DSAPubKey p) = pretty "DSA" <+> pretty p+ pretty (ElGamalPubKey p g y) =+ pretty "Elgamal" <+> pretty p <+> pretty g <+> pretty y+ pretty (ECDHPubKey p ha sa) =+ pretty "ECDH" <+> pretty p <+> pretty ha <+> pretty sa+ pretty (ECDSAPubKey p) = pretty "ECDSA" <+> pretty p+ pretty (EdDSAPubKey c ep) = pretty c <+> pretty ep+ pretty (UnknownPKey bs) = pretty "<unknown>" <+> pretty (bsToHexUpper bs) instance A.ToJSON PKey where- toJSON (RSAPubKey p) = A.toJSON p- toJSON (DSAPubKey p) = A.toJSON p- toJSON (ElGamalPubKey p g y) = A.toJSON (p, g, y)- toJSON (ECDHPubKey p ha sa) = A.toJSON (p, ha, sa)- toJSON (ECDSAPubKey p) = A.toJSON p- toJSON (EdDSAPubKey c ep) = A.toJSON (c, ep)- toJSON (UnknownPKey bs) = A.toJSON (BL.unpack bs)+ toJSON (RSAPubKey p) = A.toJSON p+ toJSON (DSAPubKey p) = A.toJSON p+ toJSON (ElGamalPubKey p g y) = A.toJSON (p, g, y)+ toJSON (ECDHPubKey p ha sa) = A.toJSON (p, ha, sa)+ toJSON (ECDSAPubKey p) = A.toJSON p+ toJSON (EdDSAPubKey c ep) = A.toJSON (c, ep)+ toJSON (UnknownPKey bs) = A.toJSON (BL.unpack bs) -data SKey = RSAPrivateKey RSA_PrivateKey- | DSAPrivateKey DSA_PrivateKey- | ElGamalPrivateKey Integer- | ECDHPrivateKey ECDSA_PrivateKey- | ECDSAPrivateKey ECDSA_PrivateKey- | EdDSAPrivateKey EdSigningCurve B.ByteString- | UnknownSKey ByteString- deriving (Data, Eq, Generic, Show, Typeable)+data SKey+ = RSAPrivateKey RSA_PrivateKey+ | DSAPrivateKey DSA_PrivateKey+ | ElGamalPrivateKey Integer+ | ECDHPrivateKey ECDSA_PrivateKey+ | ECDSAPrivateKey ECDSA_PrivateKey+ | EdDSAPrivateKey EdSigningCurve B.ByteString+ | UnknownSKey ByteString+ deriving (Data, Eq, Generic, Show, Typeable) instance Hashable SKey instance Pretty SKey where- pretty (RSAPrivateKey p) = pretty "RSA" <+> pretty p- pretty (DSAPrivateKey p) = pretty "DSA" <+> pretty p- pretty (ElGamalPrivateKey p) = pretty "Elgamal" <+> pretty p- pretty (ECDHPrivateKey p) = pretty "ECDH" <+> pretty p- pretty (ECDSAPrivateKey p) = pretty "ECDSA" <+> pretty p- pretty (EdDSAPrivateKey c bs) = pretty c <+> pretty (bsToHexUpper (BL.fromStrict bs))- pretty (UnknownSKey bs) = pretty "<unknown>" <+> pretty (bsToHexUpper bs)+ pretty (RSAPrivateKey p) = pretty "RSA" <+> pretty p+ pretty (DSAPrivateKey p) = pretty "DSA" <+> pretty p+ pretty (ElGamalPrivateKey p) = pretty "Elgamal" <+> pretty p+ pretty (ECDHPrivateKey p) = pretty "ECDH" <+> pretty p+ pretty (ECDSAPrivateKey p) = pretty "ECDSA" <+> pretty p+ pretty (EdDSAPrivateKey c bs) =+ pretty c <+> pretty (bsToHexUpper (BL.fromStrict bs))+ pretty (UnknownSKey bs) = pretty "<unknown>" <+> pretty (bsToHexUpper bs) instance A.ToJSON SKey where- toJSON (RSAPrivateKey k) = A.toJSON k- toJSON (DSAPrivateKey k) = A.toJSON k- toJSON (ElGamalPrivateKey k) = A.toJSON k- toJSON (ECDHPrivateKey k) = A.toJSON k- toJSON (ECDSAPrivateKey k) = A.toJSON k- toJSON (EdDSAPrivateKey c bs) = A.toJSON (c, B.unpack bs)- toJSON (UnknownSKey bs) = A.toJSON (BL.unpack bs)+ toJSON (RSAPrivateKey k) = A.toJSON k+ toJSON (DSAPrivateKey k) = A.toJSON k+ toJSON (ElGamalPrivateKey k) = A.toJSON k+ toJSON (ECDHPrivateKey k) = A.toJSON k+ toJSON (ECDSAPrivateKey k) = A.toJSON k+ toJSON (EdDSAPrivateKey c bs) = A.toJSON (c, B.unpack bs)+ toJSON (UnknownSKey bs) = A.toJSON (BL.unpack bs) -data PKPayload = PKPayload {- _keyVersion :: KeyVersion+data PKPayload =+ PKPayload+ { _keyVersion :: KeyVersion , _timestamp :: ThirtyTwoBitTimeStamp , _v3exp :: V3Expiration , _pkalgo :: PubKeyAlgorithm , _pubkey :: PKey- } deriving (Data, Eq, Generic, Show, Typeable)+ }+ deriving (Data, Eq, Generic, Show, Typeable) instance Ord PKPayload where- compare = comparing _keyVersion <> comparing _timestamp <> comparing _v3exp <> comparing _pkalgo <> comparing _pubkey+ compare =+ comparing _keyVersion <> comparing _timestamp <> comparing _v3exp <>+ comparing _pkalgo <>+ comparing _pubkey instance Hashable PKPayload instance Pretty PKPayload where- pretty (PKPayload kv ts v3e pka p) = pretty kv <+> pretty ts <+> pretty v3e <+> pretty pka <+> pretty p+ pretty (PKPayload kv ts v3e pka p) =+ pretty kv <+> pretty ts <+> pretty v3e <+> pretty pka <+> pretty p $(ATH.deriveToJSON ATH.defaultOptions ''PKPayload) -data SKAddendum = SUS16bit SymmetricAlgorithm S2K IV ByteString- | SUSSHA1 SymmetricAlgorithm S2K IV ByteString- | SUSym SymmetricAlgorithm IV ByteString- | SUUnencrypted SKey Word16- deriving (Data, Eq, Generic, Show, Typeable)+data SKAddendum+ = SUS16bit SymmetricAlgorithm S2K IV ByteString+ | SUSSHA1 SymmetricAlgorithm S2K IV ByteString+ | SUSym SymmetricAlgorithm IV ByteString+ | SUUnencrypted SKey Word16+ deriving (Data, Eq, Generic, Show, Typeable) instance Ord SKAddendum where- compare a b = show a `compare` show b -- FIXME: this is ridiculous+ compare a b = show a `compare` show b -- FIXME: this is ridiculous instance Hashable SKAddendum instance Pretty SKAddendum where- pretty (SUS16bit sa s2k iv bs) = pretty "SUS16bit" <+> pretty sa <+> pretty s2k <+> pretty iv <+> pretty (bsToHexUpper bs)- pretty (SUSSHA1 sa s2k iv bs) = pretty "SUSSHA1" <+> pretty sa <+> pretty s2k <+> pretty iv <+> pretty (bsToHexUpper bs)- pretty (SUSym sa iv bs) = pretty "SUSym" <+> pretty sa <+> pretty iv <+> pretty (bsToHexUpper bs)- pretty (SUUnencrypted s ck) = pretty "SUUnencrypted" <+> pretty s <+> pretty ck+ pretty (SUS16bit sa s2k iv bs) =+ pretty "SUS16bit" <+>+ pretty sa <+> pretty s2k <+> pretty iv <+> pretty (bsToHexUpper bs)+ pretty (SUSSHA1 sa s2k iv bs) =+ pretty "SUSSHA1" <+>+ pretty sa <+> pretty s2k <+> pretty iv <+> pretty (bsToHexUpper bs)+ pretty (SUSym sa iv bs) =+ pretty "SUSym" <+> pretty sa <+> pretty iv <+> pretty (bsToHexUpper bs)+ pretty (SUUnencrypted s ck) =+ pretty "SUUnencrypted" <+> pretty s <+> pretty ck instance A.ToJSON SKAddendum where- toJSON (SUS16bit sa s2k iv bs) = A.toJSON (sa, s2k, iv, BL.unpack bs)- toJSON (SUSSHA1 sa s2k iv bs) = A.toJSON (sa, s2k, iv, BL.unpack bs)- toJSON (SUSym sa iv bs) = A.toJSON (sa, iv, BL.unpack bs)- toJSON (SUUnencrypted s ck) = A.toJSON (s, ck)+ toJSON (SUS16bit sa s2k iv bs) = A.toJSON (sa, s2k, iv, BL.unpack bs)+ toJSON (SUSSHA1 sa s2k iv bs) = A.toJSON (sa, s2k, iv, BL.unpack bs)+ toJSON (SUSym sa iv bs) = A.toJSON (sa, iv, BL.unpack bs)+ toJSON (SUUnencrypted s ck) = A.toJSON (s, ck)
Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs view
@@ -2,7 +2,6 @@ -- Copyright © 2012-2018 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}@@ -23,321 +22,419 @@ import Data.Data (Data) import Data.List.NonEmpty (NonEmpty) import Data.Text (Text)+import Data.Text.Prettyprint.Doc (Pretty(..)) import Data.Typeable (Typeable) import Data.Word (Word8)-import Data.Text.Prettyprint.Doc (Pretty(..)) class Packet a where- data PacketType a :: *- packetType :: a -> PacketType a- packetCode :: PacketType a -> Word8- toPkt :: a -> Pkt- fromPkt :: Pkt -> a+ data PacketType a :: *+ packetType :: a -> PacketType a+ packetCode :: PacketType a -> Word8+ toPkt :: a -> Pkt+ fromPkt :: Pkt -> a -data PKESK = PKESK+data PKESK =+ PKESK { _pkeskPacketVersion :: PacketVersion , _pkeskEightOctetKeyId :: EightOctetKeyId , _pkeskPubKeyAlgorithm :: PubKeyAlgorithm , _pkeskMPIs :: NonEmpty MPI- } deriving (Data, Eq, Show, Typeable)+ }+ deriving (Data, Eq, Show, Typeable)+ instance Packet PKESK where- data PacketType PKESK = PKESKType deriving (Show, Eq)- packetType _ = PKESKType- packetCode _ = 1- toPkt (PKESK a b c d) = PKESKPkt a b c d- fromPkt (PKESKPkt a b c d) = PKESK a b c d- fromPkt _ = error "Cannot coerce non-PKESK packet"+ data PacketType PKESK = PKESKType+ deriving (Show, Eq)+ packetType _ = PKESKType+ packetCode _ = 1+ toPkt (PKESK a b c d) = PKESKPkt a b c d+ fromPkt (PKESKPkt a b c d) = PKESK a b c d+ fromPkt _ = error "Cannot coerce non-PKESK packet" instance Pretty PKESK where- pretty = pretty . toPkt+ pretty = pretty . toPkt -newtype Signature = Signature -- FIXME?+newtype Signature =+ Signature -- FIXME? { _signaturePayload :: SignaturePayload- } deriving (Data, Eq, Show, Typeable)+ }+ deriving (Data, Eq, Show, Typeable)+ instance Packet Signature where- data PacketType Signature = SignatureType deriving (Show, Eq)- packetType _ = SignatureType- packetCode _ = 2- toPkt (Signature a) = SignaturePkt a- fromPkt (SignaturePkt a) = Signature a- fromPkt _ = error "Cannot coerce non-Signature packet"+ data PacketType Signature = SignatureType+ deriving (Show, Eq)+ packetType _ = SignatureType+ packetCode _ = 2+ toPkt (Signature a) = SignaturePkt a+ fromPkt (SignaturePkt a) = Signature a+ fromPkt _ = error "Cannot coerce non-Signature packet" instance Pretty Signature where- pretty = pretty . toPkt+ pretty = pretty . toPkt -data SKESK = SKESK+data SKESK =+ SKESK { _skeskPacketVersion :: PacketVersion , _skeskSymmetricAlgorithm :: SymmetricAlgorithm , _skeskS2K :: S2K , _skeskESK :: Maybe BL.ByteString- } deriving (Data, Eq, Show, Typeable)+ }+ deriving (Data, Eq, Show, Typeable)+ instance Packet SKESK where- data PacketType SKESK = SKESKType deriving (Show, Eq)- packetType _ = SKESKType- packetCode _ = 3- toPkt (SKESK a b c d) = SKESKPkt a b c d- fromPkt (SKESKPkt a b c d) = SKESK a b c d- fromPkt _ = error "Cannot coerce non-SKESK packet"+ data PacketType SKESK = SKESKType+ deriving (Show, Eq)+ packetType _ = SKESKType+ packetCode _ = 3+ toPkt (SKESK a b c d) = SKESKPkt a b c d+ fromPkt (SKESKPkt a b c d) = SKESK a b c d+ fromPkt _ = error "Cannot coerce non-SKESK packet" instance Pretty SKESK where- pretty = pretty . toPkt+ pretty = pretty . toPkt -data OnePassSignature = OnePassSignature+data OnePassSignature =+ OnePassSignature { _onePassSignaturePacketVersion :: PacketVersion , _onePassSignatureSigType :: SigType , _onePassSignatureHashAlgorithm :: HashAlgorithm , _onePassSignaturePubKeyAlgorithm :: PubKeyAlgorithm , _onePassSignatureEightOctetKeyId :: EightOctetKeyId , _onePassSignatureNestedFlag :: NestedFlag- } deriving (Data, Eq, Show, Typeable)+ }+ deriving (Data, Eq, Show, Typeable)+ instance Packet OnePassSignature where- data PacketType OnePassSignature = OnePassSignatureType deriving (Show, Eq)- packetType _ = OnePassSignatureType- packetCode _ = 4- toPkt (OnePassSignature a b c d e f) = OnePassSignaturePkt a b c d e f- fromPkt (OnePassSignaturePkt a b c d e f) = OnePassSignature a b c d e f- fromPkt _ = error "Cannot coerce non-OnePassSignature packet"+ data PacketType OnePassSignature = OnePassSignatureType+ deriving (Show, Eq)+ packetType _ = OnePassSignatureType+ packetCode _ = 4+ toPkt (OnePassSignature a b c d e f) = OnePassSignaturePkt a b c d e f+ fromPkt (OnePassSignaturePkt a b c d e f) = OnePassSignature a b c d e f+ fromPkt _ = error "Cannot coerce non-OnePassSignature packet" instance Pretty OnePassSignature where- pretty = pretty . toPkt+ pretty = pretty . toPkt -data SecretKey = SecretKey+data SecretKey =+ SecretKey { _secretKeyPKPayload :: PKPayload , _secretKeySKAddendum :: SKAddendum- } deriving (Data, Eq, Show, Typeable)+ }+ deriving (Data, Eq, Show, Typeable)+ instance Packet SecretKey where- data PacketType SecretKey = SecretKeyType deriving (Show, Eq)- packetType _ = SecretKeyType- packetCode _ = 5- toPkt (SecretKey a b) = SecretKeyPkt a b- fromPkt (SecretKeyPkt a b) = SecretKey a b- fromPkt _ = error "Cannot coerce non-SecretKey packet"+ data PacketType SecretKey = SecretKeyType+ deriving (Show, Eq)+ packetType _ = SecretKeyType+ packetCode _ = 5+ toPkt (SecretKey a b) = SecretKeyPkt a b+ fromPkt (SecretKeyPkt a b) = SecretKey a b+ fromPkt _ = error "Cannot coerce non-SecretKey packet" instance Pretty SecretKey where- pretty = pretty . toPkt+ pretty = pretty . toPkt -newtype PublicKey = PublicKey+newtype PublicKey =+ PublicKey { _publicKeyPKPayload :: PKPayload- } deriving (Data, Eq, Show, Typeable)+ }+ deriving (Data, Eq, Show, Typeable)+ instance Packet PublicKey where- data PacketType PublicKey = PublicKeyType deriving (Show, Eq)- packetType _ = PublicKeyType- packetCode _ = 6- toPkt (PublicKey a) = PublicKeyPkt a- fromPkt (PublicKeyPkt a) = PublicKey a- fromPkt _ = error "Cannot coerce non-PublicKey packet"+ data PacketType PublicKey = PublicKeyType+ deriving (Show, Eq)+ packetType _ = PublicKeyType+ packetCode _ = 6+ toPkt (PublicKey a) = PublicKeyPkt a+ fromPkt (PublicKeyPkt a) = PublicKey a+ fromPkt _ = error "Cannot coerce non-PublicKey packet" instance Pretty PublicKey where- pretty = pretty . toPkt+ pretty = pretty . toPkt -data SecretSubkey = SecretSubkey+data SecretSubkey =+ SecretSubkey { _secretSubkeyPKPayload :: PKPayload , _secretSubkeySKAddendum :: SKAddendum- } deriving (Data, Eq, Show, Typeable)+ }+ deriving (Data, Eq, Show, Typeable)+ instance Packet SecretSubkey where- data PacketType SecretSubkey = SecretSubkeyType deriving (Show, Eq)- packetType _ = SecretSubkeyType- packetCode _ = 7- toPkt (SecretSubkey a b) = SecretSubkeyPkt a b- fromPkt (SecretSubkeyPkt a b) = SecretSubkey a b- fromPkt _ = error "Cannot coerce non-SecretSubkey packet"+ data PacketType SecretSubkey = SecretSubkeyType+ deriving (Show, Eq)+ packetType _ = SecretSubkeyType+ packetCode _ = 7+ toPkt (SecretSubkey a b) = SecretSubkeyPkt a b+ fromPkt (SecretSubkeyPkt a b) = SecretSubkey a b+ fromPkt _ = error "Cannot coerce non-SecretSubkey packet" instance Pretty SecretSubkey where- pretty = pretty . toPkt+ pretty = pretty . toPkt -data CompressedData = CompressedData+data CompressedData =+ CompressedData { _compressedDataCompressionAlgorithm :: CompressionAlgorithm , _compressedDataPayload :: CompressedDataPayload- } deriving (Data, Eq, Show, Typeable)+ }+ deriving (Data, Eq, Show, Typeable)+ instance Packet CompressedData where- data PacketType CompressedData = CompressedDataType deriving (Show, Eq)- packetType _ = CompressedDataType- packetCode _ = 8- toPkt (CompressedData a b) = CompressedDataPkt a b- fromPkt (CompressedDataPkt a b) = CompressedData a b- fromPkt _ = error "Cannot coerce non-CompressedData packet"+ data PacketType CompressedData = CompressedDataType+ deriving (Show, Eq)+ packetType _ = CompressedDataType+ packetCode _ = 8+ toPkt (CompressedData a b) = CompressedDataPkt a b+ fromPkt (CompressedDataPkt a b) = CompressedData a b+ fromPkt _ = error "Cannot coerce non-CompressedData packet" instance Pretty CompressedData where- pretty = pretty . toPkt+ pretty = pretty . toPkt -newtype SymEncData = SymEncData+newtype SymEncData =+ SymEncData { _symEncDataPayload :: ByteString- } deriving (Data, Eq, Show, Typeable)+ }+ deriving (Data, Eq, Show, Typeable)+ instance Packet SymEncData where- data PacketType SymEncData = SymEncDataType deriving (Show, Eq)- packetType _ = SymEncDataType- packetCode _ = 9- toPkt (SymEncData a) = SymEncDataPkt a- fromPkt (SymEncDataPkt a) = SymEncData a- fromPkt _ = error "Cannot coerce non-SymEncData packet"+ data PacketType SymEncData = SymEncDataType+ deriving (Show, Eq)+ packetType _ = SymEncDataType+ packetCode _ = 9+ toPkt (SymEncData a) = SymEncDataPkt a+ fromPkt (SymEncDataPkt a) = SymEncData a+ fromPkt _ = error "Cannot coerce non-SymEncData packet" instance Pretty SymEncData where- pretty = pretty . toPkt+ pretty = pretty . toPkt -newtype Marker = Marker+newtype Marker =+ Marker { _markerPayload :: ByteString- } deriving (Data, Eq, Show, Typeable)+ }+ deriving (Data, Eq, Show, Typeable)+ instance Packet Marker where- data PacketType Marker = MarkerType deriving (Show, Eq)- packetType _ = MarkerType- packetCode _ = 10- toPkt (Marker a) = MarkerPkt a- fromPkt (MarkerPkt a) = Marker a- fromPkt _ = error "Cannot coerce non-Marker packet"+ data PacketType Marker = MarkerType+ deriving (Show, Eq)+ packetType _ = MarkerType+ packetCode _ = 10+ toPkt (Marker a) = MarkerPkt a+ fromPkt (MarkerPkt a) = Marker a+ fromPkt _ = error "Cannot coerce non-Marker packet" instance Pretty Marker where- pretty = pretty . toPkt+ pretty = pretty . toPkt -data LiteralData = LiteralData+data LiteralData =+ LiteralData { _literalDataDataType :: DataType , _literalDataFileName :: FileName , _literalDataTimeStamp :: ThirtyTwoBitTimeStamp , _literalDataPayload :: ByteString- } deriving (Data, Eq, Show, Typeable)+ }+ deriving (Data, Eq, Show, Typeable)+ instance Packet LiteralData where- data PacketType LiteralData = LiteralDataType deriving (Show, Eq)- packetType _ = LiteralDataType- packetCode _ = 11- toPkt (LiteralData a b c d) = LiteralDataPkt a b c d- fromPkt (LiteralDataPkt a b c d) = LiteralData a b c d- fromPkt _ = error "Cannot coerce non-LiteralData packet"+ data PacketType LiteralData = LiteralDataType+ deriving (Show, Eq)+ packetType _ = LiteralDataType+ packetCode _ = 11+ toPkt (LiteralData a b c d) = LiteralDataPkt a b c d+ fromPkt (LiteralDataPkt a b c d) = LiteralData a b c d+ fromPkt _ = error "Cannot coerce non-LiteralData packet" instance Pretty LiteralData where- pretty = pretty . toPkt+ pretty = pretty . toPkt -newtype Trust = Trust+newtype Trust =+ Trust { _trustPayload :: ByteString- } deriving (Data, Eq, Show, Typeable)+ }+ deriving (Data, Eq, Show, Typeable)+ instance Packet Trust where- data PacketType Trust = TrustType deriving (Show, Eq)- packetType _ = TrustType- packetCode _ = 12- toPkt (Trust a) = TrustPkt a- fromPkt (TrustPkt a) = Trust a- fromPkt _ = error "Cannot coerce non-Trust packet"+ data PacketType Trust = TrustType+ deriving (Show, Eq)+ packetType _ = TrustType+ packetCode _ = 12+ toPkt (Trust a) = TrustPkt a+ fromPkt (TrustPkt a) = Trust a+ fromPkt _ = error "Cannot coerce non-Trust packet" instance Pretty Trust where- pretty = pretty . toPkt+ pretty = pretty . toPkt -newtype UserId = UserId+newtype UserId =+ UserId { _userIdPayload :: Text- } deriving (Data, Eq, Show, Typeable)+ }+ deriving (Data, Eq, Show, Typeable)+ instance Packet UserId where- data PacketType UserId = UserIdType deriving (Show, Eq)- packetType _ = UserIdType- packetCode _ = 13- toPkt (UserId a) = UserIdPkt a- fromPkt (UserIdPkt a) = UserId a- fromPkt _ = error "Cannot coerce non-UserId packet"+ data PacketType UserId = UserIdType+ deriving (Show, Eq)+ packetType _ = UserIdType+ packetCode _ = 13+ toPkt (UserId a) = UserIdPkt a+ fromPkt (UserIdPkt a) = UserId a+ fromPkt _ = error "Cannot coerce non-UserId packet" instance Pretty UserId where- pretty = pretty . toPkt+ pretty = pretty . toPkt -newtype PublicSubkey = PublicSubkey+newtype PublicSubkey =+ PublicSubkey { _publicSubkeyPKPayload :: PKPayload- } deriving (Data, Eq, Show, Typeable)+ }+ deriving (Data, Eq, Show, Typeable)+ instance Packet PublicSubkey where- data PacketType PublicSubkey = PublicSubkeyType deriving (Show, Eq)- packetType _ = PublicSubkeyType- packetCode _ = 14- toPkt (PublicSubkey a) = PublicSubkeyPkt a- fromPkt (PublicSubkeyPkt a) = PublicSubkey a- fromPkt _ = error "Cannot coerce non-PublicSubkey packet"+ data PacketType PublicSubkey = PublicSubkeyType+ deriving (Show, Eq)+ packetType _ = PublicSubkeyType+ packetCode _ = 14+ toPkt (PublicSubkey a) = PublicSubkeyPkt a+ fromPkt (PublicSubkeyPkt a) = PublicSubkey a+ fromPkt _ = error "Cannot coerce non-PublicSubkey packet" instance Pretty PublicSubkey where- pretty = pretty . toPkt+ pretty = pretty . toPkt -newtype UserAttribute = UserAttribute+newtype UserAttribute =+ UserAttribute { _userAttributeSubPackets :: [UserAttrSubPacket]- } deriving (Data, Eq, Show, Typeable)+ }+ deriving (Data, Eq, Show, Typeable)+ instance Packet UserAttribute where- data PacketType UserAttribute = UserAttributeType deriving (Show, Eq)- packetType _ = UserAttributeType- packetCode _ = 17- toPkt (UserAttribute a) = UserAttributePkt a- fromPkt (UserAttributePkt a) = UserAttribute a- fromPkt _ = error "Cannot coerce non-UserAttribute packet"+ data PacketType UserAttribute = UserAttributeType+ deriving (Show, Eq)+ packetType _ = UserAttributeType+ packetCode _ = 17+ toPkt (UserAttribute a) = UserAttributePkt a+ fromPkt (UserAttributePkt a) = UserAttribute a+ fromPkt _ = error "Cannot coerce non-UserAttribute packet" instance Pretty UserAttribute where- pretty = pretty . toPkt+ pretty = pretty . toPkt -data SymEncIntegrityProtectedData = SymEncIntegrityProtectedData+data SymEncIntegrityProtectedData =+ SymEncIntegrityProtectedData { _symEncIntegrityProtectedDataPacketVersion :: PacketVersion , _symEncIntegrityProtectedDataPayload :: ByteString- } deriving (Data, Eq, Show, Typeable)+ }+ deriving (Data, Eq, Show, Typeable)+ instance Packet SymEncIntegrityProtectedData where- data PacketType SymEncIntegrityProtectedData = SymEncIntegrityProtectedDataType deriving (Show, Eq)- packetType _ = SymEncIntegrityProtectedDataType- packetCode _ = 18- toPkt (SymEncIntegrityProtectedData a b) = SymEncIntegrityProtectedDataPkt a b- fromPkt (SymEncIntegrityProtectedDataPkt a b) = SymEncIntegrityProtectedData a b- fromPkt _ = error "Cannot coerce non-SymEncIntegrityProtectedData packet"+ data PacketType+ SymEncIntegrityProtectedData = SymEncIntegrityProtectedDataType+ deriving (Show, Eq)+ packetType _ = SymEncIntegrityProtectedDataType+ packetCode _ = 18+ toPkt (SymEncIntegrityProtectedData a b) = SymEncIntegrityProtectedDataPkt a b+ fromPkt (SymEncIntegrityProtectedDataPkt a b) =+ SymEncIntegrityProtectedData a b+ fromPkt _ = error "Cannot coerce non-SymEncIntegrityProtectedData packet" instance Pretty SymEncIntegrityProtectedData where- pretty = pretty . toPkt+ pretty = pretty . toPkt -newtype ModificationDetectionCode = ModificationDetectionCode+newtype ModificationDetectionCode =+ ModificationDetectionCode { _modificationDetectionCodePayload :: ByteString- } deriving (Data, Eq, Show, Typeable)+ }+ deriving (Data, Eq, Show, Typeable)+ instance Packet ModificationDetectionCode where- data PacketType ModificationDetectionCode = ModificationDetectionCodeType deriving (Show, Eq)- packetType _ = ModificationDetectionCodeType- packetCode _ = 19- toPkt (ModificationDetectionCode a) = ModificationDetectionCodePkt a- fromPkt (ModificationDetectionCodePkt a) = ModificationDetectionCode a- fromPkt _ = error "Cannot coerce non-ModificationDetectionCode packet"+ data PacketType+ ModificationDetectionCode = ModificationDetectionCodeType+ deriving (Show, Eq)+ packetType _ = ModificationDetectionCodeType+ packetCode _ = 19+ toPkt (ModificationDetectionCode a) = ModificationDetectionCodePkt a+ fromPkt (ModificationDetectionCodePkt a) = ModificationDetectionCode a+ fromPkt _ = error "Cannot coerce non-ModificationDetectionCode packet" instance Pretty ModificationDetectionCode where- pretty = pretty . toPkt+ pretty = pretty . toPkt -data OtherPacket = OtherPacket+data OtherPacket =+ OtherPacket { _otherPacketType :: Word8 , _otherPacketPayload :: ByteString- } deriving (Data, Eq, Show, Typeable)+ }+ deriving (Data, Eq, Show, Typeable)+ instance Packet OtherPacket where- data PacketType OtherPacket = OtherPacketType deriving (Show, Eq)- packetType _ = OtherPacketType- packetCode _ = undefined -- FIXME- toPkt (OtherPacket a b) = OtherPacketPkt a b- fromPkt (OtherPacketPkt a b) = OtherPacket a b- fromPkt _ = error "Cannot coerce non-OtherPacket packet"+ data PacketType OtherPacket = OtherPacketType+ deriving (Show, Eq)+ packetType _ = OtherPacketType+ packetCode _ = undefined -- FIXME+ toPkt (OtherPacket a b) = OtherPacketPkt a b+ fromPkt (OtherPacketPkt a b) = OtherPacket a b+ fromPkt _ = error "Cannot coerce non-OtherPacket packet" instance Pretty OtherPacket where- pretty = pretty . toPkt+ pretty = pretty . toPkt -data BrokenPacket = BrokenPacket+data BrokenPacket =+ BrokenPacket { _brokenPacketParseError :: String , _brokenPacketType :: Word8 , _brokenPacketPayload :: ByteString- } deriving (Data, Eq, Show, Typeable)+ }+ deriving (Data, Eq, Show, Typeable)+ instance Packet BrokenPacket where- data PacketType BrokenPacket = BrokenPacketType deriving (Show, Eq)- packetType _ = BrokenPacketType- packetCode _ = undefined- toPkt (BrokenPacket a b c) = BrokenPacketPkt a b c- fromPkt (BrokenPacketPkt a b c) = BrokenPacket a b c- fromPkt _ = error "Cannot coerce non-BrokenPacket packet"+ data PacketType BrokenPacket = BrokenPacketType+ deriving (Show, Eq)+ packetType _ = BrokenPacketType+ packetCode _ = undefined+ toPkt (BrokenPacket a b c) = BrokenPacketPkt a b c+ fromPkt (BrokenPacketPkt a b c) = BrokenPacket a b c+ fromPkt _ = error "Cannot coerce non-BrokenPacket packet" instance Pretty BrokenPacket where- pretty = pretty . toPkt+ pretty = pretty . toPkt $(makeLenses ''PKESK)+ $(makeLenses ''Signature)+ $(makeLenses ''SKESK)+ $(makeLenses ''OnePassSignature)+ $(makeLenses ''SecretKey)+ $(makeLenses ''PKPayload)+ $(makeLenses ''PublicKey)+ $(makeLenses ''SecretSubkey)+ $(makeLenses ''CompressedData)+ $(makeLenses ''SymEncData)+ $(makeLenses ''Marker)+ $(makeLenses ''LiteralData)+ $(makeLenses ''Trust)+ $(makeLenses ''UserId)+ $(makeLenses ''PublicSubkey)+ $(makeLenses ''UserAttribute)+ $(makeLenses ''SymEncIntegrityProtectedData)+ $(makeLenses ''ModificationDetectionCode)+ $(makeLenses ''OtherPacket)+ $(makeLenses ''BrokenPacket)
Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs view
@@ -2,7 +2,6 @@ -- Copyright © 2012-2018 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}@@ -18,6 +17,7 @@ import Codec.Encryption.OpenPGP.Types.Internal.Base import Codec.Encryption.OpenPGP.Types.Internal.PKITypes +import Codec.Encryption.OpenPGP.Types.Internal.PrettyUtils (prettyLBS) import Control.Lens (makeLenses) import Data.Aeson ((.=), object) import qualified Data.Aeson as A@@ -31,103 +31,197 @@ import Data.Ord (comparing) import Data.Text (Text) import qualified Data.Text as T+import Data.Text.Prettyprint.Doc (Pretty(..), (<+>)) import Data.Typeable (Typeable) import Data.Word (Word8)-import Data.Text.Prettyprint.Doc (Pretty(..), (<+>))-import Codec.Encryption.OpenPGP.Types.Internal.PrettyUtils (prettyLBS) -- data Pkt = forall a. (Packet a, Show a, Eq a) => Pkt a-data Pkt = PKESKPkt PacketVersion EightOctetKeyId PubKeyAlgorithm (NonEmpty MPI)- | SignaturePkt SignaturePayload- | SKESKPkt PacketVersion SymmetricAlgorithm S2K (Maybe BL.ByteString)- | OnePassSignaturePkt PacketVersion SigType HashAlgorithm PubKeyAlgorithm EightOctetKeyId NestedFlag- | SecretKeyPkt PKPayload SKAddendum- | PublicKeyPkt PKPayload- | SecretSubkeyPkt PKPayload SKAddendum- | CompressedDataPkt CompressionAlgorithm CompressedDataPayload- | SymEncDataPkt ByteString- | MarkerPkt ByteString- | LiteralDataPkt DataType FileName ThirtyTwoBitTimeStamp ByteString- | TrustPkt ByteString- | UserIdPkt Text- | PublicSubkeyPkt PKPayload- | UserAttributePkt [UserAttrSubPacket]- | SymEncIntegrityProtectedDataPkt PacketVersion ByteString- | ModificationDetectionCodePkt ByteString- | OtherPacketPkt Word8 ByteString- | BrokenPacketPkt String Word8 ByteString- deriving (Data, Eq, Generic, Show, Typeable) -- FIXME+data Pkt+ = PKESKPkt PacketVersion EightOctetKeyId PubKeyAlgorithm (NonEmpty MPI)+ | SignaturePkt SignaturePayload+ | SKESKPkt PacketVersion SymmetricAlgorithm S2K (Maybe BL.ByteString)+ | OnePassSignaturePkt+ PacketVersion+ SigType+ HashAlgorithm+ PubKeyAlgorithm+ EightOctetKeyId+ NestedFlag+ | SecretKeyPkt PKPayload SKAddendum+ | PublicKeyPkt PKPayload+ | SecretSubkeyPkt PKPayload SKAddendum+ | CompressedDataPkt CompressionAlgorithm CompressedDataPayload+ | SymEncDataPkt ByteString+ | MarkerPkt ByteString+ | LiteralDataPkt DataType FileName ThirtyTwoBitTimeStamp ByteString+ | TrustPkt ByteString+ | UserIdPkt Text+ | PublicSubkeyPkt PKPayload+ | UserAttributePkt [UserAttrSubPacket]+ | SymEncIntegrityProtectedDataPkt PacketVersion ByteString+ | ModificationDetectionCodePkt ByteString+ | OtherPacketPkt Word8 ByteString+ | BrokenPacketPkt String Word8 ByteString+ deriving (Data, Eq, Generic, Show, Typeable) -- FIXME instance Hashable Pkt instance Ord Pkt where- compare = comparing pktTag <> comparing hash -- FIXME: is there something saner?+ compare = comparing pktTag <> comparing hash -- FIXME: is there something saner? instance Pretty Pkt where- pretty (PKESKPkt pv eoki pka mpis) = pretty "PKESK v" <> pretty pv <> pretty ':' <+> pretty eoki <+> pretty pka <+> (pretty . NE.toList) mpis- pretty (SignaturePkt sp) = pretty sp- pretty (SKESKPkt pv sa s2k mbs) = pretty "SKESK v" <> pretty pv <> pretty ':' <+> pretty sa <+> pretty s2k <+> pretty (fmap bsToHexUpper mbs)- pretty (OnePassSignaturePkt pv st ha pka eoki nestedflag) = pretty "one-pass signature v" <> pretty pv <> pretty ':' <+> pretty st <+> pretty ha <+> pretty pka <+> pretty eoki <+> pretty nestedflag- pretty (SecretKeyPkt pkp ska) = pretty "secret key:" <+> pretty pkp <+> pretty ska- pretty (PublicKeyPkt pkp) = pretty "public key:" <+> pretty pkp- pretty (SecretSubkeyPkt pkp ska) = pretty "secret subkey:" <+> pretty pkp <+> pretty ska- pretty (CompressedDataPkt ca cdp) = pretty "compressed-data:" <+> pretty ca <+> prettyLBS cdp- pretty (SymEncDataPkt bs) = pretty "symmetrically-encrypted-data:" <+> pretty (bsToHexUpper bs)- pretty (MarkerPkt bs) = pretty "marker:" <+> pretty (bsToHexUpper bs)- pretty (LiteralDataPkt dt fn ts bs) = pretty "literal-data" <+> pretty dt <+> prettyLBS fn <+> pretty ts <+> pretty (bsToHexUpper bs)- pretty (TrustPkt bs) = pretty "trust:" <+> pretty (BL.unpack bs)- pretty (UserIdPkt u) = pretty "user-ID:" <+> pretty u- pretty (PublicSubkeyPkt pkp) = pretty "public subkey:" <+> pretty pkp- pretty (UserAttributePkt us) = pretty "user-attribute:" <+> pretty us- pretty (SymEncIntegrityProtectedDataPkt pv bs) = pretty "symmetrically-encrypted-integrity-protected-data v" <> pretty pv <> pretty ':' <+> pretty (bsToHexUpper bs)- pretty (ModificationDetectionCodePkt bs) = pretty "MDC:" <+> pretty (bsToHexUpper bs)- pretty (OtherPacketPkt t bs) = pretty "unknown packet type" <+> pretty t <> pretty ':' <+> pretty (bsToHexUpper bs)- pretty (BrokenPacketPkt s t bs) = pretty "BROKEN packet (" <> pretty s <> pretty ')' <+> pretty t <> pretty ':' <+> pretty (bsToHexUpper bs)+ pretty (PKESKPkt pv eoki pka mpis) =+ pretty "PKESK v" <> pretty pv <> pretty ':' <+>+ pretty eoki <+> pretty pka <+> (pretty . NE.toList) mpis+ pretty (SignaturePkt sp) = pretty sp+ pretty (SKESKPkt pv sa s2k mbs) =+ pretty "SKESK v" <> pretty pv <> pretty ':' <+>+ pretty sa <+> pretty s2k <+> pretty (fmap bsToHexUpper mbs)+ pretty (OnePassSignaturePkt pv st ha pka eoki nestedflag) =+ pretty "one-pass signature v" <> pretty pv <> pretty ':' <+>+ pretty st <+> pretty ha <+> pretty pka <+> pretty eoki <+> pretty nestedflag+ pretty (SecretKeyPkt pkp ska) =+ pretty "secret key:" <+> pretty pkp <+> pretty ska+ pretty (PublicKeyPkt pkp) = pretty "public key:" <+> pretty pkp+ pretty (SecretSubkeyPkt pkp ska) =+ pretty "secret subkey:" <+> pretty pkp <+> pretty ska+ pretty (CompressedDataPkt ca cdp) =+ pretty "compressed-data:" <+> pretty ca <+> prettyLBS cdp+ pretty (SymEncDataPkt bs) =+ pretty "symmetrically-encrypted-data:" <+> pretty (bsToHexUpper bs)+ pretty (MarkerPkt bs) = pretty "marker:" <+> pretty (bsToHexUpper bs)+ pretty (LiteralDataPkt dt fn ts bs) =+ pretty "literal-data" <+>+ pretty dt <+> prettyLBS fn <+> pretty ts <+> pretty (bsToHexUpper bs)+ pretty (TrustPkt bs) = pretty "trust:" <+> pretty (BL.unpack bs)+ pretty (UserIdPkt u) = pretty "user-ID:" <+> pretty u+ pretty (PublicSubkeyPkt pkp) = pretty "public subkey:" <+> pretty pkp+ pretty (UserAttributePkt us) = pretty "user-attribute:" <+> pretty us+ pretty (SymEncIntegrityProtectedDataPkt pv bs) =+ pretty "symmetrically-encrypted-integrity-protected-data v" <> pretty pv <>+ pretty ':' <+>+ pretty (bsToHexUpper bs)+ pretty (ModificationDetectionCodePkt bs) =+ pretty "MDC:" <+> pretty (bsToHexUpper bs)+ pretty (OtherPacketPkt t bs) =+ pretty "unknown packet type" <+>+ pretty t <> pretty ':' <+> pretty (bsToHexUpper bs)+ pretty (BrokenPacketPkt s t bs) =+ pretty "BROKEN packet (" <> pretty s <> pretty ')' <+>+ pretty t <> pretty ':' <+> pretty (bsToHexUpper bs) instance A.ToJSON Pkt where- toJSON (PKESKPkt pv eoki pka mpis) = object [T.pack "pkesk" .= object [T.pack "version" .= pv, T.pack "keyid" .= eoki, T.pack "pkalgo" .= pka, T.pack "mpis" .= NE.toList mpis]]- toJSON (SignaturePkt sp) = object [T.pack "signature" .= sp]- toJSON (SKESKPkt pv sa s2k mbs) = object [T.pack "skesk" .= object [T.pack "version" .= pv, T.pack "symalgo" .= sa, T.pack "s2k" .= s2k, T.pack "data" .= maybe mempty BL.unpack mbs]]- toJSON (OnePassSignaturePkt pv st ha pka eoki nestedflag) = object [T.pack "onepasssignature" .= object [T.pack "version" .= pv, T.pack "sigtype" .= st, T.pack "hashalgo" .= ha, T.pack "pkalgo" .= pka, T.pack "keyid" .= eoki, T.pack "nested" .= nestedflag]]- toJSON (SecretKeyPkt pkp ska) = object [T.pack "secretkey" .= object [T.pack "public" .= pkp, T.pack "secret" .= ska]]- toJSON (PublicKeyPkt pkp) = object [T.pack "publickey" .= pkp]- toJSON (SecretSubkeyPkt pkp ska) = object [T.pack "secretsubkey" .= object [T.pack "public" .= pkp, T.pack "secret" .= ska]]- toJSON (CompressedDataPkt ca cdp) = object [T.pack "compresseddata" .= object [T.pack "compressionalgo" .= ca, T.pack "data" .= BL.unpack cdp]]- toJSON (SymEncDataPkt bs) = object [T.pack "symencdata" .= BL.unpack bs]- toJSON (MarkerPkt bs) = object [T.pack "marker" .= BL.unpack bs]- toJSON (LiteralDataPkt dt fn ts bs) = object [T.pack "literaldata" .= object [T.pack "dt" .= dt, T.pack "filename" .= BL.unpack fn, T.pack "ts" .= ts, T.pack "data" .= BL.unpack bs]]- toJSON (TrustPkt bs) = object [T.pack "trust" .= BL.unpack bs]- toJSON (UserIdPkt u) = object [T.pack "userid" .= u]- toJSON (PublicSubkeyPkt pkp) = object [T.pack "publicsubkkey" .= pkp]- toJSON (UserAttributePkt us) = object [T.pack "userattribute" .= us]- toJSON (SymEncIntegrityProtectedDataPkt pv bs) = object [T.pack "symencipd" .= object [T.pack "version" .= pv, T.pack "data" .= BL.unpack bs]]- toJSON (ModificationDetectionCodePkt bs) = object [T.pack "mdc" .= BL.unpack bs]- toJSON (OtherPacketPkt t bs) = object [T.pack "otherpacket" .= object [T.pack "tag" .= t, T.pack "data" .= BL.unpack bs]]- toJSON (BrokenPacketPkt s t bs) = object [T.pack "brokenpacket" .= object [T.pack "error" .= s, T.pack "tag" .= t, T.pack "data" .= BL.unpack bs]]+ toJSON (PKESKPkt pv eoki pka mpis) =+ object+ [ T.pack "pkesk" .=+ object+ [ T.pack "version" .= pv+ , T.pack "keyid" .= eoki+ , T.pack "pkalgo" .= pka+ , T.pack "mpis" .= NE.toList mpis+ ]+ ]+ toJSON (SignaturePkt sp) = object [T.pack "signature" .= sp]+ toJSON (SKESKPkt pv sa s2k mbs) =+ object+ [ T.pack "skesk" .=+ object+ [ T.pack "version" .= pv+ , T.pack "symalgo" .= sa+ , T.pack "s2k" .= s2k+ , T.pack "data" .= maybe mempty BL.unpack mbs+ ]+ ]+ toJSON (OnePassSignaturePkt pv st ha pka eoki nestedflag) =+ object+ [ T.pack "onepasssignature" .=+ object+ [ T.pack "version" .= pv+ , T.pack "sigtype" .= st+ , T.pack "hashalgo" .= ha+ , T.pack "pkalgo" .= pka+ , T.pack "keyid" .= eoki+ , T.pack "nested" .= nestedflag+ ]+ ]+ toJSON (SecretKeyPkt pkp ska) =+ object+ [ T.pack "secretkey" .=+ object [T.pack "public" .= pkp, T.pack "secret" .= ska]+ ]+ toJSON (PublicKeyPkt pkp) = object [T.pack "publickey" .= pkp]+ toJSON (SecretSubkeyPkt pkp ska) =+ object+ [ T.pack "secretsubkey" .=+ object [T.pack "public" .= pkp, T.pack "secret" .= ska]+ ]+ toJSON (CompressedDataPkt ca cdp) =+ object+ [ T.pack "compresseddata" .=+ object [T.pack "compressionalgo" .= ca, T.pack "data" .= BL.unpack cdp]+ ]+ toJSON (SymEncDataPkt bs) = object [T.pack "symencdata" .= BL.unpack bs]+ toJSON (MarkerPkt bs) = object [T.pack "marker" .= BL.unpack bs]+ toJSON (LiteralDataPkt dt fn ts bs) =+ object+ [ T.pack "literaldata" .=+ object+ [ T.pack "dt" .= dt+ , T.pack "filename" .= BL.unpack fn+ , T.pack "ts" .= ts+ , T.pack "data" .= BL.unpack bs+ ]+ ]+ toJSON (TrustPkt bs) = object [T.pack "trust" .= BL.unpack bs]+ toJSON (UserIdPkt u) = object [T.pack "userid" .= u]+ toJSON (PublicSubkeyPkt pkp) = object [T.pack "publicsubkkey" .= pkp]+ toJSON (UserAttributePkt us) = object [T.pack "userattribute" .= us]+ toJSON (SymEncIntegrityProtectedDataPkt pv bs) =+ object+ [ T.pack "symencipd" .=+ object [T.pack "version" .= pv, T.pack "data" .= BL.unpack bs]+ ]+ toJSON (ModificationDetectionCodePkt bs) =+ object [T.pack "mdc" .= BL.unpack bs]+ toJSON (OtherPacketPkt t bs) =+ object+ [ T.pack "otherpacket" .=+ object [T.pack "tag" .= t, T.pack "data" .= BL.unpack bs]+ ]+ toJSON (BrokenPacketPkt s t bs) =+ object+ [ T.pack "brokenpacket" .=+ object+ [ T.pack "error" .= s+ , T.pack "tag" .= t+ , T.pack "data" .= BL.unpack bs+ ]+ ] pktTag :: Pkt -> Word8-pktTag PKESKPkt{} = 1+pktTag PKESKPkt {} = 1 pktTag (SignaturePkt _) = 2-pktTag SKESKPkt{} = 3-pktTag OnePassSignaturePkt{} = 4-pktTag SecretKeyPkt{} = 5+pktTag SKESKPkt {} = 3+pktTag OnePassSignaturePkt {} = 4+pktTag SecretKeyPkt {} = 5 pktTag (PublicKeyPkt _) = 6-pktTag SecretSubkeyPkt{} = 7-pktTag CompressedDataPkt{} = 8+pktTag SecretSubkeyPkt {} = 7+pktTag CompressedDataPkt {} = 8 pktTag (SymEncDataPkt _) = 9 pktTag (MarkerPkt _) = 10-pktTag LiteralDataPkt{} = 11+pktTag LiteralDataPkt {} = 11 pktTag (TrustPkt _) = 12 pktTag (UserIdPkt _) = 13 pktTag (PublicSubkeyPkt _) = 14 pktTag (UserAttributePkt _) = 17-pktTag SymEncIntegrityProtectedDataPkt{} = 18+pktTag SymEncIntegrityProtectedDataPkt {} = 18 pktTag (ModificationDetectionCodePkt _) = 19 pktTag (OtherPacketPkt t _) = t pktTag (BrokenPacketPkt _ t _) = t -- is this the right thing to do? -data Verification = Verification {- _verificationSigner :: PKPayload+data Verification =+ Verification+ { _verificationSigner :: PKPayload , _verificationSignature :: SignaturePayload }
Codec/Encryption/OpenPGP/Types/Internal/PrettyUtils.hs view
@@ -2,13 +2,12 @@ -- Copyright © 2018 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- module Codec.Encryption.OpenPGP.Types.Internal.PrettyUtils where import qualified Data.ByteString.Lazy as BL import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode)-import Data.Text.Prettyprint.Doc (Pretty(..), Doc)+import Data.Text.Prettyprint.Doc (Doc, Pretty(..)) prettyBS = pretty . decodeUtf8With lenientDecode
Codec/Encryption/OpenPGP/Types/Internal/TK.hs view
@@ -2,7 +2,6 @@ -- Copyright © 2012-2016 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}@@ -24,20 +23,23 @@ import Data.Text (Text) import Data.Typeable (Typeable) -data TK = TK {- _tkKey :: (PKPayload, Maybe SKAddendum)- , _tkRevs :: [SignaturePayload]- , _tkUIDs :: [(Text, [SignaturePayload])]- , _tkUAts :: [([UserAttrSubPacket], [SignaturePayload])]- , _tkSubs :: [(Pkt, [SignaturePayload])]- } deriving (Data, Eq, Generic, Show, Typeable)+data TK =+ TK+ { _tkKey :: (PKPayload, Maybe SKAddendum)+ , _tkRevs :: [SignaturePayload]+ , _tkUIDs :: [(Text, [SignaturePayload])]+ , _tkUAts :: [([UserAttrSubPacket], [SignaturePayload])]+ , _tkSubs :: [(Pkt, [SignaturePayload])]+ }+ deriving (Data, Eq, Generic, Show, Typeable) instance Ord TK where- compare = comparing _tkKey -- FIXME: is this ridiculous?+ compare = comparing _tkKey -- FIXME: is this ridiculous? $(ATH.deriveToJSON ATH.defaultOptions ''TK) -type KeyringIxs = '[EightOctetKeyId, TwentyOctetFingerprint, Text]+type KeyringIxs = '[ EightOctetKeyId, TwentyOctetFingerprint, Text]+ type Keyring = IxSet KeyringIxs TK $(makeLenses ''TK)
Data/Conduit/OpenPGP/Compression.hs view
@@ -2,17 +2,16 @@ -- Copyright © 2012-2018 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).--module Data.Conduit.OpenPGP.Compression (- conduitCompress- , conduitDecompress-) where+module Data.Conduit.OpenPGP.Compression+ ( conduitCompress+ , conduitDecompress+ ) where import Codec.Encryption.OpenPGP.Compression import Codec.Encryption.OpenPGP.Types+import Control.Monad.Trans.Resource (MonadThrow) import Data.Conduit import qualified Data.Conduit.List as CL-import Control.Monad.Trans.Resource (MonadThrow) conduitCompress :: MonadThrow m => CompressionAlgorithm -> ConduitT Pkt Pkt m () conduitCompress algo = CL.consume >>= \ps -> yield (compressPkts algo ps)
Data/Conduit/OpenPGP/Decrypt.hs view
@@ -77,13 +77,15 @@ return (s, d) m@(ModificationDetectionCodePkt mdc) -> do when (isNothing (_lastClearText s)) $ fail "MDC with no referent"- let mcalculated =- calculateMDC <$> _lastNonce s <*> _lastClearText s+ let mcalculated = calculateMDC <$> _lastNonce s <*> _lastClearText s when (mcalculated /= Just mdc) $ fail $ "MDC indicates tampering: " ++ show (B16L.encode mdc) ++- " versus " ++ maybe "<empty>" (show . B16L.encode) mcalculated ++ " ... " ++ show (_lastNonce s) ++ " / " ++ show (_lastClearText s)+ " versus " +++ maybe "<empty>" (show . B16L.encode) mcalculated +++ " ... " +++ show (_lastNonce s) ++ " / " ++ show (_lastClearText s) return (s, [m]) p -> return (s, [p]) @@ -132,13 +134,18 @@ runConduitRes $ CB.sourceLbs (BL.fromStrict decrypted) .| conduitGet get .| conduitDecompress .|- conduitDecrypt' rs { _depth = _depth rs + 1, _lastNonce = Just nonce, _lastClearText = Just decrypted } cb .|+ conduitDecrypt'+ rs+ { _depth = _depth rs + 1+ , _lastNonce = Just nonce+ , _lastClearText = Just decrypted+ }+ cb .| CL.consume calculateMDC :: B.ByteString -> B.ByteString -> BL.ByteString calculateMDC nonce garbage- | B.length garbage < 23 = mempty -- FIXME: this is horrible- | otherwise =- BL.fromStrict .- BA.convert . (CH.hash :: B.ByteString -> CH.Digest CHA.SHA1) $- nonce <> B.take (B.length garbage - 22) garbage <> B.pack [211,20]+ | B.length garbage < 23 = mempty -- FIXME: this is horrible+ | otherwise =+ BL.fromStrict . BA.convert . (CH.hash :: B.ByteString -> CH.Digest CHA.SHA1) $+ nonce <> B.take (B.length garbage - 22) garbage <> B.pack [211, 20]
Data/Conduit/OpenPGP/Filter.hs view
@@ -2,14 +2,13 @@ -- Copyright © 2014-2018 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE GADTs #-} -module Data.Conduit.OpenPGP.Filter (- conduitPktFilter- , conduitTKFilter- , FilterPredicates(..)-) where+module Data.Conduit.OpenPGP.Filter+ ( conduitPktFilter+ , conduitTKFilter+ , FilterPredicates(..)+ ) where import Control.Monad.Trans.Reader (Reader, runReader) import Data.Conduit (ConduitT)@@ -17,21 +16,19 @@ import Codec.Encryption.OpenPGP.Types --data FilterPredicates =- RTKFilterPredicate (Reader TK Bool) -- ^ fp for transferable keys- | RPFilterPredicate (Reader Pkt Bool) -- ^ fp for context-less packets+data FilterPredicates+ = RTKFilterPredicate (Reader TK Bool) -- ^ fp for transferable keys+ | RPFilterPredicate (Reader Pkt Bool) -- ^ fp for context-less packets conduitPktFilter :: Monad m => FilterPredicates -> ConduitT Pkt Pkt m () conduitPktFilter = CL.filter . superPredicate superPredicate :: FilterPredicates -> Pkt -> Bool superPredicate (RPFilterPredicate e) p = runReader e p-superPredicate _ _ = False -- do not match incorrect type of packet+superPredicate _ _ = False -- do not match incorrect type of packet conduitTKFilter :: Monad m => FilterPredicates -> ConduitT TK TK m () conduitTKFilter = CL.filter . superTKPredicate superTKPredicate :: FilterPredicates -> TK -> Bool superTKPredicate (RTKFilterPredicate e) = runReader e-
Data/Conduit/OpenPGP/Keyring.hs view
@@ -2,24 +2,33 @@ -- Copyright © 2012-2018 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).--module Data.Conduit.OpenPGP.Keyring (- conduitToTKs- , conduitToTKsDropping- , sinkKeyringMap-) where+module Data.Conduit.OpenPGP.Keyring+ ( conduitToTKs+ , conduitToTKsDropping+ , sinkKeyringMap+ ) where import Data.Conduit import qualified Data.Conduit.List as CL import Data.IxSet.Typed (empty, insert) -import Codec.Encryption.OpenPGP.KeyringParser (finalizeParsing, parseAChunk, anyTK)-import Codec.Encryption.OpenPGP.Types+import Codec.Encryption.OpenPGP.KeyringParser+ ( anyTK+ , finalizeParsing+ , parseAChunk+ ) import Codec.Encryption.OpenPGP.Ontology (isTrustPkt)+import Codec.Encryption.OpenPGP.Types import Data.Conduit.OpenPGP.Keyring.Instances () -data Phase = MainKey | Revs | Uids | UAts | Subs | SkippingBroken- deriving (Eq, Ord, Show)+data Phase+ = MainKey+ | Revs+ | Uids+ | UAts+ | Subs+ | SkippingBroken+ deriving (Eq, Ord, Show) conduitToTKs :: Monad m => ConduitT Pkt TK m () conduitToTKs = conduitToTKs' True@@ -27,22 +36,31 @@ conduitToTKsDropping :: Monad m => ConduitT Pkt TK m () conduitToTKsDropping = conduitToTKs' False -fakecmAccum :: Monad m => (accum -> (accum, [b])) -> (a -> accum -> (accum, [b])) -> accum -> ConduitT a b m ()-fakecmAccum finalizer f =- loop+fakecmAccum ::+ Monad m+ => (accum -> (accum, [b]))+ -> (a -> accum -> (accum, [b]))+ -> accum+ -> ConduitT a b m ()+fakecmAccum finalizer f = loop where- loop accum =- await >>= maybe (mapM_ yield (snd (finalizer accum))) go+ loop accum = await >>= maybe (mapM_ yield (snd (finalizer accum))) go where go a = do- let (accum', bs) = f a accum- mapM_ yield bs- loop accum'+ let (accum', bs) = f a accum+ mapM_ yield bs+ loop accum' conduitToTKs' :: Monad m => Bool -> ConduitT Pkt TK m ()-conduitToTKs' intolerant = CL.filter notTrustPacket .| CL.map (:[]) .| fakecmAccum finalizeParsing (parseAChunk (anyTK intolerant)) ([], Just (Nothing, anyTK intolerant)) .| CL.catMaybes- where- notTrustPacket = not . isTrustPkt+conduitToTKs' intolerant =+ CL.filter notTrustPacket .| CL.map (: []) .|+ fakecmAccum+ finalizeParsing+ (parseAChunk (anyTK intolerant))+ ([], Just (Nothing, anyTK intolerant)) .|+ CL.catMaybes+ where+ notTrustPacket = not . isTrustPkt sinkKeyringMap :: Monad m => ConduitT TK Void m Keyring sinkKeyringMap = CL.fold (flip insert) empty
Data/Conduit/OpenPGP/Keyring/Instances.hs view
@@ -2,13 +2,13 @@ -- Copyright © 2012-2019 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} -module Data.Conduit.OpenPGP.Keyring.Instances (-) where+module Data.Conduit.OpenPGP.Keyring.Instances+ (+ ) where import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) import Codec.Encryption.OpenPGP.Internal (issuer)@@ -19,43 +19,51 @@ import Data.Either (rights) import Data.Function (on) import qualified Data.HashMap.Lazy as HashMap-import Data.IxSet.Typed (Indexable(..), ixList, ixFun)+import Data.IxSet.Typed (Indexable(..), ixFun, ixList) import Data.List (nub, sort) import qualified Data.Map as Map-import Data.Semigroup ((<>), Semigroup)+import Data.Semigroup (Semigroup, (<>)) import Data.Text (Text) instance Indexable KeyringIxs TK where- indices = ixList- (ixFun getEOKIs)- (ixFun getTOFs)- (ixFun getUIDs)+ indices = ixList (ixFun getEOKIs) (ixFun getTOFs) (ixFun getUIDs) getEOKIs :: TK -> [EightOctetKeyId] getEOKIs tk = rights (map eightOctetKeyID (tk ^.. biplate :: [PKPayload]))+ getTOFs :: TK -> [TwentyOctetFingerprint] getTOFs tk = map fingerprint (tk ^.. biplate :: [PKPayload])+ getUIDs :: TK -> [Text]-getUIDs tk = (tk^.tkUIDs)^..folded._1+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+ 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+ (<>) 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
Data/Conduit/OpenPGP/Verify.hs view
@@ -2,30 +2,35 @@ -- Copyright © 2012-2016 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).--module Data.Conduit.OpenPGP.Verify (- conduitVerify-) where+module Data.Conduit.OpenPGP.Verify+ ( conduitVerify+ ) where import Data.Conduit import Data.Time.Clock (UTCTime) import Codec.Encryption.OpenPGP.Internal (PktStreamContext(..), emptyPSC)+import Codec.Encryption.OpenPGP.Signatures (verifyAgainstKeyring, verifySigWith) import Codec.Encryption.OpenPGP.Types-import Codec.Encryption.OpenPGP.Signatures (verifySigWith, verifyAgainstKeyring) import qualified Data.Conduit.List as CL -conduitVerify :: Monad m => Keyring -> Maybe UTCTime -> ConduitT Pkt (Either String Verification) m ()+conduitVerify ::+ Monad m+ => Keyring+ -> Maybe UTCTime+ -> ConduitT Pkt (Either String Verification) m () conduitVerify kr mt = CL.concatMapAccum (flip push) emptyPSC- where- push state ld@LiteralDataPkt{} = (state { lastLD = ld }, [])- push state uid@(UserIdPkt _) = (state { lastUIDorUAt = uid }, [])- push state uat@(UserAttributePkt _) = (state { lastUIDorUAt = uat }, [])- push state pk@(PublicKeyPkt _) = (state { lastPrimaryKey = pk }, [])- 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 }, [verifySigWith (verifyAgainstKeyring kr) sig state mt])- push state (OnePassSignaturePkt _ _ _ _ _ False) = (state, [])- push state _ = (state, [])- normLineEndings = id -- FIXME+ where+ push state ld@LiteralDataPkt {} = (state {lastLD = ld}, [])+ push state uid@(UserIdPkt _) = (state {lastUIDorUAt = uid}, [])+ push state uat@(UserAttributePkt _) = (state {lastUIDorUAt = uat}, [])+ push state pk@(PublicKeyPkt _) = (state {lastPrimaryKey = pk}, [])+ 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}+ , [verifySigWith (verifyAgainstKeyring kr) sig state mt])+ push state (OnePassSignaturePkt _ _ _ _ _ False) = (state, [])+ push state _ = (state, [])+ normLineEndings = id -- FIXME
bench/mark.hs view
@@ -2,33 +2,56 @@ -- Copyright © 2014-2018 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE FlexibleContexts #-} import Criterion.Main -import Codec.Encryption.OpenPGP.Signatures (verifyTKWith, verifySigWith, verifyAgainstKeys, verifyAgainstKeyring)+import Codec.Encryption.OpenPGP.Signatures+ ( verifyAgainstKeyring+ , verifyAgainstKeys+ , verifySigWith+ , verifyTKWith+ ) -import Data.Conduit.Serialization.Binary (conduitGet)+import Data.Binary (get) import Data.Conduit.OpenPGP.Keyring (conduitToTKs, sinkKeyringMap)+import Data.Conduit.Serialization.Binary (conduitGet) import qualified Data.IxSet.Typed as IxSet-import Data.Binary (get) import qualified Data.Conduit as DC import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL main :: IO ()-main = defaultMain [- bgroup "keyring" [ bench "load keys" $ whnfIO (loadKeys "tests/data/pubring.gpg")- , bench "load keyring" $ whnfIO (loadKeyring "tests/data/pubring.gpg")- , bench "self-verify keys" $ whnfIO (selfVerifyKeys "tests/data/pubring.gpg")- , bench "self-verify keyring" $ whnfIO (selfVerifyKeyring "tests/data/pubring.gpg")- ]- ]+main =+ defaultMain+ [ bgroup+ "keyring"+ [ bench "load keys" $ whnfIO (loadKeys "tests/data/pubring.gpg")+ , bench "load keyring" $ whnfIO (loadKeyring "tests/data/pubring.gpg")+ , bench "self-verify keys" $+ whnfIO (selfVerifyKeys "tests/data/pubring.gpg")+ , bench "self-verify keyring" $+ whnfIO (selfVerifyKeyring "tests/data/pubring.gpg")+ ]+ ] where- loadKeys fp = DC.runConduitRes $ CB.sourceFile fp DC..| conduitGet get DC..| conduitToTKs DC..| CL.consume- loadKeyring fp = DC.runConduitRes $ CB.sourceFile fp DC..| conduitGet get DC..| conduitToTKs DC..| sinkKeyringMap-- selfVerifyKeys fp = fmap (\ks -> mapM (verifyTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks) (loadKeys fp)- selfVerifyKeyring fp = fmap (\kr -> mapM (verifyTKWith (verifySigWith (verifyAgainstKeyring kr)) Nothing) (IxSet.toList kr)) (loadKeyring fp)+ loadKeys fp =+ DC.runConduitRes $+ CB.sourceFile fp DC..| conduitGet get DC..| conduitToTKs DC..| CL.consume+ loadKeyring fp =+ DC.runConduitRes $+ CB.sourceFile fp DC..| conduitGet get DC..| conduitToTKs DC..|+ sinkKeyringMap+ selfVerifyKeys fp =+ fmap+ (\ks ->+ mapM (verifyTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks)+ (loadKeys fp)+ selfVerifyKeyring fp =+ fmap+ (\kr ->+ mapM+ (verifyTKWith (verifySigWith (verifyAgainstKeyring kr)) Nothing)+ (IxSet.toList kr))+ (loadKeyring fp)
hOpenPGP.cabal view
@@ -1,5 +1,5 @@ Name: hOpenPGP-Version: 2.8.3+Version: 2.8.4 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@@ -153,6 +153,8 @@ , tests/data/ed25519-without-curve25519.pubkey , tests/data/ed25519.pubkey , tests/data/ed25519.secretkey+ , tests/data/encryption-sym-pgcrypto.pgp+ , tests/data/pgcrypto-passphrase.txt Cabal-version: >= 1.10 flag network-uri@@ -277,7 +279,6 @@ , unordered-containers , zlib , tasty- , tasty-expected-failure , tasty-hunit , tasty-quickcheck , QuickCheck > 2.9@@ -342,4 +343,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hOpenPGP.git- tag: v2.8.3+ tag: v2.8.4
+ tests/data/encryption-sym-pgcrypto.pgp view
@@ -0,0 +1,1 @@+à ZvWñÁiÒ=Ê»§CÒ²|l+«¬²ù(ÍTÆ+U.M½Æ%EÈ4Y7òÈÁÐn¯ÅSôr¡ÕöGpZ ¿
+ tests/data/pgcrypto-passphrase.txt view
@@ -0,0 +1,1 @@+blocks
tests/suite.hs view
@@ -23,8 +23,8 @@ , verifyTKWith ) import Codec.Encryption.OpenPGP.Types-import Control.Exception.Base (catch, SomeException) import Control.Error.Util (isRight)+import Control.Exception.Base (SomeException, catch) import Control.Monad.Trans.Resource (ResourceT) import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import qualified Crypto.PubKey.RSA as RSA@@ -854,11 +854,11 @@ "symmetric-password.txt" "test\n") , testCase- "Symmetric Encryption pgcrypto"- (testSymmetricEncryption- "encryption-sym-pgcrypto.pgp"- "pgcrypto-passphrase.txt"- "{\"t\":\"plus\"}")+ "Symmetric Encryption pgcrypto"+ (testSymmetricEncryption+ "encryption-sym-pgcrypto.pgp"+ "pgcrypto-passphrase.txt"+ "{\"t\":\"plus\"}") ] , testGroup "Encrypted secret keys"