1 files changed, 59 insertions, 42 deletions

diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs
index a3df62d..c5754f1 100644
--- a/lib/KeyRing/BuildKeyDB.hs
+++ b/lib/KeyRing/BuildKeyDB.hs
@@ -36,6 +36,7 @@ import qualified Data.ByteString.Lazy       as L (ByteString, concat, empty,
                                                   null, toChunks,
                                                   toStrict, head)
 import           Data.Char
+import           Data.Functor
 import           Data.List
 import qualified Data.Map                   as Map
 import           Data.Maybe
@@ -191,7 +192,7 @@ buildKeyDB ctx grip0 keyring = do
                              , rtGrip        = grip
                              , rtWorkingKey  = wk
                              , rtRingAccess  = accs
-                             , rtKeyDB       = Map.empty
+                             , rtKeyDB       = emptyKeyDB
                              , rtPassphrases = transcode
                              }
     -- autosigns and deletes
@@ -199,7 +200,7 @@ buildKeyDB ctx grip0 keyring = do
         let trans :: InputFile -> (StreamInfo,Message) -> IO (KikiCondition (KikiReport,KeyDB))
             trans f (info,ps) = do
                 let manip = combineTransforms (transforms info)
-                    rt1 = rt0 { rtKeyDB = merge Map.empty f ps }
+                    rt1 = rt0 { rtKeyDB = merge emptyKeyDB f ps }
                     acc = Just Sec /= Map.lookup f accs
                 r <- performManipulations doDecrypt rt1 mwk manip
                 try r $ \(rt2,report) -> do
@@ -214,10 +215,11 @@ buildKeyDB ctx grip0 keyring = do
 #endif
     try transformed0 $ \transformed -> do
     let -- | db_rings - all keyrings combined into one
-        db_rings :: Map.Map KeyKey KeyData
-        db_rings = Map.foldlWithKey' mergeIt Map.empty transformed
+        db_rings = Map.foldlWithKey' mergeIt emptyKeyDB transformed
                     where
-                      mergeIt db f (_,dbtrans) = Map.unionWith mergeKeyData  db dbtrans
+                      mergeIt db f (_,dbtrans)
+                        = KeyDB { byKeyKey = Map.unionWith mergeKeyData (byKeyKey db) (byKeyKey dbtrans)
+                                }
         -- | reportTrans
         -- events, indexed by file
         reportTrans :: [(FilePath, KikiReportAction)]
@@ -257,7 +259,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 db)
+                ms = map fst $ filterMatches topspec (Map.toList $ byKeyKey db)
                 cmd = initializer stream
             return (n,subspec,ms,stream, cmd)
 
@@ -356,25 +358,35 @@ merge :: KeyDB -> InputFile -> Message -> KeyDB
 merge db inputfile (Message ps) = merge_ db filename qs
  where
     filename = resolveForReport Nothing inputfile
-
     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)
-                _                                -> (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
+-- Aggregate packets into a list of triples:
+--
+--   A top (master) key
+--
+--   A subkey, or if this entry corresponds to the master-key, this field is a
+--   MarkerPacket placeholder.
+--
+--   An optional trust packet in the form of a singleton or empty Map whose key
+--   is the filename.
+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)
+            _                                -> (top,sub,ret p)
+
+    -- Most arguments are ignored and we simply create the singleton trust-map when appropriate.
+    -- XXX: Simplify this?
+    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
 
 
 mergeKeyData :: KeyData -> KeyData -> KeyData
@@ -405,17 +417,18 @@ mergeKeyData (KeyData atop asigs auids asubs)
 
 doImportG
   :: PacketTranscoder
-     -> Map.Map KeyKey KeyData
+     -> KeyDB
      -> [KeyKey] -- m0,  only head is used
      -> [SignatureSubpacket] -- tags
      -> InputFile
      -> Packet
-     -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
+     -> 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 db
+        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 (Map.insert kk kd' db, rrs)
+    try kdr $ \(kd',rrs) -> return $ KikiSuccess ( db { byKeyKey = Map.insert kk kd' (byKeyKey db) }
+                                                 , rrs)
 
 
 iswallet :: FileType -> Bool
