Promote KeyDB to a type.

4 files changed, 79 insertions, 56 deletions

diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index bc3af6a..c40eba7 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -437,10 +437,10 @@ selectPublicKeyAndSigs :: (KeySpec,Maybe String) -> KeyDB -> [(KeyKey,Packet,[Pa
 selectPublicKeyAndSigs (spec,mtag) db =
     case mtag of
         Nothing -> do
-            (kk,r) <- Map.toList $ fmap (findbyspec spec) db
+            (kk,r) <- Map.toList $ fmap (findbyspec spec) (byKeyKey db)
             (sub,sigs) <- r
             return (kk,sub,sigs)
-        Just tag -> Map.toList (Map.filter (matchSpec spec) db) >>= findsubs tag
+        Just tag -> Map.toList (Map.filter (matchSpec spec) (byKeyKey db)) >>= findsubs tag
  where
     topresult kd = (keyPacket kd, map (packet .fst) $ keySigAndTrusts kd)
 
@@ -625,7 +625,7 @@ coinKeysOwnedBy :: KeyDB -> Maybe Packet -> [(CryptoCoins.CoinNetwork,MappedPack
 coinKeysOwnedBy db wk = do
     wk <- maybeToList wk
     let kk = keykey wk
-    KeyData top topsigs uids subs <- maybeToList $ Map.lookup kk db
+    KeyData top topsigs uids subs <- maybeToList $ Map.lookup kk (byKeyKey db)
     (subkk,SubKey mp sigs) <- Map.toList subs
     let sub = packet mp
     guard $ isCryptoCoinKey sub
@@ -689,7 +689,7 @@ guardAuthentic rt keydata = guard (isauth rt keydata)
 
 isauth :: KeyRingRuntime -> KeyData -> Bool
 isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk
-          where wk = workingKey (rtGrip rt) (rtKeyDB rt)
+          where wk = workingKey (rtGrip rt) (byKeyKey $ rtKeyDB rt)
                 dont_have (KeyData p _ _ _) = not . Map.member (rtPubring rt)
                                                    $ locations p
                 has_good_sig wk (KeyData k sigs uids subs) = any goodsig $ Map.toList uids
@@ -756,7 +756,7 @@ writeRingKeys krd rt {- db wk secring pubring -} unspilled report_manips = do
                               (error $ f ++ ": write public or secret key to file?")
                     importByExistingMaster kd@(KeyData p _ _ _) =
                         fmap originallyPublic $ Map.lookup f $ locations p
-                d <- sortByHint f keyMappedPacket (Map.elems db')
+                d <- sortByHint f keyMappedPacket (Map.elems $ byKeyKey db')
                 acc <- maybeToList $ Map.lookup f0 (rtRingAccess rt)
                 only_public <- maybeToList $ wantedForFill acc (fill stream) d
                 guard $ only_public || isSecretKey (keyPacket d)
@@ -1021,7 +1021,7 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do
                     -- ms =  map (keykey . fst) $ selectAll True (topspec,subspec) db
                     -- ms = filterMatches topspec $ Map.toList db
                     ns = do
-                       (kk,kd) <- filterMatches topspec $ Map.toList db
+                       (kk,kd) <- filterMatches topspec $ Map.toList $ byKeyKey db
                        return (kk , subkeysForExport subspec kd)
                 return (fname,subspec,ns,stream)
             (exports0,ambiguous) = partition (\(_,_,ns,_)->null $ drop 1 $ (ns>>=snd))
@@ -1069,7 +1069,7 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do
                     usage <- take 1 $ mapMaybe usageFromFilter [fill stream,spill stream]
                     let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage
                     guard $ null $ do
-                        (kk,kd) <- filterMatches topspec $ Map.toList db
+                        (kk,kd) <- filterMatches topspec $ Map.toList $ byKeyKey db
                         subkeysForExport subspec kd
                     return (f,stream)
                 where
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
diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index 20ab1f2..4fb19ff 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -449,7 +449,7 @@ generateHostsFile fw rt      = do
 names :: KeyRingRuntime -> Maybe Hostnames
 names rt = do wk <- rtWorkingKey rt
               -- XXX unnecessary signature check
-              return $ getHostnames (rtKeyDB rt Map.! keykey wk)
+              return $ getHostnames (byKeyKey (rtKeyDB rt) Map.! keykey wk)
 
 getssh               :: (Char8.ByteString, SockAddr, KeyData) -> Char8.ByteString
 getssh (contactname,_addr,kd) = do
@@ -545,7 +545,7 @@ writePublicKeyFiles rt fw grip oname wkaddr = do
     either warn (write fw "ssh_host_rsa_key.pub") $ show_ssh' "ssh-server" grip (rtKeyDB rt)
     either warn (write fw $ ipsecCertPath oname) $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket
 
-    let onionkeys = mapMaybe namedContact $ Map.elems $ rtKeyDB rt
+    let onionkeys = mapMaybe namedContact $ Map.elems $ byKeyKey $ rtKeyDB rt
         cs = filter (\(_,_,kd) -> notme kd) onionkeys
         kk = keykey (fromJust $ rtWorkingKey rt)
         notme kd = keykey (keyPacket kd) /= kk
diff --git a/lib/Transforms.hs b/lib/Transforms.hs
index 8eaa482..7a676b0 100644
--- a/lib/Transforms.hs
+++ b/lib/Transforms.hs
@@ -62,8 +62,13 @@ data KeyData = KeyData
     , keyUids         :: (Map.Map String ([SigAndTrust],OriginMap)) -- uids
     , keySubKeys      :: (Map.Map KeyKey SubKey)                    -- subkeys
     } deriving Show
-type KeyDB = Map.Map KeyKey KeyData
 
+data KeyDB = KeyDB
+    { byKeyKey :: Map.Map KeyKey KeyData
+    } deriving Show
+
+emptyKeyDB :: KeyDB
+emptyKeyDB = KeyDB { byKeyKey = Map.empty }
 
 
 data KeyRingRuntime = KeyRingRuntime
@@ -779,7 +784,7 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do
 
 -- TODO: Use fingerprint to narrow candidates.
 candidateSignerKeys :: KeyDB -> Packet -> [Packet]
-candidateSignerKeys db sig = map keyPacket $ Map.elems db
+candidateSignerKeys db sig = map keyPacket $ Map.elems (byKeyKey db)
 
 performManipulations ::
                 (PacketDecrypter)
@@ -790,9 +795,10 @@ performManipulations ::
 performManipulations doDecrypt rt wk manip = do
     let db = rtKeyDB rt
         performAll kd = foldM perform (KikiSuccess (kd,[])) $ manip rt kd
-    r <- Traversable.mapM performAll db
+    r <- Traversable.mapM performAll (byKeyKey db)
     try (sequenceA r) $ \db -> do
-    return $ KikiSuccess (rt { rtKeyDB =  fmap fst db }, concatMap snd $ Map.elems db)
+    return $ KikiSuccess ( rt { rtKeyDB = (rtKeyDB rt) { byKeyKey = fmap fst db } }
+                         , concatMap snd $ Map.elems db)
  where
     perform :: KikiCondition (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport))
     perform kd (InducerSignature uid subpaks) = do
@@ -812,7 +818,7 @@ performManipulations doDecrypt rt wk manip = do
             selfsigs = filter (\(sig,v,whosign) -> isJust (v >> Just wkun >>= guard
                                    . (== keykey whosign)
                                    . keykey)) vs
-            keys = map keyPacket $ Map.elems (rtKeyDB rt) -- TODO candidateSignerKeys (rtKeyDB rt) sig
+            keys = map keyPacket $ Map.elems (byKeyKey $ rtKeyDB rt) -- TODO candidateSignerKeys (rtKeyDB rt) sig
             overs sig = signatures $ Message (keys ++ [keyPacket kd,UserIDPacket uid,sig])
             vs :: [ ( Packet -- signature
                    , Maybe SignatureOver -- Nothing means non-verified