moved merge function into KeyRing module

1 files changed, 0 insertions, 205 deletions

diff --git a/kiki.hs b/kiki.hs
index 217f70f..47d9bdb 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -328,22 +328,12 @@ writePEM typ dta = pem
 
     -- 64 byte lines
 
-isKey (PublicKeyPacket {}) = True
-isKey (SecretKeyPacket {}) = True
-isKey _                    = False
-
-isUserID (UserIDPacket {}) = True
-isUserID _                 = False
-
 isEmbeddedSignature (EmbeddedSignaturePacket {}) = True
 isEmbeddedSignature _                            = False
 
 isCertificationSig (CertificationSignature {}) = True
 isCertificationSig _                           = True
 
-isTrust (TrustPacket {}) = True
-isTrust _                = False
-
 issuer (IssuerPacket issuer) = Just issuer
 issuer _                     = Nothing
 backsig (EmbeddedSignaturePacket s) = Just s
@@ -1008,203 +998,8 @@ 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
-    ret p = (p,Map.empty)
-    doit (top,sub,prev) p =
-        case p of
-            _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p)
-            _ | isKey p && is_subkey p       -> (top,p,ret p)
-            _ | isUserID p                   -> (top,p,ret p)
-            _ | isTrust p                    -> (top,sub,updateTrust top sub prev p)
-            _ | otherwise                    -> (top,sub,ret p)
-
-    updateTrust top (PublicKeyPacket {}) (pre,t) p = (pre,Map.insert filename p t) -- public
-    updateTrust (PublicKeyPacket {}) _   (pre,t) p = (pre,Map.insert filename p t) -- public
-    updateTrust _                    _   (pre,t) p = (pre,Map.insert filename p t) -- secret
-
-
-data OriginFlags = OriginFlags {
-        originallyPublic :: Bool,
-        originalNum :: Int
-    }
-    deriving Show
-origin :: Packet -> Int -> OriginFlags
-origin p n = OriginFlags ispub n
- where
-    ispub = case p of
-                    SecretKeyPacket {} -> False
-                    _                  -> True
-
-type OriginMap = Map.Map FilePath OriginFlags
-data MappedPacket = MappedPacket
-        { packet :: Packet
-        , usage_tag :: Maybe String
-        , locations :: OriginMap
-        }
-
-mappedPacket filename p = MappedPacket 
-    { packet = p
-    , usage_tag = Nothing
-    , locations = Map.singleton filename (origin p (-1))
-    }
-
-type TrustMap = Map.Map FilePath Packet
-type SigAndTrust = ( MappedPacket
-                   , TrustMap     ) -- trust packets
-
-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 KeyKey SubKey)    -- subkeys
-
-type KeyDB = Map.Map KeyKey KeyData
-
 torhash key = maybe "" id $ derToBase32 <$> derRSA key
 
-keykey key =
-    -- Note: The key's timestamp is included in it's fingerprint.
-    --       Therefore, the same key with a different timestamp is
-    --       considered distinct using this keykey implementation.
-    fingerprint_material (key {timestamp=0}) -- 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 | keykey a==keykey 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 | keykey a==keykey b = EQ
-subcomp a b = error $ unlines ["Unable to merge subs:"
-                              , fingerprint a
-                              , PP.ppShow a
-                              , fingerprint b
-                              , PP.ppShow b
-                              ]
-subcomp_m a b = subcomp (packet a) (packet b)
-
-merge :: KeyDB -> FilePath -> Message -> KeyDB
-merge db filename (Message ps) = merge_ db filename qs
- where
-    qs = scanPackets filename ps
-
-merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
-                -> KeyDB
-merge_ db filename qs = foldl mergeit db (zip [0..] qs)
- where
-    asMapped n p = let m = mappedPacket filename p
-                   in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
-    asSigAndTrust n (p,tm) = (asMapped n p,tm)
-    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
-     where
-        -- NOTE:
-        --  if a keyring file has both a public key packet and a secret key packet
-        --  for the same key, then only one of them will survive, which ever is 
-        --  later in the file.
-        -- 
-        --  This is due to the use of statements like 
-        --      (Map.insert filename (origin p n) (locations key))
-        --
-        update v | isKey p && not (is_subkey p)
-          = case v of
-             Nothing -> Just $ KeyData (asMapped n p) [] emptyUids Map.empty
-             Just (KeyData key sigs uids subkeys) | keykey (packet key) == keykey p
-                     -> Just $ KeyData ( (asMapped n (minimumBy keycomp [packet key,p]))
-                                          { locations = Map.insert filename (origin p n) (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
-          = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys)
-        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) uids)
-                                               subkeys
-             _  | isKey sub  -> Just $ KeyData key
-                                               sigs
-                                               uids
-                                               (Map.alter (mergeSubSig n ptt) (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 :: Int -> Packet -> Maybe SubKey -> Maybe SubKey
-    mergeSubkey n p Nothing                  = Just $ SubKey (asMapped n p) []
-    mergeSubkey n p (Just (SubKey key sigs)) = Just $
-        SubKey ((asMapped n (minimumBy subcomp [packet key,p]))
-                 { locations = Map.insert filename (origin p n) (locations key) })
-               sigs
-
-    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
-
-
-    mergeSig :: Int -> (Packet,TrustMap) -> [SigAndTrust] -> [SigAndTrust]
-    mergeSig n sig sigs =
-      let (xs,ys) = break (isSameSig sig) sigs
-      in if null ys
-          then sigs++[first (asMapped n) sig]
-          else let y:ys'=ys
-               in xs ++ (mergeSameSig n sig y : ys')
-
-
-    isSameSig (a,_) (MappedPacket {packet=b},_) | isSignaturePacket a && isSignaturePacket b =
-        a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] }
-    isSameSig (a,_) (MappedPacket {packet=b},_) = a==b
-
-    mergeSameSig :: Int -> (Packet,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap)
-    mergeSameSig n (a,ta) (m@(MappedPacket{packet=b,locations=locs}),tb) | isSignaturePacket a && isSignaturePacket b =
-       ( m { packet = (b { unhashed_subpackets =
-                            foldl mergeItem (unhashed_subpackets b) (unhashed_subpackets a) })
-           , locations = Map.insert filename (origin a n) locs }
-        , tb `Map.union` ta )
-
-     where
-        -- TODO: when merging items, we should delete invalidated origins
-        -- from the orgin map.
-        mergeItem ys x = if x `elem` ys then ys else ys++[x]
-
-    mergeSameSig n a b = trace ("discarding dup "++show a) b
-
-    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 $
-        "Unable to merge subkey signature: "++(words (show sig) >>= take 1)
-
 flattenKeys :: Bool -> KeyDB -> Message
 flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db)
  where