summaryrefslogtreecommitdiff
path: root/kiki.hs
diff options
context:
space:
mode:
Diffstat (limited to 'kiki.hs')
-rw-r--r--kiki.hs71
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
575 let (lks, fails) = partition (isJust . fst) ls 575 let (lks, fails) = partition (isJust . fst) ls
576 return (map (\(lk,f)->(fromJust lk,f)) lks, map snd fails) 576 return (map (\(lk,f)->(fromJust lk,f)) lks, map snd fails)
577 577
578unlockFiles lks = forM_ lks $ \lk -> dotlock_release lk 578unlockFiles lks = forM_ lks $ \(lk,f) -> do
579 -- warn $ "unlocking "++show f
580 dotlock_release lk
579 581
580parseOptionFile fname = do 582parseOptionFile fname = do
581 xs <- fmap lines (readFile fname) 583 xs <- fmap lines (readFile fname)
@@ -851,7 +853,7 @@ type KeyKey = [Char8.ByteString]
851data SubKey = SubKey MappedPacket [SigAndTrust] 853data SubKey = SubKey MappedPacket [SigAndTrust]
852data KeyData = KeyData MappedPacket -- main key 854data KeyData = KeyData MappedPacket -- main key
853 [SigAndTrust] -- sigs on main key 855 [SigAndTrust] -- sigs on main key
854 ((Map.Map String [SigAndTrust]),OriginMap) -- uids 856 (Map.Map String ([SigAndTrust],OriginMap)) -- uids
855 (Map.Map KeyKey SubKey) -- subkeys 857 (Map.Map KeyKey SubKey) -- subkeys
856 858
857type KeyDB = Map.Map KeyKey KeyData 859type KeyDB = Map.Map KeyKey KeyData
@@ -888,7 +890,7 @@ merge db filename (Message ps) = foldl mergeit db (zip [0..] qs)
888 qs = scanPackets filename ps 890 qs = scanPackets filename ps
889 asMapped n p = MappedPacket p (Map.singleton filename (origin p n)) 891 asMapped n p = MappedPacket p (Map.singleton filename (origin p n))
890 asSigAndTrust n (p,tm) = (asMapped n p,tm) 892 asSigAndTrust n (p,tm) = (asMapped n p,tm)
891 emptyUids = (Map.empty,Map.empty) 893 emptyUids = Map.empty
892 -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets 894 -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets
893 mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB 895 mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB
894 mergeit db (n,(top,sub,ptt@(p,trustmap))) | isKey top = Map.alter update (keykey top) db 896 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)
914 ,show (fingerprint top, fingerprint p)] 916 ,show (fingerprint top, fingerprint p)]
915 update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p 917 update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p
916 = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys) 918 = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys)
917 update (Just (KeyData key sigs (uids,locs) subkeys)) | isUserID p 919 update (Just (KeyData key sigs uids subkeys)) | isUserID p
918 = Just $ KeyData key sigs ( Map.alter (mergeUid ptt) (uidkey p) uids 920 = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids)
919 , Map.insert filename (origin p n) locs )
920 subkeys 921 subkeys
921 update (Just (KeyData key sigs uids subkeys)) 922 update (Just (KeyData key sigs uids subkeys))
922 = case sub of 923 = case sub of
923 MarkerPacket -> Just $ KeyData key (mergeSig n ptt sigs) uids subkeys 924 MarkerPacket -> Just $ KeyData key (mergeSig n ptt sigs) uids subkeys
924 UserIDPacket {} -> Just $ KeyData key 925 UserIDPacket {} -> Just $ KeyData key
925 sigs 926 sigs
926 (Map.alter (mergeUidSig n ptt) (uidkey sub) (fst uids) 927 (Map.alter (mergeUidSig n ptt) (uidkey sub) uids)
927 ,Map.insert filename (origin p n) (snd uids))
928 subkeys 928 subkeys
929 _ | isKey sub -> Just $ KeyData key 929 _ | isKey sub -> Just $ KeyData key
930 sigs 930 sigs
@@ -942,9 +942,10 @@ merge db filename (Message ps) = foldl mergeit db (zip [0..] qs)
942 (Map.insert filename (origin p n) (locations key))) 942 (Map.insert filename (origin p n) (locations key)))
943 sigs 943 sigs
944 944
945 mergeUid (UserIDPacket s,_) Nothing = Just [] 945 mergeUid :: Int ->(Packet,a) -> Maybe ([SigAndTrust],OriginMap) -> Maybe ([SigAndTrust],OriginMap)
946 mergeUid (UserIDPacket s,_) (Just sigs) = Just sigs 946 mergeUid n (UserIDPacket s,_) Nothing = Just ([],Map.singleton filename (origin MarkerPacket n))
947 mergeUid p _ = error $ "Unable to merge into UID record: " ++whatP p 947 mergeUid n (UserIDPacket s,_) (Just (sigs,m)) = Just (sigs, Map.insert filename (origin MarkerPacket n) m)
948 mergeUid n p _ = error $ "Unable to merge into UID record: " ++whatP p
948 949
949 whatP (a,_) = concat . take 1 . words . show $ a 950 whatP (a,_) = concat . take 1 . words . show $ a
950 951
@@ -977,8 +978,8 @@ merge db filename (Message ps) = foldl mergeit db (zip [0..] qs)
977 978
978 mergeSameSig n a b = trace ("discarding dup "++show a) b 979 mergeSameSig n a b = trace ("discarding dup "++show a) b
979 980
980 mergeUidSig n sig (Just sigs) = Just $ mergeSig n sig sigs 981 mergeUidSig n sig (Just (sigs,m)) = Just (mergeSig n sig sigs, m)
981 mergeUidSig n sig Nothing = Just [asSigAndTrust n sig] 982 mergeUidSig n sig Nothing = Just ([asSigAndTrust n sig],Map.empty)
982 983
983 mergeSubSig n sig (Just (SubKey key sigs)) = Just $ SubKey key (mergeSig n sig sigs) 984 mergeSubSig n sig (Just (SubKey key sigs)) = Just $ SubKey key (mergeSig n sig sigs)
984 mergeSubSig n sig Nothing = error $ 985 mergeSubSig n sig Nothing = error $
@@ -1002,11 +1003,11 @@ concatSort fname getp f = concat . sortByHint fname getp . map f
1002flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket] 1003flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket]
1003flattenTop fname ispub (KeyData key sigs uids subkeys) = 1004flattenTop fname ispub (KeyData key sigs uids subkeys) =
1004 unk ispub key : 1005 unk ispub key :
1005 ( concatSort fname head (flattenUid fname ispub (snd uids)) (Map.assocs (fst uids)) 1006 ( concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
1006 ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys)) 1007 ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys))
1007 1008
1008flattenUid :: FilePath -> Bool -> OriginMap -> (String,[SigAndTrust]) -> [MappedPacket] 1009flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
1009flattenUid fname ispub om (str,sigs) = 1010flattenUid fname ispub (str,(sigs,om)) =
1010 MappedPacket (UserIDPacket str) om : concatSort fname head (unsig fname ispub) sigs 1011 MappedPacket (UserIDPacket str) om : concatSort fname head (unsig fname ispub) sigs
1011 1012
1012flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket] 1013flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket]
@@ -1042,7 +1043,8 @@ sortByHint fname f = sortBy (comparing gethint)
1042 1043
1043keyPacket (KeyData k _ _ _) = k 1044keyPacket (KeyData k _ _ _) = k
1044 1045
1045writeOutKeyrings db = do 1046writeOutKeyrings :: Map.Map FilePath DotLock -> KeyDB -> IO ()
1047writeOutKeyrings lkmap db = do
1046 let ks = Map.elems db 1048 let ks = Map.elems db
1047 fs = Map.keys (foldr unionfiles Map.empty ks) 1049 fs = Map.keys (foldr unionfiles Map.empty ks)
1048 where unionfiles (KeyData p _ _ _) m = 1050 where unionfiles (KeyData p _ _ _) m =
@@ -1056,11 +1058,27 @@ writeOutKeyrings db = do
1056 flattenTop f (originallyPublic n) d 1058 flattenTop f (originallyPublic n) d
1057 changes = filter notnew x 1059 changes = filter notnew x
1058 where notnew p = isNothing (Map.lookup f $ locations p) 1060 where notnew p = isNothing (Map.lookup f $ locations p)
1059 unlines $ ( (f ++ ":") : map (showPacket . packet) x) ++ 1061 {-
1060 ( "CHANGES: " : map ((" "++) . showPacket . packet) changes) 1062 trace (unlines $ ( (f ++ ":") : map (showPacket . packet) x) ++
1061 putStrLn s 1063 ( "CHANGES: " : map ((" "++) . showPacket . packet) changes)) $ do
1062 -- putStrLn $ "fs = " ++ show fs 1064 -}
1063 return () -- TODO 1065 return (f,(changes,x))
1066 towrites <- fmap catMaybes $ Control.Monad.forM s $ \(f,(changes,x)) -> do
1067 let noop = return Nothing
1068 write f = return (Just f)
1069 case changes of
1070 [] -> noop -- warn (f ++": nothing to do.") >> noop
1071 cs -> case Map.lookup f lkmap of
1072 Just lk -> do
1073 forM_ cs $ \c -> warn $ f++": new "++showPacket (packet c)
1074 write (f,lk,x)
1075 Nothing -> do
1076 forM_ cs $ \c -> warn $ f++": missing "++showPacket (packet c)
1077 noop
1078 forM_ towrites $ \(f,lk,x) -> do
1079 let m = Message $ map packet x
1080 -- warn $ "writing "++f
1081 L.writeFile f (encode m)
1064 1082
1065data Arguments = 1083data Arguments =
1066 Cross_Merge { homedir :: Maybe FilePath 1084 Cross_Merge { homedir :: Maybe FilePath
@@ -1324,12 +1342,13 @@ main = do
1324 (fsns,failed_locks) <- lockFiles (secring:pubring:files cmd) 1342 (fsns,failed_locks) <- lockFiles (secring:pubring:files cmd)
1325 forM_ failed_locks $ \f -> warn $ "Failed to lock: " ++ f 1343 forM_ failed_locks $ \f -> warn $ "Failed to lock: " ++ f
1326 let (lks,fs) = unzip fsns 1344 let (lks,fs) = unzip fsns
1327 forM_ fs $ \f -> warn $ "locked: " ++ f 1345 -- forM_ fs $ \f -> warn $ "locked: " ++ f
1328 let readp n = fmap (n,) (readPacketsFromFile n) 1346 let readp n = fmap (n,) (readPacketsFromFile n)
1329 ms <- mapM readp fs 1347 ms <- mapM readp (fs++failed_locks)
1330 let db = foldl' (uncurry . merge) Map.empty ms 1348 let db = foldl' (uncurry . merge) Map.empty ms
1331 writeOutKeyrings db 1349 let lkmap = Map.fromList (map swap fsns)
1332 unlockFiles lks 1350 writeOutKeyrings lkmap db
1351 unlockFiles fsns
1333 return () 1352 return ()
1334 1353
1335 {- 1354 {-