From 92c2d5cc27781cb20cb3c1264ba405aa74a822c3 Mon Sep 17 00:00:00 2001 From: joe Date: Fri, 2 May 2014 13:41:33 -0400 Subject: Now supports unspillable keyrings. --- KeyRing.hs | 105 ++++++++++++++++++++++++++++++++++++------------------------- 1 file changed, 62 insertions(+), 43 deletions(-) diff --git a/KeyRing.hs b/KeyRing.hs index 3eba3de..c79de9f 100644 --- a/KeyRing.hs +++ b/KeyRing.hs @@ -1069,8 +1069,7 @@ writeHostsFiles krd ctx (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do return $ concat rss -buildKeyDB :: (MappedPacket -> IO (KikiCondition Packet)) - -> InputFileContext -> Maybe String -> KeyRingOperation +buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation -> IO (KikiCondition ((KeyDB ,Maybe String ,Maybe MappedPacket @@ -1080,9 +1079,11 @@ buildKeyDB :: (MappedPacket -> IO (KikiCondition Packet)) [(SockAddr, (KeyKey, KeyKey))], [SockAddr]) ,Map.Map FilePath Access + ,MappedPacket -> IO (KikiCondition Packet) + ,Map.Map InputFile Message ) ,[(FilePath,KikiReportAction)])) -buildKeyDB doDecrypt ctx grip0 keyring = do +buildKeyDB ctx grip0 keyring = do let files isring = do (f,stream) <- Map.toList (kFiles keyring) @@ -1104,19 +1105,8 @@ buildKeyDB doDecrypt ctx grip0 keyring = do readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n)) - importWalletKey wk db' (top,fname,sub,tag) = do - try db' $ \(db',report0) -> do - r <- doImportG doDecrypt - db' - (fmap keykey $ maybeToList wk) - tag - fname - sub - try r $ \(db'',report) -> do - return $ KikiSuccess (db'', report0 ++ report) - -- KeyRings (todo: KikiCondition reporting?) - (db_rings,mwk,grip,accs) <- do + (db_rings,mwk,grip,accs,keys,unspilled) <- do ringPackets <- Map.traverseWithKey readp ringMap let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message) @@ -1126,20 +1116,44 @@ buildKeyDB doDecrypt ctx grip0 keyring = do (_,Message ps) <- Map.lookup HomeSec ringPackets listToMaybe ps (spilled,unspilled) = Map.partition (spillable . fst) ringPackets - db_rings = Map.foldlWithKey mergeIt Map.empty ringPackets + db_rings = Map.foldlWithKey mergeIt Map.empty spilled where mergeIt db f (_,ps) = merge db f ps + keys :: Map.Map KeyKey MappedPacket + keys = Map.foldl slurpkeys Map.empty + $ Map.mapWithKey filterSecrets ringPackets + where isSecretKey (SecretKeyPacket {}) = True + isSecretKey _ = False + filterSecrets f (_,Message ps) = + filter (isSecretKey . packet) + $ zipWith (mappedPacketWithHint fname) ps [1..] + where fname = resolveForReport (Just ctx) f + slurpkeys m ps = m `Map.union` Map.fromList ps' + where ps' = zip (map (keykey . packet) ps) ps wk = listToMaybe $ do fp <- maybeToList grip - (kk,kd) <- Map.toList db_rings - guard $ matchSpec (KeyGrip fp) (kk,kd) - return $ keyMappedPacket kd + let matchfp mp = not (is_subkey p) && matchpr fp p == fp + where p = packet mp + Map.elems $ Map.filter matchfp keys accs = Map.mapKeys (concat . resolveInputFile ctx) $ fmap (access . fst) ringPackets - return (db_rings,wk,grip,accs) + return (db_rings,wk,grip,accs,keys,fmap snd unspilled) + + doDecrypt <- makeMemoizingDecrypter keyring ctx keys let wk = fmap packet mwk -- Wallets + let importWalletKey wk db' (top,fname,sub,tag) = do + try db' $ \(db',report0) -> do + r <- doImportG doDecrypt + db' + (fmap keykey $ maybeToList wk) + tag + fname + sub + try r $ \(db'',report) -> do + return $ KikiSuccess (db'', report0 ++ report) + wms <- mapM (readw wk) (files iswallet) let wallet_keys = do maybeToList wk @@ -1171,7 +1185,8 @@ buildKeyDB doDecrypt ctx grip0 keyring = do r <- mergeHostFiles keyring db ctx try r $ \((db,hs),reportHosts) -> do - return $ KikiSuccess ( (db, grip, mwk, hs, accs), reportWallets ++ reportPEMs ) + return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled) + , reportWallets ++ reportPEMs ) torhash :: Packet -> String torhash key = fromMaybe "" $ derToBase32 <$> derRSA key @@ -1465,13 +1480,13 @@ isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk guard $ matchSpec (KeyGrip fp) elm return $ keyPacket (snd elm) -writeRingKeys :: KeyRingOperation -> KeyRingRuntime +writeRingKeys :: KeyRingOperation -> KeyRingRuntime -> Map.Map InputFile Message {- -> KeyDB -> Maybe Packet -> FilePath -> FilePath -} -> IO (KikiCondition [(FilePath,KikiReportAction)]) -writeRingKeys krd rt {- db wk secring pubring -} = do +writeRingKeys krd rt {- db wk secring pubring -} unspilled = do let isring (KeyRingFile {}) = True isring _ = False db = rtKeyDB rt @@ -1484,7 +1499,10 @@ writeRingKeys krd rt {- db wk secring pubring -} = do guard (isring $ typ stream) f <- resolveInputFile ctx f0 return (f,f0,stream) - let x = do + let db' = fromMaybe db $ do + msg <- Map.lookup f0 unspilled + return $ merge db f0 msg + x = do let wantedForFill :: Access -> KeyFilter -> KeyData -> Maybe Bool wantedForFill acc KF_None = importByExistingMaster -- Note the KF_None case is almost irrelevent as it will be @@ -1504,7 +1522,7 @@ writeRingKeys krd rt {- db wk secring pubring -} = do (error $ f ++ ": write public or secret key to file?") importByExistingMaster kd@(KeyData p _ _ _) = fmap originallyPublic $ Map.lookup f $ locations p - d <- sortByHint f keyMappedPacket (Map.elems db) + d <- sortByHint f keyMappedPacket (Map.elems db') acc <- maybeToList $ Map.lookup f (rtRingAccess rt) only_public <- maybeToList $ wantedForFill acc (fill stream) d case fill stream of @@ -1640,8 +1658,9 @@ writePEMKeys doDecrypt db exports = do return $ KikiSuccess (fname,pun) makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext + -> Map.Map KeyKey MappedPacket -> IO (MappedPacket -> IO (KikiCondition Packet)) -makeMemoizingDecrypter operation ctx = do +makeMemoizingDecrypter operation ctx keys = do -- (*) Notice we do not pass ctx to resolveForReport. -- This is because the merge function does not currently use a context -- and the pws map keys must match the MappedPacket locations. @@ -1664,10 +1683,7 @@ makeMemoizingDecrypter operation ctx = do $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp) && isNothing (passSpecKeySpec sp)) $ kPassphrases operation - unkeysRef <- newIORef Map.empty - -- TODO: - -- Use buildKeyDB on unspilled files to create an unspillable KeyDB. - -- This KeyDB should be used later by decryptIt. + unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet) return $ doDecrypt unkeysRef (pws `Map.union` pws2) defpw where doDecrypt :: IORef (Map.Map KeyKey Packet) @@ -1675,9 +1691,12 @@ makeMemoizingDecrypter operation ctx = do -> Maybe (IO S.ByteString) -> MappedPacket -> IO (KikiCondition Packet) - doDecrypt unkeysRef pws defpw mp = do + doDecrypt unkeysRef pws defpw mp0 = do unkeys <- readIORef unkeysRef - let wk = packet mp + let mp = fromMaybe mp0 $ do + k <- Map.lookup kk keys + return $ mergeKeyPacket "decrypt" mp0 k + wk = packet mp0 kk = keykey wk fs = Map.keys $ locations mp @@ -1687,7 +1706,7 @@ makeMemoizingDecrypter operation ctx = do -- combine the packet with it's unspilled version before -- attempting to decrypt it. pw <- getpw - let wkun = fromMaybe wk $ decryptSecretKey pw wk + let wkun = fromMaybe wk $ decryptSecretKey pw (packet mp) case symmetric_algorithm wkun of Unencrypted -> do writeIORef unkeysRef (Map.insert kk wkun unkeys) @@ -1860,14 +1879,9 @@ runKeyRing operation = do then return $ KikiResult (FailedToLock failed_locks) [] else do - -- memoizing decrypter - -- TODO: Unspilled keyrings should be usable for decrypting - -- and signing. - decrypt <- makeMemoizingDecrypter operation ctx - -- merge all keyrings, PEM files, and wallets - bresult <- buildKeyDB decrypt ctx grip0 operation - try' bresult $ \((db,grip,wk,hs,accs),report_imports) -> do + bresult <- buildKeyDB ctx grip0 operation + try' bresult $ \((db,grip,wk,hs,accs,decrypt,unspilled),report_imports) -> do externals_ret <- initializeMissingPEMFiles operation ctx @@ -1894,7 +1908,7 @@ runKeyRing operation = do r <- writeWalletKeys operation (rtKeyDB rt) (fmap packet wk) try' r $ \report_wallets -> do - r <- writeRingKeys operation rt -- db wk secring pubring + r <- writeRingKeys operation rt unspilled try' r $ \report_rings -> do r <- writePEMKeys decrypt (rtKeyDB rt) exports @@ -2321,6 +2335,12 @@ mappedPacket filename p = MappedPacket , locations = Map.singleton filename (origin p (-1)) } +mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket +mappedPacketWithHint filename p hint = MappedPacket + { packet = p + , locations = Map.singleton filename (origin p hint) + } + keykey :: Packet -> KeyKey keykey key = -- Note: The key's timestamp is normally included in it's fingerprint. @@ -2386,8 +2406,7 @@ merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet)) -> KeyDB merge_ db filename qs = foldl mergeit db (zip [0..] qs) where - asMapped n p = let m = mappedPacket filename p - in m { locations = fmap (\x->x {originalNum=n}) (locations m) } + asMapped n p = mappedPacketWithHint filename p n asSigAndTrust n (p,tm) = (asMapped n p,tm) emptyUids = Map.empty -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets -- cgit v1.2.3