summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2014-05-06 01:29:09 -0400
committerjoe <joe@jerkface.net>2014-05-06 01:29:09 -0400
commit9cf8e1743d4c8039d36b13b7cecf6413fd80c9ad (patch)
tree8f7dfd8584ea627ff7ead8a58c9ecbfc4afc56fe
parentb67c7e1a1fab761159e45505579e9ab6d8ec78d8 (diff)
per file transforms
-rw-r--r--KeyRing.hs48
1 files 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
219 -- (see 'rtRingAccess') 219 -- (see 'rtRingAccess')
220 | Sec -- ^ secret information 220 | Sec -- ^ secret information
221 | Pub -- ^ public information 221 | Pub -- ^ public information
222 deriving (Eq,Ord,Show)
222 223
223-- | Note that the documentation here is intended for when this value is 224-- | Note that the documentation here is intended for when this value is
224-- assigned to 'fill'. For other usage, see 'spill'. 225-- assigned to 'fill'. For other usage, see 'spill'.
@@ -328,7 +329,7 @@ data KeyRingRuntime = KeyRingRuntime
328 -- ^ The common information pool where files spilled 329 -- ^ The common information pool where files spilled
329 -- their content and from which they received new 330 -- their content and from which they received new
330 -- content. 331 -- content.
331 , rtRingAccess :: Map.Map FilePath Access 332 , rtRingAccess :: Map.Map InputFile Access
332 -- ^ The 'Access' values used for files of type 333 -- ^ The 'Access' values used for files of type
333 -- 'KeyRingFile'. If 'AutoAccess' was specified 334 -- 'KeyRingFile'. If 'AutoAccess' was specified
334 -- for a file, this 'Map.Map' will indicate the 335 -- for a file, this 'Map.Map' will indicate the
@@ -1206,7 +1207,7 @@ buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation
1206 Hosts.Hosts, 1207 Hosts.Hosts,
1207 [(SockAddr, (KeyKey, KeyKey))], 1208 [(SockAddr, (KeyKey, KeyKey))],
1208 [SockAddr]) 1209 [SockAddr])
1209 ,Map.Map FilePath Access 1210 ,Map.Map InputFile Access
1210 ,MappedPacket -> IO (KikiCondition Packet) 1211 ,MappedPacket -> IO (KikiCondition Packet)
1211 ,Map.Map InputFile Message 1212 ,Map.Map InputFile Message
1212 ) 1213 )
@@ -1234,7 +1235,7 @@ buildKeyDB ctx grip0 keyring = do
1234 readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n)) 1235 readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n))
1235 1236
1236 -- KeyRings (todo: KikiCondition reporting?) 1237 -- KeyRings (todo: KikiCondition reporting?)
1237 (db_rings,mwk,grip,accs,keys,unspilled) <- do 1238 (spilled,mwk,grip,accs,keys,unspilled) <- do
1238 ringPackets <- Map.traverseWithKey readp ringMap 1239 ringPackets <- Map.traverseWithKey readp ringMap
1239 let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message) 1240 let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message)
1240 1241
@@ -1244,8 +1245,6 @@ buildKeyDB ctx grip0 keyring = do
1244 (_,Message ps) <- Map.lookup HomeSec ringPackets 1245 (_,Message ps) <- Map.lookup HomeSec ringPackets
1245 listToMaybe ps 1246 listToMaybe ps
1246 (spilled,unspilled) = Map.partition (spillable . fst) ringPackets 1247 (spilled,unspilled) = Map.partition (spillable . fst) ringPackets
1247 db_rings = Map.foldlWithKey mergeIt Map.empty spilled
1248 where mergeIt db f (_,ps) = merge db f ps
1249 keys :: Map.Map KeyKey MappedPacket 1248 keys :: Map.Map KeyKey MappedPacket
1250 keys = Map.foldl slurpkeys Map.empty 1249 keys = Map.foldl slurpkeys Map.empty
1251 $ Map.mapWithKey filterSecrets ringPackets 1250 $ Map.mapWithKey filterSecrets ringPackets
@@ -1262,13 +1261,32 @@ buildKeyDB ctx grip0 keyring = do
1262 let matchfp mp = not (is_subkey p) && matchpr fp p == fp 1261 let matchfp mp = not (is_subkey p) && matchpr fp p == fp
1263 where p = packet mp 1262 where p = packet mp
1264 Map.elems $ Map.filter matchfp keys 1263 Map.elems $ Map.filter matchfp keys
1265 accs = Map.mapKeys (concat . resolveInputFile ctx) 1264 accs = fmap (access . fst) ringPackets
1266 $ fmap (access . fst) ringPackets 1265 return (spilled,wk,grip,accs,keys,fmap snd unspilled)
1267 return (db_rings,wk,grip,accs,keys,fmap snd unspilled)
1268 1266
1269 doDecrypt <- makeMemoizingDecrypter keyring ctx keys 1267 doDecrypt <- makeMemoizingDecrypter keyring ctx keys
1270 1268
1271 let wk = fmap packet mwk 1269 let wk = fmap packet mwk
1270 rt0 = KeyRingRuntime { rtPubring = homepubPath ctx
1271 , rtSecring = homesecPath ctx
1272 , rtGrip = grip
1273 , rtWorkingKey = wk
1274 , rtRingAccess = accs
1275 , rtKeyDB = Map.empty
1276 }
1277 transformed <-
1278 let trans f (info,ps) = do
1279 let manip = combineTransforms (transforms info)
1280 rt1 = rt0 { rtKeyDB = merge Map.empty f ps }
1281 acc = True
1282 r <- performManipulations doDecrypt rt1 mwk manip
1283 return $ either (const (info,ps))
1284 (\(rt2,report) -> (info,flattenKeys acc $ rtKeyDB rt2))
1285 $ functorToEither r
1286 in Map.traverseWithKey trans spilled
1287 let db_rings = Map.foldlWithKey' mergeIt Map.empty transformed
1288 where
1289 mergeIt db f (info,ps) = merge db f ps
1272 1290
1273 -- Wallets 1291 -- Wallets
1274 let importWalletKey wk db' (top,fname,sub,tag) = do 1292 let importWalletKey wk db' (top,fname,sub,tag) = do
@@ -1647,7 +1665,7 @@ writeRingKeys krd rt {- db wk secring pubring -} unspilled = do
1647 importByExistingMaster kd@(KeyData p _ _ _) = 1665 importByExistingMaster kd@(KeyData p _ _ _) =
1648 fmap originallyPublic $ Map.lookup f $ locations p 1666 fmap originallyPublic $ Map.lookup f $ locations p
1649 d <- sortByHint f keyMappedPacket (Map.elems db') 1667 d <- sortByHint f keyMappedPacket (Map.elems db')
1650 acc <- maybeToList $ Map.lookup f (rtRingAccess rt) 1668 acc <- maybeToList $ Map.lookup f0 (rtRingAccess rt)
1651 only_public <- maybeToList $ wantedForFill acc (fill stream) d 1669 only_public <- maybeToList $ wantedForFill acc (fill stream) d
1652 case fill stream of 1670 case fill stream of
1653 KF_Match usage -> do grip <- maybeToList $ rtGrip rt 1671 KF_Match usage -> do grip <- maybeToList $ rtGrip rt
@@ -1849,12 +1867,11 @@ makeMemoizingDecrypter operation ctx keys = do
1849 1867
1850performManipulations :: 1868performManipulations ::
1851 (MappedPacket -> IO (KikiCondition Packet)) 1869 (MappedPacket -> IO (KikiCondition Packet))
1852 -> KeyRingOperation
1853 -> KeyRingRuntime 1870 -> KeyRingRuntime
1854 -> Maybe MappedPacket 1871 -> Maybe MappedPacket
1855 -> (KeyRingRuntime -> KeyData -> [PacketUpdate]) 1872 -> (KeyRingRuntime -> KeyData -> [PacketUpdate])
1856 -> IO (KikiCondition (KeyRingRuntime,[(FilePath,KikiReportAction)])) 1873 -> IO (KikiCondition (KeyRingRuntime,[(FilePath,KikiReportAction)]))
1857performManipulations doDecrypt operation rt wk manip = do 1874performManipulations doDecrypt rt wk manip = do
1858 let db = rtKeyDB rt 1875 let db = rtKeyDB rt
1859 performAll kd = foldM perform (KikiSuccess kd) $ manip rt kd 1876 performAll kd = foldM perform (KikiSuccess kd) $ manip rt kd
1860 r <- Traversable.mapM performAll db 1877 r <- Traversable.mapM performAll db
@@ -1977,12 +1994,12 @@ interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo"
1977interpretManip kd manip = return kd 1994interpretManip kd manip = return kd
1978-} 1995-}
1979 1996
1980combineTransforms :: KeyRingOperation -> KeyRingRuntime -> KeyData -> [PacketUpdate] 1997combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate]
1981combineTransforms operation rt kd = updates 1998combineTransforms trans rt kd = updates
1982 where 1999 where
1983 updates = -- kManip operation rt kd ++ 2000 updates = -- kManip operation rt kd ++
1984 concatMap (\t -> resolveTransform t rt kd) sanitized 2001 concatMap (\t -> resolveTransform t rt kd) sanitized
1985 sanitized = group (sort (opTransforms operation)) >>= take 1 2002 sanitized = group (sort trans) >>= take 1
1986 2003
1987isSubkeySignature (SubkeySignature {}) = True 2004isSubkeySignature (SubkeySignature {}) = True
1988isSubkeySignature _ = False 2005isSubkeySignature _ = False
@@ -2160,10 +2177,9 @@ runKeyRing operation = do
2160 } 2177 }
2161 2178
2162 r <- performManipulations decrypt 2179 r <- performManipulations decrypt
2163 operation
2164 rt 2180 rt
2165 wk 2181 wk
2166 (combineTransforms operation) 2182 (combineTransforms $ opTransforms operation)
2167 try' r $ \(rt,report_manips) -> do 2183 try' r $ \(rt,report_manips) -> do
2168 2184
2169 r <- writeWalletKeys operation (rtKeyDB rt) (fmap packet wk) 2185 r <- writeWalletKeys operation (rtKeyDB rt) (fmap packet wk)