Tested cross-merge capability!

1 files changed, 45 insertions, 26 deletions

diff --git a/kiki.hs b/kiki.hs
index 96e57e2..d7a802b 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -575,7 +575,9 @@ lockFiles fs = do
     let (lks, fails) = partition (isJust . fst) ls
     return (map (\(lk,f)->(fromJust lk,f)) lks, map snd fails)
 
-unlockFiles lks = forM_ lks $ \lk -> dotlock_release lk
+unlockFiles lks = forM_ lks $ \(lk,f) -> do
+    -- warn $ "unlocking "++show f
+    dotlock_release lk
 
 parseOptionFile fname = do
     xs <- fmap lines (readFile fname)
@@ -851,7 +853,7 @@ type KeyKey = [Char8.ByteString]
 data SubKey = SubKey MappedPacket [SigAndTrust]
 data KeyData = KeyData MappedPacket    -- main key
                        [SigAndTrust]  -- sigs on main key
-                       ((Map.Map String [SigAndTrust]),OriginMap)  -- uids
+                       (Map.Map String ([SigAndTrust],OriginMap))  -- uids
                        (Map.Map KeyKey SubKey)    -- subkeys
 
 type KeyDB = Map.Map KeyKey KeyData
@@ -888,7 +890,7 @@ merge db filename (Message ps) = foldl mergeit db (zip [0..] qs)
     qs = scanPackets filename ps
     asMapped n p = MappedPacket p (Map.singleton filename (origin p n))
     asSigAndTrust n (p,tm) = (asMapped n p,tm)
-    emptyUids = (Map.empty,Map.empty)
+    emptyUids = Map.empty
     -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets
     mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB
     mergeit db (n,(top,sub,ptt@(p,trustmap))) | isKey top = Map.alter update (keykey top) db
@@ -914,17 +916,15 @@ merge db filename (Message ps) = foldl mergeit db (zip [0..] qs)
                                          ,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 n p) (keykey p) subkeys)
-        update (Just (KeyData key sigs (uids,locs) subkeys)) | isUserID p
-          = Just $ KeyData key sigs ( Map.alter (mergeUid ptt) (uidkey p) uids
-                                    , Map.insert filename (origin p n) locs )
+        update (Just (KeyData key sigs uids subkeys)) | isUserID p
+          = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids)
                                     subkeys
         update (Just (KeyData key sigs uids subkeys))
           = case sub of
              MarkerPacket    -> Just $ KeyData key (mergeSig n ptt sigs) uids subkeys
              UserIDPacket {} -> Just $ KeyData key
                                                sigs
-                                               (Map.alter (mergeUidSig n ptt) (uidkey sub) (fst uids)
-                                               ,Map.insert filename (origin p n) (snd uids))
+                                               (Map.alter (mergeUidSig n ptt) (uidkey sub) uids)
                                                subkeys
              _  | isKey sub  -> Just $ KeyData key
                                                sigs
@@ -942,9 +942,10 @@ merge db filename (Message ps) = foldl mergeit db (zip [0..] qs)
                              (Map.insert filename (origin p n) (locations key)))
                sigs
 
-    mergeUid (UserIDPacket s,_) Nothing     = Just []
-    mergeUid (UserIDPacket s,_) (Just sigs) = Just sigs
-    mergeUid p _ = error $ "Unable to merge into UID record: " ++whatP p
+    mergeUid :: Int ->(Packet,a) -> Maybe ([SigAndTrust],OriginMap) -> Maybe ([SigAndTrust],OriginMap)
+    mergeUid n (UserIDPacket s,_) Nothing         = Just ([],Map.singleton filename (origin MarkerPacket n))
+    mergeUid n (UserIDPacket s,_) (Just (sigs,m)) = Just (sigs, Map.insert filename (origin MarkerPacket n) m)
+    mergeUid n p _ = error $ "Unable to merge into UID record: " ++whatP p
 
     whatP (a,_) = concat . take 1 . words . show $ a
 
@@ -977,8 +978,8 @@ merge db filename (Message ps) = foldl mergeit db (zip [0..] qs)
 
     mergeSameSig n a b = trace ("discarding dup "++show a) b
 
