From 067c3647ed02c24c08b17803e28679e69d2e6dd9 Mon Sep 17 00:00:00 2001 From: joe Date: Thu, 25 Aug 2016 20:58:38 -0400 Subject: Implemented key encryption. --- lib/KeyRing.hs | 53 ++++++++++++++++++++++++++++++++--------------------- 1 file changed, 32 insertions(+), 21 deletions(-) (limited to 'lib/KeyRing.hs') diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs index 4e83d80..bc881f2 100644 --- a/lib/KeyRing.hs +++ b/lib/KeyRing.hs @@ -110,6 +110,7 @@ module KeyRing , writeKeyToFile , resolveForReport , KeyKey -- needed for Type sigs + , makeMemoizingDecrypter ) where import System.Environment @@ -405,7 +406,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 :: PacketDecrypter + , rtPassphrases :: PacketTranscoder } -- | Roster-entry level actions @@ -1460,8 +1461,7 @@ generateSubkey transcode 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 + kdr <- insertSubkey transcode (keykey (keyPacket kd)) kd [mkUsage tag] "" newkey try kdr $ \(newkd,report) -> do return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)]) else do @@ -1469,14 +1469,14 @@ generateSubkey transcode kd' (genparam,StreamInfo { spill = KF_Match tag }) = do generateSubkey _ kd _ = return kd importSecretKey :: - (PacketDecrypter) + (PacketTranscoder) -> KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]) -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t) -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) -importSecretKey doDecrypt db' tup = do +importSecretKey transcode db' tup = do try db' $ \(db',report0) -> do - r <- doImport doDecrypt + r <- doImport transcode db' tup try r $ \(db'',report) -> do @@ -1692,7 +1692,7 @@ buildKeyDB ctx grip0 keyring = do , rtWorkingKey = wk , rtRingAccess = accs , rtKeyDB = Map.empty - , rtPassphrases = doDecrypt + , rtPassphrases = transcode } -- autosigns and deletes transformed0 <- @@ -1723,7 +1723,7 @@ buildKeyDB ctx grip0 keyring = do -- Wallets let importWalletKey wk db' (top,fname,sub,tag) = do try db' $ \(db',report0) -> do - r <- doImportG doDecrypt + r <- doImportG transcode db' (fmap keykey $ maybeToList wk) [mkUsage tag] @@ -1739,6 +1739,7 @@ buildKeyDB ctx grip0 keyring = do (_,sub,(_,m)) <- xs (tag,top) <- Map.toList m return (top,fname,sub,tag) + db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys try db $ \(db,reportWallets) -> do @@ -1758,7 +1759,7 @@ buildKeyDB ctx grip0 keyring = do cmd = initializer stream return (n,subspec,ms,stream, cmd) imports <- filterM (\(n,_,_,_,_) -> doesFileExist n) pems - db <- foldM (importSecretKey doDecrypt) (KikiSuccess (db,[])) imports + db <- foldM (importSecretKey transcode) (KikiSuccess (db,[])) imports try db $ \(db,reportPEMs) -> do -- generate keys @@ -2011,11 +2012,11 @@ readSecretPEMFile fname = do return $ dta doImport - :: (PacketDecrypter) + :: PacketTranscoder -> Map.Map KeyKey KeyData -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t) -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) -doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do +doImport transcode db (fname,subspec,ms,typ -> typ,_) = do flip (maybe $ return CannotImportMasterKey) subspec $ \tag -> do (certs,keys) <- case typ of @@ -2049,26 +2050,31 @@ doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do , notation_value = Char8.unpack bs } datedKey = key { timestamp = fromTime $ minimum dates } dates = fromTime (timestamp key) : map pcertTimestamp certs - r <- doImportG doDecrypt db m0 (mkUsage tag:blobs) fname datedKey + r <- doImportG transcode db m0 (mkUsage tag:blobs) fname datedKey try r $ \(db',report') -> do return $ KikiSuccess (db',report++report') doImportG - :: (PacketDecrypter) + :: PacketTranscoder -> Map.Map KeyKey KeyData -> [KeyKey] -- m0, only head is used -> [SignatureSubpacket] -- tags -> FilePath -> Packet -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) -doImportG doDecrypt db m0 tags fname key = do +doImportG transcode db m0 tags fname key = do let kk = head m0 Just kd@(KeyData top topsigs uids subs) = Map.lookup kk db - kdr <- insertSubkey doDecrypt kk kd tags fname key + kdr <- insertSubkey transcode kk kd tags fname key try kdr $ \(kd',rrs) -> return $ KikiSuccess (Map.insert kk kd' db, rrs) -insertSubkey doDecrypt kk (KeyData top topsigs uids subs) tags fname key = do +insertSubkey transcode kk (KeyData top topsigs uids subs) tags fname key0 = do + let topcipher = symmetric_algorithm $ packet top + tops2k = s2k $ packet top + key' <- transcode (topcipher,tops2k) $ mappedPacket "" key0 + try key' $ \key -> do let subkk = keykey key + doDecrypt = transcode (Unencrypted,S2K 100 "") (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key) []) ( (False,) . addOrigin ) @@ -2123,7 +2129,9 @@ insertSubkey doDecrypt kk (KeyData top topsigs uids subs) tags fname key = do (xs',minsig,ys') = findTag tags wk key subsigs doInsert mbsig = do -- NEW SUBKEY BINDING SIGNATURE - sig' <- makeSig doDecrypt top fname subkey_p tags mbsig + -- XXX: Here I assume that key0 is the unencrypted version + -- of subkey_p. TODO: Check this assumption. + sig' <- makeSig doDecrypt top fname subkey_p{packet=key0} tags mbsig try sig' $ \(sig',report) -> do report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)] let subs' = Map.insert subkk @@ -2567,7 +2575,9 @@ makeMemoizingDecrypter operation ctx keys = do -- combine the packet with it's unspilled version before -- attempting to decrypt it. pw <- getpw - let wkun = fromMaybe wk $ decryptSecretKey pw (packet mp) + let wkun = fromMaybe wk $ do + guard $ symmetric_algorithm (packet mp) /= Unencrypted + decryptSecretKey pw (packet mp) case symmetric_algorithm wkun of Unencrypted -> do writeIORef unkeysRef (Map.insert kk wkun unkeys) @@ -2723,7 +2733,7 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do ExitFailure num -> return (tup,FailedExternal num) ExitSuccess -> return (tup,ExternallyGeneratedFile) - v <- foldM (importSecretKey decrypt) + v <- foldM (importSecretKey transcode) (KikiSuccess (db,[])) $ do ((f,subspec,ms,stream,cmd),r) <- rs guard $ case r of @@ -2964,7 +2974,7 @@ runKeyRing operation = do , rtWorkingKey = fmap packet wk , rtKeyDB = db , rtRingAccess = accs - , rtPassphrases = decrypt + , rtPassphrases = transcode } -- Maybe add signatures, delete subkeys @@ -3171,11 +3181,12 @@ readPacketsFromWallet wk fname = do timestamp <- getInputFileTime ctx fname input <- readInputFileL ctx fname let (ks,_) = slurpWIPKeys timestamp input + {- unless (null ks) $ do -- decrypt wk -- create sigs -- return key/sig pairs - return () + return () -} return $ do wk <- maybeToList wk guard (not $ null ks) -- cgit v1.2.3