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 @@ -13,7 +13,6 @@ import qualified Codec.Compression.Zlib.Raw as ZlibRaw import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.Types -import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Serialize (get, put) @@ -21,12 +20,11 @@ import Data.Serialize.Put (runPut) decompressPkt :: Pkt -> [Pkt] -decompressPkt (CompressedDataPkt algo bs') = case (runGet get . B.concat . BL.toChunks) (decompressPkt' algo bs') of +decompressPkt (CompressedDataPkt algo bs) = + case (runGet get . B.concat . BL.toChunks) (dfunc algo (BL.fromChunks [bs])) of Left _ -> [] Right packs -> unBlock packs where - decompressPkt' :: CompressionAlgorithm -> ByteString -> BL.ByteString - decompressPkt' ca bs = dfunc ca (BL.fromChunks [bs]) dfunc ZIP = ZlibRaw.decompress dfunc ZLIB = Zlib.decompress dfunc BZip2 = BZip.decompress @@ -35,12 +33,10 @@ compressPkts :: CompressionAlgorithm -> [Pkt] -> Pkt compressPkts ca packs = do - let bs' = runPut $ put (Block packs) - let cbs = B.concat . BL.toChunks $ compressPkts' ca bs' + let bs = runPut $ put (Block packs) + cbs = B.concat . BL.toChunks $ cfunc ca (BL.fromChunks [bs]) CompressedDataPkt ca cbs where - compressPkts' :: CompressionAlgorithm -> ByteString -> BL.ByteString - compressPkts' ca bs = cfunc ca (BL.fromChunks [bs]) cfunc ZIP = ZlibRaw.compress cfunc ZLIB = Zlib.compress cfunc BZip2 = BZip.compress 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 @@ -19,10 +19,10 @@ import Codec.Encryption.OpenPGP.Types eightOctetKeyID :: PKPayload -> EightOctetKeyId -eightOctetKeyID (DeprecatedPubV3 _ _ RSA (RSAPubKey rp)) = (EightOctetKeyId . B.reverse . B.take 4 . B.reverse . integerToBEBS . RSA.public_n) rp -eightOctetKeyID p4@(PubV4 {}) = (EightOctetKeyId . B.drop 12 . unTOF . fingerprint) p4 +eightOctetKeyID (PKPayload DeprecatedV3 _ _ RSA (RSAPubKey rp)) = (EightOctetKeyId . B.reverse . B.take 4 . B.reverse . integerToBEBS . RSA.public_n) rp +eightOctetKeyID p4@(PKPayload V4 _ _ _ _) = (EightOctetKeyId . B.drop 12 . unTOF . fingerprint) p4 eightOctetKeyID _ = error "This should never happen." fingerprint :: PKPayload -> TwentyOctetFingerprint -fingerprint p3@(DeprecatedPubV3 {}) = (TwentyOctetFingerprint . MD5.hash) (runPut $ putPKPforFingerprinting (PublicKeyPkt p3)) -fingerprint p4@(PubV4 {}) = (TwentyOctetFingerprint . SHA1.hash) (runPut $ putPKPforFingerprinting (PublicKeyPkt p4)) +fingerprint p3@(PKPayload DeprecatedV3 _ _ _ _) = (TwentyOctetFingerprint . MD5.hash) (runPut $ putPKPforFingerprinting (PublicKeyPkt p3)) +fingerprint p4@(PKPayload V4 _ _ _ _) = (TwentyOctetFingerprint . SHA1.hash) (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 @@ -14,15 +14,13 @@ , pubkeyToMPIs ) where -import qualified Crypto.Hash.RIPEMD160 as RIPEMD160 -import Crypto.PubKey.HashDescr (HashDescr(..), hashDescrMD5, hashDescrSHA1, hashDescrSHA224, hashDescrSHA256, hashDescrSHA384, hashDescrSHA512) +import Crypto.PubKey.HashDescr (HashDescr(..), hashDescrMD5, hashDescrSHA1, hashDescrSHA224, hashDescrSHA256, hashDescrSHA384, hashDescrSHA512, hashDescrRIPEMD160) import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.RSA as RSA import Data.Bits (testBit, shiftL, shiftR, (.&.)) import Data.ByteString (ByteString) import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC8 import Data.List (find, mapAccumR, unfoldr) import Data.Word (Word8, Word16) @@ -60,7 +58,7 @@ hashDescr :: HashAlgorithm -> HashDescr hashDescr SHA1 = hashDescrSHA1 -hashDescr RIPEMD160 = HashDescr (RIPEMD160.hash) (B.append (BC8.pack "\x30\x21\x30\x09\x06\x05\x2b\x24\x03\x02\x01\x05\x00\x04\x14")) +hashDescr RIPEMD160 = hashDescrRIPEMD160 hashDescr SHA256 = hashDescrSHA256 hashDescr SHA384 = hashDescrSHA384 hashDescr SHA512 = hashDescrSHA512 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 @@ -768,7 +768,7 @@ getSecretKey :: PKPayload -> Get SKey getSecretKey pkp - | pubKeyAlgo pkp `elem` [RSA, RSAEncryptOnly, RSASignOnly] = + | _pkalgo pkp `elem` [RSA, RSAEncryptOnly, RSASignOnly] = do MPI d <- get MPI p <- get MPI q <- get @@ -777,11 +777,11 @@ dP = 0 dQ = 0 qinv = 0 - pub = (\(RSAPubKey x) -> x) (pubKeyKey pkp) + pub = (\(RSAPubKey x) -> x) (_pubkey pkp) return $ RSAPrivateKey (R.PrivateKey pub d p q dP dQ qinv) - | pubKeyAlgo pkp == DSA = do MPI x <- get - return $ DSAPrivateKey (D.PrivateKey (0,0,0) x) - | pubKeyAlgo pkp `elem` [ElgamalEncryptOnly,Elgamal] = + | _pkalgo pkp == DSA = do MPI x <- get + return $ DSAPrivateKey (D.PrivateKey (0,0,0) x) + | _pkalgo pkp `elem` [ElgamalEncryptOnly,Elgamal] = do MPI x <- get return $ ElGamalPrivateKey [x] @@ -795,35 +795,27 @@ version <- getWord8 ctime <- getWord32be if version `elem` [2,3] then - do v3exp <- getWord16be + do v3e <- getWord16be pka <- get pk <- getPubkey pka - return $ DeprecatedPubV3 ctime v3exp pka pk + return $! PKPayload DeprecatedV3 ctime v3e pka pk else do pka <- get pk <- getPubkey pka - return $ PubV4 ctime pka pk + return $! PKPayload V4 ctime 0 pka pk putPKPayload :: PKPayload -> Put -putPKPayload (DeprecatedPubV3 ctime v3exp pka pk) = do +putPKPayload (PKPayload DeprecatedV3 ctime v3e pka pk) = do putWord8 3 putWord32be ctime - putWord16be v3exp + putWord16be v3e put pka putPubkey pk -putPKPayload (PubV4 ctime pka pk) = do +putPKPayload (PKPayload V4 ctime _ pka pk) = do putWord8 4 putWord32be ctime put pka putPubkey pk - -pubKeyAlgo :: PKPayload -> PubKeyAlgorithm -pubKeyAlgo (DeprecatedPubV3 _ _ pka _) = pka -pubKeyAlgo (PubV4 _ pka _) = pka - -pubKeyKey :: PKPayload -> PKey -pubKeyKey (DeprecatedPubV3 _ _ _ k) = k -pubKeyKey (PubV4 _ _ k) = k getSKAddendum :: PKPayload -> Get SKAddendum getSKAddendum pkp = do 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 @@ -26,8 +26,8 @@ import Codec.Encryption.OpenPGP.Types putPKPforFingerprinting :: Pkt -> Put -putPKPforFingerprinting (PublicKeyPkt pkp@(DeprecatedPubV3 _ _ _ pk)) = mapM_ putMPIforFingerprinting (pubkeyToMPIs pk) -putPKPforFingerprinting (PublicKeyPkt pkp@(PubV4 {})) = do +putPKPforFingerprinting (PublicKeyPkt (PKPayload DeprecatedV3 _ _ _ pk)) = mapM_ putMPIforFingerprinting (pubkeyToMPIs pk) +putPKPforFingerprinting (PublicKeyPkt pkp@(PKPayload V4 _ _ _ _)) = do putWord8 0x99 let bs = runPut $ put pkp putWord16be . fromIntegral $ B.length bs 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 @@ -19,6 +19,7 @@ , SigType(..) , ImageHeader(..) , ImageFormat(..) + , KeyVersion(..) , PKPayload(..) , SKAddendum(..) , DataType(..) @@ -426,8 +427,16 @@ | SigVOther Word8 ByteString deriving (Data, Eq, Show, Typeable) -- FIXME -data PKPayload = DeprecatedPubV3 TimeStamp V3Expiration PubKeyAlgorithm PKey - | PubV4 TimeStamp PubKeyAlgorithm PKey +data KeyVersion = DeprecatedV3 | V4 + deriving (Data, Eq, Ord, Show, Typeable) + +data PKPayload = PKPayload { + _keyVersion :: KeyVersion + , _timestamp :: TimeStamp + , _v3exp :: V3Expiration + , _pkalgo :: PubKeyAlgorithm + , _pubkey :: PKey + } deriving (Data, Eq, Show, Typeable) instance Ord PKPayload where @@ -631,10 +640,10 @@ deriving (Show, Eq, Data, Typeable) -- FIXME data PKESK = PKESK - { pkeskPacketVersion :: PacketVersion - , pkeskEightOctetKeyId :: EightOctetKeyId - , pkeskPubKeyAlgorithm :: PubKeyAlgorithm - , pkeskMPIs :: [MPI] + { _pkeskPacketVersion :: PacketVersion + , _pkeskEightOctetKeyId :: EightOctetKeyId + , _pkeskPubKeyAlgorithm :: PubKeyAlgorithm + , _pkeskMPIs :: [MPI] } deriving (Data, Eq, Show, Typeable) instance Packet PKESK where data PacketType PKESK = PKESKType @@ -644,7 +653,7 @@ fromPkt (PKESKPkt a b c d) = PKESK a b c d data Signature = Signature -- FIXME? - { signaturePayload :: SignaturePayload + { _signaturePayload :: SignaturePayload } deriving (Data, Eq, Show, Typeable) instance Packet Signature where data PacketType Signature = SignatureType @@ -654,10 +663,10 @@ fromPkt (SignaturePkt a) = Signature a data SKESK = SKESK - { skeskPacketVersion :: PacketVersion - , skeskSymmetricAlgorithm :: SymmetricAlgorithm - , skeskS2K :: S2K - , skeskMPIs :: [MPI] + { _skeskPacketVersion :: PacketVersion + , _skeskSymmetricAlgorithm :: SymmetricAlgorithm + , _skeskS2K :: S2K + , _skeskMPIs :: [MPI] } deriving (Data, Eq, Show, Typeable) instance Packet SKESK where data PacketType SKESK = SKESKType @@ -667,12 +676,12 @@ fromPkt (SKESKPkt a b c d) = SKESK a b c d data OnePassSignature = OnePassSignature - { onePassSignaturePacketVersion :: PacketVersion - , onePassSignatureSigType :: SigType - , onePassSignatureHashAlgorithm :: HashAlgorithm - , onePassSignaturePubKeyAlgorithm :: PubKeyAlgorithm - , onePassSignatureEightOctetKeyId :: EightOctetKeyId - , onePassSignatureNestedFlag :: NestedFlag + { _onePassSignaturePacketVersion :: PacketVersion + , _onePassSignatureSigType :: SigType + , _onePassSignatureHashAlgorithm :: HashAlgorithm + , _onePassSignaturePubKeyAlgorithm :: PubKeyAlgorithm + , _onePassSignatureEightOctetKeyId :: EightOctetKeyId + , _onePassSignatureNestedFlag :: NestedFlag } deriving (Data, Eq, Show, Typeable) instance Packet OnePassSignature where data PacketType OnePassSignature = OnePassSignatureType @@ -682,8 +691,8 @@ fromPkt (OnePassSignaturePkt a b c d e f) = OnePassSignature a b c d e f data SecretKey = SecretKey - { secretKeyPKPayload :: PKPayload - , secretKeySKAddendum :: SKAddendum + { _secretKeyPKPayload :: PKPayload + , _secretKeySKAddendum :: SKAddendum } deriving (Data, Eq, Show, Typeable) instance Packet SecretKey where data PacketType SecretKey = SecretKeyType @@ -693,7 +702,7 @@ fromPkt (SecretKeyPkt a b) = SecretKey a b data PublicKey = PublicKey - { publicKeyPKPayload :: PKPayload + { _publicKeyPKPayload :: PKPayload } deriving (Data, Eq, Show, Typeable) instance Packet PublicKey where data PacketType PublicKey = PublicKeyType @@ -703,8 +712,8 @@ fromPkt (PublicKeyPkt a) = PublicKey a data SecretSubkey = SecretSubkey - { secretSubkeyPKPayload :: PKPayload - , secretSubkeySKAddendum :: SKAddendum + { _secretSubkeyPKPayload :: PKPayload + , _secretSubkeySKAddendum :: SKAddendum } deriving (Data, Eq, Show, Typeable) instance Packet SecretSubkey where data PacketType SecretSubkey = SecretSubkeyType @@ -714,8 +723,8 @@ fromPkt (SecretSubkeyPkt a b) = SecretSubkey a b data CompressedData = CompressedData - { compressedDataCompressionAlgorithm :: CompressionAlgorithm - , compressedDataPayload :: CompressedDataPayload + { _compressedDataCompressionAlgorithm :: CompressionAlgorithm + , _compressedDataPayload :: CompressedDataPayload } deriving (Data, Eq, Show, Typeable) instance Packet CompressedData where data PacketType CompressedData = CompressedDataType @@ -725,7 +734,7 @@ fromPkt (CompressedDataPkt a b) = CompressedData a b data SymEncData = SymEncData - { symEncDataPayload :: ByteString + { _symEncDataPayload :: ByteString } deriving (Data, Eq, Show, Typeable) instance Packet SymEncData where data PacketType SymEncData = SymEncDataType @@ -735,7 +744,7 @@ fromPkt (SymEncDataPkt a) = SymEncData a data Marker = Marker - { markerPayload :: ByteString + { _markerPayload :: ByteString } deriving (Data, Eq, Show, Typeable) instance Packet Marker where data PacketType Marker = MarkerType @@ -745,10 +754,10 @@ fromPkt (MarkerPkt a) = Marker a data LiteralData = LiteralData - { literalDataDataType :: DataType - , literalDataFileName :: FileName - , literalDataTimeStamp :: TimeStamp - , literalDataPayload :: ByteString + { _literalDataDataType :: DataType + , _literalDataFileName :: FileName + , _literalDataTimeStamp :: TimeStamp + , _literalDataPayload :: ByteString } deriving (Data, Eq, Show, Typeable) instance Packet LiteralData where data PacketType LiteralData = LiteralDataType @@ -758,7 +767,7 @@ fromPkt (LiteralDataPkt a b c d) = LiteralData a b c d data Trust = Trust - { trustPayload :: ByteString + { _trustPayload :: ByteString } deriving (Data, Eq, Show, Typeable) instance Packet Trust where data PacketType Trust = TrustType @@ -768,7 +777,7 @@ fromPkt (TrustPkt a) = Trust a data UserId = UserId - { userIdPayload :: String + { _userIdPayload :: String } deriving (Data, Eq, Show, Typeable) instance Packet UserId where data PacketType UserId = UserIdType @@ -778,7 +787,7 @@ fromPkt (UserIdPkt a) = UserId a data PublicSubkey = PublicSubkey - { publicSubkeyPKPayload :: PKPayload + { _publicSubkeyPKPayload :: PKPayload } deriving (Data, Eq, Show, Typeable) instance Packet PublicSubkey where data PacketType PublicSubkey = PublicSubkeyType @@ -788,7 +797,7 @@ fromPkt (PublicSubkeyPkt a) = PublicSubkey a data UserAttribute = UserAttribute - { userAttributeSubPackets :: [UserAttrSubPacket] + { _userAttributeSubPackets :: [UserAttrSubPacket] } deriving (Data, Eq, Show, Typeable) instance Packet UserAttribute where data PacketType UserAttribute = UserAttributeType @@ -798,8 +807,8 @@ fromPkt (UserAttributePkt a) = UserAttribute a data SymEncIntegrityProtectedData = SymEncIntegrityProtectedData - { symEncIntegrityProtectedDataPacketVersion :: PacketVersion - , symEncIntegrityProtectedDataPayload :: ByteString + { _symEncIntegrityProtectedDataPacketVersion :: PacketVersion + , _symEncIntegrityProtectedDataPayload :: ByteString } deriving (Data, Eq, Show, Typeable) instance Packet SymEncIntegrityProtectedData where data PacketType SymEncIntegrityProtectedData = SymEncIntegrityProtectedDataType @@ -809,7 +818,7 @@ fromPkt (SymEncIntegrityProtectedDataPkt a b) = SymEncIntegrityProtectedData a b data ModificationDetectionCode = ModificationDetectionCode - { modificationDetectionCodePayload :: ByteString + { _modificationDetectionCodePayload :: ByteString } deriving (Data, Eq, Show, Typeable) instance Packet ModificationDetectionCode where data PacketType ModificationDetectionCode = ModificationDetectionCodeType @@ -819,8 +828,8 @@ fromPkt (ModificationDetectionCodePkt a) = ModificationDetectionCode a data OtherPacket = OtherPacket - { otherPacketType :: Word8 - , otherPacketPayload :: ByteString + { _otherPacketType :: Word8 + , _otherPacketPayload :: ByteString } deriving (Data, Eq, Show, Typeable) instance Packet OtherPacket where data PacketType OtherPacket = OtherPacketType @@ -830,8 +839,28 @@ fromPkt (OtherPacketPkt a b) = OtherPacket a b data Verification = Verification { - verificationSigner :: PKPayload - , verificationSignature :: SignaturePayload + _verificationSigner :: PKPayload + , _verificationSignature :: SignaturePayload } +$(makeLenses ''PKESK) +$(makeLenses ''Signature) +$(makeLenses ''SKESK) +$(makeLenses ''OnePassSignature) +$(makeLenses ''SecretKey) +$(makeLenses ''PKPayload) +$(makeLenses ''PublicKey) +$(makeLenses ''SecretSubkey) +$(makeLenses ''CompressedData) +$(makeLenses ''SymEncData) +$(makeLenses ''Marker) +$(makeLenses ''LiteralData) +$(makeLenses ''Trust) +$(makeLenses ''UserId) +$(makeLenses ''PublicSubkey) +$(makeLenses ''UserAttribute) +$(makeLenses ''SymEncIntegrityProtectedData) +$(makeLenses ''ModificationDetectionCode) +$(makeLenses ''OtherPacket) $(makeLenses ''TK) +$(makeLenses ''Verification) diff --git a/Codec/Encryption/OpenPGP/Verify.hs b/Codec/Encryption/OpenPGP/Verify.hs --- a/Codec/Encryption/OpenPGP/Verify.hs +++ b/Codec/Encryption/OpenPGP/Verify.hs @@ -34,7 +34,7 @@ verifySig :: Keyring -> Pkt -> PktStreamContext -> Maybe UTCTime -> Either String Verification -- FIXME: check expiration here? verifySig kr sig@(SignaturePkt (SigV4 st _ _ hs _ _ _)) state mt = do v <- verify kr sig mt (payloadForSig st state) - _ <- mapM_ (checkIssuer (eightOctetKeyID (verificationSigner v)) . sspPayload) hs + _ <- mapM_ (checkIssuer (eightOctetKeyID (_verificationSigner v)) . sspPayload) hs return v where checkIssuer :: EightOctetKeyId -> SigSubPacketPayload -> Either String Bool @@ -70,7 +70,7 @@ 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 any (\(p,f) -> p == pka && f == fingerprint (verificationSigner v)) vokers then [Left "Key revoked"] else [Right s] + (s@(SigV4 KeyRevocationSig pka _ _ _ _ _), v) -> if any (\(p,f) -> p == pka && f == fingerprint (_verificationSigner v)) vokers then [Left "Key revoked"] else [Right s] _ -> [] isKeyRevocation (SigV4 KeyRevocationSig _ _ _ _ _ _) = True isKeyRevocation _ = False @@ -104,13 +104,13 @@ 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@(PubV4 _ _ pkey)) ha pl = verify'' (pkaAndMPIs s) ha pub pkey pl + verify' (SignaturePkt s) (pub@(PKPayload V4 _ _ _ pkey)) ha pl = verify'' (pkaAndMPIs s) ha pub pkey pl verify' _ _ _ _ = error "This should never happen." verify'' (DSA,mpis) ha pub (DSAPubKey pkey) bs = verify''' (dsaVerify mpis ha pkey bs) pub verify'' (RSA,mpis) ha pub (RSAPubKey pkey) bs = verify''' (rsaVerify mpis ha pkey bs) pub @@ -134,7 +134,7 @@ pkaAndMPIs _ = error "This should never happen." isSignatureExpired :: Pkt -> Maybe UTCTime -> Either String Bool isSignatureExpired s Nothing = return False - isSignatureExpired s (Just t) = if any (expiredBefore t) ((\(SigV4 _ _ _ h _ _ _) -> h) . signaturePayload . fromPkt $ s) then Left "signature expired" else return True + 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 diff --git a/Data/Conduit/OpenPGP/Compression.hs b/Data/Conduit/OpenPGP/Compression.hs --- a/Data/Conduit/OpenPGP/Compression.hs +++ b/Data/Conduit/OpenPGP/Compression.hs @@ -12,13 +12,9 @@ import Codec.Encryption.OpenPGP.Types import Data.Conduit import qualified Data.Conduit.List as CL -import qualified Data.Conduit.Util as CU conduitCompress :: MonadThrow m => CompressionAlgorithm -> Conduit Pkt m Pkt -conduitCompress algo = CU.conduitState [] push (close algo) - where - push state input = return $ CU.StateProducing (input : state) [] - close a state = return [compressPkts a state] +conduitCompress algo = CL.consume >>= \ps -> yield (compressPkts algo ps) conduitDecompress :: MonadThrow m => Conduit Pkt m Pkt conduitDecompress = CL.concatMap decompressPkt diff --git a/Data/Conduit/OpenPGP/Keyring.hs b/Data/Conduit/OpenPGP/Keyring.hs --- a/Data/Conduit/OpenPGP/Keyring.hs +++ b/Data/Conduit/OpenPGP/Keyring.hs @@ -12,7 +12,6 @@ import qualified Data.ByteString as B import Data.Conduit import qualified Data.Conduit.List as CL -import qualified Data.Conduit.Util as CU import Data.IxSet (empty, insert) import Codec.Encryption.OpenPGP.Types @@ -27,52 +26,63 @@ conduitToTKsDropping :: MonadResource m => Conduit Pkt m TK conduitToTKsDropping = conduitToTKs' False +fakecmAccum :: Monad m => (a -> (Phase, Maybe TK) -> ((Phase, Maybe TK), [TK])) -> (Phase, Maybe TK) -> Conduit a m TK +fakecmAccum f = + loop + where + loop accum = + await >>= maybe (finalyield accum) go + where + go a = do + let (accum', bs) = f a accum + Prelude.mapM_ yield bs + loop accum' + finalyield = maybe (return ()) yield . snd + conduitToTKs' :: MonadResource m => Bool -> Conduit Pkt m TK -conduitToTKs' intolerant = CU.conduitState (MainKey, Nothing) push close +conduitToTKs' intolerant = fakecmAccum push (MainKey, Nothing) where - push state input = case (state, input) of - ((MainKey, _), PublicKeyPkt pkp) -> return $ CU.StateProducing (Revs, Just (TK pkp Nothing [] [] [] [])) [] - ((MainKey, _), SecretKeyPkt pkp ska) -> return $ CU.StateProducing (Revs, Just (TK pkp (Just ska) [] [] [] [])) [] - ((Revs, Just (TK pkp Nothing revs uids uats subs)), SignaturePkt s) -> return $ CU.StateProducing (Revs, Just (TK pkp Nothing (revs ++ [s]) uids uats subs)) [] - ((Revs, Just (TK pkp Nothing revs _ uats subs)), UserIdPkt u) -> return $ CU.StateProducing (Uids, Just (TK pkp Nothing revs [(u, [])] uats subs)) [] - ((Uids, Just (TK pkp Nothing revs uids uats subs)), SignaturePkt s) -> return $ CU.StateProducing (Uids, Just (TK pkp Nothing revs (addUidSig s uids) uats subs)) [] - ((Uids, Just (TK pkp Nothing revs uids uats subs)), UserIdPkt u) -> return $ CU.StateProducing (Uids, Just (TK pkp Nothing revs (uids ++ [(u, [])]) uats subs)) [] - ((Uids, Just (TK pkp Nothing revs uids _ subs)), UserAttributePkt u) -> return $ CU.StateProducing (UAts, Just (TK pkp Nothing revs uids [(u, [])] subs)) [] - ((Uids, Just (TK pkp Nothing revs uids uats _)), PublicSubkeyPkt p) -> return $ CU.StateProducing (Subs, Just (TK pkp Nothing revs uids uats [(PublicSubkeyPkt p, SigVOther 0 B.empty, Nothing)])) [] - ((Uids, Just (TK pkp Nothing revs uids uats subs)), PublicKeyPkt p) -> return $ CU.StateProducing (Revs, Just (TK p Nothing [] [] [] [])) [TK pkp Nothing revs uids uats subs] - ((UAts, Just (TK pkp Nothing revs uids uats subs)), SignaturePkt s) -> return $ CU.StateProducing (UAts, Just (TK pkp Nothing revs uids (addUAtSig s uats) subs)) [] - ((UAts, Just (TK pkp Nothing revs uids uats subs)), UserAttributePkt u) -> return $ CU.StateProducing (UAts, Just (TK pkp Nothing revs uids (uats ++ [(u, [])]) subs)) [] - ((UAts, Just (TK pkp Nothing revs uids uats subs)), UserIdPkt u) -> return $ CU.StateProducing (Uids, Just (TK pkp Nothing revs (uids ++ [(u, [])]) uats subs)) [] - ((UAts, Just (TK pkp Nothing revs uids uats _)), PublicSubkeyPkt p) -> return $ CU.StateProducing (Subs, Just (TK pkp Nothing revs uids uats [(PublicSubkeyPkt p, SigVOther 0 B.empty, Nothing)])) [] - ((UAts, Just (TK pkp Nothing revs uids uats subs)), PublicKeyPkt p) -> return $ CU.StateProducing (Revs, Just (TK p Nothing [] [] [] [])) [TK pkp Nothing revs uids uats subs] - ((Subs, Just (TK pkp Nothing revs uids uats subs)), PublicSubkeyPkt p) -> return $ CU.StateProducing (Subs, Just (TK pkp Nothing revs uids uats (subs ++ [(PublicSubkeyPkt p, SigVOther 0 B.empty, Nothing)]))) [] - ((Subs, Just (TK pkp Nothing revs uids uats subs)), SignaturePkt s) -> case sType s of - SubkeyBindingSig -> return $ CU.StateProducing (Subs, Just (TK pkp Nothing revs uids uats (setBSig s subs))) [] - SubkeyRevocationSig -> return $ CU.StateProducing (Subs, Just (TK pkp Nothing revs uids uats (setRSig s subs))) [] - _ -> return (dropOrError intolerant state $ "Unexpected subkey sig: " ++ show (fst state) ++ "/" ++ show input) - ((Subs, Just (TK pkp Nothing revs uids uats subs)), PublicKeyPkt p) -> return $ CU.StateProducing (Revs, Just (TK p Nothing [] [] [] [])) [TK pkp Nothing revs uids uats subs] - ((Revs, Just (TK pkp mska revs uids uats subs)), SignaturePkt s) -> return $ CU.StateProducing (Revs, Just (TK pkp mska (revs ++ [s]) uids uats subs)) [] - ((Revs, Just (TK pkp mska revs _ uats subs)), UserIdPkt u) -> return $ CU.StateProducing (Uids, Just (TK pkp mska revs [(u, [])] uats subs)) [] - ((Uids, Just (TK pkp mska revs uids uats subs)), SignaturePkt s) -> return $ CU.StateProducing (Uids, Just (TK pkp mska revs (addUidSig s uids) uats subs)) [] - ((Uids, Just (TK pkp mska revs uids uats subs)), UserIdPkt u) -> return $ CU.StateProducing (Uids, Just (TK pkp mska revs (uids ++ [(u, [])]) uats subs)) [] - ((Uids, Just (TK pkp mska revs uids _ subs)), UserAttributePkt u) -> return $ CU.StateProducing (UAts, Just (TK pkp mska revs uids [(u, [])] subs)) [] - ((Uids, Just (TK pkp mska revs uids uats _)), SecretSubkeyPkt p s) -> return $ CU.StateProducing (Subs, Just (TK pkp mska revs uids uats [(SecretSubkeyPkt p s, SigVOther 0 B.empty, Nothing)])) [] - ((Uids, Just (TK pkp mska revs uids uats subs)), SecretKeyPkt p s) -> return $ CU.StateProducing (Revs, Just (TK p (Just s) [] [] [] [])) [TK pkp mska revs uids uats subs] - ((UAts, Just (TK pkp mska revs uids uats subs)), SignaturePkt s) -> return $ CU.StateProducing (UAts, Just (TK pkp mska revs uids (addUAtSig s uats) subs)) [] - ((UAts, Just (TK pkp mska revs uids uats subs)), UserAttributePkt u) -> return $ CU.StateProducing (UAts, Just (TK pkp mska revs uids (uats ++ [(u, [])]) subs)) [] - ((UAts, Just (TK pkp mska revs uids uats subs)), UserIdPkt u) -> return $ CU.StateProducing (Uids, Just (TK pkp mska revs (uids ++ [(u, [])]) uats subs)) [] - ((UAts, Just (TK pkp mska revs uids uats _)), SecretSubkeyPkt p s) -> return $ CU.StateProducing (Subs, Just (TK pkp mska revs uids uats [(SecretSubkeyPkt p s, SigVOther 0 B.empty, Nothing)])) [] - ((UAts, Just (TK pkp mska revs uids uats subs)), SecretKeyPkt p s) -> return $ CU.StateProducing (Revs, Just (TK p (Just s) [] [] [] [])) [TK pkp mska revs uids uats subs] - ((Subs, Just (TK pkp mska revs uids uats subs)), SecretSubkeyPkt p s) -> return $ CU.StateProducing (Subs, Just (TK pkp mska revs uids uats (subs ++ [(SecretSubkeyPkt p s, SigVOther 0 B.empty, Nothing)]))) [] - ((Subs, Just (TK pkp mska revs uids uats subs)), SignaturePkt s) -> case sType s of - SubkeyBindingSig -> return $ CU.StateProducing (Subs, Just (TK pkp mska revs uids uats (setBSig s subs))) [] - SubkeyRevocationSig -> return $ CU.StateProducing (Subs, Just (TK pkp mska revs uids uats (setRSig s subs))) [] - _ -> return (dropOrError intolerant state $ "Unexpected subkey sig: " ++ show (fst state) ++ "/" ++ show input) - ((Subs, Just (TK pkp mska revs uids uats subs)), SecretKeyPkt p s) -> return $ CU.StateProducing (Revs, Just (TK p (Just s) [] [] [] [])) [TK pkp mska revs uids uats subs] - ((_,_), TrustPkt _) -> return $ CU.StateProducing state [] - _ -> return (dropOrError intolerant state $ "Unexpected packet: " ++ show (fst state) ++ "/" ++ show input) - close (_, Nothing) = return [] - close (_, Just tk) = return [tk] + push i s = case (s, i) of + ((MainKey, _), PublicKeyPkt pkp) -> ((Revs, Just (TK pkp Nothing [] [] [] [])), []) + ((MainKey, _), SecretKeyPkt pkp ska) -> ((Revs, Just (TK pkp (Just ska) [] [] [] [])), []) + ((Revs, Just (TK pkp Nothing revs uids uats subs)), SignaturePkt sp) -> ((Revs, Just (TK pkp Nothing (revs ++ [sp]) uids uats subs)), []) + ((Revs, Just (TK pkp Nothing revs _ uats subs)), UserIdPkt u) -> ((Uids, Just (TK pkp Nothing revs [(u, [])] uats subs)), []) + ((Uids, Just (TK pkp Nothing revs uids uats subs)), SignaturePkt sp) -> ((Uids, Just (TK pkp Nothing revs (addUidSig sp uids) uats subs)), []) + ((Uids, Just (TK pkp Nothing revs uids uats subs)), UserIdPkt u) -> ((Uids, Just (TK pkp Nothing revs (uids ++ [(u, [])]) uats subs)), []) + ((Uids, Just (TK pkp Nothing revs uids _ subs)), UserAttributePkt u) -> ((UAts, Just (TK pkp Nothing revs uids [(u, [])] subs)), []) + ((Uids, Just (TK pkp Nothing revs uids uats _)), PublicSubkeyPkt p) -> ((Subs, Just (TK pkp Nothing revs uids uats [(PublicSubkeyPkt p, SigVOther 0 B.empty, Nothing)])), []) + ((Uids, Just (TK pkp Nothing revs uids uats subs)), PublicKeyPkt p) -> ((Revs, Just (TK p Nothing [] [] [] [])), [TK pkp Nothing revs uids uats subs]) + ((UAts, Just (TK pkp Nothing revs uids uats subs)), SignaturePkt sp) -> ((UAts, Just (TK pkp Nothing revs uids (addUAtSig sp uats) subs)), []) + ((UAts, Just (TK pkp Nothing revs uids uats subs)), UserAttributePkt u) -> ((UAts, Just (TK pkp Nothing revs uids (uats ++ [(u, [])]) subs)), []) + ((UAts, Just (TK pkp Nothing revs uids uats subs)), UserIdPkt u) -> ((Uids, Just (TK pkp Nothing revs (uids ++ [(u, [])]) uats subs)), []) + ((UAts, Just (TK pkp Nothing revs uids uats _)), PublicSubkeyPkt p) -> ((Subs, Just (TK pkp Nothing revs uids uats [(PublicSubkeyPkt p, SigVOther 0 B.empty, Nothing)])), []) + ((UAts, Just (TK pkp Nothing revs uids uats subs)), PublicKeyPkt p) -> ((Revs, Just (TK p Nothing [] [] [] [])), [TK pkp Nothing revs uids uats subs]) + ((Subs, Just (TK pkp Nothing revs uids uats subs)), PublicSubkeyPkt p) -> ((Subs, Just (TK pkp Nothing revs uids uats (subs ++ [(PublicSubkeyPkt p, SigVOther 0 B.empty, Nothing)]))), []) + ((Subs, Just (TK pkp Nothing revs uids uats subs)), SignaturePkt sp) -> case sType sp of + SubkeyBindingSig -> ((Subs, Just (TK pkp Nothing revs uids uats (setBSig sp subs))), []) + SubkeyRevocationSig -> ((Subs, Just (TK pkp Nothing revs uids uats (setRSig sp subs))), []) + _ -> dropOrError intolerant s $ "Unexpected subkey sig: " ++ show (fst s) ++ "/" ++ show i + ((Subs, Just (TK pkp Nothing revs uids uats subs)), PublicKeyPkt p) -> ((Revs, Just (TK p Nothing [] [] [] [])), [TK pkp Nothing revs uids uats subs]) + ((Revs, Just (TK pkp mska revs uids uats subs)), SignaturePkt sp) -> ((Revs, Just (TK pkp mska (revs ++ [sp]) uids uats subs)), []) + ((Revs, Just (TK pkp mska revs _ uats subs)), UserIdPkt u) -> ((Uids, Just (TK pkp mska revs [(u, [])] uats subs)), []) + ((Uids, Just (TK pkp mska revs uids uats subs)), SignaturePkt sp) -> ((Uids, Just (TK pkp mska revs (addUidSig sp uids) uats subs)), []) + ((Uids, Just (TK pkp mska revs uids uats subs)), UserIdPkt u) -> ((Uids, Just (TK pkp mska revs (uids ++ [(u, [])]) uats subs)), []) + ((Uids, Just (TK pkp mska revs uids _ subs)), UserAttributePkt u) -> ((UAts, Just (TK pkp mska revs uids [(u, [])] subs)), []) + ((Uids, Just (TK pkp mska revs uids uats _)), SecretSubkeyPkt p ss) -> ((Subs, Just (TK pkp mska revs uids uats [(SecretSubkeyPkt p ss, SigVOther 0 B.empty, Nothing)])), []) + ((Uids, Just (TK pkp mska revs uids uats subs)), SecretKeyPkt p sk) -> ((Revs, Just (TK p (Just sk) [] [] [] [])), [TK pkp mska revs uids uats subs]) + ((UAts, Just (TK pkp mska revs uids uats subs)), SignaturePkt sp) -> ((UAts, Just (TK pkp mska revs uids (addUAtSig sp uats) subs)), []) + ((UAts, Just (TK pkp mska revs uids uats subs)), UserAttributePkt u) -> ((UAts, Just (TK pkp mska revs uids (uats ++ [(u, [])]) subs)), []) + ((UAts, Just (TK pkp mska revs uids uats subs)), UserIdPkt u) -> ((Uids, Just (TK pkp mska revs (uids ++ [(u, [])]) uats subs)), []) + ((UAts, Just (TK pkp mska revs uids uats _)), SecretSubkeyPkt p ss) -> ((Subs, Just (TK pkp mska revs uids uats [(SecretSubkeyPkt p ss, SigVOther 0 B.empty, Nothing)])), []) + ((UAts, Just (TK pkp mska revs uids uats subs)), SecretKeyPkt p ss) -> ((Revs, Just (TK p (Just ss) [] [] [] [])), [TK pkp mska revs uids uats subs]) + ((Subs, Just (TK pkp mska revs uids uats subs)), SecretSubkeyPkt p ss) -> ((Subs, Just (TK pkp mska revs uids uats (subs ++ [(SecretSubkeyPkt p ss, SigVOther 0 B.empty, Nothing)]))), []) + ((Subs, Just (TK pkp mska revs uids uats subs)), SignaturePkt sp) -> case sType sp of + SubkeyBindingSig -> ((Subs, Just (TK pkp mska revs uids uats (setBSig sp subs))), []) + SubkeyRevocationSig -> ((Subs, Just (TK pkp mska revs uids uats (setRSig sp subs))), []) + _ -> dropOrError intolerant s $ "Unexpected subkey sig: " ++ show (fst s) ++ "/" ++ show i + ((Subs, Just (TK pkp mska revs uids uats subs)), SecretKeyPkt p sk) -> ((Revs, Just (TK p (Just sk) [] [] [] [])), [TK pkp mska revs uids uats subs]) + ((_,_), TrustPkt _) -> (s, []) + _ -> dropOrError intolerant s $ "Unexpected packet: " ++ show (fst s) ++ "/" ++ show i addUidSig s uids = init uids ++ [(\(u, us) -> (u, us ++ [s])) (last uids)] addUAtSig s uats = init uats ++ [(\(u, us) -> (u, us ++ [s])) (last uats)] setBSig s subs = init subs ++ [(\(p, _, r) -> (p, s, r)) (last subs)] @@ -80,9 +90,9 @@ sType (SigV3 st _ _ _ _ _ _) = st sType (SigV4 st _ _ _ _ _ _) = st sType _ = error "This should never happen." - dropOrError :: Bool -> (Phase, Maybe TK) -> String -> CU.ConduitStateResult (Phase, Maybe TK) Pkt TK + dropOrError :: Bool -> (Phase, Maybe TK) -> String -> ((Phase, Maybe TK), [TK]) dropOrError True _ e = error e - dropOrError False s _ = CU.StateProducing s [] + dropOrError False s _ = (s, []) sinkKeyringMap :: MonadResource m => Sink TK m Keyring sinkKeyringMap = CL.fold (flip insert) empty diff --git a/Data/Conduit/OpenPGP/Verify.hs b/Data/Conduit/OpenPGP/Verify.hs --- a/Data/Conduit/OpenPGP/Verify.hs +++ b/Data/Conduit/OpenPGP/Verify.hs @@ -8,25 +8,24 @@ ) where import Data.Conduit -import qualified Data.Conduit.Util as CU import Data.Time.Clock (UTCTime) import Codec.Encryption.OpenPGP.Internal (PktStreamContext(..), emptyPSC) import Codec.Encryption.OpenPGP.Types import Codec.Encryption.OpenPGP.Verify (verifySig) +import qualified Data.Conduit.List as CL conduitVerify :: MonadResource m => Keyring -> Maybe UTCTime -> Conduit Pkt m (Either String Verification) -conduitVerify kr mt = CU.conduitState emptyPSC push close +conduitVerify kr mt = CL.concatMapAccum (flip push) emptyPSC where - push state ld@(LiteralDataPkt {}) = return $ CU.StateProducing (state { lastLD = ld }) [] - push state uid@(UserIdPkt _) = return $ CU.StateProducing (state { lastUIDorUAt = uid }) [] - push state uat@(UserAttributePkt _) = return $ CU.StateProducing (state { lastUIDorUAt = uat }) [] - push state pk@(PublicKeyPkt _) = return $ CU.StateProducing (state { lastPrimaryKey = pk }) [] - push state pk@(PublicSubkeyPkt _) = return $ CU.StateProducing (state { lastSubkey = pk }) [] - push state sk@(SecretKeyPkt _ _) = return $ CU.StateProducing (state { lastPrimaryKey = sk }) [] - push state sk@(SecretSubkeyPkt _ _) = return $ CU.StateProducing (state { lastSubkey = sk }) [] - push state sig@(SignaturePkt (SigV4 {})) = return $ CU.StateProducing state { lastSig = sig } [verifySig kr sig state mt] - push state (OnePassSignaturePkt _ _ _ _ _ False) = return $ CU.StateProducing state [] - push state _ = return $ CU.StateProducing state [] - close _ = return [] + push state ld@(LiteralDataPkt {}) = (state { lastLD = ld }, []) + push state uid@(UserIdPkt _) = (state { lastUIDorUAt = uid }, []) + push state uat@(UserAttributePkt _) = (state { lastUIDorUAt = uat }, []) + push state pk@(PublicKeyPkt _) = (state { lastPrimaryKey = pk }, []) + push state pk@(PublicSubkeyPkt _) = (state { lastSubkey = pk }, []) + push state sk@(SecretKeyPkt _ _) = (state { lastPrimaryKey = sk }, []) + push state sk@(SecretSubkeyPkt _ _) = (state { lastSubkey = sk }, []) + push state sig@(SignaturePkt (SigV4 {})) = (state { lastSig = sig }, [verifySig kr sig state mt]) + push state (OnePassSignaturePkt _ _ _ _ _ False) = (state, []) + push state _ = (state, []) normLineEndings = id -- FIXME diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,5 +1,5 @@ Name: hOpenPGP -Version: 0.6 +Version: 0.6.1 Synopsis: native Haskell implementation of OpenPGP (RFC4880) Description: native Haskell implementation of OpenPGP (RFC4880) Homepage: http://floss.scru.org/hOpenPGP/ @@ -133,10 +133,10 @@ , bytestring , bzlib , cereal - , cereal-conduit >= 0.6 && < 0.7 - , conduit >= 0.5 && < 0.6 + , cereal-conduit >= 0.6 && < 0.8 + , conduit >= 0.5 && < 1.1 , containers - , crypto-pubkey >= 0.1.1 + , crypto-pubkey >= 0.1.2 , cryptohash , ixset >= 1.0 , lens >= 3.0 @@ -157,10 +157,10 @@ , bytestring , bzlib , cereal - , cereal-conduit >= 0.6 && < 0.7 - , conduit >= 0.5 && < 0.6 + , cereal-conduit + , conduit , containers - , crypto-pubkey >= 0.1.1 + , crypto-pubkey >= 0.1.2 , cryptohash , ixset >= 1.0 , lens >= 3.0 diff --git a/tests/suite.hs b/tests/suite.hs --- a/tests/suite.hs +++ b/tests/suite.hs @@ -15,8 +15,8 @@ import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) import Codec.Encryption.OpenPGP.Types import Data.Conduit.Cereal (conduitGet) -import Data.Conduit.OpenPGP.Compression (conduitDecompress) -import Data.Conduit.OpenPGP.Keyring (conduitToTKs, sinkKeyringMap) +import Data.Conduit.OpenPGP.Compression (conduitCompress, conduitDecompress) +import Data.Conduit.OpenPGP.Keyring (conduitToTKs, conduitToTKsDropping, sinkKeyringMap) import Data.Conduit.OpenPGP.Verify (conduitVerify) import qualified Data.ByteString as B @@ -35,7 +35,7 @@ bs <- B.readFile $ "tests/data/" ++ fpr let firstpass = runGet get bs case fmap unBlock firstpass of - Left err -> assertFailure $ "First pass failed on " ++ fpr + Left _ -> assertFailure $ "First pass failed on " ++ fpr Right [] -> assertFailure $ "First pass of " ++ fpr ++ " decoded to nothing." Right packs -> do let roundtrip = runPut $ put (Block packs) let secondpass = runGet (get :: Get (Block Pkt)) roundtrip @@ -64,7 +64,7 @@ testConduitOutputLength :: FilePath -> DC.Conduit B.ByteString (DC.ResourceT IO) b -> Int -> Assertion testConduitOutputLength fpr c target = do len <- DC.runResourceT $ CB.sourceFile ("tests/data/" ++ fpr) DC.$= c DC.$$ counter - assertEqual ("expected length" ++ show target) target len + assertEqual ("expected length " ++ show target) target len testKeyIDandFingerprint :: FilePath -> String -> Assertion testKeyIDandFingerprint fpr kf = do @@ -84,7 +84,7 @@ testVerifyMessage keyring message issuers = do kr <- DC.runResourceT $ CB.sourceFile ("tests/data/" ++ keyring) DC.$= conduitGet get DC.$= conduitToTKs DC.$$ sinkKeyringMap verification <- DC.runResourceT $ CB.sourceFile ("tests/data/" ++ message) DC.$= conduitGet get DC.$= conduitDecompress DC.$= conduitVerify kr Nothing DC.$$ CL.consume - let verification' = map (fmap (fingerprint . verificationSigner)) verification + let verification' = map (fmap (fingerprint . _verificationSigner)) verification assertEqual (keyring ++ " for " ++ message) (map Right issuers) verification' tests :: [Test] @@ -209,8 +209,23 @@ , testCase "6F87040E" (testVerifyMessage "pubring.gpg" "6F87040E.pubkey" ([fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E", fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D", fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC"])) , testCase "6F87040E-cr" (testVerifyMessage "pubring.gpg" "6F87040E-cr.pubkey" ([fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC", fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC", fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E", fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D", fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC"])) , testCase "simple RSA secret key" (testVerifyMessage "pubring.gpg" "simple.seckey" ([fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"])) + ], + testGroup "Compression group" [ + testCase "compressedsig.gpg" (testCompression "compressedsig.gpg") + , testCase "compressedsig-zlib.gpg" (testCompression "compressedsig-zlib.gpg") + , testCase "compressedsig-bzip2.gpg" (testCompression "compressedsig-bzip2.gpg") + ], + testGroup "Conduit length group" [ + testCase "conduitCompress (ZIP)" (testConduitOutputLength "pubring.gpg" (cgp DC.=$= conduitCompress ZIP) 1) + , testCase "conduitCompress (Zlib)" (testConduitOutputLength "pubring.gpg" (cgp DC.=$= conduitCompress ZLIB) 1) + , testCase "conduitCompress (BZip2)" (testConduitOutputLength "pubring.gpg" (cgp DC.=$= conduitCompress BZip2) 1) + , testCase "conduitToTKs" (testConduitOutputLength "pubring.gpg" (cgp DC.=$= conduitToTKs) 4) + , testCase "conduitToTKsDropping" (testConduitOutputLength "pubring.gpg" (cgp DC.=$= conduitToTKsDropping) 4) ] ] + +cgp :: DC.Conduit B.ByteString (DC.ResourceT IO) Pkt +cgp = conduitGet (get :: Get Pkt) fp :: String -> TwentyOctetFingerprint fp = read