From a8da6f5843f3a5e6f7c975a746dea27adcf3907e Mon Sep 17 00:00:00 2001 From: joe Date: Sat, 12 Apr 2014 17:19:46 -0400 Subject: moved merge function into KeyRing module --- KeyRing.hs | 218 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 215 insertions(+), 3 deletions(-) (limited to 'KeyRing.hs') 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) + -- cgit v1.2.3