summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2016-08-31 22:16:21 -0400
committerjoe <joe@jerkface.net>2016-08-31 22:16:21 -0400
commitd8950d3ccdf51f308aa93f06c16f26b15a6c55c4 (patch)
treea44064fbfc52d5ca1d51cfd0229625c6049bbfa0
parentfae3728a6b7e8ee13ed009e7c9cf3918eb4b89d7 (diff)
New command to rename subkeys.
Diffstat
-rw-r--r--kiki.hs33
-rw-r--r--lib/KeyRing.hs184
-rw-r--r--lib/Transforms.hs255
-rw-r--r--lib/Types.hs5
4 files changed, 277 insertions, 200 deletions
diff --git a/kiki.hs b/kiki.hs
index 5c27c36..9796c3d 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -1554,6 +1554,37 @@ kiki "delete" args = do
1554 forM_ report $ \(fname,act) -> do 1554 forM_ report $ \(fname,act) -> do
1555 putStrLn $ fname ++ ": " ++ reportString act 1555 putStrLn $ fname ++ ": " ++ reportString act
1556 1556
1557kiki "rename" args | "--help" `elem` args = do
1558 putStr . unlines $
1559 [ "kiki rename [--homedir <home>] [--passphrase-fd <fd>] <old-tag> <new-tag>"
1560 , ""
1561 , " Reassigns a key usage tag from old-tag to new-tag."
1562 , " The old signature will be replaced and a new one formed."
1563 ]
1564 return ()
1565kiki "rename" args = do
1566 let (sargs,margs) = processArgs sargspec polyVariadicArgs "--rename" args
1567 where sargspec = [("--homedir",1)]
1568 polyVariadicArgs = ["--rename"]
1569 passfd = fmap (FileDesc . read) passphrase_fd
1570 where passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs
1571 (oldtag:newtag:_) = fromMaybe [] $ Map.lookup "--rename" margs
1572 homespec = join . take 1 <$> Map.lookup "--homedir" margs
1573 kikiOp = KeyRingOperation
1574 { opFiles = Map.fromList $
1575 [ ( HomeSec, buildStreamInfo KF_All KeyRingFile )
1576 , ( HomePub, buildStreamInfo KF_All KeyRingFile )
1577 ]
1578 , opPassphrases = withAgent $ do pfile <- maybeToList passfd
1579 return $ PassphraseSpec Nothing Nothing pfile
1580 , opTransforms = [ RenameSubkeys oldtag newtag]
1581 , opHome = homespec
1582 }
1583 KikiResult rt report <- runKeyRing kikiOp
1584 forM_ report $ \(fname,act) -> do
1585 putStrLn $ fname ++ ": " ++ reportString act
1586
1587
1557kiki "tar" args | "--help" `elem` args = do 1588kiki "tar" args | "--help" `elem` args = do
1558 putStr . unlines $ 1589 putStr . unlines $
1559 [ "kiki tar (-c|-t) [--secrets SPEC] [--passphrase-fd FD] [--homedir HOMEDIR]" 1590 [ "kiki tar (-c|-t) [--secrets SPEC] [--passphrase-fd FD] [--homedir HOMEDIR]"
@@ -1752,7 +1783,7 @@ commands =
1752 -- , ( "init-key", "initialize the samizdat key ring") 1783 -- , ( "init-key", "initialize the samizdat key ring")
1753 , ( "init", "Initialize kiki") 1784 , ( "init", "Initialize kiki")
1754 , ( "delete", "Delete a subkey and its associated signatures" ) 1785 , ( "delete", "Delete a subkey and its associated signatures" )
1755 -- TODO: , ( "rename", "Change the usage tag on a specified subkey" ) 1786 , ( "rename", "Change the usage tag on a specified subkey" )
1756 -- also repairs signature and adds missing cross-certification. 1787 -- also repairs signature and adds missing cross-certification.
1757 , ( "tar", "import or export system key files in tar format" ) 1788 , ( "tar", "import or export system key files in tar format" )
1758 ] 1789 ]
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index bb32a2e..87b38bf 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -2333,190 +2333,6 @@ readPacketsFromFile ctx fname = do
2333 return $ decode input 2333 return $ decode input
2334#endif 2334#endif
2335 2335
2336-- | Get the time stamp of a signature.
2337--
2338-- Warning: This function checks unhashed_subpackets if no timestamp occurs in
2339-- the hashed section. TODO: change this?
2340--
2341signature_time :: SignatureOver -> Word32
2342signature_time ov = case (if null cs then ds else cs) of
2343 [] -> minBound
2344 xs -> maximum xs
2345 where
2346 ps = signatures_over ov
2347 ss = filter isSignaturePacket ps
2348 cs = concatMap (concatMap creationTime . hashed_subpackets) ss
2349 ds = concatMap (concatMap creationTime . unhashed_subpackets) ss
2350 creationTime (SignatureCreationTimePacket t) = [t]
2351 creationTime _ = []
2352
2353splitAtMinBy :: (t -> t -> Ordering) -> [t] -> ([t], [t])
2354splitAtMinBy comp xs = minimumBy comp' xxs
2355 where
2356 xxs = zip (inits xs) (tails xs)
2357 comp' (_,as) (_,bs) = compM (listToMaybe as) (listToMaybe bs)
2358 compM (Just a) (Just b) = comp a b
2359 compM Nothing mb = GT
2360 compM _ _ = LT
2361
2362
2363
2364-- | Given list of subpackets, a master key, one of its subkeys and a
2365-- list of signatures on that subkey, yields:
2366--
2367-- * preceding list of signatures
2368--
2369-- * The most recent valid signature made by the master key along with a
2370-- flag that indicates whether or not all of the supplied subpackets occur in
2371-- it or, if no valid signature from the working key is present, Nothing.
2372--
2373-- * following list of signatures
2374--
2375findTag ::
2376 [SignatureSubpacket]
2377 -> Packet
2378 -> Packet
2379 -> [(MappedPacket, b)]
2380 -> ([(MappedPacket, b)],
2381 Maybe (Bool, (MappedPacket, b)),
2382 [(MappedPacket, b)])
2383findTag tag topk subkey subsigs = (xs',minsig,ys')
2384 where
2385 vs = map (\sig ->
2386 (sig, do
2387 sig <- Just (packet . fst $ sig)
2388 guard (isSignaturePacket sig)
2389 guard $ flip isSuffixOf
2390 (fingerprint topk)
2391 . fromMaybe "%bad%"
2392 . signature_issuer
2393 $ sig
2394 listToMaybe $
2395 map (signature_time . verify (Message [topk]))
2396 (signatures $ Message [topk,subkey,sig])))
2397 subsigs
2398 (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs
2399 xs' = map fst xs
2400 ys' = map fst $ if isNothing minsig then ys else drop 1 ys
2401 minsig = do
2402 (sig,ov) <- listToMaybe ys
2403 ov
2404 let hshed = hashed_subpackets $ packet $ fst sig
2405 return ( null $ tag \\ hshed, sig)
2406
2407mkUsage :: String -> SignatureSubpacket
2408mkUsage tag | Just flags <- lookup tag specials
2409 = KeyFlagsPacket
2410 { certify_keys = fromEnum flags .&. 0x1 /= 0
2411 , sign_data = fromEnum flags .&. 0x2 /= 0
2412 , encrypt_communication = fromEnum flags .&. 0x4 /= 0
2413 , encrypt_storage = fromEnum flags .&. 0x8 /= 0
2414 , split_key = False
2415 , authentication = False
2416 , group_key = False
2417 }
2418 where
2419 flagsets = [Special .. VouchSignEncrypt]
2420 specials = map (\f -> (usageString f, f)) flagsets
2421
2422mkUsage tag = NotationDataPacket
2423 { human_readable = True
2424 , notation_name = "usage@"
2425 , notation_value = tag
2426 }
2427
2428makeSig ::
2429 (PacketDecrypter)
2430 -> MappedPacket
2431 -> [Char]
2432 -> MappedPacket
2433 -> [SignatureSubpacket]
2434 -> Maybe (MappedPacket, Map.Map k a)
2435 -> IO (KikiCondition ((MappedPacket, Map.Map k a), [KikiReportAction]))
2436makeSig doDecrypt top fname subkey_p tags mbsig = do
2437 let wk = packet top
2438 wkun <- doDecrypt top
2439 try wkun $ \wkun -> do
2440 let grip = fingerprint wk
2441 addOrigin new_sig =
2442 flip (maybe $ return FailedToMakeSignature)
2443 (new_sig >>= listToMaybe . signatures_over)
2444 $ \new_sig -> do
2445 let mp' = mappedPacket fname new_sig
2446 return $ KikiSuccess (mp', Map.empty)
2447 parsedkey = [packet subkey_p]
2448 hashed0 | any isFlagsPacket tags = tags
2449 | otherwise
2450 = KeyFlagsPacket
2451 { certify_keys = False
2452 , sign_data = False
2453 , encrypt_communication = False
2454 , encrypt_storage = False
2455 , split_key = False
2456 , authentication = True
2457 , group_key = False }
2458 : tags
2459 -- implicitly added:
2460 -- , SignatureCreationTimePacket (fromIntegral timestamp)
2461 isFlagsPacket (KeyFlagsPacket {}) = True
2462 isFlagsPacket _ = False
2463 subgrip = fingerprint (head parsedkey)
2464
2465 back_sig <- pgpSign (Message parsedkey)
2466 (SubkeySignature wk
2467 (head parsedkey)
2468 (sigpackets 0x19
2469 hashed0
2470 [IssuerPacket subgrip]))
2471 (if key_algorithm (head parsedkey)==ECDSA
2472 then SHA256
2473 else SHA1)
2474 subgrip
2475 let iss = IssuerPacket (fingerprint wk)
2476 cons_iss back_sig = iss : map EmbeddedSignaturePacket (signatures_over back_sig)
2477 unhashed0 = maybe [iss] cons_iss back_sig
2478
2479 new_sig <- pgpSign (Message [wkun])
2480 (SubkeySignature wk
2481 (head parsedkey)
2482 (sigpackets 0x18
2483 hashed0
2484 unhashed0))
2485 SHA1
2486 grip
2487 let newSig = do
2488 r <- addOrigin new_sig
2489 return $ fmap (,[]) r
2490 flip (maybe newSig) mbsig $ \(mp,trustmap) -> do
2491 let sig = packet mp
2492 isCreation (SignatureCreationTimePacket {}) = True
2493 isCreation _ = False
2494 isExpiration (SignatureExpirationTimePacket {}) = True
2495 isExpiration _ = False
2496 (cs,ps) = partition isCreation (hashed_subpackets sig)
2497 (es,qs) = partition isExpiration ps
2498 stamp = listToMaybe . sortBy (comparing Down) $
2499 map unwrap cs where unwrap (SignatureCreationTimePacket x) = x
2500 exp = listToMaybe $ sort $
2501 map unwrap es where unwrap (SignatureExpirationTimePacket x) = x
2502 expires = liftA2 (+) stamp exp
2503 timestamp <- now
2504 if fmap ( (< timestamp) . fromIntegral) expires == Just True then
2505 return $ KikiSuccess ((mp,trustmap), [ UnableToUpdateExpiredSignature ] )
2506 else do
2507 let times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp))
2508 $ maybeToList $ do
2509 e <- expires
2510 return $ SignatureExpirationTimePacket (e - fromIntegral timestamp)
2511 sig' = sig { hashed_subpackets = times ++ (qs `union` tags) }
2512 new_sig <- pgpSign (Message [wkun])
2513 (SubkeySignature wk
2514 (packet subkey_p)
2515 [sig'] )
2516 SHA1
2517 (fingerprint wk)
2518 newsig <- addOrigin new_sig
2519 return $ fmap (,[]) newsig
2520 2336
2521merge :: KeyDB -> InputFile -> Message -> KeyDB 2337merge :: KeyDB -> InputFile -> Message -> KeyDB
2522merge db inputfile (Message ps) = merge_ db filename qs 2338merge db inputfile (Message ps) = merge_ db filename qs
diff --git a/lib/Transforms.hs b/lib/Transforms.hs
index 093d594..ba85b18 100644
--- a/lib/Transforms.hs
+++ b/lib/Transforms.hs
@@ -1,9 +1,13 @@
1{-# LANGUAGE CPP #-} 1{-# LANGUAGE CPP #-}
2{-# LANGUAGE TupleSections #-} 2{-# LANGUAGE DoAndIfThenElse #-}
3{-# LANGUAGE ViewPatterns #-}
4{-# LANGUAGE OverloadedStrings #-} 3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE PatternGuards #-}
5{-# LANGUAGE TupleSections #-}
6{-# LANGUAGE ViewPatterns #-}
5module Transforms where 7module Transforms where
6 8
9import Control.Applicative
10import Control.Arrow
7import Control.Monad 11import Control.Monad
8import Data.Char 12import Data.Char
9import Data.List 13import Data.List
@@ -11,11 +15,12 @@ import Data.Maybe
11import Data.Ord 15import Data.Ord
12import Data.OpenPGP 16import Data.OpenPGP
13import Data.OpenPGP.Util 17import Data.OpenPGP.Util
14import Data.Word (Word8) 18import Data.Word
15import Types 19import Types
16import FunctorToMaybe 20import FunctorToMaybe
17import GnuPGAgent ( key_nbits ) 21import GnuPGAgent ( key_nbits )
18import PacketTranscoder 22import PacketTranscoder
23import TimeUtil
19import qualified Data.Traversable as Traversable 24import qualified Data.Traversable as Traversable
20import qualified Data.ByteString as S 25import qualified Data.ByteString as S
21import qualified Data.ByteString.Lazy as L 26import qualified Data.ByteString.Lazy as L
@@ -88,6 +93,7 @@ data KeyRingRuntime = KeyRingRuntime
88-- | Roster-entry level actions 93-- | Roster-entry level actions
89data PacketUpdate = InducerSignature String [SignatureSubpacket] 94data PacketUpdate = InducerSignature String [SignatureSubpacket]
90 | SubKeyDeletion KeyKey KeyKey 95 | SubKeyDeletion KeyKey KeyKey
96 | SubKeyRenaming String String
91 97
92data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show) 98data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show)
93 99
@@ -166,6 +172,99 @@ data PGPKeyFlags =
166 172
167-- Functions 173-- Functions
168 174
175splitAtMinBy :: (t -> t -> Ordering) -> [t] -> ([t], [t])
176splitAtMinBy comp xs = minimumBy comp' xxs
177 where
178 xxs = zip (inits xs) (tails xs)
179 comp' (_,as) (_,bs) = compM (listToMaybe as) (listToMaybe bs)
180 compM (Just a) (Just b) = comp a b
181 compM Nothing mb = GT
182 compM _ _ = LT
183
184
185-- | Get the time stamp of a signature.
186--
187-- Warning: This function checks unhashed_subpackets if no timestamp occurs in
188-- the hashed section. TODO: change this?
189--
190signature_time :: SignatureOver -> Word32
191signature_time ov = case (if null cs then ds else cs) of
192 [] -> minBound
193 xs -> maximum xs
194 where
195 ps = signatures_over ov
196 ss = filter isSignaturePacket ps
197 cs = concatMap (concatMap creationTime . hashed_subpackets) ss
198 ds = concatMap (concatMap creationTime . unhashed_subpackets) ss
199 creationTime (SignatureCreationTimePacket t) = [t]
200 creationTime _ = []
201
202
203-- | Given list of subpackets, a master key, one of its subkeys and a
204-- list of signatures on that subkey, yields:
205--
206-- * preceding list of signatures
207--
208-- * The most recent valid signature made by the master key along with a
209-- flag that indicates whether or not all of the supplied subpackets occur in
210-- it or, if no valid signature from the working key is present, Nothing.
211--
212-- * following list of signatures
213--
214findTag ::
215 [SignatureSubpacket]
216 -> Packet
217 -> Packet
218 -> [(MappedPacket, b)]
219 -> ([(MappedPacket, b)],
220 Maybe (Bool, (MappedPacket, b)),
221 [(MappedPacket, b)])
222findTag tag topk subkey subsigs = (xs',minsig,ys')
223 where
224 vs = map (\sig ->
225 (sig, do
226 sig <- Just (packet . fst $ sig)
227 guard (isSignaturePacket sig)
228 guard $ flip isSuffixOf
229 (fingerprint topk)
230 . fromMaybe "%bad%"
231 . signature_issuer
232 $ sig
233 listToMaybe $
234 map (signature_time . verify (Message [topk]))
235 (signatures $ Message [topk,subkey,sig])))
236 subsigs
237 (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs
238 xs' = map fst xs
239 ys' = map fst $ if isNothing minsig then ys else drop 1 ys
240 minsig = do
241 (sig,ov) <- listToMaybe ys
242 ov
243 let hshed = hashed_subpackets $ packet $ fst sig
244 return ( null $ tag \\ hshed, sig)
245
246mkUsage :: String -> SignatureSubpacket
247mkUsage tag | Just flags <- lookup tag specials
248 = KeyFlagsPacket
249 { certify_keys = fromEnum flags .&. 0x1 /= 0
250 , sign_data = fromEnum flags .&. 0x2 /= 0
251 , encrypt_communication = fromEnum flags .&. 0x4 /= 0
252 , encrypt_storage = fromEnum flags .&. 0x8 /= 0
253 , split_key = False
254 , authentication = False
255 , group_key = False
256 }
257 where
258 flagsets = [Special .. VouchSignEncrypt]
259 specials = map (\f -> (usageString f, f)) flagsets
260
261mkUsage tag = NotationDataPacket
262 { human_readable = True
263 , notation_name = "usage@"
264 , notation_value = tag
265 }
266
267
169unk :: Bool -> MappedPacket -> MappedPacket 268unk :: Bool -> MappedPacket -> MappedPacket
170unk isPublic = if isPublic then toPacket secretToPublic else id 269unk isPublic = if isPublic then toPacket secretToPublic else id
171 where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)} 270 where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)}
@@ -421,15 +520,14 @@ showPacket p | isKey p = (if is_subkey p
421 | otherwise = showPacket0 p 520 | otherwise = showPacket0 p
422 where 521 where
423 sigusage p = 522 sigusage p =
424 case take 1 (tagStrings p) of 523 case (usage_tags,flags) of
425 [] -> "" 524 ([],[]) -> ""
426 tag:_ -> " "++show tag -- "("++tag++")" 525 (_:_,_) -> " "++show usage_tags
526 (_,ts) -> " "++show ts
427 where 527 where
428 tagStrings p = usage_tags ++ flags 528 usage_tags = mapMaybe usage xs
429 where 529 flags = mapMaybe (fmap usageString . keyflags) xs
430 usage_tags = mapMaybe usage xs 530 xs = hashed_subpackets p
431 flags = mapMaybe (fmap usageString . keyflags) xs
432 xs = hashed_subpackets p
433 531
434 532
435showPacket0 p = dropSuffix "Packet" . concat . take 1 $ words (show p) 533showPacket0 p = dropSuffix "Packet" . concat . take 1 $ words (show p)
@@ -588,6 +686,99 @@ try x body =
588 Left e -> return e 686 Left e -> return e
589 Right x -> body x 687 Right x -> body x
590 688
689makeSig ::
690 PacketDecrypter
691 -> MappedPacket
692 -> FilePath
693 -> MappedPacket
694 -> [SignatureSubpacket]
695 -> Maybe (MappedPacket, Map.Map k a)
696 -> IO (KikiCondition ((MappedPacket, Map.Map k a), [KikiReportAction]))
697makeSig doDecrypt top fname subkey_p tags mbsig = do
698 let wk = packet top
699 wkun <- doDecrypt top
700 try wkun $ \wkun -> do
701 let grip = fingerprint wk
702 addOrigin new_sig =
703 flip (maybe $ return FailedToMakeSignature)
704 (new_sig >>= listToMaybe . signatures_over)
705 $ \new_sig -> do
706 let mp' = mappedPacket fname new_sig
707 return $ KikiSuccess (mp', Map.empty)
708 parsedkey = [packet subkey_p]
709 hashed0 | any isFlagsPacket tags = tags
710 | otherwise
711 = KeyFlagsPacket
712 { certify_keys = False
713 , sign_data = False
714 , encrypt_communication = False
715 , encrypt_storage = False
716 , split_key = False
717 , authentication = True
718 , group_key = False }
719 : tags
720 -- implicitly added:
721 -- , SignatureCreationTimePacket (fromIntegral timestamp)
722 isFlagsPacket (KeyFlagsPacket {}) = True
723 isFlagsPacket _ = False
724 subgrip = fingerprint (head parsedkey)
725
726 back_sig <- pgpSign (Message parsedkey)
727 (SubkeySignature wk
728 (head parsedkey)
729 (sigpackets 0x19
730 hashed0
731 [IssuerPacket subgrip]))
732 (if key_algorithm (head parsedkey)==ECDSA
733 then SHA256
734 else SHA1)
735 subgrip
736 let iss = IssuerPacket (fingerprint wk)
737 cons_iss back_sig = iss : map EmbeddedSignaturePacket (signatures_over back_sig)
738 unhashed0 = maybe [iss] cons_iss back_sig
739
740 new_sig <- pgpSign (Message [wkun])
741 (SubkeySignature wk
742 (head parsedkey)
743 (sigpackets 0x18
744 hashed0
745 unhashed0))
746 SHA1
747 grip
748 let newSig = do
749 r <- addOrigin new_sig
750 return $ fmap (,[]) r
751 flip (maybe newSig) mbsig $ \(mp,trustmap) -> do
752 let sig = packet mp
753 isCreation (SignatureCreationTimePacket {}) = True
754 isCreation _ = False
755 isExpiration (SignatureExpirationTimePacket {}) = True
756 isExpiration _ = False
757 (cs,ps) = partition isCreation (hashed_subpackets sig)
758 (es,qs) = partition isExpiration ps
759 stamp = listToMaybe . sortBy (comparing Down) $
760 map unwrap cs where unwrap (SignatureCreationTimePacket x) = x
761 exp = listToMaybe $ sort $
762 map unwrap es where unwrap (SignatureExpirationTimePacket x) = x
763 expires = liftA2 (+) stamp exp
764 timestamp <- now
765 if fmap ( (< timestamp) . fromIntegral) expires == Just True then
766 return $ KikiSuccess ((mp,trustmap), [ UnableToUpdateExpiredSignature ] )
767 else do
768 let times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp))
769 $ maybeToList $ do
770 e <- expires
771 return $ SignatureExpirationTimePacket (e - fromIntegral timestamp)
772 sig' = sig { hashed_subpackets = times ++ (qs `union` tags) }
773 new_sig <- pgpSign (Message [wkun])
774 (SubkeySignature wk
775 (packet subkey_p)
776 [sig'] )
777 SHA1
778 (fingerprint wk)
779 newsig <- addOrigin new_sig
780 return $ fmap (,[]) newsig
781
591 782
592 783
593 784
@@ -660,6 +851,40 @@ performManipulations doDecrypt rt wk manip = do
660 rings = [HomeSec, HomePub] >>= resolveInputFile ctx 851 rings = [HomeSec, HomePub] >>= resolveInputFile ctx
661 return $ KikiSuccess (kd' , report ++ [ (f,DeletedPacket $ showPacket p) | f <- rings, p <- ps ]) 852 return $ KikiSuccess (kd' , report ++ [ (f,DeletedPacket $ showPacket p) | f <- rings, p <- ps ])
662 853
854 -- perform :: KikiCondition (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport))
855 perform kd (SubKeyRenaming srctag dsttag) = do
856 try kd $ \(kd,report) -> do
857 flip (maybe $ return NoWorkingKey) wk $ \wk' -> do
858 subkeys' <- traverse (freshenOne wk') (keySubKeys kd)
859 let _ = subkeys' :: Map.Map KeyKey (KikiCondition (SubKey, KikiReport))
860 succeded (KikiSuccess a) = True
861 succeded _ = False
862 (good,bad) = Map.partition succeded subkeys'
863 uncondition (KikiSuccess a) = a
864 uncondition _ = error "unexpected error"
865 good' = fmap uncondition good
866 if not (Map.null bad)
867 then return $ fmap (error "bad cast") $ head (Map.elems bad)
868 else return $ KikiSuccess ( kd { keySubKeys = fmap fst good' }
869 , report ++ concatMap snd (Map.elems good'))
870 where
871 freshenOne :: MappedPacket -> SubKey -> IO (KikiCondition (SubKey,[(FilePath, KikiReportAction)]))
872 freshenOne wk subkey@(SubKey subkey_p subsigs) = do
873 let (xs',minsig,ys') = findTag [mkUsage srctag] (packet wk) (packet subkey_p) subsigs
874 case minsig of
875 Just (True,sig) -> do
876 let fname = "--rename-subkey"
877 not_deleted p = mkUsage srctag /= p
878 mod sig = sig { hashed_subpackets = filter not_deleted $ hashed_subpackets sig }
879 sig' = first (fmap mod) sig
880 sigr <- makeSig doDecrypt wk fname subkey_p [mkUsage dsttag] (Just sig')
881 try sigr $ \(sig',sigreport) -> do
882 let old = packet (fst sig)
883 report <- return $ fmap (fname,) sigreport ++ [(fname, DeletedPacket (showPacket old)),(fname, YieldSignature)]
884 return $ KikiSuccess $ (SubKey subkey_p $ xs'++[sig']++ys', report)
885 _ -> return $ KikiSuccess (subkey, [])
886
887
663isBracket :: Char -> Bool 888isBracket :: Char -> Bool
664isBracket '<' = True 889isBracket '<' = True
665isBracket '>' = True 890isBracket '>' = True
@@ -717,7 +942,7 @@ resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops
717 gs = groupBy sameMaster (sortBy (comparing code) bindings') 942 gs = groupBy sameMaster (sortBy (comparing code) bindings')
718 943
719 944
720-- (2 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] 945-- (2 of 4) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
721resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk 946resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk
722 where 947 where
723 topk = keykey $ packet k -- key to master of key to be deleted 948 topk = keykey $ packet k -- key to master of key to be deleted
@@ -726,7 +951,7 @@ resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap subm
726 guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub))) 951 guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub)))
727 return k 952 return k
728 953
729-- (3 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] 954-- (3 of 4) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
730resolveTransform (DeleteSubkeyByUsage tag) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk 955resolveTransform (DeleteSubkeyByUsage tag) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk
731 where 956 where
732 topk = keykey $ packet k -- key to master of key to be deleted 957 topk = keykey $ packet k -- key to master of key to be deleted
@@ -736,3 +961,5 @@ resolveTransform (DeleteSubkeyByUsage tag) rt kd@(KeyData k ksigs umap submap) =
736 take 1 $ filter (has_tag tag) $ map (packet . fst) sigs 961 take 1 $ filter (has_tag tag) $ map (packet . fst) sigs
737 return k 962 return k
738 963
964-- (4 of 4) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
965resolveTransform (RenameSubkeys srctag dsttag) rt kd = [SubKeyRenaming srctag dsttag]
diff --git a/lib/Types.hs b/lib/Types.hs
index 86836e0..df2dfbe 100644
--- a/lib/Types.hs
+++ b/lib/Types.hs
@@ -140,8 +140,11 @@ data Transform =
140 -- ^ Delete the subkey specified by the given fingerprint and any 140 -- ^ Delete the subkey specified by the given fingerprint and any
141 -- associated signatures on that key. 141 -- associated signatures on that key.
142 | DeleteSubkeyByUsage String 142 | DeleteSubkeyByUsage String
143 -- ^ Delete the subkey specified by the given fingerprint and any 143 -- ^ Delete the subkey specified by the given usage tag and any
144 -- associated signatures on that key. 144 -- associated signatures on that key.
145 | RenameSubkeys String String
146 -- ^ Replace all subkey signatures matching the first usage tag with
147 -- fresh signatures that match the second usage tag.
145 deriving (Eq,Ord,Show) 148 deriving (Eq,Ord,Show)
146 149
147-- | Use this type to indicate whether a file of type 'KeyRingFile' is expected 150-- | Use this type to indicate whether a file of type 'KeyRingFile' is expected
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-01 03:09:33 +0000