hOpenPGP-2.5.5/0000755000000000000000000000000012770565031011337 5ustar0000000000000000hOpenPGP-2.5.5/Setup.hs0000644000000000000000000000005612770565031012774 0ustar0000000000000000import Distribution.Simple main = defaultMain hOpenPGP-2.5.5/LICENSE0000644000000000000000000000207612770565031012351 0ustar0000000000000000Copyright © 2012-2014 Clint Adams Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. hOpenPGP-2.5.5/hOpenPGP.cabal0000644000000000000000000003007712770565031013752 0ustar0000000000000000Name: hOpenPGP Version: 2.5.5 Synopsis: native Haskell implementation of OpenPGP (RFC4880) Description: native Haskell implementation of OpenPGP (RFC4880), plus Camellia (RFC5581) Homepage: http://floss.scru.org/hOpenPGP/ License: MIT License-file: LICENSE Author: Clint Adams Maintainer: Clint Adams Copyright: 2012-2016 Clint Adams Category: Codec, Data Build-type: Simple Extra-source-files: tests/suite.hs , tests/data/000001-006.public_key , tests/data/000002-013.user_id , tests/data/000003-002.sig , tests/data/000004-012.ring_trust , tests/data/000005-002.sig , tests/data/000006-012.ring_trust , tests/data/000007-002.sig , tests/data/000008-012.ring_trust , tests/data/000009-002.sig , tests/data/000010-012.ring_trust , tests/data/000011-002.sig , tests/data/000012-012.ring_trust , tests/data/000013-014.public_subkey , tests/data/000014-002.sig , tests/data/000015-012.ring_trust , tests/data/000016-006.public_key , tests/data/000017-002.sig , tests/data/000018-012.ring_trust , tests/data/000019-013.user_id , tests/data/000020-002.sig , tests/data/000021-012.ring_trust , tests/data/000022-002.sig , tests/data/000023-012.ring_trust , tests/data/000024-014.public_subkey , tests/data/000025-002.sig , tests/data/000026-012.ring_trust , tests/data/000027-006.public_key , tests/data/000028-002.sig , tests/data/000029-012.ring_trust , tests/data/000030-013.user_id , tests/data/000031-002.sig , tests/data/000032-012.ring_trust , tests/data/000033-002.sig , tests/data/000034-012.ring_trust , tests/data/000035-006.public_key , tests/data/000036-013.user_id , tests/data/000037-002.sig , tests/data/000038-012.ring_trust , tests/data/000039-002.sig , tests/data/000040-012.ring_trust , tests/data/000041-017.attribute , tests/data/000042-002.sig , tests/data/000043-012.ring_trust , tests/data/000044-014.public_subkey , tests/data/000045-002.sig , tests/data/000046-012.ring_trust , tests/data/000047-005.secret_key , tests/data/000048-013.user_id , tests/data/000049-002.sig , tests/data/000050-012.ring_trust , tests/data/000051-007.secret_subkey , tests/data/000052-002.sig , tests/data/000053-012.ring_trust , tests/data/000054-005.secret_key , tests/data/000055-002.sig , tests/data/000056-012.ring_trust , tests/data/000057-013.user_id , tests/data/000058-002.sig , tests/data/000059-012.ring_trust , tests/data/000060-007.secret_subkey , tests/data/000061-002.sig , tests/data/000062-012.ring_trust , tests/data/000063-005.secret_key , tests/data/000064-002.sig , tests/data/000065-012.ring_trust , tests/data/000066-013.user_id , tests/data/000067-002.sig , tests/data/000068-012.ring_trust , tests/data/000069-005.secret_key , tests/data/000070-013.user_id , tests/data/000071-002.sig , tests/data/000072-012.ring_trust , tests/data/000073-017.attribute , tests/data/000074-002.sig , tests/data/000075-012.ring_trust , tests/data/000076-007.secret_subkey , tests/data/000077-002.sig , tests/data/000078-012.ring_trust , tests/data/pubring.gpg , tests/data/secring.gpg , tests/data/compressedsig.gpg , tests/data/msg1.asc , tests/data/uncompressed-ops-rsa.gpg , tests/data/uncompressed-ops-dsa.gpg , tests/data/uncompressed-ops-dsa-sha384.txt.gpg , tests/data/encryption.gpg , tests/data/compressedsig-zlib.gpg , tests/data/compressedsig-bzip2.gpg , tests/data/onepass_sig , tests/data/simple.seckey , tests/data/minimized.gpg , tests/data/subkey.gpg , tests/data/signing-subkey.gpg , tests/data/uat.gpg , tests/data/prikey-rev.gpg , tests/data/subkey-rev.gpg , tests/data/6F87040E.pubkey , tests/data/6F87040E-cr.pubkey , tests/data/v3.key , tests/data/primary-binding.gpg , tests/data/pki-password.txt , tests/data/symmetric-password.txt , tests/data/encryption-sym-aes256-s2k0.gpg , tests/data/encryption-sym-aes128-s2k0.gpg , tests/data/encryption-sym-aes128.gpg , tests/data/encryption-sym-aes256.gpg , tests/data/encryption-sym-3des-s2k0.gpg , tests/data/encryption-sym-3des.gpg , tests/data/encryption-sym-aes192-s2k0.gpg , tests/data/encryption-sym-aes192.gpg , tests/data/encryption-sym-blowfish-s2k0.gpg , tests/data/encryption-sym-blowfish.gpg , tests/data/encryption-sym-twofish-s2k0.gpg , tests/data/encryption-sym-twofish.gpg , tests/data/encryption-sym-cast5-mdc-s2k0.gpg , tests/data/encryption-sym-cast5-mdc.gpg , tests/data/encryption-sym-blowfish-mdc-s2k0.gpg , tests/data/encryption-sym-blowfish-mdc.gpg , tests/data/encryption-sym-3des-mdc-s2k0.gpg , tests/data/encryption-sym-3des-mdc.gpg , tests/data/encryption-sym-cast5.gpg , tests/data/encryption-sym-cast5-s2k0.gpg , tests/data/encryption-sym-camellia128.gpg , tests/data/encryption-sym-camellia128-s2k0.gpg , tests/data/encryption-sym-camellia192.gpg , tests/data/encryption-sym-camellia256.gpg , tests/data/16bitcksum.seckey , tests/data/aes256-sha512.seckey , tests/data/unencrypted.seckey , tests/data/v3-genericcert.sig , tests/data/revoked.pubkey , tests/data/expired.pubkey , tests/data/sigs-with-regexes , tests/data/gnu-dummy-s2k-101-secret-key.gpg , tests/data/anibal-ed25519.gpg Cabal-version: >= 1.10 flag network-uri description: Get Network.URI from the network-uri package default: True Library Exposed-modules: Codec.Encryption.OpenPGP.Types , Codec.Encryption.OpenPGP.CFB , Codec.Encryption.OpenPGP.Compression , Codec.Encryption.OpenPGP.Expirations , Codec.Encryption.OpenPGP.Fingerprint , Codec.Encryption.OpenPGP.KeyInfo , Codec.Encryption.OpenPGP.KeyringParser , Codec.Encryption.OpenPGP.KeySelection , Codec.Encryption.OpenPGP.Ontology , Codec.Encryption.OpenPGP.S2K , Codec.Encryption.OpenPGP.SecretKey , Codec.Encryption.OpenPGP.Serialize , Codec.Encryption.OpenPGP.Signatures , Data.Conduit.OpenPGP.Compression , Data.Conduit.OpenPGP.Decrypt , Data.Conduit.OpenPGP.Filter , Data.Conduit.OpenPGP.Keyring , Data.Conduit.OpenPGP.Keyring.Instances , Data.Conduit.OpenPGP.Verify Other-Modules: Codec.Encryption.OpenPGP.Internal , Codec.Encryption.OpenPGP.Internal.CryptoCipherTypes , Codec.Encryption.OpenPGP.Internal.Cryptonite , Codec.Encryption.OpenPGP.Internal.HOBlockCipher , Codec.Encryption.OpenPGP.SerializeForSigs , Codec.Encryption.OpenPGP.Types.Internal.Base , Codec.Encryption.OpenPGP.Types.Internal.CryptoniteNewtypes , Codec.Encryption.OpenPGP.Types.Internal.PacketClass , Codec.Encryption.OpenPGP.Types.Internal.PKITypes , Codec.Encryption.OpenPGP.Types.Internal.Pkt , Codec.Encryption.OpenPGP.Types.Internal.TK , Codec.Encryption.OpenPGP.BlockCipher Build-depends: aeson , attoparsec , base > 4 && < 5 , base16-bytestring , base64-bytestring , bifunctors , byteable , bytestring , bzlib , binary >= 0.6.4.0 , binary-conduit , conduit >= 0.5 && < 1.3 , conduit-extra >= 1.1 , containers , cryptonite >= 0.5 , crypto-cipher-types , data-default-class , errors , hashable , incremental-parser , ixset-typed , lens >= 3.0 , memory , monad-loops , nettle , newtype , openpgp-asciiarmor >= 0.1 , resourcet > 0.4 , securemem , semigroups , split , text , time >= 1.1 , time-locale-compat , transformers , unordered-containers , wl-pprint-extras , zlib if flag(network-uri) build-depends: network-uri >= 2.6, network >= 2.6 else build-depends: network-uri < 2.6, network < 2.6 default-language: Haskell2010 Test-Suite tests type: exitcode-stdio-1.0 main-is: tests/suite.hs other-modules: Codec.Encryption.OpenPGP.Arbitrary Ghc-options: -Wall -with-rtsopts=-K1K Build-depends: hOpenPGP , aeson , attoparsec , base > 4 && < 5 , base16-bytestring , bifunctors , byteable , bytestring , bzlib , binary >= 0.6.4.0 , binary-conduit , conduit , conduit-extra , containers , cryptonite >= 0.5 , crypto-cipher-types , data-default-class , errors , hashable , incremental-parser , ixset-typed , lens >= 3.0 , memory , monad-loops , nettle , newtype , securemem , semigroups , split , text , time >= 1.1 , time-locale-compat , transformers , unordered-containers , wl-pprint-extras , zlib , tasty , tasty-hunit , tasty-quickcheck , QuickCheck , quickcheck-instances , resourcet > 0.4 if flag(network-uri) build-depends: network-uri >= 2.6, network >= 2.6 else build-depends: network-uri < 2.6, network < 2.6 default-language: Haskell2010 Benchmark benchmark type: exitcode-stdio-1.0 main-is: bench/mark.hs Ghc-options: -Wall Build-depends: hOpenPGP , aeson , base > 4 && < 5 , base16-bytestring , base64-bytestring , bifunctors , byteable , bytestring , bzlib , binary >= 0.6.4.0 , binary-conduit , conduit >= 0.5 && < 1.3 , conduit-extra >= 1.1 , containers , cryptonite >= 0.5 , crypto-cipher-types , data-default-class , errors , hashable , incremental-parser , ixset-typed , lens >= 3.0 , memory , monad-loops , nettle , newtype , openpgp-asciiarmor >= 0.1 , resourcet > 0.4 , securemem , semigroups , split , text , time >= 1.1 , time-locale-compat , transformers , unordered-containers , wl-pprint-extras , zlib , criterion > 0.8 if flag(network-uri) build-depends: network-uri >= 2.6, network >= 2.6 else build-depends: network-uri < 2.6, network < 2.6 default-language: Haskell2010 source-repository head type: git location: git://git.debian.org/users/clint/hOpenPGP.git source-repository this type: git location: git://git.debian.org/users/clint/hOpenPGP.git tag: v2.5.5 hOpenPGP-2.5.5/bench/0000755000000000000000000000000012770565031012416 5ustar0000000000000000hOpenPGP-2.5.5/bench/mark.hs0000644000000000000000000000316512770565031013711 0ustar0000000000000000-- mark.hs: hOpenPGP benchmark suite -- Copyright © 2014-2016 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 Control.Monad.Trans.Resource (runResourceT) import Data.Conduit.Serialization.Binary (conduitGet) import Data.Conduit.OpenPGP.Keyring (conduitToTKs, sinkKeyringMap) 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") ] ] where loadKeys fp = runResourceT $ CB.sourceFile fp DC.$= conduitGet get DC.$= conduitToTKs DC.$$ CL.consume loadKeyring fp = runResourceT $ 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-2.5.5/Codec/0000755000000000000000000000000012770565031012354 5ustar0000000000000000hOpenPGP-2.5.5/Codec/Encryption/0000755000000000000000000000000012770565031014506 5ustar0000000000000000hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/0000755000000000000000000000000012770565031015756 5ustar0000000000000000hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/Fingerprint.hs0000644000000000000000000000371512770565031020607 0ustar0000000000000000-- Fingerprint.hs: OpenPGP (RFC4880) fingerprinting methods -- 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 import qualified Crypto.PubKey.RSA as RSA import Crypto.Hash (hashlazy, Digest) import Crypto.Hash.Algorithms (MD5, SHA1) import Crypto.Number.Serialize (i2osp) 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 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)) hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/Types.hs0000644000000000000000000000112412770565031017414 0ustar0000000000000000-- Types.hs: OpenPGP (RFC4880) data types -- 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 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.Pkt as X import Codec.Encryption.OpenPGP.Types.Internal.TK as X hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/Compression.hs0000644000000000000000000000254112770565031020615 0ustar0000000000000000-- Compression.hs: OpenPGP (RFC4880) compression and decompression -- 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 import qualified Codec.Compression.BZip as BZip import qualified Codec.Compression.Zlib as Zlib import qualified Codec.Compression.Zlib.Raw as ZlibRaw import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.Types import Data.Binary (get, put) import Data.Binary.Get (runGetOrFail) import Data.Binary.Put (runPut) 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" 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" hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/Ontology.hs0000644000000000000000000000430712770565031020130 0ustar0000000000000000-- Ontology.hs: OpenPGP (RFC4880) "is" functions -- 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 ( -- * for signature payloads isCertRevocationSig , isRevokerP , isPKBindingSig , isSKBindingSig , isSubkeyBindingSig , isSubkeyRevocation , isTrustPkt -- * for signature subpackets , isCT , isIssuerSSP , isKET , isKUF , isPHA , isRevocationKeySSP , isSigCreationTime ) where import Codec.Encryption.OpenPGP.Types isCertRevocationSig :: SignaturePayload -> Bool isCertRevocationSig (SigV4 CertRevocationSig _ _ _ _ _ _) = True isCertRevocationSig _ = False isRevokerP :: SignaturePayload -> Bool isRevokerP (SigV4 SignatureDirectlyOnAKey _ _ h u _ _) = any isRevocationKeySSP h && any isIssuerSSP u isRevokerP _ = False isPKBindingSig :: SignaturePayload -> Bool isPKBindingSig (SigV4 PrimaryKeyBindingSig _ _ _ _ _ _) = True isPKBindingSig _ = False isSKBindingSig :: SignaturePayload -> Bool isSKBindingSig (SigV4 SubkeyBindingSig _ _ _ _ _ _) = True isSKBindingSig _ = False isSubkeyRevocation :: SignaturePayload -> Bool isSubkeyRevocation (SigV4 SubkeyRevocationSig _ _ _ _ _ _) = True isSubkeyRevocation _ = False isSubkeyBindingSig :: SignaturePayload -> Bool isSubkeyBindingSig (SigV4 SubkeyBindingSig _ _ _ _ _ _) = True isSubkeyBindingSig _ = False isTrustPkt :: Pkt -> Bool isTrustPkt (TrustPkt _) = True isTrustPkt _ = False isCT :: SigSubPacket -> Bool isCT (SigSubPacket _ (SigCreationTime _)) = True isCT _ = False isIssuerSSP :: SigSubPacket -> Bool isIssuerSSP (SigSubPacket _ (Issuer _)) = True isIssuerSSP _ = False isKET :: SigSubPacket -> Bool isKET (SigSubPacket _ (KeyExpirationTime _)) = True isKET _ = False isKUF :: SigSubPacket -> Bool isKUF (SigSubPacket _ (KeyFlags _)) = True isKUF _ = False isPHA :: SigSubPacket -> Bool isPHA (SigSubPacket _ (PreferredHashAlgorithms _)) = True isPHA _ = False isRevocationKeySSP :: SigSubPacket -> Bool isRevocationKeySSP (SigSubPacket _ RevocationKey{}) = True isRevocationKeySSP _ = False isSigCreationTime :: SigSubPacket -> Bool isSigCreationTime (SigSubPacket _ (SigCreationTime _)) = True isSigCreationTime _ = False hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/CFB.hs0000644000000000000000000000607412770565031016713 0ustar0000000000000000-- CFB.hs: OpenPGP (RFC4880) CFB mode -- Copyright © 2013-2016 Clint Adams -- Copyright © 2013 Daniel Kahn Gillmor -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE CPP #-} module Codec.Encryption.OpenPGP.CFB ( decrypt , decryptNoNonce , decryptOpenPGPCfb , encryptNoNonce ) where import Codec.Encryption.OpenPGP.BlockCipher (withSymmetricCipher) import Codec.Encryption.OpenPGP.Internal.HOBlockCipher import Codec.Encryption.OpenPGP.Types #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*>)) #endif import qualified Data.ByteString as B decryptOpenPGPCfb :: SymmetricAlgorithm -> B.ByteString -> B.ByteString -> Either String B.ByteString decryptOpenPGPCfb Plaintext ciphertext _ = return ciphertext decryptOpenPGPCfb sa ciphertext keydata = withSymmetricCipher sa keydata $ \bc -> do nonce <- decrypt1 ciphertext bc cleartext <- decrypt2 ciphertext bc if nonceCheck bc nonce then return cleartext else Left "Session key quickcheck failed" where decrypt1 :: HOBlockCipher cipher => B.ByteString -> cipher -> Either String B.ByteString decrypt1 ct cipher = paddedCfbDecrypt cipher (B.replicate (blockSize cipher) 0) (B.take (blockSize cipher + 2) ct) decrypt2 :: HOBlockCipher cipher => B.ByteString -> cipher -> Either String B.ByteString decrypt2 ct cipher = let i = B.take (blockSize cipher) (B.drop 2 ct) in paddedCfbDecrypt cipher i (B.drop (blockSize cipher + 2) ct) decrypt :: SymmetricAlgorithm -> B.ByteString -> B.ByteString -> Either String B.ByteString decrypt Plaintext ciphertext _ = return ciphertext decrypt sa ciphertext keydata = withSymmetricCipher sa keydata $ \bc -> do (nonce, cleartext) <- fmap (B.splitAt (blockSize bc + 2)) (decrypt' ciphertext bc) if nonceCheck bc nonce then return cleartext else Left "Session key quickcheck failed" where decrypt' :: HOBlockCipher cipher => B.ByteString -> cipher -> Either String B.ByteString decrypt' ct cipher = paddedCfbDecrypt cipher (B.replicate (blockSize cipher) 0) ct decryptNoNonce :: SymmetricAlgorithm -> IV -> B.ByteString -> B.ByteString -> Either String B.ByteString decryptNoNonce Plaintext _ ciphertext _ = return ciphertext decryptNoNonce sa iv ciphertext keydata = withSymmetricCipher sa keydata (decrypt' ciphertext) where decrypt' :: HOBlockCipher cipher => B.ByteString -> cipher -> Either String B.ByteString decrypt' ct cipher = paddedCfbDecrypt cipher (unIV iv) ct nonceCheck :: HOBlockCipher cipher => cipher -> B.ByteString -> Bool nonceCheck bc = (==) <$> B.take 2 . B.drop (blockSize bc - 2) <*> B.drop (blockSize bc) encryptNoNonce :: SymmetricAlgorithm -> S2K -> IV -> B.ByteString -> B.ByteString -> Either String B.ByteString encryptNoNonce Plaintext _ _ payload _ = return payload encryptNoNonce sa s2k iv payload keydata = withSymmetricCipher sa keydata (encrypt' payload) where encrypt' :: HOBlockCipher cipher => B.ByteString -> cipher -> Either String B.ByteString encrypt' ct cipher = paddedCfbEncrypt cipher (unIV iv) ct hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/S2K.hs0000644000000000000000000000351312770565031016713 0ustar0000000000000000-- S2K.hs: OpenPGP (RFC4880) string-to-key conversion -- 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 import Codec.Encryption.OpenPGP.BlockCipher (keySize) import Codec.Encryption.OpenPGP.Types import Control.Monad.Loops (untilM_) import Control.Monad.Trans.State.Lazy (execState, get, put) import qualified Crypto.Hash as CH import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL 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 _ _ _ = error "FIXME: unimplemented S2K type" skesk2Key :: SKESK -> BL.ByteString -> B.ByteString skesk2Key (SKESK 4 sa s2k Nothing) pass = string2Key s2k (keySize sa) pass 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" hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/KeyringParser.hs0000644000000000000000000001732412770565031021106 0ustar0000000000000000-- KeyringParser.hs: OpenPGP (RFC4880) transferable keys parsing -- Copyright © 2012-2016 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE CPP #-} module Codec.Encryption.OpenPGP.KeyringParser ( -- * Parsers parseAChunk , finalizeParsing , anyTK , UidOrUat(..) , splitUs , publicTK , secretTK , brokenTK , pkPayload , signature , signedUID , signedUAt , signedOrRevokedPubSubkey , brokenPubSubkey , rawOrSignedOrRevokedSecSubkey , brokenSecSubkey , skPayload , broken -- * Utilities , parseTKs ) where import Control.Applicative (many, (<|>)) #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Data.Maybe (catMaybes) #if !MIN_VERSION_base(4,8,0) import Data.Monoid (Monoid, mconcat) #endif import Data.Monoid ((<>)) import Data.Text (Text) import Codec.Encryption.OpenPGP.Types import Codec.Encryption.OpenPGP.Ontology (isTrustPkt) import Data.Conduit.OpenPGP.Keyring.Instances () import Text.ParserCombinators.Incremental.LeftBiasedLocal (concatMany, completeResults, feed, feedEof, inspect, Parser, 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 _ a ([], Nothing) = error $ "Failure before " ++ show a 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 ([], Nothing) = error "Unexpected finalization failure" finalizeParsing (cr, Nothing) = (([], Nothing), map fst cr) finalizeParsing (_, Just (_, p)) = finalizeParsing (inspect (feedEof p)) anyTK :: Bool -> Parser [Pkt] (Maybe TK) anyTK True = publicTK True <|> secretTK True anyTK False = publicTK False <|> secretTK False <|> brokenTK 6 <|> brokenTK 5 data UidOrUat = I Text | A [UserAttrSubPacket] deriving Show 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 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 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 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 brokenTK 5 = do _ <- 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 [PublicKeyPkt p] <- satisfy isPKP return (p, Nothing) 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 [SignaturePkt sp] <- satisfy (isSP intolerant) return $! (if intolerant then id else filter isSP') [sp] 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 [UserIdPkt u] <- satisfy isUID sigs <- concatMany (signature intolerant [GenericCert, PersonaCert, CasualCert, PositiveCert, CertRevocationSig]) return (I u, sigs) where isUID [UserIdPkt _] = True isUID _ = False signedUAt :: Bool -> Parser [Pkt] (UidOrUat, [SignaturePayload]) signedUAt intolerant = do [UserAttributePkt us] <- satisfy isUAt sigs <- concatMany (signature intolerant [GenericCert, PersonaCert, CasualCert, PositiveCert, CertRevocationSig]) return (A us, sigs) where isUAt [UserAttributePkt _] = True isUAt _ = False signedOrRevokedPubSubkey :: Bool -> Parser [Pkt] [(Pkt, [SignaturePayload])] signedOrRevokedPubSubkey intolerant = do [p] <- satisfy isPSKP sigs <- concatMany (signature intolerant [SubkeyBindingSig, SubkeyRevocationSig]) return [(p, sigs)] where isPSKP [PublicSubkeyPkt _] = True isPSKP _ = False brokenPubSubkey :: Parser [Pkt] [(Pkt, [SignaturePayload])] brokenPubSubkey = do _ <- broken 14 _ <- concatMany (signature False [SubkeyBindingSig, SubkeyRevocationSig]) return [] rawOrSignedOrRevokedSecSubkey :: Bool -> Parser [Pkt] [(Pkt, [SignaturePayload])] rawOrSignedOrRevokedSecSubkey intolerant = do [p] <- satisfy isSSKP sigs <- concatMany (signature intolerant [SubkeyBindingSig, SubkeyRevocationSig]) return [(p, sigs)] where isSSKP [SecretSubkeyPkt _ _] = True isSSKP _ = False brokenSecSubkey :: Parser [Pkt] [(Pkt, [SignaturePayload])] brokenSecSubkey = do _ <- broken 7 _ <- concatMany (signature False [SubkeyBindingSig, SubkeyRevocationSig]) return [] skPayload :: Parser [Pkt] (PKPayload, Maybe SKAddendum) skPayload = do [SecretKeyPkt p ska] <- satisfy isSKP return (p, Just ska) where isSKP [SecretKeyPkt _ _] = True isSKP _ = False broken :: Int -> Parser [Pkt] Pkt broken t = do [bp] <- satisfy isBroken return bp 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 hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/Serialize.hs0000644000000000000000000013735312770565031020255 0ustar0000000000000000-- Serialize.hs: OpenPGP (RFC4880) serialization (using cereal) -- Copyright © 2012-2016 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE CPP #-} module Codec.Encryption.OpenPGP.Serialize ( -- * Serialization functions putSKAddendum , getSecretKey -- * Utilities , parsePkts ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif 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 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 #if !MIN_VERSION_base(4,8,0) import Data.Monoid (mempty) #endif 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, Word32) import Data.Maybe (fromMaybe) import Network.URI (nullURI, parseURI, uriToString) import Codec.Encryption.OpenPGP.Internal (pubkeyToMPIs, multiplicativeInverse) 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 > 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 (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 pkp <- getPKPayload return $ PublicSubkeyPkt pkp | 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 _ = UnknownPKey <$> getRemainingLazyByteString putPubkey :: PKey -> Put putPubkey (UnknownPKey bs) = putLazyByteString bs 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 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 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 putSKey sk putWord16be checksum 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 put (PublicKey (key^.tkKey._1)) 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 hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/KeyInfo.hs0000644000000000000000000000241112770565031017654 0ustar0000000000000000-- KeyInfo.hs: OpenPGP (RFC4880) fingerprinting methods -- Copyright © 2012-2016 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 import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.DSA as DSA import Data.Bits (shiftR) import Data.List (unfoldr) import Codec.Encryption.OpenPGP.Types pubkeySize :: PKey -> Either String Int pubkeySize (RSAPubKey (RSA_PublicKey x)) = Right (RSA.public_size x * 8) pubkeySize (DSAPubKey (DSA_PublicKey x)) = Right (bitcount . DSA.params_p . DSA.public_params $ x) pubkeySize (ElGamalPubKey p _ _) = Right (bitcount p) pubkeySize x = Left $ "Unable to calculate size of " ++ show x bitcount :: Integer -> Int bitcount = (*8) . length . unfoldr (\x -> if x == 0 then Nothing else Just (True, x `shiftR` 8)) -- FIXME: redo these for hOpenPGP 3 pkalgoAbbrev :: PubKeyAlgorithm -> String pkalgoAbbrev RSA = "R" pkalgoAbbrev DSA = "D" pkalgoAbbrev ElgamalEncryptOnly = "g" pkalgoAbbrev DeprecatedRSAEncryptOnly = "-" pkalgoAbbrev DeprecatedRSASignOnly = "_" pkalgoAbbrev ECDH = "e" pkalgoAbbrev ECDSA = "E" pkalgoAbbrev ForbiddenElgamal = "f" pkalgoAbbrev DH = "d" pkalgoAbbrev (OtherPKA _) = "." hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/KeySelection.hs0000644000000000000000000000253312770565031020713 0ustar0000000000000000-- KeySelection.hs: OpenPGP (RFC4880) ways to ask for keys -- Copyright © 2014-2016 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Codec.Encryption.OpenPGP.KeySelection ( parseEightOctetKeyId , parseFingerprint ) where import Codec.Encryption.OpenPGP.Types #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (*>)) #endif import Control.Applicative (optional) import Control.Monad ((<=<)) import Crypto.Number.Serialize (i2osp) import Data.Attoparsec.Text (asciiCI, count, hexadecimal, inClass, parseOnly, Parser, 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 parseFingerprint :: Text -> Either String TwentyOctetFingerprint parseFingerprint = fmap TwentyOctetFingerprint . (parseOnly hexes <=< parseOnly (hexen 40)) . toUpper . T.filter (/=' ') hexPrefix :: Parser (Maybe Text) hexPrefix = optional (asciiCI "0x") hexen :: Int -> Parser Text hexen n = T.pack <$> count n (satisfy (inClass "A-F0-9")) hexes :: Parser BL.ByteString hexes = BL.fromStrict . i2osp <$> hexadecimal hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/BlockCipher.hs0000644000000000000000000000613612770565031020505 0ustar0000000000000000-- BlockCipher.hs: OpenPGP (RFC4880) block cipher stuff -- 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 , withSymmetricCipher ) 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.Camellia as Camellia import qualified Crypto.Nettle.Ciphers as CNC import qualified Data.ByteString as B type HOCipher a = forall cipher. HOBlockCipher cipher => cipher -> 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 -- in octets; FIXME: co-opt Cipher's cipherKeySize or not? keySize :: SymmetricAlgorithm -> Int keySize Plaintext = 0 keySize IDEA = 16 -- according to https://en.wikipedia.org/wiki/International_Data_Encryption_Algorithm keySize TripleDES = 24 -- RFC 4880 says 168 bits (derived from 192 bits) but we don't know who does the derivation keySize CAST5 = 16 keySize Blowfish = 16 keySize ReservedSAFER = undefined keySize ReservedDES = undefined keySize AES128 = 16 keySize AES192 = 24 keySize AES256 = 32 keySize Twofish = 32 keySize Camellia128 = 16 keySize Camellia192 = 24 keySize Camellia256 = 32 keySize (OtherSA _) = undefined hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/Arbitrary.hs0000644000000000000000000001562212770565031020257 0ustar0000000000000000-- Arbitrary.hs: QuickCheck instances -- Copyright © 2014-2016 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE CPP #-} 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.Instances () instance Arbitrary PKESK where arbitrary = do pv <- arbitrary eoki <- arbitrary pka <- arbitrary mpis <- arbitrary return $ PKESK pv eoki pka mpis instance Arbitrary Signature where arbitrary = fmap Signature arbitrary instance Arbitrary UserId where 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) instance Arbitrary SigSubPacket where 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] 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 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] instance Arbitrary EightOctetKeyId where arbitrary = fmap (EightOctetKeyId . BL.pack) (vector 8) instance Arbitrary TwentyOctetFingerprint where arbitrary = fmap (TwentyOctetFingerprint . BL.pack) (vector 20) instance Arbitrary MPI where 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] instance Arbitrary HashAlgorithm where 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 ] instance Arbitrary RevocationClass where 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)) instance Arbitrary CompressionAlgorithm where 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)) instance Arbitrary KeyFlag where arbitrary = elements [GroupKey, AuthKey, SplitKey, EncryptStorageKey, EncryptCommunicationsKey, SignDataKey, CertifyKeysKey] instance Arbitrary RevocationCode where arbitrary = elements [NoReason, KeySuperseded, KeyMaterialCompromised, KeyRetiredAndNoLongerUsed, UserIdInfoNoLongerValid] instance Arbitrary FeatureFlag where arbitrary = frequency [(9,md),(1,fo)] where md = return ModificationDetection fo = fmap FeatureOther (choose (8,63)) instance Arbitrary ThirtyTwoBitTimeStamp where arbitrary = fmap ThirtyTwoBitTimeStamp arbitrary instance Arbitrary ThirtyTwoBitDuration where arbitrary = fmap ThirtyTwoBitDuration arbitrary instance Arbitrary NotationName where arbitrary = fmap NotationName arbitrary instance Arbitrary NotationValue where arbitrary = fmap NotationValue arbitrary #if !MIN_VERSION_QuickCheck(2,9,0) -- FIXME: this should be elsewhere instance Arbitrary a => Arbitrary (NE.NonEmpty a) where arbitrary = NE.fromList `fmap` listOf1 arbitrary #endif hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/SecretKey.hs0000644000000000000000000001115512770565031020213 0ustar0000000000000000-- SecretKey.hs: OpenPGP (RFC4880) secret key encryption/decryption -- Copyright © 2013-2016 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 import Codec.Encryption.OpenPGP.Internal.HOBlockCipher import Codec.Encryption.OpenPGP.Types import Codec.Encryption.OpenPGP.BlockCipher (withSymmetricCipher, keySize) import Codec.Encryption.OpenPGP.CFB (decryptNoNonce, encryptNoNonce) import Codec.Encryption.OpenPGP.Serialize (getSecretKey) import Codec.Encryption.OpenPGP.S2K (skesk2Key, string2Key) import qualified Crypto.Hash as CH import Crypto.Number.ModArithmetic (inverse) 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.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 saBlockSize :: SymmetricAlgorithm -> Int 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 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 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)) 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 -- |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 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 _ _ _ _ = 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 } hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/Internal.hs0000644000000000000000000001114112770565031020064 0ustar0000000000000000-- Internal.hs: private utility functions and such -- Copyright © 2012-2016 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 , sigType , sigPKA , sigHA , sigCT , truncatingVerify ) where import Crypto.Hash (hashWith) import qualified Crypto.Hash.IO as CHI import Crypto.Number.Basic (numBits) import Crypto.Number.ModArithmetic (expFast, inverse) import Crypto.Number.Serialize (os2ip) import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.RSA as RSA import Data.Bits (testBit) import Data.ByteArray (ByteArrayAccess) import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import Data.List (find) import Data.Maybe (fromJust) import Data.Word (Word8, Word16) import Codec.Encryption.OpenPGP.Types import Codec.Encryption.OpenPGP.Ontology (isIssuerSSP, isSigCreationTime) 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) 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") issuer :: Pkt -> Maybe EightOctetKeyId 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 (ElGamalPubKey p g y) = [MPI p, MPI g, MPI y] 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) sigType :: SignaturePayload -> Maybe SigType sigType (SigV3 st _ _ _ _ _ _) = Just st sigType (SigV4 st _ _ _ _ _ _) = Just st sigType _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild sigPKA :: SignaturePayload -> Maybe PubKeyAlgorithm sigPKA (SigV3 _ _ _ pka _ _ _) = Just pka sigPKA (SigV4 _ pka _ _ _ _ _) = Just pka sigPKA _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild sigHA :: SignaturePayload -> Maybe HashAlgorithm sigHA (SigV3 _ _ _ _ ha _ _) = Just ha sigHA (SigV4 _ _ ha _ _ _ _) = Just ha sigHA _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild sigCT :: SignaturePayload -> Maybe ThirtyTwoBitTimeStamp sigCT (SigV3 _ ct _ _ _ _ _) = Just ct sigCT (SigV4 _ _ _ hsubs _ _ _) = fmap (\(SigSubPacket _ (SigCreationTime i)) -> i) (find isSigCreationTime hsubs) sigCT _ = Nothing truncatingVerify :: (ByteArrayAccess msg, CHI.HashAlgorithm hash) => hash -> DSA.PublicKey -> DSA.Signature -> msg -> Bool truncatingVerify hashAlg pk (DSA.Signature r s) m -- Reject the signature if either 0 < r < q or 0 < s < q is not satisfied. | r <= 0 || r >= q || s <= 0 || s >= q = False | otherwise = v == r where (DSA.Params p g q) = DSA.public_params pk y = DSA.public_y pk hm = os2ip . dsaTruncate . BA.convert $ hashWith hashAlg m w = fromJust $ inverse s q u1 = (hm*w) `mod` q u2 = (r*w) `mod` q v = (expFast g u1 p * expFast y u2 p) `mod` p `mod` q dsaTruncate bs = let lbs = BL.fromStrict bs in if countBits lbs > fromIntegral dsaQLen then B.take (dsaQLen `div` 8) bs else bs -- FIXME: uneven bits dsaQLen = numBits q hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/SerializeForSigs.hs0000644000000000000000000001243112770565031021537 0ustar0000000000000000-- SerializeForSigs.hs: OpenPGP (RFC4880) special serialization for signature purposes -- 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 import Control.Lens ((^.)) import Crypto.Number.Serialize (i2osp) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString as B 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) import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.Types putPKPforFingerprinting :: Pkt -> Put 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)" 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)" putSigTrailer :: Pkt -> Put putSigTrailer (SignaturePkt (SigV4 _ _ _ hs _ _ _)) = do 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)" putUforSigning :: Pkt -> Put putUforSigning u@(UserIdPkt _) = putUIDforSigning u putUforSigning u@(UserAttributePkt _) = putUAtforSigning u putUforSigning _ = fail "This should never happen (putUforSigning)" putUIDforSigning :: Pkt -> Put putUIDforSigning (UserIdPkt u) = do 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 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 putSigforSigning _ = fail "Non-V4 not implemented." putKeyforSigning :: Pkt -> Put putKeyforSigning (PublicKeyPkt pkp) = putKeyForSigning' pkp 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' :: PKPayload -> Put putKeyForSigning' pkp = do 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 CanonicalTextSig state = payloadForSig BinarySig state payloadForSig StandaloneSig _ = BL.empty 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 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]) hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/Signatures.hs0000644000000000000000000002412212770565031020437 0ustar0000000000000000-- Signatures.hs: OpenPGP (RFC4880) signature verification -- Copyright © 2012-2016 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE CPP #-} module Codec.Encryption.OpenPGP.Signatures ( verifySigWith , verifyAgainstKeyring , verifyAgainstKeys , verifyTKWith ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*>)) #endif import Control.Error.Util (hush) import Control.Lens ((^.), _1) import Control.Monad (liftM2) import qualified Crypto.Hash.Algorithms as CHA import Crypto.Number.Serialize (i2osp) import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.RSA.PKCS15 as P15 import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import Data.Either (lefts, rights) import Data.IxSet.Typed ((@=)) import qualified Data.IxSet.Typed as IxSet import Data.List.NonEmpty (NonEmpty(..)) 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, truncatingVerify) import Codec.Encryption.OpenPGP.Ontology (isRevokerP, isRevocationKeySSP, isSubkeyBindingSig, isSubkeyRevocation) import Codec.Encryption.OpenPGP.SerializeForSigs (putPartialSigforSigning, putSigTrailer, payloadForSig) 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 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 verifySigWith _ _ _ _ = Left "This should never happen (verifySigWith)." 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 (\(_, sps) -> sps /= []) . checkUidSigs $ key^.tkUIDs -- FIXME: check revocations here? let uats = filter (\(_, sps) -> sps /= []) . 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 = case vsf (SignaturePkt sp) emptyPSC { lastPrimaryKey = PublicKeyPkt (key ^. tkKey._1), lastSubkey = sk} mt of Left _ -> False Right _ -> True 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 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 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 = verify''' (dsaVerify mpis hd pkey bs) pub verify'' (RSA,mpis) hd pub (RSAPubKey (RSA_PublicKey pkey)) bs = verify''' (rsaVerify mpis hd pkey bs) pub verify'' _ _ _ _ _ = Left "unimplemented key type" verify''' f pub = if f then Right pub else Left "verification failed" dsaVerify (r:|[s]) hd pkey = truncatingVerify hd pkey (dsaMPIsToSig r s) dsaVerify _ _ _ = const False -- FIXME: this should be some sort of Either chain? rsaVerify mpis hd pkey bs = P15.verify (Just hd) pkey bs (rsaMPItoSig mpis) dsaMPIsToSig r s = DSA.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 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 hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/Expirations.hs0000644000000000000000000000245112770565031020621 0ustar0000000000000000-- Expirations.hs: OpenPGP (RFC4880) expiration checking -- 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 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) -- 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 getKeyExpirationTimesFromSignature :: SignaturePayload -> [ThirtyTwoBitDuration] getKeyExpirationTimesFromSignature (SigV4 _ _ _ xs _ _ _) = map (\(SigSubPacket _ (KeyExpirationTime x)) -> x) $ filter isKET xs hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/Internal/0000755000000000000000000000000012770565031017532 5ustar0000000000000000hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/Internal/CryptoCipherTypes.hs0000644000000000000000000000401712770565031023530 0ustar0000000000000000-- CryptoCipherTypes.hs: shim for crypto-cipher-types stuff (current nettle) -- 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 import Control.Error.Util (note) import qualified "crypto-cipher-types" Crypto.Cipher.Types as OldCCT import qualified "cryptonite" Crypto.Cipher.Types as CCT import qualified Data.ByteString as B import Codec.Encryption.OpenPGP.Internal.HOBlockCipher 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) 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 = note "nettle bad IV" . OldCCT.makeIV hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/Internal/Cryptonite.hs0000644000000000000000000000236612770565031022235 0ustar0000000000000000-- Cryptonite.hs: shim for cryptonite -- 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 import Control.Error.Util (note) import qualified "cryptonite" Crypto.Cipher.Types as CCT import qualified Crypto.Error as CE import Data.Bifunctor (bimap) import qualified Data.ByteString as B import Codec.Encryption.OpenPGP.Internal.HOBlockCipher 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) hammerIV :: CCT.BlockCipher cipher => B.ByteString -> Either String (CCT.IV cipher) hammerIV = note "cryptonite bad IV" . CCT.makeIV hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/Internal/HOBlockCipher.hs0000644000000000000000000000206612770565031022506 0ustar0000000000000000-- HOBlockCipher.hs: abstraction for the different BlockCipher classes, plus crazy CFB mode stuff -- 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 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 hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/Types/0000755000000000000000000000000012770565031017062 5ustar0000000000000000hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/Types/Internal/0000755000000000000000000000000012770565031020636 5ustar0000000000000000hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs0000644000000000000000000001137312770565031022647 0ustar0000000000000000-- PKITypes.hs: OpenPGP (RFC4880) data types for public/secret keys -- 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 #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} module Codec.Encryption.OpenPGP.Types.Internal.PKITypes where import GHC.Generics (Generic) import Codec.Encryption.OpenPGP.Types.Internal.Base import Codec.Encryption.OpenPGP.Types.Internal.CryptoniteNewtypes import qualified Data.Aeson as A import qualified Data.Aeson.TH as ATH 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.Typeable (Typeable) import Data.Word (Word16) import Text.PrettyPrint.Free (Pretty(..), (<+>), text) data PKey = RSAPubKey RSA_PublicKey | DSAPubKey DSA_PublicKey | ElGamalPubKey Integer Integer Integer | ECDHPubKey ECDSA_PublicKey HashAlgorithm SymmetricAlgorithm | ECDSAPubKey ECDSA_PublicKey | UnknownPKey ByteString deriving (Data, Eq, Generic, Ord, Show, Typeable) instance Hashable PKey instance Pretty PKey where pretty (RSAPubKey p) = text "RSA" <+> pretty p pretty (DSAPubKey p) = text "DSA" <+> pretty p pretty (ElGamalPubKey p g y) = text "Elgamal" <+> pretty p <+> pretty g <+> pretty y pretty (ECDHPubKey p ha sa) = text "ECDH" <+> pretty p <+> pretty ha <+> pretty sa pretty (ECDSAPubKey p) = text "ECDSA" <+> pretty p pretty (UnknownPKey bs) = text "" <+> 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 (UnknownPKey bs) = A.toJSON (BL.unpack bs) data SKey = RSAPrivateKey RSA_PrivateKey | DSAPrivateKey DSA_PrivateKey | ElGamalPrivateKey Integer | ECDHPrivateKey ECDSA_PrivateKey | ECDSAPrivateKey ECDSA_PrivateKey | UnknownSKey ByteString deriving (Data, Eq, Generic, Show, Typeable) instance Hashable SKey instance Pretty SKey where pretty (RSAPrivateKey p) = text "RSA" <+> pretty p pretty (DSAPrivateKey p) = text "DSA" <+> pretty p pretty (ElGamalPrivateKey p) = text "Elgamal" <+> pretty p pretty (ECDHPrivateKey p) = text "ECDH" <+> pretty p pretty (ECDSAPrivateKey p) = text "ECDSA" <+> pretty p pretty (UnknownSKey bs) = text "" <+> 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 (UnknownSKey bs) = A.toJSON (BL.unpack bs) data PKPayload = PKPayload { _keyVersion :: KeyVersion , _timestamp :: ThirtyTwoBitTimeStamp , _v3exp :: V3Expiration , _pkalgo :: PubKeyAlgorithm , _pubkey :: PKey } deriving (Data, Eq, Generic, Show, Typeable) instance Ord PKPayload where 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 $(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) instance Ord SKAddendum where 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) = text "SUS16bit" <+> pretty sa <+> pretty s2k <+> pretty iv <+> pretty (bsToHexUpper bs) pretty (SUSSHA1 sa s2k iv bs) = text "SUSSHA1" <+> pretty sa <+> pretty s2k <+> pretty iv <+> pretty (bsToHexUpper bs) pretty (SUSym sa iv bs) = text "SUSym" <+> pretty sa <+> pretty iv <+> pretty (bsToHexUpper bs) pretty (SUUnencrypted s ck) = text "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) hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/Types/Internal/CryptoniteNewtypes.hs0000644000000000000000000001121312770565031025067 0ustar0000000000000000-- CryptoniteNewtypes.hs: OpenPGP (RFC4880) newtype wrappers for some cryptonite types -- Copyright © 2012-2016 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Codec.Encryption.OpenPGP.Types.Internal.CryptoniteNewtypes where import GHC.Generics (Generic) import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import qualified Data.Aeson as A import Data.Data (Data) import Data.Hashable (Hashable(..)) import Data.Typeable (Typeable) import Text.PrettyPrint.Free (Pretty(..), (<+>), tupled) 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) 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) instance Ord RSA_PublicKey instance A.ToJSON RSA_PublicKey where 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) instance Ord ECDSA_PublicKey instance A.ToJSON ECDSA_PublicKey where 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) instance Ord DSA_PrivateKey instance A.ToJSON DSA_PrivateKey where 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) 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) 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) instance Ord ECDSA_PrivateKey instance A.ToJSON ECDSA_PrivateKey where 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) 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) instance Pretty DSA_Params where 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 instance Hashable DSA_PublicKey where 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 instance Hashable RSA_PublicKey where 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 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 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 hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs0000644000000000000000000001664412770565031021743 0ustar0000000000000000-- Pkt.hs: OpenPGP (RFC4880) Pkt data types -- Copyright © 2012-2016 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} module Codec.Encryption.OpenPGP.Types.Internal.Pkt where import GHC.Generics (Generic) import Codec.Encryption.OpenPGP.Types.Internal.Base import Codec.Encryption.OpenPGP.Types.Internal.PKITypes import Control.Lens (makeLenses) import Data.Aeson ((.=), object) import qualified Data.Aeson as A import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import Data.Data (Data) import Data.Hashable (Hashable(..)) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE #if !MIN_VERSION_base(4,8,0) import Data.Monoid (mempty) #endif import Data.Monoid ((<>)) import Data.Ord (comparing) import Data.Text (Text) import qualified Data.Text as T import Data.Typeable (Typeable) import Data.Word (Word8) import Text.PrettyPrint.Free (Pretty(..), (<+>), char, text) -- 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 instance Hashable Pkt instance Ord Pkt where compare = comparing pktTag <> comparing hash -- FIXME: is there something saner? instance Pretty Pkt where pretty (PKESKPkt pv eoki pka mpis) = text "PKESK v" <> pretty pv <> char ':' <+> pretty eoki <+> pretty pka <+> (pretty . NE.toList) mpis pretty (SignaturePkt sp) = pretty sp pretty (SKESKPkt pv sa s2k mbs) = text "SKESK v" <> pretty pv <> char ':' <+> pretty sa <+> pretty s2k <+> pretty (fmap bsToHexUpper mbs) pretty (OnePassSignaturePkt pv st ha pka eoki nestedflag) = text "one-pass signature v" <> pretty pv <> char ':' <+> pretty st <+> pretty ha <+> pretty pka <+> pretty eoki <+> pretty nestedflag pretty (SecretKeyPkt pkp ska) = text "secret key:" <+> pretty pkp <+> pretty ska pretty (PublicKeyPkt pkp) = text "public key:" <+> pretty pkp pretty (SecretSubkeyPkt pkp ska) = text "secret subkey:" <+> pretty pkp <+> pretty ska pretty (CompressedDataPkt ca cdp) = text "compressed-data:" <+> pretty ca <+> pretty cdp pretty (SymEncDataPkt bs) = text "symmetrically-encrypted-data:" <+> pretty (bsToHexUpper bs) pretty (MarkerPkt bs) = text "marker:" <+> pretty (bsToHexUpper bs) pretty (LiteralDataPkt dt fn ts bs) = text "literal-data" <+> pretty dt <+> pretty fn <+> pretty ts <+> pretty (bsToHexUpper bs) pretty (TrustPkt bs) = text "trust:" <+> pretty (BL.unpack bs) pretty (UserIdPkt u) = text "user-ID:" <+> pretty u pretty (PublicSubkeyPkt pkp) = text "public subkey:" <+> pretty pkp pretty (UserAttributePkt us) = text "user-attribute:" <+> pretty us pretty (SymEncIntegrityProtectedDataPkt pv bs) = text "symmetrically-encrypted-integrity-protected-data v" <> pretty pv <> char ':' <+> pretty (bsToHexUpper bs) pretty (ModificationDetectionCodePkt bs) = text "MDC:" <+> pretty (bsToHexUpper bs) pretty (OtherPacketPkt t bs) = text "unknown packet type" <+> pretty t <> char ':' <+> pretty (bsToHexUpper bs) pretty (BrokenPacketPkt s t bs) = text "BROKEN packet (" <> pretty s <> char ')' <+> pretty t <> char ':' <+> 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]] pktTag :: Pkt -> Word8 pktTag PKESKPkt{} = 1 pktTag (SignaturePkt _) = 2 pktTag SKESKPkt{} = 3 pktTag OnePassSignaturePkt{} = 4 pktTag SecretKeyPkt{} = 5 pktTag (PublicKeyPkt _) = 6 pktTag SecretSubkeyPkt{} = 7 pktTag CompressedDataPkt{} = 8 pktTag (SymEncDataPkt _) = 9 pktTag (MarkerPkt _) = 10 pktTag LiteralDataPkt{} = 11 pktTag (TrustPkt _) = 12 pktTag (UserIdPkt _) = 13 pktTag (PublicSubkeyPkt _) = 14 pktTag (UserAttributePkt _) = 17 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 , _verificationSignature :: SignaturePayload } $(makeLenses ''Verification) hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/Types/Internal/Base.hs0000644000000000000000000011070312770565031022046 0ustar0000000000000000-- Base.hs: OpenPGP (RFC4880) data types -- Copyright © 2012-2016 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE CPP #-} {-# 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) #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif 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.Byteable (Byteable) 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) #if !MIN_VERSION_base(4,8,0) import Data.Monoid (Monoid, mempty) #endif import Data.Monoid ((<>)) import Data.Ord (comparing) 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 Text.PrettyPrint.Free (Pretty(..), (<+>), char, hsep, punctuate, space, text) 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 = text "plaintext" pretty IDEA = text "IDEA" pretty TripleDES = text "3DES" pretty CAST5 = text "CAST-128" pretty Blowfish = text "Blowfish" pretty ReservedSAFER = text "(reserved) SAFER" pretty ReservedDES = text "(reserved) DES" pretty AES128 = text "AES-128" pretty AES192 = text "AES-192" pretty AES256 = text "AES-256" pretty Twofish = text "Twofish" pretty Camellia128 = text "Camellia-128" pretty Camellia192 = text "Camellia-192" pretty Camellia256 = text "Camellia-256" pretty (OtherSA sa) = text "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 = text "human-readable" pretty (OtherNF o) = text "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 = text . 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 = text . 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 = text "sensitive" pretty (RClOther o) = text "unknown revocation class" <+> pretty o $(ATH.deriveJSON ATH.defaultOptions ''RevocationClass) data PubKeyAlgorithm = RSA | DeprecatedRSAEncryptOnly | DeprecatedRSASignOnly | ElgamalEncryptOnly | DSA | ECDH | ECDSA | ForbiddenElgamal | DH | 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 (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 o = OtherPKA o instance Hashable PubKeyAlgorithm instance Pretty PubKeyAlgorithm where pretty RSA = text "RSA" pretty DeprecatedRSAEncryptOnly = text "(deprecated) RSA encrypt-only" pretty DeprecatedRSASignOnly = text "(deprecated) RSA sign-only" pretty ElgamalEncryptOnly = text "Elgamal encrypt-only" pretty DSA = text "DSA" pretty ECDH = text "ECDH" pretty ECDSA = text "ECDSA" pretty ForbiddenElgamal = text "(forbidden) Elgamal" pretty DH = text "DH" pretty (OtherPKA pka) = text "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 text . 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, Pretty, Show, Typeable) 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, Pretty, Show, Typeable) 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 = text "(deprecated) MD5" pretty SHA1 = text "SHA-1" pretty RIPEMD160 = text "RIPEMD-160" pretty SHA256 = text "SHA-256" pretty SHA384 = text "SHA-384" pretty SHA512 = text "SHA-512" pretty SHA224 = text "SHA-224" pretty (OtherHA ha) = text "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 = text "uncompressed" pretty ZIP = text "ZIP" pretty ZLIB = text "zlib" pretty BZip2 = text "bzip2" pretty (OtherCA ca) = text "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 = text "no-modify" pretty (KSPOther o) = text "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 = text "group" pretty AuthKey = text "auth" pretty SplitKey = text "split" pretty EncryptStorageKey = text "encrypt-storage" pretty EncryptCommunicationsKey = text "encrypt-communications" pretty SignDataKey = text "sign-data" pretty CertifyKeysKey = text "certify-keys" pretty (KFOther o) = text "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 = text "no reason" pretty KeySuperseded = text "key superseded" pretty KeyMaterialCompromised = text "key material compromised" pretty KeyRetiredAndNoLongerUsed = text "key retired and no longer used" pretty UserIdInfoNoLongerValid = text "user-ID info no longer valid" pretty (RCoOther o) = text "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 = text "modification-detection" pretty (FeatureOther o) = text "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 = text "binary" pretty CanonicalTextSig = text "canonical-text" pretty StandaloneSig = text "standalone" pretty GenericCert = text "generic" pretty PersonaCert = text "persona" pretty CasualCert = text "casual" pretty PositiveCert = text "positive" pretty SubkeyBindingSig = text "subkey-binding" pretty PrimaryKeyBindingSig = text "primary-key-binding" pretty SignatureDirectlyOnAKey = text "signature directly on a key" pretty KeyRevocationSig = text "key-revocation" pretty SubkeyRevocationSig = text "subkey-revocation" pretty CertRevocationSig = text "cert-revocation" pretty TimestampSig = text "timestamp" pretty ThirdPartyConfirmationSig = text "third-party-confirmation" pretty (OtherSig o) = text "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) = text "signature v3" <> char ':' <+> pretty st <+> pretty ts <+> pretty eoki <+> pretty pka <+> pretty ha <+> pretty w16 <+> (pretty . NE.toList) mpis pretty (SigV4 st pka ha hsps usps w16 mpis) = text "signature v4" <> char ':' <+> pretty st <+> pretty pka <+> pretty ha <+> pretty hsps <+> pretty usps <+> pretty w16 <+> (pretty . NE.toList) mpis pretty (SigVOther t bs) = text "unknown signature v" <> pretty t <> char ':' <+> pretty (BL.unpack bs) instance A.ToJSON SignaturePayload where 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 | UserDefinedSigSub Word8 ByteString | OtherSigSub Word8 ByteString deriving (Data, Eq, Generic, Show, Typeable) -- FIXME instance Hashable SigSubPacketPayload instance Pretty SigSubPacketPayload where pretty (SigCreationTime ts) = text "creation-time" <+> pretty ts pretty (SigExpirationTime d) = text "sig expiration time" <+> pretty d pretty (ExportableCertification e) = text "exportable certification" <+> pretty e pretty (TrustSignature tl ta) = text "trust signature" <+> pretty tl <+> pretty ta pretty (RegularExpression apdre) = text "regular expression" <+> pretty apdre pretty (Revocable r) = text "revocable" <+> pretty r pretty (KeyExpirationTime d) = text "key expiration time" <+> pretty d pretty (PreferredSymmetricAlgorithms sas) = text "preferred symmetric algorithms" <+> pretty sas pretty (RevocationKey rcs pka tof) = text "revocation key" <+> pretty (Set.toList rcs) <+> pretty pka <+> pretty tof pretty (Issuer eoki) = text "issuer" <+> pretty eoki pretty (NotationData nfs nn nv) = text "notation data" <+> pretty (Set.toList nfs) <+> pretty nn <+> pretty nv pretty (PreferredHashAlgorithms phas) = text "preferred hash algorithms" <+> pretty phas pretty (PreferredCompressionAlgorithms pcas) = text "preferred compression algorithms" <+> pretty pcas pretty (KeyServerPreferences kspfs) = text "keyserver preferences" <+> pretty (Set.toList kspfs) pretty (PreferredKeyServer ks) = text "preferred keyserver" <+> pretty ks pretty (PrimaryUserId p) = (if p then mempty else text "NOT ") <> text "primary user-ID" pretty (PolicyURL u) = text "policy URL" <+> pretty u pretty (KeyFlags kfs) = text "key flags" <+> pretty (Set.toList kfs) pretty (SignersUserId u) = text "signer's user-ID" <+> pretty u pretty (ReasonForRevocation rc rr) = text "reason for revocation" <+> pretty rc <+> pretty rr pretty (Features ffs) = text "features" <+> pretty (Set.toList ffs) pretty (SignatureTarget pka ha sh) = text "signature target" <+> pretty pka <+> pretty ha <+> pretty sh pretty (EmbeddedSignature sp) = text "embedded signature" <+> pretty sp pretty (UserDefinedSigSub t bs) = text "user-defined signature subpacket type" <+> pretty t <+> pretty (BL.unpack bs) pretty (OtherSigSub t bs) = text "unknown signature subpacket type" <+> pretty t <+> pretty 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 (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 char '*' 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 = text "(deprecated) v3" pretty V4 = text "v4" $(ATH.deriveJSON ATH.defaultOptions ''KeyVersion) newtype IV = IV {unIV :: B.ByteString} deriving (Byteable, ByteArrayAccess, Data, Eq, Generic, Hashable, 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 = text "binary" pretty TextData = text "text" pretty UTF8Data = text "UTF-8" pretty (OtherData o) = text "other data type " <+> pretty o $(ATH.deriveJSON ATH.defaultOptions ''DataType) newtype Salt = Salt {unSalt :: B.ByteString} deriving (Byteable, 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) = text "simple S2K," <+> pretty ha pretty (Salted ha salt) = text "salted S2K," <+> pretty ha <+> pretty salt pretty (IteratedSalted ha salt icount) = text "iterated-salted S2K," <+> pretty ha <+> pretty salt <+> pretty icount pretty (OtherS2K t bs) = text "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 = text "JPEG" pretty (OtherImage o) = text "unknown image format" <+> pretty o $(ATH.deriveJSON ATH.defaultOptions ''ImageFormat) data 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) = text "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) = text "image-attribute" <+> pretty ih <+> pretty (BL.unpack d) pretty (OtherUASub t bs) = text "unknown attribute type" <> pretty t <+> pretty (BL.unpack bs) instance A.ToJSON UserAttrSubPacket where toJSON (ImageAttribute ih d) = A.toJSON (ih, BL.unpack d) toJSON (OtherUASub t bs) = A.toJSON (t, BL.unpack bs) data ECCCurve = BrokenNISTP256 | BrokenNISTP384 | BrokenNISTP521 deriving (Data, Eq, Generic, Ord, Show, Typeable) instance Hashable ECCCurve newtype Block a = Block {unBlock :: [a]} -- so we can override cereal instance deriving (Show, Eq) hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs0000644000000000000000000003006712770565031023375 0ustar0000000000000000-- PacketClass.hs: OpenPGP (RFC4880) data types -- 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 #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Codec.Encryption.OpenPGP.Types.Internal.PacketClass where import Codec.Encryption.OpenPGP.Types.Internal.Base import Codec.Encryption.OpenPGP.Types.Internal.PKITypes import Codec.Encryption.OpenPGP.Types.Internal.Pkt import Control.Lens (makeLenses) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import Data.Data (Data) import Data.List.NonEmpty (NonEmpty) import Data.Text (Text) import Data.Typeable (Typeable) import Data.Word (Word8) import Text.PrettyPrint.Free (Pretty(..)) class Packet a where data PacketType a :: * packetType :: a -> PacketType a packetCode :: PacketType a -> Word8 toPkt :: a -> Pkt fromPkt :: Pkt -> a data PKESK = PKESK { _pkeskPacketVersion :: PacketVersion , _pkeskEightOctetKeyId :: EightOctetKeyId , _pkeskPubKeyAlgorithm :: PubKeyAlgorithm , _pkeskMPIs :: NonEmpty MPI } 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" instance Pretty PKESK where pretty = pretty . toPkt data Signature = Signature -- FIXME? { _signaturePayload :: SignaturePayload } 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" instance Pretty Signature where pretty = pretty . toPkt data SKESK = SKESK { _skeskPacketVersion :: PacketVersion , _skeskSymmetricAlgorithm :: SymmetricAlgorithm , _skeskS2K :: S2K , _skeskESK :: Maybe BL.ByteString } 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" instance Pretty SKESK where pretty = pretty . toPkt data OnePassSignature = OnePassSignature { _onePassSignaturePacketVersion :: PacketVersion , _onePassSignatureSigType :: SigType , _onePassSignatureHashAlgorithm :: HashAlgorithm , _onePassSignaturePubKeyAlgorithm :: PubKeyAlgorithm , _onePassSignatureEightOctetKeyId :: EightOctetKeyId , _onePassSignatureNestedFlag :: NestedFlag } 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" instance Pretty OnePassSignature where pretty = pretty . toPkt data SecretKey = SecretKey { _secretKeyPKPayload :: PKPayload , _secretKeySKAddendum :: SKAddendum } 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" instance Pretty SecretKey where pretty = pretty . toPkt data PublicKey = PublicKey { _publicKeyPKPayload :: PKPayload } 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" instance Pretty PublicKey where pretty = pretty . toPkt data SecretSubkey = SecretSubkey { _secretSubkeyPKPayload :: PKPayload , _secretSubkeySKAddendum :: SKAddendum } 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" instance Pretty SecretSubkey where pretty = pretty . toPkt data CompressedData = CompressedData { _compressedDataCompressionAlgorithm :: CompressionAlgorithm , _compressedDataPayload :: CompressedDataPayload } 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" instance Pretty CompressedData where pretty = pretty . toPkt data SymEncData = SymEncData { _symEncDataPayload :: ByteString } 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" instance Pretty SymEncData where pretty = pretty . toPkt data Marker = Marker { _markerPayload :: ByteString } 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" instance Pretty Marker where pretty = pretty . toPkt data LiteralData = LiteralData { _literalDataDataType :: DataType , _literalDataFileName :: FileName , _literalDataTimeStamp :: ThirtyTwoBitTimeStamp , _literalDataPayload :: ByteString } 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" instance Pretty LiteralData where pretty = pretty . toPkt data Trust = Trust { _trustPayload :: ByteString } 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" instance Pretty Trust where pretty = pretty . toPkt data UserId = UserId { _userIdPayload :: Text } 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" instance Pretty UserId where pretty = pretty . toPkt data PublicSubkey = PublicSubkey { _publicSubkeyPKPayload :: PKPayload } 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" instance Pretty PublicSubkey where pretty = pretty . toPkt data UserAttribute = UserAttribute { _userAttributeSubPackets :: [UserAttrSubPacket] } 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" instance Pretty UserAttribute where pretty = pretty . toPkt data SymEncIntegrityProtectedData = SymEncIntegrityProtectedData { _symEncIntegrityProtectedDataPacketVersion :: PacketVersion , _symEncIntegrityProtectedDataPayload :: ByteString } 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" instance Pretty SymEncIntegrityProtectedData where pretty = pretty . toPkt data ModificationDetectionCode = ModificationDetectionCode { _modificationDetectionCodePayload :: ByteString } 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" instance Pretty ModificationDetectionCode where pretty = pretty . toPkt data OtherPacket = OtherPacket { _otherPacketType :: Word8 , _otherPacketPayload :: ByteString } 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" instance Pretty OtherPacket where pretty = pretty . toPkt data BrokenPacket = BrokenPacket { _brokenPacketParseError :: String , _brokenPacketType :: Word8 , _brokenPacketPayload :: ByteString } 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" instance Pretty BrokenPacket where 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) hOpenPGP-2.5.5/Codec/Encryption/OpenPGP/Types/Internal/TK.hs0000644000000000000000000000250712770565031021514 0ustar0000000000000000-- TK.hs: OpenPGP (RFC4880) transferable key data type -- 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 #-} {-# LANGUAGE TemplateHaskell #-} module Codec.Encryption.OpenPGP.Types.Internal.TK where import GHC.Generics (Generic) import Codec.Encryption.OpenPGP.Types.Internal.Base import Codec.Encryption.OpenPGP.Types.Internal.PKITypes import Codec.Encryption.OpenPGP.Types.Internal.Pkt import Control.Lens (makeLenses) import qualified Data.Aeson as A import qualified Data.Aeson.TH as ATH import Data.Data (Data) import Data.IxSet.Typed (IxSet) import Data.Ord (comparing) 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) instance Ord TK where compare = comparing _tkKey -- FIXME: is this ridiculous? $(ATH.deriveToJSON ATH.defaultOptions ''TK) type KeyringIxs = '[EightOctetKeyId, TwentyOctetFingerprint, Text] type Keyring = IxSet KeyringIxs TK $(makeLenses ''TK) hOpenPGP-2.5.5/tests/0000755000000000000000000000000012770565031012501 5ustar0000000000000000hOpenPGP-2.5.5/tests/suite.hs0000644000000000000000000006636212770565031014203 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- suite.hs: hOpenPGP test suite -- Copyright © 2012-2016 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). import Test.Tasty (defaultMain, testGroup, TestTree) import Test.Tasty.HUnit (testCase, Assertion, assertFailure, assertEqual) import Test.Tasty.QuickCheck as QC import Data.Bifunctor (bimap) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Codec.Encryption.OpenPGP.Arbitrary () import Codec.Encryption.OpenPGP.Compression (decompressPkt, compressPkts) import Codec.Encryption.OpenPGP.Expirations (isTKTimeValid) import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) import Codec.Encryption.OpenPGP.KeyInfo (pkalgoAbbrev, pubkeySize) import Codec.Encryption.OpenPGP.KeyringParser (parseTKs) import Codec.Encryption.OpenPGP.KeySelection (parseFingerprint) import Codec.Encryption.OpenPGP.SecretKey (decryptPrivateKey, encryptPrivateKey) import Codec.Encryption.OpenPGP.Serialize (parsePkts) import Codec.Encryption.OpenPGP.Signatures (verifyTKWith, verifySigWith, verifyAgainstKeys) import Codec.Encryption.OpenPGP.Types import Control.Error.Util (isRight) import Control.Monad.Trans.Resource (ResourceT, runResourceT) import qualified Crypto.PubKey.RSA as RSA import Data.Conduit.Serialization.Binary (conduitGet) import Data.Conduit.OpenPGP.Compression (conduitCompress, conduitDecompress) import Data.Conduit.OpenPGP.Decrypt (conduitDecrypt) import Data.Conduit.OpenPGP.Keyring (conduitToTKs, conduitToTKsDropping, sinkKeyringMap) import Data.Conduit.OpenPGP.Verify (conduitVerify) import Data.IxSet.Typed ((@=), getOne) import Data.Maybe (isJust) import Data.Binary (get, put) import Data.Binary.Get (runGetOrFail, Get) import Data.Binary.Put (runPut) import Data.Text (Text) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Text.PrettyPrint.Free (pretty) import qualified Data.Conduit as DC import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL -- this needs a better name runGet :: Get a -> BL.ByteString -> Either String a runGet g bs = bimap (\(_,_,x) -> x) (\(_,_,x) -> x) (runGetOrFail g bs) testSerialization :: FilePath -> Assertion testSerialization fpr = do bs <- BL.readFile $ "tests/data/" ++ fpr let firstpass = runGet get bs case fmap unBlock firstpass of Left _ -> assertFailure $ "First pass failed on " ++ fpr Right [] -> assertFailure $ "First pass of " ++ fpr ++ " decoded to nothing." Right packs -> do let roundtrip = runPut $ put (Block packs) let secondpass = runGet (get :: Get (Block Pkt)) roundtrip if fmap unBlock secondpass == Right [] then assertFailure $ "Second pass of " ++ fpr ++ " decoded to nothing." else assertEqual ("for " ++ fpr) firstpass secondpass testCompression :: FilePath -> Assertion testCompression fpr = do bs <- BL.readFile $ "tests/data/" ++ fpr let firstpass = fmap (concatMap decompressPkt . unBlock) . runGet get $ bs case firstpass of Left _ -> assertFailure $ "First pass failed on " ++ fpr Right [] -> assertFailure $ "First pass of " ++ fpr ++ " decoded to nothing." Right packs -> do let roundtrip = runPut $ put . Block $ [compressPkts ZIP packs] let secondpass = fmap (concatMap decompressPkt . unBlock) . runGet get $ roundtrip if secondpass == Right [] then assertFailure $ "Second pass of " ++ fpr ++ " decoded to nothing." else assertEqual ("for " ++ fpr) firstpass secondpass counter :: (Monad m) => DC.Sink a m Int counter = CL.fold (const . (1+)) 0 testConduitOutputLength :: FilePath -> DC.Conduit B.ByteString (ResourceT IO) b -> Int -> Assertion testConduitOutputLength fpr c target = do len <- runResourceT $ CB.sourceFile ("tests/data/" ++ fpr) DC.$= c DC.$$ counter assertEqual ("expected length " ++ show target) target len testPKAandSizeAndKeyIDandFingerprint :: FilePath -> String -> Assertion testPKAandSizeAndKeyIDandFingerprint fpr kf = do bs <- BL.readFile $ "tests/data/" ++ fpr case runGet (get :: Get Pkt) bs of Left _ -> assertFailure $ "Decoding of " ++ fpr ++ " broke." Right (PublicKeyPkt pkp) -> do let pref = concat [pkalgoAbbrev (_pkalgo pkp), either (const "unknown") show (pubkeySize (_pubkey pkp)), ":", either (const "unknown") (show . pretty) (eightOctetKeyID pkp), "/"] assertEqual ("for " ++ fpr ++ " (spaceless)") (spaceless kf) (pref ++ show (pretty (fingerprint pkp))) assertEqual ("for " ++ fpr ++ " (spaced)") kf (pref ++ show (pretty (SpacedFingerprint (fingerprint pkp)))) _ -> assertFailure "Expected public key, got something else." where spaceless = filter (/=' ') testKeyringLookup :: FilePath -> String -> Bool -> Assertion testKeyringLookup fpr eok expected = do kr <- runResourceT $ CB.sourceFile ("tests/data/" ++ fpr) DC.$= conduitGet get DC.$= conduitToTKs DC.$$ sinkKeyringMap let key = getOne (kr @= (read eok :: EightOctetKeyId)) assertEqual (eok ++ " in " ++ fpr) expected (isJust key) testVerifyMessage :: FilePath -> FilePath -> [TwentyOctetFingerprint] -> Assertion testVerifyMessage keyring message issuers = do kr <- runResourceT $ CB.sourceFile ("tests/data/" ++ keyring) DC.$= conduitGet get DC.$= conduitToTKs DC.$$ sinkKeyringMap verification <- runResourceT $ CB.sourceFile ("tests/data/" ++ message) DC.$= conduitGet get DC.$= conduitDecompress DC.$= conduitVerify kr Nothing DC.$$ CL.consume let verification' = map (fmap (fingerprint . _verificationSigner)) verification assertEqual (keyring ++ " for " ++ message) (map Right issuers) verification' testKeysSelfVerification :: Bool -> FilePath -> Assertion testKeysSelfVerification expectsuccess keyfile = do ks <- runResourceT $ CB.sourceFile ("tests/data/" ++ keyfile) DC.$= conduitGet get DC.$= conduitToTKs DC.$$ CL.consume let verifieds = mapM (verifyTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks assertEqual (keyfile ++ " self-verification") expectsuccess (isRight verifieds) testKeysExpiration :: Bool -> FilePath -> Assertion testKeysExpiration expectsuccess keyfile = do ks <- runResourceT $ CB.sourceFile ("tests/data/" ++ keyfile) DC.$= conduitGet get DC.$= conduitToTKs DC.$$ CL.consume let Right verifieds = mapM (verifyTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks tvalid = all (isTKTimeValid (posixSecondsToUTCTime (realToFrac (1400000000 :: Integer)))) verifieds assertEqual (keyfile ++ " key expiration") expectsuccess tvalid -- This needs a lot of work testSymmetricEncryption :: FilePath -> FilePath -> BL.ByteString -> Assertion testSymmetricEncryption encfile passfile cleartext = do passphrase <- BL.readFile $ "tests/data/" ++ passfile -- get parse tree pt <- runResourceT $ CB.sourceFile ("tests/data/" ++ encfile) DC.$= conduitGet get DC.$$ CL.consume -- assert parse tree has exactly two packets: skesk, encdata assertEqual "wrong number of packets" 2 (length pt) let skesk = fromPkt.head $ pt d = fromPkt.last $ pt -- FIXME: these assertions don't currently do anything properly, -- because haskell notices the _-prefixed accessor invocations below -- and the type system chokes before we hit them: assertEqual "first packet should be SKESK" SKESKType (packetType skesk) assertEqual "second packet should be encrypted data" SymEncIntegrityProtectedDataType (packetType d) decrypted <- runResourceT $ CL.sourceList pt DC.$= conduitDecrypt (fakeCallback passphrase) DC.$$ CL.consume let payload = _literalDataPayload . fromPkt . head $ decrypted assertEqual ("cleartext for " ++ encfile) cleartext payload where fakeCallback :: BL.ByteString -> String -> IO BL.ByteString fakeCallback = const . return testSecretKeyDecryption :: FilePath -> FilePath -> Assertion testSecretKeyDecryption keyfile passfile = do passphrase <- BL.readFile $ "tests/data/" ++ passfile kr <- runResourceT $ CB.sourceFile ("tests/data/" ++ keyfile) DC.$= conduitGet get DC.$$ CL.consume let SecretKey pkp ska = fromPkt . head $ kr SUUnencrypted skey _ = decryptPrivateKey (pkp, ska) passphrase doPkeyAndSkeyMatch (_pubkey pkp) skey -- FIXME: this should be reworked either with tasty-golden or some other form of sanity testSecretKeyEncryption :: FilePath -> FilePath -> Assertion testSecretKeyEncryption keyfile passfile = do passphrase <- BL.readFile $ "tests/data/" ++ passfile kr <- runResourceT $ CB.sourceFile ("tests/data/" ++ keyfile) DC.$= conduitGet get DC.$$ CL.consume gkr <- runResourceT $ CB.sourceFile ("tests/data/" ++ "aes256-sha512.seckey") DC.$= conduitGet get DC.$$ CL.consume let SecretKey pkp ska = fromPkt . head $ kr newska = encryptPrivateKey "\226~\197\a\202#\"G" (IV "\187\219\253I\236\204\t5D\196\NAK>;\202\185\t") ska passphrase newtruck = toPkt (SecretKey pkp newska):tail kr assertEqual "encrypted private key matches golden file" gkr newtruck testParsePktsUtil :: FilePath -> Assertion testParsePktsUtil fn = do let fpath = "tests/data/" ++ fn cp <- runResourceT $ CB.sourceFile fpath DC.$= conduitGet get DC.$$ CL.consume pp <- parsePkts `fmap` BL.readFile fpath assertEqual "parsePkts utility function gives same results as conduit pipeline" cp pp testParseTKsUtil :: FilePath -> Assertion testParseTKsUtil fn = do let fpath = "tests/data/" ++ fn lbs <- BL.readFile fpath cp <- runResourceT $ CB.sourceLbs lbs DC.$= conduitGet get DC.$= conduitToTKs DC.$$ CL.consume let pt = parseTKs True . parsePkts $ lbs assertEqual "parsePkts utility function gives same results as conduit pipeline" cp pt tests :: TestTree tests = testGroup "Tests" [properties, unitTests] unitTests :: TestTree unitTests = testGroup "Unit Tests" [ testGroup "Serialization group" [ testCase "000001-006.public_key" (testSerialization "000001-006.public_key") , testCase "000002-013.user_id" (testSerialization "000002-013.user_id") , testCase "000003-002.sig" (testSerialization "000003-002.sig") , testCase "000004-012.ring_trust" (testSerialization "000004-012.ring_trust") , testCase "000005-002.sig" (testSerialization "000005-002.sig") , testCase "000006-012.ring_trust" (testSerialization "000006-012.ring_trust") , testCase "000007-002.sig" (testSerialization "000007-002.sig") , testCase "000008-012.ring_trust" (testSerialization "000008-012.ring_trust") , testCase "000009-002.sig" (testSerialization "000009-002.sig") , testCase "000010-012.ring_trust" (testSerialization "000010-012.ring_trust") , testCase "000011-002.sig" (testSerialization "000011-002.sig") , testCase "000012-012.ring_trust" (testSerialization "000012-012.ring_trust") , testCase "000013-014.public_subkey" (testSerialization "000013-014.public_subkey") , testCase "000014-002.sig" (testSerialization "000014-002.sig") , testCase "000015-012.ring_trust" (testSerialization "000015-012.ring_trust") , testCase "000016-006.public_key" (testSerialization "000016-006.public_key") , testCase "000017-002.sig" (testSerialization "000017-002.sig") , testCase "000018-012.ring_trust" (testSerialization "000018-012.ring_trust") , testCase "000019-013.user_id" (testSerialization "000019-013.user_id") , testCase "000020-002.sig" (testSerialization "000020-002.sig") , testCase "000021-012.ring_trust" (testSerialization "000021-012.ring_trust") , testCase "000022-002.sig" (testSerialization "000022-002.sig") , testCase "000023-012.ring_trust" (testSerialization "000023-012.ring_trust") , testCase "000024-014.public_subkey" (testSerialization "000024-014.public_subkey") , testCase "000025-002.sig" (testSerialization "000025-002.sig") , testCase "000026-012.ring_trust" (testSerialization "000026-012.ring_trust") , testCase "000027-006.public_key" (testSerialization "000027-006.public_key") , testCase "000028-002.sig" (testSerialization "000028-002.sig") , testCase "000029-012.ring_trust" (testSerialization "000029-012.ring_trust") , testCase "000030-013.user_id" (testSerialization "000030-013.user_id") , testCase "000031-002.sig" (testSerialization "000031-002.sig") , testCase "000032-012.ring_trust" (testSerialization "000032-012.ring_trust") , testCase "000033-002.sig" (testSerialization "000033-002.sig") , testCase "000034-012.ring_trust" (testSerialization "000034-012.ring_trust") , testCase "000035-006.public_key" (testSerialization "000035-006.public_key") , testCase "000036-013.user_id" (testSerialization "000036-013.user_id") , testCase "000037-002.sig" (testSerialization "000037-002.sig") , testCase "000038-012.ring_trust" (testSerialization "000038-012.ring_trust") , testCase "000039-002.sig" (testSerialization "000039-002.sig") , testCase "000040-012.ring_trust" (testSerialization "000040-012.ring_trust") , testCase "000041-017.attribute" (testSerialization "000041-017.attribute") , testCase "000042-002.sig" (testSerialization "000042-002.sig") , testCase "000043-012.ring_trust" (testSerialization "000043-012.ring_trust") , testCase "000044-014.public_subkey" (testSerialization "000044-014.public_subkey") , testCase "000045-002.sig" (testSerialization "000045-002.sig") , testCase "000046-012.ring_trust" (testSerialization "000046-012.ring_trust") , testCase "000047-005.secret_key" (testSerialization "000047-005.secret_key") , testCase "000048-013.user_id" (testSerialization "000048-013.user_id") , testCase "000049-002.sig" (testSerialization "000049-002.sig") , testCase "000050-012.ring_trust" (testSerialization "000050-012.ring_trust") , testCase "000051-007.secret_subkey" (testSerialization "000051-007.secret_subkey") , testCase "000052-002.sig" (testSerialization "000052-002.sig") , testCase "000053-012.ring_trust" (testSerialization "000053-012.ring_trust") , testCase "000054-005.secret_key" (testSerialization "000054-005.secret_key") , testCase "000055-002.sig" (testSerialization "000055-002.sig") , testCase "000056-012.ring_trust" (testSerialization "000056-012.ring_trust") , testCase "000057-013.user_id" (testSerialization "000057-013.user_id") , testCase "000058-002.sig" (testSerialization "000058-002.sig") , testCase "000059-012.ring_trust" (testSerialization "000059-012.ring_trust") , testCase "000060-007.secret_subkey" (testSerialization "000060-007.secret_subkey") , testCase "000061-002.sig" (testSerialization "000061-002.sig") , testCase "000062-012.ring_trust" (testSerialization "000062-012.ring_trust") , testCase "000063-005.secret_key" (testSerialization "000063-005.secret_key") , testCase "000064-002.sig" (testSerialization "000064-002.sig") , testCase "000065-012.ring_trust" (testSerialization "000065-012.ring_trust") , testCase "000066-013.user_id" (testSerialization "000066-013.user_id") , testCase "000067-002.sig" (testSerialization "000067-002.sig") , testCase "000068-012.ring_trust" (testSerialization "000068-012.ring_trust") , testCase "000069-005.secret_key" (testSerialization "000069-005.secret_key") , testCase "000070-013.user_id" (testSerialization "000070-013.user_id") , testCase "000071-002.sig" (testSerialization "000071-002.sig") , testCase "000072-012.ring_trust" (testSerialization "000072-012.ring_trust") , testCase "000073-017.attribute" (testSerialization "000073-017.attribute") , testCase "000074-002.sig" (testSerialization "000074-002.sig") , testCase "000075-012.ring_trust" (testSerialization "000075-012.ring_trust") , testCase "000076-007.secret_subkey" (testSerialization "000076-007.secret_subkey") , testCase "000077-002.sig" (testSerialization "000077-002.sig") , testCase "000078-012.ring_trust" (testSerialization "000078-012.ring_trust") , testCase "pubring.gpg" (testSerialization "pubring.gpg") , testCase "secring.gpg" (testSerialization "secring.gpg") , testCase "compressedsig.gpg" (testSerialization "compressedsig.gpg") , testCase "compressedsig-zlib.gpg" (testSerialization "compressedsig-zlib.gpg") , testCase "compressedsig-bzip2.gpg" (testSerialization "compressedsig-bzip2.gpg") , testCase "onepass_sig" (testSerialization "onepass_sig") , testCase "uncompressed-ops-dsa.gpg" (testSerialization "uncompressed-ops-dsa.gpg") , testCase "uncompressed-ops-rsa.gpg" (testSerialization "uncompressed-ops-rsa.gpg") , testCase "simple.seckey" (testSerialization "simple.seckey") , testCase "v3-genericcert.sig" (testSerialization "v3-genericcert.sig") , testCase "sigs-with-regexes" (testSerialization "sigs-with-regexes") , testCase "gnu-dummy-s2k-101-secret-key.gpg" (testSerialization "gnu-dummy-s2k-101-secret-key.gpg") , testCase "anibal-ed25519.gpg" (testSerialization "anibal-ed25519.gpg") ], testGroup "PKA/Size/KeyID/fingerprint group" [ testCase "v3 key" (testPKAandSizeAndKeyIDandFingerprint "v3.key" "R1024:C7261095/CBD9 F412 6807 E405 CC2D 2712 1DF5 E86E") , testCase "v4 key" (testPKAandSizeAndKeyIDandFingerprint "000001-006.public_key" "R1248:D4D54EA16F87040E/421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E") ], testGroup "Keyring group" [ testCase "pubring 7732CF988A63EA86" (testKeyringLookup "pubring.gpg" "7732CF988A63EA86" True) , testCase "pubring 123456789ABCDEF0" (testKeyringLookup "pubring.gpg" "123456789ABCDEF0" False) , testCase "pubsub AD992E9C24399832" (testKeyringLookup "pubring.gpg" "AD992E9C24399832" True) , testCase "secring 7732CF988A63EA86" (testKeyringLookup "secring.gpg" "7732CF988A63EA86" True) , testCase "secring 123456789ABCDEF0" (testKeyringLookup "secring.gpg" "123456789ABCDEF0" False) , testCase "secsub AD992E9C24399832" (testKeyringLookup "secring.gpg" "AD992E9C24399832" True) -- FIXME: should count keys in rings ], testGroup "Message verification group" [ testCase "uncompressed-ops-dsa" (testVerifyMessage "pubring.gpg" "uncompressed-ops-dsa.gpg" [fp "1EB2 0B2F 5A5C C3BE AFD6 E5CB 7732 CF98 8A63 EA86"]) , testCase "uncompressed-ops-dsa-sha384" (testVerifyMessage "pubring.gpg" "uncompressed-ops-dsa-sha384.txt.gpg" [fp "1EB2 0B2F 5A5C C3BE AFD6 E5CB 7732 CF98 8A63 EA86"]) , testCase "uncompressed-ops-rsa" (testVerifyMessage "pubring.gpg" "uncompressed-ops-rsa.gpg" [fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D"]) , testCase "compressedsig" (testVerifyMessage "pubring.gpg" "compressedsig.gpg" [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) , testCase "compressedsig-zlib" (testVerifyMessage "pubring.gpg" "compressedsig-zlib.gpg" [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) , testCase "compressedsig-bzip2" (testVerifyMessage "pubring.gpg" "compressedsig-bzip2.gpg" [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) ], testGroup "Certificate verification group" [ testCase "userid" (testVerifyMessage "pubring.gpg" "minimized.gpg" [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) , testCase "subkey" (testVerifyMessage "pubring.gpg" "subkey.gpg" [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) , testCase "primary key binding" (testVerifyMessage "signing-subkey.gpg" "primary-binding.gpg" [fp "ED1B D216 F70E 5D5F 4444 48F9 B830 F2C4 83A9 9AE5"]) , testCase "attribute" (testVerifyMessage "pubring.gpg" "uat.gpg" [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) , testCase "primary key revocation" (testVerifyMessage "pubring.gpg" "prikey-rev.gpg" [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) , testCase "subkey revocation" (testVerifyMessage "pubring.gpg" "subkey-rev.gpg" [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) , testCase "6F87040E" (testVerifyMessage "pubring.gpg" "6F87040E.pubkey" [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E", fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D", fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC"]) , testCase "6F87040E-cr" (testVerifyMessage "pubring.gpg" "6F87040E-cr.pubkey" [fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC", fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC", fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E", fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D", fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC"]) , testCase "simple RSA secret key" (testVerifyMessage "pubring.gpg" "simple.seckey" [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) ], testGroup "Key verification group" [ testCase "6F87040E pubkey" (testKeysSelfVerification True "6F87040E.pubkey") , testCase "revoked pubkey" (testKeysSelfVerification False "revoked.pubkey") , testCase "expired pubkey" (testKeysSelfVerification True "expired.pubkey") ], testGroup "Key expiration group" [ testCase "6F87040E pubkey" (testKeysExpiration True "6F87040E.pubkey") , testCase "expired pubkey" (testKeysExpiration False "expired.pubkey") ], testGroup "Compression group" [ testCase "compressedsig.gpg" (testCompression "compressedsig.gpg") , testCase "compressedsig-zlib.gpg" (testCompression "compressedsig-zlib.gpg") , testCase "compressedsig-bzip2.gpg" (testCompression "compressedsig-bzip2.gpg") ], testGroup "Conduit length group" [ testCase "conduitCompress (ZIP)" (testConduitOutputLength "pubring.gpg" (cgp DC.=$= conduitCompress ZIP) 1) , testCase "conduitCompress (Zlib)" (testConduitOutputLength "pubring.gpg" (cgp DC.=$= conduitCompress ZLIB) 1) , testCase "conduitCompress (BZip2)" (testConduitOutputLength "pubring.gpg" (cgp DC.=$= conduitCompress BZip2) 1) , testCase "conduitToTKs" (testConduitOutputLength "pubring.gpg" (cgp DC.=$= conduitToTKs) 4) , testCase "conduitToTKsDropping" (testConduitOutputLength "pubring.gpg" (cgp DC.=$= conduitToTKsDropping) 4) ], testGroup "Encrypted data" [ testCase "Symmetric Encryption simple S2K SHA1 3DES, no MDC" (testSymmetricEncryption "encryption-sym-3des-s2k0.gpg" "symmetric-password.txt" "test\n") , testCase "Symmetric Encryption iterated-salted S2K SHA1 3DES, no MDC" (testSymmetricEncryption "encryption-sym-3des.gpg" "symmetric-password.txt" "test\n") , testCase "Symmetric Encryption simple S2K SHA1 3DES" (testSymmetricEncryption "encryption-sym-3des-mdc-s2k0.gpg" "symmetric-password.txt" "test\n") , testCase "Symmetric Encryption iterated-salted S2K SHA1 3DES" (testSymmetricEncryption "encryption-sym-3des-mdc.gpg" "symmetric-password.txt" "test\n") , testCase "Symmetric Encryption simple S2K SHA1 CAST5, no MDC" (testSymmetricEncryption "encryption-sym-cast5-s2k0.gpg" "symmetric-password.txt" "test\n") , testCase "Symmetric Encryption iterated-salted S2K SHA1 CAST5, no MDC" (testSymmetricEncryption "encryption-sym-cast5.gpg" "symmetric-password.txt" "test\n") , testCase "Symmetric Encryption simple S2K SHA1 CAST5" (testSymmetricEncryption "encryption-sym-cast5-mdc-s2k0.gpg" "symmetric-password.txt" "test\n") , testCase "Symmetric Encryption iterated-salted S2K SHA1 CAST5" (testSymmetricEncryption "encryption-sym-cast5-mdc.gpg" "symmetric-password.txt" "test\n") , testCase "Symmetric Encryption simple S2K SHA1 Blowfish, no MDC" (testSymmetricEncryption "encryption-sym-blowfish-s2k0.gpg" "symmetric-password.txt" "test\n") , testCase "Symmetric Encryption iterated-salted S2K SHA1 Blowfish, no MDC" (testSymmetricEncryption "encryption-sym-blowfish.gpg" "symmetric-password.txt" "test\n") , testCase "Symmetric Encryption simple S2K SHA1 Blowfish" (testSymmetricEncryption "encryption-sym-blowfish-mdc-s2k0.gpg" "symmetric-password.txt" "test\n") , testCase "Symmetric Encryption iterated-salted S2K SHA1 Blowfish" (testSymmetricEncryption "encryption-sym-blowfish-mdc.gpg" "symmetric-password.txt" "test\n") , testCase "Symmetric Encryption simple S2K SHA1 AES128" (testSymmetricEncryption "encryption-sym-aes128-s2k0.gpg" "symmetric-password.txt" "test\n") , testCase "Symmetric Encryption iterated-salted S2K SHA1 AES128" (testSymmetricEncryption "encryption-sym-aes128.gpg" "symmetric-password.txt" "test\n") , testCase "Symmetric Encryption simple S2K SHA1 AES192" (testSymmetricEncryption "encryption-sym-aes192-s2k0.gpg" "symmetric-password.txt" "test\n") , testCase "Symmetric Encryption iterated-salted S2K SHA1 AES192" (testSymmetricEncryption "encryption-sym-aes192.gpg" "symmetric-password.txt" "test\n") , testCase "Symmetric Encryption simple S2K SHA1 AES256" (testSymmetricEncryption "encryption-sym-aes256-s2k0.gpg" "symmetric-password.txt" "test\n") , testCase "Symmetric Encryption iterated-salted S2K SHA1 AES256" (testSymmetricEncryption "encryption-sym-aes256.gpg" "symmetric-password.txt" "test\n") , testCase "Symmetric Encryption simple S2K SHA1 Twofish" (testSymmetricEncryption "encryption-sym-twofish-s2k0.gpg" "symmetric-password.txt" "test\n") , testCase "Symmetric Encryption iterated-salted S2K SHA1 Twofish" (testSymmetricEncryption "encryption-sym-twofish.gpg" "symmetric-password.txt" "test\n") , testCase "Symmetric Encryption simple Camellia128" (testSymmetricEncryption "encryption-sym-camellia128-s2k0.gpg" "symmetric-password.txt" "test\n") , testCase "Symmetric Encryption iterated-salted Camellia128" (testSymmetricEncryption "encryption-sym-camellia128.gpg" "symmetric-password.txt" "test\n") , testCase "Symmetric Encryption iterated-salted Camellia192" (testSymmetricEncryption "encryption-sym-camellia192.gpg" "symmetric-password.txt" "test\n") , testCase "Symmetric Encryption iterated-salted Camellia256" (testSymmetricEncryption "encryption-sym-camellia256.gpg" "symmetric-password.txt" "test\n") ], testGroup "Encrypted secret keys" [ testCase "SUSSHA1 CAST5 IteratedSalted SHA1 RSA" (testSecretKeyDecryption "simple.seckey" "pki-password.txt") , testCase "SUS16bit CAST5 IteratedSalted SHA1 RSA" (testSecretKeyDecryption "16bitcksum.seckey" "pki-password.txt") , testCase "SUSSHA1 AES256 IteratedSalted SHA512 RSA" (testSecretKeyDecryption "aes256-sha512.seckey" "pki-password.txt") ], testGroup "Encrypting secret keys" [ testCase "SUSSHA1 AES256 IteratedSalted SHA512 RSA" (testSecretKeyEncryption "unencrypted.seckey" "pki-password.txt") ], testGroup "Utility function group" [ testCase "pubring as packets" (testParsePktsUtil "pubring.gpg") , testCase "pubring as TKs" (testParseTKsUtil "pubring.gpg") ] ] properties :: TestTree properties = testGroup "Properties" [qcProps] qcProps :: TestTree qcProps = testGroup "(checked by QuickCheck)" [ QC.testProperty "PKESK packet serialization-deserialization" $ \pkesk -> Right (pkesk :: PKESK) == runGet get (runPut (put pkesk)) , QC.testProperty "Signature packet serialization-deserialization" $ \sig -> Right (sig :: Signature) == runGet get (runPut (put sig)) , QC.testProperty "UserId packet serialization-deserialization" $ \uid -> Right (uid :: UserId) == runGet get (runPut (put uid)) ] cgp :: DC.Conduit B.ByteString (ResourceT IO) Pkt cgp = conduitGet (get :: Get Pkt) fp :: Text -> TwentyOctetFingerprint fp = either error id . parseFingerprint doPkeyAndSkeyMatch :: PKey -> SKey -> Assertion doPkeyAndSkeyMatch (RSAPubKey (RSA_PublicKey rpub)) (RSAPrivateKey (RSA_PrivateKey rpriv)) = assertEqual "RSA private key matches RSA public key" rpub (RSA.private_pub rpriv) doPkeyAndSkeyMatch _ _ = assertFailure "matching unimplemented" main :: IO () main = defaultMain tests hOpenPGP-2.5.5/tests/data/0000755000000000000000000000000012770565031013412 5ustar0000000000000000hOpenPGP-2.5.5/tests/data/000056-012.ring_trust0000644000000000000000000000000412770565031016560 0ustar0000000000000000hOpenPGP-2.5.5/tests/data/000019-013.user_id0000644000000000000000000000004612770565031016020 0ustar0000000000000000$Test Key (DSA) hOpenPGP-2.5.5/tests/data/000017-002.sig0000644000000000000000000000017312770565031015145 0ustar0000000000000000y!OwJ  /Z\þw2Ϙc ^#A2b& bta=0)Ҷ?9pɼRORͤ[L]ڳ,}pcï-`+LѰhOpenPGP-2.5.5/tests/data/onepass_sig0000644000000000000000000000001712770565031015645 0ustar0000000000000000 NohOpenPGP-2.5.5/tests/data/000040-012.ring_trust0000644000000000000000000000000412770565031016551 0ustar0000000000000000hOpenPGP-2.5.5/tests/data/000029-012.ring_trust0000644000000000000000000000000412770565031016560 0ustar0000000000000000hOpenPGP-2.5.5/tests/data/000020-002.sig0000644000000000000000000000020212770565031015130 0ustar0000000000000000(Ow    ^#A2bܯgi\Q$`;! 873?wNj*rK%% Aý~uhOpenPGP-2.5.5/tests/data/encryption-sym-aes256-s2k0.gpg0000644000000000000000000000010212770565031020662 0ustar0000000000000000 :'.-D2tl"kVBdty(f}E;| hOpenPGP-2.5.5/tests/data/000030-013.user_id0000644000000000000000000000005512770565031016011 0ustar0000000000000000+Test Key (DSA sign-only) hOpenPGP-2.5.5/tests/data/encryption-sym-blowfish-mdc.gpg0000644000000000000000000000011412770565031021461 0ustar0000000000000000 K`;PRtW,!mp ɄX_TsdzH8*Z^Xccݟd17Gqr hOpenPGP-2.5.5/tests/data/6F87040E-cr.pubkey0000644000000000000000000000161512770565031016223 0ustar0000000000000000Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~o0OwITesting revsig ^#A2biBV#WY#-B>,[> $x yfu 38#o0OwIDtesting revsig ^#A2b>+ #1ѽ^Qmz6!$W+6+TQeL[3Gl/(Ow$ π   No=8 \-97Ed;|̙j%`9^a M~U3pѰuhxᶱ[WkSfB)C3 %C ]h,x-fɗI Q]-liuCa$`ml5e1ΥnOwHw >hm´#pBjH t_%*Y/V;k.Yy7%;z(Pvn*_7JD+&*,il)c Y3n]U}aD|"[N#a^OwI5 ^#A2bQ>&P{k-aعl nqaѡ0!Y꾹gkv0HjhOpenPGP-2.5.5/tests/data/000047-005.secret_key0000644000000000000000000000114212770565031016523 0ustar0000000000000000_Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~mW3W%O:`X~8%d\ٺ§'hOpenPGP-2.5.5/tests/data/signing-subkey.gpg0000644000000000000000000000172012770565031017047 0ustar0000000000000000Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~(Ow$ π   No=8 \-97Ed;|̙j%`9^a M~U3pѰuhxᶱ[WkSfB)C3 %C ]h,x-fɗI Q]-liuCa$`ml5e1ΥnPZl;yh}6DDdBn RVNv$.o/YP-ȑsB/blͅ &l)Fmm.z\ąU;?,<6銁>EXVE+m*8QSCp x]u P No P 0ăcas:f&`\R!tϪ3οxa_|Xq?gщʋS<9S.upr{>mBy"5n}6`}Ҍ/|,lcIyդ8iI4_l e3t%1~hOpenPGP-2.5.5/tests/data/000076-007.secret_subkey0000644000000000000000000000170112770565031017242 0ustar0000000000000000OwJGgC!_ZGk렂=KsxH-!*nLvXFw|#W,l;qfO^>3(@ 8A ̇کv4'gb2R!e.}񀙱ltM?E-]5ds1\Z7_MեZC)'MB4gȇIİLJ3JX< |4NW~AG}5[BaCrj/"͒u6 t=pjZ}Eh2:ZN<NcIVPDaP6Sd ׶P(sQ+'Jy!ڿ`{? bh5׽ OaD\2Vޖtr#'dWB_'<{ O,L , hd(&%/{3F){٬m5_YStuCCb̐hOpenPGP-2.5.5/tests/data/000001-006.public_key0000644000000000000000000000025312770565031016505 0ustar0000000000000000Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~S}%Nbx%9mˣ^l":C*=hOpenPGP-2.5.5/tests/data/primary-binding.gpg0000644000000000000000000000102012770565031017175 0ustar0000000000000000Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~EXVE+m*8QSCp x]P 0ăcas:f&`\R!tϪ3οxa_|Xq?gщʋS<o'   J ^eGPG ~*]*6- F;+rYlQpC{腵en!Micah Anderson o'   J ^eGPG ~*]*|J0~Ȏ.t9-Ngl8U2$Micah Anderson l$   J ^eGPG ~*]*8?#î~vg @zZҡp~w.(p'Micah Johan Anderson d$   J ^ ~*]*Oy `o8VkK'(oM .ͺUO<3Æ1Micah Anderson (no comment) l$   J ^eGPG ~*]**mu{'%p{U=  H"౤M\GR |N;\oEΦa&ߋwb8?ŦcsYV-BЁrr~sJd) lc#u+~-X{LYL)"lKI G ~*]*;la!xQ/%@HtF1zwV!^D?X(Hƻsmartcard broke ~*]*{8>6Cmȅi؋?+8 WΉnhGR%Oio Zlne\ =Ii[BIaم4,ήX I ;(!O+HШ&-Ydӻ#>yFϏ'JmnI G ~*]*bRˎrKȚiڣ>[ HE!˜QY/X(Hƻwsmartcard broke ~*]* vFdY@@>T?L)~B+c'GIQ5> 6F3?mW/%"H<춰=(V )X vnA<{Y≔ffi{^=cT`S!,FкGhrm*X"|g's_xI GI ~*]*pT6QUu:mv +}q~%cZ(HAopenpgp key broke ~*]* .*KU53m.yӿykߩʉ\Da HP5 !t<xn Qj~3to #c7 2!_(?9  7+IP;tjsO+R(7jr:j\0`e6Dﶢh 䎛c]I HP5 ~*]*k8 zAA#!Gj7Pu:j-'X(Hksmartcard broke ~*]* c^s&1Gbk1e yöe UָGaC"ǩy\hӦXDk4XZR$Ol}&tܵHεž/HVpvܷquf do#J&%v OT7fv?HR_* }I G ~*]*a4l_QW(.CX5;1Z9umX(H&smartcard broke ~*]*FX4W^sY~ a.:% BOΛt| a=B%\ $7,,;?}BEUW-'ͥ+ O1w SOr(2H+Replaced subkey due to smartcard breakage ~*]*LX_rsI1?XGIyê/ M6zU/k[o2$Ů俐hW ܫ6cZˤ}b8vCyRRT7`zRFBzDW24*JDz+y@3Uke<8~ ![(HAyopenpgp card broke ~*]*PWVT7TJ-TpK6WJE0zvGX> GIz ~*]* GIz t\E_M5(2!sşN\=tƢ:ܕ >Lkge<ʤ4]7A=?GFXf5`$Sk71~Ĺ,pW꒖ 3`IFC`jENA"s޸T*SWj=V3< >HP5`P%**o)/Gp~CEervPyw/evq!Y͏vܸR 0cO-~T"fz/_ui>#&<)R|:Ă꺙mp{ J_г 6qI HP5` ~*]*/UwX"تE/^JAy~*cgNX(Hsmartcard broke ~*]*ЯG|@q&.p=b3U2up۩f$ cHP5eGxy&ERČ{s[3eCw]q2!?*6vQ w8'qn-+WꨁK&9ptAw(oaę2sk<ċ۠Htb'UQqmAWDj9=u m@^WI(S /Cw0eza_%mӓ&3d@ugKvp=y5t 9]R#4jJ?v+,Rԍ; i: $!,;BevE̿-}Áx RJAtcmЋA:/rQF#$喙9ZKFPȆnT:mV<rFxP@B|B+a,**3ʡC`5R 3x%:;,seilm{U=rQ1N9] ~*]*eGPG H>ƌ2N< G8DsР>2S_8*{( ;J8$4Please see: http://micah.riseup.net/key_transition ~*]*vEqjE)r?c^OpKV r:XhOpenPGP-2.5.5/tests/data/subkey.gpg0000644000000000000000000000107712770565031015420 0ustar0000000000000000Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~Ow$ພo# \X" l9Nv`x]pBA hzSX[s'S4~#{T V`;~ 'o]3U.-Psڮ>S}%Nbx%9mˣ^l":C*=Ow$  π No9R \R^mNʖlysQ%x=ӿbG"lf!%F*w͎gL#!^_ql5qWe/< 0k)sL34ʺmEy$éH#TP.f\w=j4akhOpenPGP-2.5.5/tests/data/compressedsig-bzip2.gpg0000644000000000000000000000067212770565031020011 0ustar0000000000000000BZh61AY&SYVmns{E"ZPf(1ŷKU0LTѴFL4`Li 1CL H`ISzHt20M0`G00TD= dFFOHd4i4 cD$HAP%~":(X;.;)6Lތ̖jH0D>ḽO&BD`;M*E8 nfoeuueFdYz Y#K,H.B4hNf'0 Jg~PIr#{,RHUG#/G:[~WkUY, #JٷDp"#e'"(H+67hOpenPGP-2.5.5/tests/data/000059-012.ring_trust0000644000000000000000000000000412770565031016563 0ustar0000000000000000hOpenPGP-2.5.5/tests/data/000009-002.sig0000644000000000000000000000023612770565031015146 0ustar0000000000000000OwHw >hm´#pBjH t_%*Y/V;k.Yy7%;z(Pvn*_7JD+&*,il)c Y3n]U}aD|"[N#ahOpenPGP-2.5.5/tests/data/encryption-sym-cast5.gpg0000644000000000000000000000005412770565031020125 0ustar0000000000000000 m]`ڗy2@nf<;ʪF`ODhOpenPGP-2.5.5/tests/data/000057-013.user_id0000644000000000000000000000004612770565031016022 0ustar0000000000000000$Test Key (DSA) hOpenPGP-2.5.5/tests/data/000065-012.ring_trust0000644000000000000000000000000412770565031016560 0ustar0000000000000000hOpenPGP-2.5.5/tests/data/000063-005.secret_key0000644000000000000000000000074412770565031016530 0ustar0000000000000000Ow3!$}9 W̳us<,?#/ `N["cgU[In?60tw&U8j,K|7[Cb|p6.oaV1aS"oՍ)6W.=='%WgDڤDAmiԚr8h>$B/'tMZ ַk(Txg^;?Q#׻HD?HgQW-i|rKHA B,GO>G9ٓfp',6n?טYT/ ?XvT:`p/y){0ϜFw7νyV_3v }yNi[͙\zC?9A$YZ".ܵh``(S -lNwF5B`l m)hOpenPGP-2.5.5/tests/data/000037-002.sig0000644000000000000000000000030012770565031015137 0ustar0000000000000000(Ow! hmAD&5Ԝjmg^y]bnKA;x˲BT[DwQ%2rwEB b;ʴY+;I Sl Xr Ju#ʶK&Λ_o7HBߙAzHkWp`4dl LJ"`H.lۏ'O4]4,X3܉O'q)u]hhHi'KI>1/L,ڀT R6Z7VA,,&|yrXh,@@D:7k=0sD2އFcOq~8gU;[U 4AT}G J6>?9by$(A\vծ:Qe`0*(hOpenPGP-2.5.5/tests/data/000022-002.sig0000644000000000000000000000027212770565031015141 0ustar0000000000000000OwH4 NowMy/]GYjZU8{Sc!Q'VJ""[zT|ĽX]`qdD+Ւ !BwR'+iDm@ (ǘQصf.^3mw8P*}(Qwrdx')mqVP2g wa mG >\$B6C;i^4Rgׁ`A0ʭerT$fJ{y!TM{2XIסtWaʞ+hOpenPGP-2.5.5/tests/data/000014-002.sig0000644000000000000000000000030312770565031015135 0ustar0000000000000000Ow$  π No9R \R^mNʖlysQ%x=ӿbG"lf!%F*w͎gL#!^_ql5qWe/< 0k)sL34ʺmEy$éH#TP.f\w=j4akhOpenPGP-2.5.5/tests/data/000050-012.ring_trust0000644000000000000000000000000412770565031016552 0ustar0000000000000000hOpenPGP-2.5.5/tests/data/000035-006.public_key0000644000000000000000000000021712770565031016514 0ustar0000000000000000Ow!ž%Jo_-0=!t֤70#M\d&KnHyI Qm PG;RLjF!"N$9t98wvW"I%/̈LNСz Ny hOpenPGP-2.5.5/tests/data/000073-017.attribute0000644000000000000000000000334112770565031016376 0ustar0000000000000000JFIFHHC  !"$"$C_"3!1"A2QVa#3Tq-!1AQa"2qBR ?}{H5Un5ˊ[]RB`JJ֤ RauvǏ"S''_xerqJP>;n@%̓fZ~qᏦ8ۋjxUB*__N~v׏qk#ĸ*:` `†?'FJt)n:StƢ5Nllj::^61 6NB |]\Idg=TD@VTDŽ?S֤~O?Z{tf¢uU9uRąCH 9A̭ă_]N)0Tuڞ\_Z|Q_O>t|Tp7 ۏq@ L_mMQCQb_$$((`_Up Taohqe3d"kH& LVO"=7*R(q7JJ!q{yE+"1Rf#ĥK JE@Mԑs:\>;QZېs 6= 28`zޭXRxY;w$$-Lş6KITAQFʧ5=4 (6{ e]`"YmXqu4rj2\YFJB tB6ꞡjrTit0BUtsȹ~;v;^qRQ5->o!IH! M4vn f"d\\SfJB/S/$=RA~ܲfiuErYtw!@ ˂>NU{pVQUee R%7Zl1㟞*liuovo|c{["*QrߓC@1'ZA~mf˶<'pL؋p$Hh* %@$ň#j۲UD6ֶ$$n4hګ VTs@39yF5YN!Ч\[FuqtVorF~Q1LhS.ڊMqt ?sFoUS$3tupѧSȆE- 6ZĤ8LzjQ,_B]BIQDs4hMLOs3>d3kpS(?71<\S~8ԾNKTw@āv-NcP'S ̑][`T \ƦKOҢTT\((*$H!FXm'2` G)&cW4aKMqlE3ٲ( uАQL\Jo_~ +­Dx:sTj_hOpenPGP-2.5.5/tests/data/000016-006.public_key0000644000000000000000000000226112770565031016514 0ustar0000000000000000Ow m] yayT*p}GLE!SH)䃉4ŷQ,lŖF!b 4ދj;R  4<ްoz})Q6\R2y俓ܣ%}U|n;[ m @t9N\ߊW 4d*\ #KP E6)R߶l#0ӚBD`^.{{m#}gGV+ 6!b7Fa'Y J-`L4cWM9[E}U+0'3/HKfxpΞ{E*DQ:j oB&mK&_ S2B_"#0NEuFrV5m`sm렖}X4/H R-;548[,_zk\6"WLR ׁ*PieK6d*e5ͰF2HƩm&ވ0MO3e*5<*hp;gv-SIJZ8xRaZܗQDY,css9AO5 `]BQayl9J r t7sKamK . eDH Dqœ;B=zDky[dwz-ůnga5uTjgat̑LL]hOpenPGP-2.5.5/tests/data/encryption-sym-camellia192.gpg0000644000000000000000000000011712770565031021111 0ustar0000000000000000   fS `>j1ZHW{1ҾĽFA$r2q l1+GSCY0t 3Fwi:hOpenPGP-2.5.5/tests/data/encryption-sym-cast5-s2k0.gpg0000644000000000000000000000004312770565031020700 0ustar0000000000000000䞴;K<֭E'hOpenPGP-2.5.5/tests/data/encryption-sym-blowfish-s2k0.gpg0000644000000000000000000000005412770565031021500 0ustar0000000000000000$ćEe(U@3jl0mUp phOpenPGP-2.5.5/tests/data/000049-002.sig0000644000000000000000000000033412770565031015151 0ustar0000000000000000(Ow$ π   No=8 \-97Ed;|̙j%`9^a M~U3pѰuhxᶱ[WkSfB)C3 %C ]h,x-fɗI Q]-liuCa$`ml5e1ΥnhOpenPGP-2.5.5/tests/data/6F87040E.pubkey0000644000000000000000000000125312770565031015617 0ustar0000000000000000Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~(Ow$ π   No=8 \-97Ed;|̙j%`9^a M~U3pѰuhxᶱ[WkSfB)C3 %C ]h,x-fɗI Q]-liuCa$`ml5e1ΥnOwHw >hm´#pBjH t_%*Y/V;k.Yy7%;z(Pvn*_7JD+&*,il)c Y3n]U}aD|"[N#a^OwI5 ^#A2bQ>&P{k-aعl nqaѡ0!Y꾹gkv0HjhOpenPGP-2.5.5/tests/data/msg1.asc0000644000000000000000000000025112770565031014747 0ustar0000000000000000-----BEGIN PGP MESSAGE----- Version: OpenPrivacy 0.99 yDgBO22WxBHv7O8X7O/jygAEzol56iUKiXmV+XmpCtmpqQUKiQrFqclFqUDBovzS vBSFjNSiVHsuAA== =njUN -----END PGP MESSAGE----- hOpenPGP-2.5.5/tests/data/prikey-rev.gpg0000644000000000000000000000057012770565031016210 0ustar0000000000000000Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~z6ŭ0_C$:8RA58TMGN9hOpenPGP-2.5.5/tests/data/000051-007.secret_subkey0000644000000000000000000000114312770565031017233 0ustar0000000000000000`Ow$ພo# \X" l9Nv`x]pBA hzSX[s'S4~#{T V`;~ 'o]3U.-Psڮ>S}%Nbx%9mˣ^l":C*=emGM`A]Q$VamQX&nySRw!+ˑk^IW!4HX`5yKh4nQ?ՙthSM]$f/\Ts,FJwJ^Il2k0!xU;/̶̪a}>F7AL}ΚtP6n|iqq«VWzjkv-iV $=d/B9KʋTp%a *' : r$4* @OM2Whu}Va v< YG="ӱRf Q/swn 7 ưUl4ߕ,jLv)DÎyhl4YhOpenPGP-2.5.5/tests/data/000007-002.sig0000644000000000000000000000033412770565031015143 0ustar0000000000000000(Ow$ π   No=8 \-97Ed;|̙j%`9^a M~U3pѰuhxᶱ[WkSfB)C3 %C ]h,x-fɗI Q]-liuCa$`ml5e1ΥnhOpenPGP-2.5.5/tests/data/000012-012.ring_trust0000644000000000000000000000000412770565031016550 0ustar0000000000000000hOpenPGP-2.5.5/tests/data/000075-012.ring_trust0000644000000000000000000000000412770565031016561 0ustar0000000000000000hOpenPGP-2.5.5/tests/data/000021-012.ring_trust0000644000000000000000000000000412770565031016550 0ustar0000000000000000hOpenPGP-2.5.5/tests/data/000052-002.sig0000644000000000000000000000030312770565031015137 0ustar0000000000000000Ow$  π No9R \R^mNʖlysQ%x=ӿbG"lf!%F*w͎gL#!^_ql5qWe/< 0k)sL34ʺmEy$éH#TP.f\w=j4akhOpenPGP-2.5.5/tests/data/000042-002.sig0000644000000000000000000000030012770565031015133 0ustar0000000000000000(OwL hmdi!Սyǜ+d1A(}=M4 BvSu [TXq, %f8o; m *At'|Fg0]%]%yޡ UVC~d:+5 uhOpenPGP-2.5.5/tests/data/000062-012.ring_trust0000644000000000000000000000000412770565031016555 0ustar0000000000000000hOpenPGP-2.5.5/tests/data/uncompressed-ops-dsa-sha384.txt.gpg0000644000000000000000000000022612770565031022012 0ustar0000000000000000  w2Ϙc=buncompressed-ops.txtO Uncompressed one-pass sig message. F O w2Ϙc*'iOYY' Kf/oXmhOpenPGP-2.5.5/tests/data/000005-002.sig0000644000000000000000000000016112770565031015137 0ustar0000000000000000o0OwIDtesting revsig ^#A2b>+ #1ѽ^Qmz6!$W+6+TQeL[3Gl/hOpenPGP-2.5.5/tests/data/000002-013.user_id0000644000000000000000000000004612770565031016010 0ustar0000000000000000$Test Key (RSA) hOpenPGP-2.5.5/tests/data/000045-002.sig0000644000000000000000000000024112770565031015142 0ustar0000000000000000 OwJ >hm߰yb)Qx0+G7ld:`c/ ~ڶTG̔Cr=0n~83aQ_zIN\|Sa8e`dqr#dW>}P끩hOpenPGP-2.5.5/tests/data/v3.key0000644000000000000000000000021712770565031014454 0ustar00000000000000001s񳠅.Ƿ3>&$^8 ](-1fg. Xv:PǽHG|ގq mNPBjCDD)ۮ|[Ӏu #Qu*mŀ&hOpenPGP-2.5.5/tests/data/encryption-sym-camellia256.gpg0000644000000000000000000000011712770565031021112 0ustar0000000000000000   ek?`>_uO:I5HTor%Dy9K\ao)v%Gv{ ahOpenPGP-2.5.5/tests/data/000023-012.ring_trust0000644000000000000000000000000412770565031016552 0ustar0000000000000000hOpenPGP-2.5.5/tests/data/gnu-dummy-s2k-101-secret-key.gpg0000644000000000000000000000043012770565031021075 0ustar0000000000000000T6@^'Wd(\!M:W HE|P8h+؈m]OchLcͻ)~{B"Ы*,eY2R U9\2H}b$:WFZeA[ h6-x*;k Au.޼ІUyyGCx@IsmᗙܢQ1>=Ȳ}`!~[Q@B4Ȏ-`)0rVbUfѨeGNUhOpenPGP-2.5.5/tests/data/000067-002.sig0000644000000000000000000000015212770565031015147 0ustar0000000000000000h(Ow    w2ϘczHm5YDBT!.ADs48$Q9H>jhOpenPGP-2.5.5/tests/data/encryption-sym-3des-s2k0.gpg0000644000000000000000000000005412770565031020521 0ustar0000000000000000$3˕,A^a[#cGI\hOpenPGP-2.5.5/tests/data/000055-002.sig0000644000000000000000000000017312770565031015147 0ustar0000000000000000y!OwJ  /Z\þw2Ϙc ^#A2b& bta=0)Ҷ?9pɼRORͤ[L]ڳ,}pcï-`+LѰhOpenPGP-2.5.5/tests/data/encryption-sym-cast5-mdc.gpg0000644000000000000000000000011412770565031020663 0ustar0000000000000000 HwԒX`;enu-7P :dDYoB%L!MX5!J_{LȷhOpenPGP-2.5.5/tests/data/000008-012.ring_trust0000644000000000000000000000000412770565031016555 0ustar0000000000000000hOpenPGP-2.5.5/tests/data/000015-012.ring_trust0000644000000000000000000000000412770565031016553 0ustar0000000000000000hOpenPGP-2.5.5/tests/data/encryption-sym-aes128.gpg0000644000000000000000000000011312770565031020105 0ustar0000000000000000 #Na&P{k-aعl nqaѡ0!Y꾹gkv0HjhOpenPGP-2.5.5/tests/data/simple.seckey0000644000000000000000000000154412770565031016114 0ustar0000000000000000_Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~mW3W%O:`X~8%d\ٺ§'$Test Key (RSA) (Ow$ π   No=8 \-97Ed;|̙j%`9^a M~U3pѰuhxᶱ[WkSfB)C3 %C ]h,x-fɗI Q]-liuCa$`ml5e1ΥnhOpenPGP-2.5.5/tests/data/symmetric-password.txt0000644000000000000000000000000612770565031020023 0ustar0000000000000000abc123hOpenPGP-2.5.5/tests/data/subkey-rev.gpg0000644000000000000000000000104312770565031016203 0ustar0000000000000000Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~S}%Nbx%9mˣ^l":C*=(PhOpenPGP testing NoKT‚͘^Xw+Zoݙ6ݕO%^m(9)7`Wzh2yf.* g\/[L|[hrfKiA&p` ^G+hOpenPGP-2.5.5/tests/data/000041-017.attribute0000644000000000000000000000334112770565031016371 0ustar0000000000000000JFIFHHC  !"$"$C_"3!1"A2QVa#3Tq-!1AQa"2qBR ?}{H5Un5ˊ[]RB`JJ֤ RauvǏ"S''_xerqJP>;n@%̓fZ~qᏦ8ۋjxUB*__N~v׏qk#ĸ*:` `†?'FJt)n:StƢ5Nllj::^61 6NB |]\Idg=TD@VTDŽ?S֤~O?Z{tf¢uU9uRąCH 9A̭ă_]N)0Tuڞ\_Z|Q_O>t|Tp7 ۏq@ L_mMQCQb_$$((`_Up Taohqe3d"kH& LVO"=7*R(q7JJ!q{yE+"1Rf#ĥK JE@Mԑs:\>;QZېs 6= 28`zޭXRxY;w$$-Lş6KITAQFʧ5=4 (6{ e]`"YmXqu4rj2\YFJB tB6ꞡjrTit0BUtsȹ~;v;^qRQ5->o!IH! M4vn f"d\\SfJB/S/$=RA~ܲfiuErYtw!@ ˂>NU{pVQUee R%7Zl1㟞*liuovo|c{["*QrߓC@1'ZA~mf˶<'pL؋p$Hh* %@$ň#j۲UD6ֶ$$n4hګ VTs@39yF5YN!Ч\[FuqtVorF~Q1LhS.ڊMqt ?sFoUS$3tupѧSȆE- 6ZĤ8LzjQ,_B]BIQDs4hMLOs3>d3kpS(?71<\S~8ԾNKTw@āv-NcP'S ̑][`T \ƦKOҢTT\((*$H!FXm'2` G)&cW4aKMqlE3ٲ( uАQL\Jo_~ +­Dx:sTj_hOpenPGP-2.5.5/tests/data/000072-012.ring_trust0000644000000000000000000000000412770565031016556 0ustar0000000000000000hOpenPGP-2.5.5/tests/data/encryption-sym-cast5-mdc-s2k0.gpg0000644000000000000000000000010312770565031021436 0ustar0000000000000000;7DmsΈɘXHAF O2O*QBtrᄠxF:`]hOpenPGP-2.5.5/tests/data/encryption-sym-camellia128-s2k0.gpg0000644000000000000000000000010612770565031021663 0ustar0000000000000000 >E)%NSRA9%pʤ%J_bB\z3߃'ͧ-`Dzp|,ҳ%؂hOpenPGP-2.5.5/tests/data/000034-012.ring_trust0000644000000000000000000000000412770565031016554 0ustar0000000000000000hOpenPGP-2.5.5/tests/data/000046-012.ring_trust0000644000000000000000000000000412770565031016557 0ustar0000000000000000hOpenPGP-2.5.5/tests/data/000044-014.public_subkey0000644000000000000000000000042012770565031017221 0ustar0000000000000000 OwJGgC!_ZGk렂=KsxH-!*nLvXFw|#W,l;qfO^>3(@ 8꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~"w)So%cܵw @p m63"ّ 9f32o;e`S(wˢnù(Ow$ π   No=8 \-97Ed;|̙j%`9^a M~U3pѰuhxᶱ[WkSfB)C3 %C ]h,x-fɗI Q]-liuCa$`ml5e1ΥnhOpenPGP-2.5.5/tests/data/compressedsig.gpg0000644000000000000000000000050412770565031016757 0ustar0000000000000000xv>5IE%9z%%! @PPPZ_[PKSI&($&g(gddJ R32sRK2:v00212e,\?oMbbJ?+&=K査ŭw=ySOUj9gCVb뷭Z2)vnH ޥ8M 3Ϛ՞J?:Z8]"#ӧ>]H1uMWo wQ?uug~CeJnbhOpenPGP-2.5.5/tests/data/000024-014.public_subkey0000644000000000000000000000114012770565031017217 0ustar0000000000000000]Ow @7la Ua?a`K䠳q{Ü@H2{'2i0  D+=6h8k]NmY\}]X+%T|T̠ =%VubD;^`钘/hĢfFj㬒vA$_,G]aNz5ͽ w?

