diff options
Diffstat (limited to 'lib/KeyDB.hs')
-rw-r--r-- | lib/KeyDB.hs | 29 |
1 files changed, 25 insertions, 4 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 | ||