diff options
Diffstat (limited to 'lib/KeyRing/BuildKeyDB.hs')
-rw-r--r-- | lib/KeyRing/BuildKeyDB.hs | 109 |
1 files changed, 25 insertions, 84 deletions
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 | |||
185 | db_rings = Map.foldlWithKey' mergeIt emptyKeyDB transformed | 185 | db_rings = Map.foldlWithKey' mergeIt emptyKeyDB transformed |
186 | where | 186 | where |
187 | mergeIt db f (_,dbtrans) | 187 | mergeIt db f (_,dbtrans) |
188 | = KeyDB { byKeyKey = Map.unionWith mergeKeyData (byKeyKey db) (byKeyKey dbtrans) | 188 | = mergeKeyDB mergeKeyData db dbtrans |
189 | } | ||
190 | -- | reportTrans | 189 | -- | reportTrans |
191 | -- events, indexed by file | 190 | -- events, indexed by file |
192 | reportTrans :: [(FilePath, KikiReportAction)] | 191 | reportTrans :: [(FilePath, KikiReportAction)] |
@@ -226,7 +225,7 @@ buildKeyDB ctx grip0 keyring = do | |||
226 | -- TODO: KikiCondition reporting for spill/fill usage mismatch? | 225 | -- TODO: KikiCondition reporting for spill/fill usage mismatch? |
227 | -- TODO: parseSpec3 | 226 | -- TODO: parseSpec3 |
228 | let (topspec,subspec) = parseSpec grip usage | 227 | let (topspec,subspec) = parseSpec grip usage |
229 | ms = map fst $ filterMatches topspec (Map.toList $ byKeyKey db) | 228 | ms = map fst $ filterMatches topspec (kkData db) |
230 | cmd = initializer stream | 229 | cmd = initializer stream |
231 | return (n,subspec,ms,stream, cmd) | 230 | return (n,subspec,ms,stream, cmd) |
232 | 231 | ||
@@ -338,7 +337,7 @@ scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret Ma | |||
338 | case p of | 337 | case p of |
339 | _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p) | 338 | _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p) |
340 | _ | isKey p && is_subkey p -> (top,p,ret p) | 339 | _ | isKey p && is_subkey p -> (top,p,ret p) |
341 | _ | isUserID p -> (top,p,ret p) | 340 | _ | isJust (isUserID p) -> (top,p,ret p) |
342 | _ | isTrust p -> (top,sub,updateTrust top sub prev p) | 341 | _ | isTrust p -> (top,sub,updateTrust top sub prev p) |
343 | _ -> (top,sub,ret p) | 342 | _ -> (top,sub,ret p) |
344 | 343 | ||
@@ -385,10 +384,14 @@ doImportG | |||
385 | -> IO (KikiCondition (KeyDB, [(FilePath,KikiReportAction)])) | 384 | -> IO (KikiCondition (KeyDB, [(FilePath,KikiReportAction)])) |
386 | doImportG transcode db m0 tags fname key = do | 385 | doImportG transcode db m0 tags fname key = do |
387 | let kk = head m0 | 386 | let kk = head m0 |
388 | Just kd@(KeyData top topsigs uids subs) = Map.lookup kk (byKeyKey db) | 387 | {- |
388 | let Just kd@(KeyData top topsigs uids subs) = Map.lookup kk (byKeyKey db) | ||
389 | kdr <- insertSubkey transcode kk kd tags fname key | 389 | kdr <- insertSubkey transcode kk kd tags fname key |
390 | try kdr $ \(kd',rrs) -> return $ KikiSuccess ( db { byKeyKey = Map.insert kk kd' (byKeyKey db) } | 390 | try kdr $ \(kd',rrs) -> return $ KikiSuccess ( alterKeyDB (const $ Just kd') kk db |
391 | , rrs) | 391 | , rrs ) |
392 | -} | ||
393 | let go (Just kd@(KeyData top topsigs uids subs)) = insertSubkey transcode kk kd tags fname key | ||
394 | transmuteAt go kk db | ||
392 | 395 | ||
393 | 396 | ||
394 | iswallet :: FileType -> Bool | 397 | iswallet :: FileType -> Bool |
@@ -487,7 +490,7 @@ outgoing_names db hostdbs0 = IPsToWriteToHostsFile $ do | |||
487 | guard $ all (null . Hosts.namesForAddress addr) hostdbs0 | 490 | guard $ all (null . Hosts.namesForAddress addr) hostdbs0 |
488 | return addr | 491 | return addr |
489 | where | 492 | where |
490 | gpgnames = map getHostnames $ Map.elems $ byKeyKey db | 493 | gpgnames = map getHostnames $ keyData db |
491 | 494 | ||
492 | filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)] | 495 | filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)] |
493 | filterMatches spec ks = filter (matchSpec spec . snd) ks | 496 | filterMatches spec ks = filter (matchSpec spec . snd) ks |
@@ -513,14 +516,13 @@ generateInternals :: | |||
513 | -> [(GenerateKeyParams,StreamInfo)] | 516 | -> [(GenerateKeyParams,StreamInfo)] |
514 | -> IO (KikiCondition (KeyDB, [(FilePath, KikiReportAction)])) | 517 | -> IO (KikiCondition (KeyDB, [(FilePath, KikiReportAction)])) |
515 | generateInternals transcode mwk db gens = do | 518 | generateInternals transcode mwk db gens = do |
516 | case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) (byKeyKey db) of | 519 | case mwk of |
517 | Just kd0 -> do | ||
518 | kd <- foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens | ||
519 | try kd $ \(kd,reportGens) -> do | ||
520 | let kk = keykey $ packet $ fromJust mwk | ||
521 | return $ KikiSuccess ( KeyDB { byKeyKey = Map.insert kk kd (byKeyKey db) } | ||
522 | , reportGens ) | ||
523 | Nothing -> return $ KikiSuccess (db,[]) | 520 | Nothing -> return $ KikiSuccess (db,[]) |
521 | Just mpkt -> do | ||
522 | let kk = keykey (packet mpkt) | ||
523 | transmuteAt (go kk) kk db | ||
524 | where | ||
525 | go kk (Just kd0) = foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens | ||
524 | 526 | ||
525 | mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext | 527 | mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext |
526 | -> IO | 528 | -> IO |
@@ -549,7 +551,7 @@ mergeHostFiles krd db ctx = do | |||
549 | 551 | ||
550 | hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL' ctx) hns | 552 | hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL' ctx) hns |
551 | 553 | ||
552 | let gpgnames = map getHostnames $ Map.elems (byKeyKey db) | 554 | let gpgnames = map getHostnames $ keyData db |
553 | os = do | 555 | os = do |
554 | Hostnames addr ns _ _ <- gpgnames | 556 | Hostnames addr ns _ _ <- gpgnames |
555 | n <- ns | 557 | n <- ns |
@@ -578,8 +580,7 @@ mergeHostFiles krd db ctx = do | |||
578 | 580 | ||
579 | -- 2. replace gpg annotations with those in U | 581 | -- 2. replace gpg annotations with those in U |
580 | -- forM use_db | 582 | -- forM use_db |
581 | db' <- Traversable.mapM (setHostnames addrs u1) (byKeyKey db) | 583 | db' <- mapKeyDB (setHostnames addrs u1) db |
582 | <&> \m -> db { byKeyKey = m } | ||
583 | 584 | ||
584 | return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,addrs)),[]) | 585 | return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,addrs)),[]) |
585 | 586 | ||
@@ -625,7 +626,7 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs) | |||
625 | -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets | 626 | -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets |
626 | mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB | 627 | mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB |
627 | mergeit db adding@(n,(top,sub,ptt@(p,trustmap))) | 628 | mergeit db adding@(n,(top,sub,ptt@(p,trustmap))) |
628 | | isKey top = db { byKeyKey = Map.alter update (keykey top) (byKeyKey db) } | 629 | | isKey top = alterKeyDB update (keykey top) db |
629 | where | 630 | where |
630 | update Nothing = Just $ KeyData (mappedPacketWithHint filename p n) [] Map.empty Map.empty | 631 | update Nothing = Just $ KeyData (mappedPacketWithHint filename p n) [] Map.empty Map.empty |
631 | update (Just kd) = dbInsertPacket kd filename adding | 632 | update (Just kd) = dbInsertPacket kd filename adding |
@@ -947,8 +948,7 @@ setHostnames (IPsToWriteToHostsFile outgoing_names) hosts kd@(KeyData topmp tops | |||
947 | uids0 = fmap zapIfHasName uids | 948 | uids0 = fmap zapIfHasName uids |
948 | fstuid = head $ do | 949 | fstuid = head $ do |
949 | p <- map packet $ flattenAllUids "" True uids | 950 | p <- map packet $ flattenAllUids "" True uids |
950 | guard $ isUserID p | 951 | maybeToList $ isUserID p |
951 | return $ uidkey p | ||
952 | uids1 = Map.adjust addnames fstuid uids0 | 952 | uids1 = Map.adjust addnames fstuid uids0 |
953 | addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin | 953 | addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin |
954 | where | 954 | where |
@@ -1068,15 +1068,15 @@ dbInsertPacket kd filename (n,(top,sub,ptt@(p,trustmap))) = update (Just kd) | |||
1068 | ,show (fingerprint top, fingerprint p)] | 1068 | ,show (fingerprint top, fingerprint p)] |
1069 | update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p | 1069 | update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p |
1070 | = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys) | 1070 | = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys) |
1071 | update (Just (KeyData key sigs uids subkeys)) | isUserID p | 1071 | update (Just (KeyData key sigs uids subkeys)) | Just uid <- isUserID p |
1072 | = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids) | 1072 | = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) uid uids) |
1073 | subkeys | 1073 | subkeys |
1074 | update (Just (KeyData key sigs uids subkeys)) | 1074 | update (Just (KeyData key sigs uids subkeys)) |
1075 | = case sub of | 1075 | = case sub of |
1076 | MarkerPacket -> Just $ KeyData key (mergeSig (first (flip (mappedPacketWithHint filename) n) ptt) sigs) uids subkeys | 1076 | MarkerPacket -> Just $ KeyData key (mergeSig (first (flip (mappedPacketWithHint filename) n) ptt) sigs) uids subkeys |
1077 | UserIDPacket {} -> Just $ KeyData key | 1077 | UserIDPacket uid-> Just $ KeyData key |
1078 | sigs | 1078 | sigs |
1079 | (Map.alter (mergeUidSig n ptt) (uidkey sub) uids) | 1079 | (Map.alter (mergeUidSig n ptt) uid uids) |
1080 | subkeys | 1080 | subkeys |
1081 | _ | isKey sub -> Just $ KeyData key | 1081 | _ | isKey sub -> Just $ KeyData key |
1082 | sigs | 1082 | sigs |
@@ -1351,15 +1351,6 @@ extractRSAKeyFields kvs = do | |||
1351 | nlen = S.length bs | 1351 | nlen = S.length bs |
1352 | 1352 | ||
1353 | 1353 | ||
1354 | selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet | ||
1355 | selectKey0 wantPublic (spec,mtag) db = do | ||
1356 | let Message ps = flattenKeys wantPublic $ byKeyKey db | ||
1357 | ys = snd $ seek_key spec ps | ||
1358 | flip (maybe (listToMaybe ys)) mtag $ \tag -> do | ||
1359 | case ys of | ||
1360 | y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1 | ||
1361 | [] -> Nothing | ||
1362 | |||
1363 | -- TODO: Data.ByteString.Lazy now exports this. | 1354 | -- TODO: Data.ByteString.Lazy now exports this. |
1364 | toStrict :: L.ByteString -> S.ByteString | 1355 | toStrict :: L.ByteString -> S.ByteString |
1365 | toStrict = foldr1 (<>) . L.toChunks | 1356 | toStrict = foldr1 (<>) . L.toChunks |
@@ -1374,53 +1365,3 @@ packetFromPublicRSAKey notBefore n e = | |||
1374 | , v3_days_of_validity = Nothing | 1365 | , v3_days_of_validity = Nothing |
1375 | } | 1366 | } |
1376 | 1367 | ||
1377 | flattenKeys :: Bool -> Map.Map KeyKey KeyData -> Message | ||
1378 | flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) | ||
1379 | (prefilter . Map.assocs $ db) | ||
1380 | where | ||
1381 | prefilter = if isPublic then id else filter isSecret | ||
1382 | where | ||
1383 | isSecret (_,(KeyData | ||
1384 | (MappedPacket { packet=(SecretKeyPacket {})}) | ||
1385 | _ | ||
1386 | _ | ||
1387 | _)) = True | ||
1388 | isSecret _ = False | ||
1389 | |||
1390 | seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet]) | ||
1391 | seek_key (KeyGrip grip) sec = (pre, subs) | ||
1392 | where | ||
1393 | (pre,subs) = break pred sec | ||
1394 | pred p@(SecretKeyPacket {}) = matchpr grip p == grip | ||
1395 | pred p@(PublicKeyPacket {}) = matchpr grip p == grip | ||
1396 | pred _ = False | ||
1397 | |||
1398 | seek_key (KeyTag key tag) ps | ||
1399 | | null bs = (ps, []) | ||
1400 | | null qs = | ||
1401 | let (as', bs') = seek_key (KeyTag key tag) (tail bs) in | ||
1402 | (as ++ (head bs : as'), bs') | ||
1403 | | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs) | ||
1404 | where | ||
1405 | (as,bs) = break (\p -> isSignaturePacket p | ||
1406 | && has_tag tag p | ||
1407 | && isJust (signature_issuer p) | ||
1408 | && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) ) | ||
1409 | ps | ||
1410 | (rs,qs) = break isKey (reverse as) | ||
1411 | |||
1412 | has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) | ||
1413 | || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) | ||
1414 | |||
1415 | seek_key (KeyUidMatch pat) ps | ||
1416 | | null bs = (ps, []) | ||
1417 | | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in | ||
1418 | (as ++ (head bs : as'), bs') | ||
1419 | | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs) | ||
1420 | where | ||
1421 | (as,bs) = break (isInfixOf pat . uidStr) ps | ||
1422 | (rs,qs) = break isKey (reverse as) | ||
1423 | |||
1424 | uidStr (UserIDPacket s) = s | ||
1425 | uidStr _ = "" | ||
1426 | |||