summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2016-08-25 02:37:17 -0400
committerjoe <joe@jerkface.net>2016-08-25 02:37:17 -0400
commitaea085761eeaeb0debc1373aeb7edee25c3120a5 (patch)
treeb3cfb75893a43d581eb3948eb2119d1db1571272 /lib
parentb71913df7945838de8526f4019ecdcba6afe6d28 (diff)
Progress toward encrypting keys.
Diffstat (limited to 'lib')
-rw-r--r--lib/KeyRing.hs80
-rw-r--r--lib/Kiki.hs1
2 files changed, 48 insertions, 33 deletions
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index 2c174b3..80b7826 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -128,7 +128,7 @@ import Data.Bits ( (.|.), (.&.) )
128import Control.Applicative ( Applicative, pure, liftA2, (<*>) ) 128import Control.Applicative ( Applicative, pure, liftA2, (<*>) )
129import System.Directory ( getHomeDirectory, doesFileExist, createDirectoryIfMissing ) 129import System.Directory ( getHomeDirectory, doesFileExist, createDirectoryIfMissing )
130import Control.Arrow ( first, second ) 130import Control.Arrow ( first, second )
131import Data.OpenPGP.Util (verify,fingerprint,decryptSecretKey,pgpSign, generateKey, GenerateKeyParams(..)) 131import Data.OpenPGP.Util
132import Data.ByteString.Lazy ( ByteString ) 132import Data.ByteString.Lazy ( ByteString )
133import Text.Show.Pretty as PP ( ppShow ) 133import Text.Show.Pretty as PP ( ppShow )
134import Data.Binary {- decode, decodeOrFail -} 134import Data.Binary {- decode, decodeOrFail -}
@@ -379,6 +379,11 @@ usageFromFilter :: MonadPlus m => KeyFilter -> m String
379usageFromFilter (KF_Match usage) = return usage 379usageFromFilter (KF_Match usage) = return usage
380usageFromFilter _ = mzero 380usageFromFilter _ = mzero
381 381
382
383type PacketTranscoder = (SymmetricAlgorithm,S2K) -> MappedPacket -> IO (KikiCondition Packet)
384
385type PacketDecrypter = MappedPacket -> IO (KikiCondition Packet)
386
382data KeyRingRuntime = KeyRingRuntime 387data KeyRingRuntime = KeyRingRuntime
383 { rtPubring :: FilePath 388 { rtPubring :: FilePath
384 -- ^ Path to the file represented by 'HomePub' 389 -- ^ Path to the file represented by 'HomePub'
@@ -399,7 +404,7 @@ data KeyRingRuntime = KeyRingRuntime
399 -- 'KeyRingFile'. If 'AutoAccess' was specified 404 -- 'KeyRingFile'. If 'AutoAccess' was specified
400 -- for a file, this 'Map.Map' will indicate the 405 -- for a file, this 'Map.Map' will indicate the
401 -- detected value that was used by the algorithm. 406 -- detected value that was used by the algorithm.
402 , rtPassphrases :: MappedPacket -> IO (KikiCondition Packet) 407 , rtPassphrases :: PacketDecrypter
403 } 408 }
404 409
405-- | Roster-entry level actions 410-- | Roster-entry level actions
@@ -418,7 +423,7 @@ data PassphraseSpec = PassphraseSpec
418 -- ^ The passphrase will be read from this file or file descriptor. 423 -- ^ The passphrase will be read from this file or file descriptor.
419 } 424 }
420 -- | Use this to carry pasphrases from a previous run. 425 -- | Use this to carry pasphrases from a previous run.
421 | PassphraseMemoizer (MappedPacket -> IO (KikiCondition Packet)) 426 | PassphraseMemoizer PacketTranscoder
422 427
423instance Show PassphraseSpec where 428instance Show PassphraseSpec where
424 show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c) 429 show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c)
@@ -1442,11 +1447,11 @@ cachedContents maybePrompt ctx fd = do
1442 return pw 1447 return pw
1443 1448
1444generateSubkey :: 1449generateSubkey ::
1445 (MappedPacket -> IO (KikiCondition Packet)) -- decrypt[ 1450 PacketTranscoder
1446 -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db 1451 -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db
1447 -> (GenerateKeyParams, StreamInfo) 1452 -> (GenerateKeyParams, StreamInfo)
1448 -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)])) 1453 -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)]))
1449generateSubkey doDecrypt kd' (genparam,StreamInfo { spill = KF_Match tag }) = do 1454generateSubkey transcode kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
1450 try kd' $ \(kd,report0) -> do 1455 try kd' $ \(kd,report0) -> do
1451 let subs = do 1456 let subs = do
1452 SubKey p sigs <- Map.elems $ keySubKeys kd 1457 SubKey p sigs <- Map.elems $ keySubKeys kd
@@ -1454,6 +1459,7 @@ generateSubkey doDecrypt kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
1454 if null subs 1459 if null subs
1455 then do 1460 then do
1456 newkey <- generateKey genparam 1461 newkey <- generateKey genparam
1462 let doDecrypt = transcode (Unencrypted,S2K 100 "")
1457 kdr <- insertSubkey doDecrypt (keykey (keyPacket kd)) kd [mkUsage tag] "" newkey 1463 kdr <- insertSubkey doDecrypt (keykey (keyPacket kd)) kd [mkUsage tag] "" newkey
1458 try kdr $ \(newkd,report) -> do 1464 try kdr $ \(newkd,report) -> do
1459 return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)]) 1465 return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)])
@@ -1462,7 +1468,7 @@ generateSubkey doDecrypt kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
1462generateSubkey _ kd _ = return kd 1468generateSubkey _ kd _ = return kd
1463 1469
1464importSecretKey :: 1470importSecretKey ::
1465 (MappedPacket -> IO (KikiCondition Packet)) 1471 (PacketDecrypter)
1466 -> KikiCondition 1472 -> KikiCondition
1467 (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]) 1473 (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])
1468 -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t) 1474 -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t)
@@ -1595,7 +1601,7 @@ buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation
1595 {- gpgnames -}[(SockAddr, (KeyKey, KeyKey))], 1601 {- gpgnames -}[(SockAddr, (KeyKey, KeyKey))],
1596 {- outgoing_names -}[SockAddr]) 1602 {- outgoing_names -}[SockAddr])
1597 ,{- accs -} Map.Map InputFile Access 1603 ,{- accs -} Map.Map InputFile Access
1598 ,{- doDecrypt -} MappedPacket -> IO (KikiCondition Packet) 1604 ,{- doDecrypt -} PacketTranscoder
1599 ,{- unspilled -} Map.Map InputFile Message 1605 ,{- unspilled -} Map.Map InputFile Message
1600 ) 1606 )
1601 ,{- report_imports -} [(FilePath,KikiReportAction)])) 1607 ,{- report_imports -} [(FilePath,KikiReportAction)]))
@@ -1675,7 +1681,8 @@ buildKeyDB ctx grip0 keyring = do
1675 accs = fmap (access . fst) ringPackets 1681 accs = fmap (access . fst) ringPackets
1676 return (spilled,mwk,grip,accs,keys,fmap snd unspilled) 1682 return (spilled,mwk,grip,accs,keys,fmap snd unspilled)
1677 1683
1678 doDecrypt <- makeMemoizingDecrypter keyring ctx keys 1684 transcode <- makeMemoizingDecrypter keyring ctx keys
1685 let doDecrypt = transcode (Unencrypted,S2K 100 "")
1679 1686
1680 let wk = fmap packet mwk 1687 let wk = fmap packet mwk
1681 rt0 = KeyRingRuntime { rtPubring = homepubPath ctx 1688 rt0 = KeyRingRuntime { rtPubring = homepubPath ctx
@@ -1758,25 +1765,25 @@ buildKeyDB ctx grip0 keyring = do
1758 where g (Generate _ params,v) = Just (params,v) 1765 where g (Generate _ params,v) = Just (params,v)
1759 g _ = Nothing 1766 g _ = Nothing
1760 1767
1761 db <- generateInternals doDecrypt mwk db gens 1768 db <- generateInternals transcode mwk db gens
1762 try db $ \(db,reportGens) -> do 1769 try db $ \(db,reportGens) -> do
1763 1770
1764 r <- mergeHostFiles keyring db ctx 1771 r <- mergeHostFiles keyring db ctx
1765 try r $ \((db,hs),reportHosts) -> do 1772 try r $ \((db,hs),reportHosts) -> do
1766 1773
1767 return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled) 1774 return $ KikiSuccess ( (db, grip, mwk, hs, accs, transcode, unspilled)
1768 , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts ) 1775 , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts )
1769 1776
1770generateInternals :: 1777generateInternals ::
1771 (MappedPacket -> IO (KikiCondition Packet)) 1778 PacketTranscoder
1772 -> Maybe MappedPacket 1779 -> Maybe MappedPacket
1773 -> Map.Map KeyKey KeyData 1780 -> Map.Map KeyKey KeyData
1774 -> [(GenerateKeyParams,StreamInfo)] 1781 -> [(GenerateKeyParams,StreamInfo)]
1775 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) 1782 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
1776generateInternals doDecrypt mwk db gens = do 1783generateInternals transcode mwk db gens = do
1777 case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) db of 1784 case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) db of
1778 Just kd0 -> do 1785 Just kd0 -> do
1779 kd <- foldM (generateSubkey doDecrypt) (KikiSuccess (kd0,[])) gens 1786 kd <- foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens
1780 try kd $ \(kd,reportGens) -> do 1787 try kd $ \(kd,reportGens) -> do
1781 let kk = keykey $ packet $ fromJust mwk 1788 let kk = keykey $ packet $ fromJust mwk
1782 return $ KikiSuccess (Map.insert kk kd db,reportGens) 1789 return $ KikiSuccess (Map.insert kk kd db,reportGens)
@@ -2003,7 +2010,7 @@ readSecretPEMFile fname = do
2003 return $ dta 2010 return $ dta
2004 2011
2005doImport 2012doImport
2006 :: (MappedPacket -> IO (KikiCondition Packet)) 2013 :: (PacketDecrypter)
2007 -> Map.Map KeyKey KeyData 2014 -> Map.Map KeyKey KeyData
2008 -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t) 2015 -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t)
2009 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) 2016 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
@@ -2046,7 +2053,7 @@ doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do
2046 return $ KikiSuccess (db',report++report') 2053 return $ KikiSuccess (db',report++report')
2047 2054
2048doImportG 2055doImportG
2049 :: (MappedPacket -> IO (KikiCondition Packet)) 2056 :: (PacketDecrypter)
2050 -> Map.Map KeyKey KeyData 2057 -> Map.Map KeyKey KeyData
2051 -> [KeyKey] -- m0, only head is used 2058 -> [KeyKey] -- m0, only head is used
2052 -> [SignatureSubpacket] -- tags 2059 -> [SignatureSubpacket] -- tags
@@ -2478,7 +2485,7 @@ writeKeyToFile StreamInfo { typ = DNSPresentation } fname packet = do
2478 return [(fname, ExportedSubkey)] 2485 return [(fname, ExportedSubkey)]
2479 algo -> return [(fname, UnableToExport algo $ fingerprint packet)] 2486 algo -> return [(fname, UnableToExport algo $ fingerprint packet)]
2480 2487
2481writePEMKeys :: (MappedPacket -> IO (KikiCondition Packet)) 2488writePEMKeys :: (PacketDecrypter)
2482 -> KeyDB 2489 -> KeyDB
2483 -> [(FilePath,Maybe String,[MappedPacket],StreamInfo)] 2490 -> [(FilePath,Maybe String,[MappedPacket],StreamInfo)]
2484 -> IO (KikiCondition [(FilePath,KikiReportAction)]) 2491 -> IO (KikiCondition [(FilePath,KikiReportAction)])
@@ -2502,8 +2509,8 @@ writePEMKeys doDecrypt db exports = do
2502 2509
2503makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext 2510makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext
2504 -> Map.Map KeyKey MappedPacket 2511 -> Map.Map KeyKey MappedPacket
2505 -> IO (MappedPacket -> IO (KikiCondition Packet)) 2512 -> IO PacketTranscoder
2506makeMemoizingDecrypter operation ctx keys = 2513makeMemoizingDecrypter operation ctx keys = do
2507 if null chains then do 2514 if null chains then do
2508 -- (*) Notice we do not pass ctx to resolveForReport. 2515 -- (*) Notice we do not pass ctx to resolveForReport.
2509 -- This is because the merge function does not currently use a context 2516 -- This is because the merge function does not currently use a context
@@ -2518,7 +2525,7 @@ makeMemoizingDecrypter operation ctx keys =
2518 $ Map.filter (isJust . pwfile . typ) $ opFiles operation) 2525 $ Map.filter (isJust . pwfile . typ) $ opFiles operation)
2519 -} 2526 -}
2520 let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n" 2527 let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n"
2521 pws2 <- 2528 pws2 <-
2522 Traversable.mapM (cachedContents prompt ctx) 2529 Traversable.mapM (cachedContents prompt ctx)
2523 $ Map.fromList $ mapMaybe 2530 $ Map.fromList $ mapMaybe
2524 (\spec -> (,passSpecPassFile spec) `fmap` do 2531 (\spec -> (,passSpecPassFile spec) `fmap` do
@@ -2541,9 +2548,10 @@ makeMemoizingDecrypter operation ctx keys =
2541 doDecrypt :: IORef (Map.Map KeyKey Packet) 2548 doDecrypt :: IORef (Map.Map KeyKey Packet)
2542 -> Map.Map FilePath (IO S.ByteString) 2549 -> Map.Map FilePath (IO S.ByteString)
2543 -> Maybe (IO S.ByteString) 2550 -> Maybe (IO S.ByteString)
2551 -> (SymmetricAlgorithm,S2K)
2544 -> MappedPacket 2552 -> MappedPacket
2545 -> IO (KikiCondition Packet) 2553 -> IO (KikiCondition Packet)
2546 doDecrypt unkeysRef pws defpw mp0 = do 2554 doDecrypt unkeysRef pws defpw (dest_alg,dest_s2k) mp0 = do
2547 unkeys <- readIORef unkeysRef 2555 unkeys <- readIORef unkeysRef
2548 let mp = fromMaybe mp0 $ do 2556 let mp = fromMaybe mp0 $ do
2549 k <- Map.lookup kk keys 2557 k <- Map.lookup kk keys
@@ -2562,19 +2570,23 @@ makeMemoizingDecrypter operation ctx keys =
2562 case symmetric_algorithm wkun of 2570 case symmetric_algorithm wkun of
2563 Unencrypted -> do 2571 Unencrypted -> do
2564 writeIORef unkeysRef (Map.insert kk wkun unkeys) 2572 writeIORef unkeysRef (Map.insert kk wkun unkeys)
2565 return $ KikiSuccess wkun 2573 ek <- encryptSecretKey pw dest_s2k dest_alg wkun
2566 _ -> decryptIt getpws 2574 case ek of
2575 Nothing -> return $ BadPassphrase
2576 Just wken -> return $ KikiSuccess wken
2577 _ -> decryptIt getpws
2567 2578
2568 getpws = mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw 2579 getpws = mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw
2569 2580
2570 case symmetric_algorithm wk of 2581 if symmetric_algorithm wk == dest_alg
2571 Unencrypted -> return (KikiSuccess wk) 2582 && ( symmetric_algorithm wk == Unencrypted || s2k wk == dest_s2k )
2572 _ -> maybe (decryptIt getpws) 2583 then return (KikiSuccess wk)
2584 else maybe (decryptIt getpws)
2573 (return . KikiSuccess) 2585 (return . KikiSuccess)
2574 $ Map.lookup kk unkeys 2586 $ Map.lookup kk unkeys
2575 2587
2576performManipulations :: 2588performManipulations ::
2577 (MappedPacket -> IO (KikiCondition Packet)) 2589 (PacketDecrypter)
2578 -> KeyRingRuntime 2590 -> KeyRingRuntime
2579 -> Maybe MappedPacket 2591 -> Maybe MappedPacket
2580 -> (KeyRingRuntime -> KeyData -> [PacketUpdate]) 2592 -> (KeyRingRuntime -> KeyData -> [PacketUpdate])
@@ -2647,14 +2659,15 @@ initializeMissingPEMFiles ::
2647 -> InputFileContext 2659 -> InputFileContext
2648 -> Maybe String 2660 -> Maybe String
2649 -> Maybe MappedPacket 2661 -> Maybe MappedPacket
2650 -> (MappedPacket -> IO (KikiCondition Packet)) 2662 -> PacketTranscoder
2651 -> KeyDB 2663 -> KeyDB
2652 -> IO (KikiCondition ( (KeyDB,[( FilePath 2664 -> IO (KikiCondition ( (KeyDB,[( FilePath
2653 , Maybe String 2665 , Maybe String
2654 , [MappedPacket] 2666 , [MappedPacket]
2655 , StreamInfo )]) 2667 , StreamInfo )])
2656 , [(FilePath,KikiReportAction)])) 2668 , [(FilePath,KikiReportAction)]))
2657initializeMissingPEMFiles operation ctx grip mwk decrypt db = do 2669initializeMissingPEMFiles operation ctx grip mwk transcode db = do
2670 let decrypt = transcode (Unencrypted,S2K 100 "")
2658 nonexistents <- 2671 nonexistents <-
2659 filterM (fmap not . doesFileExist . fst) 2672 filterM (fmap not . doesFileExist . fst)
2660 $ do (f,t) <- Map.toList (opFiles operation) 2673 $ do (f,t) <- Map.toList (opFiles operation)
@@ -2731,7 +2744,7 @@ initializeMissingPEMFiles operation ctx grip mwk decrypt db = do
2731 , spill = KF_Match tag } = Just tag 2744 , spill = KF_Match tag } = Just tag
2732 internalInitializer _ = Nothing 2745 internalInitializer _ = Nothing
2733 2746
2734 v <- generateInternals decrypt mwk db internals 2747 v <- generateInternals transcode mwk db internals
2735 2748
2736 try v $ \(db,internals_rs) -> do 2749 try v $ \(db,internals_rs) -> do
2737 2750
@@ -2930,17 +2943,18 @@ runKeyRing operation = do
2930 2943
2931 -- merge all keyrings, PEM files, and wallets 2944 -- merge all keyrings, PEM files, and wallets
2932 bresult <- buildKeyDB ctx grip0 operation 2945 bresult <- buildKeyDB ctx grip0 operation
2933 try' bresult $ \((db,grip,wk,hs,accs,decrypt,unspilled),report_imports) -> do 2946 try' bresult $ \((db,grip,wk,hs,accs,transcode,unspilled),report_imports) -> do
2934 2947
2935 externals_ret <- initializeMissingPEMFiles operation 2948 externals_ret <- initializeMissingPEMFiles operation
2936 ctx 2949 ctx
2937 grip 2950 grip
2938 wk 2951 wk
2939 decrypt 2952 transcode
2940 db 2953 db
2941 try' externals_ret $ \((db,exports),report_externals) -> do 2954 try' externals_ret $ \((db,exports),report_externals) -> do
2942 2955
2943 let rt = KeyRingRuntime 2956 let decrypt = transcode (Unencrypted,S2K 100 "")
2957 rt = KeyRingRuntime
2944 { rtPubring = homepubPath ctx 2958 { rtPubring = homepubPath ctx
2945 , rtSecring = homesecPath ctx 2959 , rtSecring = homesecPath ctx
2946 , rtGrip = grip 2960 , rtGrip = grip
@@ -3276,7 +3290,7 @@ mkUsage tag = NotationDataPacket
3276 } 3290 }
3277 3291
3278makeSig :: 3292makeSig ::
3279 (MappedPacket -> IO (KikiCondition Packet)) 3293 (PacketDecrypter)
3280 -> MappedPacket 3294 -> MappedPacket
3281 -> [Char] 3295 -> [Char]
3282 -> MappedPacket 3296 -> MappedPacket
diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index bdf8932..3bc6330 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -351,6 +351,7 @@ refreshCache rt rootdir = do
351 ipsecs :: [Packet] 351 ipsecs :: [Packet]
352 ipsecs = sortOn (Down . timestamp) 352 ipsecs = sortOn (Down . timestamp)
353 $ getSubkeys CrossSigned their_master (keySubKeys kd) "ipsec" 353 $ getSubkeys CrossSigned their_master (keySubKeys kd) "ipsec"
354 ++ getSubkeys CrossSigned their_master (keySubKeys kd) "strongswan"
354 bss <- forM (take 1 ipsecs) $ \k -> do 355 bss <- forM (take 1 ipsecs) $ \k -> do
355 let warn' x = warn x >> return Char8.empty 356 let warn' x = warn x >> return Char8.empty
356 flip (either warn') (pemFromPacket k :: Either String String) $ \pem -> do 357 flip (either warn') (pemFromPacket k :: Either String String) $ \pem -> do