diff options
author | Joe Crayne <joe@jerkface.net> | 2019-07-16 17:49:16 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2019-07-16 17:49:16 -0400 |
commit | 0c5c03357144de4acb872dc4d8c6ba4b6f6ae76e (patch) | |
tree | 0e8828223176ee9dd16acc0a4da48a48586badcf | |
parent | ddd90a85bc57099779ac83022735bbb0889a04c2 (diff) |
Faster subkey verificaiton.
-rw-r--r-- | lib/KeyDB.hs | 29 | ||||
-rw-r--r-- | lib/Transforms.hs | 38 |
2 files changed, 55 insertions, 12 deletions
diff --git a/lib/KeyDB.hs b/lib/KeyDB.hs index 0bc0fb3..c92f614 100644 --- a/lib/KeyDB.hs +++ b/lib/KeyDB.hs | |||
@@ -5,11 +5,13 @@ module KeyDB | |||
5 | , SubKey(..) | 5 | , SubKey(..) |
6 | , KeyData(..) | 6 | , KeyData(..) |
7 | , KeyDB | 7 | , KeyDB |
8 | , KeyGrip(..) | ||
8 | , emptyKeyDB | 9 | , emptyKeyDB |
9 | , keyData | 10 | , keyData |
10 | , kkData | 11 | , kkData |
11 | , lookupKeyData | 12 | , lookupKeyData |
12 | , lookupByGrip | 13 | , lookupByGrip |
14 | , associatedKeys | ||
13 | , fingerprintGrip | 15 | , fingerprintGrip |
14 | , smallprGrip | 16 | , smallprGrip |
15 | , transmute | 17 | , transmute |
@@ -26,6 +28,7 @@ module KeyDB | |||
26 | , flattenKeys | 28 | , flattenKeys |
27 | , flattenFiltered | 29 | , flattenFiltered |
28 | , UidString(..) | 30 | , UidString(..) |
31 | , buildGripMap | ||
29 | ) where | 32 | ) where |
30 | 33 | ||
31 | import Control.Monad | 34 | import Control.Monad |
@@ -79,6 +82,17 @@ data KeyDB = KeyDB | |||
79 | , byGrip :: IMap KeyGrip [KeyKey] | 82 | , byGrip :: IMap KeyGrip [KeyKey] |
80 | } deriving Show | 83 | } deriving Show |
81 | 84 | ||
85 | |||
86 | -- | TODO: This is an optimization to legacy (pre-KeyDB) code. Ultimately it | ||
87 | -- should be unneccessary. | ||
88 | buildGripMap :: [Packet] -> IMap KeyGrip [Packet] | ||
89 | buildGripMap ps = foldr go I.empty ps | ||
90 | where | ||
91 | go pkt m = I.alter (\case Just ks -> Just (pkt:ks) | ||
92 | Nothing -> Just [pkt]) | ||
93 | (fingerprintGrip . fingerprint $ pkt) | ||
94 | m | ||
95 | |||
82 | emptyKeyDB :: KeyDB | 96 | emptyKeyDB :: KeyDB |
83 | emptyKeyDB = KeyDB { byKeyKey = Map.empty, byGrip = I.empty } | 97 | emptyKeyDB = KeyDB { byKeyKey = Map.empty, byGrip = I.empty } |
84 | 98 | ||
@@ -110,16 +124,23 @@ transmute perform update db = do | |||
110 | -- Note: We currently leave deleted-keys in the byGrip map. | 124 | -- Note: We currently leave deleted-keys in the byGrip map. |
111 | , concatMap snd $ Map.elems bkk ) | 125 | , concatMap snd $ Map.elems bkk ) |
112 | 126 | ||
127 | mpGrip :: MappedPacket -> KeyGrip | ||
128 | mpGrip mp = fingerprintGrip $ fingerprint $ packet mp | ||
129 | |||
130 | associatedKeys :: KeyData -> [MappedPacket] | ||
131 | associatedKeys kd = keyMappedPacket kd : [ k | SubKey k _ <- Map.elems (keySubKeys kd) ] | ||
132 | |||
113 | alterKeyDB :: (Maybe KeyData -> Maybe KeyData) -> KeyKey -> KeyDB -> KeyDB | 133 | alterKeyDB :: (Maybe KeyData -> Maybe KeyData) -> KeyKey -> KeyDB -> KeyDB |
114 | alterKeyDB update kk db = db | 134 | alterKeyDB update kk db = db |
115 | { byKeyKey = Map.alter update kk (byKeyKey db) | 135 | { byKeyKey = Map.alter update kk (byKeyKey db) |
116 | , byGrip = case Map.lookup kk (byKeyKey db) of | 136 | , byGrip = case Map.lookup kk (byKeyKey db) of |
117 | Just _ -> byGrip db | 137 | Just _ -> byGrip db |
118 | Nothing -> case update Nothing of | 138 | Nothing -> case update Nothing of |
119 | Just kd -> I.alter (\case Nothing -> Just [kk] | 139 | Just kd -> let go g m = I.alter (\case Nothing -> Just [kk] |
120 | Just kks -> Just $ mergeL [kk] kks) | 140 | Just kks -> Just $ mergeL [kk] kks) |
121 | (fingerprintGrip $ fingerprint $ packet $ keyMappedPacket kd) | 141 | g |
122 | (byGrip db) | 142 | m |
143 | in foldr go (byGrip db) $ map mpGrip $ associatedKeys kd | ||
123 | Nothing -> byGrip db | 144 | Nothing -> byGrip db |
124 | } | 145 | } |
125 | 146 | ||
diff --git a/lib/Transforms.hs b/lib/Transforms.hs index e7097ba..f3cd5e3 100644 --- a/lib/Transforms.hs +++ b/lib/Transforms.hs | |||
@@ -16,6 +16,7 @@ import Data.Ord | |||
16 | import Data.OpenPGP | 16 | import Data.OpenPGP |
17 | import Data.OpenPGP.Util | 17 | import Data.OpenPGP.Util |
18 | import Data.Word | 18 | import Data.Word |
19 | import qualified IntMapClass as I | ||
19 | import KeyDB | 20 | import KeyDB |
20 | import KeyRing.Types | 21 | import KeyRing.Types |
21 | import FunctorToMaybe | 22 | import FunctorToMaybe |
@@ -236,12 +237,19 @@ has_tag tag p = isSignaturePacket p | |||
236 | 237 | ||
237 | 238 | ||
238 | 239 | ||
239 | verifyBindings :: [Packet] -> [Packet] -> ([SignatureOver], [SignatureOver]) | 240 | verifyBindings :: I.IMap KeyGrip [Packet] -> [Packet] -> ([SignatureOver], [SignatureOver]) |
240 | verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs) | 241 | verifyBindings gmap nonkeys = (top ++ filter isSubkeySignature embedded,othersigs) |
241 | where | 242 | where |
242 | verified = do | 243 | verified = do |
243 | sig <- signatures (Message nonkeys) | 244 | sigs <- signatures (Message nonkeys) |
244 | let v = verify (Message keys) sig | 245 | sig <- signatures_over sigs |
246 | let grip = issuerGrip sig | ||
247 | gks = concat [ ks | g <- maybeToList grip | ||
248 | , ks <- maybeToList $ I.lookup g gmap ] | ||
249 | kmsg = Message | ||
250 | $ if null gks then maybe (concat $ I.elems gmap) (const []) grip | ||
251 | else gks | ||
252 | v = verify kmsg (sigs { signatures_over = [sig] }) | ||
245 | guard (not . null $ signatures_over v) | 253 | guard (not . null $ signatures_over v) |
246 | return v | 254 | return v |
247 | (top,othersigs) = partition isSubkeySignature verified | 255 | (top,othersigs) = partition isSubkeySignature verified |
@@ -292,13 +300,15 @@ getBindings :: | |||
292 | getBindings pkts = (sigs,bindings) | 300 | getBindings pkts = (sigs,bindings) |
293 | where | 301 | where |
294 | (sigs,concat->bindings) = unzip $ do | 302 | (sigs,concat->bindings) = unzip $ do |
295 | keys <- disjoint_fp (filter isKey pkts) | 303 | keys <- take 1 $ disjoint_fp (filter isKey pkts) |
296 | let (bs,sigs) = verifyBindings keys pkts | 304 | let gmap = buildGripMap keys |
305 | (bs,sigs) = verifyBindings gmap pkts | ||
297 | return . ((keys,sigs),) $ do | 306 | return . ((keys,sigs),) $ do |
298 | b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs | 307 | b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs |
299 | i <- map signature_issuer (signatures_over b) | 308 | i <- map signature_issuer (signatures_over b) |
300 | i <- maybeToList i | 309 | i <- maybeToList i |
301 | who <- maybeToList $ find_key (show . fingerprint) (Message keys) i | 310 | g <- maybeToList $ smallprGrip i |
311 | who <- take 1 $ concat $ maybeToList $ I.lookup g gmap | ||
302 | let (code,claimants) = | 312 | let (code,claimants) = |
303 | case () of | 313 | case () of |
304 | _ | who == topkey b -> (1,[]) | 314 | _ | who == topkey b -> (1,[]) |
@@ -627,7 +637,19 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do | |||
627 | 637 | ||
628 | -- TODO: Use fingerprint to narrow candidates. | 638 | -- TODO: Use fingerprint to narrow candidates. |
629 | candidateSignerKeys :: KeyDB -> Packet -> [Packet] | 639 | candidateSignerKeys :: KeyDB -> Packet -> [Packet] |
630 | candidateSignerKeys db sig = map keyPacket $ keyData db | 640 | candidateSignerKeys db sig = |
641 | case issuerGrip sig of | ||
642 | Just g -> concatMap (map packet . associatedKeys) $ lookupByGrip g db | ||
643 | _ -> map keyPacket $ keyData db | ||
644 | |||
645 | issuerGrip :: Packet -> Maybe KeyGrip | ||
646 | issuerGrip sig = do | ||
647 | IssuerPacket hexfp <- find isIssuer (hashed_subpackets sig ++ unhashed_subpackets sig) | ||
648 | smallprGrip hexfp | ||
649 | |||
650 | isIssuer :: SignatureSubpacket -> Bool | ||
651 | isIssuer (IssuerPacket _) = True | ||
652 | isIssuer _ = False | ||
631 | 653 | ||
632 | performManipulations :: | 654 | performManipulations :: |
633 | (PacketDecrypter) | 655 | (PacketDecrypter) |