Now supports unspillable keyrings.

1 files changed, 62 insertions, 43 deletions

diff --git a/KeyRing.hs b/KeyRing.hs
index 3eba3de..c79de9f 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -1069,8 +1069,7 @@ writeHostsFiles krd ctx (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do
     return $ concat rss
 
 
-buildKeyDB :: (MappedPacket -> IO (KikiCondition Packet))
-              -> InputFileContext -> Maybe String -> KeyRingOperation
+buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation
               -> IO (KikiCondition ((KeyDB
                                     ,Maybe String
                                     ,Maybe MappedPacket
@@ -1080,9 +1079,11 @@ buildKeyDB :: (MappedPacket -> IO (KikiCondition Packet))
                                              [(SockAddr, (KeyKey, KeyKey))],
                                              [SockAddr])
                                     ,Map.Map FilePath Access
+                                    ,MappedPacket -> IO (KikiCondition Packet)
+                                    ,Map.Map InputFile Message
                                     )
                                    ,[(FilePath,KikiReportAction)]))
-buildKeyDB doDecrypt ctx grip0 keyring = do
+buildKeyDB ctx grip0 keyring = do
     let 
         files isring = do
             (f,stream) <- Map.toList (kFiles keyring)
@@ -1104,19 +1105,8 @@ buildKeyDB doDecrypt ctx grip0 keyring = do
 
         readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n))
 
-        importWalletKey wk db' (top,fname,sub,tag) = do
-            try db' $ \(db',report0) -> do
-            r <- doImportG doDecrypt
-                      db'
-                      (fmap keykey $ maybeToList wk)
-                      tag
-                      fname
-                      sub
-            try r $ \(db'',report) -> do
-            return $ KikiSuccess (db'', report0 ++ report)
-
     -- KeyRings (todo: KikiCondition reporting?)
-    (db_rings,mwk,grip,accs) <- do
+    (db_rings,mwk,grip,accs,keys,unspilled) <- do
         ringPackets <- Map.traverseWithKey readp ringMap
         let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message)
 
@@ -1126,20 +1116,44 @@ buildKeyDB doDecrypt ctx grip0 keyring = do
                     (_,Message ps) <- Map.lookup HomeSec ringPackets
                     listToMaybe ps
             (spilled,unspilled) = Map.partition (spillable . fst) ringPackets
-            db_rings = Map.foldlWithKey mergeIt Map.empty ringPackets
+            db_rings = Map.foldlWithKey mergeIt Map.empty spilled
                         where mergeIt db f (_,ps) = merge db f ps
+            keys :: Map.Map KeyKey MappedPacket
+            keys = Map.foldl slurpkeys Map.empty
+                        $ Map.mapWithKey filterSecrets ringPackets
+                    where isSecretKey (SecretKeyPacket {}) = True
+                          isSecretKey _                    = False
+                          filterSecrets f (_,Message ps) =
+                            filter (isSecretKey . packet)
+                                $ zipWith (mappedPacketWithHint fname) ps [1..]
+                            where fname = resolveForReport (Just ctx) f
+                          slurpkeys m ps = m `Map.union` Map.fromList ps'
+                            where ps' = zip (map (keykey . packet) ps) ps
             wk = listToMaybe $ do
                     fp <- maybeToList grip
-                    (kk,kd) <- Map.toList db_rings
-                    guard $ matchSpec (KeyGrip fp) (kk,kd)
-                    return $ keyMappedPacket kd
+                    let matchfp mp = not (is_subkey p) && matchpr fp p == fp
+                            where p = packet mp
+                    Map.elems $ Map.filter matchfp keys
             accs = Map.mapKeys (concat . resolveInputFile ctx)
                         $ fmap (access . fst) ringPackets
-        return (db_rings,wk,grip,accs)
+        return (db_rings,wk,grip,accs,keys,fmap snd unspilled)
+
+    doDecrypt <- makeMemoizingDecrypter keyring ctx keys
 
     let wk = fmap packet mwk
 
     -- Wallets
+    let importWalletKey wk db' (top,fname,sub,tag) = do
+            try db' $ \(db',report0) -> do
+            r <- doImportG doDecrypt
+                      db'
+                      (fmap keykey $ maybeToList wk)
+                      tag
+                      fname
+                      sub
+            try r $ \(db'',report) -> do
+            return $ KikiSuccess (db'', report0 ++ report)
+
     wms <- mapM (readw wk) (files iswallet)
     let wallet_keys = do
             maybeToList wk
@@ -1171,7 +1185,8 @@ buildKeyDB doDecrypt ctx grip0 keyring = do
     r <- mergeHostFiles keyring db ctx
     try r $ \((db,hs),reportHosts) -> do
 
-    return $ KikiSuccess ( (db, grip, mwk, hs, accs), reportWallets ++ reportPEMs )
+    return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled)
+                         , reportWallets ++ reportPEMs )
 
 torhash :: Packet -> String
 torhash key = fromMaybe "" $ derToBase32 <$> derRSA key
@@ -1465,13 +1480,13 @@ isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk
                             guard $ matchSpec (KeyGrip fp) elm
                             return $ keyPacket (snd elm)
 
-writeRingKeys :: KeyRingOperation -> KeyRingRuntime
+writeRingKeys :: KeyRingOperation -> KeyRingRuntime -> Map.Map InputFile Message
                 {-
                 ->  KeyDB -> Maybe Packet
                 -> FilePath -> FilePath
                 -}
                 -> IO (KikiCondition [(FilePath,KikiReportAction)])
