From c14cc300045989074ad433af96a36c0d86fc9e5b Mon Sep 17 00:00:00 2001 From: joe Date: Tue, 3 Dec 2013 22:12:26 -0500 Subject: Tested cross-merge capability! --- kiki.hs | 71 +++++++++++++++++++++++++++++++++++++++++------------------------ 1 file 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 () {- -- cgit v1.2.3