(ǘQصf.^3mw8P*}(Qwrdx')mqVP2g wa mG >\$B6C;i^4RhOpenPGP-2.5.5/tests/data/aes256-sha512.seckey0000644000000000000000000000156012770565031016627 0ustar0000000000000000gOw$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~;ʹ jaVGvKޤa4CL0TyʝeL Tv1ꨃ`lumQo6ĈI~$iPsαAtz$1k:OQ-b  *YJ М1]fMȻ`r~ ڜd68џղKc77 gGݬ(s,Y YrO-FQ cE)RYgAڌhy8ܞ4Q!,t؝6(de(A=z(M\ tKjTtS i;h FSeZT5 . o6j(JpЍ }Z8])zyGsc8b'}Lc jq_X gW>(ڃ$Test Key (RSA) (Ow$ π   No=8 \-97Ed;|̙j%`9^a M~U3pѰuhxᶱ[WkSfB)C3 %C ]h,x-fɗI Q]-liuCa$`ml5e1ΥnhOpenPGP-2.5.5/tests/data/encryption-sym-3des.gpg0000644000000000000000000000006512770565031017746 0ustar0000000000000000 H-Z%`$ל{; }:rv꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~o0OwITesting revsig ^#A2biBV#WY#-B>,[> $x yfu 38#o0OwIDtesting revsig ^#A2b>+ #1ѽ^Qmz6!$W+6+TQeL[3Gl/(Ow$ π   No=8 \-97Ed;|̙j%`9^a M~U3pѰuhxᶱ[WkSfB)C3 %C ]h,x-fɗI Q]-liuCa$`ml5e1ΥnOwHw >hm´#pBjH t_%*Y/V;k.Yy7%;z(Pvn*_7JD+&*,il)c Y3n]U}aD|"[N#a^OwI5 ^#A2bQ>&P{k-aعl nqaѡ0!Y꾹gkv0HjOw$ພo# \X" l9Nv`x]pBA hzSX[s'S4~#{T V`;~ 'o]3U.-Psڮ>S}%Nbx%9mˣ^l":C*=Ow$  π No9R \R^mNʖlysQ%x=ӿbG"lf!%F*w͎gL#!^_ql5qWe/< 0k)sL34ʺmEy$éH#TP.f\w=j4akOw m] yayT*p}GLE!SH)䃉4ŷQ,lŖF!b 4ދj;R  4<ްoz})Q6\R2y俓ܣ%}U|n;[ m @t9N\ߊW 4d*\ #KP E6)R߶l#0ӚBD`^.{{m#}gGV+ 6!b7Fa'Y J-`L4cWM9[E}U+0'3/HKfxpΞ{E*DQ:j oB&mK&_ S2B_"#0NEuFrV5m`sm렖}X4/H R-;548[,_zk\6"WLR ׁ*PieK6d*e5ͰF2HƩm&ވ0MO3e*5<*hp;gv-SIJZ8xRaZܗQDY,css9AO5 `]BQayl9J r t7sKamK . eDH Dqœ;B=zDky[dwz-ůnga5uTjgat̑LL]y!OwJ  /Z\þw2Ϙc ^#A2b& bta=0)Ҷ?9pɼRORͤ[L]ڳ,}pcï-`+LѰ$Test Key (DSA) (Ow    ^#A2bܯgi\Q$`;! 873?wNj*rK%% Aý~uOwH4 NowMy/]GYjZU8{Sc!Q'VJ""[zT|ĽX]`qdD+Ւ !BwR'+iDm@ (ǘQصf.^3mw8P*}(Qwrdx')mqVP2g wa mG >\$B6C;i^4RgOw   ^#A2b)$[OX`J`6\I[o?u<wGkt˨\A]gM^"߶/HOw3!$}9 W̳us<,?#/ `N["cgU[In?60tw&U8j,K|7[Cb|p6.oaV1aS"oՍ)6W.=='%WgDڤDAmiԚr8h>$B/'tMZ ַk(Txg^;?Q#׻HD?HgQW-i|rKHA B,GO>G9ٓfp',6n?טYT/ ?XvT:`p/y){0ϜFw7νyV_3v }yNi[͙\zC?9A$Ya!OwJ y3EY >hm w2ϘcnA_-]joyp&e2r ؠXŰ+Test Key (DSA sign-only) B   OwItesting@notation w2Ϙcꆸ-&iDš$)`Sg<°^OwHT ^#A2b0$LM ɑ(;濂X/t+2f]9"W=O!}co*(:UOw!ž%Jo_-0=!t֤70#M\d&KnHyI Qm PG;RLjF!"N$9t98wvW"I%/̈LNСz Ny .Test Key (RSA sign-only) (Ow! hmAD&5Ԝjmg^y]bnKA;x˲BT[DwQ%2rwEB b;ʴY;n@%̓fZ~qᏦ8ۋjxUB*__N~v׏qk#ĸ*:` `†?'FJt)n:StƢ5Nllj::^61 6NB |]\Idg=TD@VTDŽ?S֤~O?Z{tf¢uU9uRąCH 9A̭ă_]N)0Tuڞ\_Z|Q_O>t|Tp7 ۏq@ L_mMQCQb_$$((`_Up Taohqe3d"kH& LVO"=7*R(q7JJ!q{yE+"1Rf#ĥK JE@Mԑs:\>;QZېs 6= 28`zޭXRxY;w$$-Lş6KITAQFʧ5=4 (6{ e]`"YmXqu4rj2\YFJB tB6ꞡjrTit0BUtsȹ~;v;^qRQ5->o!IH! M4vn f"d\\SfJB/S/$=RA~ܲfiuErYtw!@ ˂>NU{pVQUee R%7Zl1㟞*liuovo|c{["*QrߓC@1'ZA~mf˶<'pL؋p$Hh* %@$ň#j۲UD6ֶ$$n4hګ VTs@39yF5YN!Ч\[FuqtVorF~Q1LhS.ڊMqt ?sFoUS$3tupѧSȆE- 6ZĤ8LzjQ,_B]BIQDs4hMLOs3>d3kpS(?71<\S~8ԾNKTw@āv-NcP'S ̑][`T \ƦKOҢTT\((*$H!FXm'2` G)&cW4aKMqlE3ٲ( uАQL\Jo_~ +­Dx:sTj_و(OwL hmdi!Սyǜ+d1A(}=M4 BvSu [TXq, %f8o; m *At'|Fg0]%]%yޡ UVC~d:+5 u OwJGgC!_ZGk렂=KsxH-!*nLvXFw|#W,l;qfO^>3(@ 8hm߰yb)Qx0+G7ld:`c/ ~ڶTG̔Cr=0n~83aQ_zIN\|Sa8e`dqr#dW>}P끩hOpenPGP-2.5.5/tests/data/000071-002.sig0000644000000000000000000000030012770565031015135 0ustar0000000000000000(Ow! hmAD&5Ԝjmg^y]bnKA;x˲BT[DwQ%2rwEB b;ʴYhOpenPGP-2.5.5/tests/data/000077-002.sig0000644000000000000000000000024112770565031015147 0ustar0000000000000000 OwJ >hm߰yb)Qx0+G7ld:`c/ ~ڶTG̔Cr=0n~83aQ_zIN\|Sa8e`dqr#dW>}P끩hOpenPGP-2.5.5/tests/data/encryption-sym-3des-mdc-s2k0.gpg0000644000000000000000000000010312770565031021255 0ustar0000000000000000;zc^ȳEƌE%A^/JS EG~٬yn>ۼv;hOpenPGP-2.5.5/tests/data/000031-002.sig0000644000000000000000000000020412770565031015134 0ustar0000000000000000B   OwItesting@notation w2Ϙcꆸ-&iDš$)`Sg<hOpenPGP-2.5.5/tests/data/000006-012.ring_trust0000644000000000000000000000000412770565031016553 0ustar0000000000000000hOpenPGP-2.5.5/tests/data/000070-013.user_id0000644000000000000000000000006012770565031016011 0ustar0000000000000000.Test Key (RSA sign-only) hOpenPGP-2.5.5/tests/data/000068-012.ring_trust0000644000000000000000000000000412770565031016563 0ustar0000000000000000hOpenPGP-2.5.5/tests/data/000004-012.ring_trust0000644000000000000000000000000412770565031016551 0ustar0000000000000000hOpenPGP-2.5.5/tests/data/000054-005.secret_key0000644000000000000000000000237312770565031016530 0ustar0000000000000000Ow m] yayT*p}GLE!SH)䃉4ŷQ,lŖF!b 4ދj;R  4<ްoz})Q6\R2y俓ܣ%}U|n;[ m @t9N\ߊW 4d*\ #KP E6)R߶l#0ӚBD`^.{{m#}gGV+ 6!b7Fa'Y J-`L4cWM9[E}U+0'3/HKfxpΞ{E*DQ:j oB&mK&_ S2B_"#0NEuFrV5m`sm렖}X4/H R-;548[,_zk\6"WLR ׁ*PieK6d*e5ͰF2HƩm&ވ0MO3e*5<*hp;gv-SIJZ8xRaZܗQDY,css9AO5 `]BQayl9J r t7sKamK . eDH Dqœ;B=zDky[dwz-ůnga5uTjgat̑LL]gׁ`vE%nOqaWqrn!`i}lw!B&{b]+GQ hOpenPGP-2.5.5/tests/data/000032-012.ring_trust0000644000000000000000000000000412770565031016552 0ustar0000000000000000hOpenPGP-2.5.5/tests/data/encryption-sym-twofish.gpg0000644000000000000000000000012412770565031020567 0ustar0000000000000000  ӻ"`C_–'3:=8HlY*-I4y%ss]!̾+q?3hOpenPGP-2.5.5/tests/data/encryption-sym-blowfish-mdc-s2k0.gpg0000644000000000000000000000010312770565031022234 0ustar0000000000000000;99ayO%d.E M˳D='D!3hOpenPGP-2.5.5/tests/data/000074-002.sig0000644000000000000000000000030012770565031015140 0ustar0000000000000000(OwL hmdi!Սyǜ+d1A(}=M4 BvSu [TXq, %f8o; m *At'|Fg0]%]%yޡ UVC~d:+5 uhOpenPGP-2.5.5/tests/data/secring.gpg0000644000000000000000000002070412770565031015546 0ustar0000000000000000_Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~mW3W%O:`X~8%d\ٺ§'$Test Key (RSA) (Ow$ π   No=8 \-97Ed;|̙j%`9^a M~U3pѰuhxᶱ[WkSfB)C3 %C ]h,x-fɗI Q]-liuCa$`ml5e1Υn`Ow$ພo# \X" l9Nv`x]pBA hzSX[s'S4~#{T V`;~ 'o]3U.-Psڮ>S}%Nbx%9mˣ^l":C*=emGM`A]Q$VamQX&nySRw!+ˑk^IW!4HX`5yKh4nQ?ՙthSM]$f/\Ts,FJwJ^Il2k0!xU;/̶̪a}>F7AL}ΚtP6n|iqq«VWzjkv-iV $=d/B9KʋTp%a *' : r$4* @OM2Whu}Va v< YG="ӱRf Q/swn 7 ưUl4ߕ,jLv)DÎyhl4YOw$  π No9R \R^mNʖlysQ%x=ӿbG"lf!%F*w͎gL#!^_ql5qWe/< 0k)sL34ʺmEy$éH#TP.f\w=j4akOw m] yayT*p}GLE!SH)䃉4ŷQ,lŖF!b 4ދj;R  4<ްoz})Q6\R2y俓ܣ%}U|n;[ m @t9N\ߊW 4d*\ #KP E6)R߶l#0ӚBD`^.{{m#}gGV+ 6!b7Fa'Y J-`L4cWM9[E}U+0'3/HKfxpΞ{E*DQ:j oB&mK&_ S2B_"#0NEuFrV5m`sm렖}X4/H R-;548[,_zk\6"WLR ׁ*PieK6d*e5ͰF2HƩm&ވ0MO3e*5<*hp;gv-SIJZ8xRaZܗQDY,css9AO5 `]BQayl9J r t7sKamK . eDH Dqœ;B=zDky[dwz-ůnga5uTjgat̑LL]gׁ`vE%nOqaWqrn!`i}lw!B&{b]+GQ y!OwJ  /Z\þw2Ϙc ^#A2b& bta=0)Ҷ?9pɼRORͤ[L]ڳ,}pcï-`+LѰ$Test Key (DSA) (Ow    ^#A2bܯgi\Q$`;! 873?wNj*rK%% Aý~uOw @7la Ua?a`K䠳q{Ü@H2{'2i0  D+=6h8k]NmY\}]X+%T|T̠ =%VubD;^`钘/hĢfFj㬒vA$_,G]aNz5ͽ w?

(ǘQصf.^3mw8P*}(Qwrdx')mqVP2g wa mG >\$B6C;i^4Rgׁ`A0ʭerT$fJ{y!TM{2XIסtWaʞ+fOw   ^#A2b)$ ::y!cƋI3b;@{S?bSZV9ިPMOw3!$}9 W̳us<,?#/ `N["cgU[In?60tw&U8j,K|7[Cb|p6.oaV1aS"oՍ)6W.=='%WgDڤDAmiԚr8h>$B/'tMZ ַk(Txg^;?Q#׻HD?HgQW-i|rKHA B,GO>G9ٓfp',6n?טYT/ ?XvT:`p/y){0ϜFw7νyV_3v }yNi[͙\zC?9A$YZ".ܵh``(S -lNwF5B`l m)a!OwJ y3EY >hm w2ϘcnA_-]joyp&e2r ؠXŰ+Test Key (DSA sign-only) h(Ow    w2ϘczHm5YDBT!.ADs48$Q9H>jOw!ž%Jo_-0=!t֤70#M\d&KnHyI Qm PG;RLjF!"N$9t98wvW"I%/̈LNСz Ny  WA/`++oXbN,9KpPwR,l&p<ǻ\n>+;I Sl Xr Ju#ʶK&Λ_o7HBߙAzHkWp`4dl LJ"`H.lۏ'O4]4,X3܉O'q)u]hhHi'KI>1/L,ڀT R6Z7VA,,&|yrXh,@@D:7k=0sD2އFcOq~8gU;[U 4AT}G J6>?9by$(A\vծ:Qe`0*(ƴ.Test Key (RSA sign-only) (Ow! hmAD&5Ԝjmg^y]bnKA;x˲BT[DwQ%2rwEB b;ʴY;n@%̓fZ~qᏦ8ۋjxUB*__N~v׏qk#ĸ*:` `†?'FJt)n:StƢ5Nllj::^61 6NB |]\Idg=TD@VTDŽ?S֤~O?Z{tf¢uU9uRąCH 9A̭ă_]N)0Tuڞ\_Z|Q_O>t|Tp7 ۏq@ L_mMQCQb_$$((`_Up Taohqe3d"kH& LVO"=7*R(q7JJ!q{yE+"1Rf#ĥK JE@Mԑs:\>;QZېs 6= 28`zޭXRxY;w$$-Lş6KITAQFʧ5=4 (6{ e]`"YmXqu4rj2\YFJB tB6ꞡjrTit0BUtsȹ~;v;^qRQ5->o!IH! M4vn f"d\\SfJB/S/$=RA~ܲfiuErYtw!@ ˂>NU{pVQUee R%7Zl1㟞*liuovo|c{["*QrߓC@1'ZA~mf˶<'pL؋p$Hh* %@$ň#j۲UD6ֶ$$n4hګ VTs@39yF5YN!Ч\[FuqtVorF~Q1LhS.ڊMqt ?sFoUS$3tupѧSȆE- 6ZĤ8LzjQ,_B]BIQDs4hMLOs3>d3kpS(?71<\S~8ԾNKTw@āv-NcP'S ̑][`T \ƦKOҢTT\((*$H!FXm'2` G)&cW4aKMqlE3ٲ( uАQL\Jo_~ +­Dx:sTj_و(OwL hmdi!Սyǜ+d1A(}=M4 BvSu [TXq, %f8o; m *At'|Fg0]%]%yޡ UVC~d:+5 uOwJGgC!_ZGk렂=KsxH-!*nLvXFw|#W,l;qfO^>3(@ 8A ̇کv4'gb2R!e.}񀙱ltM?E-]5ds1\Z7_MեZC)'MB4gȇIİLJ3JX< |4NW~AG}5[BaCrj/"͒u6 t=pjZ}Eh2:ZN<NcIVPDaP6Sd ׶P(sQ+'Jy!ڿ`{? bh5׽ OaD\2Vޖtr#'dWB_'<{ O,L , hd(&%/{3F){٬m5_YStuCCb̐ OwJ >hm߰yb)Qx0+G7ld:`c/ ~ڶTG̔Cr=0n~83aQ_zIN\|Sa8e`dqr#dW>}P끩hOpenPGP-2.5.5/tests/data/anibal-ed25519.gpg0000644000000000000000000000060512770565031016334 0ustar00000000000000003Uſ +G@ޒnT0_ Yx́h7`+Anibal Monsalve Salazar y !Uſ    )@s^ =?fNK"q "!؆Mt0kA!&I-9lDx#sfc{+Anibal Monsalve Salazar y !Uſ    )@s^ Ny/}j/_lOiJ?(EE"V-;:qcbUhOpenPGP-2.5.5/tests/data/000026-012.ring_trust0000644000000000000000000000000412770565031016555 0ustar0000000000000000hOpenPGP-2.5.5/tests/data/000048-013.user_id0000644000000000000000000000004612770565031016022 0ustar0000000000000000$Test Key (RSA) hOpenPGP-2.5.5/tests/data/compressedsig-zlib.gpg0000644000000000000000000000050212770565031017713 0ustar0000000000000000xxv>5IU9Iz%%dd+Qz~f^BIBRBqfz^jBb^Bnr~nAQjq1P,3$1O!?'E7-(7D 19;D<$$SW\ T^ձ d%=1,/D]=ûu!n;,TlﯞC+Z4]кX]y/52zbQC^/XAmS$cj}ȏ%=ل)Բ(~`Rͧ~@NTnNhm w2ϘcnA_-]joyp&e2r ؠXhOpenPGP-2.5.5/tests/data/pki-password.txt0000644000000000000000000000000412770565031016570 0ustar0000000000000000testhOpenPGP-2.5.5/tests/data/encryption-sym-aes192.gpg0000644000000000000000000000012412770565031020110 0ustar0000000000000000 R`C;:̋1[5{/Y>f2oLx coJrulh{3lhOpenPGP-2.5.5/tests/data/minimized.gpg0000644000000000000000000000065512770565031016104 0ustar0000000000000000Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~(Ow$ π   No=8 \-97Ed;|̙j%`9^a M~U3pѰuhxᶱ[WkSfB)C3 %C ]h,x-fɗI Q]-liuCa$`ml5e1ΥnhOpenPGP-2.5.5/tests/data/000028-002.sig0000644000000000000000000000014312770565031015144 0ustar0000000000000000a!OwJ y3EY >hm w2ϘcnA_-]joyp&e2r ؠXhOpenPGP-2.5.5/tests/data/000039-002.sig0000644000000000000000000000011012770565031015140 0ustar0000000000000000FOwHe w2Ϙc ?aKZhm=buncompressed-ops.txtOz4Uncompressed one-pass sig message. Oz4 >hmu2X;DwHsP|(E\D\h]AIK FSxl o[(,s+g&T KX~.EbQ;Y"8E9Z!`_x?MMhOpenPGP-2.5.5/tests/data/revoked.pubkey0000644000000000000000000000631612770565031016300 0ustar00000000000000008oM!v7w~!~$?p(QH(P5i-9όM|rhٮ @#!slm8  on5<`E2ŏxjd\ޜ'уگ\1$:dQgg!9_H>V nw`7>w C-?$Joڅ ܏ua1*SW/p$Sߥ`d91z4IC GubEּWw}RZWl ƥ|_xN"E,2G?iຆ\aeu\iekyLCVԼf~+IK&iZկ W͇hޢtK J#Jh3+ʼn-tpɁڈ MRQFsuperseded by key 4900 707D DC5C 07F2 DECB 0283 9C31 503C 6D86 6396 ʛ#PqFW `}/f64  y gʹ$Stefano Zacchiroli 0UIWN I don't use the @bononia.it address anymore, and it will bounce anytime soon ʛ#bZ+.c^Ђ(#-Y]_Ϳ1"IYk0$Stefano Zacchiroli _:@   ʛ#eGPG[> S>sUn9o*=$Stefano Zacchiroli c# Gwa/ ʛ#NӝHU![SMNB*3_aO9%Stefano Zacchiroli ` H۾  ʛ#5|,wG^of+ y]Xulv 0+.O(Stefano Zacchiroli ` H  ʛ#} ]1Æ^>jwYSfH%ǭr;7_+蜴,Stefano Zacchiroli (Zack) r02If2+getting rid of the bogus "(Zack)" comment ʛ#l'h C&:3.ԠXD-0Stefano Zacchiroli (Zack) r02If2+getting rid of the bogus "(Zack)" comment ʛ#." &h@S~i@m*+ 8Eg%tI8Pq,\хj7֪; `6zxRHN1$)O7֬pŀE |E,nitLSkJ[|szn(]0-쀖(NރgsOKu8s$=Pi멙E%KMpWϼ.{ꡙdNi;_mik CLrH΄R)qPA6,%x7bf_ i N8 ʛ#eGPG2(>KXy&0p@X[BK0?jJP*LA 7q(qH^jI've switched to a longer subkey for encryption; the ID of the new key is E5B57D13, it is 4096 bit long. ʛ#92 Bs׫8 @~;#_l8||7Om#ݜ H GT鴙Jtf`^7}se"X E RYʨJ3mgW8uOg['mbNbn&ϷN&6ʊs17/eHQqd sz*Tԉ =%Uy@q2ĥz!OI <~]Y vs tҽGK A(zK)4ǖ_\+yPgu(FɊ#HN8 {L& ٥OĤӓ!W6) +-gkD3V~I0&*DX' /ϥecE,F]އJl|F8e{OU\V@OmHb [W9"B#?I!#' u22jh?cWahWd6s <mND 7yS$82]oa$_JsI6ZkrA=͵k8שe#yֆ @nZ)RVy}Wm b;D Ot#͌(m?&2@e1B#~`I4;SCPȚ.=C< {PԷƂ(ڠ2w=nCK&7%F}d"2Hcn%"ӌ30`Shu}?Bc`h*=J]VI H ʛ#Bіl{ר\5ˏ5KNlb 6ųv2ۏIhOpenPGP-2.5.5/tests/data/encryption.gpg0000644000000000000000000000153412770565031016306 0ustar0000000000000000^.$92 ="TRxB`]3gܽ:QGHh9y#o +qWG\{Pj17ƃ@m. ˎrC~9fq8BpC5vV*݌B? ts~FE wέ\Y<:ʙ=X1\Z[7BBb\ W+x bNy<oO=rɐE) îWw;gS$B/'tMZ ַk(Txg^;?Q#׻HD?HgQW-i|rKHA B,GO>G9ٓfp',6n?טYT/ ?XvT:`p/y){0ϜFw7νyV_3v }yNi[͙\zC?9A$YhOpenPGP-2.5.5/tests/data/unencrypted.seckey0000644000000000000000000000150212770565031017155 0ustar00000000000000009Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~%U k"_ٸuȲ}\``ukAIh G@5$Nn8:7qtbBwD}q͏AĤ ppb )_[ pXw yů,7ȅN`Lu$k뺻n_"ύs_h^"|ߴ2R3{ kp$-r@0Z>c$2]s g? _F0{jgD=:N(z^ }'LU. `Ju+gn$*i%9  -ppWL$Ce9PY:өw}pÁ$Test Key (RSA) (Ow$ π   No=8 \-97Ed;|̙j%`9^a M~U3pѰuhxᶱ[WkSfB)C3 %C ]h,x-fɗI Q]-liuCa$`ml5e1ΥnhOpenPGP-2.5.5/tests/data/encryption-sym-aes128-s2k0.gpg0000644000000000000000000000010212770565031020660 0ustar0000000000000000:mޣDVlsAr¦@a$,{K!fi \mχQ hOpenPGP-2.5.5/tests/data/uat.gpg0000644000000000000000000000130712770565031014703 0ustar0000000000000000Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK  ?و(Py π   No~v?l̨\&]^hts|pkE)ENR&ie [ƑP<&|(PѡGZYe@L'U:-cPHį뺑0eU2G_%--by9;s-zlhOpenPGP-2.5.5/tests/data/000003-002.sig0000644000000000000000000000016112770565031015135 0ustar0000000000000000o0OwITesting revsig ^#A2biBV#WY#-B>,[> $x yfu 38#hOpenPGP-2.5.5/tests/data/000066-013.user_id0000644000000000000000000000005512770565031016022 0ustar0000000000000000+Test Key (DSA sign-only) hOpenPGP-2.5.5/tests/data/encryption-sym-blowfish.gpg0000644000000000000000000000006512770565031020725 0ustar0000000000000000 3wR+`$.X(ē"+}Q跗mק:Mw_hOpenPGP-2.5.5/tests/data/encryption-sym-3des-mdc.gpg0000644000000000000000000000011412770565031020502 0ustar0000000000000000 R_(`; =]o7FJ2-O">_1"Lg <ݸ )"e0 _!ݻ CNx)hOpenPGP-2.5.5/tests/data/uncompressed-ops-dsa.gpg0000644000000000000000000000022612770565031020164 0ustar0000000000000000 w2Ϙc=buncompressed-ops.txtOz4}Uncompressed one-pass sig message. FOz4} w2Ϙc$hk-A^jYΔ0 CompressionAlgorithm -> Conduit Pkt m Pkt conduitCompress algo = CL.consume >>= \ps -> yield (compressPkts algo ps) conduitDecompress :: MonadThrow m => Conduit Pkt m Pkt conduitDecompress = CL.concatMap decompressPkt hOpenPGP-2.5.5/Data/Conduit/OpenPGP/Keyring.hs0000644000000000000000000000315112770565031017031 0ustar0000000000000000-- Keyring.hs: OpenPGP (RFC4880) transferable keys parsing -- Copyright © 2012-2016 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 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.Ontology (isTrustPkt) import Data.Conduit.OpenPGP.Keyring.Instances () data Phase = MainKey | Revs | Uids | UAts | Subs | SkippingBroken deriving (Eq, Ord, Show) conduitToTKs :: Monad m => Conduit Pkt m TK conduitToTKs = conduitToTKs' True conduitToTKsDropping :: Monad m => Conduit Pkt m TK conduitToTKsDropping = conduitToTKs' False fakecmAccum :: Monad m => (accum -> (accum, [b])) -> (a -> accum -> (accum, [b])) -> accum -> Conduit a m b fakecmAccum finalizer f = loop where 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' conduitToTKs' :: Monad m => Bool -> Conduit Pkt m TK 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 => Sink TK m Keyring sinkKeyringMap = CL.fold (flip insert) empty hOpenPGP-2.5.5/Data/Conduit/OpenPGP/Verify.hs0000644000000000000000000000276012770565031016672 0ustar0000000000000000-- Verify.hs: OpenPGP (RFC4880) signature verification -- 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 import Data.Conduit import Data.Time.Clock (UTCTime) import Codec.Encryption.OpenPGP.Internal (PktStreamContext(..), emptyPSC) 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 -> Conduit Pkt m (Either String Verification) 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 hOpenPGP-2.5.5/Data/Conduit/OpenPGP/Filter.hs0000644000000000000000000000222612770565031016650 0ustar0000000000000000-- Filter.hs: OpenPGP (RFC4880) packet filtering -- Copyright © 2014-2015 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 import Control.Monad.Trans.Reader (Reader, runReader) import Data.Conduit (Conduit) import qualified Data.Conduit.List as CL import Codec.Encryption.OpenPGP.Types data FilterPredicates = RTKFilterPredicate (Reader TK Bool) -- ^ fp for transferable keys | RPFilterPredicate (Reader Pkt Bool) -- ^ fp for context-less packets conduitPktFilter :: Monad m => FilterPredicates -> Conduit Pkt m Pkt conduitPktFilter = CL.filter . superPredicate superPredicate :: FilterPredicates -> Pkt -> Bool superPredicate (RPFilterPredicate e) p = runReader e p superPredicate _ _ = False -- do not match incorrect type of packet conduitTKFilter :: Monad m => FilterPredicates -> Conduit TK m TK conduitTKFilter = CL.filter . superTKPredicate superTKPredicate :: FilterPredicates -> TK -> Bool superTKPredicate (RTKFilterPredicate e) = runReader e hOpenPGP-2.5.5/Data/Conduit/OpenPGP/Decrypt.hs0000644000000000000000000001063612770565031017041 0ustar0000000000000000-- Decrypt.hs: OpenPGP (RFC4880) recursive packet decryption -- Copyright © 2013-2016 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE FlexibleContexts #-} module Data.Conduit.OpenPGP.Decrypt ( conduitDecrypt ) where import Control.Monad (when) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Resource (MonadBaseControl, MonadResource, MonadThrow, runResourceT) import qualified Control.Monad.Trans.State.Lazy as S import qualified Crypto.Hash as CH import qualified Crypto.Hash.Algorithms as CHA import qualified Data.ByteArray as BA import qualified Data.ByteString.Lazy as BL import Data.Conduit import qualified Data.Conduit.Binary as CB import Data.Conduit.Serialization.Binary (conduitGet) import Data.Conduit.OpenPGP.Compression (conduitDecompress) import qualified Data.Conduit.List as CL import Data.Default.Class (Default, def) import Data.Maybe (fromJust, isNothing) import Data.Binary (get) import Codec.Encryption.OpenPGP.S2K (skesk2Key) import Codec.Encryption.OpenPGP.CFB (decrypt, decryptOpenPGPCfb) import Codec.Encryption.OpenPGP.Types data RecursorState = RecursorState { _depth :: Int , _lastPKESK :: Maybe PKESK , _lastSKESK :: Maybe SKESK , _lastLDP :: Maybe LiteralData } deriving (Eq, Show) instance Default RecursorState where def = RecursorState 0 Nothing Nothing Nothing type InputCallback m = String -> m BL.ByteString conduitDecrypt :: (MonadBaseControl IO m, MonadResource m) => InputCallback IO -> Conduit Pkt m Pkt conduitDecrypt = conduitDecrypt' 0 conduitDecrypt' :: (MonadBaseControl IO m, MonadResource m) => Int -> InputCallback IO -> Conduit Pkt m Pkt conduitDecrypt' depth cb = CL.concatMapAccumM push def { _depth = depth } -- FIXME: this depth stuff is convoluted where push :: (MonadBaseControl IO m, MonadResource m) => Pkt -> RecursorState -> m (RecursorState, [Pkt]) push i s | _depth s > 42 = fail "I think we've been quine-attacked" | otherwise = case i of SKESKPkt{} -> return (s { _lastSKESK = Just (fromPkt i) }, []) (SymEncDataPkt bs) -> do d <- decryptSEDP (_depth s) cb (fromJust . _lastSKESK $ s) bs return (processLDPs s d, d) (SymEncIntegrityProtectedDataPkt _ bs) -> do d <- decryptSEIPDP (_depth s) cb (fromJust . _lastSKESK $ s) bs return (processLDPs s d, d) m@(ModificationDetectionCodePkt mdc) -> do when (isNothing (_lastLDP s)) $ fail "MDC with no referent" when (fmap (BL.fromStrict . BA.convert . (CH.hashlazy :: BL.ByteString -> CH.Digest CHA.SHA1) . _literalDataPayload) (_lastLDP s) /= Just mdc) $ fail "MDC indicates tampering" return (s, [m]) p -> return (s, [p]) processLDPs s ds = S.execState (mapM_ ldpCheck ds) s ldpCheck l@LiteralDataPkt{} = S.get >>= \o -> S.put o { _lastLDP = Just . fromPkt $ l } ldpCheck _ = return () decryptSEDP :: (MonadBaseControl IO m, MonadIO m, MonadThrow m) => Int -> InputCallback IO -> SKESK -> BL.ByteString -> m [Pkt] decryptSEDP depth cb skesk bs = do -- FIXME: this shouldn't pass the whole SKESK passphrase <- liftIO $ cb "Input the passphrase I want" let key = skesk2Key skesk passphrase decrypted = case decryptOpenPGPCfb (_skeskSymmetricAlgorithm skesk) (BL.toStrict bs) key of Left e -> error e Right x -> x runResourceT $ CB.sourceLbs (BL.fromStrict decrypted) $= conduitGet get $= conduitDecompress $= conduitDecrypt' depth cb $$ CL.consume decryptSEIPDP :: (MonadBaseControl IO m, MonadIO m, MonadThrow m) => Int -> InputCallback IO -> SKESK -> BL.ByteString -> m [Pkt] decryptSEIPDP depth cb skesk bs = do -- FIXME: this shouldn't pass the whole SKESK passphrase <- liftIO $ cb "Input the passphrase I want" let key = skesk2Key skesk passphrase decrypted = case decrypt (_skeskSymmetricAlgorithm skesk) (BL.toStrict bs) key of Left e -> error e Right x -> x runResourceT $ CB.sourceLbs (BL.fromStrict decrypted) $= conduitGet get $= conduitDecompress $= conduitDecrypt' depth cb $$ CL.consume hOpenPGP-2.5.5/Data/Conduit/OpenPGP/Keyring/0000755000000000000000000000000012770565031016475 5ustar0000000000000000hOpenPGP-2.5.5/Data/Conduit/OpenPGP/Keyring/Instances.hs0000644000000000000000000000511512770565031020762 0ustar0000000000000000-- Instances.hs: OpenPGP (RFC4880) additional types for transferable keys -- Copyright © 2012-2016 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 import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) import Codec.Encryption.OpenPGP.Internal (issuer, sigCT) import Codec.Encryption.OpenPGP.Types import Control.Lens ((^.), (^..), _1, folded) import Data.Data.Lens (biplate) import Data.Either (rights) import Data.Function (on) import qualified Data.HashMap.Lazy as HashMap import Data.IxSet.Typed (Indexable(..), ixList, ixFun) import Data.List (nub, sort) import qualified Data.Map as Map import Data.Semigroup ((<>), Semigroup) import Data.Text (Text) instance Indexable KeyringIxs TK where 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 instance Ord SignaturePayload where compare s1@(SigV3 st1 ct1 eoki1 pka1 ha1 left16_1 mpis1) s2@(SigV3 st2 ct2 eoki2 pka2 ha2 left16_2 mpis2) = compare ct1 ct2 <> compare st1 st2 <> compare eoki1 eoki2 -- FIXME: nondeterministic compare s1@(SigV4 st1 pka1 ha1 has1 uhas1 left16_1 mpis1) s2@(SigV4 st2 pka2 ha2 has2 uhas2 left16_2 mpis2) = compare (sigCT s1) (sigCT s2) <> compare st1 st2 <> compare (issuer (SignaturePkt s1)) (issuer (SignaturePkt s2)) -- FIXME: nondeterministic compare s1@(SigVOther sv1 bs1) s2@(SigVOther sv2 bs2) = compare sv1 sv2 <> compare bs1 bs2 compare SigV3{} SigV4{} = LT compare SigV3{} SigVOther{} = LT compare SigV4{} SigV3{} = GT compare SigV4{} SigVOther{} = LT compare SigVOther{} SigV3{} = GT compare SigVOther{} SigV4{} = GT instance Semigroup TK where (<>) a b = TK (_tkKey a) (nub . sort $ _tkRevs a ++ _tkRevs b) ((kvmerge `on` _tkUIDs) a b) ((kvmerge `on` _tkUAts) a b) ((ukvmerge `on` _tkSubs) a b) where kvmerge x y = Map.toList (Map.unionWith nsa (Map.fromList x) (Map.fromList y)) ukvmerge x y = HashMap.toList (HashMap.unionWith nsa (HashMap.fromList x) (HashMap.fromList y)) nsa x y = nub . sort $ x ++ y