summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--kiki.hs3
-rw-r--r--lib/KeyRing.hs122
2 files changed, 82 insertions, 43 deletions
diff --git a/kiki.hs b/kiki.hs
index 2cdade6..325fc7f 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -1338,7 +1338,8 @@ kiki "merge" args = do
1338 Just spec -> KF_Match spec 1338 Just spec -> KF_Match spec
1339 Nothing 1339 Nothing
1340 | "signed" `elem` goods -> KF_Authentic 1340 | "signed" `elem` goods -> KF_Authentic
1341 | "subkeys" `elem` goods -> KF_Subkeys ) 1341 | "subkeys" `elem` goods -> KF_Subkeys
1342 | otherwise -> KF_All)
1342 where 1343 where
1343 ws = case groupBy (\_ c->c/=',') spec of 1344 ws = case groupBy (\_ c->c/=',') spec of
1344 w:xs -> w:map (drop 1) xs 1345 w:xs -> w:map (drop 1) xs
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index 04ac7c6..bb8b598 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -1469,6 +1469,7 @@ buildKeyDB ctx grip0 keyring = do
1469 isgen (Generate _ _) _ = True 1469 isgen (Generate _ _) _ = True
1470 isgen _ _ = False 1470 isgen _ _ = False
1471 1471
1472 readp :: InputFile -> StreamInfo -> IO (StreamInfo, Message)
1472 readp f stream = fmap readp0 $ readPacketsFromFile ctx f 1473 readp f stream = fmap readp0 $ readPacketsFromFile ctx f
1473 where 1474 where
1474 readp0 ps = (stream { access = acc' }, ps) 1475 readp0 ps = (stream { access = acc' }, ps)
@@ -1533,7 +1534,7 @@ buildKeyDB ctx grip0 keyring = do
1533 acc = Just Sec /= Map.lookup f accs 1534 acc = Just Sec /= Map.lookup f accs
1534 r <- performManipulations doDecrypt rt1 mwk manip 1535 r <- performManipulations doDecrypt rt1 mwk manip
1535 try r $ \(rt2,report) -> do 1536 try r $ \(rt2,report) -> do
1536 return $ KikiSuccess (report,(info,flattenKeys acc $ rtKeyDB rt2)) 1537 return $ KikiSuccess (report,rtKeyDB rt2)
1537#if MIN_VERSION_containers(0,5,0) 1538#if MIN_VERSION_containers(0,5,0)
1538 in fmap sequenceA $ Map.traverseWithKey trans spilled 1539 in fmap sequenceA $ Map.traverseWithKey trans spilled
1539#else 1540#else
@@ -1542,7 +1543,7 @@ buildKeyDB ctx grip0 keyring = do
1542 try transformed0 $ \transformed -> do 1543 try transformed0 $ \transformed -> do
1543 let db_rings = Map.foldlWithKey' mergeIt Map.empty transformed 1544 let db_rings = Map.foldlWithKey' mergeIt Map.empty transformed
1544 where 1545 where
1545 mergeIt db f (_,(info,ps)) = merge db f ps 1546 mergeIt db f (_,dbtrans) = Map.unionWith mergeKeyData db dbtrans
1546 reportTrans = concat $ Map.elems $ fmap fst transformed 1547 reportTrans = concat $ Map.elems $ fmap fst transformed
1547 1548
1548 -- Wallets 1549 -- Wallets
@@ -3288,25 +3289,63 @@ merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))
3288 -> KeyDB 3289 -> KeyDB
3289merge_ db filename qs = foldl mergeit db (zip [0..] qs) 3290merge_ db filename qs = foldl mergeit db (zip [0..] qs)
3290 where 3291 where
3291 asMapped n p = mappedPacketWithHint filename p n
3292 asSigAndTrust n (p,tm) = (asMapped n p,tm)
3293 emptyUids = Map.empty
3294 -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets 3292 -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets
3295 mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB 3293 mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB
3296 mergeit db (n,(top,sub,ptt@(p,trustmap))) | isKey top = Map.alter update (keykey top) db 3294 mergeit db adding@(n,(top,sub,ptt@(p,trustmap))) | isKey top = Map.alter update (keykey top) db
3297 where 3295 where
3298 -- NOTE: 3296 update Nothing = Just $ KeyData (mappedPacketWithHint filename p n) [] Map.empty Map.empty
3299 -- if a keyring file has both a public key packet and a secret key packet 3297 update (Just kd) = dbInsertPacket kd filename adding
3300 -- for the same key, then only one of them will survive, which ever is 3298 mergeit _ (_,(_,_,p)) = error $ "Unexpected PGP packet 3: "++whatP p
3301 -- later in the file. 3299
3302 -- 3300 whatP (a,_) = concat . take 1 . words . show $ a
3303 -- This is due to the use of statements like 3301
3304 -- (Map.insert filename (origin p n) (locations key)) 3302
3305 -- 3303
3306 update :: Maybe KeyData -> Maybe KeyData 3304mergeKeyData :: KeyData -> KeyData -> KeyData
3307 update v | isKey p && not (is_subkey p) 3305mergeKeyData (KeyData atop asigs auids asubs)
3306 (KeyData btop bsigs buids bsubs)
3307 = KeyData top sigs uids subs
3308 where
3309 mergeMapped a b =
3310 MappedPacket { packet = packet a
3311 , locations = Map.union (locations a) (locations b)
3312 }
3313
3314 top = mergeMapped atop btop
3315
3316 sigs = foldl' (flip mergeSig) asigs bsigs
3317
3318 uids = Map.unionWith mergeUIDSigs auids buids
3319 subs = Map.unionWith mergeSub asubs bsubs
3320
3321 mergeSub :: SubKey -> SubKey -> SubKey
3322 mergeSub (SubKey a as) (SubKey b bs) =
3323 SubKey (mergeMapped a b)
3324 (foldl' (flip mergeSig) as bs)
3325
3326 mergeUIDSigs :: ([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap)
3327 -> ([SigAndTrust],OriginMap)
3328 mergeUIDSigs (as,am) (bs,bm) = (foldl' (flip mergeSig) as bs, Map.union am bm)
3329
3330
3331dbInsertPacket :: KeyData -> FilePath -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> Maybe KeyData
3332dbInsertPacket kd filename (n,(top,sub,ptt@(p,trustmap))) = update (Just kd)
3333 where
3334 asMapped n p = mappedPacketWithHint filename p n
3335 asSigAndTrust n (p,tm) = (asMapped n p,tm)
3336
3337 -- NOTE:
3338 -- if a keyring file has both a public key packet and a secret key packet
3339 -- for the same key, then only one of them will survive, which ever is
3340 -- later in the file.
3341 --
3342 -- This is due to the use of statements like
3343 -- (Map.insert filename (origin p n) (locations key))
3344 --
3345 update :: Maybe KeyData -> Maybe KeyData
3346 update v | isKey p && not (is_subkey p)
3308 = case v of 3347 = case v of
3309 Nothing -> Just $ KeyData (asMapped n p) [] emptyUids Map.empty 3348 Nothing -> Just $ KeyData (asMapped n p) [] Map.empty Map.empty
3310 Just (KeyData key sigs uids subkeys) | keykey (packet key) == keykey p 3349 Just (KeyData key sigs uids subkeys) | keykey (packet key) == keykey p
3311 -> Just $ KeyData (mergeKeyPacket "master keys" key $ asMapped n p) 3350 -> Just $ KeyData (mergeKeyPacket "master keys" key $ asMapped n p)
3312 sigs 3351 sigs
@@ -3314,14 +3353,14 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs)
3314 subkeys 3353 subkeys
3315 _ -> error . concat $ ["Unexpected master key merge error: " 3354 _ -> error . concat $ ["Unexpected master key merge error: "
3316 ,show (fingerprint top, fingerprint p)] 3355 ,show (fingerprint top, fingerprint p)]
3317 update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p 3356 update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p
3318 = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys) 3357 = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys)
3319 update (Just (KeyData key sigs uids subkeys)) | isUserID p 3358 update (Just (KeyData key sigs uids subkeys)) | isUserID p
3320 = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids) 3359 = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids)
3321 subkeys 3360 subkeys
3322 update (Just (KeyData key sigs uids subkeys)) 3361 update (Just (KeyData key sigs uids subkeys))
3323 = case sub of 3362 = case sub of
3324 MarkerPacket -> Just $ KeyData key (mergeSig n ptt sigs) uids subkeys 3363 MarkerPacket -> Just $ KeyData key (mergeSig (first (flip (mappedPacketWithHint filename) n) ptt) sigs) uids subkeys
3325 UserIDPacket {} -> Just $ KeyData key 3364 UserIDPacket {} -> Just $ KeyData key
3326 sigs 3365 sigs
3327 (Map.alter (mergeUidSig n ptt) (uidkey sub) uids) 3366 (Map.alter (mergeUidSig n ptt) (uidkey sub) uids)
@@ -3331,9 +3370,7 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs)
3331 uids 3370 uids
3332 (Map.alter (mergeSubSig n ptt) (keykey sub) subkeys) 3371 (Map.alter (mergeSubSig n ptt) (keykey sub) subkeys)
3333 _ -> error $ "Unexpected PGP packet 1: "++(words (show p) >>= take 1) 3372 _ -> error $ "Unexpected PGP packet 1: "++(words (show p) >>= take 1)
3334 update _ = error $ "Unexpected PGP packet 2: "++(words (show p) >>= take 1) 3373 update _ = error $ "Unexpected PGP packet 2: "++(words (show p) >>= take 1)
3335
3336 mergeit _ (_,(_,_,p)) = error $ "Unexpected PGP packet 3: "++whatP p
3337 3374
3338 mergeSubkey :: Int -> Packet -> Maybe SubKey -> Maybe SubKey 3375 mergeSubkey :: Int -> Packet -> Maybe SubKey -> Maybe SubKey
3339 mergeSubkey n p Nothing = Just $ SubKey (asMapped n p) [] 3376 mergeSubkey n p Nothing = Just $ SubKey (asMapped n p) []
@@ -3349,37 +3386,38 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs)
3349 whatP (a,_) = concat . take 1 . words . show $ a 3386 whatP (a,_) = concat . take 1 . words . show $ a
3350 3387
3351 3388
3352 mergeSig :: Int -> (Packet,TrustMap) -> [SigAndTrust] -> [SigAndTrust] 3389 mergeUidSig n sig (Just (sigs,m)) = Just (mergeSig (first (flip (mappedPacketWithHint filename) n) sig) sigs, m)
3353 mergeSig n sig sigs = 3390 mergeUidSig n sig Nothing = Just ([asSigAndTrust n sig],Map.empty)
3354 let (xs,ys) = break (isSameSig sig) sigs 3391
3392 mergeSubSig n sig (Just (SubKey key sigs)) = Just $ SubKey key (mergeSig (first (flip (mappedPacketWithHint filename) n) sig) sigs)
3393 mergeSubSig n sig Nothing = error $
3394 "Unable to merge subkey signature: "++(words (show sig) >>= take 1)
3395
3396mergeSig :: SigAndTrust -> [SigAndTrust] -> [SigAndTrust]
3397mergeSig sig sigs =
3398 let (xs,ys) = break (isSameSig (first packet sig)) sigs
3355 in if null ys 3399 in if null ys
3356 then sigs++[first (asMapped n) sig] 3400 then sigs++[sig] -- [first (flip (mappedPacketWithHint fname) n) sig]
3357 else let y:ys'=ys 3401 else let y:ys'=ys
3358 in xs ++ (mergeSameSig n sig y : ys') 3402 in xs ++ (mergeSameSig sig y : ys')
3359 where 3403 where
3360 isSameSig (a,_) (MappedPacket {packet=b},_) | isSignaturePacket a && isSignaturePacket b = 3404 isSameSig (a,_) (MappedPacket {packet=b},_) | isSignaturePacket a && isSignaturePacket b =
3361 a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] } 3405 a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] }
3362 isSameSig (a,_) (MappedPacket {packet=b},_) = a==b 3406 isSameSig (a,_) (MappedPacket {packet=b},_) = a==b
3363 3407
3364 mergeSameSig :: Int -> (Packet,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap) 3408 mergeSameSig :: (MappedPacket,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap)
3365 mergeSameSig n (a,ta) (m@(MappedPacket{packet=b,locations=locs}),tb) 3409 mergeSameSig (a,ta) (m@(MappedPacket{packet=b,locations=locs}),tb)
3366 | isSignaturePacket a && isSignaturePacket b = 3410 | isSignaturePacket (packet a) && isSignaturePacket b =
3367 ( m { packet = b { unhashed_subpackets = 3411 ( m { packet = b { unhashed_subpackets =
3368 union (unhashed_subpackets b) (unhashed_subpackets a) 3412 union (unhashed_subpackets b) (unhashed_subpackets $ packet a)
3369 } 3413 }
3370 , locations = Map.insert filename (origin a n) locs } 3414 , locations = Map.union (locations a) locs } -- Map.insert fname (origin a n) locs }
3371 -- TODO: when merging items, we should delete invalidated origins 3415 -- TODO: when merging items, we should delete invalidated origins
3372 -- from the orgin map. 3416 -- from the orgin map.
3373 , tb `Map.union` ta ) 3417 , tb `Map.union` ta )
3374 3418
3375 mergeSameSig n a b = b -- trace ("discarding dup "++show a) b 3419 mergeSameSig a b = b -- trace ("discarding dup "++show a) b
3376 3420
3377 mergeUidSig n sig (Just (sigs,m)) = Just (mergeSig n sig sigs, m)
3378 mergeUidSig n sig Nothing = Just ([asSigAndTrust n sig],Map.empty)
3379
3380 mergeSubSig n sig (Just (SubKey key sigs)) = Just $ SubKey key (mergeSig n sig sigs)
3381 mergeSubSig n sig Nothing = error $
3382 "Unable to merge subkey signature: "++(words (show sig) >>= take 1)
3383 3421
3384unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket] 3422unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket]
3385unsig fname isPublic (sig,trustmap) = 3423unsig fname isPublic (sig,trustmap) =