summaryrefslogtreecommitdiff
path: root/lib/KeyRing/BuildKeyDB.hs
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/KeyRing/BuildKeyDB.hs
parent365bdcd8d9f4a08aaae35fc27722d268f4af9041 (diff)
Promote KeyDB to a type.
Diffstat (limited to 'lib/KeyRing/BuildKeyDB.hs')
-rw-r--r--lib/KeyRing/BuildKeyDB.hs101
1 files changed, 59 insertions, 42 deletions
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