From 7ce285bc7d22866b5ac9955cd9de8b83a83e6677 Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Mon, 28 Apr 2014 22:22:18 -0400
Subject: writeRingFiles now uses fill attribute instead of kImports hack.

---
 KeyRing.hs | 67 +++++++++++++++++++++++++++++++++++++++++++++++++++-----------
 1 file changed, 56 insertions(+), 11 deletions(-)

(limited to 'KeyRing.hs')

diff --git a/KeyRing.hs b/KeyRing.hs
index 26fb820..4f6ee46 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -441,7 +441,6 @@ data KikiResult a = KikiResult
 keyPacket :: KeyData -> Packet
 keyPacket (KeyData k _ _ _) = packet k
 
--- subkeyPacket (SubKey k _ ) = packet k
 subkeyMappedPacket :: SubKey -> MappedPacket
 subkeyMappedPacket (SubKey k _ ) = k
 
@@ -726,6 +725,33 @@ parseSpec grip spec = (topspec,subspec)
 filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)]
 filterMatches spec ks = filter (matchSpec spec) ks
 
+filterNewSubs :: FilePath -> (KeySpec,Maybe String) -> KeyData -> KeyData
+filterNewSubs fname spec (KeyData p sigs uids subs) = KeyData p sigs uids subs'
+ where
+    matchAll = KeyGrip ""
+
+    subkeySpec (KeyGrip grip,Nothing) = (matchAll, KeyGrip grip)
+    subkeySpec (topspec,Just mtag)    = (topspec , KeyTag (packet p) mtag)
+
+    match spec mps 
+               = not . null
+               . snd
+               . seek_key spec
+               . map packet
+               $ mps
+
+    old sub = isJust (Map.lookup fname $ locations $ subkeyMappedPacket sub)
+
+    oldOrMatch spec sub = old sub
+                          || match spec (flattenSub "" True sub)
+
+    subs' = Map.filter (if match topspec $ flattenTop "" True (KeyData p sigs uids Map.empty)
+                         then oldOrMatch subspec
+                         else old)
+                       subs
+        where
+            (topspec,subspec) = subkeySpec spec
+
 selectSecretKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
 selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db
 
@@ -1307,24 +1333,42 @@ writeRingKeys krd rt {- db wk secring pubring -} = do
         secring = rtSecring rt
         pubring = rtPubring rt
     let s = do
-        (f,f0,mutable) <- do
+        (f,f0,stream) <- do
             (f0,stream) <- Map.toList (kFiles krd)
             guard (isring $ typ stream)
             f <- resolveInputFile secring pubring f0
-            return (f,f0,isMutable stream)
+            return (f,f0,stream)
         let x = do
-                let wanted kd@(KeyData p _ _ _)
-                        = mplus (fmap originallyPublic $ Map.lookup f $ locations p)
-                            $ do
-                                pred <- Map.lookup f0 $ kImports krd
-                                pred rt kd
+                let wantedForFill :: Access -> KeyFilter -> KeyData -> Maybe Bool
+                    wantedForFill acc KF_None       = importByExistingMaster
+                        -- Note the KF_None case is almost irrelevent as it will be
+                        -- filtered later when isMutable returns False.
+                        -- We use importByExistingMaster in order to generate
+                        -- MissingPacket warnings.  To disable those warnings, use
+                        -- const Nothing instead.
+                    wantedForFill acc (KF_Match {}) = importByExistingMaster
+                    wantedForFill acc KF_Subkeys    = importByExistingMaster
+                    wantedForFill acc KF_Authentic  = \kd -> do guardAuthentic rt kd
+                                                                importByAccess acc kd
+                    wantedForFill acc KF_All        = importByAccess acc
+                    importByAccess Pub kd = importPublic
+                    importByAccess Sec kd = importSecret
+                    importByAccess AutoAccess kd =
+                        mplus (importByExistingMaster kd)
+                              (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)
-                only_public <- maybeToList $ wanted d
-                flattenTop f only_public d
+                only_public <- maybeToList $ wantedForFill (access stream) (fill stream) d
+                case fill stream of
+                    KF_Match usage -> do grip <- maybeToList $ rtGrip rt
+                                         flattenTop f only_public
+                                            $ filterNewSubs f (parseSpec grip usage) d
+                    _              -> flattenTop f only_public d
             new_packets = filter isnew x
                 where isnew p = isNothing (Map.lookup f $ locations p)
         guard (not $ null new_packets)
-        return ((f,mutable),(new_packets,x))
+        return ((f,isMutable stream),(new_packets,x))
     let (towrites,report) = (\f -> foldl f ([],[]) s) $
          \(ws,report) ((f,mutable),(new_packets,x)) ->
             if mutable
@@ -1649,6 +1693,7 @@ runKeyRing operation = do
         decrypt <- makeMemoizingDecrypter operation secring pubring
 
         -- merge all keyrings, PEM files, and wallets
+        -- TODO: resolve AutoAccess here
         bresult <- buildKeyDB decrypt secring pubring grip0 operation
         try' bresult $ \((db,grip,wk,hs),report_imports) -> do
 
-- 
cgit v1.2.3