Merging functionality (mergesecrets command)

1 files changed, 189 insertions, 1 deletions

diff --git a/kiki.hs b/kiki.hs
index 33f8428..b55510f 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -44,7 +44,7 @@ import System.Exit
 import ControlMaybe
 import Data.Char
 import Control.Arrow (second)
-import Data.Traversable
+import Data.Traversable hiding (mapM)
 import System.Console.CmdArgs
 -- import System.Posix.Time
 import Data.Time.Clock.POSIX
@@ -52,6 +52,7 @@ import System.Posix.IO (fdToHandle,fdRead)
 import System.Posix.Files
 import Data.Monoid ((<>))
 -- import Data.X509
+import qualified Data.Map as Map
 
 unprefix c spec = if null (snd p) then swap p else (fst p, tail (snd p))
  where p = break (==c) spec
@@ -773,6 +774,12 @@ data Arguments =
                 , seckey :: String }
         | CatPub { homedir :: Maybe FilePath
                  , catpub_args :: [String] }
+        | MergeSecrets 
+                 { homedir :: Maybe FilePath
+                 , files :: [FilePath]
+                 }
+        | DumpPackets { homedir :: Maybe FilePath
+                      , marshal_test :: String }
         {-
         | Decrypt { homedir :: Maybe FilePath
                   , passphrase_fd :: Maybe Int
@@ -802,6 +809,160 @@ is40digitHex xs = ys == xs && length ys==40
             | 'a' <= c && c <= 'f' = True
     ishex c = False
 
+scanPackets [] = []
+scanPackets (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,MarkerPacket) p) ps
+ where
+    doit (top,sub,_) p =
+        case p of
+            _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,p)
+            _ | isKey p && is_subkey p       -> (top,p,p)
+            _ | isUserID p                   -> (top,p,p)
+            _ | otherwise                    -> (top,sub,p)
+
+
+
+type KeyKey = [Char8.ByteString]
+data SubKey = SubKey Packet [Packet]
+data KeyData = KeyData Packet    -- main key
+                       [Packet]  -- sigs on main key
+                       (Map.Map String [Packet])  -- uids
+                       (Map.Map KeyKey SubKey)    -- subkeys
+
+type KeyDB = Map.Map KeyKey KeyData
+
+keykey key = fingerprint_material key -- TODO: smaller key?
+uidkey (UserIDPacket str) = str
+
+-- Compare master keys, LT is prefered for merging
+keycomp (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
+keycomp (PublicKeyPacket {}) (SecretKeyPacket {}) = GT
+keycomp a b | a==b = EQ
+keycomp a b = error $ unlines ["Unable to merge keys:"
+                              , fingerprint a
+                              , PP.ppShow a
+                              , fingerprint b
+                              , PP.ppShow b
+                              ]
+
+-- Compare subkeys, LT is prefered for merging
+subcomp (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
+subcomp (PublicKeyPacket {}) (SecretKeyPacket {}) = GT
+subcomp a b | a==b = EQ
+subcomp a b = error $ unlines ["Unable to merge subs:"
+                              , fingerprint a
+                              , PP.ppShow a
+                              , fingerprint b
+                              , PP.ppShow b
+                              ]
+
+merge :: Map.Map KeyKey KeyData -> Message -> Map.Map KeyKey KeyData
+merge db (Message ps) = foldl mergeit db qs
+ where
+    qs = scanPackets ps
+    mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets
+    mergeit db (top,sub,p) | isKey top = Map.alter update (keykey top) db
+     where
+        update v | isKey p && not (is_subkey p) 
+          = case v of
+             Nothing -> Just $ KeyData p [] Map.empty Map.empty
+             Just (KeyData key sigs uids subkeys) | keykey key == keykey p
+                     -> Just $ KeyData (minimumBy keycomp [key,p]) sigs uids subkeys
+             _       -> error . concat $ ["Unexpected master key merge error: "
+                                         ,show (fingerprint top, fingerprint p)]
+        update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p
+          = Just $ KeyData key sigs uids (Map.alter (mergeSubkey p) (keykey p) subkeys)
+        update (Just (KeyData key sigs uids subkeys)) | isUserID p
+          = Just $ KeyData key sigs (Map.alter (mergeUid p) (uidkey p) uids) subkeys
+        update (Just (KeyData key sigs uids subkeys))
+          = case sub of
+             MarkerPacket    -> Just $ KeyData key (mergeSig p sigs) uids subkeys
+             UserIDPacket {} -> Just $ KeyData key 
+                                               sigs 
+                                               (Map.alter (mergeUidSig p) (uidkey sub) uids)
+                                               subkeys
+             _  | isKey sub  -> Just $ KeyData key
+                                               sigs
+                                               uids
+                                               (Map.alter (mergeSubSig p) (keykey sub) subkeys)
+             _ -> error $ "Unexpected PGP packet 1: "++(words (show p) >>= take 1)
+        update _ = error $ "Unexpected PGP packet 2: "++(words (show p) >>= take 1)
+
+    mergeit _  (_,_,p) = error $ "Unexpected PGP packet 3: "++whatP p
+
+    mergeSubkey p Nothing                  = Just $ SubKey p []
+    mergeSubkey p (Just (SubKey key sigs)) = Just $
+        SubKey (minimumBy subcomp [key,p]) sigs
+
+    mergeUid (UserIDPacket s) Nothing     = Just []
+    mergeUid (UserIDPacket s) (Just sigs) = Just sigs
+    mergeUid p _ = error $ "Unable to merge into UID record: " ++whatP p
+
+    whatP = concat . take 1 . words . show
+    
+
+    mergeSig sig sigs = 
+      let (xs,ys) = break (isSameSig sig) sigs
+      in if null ys 
+          then sigs++[sig] 
+          else let y:ys'=ys 
+               in xs ++ (mergeSameSig sig y : ys')
+        
+
+    isSameSig a b | isSignaturePacket a && isSignaturePacket b = 
+        a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] }
+    isSameSig a b = a==b
+
+    mergeSameSig a b | isSignaturePacket a && isSignaturePacket b = 
+        b { unhashed_subpackets =
+                foldl mergeItem (unhashed_subpackets b) (unhashed_subpackets a)
+          }
+     where
+        mergeItem ys x = if x `elem` ys then ys else ys++[x]
+
+    mergeSameSig a b = trace ("discarding dup "++show a) b
+
+    mergeUidSig sig (Just sigs) = Just $ mergeSig sig sigs
+    mergeUidSig sig Nothing = Just [sig]
+
+    mergeSubSig sig (Just (SubKey key sigs)) = Just $ SubKey key (mergeSig sig sigs)
+    mergeSubSig sig Nothing = error $ 
+        "Unable to merge subkey signature: "++(words (show sig) >>= take 1)
+
+flattenKeys :: Map.Map KeyKey KeyData -> Message
+flattenKeys db = Message $ concatMap flattenTop (Map.assocs db)
+ where
+    flattenTop (_,(KeyData key sigs uids subkeys)) =
+        key : ( concatMap flattenUid (Map.assocs uids) 
+                ++ concatMap flattenSub (Map.assocs subkeys))
+
+    flattenUid (str,sigs) = UserIDPacket str : sigs
+
+    flattenSub (_,SubKey key sigs) = key:sigs
+
+{-
+merge db (Message ps) = scanl mergeit db qs
+ where
+    qs = scanPackets ps
+    mergeit db (top,sub,p) = todo
+      where
+        k = keykey top
+        v = maybe (merge1 (newrec top)) (merge2 sub p) $ Map.lookup k db
+
+        keykey key = fingerprint_material key -- TODO: smaller key?
+
+        newrec key | isKey key && not (is_subkey key) = 
+            KeyData key [] Map.empty Map.empty
+        newrec _ = error "Unexpected packet."
+
+        merge1 rec db = Map.insert k rec db
+
+        merge2 sub p (KeyData mk sigs uids subkeys)
+            | isKey sub = 
+                maybe todo todo $ Map.lookup skey subkeys
+          where
+            skey = keykey sub
+-}
+
 main = do
     args <- cmdArgs $ modes 
         [ List HOMEOPTION
@@ -838,6 +999,12 @@ main = do
         , CatPub HOMEOPTION
               (def &= args &= typ "KEYSPEC FILES")
             &= help "Extract a public subkey to stdout."
+        , MergeSecrets HOMEOPTION
+              (def &= args &= typFile)
+            &= help "Merge multiple keyrings to stdout."
+        , DumpPackets HOMEOPTION
+              (def &= opt ("n" ::String))
+            &= help "Output secret ring packets in ascii format for debugging."
         , Add HOMEOPTION
               (def &= opt ("passphrase"::String) 
                    &= typ "FD"
@@ -1083,6 +1250,27 @@ main = do
         -}
     -}
 
+    doCmd cmd@(DumpPackets {}) = do
+        ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome
+          , sec   -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg
+          , grip  -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321"
+          ) <- getPGPEnviron cmd
+        if map toLower (marshal_test cmd) `elem` ["y","yes"]
+            then L.putStr $ encode (Message sec)
+            else putStrLn $ PP.ppShow sec
+
+    doCmd cmd@(MergeSecrets {}) = do
+        ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome
+          , sec   -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg
+          , grip  -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321"
+          ) <- getPGPEnviron cmd
+        let db = merge Map.empty (Message sec)
+        ms <- mapM readPacketsFromFile (files cmd)
+        let db' = foldl' merge db ms
+            m = flattenKeys db'
+        L.putStr (encode m)
+        return ()
+
     doCmd cmd@(CatPub {}) = do
         let spec:files = catpub_args cmd
         let (topspec,subspec) = unprefix '/' spec