-    mergeUidSig n sig (Just sigs) = Just $ mergeSig n sig sigs
-    mergeUidSig n sig Nothing = Just [asSigAndTrust n sig]
+    mergeUidSig n sig (Just (sigs,m)) = Just (mergeSig n sig sigs, m)
+    mergeUidSig n sig Nothing     = Just ([asSigAndTrust n sig],Map.empty)
 
     mergeSubSig n sig (Just (SubKey key sigs)) = Just $ SubKey key (mergeSig n sig sigs)
     mergeSubSig n sig Nothing = error $
@@ -1002,11 +1003,11 @@ concatSort fname getp f = concat . sortByHint fname getp . map f
 flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket]
 flattenTop fname ispub (KeyData key sigs uids subkeys) =
     unk ispub key : 
-            ( concatSort fname head (flattenUid fname ispub (snd uids)) (Map.assocs (fst uids))
+            ( concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
              ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys))
 
-flattenUid :: FilePath -> Bool -> OriginMap -> (String,[SigAndTrust]) -> [MappedPacket]
-flattenUid fname ispub om (str,sigs) = 
+flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
+flattenUid fname ispub (str,(sigs,om)) = 
     MappedPacket (UserIDPacket str) om : concatSort fname head (unsig fname ispub) sigs
 
 flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket]
@@ -1042,7 +1043,8 @@ sortByHint fname f = sortBy (comparing gethint)
 
 keyPacket (KeyData k _ _ _) = k
 
-writeOutKeyrings db = do
+writeOutKeyrings :: Map.Map FilePath DotLock -> KeyDB -> IO ()
+writeOutKeyrings lkmap db = do
     let ks = Map.elems db
         fs = Map.keys (foldr unionfiles Map.empty ks)
                 where unionfiles (KeyData p _ _ _) m =
@@ -1056,11 +1058,27 @@ writeOutKeyrings db = do
                 flattenTop f (originallyPublic n) d
             changes = filter notnew x
                 where notnew p = isNothing (Map.lookup f $ locations p)
-        unlines $ ( (f ++ ":") : map (showPacket . packet) x) ++
-                  ( "CHANGES: " : map (("  "++) . showPacket . packet) changes)
-    putStrLn s
-    -- putStrLn $ "fs = " ++ show fs 
-    return () -- TODO
+        {-
+        trace (unlines $ ( (f ++ ":") : map (showPacket . packet) x) ++
+                  ( "CHANGES: " : map (("  "++) . showPacket . packet) changes)) $ do
+        -}
+        return (f,(changes,x))
+    towrites <- fmap catMaybes $ Control.Monad.forM s $ \(f,(changes,x)) -> do
+        let noop    = return Nothing
+            write f = return (Just f)
+        case changes of
+            [] -> noop -- warn (f ++": nothing to do.") >> noop
+            cs -> case Map.lookup f lkmap of
+                    Just lk -> do
+                         forM_ cs $ \c -> warn $ f++": new "++showPacket (packet c)
+                         write (f,lk,x)
+                    Nothing -> do
+                         forM_ cs $ \c -> warn $ f++": missing "++showPacket (packet c)
+                         noop
+    forM_ towrites $ \(f,lk,x) -> do
+        let m = Message $ map packet x
+        -- warn $ "writing "++f
+        L.writeFile f (encode m)
 
 data Arguments =
         Cross_Merge { homedir :: Maybe FilePath
@@ -1324,12 +1342,13 @@ main = do
         (fsns,failed_locks) <- lockFiles (secring:pubring:files cmd)
         forM_ failed_locks $ \f -> warn $ "Failed to lock: " ++ f
         let (lks,fs) = unzip fsns
-        forM_ fs $ \f -> warn $ "locked: " ++ f
+        -- forM_ fs $ \f -> warn $ "locked: " ++ f
         let readp n = fmap (n,) (readPacketsFromFile n)
-        ms <- mapM readp fs
+        ms <- mapM readp (fs++failed_locks)
         let db = foldl' (uncurry . merge) Map.empty ms
-        writeOutKeyrings db
-        unlockFiles lks
+        let lkmap = Map.fromList (map swap fsns)
+        writeOutKeyrings lkmap db
+        unlockFiles fsns
         return ()
 
     {-