1 files changed, 25 insertions, 84 deletions

diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs
index 8af8198..cd1bae9 100644
--- a/lib/KeyRing/BuildKeyDB.hs
+++ b/lib/KeyRing/BuildKeyDB.hs
@@ -185,8 +185,7 @@ buildKeyDB ctx grip0 keyring = do
         db_rings = Map.foldlWithKey' mergeIt emptyKeyDB transformed
                     where
                       mergeIt db f (_,dbtrans)
-                        = KeyDB { byKeyKey = Map.unionWith mergeKeyData (byKeyKey db) (byKeyKey dbtrans)
-                                }
+                        = mergeKeyDB mergeKeyData db dbtrans
         -- | reportTrans
         -- events, indexed by file
         reportTrans :: [(FilePath, KikiReportAction)]
@@ -226,7 +225,7 @@ buildKeyDB ctx grip0 keyring = do
             -- TODO: KikiCondition reporting for spill/fill usage mismatch?
             -- TODO: parseSpec3
             let (topspec,subspec) = parseSpec grip usage
-                ms = map fst $ filterMatches topspec (Map.toList $ byKeyKey db)
+                ms = map fst $ filterMatches topspec (kkData db)
                 cmd = initializer stream
             return (n,subspec,ms,stream, cmd)
 
@@ -338,7 +337,7 @@ scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret Ma
         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)
+            _ | isJust (isUserID p)          -> (top,p,ret p)
             _ | isTrust p                    -> (top,sub,updateTrust top sub prev p)
             _                                -> (top,sub,ret p)
 
@@ -385,10 +384,14 @@ doImportG
      -> IO (KikiCondition (KeyDB, [(FilePath,KikiReportAction)]))
 doImportG transcode db m0 tags fname key = do
     let kk = head m0
-        Just kd@(KeyData top topsigs uids subs) = Map.lookup kk (byKeyKey db)
+    {-
+    let Just kd@(KeyData top topsigs uids subs) = Map.lookup kk (byKeyKey db)
     kdr <- insertSubkey transcode kk kd tags fname key
-    try kdr $ \(kd',rrs) -> return $ KikiSuccess ( db { byKeyKey = Map.insert kk kd' (byKeyKey db) }
-                                                 , rrs)
+    try kdr $ \(kd',rrs) -> return $ KikiSuccess ( alterKeyDB (const $ Just kd') kk db
+                                                 , rrs )
+    -}
+    let go (Just kd@(KeyData top topsigs uids subs)) = insertSubkey transcode kk kd tags fname key
+    transmuteAt go kk db
 
 
 iswallet :: FileType -> Bool
@@ -487,7 +490,7 @@ outgoing_names db hostdbs0 = IPsToWriteToHostsFile $ do
     guard $ all (null . Hosts.namesForAddress addr) hostdbs0
     return addr
   where
-    gpgnames = map getHostnames $ Map.elems $ byKeyKey db
+    gpgnames = map getHostnames $ keyData db
 
 filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)]
 filterMatches spec ks = filter (matchSpec spec . snd) ks
@@ -513,14 +516,13 @@ generateInternals ::
     -> [(GenerateKeyParams,StreamInfo)]
     -> IO (KikiCondition (KeyDB, [(FilePath, KikiReportAction)]))
 generateInternals transcode mwk db gens = do
-    case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) (byKeyKey db) of
-        Just kd0 -> do
-            kd <- foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens
-            try kd $ \(kd,reportGens) -> do
-            let kk = keykey $ packet $ fromJust mwk
-            return $ KikiSuccess ( KeyDB { byKeyKey = Map.insert kk kd (byKeyKey db) }
-                                 , reportGens )
+    case mwk of
         Nothing -> return $ KikiSuccess (db,[])
+        Just mpkt -> do
+            let kk = keykey (packet mpkt)
+            transmuteAt (go kk) kk db
+        where
+         go kk (Just kd0) = foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens
 
 mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext
      -> IO
@@ -549,7 +551,7 @@ mergeHostFiles krd db ctx = do
 
     hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL' ctx) hns
 
-    let gpgnames = map getHostnames $ Map.elems (byKeyKey db)
+    let gpgnames = map getHostnames $ keyData db
         os = do
             Hostnames addr ns _ _ <- gpgnames
             n <- ns
@@ -578,8 +580,7 @@ mergeHostFiles krd db ctx = do
 
     -- 2. replace gpg annotations with those in U
     -- forM use_db
