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 --- kiki.hs | 205 ---------------------------------------------------------------- 1 file changed, 205 deletions(-) (limited to 'kiki.hs') 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 -- cgit v1.2.3