diff options
-rw-r--r-- | KeyRing.hs | 103 |
1 files changed, 59 insertions, 44 deletions
@@ -1267,45 +1267,17 @@ performManipulations doDecrypt operation rt wk = do | |||
1267 | return $ KikiSuccess (db,[]) | 1267 | return $ KikiSuccess (db,[]) |
1268 | 1268 | ||
1269 | 1269 | ||
1270 | {- | 1270 | initializeMissingPEMFiles :: |
1271 | interpretManip :: KeyData -> KeyRingAddress PacketUpdate -> IO KeyData | 1271 | KeyRingOperation |
1272 | interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo" | 1272 | -> FilePath -> FilePath -> Maybe String |
1273 | interpretManip kd manip = return kd | 1273 | -> (MappedPacket -> IO (KikiCondition Packet)) |
1274 | -} | 1274 | -> KeyDB |
1275 | 1275 | -> IO (KikiCondition ( (KeyDB,[( FilePath | |
1276 | runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime) | 1276 | , Maybe String |
1277 | runKeyRing operation = do | 1277 | , [MappedPacket] |
1278 | homedir <- getHomeDir (homeSpec operation) | 1278 | , Maybe Initializer)]) |
1279 | let try' :: KikiCondition a -> (a -> IO (KikiResult b)) -> IO (KikiResult b) | 1279 | , [(FilePath,KikiReportAction)])) |
1280 | -- FIXME: try' should probably accept a list of KikiReportActions. | 1280 | initializeMissingPEMFiles operation secring pubring grip decrypt db = do |
1281 | -- This would be useful for reporting on disk writes that have already | ||
1282 | -- succeded prior to this termination. | ||
1283 | try' v body = | ||
1284 | case functorToEither v of | ||
1285 | Left e -> return $ KikiResult e [] | ||
1286 | Right wkun -> body wkun | ||
1287 | try' homedir $ \(homedir,secring,pubring,grip0) -> do | ||
1288 | let tolocks = filesToLock operation secring pubring | ||
1289 | lks <- forM tolocks $ \f -> do | ||
1290 | lk <- dotlock_create f 0 | ||
1291 | v <- flip (maybe $ return Nothing) lk $ \lk -> do | ||
1292 | e <- dotlock_take lk (-1) | ||
1293 | if e==0 then return $ Just lk | ||
1294 | else dotlock_destroy lk >> return Nothing | ||
1295 | return (v,f) | ||
1296 | let (lked, map snd -> failed_locks) = partition (isJust . fst) lks | ||
1297 | ret <- | ||
1298 | if not $ null failed_locks | ||
1299 | then return $ KikiResult (FailedToLock failed_locks) [] | ||
1300 | else do | ||
1301 | |||
1302 | -- memoizing decrypter | ||
1303 | decrypt <- makeMemoizingDecrypter operation secring pubring | ||
1304 | |||
1305 | -- merge all keyrings, PEM files, and wallets | ||
1306 | bresult <- buildKeyDB decrypt secring pubring grip0 operation | ||
1307 | try' bresult $ \((db,grip,wk),report_imports) -> do | ||
1308 | |||
1309 | nonexistents <- | 1281 | nonexistents <- |
1310 | filterM (fmap not . doesFileExist . fst) | 1282 | filterM (fmap not . doesFileExist . fst) |
1311 | $ do (f,t) <- Map.toList (kFiles operation) | 1283 | $ do (f,t) <- Map.toList (kFiles operation) |
@@ -1329,9 +1301,8 @@ runKeyRing operation = do | |||
1329 | notmissing | 1301 | notmissing |
1330 | exports = map (\(f,subspec,ns,cmd) -> (f,subspec,ns >>= snd,cmd)) exports0 | 1302 | exports = map (\(f,subspec,ns,cmd) -> (f,subspec,ns >>= snd,cmd)) exports0 |
1331 | 1303 | ||
1332 | |||
1333 | ambiguity (f,topspec,subspec,_) = do | 1304 | ambiguity (f,topspec,subspec,_) = do |
1334 | return $ KikiResult (AmbiguousKeySpec f) [] | 1305 | return $ AmbiguousKeySpec f |
1335 | 1306 | ||
1336 | ifnotnull (x:xs) f g = f x | 1307 | ifnotnull (x:xs) f g = f x |
1337 | ifnotnull _ f g = g | 1308 | ifnotnull _ f g = g |
@@ -1339,7 +1310,7 @@ runKeyRing operation = do | |||
1339 | ifnotnull ambiguous ambiguity $ do | 1310 | ifnotnull ambiguous ambiguity $ do |
1340 | 1311 | ||
1341 | -- create nonexistent files via external commands | 1312 | -- create nonexistent files via external commands |
1342 | externals_ret <- do | 1313 | do |
1343 | let cmds = mapMaybe getcmd missing | 1314 | let cmds = mapMaybe getcmd missing |
1344 | where | 1315 | where |
1345 | getcmd (fname,subspec,ms,mcmd) = do | 1316 | getcmd (fname,subspec,ms,mcmd) = do |
@@ -1362,8 +1333,51 @@ runKeyRing operation = do | |||
1362 | return (f,subspec,map fst ms,cmd) | 1333 | return (f,subspec,map fst ms,cmd) |
1363 | 1334 | ||
1364 | try v $ \(db,import_rs) -> do | 1335 | try v $ \(db,import_rs) -> do |
1365 | return $ KikiSuccess (db, map (\((f,_,_,_),r)->(f,r)) rs | 1336 | return $ KikiSuccess ((db,exports), map (\((f,_,_,_),r)->(f,r)) rs |
1366 | ++ import_rs) | 1337 | ++ import_rs) |
1338 | {- | ||
1339 | interpretManip :: KeyData -> KeyRingAddress PacketUpdate -> IO KeyData | ||
1340 | interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo" | ||
1341 | interpretManip kd manip = return kd | ||
1342 | -} | ||
1343 | |||
1344 | runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime) | ||
1345 | runKeyRing operation = do | ||
1346 | homedir <- getHomeDir (homeSpec operation) | ||
1347 | let try' :: KikiCondition a -> (a -> IO (KikiResult b)) -> IO (KikiResult b) | ||
1348 | -- FIXME: try' should probably accept a list of KikiReportActions. | ||
1349 | -- This would be useful for reporting on disk writes that have already | ||
1350 | -- succeded prior to this termination. | ||
1351 | try' v body = | ||
1352 | case functorToEither v of | ||
1353 | Left e -> return $ KikiResult e [] | ||
1354 | Right wkun -> body wkun | ||
1355 | try' homedir $ \(homedir,secring,pubring,grip0) -> do | ||
1356 | let tolocks = filesToLock operation secring pubring | ||
1357 | lks <- forM tolocks $ \f -> do | ||
1358 | lk <- dotlock_create f 0 | ||
1359 | v <- flip (maybe $ return Nothing) lk $ \lk -> do | ||
1360 | e <- dotlock_take lk (-1) | ||
1361 | if e==0 then return $ Just lk | ||
1362 | else dotlock_destroy lk >> return Nothing | ||
1363 | return (v,f) | ||
1364 | let (lked, map snd -> failed_locks) = partition (isJust . fst) lks | ||
1365 | ret <- | ||
1366 | if not $ null failed_locks | ||
1367 | then return $ KikiResult (FailedToLock failed_locks) [] | ||
1368 | else do | ||
1369 | |||
1370 | -- memoizing decrypter | ||
1371 | decrypt <- makeMemoizingDecrypter operation secring pubring | ||
1372 | |||
1373 | -- merge all keyrings, PEM files, and wallets | ||
1374 | bresult <- buildKeyDB decrypt secring pubring grip0 operation | ||
1375 | try' bresult $ \((db,grip,wk),report_imports) -> do | ||
1376 | |||
1377 | externals_ret <- initializeMissingPEMFiles operation | ||
1378 | secring pubring grip | ||
1379 | decrypt | ||
1380 | db | ||
1367 | 1381 | ||
1368 | let rt = KeyRingRuntime | 1382 | let rt = KeyRingRuntime |
1369 | { rtPubring = pubring | 1383 | { rtPubring = pubring |
@@ -1373,7 +1387,8 @@ runKeyRing operation = do | |||
1373 | , rtKeyDB = db | 1387 | , rtKeyDB = db |
1374 | } | 1388 | } |
1375 | 1389 | ||
1376 | try' externals_ret $ \(db,report_externals) -> do | 1390 | try' externals_ret $ \((db,exports),report_externals) -> do |
1391 | |||
1377 | 1392 | ||
1378 | 1393 | ||
1379 | r <- performManipulations decrypt | 1394 | r <- performManipulations decrypt |