@@ -514,7 +527,7 @@ outgoing_names db hostdbs0 = IPsToWriteToHostsFile $ do
     guard $ all (null . Hosts.namesForAddress addr) hostdbs0
     return addr
   where
-    gpgnames = map getHostnames $ Map.elems db
+    gpgnames = map getHostnames $ Map.elems $ byKeyKey db
 
 filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)]
 filterMatches spec ks = filter (matchSpec spec . snd) ks
@@ -522,9 +535,9 @@ filterMatches spec ks = filter (matchSpec spec . snd) ks
 importSecretKey ::
   (PacketTranscoder)
   -> KikiCondition
-       (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])
+       (KeyDB, [(FilePath, KikiReportAction)])
   -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t)
-  -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
+  -> IO (KikiCondition (KeyDB, [(FilePath, KikiReportAction)]))
 importSecretKey transcode db' tup = do
             try db' $ \(db',report0) -> do
             r <- doImport transcode
@@ -536,16 +549,17 @@ importSecretKey transcode db' tup = do
 generateInternals ::
     PacketTranscoder
     -> Maybe MappedPacket
-    -> Map.Map KeyKey KeyData
+    -> KeyDB
     -> [(GenerateKeyParams,StreamInfo)]
-    -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
+    -> IO (KikiCondition (KeyDB, [(FilePath, KikiReportAction)]))
 generateInternals transcode mwk db gens = do
-    case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) db of
+    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 (Map.insert kk kd db,reportGens)
+            return $ KikiSuccess ( KeyDB { byKeyKey = Map.insert kk kd (byKeyKey db) }
+                                 , reportGens )
         Nothing -> return $ KikiSuccess (db,[])
 
 mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext
@@ -575,7 +589,7 @@ mergeHostFiles krd db ctx = do
 
     hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL' ctx) hns
 
-    let gpgnames = map getHostnames $ Map.elems db
+    let gpgnames = map getHostnames $ Map.elems (byKeyKey db)
         os = do
             Hostnames addr ns _ _ <- gpgnames
             n <- ns
@@ -604,7 +618,8 @@ mergeHostFiles krd db ctx = do
 
     -- 2. replace gpg annotations with those in U
     -- forM use_db
-    db' <- Traversable.mapM (setHostnames addrs u1) db
+    db' <- Traversable.mapM (setHostnames addrs u1) (byKeyKey db)
+            <&> \m -> db { byKeyKey = m }
 
     return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,addrs)),[])
 
@@ -649,7 +664,8 @@ merge_ db filename qs = foldl mergeit db (zip [0..] qs)
  where
     -- 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 = Map.alter update (keykey top) db
+    mergeit db adding@(n,(top,sub,ptt@(p,trustmap)))
+        | isKey top = db { byKeyKey = Map.alter update (keykey top) (byKeyKey db) }
       where
         update Nothing   = Just $ KeyData (mappedPacketWithHint filename p n) [] Map.empty Map.empty
         update (Just kd) = dbInsertPacket kd filename adding
@@ -828,9 +844,9 @@ matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us
 
 doImport
   :: PacketTranscoder
-     -> Map.Map KeyKey KeyData
+     -> KeyDB
      -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t)
-     -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
+     -> IO (KikiCondition (KeyDB, [(FilePath,KikiReportAction)]))
 doImport transcode db (fname,subspec,ms,typ -> typ,_) = do
     flip (maybe $ return CannotImportMasterKey)
          subspec $ \tag -> do
@@ -1389,7 +1405,7 @@ extractRSAKeyFields kvs = do
 
 selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
 selectKey0 wantPublic (spec,mtag) db = do
-    let Message ps = flattenKeys wantPublic db
+    let Message ps = flattenKeys wantPublic $ byKeyKey db
         ys = snd $ seek_key spec ps
     flip (maybe (listToMaybe ys)) mtag $ \tag -> do
       case ys of
@@ -1410,8 +1426,9 @@ packetFromPublicRSAKey notBefore n e =
                     , v3_days_of_validity = Nothing
                     }
 
-flattenKeys :: Bool -> KeyDB -> Message
-flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db)
+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