-writeRingKeys krd rt {- db wk secring pubring -} = do
+writeRingKeys krd rt {- db wk secring pubring -} unspilled = do
     let isring (KeyRingFile {}) = True
         isring _                = False
         db = rtKeyDB rt
@@ -1484,7 +1499,10 @@ writeRingKeys krd rt {- db wk secring pubring -} = do
             guard (isring $ typ stream)
             f <- resolveInputFile ctx f0
             return (f,f0,stream)
-        let x = do
+        let db' = fromMaybe db $ do
+                    msg <- Map.lookup f0 unspilled
+                    return $ merge db f0 msg
+            x = do
                 let wantedForFill :: Access -> KeyFilter -> KeyData -> Maybe Bool
                     wantedForFill acc KF_None       = importByExistingMaster
                         -- Note the KF_None case is almost irrelevent as it will be
@@ -1504,7 +1522,7 @@ writeRingKeys krd rt {- db wk secring pubring -} = 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 db')
                 acc <- maybeToList $ Map.lookup f (rtRingAccess rt)
                 only_public <- maybeToList $ wantedForFill acc (fill stream) d
                 case fill stream of
@@ -1640,8 +1658,9 @@ writePEMKeys doDecrypt db exports = do
         return $ KikiSuccess (fname,pun)
 
 makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext
+                        -> Map.Map KeyKey MappedPacket
                         -> IO (MappedPacket -> IO (KikiCondition Packet))
-makeMemoizingDecrypter operation ctx = do
+makeMemoizingDecrypter operation ctx keys = do
     -- (*) Notice we do not pass ctx to resolveForReport.
     -- This is because the merge function does not currently use a context
     -- and the pws map keys must match the MappedPacket locations.
@@ -1664,10 +1683,7 @@ makeMemoizingDecrypter operation ctx = do
          $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp)
                                         && isNothing (passSpecKeySpec sp))
                                     $ kPassphrases operation
-    unkeysRef <- newIORef Map.empty
-    -- TODO:
-    --   Use buildKeyDB on unspilled files to create an unspillable KeyDB.
-    --   This KeyDB should be used later by decryptIt.
+    unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet)
     return $ doDecrypt unkeysRef (pws `Map.union` pws2) defpw
  where
     doDecrypt :: IORef (Map.Map KeyKey Packet)
@@ -1675,9 +1691,12 @@ makeMemoizingDecrypter operation ctx = do
                 -> Maybe (IO S.ByteString)
                 -> MappedPacket
                 -> IO (KikiCondition Packet)
-    doDecrypt unkeysRef pws defpw mp = do
+    doDecrypt unkeysRef pws defpw mp0 = do
         unkeys <- readIORef unkeysRef
-        let wk = packet mp
+        let mp = fromMaybe mp0 $ do
+                    k <- Map.lookup kk keys
+                    return $ mergeKeyPacket "decrypt" mp0 k
+            wk = packet mp0
             kk = keykey wk
             fs = Map.keys $ locations mp
 
@@ -1687,7 +1706,7 @@ makeMemoizingDecrypter operation ctx = do
                 --  combine the packet with it's unspilled version before
                 --  attempting to decrypt it.
                 pw <- getpw
-                let wkun = fromMaybe wk $ decryptSecretKey pw wk
+                let wkun = fromMaybe wk $ decryptSecretKey pw (packet mp)
                 case symmetric_algorithm wkun of
                     Unencrypted -> do
                         writeIORef unkeysRef (Map.insert kk wkun unkeys)
@@ -1860,14 +1879,9 @@ runKeyRing operation = do
        then return $ KikiResult (FailedToLock failed_locks) []
        else do
 
-        -- memoizing decrypter
-        -- TODO: Unspilled keyrings should be usable for decrypting
-        --       and signing.
-        decrypt <- makeMemoizingDecrypter operation ctx
-
         -- merge all keyrings, PEM files, and wallets
-        bresult <- buildKeyDB decrypt ctx grip0 operation
-        try' bresult $ \((db,grip,wk,hs,accs),report_imports) -> do
+        bresult <- buildKeyDB ctx grip0 operation
+        try' bresult $ \((db,grip,wk,hs,accs,decrypt,unspilled),report_imports) -> do
 
         externals_ret <- initializeMissingPEMFiles operation
                                                    ctx
@@ -1894,7 +1908,7 @@ runKeyRing operation = do
         r <- writeWalletKeys operation (rtKeyDB rt) (fmap packet wk)
         try' r $ \report_wallets -> do
 
-        r <- writeRingKeys operation rt -- db wk secring pubring
+        r <- writeRingKeys operation rt unspilled
         try' r $ \report_rings -> do
 
         r <- writePEMKeys decrypt (rtKeyDB rt) exports
@@ -2321,6 +2335,12 @@ mappedPacket filename p = MappedPacket
     , locations = Map.singleton filename (origin p (-1))
     }
 
+mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket
+mappedPacketWithHint filename p hint = MappedPacket
+    { packet = p
+    , locations = Map.singleton filename (origin p hint)
+    }
+
 keykey :: Packet -> KeyKey
 keykey key =
     -- Note: The key's timestamp is normally included in it's fingerprint.
@@ -2386,8 +2406,7 @@ 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) }
+    asMapped n p = mappedPacketWithHint filename p n
     asSigAndTrust n (p,tm) = (asMapped n p,tm)
     emptyUids = Map.empty
     -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets