summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--KeyRing.hs105
1 files 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
1069 return $ concat rss 1069 return $ concat rss
1070 1070
1071 1071
1072buildKeyDB :: (MappedPacket -> IO (KikiCondition Packet)) 1072buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation
1073 -> InputFileContext -> Maybe String -> KeyRingOperation
1074 -> IO (KikiCondition ((KeyDB 1073 -> IO (KikiCondition ((KeyDB
1075 ,Maybe String 1074 ,Maybe String
1076 ,Maybe MappedPacket 1075 ,Maybe MappedPacket
@@ -1080,9 +1079,11 @@ buildKeyDB :: (MappedPacket -> IO (KikiCondition Packet))
1080 [(SockAddr, (KeyKey, KeyKey))], 1079 [(SockAddr, (KeyKey, KeyKey))],
1081 [SockAddr]) 1080 [SockAddr])
1082 ,Map.Map FilePath Access 1081 ,Map.Map FilePath Access
1082 ,MappedPacket -> IO (KikiCondition Packet)
1083 ,Map.Map InputFile Message
1083 ) 1084 )
1084 ,[(FilePath,KikiReportAction)])) 1085 ,[(FilePath,KikiReportAction)]))
1085buildKeyDB doDecrypt ctx grip0 keyring = do 1086buildKeyDB ctx grip0 keyring = do
1086 let 1087 let
1087 files isring = do 1088 files isring = do
1088 (f,stream) <- Map.toList (kFiles keyring) 1089 (f,stream) <- Map.toList (kFiles keyring)
@@ -1104,19 +1105,8 @@ buildKeyDB doDecrypt ctx grip0 keyring = do
1104 1105
1105 readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n)) 1106 readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n))
1106 1107
1107 importWalletKey wk db' (top,fname,sub,tag) = do
1108 try db' $ \(db',report0) -> do
1109 r <- doImportG doDecrypt
1110 db'
1111 (fmap keykey $ maybeToList wk)
1112 tag
1113 fname
1114 sub
1115 try r $ \(db'',report) -> do
1116 return $ KikiSuccess (db'', report0 ++ report)
1117
1118 -- KeyRings (todo: KikiCondition reporting?) 1108 -- KeyRings (todo: KikiCondition reporting?)
1119 (db_rings,mwk,grip,accs) <- do 1109 (db_rings,mwk,grip,accs,keys,unspilled) <- do
1120 ringPackets <- Map.traverseWithKey readp ringMap 1110 ringPackets <- Map.traverseWithKey readp ringMap
1121 let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message) 1111 let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message)
1122 1112
@@ -1126,20 +1116,44 @@ buildKeyDB doDecrypt ctx grip0 keyring = do
1126 (_,Message ps) <- Map.lookup HomeSec ringPackets 1116 (_,Message ps) <- Map.lookup HomeSec ringPackets
1127 listToMaybe ps 1117 listToMaybe ps
1128 (spilled,unspilled) = Map.partition (spillable . fst) ringPackets 1118 (spilled,unspilled) = Map.partition (spillable . fst) ringPackets
1129 db_rings = Map.foldlWithKey mergeIt Map.empty ringPackets 1119 db_rings = Map.foldlWithKey mergeIt Map.empty spilled
1130 where mergeIt db f (_,ps) = merge db f ps 1120 where mergeIt db f (_,ps) = merge db f ps
1121 keys :: Map.Map KeyKey MappedPacket
1122 keys = Map.foldl slurpkeys Map.empty
1123 $ Map.mapWithKey filterSecrets ringPackets
1124 where isSecretKey (SecretKeyPacket {}) = True
1125 isSecretKey _ = False
1126 filterSecrets f (_,Message ps) =
1127 filter (isSecretKey . packet)
1128 $ zipWith (mappedPacketWithHint fname) ps [1..]
1129 where fname = resolveForReport (Just ctx) f
1130 slurpkeys m ps = m `Map.union` Map.fromList ps'
1131 where ps' = zip (map (keykey . packet) ps) ps
1131 wk = listToMaybe $ do 1132 wk = listToMaybe $ do
1132 fp <- maybeToList grip 1133 fp <- maybeToList grip
1133 (kk,kd) <- Map.toList db_rings 1134 let matchfp mp = not (is_subkey p) && matchpr fp p == fp
1134 guard $ matchSpec (KeyGrip fp) (kk,kd) 1135 where p = packet mp
1135 return $ keyMappedPacket kd 1136 Map.elems $ Map.filter matchfp keys
1136 accs = Map.mapKeys (concat . resolveInputFile ctx) 1137 accs = Map.mapKeys (concat . resolveInputFile ctx)
1137 $ fmap (access . fst) ringPackets 1138 $ fmap (access . fst) ringPackets
1138 return (db_rings,wk,grip,accs) 1139 return (db_rings,wk,grip,accs,keys,fmap snd unspilled)
1140
1141 doDecrypt <- makeMemoizingDecrypter keyring ctx keys
1139 1142
1140 let wk = fmap packet mwk 1143 let wk = fmap packet mwk
1141 1144
1142 -- Wallets 1145 -- Wallets
1146 let importWalletKey wk db' (top,fname,sub,tag) = do
1147 try db' $ \(db',report0) -> do
1148 r <- doImportG doDecrypt
1149 db'
1150 (fmap keykey $ maybeToList wk)
1151 tag
1152 fname
1153 sub
1154 try r $ \(db'',report) -> do
1155 return $ KikiSuccess (db'', report0 ++ report)
1156
1143 wms <- mapM (readw wk) (files iswallet) 1157 wms <- mapM (readw wk) (files iswallet)
1144 let wallet_keys = do 1158 let wallet_keys = do
1145 maybeToList wk 1159 maybeToList wk
@@ -1171,7 +1185,8 @@ buildKeyDB doDecrypt ctx grip0 keyring = do
1171 r <- mergeHostFiles keyring db ctx 1185 r <- mergeHostFiles keyring db ctx
1172 try r $ \((db,hs),reportHosts) -> do 1186 try r $ \((db,hs),reportHosts) -> do
1173 1187
1174 return $ KikiSuccess ( (db, grip, mwk, hs, accs), reportWallets ++ reportPEMs ) 1188 return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled)
1189 , reportWallets ++ reportPEMs )
1175 1190
1176torhash :: Packet -> String 1191torhash :: Packet -> String
1177torhash key = fromMaybe "" $ derToBase32 <$> derRSA key 1192torhash key = fromMaybe "" $ derToBase32 <$> derRSA key
@@ -1465,13 +1480,13 @@ isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk
1465 guard $ matchSpec (KeyGrip fp) elm 1480 guard $ matchSpec (KeyGrip fp) elm
1466 return $ keyPacket (snd elm) 1481 return $ keyPacket (snd elm)
1467 1482
1468writeRingKeys :: KeyRingOperation -> KeyRingRuntime 1483writeRingKeys :: KeyRingOperation -> KeyRingRuntime -> Map.Map InputFile Message
1469 {- 1484 {-
1470 -> KeyDB -> Maybe Packet 1485 -> KeyDB -> Maybe Packet
1471 -> FilePath -> FilePath 1486 -> FilePath -> FilePath
1472 -} 1487 -}
1473 -> IO (KikiCondition [(FilePath,KikiReportAction)]) 1488 -> IO (KikiCondition [(FilePath,KikiReportAction)])
1474writeRingKeys krd rt {- db wk secring pubring -} = do 1489writeRingKeys krd rt {- db wk secring pubring -} unspilled = do
1475 let isring (KeyRingFile {}) = True 1490 let isring (KeyRingFile {}) = True
1476 isring _ = False 1491 isring _ = False
1477 db = rtKeyDB rt 1492 db = rtKeyDB rt
@@ -1484,7 +1499,10 @@ writeRingKeys krd rt {- db wk secring pubring -} = do
1484 guard (isring $ typ stream) 1499 guard (isring $ typ stream)
1485 f <- resolveInputFile ctx f0 1500 f <- resolveInputFile ctx f0
1486 return (f,f0,stream) 1501 return (f,f0,stream)
1487 let x = do 1502 let db' = fromMaybe db $ do
1503 msg <- Map.lookup f0 unspilled
1504 return $ merge db f0 msg
1505 x = do
1488 let wantedForFill :: Access -> KeyFilter -> KeyData -> Maybe Bool 1506 let wantedForFill :: Access -> KeyFilter -> KeyData -> Maybe Bool
1489 wantedForFill acc KF_None = importByExistingMaster 1507 wantedForFill acc KF_None = importByExistingMaster
1490 -- Note the KF_None case is almost irrelevent as it will be 1508 -- Note the KF_None case is almost irrelevent as it will be
@@ -1504,7 +1522,7 @@ writeRingKeys krd rt {- db wk secring pubring -} = do
1504 (error $ f ++ ": write public or secret key to file?") 1522 (error $ f ++ ": write public or secret key to file?")
1505 importByExistingMaster kd@(KeyData p _ _ _) = 1523 importByExistingMaster kd@(KeyData p _ _ _) =
1506 fmap originallyPublic $ Map.lookup f $ locations p 1524 fmap originallyPublic $ Map.lookup f $ locations p
1507 d <- sortByHint f keyMappedPacket (Map.elems db) 1525 d <- sortByHint f keyMappedPacket (Map.elems db')
1508 acc <- maybeToList $ Map.lookup f (rtRingAccess rt) 1526 acc <- maybeToList $ Map.lookup f (rtRingAccess rt)
1509 only_public <- maybeToList $ wantedForFill acc (fill stream) d 1527 only_public <- maybeToList $ wantedForFill acc (fill stream) d
1510 case fill stream of 1528 case fill stream of
@@ -1640,8 +1658,9 @@ writePEMKeys doDecrypt db exports = do
1640 return $ KikiSuccess (fname,pun) 1658 return $ KikiSuccess (fname,pun)
1641 1659
1642makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext 1660makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext
1661 -> Map.Map KeyKey MappedPacket
1643 -> IO (MappedPacket -> IO (KikiCondition Packet)) 1662 -> IO (MappedPacket -> IO (KikiCondition Packet))
1644makeMemoizingDecrypter operation ctx = do 1663makeMemoizingDecrypter operation ctx keys = do
1645 -- (*) Notice we do not pass ctx to resolveForReport. 1664 -- (*) Notice we do not pass ctx to resolveForReport.
1646 -- This is because the merge function does not currently use a context 1665 -- This is because the merge function does not currently use a context
1647 -- and the pws map keys must match the MappedPacket locations. 1666 -- and the pws map keys must match the MappedPacket locations.
@@ -1664,10 +1683,7 @@ makeMemoizingDecrypter operation ctx = do
1664 $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp) 1683 $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp)
1665 && isNothing (passSpecKeySpec sp)) 1684 && isNothing (passSpecKeySpec sp))
1666 $ kPassphrases operation 1685 $ kPassphrases operation
1667 unkeysRef <- newIORef Map.empty 1686 unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet)
1668 -- TODO:
1669 -- Use buildKeyDB on unspilled files to create an unspillable KeyDB.
1670 -- This KeyDB should be used later by decryptIt.
1671 return $ doDecrypt unkeysRef (pws `Map.union` pws2) defpw 1687 return $ doDecrypt unkeysRef (pws `Map.union` pws2) defpw
1672 where 1688 where
1673 doDecrypt :: IORef (Map.Map KeyKey Packet) 1689 doDecrypt :: IORef (Map.Map KeyKey Packet)
@@ -1675,9 +1691,12 @@ makeMemoizingDecrypter operation ctx = do
1675 -> Maybe (IO S.ByteString) 1691 -> Maybe (IO S.ByteString)
1676 -> MappedPacket 1692 -> MappedPacket
1677 -> IO (KikiCondition Packet) 1693 -> IO (KikiCondition Packet)
1678 doDecrypt unkeysRef pws defpw mp = do 1694 doDecrypt unkeysRef pws defpw mp0 = do
1679 unkeys <- readIORef unkeysRef 1695 unkeys <- readIORef unkeysRef
1680 let wk = packet mp 1696 let mp = fromMaybe mp0 $ do
1697 k <- Map.lookup kk keys
1698 return $ mergeKeyPacket "decrypt" mp0 k
1699 wk = packet mp0
1681 kk = keykey wk 1700 kk = keykey wk
1682 fs = Map.keys $ locations mp 1701 fs = Map.keys $ locations mp
1683 1702
@@ -1687,7 +1706,7 @@ makeMemoizingDecrypter operation ctx = do
1687 -- combine the packet with it's unspilled version before 1706 -- combine the packet with it's unspilled version before
1688 -- attempting to decrypt it. 1707 -- attempting to decrypt it.
1689 pw <- getpw 1708 pw <- getpw
1690 let wkun = fromMaybe wk $ decryptSecretKey pw wk 1709 let wkun = fromMaybe wk $ decryptSecretKey pw (packet mp)
1691 case symmetric_algorithm wkun of 1710 case symmetric_algorithm wkun of
1692 Unencrypted -> do 1711 Unencrypted -> do
1693 writeIORef unkeysRef (Map.insert kk wkun unkeys) 1712 writeIORef unkeysRef (Map.insert kk wkun unkeys)
@@ -1860,14 +1879,9 @@ runKeyRing operation = do
1860 then return $ KikiResult (FailedToLock failed_locks) [] 1879 then return $ KikiResult (FailedToLock failed_locks) []
1861 else do 1880 else do
1862 1881
1863 -- memoizing decrypter
1864 -- TODO: Unspilled keyrings should be usable for decrypting
1865 -- and signing.
1866 decrypt <- makeMemoizingDecrypter operation ctx
1867
1868 -- merge all keyrings, PEM files, and wallets 1882 -- merge all keyrings, PEM files, and wallets
1869 bresult <- buildKeyDB decrypt ctx grip0 operation 1883 bresult <- buildKeyDB ctx grip0 operation
1870 try' bresult $ \((db,grip,wk,hs,accs),report_imports) -> do 1884 try' bresult $ \((db,grip,wk,hs,accs,decrypt,unspilled),report_imports) -> do
1871 1885
1872 externals_ret <- initializeMissingPEMFiles operation 1886 externals_ret <- initializeMissingPEMFiles operation
1873 ctx 1887 ctx
@@ -1894,7 +1908,7 @@ runKeyRing operation = do
1894 r <- writeWalletKeys operation (rtKeyDB rt) (fmap packet wk) 1908 r <- writeWalletKeys operation (rtKeyDB rt) (fmap packet wk)
1895 try' r $ \report_wallets -> do 1909 try' r $ \report_wallets -> do
1896 1910
1897 r <- writeRingKeys operation rt -- db wk secring pubring 1911 r <- writeRingKeys operation rt unspilled
1898 try' r $ \report_rings -> do 1912 try' r $ \report_rings -> do
1899 1913
1900 r <- writePEMKeys decrypt (rtKeyDB rt) exports 1914 r <- writePEMKeys decrypt (rtKeyDB rt) exports
@@ -2321,6 +2335,12 @@ mappedPacket filename p = MappedPacket
2321 , locations = Map.singleton filename (origin p (-1)) 2335 , locations = Map.singleton filename (origin p (-1))
2322 } 2336 }
2323 2337
2338mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket
2339mappedPacketWithHint filename p hint = MappedPacket
2340 { packet = p
2341 , locations = Map.singleton filename (origin p hint)
2342 }
2343
2324keykey :: Packet -> KeyKey 2344keykey :: Packet -> KeyKey
2325keykey key = 2345keykey key =
2326 -- Note: The key's timestamp is normally included in it's fingerprint. 2346 -- 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))
2386 -> KeyDB 2406 -> KeyDB
2387merge_ db filename qs = foldl mergeit db (zip [0..] qs) 2407merge_ db filename qs = foldl mergeit db (zip [0..] qs)
2388 where 2408 where
2389 asMapped n p = let m = mappedPacket filename p 2409 asMapped n p = mappedPacketWithHint filename p n
2390 in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
2391 asSigAndTrust n (p,tm) = (asMapped n p,tm) 2410 asSigAndTrust n (p,tm) = (asMapped n p,tm)
2392 emptyUids = Map.empty 2411 emptyUids = Map.empty
2393 -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets 2412 -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets