From 3f29bdc88a068ec3eab91a8bac12757e3a106ceb Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sat, 13 Jul 2019 21:18:22 -0400 Subject: Finished encapsulation of KeyDB. --- lib/KeyRing/BuildKeyDB.hs | 109 +++++++++++----------------------------------- 1 file changed, 25 insertions(+), 84 deletions(-) (limited to 'lib/KeyRing/BuildKeyDB.hs') diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs index 8af8198..cd1bae9 100644 --- a/lib/KeyRing/BuildKeyDB.hs +++ b/lib/KeyRing/BuildKeyDB.hs @@ -185,8 +185,7 @@ buildKeyDB ctx grip0 keyring = do db_rings = Map.foldlWithKey' mergeIt emptyKeyDB transformed where mergeIt db f (_,dbtrans) - = KeyDB { byKeyKey = Map.unionWith mergeKeyData (byKeyKey db) (byKeyKey dbtrans) - } + = mergeKeyDB mergeKeyData db dbtrans -- | reportTrans -- events, indexed by file reportTrans :: [(FilePath, KikiReportAction)] @@ -226,7 +225,7 @@ buildKeyDB ctx grip0 keyring = do -- TODO: KikiCondition reporting for spill/fill usage mismatch? -- TODO: parseSpec3 let (topspec,subspec) = parseSpec grip usage - ms = map fst $ filterMatches topspec (Map.toList $ byKeyKey db) + ms = map fst $ filterMatches topspec (kkData db) cmd = initializer stream return (n,subspec,ms,stream, cmd) @@ -338,7 +337,7 @@ scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret Ma case p of _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p) _ | isKey p && is_subkey p -> (top,p,ret p) - _ | isUserID p -> (top,p,ret p) + _ | isJust (isUserID p) -> (top,p,ret p) _ | isTrust p -> (top,sub,updateTrust top sub prev p) _ -> (top,sub,ret p) @@ -385,10 +384,14 @@ doImportG -> IO (KikiCondition (KeyDB, [(FilePath,KikiReportAction)])) doImportG transcode db m0 tags fname key = do let kk = head m0 - Just kd@(KeyData top topsigs uids subs) = Map.lookup kk (byKeyKey db) + {- + let Just kd@(KeyData top topsigs uids subs) = Map.lookup kk (byKeyKey db) kdr <- insertSubkey transcode kk kd tags fname key - try kdr $ \(kd',rrs) -> return $ KikiSuccess ( db { byKeyKey = Map.insert kk kd' (byKeyKey db) } - , rrs) + try kdr $ \(kd',rrs) -> return $ KikiSuccess ( alterKeyDB (const $ Just kd') kk db + , rrs ) + -} + let go (Just kd@(KeyData top topsigs uids subs)) = insertSubkey transcode kk kd tags fname key + transmuteAt go kk db iswallet :: FileType -> Bool @@ -487,7 +490,7 @@ outgoing_names db hostdbs0 = IPsToWriteToHostsFile $ do guard $ all (null . Hosts.namesForAddress addr) hostdbs0 return addr where - gpgnames = map getHostnames $ Map.elems $ byKeyKey db + gpgnames = map getHostnames $ keyData db filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)] filterMatches spec ks = filter (matchSpec spec . snd) ks @@ -513,14 +516,13 @@ generateInternals :: -> [(GenerateKeyParams,StreamInfo)] -> IO (KikiCondition (KeyDB, [(FilePath, KikiReportAction)])) generateInternals transcode mwk db gens = do - case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) (byKeyKey db) of - Just kd0 -> do - kd <- foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens - try kd $ \(kd,reportGens) -> do - let kk = keykey $ packet $ fromJust mwk - return $ KikiSuccess ( KeyDB { byKeyKey = Map.insert kk kd (byKeyKey db) } - , reportGens ) + case mwk of Nothing -> return $ KikiSuccess (db,[]) + Just mpkt -> do + let kk = keykey (packet mpkt) + transmuteAt (go kk) kk db + where + go kk (Just kd0) = foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext -> IO @@ -549,7 +551,7 @@ mergeHostFiles krd db ctx = do hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL' ctx) hns - let gpgnames = map getHostnames $ Map.elems (byKeyKey db) + let gpgnames = map getHostnames $ keyData db os = do Hostnames addr ns _ _ <- gpgnames n <- ns @@ -578,8 +580,7 @@ mergeHostFiles krd db ctx = do -- 2. replace gpg annotations with those in U -- forM use_db - db' <- Traversable.mapM (setHostnames addrs u1) (byKeyKey db) - <&> \m -> db { byKeyKey = m } + db' <- mapKeyDB (setHostnames addrs u1) db return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,addrs)),[]) @@ -625,7 +626,7 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs) -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB mergeit db adding@(n,(top,sub,ptt@(p,trustmap))) - | isKey top = db { byKeyKey = Map.alter update (keykey top) (byKeyKey db) } + | isKey top = alterKeyDB update (keykey top) db where update Nothing = Just $ KeyData (mappedPacketWithHint filename p n) [] Map.empty Map.empty update (Just kd) = dbInsertPacket kd filename adding @@ -947,8 +948,7 @@ setHostnames (IPsToWriteToHostsFile outgoing_names) hosts kd@(KeyData topmp tops uids0 = fmap zapIfHasName uids fstuid = head $ do p <- map packet $ flattenAllUids "" True uids - guard $ isUserID p - return $ uidkey p + maybeToList $ isUserID p uids1 = Map.adjust addnames fstuid uids0 addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin where @@ -1068,15 +1068,15 @@ dbInsertPacket kd filename (n,(top,sub,ptt@(p,trustmap))) = update (Just kd) ,show (fingerprint top, fingerprint p)] update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys) - update (Just (KeyData key sigs uids subkeys)) | isUserID p - = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids) + update (Just (KeyData key sigs uids subkeys)) | Just uid <- isUserID p + = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) uid uids) subkeys update (Just (KeyData key sigs uids subkeys)) = case sub of MarkerPacket -> Just $ KeyData key (mergeSig (first (flip (mappedPacketWithHint filename) n) ptt) sigs) uids subkeys - UserIDPacket {} -> Just $ KeyData key + UserIDPacket uid-> Just $ KeyData key sigs - (Map.alter (mergeUidSig n ptt) (uidkey sub) uids) + (Map.alter (mergeUidSig n ptt) uid uids) subkeys _ | isKey sub -> Just $ KeyData key sigs @@ -1351,15 +1351,6 @@ extractRSAKeyFields kvs = do nlen = S.length bs -selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet -selectKey0 wantPublic (spec,mtag) db = do - let Message ps = flattenKeys wantPublic $ byKeyKey db - ys = snd $ seek_key spec ps - flip (maybe (listToMaybe ys)) mtag $ \tag -> do - case ys of - y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1 - [] -> Nothing - -- TODO: Data.ByteString.Lazy now exports this. toStrict :: L.ByteString -> S.ByteString toStrict = foldr1 (<>) . L.toChunks @@ -1374,53 +1365,3 @@ packetFromPublicRSAKey notBefore n e = , v3_days_of_validity = Nothing } -flattenKeys :: Bool -> Map.Map KeyKey KeyData -> Message -flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) - (prefilter . Map.assocs $ db) - where - prefilter = if isPublic then id else filter isSecret - where - isSecret (_,(KeyData - (MappedPacket { packet=(SecretKeyPacket {})}) - _ - _ - _)) = True - isSecret _ = False - -seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet]) -seek_key (KeyGrip grip) sec = (pre, subs) - where - (pre,subs) = break pred sec - pred p@(SecretKeyPacket {}) = matchpr grip p == grip - pred p@(PublicKeyPacket {}) = matchpr grip p == grip - pred _ = False - -seek_key (KeyTag key tag) ps - | null bs = (ps, []) - | null qs = - let (as', bs') = seek_key (KeyTag key tag) (tail bs) in - (as ++ (head bs : as'), bs') - | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs) - where - (as,bs) = break (\p -> isSignaturePacket p - && has_tag tag p - && isJust (signature_issuer p) - && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) ) - ps - (rs,qs) = break isKey (reverse as) - - has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) - || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) - -seek_key (KeyUidMatch pat) ps - | null bs = (ps, []) - | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in - (as ++ (head bs : as'), bs') - | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs) - where - (as,bs) = break (isInfixOf pat . uidStr) ps - (rs,qs) = break isKey (reverse as) - - uidStr (UserIDPacket s) = s - uidStr _ = "" - -- cgit v1.2.3