hOpenPGP 1.11 → 2.0
raw patch · 22 files changed
+1240/−742 lines, 22 filesdep +aesondep +bifunctorsdep +binarydep −ansi-wl-pprintdep −cerealdep −cereal-conduitdep ~QuickCheckdep ~basedep ~conduit
Dependencies added: aeson, bifunctors, binary, binary-conduit, byteable, criterion, data-default-class, network, network-uri, newtype, old-locale, wl-pprint-extras
Dependencies removed: ansi-wl-pprint, cereal, cereal-conduit, data-default, mtl
Dependency ranges changed: QuickCheck, base, conduit, conduit-extra, crypto-pubkey, incremental-parser, time
Files
- Codec/Encryption/OpenPGP/Arbitrary.hs +43/−29
- Codec/Encryption/OpenPGP/CFB.hs +9/−8
- Codec/Encryption/OpenPGP/Compression.hs +10/−12
- Codec/Encryption/OpenPGP/Expirations.hs +4/−5
- Codec/Encryption/OpenPGP/Fingerprint.hs +9/−9
- Codec/Encryption/OpenPGP/Internal.hs +10/−10
- Codec/Encryption/OpenPGP/KeyInfo.hs +3/−3
- Codec/Encryption/OpenPGP/KeySelection.hs +3/−3
- Codec/Encryption/OpenPGP/KeyringParser.hs +12/−11
- Codec/Encryption/OpenPGP/S2K.hs +3/−3
- Codec/Encryption/OpenPGP/SecretKey.hs +20/−14
- Codec/Encryption/OpenPGP/Serialize.hs +275/−275
- Codec/Encryption/OpenPGP/SerializeForSigs.hs +19/−19
- Codec/Encryption/OpenPGP/Signatures.hs +31/−31
- Codec/Encryption/OpenPGP/Types.hs +628/−66
- Data/Conduit/OpenPGP/Decrypt.hs +9/−10
- Data/Conduit/OpenPGP/Filter.hs +7/−199
- Data/Conduit/OpenPGP/Keyring/Instances.hs +5/−5
- bench/mark.hs +33/−0
- hOpenPGP.cabal +85/−15
- tests/data/debian-keyring.gpg too large to diff
- tests/suite.hs +22/−15
Codec/Encryption/OpenPGP/Arbitrary.hs view
@@ -1,13 +1,17 @@ -- Arbitrary.hs: QuickCheck instances--- Copyright © 2014 Clint Adams+-- Copyright © 2014-2015 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). module Codec.Encryption.OpenPGP.Arbitrary () where import Codec.Encryption.OpenPGP.Types-import qualified Data.ByteString as B-import Test.QuickCheck (Arbitrary(..), choose, elements, frequency, getPositive, oneof, vector)+import Control.Monad (liftM)+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@@ -18,10 +22,10 @@ return $ PKESK pv eoki pka mpis instance Arbitrary Signature where- arbitrary = arbitrary >>= return . Signature+ arbitrary = liftM Signature arbitrary instance Arbitrary UserId where- arbitrary = arbitrary >>= return . UserId+ arbitrary = liftM UserId arbitrary -- @@ -60,28 +64,28 @@ 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 = arbitrary >>= return . SigCreationTime- set = arbitrary >>= return . SigExpirationTime- ec = arbitrary >>= return . ExportableCertification+ sct = liftM SigCreationTime arbitrary+ set = liftM SigExpirationTime arbitrary+ ec = liftM ExportableCertification arbitrary ts = arbitrary >>= \tl -> arbitrary >>= \ta -> return (TrustSignature tl ta)- re = arbitrary >>= return . RegularExpression- ket = arbitrary >>= return . KeyExpirationTime- psa = arbitrary >>= return . PreferredSymmetricAlgorithms+ re = liftM RegularExpression arbitrary+ ket = liftM KeyExpirationTime arbitrary+ psa = liftM PreferredSymmetricAlgorithms arbitrary rk = arbitrary >>= \rcs -> arbitrary >>= \pka -> arbitrary >>= \tof -> return (RevocationKey rcs pka tof)- i = arbitrary >>= return . Issuer+ i = liftM Issuer arbitrary nd = arbitrary >>= \nfs -> arbitrary >>= \nn -> arbitrary >>= \nv -> return (NotationData nfs nn nv)- phas = arbitrary >>= return . PreferredHashAlgorithms- pcas = arbitrary >>= return . PreferredCompressionAlgorithms- ksps = arbitrary >>= return . KeyServerPreferences- pks = arbitrary >>= return . PreferredKeyServer- puid = arbitrary >>= return . PrimaryUserId- purl = arbitrary >>= return . PolicyURL- kfs = arbitrary >>= return . KeyFlags- suid = arbitrary >>= return . SignersUserId+ phas = liftM PreferredHashAlgorithms arbitrary+ pcas = liftM PreferredCompressionAlgorithms arbitrary+ ksps = liftM KeyServerPreferences arbitrary+ pks = liftM PreferredKeyServer arbitrary+ puid = liftM PrimaryUserId arbitrary+ purl = liftM (PolicyURL . URL . fromMaybe nullURI . parseURI) arbitrary+ kfs = liftM KeyFlags arbitrary+ suid = liftM SignersUserId arbitrary rfr = arbitrary >>= \rc -> arbitrary >>= \rr -> return (ReasonForRevocation rc rr)- fs = arbitrary >>= return . Features+ fs = liftM Features arbitrary st = arbitrary >>= \pka -> arbitrary >>= \ha -> arbitrary >>= \sh -> return (SignatureTarget pka ha sh)- es = arbitrary >>= return . EmbeddedSignature -- FIXME: figure out why EmbeddedSignature fails to serialize properly+ es = liftM 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 @@ -91,13 +95,13 @@ arbitrary = elements [RSA, DSA, ECDH, ECDSA, DH] instance Arbitrary EightOctetKeyId where- arbitrary = vector 8 >>= return . EightOctetKeyId . B.pack+ arbitrary = liftM (EightOctetKeyId . BL.pack) (vector 8) instance Arbitrary TwentyOctetFingerprint where- arbitrary = vector 20 >>= return . TwentyOctetFingerprint . B.pack+ arbitrary = liftM (TwentyOctetFingerprint . BL.pack) (vector 20) instance Arbitrary MPI where- arbitrary = arbitrary >>= return . MPI . getPositive+ arbitrary = liftM (MPI . getPositive) arbitrary instance Arbitrary SigType where arbitrary = elements [BinarySig, CanonicalTextSig, StandaloneSig, GenericCert, PersonaCert, CasualCert, PositiveCert, SubkeyBindingSig, PrimaryKeyBindingSig, SignatureDirectlyOnAKey, KeyRevocationSig, SubkeyRevocationSig, CertRevocationSig, TimestampSig, ThirdPartyConfirmationSig]@@ -112,13 +116,13 @@ arbitrary = frequency [(9,srk),(1,rco)] where srk = return SensitiveRK- rco = choose (2,7) >>= return . RClOther+ rco = liftM RClOther (choose (2,7)) instance Arbitrary NotationFlag where arbitrary = frequency [(9,hr),(1,onf)] where hr = return HumanReadable- onf = choose (1,31) >>= return . OtherNF+ onf = liftM OtherNF (choose (1,31)) instance Arbitrary CompressionAlgorithm where arbitrary = elements [Uncompressed,ZIP,ZLIB,BZip2]@@ -127,7 +131,7 @@ arbitrary = frequency [(9,nm),(1,kspo)] where nm = return NoModify- kspo = choose (2,63) >>= return . KSPOther+ kspo = liftM KSPOther (choose (2,63)) instance Arbitrary KeyFlag where arbitrary = elements [GroupKey, AuthKey, SplitKey, EncryptStorageKey, EncryptCommunicationsKey, SignDataKey, CertifyKeysKey]@@ -139,4 +143,14 @@ arbitrary = frequency [(9,md),(1,fo)] where md = return ModificationDetection- fo = choose (8,63) >>= return . FeatureOther+ fo = liftM FeatureOther (choose (8,63))++instance Arbitrary ThirtyTwoBitTimeStamp where+ arbitrary = liftM ThirtyTwoBitTimeStamp arbitrary++instance Arbitrary ThirtyTwoBitDuration where+ arbitrary = liftM ThirtyTwoBitDuration arbitrary++-- FIXME: this should be elsewhere+instance Arbitrary a => Arbitrary (NE.NonEmpty a) where+ arbitrary = NE.fromList `liftM` listOf1 arbitrary
Codec/Encryption/OpenPGP/CFB.hs view
@@ -1,5 +1,6 @@ -- CFB.hs: OpenPGP (RFC4880) CFB mode--- Copyright © 2013 Daniel Kahn Gillmor and Clint Adams+-- Copyright © 2013-2015 Clint Adams+-- Copyright © 2013 Daniel Kahn Gillmor -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -26,7 +27,7 @@ bc <- mkBCipher sa keydata let nonce = decrypt1 ciphertext bc cleartext <- decrypt2 ciphertext bc- if nonceCheck bc nonce then return cleartext else fail "Session key quickcheck failed"+ if nonceCheck bc nonce then return cleartext else Left "Session key quickcheck failed" where decrypt1 :: B.ByteString -> BCipher -> B.ByteString decrypt1 ct (BCipher cipher) = cdecrypt sa cipher nullIV (B.take (blockSize cipher + 2) ct)@@ -38,7 +39,7 @@ decrypt sa ciphertext keydata = do bc <- mkBCipher sa keydata let (nonce, cleartext) = B.splitAt (bcBlockSize bc + 2) (decrypt' ciphertext bc)- if nonceCheck bc nonce then return cleartext else fail "Session key quickcheck failed"+ if nonceCheck bc nonce then return cleartext else Left "Session key quickcheck failed" where decrypt' :: B.ByteString -> BCipher -> B.ByteString decrypt' ct (BCipher cipher) = cdecrypt sa cipher nullIV ct@@ -66,11 +67,11 @@ padded = ciphertext `B.append` B.pack (replicate (blockSize cipher - (B.length ciphertext `mod` blockSize cipher)) 0) mkBCipher :: ToSecureMem b => SymmetricAlgorithm -> b -> Either String BCipher-mkBCipher Plaintext = const (fail "this shouldn't have happened") -- FIXME: orphan instance?-mkBCipher IDEA = const (fail "IDEA not yet implemented") -- FIXME: IDEA-mkBCipher ReservedSAFER = const (fail "SAFER not implemented") -- FIXME: or not?-mkBCipher ReservedDES = const (fail "DES not implemented") -- FIXME: or not?-mkBCipher (OtherSA _) = const (fail "Unknown, unimplemented symmetric algorithm")+mkBCipher Plaintext = const (Left "this shouldn't have happened") -- FIXME: orphan instance?+mkBCipher IDEA = const (Left "IDEA not yet implemented") -- FIXME: IDEA+mkBCipher ReservedSAFER = const (Left "SAFER not implemented") -- FIXME: or not?+mkBCipher ReservedDES = const (Left "DES not implemented") -- FIXME: or not?+mkBCipher (OtherSA _) = const (Left "Unknown, unimplemented symmetric algorithm") mkBCipher CAST5 = return . BCipher . (ciph :: ToSecureMem b => b -> CNC.CAST128) mkBCipher Twofish = return . BCipher . (ciph :: ToSecureMem b => b -> CNC.TWOFISH) mkBCipher TripleDES = return . BCipher . (ciph :: ToSecureMem b => b -> CC.DES_EDE3)
Codec/Encryption/OpenPGP/Compression.hs view
@@ -1,5 +1,5 @@ -- Compression.hs: OpenPGP (RFC4880) compression and decompression--- Copyright © 2012-2013 Clint Adams+-- Copyright © 2012-2015 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -13,17 +13,15 @@ import qualified Codec.Compression.Zlib.Raw as ZlibRaw import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.Types-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import Data.Serialize (get, put)-import Data.Serialize.Get (runGet)-import Data.Serialize.Put (runPut)+import Data.Binary (get, put)+import Data.Binary.Get (runGetOrFail)+import Data.Binary.Put (runPut) decompressPkt :: Pkt -> [Pkt] decompressPkt (CompressedDataPkt algo bs) =- case (runGet get . B.concat . BL.toChunks) (dfunc algo (BL.fromChunks [bs])) of- Left _ -> []- Right packs -> unBlock packs+ case runGetOrFail get (dfunc algo bs) of+ Left _ -> []+ Right (_, _, packs) -> unBlock packs where dfunc ZIP = ZlibRaw.decompress dfunc ZLIB = Zlib.decompress@@ -32,10 +30,10 @@ decompressPkt p = [p] compressPkts :: CompressionAlgorithm -> [Pkt] -> Pkt-compressPkts ca packs = do+compressPkts ca packs = let bs = runPut $ put (Block packs)- cbs = B.concat . BL.toChunks $ cfunc ca (BL.fromChunks [bs])- CompressedDataPkt ca cbs+ cbs = cfunc ca bs+ in CompressedDataPkt ca cbs where cfunc ZIP = ZlibRaw.compress cfunc ZLIB = Zlib.compress
Codec/Encryption/OpenPGP/Expirations.hs view
@@ -1,5 +1,5 @@ -- Expirations.hs: OpenPGP (RFC4880) expiration checking--- Copyright © 2014 Clint Adams+-- Copyright © 2014-2015 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -9,7 +9,6 @@ ) where import Control.Lens ((&), (^.), _1)-import Data.List (sort) import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) @@ -20,11 +19,11 @@ isTKTimeValid ct key = ct >= keyCreationTime && ct < keyExpirationTime where keyCreationTime = key^.tkKey._1.timestamp & posixSecondsToUTCTime . realToFrac- keyExpirationTime = posixSecondsToUTCTime . realToFrac . ((+) (key^.tkKey._1.timestamp)) . newest . concatMap getKeyExpirationTimesFromSignature $ (concatMap snd (key^.tkUIDs) ++ concatMap snd (key^.tkUAts))+ keyExpirationTime = posixSecondsToUTCTime . realToFrac . ((key^.tkKey._1.timestamp & unThirtyTwoBitTimeStamp) +) . unThirtyTwoBitDuration . newest . concatMap getKeyExpirationTimesFromSignature $ (concatMap snd (key^.tkUIDs) ++ concatMap snd (key^.tkUAts)) newest [] = maxBound- newest xs = last (sort xs)+ newest xs = maximum xs -getKeyExpirationTimesFromSignature :: SignaturePayload -> [TimeStamp]+getKeyExpirationTimesFromSignature :: SignaturePayload -> [ThirtyTwoBitDuration] getKeyExpirationTimesFromSignature (SigV4 _ _ _ xs _ _ _) = map (\(SigSubPacket _ (KeyExpirationTime x)) -> x) $ filter isKET xs where isKET (SigSubPacket _ (KeyExpirationTime _)) = True
Codec/Encryption/OpenPGP/Fingerprint.hs view
@@ -1,5 +1,5 @@ -- Fingerprint.hs: OpenPGP (RFC4880) fingerprinting methods--- Copyright © 2012-2014 Clint Adams+-- Copyright © 2012-2015 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -11,20 +11,20 @@ import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.Hash.MD5 as MD5 import qualified Crypto.Hash.SHA1 as SHA1-import qualified Data.ByteString as B-import Data.Serialize.Put (runPut)+import qualified Data.ByteString.Lazy as BL+import Data.Binary.Put (runPut) import Codec.Encryption.OpenPGP.SerializeForSigs (putPKPforFingerprinting) import Codec.Encryption.OpenPGP.Internal (integerToBEBS) import Codec.Encryption.OpenPGP.Types eightOctetKeyID :: PKPayload -> Either String EightOctetKeyId-eightOctetKeyID (PKPayload DeprecatedV3 _ _ RSA (RSAPubKey rp)) = (Right . EightOctetKeyId . B.reverse . B.take 4 . B.reverse . integerToBEBS . RSA.public_n) rp-eightOctetKeyID (PKPayload DeprecatedV3 _ _ DeprecatedRSAEncryptOnly (RSAPubKey rp)) = (Right . EightOctetKeyId . B.reverse . B.take 4 . B.reverse . integerToBEBS . RSA.public_n) rp-eightOctetKeyID (PKPayload DeprecatedV3 _ _ DeprecatedRSASignOnly (RSAPubKey rp)) = (Right . EightOctetKeyId . B.reverse . B.take 4 . B.reverse . integerToBEBS . RSA.public_n) rp+eightOctetKeyID (PKPayload DeprecatedV3 _ _ RSA (RSAPubKey (RSA_PublicKey rp))) = (Right . EightOctetKeyId . BL.reverse . BL.take 4 . BL.reverse . integerToBEBS . RSA.public_n) rp+eightOctetKeyID (PKPayload DeprecatedV3 _ _ DeprecatedRSAEncryptOnly (RSAPubKey (RSA_PublicKey rp))) = (Right . EightOctetKeyId . BL.reverse . BL.take 4 . BL.reverse . integerToBEBS . RSA.public_n) rp+eightOctetKeyID (PKPayload DeprecatedV3 _ _ DeprecatedRSASignOnly (RSAPubKey (RSA_PublicKey rp))) = (Right . EightOctetKeyId . BL.reverse . BL.take 4 . BL.reverse . integerToBEBS . RSA.public_n) rp eightOctetKeyID (PKPayload DeprecatedV3 _ _ _ _) = Left "Cannot calculate the key ID of a non-RSA V3 key"-eightOctetKeyID p4@(PKPayload V4 _ _ _ _) = (Right . EightOctetKeyId . B.drop 12 . unTOF . fingerprint) p4+eightOctetKeyID p4@(PKPayload V4 _ _ _ _) = (Right . EightOctetKeyId . BL.drop 12 . unTOF . fingerprint) p4 fingerprint :: PKPayload -> TwentyOctetFingerprint-fingerprint p3@(PKPayload DeprecatedV3 _ _ _ _) = (TwentyOctetFingerprint . MD5.hash) (runPut $ putPKPforFingerprinting (PublicKeyPkt p3))-fingerprint p4@(PKPayload V4 _ _ _ _) = (TwentyOctetFingerprint . SHA1.hash) (runPut $ putPKPforFingerprinting (PublicKeyPkt p4))+fingerprint p3@(PKPayload DeprecatedV3 _ _ _ _) = (TwentyOctetFingerprint . BL.fromStrict . MD5.hashlazy) (runPut $ putPKPforFingerprinting (PublicKeyPkt p3))+fingerprint p4@(PKPayload V4 _ _ _ _) = (TwentyOctetFingerprint . BL.fromStrict . SHA1.hashlazy) (runPut $ putPKPforFingerprinting (PublicKeyPkt p4))
Codec/Encryption/OpenPGP/Internal.hs view
@@ -1,5 +1,5 @@ -- Internal.hs: private utility functions--- Copyright © 2012-2014 Clint Adams+-- Copyright © 2012-2015 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -26,8 +26,8 @@ import qualified Crypto.PubKey.RSA as RSA import Data.Bits (testBit, shiftL, shiftR, (.&.))-import Data.ByteString (ByteString)-import qualified Data.ByteString as B+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as BL import Data.List (find, mapAccumR, unfoldr) import Data.Word (Word8, Word16) @@ -35,18 +35,18 @@ countBits :: ByteString -> Word16 countBits bs- | B.null bs = 0- | otherwise = fromIntegral (B.length bs * 8) - fromIntegral (go (B.head bs) 7)+ | 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) beBSToInteger :: ByteString -> Integer-beBSToInteger = sum . snd . mapAccumR (\acc x -> (acc + 8, fromIntegral x `shiftL` acc)) 0 . B.unpack+beBSToInteger = sum . snd . mapAccumR (\acc x -> (acc + 8, fromIntegral x `shiftL` acc)) 0 . BL.unpack integerToBEBS :: Integer -> ByteString-integerToBEBS = B.pack . reverse . unfoldr (\x -> if x == 0 then Nothing else Just ((fromIntegral x :: Word8) .&. 0xff, x `shiftR` 8))+integerToBEBS = BL.pack . reverse . unfoldr (\x -> if x == 0 then Nothing else Just ((fromIntegral x :: Word8) .&. 0xff, x `shiftR` 8)) data PktStreamContext = PktStreamContext { lastLD :: Pkt , lastUIDorUAt :: Pkt@@ -76,8 +76,8 @@ hashDescr x = Left $ "Unknown hash problem: " ++ show x pubkeyToMPIs :: PKey -> [MPI]-pubkeyToMPIs (RSAPubKey k) = [MPI (RSA.public_n k), MPI (RSA.public_e k)]-pubkeyToMPIs (DSAPubKey k) = [+pubkeyToMPIs (RSAPubKey (RSA_PublicKey k)) = [MPI (RSA.public_n k), MPI (RSA.public_e k)]+pubkeyToMPIs (DSAPubKey (DSA_PublicKey k)) = [ pkParams DSA.params_p , pkParams DSA.params_q , pkParams DSA.params_g@@ -107,7 +107,7 @@ sigHA (SigV4 _ _ ha _ _ _ _) = Just ha sigHA _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild -sigCT :: SignaturePayload -> Maybe TimeStamp+sigCT :: SignaturePayload -> Maybe ThirtyTwoBitTimeStamp sigCT (SigV3 _ ct _ _ _ _ _) = Just ct sigCT (SigV4 _ _ _ hsubs _ _ _) = fmap (\(SigSubPacket _ (SigCreationTime i)) -> i) (find isSigCreationTime hsubs) where
Codec/Encryption/OpenPGP/KeyInfo.hs view
@@ -1,5 +1,5 @@ -- KeyInfo.hs: OpenPGP (RFC4880) fingerprinting methods--- Copyright © 2012-2014 Clint Adams+-- Copyright © 2012-2015 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -18,8 +18,8 @@ import Codec.Encryption.OpenPGP.Types -pubkeySize (RSAPubKey x) = Right (RSA.public_size x * 8)-pubkeySize (DSAPubKey x) = Right (bitcount . DSA.params_p . DSA.public_params $ x)+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 x) = Right (bitcount $ head x) pubkeySize x = Left $ "Unable to calculate size of " ++ show x
Codec/Encryption/OpenPGP/KeySelection.hs view
@@ -1,5 +1,5 @@ -- KeySelection.hs: OpenPGP (RFC4880) ways to ask for keys--- Copyright © 2014 Clint Adams+-- Copyright © 2014-2015 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -10,7 +10,7 @@ , parseFingerprint ) where -import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL import Codec.Encryption.OpenPGP.Internal (integerToBEBS) import Codec.Encryption.OpenPGP.Types import Control.Applicative (optional, (<$>), (*>))@@ -31,5 +31,5 @@ hexen :: Int -> Parser Text hexen n = T.pack <$> count n (satisfy (inClass "A-F0-9")) -hexes :: Parser B.ByteString+hexes :: Parser BL.ByteString hexes = integerToBEBS <$> hexadecimal
Codec/Encryption/OpenPGP/KeyringParser.hs view
@@ -1,5 +1,5 @@ -- KeyringParser.hs: OpenPGP (RFC4880) transferable keys parsing--- Copyright © 2012-2014 Clint Adams+-- Copyright © 2012-2015 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -26,6 +26,7 @@ import Control.Applicative (many, (<$>), (<|>)) import Data.Monoid (Monoid, (<>), mconcat)+import Data.Text (Text) import Codec.Encryption.OpenPGP.Types import Data.Conduit.OpenPGP.Keyring.Instances ()@@ -37,7 +38,7 @@ 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 ([], Nothing) = error "Unexpected finalization failure" finalizeParsing (cr, Nothing) = (([], Nothing), map fst cr) finalizeParsing (_, Just (_, p)) = finalizeParsing (inspect (feedEof p)) @@ -45,21 +46,21 @@ parseTK True = publicTK True <|> secretTK True parseTK False = publicTK False <|> secretTK False <|> brokenTK 6 <|> brokenTK 5 -data UidOrUat = I String | A [UserAttrSubPacket]+data UidOrUat = I Text | A [UserAttrSubPacket] deriving Show -splitUs :: [(UidOrUat, [SignaturePayload])] -> ([(String, [SignaturePayload])], [([UserAttrSubPacket], [SignaturePayload])])+splitUs :: [(UidOrUat, [SignaturePayload])] -> ([(Text, [SignaturePayload])], [([UserAttrSubPacket], [SignaturePayload])]) splitUs us = (is, as) where is = map unI (filter isI us) as = map unA (filter isA us)- isI ((I _), _) = True+ isI (I _, _) = True isI _ = False- isA ((A _), _) = True+ isA (A _, _) = True isA _ = False- unI ((I x), y) = (x, y)+ unI (I x, y) = (x, y) unI x = error $ "unI should never be called on " ++ show x- unA ((A x), y) = (x, y)+ unA (A x, y) = (x, y) unA x = error $ "unA should never be called on " ++ show x publicTK, secretTK :: Bool -> Parser [Pkt] (Maybe TK)@@ -68,7 +69,7 @@ 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)+ return $ Just (TK pkp pkpsigs uids uats subs) where pubsub True = signedOrRevokedPubSubkey True pubsub False = signedOrRevokedPubSubkey False <|> brokenPubSubkey@@ -77,7 +78,7 @@ 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)+ return $ Just (TK skp skpsigs uids uats subs) where secsub True = rawOrSignedOrRevokedSecSubkey True secsub False = rawOrSignedOrRevokedSecSubkey False <|> brokenSecSubkey@@ -105,7 +106,7 @@ isPKP _ = False signature :: Bool -> [SigType] -> Parser [Pkt] [SignaturePayload]-signature intolerant rts = if intolerant then signature' else (signature' <|> brokensig')+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]
Codec/Encryption/OpenPGP/S2K.hs view
@@ -1,5 +1,5 @@ -- S2K.hs: OpenPGP (RFC4880) string-to-key conversion--- Copyright © 2013 Clint Adams+-- Copyright © 2013-2015 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -19,8 +19,8 @@ string2Key :: S2K -> Int -> BL.ByteString -> B.ByteString string2Key (Simple ha) ksz bs = B.take (fromIntegral ksz) $ hashpp (hf ha) ksz bs-string2Key (Salted ha salt) ksz bs = string2Key (Simple ha) ksz (BL.append (BL.fromChunks [salt]) bs)-string2Key (IteratedSalted ha salt cnt) ksz bs = string2Key (Simple ha) ksz (BL.take (fromIntegral cnt) . BL.cycle $ BL.append (BL.fromStrict salt) bs)+string2Key (Salted ha salt) ksz bs = string2Key (Simple ha) ksz (BL.append (BL.fromStrict (unSalt salt)) bs)+string2Key (IteratedSalted ha salt cnt) ksz bs = string2Key (Simple ha) ksz (BL.take (fromIntegral cnt) . BL.cycle $ BL.append (BL.fromStrict (unSalt salt)) bs) string2Key _ _ _ = error "FIXME: unimplemented S2K type" hf :: HashAlgorithm -> BL.ByteString -> B.ByteString
Codec/Encryption/OpenPGP/SecretKey.hs view
@@ -1,5 +1,5 @@ -- SecretKey.hs: OpenPGP (RFC4880) secret key decryption--- Copyright © 2013 Clint Adams+-- Copyright © 2013-2015 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -20,8 +20,10 @@ import Crypto.Random (createEntropyPool, cprgCreate, cprgGenerateWithEntropy, SystemRNG) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL-import Data.Serialize (runGet, runPut, put)-import Data.Serialize.Get (getBytes, remaining, getWord16be)+import Data.Binary (put)+import Data.Binary.Get (getLazyByteString, remaining, getWord16be, runGetOrFail)+import Data.Binary.Put (runPut)+import Data.Bifunctor (bimap) import qualified Crypto.PubKey.RSA as R decryptPrivateKey :: (PKPayload, SKAddendum) -> BL.ByteString -> SKAddendum@@ -33,21 +35,25 @@ 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 payload key- (s, cksum) <- runGet (getSecretKey pkp >>= \sk -> getWord16be >>= \csum -> return (sk, csum)) p -- FIXME: check the 16bit hash+ 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 payload key- (s, cksum) <- runGet (getSecretKey pkp >>= \sk -> remaining >>= (getBytes >=> \csum -> return (sk, csum))) p -- FIXME: check the SHA1 hash+ 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?-decryptSKA _ _ = fail "Unexpected codepath"+ where+ getSecretKeyAndChecksum p = bimap (\(_,_,x) -> x) (\(_,_,x) -> x) (runGetOrFail (getSecretKey pkp >>= \sk -> remaining >>= (getLazyByteString >=> \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 i ska pp)+encryptPrivateKeyIO ska pp = saltiv >>= \(s,i) -> return (encryptPrivateKey s (IV i) ska pp) where saltiv = do ep <- createEntropyPool@@ -60,17 +66,17 @@ encryptPrivateKey _ _ ska@(SUS16bit {}) _ = ska encryptPrivateKey _ _ ska@(SUSSHA1 {}) _ = ska encryptPrivateKey _ _ ska@(SUSym {}) _ = ska-encryptPrivateKey salt iv (SUUnencrypted skey _) pp = SUSSHA1 AES256 s2k iv (encryptSKey skey s2k iv pp)+encryptPrivateKey salt iv (SUUnencrypted skey _) pp = SUSSHA1 AES256 s2k iv (BL.fromStrict (encryptSKey skey s2k iv pp)) where- s2k = IteratedSalted SHA512 salt 12058624+ s2k = IteratedSalted SHA512 (Salt salt) 12058624 encryptSKey :: SKey -> S2K -> IV -> BL.ByteString -> B.ByteString-encryptSKey (RSAPrivateKey (R.PrivateKey _ d p q _ _ _)) s2k iv pp = either error id (encryptNoNonce AES256 s2k iv payload key)+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 = SHA1.hash algospecific- payload = algospecific `B.append` cksum+ cksum = SHA1.hashlazy algospecific+ payload = algospecific `BL.append` BL.fromStrict cksum u = inverse q p encryptSKey _ _ _ _ = error "Non-RSA keytypes not handled yet" -- FIXME: do DSA and ElGamal
Codec/Encryption/OpenPGP/Serialize.hs view
@@ -1,5 +1,5 @@ -- Serialize.hs: OpenPGP (RFC4880) serialization (using cereal)--- Copyright © 2012-2014 Clint Adams+-- Copyright © 2012-2015 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -8,18 +8,22 @@ , getSecretKey ) where -import Control.Applicative ((<$>),(<*>))+import Control.Applicative ((<$>),(<*>), many, some) import Control.Lens ((^.), _1) import Control.Monad (guard, liftM, mplus, replicateM, replicateM_) import qualified Crypto.PubKey.RSA as R import qualified Crypto.PubKey.DSA as D import Data.Bits ((.&.), (.|.), shiftL, shiftR, testBit)-import Data.ByteString (ByteString)+import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL import Data.List (mapAccumL)-import Data.Serialize (Serialize, get, put)-import Data.Serialize.Get (Get, getWord8, getWord16be, getWord32be, getBytes, getByteString, getWord16le, runGet, remaining)-import Data.Serialize.Put (Put, putWord8, putWord16be, putWord32be, putByteString, putWord16le, runPut)+import qualified Data.List.NonEmpty as NE+import Data.Binary (Binary, get, put)+import Data.Binary.Get (Get, getWord8, getWord16be, getWord32be, getByteString, getLazyByteString, getWord16le, runGetOrFail, remaining, ByteOffset)+import Data.Binary.Put (Put, putWord8, putWord16be, putWord32be, putByteString, putLazyByteString, putWord16le, runPut)+import qualified Data.Foldable as F+import Data.Monoid (mempty) import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Text as T@@ -27,138 +31,139 @@ 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 (countBits, beBSToInteger, integerToBEBS, pubkeyToMPIs, multiplicativeInverse) import Codec.Encryption.OpenPGP.Types -instance Serialize SigSubPacket where+instance Binary SigSubPacket where get = getSigSubPacket put = putSigSubPacket --- instance Serialize (Set NotationFlag) where+-- instance Binary (Set NotationFlag) where -- put = putNotationFlagSet -instance Serialize CompressionAlgorithm where+instance Binary CompressionAlgorithm where get = liftM toFVal getWord8 put = putWord8 . fromFVal -instance Serialize PubKeyAlgorithm where+instance Binary PubKeyAlgorithm where get = liftM toFVal getWord8 put = putWord8 . fromFVal -instance Serialize HashAlgorithm where+instance Binary HashAlgorithm where get = liftM toFVal getWord8 put = putWord8 . fromFVal -instance Serialize SymmetricAlgorithm where+instance Binary SymmetricAlgorithm where get = liftM toFVal getWord8 put = putWord8 . fromFVal -instance Serialize MPI where+instance Binary MPI where get = getMPI put = putMPI -instance Serialize SigType where+instance Binary SigType where get = liftM toFVal getWord8 put = putWord8 . fromFVal -instance Serialize UserAttrSubPacket where+instance Binary UserAttrSubPacket where get = getUserAttrSubPacket put = putUserAttrSubPacket -instance Serialize S2K where+instance Binary S2K where get = getS2K put = putS2K -instance Serialize PKESK where+instance Binary PKESK where get = fmap fromPkt getPkt put = putPkt . toPkt -instance Serialize Signature where+instance Binary Signature where get = fmap fromPkt getPkt put = putPkt . toPkt -instance Serialize SKESK where+instance Binary SKESK where get = fmap fromPkt getPkt put = putPkt . toPkt -instance Serialize OnePassSignature where+instance Binary OnePassSignature where get = fmap fromPkt getPkt put = putPkt . toPkt -instance Serialize SecretKey where+instance Binary SecretKey where get = fmap fromPkt getPkt put = putPkt . toPkt -instance Serialize PublicKey where+instance Binary PublicKey where get = fmap fromPkt getPkt put = putPkt . toPkt -instance Serialize SecretSubkey where+instance Binary SecretSubkey where get = fmap fromPkt getPkt put = putPkt . toPkt -instance Serialize CompressedData where+instance Binary CompressedData where get = fmap fromPkt getPkt put = putPkt . toPkt -instance Serialize SymEncData where+instance Binary SymEncData where get = fmap fromPkt getPkt put = putPkt . toPkt -instance Serialize Marker where+instance Binary Marker where get = fmap fromPkt getPkt put = putPkt . toPkt -instance Serialize LiteralData where+instance Binary LiteralData where get = fmap fromPkt getPkt put = putPkt . toPkt -instance Serialize Trust where+instance Binary Trust where get = fmap fromPkt getPkt put = putPkt . toPkt -instance Serialize UserId where+instance Binary UserId where get = fmap fromPkt getPkt put = putPkt . toPkt -instance Serialize PublicSubkey where+instance Binary PublicSubkey where get = fmap fromPkt getPkt put = putPkt . toPkt -instance Serialize UserAttribute where+instance Binary UserAttribute where get = fmap fromPkt getPkt put = putPkt . toPkt -instance Serialize SymEncIntegrityProtectedData where+instance Binary SymEncIntegrityProtectedData where get = fmap fromPkt getPkt put = putPkt . toPkt -instance Serialize ModificationDetectionCode where+instance Binary ModificationDetectionCode where get = fmap fromPkt getPkt put = putPkt . toPkt -instance Serialize OtherPacket where+instance Binary OtherPacket where get = fmap fromPkt getPkt put = putPkt . toPkt -instance Serialize Pkt where+instance Binary Pkt where get = getPkt put = putPkt -instance Serialize a => Serialize (Block a) where+instance Binary a => Binary (Block a) where get = Block `fmap` many get put = mapM_ put . unBlock -instance Serialize PKPayload where+instance Binary PKPayload where get = getPKPayload put = putPKPayload -instance Serialize SignaturePayload where+instance Binary SignaturePayload where get = getSignaturePayload put = putSignaturePayload -instance Serialize TK where+instance Binary TK where get = undefined put = putTK @@ -168,13 +173,13 @@ (crit, pt) <- getSigSubPacketType getSigSubPacket' pt crit l where- getSigSubPacket' :: Word8 -> Bool -> Int -> Get SigSubPacket+ getSigSubPacket' :: Word8 -> Bool -> ByteOffset -> Get SigSubPacket getSigSubPacket' pt crit l | pt == 2 = do- et <- getWord32be+ et <- fmap ThirtyTwoBitTimeStamp getWord32be return $ SigSubPacket crit (SigCreationTime et) | pt == 3 = do- et <- getWord32be+ et <- fmap ThirtyTwoBitDuration getWord32be return $ SigSubPacket crit (SigExpirationTime et) | pt == 4 = do e <- get@@ -184,90 +189,90 @@ ta <- getWord8 return $ SigSubPacket crit (TrustSignature tl ta) | pt == 6 = do- apdre <- getByteString (l - 2)+ apdre <- getLazyByteString (l - 2) nul <- getWord8 guard (nul == 0)- return $ SigSubPacket crit (RegularExpression (B.copy apdre))+ return $ SigSubPacket crit (RegularExpression (BL.copy apdre)) | pt == 7 = do r <- get return $ SigSubPacket crit (Revocable r) | pt == 9 = do- et <- getWord32be+ et <- fmap ThirtyTwoBitDuration getWord32be return $ SigSubPacket crit (KeyExpirationTime et) | pt == 11 = do- sa <- replicateM (l - 1) get+ sa <- replicateM (fromIntegral (l - 1)) get return $ SigSubPacket crit (PreferredSymmetricAlgorithms sa) | pt == 12 = do rclass <- getWord8 guard (testBit rclass 7) algid <- get- fp <- getByteString 20- return $ SigSubPacket crit (RevocationKey (bsToFFSet . B.singleton $ rclass .&. 0x7f) algid (TwentyOctetFingerprint fp))+ fp <- getLazyByteString 20+ return $ SigSubPacket crit (RevocationKey (bsToFFSet . BL.singleton $ rclass .&. 0x7f) algid (TwentyOctetFingerprint fp)) | pt == 16 = do- keyid <- getByteString (l - 1)+ keyid <- getLazyByteString (l - 1) return $ SigSubPacket crit (Issuer (EightOctetKeyId keyid)) | pt == 20 = do- flags <- getByteString 4+ flags <- getLazyByteString 4 nl <- getWord16be vl <- getWord16be- nd <- getByteString (fromIntegral nl)- nv <- getByteString (fromIntegral vl)+ nd <- getLazyByteString (fromIntegral nl)+ nv <- getLazyByteString (fromIntegral vl) return $ SigSubPacket crit (NotationData (bsToFFSet flags) nd nv) | pt == 21 = do- ha <- replicateM (l - 1) get+ ha <- replicateM (fromIntegral (l - 1)) get return $ SigSubPacket crit (PreferredHashAlgorithms ha) | pt == 22 = do- ca <- replicateM (l - 1) get+ ca <- replicateM (fromIntegral (l - 1)) get return $ SigSubPacket crit (PreferredCompressionAlgorithms ca) | pt == 23 = do- ksps <- getByteString (l - 1)+ ksps <- getLazyByteString (l - 1) return $ SigSubPacket crit (KeyServerPreferences (bsToFFSet ksps)) | pt == 24 = do- pks <- getByteString (l - 1)+ pks <- getLazyByteString (l - 1) return $ SigSubPacket crit (PreferredKeyServer pks) | pt == 25 = do primacy <- get return $ SigSubPacket crit (PrimaryUserId primacy) | pt == 26 = do- url <- getByteString (l - 1)+ url <- fmap (URL . fromMaybe nullURI . parseURI . T.unpack . decodeUtf8With lenientDecode) (getByteString (fromIntegral (l - 1))) return $ SigSubPacket crit (PolicyURL url) | pt == 27 = do- kfs <- getByteString (l - 1)+ kfs <- getLazyByteString (l - 1) return $ SigSubPacket crit (KeyFlags (bsToFFSet kfs)) | pt == 28 = do- uid <- getByteString (l - 1)- return $ SigSubPacket crit (SignersUserId (T.unpack . decodeUtf8With lenientDecode $ uid))+ uid <- getByteString (fromIntegral (l - 1))+ return $ SigSubPacket crit (SignersUserId (decodeUtf8With lenientDecode uid)) | pt == 29 = do rcode <- getWord8- rreason <- getByteString (l - 2)+ rreason <- fmap (decodeUtf8With lenientDecode) (getByteString (fromIntegral (l - 2))) return $ SigSubPacket crit (ReasonForRevocation (toFVal rcode) rreason) | pt == 30 = do- fbs <- getByteString (l - 1)+ fbs <- getLazyByteString (l - 1) return $ SigSubPacket crit (Features (bsToFFSet fbs)) | pt == 31 = do pka <- get ha <- get- hash <- getByteString (l - 3)+ 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 <- getByteString (l - 1)+ payload <- getLazyByteString (l - 1) return $ SigSubPacket crit (UserDefinedSigSub pt payload) | otherwise = do- payload <- getByteString (l - 1)+ 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 et+ putWord32be . unThirtyTwoBitTimeStamp $ et putSigSubPacket (SigSubPacket crit (SigExpirationTime et)) = do putSubPacketLength 5 putSigSubPacketType crit 3- putWord32be et+ putWord32be . unThirtyTwoBitDuration $ et putSigSubPacket (SigSubPacket crit (ExportableCertification e)) = do putSubPacketLength 2 putSigSubPacketType crit 4@@ -278,9 +283,9 @@ put tl put ta putSigSubPacket (SigSubPacket crit (RegularExpression apdre)) = do- putSubPacketLength . fromIntegral $ (2 + B.length apdre)+ putSubPacketLength . fromIntegral $ (2 + BL.length apdre) putSigSubPacketType crit 6- putByteString apdre+ putLazyByteString apdre putWord8 0 putSigSubPacket (SigSubPacket crit (Revocable r)) = do putSubPacketLength 2@@ -289,7 +294,7 @@ putSigSubPacket (SigSubPacket crit (KeyExpirationTime et)) = do putSubPacketLength 5 putSigSubPacketType crit 9- putWord32be et+ putWord32be . unThirtyTwoBitDuration $ et putSigSubPacket (SigSubPacket crit (PreferredSymmetricAlgorithms ess)) = do putSubPacketLength . fromIntegral $ (1 + length ess) putSigSubPacketType crit 11@@ -297,21 +302,21 @@ putSigSubPacket (SigSubPacket crit (RevocationKey rclass algid fp)) = do putSubPacketLength 23 putSigSubPacketType crit 12- putByteString . ffSetToFixedLengthBS 1 $ Set.insert (RClOther 0) rclass+ putLazyByteString . ffSetToFixedLengthBS 1 $ Set.insert (RClOther 0) rclass put algid- putByteString (unTOF fp) -- 20 octets+ putLazyByteString (unTOF fp) -- 20 octets putSigSubPacket (SigSubPacket crit (Issuer keyid)) = do putSubPacketLength 9 putSigSubPacketType crit 16- putByteString (unEOKI keyid) -- 8 octets+ putLazyByteString (unEOKI keyid) -- 8 octets putSigSubPacket (SigSubPacket crit (NotationData nfs nn nv)) = do- putSubPacketLength . fromIntegral $ (9 + B.length nn + B.length nv)+ putSubPacketLength . fromIntegral $ (9 + BL.length nn + BL.length nv) putSigSubPacketType crit 20- putByteString . ffSetToFixedLengthBS 4 $ nfs- putWord16be . fromIntegral . B.length $ nn- putWord16be . fromIntegral . B.length $ nv- putByteString nn- putByteString nv+ putLazyByteString . ffSetToFixedLengthBS 4 $ 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@@ -322,60 +327,62 @@ mapM_ put ecs putSigSubPacket (SigSubPacket crit (KeyServerPreferences ksps)) = do let kbs = ffSetToBS ksps- putSubPacketLength . fromIntegral $ (1 + B.length kbs)+ putSubPacketLength . fromIntegral $ (1 + BL.length kbs) putSigSubPacketType crit 23- putByteString kbs+ putLazyByteString kbs putSigSubPacket (SigSubPacket crit (PreferredKeyServer ks)) = do- putSubPacketLength . fromIntegral $ (1 + B.length ks)+ putSubPacketLength . fromIntegral $ (1 + BL.length ks) putSigSubPacketType crit 24- putByteString ks+ putLazyByteString ks putSigSubPacket (SigSubPacket crit (PrimaryUserId primacy)) = do putSubPacketLength 2 putSigSubPacketType crit 25 put primacy-putSigSubPacket (SigSubPacket crit (PolicyURL url)) = do- putSubPacketLength . fromIntegral $ (1 + B.length url)+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 url+ putByteString bs putSigSubPacket (SigSubPacket crit (KeyFlags kfs)) = do let kbs = ffSetToBS kfs- putSubPacketLength . fromIntegral $ (1 + B.length kbs)+ putSubPacketLength . fromIntegral $ (1 + BL.length kbs) putSigSubPacketType crit 27- putByteString kbs+ putLazyByteString kbs putSigSubPacket (SigSubPacket crit (SignersUserId userid)) = do- let bs = encodeUtf8 . T.pack $ userid+ let bs = encodeUtf8 userid putSubPacketLength . fromIntegral $ (1 + B.length bs) putSigSubPacketType crit 28 putByteString bs putSigSubPacket (SigSubPacket crit (ReasonForRevocation rcode rreason)) = do- putSubPacketLength . fromIntegral $ (2 + B.length rreason)+ let reasonbs = encodeUtf8 rreason+ putSubPacketLength . fromIntegral $ (2 + B.length reasonbs) putSigSubPacketType crit 29 putWord8 . fromFVal $ rcode- putByteString rreason+ putByteString reasonbs putSigSubPacket (SigSubPacket crit (Features fs)) = do let fbs = ffSetToBS fs- putSubPacketLength . fromIntegral $ (1 + B.length fbs)+ putSubPacketLength . fromIntegral $ (1 + BL.length fbs) putSigSubPacketType crit 30- putByteString fbs+ putLazyByteString fbs putSigSubPacket (SigSubPacket crit (SignatureTarget pka ha hash)) = do- putSubPacketLength . fromIntegral $ (3 + B.length hash)+ putSubPacketLength . fromIntegral $ (3 + BL.length hash) putSigSubPacketType crit 31 put pka put ha- putByteString hash+ putLazyByteString hash putSigSubPacket (SigSubPacket crit (EmbeddedSignature sp)) = do let spb = runPut (put sp)- putSubPacketLength . fromIntegral $ (1 + B.length spb)+ putSubPacketLength . fromIntegral $ (1 + BL.length spb) putSigSubPacketType crit 32- putByteString spb+ putLazyByteString spb putSigSubPacket (SigSubPacket crit (UserDefinedSigSub ptype payload)) = do- putSubPacketLength . fromIntegral $ (1 + B.length payload)+ putSubPacketLength . fromIntegral $ (1 + BL.length payload) putSigSubPacketType crit ptype- putByteString payload+ putLazyByteString payload putSigSubPacket (SigSubPacket crit (OtherSigSub ptype payload)) = do- putSubPacketLength . fromIntegral $ (1 + B.length payload)+ putSubPacketLength . fromIntegral $ (1 + BL.length payload) putSigSubPacketType crit ptype- putByteString payload+ putLazyByteString payload getSubPacketLength :: Get Word32 getSubPacketLength = getSubPacketLength' =<< getWord8@@ -408,13 +415,13 @@ putSigSubPacketType True sst = putWord8 (sst .|. 0x80) bsToFFSet :: FutureFlag a => ByteString -> Set a-bsToFFSet bs = Set.fromAscList . concat . snd $ mapAccumL (\acc y -> (acc+8, concatMap (\x -> if y .&. shiftR 128 x == shiftR 128 x then [toFFlag (acc + x)] else []) [0..7])) 0 (B.unpack bs)+bsToFFSet bs = Set.fromAscList . concat . snd $ mapAccumL (\acc y -> (acc+8, concatMap (\x -> if y .&. shiftR 128 x == shiftR 128 x then [toFFlag (acc + x)] else []) [0..7])) 0 (BL.unpack bs) ffSetToFixedLengthBS :: (Integral a, FutureFlag b) => a -> Set b -> ByteString-ffSetToFixedLengthBS len ffs = B.take (fromIntegral len) (B.append (ffSetToBS ffs) (B.pack (replicate 5 0)))+ffSetToFixedLengthBS len ffs = BL.take (fromIntegral len) (BL.append (ffSetToBS ffs) (BL.pack (replicate 5 0))) ffSetToBS :: FutureFlag a => Set a -> ByteString-ffSetToBS = B.pack . ffSetToBS'+ffSetToBS = BL.pack . ffSetToBS' where ffSetToBS' :: FutureFlag a => Set a -> [Word8] ffSetToBS' ks@@ -422,12 +429,12 @@ | 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) = B.pack [0, fromIntegral . fromFVal $ hashalgo]+fromS2K (Simple hashalgo) = BL.pack [0, fromIntegral . fromFVal $ hashalgo] fromS2K (Salted hashalgo salt)- | B.length salt == 8 = B.pack [1, fromIntegral . fromFVal $ hashalgo] `B.append` 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 salt == 8 = B.pack [3, fromIntegral . fromFVal $ hashalgo] `B.append` salt `B.snoc` encodeIterationCount 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 @@ -466,15 +473,15 @@ | t == 1 = do ha <- getWord8 salt <- getByteString 8- return $ Salted (toFVal ha) salt+ return $ Salted (toFVal ha) (Salt salt) | t == 3 = do ha <- getWord8 salt <- getByteString 8 count <- getWord8- return $ IteratedSalted (toFVal ha) salt (decodeIterationCount count)+ return $ IteratedSalted (toFVal ha) (Salt salt) (decodeIterationCount count) | otherwise = do len <- remaining- bs <- getByteString len+ bs <- getLazyByteString len return $ OtherS2K t bs putS2K :: S2K -> Put@@ -483,9 +490,9 @@ putS2K (IteratedSalted ha salt count) = do putWord8 3 put ha- putByteString salt+ putByteString (unSalt salt) putWord8 $ encodeIterationCount count-putS2K (OtherS2K t bs) = putWord8 t >> putByteString bs+putS2K (OtherS2K t bs) = putWord8 t >> putLazyByteString bs getPacketTypeAndPayload :: Get (Word8, ByteString) getPacketTypeAndPayload = do@@ -496,122 +503,122 @@ let t = shiftR (tag .&. 0x3c) 2 case tag .&. 0x03 of 0 -> do len <- getWord8- bs <- getByteString (fromIntegral len)+ bs <- getLazyByteString (fromIntegral len) return (t, bs) 1 -> do len <- getWord16be- bs <- getByteString (fromIntegral len)+ bs <- getLazyByteString (fromIntegral len) return (t, bs) 2 -> do len <- getWord32be- bs <- getByteString (fromIntegral len)+ bs <- getLazyByteString (fromIntegral len) return (t, bs) 3 -> do len <- remaining- bs <- getByteString len+ bs <- getLazyByteString len return (t, bs) _ -> error "This should never happen (getPacketTypeAndPayload/0x00)." 0x40 -> do len <- fmap fromIntegral getPacketLength- bs <- getByteString len+ bs <- getLazyByteString len return (tag .&. 0x3f, bs) _ -> error "This should never happen (getPacketTypeAndPayload/???)." getPkt :: Get Pkt getPkt = do (t, pl) <- getPacketTypeAndPayload- case runGet (getPkt' t (B.length pl)) pl of- Left e -> return $! BrokenPacketPkt e t pl- Right p -> return p+ case runGetOrFail (getPkt' t (BL.length pl)) pl of+ Left (_, _, e) -> return $! BrokenPacketPkt e t pl+ Right (_, _, p) -> return p where- getPkt' :: Word8 -> Int -> Get Pkt+ getPkt' :: Word8 -> ByteOffset -> Get Pkt getPkt' t len | t == 1 = do pv <- getWord8- eokeyid <- getByteString 8+ eokeyid <- getLazyByteString 8 pkalgo <- getWord8 remainder <- remaining- mpib <- getBytes remainder- case runGet (many getMPI) mpib of- Left e -> fail ("PKESK MPIs " ++ e)- Right sk -> return $ PKESKPkt pv (EightOctetKeyId eokeyid) (toFVal pkalgo) sk+ mpib <- getLazyByteString remainder+ case runGetOrFail (some getMPI) mpib of+ Left (_, _, e) -> fail ("PKESK MPIs " ++ e)+ Right (_, _, sk) -> return $ PKESKPkt pv (EightOctetKeyId eokeyid) (toFVal pkalgo) (NE.fromList sk) | t == 2 = do remainder <- remaining- bs <- getBytes remainder- case runGet get bs of- Left e -> fail ("signature packet " ++ e)- Right sp -> return $ SignaturePkt sp+ bs <- getLazyByteString remainder+ 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 remainder <- remaining- esk <- getByteString remainder- return $ SKESKPkt pv (toFVal symalgo) s2k (if B.null esk then Nothing else Just esk)+ esk <- getLazyByteString remainder+ 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 <- getByteString 8+ skeyid <- getLazyByteString 8 nested <- getWord8 return $ OnePassSignaturePkt pv (toFVal sigtype) (toFVal ha) (toFVal pka) (EightOctetKeyId skeyid) (nested == 0) | t == 5 = do- bs <- getBytes len- let ps = flip runGet bs $ do pkp <- getPKPayload- ska <- getSKAddendum pkp- return $ SecretKeyPkt pkp ska+ 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+ Left (_, _, err) -> fail ("secret key " ++ err)+ Right (_, _, key) -> return key | t == 6 = do pkp <- getPKPayload return $ PublicKeyPkt pkp | t == 7 = do- bs <- getBytes len- let ps = flip runGet bs $ do pkp <- getPKPayload- ska <- getSKAddendum pkp- return $ SecretSubkeyPkt pkp ska+ 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+ Left (_, _, err) -> fail ("secret subkey " ++ err)+ Right (_, _, key) -> return key | t == 8 = do ca <- getWord8- cdata <- getByteString (len - 1)+ cdata <- getLazyByteString (len - 1) return $ CompressedDataPkt (toFVal ca) cdata | t == 9 = do- sdata <- getByteString len+ sdata <- getLazyByteString len return $ SymEncDataPkt sdata | t == 10 = do- marker <- getByteString len+ marker <- getLazyByteString len return $ MarkerPkt marker | t == 11 = do dt <- getWord8 flen <- getWord8- fn <- getByteString (fromIntegral flen)- ts <- getWord32be- ldata <- getByteString (len - (6 + fromIntegral flen))+ 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 <- getByteString len+ tdata <- getLazyByteString len return $ TrustPkt tdata | t == 13 = do- udata <- getBytes len- return . UserIdPkt . T.unpack . decodeUtf8With lenientDecode $ udata+ udata <- getByteString (fromIntegral len)+ return . UserIdPkt . decodeUtf8With lenientDecode $ udata | t == 14 = do pkp <- getPKPayload return $ PublicSubkeyPkt pkp | t == 17 = do- bs <- getBytes len- case runGet (many getUserAttrSubPacket) bs of- Left err -> fail ("user attribute " ++ err)- Right uas -> return $ UserAttributePkt uas+ 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 <- getByteString (len - 1)+ b <- getLazyByteString (len - 1) return $ SymEncIntegrityProtectedDataPkt pv b | t == 19 = do- hash <- getByteString 20+ hash <- getLazyByteString 20 return $ ModificationDetectionCodePkt hash | otherwise = do- payload <- getByteString len+ payload <- getLazyByteString len return $ OtherPacketPkt t payload getUserAttrSubPacket :: Get UserAttrSubPacket@@ -620,24 +627,24 @@ t <- getWord8 getUserAttrSubPacket' t l where- getUserAttrSubPacket' :: Word8 -> Int -> Get UserAttrSubPacket+ getUserAttrSubPacket' :: Word8 -> ByteOffset -> Get UserAttrSubPacket getUserAttrSubPacket' t l | t == 1 = do ihlen <- getWord16le hver <- getWord8 -- should be 1 iformat <- getWord8- nuls <- getBytes 12 -- should be NULs- bs <- getByteString (l - 17)- if hver /= 1 || nuls /= B.pack (replicate 12 0) then fail "Corrupt UAt subpacket" else return $ ImageAttribute (ImageHV1 (toFVal iformat)) bs+ 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 <- getByteString (l - 1)+ bs <- getLazyByteString (l - 1) return $ OtherUASub t bs putUserAttrSubPacket :: UserAttrSubPacket -> Put putUserAttrSubPacket ua = do let sp = runPut $ putUserAttrSubPacket' ua- putSubPacketLength . fromIntegral . B.length $ sp- putByteString sp+ putSubPacketLength . fromIntegral . BL.length $ sp+ putLazyByteString sp where putUserAttrSubPacket' (ImageAttribute (ImageHV1 iformat) idata) = do putWord8 1@@ -645,34 +652,34 @@ putWord8 1 putWord8 (fromFVal iformat) replicateM_ 12 $ putWord8 0- putByteString idata+ putLazyByteString idata putUserAttrSubPacket' (OtherUASub t bs) = do putWord8 t- putByteString bs+ putLazyByteString bs putPkt :: Pkt -> Put putPkt (PKESKPkt pv eokeyid pkalgo mpis) = do putWord8 (0xc0 .|. 1)- let bsk = runPut $ mapM_ put mpis- putPacketLength . fromIntegral $ 10 + B.length bsk+ let bsk = runPut $ F.mapM_ put mpis+ putPacketLength . fromIntegral $ 10 + BL.length bsk putWord8 pv -- must be 3- putByteString (unEOKI eokeyid) -- must be 8 octets+ putLazyByteString (unEOKI eokeyid) -- must be 8 octets putWord8 $ fromIntegral . fromFVal $ pkalgo- putByteString bsk+ putLazyByteString bsk putPkt (SignaturePkt sp) = do putWord8 (0xc0 .|. 2) let bs = runPut $ put sp- putPacketLength . fromIntegral . B.length $ bs- putByteString bs+ putPacketLength . fromIntegral . BL.length $ bs+ putLazyByteString bs putPkt (SKESKPkt pv symalgo s2k mesk) = do putWord8 (0xc0 .|. 3) let bs2k = fromS2K s2k- let bsk = fromMaybe B.empty mesk- putPacketLength . fromIntegral $ 2 + B.length bs2k + B.length bsk+ let bsk = fromMaybe BL.empty mesk+ putPacketLength . fromIntegral $ 2 + BL.length bs2k + BL.length bsk putWord8 pv -- should be 4 putWord8 $ fromIntegral . fromFVal $ symalgo- putByteString bs2k- putByteString bsk+ putLazyByteString bs2k+ putLazyByteString bsk putPkt (OnePassSignaturePkt pv sigtype ha pka skeyid nested) = do putWord8 (0xc0 .|. 4) let bs = runPut $ do@@ -680,106 +687,106 @@ putWord8 $ fromIntegral . fromFVal $ sigtype putWord8 $ fromIntegral . fromFVal $ ha putWord8 $ fromIntegral . fromFVal $ pka- putByteString (unEOKI skeyid)+ putLazyByteString (unEOKI skeyid) putWord8 . fromIntegral . fromEnum $ not nested -- FIXME: what do other values mean?- putPacketLength . fromIntegral $ B.length bs- putByteString bs+ putPacketLength . fromIntegral $ BL.length bs+ putLazyByteString bs putPkt (SecretKeyPkt pkp ska) = do putWord8 (0xc0 .|. 5) let bs = runPut (putPKPayload pkp >> putSKAddendum ska)- putPacketLength . fromIntegral $ B.length bs- putByteString bs+ putPacketLength . fromIntegral $ BL.length bs+ putLazyByteString bs putPkt (PublicKeyPkt pkp) = do putWord8 (0xc0 .|. 6) let bs = runPut $ putPKPayload pkp- putPacketLength . fromIntegral $ B.length bs- putByteString bs+ putPacketLength . fromIntegral $ BL.length bs+ putLazyByteString bs putPkt (SecretSubkeyPkt pkp ska) = do putWord8 (0xc0 .|. 7) let bs = runPut (putPKPayload pkp >> putSKAddendum ska)- putPacketLength . fromIntegral $ B.length bs- putByteString bs+ putPacketLength . fromIntegral $ BL.length bs+ putLazyByteString bs putPkt (CompressedDataPkt ca cdata) = do putWord8 (0xc0 .|. 8) let bs = runPut $ do putWord8 $ fromIntegral . fromFVal $ ca- putByteString cdata- putPacketLength . fromIntegral $ B.length bs- putByteString bs+ putLazyByteString cdata+ putPacketLength . fromIntegral $ BL.length bs+ putLazyByteString bs putPkt (SymEncDataPkt b) = do putWord8 (0xc0 .|. 9)- putPacketLength . fromIntegral $ B.length b- putByteString b+ putPacketLength . fromIntegral $ BL.length b+ putLazyByteString b putPkt (MarkerPkt b) = do putWord8 (0xc0 .|. 10)- putPacketLength . fromIntegral $ B.length b- putByteString b+ putPacketLength . fromIntegral $ BL.length b+ putLazyByteString b putPkt (LiteralDataPkt dt fn ts b) = do putWord8 (0xc0 .|. 11) let bs = runPut $ do putWord8 $ fromIntegral . fromFVal $ dt- putWord8 $ fromIntegral . B.length $ fn- putByteString fn- putWord32be ts- putByteString b- putPacketLength . fromIntegral $ B.length bs- putByteString bs+ putWord8 $ fromIntegral . BL.length $ fn+ putLazyByteString fn+ putWord32be . unThirtyTwoBitTimeStamp $ ts+ putLazyByteString b+ putPacketLength . fromIntegral $ BL.length bs+ putLazyByteString bs putPkt (TrustPkt b) = do putWord8 (0xc0 .|. 12)- putPacketLength . fromIntegral . B.length $ b- putByteString b+ putPacketLength . fromIntegral . BL.length $ b+ putLazyByteString b putPkt (UserIdPkt u) = do putWord8 (0xc0 .|. 13)- let bs = encodeUtf8 . T.pack $ u+ let bs = encodeUtf8 u putPacketLength . fromIntegral $ B.length bs putByteString bs putPkt (PublicSubkeyPkt pkp) = do putWord8 (0xc0 .|. 14) let bs = runPut $ putPKPayload pkp- putPacketLength . fromIntegral $ B.length bs- putByteString bs+ putPacketLength . fromIntegral $ BL.length bs+ putLazyByteString bs putPkt (UserAttributePkt us) = do putWord8 (0xc0 .|. 17) let bs = runPut $ mapM_ put us- putPacketLength . fromIntegral $ B.length bs- putByteString bs+ putPacketLength . fromIntegral $ BL.length bs+ putLazyByteString bs putPkt (SymEncIntegrityProtectedDataPkt pv b) = do putWord8 (0xc0 .|. 18)- putPacketLength . fromIntegral $ B.length b + 1+ putPacketLength . fromIntegral $ BL.length b + 1 putWord8 pv -- should be 1- putByteString b+ putLazyByteString b putPkt (ModificationDetectionCodePkt hash) = do putWord8 (0xc0 .|. 19)- putPacketLength . fromIntegral . B.length $ hash- putByteString hash+ putPacketLength . fromIntegral . BL.length $ hash+ putLazyByteString hash putPkt (OtherPacketPkt t payload) = do putWord8 (0xc0 .|. t) -- FIXME: restrict t- putPacketLength . fromIntegral . B.length $ payload- putByteString payload+ putPacketLength . fromIntegral . BL.length $ payload+ putLazyByteString payload putPkt (BrokenPacketPkt _ t payload) = putPkt (OtherPacketPkt t payload) getMPI :: Get MPI getMPI = do mpilen <- getWord16be- bs <- getByteString (fromIntegral (mpilen + 7) `div` 8)+ bs <- getLazyByteString (fromIntegral (mpilen + 7) `div` 8) return $ MPI (beBSToInteger bs) getPubkey :: PubKeyAlgorithm -> Get PKey getPubkey RSA = do MPI n <- get MPI e <- get- return $ RSAPubKey (R.PublicKey (B.length . integerToBEBS $ n) n e)+ return $ RSAPubKey (RSA_PublicKey (R.PublicKey (fromIntegral . BL.length . integerToBEBS $ 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 (D.PublicKey (D.Params p g q) y)+ 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 <$> (getByteString =<< remaining)+getPubkey _ = UnknownPKey <$> (getLazyByteString =<< remaining) putPubkey :: PKey -> Put putPubkey (UnknownPKey bs) = put bs@@ -796,28 +803,28 @@ dP = 0 dQ = 0 qinv = 0- pub = (\(RSAPubKey x) -> x) (pkp^.pubkey)- return $ RSAPrivateKey (R.PrivateKey pub d p q dP dQ qinv)+ 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 (D.PrivateKey (D.Params 0 0 0) x)+ 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 (R.PrivateKey _ d p q _ _ _)) = put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u)+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 = integerToBEBS i putWord16be . countBits $ bs- putByteString bs+ putLazyByteString bs getPKPayload :: Get PKPayload getPKPayload = do version <- getWord8- ctime <- getWord32be+ ctime <- fmap ThirtyTwoBitTimeStamp getWord32be if version `elem` [2,3] then do v3e <- getWord16be pka <- get@@ -831,13 +838,13 @@ putPKPayload :: PKPayload -> Put putPKPayload (PKPayload DeprecatedV3 ctime v3e pka pk) = do putWord8 3- putWord32be ctime+ putWord32be . unThirtyTwoBitTimeStamp $ ctime putWord16be v3e put pka putPubkey pk putPKPayload (PKPayload V4 ctime _ pka pk) = do putWord8 4- putWord32be ctime+ putWord32be . unThirtyTwoBitTimeStamp $ ctime put pka putPubkey pk @@ -851,33 +858,33 @@ 255 -> do symenc <- getWord8 s2k <- getS2K case s2k of -- FIXME: this is a mess- OtherS2K _ _ -> return $ SUS16bit (toFVal symenc) s2k B.empty B.empty+ OtherS2K _ _ -> return $ SUS16bit (toFVal symenc) s2k mempty BL.empty _ -> do iv <- getByteString (symEncBlockSize . toFVal $ symenc) remainder <- remaining- encryptedblock <- getByteString remainder- return $ SUS16bit (toFVal symenc) s2k iv encryptedblock+ encryptedblock <- getLazyByteString remainder+ 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 B.empty B.empty+ OtherS2K _ _ -> return $ SUSSHA1 (toFVal symenc) s2k mempty BL.empty _ -> do iv <- getByteString (symEncBlockSize . toFVal $ symenc) remainder <- remaining- encryptedblock <- getByteString remainder- return $ SUSSHA1 (toFVal symenc) s2k iv encryptedblock+ encryptedblock <- getLazyByteString remainder+ return $ SUSSHA1 (toFVal symenc) s2k (IV iv) encryptedblock symenc -> do iv <- getByteString (symEncBlockSize . toFVal $ symenc) remainder <- remaining- encryptedblock <- getByteString remainder- return $ SUSym (toFVal symenc) iv encryptedblock+ encryptedblock <- getLazyByteString remainder+ return $ SUSym (toFVal symenc) (IV iv) encryptedblock putSKAddendum :: SKAddendum -> Put putSKAddendum (SUSSHA1 symenc s2k iv encryptedblock) = do putWord8 254 put symenc put s2k- putByteString iv- putByteString encryptedblock+ putByteString (unIV iv)+ putLazyByteString encryptedblock putSKAddendum (SUUnencrypted sk checksum) = do putWord8 0 putSKey sk@@ -896,10 +903,10 @@ symEncBlockSize (Twofish) = 16 symEncBlockSize _ = 8 -- FIXME -decodeIterationCount :: Word8 -> Int-decodeIterationCount c = (16 + (fromIntegral c .&. 15)) `shiftL` ((fromIntegral c `shiftR` 4) + 6)+decodeIterationCount :: Word8 -> IterationCount+decodeIterationCount c = IterationCount ((16 + (fromIntegral c .&. 15)) `shiftL` ((fromIntegral c `shiftR` 4) + 6)) -encodeIterationCount :: Int -> Word8 -- should this really be a lookup table?+encodeIterationCount :: IterationCount -> Word8 -- should this really be a lookup table? encodeIterationCount 1024 = 0 encodeIterationCount 1088 = 1 encodeIterationCount 1152 = 2@@ -1166,39 +1173,39 @@ hashlen <- getWord8 guard (hashlen == 5) st <- getWord8- ctime <- getWord32be- eok <- getByteString 8+ ctime <- fmap ThirtyTwoBitTimeStamp getWord32be+ eok <- getLazyByteString 8 pka <- get ha <- get left16 <- getWord16be remainder <- remaining- mpib <- getBytes remainder- case runGet (many getMPI) mpib of- Left e -> fail ("v3 sig MPIs " ++ e)- Right mpis -> return $ SigV3 (toFVal st) ctime (EightOctetKeyId eok) (toFVal pka) (toFVal ha) left16 mpis+ mpib <- getLazyByteString remainder+ 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 <- getBytes (fromIntegral hlen)- let hashed = case runGet (many getSigSubPacket) hb of- Left err -> fail ("v4 sig hasheds " ++ err)- Right h -> h+ 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 <- getBytes (fromIntegral ulen)- let unhashed = case runGet (many getSigSubPacket) ub of- Left err -> fail ("v4 sig unhasheds " ++ err)- Right u -> u+ ub <- getLazyByteString (fromIntegral ulen)+ let unhashed = case runGetOrFail (many getSigSubPacket) ub of+ Left (_, _, err) -> fail ("v4 sig unhasheds " ++ err)+ Right (_, _, u) -> u left16 <- getWord16be remainder <- remaining- mpib <- getBytes remainder- case runGet (many getMPI) mpib of- Left e -> fail ("v4 sig MPIs " ++ e)- Right mpis -> return $ SigV4 (toFVal st) (toFVal pka) (toFVal ha) hashed unhashed left16 mpis+ mpib <- getLazyByteString remainder+ 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 remainder <- remaining- bs <- getByteString remainder+ bs <- getLazyByteString remainder return $ SigVOther pv bs putSignaturePayload :: SignaturePayload -> Put@@ -1206,28 +1213,28 @@ putWord8 3 putWord8 5 -- hashlen put st- putWord32be ctime- putByteString (unEOKI eok)+ putWord32be . unThirtyTwoBitTimeStamp $ ctime+ putLazyByteString (unEOKI eok) put pka put ha putWord16be left16- mapM_ put mpis+ 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 . B.length $ hb- putByteString hb+ putWord16be . fromIntegral . BL.length $ hb+ putLazyByteString hb let ub = runPut $ mapM_ put unhashed- putWord16be . fromIntegral . B.length $ ub- putByteString ub+ putWord16be . fromIntegral . BL.length $ ub+ putLazyByteString ub putWord16be left16- mapM_ put mpis+ F.mapM_ put mpis putSignaturePayload (SigVOther pv bs) = do putWord8 pv- putByteString bs+ putLazyByteString bs putTK :: TK -> Put putTK key = do@@ -1240,10 +1247,3 @@ 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---- Stolen from Axman6-many :: Get a -> Get [a]-many p = many1 p `mplus` return []--many1 :: Get a -> Get [a]-many1 p = (:) <$> p <*> many p
Codec/Encryption/OpenPGP/SerializeForSigs.hs view
@@ -1,5 +1,5 @@ -- SerializeForSigs.hs: OpenPGP (RFC4880) special serialization for signature purposes--- Copyright © 2012-2014 Clint Adams+-- Copyright © 2012-2015 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -16,11 +16,11 @@ ) where import Control.Lens ((^.))-import Data.ByteString (ByteString)+import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString as B-import Data.Serialize (Serialize, put)-import Data.Serialize.Put (Put, putWord8, putWord16be, putWord32be, putByteString, runPut)-import qualified Data.Text as T+import qualified Data.ByteString.Lazy as BL+import Data.Binary (Binary, put)+import Data.Binary.Put (Put, putWord8, putWord16be, putWord32be, putByteString, putLazyByteString, runPut) import Data.Text.Encoding (encodeUtf8) import Codec.Encryption.OpenPGP.Internal (PktStreamContext(..), integerToBEBS, pubkeyToMPIs)@@ -32,12 +32,12 @@ putPKPforFingerprinting (PublicKeyPkt pkp@(PKPayload V4 _ _ _ _)) = do putWord8 0x99 let bs = runPut $ put pkp- putWord16be . fromIntegral $ B.length bs- putByteString bs+ putWord16be . fromIntegral $ BL.length bs+ putLazyByteString bs putPKPforFingerprinting _ = fail "This should never happen (putPKPforFingerprinting)" putMPIforFingerprinting:: MPI -> Put-putMPIforFingerprinting(MPI i) = let bs = integerToBEBS i in putByteString bs+putMPIforFingerprinting(MPI i) = let bs = integerToBEBS i in putLazyByteString bs putPartialSigforSigning :: Pkt -> Put putPartialSigforSigning (SignaturePkt (SigV4 st pka ha hashed _ _ _)) = do@@ -46,15 +46,15 @@ put pka put ha let hb = runPut $ mapM_ put hashed- putWord16be . fromIntegral . B.length $ hb- putByteString hb+ 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) . B.length $ runPut $ mapM_ put hs+ putWord32be . fromIntegral . (+6) . BL.length $ runPut $ mapM_ put hs -- this +6 seems like a bug in RFC4880 putSigTrailer _ = fail "This should never happen (putSigTrailer)" @@ -66,7 +66,7 @@ putUIDforSigning :: Pkt -> Put putUIDforSigning (UserIdPkt u) = do putWord8 0xB4- let bs = encodeUtf8 . T.pack $ u+ let bs = encodeUtf8 u putWord32be . fromIntegral . B.length $ bs putByteString bs putUIDforSigning _ = fail "This should never happen (putUIDforSigning)"@@ -75,16 +75,16 @@ putUAtforSigning (UserAttributePkt us) = do putWord8 0xD1 let bs = runPut (mapM_ put us)- putWord32be . fromIntegral . B.length $ bs- putByteString bs+ 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 . B.length $ bs- putByteString bs+ putWord32be . fromIntegral . BL.length $ bs+ putLazyByteString bs putSigforSigning _ = fail "Non-V4 not implemented." putKeyforSigning :: Pkt -> Put@@ -98,13 +98,13 @@ putKeyForSigning' pkp = do putWord8 0x99 let bs = runPut $ put pkp- putWord16be . fromIntegral . B.length $ bs- putByteString bs+ 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 _ = B.empty+payloadForSig StandaloneSig _ = BL.empty payloadForSig GenericCert state = kandUPayload (lastPrimaryKey state) (lastUIDorUAt state) payloadForSig PersonaCert state = payloadForSig GenericCert state payloadForSig CasualCert state = payloadForSig GenericCert state
Codec/Encryption/OpenPGP/Signatures.hs view
@@ -1,5 +1,5 @@ -- Signatures.hs: OpenPGP (RFC4880) signature verification--- Copyright © 2012-2014 Clint Adams+-- Copyright © 2012-2015 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -19,14 +19,17 @@ import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.RSA.PKCS15 as P15 -import Data.ByteString (ByteString)+import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL import Data.Either (lefts, rights) import Data.IxSet ((@=)) import qualified Data.IxSet 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.Serialize.Put (runPut)+import Data.Binary.Put (runPut) import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) import Codec.Encryption.OpenPGP.Internal (countBits, integerToBEBS, PktStreamContext(..), issuer, emptyPSC, hashDescr)@@ -58,7 +61,7 @@ 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 :: [(String, [SignaturePayload])] -> [(String, [SignaturePayload])]+ 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))@@ -71,13 +74,11 @@ 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+ 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]- _ -> []- isKeyRevocation (SigV4 KeyRevocationSig _ _ _ _ _ _) = True- isKeyRevocation _ = False+ _ -> [] isSubkeyRevocation (SigV4 SubkeyRevocationSig _ _ _ _ _ _) = True isSubkeyRevocation _ = False isSubkeyBindingSig (SigV4 SubkeyBindingSig _ _ _ _ _ _) = True@@ -88,7 +89,7 @@ isRevocationKeySSP _ = False isIssuerSSP (SigSubPacket _ (Issuer _)) = True isIssuerSSP _ = False- vUid :: (String, SignaturePayload) -> Either String Verification+ 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@@ -97,7 +98,7 @@ 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+ Right _ -> True verifyRevoker :: SignaturePayload -> Either String [(PubKeyAlgorithm, TwentyOctetFingerprint)] verifyRevoker sp = do _ <- vSig sp@@ -112,47 +113,46 @@ 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) (finalPayload sig payload)) allrelevantpkps+ 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+ 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- verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ pkey)) ha pl = verify'' (pkaAndMPIs s) ha pub pkey pl+ subPKP' _ = error "This should never happen (subPKP')"+ verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ pkey)) ha pl = hashDescr ha >>= \hd -> verify'' (pkaAndMPIs s) hd pub pkey pl verify' _ _ _ _ = error "This should never happen (verify')."- verify'' (DSA,mpis) ha pub (DSAPubKey pkey) bs = verify''' (dsaVerify mpis (hashDescr ha) pkey bs) pub- verify'' (RSA,mpis) ha pub (RSAPubKey pkey) bs = verify''' (rsaVerify mpis (hashDescr ha) pkey bs) pub+ 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:[]) (Right hd) pkey = DSA.verify (dsaTruncate pkey . hashFunction hd) pkey (dsaMPIsToSig r s)- dsaVerify _ (Right _) _ = const False -- FIXME: this should be some sort of Either chain- dsaVerify _ (Left _) _ = const False -- FIXME: this should be some sort of Either chain- rsaVerify mpis (Right hd) pkey bs = P15.verify hd pkey bs (rsaMPItoSig mpis)- rsaVerify _ (Left _) _ _ = False -- FIXME: this should be some sort of Either chain+ verify''' f pub = if f then Right pub else Left "verification failed"+ dsaVerify (r:|[s]) hd pkey = DSA.verify (dsaTruncate pkey . hashFunction hd) pkey (dsaMPIsToSig r s)+ dsaVerify _ _ _ = const False -- FIXME: this should be some sort of Either chain?+ rsaVerify mpis hd pkey bs = P15.verify hd pkey bs (BL.toStrict (rsaMPItoSig mpis)) dsaMPIsToSig r s = DSA.Signature (unMPI r) (unMPI s)- rsaMPItoSig mpis = integerToBEBS (unMPI (head mpis))+ rsaMPItoSig (sig:|[]) = integerToBEBS (unMPI sig) hashalgo :: Pkt -> HashAlgorithm hashalgo (SignaturePkt (SigV4 _ _ ha _ _ _ _)) = ha hashalgo _ = error "This should never happen (hashalgo)."- dsaTruncate pkey bs = if countBits bs > dsaQLen pkey then B.take (fromIntegral (dsaQLen pkey) `div` 8) bs else bs -- FIXME: uneven bits+ dsaTruncate pkey bs = let lbs = BL.fromStrict bs in if countBits lbs > dsaQLen pkey then B.take (fromIntegral (dsaQLen pkey) `div` 8) bs else bs -- FIXME: uneven bits dsaQLen = countBits . integerToBEBS . DSA.params_q . DSA.public_params- pkaAndMPIs (SigV4 _ pka _ _ _ _ mpis) = (pka,mpis)- pkaAndMPIs _ = error "This should never happen (pkaAndMPIs)."+ pkaAndMPIs (SigV4 _ pka _ _ _ _ mpis) = (pka,mpis)+ pkaAndMPIs _ = error "This should never happen (pkaAndMPIs)." isSignatureExpired :: Pkt -> Maybe UTCTime -> Either String Bool- isSignatureExpired s Nothing = return False+ 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 = B.concat [pl, sigbit s, trailer s]+finalPayload s pl = BL.concat [pl, sigbit, trailer s] where- sigbit s = runPut $ putPartialSigforSigning s+ sigbit = runPut $ putPartialSigforSigning s trailer :: Pkt -> ByteString- trailer s@(SignaturePkt (SigV4 {})) = runPut $ putSigTrailer s- trailer _ = B.empty+ trailer (SignaturePkt (SigV4 {})) = runPut $ putSigTrailer s+ trailer _ = BL.empty
Codec/Encryption/OpenPGP/Types.hs view
@@ -1,9 +1,15 @@ -- Types.hs: OpenPGP (RFC4880) data types--- Copyright © 2012-2014 Clint Adams+-- Copyright © 2012-2015 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, ExistentialQuantification, TemplateHaskell, TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} module Codec.Encryption.OpenPGP.Types where @@ -11,46 +17,55 @@ import Control.Arrow ((***)) import Control.Lens (makeLenses)+import Control.Newtype (Newtype(..)) import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.DSA as DSA-import Data.ByteString (ByteString)+import qualified Crypto.PubKey.ECC.ECDSA as ECDSA+import Data.Aeson ((.=), object)+import qualified Data.Aeson as A+import Data.Byteable (Byteable)+import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL import Data.Char (toLower, toUpper) import Data.Data (Data) import Data.Hashable (Hashable(..)) import Data.IxSet (IxSet)-import Data.List (intercalate)+import Data.List (unfoldr)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NE import Data.List.Split (chunksOf)-import Data.Monoid ((<>))+import Data.Monoid ((<>), Monoid, mempty) 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) import Numeric (readHex, showHex)-import Text.PrettyPrint.ANSI.Leijen (Pretty(..), (<+>), hsep, space, text)+import System.Locale (defaultTimeLocale)+import Text.PrettyPrint.Free (Pretty(..), (<+>), char, hsep, punctuate, space, text, tupled) -type TimeStamp = Word32 type Exportability = Bool type TrustLevel = Word8 type TrustAmount = Word8 type AlmostPublicDomainRegex = ByteString type Revocability = Bool-type RevocationReason = ByteString+type RevocationReason = Text type KeyServer = ByteString-type URL = ByteString type NotationName = ByteString type NotationValue = ByteString type SignatureHash = ByteString type PacketVersion = Word8-type Salt = ByteString-type Count = Int type V3Expiration = Word16 type CompressedDataPayload = ByteString type FileName = ByteString type ImageData = ByteString type NestedFlag = Bool-type IV = ByteString data SymmetricAlgorithm = Plaintext | IDEA@@ -100,6 +115,22 @@ 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 (OtherSA sa) = text "unknown symmetric algorithm" <+> (text . show) sa++instance A.ToJSON SymmetricAlgorithm+ data NotationFlag = HumanReadable | OtherNF Word8 -- FIXME: this should be constrained to 4 bits? deriving (Data, Generic, Show, Typeable)@@ -119,23 +150,79 @@ instance Hashable NotationFlag +instance Pretty NotationFlag where+ pretty HumanReadable = text "human-readable"+ pretty (OtherNF o) = text "unknown notation flag type" <+> pretty o++instance A.ToJSON NotationFlag+ data SigSubPacket = SigSubPacket { _sspCriticality :: Bool , _sspPayload :: SigSubPacketPayload- } deriving (Data, Eq, Generic, Typeable)+ } deriving (Data, Eq, Generic, Show, Typeable) -instance Show SigSubPacket where- show x = (if _sspCriticality x then "*" else "") ++ (show . _sspPayload) x+instance Pretty SigSubPacket where+ pretty x = (if _sspCriticality x then char '*' else mempty) <> (pretty . _sspPayload) x instance Hashable SigSubPacket -data SigSubPacketPayload = SigCreationTime TimeStamp- | SigExpirationTime TimeStamp+instance A.ToJSON SigSubPacket++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++instance A.ToJSON ThirtyTwoBitTimeStamp++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++instance A.ToJSON ThirtyTwoBitDuration++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 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 = A.toJSON . (\uri -> uriToString id uri "") . unpack++data SigSubPacketPayload = SigCreationTime ThirtyTwoBitTimeStamp+ | SigExpirationTime ThirtyTwoBitDuration | ExportableCertification Exportability | TrustSignature TrustLevel TrustAmount | RegularExpression AlmostPublicDomainRegex | Revocable Revocability- | KeyExpirationTime TimeStamp+ | KeyExpirationTime ThirtyTwoBitDuration | PreferredSymmetricAlgorithms [SymmetricAlgorithm] | RevocationKey (Set RevocationClass) PubKeyAlgorithm TwentyOctetFingerprint | Issuer EightOctetKeyId@@ -147,7 +234,7 @@ | PrimaryUserId Bool | PolicyURL URL | KeyFlags (Set KeyFlag)- | SignersUserId String+ | SignersUserId Text | ReasonForRevocation RevocationCode RevocationReason | Features (Set FeatureFlag) | SignatureTarget PubKeyAlgorithm HashAlgorithm SignatureHash@@ -158,6 +245,60 @@ 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" <+> prettyList sas+ pretty (RevocationKey rcs pka tof) = text "revocation key" <+> prettyList (Set.toList rcs) <+> pretty pka <+> pretty tof+ pretty (Issuer eoki) = text "issuer" <+> pretty eoki+ pretty (NotationData nfs nn nv) = text "notation data" <+> prettyList (Set.toList nfs) <+> pretty nn <+> pretty nv+ pretty (PreferredHashAlgorithms phas) = text "preferred hash algorithms" <+> prettyList phas+ pretty (PreferredCompressionAlgorithms pcas) = text "preferred compression algorithms" <+> pretty pcas+ pretty (KeyServerPreferences kspfs) = text "keyserver preferences" <+> prettyList (Set.toList kspfs)+ pretty (PreferredKeyServer ks) = text "preferred keyserver" <+> pretty ks+ pretty (PrimaryUserId p) = (if p then mempty else text "NOT ") <> text "primary user-ID"+ pretty (PolicyURL u) = text "policy URL" <+> pretty u+ pretty (KeyFlags kfs) = text "key flags" <+> prettyList (Set.toList kfs)+ pretty (SignersUserId u) = text "signer's user-ID" <+> pretty u+ pretty (ReasonForRevocation rc rr) = text "reason for revocation" <+> pretty rc <+> pretty rr+ pretty (Features ffs) = text "features" <+> prettyList (Set.toList ffs)+ pretty (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) = A.toJSON ts+ toJSON (SigExpirationTime d) = A.toJSON d+ toJSON (ExportableCertification e) = A.toJSON e+ toJSON (TrustSignature tl ta) = A.toJSON (tl, ta)+ toJSON (RegularExpression apdre) = A.toJSON (BL.unpack apdre)+ toJSON (Revocable r) = A.toJSON r+ toJSON (KeyExpirationTime d) = A.toJSON d+ toJSON (PreferredSymmetricAlgorithms sas) = A.toJSON sas+ toJSON (RevocationKey rcs pka tof) = A.toJSON (rcs, pka, tof)+ toJSON (Issuer eoki) = A.toJSON eoki+ toJSON (NotationData nfs nn nv) = A.toJSON (nfs, BL.unpack nn, BL.unpack nv)+ toJSON (PreferredHashAlgorithms phas) = A.toJSON phas+ toJSON (PreferredCompressionAlgorithms pcas) = A.toJSON pcas+ toJSON (KeyServerPreferences kspfs) = A.toJSON kspfs+ toJSON (PreferredKeyServer ks) = A.toJSON (show ks)+ toJSON (PrimaryUserId p) = A.toJSON p+ toJSON (PolicyURL u) = A.toJSON u+ toJSON (KeyFlags kfs) = A.toJSON kfs+ toJSON (SignersUserId u) = A.toJSON u+ toJSON (ReasonForRevocation rc rr) = A.toJSON (rc, rr)+ toJSON (Features ffs) = A.toJSON ffs+ toJSON (SignatureTarget pka ha sh) = A.toJSON (pka, ha, BL.unpack sh)+ toJSON (EmbeddedSignature sp) = A.toJSON sp+ toJSON (UserDefinedSigSub t bs) = A.toJSON (t, BL.unpack bs)+ toJSON (OtherSigSub t bs) = A.toJSON (t, BL.unpack bs)+ data HashAlgorithm = DeprecatedMD5 | SHA1 | RIPEMD160@@ -194,6 +335,18 @@ 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" <+> (text . show) ha++instance A.ToJSON HashAlgorithm+ data CompressionAlgorithm = Uncompressed | ZIP | ZLIB@@ -221,6 +374,15 @@ 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" <+> (text . show) ca++instance A.ToJSON CompressionAlgorithm+ class (Eq a, Ord a) => FutureVal a where fromFVal :: a -> Word8 toFVal :: Word8 -> a@@ -267,6 +429,20 @@ 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 pka = text "unknown pubkey algorithm type" <+> (text . show) pka++instance A.ToJSON PubKeyAlgorithm+ class (Eq a, Ord a) => FutureFlag a where fromFFlag :: a -> Int toFFlag :: Int -> a@@ -290,6 +466,12 @@ instance Hashable KSPFlag +instance Pretty KSPFlag where+ pretty NoModify = text "no-modify"+ pretty (KSPOther o) = text "unknown keyserver preference flag type" <+> pretty o++instance A.ToJSON KSPFlag+ data KeyFlag = GroupKey | AuthKey | SplitKey@@ -327,6 +509,18 @@ instance Hashable KeyFlag +instance Pretty KeyFlag where+ pretty GroupKey = text "group key"+ pretty AuthKey = text "auth key"+ pretty SplitKey = text "split key"+ pretty EncryptStorageKey = text "encrypt-storage key"+ pretty EncryptCommunicationsKey = text "encrypt-communications key"+ pretty SignDataKey = text "sign-data key"+ pretty CertifyKeysKey = text "certify-keys key"+ pretty (KFOther o) = text "unknown key flag type" <+> pretty o++instance A.ToJSON KeyFlag+ data RevocationClass = SensitiveRK | RClOther Word8 -- FIXME: this should be constrained to 3 bits deriving (Data, Generic, Show, Typeable)@@ -346,6 +540,12 @@ instance Hashable RevocationClass +instance Pretty RevocationClass where+ pretty SensitiveRK = text "sensitive"+ pretty (RClOther o) = text "unknown revocation class" <+> pretty o++instance A.ToJSON RevocationClass+ data RevocationCode = NoReason | KeySuperseded | KeyMaterialCompromised@@ -376,6 +576,16 @@ 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++instance A.ToJSON RevocationCode+ data FeatureFlag = ModificationDetection | FeatureOther Int deriving (Data, Generic, Show, Typeable)@@ -397,26 +607,57 @@ 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++instance A.ToJSON FeatureFlag+ 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 -data SignaturePayload = SigV3 SigType Word32 EightOctetKeyId PubKeyAlgorithm HashAlgorithm Word16 [MPI]- | SigV4 SigType PubKeyAlgorithm HashAlgorithm [SigSubPacket] [SigSubPacket] Word16 [MPI]+instance Pretty MPI where+ pretty = pretty . unpack++instance A.ToJSON 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) -- FIXME+ 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 <+> (prettyList . NE.toList) mpis+ pretty (SigV4 st pka ha hsps usps w16 mpis) = text "signature v4" <> char ':' <+> pretty st <+> pretty pka <+> pretty ha <+> prettyList hsps <+> prettyList usps <+> pretty w16 <+> (prettyList . NE.toList) mpis+ pretty (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 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"++instance A.ToJSON KeyVersion+ data PKPayload = PKPayload { _keyVersion :: KeyVersion- , _timestamp :: TimeStamp+ , _timestamp :: ThirtyTwoBitTimeStamp , _v3exp :: V3Expiration , _pkalgo :: PubKeyAlgorithm , _pubkey :: PKey@@ -427,6 +668,24 @@ instance Hashable PKPayload +instance Pretty PKPayload where+ pretty (PKPayload kv ts v3e pka p) = pretty kv <+> pretty ts <+> pretty v3e <+> pretty pka <+> pretty p++instance A.ToJSON PKPayload++newtype IV = IV {unIV :: B.ByteString}+ deriving (Byteable, 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 . unpack++instance A.ToJSON IV where+ toJSON = A.toJSON . show . unpack+ data SKAddendum = SUS16bit SymmetricAlgorithm S2K IV ByteString | SUSSHA1 SymmetricAlgorithm S2K IV ByteString | SUSym SymmetricAlgorithm IV ByteString@@ -438,6 +697,18 @@ instance Hashable SKAddendum +instance Pretty SKAddendum where+ pretty (SUS16bit sa s2k iv bs) = text "SUS16bit" <+> pretty sa <+> pretty s2k <+> pretty iv <+> pretty bs+ pretty (SUSSHA1 sa s2k iv bs) = text "SUSSHA1" <+> pretty sa <+> pretty s2k <+> pretty iv <+> pretty bs+ pretty (SUSym sa iv bs) = text "SUSym" <+> pretty sa <+> pretty iv <+> pretty 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)+ data DataType = BinaryData | TextData | UTF8Data@@ -463,17 +734,62 @@ 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 " <+> (text . show) o++instance A.ToJSON 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 . 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++instance A.ToJSON IterationCount+ data S2K = Simple HashAlgorithm | Salted HashAlgorithm Salt- | IteratedSalted HashAlgorithm Salt Count+ | IteratedSalted HashAlgorithm Salt IterationCount | OtherS2K Word8 ByteString- deriving (Data, Eq, Generic, Show, Typeable) -- FIXME+ 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 "simple S2K," <+> pretty ha <+> pretty salt+ pretty (IteratedSalted ha salt icount) = text "simple S2K," <+> pretty ha <+> pretty salt <+> pretty icount+ pretty (OtherS2K t bs) = text "unknown S2K type" <+> pretty t <+> pretty 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 UserAttrSubPacket = ImageAttribute ImageHeader ImageData | OtherUASub Word8 ByteString- deriving (Data, Eq, Generic, Show, Typeable) -- FIXME+ deriving (Data, Eq, Generic, Show, Typeable) instance Hashable UserAttrSubPacket @@ -483,6 +799,14 @@ 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" <> (text . show) 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 ImageHeader = ImageHV1 ImageFormat deriving (Data, Eq, Generic, Show, Typeable) @@ -491,6 +815,11 @@ instance Hashable ImageHeader +instance Pretty ImageHeader where+ pretty (ImageHV1 f) = text "imghdr v1" <+> pretty f++instance A.ToJSON ImageHeader+ data ImageFormat = JPEG | OtherImage Word8 deriving (Data, Generic, Show, Typeable)@@ -510,6 +839,12 @@ instance Hashable ImageFormat +instance Pretty ImageFormat where+ pretty JPEG = text "JPEG"+ pretty (OtherImage o) = text "unknown image format" <+> pretty o++instance A.ToJSON ImageFormat+ data SigType = BinarySig | CanonicalTextSig | StandaloneSig@@ -571,71 +906,199 @@ instance Hashable SigType -instance Ord DSA.PublicKey-instance Ord RSA.PublicKey-instance Ord DSA.PrivateKey-instance Ord RSA.PrivateKey+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 -instance Hashable DSA.Params where- hashWithSalt s (DSA.Params p g q) = s `hashWithSalt` p `hashWithSalt` g `hashWithSalt` q-instance Hashable DSA.PublicKey where- hashWithSalt s (DSA.PublicKey p y) = s `hashWithSalt` p `hashWithSalt` y-instance Hashable DSA.PrivateKey where- hashWithSalt s (DSA.PrivateKey p x) = s `hashWithSalt` p `hashWithSalt` x-instance Hashable RSA.PublicKey where- hashWithSalt s (RSA.PublicKey size n e) = s `hashWithSalt` size `hashWithSalt` n `hashWithSalt` e-instance Hashable RSA.PrivateKey where- hashWithSalt s (RSA.PrivateKey pub d p q dP dQ qinv) = s `hashWithSalt` pub `hashWithSalt` d `hashWithSalt` p `hashWithSalt` q `hashWithSalt` dP `hashWithSalt` dQ `hashWithSalt` qinv+instance A.ToJSON SigType -data PKey = RSAPubKey RSA.PublicKey- | DSAPubKey DSA.PublicKey+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++data ECCCurve = BrokenNISTP256+ | BrokenNISTP384+ | BrokenNISTP521+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++instance Hashable ECCCurve++data PKey = RSAPubKey RSA_PublicKey+ | DSAPubKey DSA_PublicKey | ElGamalPubKey [Integer]- | UnknownPKey ByteString+ | ECDHPubKey ECDSA_PublicKey HashAlgorithm SymmetricAlgorithm+ | ECDSAPubKey ECDSA_PublicKey+ | UnknownPKey ByteString deriving (Data, Eq, Generic, Ord, Show, Typeable) instance Hashable PKey -data SKey = RSAPrivateKey RSA.PrivateKey- | DSAPrivateKey DSA.PrivateKey+instance Pretty PKey where+ pretty (RSAPubKey p) = text "RSA" <+> pretty p+ pretty (DSAPubKey p) = text "DSA" <+> pretty p+ pretty (ElGamalPubKey p) = text "Elgamal" <+> pretty p+ pretty (ECDHPubKey p ha sa) = text "ECDH" <+> pretty p <+> pretty ha <+> pretty sa+ pretty (ECDSAPubKey p) = text "ECDSA" <+> pretty p+ pretty (UnknownPKey bs) = text "unknown" <+> pretty bs++instance A.ToJSON PKey where+ toJSON (RSAPubKey p) = A.toJSON p+ toJSON (DSAPubKey p) = A.toJSON p+ toJSON (ElGamalPubKey p) = A.toJSON p+ 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]- | UnknownSKey ByteString+ | 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 "unknown" <+> pretty 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)+ newtype Block a = Block {unBlock :: [a]} -- so we can override cereal instance deriving (Show, Eq) newtype EightOctetKeyId = EightOctetKeyId {unEOKI :: ByteString}- deriving (Eq, Ord, Data, Generic, Typeable) -- FIXME+ deriving (Data, Eq, Generic, Ord, Show, Typeable) -instance Show EightOctetKeyId where- show = w8sToHex . B.unpack . unEOKI+instance Newtype EightOctetKeyId ByteString where+ pack = EightOctetKeyId+ unpack (EightOctetKeyId o) = o +instance Pretty EightOctetKeyId where+ pretty = text . w8sToHex . BL.unpack . unpack++-- FIXME: read-show instance Read EightOctetKeyId where- readsPrec _ = map ((EightOctetKeyId . B.pack *** concat) . unzip) . chunksOf 8 . hexToW8s+ readsPrec _ = map ((EightOctetKeyId . BL.pack *** concat) . unzip) . chunksOf 8 . hexToW8s instance Hashable EightOctetKeyId +instance A.ToJSON EightOctetKeyId where+ toJSON = A.toJSON . w8sToHex . BL.unpack . unpack+ newtype TwentyOctetFingerprint = TwentyOctetFingerprint {unTOF :: ByteString}- deriving (Data, Eq, Generic, Ord, Typeable)+ deriving (Data, Eq, Generic, Ord, Show, Typeable) -instance Show TwentyOctetFingerprint where- show = w8sToHex . B.unpack . unTOF+instance Newtype TwentyOctetFingerprint ByteString where+ pack = TwentyOctetFingerprint+ unpack (TwentyOctetFingerprint o) = o +-- FIXME: read-show instance Read TwentyOctetFingerprint where- readsPrec _ = map ((TwentyOctetFingerprint . B.pack *** concat) . unzip) . chunksOf 20 . hexToW8s . filter (/= ' ')+ readsPrec _ = map ((TwentyOctetFingerprint . BL.pack *** concat) . unzip) . chunksOf 20 . hexToW8s . filter (/= ' ') instance Hashable TwentyOctetFingerprint instance Pretty TwentyOctetFingerprint where- pretty = hsep . intercalate [space] . chunksOf 5 . map text . chunksOf 4 . take 40 . w8sToHex . B.unpack . unTOF+ pretty = text . take 40 . w8sToHex . BL.unpack . unTOF +instance A.ToJSON TwentyOctetFingerprint where+ toJSON = A.toJSON . show . pretty+ newtype SpacedFingerprint = SpacedFingerprint { unSpacedFingerprint :: TwentyOctetFingerprint } -instance Show SpacedFingerprint where- show = take 50 . concatMap (++" ") . concatMap (++[""]) . chunksOf 5 . chunksOf 4 . show . unSpacedFingerprint+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 . w8sToHex . BL.unpack . unTOF . unpack+ w8sToHex :: [Word8] -> String w8sToHex = map toUpper . concatMap ((\x -> if length x == 1 then '0':x else x) . flip showHex "") @@ -645,7 +1108,7 @@ data TK = TK { _tkKey :: (PKPayload, Maybe SKAddendum) , _tkRevs :: [SignaturePayload]- , _tkUIDs :: [(String, [SignaturePayload])]+ , _tkUIDs :: [(Text, [SignaturePayload])] , _tkUAts :: [([UserAttrSubPacket], [SignaturePayload])] , _tkSubs :: [(Pkt, [SignaturePayload])] } deriving (Data, Eq, Show, Typeable)@@ -663,9 +1126,9 @@ fromPkt :: Pkt -> a -- data Pkt = forall a. (Packet a, Show a, Eq a) => Pkt a-data Pkt = PKESKPkt PacketVersion EightOctetKeyId PubKeyAlgorithm [MPI]+data Pkt = PKESKPkt PacketVersion EightOctetKeyId PubKeyAlgorithm (NonEmpty MPI) | SignaturePkt SignaturePayload- | SKESKPkt PacketVersion SymmetricAlgorithm S2K (Maybe B.ByteString)+ | SKESKPkt PacketVersion SymmetricAlgorithm S2K (Maybe BL.ByteString) | OnePassSignaturePkt PacketVersion SigType HashAlgorithm PubKeyAlgorithm EightOctetKeyId NestedFlag | SecretKeyPkt PKPayload SKAddendum | PublicKeyPkt PKPayload@@ -673,9 +1136,9 @@ | CompressedDataPkt CompressionAlgorithm CompressedDataPayload | SymEncDataPkt ByteString | MarkerPkt ByteString- | LiteralDataPkt DataType FileName TimeStamp ByteString+ | LiteralDataPkt DataType FileName ThirtyTwoBitTimeStamp ByteString | TrustPkt ByteString- | UserIdPkt String+ | UserIdPkt Text | PublicSubkeyPkt PKPayload | UserAttributePkt [UserAttrSubPacket] | SymEncIntegrityProtectedDataPkt PacketVersion ByteString@@ -689,6 +1152,48 @@ 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" <> (text . show) pv <> char ':' <+> pretty eoki <+> pretty pka <+> (prettyList . NE.toList) mpis+ pretty (SignaturePkt sp) = pretty sp+ pretty (SKESKPkt pv sa s2k mbs) = text "SKESK v" <> (text . show) pv <> char ':' <+> pretty sa <+> pretty s2k <+> pretty mbs+ pretty (OnePassSignaturePkt pv st ha pka eoki nestedflag) = text "one-pass signature v" <> (text . show) pv <> char ':' <+> pretty st <+> pretty ha <+> pretty pka <+> pretty eoki <+> pretty nestedflag+ pretty (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 bs+ pretty (MarkerPkt bs) = text "marker:" <+> pretty bs+ pretty (LiteralDataPkt dt fn ts bs) = text "literal-data" <+> pretty dt <+> pretty fn <+> pretty ts <+> pretty 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:" <+> prettyList us+ pretty (SymEncIntegrityProtectedDataPkt pv bs) = text "symmetrically-encrypted-integrity-protected-data v" <> (text . show) pv <> char ':' <+> pretty bs+ pretty (ModificationDetectionCodePkt bs) = text "MDC:" <+> pretty bs+ pretty (OtherPacketPkt t bs) = text "unknown packet type" <+> pretty t <> char ':' <+> pretty bs+ pretty (BrokenPacketPkt s t bs) = text "BROKEN packet (" <> pretty s <> char ')' <+> pretty t <> char ':' <+> pretty bs++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@@ -713,7 +1218,7 @@ { _pkeskPacketVersion :: PacketVersion , _pkeskEightOctetKeyId :: EightOctetKeyId , _pkeskPubKeyAlgorithm :: PubKeyAlgorithm- , _pkeskMPIs :: [MPI]+ , _pkeskMPIs :: (NonEmpty MPI) } deriving (Data, Eq, Show, Typeable) instance Packet PKESK where data PacketType PKESK = PKESKType deriving (Show, Eq)@@ -722,6 +1227,9 @@ toPkt (PKESK a b c d) = PKESKPkt a b c d fromPkt (PKESKPkt a b c d) = PKESK a b c d +instance Pretty PKESK where+ pretty = pretty . toPkt+ data Signature = Signature -- FIXME? { _signaturePayload :: SignaturePayload } deriving (Data, Eq, Show, Typeable)@@ -732,11 +1240,14 @@ toPkt (Signature a ) = SignaturePkt a fromPkt (SignaturePkt a) = Signature a +instance Pretty Signature where+ pretty = pretty . toPkt+ data SKESK = SKESK { _skeskPacketVersion :: PacketVersion , _skeskSymmetricAlgorithm :: SymmetricAlgorithm , _skeskS2K :: S2K- , _skeskESK :: Maybe B.ByteString+ , _skeskESK :: Maybe BL.ByteString } deriving (Data, Eq, Show, Typeable) instance Packet SKESK where data PacketType SKESK = SKESKType deriving (Show, Eq)@@ -745,6 +1256,9 @@ toPkt (SKESK a b c d) = SKESKPkt a b c d fromPkt (SKESKPkt a b c d) = SKESK a b c d +instance Pretty SKESK where+ pretty = pretty . toPkt+ data OnePassSignature = OnePassSignature { _onePassSignaturePacketVersion :: PacketVersion , _onePassSignatureSigType :: SigType@@ -760,6 +1274,9 @@ 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 +instance Pretty OnePassSignature where+ pretty = pretty . toPkt+ data SecretKey = SecretKey { _secretKeyPKPayload :: PKPayload , _secretKeySKAddendum :: SKAddendum@@ -771,6 +1288,9 @@ toPkt (SecretKey a b) = SecretKeyPkt a b fromPkt (SecretKeyPkt a b) = SecretKey a b +instance Pretty SecretKey where+ pretty = pretty . toPkt+ data PublicKey = PublicKey { _publicKeyPKPayload :: PKPayload } deriving (Data, Eq, Show, Typeable)@@ -781,6 +1301,9 @@ toPkt (PublicKey a) = PublicKeyPkt a fromPkt (PublicKeyPkt a) = PublicKey a +instance Pretty PublicKey where+ pretty = pretty . toPkt+ data SecretSubkey = SecretSubkey { _secretSubkeyPKPayload :: PKPayload , _secretSubkeySKAddendum :: SKAddendum@@ -792,6 +1315,9 @@ toPkt (SecretSubkey a b) = SecretSubkeyPkt a b fromPkt (SecretSubkeyPkt a b) = SecretSubkey a b +instance Pretty SecretSubkey where+ pretty = pretty . toPkt+ data CompressedData = CompressedData { _compressedDataCompressionAlgorithm :: CompressionAlgorithm , _compressedDataPayload :: CompressedDataPayload@@ -803,6 +1329,9 @@ toPkt (CompressedData a b) = CompressedDataPkt a b fromPkt (CompressedDataPkt a b) = CompressedData a b +instance Pretty CompressedData where+ pretty = pretty . toPkt+ data SymEncData = SymEncData { _symEncDataPayload :: ByteString } deriving (Data, Eq, Show, Typeable)@@ -813,6 +1342,9 @@ toPkt (SymEncData a) = SymEncDataPkt a fromPkt (SymEncDataPkt a) = SymEncData a +instance Pretty SymEncData where+ pretty = pretty . toPkt+ data Marker = Marker { _markerPayload :: ByteString } deriving (Data, Eq, Show, Typeable)@@ -823,10 +1355,13 @@ toPkt (Marker a) = MarkerPkt a fromPkt (MarkerPkt a) = Marker a +instance Pretty Marker where+ pretty = pretty . toPkt+ data LiteralData = LiteralData { _literalDataDataType :: DataType , _literalDataFileName :: FileName- , _literalDataTimeStamp :: TimeStamp+ , _literalDataTimeStamp :: ThirtyTwoBitTimeStamp , _literalDataPayload :: ByteString } deriving (Data, Eq, Show, Typeable) instance Packet LiteralData where@@ -836,6 +1371,9 @@ toPkt (LiteralData a b c d) = LiteralDataPkt a b c d fromPkt (LiteralDataPkt a b c d) = LiteralData a b c d +instance Pretty LiteralData where+ pretty = pretty . toPkt+ data Trust = Trust { _trustPayload :: ByteString } deriving (Data, Eq, Show, Typeable)@@ -846,8 +1384,11 @@ toPkt (Trust a) = TrustPkt a fromPkt (TrustPkt a) = Trust a +instance Pretty Trust where+ pretty = pretty . toPkt+ data UserId = UserId- { _userIdPayload :: String+ { _userIdPayload :: Text } deriving (Data, Eq, Show, Typeable) instance Packet UserId where data PacketType UserId = UserIdType deriving (Show, Eq)@@ -856,6 +1397,9 @@ toPkt (UserId a) = UserIdPkt a fromPkt (UserIdPkt a) = UserId a +instance Pretty UserId where+ pretty = pretty . toPkt+ data PublicSubkey = PublicSubkey { _publicSubkeyPKPayload :: PKPayload } deriving (Data, Eq, Show, Typeable)@@ -866,6 +1410,9 @@ toPkt (PublicSubkey a) = PublicSubkeyPkt a fromPkt (PublicSubkeyPkt a) = PublicSubkey a +instance Pretty PublicSubkey where+ pretty = pretty . toPkt+ data UserAttribute = UserAttribute { _userAttributeSubPackets :: [UserAttrSubPacket] } deriving (Data, Eq, Show, Typeable)@@ -876,6 +1423,9 @@ toPkt (UserAttribute a) = UserAttributePkt a fromPkt (UserAttributePkt a) = UserAttribute a +instance Pretty UserAttribute where+ pretty = pretty . toPkt+ data SymEncIntegrityProtectedData = SymEncIntegrityProtectedData { _symEncIntegrityProtectedDataPacketVersion :: PacketVersion , _symEncIntegrityProtectedDataPayload :: ByteString@@ -887,6 +1437,9 @@ toPkt (SymEncIntegrityProtectedData a b) = SymEncIntegrityProtectedDataPkt a b fromPkt (SymEncIntegrityProtectedDataPkt a b) = SymEncIntegrityProtectedData a b +instance Pretty SymEncIntegrityProtectedData where+ pretty = pretty . toPkt+ data ModificationDetectionCode = ModificationDetectionCode { _modificationDetectionCodePayload :: ByteString } deriving (Data, Eq, Show, Typeable)@@ -897,6 +1450,9 @@ toPkt (ModificationDetectionCode a) = ModificationDetectionCodePkt a fromPkt (ModificationDetectionCodePkt a) = ModificationDetectionCode a +instance Pretty ModificationDetectionCode where+ pretty = pretty . toPkt+ data OtherPacket = OtherPacket { _otherPacketType :: Word8 , _otherPacketPayload :: ByteString@@ -908,6 +1464,9 @@ toPkt (OtherPacket a b) = OtherPacketPkt a b fromPkt (OtherPacketPkt a b) = OtherPacket a b +instance Pretty OtherPacket where+ pretty = pretty . toPkt+ data BrokenPacket = BrokenPacket { _brokenPacketParseError :: String , _brokenPacketType :: Word8@@ -919,6 +1478,9 @@ packetCode _ = undefined toPkt (BrokenPacket a b c) = BrokenPacketPkt a b c fromPkt (BrokenPacketPkt a b c) = BrokenPacket a b c++instance Pretty BrokenPacket where+ pretty = pretty . toPkt data Verification = Verification { _verificationSigner :: PKPayload
Data/Conduit/OpenPGP/Decrypt.hs view
@@ -1,5 +1,5 @@ -- Decrypt.hs: OpenPGP (RFC4880) recursive packet decryption--- Copyright © 2013-2014 Clint Adams+-- Copyright © 2013-2015 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -14,16 +14,15 @@ import Control.Monad.Trans.Resource (MonadBaseControl, MonadResource, MonadThrow, runResourceT) import qualified Control.Monad.Trans.State.Lazy as S import qualified Crypto.Hash.SHA1 as SHA1-import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Conduit import qualified Data.Conduit.Binary as CB-import Data.Conduit.Cereal (conduitGet)+import Data.Conduit.Serialization.Binary (conduitGet) import Data.Conduit.OpenPGP.Compression (conduitDecompress) import qualified Data.Conduit.List as CL-import Data.Default (Default, def)+import Data.Default.Class (Default, def) import Data.Maybe (fromJust, isNothing)-import Data.Serialize (get)+import Data.Binary (get) import Codec.Encryption.OpenPGP.S2K (skesk2Key) import Codec.Encryption.OpenPGP.CFB (decrypt, decryptOpenPGPCfb)@@ -57,27 +56,27 @@ (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 (SHA1.hash . _literalDataPayload) (_lastLDP s) /= Just mdc) $ fail "MDC indicates tampering"+ when (fmap (BL.fromStrict . SHA1.hashlazy . _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 -> B.ByteString -> m [Pkt]+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) bs key of+ 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 -> B.ByteString -> m [Pkt]+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) bs key of+ 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
Data/Conduit/OpenPGP/Filter.hs view
@@ -1,150 +1,31 @@ -- Filter.hs: OpenPGP (RFC4880) packet filtering--- Copyright © 2014 Clint Adams+-- Copyright © 2014-2015 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). -{-# LANGUAGE GADTs, RecordWildCards #-}+{-# LANGUAGE GADTs #-} module Data.Conduit.OpenPGP.Filter ( conduitPktFilter , conduitTKFilter , FilterPredicates(..)- , Expr(..)- , PKPVar(..)- , PKPOp(..)- , PKPValue(..)- , SPVar(..)- , SPOp(..)- , SPValue(..)- , OVar(..)- , OOp(..)- , OValue(..)- , UPredicate(..)- , UOp(..)- , Exp(..)- , unop- , binop ) where -import Control.Applicative (Applicative, (<$>), (<*>), pure)-import Control.Error.Util (hush)-import Control.Monad ((>=>))-import Control.Monad.Loops (allM, anyM)-import Control.Monad.Reader (ask, reader, runReader, Reader)-import Control.Monad.Trans.Resource (MonadResource)-import qualified Data.ByteString as B-import Data.Conduit+import Control.Monad.Trans.Reader (Reader, runReader)+import Data.Conduit (Conduit) import qualified Data.Conduit.List as CL-import Data.Maybe (fromMaybe)-import Data.Serialize (runPut, put) -import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)-import Codec.Encryption.OpenPGP.Internal (sigType, sigPKA, sigHA)-import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize) import Codec.Encryption.OpenPGP.Types data FilterPredicates =- UnifiedFilterPredicate (Expr UPredicate) -- ^ "old"-style filter predicate, hopefully to be deprecated- | TransitionalTKFP (Exp (Reader TK) Bool) -- ^ a more flexible fp for transferable keys, hopefully to be deprecated- | RTKFilterPredicate (Reader TK Bool) -- ^ an even more flexible fp for transferable keys- | RPFilterPredicate (Reader Pkt Bool) -- ^ an even more flexible fp for context-less packets--data Expr a = EAny- | E a- | EAnd (Expr a) (Expr a)- | EOr (Expr a) (Expr a)- | ENot (Expr a)--eval :: (a -> v -> Bool) -> Expr a -> v -> Bool-eval t e v = ev e- where- ev EAny = True- ev (EAnd e1 e2) = ev e1 && ev e2- ev (EOr e1 e2) = ev e1 || ev e2- ev (ENot e1) = (not . ev) e1- ev (E e') = t e' v--data PKPOp = PKEquals | PKLessThan | PKGreaterThan- deriving Enum--data PKPPredicate = PKPPredicate PKPVar PKPOp PKPValue--data PKPVar = PKPVVersion -- ^ public key version- | PKPVPKA -- ^ public key algorithm- | PKPVKeysize -- ^ public key size (in bits)- | PKPVTimestamp -- ^ public key creation time- | PKPVEOKI -- ^ public key's eight-octet key ID- | PKPVTOF -- ^ public key's twenty-octet fingerprint--data PKPValue = PKPInt Int- | PKPPKA PubKeyAlgorithm- | PKPEOKI (Either String EightOctetKeyId)- | PKPTOF TwentyOctetFingerprint- deriving Eq--instance Ord PKPValue where- compare i j = compare (pkvToInt i) (pkvToInt j)--pkvToInt (PKPInt i) = i-pkvToInt (PKPPKA i) = fromIntegral (fromFVal i)--data SPOp = SPEquals | SPLessThan | SPGreaterThan- deriving Enum--data SPPredicate = SPPredicate SPVar SPOp SPValue--data SPVar = SPVVersion -- ^ signature packet version- | SPVSigType -- ^ signature packet tyep- | SPVPKA -- ^ signature packet public key algorithm- | SPVHA -- ^ signature packet hash algorithm--data SPValue = SPInt Int- | SPSigType SigType- | SPPKA PubKeyAlgorithm- | SPHA HashAlgorithm- deriving Eq--instance Ord SPValue where- compare i j = compare (spvToInt i) (spvToInt j)--spvToInt (SPInt i) = i-spvToInt (SPSigType i) = fromIntegral (fromFVal i)-spvToInt (SPPKA i) = fromIntegral (fromFVal i)-spvToInt (SPHA i) = fromIntegral (fromFVal i)--data OOp = OEquals | OLessThan | OGreaterThan- deriving Enum--data OPredicate = OPredicate OVar OOp OValue--data OVar = OVTag -- ^ OpenPGP packet tag- | OVLength -- ^ packet length (length of what, though?)--data OValue = OInt Int- | OInteger Integer- deriving Eq--instance Ord OValue where- compare i j = compare (ovToInteger i) (ovToInteger j)--ovToInteger (OInt i) = fromIntegral i-ovToInteger (OInteger i) = i--data UPredicate = UPKPP PKPVar UOp PKPValue- | USPP SPVar UOp SPValue- | UOP OVar UOp OValue--data UOp = UEquals -- ^ (==)- | ULessThan -- ^ (<)- | UGreaterThan -- ^ (>)- deriving Enum+ 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 (UnifiedFilterPredicate ufp) p = eval uEval ufp p superPredicate (RPFilterPredicate e) p = runReader e p superPredicate _ _ = False -- do not match incorrect type of packet @@ -152,78 +33,5 @@ conduitTKFilter = CL.filter . superTKPredicate superTKPredicate :: FilterPredicates -> TK -> Bool-superTKPredicate (UnifiedFilterPredicate ufp) p = eval uEval ufp (PublicKeyPkt (fst (_tkKey p))) -- FIXME: should operate on more than just the pkp-superTKPredicate (TransitionalTKFP e) k = runReader (evalM e) k-superTKPredicate (RTKFilterPredicate e) k = runReader e k--pkpEval :: PKPPredicate -> PKPayload -> Bool-pkpEval (PKPPredicate lhs o rhs) pkp = uncurry (opreduce o) (vreduce (lhs,pkp),rhs)- where- opreduce PKEquals = (==)- opreduce PKLessThan = (<)- opreduce PKGreaterThan = (>)- vreduce (PKPVVersion, p) = PKPInt (kv (_keyVersion p))- vreduce (PKPVPKA, p) = PKPPKA (_pkalgo p)- vreduce (PKPVKeysize, p) = PKPInt (fromMaybe 0 . hush . pubkeySize . _pubkey $ p) -- FIXME: a Left here should invalidate the predicate or something- vreduce (PKPVTimestamp, p) = PKPInt (fromIntegral (_timestamp p))- vreduce (PKPVEOKI, p) = PKPEOKI (eightOctetKeyID p)- vreduce (PKPVTOF, p) = PKPTOF (fingerprint p)- kv DeprecatedV3 = 3- kv V4 = 4--spEval :: SPPredicate -> SignaturePayload -> Bool-spEval (SPPredicate lhs o rhs) pkp = case vreduce (lhs, pkp) >>= \x -> return (uncurry (opreduce o) (x,rhs)) of- Just True -> True- _ -> False- where- opreduce SPEquals = (==)- opreduce SPLessThan = (<)- opreduce SPGreaterThan = (>)- vreduce (SPVVersion, s) = Just (SPInt (sigVersion s))- vreduce (SPVSigType, s) = fmap SPSigType (sigType s)- vreduce (SPVPKA, s) = fmap SPPKA (sigPKA s)- vreduce (SPVHA, s) = fmap SPHA (sigHA s)- sigVersion (SigV3 {}) = 3- sigVersion (SigV4 {}) = 4- sigVersion (SigVOther v _) = fromIntegral v--oEval :: OPredicate -> Pkt -> Bool-oEval (OPredicate lhs o rhs) pkp = uncurry (opreduce o) (vreduce (lhs,pkp),rhs)- where- opreduce OEquals = (==)- opreduce OLessThan = (<)- opreduce OGreaterThan = (>)- vreduce (OVTag, p) = OInteger (fromIntegral (pktTag p))- vreduce (OVLength, p) = OInteger (fromIntegral (B.length (runPut $ put p))) -- FIXME: this should be a length that makes sense--uEval :: UPredicate -> Pkt -> Bool-uEval (UPKPP l o r) (PublicKeyPkt p) = pkpEval (PKPPredicate l (toEnum . fromEnum $ o) r) p-uEval (USPP l o r) (SignaturePkt s) = spEval (SPPredicate l (toEnum . fromEnum $ o) r) s-uEval (UOP l o r) pkt = oEval (OPredicate l (toEnum . fromEnum $ o) r) pkt-uEval _ _ = False -- do not match packets of wrong type------data Exp m a where- I :: Integer -> Exp m Integer- B :: Bool -> Exp m Bool- S :: String -> Exp m String- Lift :: b -> Exp m b- Ap :: Exp m (b -> c) -> Exp m b -> Exp m c- AnyAll :: ((b -> m Bool) -> [b] -> m Bool) -> (b -> Exp m Bool) -> Exp m [b] -> Exp m Bool- MA :: m b -> Exp m b--evalM :: (Functor m, Applicative m, Monad m) => Exp m a -> m a-evalM (I n) = return n-evalM (B b) = return b-evalM (S s) = return s-evalM (Lift l) = return l-evalM (MA a) = a-evalM (Ap f a) = evalM f <*> evalM a-evalM (AnyAll aa f l) = evalM l >>= (aa (evalM . f) >=> return)--unop :: (a -> b) -> Exp m a -> Exp m b-unop = Ap . Lift+superTKPredicate (RTKFilterPredicate e) = runReader e -binop :: (a -> a -> b) -> Exp m a -> Exp m a -> Exp m b-binop = (Ap .) . Ap . Lift
Data/Conduit/OpenPGP/Keyring/Instances.hs view
@@ -1,5 +1,5 @@ -- Instances.hs: OpenPGP (RFC4880) additional types for transferable keys--- Copyright © 2012-2014 Clint Adams+-- Copyright © 2012-2015 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -14,15 +14,15 @@ import Data.Either (rights) import Data.Function (on) import qualified Data.HashMap.Lazy as HashMap-import Data.IxSet (Proxy(..), Indexable(..), ixSet, ixGen, ixFun)+import Data.IxSet (Indexable(..), ixSet, ixFun) import Data.List (nub, sort) import qualified Data.Map as Map import Data.Semigroup ((<>), Semigroup)+import Data.Text (Text) instance Indexable TK where empty = ixSet- [ ixGen (Proxy :: Proxy PKPayload)- , ixFun getEOKIs+ [ ixFun getEOKIs , ixFun getTOFs , ixFun getUIDs ]@@ -31,7 +31,7 @@ getEOKIs tk = rights (map eightOctetKeyID (tk ^.. biplate :: [PKPayload])) getTOFs :: TK -> [TwentyOctetFingerprint] getTOFs tk = map fingerprint (tk ^.. biplate :: [PKPayload])-getUIDs :: TK -> [String]+getUIDs :: TK -> [Text] getUIDs tk = (tk^.tkUIDs)^..folded._1 instance Ord SignaturePayload where
+ bench/mark.hs view
@@ -0,0 +1,33 @@+-- mark.hs: hOpenPGP benchmark suite+-- Copyright © 2014-2015 Clint Adams+-- This software is released under the terms of the Expat license.+-- (See the LICENSE file).++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 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++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)++main :: IO ()+main = defaultMain [+ bgroup "keyring" [ bench "load keys" $ whnfIO (loadKeys "tests/data/debian-keyring.gpg")+ , bench "load keyring" $ whnfIO (loadKeyring "tests/data/debian-keyring.gpg")+ , bench "self-verify keys" $ whnfIO (selfVerifyKeys "tests/data/debian-keyring.gpg")+ , bench "self-verify keyring" $ whnfIO (selfVerifyKeyring "tests/data/debian-keyring.gpg")+ ]+ ]
hOpenPGP.cabal view
@@ -1,5 +1,5 @@ Name: hOpenPGP-Version: 1.11+Version: 2.0 Synopsis: native Haskell implementation of OpenPGP (RFC4880) Description: native Haskell implementation of OpenPGP (RFC4880) Homepage: http://floss.scru.org/hOpenPGP/@@ -7,7 +7,7 @@ License-file: LICENSE Author: Clint Adams Maintainer: Clint Adams <clint@debian.org>-Copyright: 2012-2014 Clint Adams+Copyright: 2012-2015 Clint Adams Category: Codec, Data Build-type: Simple Extra-source-files: tests/suite.hs@@ -141,9 +141,13 @@ , tests/data/expired.pubkey , tests/data/sigs-with-regexes , tests/data/gnu-dummy-s2k-101-secret-key.gpg+ , tests/data/debian-keyring.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@@ -167,31 +171,34 @@ Other-Modules: Codec.Encryption.OpenPGP.Internal , Codec.Encryption.OpenPGP.SerializeForSigs , Codec.Encryption.OpenPGP.BlockCipher- Build-depends: attoparsec- , ansi-wl-pprint >= 0.6.7+ Build-depends: aeson+ , attoparsec , base > 4 && < 5 , base64-bytestring+ , bifunctors+ , byteable , bytestring , bzlib- , cereal- , cereal-conduit >= 0.6 && < 0.8+ , binary >= 0.6.4.0+ , binary-conduit , conduit >= 0.5 && < 1.3 , conduit-extra >= 1.1 , containers , crypto-cipher-types- , crypto-pubkey >= 0.1.4+ , crypto-pubkey >= 0.2.3 , crypto-random , cryptocipher , cryptohash- , data-default+ , data-default-class , errors , hashable , incremental-parser , ixset >= 1.0 , lens >= 3.0 , monad-loops- , mtl , nettle+ , newtype+ , old-locale , openpgp-asciiarmor >= 0.1 , resourcet > 0.4 , securemem@@ -201,7 +208,12 @@ , time >= 1.1 , 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 @@ -211,30 +223,33 @@ other-modules: Codec.Encryption.OpenPGP.Arbitrary Ghc-options: -Wall Build-depends: hOpenPGP- , ansi-wl-pprint >= 0.6.7+ , aeson , attoparsec , base > 4 && < 5+ , bifunctors+ , byteable , bytestring , bzlib- , cereal- , cereal-conduit+ , binary >= 0.6.4.0+ , binary-conduit , conduit , conduit-extra , containers , crypto-cipher-types- , crypto-pubkey >= 0.1.4+ , crypto-pubkey >= 0.2.3 , crypto-random , cryptocipher , cryptohash- , data-default+ , data-default-class , errors , hashable , incremental-parser , ixset >= 1.0 , lens >= 3.0 , monad-loops- , mtl , nettle+ , newtype+ , old-locale , securemem , semigroups , split@@ -242,6 +257,7 @@ , time >= 1.1 , transformers , unordered-containers+ , wl-pprint-extras , zlib , tasty , tasty-hunit@@ -249,6 +265,60 @@ , 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+ , base64-bytestring+ , bifunctors+ , byteable+ , bytestring+ , bzlib+ , binary >= 0.6.4.0+ , binary-conduit+ , conduit >= 0.5 && < 1.3+ , conduit-extra >= 1.1+ , containers+ , crypto-cipher-types+ , crypto-pubkey >= 0.2.3+ , crypto-random+ , cryptocipher+ , cryptohash+ , data-default-class+ , errors+ , hashable+ , incremental-parser+ , ixset >= 1.0+ , lens >= 3.0+ , monad-loops+ , nettle+ , newtype+ , old-locale+ , openpgp-asciiarmor >= 0.1+ , resourcet > 0.4+ , securemem+ , semigroups+ , split+ , text+ , time >= 1.1+ , 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
+ tests/data/debian-keyring.gpg view
file too large to diff
tests/suite.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -- suite.hs: hOpenPGP test suite--- Copyright © 2012-2014 Clint Adams+-- Copyright © 2012-2015 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -9,6 +9,7 @@ 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 ()@@ -23,26 +24,31 @@ import Control.Error.Util (isRight) import Control.Monad.Trans.Resource (ResourceT, runResourceT) import Crypto.PubKey.RSA (PrivateKey(private_pub))-import Data.Conduit.Cereal (conduitGet)+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 ((@=), getOne) import Data.Maybe (isJust)-import Data.Serialize (get, put)-import Data.Serialize.Get (runGet, Get)-import Data.Serialize.Put (runPut)+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 <- B.readFile $ "tests/data/" ++ fpr+ bs <- BL.readFile $ "tests/data/" ++ fpr let firstpass = runGet get bs case fmap unBlock firstpass of Left _ -> assertFailure $ "First pass failed on " ++ fpr@@ -56,7 +62,7 @@ testCompression :: FilePath -> Assertion testCompression fpr = do- bs <- B.readFile $ "tests/data/" ++ fpr+ 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@@ -78,12 +84,12 @@ testKeyIDandFingerprint :: FilePath -> String -> Assertion testKeyIDandFingerprint fpr kf = do- bs <- B.readFile $ "tests/data/" ++ fpr+ bs <- BL.readFile $ "tests/data/" ++ fpr case runGet (get :: Get Pkt) bs of Left _ -> assertFailure $ "Decoding of " ++ fpr ++ " broke." Right (PublicKeyPkt pkp) -> do- assertEqual ("for " ++ fpr ++ " (spaceless)") (spaceless kf) (either (const "unknown") show (eightOctetKeyID pkp) ++ "/" ++ show (fingerprint pkp))- assertEqual ("for " ++ fpr ++ " (spaced)") kf (either (const "unknown") show (eightOctetKeyID pkp) ++ "/" ++ show (SpacedFingerprint (fingerprint pkp)))+ assertEqual ("for " ++ fpr ++ " (spaceless)") (spaceless kf) (either (const "unknown") (show . pretty) (eightOctetKeyID pkp) ++ "/" ++ show (pretty (fingerprint pkp)))+ assertEqual ("for " ++ fpr ++ " (spaced)") kf (either (const "unknown") (show . pretty) (eightOctetKeyID pkp) ++ "/" ++ show (pretty (SpacedFingerprint (fingerprint pkp)))) _ -> assertFailure "Expected public key, got something else." where spaceless = filter (/=' ')@@ -115,7 +121,7 @@ assertEqual (keyfile ++ " key expiration") expectsuccess tvalid -- This needs a lot of work-testSymmetricEncryption :: FilePath -> FilePath -> B.ByteString -> Assertion+testSymmetricEncryption :: FilePath -> FilePath -> BL.ByteString -> Assertion testSymmetricEncryption encfile passfile cleartext = do passphrase <- BL.readFile $ "tests/data/" ++ passfile -- get parse tree@@ -141,8 +147,8 @@ 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 (RSAPrivateKey dpk) _ = decryptPrivateKey (pkp, ska) passphrase -- FIXME: better API for multiple keytypes- RSAPubKey pk = _pubkey pkp+ SUUnencrypted (RSAPrivateKey (RSA_PrivateKey dpk)) _ = decryptPrivateKey (pkp, ska) passphrase -- FIXME: better API for multiple keytypes+ RSAPubKey (RSA_PublicKey pk) = _pubkey pkp assertEqual "private key matches public key" pk (private_pub dpk) -- FIXME: this should be reworked either with tasty-golden or some other form of sanity@@ -152,7 +158,7 @@ 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" "\187\219\253I\236\204\t5D\196\NAK>;\202\185\t" ska passphrase+ 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 @@ -255,7 +261,7 @@ , testCase "gnu-dummy-s2k-101-secret-key.gpg" (testSerialization "gnu-dummy-s2k-101-secret-key.gpg") ], testGroup "KeyID/fingerprint group" [- testCase "v3 key" (testKeyIDandFingerprint "v3.key" "C7261095/CBD9 F412 6807 E405 CC2D 2712 1DF5 E86E ")+ testCase "v3 key" (testKeyIDandFingerprint "v3.key" "C7261095/CBD9 F412 6807 E405 CC2D 2712 1DF5 E86E") , testCase "v4 key" (testKeyIDandFingerprint "000001-006.public_key" "D4D54EA16F87040E/421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E") ], testGroup "Keyring group" [@@ -265,6 +271,7 @@ , testCase "secring 7732CF988A63EA86" (testKeyringLookup "secring.gpg" "7732CF988A63EA86" True) , testCase "secring 123456789ABCDEF0" (testKeyringLookup "secring.gpg" "123456789ABCDEF0" False) , testCase "secsub AD992E9C24399832" (testKeyringLookup "secring.gpg" "AD992E9C24399832" True)+ , testCase "d-k 94FA372B2DA8B985" (testKeyringLookup "debian-keyring.gpg" "0x94FA372B2DA8B985" False) -- FIXME: should count keys in rings ], testGroup "Message verification group" [