From d8950d3ccdf51f308aa93f06c16f26b15a6c55c4 Mon Sep 17 00:00:00 2001 From: joe Date: Wed, 31 Aug 2016 22:16:21 -0400 Subject: New command to rename subkeys. --- kiki.hs | 33 ++++++- lib/KeyRing.hs | 184 --------------------------------------- lib/Transforms.hs | 255 +++++++++++++++++++++++++++++++++++++++++++++++++++--- lib/Types.hs | 5 +- 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 forM_ report $ \(fname,act) -> do putStrLn $ fname ++ ": " ++ reportString act +kiki "rename" args | "--help" `elem` args = do + putStr . unlines $ + [ "kiki rename [--homedir ] [--passphrase-fd ] " + , "" + , " Reassigns a key usage tag from old-tag to new-tag." + , " The old signature will be replaced and a new one formed." + ] + return () +kiki "rename" args = do + let (sargs,margs) = processArgs sargspec polyVariadicArgs "--rename" args + where sargspec = [("--homedir",1)] + polyVariadicArgs = ["--rename"] + passfd = fmap (FileDesc . read) passphrase_fd + where passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs + (oldtag:newtag:_) = fromMaybe [] $ Map.lookup "--rename" margs + homespec = join . take 1 <$> Map.lookup "--homedir" margs + kikiOp = KeyRingOperation + { opFiles = Map.fromList $ + [ ( HomeSec, buildStreamInfo KF_All KeyRingFile ) + , ( HomePub, buildStreamInfo KF_All KeyRingFile ) + ] + , opPassphrases = withAgent $ do pfile <- maybeToList passfd + return $ PassphraseSpec Nothing Nothing pfile + , opTransforms = [ RenameSubkeys oldtag newtag] + , opHome = homespec + } + KikiResult rt report <- runKeyRing kikiOp + forM_ report $ \(fname,act) -> do + putStrLn $ fname ++ ": " ++ reportString act + + kiki "tar" args | "--help" `elem` args = do putStr . unlines $ [ "kiki tar (-c|-t) [--secrets SPEC] [--passphrase-fd FD] [--homedir HOMEDIR]" @@ -1752,7 +1783,7 @@ commands = -- , ( "init-key", "initialize the samizdat key ring") , ( "init", "Initialize kiki") , ( "delete", "Delete a subkey and its associated signatures" ) - -- TODO: , ( "rename", "Change the usage tag on a specified subkey" ) + , ( "rename", "Change the usage tag on a specified subkey" ) -- also repairs signature and adds missing cross-certification. , ( "tar", "import or export system key files in tar format" ) ] 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 return $ decode input #endif --- | Get the time stamp of a signature. --- --- Warning: This function checks unhashed_subpackets if no timestamp occurs in --- the hashed section. TODO: change this? --- -signature_time :: SignatureOver -> Word32 -signature_time ov = case (if null cs then ds else cs) of - [] -> minBound - xs -> maximum xs - where - ps = signatures_over ov - ss = filter isSignaturePacket ps - cs = concatMap (concatMap creationTime . hashed_subpackets) ss - ds = concatMap (concatMap creationTime . unhashed_subpackets) ss - creationTime (SignatureCreationTimePacket t) = [t] - creationTime _ = [] - -splitAtMinBy :: (t -> t -> Ordering) -> [t] -> ([t], [t]) -splitAtMinBy comp xs = minimumBy comp' xxs - where - xxs = zip (inits xs) (tails xs) - comp' (_,as) (_,bs) = compM (listToMaybe as) (listToMaybe bs) - compM (Just a) (Just b) = comp a b - compM Nothing mb = GT - compM _ _ = LT - - - --- | Given list of subpackets, a master key, one of its subkeys and a --- list of signatures on that subkey, yields: --- --- * preceding list of signatures --- --- * The most recent valid signature made by the master key along with a --- flag that indicates whether or not all of the supplied subpackets occur in --- it or, if no valid signature from the working key is present, Nothing. --- --- * following list of signatures --- -findTag :: - [SignatureSubpacket] - -> Packet - -> Packet - -> [(MappedPacket, b)] - -> ([(MappedPacket, b)], - Maybe (Bool, (MappedPacket, b)), - [(MappedPacket, b)]) -findTag tag topk subkey subsigs = (xs',minsig,ys') - where - vs = map (\sig -> - (sig, do - sig <- Just (packet . fst $ sig) - guard (isSignaturePacket sig) - guard $ flip isSuffixOf - (fingerprint topk) - . fromMaybe "%bad%" - . signature_issuer - $ sig - listToMaybe $ - map (signature_time . verify (Message [topk])) - (signatures $ Message [topk,subkey,sig]))) - subsigs - (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs - xs' = map fst xs - ys' = map fst $ if isNothing minsig then ys else drop 1 ys - minsig = do - (sig,ov) <- listToMaybe ys - ov - let hshed = hashed_subpackets $ packet $ fst sig - return ( null $ tag \\ hshed, sig) - -mkUsage :: String -> SignatureSubpacket -mkUsage tag | Just flags <- lookup tag specials - = KeyFlagsPacket - { certify_keys = fromEnum flags .&. 0x1 /= 0 - , sign_data = fromEnum flags .&. 0x2 /= 0 - , encrypt_communication = fromEnum flags .&. 0x4 /= 0 - , encrypt_storage = fromEnum flags .&. 0x8 /= 0 - , split_key = False - , authentication = False - , group_key = False - } - where - flagsets = [Special .. VouchSignEncrypt] - specials = map (\f -> (usageString f, f)) flagsets - -mkUsage tag = NotationDataPacket - { human_readable = True - , notation_name = "usage@" - , notation_value = tag - } - -makeSig :: - (PacketDecrypter) - -> MappedPacket - -> [Char] - -> MappedPacket - -> [SignatureSubpacket] - -> Maybe (MappedPacket, Map.Map k a) - -> IO (KikiCondition ((MappedPacket, Map.Map k a), [KikiReportAction])) -makeSig doDecrypt top fname subkey_p tags mbsig = do - let wk = packet top - wkun <- doDecrypt top - try wkun $ \wkun -> do - let grip = fingerprint wk - addOrigin new_sig = - flip (maybe $ return FailedToMakeSignature) - (new_sig >>= listToMaybe . signatures_over) - $ \new_sig -> do - let mp' = mappedPacket fname new_sig - return $ KikiSuccess (mp', Map.empty) - parsedkey = [packet subkey_p] - hashed0 | any isFlagsPacket tags = tags - | otherwise - = KeyFlagsPacket - { certify_keys = False - , sign_data = False - , encrypt_communication = False - , encrypt_storage = False - , split_key = False - , authentication = True - , group_key = False } - : tags - -- implicitly added: - -- , SignatureCreationTimePacket (fromIntegral timestamp) - isFlagsPacket (KeyFlagsPacket {}) = True - isFlagsPacket _ = False - subgrip = fingerprint (head parsedkey) - - back_sig <- pgpSign (Message parsedkey) - (SubkeySignature wk - (head parsedkey) - (sigpackets 0x19 - hashed0 - [IssuerPacket subgrip])) - (if key_algorithm (head parsedkey)==ECDSA - then SHA256 - else SHA1) - subgrip - let iss = IssuerPacket (fingerprint wk) - cons_iss back_sig = iss : map EmbeddedSignaturePacket (signatures_over back_sig) - unhashed0 = maybe [iss] cons_iss back_sig - - new_sig <- pgpSign (Message [wkun]) - (SubkeySignature wk - (head parsedkey) - (sigpackets 0x18 - hashed0 - unhashed0)) - SHA1 - grip - let newSig = do - r <- addOrigin new_sig - return $ fmap (,[]) r - flip (maybe newSig) mbsig $ \(mp,trustmap) -> do - let sig = packet mp - isCreation (SignatureCreationTimePacket {}) = True - isCreation _ = False - isExpiration (SignatureExpirationTimePacket {}) = True - isExpiration _ = False - (cs,ps) = partition isCreation (hashed_subpackets sig) - (es,qs) = partition isExpiration ps - stamp = listToMaybe . sortBy (comparing Down) $ - map unwrap cs where unwrap (SignatureCreationTimePacket x) = x - exp = listToMaybe $ sort $ - map unwrap es where unwrap (SignatureExpirationTimePacket x) = x - expires = liftA2 (+) stamp exp - timestamp <- now - if fmap ( (< timestamp) . fromIntegral) expires == Just True then - return $ KikiSuccess ((mp,trustmap), [ UnableToUpdateExpiredSignature ] ) - else do - let times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp)) - $ maybeToList $ do - e <- expires - return $ SignatureExpirationTimePacket (e - fromIntegral timestamp) - sig' = sig { hashed_subpackets = times ++ (qs `union` tags) } - new_sig <- pgpSign (Message [wkun]) - (SubkeySignature wk - (packet subkey_p) - [sig'] ) - SHA1 - (fingerprint wk) - newsig <- addOrigin new_sig - return $ fmap (,[]) newsig merge :: KeyDB -> InputFile -> Message -> KeyDB 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 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} module Transforms where +import Control.Applicative +import Control.Arrow import Control.Monad import Data.Char import Data.List @@ -11,11 +15,12 @@ import Data.Maybe import Data.Ord import Data.OpenPGP import Data.OpenPGP.Util -import Data.Word (Word8) +import Data.Word import Types import FunctorToMaybe import GnuPGAgent ( key_nbits ) import PacketTranscoder +import TimeUtil import qualified Data.Traversable as Traversable import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L @@ -88,6 +93,7 @@ data KeyRingRuntime = KeyRingRuntime -- | Roster-entry level actions data PacketUpdate = InducerSignature String [SignatureSubpacket] | SubKeyDeletion KeyKey KeyKey + | SubKeyRenaming String String data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show) @@ -166,6 +172,99 @@ data PGPKeyFlags = -- Functions +splitAtMinBy :: (t -> t -> Ordering) -> [t] -> ([t], [t]) +splitAtMinBy comp xs = minimumBy comp' xxs + where + xxs = zip (inits xs) (tails xs) + comp' (_,as) (_,bs) = compM (listToMaybe as) (listToMaybe bs) + compM (Just a) (Just b) = comp a b + compM Nothing mb = GT + compM _ _ = LT + + +-- | Get the time stamp of a signature. +-- +-- Warning: This function checks unhashed_subpackets if no timestamp occurs in +-- the hashed section. TODO: change this? +-- +signature_time :: SignatureOver -> Word32 +signature_time ov = case (if null cs then ds else cs) of + [] -> minBound + xs -> maximum xs + where + ps = signatures_over ov + ss = filter isSignaturePacket ps + cs = concatMap (concatMap creationTime . hashed_subpackets) ss + ds = concatMap (concatMap creationTime . unhashed_subpackets) ss + creationTime (SignatureCreationTimePacket t) = [t] + creationTime _ = [] + + +-- | Given list of subpackets, a master key, one of its subkeys and a +-- list of signatures on that subkey, yields: +-- +-- * preceding list of signatures +-- +-- * The most recent valid signature made by the master key along with a +-- flag that indicates whether or not all of the supplied subpackets occur in +-- it or, if no valid signature from the working key is present, Nothing. +-- +-- * following list of signatures +-- +findTag :: + [SignatureSubpacket] + -> Packet + -> Packet + -> [(MappedPacket, b)] + -> ([(MappedPacket, b)], + Maybe (Bool, (MappedPacket, b)), + [(MappedPacket, b)]) +findTag tag topk subkey subsigs = (xs',minsig,ys') + where + vs = map (\sig -> + (sig, do + sig <- Just (packet . fst $ sig) + guard (isSignaturePacket sig) + guard $ flip isSuffixOf + (fingerprint topk) + . fromMaybe "%bad%" + . signature_issuer + $ sig + listToMaybe $ + map (signature_time . verify (Message [topk])) + (signatures $ Message [topk,subkey,sig]))) + subsigs + (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs + xs' = map fst xs + ys' = map fst $ if isNothing minsig then ys else drop 1 ys + minsig = do + (sig,ov) <- listToMaybe ys + ov + let hshed = hashed_subpackets $ packet $ fst sig + return ( null $ tag \\ hshed, sig) + +mkUsage :: String -> SignatureSubpacket +mkUsage tag | Just flags <- lookup tag specials + = KeyFlagsPacket + { certify_keys = fromEnum flags .&. 0x1 /= 0 + , sign_data = fromEnum flags .&. 0x2 /= 0 + , encrypt_communication = fromEnum flags .&. 0x4 /= 0 + , encrypt_storage = fromEnum flags .&. 0x8 /= 0 + , split_key = False + , authentication = False + , group_key = False + } + where + flagsets = [Special .. VouchSignEncrypt] + specials = map (\f -> (usageString f, f)) flagsets + +mkUsage tag = NotationDataPacket + { human_readable = True + , notation_name = "usage@" + , notation_value = tag + } + + unk :: Bool -> MappedPacket -> MappedPacket unk isPublic = if isPublic then toPacket secretToPublic else id where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)} @@ -421,15 +520,14 @@ showPacket p | isKey p = (if is_subkey p | otherwise = showPacket0 p where sigusage p = - case take 1 (tagStrings p) of - [] -> "" - tag:_ -> " "++show tag -- "("++tag++")" + case (usage_tags,flags) of + ([],[]) -> "" + (_:_,_) -> " "++show usage_tags + (_,ts) -> " "++show ts where - tagStrings p = usage_tags ++ flags - where - usage_tags = mapMaybe usage xs - flags = mapMaybe (fmap usageString . keyflags) xs - xs = hashed_subpackets p + usage_tags = mapMaybe usage xs + flags = mapMaybe (fmap usageString . keyflags) xs + xs = hashed_subpackets p showPacket0 p = dropSuffix "Packet" . concat . take 1 $ words (show p) @@ -588,6 +686,99 @@ try x body = Left e -> return e Right x -> body x +makeSig :: + PacketDecrypter + -> MappedPacket + -> FilePath + -> MappedPacket + -> [SignatureSubpacket] + -> Maybe (MappedPacket, Map.Map k a) + -> IO (KikiCondition ((MappedPacket, Map.Map k a), [KikiReportAction])) +makeSig doDecrypt top fname subkey_p tags mbsig = do + let wk = packet top + wkun <- doDecrypt top + try wkun $ \wkun -> do + let grip = fingerprint wk + addOrigin new_sig = + flip (maybe $ return FailedToMakeSignature) + (new_sig >>= listToMaybe . signatures_over) + $ \new_sig -> do + let mp' = mappedPacket fname new_sig + return $ KikiSuccess (mp', Map.empty) + parsedkey = [packet subkey_p] + hashed0 | any isFlagsPacket tags = tags + | otherwise + = KeyFlagsPacket + { certify_keys = False + , sign_data = False + , encrypt_communication = False + , encrypt_storage = False + , split_key = False + , authentication = True + , group_key = False } + : tags + -- implicitly added: + -- , SignatureCreationTimePacket (fromIntegral timestamp) + isFlagsPacket (KeyFlagsPacket {}) = True + isFlagsPacket _ = False + subgrip = fingerprint (head parsedkey) + + back_sig <- pgpSign (Message parsedkey) + (SubkeySignature wk + (head parsedkey) + (sigpackets 0x19 + hashed0 + [IssuerPacket subgrip])) + (if key_algorithm (head parsedkey)==ECDSA + then SHA256 + else SHA1) + subgrip + let iss = IssuerPacket (fingerprint wk) + cons_iss back_sig = iss : map EmbeddedSignaturePacket (signatures_over back_sig) + unhashed0 = maybe [iss] cons_iss back_sig + + new_sig <- pgpSign (Message [wkun]) + (SubkeySignature wk + (head parsedkey) + (sigpackets 0x18 + hashed0 + unhashed0)) + SHA1 + grip + let newSig = do + r <- addOrigin new_sig + return $ fmap (,[]) r + flip (maybe newSig) mbsig $ \(mp,trustmap) -> do + let sig = packet mp + isCreation (SignatureCreationTimePacket {}) = True + isCreation _ = False + isExpiration (SignatureExpirationTimePacket {}) = True + isExpiration _ = False + (cs,ps) = partition isCreation (hashed_subpackets sig) + (es,qs) = partition isExpiration ps + stamp = listToMaybe . sortBy (comparing Down) $ + map unwrap cs where unwrap (SignatureCreationTimePacket x) = x + exp = listToMaybe $ sort $ + map unwrap es where unwrap (SignatureExpirationTimePacket x) = x + expires = liftA2 (+) stamp exp + timestamp <- now + if fmap ( (< timestamp) . fromIntegral) expires == Just True then + return $ KikiSuccess ((mp,trustmap), [ UnableToUpdateExpiredSignature ] ) + else do + let times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp)) + $ maybeToList $ do + e <- expires + return $ SignatureExpirationTimePacket (e - fromIntegral timestamp) + sig' = sig { hashed_subpackets = times ++ (qs `union` tags) } + new_sig <- pgpSign (Message [wkun]) + (SubkeySignature wk + (packet subkey_p) + [sig'] ) + SHA1 + (fingerprint wk) + newsig <- addOrigin new_sig + return $ fmap (,[]) newsig + @@ -660,6 +851,40 @@ performManipulations doDecrypt rt wk manip = do rings = [HomeSec, HomePub] >>= resolveInputFile ctx return $ KikiSuccess (kd' , report ++ [ (f,DeletedPacket $ showPacket p) | f <- rings, p <- ps ]) + -- perform :: KikiCondition (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport)) + perform kd (SubKeyRenaming srctag dsttag) = do + try kd $ \(kd,report) -> do + flip (maybe $ return NoWorkingKey) wk $ \wk' -> do + subkeys' <- traverse (freshenOne wk') (keySubKeys kd) + let _ = subkeys' :: Map.Map KeyKey (KikiCondition (SubKey, KikiReport)) + succeded (KikiSuccess a) = True + succeded _ = False + (good,bad) = Map.partition succeded subkeys' + uncondition (KikiSuccess a) = a + uncondition _ = error "unexpected error" + good' = fmap uncondition good + if not (Map.null bad) + then return $ fmap (error "bad cast") $ head (Map.elems bad) + else return $ KikiSuccess ( kd { keySubKeys = fmap fst good' } + , report ++ concatMap snd (Map.elems good')) + where + freshenOne :: MappedPacket -> SubKey -> IO (KikiCondition (SubKey,[(FilePath, KikiReportAction)])) + freshenOne wk subkey@(SubKey subkey_p subsigs) = do + let (xs',minsig,ys') = findTag [mkUsage srctag] (packet wk) (packet subkey_p) subsigs + case minsig of + Just (True,sig) -> do + let fname = "--rename-subkey" + not_deleted p = mkUsage srctag /= p + mod sig = sig { hashed_subpackets = filter not_deleted $ hashed_subpackets sig } + sig' = first (fmap mod) sig + sigr <- makeSig doDecrypt wk fname subkey_p [mkUsage dsttag] (Just sig') + try sigr $ \(sig',sigreport) -> do + let old = packet (fst sig) + report <- return $ fmap (fname,) sigreport ++ [(fname, DeletedPacket (showPacket old)),(fname, YieldSignature)] + return $ KikiSuccess $ (SubKey subkey_p $ xs'++[sig']++ys', report) + _ -> return $ KikiSuccess (subkey, []) + + isBracket :: Char -> Bool isBracket '<' = True isBracket '>' = True @@ -717,7 +942,7 @@ resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops gs = groupBy sameMaster (sortBy (comparing code) bindings') --- (2 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] +-- (2 of 4) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk where 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 guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub))) return k --- (3 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] +-- (3 of 4) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] resolveTransform (DeleteSubkeyByUsage tag) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk where 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) = take 1 $ filter (has_tag tag) $ map (packet . fst) sigs return k +-- (4 of 4) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] +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 = -- ^ Delete the subkey specified by the given fingerprint and any -- associated signatures on that key. | DeleteSubkeyByUsage String - -- ^ Delete the subkey specified by the given fingerprint and any + -- ^ Delete the subkey specified by the given usage tag and any -- associated signatures on that key. + | RenameSubkeys String String + -- ^ Replace all subkey signatures matching the first usage tag with + -- fresh signatures that match the second usage tag. deriving (Eq,Ord,Show) -- | Use this type to indicate whether a file of type 'KeyRingFile' is expected -- cgit v1.2.3