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-2013 Clint Adams +-- Copyright © 2012-2014 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -13,6 +13,9 @@ , emptyPSC , pubkeyToMPIs , multiplicativeInverse + , sigType + , sigPKA + , sigHA ) where import Crypto.PubKey.HashDescr (HashDescr(..), hashDescrMD5, hashDescrSHA1, hashDescrSHA224, hashDescrSHA256, hashDescrSHA384, hashDescrSHA512, hashDescrRIPEMD160) @@ -83,3 +86,18 @@ multiplicativeInverse _ 1 = 1 multiplicativeInverse q p = (n * q + 1) `div` p where n = p - multiplicativeInverse p (q `mod` p) + +sigType :: SignaturePayload -> Maybe SigType +sigType (SigV3 st _ _ _ _ _ _) = Just st +sigType (SigV4 st _ _ _ _ _ _) = Just st +sigType _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild + +sigPKA :: SignaturePayload -> Maybe PubKeyAlgorithm +sigPKA (SigV3 _ _ _ pka _ _ _) = Just pka +sigPKA (SigV4 _ pka _ _ _ _ _) = Just pka +sigPKA _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild + +sigHA :: SignaturePayload -> Maybe HashAlgorithm +sigHA (SigV3 _ _ _ _ ha _ _) = Just ha +sigHA (SigV4 _ _ ha _ _ _ _) = Just ha +sigHA _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild 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-2013 Clint Adams +-- Copyright © 2012-2014 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). 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 @@ -584,6 +584,26 @@ | OtherPacketPkt Word8 ByteString deriving (Show, Eq, Data, Typeable) -- FIXME +pktTag :: Pkt -> Word8 +pktTag (PKESKPkt {}) = 1 +pktTag (SignaturePkt _) = 2 +pktTag (SKESKPkt {}) = 3 +pktTag (OnePassSignaturePkt {}) = 4 +pktTag (SecretKeyPkt {}) = 5 +pktTag (PublicKeyPkt _) = 6 +pktTag (SecretSubkeyPkt {}) = 7 +pktTag (CompressedDataPkt {}) = 8 +pktTag (SymEncDataPkt _) = 9 +pktTag (MarkerPkt _) = 10 +pktTag (LiteralDataPkt {}) = 11 +pktTag (TrustPkt _) = 12 +pktTag (UserIdPkt _) = 13 +pktTag (PublicSubkeyPkt _) = 14 +pktTag (UserAttributePkt _) = 17 +pktTag (SymEncIntegrityProtectedDataPkt {}) = 18 +pktTag (ModificationDetectionCodePkt _) = 19 +pktTag (OtherPacketPkt t _) = t + data PKESK = PKESK { _pkeskPacketVersion :: PacketVersion , _pkeskEightOctetKeyId :: EightOctetKeyId diff --git a/Data/Conduit/OpenPGP/Filter.hs b/Data/Conduit/OpenPGP/Filter.hs new file mode 100644 --- /dev/null +++ b/Data/Conduit/OpenPGP/Filter.hs @@ -0,0 +1,152 @@ +-- Filter.hs: OpenPGP (RFC4880) packet filtering +-- Copyright © 2014 Clint Adams +-- This software is released under the terms of the Expat license. +-- (See the LICENSE file). + +module Data.Conduit.OpenPGP.Filter ( + conduitFilter + , FilterPredicates(..) + , Expr(..) + , PKPPredicate(..) + , PKPVar(..) + , PKPOp(..) + , PKPValue(..) + , SPPredicate(..) + , SPVar(..) + , SPOp(..) + , SPValue(..) + , OPredicate(..) + , OVar(..) + , OOp(..) + , OValue(..) +) where + +import qualified Data.ByteString as B +import Data.Conduit +import qualified Data.Conduit.List as CL + +import Codec.Encryption.OpenPGP.Internal (sigType, sigPKA, sigHA) +import Codec.Encryption.OpenPGP.KeyInfo (keySize) +import Codec.Encryption.OpenPGP.Types + +data FilterPredicates = FilterPredicates { + _pubKeyPktPredicate :: Expr PKPPredicate + , _sigPktPredicate :: Expr SPPredicate + , _otherPredicate :: Expr OPredicate +} + +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 + +data PKPPredicate = PKPPredicate PKPVar PKPOp PKPValue + +data PKPVar = PKPVVersion + | PKPVPKA + | PKPVKeysize + | PKPVTimestamp + +data PKPValue = PKPInt Int + | PKPPKA PubKeyAlgorithm + 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 + +data SPPredicate = SPPredicate SPVar SPOp SPValue + +data SPVar = SPVVersion + | SPVSigType + | SPVPKA + | SPVHA + +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 + +data OPredicate = OPredicate OVar OOp OValue + +data OVar = OVTag + +data OValue = OInt Int + deriving Eq + +instance Ord OValue where + compare i j = compare (ovToInt i) (ovToInt j) + +ovToInt (OInt i) = i + +conduitFilter :: MonadResource m => FilterPredicates -> Conduit Pkt m Pkt +conduitFilter = CL.filter . superPredicate + +superPredicate :: FilterPredicates -> Pkt -> Bool +superPredicate fp (PublicKeyPkt pkp) = eval pkpEval (_pubKeyPktPredicate fp) pkp +superPredicate fp (SignaturePkt sp) = eval spEval (_sigPktPredicate fp) sp +superPredicate fp p = eval oEval (_otherPredicate fp) p + +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 (keySize . _pubkey $ p) + vreduce (PKPVTimestamp, p) = PKPInt (fromIntegral (_timestamp 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) = OInt (fromIntegral (pktTag p)) 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 @@ -1,5 +1,5 @@ -- Keyring.hs: OpenPGP (RFC4880) transferable keys parsing --- Copyright © 2012-2013 Clint Adams +-- Copyright © 2012-2014 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). @@ -14,6 +14,7 @@ import qualified Data.Conduit.List as CL import Data.IxSet (empty, insert) +import Codec.Encryption.OpenPGP.Internal (sigType) import Codec.Encryption.OpenPGP.Types import Data.Conduit.OpenPGP.Keyring.Instances () @@ -58,7 +59,7 @@ ((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 + ((Subs, Just (TK pkp Nothing revs uids uats subs)), SignaturePkt sp) -> case sigType sp of Just SubkeyBindingSig -> ((Subs, Just (TK pkp Nothing revs uids uats (setBSig sp subs))), []) Just SubkeyRevocationSig -> ((Subs, Just (TK pkp Nothing revs uids uats (setRSig sp subs))), []) _ -> dropOrError intolerant s $ "Unexpected subkey sig: " ++ show (fst s) ++ "/" ++ show i @@ -76,7 +77,7 @@ ((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 + ((Subs, Just (TK pkp mska revs uids uats subs)), SignaturePkt sp) -> case sigType sp of Just SubkeyBindingSig -> ((Subs, Just (TK pkp mska revs uids uats (setBSig sp subs))), []) Just SubkeyRevocationSig -> ((Subs, Just (TK pkp mska revs uids uats (setRSig sp subs))), []) _ -> dropOrError intolerant s $ "Unexpected subkey sig: " ++ show (fst s) ++ "/" ++ show i @@ -87,9 +88,6 @@ addUAtSig s uats = init uats ++ [(\(u, us) -> (u, us ++ [s])) (last uats)] setBSig s subs = init subs ++ [(\(p, _, r) -> (p, s, r)) (last subs)] setRSig s subs = init subs ++ [(\(p, b, _) -> (p, b, Just s)) (last subs)] - sType (SigV3 st _ _ _ _ _ _) = Just st - sType (SigV4 st _ _ _ _ _ _) = Just st - sType _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild dropOrError :: Bool -> (Phase, Maybe TK) -> String -> ((Phase, Maybe TK), [TK]) dropOrError True _ e = error e dropOrError False s _ = (s, []) diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,5 +1,5 @@ Name: hOpenPGP -Version: 0.10.2 +Version: 0.11 Synopsis: native Haskell implementation of OpenPGP (RFC4880) Description: native Haskell implementation of OpenPGP (RFC4880) Homepage: http://floss.scru.org/hOpenPGP/ @@ -153,6 +153,7 @@ , Codec.Encryption.OpenPGP.Signatures , Data.Conduit.OpenPGP.Compression , Data.Conduit.OpenPGP.Decrypt + , Data.Conduit.OpenPGP.Filter , Data.Conduit.OpenPGP.Keyring , Data.Conduit.OpenPGP.Keyring.Instances , Data.Conduit.OpenPGP.Verify @@ -233,4 +234,4 @@ source-repository this type: git location: git://git.debian.org/users/clint/hOpenPGP.git - tag: v0.10.2 + tag: v0.11