-    db' <- Traversable.mapM (setHostnames addrs u1) (byKeyKey db)
-            <&> \m -> db { byKeyKey = m }
+    db' <- mapKeyDB (setHostnames addrs u1) db
 
     return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,addrs)),[])
 
@@ -625,7 +626,7 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs)
     -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets
     mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB
     mergeit db adding@(n,(top,sub,ptt@(p,trustmap)))
-        | isKey top = db { byKeyKey = Map.alter update (keykey top) (byKeyKey db) }
+        | isKey top = alterKeyDB update (keykey top) db
       where
         update Nothing   = Just $ KeyData (mappedPacketWithHint filename p n) [] Map.empty Map.empty
         update (Just kd) = dbInsertPacket kd filename adding
@@ -947,8 +948,7 @@ setHostnames (IPsToWriteToHostsFile outgoing_names) hosts kd@(KeyData topmp tops
     uids0 = fmap zapIfHasName uids
     fstuid = head $ do
         p <- map packet $ flattenAllUids "" True uids
-        guard $ isUserID p
-        return $ uidkey p
+        maybeToList $ isUserID p
     uids1 = Map.adjust addnames fstuid uids0
     addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin
      where
@@ -1068,15 +1068,15 @@ dbInsertPacket kd filename (n,(top,sub,ptt@(p,trustmap))) = update (Just kd)
                                          ,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)
+    update (Just (KeyData key sigs uids subkeys)) | Just uid <- isUserID p
+          = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) uid uids)
                                     subkeys
     update (Just (KeyData key sigs uids subkeys))
           = case sub of
              MarkerPacket    -> Just $ KeyData key (mergeSig (first (flip (mappedPacketWithHint filename) n) ptt) sigs) uids subkeys
-             UserIDPacket {} -> Just $ KeyData key
+             UserIDPacket uid-> Just $ KeyData key
                                                sigs
-                                               (Map.alter (mergeUidSig n ptt) (uidkey sub) uids)
+                                               (Map.alter (mergeUidSig n ptt) uid uids)
                                                subkeys
              _  | isKey sub  -> Just $ KeyData key
                                                sigs
@@ -1351,15 +1351,6 @@ extractRSAKeyFields kvs = do
         nlen = S.length bs
 
 
-selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
-selectKey0 wantPublic (spec,mtag) db = do
-    let Message ps = flattenKeys wantPublic $ byKeyKey db
-        ys = snd $ seek_key spec ps
-    flip (maybe (listToMaybe ys)) mtag $ \tag -> do
-      case ys of
-          y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1
-          []    -> Nothing
-
 -- TODO: Data.ByteString.Lazy now exports this.
 toStrict :: L.ByteString -> S.ByteString
 toStrict = foldr1 (<>) . L.toChunks
@@ -1374,53 +1365,3 @@ packetFromPublicRSAKey notBefore n e =
                     , v3_days_of_validity = Nothing
                     }
 
-flattenKeys :: Bool -> Map.Map KeyKey KeyData -> Message
-flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd)
-                                              (prefilter . Map.assocs $ db)
- where
-    prefilter = if isPublic then id else filter isSecret
-                 where
-                  isSecret (_,(KeyData
-                                  (MappedPacket { packet=(SecretKeyPacket {})})
-                                  _
-                                  _
-                                  _)) = True
-                  isSecret _          = False
-
-seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet])
-seek_key (KeyGrip grip) sec = (pre, subs)
-  where
-    (pre,subs) = break pred sec
-    pred p@(SecretKeyPacket {}) = matchpr grip p == grip
-    pred p@(PublicKeyPacket {}) = matchpr grip p == grip
-    pred _                      = False
-
-seek_key (KeyTag key tag) ps
-    | null bs = (ps, [])
-    | null qs =
-      let (as', bs') = seek_key (KeyTag key tag) (tail bs) in
-        (as ++ (head bs : as'), bs')
-    | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
-  where
-    (as,bs) = break (\p -> isSignaturePacket p
-                        && has_tag tag p
-                        && isJust (signature_issuer p)
-                        && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) )
-                    ps
-    (rs,qs) = break isKey (reverse as)
-
-    has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
-                    || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
-
-seek_key (KeyUidMatch pat) ps
-    | null bs = (ps, [])
-    | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in
-                    (as ++ (head bs : as'), bs')
-    | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
-  where
-    (as,bs) = break (isInfixOf pat . uidStr) ps
-    (rs,qs) = break isKey (reverse as)
-
-    uidStr (UserIDPacket s) = s
-    uidStr _                = ""
-