diff options
Diffstat (limited to 'lib')
-rw-r--r-- | lib/KeyDB.hs | 42 |
1 files changed, 39 insertions, 3 deletions
diff --git a/lib/KeyDB.hs b/lib/KeyDB.hs index 1aef747..5e74ea4 100644 --- a/lib/KeyDB.hs +++ b/lib/KeyDB.hs | |||
@@ -1,3 +1,4 @@ | |||
1 | {-# LANGUAGE LambdaCase #-} | ||
1 | module KeyDB | 2 | module KeyDB |
2 | ( TrustMap | 3 | ( TrustMap |
3 | , SigAndTrust | 4 | , SigAndTrust |
@@ -8,6 +9,7 @@ module KeyDB | |||
8 | , keyData | 9 | , keyData |
9 | , kkData | 10 | , kkData |
10 | , lookupKeyData | 11 | , lookupKeyData |
12 | , lookupByGrip | ||
11 | , transmute | 13 | , transmute |
12 | , transmuteAt | 14 | , transmuteAt |
13 | , alterKeyDB | 15 | , alterKeyDB |
@@ -25,13 +27,21 @@ module KeyDB | |||
25 | ) where | 27 | ) where |
26 | 28 | ||
27 | import Control.Monad | 29 | import Control.Monad |
30 | import Data.Binary | ||
31 | import qualified Data.ByteString as S | ||
32 | import qualified Data.ByteString.Lazy as L | ||
28 | import Data.Functor | 33 | import Data.Functor |
29 | import Data.List | 34 | import Data.List |
30 | import qualified Data.Map.Strict as Map | 35 | import qualified Data.Map.Strict as Map |
31 | import Data.Maybe | 36 | import Data.Maybe |
32 | import Data.OpenPGP | 37 | import Data.OpenPGP |
33 | import Data.Ord | 38 | import Data.Ord |
39 | import Foreign.Storable | ||
34 | 40 | ||
41 | import Data.List.Merge | ||
42 | import Data.OpenPGP.Util | ||
43 | import qualified IntMapClass as I | ||
44 | ;import IntMapClass (IMap) | ||
35 | import KeyRing.Types | 45 | import KeyRing.Types |
36 | 46 | ||
37 | type TrustMap = Map.Map FilePath Packet | 47 | type TrustMap = Map.Map FilePath Packet |
@@ -51,12 +61,20 @@ data KeyData = KeyData | |||
51 | } deriving Show | 61 | } deriving Show |
52 | 62 | ||
53 | 63 | ||
64 | newtype KeyGrip = KeyInt Int | ||
65 | |||
66 | fingerprintGrip :: Fingerprint -> KeyGrip | ||
67 | fingerprintGrip (Fingerprint bs) = | ||
68 | case decode $ L.fromStrict $ S.drop (S.length bs - sizeOf (0::Int)) bs of | ||
69 | i -> KeyInt i | ||
70 | |||
54 | data KeyDB = KeyDB | 71 | data KeyDB = KeyDB |
55 | { byKeyKey :: Map.Map KeyKey KeyData | 72 | { byKeyKey :: Map.Map KeyKey KeyData |
73 | , byGrip :: IMap KeyGrip [KeyKey] | ||
56 | } deriving Show | 74 | } deriving Show |
57 | 75 | ||
58 | emptyKeyDB :: KeyDB | 76 | emptyKeyDB :: KeyDB |
59 | emptyKeyDB = KeyDB { byKeyKey = Map.empty } | 77 | emptyKeyDB = KeyDB { byKeyKey = Map.empty, byGrip = I.empty } |
60 | 78 | ||
61 | keyData :: KeyDB -> [KeyData] | 79 | keyData :: KeyDB -> [KeyData] |
62 | keyData db = Map.elems (byKeyKey db) | 80 | keyData db = Map.elems (byKeyKey db) |
@@ -67,6 +85,11 @@ kkData db = Map.toList (byKeyKey db) | |||
67 | lookupKeyData :: KeyKey -> KeyDB -> Maybe KeyData | 85 | lookupKeyData :: KeyKey -> KeyDB -> Maybe KeyData |
68 | lookupKeyData kk db = Map.lookup kk (byKeyKey db) | 86 | lookupKeyData kk db = Map.lookup kk (byKeyKey db) |
69 | 87 | ||
88 | lookupByGrip :: KeyGrip -> KeyDB -> [KeyData] | ||
89 | lookupByGrip k db = mapMaybe (`Map.lookup` byKeyKey db) | ||
90 | $ concat . maybeToList | ||
91 | $ I.lookup k (byGrip db) | ||
92 | |||
70 | transmute :: (Monad m, Monad kiki, Traversable kiki) => | 93 | transmute :: (Monad m, Monad kiki, Traversable kiki) => |
71 | ((KeyData, [info]) -> opcode -> m (kiki (KeyData, [info]))) -- ^ interpreter | 94 | ((KeyData, [info]) -> opcode -> m (kiki (KeyData, [info]))) -- ^ interpreter |
72 | -> (KeyData -> [opcode]) -- ^ instructions | 95 | -> (KeyData -> [opcode]) -- ^ instructions |
@@ -78,10 +101,21 @@ transmute perform update db = do | |||
78 | (update kd) | 101 | (update kd) |
79 | r <- sequenceA <$> mapM performAll (byKeyKey db) | 102 | r <- sequenceA <$> mapM performAll (byKeyKey db) |
80 | return $ r <&> \bkk -> ( db { byKeyKey = fst <$> bkk } | 103 | return $ r <&> \bkk -> ( db { byKeyKey = fst <$> bkk } |
104 | -- Note: We currently leave deleted-keys in the byGrip map. | ||
81 | , concatMap snd $ Map.elems bkk ) | 105 | , concatMap snd $ Map.elems bkk ) |
82 | 106 | ||
83 | alterKeyDB :: (Maybe KeyData -> Maybe KeyData) -> KeyKey -> KeyDB -> KeyDB | 107 | alterKeyDB :: (Maybe KeyData -> Maybe KeyData) -> KeyKey -> KeyDB -> KeyDB |
84 | alterKeyDB update kk db = db { byKeyKey = Map.alter update kk (byKeyKey db) } | 108 | alterKeyDB update kk db = db |
109 | { byKeyKey = Map.alter update kk (byKeyKey db) | ||
110 | , byGrip = case Map.lookup kk (byKeyKey db) of | ||
111 | Just _ -> byGrip db | ||
112 | Nothing -> case update Nothing of | ||
113 | Just kd -> I.alter (\case Nothing -> Just [kk] | ||
114 | Just kks -> Just $ mergeL [kk] kks) | ||
115 | (fingerprintGrip $ fingerprint $ packet $ keyMappedPacket kd) | ||
116 | (byGrip db) | ||
117 | Nothing -> byGrip db | ||
118 | } | ||
85 | 119 | ||
86 | transmuteAt :: ( Monad m | 120 | transmuteAt :: ( Monad m |
87 | , Functor kiki | 121 | , Functor kiki |
@@ -93,7 +127,9 @@ transmuteAt go kk db = do | |||
93 | 127 | ||
94 | mergeKeyDB :: (KeyData -> KeyData -> KeyData) -> KeyDB -> KeyDB -> KeyDB | 128 | mergeKeyDB :: (KeyData -> KeyData -> KeyData) -> KeyDB -> KeyDB -> KeyDB |
95 | mergeKeyDB mergeKeyData db dbtrans = | 129 | mergeKeyDB mergeKeyData db dbtrans = |
96 | KeyDB { byKeyKey = Map.unionWith mergeKeyData (byKeyKey db) (byKeyKey dbtrans) } | 130 | KeyDB { byKeyKey = Map.unionWith mergeKeyData (byKeyKey db) (byKeyKey dbtrans) |
131 | , byGrip = I.unionWith mergeL (byGrip db) (byGrip dbtrans) | ||
132 | } | ||
97 | 133 | ||
98 | mapKeyDB :: Monad m => (KeyData -> m KeyData) -> KeyDB -> m KeyDB | 134 | mapKeyDB :: Monad m => (KeyData -> m KeyData) -> KeyDB -> m KeyDB |
99 | mapKeyDB f db = fmap (\m -> db { byKeyKey = m }) $ mapM f (byKeyKey db) | 135 | mapKeyDB f db = fmap (\m -> db { byKeyKey = m }) $ mapM f (byKeyKey db) |