From 67df213456f470ba7e46b6193550bb28eabfb7e7 Mon Sep 17 00:00:00 2001 From: joe Date: Sat, 2 Nov 2013 18:43:17 -0400 Subject: Better handling for subkey-add of already existing key. --- kiki.hs | 140 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 125 insertions(+), 15 deletions(-) diff --git a/kiki.hs b/kiki.hs index d590cd4..2194059 100644 --- a/kiki.hs +++ b/kiki.hs @@ -8,6 +8,7 @@ module Main where import Debug.Trace +import GHC.Exts (Down(..)) import Data.Binary import Data.OpenPGP import qualified Data.ByteString.Lazy as L @@ -222,6 +223,10 @@ verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersig let sigover = signatures_over sub unhashed = sigover >>= unhashed_subpackets subsigs = mapMaybe backsig unhashed + -- This should consist only of 0x19 values + -- subtypes = map signature_type subsigs + -- trace ("subtypes = "++show subtypes) (return ()) + -- trace ("issuers: "++show (map signature_issuer subsigs)) (return ()) sig <- signatures (Message ([topkey sub,subkey sub]++subsigs)) let v = verify (Message [subkey sub]) sig guard (not . null $ signatures_over v) @@ -905,7 +910,11 @@ main = do then sigs {- else trace ( "key params: "++params (fromJust selfkey)++"\n" - ++traceSig (topkey new_sig) (user_id new_sig) (signatures_over new_sig)) sigs ++ map modsig (signatures_over new_sig) + ++traceSig (topkey new_sig) + (user_id new_sig) + (signatures_over new_sig)) + sigs + ++ {- map modsig -} (signatures_over new_sig) -} else sigs ++ signatures_over new_sig modsig sig = sig { signature = map id (signature sig) } @@ -1072,9 +1081,119 @@ main = do let pkf = fingerprint (head parsedkey) (prepk,pks) = seek_key pkf subkeys' - if not (null pks) then putStrLn "Key already present." - else do + if not (null pks) + then existingKey (prepk,pks) remainder wkun wk parsedkey (key_usage cmd) pre uids subkeys (output cmd) grip + else newKey wkun wk parsedkey (key_usage cmd) pre uids subkeys (output cmd) grip + doCmd cmd@(PemFP {}) = do + let parseKeySpec hint spec = case break (==':') spec of + (fmt,_:file) -> (fmt,file) + (file,"") -> (guessKeyFormat hint ("ssh-host"), file) + (secfmt,secfile) = parseKeySpec 'S' $ seckey cmd + Message seckey <- readKeyFromFile False secfmt secfile + -- Message pubkey <- readKeyFromFile True pubfmt pubfile + putStrLn $ fingerprint (head seckey) + + +isSameKey a b = sort (key apub) == sort (key bpub) + where + apub = secretToPublic a + bpub = secretToPublic b + +existingKey (prepk,pks) remainder wkun wk parsedkey tag pre uids subkeys output_file grip = do + -- putStrLn "Key already present." + let pk:trail = pks + (trailsigs,trail') = span isSignaturePacket trail + (mysigs,notmines) = partition (endsWith grip . maybe "%bad%" id . signature_issuer) + trailsigs + endsWith big small = drop (length big - length small) big == small + vs = map (\sig -> + (sig, map (verify (Message [wk])) + (signatures $ Message [wk,pk,sig]))) + mysigs + (verified,unverified) = partition (not . null . snd) vs + sorted = sortBy (comparing (Down . signature_time . head . snd)) verified + -- Note: format allows for signatures of type 0x28 Subkey revocation signature. + case sorted of + [] -> do + putStrLn "Adding valid signature to existing key..." + newKey wkun wk [pk] tag pre uids (trail++prepk++remainder) output_file grip + (sig,ov):vs -> do + -- TODO: update sig to contain usage@ = tag + let hs = filter (\p->isNotation p && notation_name p=="usage@") (hashed_subpackets sig) + ks = map notation_value hs + isNotation (NotationDataPacket {}) = True + isNotation _ = False + noop = do + -- Nothing to do + let sec' = pre ++ [wk] ++ uids ++ subkeys + putStrLn $ tag ++ " key already present." + L.writeFile output_file (encode (Message sec')) + if tag `elem` ks + then noop + else do + g <- newGenIO + timestamp <- now + let 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 + if fmap ( (< timestamp) . fromIntegral) expires == Just True then do + putStrLn $ "Unable to update expired signature" + noop + else do + let new_sig = fst $ sign (Message [wkun]) + (SubkeySignature wk + (head parsedkey) + [sig'] ) + SHA1 + grip + timestamp + (g::SystemRandom) + times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp)) + $ maybeToList $ do + e <- expires + return $ SignatureExpirationTimePacket (e - fromIntegral timestamp) + notation = NotationDataPacket + { notation_name = "usage@" + , notation_value = tag + , human_readable = True } + sig' = sig { hashed_subpackets = times ++ [notation] ++ qs } + + -- noop let sec' = pre ++ [wk] ++ uids ++ subkeys + sec' = pre + ++ [wk] + ++ uids + ++ prepk + ++ [pk] + ++ signatures_over new_sig + ++ map fst vs + ++ map fst unverified + ++ notmines + ++ trail' + ++ remainder + putStrLn $ "Adding usage@="++tag + L.writeFile output_file (encode (Message sec')) + where + signature_time ov = case if null cs then ds else cs of + [] -> minBound + xs -> last (sort 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 _ = [] + +newKey wkun wk parsedkey tag pre uids subkeys output_file grip = do g <- newGenIO timestamp <- now @@ -1113,8 +1232,9 @@ main = do , NotationDataPacket { human_readable = True , notation_name = "usage@" - , notation_value = key_usage cmd + , notation_value = tag } + , SignatureCreationTimePacket (fromIntegral timestamp) ] subgrip = fingerprint (head parsedkey) @@ -1133,7 +1253,7 @@ main = do let sec' = pre ++ [wk] ++ uids ++ parsedkey ++ signatures_over new_sig ++ subkeys putStrLn $ listKeys sec' - L.writeFile (output cmd) (encode (Message sec')) + L.writeFile output_file (encode (Message sec')) {- let backsigs = do @@ -1150,16 +1270,6 @@ main = do return () - doCmd cmd@(PemFP {}) = do - let parseKeySpec hint spec = case break (==':') spec of - (fmt,_:file) -> (fmt,file) - (file,"") -> (guessKeyFormat hint ("ssh-host"), file) - (secfmt,secfile) = parseKeySpec 'S' $ seckey cmd - Message seckey <- readKeyFromFile False secfmt secfile - -- Message pubkey <- readKeyFromFile True pubfmt pubfile - putStrLn $ fingerprint (head seckey) - - groupBindings pub = -- cgit v1.2.3