From 9cf8e1743d4c8039d36b13b7cecf6413fd80c9ad Mon Sep 17 00:00:00 2001 From: joe Date: Tue, 6 May 2014 01:29:09 -0400 Subject: per file transforms --- KeyRing.hs | 48 ++++++++++++++++++++++++++++++++---------------- 1 file changed, 32 insertions(+), 16 deletions(-) diff --git a/KeyRing.hs b/KeyRing.hs index 57f80d9..023c027 100644 --- a/KeyRing.hs +++ b/KeyRing.hs @@ -219,6 +219,7 @@ data Access = AutoAccess -- ^ secret or public as appropriate based on existing -- (see 'rtRingAccess') | Sec -- ^ secret information | Pub -- ^ public information + deriving (Eq,Ord,Show) -- | Note that the documentation here is intended for when this value is -- assigned to 'fill'. For other usage, see 'spill'. @@ -328,7 +329,7 @@ data KeyRingRuntime = KeyRingRuntime -- ^ The common information pool where files spilled -- their content and from which they received new -- content. - , rtRingAccess :: Map.Map FilePath Access + , rtRingAccess :: Map.Map InputFile Access -- ^ The 'Access' values used for files of type -- 'KeyRingFile'. If 'AutoAccess' was specified -- for a file, this 'Map.Map' will indicate the @@ -1206,7 +1207,7 @@ buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation Hosts.Hosts, [(SockAddr, (KeyKey, KeyKey))], [SockAddr]) - ,Map.Map FilePath Access + ,Map.Map InputFile Access ,MappedPacket -> IO (KikiCondition Packet) ,Map.Map InputFile Message ) @@ -1234,7 +1235,7 @@ buildKeyDB ctx grip0 keyring = do readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n)) -- KeyRings (todo: KikiCondition reporting?) - (db_rings,mwk,grip,accs,keys,unspilled) <- do + (spilled,mwk,grip,accs,keys,unspilled) <- do ringPackets <- Map.traverseWithKey readp ringMap let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message) @@ -1244,8 +1245,6 @@ buildKeyDB 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 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 @@ -1262,13 +1261,32 @@ buildKeyDB ctx grip0 keyring = do 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,keys,fmap snd unspilled) + accs = fmap (access . fst) ringPackets + return (spilled,wk,grip,accs,keys,fmap snd unspilled) doDecrypt <- makeMemoizingDecrypter keyring ctx keys let wk = fmap packet mwk + rt0 = KeyRingRuntime { rtPubring = homepubPath ctx + , rtSecring = homesecPath ctx + , rtGrip = grip + , rtWorkingKey = wk + , rtRingAccess = accs + , rtKeyDB = Map.empty + } + transformed <- + let trans f (info,ps) = do + let manip = combineTransforms (transforms info) + rt1 = rt0 { rtKeyDB = merge Map.empty f ps } + acc = True + r <- performManipulations doDecrypt rt1 mwk manip + return $ either (const (info,ps)) + (\(rt2,report) -> (info,flattenKeys acc $ rtKeyDB rt2)) + $ functorToEither r + in Map.traverseWithKey trans spilled + let db_rings = Map.foldlWithKey' mergeIt Map.empty transformed + where + mergeIt db f (info,ps) = merge db f ps -- Wallets let importWalletKey wk db' (top,fname,sub,tag) = do @@ -1647,7 +1665,7 @@ writeRingKeys krd rt {- db wk secring pubring -} unspilled = do importByExistingMaster kd@(KeyData p _ _ _) = fmap originallyPublic $ Map.lookup f $ locations p d <- sortByHint f keyMappedPacket (Map.elems db') - acc <- maybeToList $ Map.lookup f (rtRingAccess rt) + acc <- maybeToList $ Map.lookup f0 (rtRingAccess rt) only_public <- maybeToList $ wantedForFill acc (fill stream) d case fill stream of KF_Match usage -> do grip <- maybeToList $ rtGrip rt @@ -1849,12 +1867,11 @@ makeMemoizingDecrypter operation ctx keys = do performManipulations :: (MappedPacket -> IO (KikiCondition Packet)) - -> KeyRingOperation -> KeyRingRuntime -> Maybe MappedPacket -> (KeyRingRuntime -> KeyData -> [PacketUpdate]) -> IO (KikiCondition (KeyRingRuntime,[(FilePath,KikiReportAction)])) -performManipulations doDecrypt operation rt wk manip = do +performManipulations doDecrypt rt wk manip = do let db = rtKeyDB rt performAll kd = foldM perform (KikiSuccess kd) $ manip rt kd r <- Traversable.mapM performAll db @@ -1977,12 +1994,12 @@ interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo" interpretManip kd manip = return kd -} -combineTransforms :: KeyRingOperation -> KeyRingRuntime -> KeyData -> [PacketUpdate] -combineTransforms operation rt kd = updates +combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate] +combineTransforms trans rt kd = updates where updates = -- kManip operation rt kd ++ concatMap (\t -> resolveTransform t rt kd) sanitized - sanitized = group (sort (opTransforms operation)) >>= take 1 + sanitized = group (sort trans) >>= take 1 isSubkeySignature (SubkeySignature {}) = True isSubkeySignature _ = False @@ -2160,10 +2177,9 @@ runKeyRing operation = do } r <- performManipulations decrypt - operation rt wk - (combineTransforms operation) + (combineTransforms $ opTransforms operation) try' r $ \(rt,report_manips) -> do r <- writeWalletKeys operation (rtKeyDB rt) (fmap packet wk) -- cgit v1.2.3