diff options
Diffstat (limited to 'lib/KeyRing.hs')
-rw-r--r-- | lib/KeyRing.hs | 61 |
1 files changed, 45 insertions, 16 deletions
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs index faf5e70..b59fb9e 100644 --- a/lib/KeyRing.hs +++ b/lib/KeyRing.hs | |||
@@ -42,6 +42,7 @@ module KeyRing | |||
42 | , Access(..) | 42 | , Access(..) |
43 | , FileType(..) | 43 | , FileType(..) |
44 | , InputFile(..) | 44 | , InputFile(..) |
45 | , Initializer(..) | ||
45 | , KeyFilter(..) | 46 | , KeyFilter(..) |
46 | -- * Results of a KeyRing Operation | 47 | -- * Results of a KeyRing Operation |
47 | , KeyRingRuntime(..) | 48 | , KeyRingRuntime(..) |
@@ -248,7 +249,8 @@ data InputFile = HomeSec | |||
248 | deriving (Eq,Ord,Show) | 249 | deriving (Eq,Ord,Show) |
249 | 250 | ||
250 | -- type UsageTag = String | 251 | -- type UsageTag = String |
251 | type Initializer = String | 252 | data Initializer = NoCreate | Internal GenerateKeyParams | External String |
253 | deriving (Eq,Ord,Show) | ||
252 | 254 | ||
253 | data FileType = KeyRingFile | 255 | data FileType = KeyRingFile |
254 | | PEMFile | 256 | | PEMFile |
@@ -321,10 +323,10 @@ data StreamInfo = StreamInfo | |||
321 | -- * The 'spill' setting is ignored and the file's contents are shared. | 323 | -- * The 'spill' setting is ignored and the file's contents are shared. |
322 | -- (TODO) | 324 | -- (TODO) |
323 | -- | 325 | -- |
324 | , initializer :: Maybe String | 326 | , initializer :: Initializer |
325 | -- ^ If 'typ' is 'PEMFile' and an 'initializer' string is set, then it is | 327 | -- ^ If 'typ' is 'PEMFile' and an 'External' 'initializer' string is set, |
326 | -- interpretted as a shell command that may be used to create the key if it | 328 | -- then it is interpretted as a shell command that may be used to create |
327 | -- does not exist. | 329 | -- the key if it does not exist. |
328 | , transforms :: [Transform] | 330 | , transforms :: [Transform] |
329 | -- ^ Per-file transformations that occur before the contents of a file are | 331 | -- ^ Per-file transformations that occur before the contents of a file are |
330 | -- spilled into the common pool. | 332 | -- spilled into the common pool. |
@@ -1568,13 +1570,8 @@ buildKeyDB ctx grip0 keyring = do | |||
1568 | let gens = mapMaybe g $ Map.toList genMap | 1570 | let gens = mapMaybe g $ Map.toList genMap |
1569 | where g (Generate params,v) = Just (params,v) | 1571 | where g (Generate params,v) = Just (params,v) |
1570 | g _ = Nothing | 1572 | g _ = Nothing |
1571 | db <- case mwk >>= \wk -> Map.lookup (keykey $ packet wk) db of | 1573 | |
1572 | Just kd0 -> do | 1574 | db <- generateInternals doDecrypt mwk db gens |
1573 | kd <- foldM (generateSubkey doDecrypt) (KikiSuccess (kd0,[])) gens | ||
1574 | try kd $ \(kd,reportGens) -> do | ||
1575 | let kk = keykey $ packet $ fromJust mwk | ||
1576 | return $ KikiSuccess (Map.insert kk kd db,reportGens) | ||
1577 | Nothing -> return $ KikiSuccess (db,[]) | ||
1578 | try db $ \(db,reportGens) -> do | 1575 | try db $ \(db,reportGens) -> do |
1579 | 1576 | ||
1580 | r <- mergeHostFiles keyring db ctx | 1577 | r <- mergeHostFiles keyring db ctx |
@@ -1583,6 +1580,21 @@ buildKeyDB ctx grip0 keyring = do | |||
1583 | return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled) | 1580 | return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled) |
1584 | , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts ) | 1581 | , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts ) |
1585 | 1582 | ||
1583 | generateInternals :: | ||
1584 | (MappedPacket -> IO (KikiCondition Packet)) | ||
1585 | -> Maybe MappedPacket | ||
1586 | -> Map.Map KeyKey KeyData | ||
1587 | -> [(GenerateKeyParams,StreamInfo)] | ||
1588 | -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) | ||
1589 | generateInternals doDecrypt mwk db gens = do | ||
1590 | case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) db of | ||
1591 | Just kd0 -> do | ||
1592 | kd <- foldM (generateSubkey doDecrypt) (KikiSuccess (kd0,[])) gens | ||
1593 | try kd $ \(kd,reportGens) -> do | ||
1594 | let kk = keykey $ packet $ fromJust mwk | ||
1595 | return $ KikiSuccess (Map.insert kk kd db,reportGens) | ||
1596 | Nothing -> return $ KikiSuccess (db,[]) | ||
1597 | |||
1586 | torhash :: Packet -> String | 1598 | torhash :: Packet -> String |
1587 | torhash key = fromMaybe "" $ derToBase32 <$> derRSA key | 1599 | torhash key = fromMaybe "" $ derToBase32 <$> derRSA key |
1588 | 1600 | ||
@@ -2443,7 +2455,9 @@ performManipulations doDecrypt rt wk manip = do | |||
2443 | 2455 | ||
2444 | initializeMissingPEMFiles :: | 2456 | initializeMissingPEMFiles :: |
2445 | KeyRingOperation | 2457 | KeyRingOperation |
2446 | -> InputFileContext -> Maybe String | 2458 | -> InputFileContext |
2459 | -> Maybe String | ||
2460 | -> Maybe MappedPacket | ||
2447 | -> (MappedPacket -> IO (KikiCondition Packet)) | 2461 | -> (MappedPacket -> IO (KikiCondition Packet)) |
2448 | -> KeyDB | 2462 | -> KeyDB |
2449 | -> IO (KikiCondition ( (KeyDB,[( FilePath | 2463 | -> IO (KikiCondition ( (KeyDB,[( FilePath |
@@ -2451,7 +2465,7 @@ initializeMissingPEMFiles :: | |||
2451 | , [MappedPacket] | 2465 | , [MappedPacket] |
2452 | , StreamInfo )]) | 2466 | , StreamInfo )]) |
2453 | , [(FilePath,KikiReportAction)])) | 2467 | , [(FilePath,KikiReportAction)])) |
2454 | initializeMissingPEMFiles operation ctx grip decrypt db = do | 2468 | initializeMissingPEMFiles operation ctx grip mwk decrypt db = do |
2455 | nonexistents <- | 2469 | nonexistents <- |
2456 | filterM (fmap not . doesFileExist . fst) | 2470 | filterM (fmap not . doesFileExist . fst) |
2457 | $ do (f,t) <- Map.toList (opFiles operation) | 2471 | $ do (f,t) <- Map.toList (opFiles operation) |
@@ -2489,7 +2503,9 @@ initializeMissingPEMFiles operation ctx grip decrypt db = do | |||
2489 | let cmds = mapMaybe getcmd missing | 2503 | let cmds = mapMaybe getcmd missing |
2490 | where | 2504 | where |
2491 | getcmd (fname,subspec,ms,stream) = do | 2505 | getcmd (fname,subspec,ms,stream) = do |
2492 | cmd <- initializer stream | 2506 | cmd <- case initializer stream of |
2507 | External str -> Just str | ||
2508 | _ -> Nothing | ||
2493 | return (fname,subspec,ms,stream,cmd) | 2509 | return (fname,subspec,ms,stream,cmd) |
2494 | rs <- forM cmds $ \tup@(fname,subspec,ms,stream,cmd) -> do | 2510 | rs <- forM cmds $ \tup@(fname,subspec,ms,stream,cmd) -> do |
2495 | e <- systemEnv [ ("file",fname) | 2511 | e <- systemEnv [ ("file",fname) |
@@ -2508,8 +2524,20 @@ initializeMissingPEMFiles operation ctx grip decrypt db = do | |||
2508 | return (f,subspec,map fst ms,stream,cmd) | 2524 | return (f,subspec,map fst ms,stream,cmd) |
2509 | 2525 | ||
2510 | try v $ \(db,import_rs) -> do | 2526 | try v $ \(db,import_rs) -> do |
2527 | |||
2528 | -- generateInternals | ||
2529 | let internals = mapMaybe getParams missing | ||
2530 | where | ||
2531 | getParams (fname,subspec,ms,stream) = | ||
2532 | case initializer stream of | ||
2533 | Internal p -> Just (p, stream)[ | ||
2534 | _ -> Nothing | ||
2535 | v <- generateInternals decrypt mwk db internals | ||
2536 | |||
2537 | try v $ \(db,internals_rs) -> do | ||
2538 | |||
2511 | return $ KikiSuccess ((db,exports), map (\((f,_,_,_,_),r)->(f,r)) rs | 2539 | return $ KikiSuccess ((db,exports), map (\((f,_,_,_,_),r)->(f,r)) rs |
2512 | ++ import_rs) | 2540 | ++ import_rs ++ internals_rs) |
2513 | {- | 2541 | {- |
2514 | interpretManip :: KeyData -> KeyRingAddress PacketUpdate -> IO KeyData | 2542 | interpretManip :: KeyData -> KeyRingAddress PacketUpdate -> IO KeyData |
2515 | interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo" | 2543 | interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo" |
@@ -2695,6 +2723,7 @@ runKeyRing operation = do | |||
2695 | externals_ret <- initializeMissingPEMFiles operation | 2723 | externals_ret <- initializeMissingPEMFiles operation |
2696 | ctx | 2724 | ctx |
2697 | grip | 2725 | grip |
2726 | wk | ||
2698 | decrypt | 2727 | decrypt |
2699 | db | 2728 | db |
2700 | try' externals_ret $ \((db,exports),report_externals) -> do | 2729 | try' externals_ret $ \((db,exports),report_externals) -> do |