From aea085761eeaeb0debc1373aeb7edee25c3120a5 Mon Sep 17 00:00:00 2001 From: joe Date: Thu, 25 Aug 2016 02:37:17 -0400 Subject: Progress toward encrypting keys. --- lib/KeyRing.hs | 80 ++++++++++++++++++++++++++++++++++------------------------ 1 file changed, 47 insertions(+), 33 deletions(-) (limited to 'lib/KeyRing.hs') 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 ( (.|.), (.&.) ) import Control.Applicative ( Applicative, pure, liftA2, (<*>) ) import System.Directory ( getHomeDirectory, doesFileExist, createDirectoryIfMissing ) import Control.Arrow ( first, second ) -import Data.OpenPGP.Util (verify,fingerprint,decryptSecretKey,pgpSign, generateKey, GenerateKeyParams(..)) +import Data.OpenPGP.Util import Data.ByteString.Lazy ( ByteString ) import Text.Show.Pretty as PP ( ppShow ) import Data.Binary {- decode, decodeOrFail -} @@ -379,6 +379,11 @@ usageFromFilter :: MonadPlus m => KeyFilter -> m String usageFromFilter (KF_Match usage) = return usage usageFromFilter _ = mzero + +type PacketTranscoder = (SymmetricAlgorithm,S2K) -> MappedPacket -> IO (KikiCondition Packet) + +type PacketDecrypter = MappedPacket -> IO (KikiCondition Packet) + data KeyRingRuntime = KeyRingRuntime { rtPubring :: FilePath -- ^ Path to the file represented by 'HomePub' @@ -399,7 +404,7 @@ data KeyRingRuntime = KeyRingRuntime -- 'KeyRingFile'. If 'AutoAccess' was specified -- for a file, this 'Map.Map' will indicate the -- detected value that was used by the algorithm. - , rtPassphrases :: MappedPacket -> IO (KikiCondition Packet) + , rtPassphrases :: PacketDecrypter } -- | Roster-entry level actions @@ -418,7 +423,7 @@ data PassphraseSpec = PassphraseSpec -- ^ The passphrase will be read from this file or file descriptor. } -- | Use this to carry pasphrases from a previous run. - | PassphraseMemoizer (MappedPacket -> IO (KikiCondition Packet)) + | PassphraseMemoizer PacketTranscoder instance Show PassphraseSpec where show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c) @@ -1442,11 +1447,11 @@ cachedContents maybePrompt ctx fd = do return pw generateSubkey :: - (MappedPacket -> IO (KikiCondition Packet)) -- decrypt[ + PacketTranscoder -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db -> (GenerateKeyParams, StreamInfo) -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)])) -generateSubkey doDecrypt kd' (genparam,StreamInfo { spill = KF_Match tag }) = do +generateSubkey transcode kd' (genparam,StreamInfo { spill = KF_Match tag }) = do try kd' $ \(kd,report0) -> do let subs = do SubKey p sigs <- Map.elems $ keySubKeys kd @@ -1454,6 +1459,7 @@ generateSubkey doDecrypt kd' (genparam,StreamInfo { spill = KF_Match tag }) = do if null subs then do newkey <- generateKey genparam + let doDecrypt = transcode (Unencrypted,S2K 100 "") kdr <- insertSubkey doDecrypt (keykey (keyPacket kd)) kd [mkUsage tag] "" newkey try kdr $ \(newkd,report) -> do return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)]) @@ -1462,7 +1468,7 @@ generateSubkey doDecrypt kd' (genparam,StreamInfo { spill = KF_Match tag }) = do generateSubkey _ kd _ = return kd importSecretKey :: - (MappedPacket -> IO (KikiCondition Packet)) + (PacketDecrypter) -> KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]) -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t) @@ -1595,7 +1601,7 @@ buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation {- gpgnames -}[(SockAddr, (KeyKey, KeyKey))], {- outgoing_names -}[SockAddr]) ,{- accs -} Map.Map InputFile Access - ,{- doDecrypt -} MappedPacket -> IO (KikiCondition Packet) + ,{- doDecrypt -} PacketTranscoder ,{- unspilled -} Map.Map InputFile Message ) ,{- report_imports -} [(FilePath,KikiReportAction)])) @@ -1675,7 +1681,8 @@ buildKeyDB ctx grip0 keyring = do accs = fmap (access . fst) ringPackets return (spilled,mwk,grip,accs,keys,fmap snd unspilled) - doDecrypt <- makeMemoizingDecrypter keyring ctx keys + transcode <- makeMemoizingDecrypter keyring ctx keys + let doDecrypt = transcode (Unencrypted,S2K 100 "") let wk = fmap packet mwk rt0 = KeyRingRuntime { rtPubring = homepubPath ctx @@ -1758,25 +1765,25 @@ buildKeyDB ctx grip0 keyring = do where g (Generate _ params,v) = Just (params,v) g _ = Nothing - db <- generateInternals doDecrypt mwk db gens + db <- generateInternals transcode mwk db gens try db $ \(db,reportGens) -> do r <- mergeHostFiles keyring db ctx try r $ \((db,hs),reportHosts) -> do - return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled) + return $ KikiSuccess ( (db, grip, mwk, hs, accs, transcode, unspilled) , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts ) generateInternals :: - (MappedPacket -> IO (KikiCondition Packet)) + PacketTranscoder -> Maybe MappedPacket -> Map.Map KeyKey KeyData -> [(GenerateKeyParams,StreamInfo)] -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) -generateInternals doDecrypt mwk db gens = do +generateInternals transcode mwk db gens = do case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) db of Just kd0 -> do - kd <- foldM (generateSubkey doDecrypt) (KikiSuccess (kd0,[])) gens + kd <- foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens try kd $ \(kd,reportGens) -> do let kk = keykey $ packet $ fromJust mwk return $ KikiSuccess (Map.insert kk kd db,reportGens) @@ -2003,7 +2010,7 @@ readSecretPEMFile fname = do return $ dta doImport - :: (MappedPacket -> IO (KikiCondition Packet)) + :: (PacketDecrypter) -> Map.Map KeyKey KeyData -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t) -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) @@ -2046,7 +2053,7 @@ doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do return $ KikiSuccess (db',report++report') doImportG - :: (MappedPacket -> IO (KikiCondition Packet)) + :: (PacketDecrypter) -> Map.Map KeyKey KeyData -> [KeyKey] -- m0, only head is used -> [SignatureSubpacket] -- tags @@ -2478,7 +2485,7 @@ writeKeyToFile StreamInfo { typ = DNSPresentation } fname packet = do return [(fname, ExportedSubkey)] algo -> return [(fname, UnableToExport algo $ fingerprint packet)] -writePEMKeys :: (MappedPacket -> IO (KikiCondition Packet)) +writePEMKeys :: (PacketDecrypter) -> KeyDB -> [(FilePath,Maybe String,[MappedPacket],StreamInfo)] -> IO (KikiCondition [(FilePath,KikiReportAction)]) @@ -2502,8 +2509,8 @@ writePEMKeys doDecrypt db exports = do makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext -> Map.Map KeyKey MappedPacket - -> IO (MappedPacket -> IO (KikiCondition Packet)) -makeMemoizingDecrypter operation ctx keys = + -> IO PacketTranscoder +makeMemoizingDecrypter operation ctx keys = do if null chains then do -- (*) Notice we do not pass ctx to resolveForReport. -- This is because the merge function does not currently use a context @@ -2518,7 +2525,7 @@ makeMemoizingDecrypter operation ctx keys = $ Map.filter (isJust . pwfile . typ) $ opFiles operation) -} let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n" - pws2 <- + pws2 <- Traversable.mapM (cachedContents prompt ctx) $ Map.fromList $ mapMaybe (\spec -> (,passSpecPassFile spec) `fmap` do @@ -2541,9 +2548,10 @@ makeMemoizingDecrypter operation ctx keys = doDecrypt :: IORef (Map.Map KeyKey Packet) -> Map.Map FilePath (IO S.ByteString) -> Maybe (IO S.ByteString) + -> (SymmetricAlgorithm,S2K) -> MappedPacket -> IO (KikiCondition Packet) - doDecrypt unkeysRef pws defpw mp0 = do + doDecrypt unkeysRef pws defpw (dest_alg,dest_s2k) mp0 = do unkeys <- readIORef unkeysRef let mp = fromMaybe mp0 $ do k <- Map.lookup kk keys @@ -2562,19 +2570,23 @@ makeMemoizingDecrypter operation ctx keys = case symmetric_algorithm wkun of Unencrypted -> do writeIORef unkeysRef (Map.insert kk wkun unkeys) - return $ KikiSuccess wkun - _ -> decryptIt getpws + ek <- encryptSecretKey pw dest_s2k dest_alg wkun + case ek of + Nothing -> return $ BadPassphrase + Just wken -> return $ KikiSuccess wken + _ -> decryptIt getpws getpws = mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw - case symmetric_algorithm wk of - Unencrypted -> return (KikiSuccess wk) - _ -> maybe (decryptIt getpws) + if symmetric_algorithm wk == dest_alg + && ( symmetric_algorithm wk == Unencrypted || s2k wk == dest_s2k ) + then return (KikiSuccess wk) + else maybe (decryptIt getpws) (return . KikiSuccess) $ Map.lookup kk unkeys performManipulations :: - (MappedPacket -> IO (KikiCondition Packet)) + (PacketDecrypter) -> KeyRingRuntime -> Maybe MappedPacket -> (KeyRingRuntime -> KeyData -> [PacketUpdate]) @@ -2647,14 +2659,15 @@ initializeMissingPEMFiles :: -> InputFileContext -> Maybe String -> Maybe MappedPacket - -> (MappedPacket -> IO (KikiCondition Packet)) + -> PacketTranscoder -> KeyDB -> IO (KikiCondition ( (KeyDB,[( FilePath , Maybe String , [MappedPacket] , StreamInfo )]) , [(FilePath,KikiReportAction)])) -initializeMissingPEMFiles operation ctx grip mwk decrypt db = do +initializeMissingPEMFiles operation ctx grip mwk transcode db = do + let decrypt = transcode (Unencrypted,S2K 100 "") nonexistents <- filterM (fmap not . doesFileExist . fst) $ do (f,t) <- Map.toList (opFiles operation) @@ -2731,7 +2744,7 @@ initializeMissingPEMFiles operation ctx grip mwk decrypt db = do , spill = KF_Match tag } = Just tag internalInitializer _ = Nothing - v <- generateInternals decrypt mwk db internals + v <- generateInternals transcode mwk db internals try v $ \(db,internals_rs) -> do @@ -2930,17 +2943,18 @@ runKeyRing operation = do -- merge all keyrings, PEM files, and wallets bresult <- buildKeyDB ctx grip0 operation - try' bresult $ \((db,grip,wk,hs,accs,decrypt,unspilled),report_imports) -> do + try' bresult $ \((db,grip,wk,hs,accs,transcode,unspilled),report_imports) -> do externals_ret <- initializeMissingPEMFiles operation ctx grip wk - decrypt + transcode db try' externals_ret $ \((db,exports),report_externals) -> do - let rt = KeyRingRuntime + let decrypt = transcode (Unencrypted,S2K 100 "") + rt = KeyRingRuntime { rtPubring = homepubPath ctx , rtSecring = homesecPath ctx , rtGrip = grip @@ -3276,7 +3290,7 @@ mkUsage tag = NotationDataPacket } makeSig :: - (MappedPacket -> IO (KikiCondition Packet)) + (PacketDecrypter) -> MappedPacket -> [Char] -> MappedPacket -- cgit v1.2.3