summaryrefslogtreecommitdiff
path: root/KeyRing.hs
diff options
context:
space:
mode:
Diffstat (limited to 'KeyRing.hs')
-rw-r--r--KeyRing.hs103
1 files changed, 59 insertions, 44 deletions
diff --git a/KeyRing.hs b/KeyRing.hs
index 8571482..b0e24de 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -1267,45 +1267,17 @@ performManipulations doDecrypt operation rt wk = do
1267 return $ KikiSuccess (db,[]) 1267 return $ KikiSuccess (db,[])
1268 1268
1269 1269
1270{- 1270initializeMissingPEMFiles ::
1271interpretManip :: KeyData -> KeyRingAddress PacketUpdate -> IO KeyData 1271 KeyRingOperation
1272interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo" 1272 -> FilePath -> FilePath -> Maybe String
1273interpretManip kd manip = return kd 1273 -> (MappedPacket -> IO (KikiCondition Packet))
1274-} 1274 -> KeyDB
1275 1275 -> IO (KikiCondition ( (KeyDB,[( FilePath
1276runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime) 1276 , Maybe String
1277runKeyRing 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. 1280initializeMissingPEMFiles 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{-
1339interpretManip :: KeyData -> KeyRingAddress PacketUpdate -> IO KeyData
1340interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo"
1341interpretManip kd manip = return kd
1342-}
1343
1344runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime)
1345runKeyRing 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