diff options
-rw-r--r-- | kiki.hs | 33 | ||||
-rw-r--r-- | lib/KeyRing.hs | 184 | ||||
-rw-r--r-- | lib/Transforms.hs | 255 | ||||
-rw-r--r-- | lib/Types.hs | 5 |
4 files changed, 277 insertions, 200 deletions
@@ -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 | ||
1557 | kiki "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 () | ||
1565 | kiki "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 | |||
1557 | kiki "tar" args | "--help" `elem` args = do | 1588 | kiki "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 | -- | ||
2341 | signature_time :: SignatureOver -> Word32 | ||
2342 | signature_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 | |||
2353 | splitAtMinBy :: (t -> t -> Ordering) -> [t] -> ([t], [t]) | ||
2354 | splitAtMinBy 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 | -- | ||
2375 | findTag :: | ||
2376 | [SignatureSubpacket] | ||
2377 | -> Packet | ||
2378 | -> Packet | ||
2379 | -> [(MappedPacket, b)] | ||
2380 | -> ([(MappedPacket, b)], | ||
2381 | Maybe (Bool, (MappedPacket, b)), | ||
2382 | [(MappedPacket, b)]) | ||
2383 | findTag 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 | |||
2407 | mkUsage :: String -> SignatureSubpacket | ||
2408 | mkUsage 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 | |||
2422 | mkUsage tag = NotationDataPacket | ||
2423 | { human_readable = True | ||
2424 | , notation_name = "usage@" | ||
2425 | , notation_value = tag | ||
2426 | } | ||
2427 | |||
2428 | makeSig :: | ||
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])) | ||
2436 | makeSig 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 | ||
2521 | merge :: KeyDB -> InputFile -> Message -> KeyDB | 2337 | merge :: KeyDB -> InputFile -> Message -> KeyDB |
2522 | merge db inputfile (Message ps) = merge_ db filename qs | 2338 | merge 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 #-} | ||
5 | module Transforms where | 7 | module Transforms where |
6 | 8 | ||
9 | import Control.Applicative | ||
10 | import Control.Arrow | ||
7 | import Control.Monad | 11 | import Control.Monad |
8 | import Data.Char | 12 | import Data.Char |
9 | import Data.List | 13 | import Data.List |
@@ -11,11 +15,12 @@ import Data.Maybe | |||
11 | import Data.Ord | 15 | import Data.Ord |
12 | import Data.OpenPGP | 16 | import Data.OpenPGP |
13 | import Data.OpenPGP.Util | 17 | import Data.OpenPGP.Util |
14 | import Data.Word (Word8) | 18 | import Data.Word |
15 | import Types | 19 | import Types |
16 | import FunctorToMaybe | 20 | import FunctorToMaybe |
17 | import GnuPGAgent ( key_nbits ) | 21 | import GnuPGAgent ( key_nbits ) |
18 | import PacketTranscoder | 22 | import PacketTranscoder |
23 | import TimeUtil | ||
19 | import qualified Data.Traversable as Traversable | 24 | import qualified Data.Traversable as Traversable |
20 | import qualified Data.ByteString as S | 25 | import qualified Data.ByteString as S |
21 | import qualified Data.ByteString.Lazy as L | 26 | import qualified Data.ByteString.Lazy as L |
@@ -88,6 +93,7 @@ data KeyRingRuntime = KeyRingRuntime | |||
88 | -- | Roster-entry level actions | 93 | -- | Roster-entry level actions |
89 | data PacketUpdate = InducerSignature String [SignatureSubpacket] | 94 | data PacketUpdate = InducerSignature String [SignatureSubpacket] |
90 | | SubKeyDeletion KeyKey KeyKey | 95 | | SubKeyDeletion KeyKey KeyKey |
96 | | SubKeyRenaming String String | ||
91 | 97 | ||
92 | data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show) | 98 | data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show) |
93 | 99 | ||
@@ -166,6 +172,99 @@ data PGPKeyFlags = | |||
166 | 172 | ||
167 | -- Functions | 173 | -- Functions |
168 | 174 | ||
175 | splitAtMinBy :: (t -> t -> Ordering) -> [t] -> ([t], [t]) | ||
176 | splitAtMinBy 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 | -- | ||
190 | signature_time :: SignatureOver -> Word32 | ||
191 | signature_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 | -- | ||
214 | findTag :: | ||
215 | [SignatureSubpacket] | ||
216 | -> Packet | ||
217 | -> Packet | ||
218 | -> [(MappedPacket, b)] | ||
219 | -> ([(MappedPacket, b)], | ||
220 | Maybe (Bool, (MappedPacket, b)), | ||
221 | [(MappedPacket, b)]) | ||
222 | findTag 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 | |||
246 | mkUsage :: String -> SignatureSubpacket | ||
247 | mkUsage 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 | |||
261 | mkUsage tag = NotationDataPacket | ||
262 | { human_readable = True | ||
263 | , notation_name = "usage@" | ||
264 | , notation_value = tag | ||
265 | } | ||
266 | |||
267 | |||
169 | unk :: Bool -> MappedPacket -> MappedPacket | 268 | unk :: Bool -> MappedPacket -> MappedPacket |
170 | unk isPublic = if isPublic then toPacket secretToPublic else id | 269 | unk 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 | ||
435 | showPacket0 p = dropSuffix "Packet" . concat . take 1 $ words (show p) | 533 | showPacket0 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 | ||
689 | makeSig :: | ||
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])) | ||
697 | makeSig 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 | |||
663 | isBracket :: Char -> Bool | 888 | isBracket :: Char -> Bool |
664 | isBracket '<' = True | 889 | isBracket '<' = True |
665 | isBracket '>' = True | 890 | isBracket '>' = 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] |
721 | resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk | 946 | resolveTransform (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] |
730 | resolveTransform (DeleteSubkeyByUsage tag) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk | 955 | resolveTransform (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] | ||
965 | resolveTransform (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 |