Remember packet origins in key database.

1 files changed, 52 insertions, 22 deletions

diff --git a/kiki.hs b/kiki.hs
index 1ea014d..bc45991 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -807,6 +807,7 @@ is40digitHex xs = ys == xs && length ys==40
             | 'a' <= c && c <= 'f' = True
     ishex c = False
 
+scanPackets :: FilePath -> [Packet] -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
 scanPackets filename [] = []
 scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret MarkerPacket) p) ps
  where
@@ -824,12 +825,21 @@ scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret Ma
     updateTrust _                    _   (pre,t) p = (pre,Map.insert filename p t) -- secret
 
 
-type SigAndTrust = ( Packet
-                   , Map.Map FilePath Packet ) -- trust packets
+type OriginFlags = ()
+originNil = ()
+
+data MappedPacket = MappedPacket
+        { packet :: Packet
+        , locations :: Map.Map FilePath OriginFlags
+        }
+
+type TrustMap = Map.Map FilePath Packet
+type SigAndTrust = ( MappedPacket
+                   , TrustMap     ) -- trust packets
 
 type KeyKey = [Char8.ByteString]
-data SubKey = SubKey Packet [SigAndTrust]
-data KeyData = KeyData Packet    -- main key
+data SubKey = SubKey MappedPacket [SigAndTrust]
+data KeyData = KeyData MappedPacket    -- main key
                        [SigAndTrust]  -- sigs on main key
                        (Map.Map String [SigAndTrust])  -- uids
                        (Map.Map KeyKey SubKey)    -- subkeys
@@ -860,19 +870,27 @@ subcomp a b = error $ unlines ["Unable to merge subs:"
                               , fingerprint b
                               , PP.ppShow b
                               ]
+subcomp_m a b = subcomp (packet a) (packet b)
 
-merge :: Map.Map KeyKey KeyData -> FilePath -> Message -> Map.Map KeyKey KeyData
+merge :: KeyDB -> FilePath -> Message -> KeyDB
 merge db filename (Message ps) = foldl mergeit db qs
  where
     qs = scanPackets filename ps
+    asMapped p = MappedPacket p (Map.singleton filename originNil)
+    asSigAndTrust (p,tm) = (asMapped p,tm)
     -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets
+    mergeit :: KeyDB -> (Packet,Packet,(Packet,Map.Map FilePath Packet)) -> KeyDB
     mergeit db (top,sub,ptt@(p,trustmap)) | 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
+             Nothing -> Just $ KeyData (asMapped p) [] Map.empty Map.empty
+             Just (KeyData key sigs uids subkeys) | keykey (packet key) == keykey p
+                     -> Just $ KeyData ( MappedPacket (minimumBy keycomp [packet key,p])
+                                                      (Map.insert filename originNil (locations key)) )
+                                       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
@@ -895,9 +913,12 @@ merge db filename (Message ps) = foldl mergeit db qs
 
     mergeit _  (_,_,p) = error $ "Unexpected PGP packet 3: "++whatP p
 
-    mergeSubkey p Nothing                  = Just $ SubKey p []
+    mergeSubkey :: Packet -> Maybe SubKey -> Maybe SubKey
+    mergeSubkey p Nothing                  = Just $ SubKey (asMapped p) []
     mergeSubkey p (Just (SubKey key sigs)) = Just $
-        SubKey (minimumBy subcomp [key,p]) sigs
+        SubKey (MappedPacket (minimumBy subcomp [packet key,p])
+                             (Map.insert filename originNil (locations key)))
+               sigs
 
     mergeUid (UserIDPacket s,_) Nothing     = Just []
     mergeUid (UserIDPacket s,_) (Just sigs) = Just sigs
@@ -906,21 +927,25 @@ merge db filename (Message ps) = foldl mergeit db qs
     whatP (a,_) = concat . take 1 . words . show $ a
     
 
+    mergeSig :: (Packet,TrustMap) -> [SigAndTrust] -> [SigAndTrust]
     mergeSig sig sigs = 
       let (xs,ys) = break (isSameSig sig) sigs
+          first f (x,y) = (f x,y)
       in if null ys 
-          then sigs++[sig] 
+          then sigs++[first asMapped sig]
           else let y:ys'=ys 
                in xs ++ (mergeSameSig sig y : ys')
         
 
-    isSameSig (a,_) (b,_) | isSignaturePacket a && isSignaturePacket b = 
+    isSameSig (a,_) (MappedPacket b _,_) | isSignaturePacket a && isSignaturePacket b = 
         a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] }
-    isSameSig (a,_) (b,_) = a==b
+    isSameSig (a,_) (MappedPacket b _,_) = a==b
 
-    mergeSameSig (a,ta) (b,tb) | isSignaturePacket a && isSignaturePacket b = 
-       ( b { unhashed_subpackets =
-                foldl mergeItem (unhashed_subpackets b) (unhashed_subpackets a) }
+    mergeSameSig :: (Packet,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap)
+    mergeSameSig (a,ta) (MappedPacket b locs,tb) | isSignaturePacket a && isSignaturePacket b = 
+       ( MappedPacket (b { unhashed_subpackets =
+                            foldl mergeItem (unhashed_subpackets b) (unhashed_subpackets a) })
+                      (Map.insert filename originNil locs)
         , tb `Map.union` ta )
     
      where
@@ -929,13 +954,13 @@ merge db filename (Message ps) = foldl mergeit db qs
     mergeSameSig a b = trace ("discarding dup "++show a) b
 
     mergeUidSig sig (Just sigs) = Just $ mergeSig sig sigs
-    mergeUidSig sig Nothing = Just [sig]
+    mergeUidSig sig Nothing = Just [asSigAndTrust 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 :: Bool -> Map.Map KeyKey KeyData -> Message
+flattenKeys :: Bool -> KeyDB -> Message
 flattenKeys isPublic db = Message $ concatMap flattenTop (prefilter . Map.assocs $ db)
  where
     flattenTop (_,(KeyData key sigs uids subkeys)) =
@@ -946,15 +971,20 @@ flattenKeys isPublic db = Message $ concatMap flattenTop (prefilter . Map.assocs
 
     flattenSub (_,SubKey key sigs) = unk key: concatMap unsig sigs
 
-    unk k = if isPublic then secretToPublic k else k
-    unsig (sig,trustmap) = [sig]++ take 1 (Map.elems $ Map.filterWithKey f trustmap) 
+    unk = (if isPublic then secretToPublic else id) . packet
+    unsig (sig,trustmap) = [packet sig]++ take 1 (Map.elems $ Map.filterWithKey f trustmap) 
       where
         f "%secring" _ = not isPublic
         f _          _ = isPublic
 
     prefilter = if isPublic then id else filter isSecret
-                 where isSecret (_,(KeyData (SecretKeyPacket {}) _ _ _)) = True
-                       isSecret _                                        = False
+                 where 
+                  isSecret (_,(KeyData
+                                  (MappedPacket { packet=(SecretKeyPacket {})})
+                                  _
+                                  _
+                                  _)) = True
+                  isSecret _          = False
 
 writeOutKeyrings db = return () -- TODO