diff options
-rw-r--r-- | KeyRing.hs | 67 |
1 files changed, 56 insertions, 11 deletions
@@ -441,7 +441,6 @@ data KikiResult a = KikiResult | |||
441 | keyPacket :: KeyData -> Packet | 441 | keyPacket :: KeyData -> Packet |
442 | keyPacket (KeyData k _ _ _) = packet k | 442 | keyPacket (KeyData k _ _ _) = packet k |
443 | 443 | ||
444 | -- subkeyPacket (SubKey k _ ) = packet k | ||
445 | subkeyMappedPacket :: SubKey -> MappedPacket | 444 | subkeyMappedPacket :: SubKey -> MappedPacket |
446 | subkeyMappedPacket (SubKey k _ ) = k | 445 | subkeyMappedPacket (SubKey k _ ) = k |
447 | 446 | ||
@@ -726,6 +725,33 @@ parseSpec grip spec = (topspec,subspec) | |||
726 | filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)] | 725 | filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)] |
727 | filterMatches spec ks = filter (matchSpec spec) ks | 726 | filterMatches spec ks = filter (matchSpec spec) ks |
728 | 727 | ||
728 | filterNewSubs :: FilePath -> (KeySpec,Maybe String) -> KeyData -> KeyData | ||
729 | filterNewSubs fname spec (KeyData p sigs uids subs) = KeyData p sigs uids subs' | ||
730 | where | ||
731 | matchAll = KeyGrip "" | ||
732 | |||
733 | subkeySpec (KeyGrip grip,Nothing) = (matchAll, KeyGrip grip) | ||
734 | subkeySpec (topspec,Just mtag) = (topspec , KeyTag (packet p) mtag) | ||
735 | |||
736 | match spec mps | ||
737 | = not . null | ||
738 | . snd | ||
739 | . seek_key spec | ||
740 | . map packet | ||
741 | $ mps | ||
742 | |||
743 | old sub = isJust (Map.lookup fname $ locations $ subkeyMappedPacket sub) | ||
744 | |||
745 | oldOrMatch spec sub = old sub | ||
746 | || match spec (flattenSub "" True sub) | ||
747 | |||
748 | subs' = Map.filter (if match topspec $ flattenTop "" True (KeyData p sigs uids Map.empty) | ||
749 | then oldOrMatch subspec | ||
750 | else old) | ||
751 | subs | ||
752 | where | ||
753 | (topspec,subspec) = subkeySpec spec | ||
754 | |||
729 | selectSecretKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet | 755 | selectSecretKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet |
730 | selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db | 756 | selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db |
731 | 757 | ||
@@ -1307,24 +1333,42 @@ writeRingKeys krd rt {- db wk secring pubring -} = do | |||
1307 | secring = rtSecring rt | 1333 | secring = rtSecring rt |
1308 | pubring = rtPubring rt | 1334 | pubring = rtPubring rt |
1309 | let s = do | 1335 | let s = do |
1310 | (f,f0,mutable) <- do | 1336 | (f,f0,stream) <- do |
1311 | (f0,stream) <- Map.toList (kFiles krd) | 1337 | (f0,stream) <- Map.toList (kFiles krd) |
1312 | guard (isring $ typ stream) | 1338 | guard (isring $ typ stream) |
1313 | f <- resolveInputFile secring pubring f0 | 1339 | f <- resolveInputFile secring pubring f0 |
1314 | return (f,f0,isMutable stream) | 1340 | return (f,f0,stream) |
1315 | let x = do | 1341 | let x = do |
1316 | let wanted kd@(KeyData p _ _ _) | 1342 | let wantedForFill :: Access -> KeyFilter -> KeyData -> Maybe Bool |
1317 | = mplus (fmap originallyPublic $ Map.lookup f $ locations p) | 1343 | wantedForFill acc KF_None = importByExistingMaster |
1318 | $ do | 1344 | -- Note the KF_None case is almost irrelevent as it will be |
1319 | pred <- Map.lookup f0 $ kImports krd | 1345 | -- filtered later when isMutable returns False. |
1320 | pred rt kd | 1346 | -- We use importByExistingMaster in order to generate |
1347 | -- MissingPacket warnings. To disable those warnings, use | ||
1348 | -- const Nothing instead. | ||
1349 | wantedForFill acc (KF_Match {}) = importByExistingMaster | ||
1350 | wantedForFill acc KF_Subkeys = importByExistingMaster | ||
1351 | wantedForFill acc KF_Authentic = \kd -> do guardAuthentic rt kd | ||
1352 | importByAccess acc kd | ||
1353 | wantedForFill acc KF_All = importByAccess acc | ||
1354 | importByAccess Pub kd = importPublic | ||
1355 | importByAccess Sec kd = importSecret | ||
1356 | importByAccess AutoAccess kd = | ||
1357 | mplus (importByExistingMaster kd) | ||
1358 | (error $ f ++ ": write public or secret key to file?") | ||
1359 | importByExistingMaster kd@(KeyData p _ _ _) = | ||
1360 | fmap originallyPublic $ Map.lookup f $ locations p | ||
1321 | d <- sortByHint f keyMappedPacket (Map.elems db) | 1361 | d <- sortByHint f keyMappedPacket (Map.elems db) |
1322 | only_public <- maybeToList $ wanted d | 1362 | only_public <- maybeToList $ wantedForFill (access stream) (fill stream) d |
1323 | flattenTop f only_public d | 1363 | case fill stream of |
1364 | KF_Match usage -> do grip <- maybeToList $ rtGrip rt | ||
1365 | flattenTop f only_public | ||
1366 | $ filterNewSubs f (parseSpec grip usage) d | ||
1367 | _ -> flattenTop f only_public d | ||
1324 | new_packets = filter isnew x | 1368 | new_packets = filter isnew x |
1325 | where isnew p = isNothing (Map.lookup f $ locations p) | 1369 | where isnew p = isNothing (Map.lookup f $ locations p) |
1326 | guard (not $ null new_packets) | 1370 | guard (not $ null new_packets) |
1327 | return ((f,mutable),(new_packets,x)) | 1371 | return ((f,isMutable stream),(new_packets,x)) |
1328 | let (towrites,report) = (\f -> foldl f ([],[]) s) $ | 1372 | let (towrites,report) = (\f -> foldl f ([],[]) s) $ |
1329 | \(ws,report) ((f,mutable),(new_packets,x)) -> | 1373 | \(ws,report) ((f,mutable),(new_packets,x)) -> |
1330 | if mutable | 1374 | if mutable |
@@ -1649,6 +1693,7 @@ runKeyRing operation = do | |||
1649 | decrypt <- makeMemoizingDecrypter operation secring pubring | 1693 | decrypt <- makeMemoizingDecrypter operation secring pubring |
1650 | 1694 | ||
1651 | -- merge all keyrings, PEM files, and wallets | 1695 | -- merge all keyrings, PEM files, and wallets |
1696 | -- TODO: resolve AutoAccess here | ||
1652 | bresult <- buildKeyDB decrypt secring pubring grip0 operation | 1697 | bresult <- buildKeyDB decrypt secring pubring grip0 operation |
1653 | try' bresult $ \((db,grip,wk,hs),report_imports) -> do | 1698 | try' bresult $ \((db,grip,wk,hs),report_imports) -> do |
1654 | 1699 | ||