Better handling for subkey-add of already existing key.

1 files 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 =