moved merge function into KeyRing module

1 files changed, 215 insertions, 3 deletions

diff --git a/KeyRing.hs b/KeyRing.hs
index 7073e43..39bff4c 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -8,9 +8,14 @@ import Control.Monad
 import Data.Maybe
 import Data.Char
 import Data.List
-import Control.Applicative ( (<$>) )
-import System.Directory    ( getHomeDirectory, doesFileExist )
-import Control.Arrow       ( first, second )
+import Data.OpenPGP
+import Control.Applicative    ( (<$>) )
+import System.Directory       ( getHomeDirectory, doesFileExist )
+import Control.Arrow          ( first, second )
+import Data.OpenPGP.Util      ( fingerprint )
+import Data.ByteString.Lazy   ( ByteString )
+import Text.Show.Pretty as PP ( ppShow )
+import qualified Data.Map as Map
 
 import DotLock
 
@@ -146,3 +151,210 @@ getHomeDir protohome = do
 lookupEnv var =
     handleIO_ (return Nothing) $ fmap Just (getEnv var)
 #endif
+
+isKey (PublicKeyPacket {}) = True
+isKey (SecretKeyPacket {}) = True
+isKey _                    = False
+
+isUserID (UserIDPacket {}) = True
+isUserID _                 = False
+
+isTrust (TrustPacket {}) = True
+isTrust _                = False
+
+
+data OriginFlags = OriginFlags {
+        originallyPublic :: Bool,
+        originalNum :: Int
+    }
+    deriving Show
+type OriginMap = Map.Map FilePath OriginFlags
+data MappedPacket = MappedPacket
+        { packet :: Packet
+        , usage_tag :: Maybe String
+        , locations :: OriginMap
+        }
+
+type TrustMap = Map.Map FilePath Packet
+type SigAndTrust = ( MappedPacket
+                   , TrustMap     ) -- trust packets
+
+type KeyKey = [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
+
+origin :: Packet -> Int -> OriginFlags
+origin p n = OriginFlags ispub n
+ where
+    ispub = case p of
+                    SecretKeyPacket {} -> False
+                    _                  -> True
+
+mappedPacket filename p = MappedPacket 
+    { packet = p
+    , usage_tag = Nothing
+    , locations = Map.singleton filename (origin p (-1))
+    }
+
+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
+
+merge :: KeyDB -> FilePath -> Message -> KeyDB
+merge db filename (Message ps) = merge_ db filename qs
+ where
+    qs = scanPackets filename ps
+
+    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
+
+
+
+
+merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
+                -> KeyDB
+merge_ db filename qs = foldl mergeit db (zip [0..] qs)
+ where
+    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
+                                  ]
+
+    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
+     where
+        -- Compare master keys, LT is prefered for merging
+        -- 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)
+
+    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 = 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)
+