diff --git a/Codec/Encryption/OpenPGP/Arbitrary.hs b/Codec/Encryption/OpenPGP/Arbitrary.hs --- a/Codec/Encryption/OpenPGP/Arbitrary.hs +++ b/Codec/Encryption/OpenPGP/Arbitrary.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/CFB.hs b/Codec/Encryption/OpenPGP/CFB.hs --- a/Codec/Encryption/OpenPGP/CFB.hs +++ b/Codec/Encryption/OpenPGP/CFB.hs @@ -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) diff --git a/Codec/Encryption/OpenPGP/Compression.hs b/Codec/Encryption/OpenPGP/Compression.hs --- a/Codec/Encryption/OpenPGP/Compression.hs +++ b/Codec/Encryption/OpenPGP/Compression.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Expirations.hs b/Codec/Encryption/OpenPGP/Expirations.hs --- a/Codec/Encryption/OpenPGP/Expirations.hs +++ b/Codec/Encryption/OpenPGP/Expirations.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Fingerprint.hs b/Codec/Encryption/OpenPGP/Fingerprint.hs --- a/Codec/Encryption/OpenPGP/Fingerprint.hs +++ b/Codec/Encryption/OpenPGP/Fingerprint.hs @@ -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)) diff --git a/Codec/Encryption/OpenPGP/Internal.hs b/Codec/Encryption/OpenPGP/Internal.hs --- a/Codec/Encryption/OpenPGP/Internal.hs +++ b/Codec/Encryption/OpenPGP/Internal.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/KeyInfo.hs b/Codec/Encryption/OpenPGP/KeyInfo.hs --- a/Codec/Encryption/OpenPGP/KeyInfo.hs +++ b/Codec/Encryption/OpenPGP/KeyInfo.hs @@ -1,5 +1,5 @@ -- KeyInfo.hs: OpenPGP (RFC4880) fingerprinting methods --- Copyright © 2012-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 diff --git a/Codec/Encryption/OpenPGP/KeySelection.hs b/Codec/Encryption/OpenPGP/KeySelection.hs --- a/Codec/Encryption/OpenPGP/KeySelection.hs +++ b/Codec/Encryption/OpenPGP/KeySelection.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/KeyringParser.hs b/Codec/Encryption/OpenPGP/KeyringParser.hs --- a/Codec/Encryption/OpenPGP/KeyringParser.hs +++ b/Codec/Encryption/OpenPGP/KeyringParser.hs @@ -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] diff --git a/Codec/Encryption/OpenPGP/S2K.hs b/Codec/Encryption/OpenPGP/S2K.hs --- a/Codec/Encryption/OpenPGP/S2K.hs +++ b/Codec/Encryption/OpenPGP/S2K.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/SecretKey.hs b/Codec/Encryption/OpenPGP/SecretKey.hs --- a/Codec/Encryption/OpenPGP/SecretKey.hs +++ b/Codec/Encryption/OpenPGP/SecretKey.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Serialize.hs b/Codec/Encryption/OpenPGP/Serialize.hs --- a/Codec/Encryption/OpenPGP/Serialize.hs +++ b/Codec/Encryption/OpenPGP/Serialize.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/SerializeForSigs.hs b/Codec/Encryption/OpenPGP/SerializeForSigs.hs --- a/Codec/Encryption/OpenPGP/SerializeForSigs.hs +++ b/Codec/Encryption/OpenPGP/SerializeForSigs.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Signatures.hs b/Codec/Encryption/OpenPGP/Signatures.hs --- a/Codec/Encryption/OpenPGP/Signatures.hs +++ b/Codec/Encryption/OpenPGP/Signatures.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Types.hs b/Codec/Encryption/OpenPGP/Types.hs --- a/Codec/Encryption/OpenPGP/Types.hs +++ b/Codec/Encryption/OpenPGP/Types.hs @@ -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 diff --git a/Data/Conduit/OpenPGP/Decrypt.hs b/Data/Conduit/OpenPGP/Decrypt.hs --- a/Data/Conduit/OpenPGP/Decrypt.hs +++ b/Data/Conduit/OpenPGP/Decrypt.hs @@ -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 diff --git a/Data/Conduit/OpenPGP/Filter.hs b/Data/Conduit/OpenPGP/Filter.hs --- a/Data/Conduit/OpenPGP/Filter.hs +++ b/Data/Conduit/OpenPGP/Filter.hs @@ -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 diff --git a/Data/Conduit/OpenPGP/Keyring/Instances.hs b/Data/Conduit/OpenPGP/Keyring/Instances.hs --- a/Data/Conduit/OpenPGP/Keyring/Instances.hs +++ b/Data/Conduit/OpenPGP/Keyring/Instances.hs @@ -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 diff --git a/bench/mark.hs b/bench/mark.hs new file mode 100644 --- /dev/null +++ b/bench/mark.hs @@ -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") + ] + ] diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -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 -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 diff --git a/tests/data/debian-keyring.gpg b/tests/data/debian-keyring.gpg new file mode 100644 # file too large to diff: tests/data/debian-keyring.gpg diff --git a/tests/suite.hs b/tests/suite.hs --- a/tests/suite.hs +++ b/tests/suite.hs @@ -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" [