summaryrefslogtreecommitdiff
path: root/KeyRing.hs
diff options
context:
space:
mode:
Diffstat (limited to 'KeyRing.hs')
-rw-r--r--KeyRing.hs166
1 files changed, 130 insertions, 36 deletions
diff --git a/KeyRing.hs b/KeyRing.hs
index 8cd4bcb..c595d77 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -529,6 +529,70 @@ parseSpec grip spec = (topspec,subspec)
529filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)] 529filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)]
530filterMatches spec ks = filter (matchSpec spec) ks 530filterMatches spec ks = filter (matchSpec spec) ks
531 531
532selectSecretKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
533selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db
534
535selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
536selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db
537
538selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
539selectKey0 wantPublic (spec,mtag) db = do
540 let Message ps = flattenKeys wantPublic db
541 ys = snd $ seek_key spec ps
542 flip (maybe (listToMaybe ys)) mtag $ \tag -> do
543 let (subspec,ys1) = (KeyTag y tag,ys1) where y:ys1 = ys
544 zs = snd $ seek_key subspec ys1
545 listToMaybe zs
546
547seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet])
548seek_key (KeyGrip grip) sec = (pre, subs)
549 where
550 (pre,subs) = break pred sec
551 pred p@(SecretKeyPacket {}) = matchpr grip p == grip
552 pred p@(PublicKeyPacket {}) = matchpr grip p == grip
553 pred _ = False
554
555seek_key (KeyTag key tag) ps = if null bs
556 then (ps,[])
557 else if null qs
558 then let (as',bs') = seek_key (KeyTag key tag) (tail bs)
559 in (as ++ (head bs:as'), bs')
560 else (reverse (tail qs), head qs : reverse rs ++ bs)
561 where
562 (as,bs) = break (\p -> isSignaturePacket p
563 && has_tag tag p
564 && isJust (signature_issuer p)
565 && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) )
566 ps
567 (rs,qs) = break isKey (reverse as)
568
569 has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
570 || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
571
572seek_key (KeyUidMatch pat) ps = if null bs
573 then (ps,[])
574 else if null qs
575 then let (as',bs') = seek_key (KeyUidMatch pat) (tail bs)
576 in (as ++ (head bs:as'), bs')
577 else (reverse (tail qs), head qs : reverse rs ++ bs)
578 where
579 (as,bs) = break (isInfixOf pat . uidStr)
580 ps
581 (rs,qs) = break isKey (reverse as)
582
583 uidStr (UserIDPacket s) = s
584 uidStr _ = ""
585
586
587importPEMKey db' tup = do
588 try db' $ \(db',report0) -> do
589 r <- doImport doDecrypt
590 db'
591 tup
592 try r $ \(db'',report) -> do
593 return $ KikiSuccess (db'', report0 ++ report)
594 where doDecrypt = todo
595
532 596
533buildKeyDB :: FilePath -> FilePath -> Maybe String -> KeyRingData 597buildKeyDB :: FilePath -> FilePath -> Maybe String -> KeyRingData
534 -> IO (KikiCondition ((KeyDB,Maybe String,Maybe Packet),[(FilePath,KikiReportAction)])) 598 -> IO (KikiCondition ((KeyDB,Maybe String,Maybe Packet),[(FilePath,KikiReportAction)]))
@@ -559,14 +623,6 @@ buildKeyDB secring pubring grip0 keyring = do
559 try r $ \(db'',report) -> do 623 try r $ \(db'',report) -> do
560 return $ KikiSuccess (db'', report0 ++ report) 624 return $ KikiSuccess (db'', report0 ++ report)
561 625
562 importPEMKey db' tup = do
563 try db' $ \(db',report0) -> do
564 r <- doImport doDecrypt
565 db'
566 tup
567 try r $ \(db'',report) -> do
568 return $ KikiSuccess (db'', report0 ++ report)
569
570 doDecrypt = todo 626 doDecrypt = todo
571 627
572 -- KeyRings (todo: KikiCondition reporting?) 628 -- KeyRings (todo: KikiCondition reporting?)
@@ -929,46 +985,71 @@ runKeyRing keyring = do
929 if not $ null failed_locks 985 if not $ null failed_locks
930 then return $ KikiResult (FailedToLock failed_locks) [] 986 then return $ KikiResult (FailedToLock failed_locks) []
931 else do 987 else do
988
989 let doDecrypt = todo
990
991 -- merge all keyrings, PEM files, and wallets
992 bresult <- buildKeyDB secring pubring grip0 keyring
993
994 try' bresult $ \((db,grip,wk),report_imports) -> do
995
996 nonexistents <-
997 filterM (fmap not . doesFileExist . fst)
998 $ do (f,t) <- Map.toList (kFiles keyring)
999 f <- resolveInputFile secring pubring f
1000 return (f,t)
1001
1002
932 -- create nonexistent files via external commands 1003 -- create nonexistent files via external commands
933 report_externals <- do 1004 externals_ret <- do
934 let cmds = do 1005 let cmds = do
935 (f,(rtyp,ftyp)) <- Map.toList (kFiles keyring) 1006 (fname,(rtyp,ftyp)) <- nonexistents
936 cmd <- maybeToList (initializer rtyp) 1007 cmd <- maybeToList (initializer rtyp)
937 (_,subspec) <- fmap (parseSpec "") $ getUsage ftyp 1008 (topspec,subspec) <- fmap (parseSpec $ maybe "" id grip)
938 fname <- resolveInputFile secring pubring f 1009 $ getUsage ftyp
939 return (fname,maybe "" id subspec,cmd) 1010 let ms = map fst $ filterMatches topspec (Map.toList db)
940 forM cmds $ \(fname,usage,cmd) -> do 1011 guard $ isNothing $ selectPublicKey (topspec,subspec) db
1012 return (fname,subspec,ms,cmd)
1013 rs <- forM cmds $ \tup@(fname,subspec,ms,cmd) -> do
941 e <- systemEnv [ ("file",fname) 1014 e <- systemEnv [ ("file",fname)
942 , ("usage",usage) ] 1015 , ("usage",maybe "" id subspec) ]
943 cmd 1016 cmd
944 case e of 1017 case e of
945 ExitFailure num -> return (fname,FailedExternal num) 1018 ExitFailure num -> return (tup,FailedExternal num)
946 ExitSuccess -> return (fname,ExternallyGeneratedFile) 1019 ExitSuccess -> return (tup,ExternallyGeneratedFile)
947 1020
948 -- merge all keyrings, PEM files, and wallets 1021 v <- foldM importPEMKey (KikiSuccess (db,[])) $ do
949 bresult <- buildKeyDB secring pubring grip0 keyring 1022 (tup,r) <- rs
1023 guard $ case r of
1024 ExternallyGeneratedFile -> True
1025 _ -> False
1026 return tup
950 1027
951 try' bresult $ \((db,grip,wk),report_imports) -> do 1028 try v $ \(db,import_rs) -> do
952 let a = KeyRingRuntime 1029 return $ KikiSuccess (db, map (\((f,_,_,_),r)->(f,r)) rs
953 { rtPubring = pubring 1030 ++ import_rs)
954 , rtSecring = secring
955 , rtGrip = grip
956 , rtKeyDB = db
957 }
958 1031
959 r <- writeWalletKeys keyring db wk 1032 try' externals_ret $ \(db,report_externals) -> do
960 try' r $ \report_wallets -> do
961 1033
962 r <- writeRingKeys keyring db wk secring pubring 1034 r <- writeWalletKeys keyring db wk
963 try' r $ \report_rings -> do 1035 try' r $ \report_wallets -> do
964 1036
965 -- todo writePEMKeys 1037 r <- writeRingKeys keyring db wk secring pubring
1038 try' r $ \report_rings -> do
966 1039
967 return $ KikiResult (KikiSuccess a) 1040 -- todo writePEMKeys
968 $ concat [ report_externals 1041
969 , report_imports 1042 let rt = KeyRingRuntime
970 , report_wallets 1043 { rtPubring = pubring
971 , report_rings ] 1044 , rtSecring = secring
1045 , rtGrip = grip
1046 , rtKeyDB = db
1047 }
1048 return $ KikiResult (KikiSuccess rt)
1049 $ concat [ report_imports
1050 , report_externals
1051 , report_wallets
1052 , report_rings ]
972 1053
973 forM_ lked $ \(Just lk, fname) -> dotlock_release lk 1054 forM_ lked $ \(Just lk, fname) -> dotlock_release lk
974 1055
@@ -1524,6 +1605,19 @@ sortByHint fname f = sortBy (comparing gethint)
1524 gethint = maybe defnum originalNum . Map.lookup fname . locations . f 1605 gethint = maybe defnum originalNum . Map.lookup fname . locations . f
1525 defnum = -1 1606 defnum = -1
1526 1607
1608flattenKeys :: Bool -> KeyDB -> Message
1609flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db)
1610 where
1611 prefilter = if isPublic then id else filter isSecret
1612 where
1613 isSecret (_,(KeyData
1614 (MappedPacket { packet=(SecretKeyPacket {})})
1615 _
1616 _
1617 _)) = True
1618 isSecret _ = False
1619
1620
1527flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket] 1621flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket]
1528flattenTop fname ispub (KeyData key sigs uids subkeys) = 1622flattenTop fname ispub (KeyData key sigs uids subkeys) =
1529 unk ispub key : 1623 unk ispub key :