summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
authorJoe Crayne <joe@jerkface.net>2019-07-11 23:43:16 -0400
committerJoe Crayne <joe@jerkface.net>2019-07-11 23:43:16 -0400
commit352b340868f52d4749180c1ceb63e599170abada (patch)
tree34127970fff880afee59e55254433faf811e02ed /lib
parent365bdcd8d9f4a08aaae35fc27722d268f4af9041 (diff)
Promote KeyDB to a type.
Diffstat (limited to 'lib')
-rw-r--r--lib/KeyRing.hs14
-rw-r--r--lib/KeyRing/BuildKeyDB.hs101
-rw-r--r--lib/Kiki.hs4
-rw-r--r--lib/Transforms.hs16
4 files changed, 79 insertions, 56 deletions
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index bc3af6a..c40eba7 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -437,10 +437,10 @@ selectPublicKeyAndSigs :: (KeySpec,Maybe String) -> KeyDB -> [(KeyKey,Packet,[Pa
437selectPublicKeyAndSigs (spec,mtag) db = 437selectPublicKeyAndSigs (spec,mtag) db =
438 case mtag of 438 case mtag of
439 Nothing -> do 439 Nothing -> do
440 (kk,r) <- Map.toList $ fmap (findbyspec spec) db 440 (kk,r) <- Map.toList $ fmap (findbyspec spec) (byKeyKey db)
441 (sub,sigs) <- r 441 (sub,sigs) <- r
442 return (kk,sub,sigs) 442 return (kk,sub,sigs)
443 Just tag -> Map.toList (Map.filter (matchSpec spec) db) >>= findsubs tag 443 Just tag -> Map.toList (Map.filter (matchSpec spec) (byKeyKey db)) >>= findsubs tag
444 where 444 where
445 topresult kd = (keyPacket kd, map (packet .fst) $ keySigAndTrusts kd) 445 topresult kd = (keyPacket kd, map (packet .fst) $ keySigAndTrusts kd)
446 446
@@ -625,7 +625,7 @@ coinKeysOwnedBy :: KeyDB -> Maybe Packet -> [(CryptoCoins.CoinNetwork,MappedPack
625coinKeysOwnedBy db wk = do 625coinKeysOwnedBy db wk = do
626 wk <- maybeToList wk 626 wk <- maybeToList wk
627 let kk = keykey wk 627 let kk = keykey wk
628 KeyData top topsigs uids subs <- maybeToList $ Map.lookup kk db 628 KeyData top topsigs uids subs <- maybeToList $ Map.lookup kk (byKeyKey db)
629 (subkk,SubKey mp sigs) <- Map.toList subs 629 (subkk,SubKey mp sigs) <- Map.toList subs
630 let sub = packet mp 630 let sub = packet mp
631 guard $ isCryptoCoinKey sub 631 guard $ isCryptoCoinKey sub
@@ -689,7 +689,7 @@ guardAuthentic rt keydata = guard (isauth rt keydata)
689 689
690isauth :: KeyRingRuntime -> KeyData -> Bool 690isauth :: KeyRingRuntime -> KeyData -> Bool
691isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk 691isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk
692 where wk = workingKey (rtGrip rt) (rtKeyDB rt) 692 where wk = workingKey (rtGrip rt) (byKeyKey $ rtKeyDB rt)
693 dont_have (KeyData p _ _ _) = not . Map.member (rtPubring rt) 693 dont_have (KeyData p _ _ _) = not . Map.member (rtPubring rt)
694 $ locations p 694 $ locations p
695 has_good_sig wk (KeyData k sigs uids subs) = any goodsig $ Map.toList uids 695 has_good_sig wk (KeyData k sigs uids subs) = any goodsig $ Map.toList uids
@@ -756,7 +756,7 @@ writeRingKeys krd rt {- db wk secring pubring -} unspilled report_manips = do
756 (error $ f ++ ": write public or secret key to file?") 756 (error $ f ++ ": write public or secret key to file?")
757 importByExistingMaster kd@(KeyData p _ _ _) = 757 importByExistingMaster kd@(KeyData p _ _ _) =
758 fmap originallyPublic $ Map.lookup f $ locations p 758 fmap originallyPublic $ Map.lookup f $ locations p
759 d <- sortByHint f keyMappedPacket (Map.elems db') 759 d <- sortByHint f keyMappedPacket (Map.elems $ byKeyKey db')
760 acc <- maybeToList $ Map.lookup f0 (rtRingAccess rt) 760 acc <- maybeToList $ Map.lookup f0 (rtRingAccess rt)
761 only_public <- maybeToList $ wantedForFill acc (fill stream) d 761 only_public <- maybeToList $ wantedForFill acc (fill stream) d
762 guard $ only_public || isSecretKey (keyPacket d) 762 guard $ only_public || isSecretKey (keyPacket d)
@@ -1021,7 +1021,7 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do
1021 -- ms = map (keykey . fst) $ selectAll True (topspec,subspec) db 1021 -- ms = map (keykey . fst) $ selectAll True (topspec,subspec) db
1022 -- ms = filterMatches topspec $ Map.toList db 1022 -- ms = filterMatches topspec $ Map.toList db
1023 ns = do 1023 ns = do
1024 (kk,kd) <- filterMatches topspec $ Map.toList db 1024 (kk,kd) <- filterMatches topspec $ Map.toList $ byKeyKey db
1025 return (kk , subkeysForExport subspec kd) 1025 return (kk , subkeysForExport subspec kd)
1026 return (fname,subspec,ns,stream) 1026 return (fname,subspec,ns,stream)
1027 (exports0,ambiguous) = partition (\(_,_,ns,_)->null $ drop 1 $ (ns>>=snd)) 1027 (exports0,ambiguous) = partition (\(_,_,ns,_)->null $ drop 1 $ (ns>>=snd))
@@ -1069,7 +1069,7 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do
1069 usage <- take 1 $ mapMaybe usageFromFilter [fill stream,spill stream] 1069 usage <- take 1 $ mapMaybe usageFromFilter [fill stream,spill stream]
1070 let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage 1070 let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage
1071 guard $ null $ do 1071 guard $ null $ do
1072 (kk,kd) <- filterMatches topspec $ Map.toList db 1072 (kk,kd) <- filterMatches topspec $ Map.toList $ byKeyKey db
1073 subkeysForExport subspec kd 1073 subkeysForExport subspec kd
1074 return (f,stream) 1074 return (f,stream)
1075 where 1075 where
diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs
index a3df62d..c5754f1 100644
--- a/lib/KeyRing/BuildKeyDB.hs
+++ b/lib/KeyRing/BuildKeyDB.hs
@@ -36,6 +36,7 @@ import qualified Data.ByteString.Lazy as L (ByteString, concat, empty,
36 null, toChunks, 36 null, toChunks,
37 toStrict, head) 37 toStrict, head)
38import Data.Char 38import Data.Char
39import Data.Functor
39import Data.List 40import Data.List
40import qualified Data.Map as Map 41import qualified Data.Map as Map
41import Data.Maybe 42import Data.Maybe
@@ -191,7 +192,7 @@ buildKeyDB ctx grip0 keyring = do
191 , rtGrip = grip 192 , rtGrip = grip
192 , rtWorkingKey = wk 193 , rtWorkingKey = wk
193 , rtRingAccess = accs 194 , rtRingAccess = accs
194 , rtKeyDB = Map.empty 195 , rtKeyDB = emptyKeyDB
195 , rtPassphrases = transcode 196 , rtPassphrases = transcode
196 } 197 }
197 -- autosigns and deletes 198 -- autosigns and deletes
@@ -199,7 +200,7 @@ buildKeyDB ctx grip0 keyring = do
199 let trans :: InputFile -> (StreamInfo,Message) -> IO (KikiCondition (KikiReport,KeyDB)) 200 let trans :: InputFile -> (StreamInfo,Message) -> IO (KikiCondition (KikiReport,KeyDB))
200 trans f (info,ps) = do 201 trans f (info,ps) = do
201 let manip = combineTransforms (transforms info) 202 let manip = combineTransforms (transforms info)
202 rt1 = rt0 { rtKeyDB = merge Map.empty f ps } 203 rt1 = rt0 { rtKeyDB = merge emptyKeyDB f ps }
203 acc = Just Sec /= Map.lookup f accs 204 acc = Just Sec /= Map.lookup f accs
204 r <- performManipulations doDecrypt rt1 mwk manip 205 r <- performManipulations doDecrypt rt1 mwk manip
205 try r $ \(rt2,report) -> do 206 try r $ \(rt2,report) -> do
@@ -214,10 +215,11 @@ buildKeyDB ctx grip0 keyring = do
214#endif 215#endif
215 try transformed0 $ \transformed -> do 216 try transformed0 $ \transformed -> do
216 let -- | db_rings - all keyrings combined into one 217 let -- | db_rings - all keyrings combined into one
217 db_rings :: Map.Map KeyKey KeyData 218 db_rings = Map.foldlWithKey' mergeIt emptyKeyDB transformed
218 db_rings = Map.foldlWithKey' mergeIt Map.empty transformed
219 where 219 where
220 mergeIt db f (_,dbtrans) = Map.unionWith mergeKeyData db dbtrans 220 mergeIt db f (_,dbtrans)
221 = KeyDB { byKeyKey = Map.unionWith mergeKeyData (byKeyKey db) (byKeyKey dbtrans)
222 }
221 -- | reportTrans 223 -- | reportTrans
222 -- events, indexed by file 224 -- events, indexed by file
223 reportTrans :: [(FilePath, KikiReportAction)] 225 reportTrans :: [(FilePath, KikiReportAction)]
@@ -257,7 +259,7 @@ buildKeyDB ctx grip0 keyring = do
257 -- TODO: KikiCondition reporting for spill/fill usage mismatch? 259 -- TODO: KikiCondition reporting for spill/fill usage mismatch?
258 -- TODO: parseSpec3 260 -- TODO: parseSpec3
259 let (topspec,subspec) = parseSpec grip usage 261 let (topspec,subspec) = parseSpec grip usage
260 ms = map fst $ filterMatches topspec (Map.toList db) 262 ms = map fst $ filterMatches topspec (Map.toList $ byKeyKey db)
261 cmd = initializer stream 263 cmd = initializer stream
262 return (n,subspec,ms,stream, cmd) 264 return (n,subspec,ms,stream, cmd)
263 265
@@ -356,25 +358,35 @@ merge :: KeyDB -> InputFile -> Message -> KeyDB
356merge db inputfile (Message ps) = merge_ db filename qs 358merge db inputfile (Message ps) = merge_ db filename qs
357 where 359 where
358 filename = resolveForReport Nothing inputfile 360 filename = resolveForReport Nothing inputfile
359
360 qs = scanPackets filename ps 361 qs = scanPackets filename ps
361 362
362 scanPackets :: FilePath -> [Packet] -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))] 363-- Aggregate packets into a list of triples:
363 scanPackets filename [] = [] 364--
364 scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret MarkerPacket) p) ps 365-- A top (master) key
365 where 366--
366 ret p = (p,Map.empty) 367-- A subkey, or if this entry corresponds to the master-key, this field is a
367 doit (top,sub,prev) p = 368-- MarkerPacket placeholder.
368 case p of 369--
369 _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p) 370-- An optional trust packet in the form of a singleton or empty Map whose key
370 _ | isKey p && is_subkey p -> (top,p,ret p) 371-- is the filename.
371 _ | isUserID p -> (top,p,ret p) 372scanPackets :: FilePath -> [Packet] -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
372 _ | isTrust p -> (top,sub,updateTrust top sub prev p) 373scanPackets filename [] = []
373 _ -> (top,sub,ret p) 374scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret MarkerPacket) p) ps
374 375 where
375 updateTrust top (PublicKeyPacket {}) (pre,t) p = (pre,Map.insert filename p t) -- public 376 ret p = (p,Map.empty)
376 updateTrust (PublicKeyPacket {}) _ (pre,t) p = (pre,Map.insert filename p t) -- public 377 doit (top,sub,prev) p =
377 updateTrust _ _ (pre,t) p = (pre,Map.insert filename p t) -- secret 378 case p of
379 _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p)
380 _ | isKey p && is_subkey p -> (top,p,ret p)
381 _ | isUserID p -> (top,p,ret p)
382 _ | isTrust p -> (top,sub,updateTrust top sub prev p)
383 _ -> (top,sub,ret p)
384
385 -- Most arguments are ignored and we simply create the singleton trust-map when appropriate.
386 -- XXX: Simplify this?
387 updateTrust top (PublicKeyPacket {}) (pre,t) p = (pre,Map.insert filename p t) -- public
388 updateTrust (PublicKeyPacket {}) _ (pre,t) p = (pre,Map.insert filename p t) -- public
389 updateTrust _ _ (pre,t) p = (pre,Map.insert filename p t) -- secret
378 390
379 391
380mergeKeyData :: KeyData -> KeyData -> KeyData 392mergeKeyData :: KeyData -> KeyData -> KeyData
@@ -405,17 +417,18 @@ mergeKeyData (KeyData atop asigs auids asubs)
405 417
406doImportG 418doImportG
407 :: PacketTranscoder 419 :: PacketTranscoder
408 -> Map.Map KeyKey KeyData 420 -> KeyDB
409 -> [KeyKey] -- m0, only head is used 421 -> [KeyKey] -- m0, only head is used
410 -> [SignatureSubpacket] -- tags 422 -> [SignatureSubpacket] -- tags
411 -> InputFile 423 -> InputFile
412 -> Packet 424 -> Packet
413 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) 425 -> IO (KikiCondition (KeyDB, [(FilePath,KikiReportAction)]))
414doImportG transcode db m0 tags fname key = do 426doImportG transcode db m0 tags fname key = do
415 let kk = head m0 427 let kk = head m0
416 Just kd@(KeyData top topsigs uids subs) = Map.lookup kk db 428 Just kd@(KeyData top topsigs uids subs) = Map.lookup kk (byKeyKey db)
417 kdr <- insertSubkey transcode kk kd tags fname key 429 kdr <- insertSubkey transcode kk kd tags fname key
418 try kdr $ \(kd',rrs) -> return $ KikiSuccess (Map.insert kk kd' db, rrs) 430 try kdr $ \(kd',rrs) -> return $ KikiSuccess ( db { byKeyKey = Map.insert kk kd' (byKeyKey db) }
431 , rrs)
419 432
420 433
421iswallet :: FileType -> Bool 434iswallet :: FileType -> Bool
@@ -514,7 +527,7 @@ outgoing_names db hostdbs0 = IPsToWriteToHostsFile $ do
514 guard $ all (null . Hosts.namesForAddress addr) hostdbs0 527 guard $ all (null . Hosts.namesForAddress addr) hostdbs0
515 return addr 528 return addr
516 where 529 where
517 gpgnames = map getHostnames $ Map.elems db 530 gpgnames = map getHostnames $ Map.elems $ byKeyKey db
518 531
519filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)] 532filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)]
520filterMatches spec ks = filter (matchSpec spec . snd) ks 533filterMatches spec ks = filter (matchSpec spec . snd) ks
@@ -522,9 +535,9 @@ filterMatches spec ks = filter (matchSpec spec . snd) ks
522importSecretKey :: 535importSecretKey ::
523 (PacketTranscoder) 536 (PacketTranscoder)
524 -> KikiCondition 537 -> KikiCondition
525 (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]) 538 (KeyDB, [(FilePath, KikiReportAction)])
526 -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t) 539 -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t)
527 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) 540 -> IO (KikiCondition (KeyDB, [(FilePath, KikiReportAction)]))
528importSecretKey transcode db' tup = do 541importSecretKey transcode db' tup = do
529 try db' $ \(db',report0) -> do 542 try db' $ \(db',report0) -> do
530 r <- doImport transcode 543 r <- doImport transcode
@@ -536,16 +549,17 @@ importSecretKey transcode db' tup = do
536generateInternals :: 549generateInternals ::
537 PacketTranscoder 550 PacketTranscoder
538 -> Maybe MappedPacket 551 -> Maybe MappedPacket
539 -> Map.Map KeyKey KeyData 552 -> KeyDB
540 -> [(GenerateKeyParams,StreamInfo)] 553 -> [(GenerateKeyParams,StreamInfo)]
541 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) 554 -> IO (KikiCondition (KeyDB, [(FilePath, KikiReportAction)]))
542generateInternals transcode mwk db gens = do 555generateInternals transcode mwk db gens = do
543 case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) db of 556 case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) (byKeyKey db) of
544 Just kd0 -> do 557 Just kd0 -> do
545 kd <- foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens 558 kd <- foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens
546 try kd $ \(kd,reportGens) -> do 559 try kd $ \(kd,reportGens) -> do
547 let kk = keykey $ packet $ fromJust mwk 560 let kk = keykey $ packet $ fromJust mwk
548 return $ KikiSuccess (Map.insert kk kd db,reportGens) 561 return $ KikiSuccess ( KeyDB { byKeyKey = Map.insert kk kd (byKeyKey db) }
562 , reportGens )
549 Nothing -> return $ KikiSuccess (db,[]) 563 Nothing -> return $ KikiSuccess (db,[])
550 564
551mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext 565mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext
@@ -575,7 +589,7 @@ mergeHostFiles krd db ctx = do
575 589
576 hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL' ctx) hns 590 hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL' ctx) hns
577 591
578 let gpgnames = map getHostnames $ Map.elems db 592 let gpgnames = map getHostnames $ Map.elems (byKeyKey db)
579 os = do 593 os = do
580 Hostnames addr ns _ _ <- gpgnames 594 Hostnames addr ns _ _ <- gpgnames
581 n <- ns 595 n <- ns
@@ -604,7 +618,8 @@ mergeHostFiles krd db ctx = do
604 618
605 -- 2. replace gpg annotations with those in U 619 -- 2. replace gpg annotations with those in U
606 -- forM use_db 620 -- forM use_db
607 db' <- Traversable.mapM (setHostnames addrs u1) db 621 db' <- Traversable.mapM (setHostnames addrs u1) (byKeyKey db)
622 <&> \m -> db { byKeyKey = m }
608 623
609 return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,addrs)),[]) 624 return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,addrs)),[])
610 625
@@ -649,7 +664,8 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs)
649 where 664 where
650 -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets 665 -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets
651 mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB 666 mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB
652 mergeit db adding@(n,(top,sub,ptt@(p,trustmap))) | isKey top = Map.alter update (keykey top) db 667 mergeit db adding@(n,(top,sub,ptt@(p,trustmap)))
668 | isKey top = db { byKeyKey = Map.alter update (keykey top) (byKeyKey db) }
653 where 669 where
654 update Nothing = Just $ KeyData (mappedPacketWithHint filename p n) [] Map.empty Map.empty 670 update Nothing = Just $ KeyData (mappedPacketWithHint filename p n) [] Map.empty Map.empty
655 update (Just kd) = dbInsertPacket kd filename adding 671 update (Just kd) = dbInsertPacket kd filename adding
@@ -828,9 +844,9 @@ matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us
828 844
829doImport 845doImport
830 :: PacketTranscoder 846 :: PacketTranscoder
831 -> Map.Map KeyKey KeyData 847 -> KeyDB
832 -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t) 848 -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t)
833 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) 849 -> IO (KikiCondition (KeyDB, [(FilePath,KikiReportAction)]))
834doImport transcode db (fname,subspec,ms,typ -> typ,_) = do 850doImport transcode db (fname,subspec,ms,typ -> typ,_) = do
835 flip (maybe $ return CannotImportMasterKey) 851 flip (maybe $ return CannotImportMasterKey)
836 subspec $ \tag -> do 852 subspec $ \tag -> do
@@ -1389,7 +1405,7 @@ extractRSAKeyFields kvs = do
1389 1405
1390selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet 1406selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
1391selectKey0 wantPublic (spec,mtag) db = do 1407selectKey0 wantPublic (spec,mtag) db = do
1392 let Message ps = flattenKeys wantPublic db 1408 let Message ps = flattenKeys wantPublic $ byKeyKey db
1393 ys = snd $ seek_key spec ps 1409 ys = snd $ seek_key spec ps
1394 flip (maybe (listToMaybe ys)) mtag $ \tag -> do 1410 flip (maybe (listToMaybe ys)) mtag $ \tag -> do
1395 case ys of 1411 case ys of
@@ -1410,8 +1426,9 @@ packetFromPublicRSAKey notBefore n e =
1410 , v3_days_of_validity = Nothing 1426 , v3_days_of_validity = Nothing
1411 } 1427 }
1412 1428
1413flattenKeys :: Bool -> KeyDB -> Message 1429flattenKeys :: Bool -> Map.Map KeyKey KeyData -> Message
1414flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db) 1430flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd)
1431 (prefilter . Map.assocs $ db)
1415 where 1432 where
1416 prefilter = if isPublic then id else filter isSecret 1433 prefilter = if isPublic then id else filter isSecret
1417 where 1434 where
diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index 20ab1f2..4fb19ff 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -449,7 +449,7 @@ generateHostsFile fw rt = do
449names :: KeyRingRuntime -> Maybe Hostnames 449names :: KeyRingRuntime -> Maybe Hostnames
450names rt = do wk <- rtWorkingKey rt 450names rt = do wk <- rtWorkingKey rt
451 -- XXX unnecessary signature check 451 -- XXX unnecessary signature check
452 return $ getHostnames (rtKeyDB rt Map.! keykey wk) 452 return $ getHostnames (byKeyKey (rtKeyDB rt) Map.! keykey wk)
453 453
454getssh :: (Char8.ByteString, SockAddr, KeyData) -> Char8.ByteString 454getssh :: (Char8.ByteString, SockAddr, KeyData) -> Char8.ByteString
455getssh (contactname,_addr,kd) = do 455getssh (contactname,_addr,kd) = do
@@ -545,7 +545,7 @@ writePublicKeyFiles rt fw grip oname wkaddr = do
545 either warn (write fw "ssh_host_rsa_key.pub") $ show_ssh' "ssh-server" grip (rtKeyDB rt) 545 either warn (write fw "ssh_host_rsa_key.pub") $ show_ssh' "ssh-server" grip (rtKeyDB rt)
546 either warn (write fw $ ipsecCertPath oname) $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket 546 either warn (write fw $ ipsecCertPath oname) $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket
547 547
548 let onionkeys = mapMaybe namedContact $ Map.elems $ rtKeyDB rt 548 let onionkeys = mapMaybe namedContact $ Map.elems $ byKeyKey $ rtKeyDB rt
549 cs = filter (\(_,_,kd) -> notme kd) onionkeys 549 cs = filter (\(_,_,kd) -> notme kd) onionkeys
550 kk = keykey (fromJust $ rtWorkingKey rt) 550 kk = keykey (fromJust $ rtWorkingKey rt)
551 notme kd = keykey (keyPacket kd) /= kk 551 notme kd = keykey (keyPacket kd) /= kk
diff --git a/lib/Transforms.hs b/lib/Transforms.hs
index 8eaa482..7a676b0 100644
--- a/lib/Transforms.hs
+++ b/lib/Transforms.hs
@@ -62,8 +62,13 @@ data KeyData = KeyData
62 , keyUids :: (Map.Map String ([SigAndTrust],OriginMap)) -- uids 62 , keyUids :: (Map.Map String ([SigAndTrust],OriginMap)) -- uids
63 , keySubKeys :: (Map.Map KeyKey SubKey) -- subkeys 63 , keySubKeys :: (Map.Map KeyKey SubKey) -- subkeys
64 } deriving Show 64 } deriving Show
65type KeyDB = Map.Map KeyKey KeyData
66 65
66data KeyDB = KeyDB
67 { byKeyKey :: Map.Map KeyKey KeyData
68 } deriving Show
69
70emptyKeyDB :: KeyDB
71emptyKeyDB = KeyDB { byKeyKey = Map.empty }
67 72
68 73
69data KeyRingRuntime = KeyRingRuntime 74data KeyRingRuntime = KeyRingRuntime
@@ -779,7 +784,7 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do
779 784
780-- TODO: Use fingerprint to narrow candidates. 785-- TODO: Use fingerprint to narrow candidates.
781candidateSignerKeys :: KeyDB -> Packet -> [Packet] 786candidateSignerKeys :: KeyDB -> Packet -> [Packet]
782candidateSignerKeys db sig = map keyPacket $ Map.elems db 787candidateSignerKeys db sig = map keyPacket $ Map.elems (byKeyKey db)
783 788
784performManipulations :: 789performManipulations ::
785 (PacketDecrypter) 790 (PacketDecrypter)
@@ -790,9 +795,10 @@ performManipulations ::
790performManipulations doDecrypt rt wk manip = do 795performManipulations doDecrypt rt wk manip = do
791 let db = rtKeyDB rt 796 let db = rtKeyDB rt
792 performAll kd = foldM perform (KikiSuccess (kd,[])) $ manip rt kd 797 performAll kd = foldM perform (KikiSuccess (kd,[])) $ manip rt kd
793 r <- Traversable.mapM performAll db 798 r <- Traversable.mapM performAll (byKeyKey db)
794 try (sequenceA r) $ \db -> do 799 try (sequenceA r) $ \db -> do
795 return $ KikiSuccess (rt { rtKeyDB = fmap fst db }, concatMap snd $ Map.elems db) 800 return $ KikiSuccess ( rt { rtKeyDB = (rtKeyDB rt) { byKeyKey = fmap fst db } }
801 , concatMap snd $ Map.elems db)
796 where 802 where
797 perform :: KikiCondition (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport)) 803 perform :: KikiCondition (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport))
798 perform kd (InducerSignature uid subpaks) = do 804 perform kd (InducerSignature uid subpaks) = do
@@ -812,7 +818,7 @@ performManipulations doDecrypt rt wk manip = do
812 selfsigs = filter (\(sig,v,whosign) -> isJust (v >> Just wkun >>= guard 818 selfsigs = filter (\(sig,v,whosign) -> isJust (v >> Just wkun >>= guard
813 . (== keykey whosign) 819 . (== keykey whosign)
814 . keykey)) vs 820 . keykey)) vs
815 keys = map keyPacket $ Map.elems (rtKeyDB rt) -- TODO candidateSignerKeys (rtKeyDB rt) sig 821 keys = map keyPacket $ Map.elems (byKeyKey $ rtKeyDB rt) -- TODO candidateSignerKeys (rtKeyDB rt) sig
816 overs sig = signatures $ Message (keys ++ [keyPacket kd,UserIDPacket uid,sig]) 822 overs sig = signatures $ Message (keys ++ [keyPacket kd,UserIDPacket uid,sig])
817 vs :: [ ( Packet -- signature 823 vs :: [ ( Packet -- signature
818 , Maybe SignatureOver -- Nothing means non-verified 824 , Maybe SignatureOver -- Nothing means non-verified