summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lib/KeyRing.hs94
1 files changed, 66 insertions, 28 deletions
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index 0fbf2c2..faf5e70 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -49,8 +49,6 @@ module KeyRing
49 , KeyDB 49 , KeyDB
50 , KeyData(..) 50 , KeyData(..)
51 , SubKey(..) 51 , SubKey(..)
52 , packet
53 , locations
54 , keyflags 52 , keyflags
55 -- * Miscelaneous Utilities 53 -- * Miscelaneous Utilities
56 , isKey 54 , isKey
@@ -117,7 +115,7 @@ import Data.Bits ( (.|.), (.&.) )
117import Control.Applicative ( Applicative, pure, liftA2, (<*>) ) 115import Control.Applicative ( Applicative, pure, liftA2, (<*>) )
118import System.Directory ( getHomeDirectory, doesFileExist, createDirectoryIfMissing ) 116import System.Directory ( getHomeDirectory, doesFileExist, createDirectoryIfMissing )
119import Control.Arrow ( first, second ) 117import Control.Arrow ( first, second )
120import Data.OpenPGP.Util (verify,fingerprint,decryptSecretKey,pgpSign) 118import Data.OpenPGP.Util (verify,fingerprint,decryptSecretKey,pgpSign, generateKey, GenerateKeyParams(..))
121import Data.ByteString.Lazy ( ByteString ) 119import Data.ByteString.Lazy ( ByteString )
122import Text.Show.Pretty as PP ( ppShow ) 120import Text.Show.Pretty as PP ( ppShow )
123import Data.Binary {- decode, decodeOrFail -} 121import Data.Binary {- decode, decodeOrFail -}
@@ -244,6 +242,9 @@ data InputFile = HomeSec
244 -- ^ Contents will be read from the first descriptor and updated 242 -- ^ Contents will be read from the first descriptor and updated
245 -- content will be writen to the second. Note: Don't use Pipe 243 -- content will be writen to the second. Note: Don't use Pipe
246 -- for 'Wallet' files. (TODO: Wallet support) 244 -- for 'Wallet' files. (TODO: Wallet support)
245 | Generate GenerateKeyParams
246 -- ^ New key packets will be generated if there is no
247 -- matching content already in the key pool.
247 deriving (Eq,Ord,Show) 248 deriving (Eq,Ord,Show)
248 249
249-- type UsageTag = String 250-- type UsageTag = String
@@ -1288,6 +1289,24 @@ cachedContents maybePrompt ctx fd = do
1288 writeIORef ref (Just pw) 1289 writeIORef ref (Just pw)
1289 return pw 1290 return pw
1290 1291
1292generateSubkey ::
1293 (MappedPacket -> IO (KikiCondition Packet)) -- decrypt[
1294 -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db
1295 -> (GenerateKeyParams, StreamInfo)
1296 -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)]))
1297generateSubkey doDecrypt kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
1298 try kd' $ \(kd,report0) -> do
1299 let subs = do
1300 SubKey p sigs <- Map.elems $ keySubKeys kd
1301 filter (has_tag tag) $ map (packet . fst) sigs
1302 if null subs
1303 then do
1304 newkey <- generateKey genparam
1305 kdr <- insertSubkey doDecrypt (keykey (keyPacket kd)) kd [mkUsage tag] "" newkey
1306 try kdr $ \(newkd,report) -> do
1307 return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)])
1308 else return $ KikiSuccess (kd,report0)
1309
1291importSecretKey :: 1310importSecretKey ::
1292 (MappedPacket -> IO (KikiCondition Packet)) 1311 (MappedPacket -> IO (KikiCondition Packet))
1293 -> KikiCondition 1312 -> KikiCondition
@@ -1418,12 +1437,16 @@ buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation
1418 ,[(FilePath,KikiReportAction)])) 1437 ,[(FilePath,KikiReportAction)]))
1419buildKeyDB ctx grip0 keyring = do 1438buildKeyDB ctx grip0 keyring = do
1420 let 1439 let
1421 files isring = do 1440 files istyp = do
1422 (f,stream) <- Map.toList (opFiles keyring) 1441 (f,stream) <- Map.toList (opFiles keyring)
1423 guard (isring $ typ stream) 1442 guard (istyp $ typ stream)
1424 resolveInputFile ctx f 1443 resolveInputFile ctx f
1425 1444
1426 ringMap = Map.filter (isring . typ) $ opFiles keyring 1445 ringMap0 = Map.filter (isring . typ) $ opFiles keyring
1446 (genMap,ringMap) = Map.partitionWithKey isgen ringMap0
1447 where
1448 isgen (Generate _) _ = True
1449 isgen _ _ = False
1427 1450
1428 readp f stream = fmap readp0 $ readPacketsFromFile ctx f 1451 readp f stream = fmap readp0 $ readPacketsFromFile ctx f
1429 where 1452 where
@@ -1541,11 +1564,24 @@ buildKeyDB ctx grip0 keyring = do
1541 db <- foldM (importSecretKey doDecrypt) (KikiSuccess (db,[])) imports 1564 db <- foldM (importSecretKey doDecrypt) (KikiSuccess (db,[])) imports
1542 try db $ \(db,reportPEMs) -> do 1565 try db $ \(db,reportPEMs) -> do
1543 1566
1567 -- generate keys
1568 let gens = mapMaybe g $ Map.toList genMap
1569 where g (Generate params,v) = Just (params,v)
1570 g _ = Nothing
1571 db <- case mwk >>= \wk -> Map.lookup (keykey $ packet wk) db of
1572 Just kd0 -> do
1573 kd <- foldM (generateSubkey doDecrypt) (KikiSuccess (kd0,[])) gens
1574 try kd $ \(kd,reportGens) -> do
1575 let kk = keykey $ packet $ fromJust mwk
1576 return $ KikiSuccess (Map.insert kk kd db,reportGens)
1577 Nothing -> return $ KikiSuccess (db,[])
1578 try db $ \(db,reportGens) -> do
1579
1544 r <- mergeHostFiles keyring db ctx 1580 r <- mergeHostFiles keyring db ctx
1545 try r $ \((db,hs),reportHosts) -> do 1581 try r $ \((db,hs),reportHosts) -> do
1546 1582
1547 return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled) 1583 return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled)
1548 , reportTrans ++ reportWallets ++ reportPEMs ++ reportHosts ) 1584 , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts )
1549 1585
1550torhash :: Packet -> String 1586torhash :: Packet -> String
1551torhash key = fromMaybe "" $ derToBase32 <$> derRSA key 1587torhash key = fromMaybe "" $ derToBase32 <$> derRSA key
@@ -1768,11 +1804,10 @@ readSecretPEMFile fname = do
1768 return $ dta 1804 return $ dta
1769 1805
1770doImport 1806doImport
1771 :: Ord k => 1807 :: (MappedPacket -> IO (KikiCondition Packet))
1772 (MappedPacket -> IO (KikiCondition Packet)) 1808 -> Map.Map KeyKey KeyData
1773 -> Map.Map k KeyData 1809 -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t)
1774 -> (FilePath, Maybe [Char], [k], StreamInfo, t) 1810 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
1775 -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)]))
1776doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do 1811doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do
1777 flip (maybe $ return CannotImportMasterKey) 1812 flip (maybe $ return CannotImportMasterKey)
1778 subspec $ \tag -> do 1813 subspec $ \tag -> do
@@ -1812,18 +1847,21 @@ doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do
1812 return $ KikiSuccess (db',report++report') 1847 return $ KikiSuccess (db',report++report')
1813 1848
1814doImportG 1849doImportG
1815 :: Ord k => 1850 :: (MappedPacket -> IO (KikiCondition Packet))
1816 (MappedPacket -> IO (KikiCondition Packet)) 1851 -> Map.Map KeyKey KeyData
1817 -> Map.Map k KeyData 1852 -> [KeyKey] -- m0, only head is used
1818 -> [k] 1853 -> [SignatureSubpacket] -- tags
1819 -> [SignatureSubpacket] 1854 -> FilePath
1820 -> [Char]
1821 -> Packet 1855 -> Packet
1822 -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)])) 1856 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
1823doImportG doDecrypt db m0 tags fname key = do 1857doImportG doDecrypt db m0 tags fname key = do
1824 let kk = head m0 1858 let kk = head m0
1825 Just (KeyData top topsigs uids subs) = Map.lookup kk db 1859 Just kd@(KeyData top topsigs uids subs) = Map.lookup kk db
1826 subkk = keykey key 1860 kdr <- insertSubkey doDecrypt kk kd tags fname key
1861 try kdr $ \(kd',rrs) -> return $ KikiSuccess (Map.insert kk kd' db, rrs)
1862
1863insertSubkey doDecrypt kk (KeyData top topsigs uids subs) tags fname key = do
1864 let subkk = keykey key
1827 (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key) 1865 (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key)
1828 []) 1866 [])
1829 ( (False,) . addOrigin ) 1867 ( (False,) . addOrigin )
@@ -1876,7 +1914,7 @@ doImportG doDecrypt db m0 tags fname key = do
1876 let SubKey subkey_p subsigs = subkey 1914 let SubKey subkey_p subsigs = subkey
1877 wk = packet top 1915 wk = packet top
1878 (xs',minsig,ys') = findTag tags wk key subsigs 1916 (xs',minsig,ys') = findTag tags wk key subsigs
1879 doInsert mbsig db = do 1917 doInsert mbsig = do
1880 -- NEW SUBKEY BINDING SIGNATURE 1918 -- NEW SUBKEY BINDING SIGNATURE
1881 sig' <- makeSig doDecrypt top fname subkey_p tags mbsig 1919 sig' <- makeSig doDecrypt top fname subkey_p tags mbsig
1882 try sig' $ \(sig',report) -> do 1920 try sig' $ \(sig',report) -> do
@@ -1884,7 +1922,7 @@ doImportG doDecrypt db m0 tags fname key = do
1884 let subs' = Map.insert subkk 1922 let subs' = Map.insert subkk
1885 (SubKey subkey_p $ xs'++[sig']++ys') 1923 (SubKey subkey_p $ xs'++[sig']++ys')
1886 subs 1924 subs
1887 return $ KikiSuccess ( Map.insert kk (KeyData top topsigs uids' subs') db 1925 return $ KikiSuccess ( KeyData top topsigs uids' subs'
1888 , report ) 1926 , report )
1889 1927
1890 report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)]) 1928 report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)])
@@ -1893,12 +1931,12 @@ doImportG doDecrypt db m0 tags fname key = do
1893 in return (f report) 1931 in return (f report)
1894 1932
1895 case minsig of 1933 case minsig of
1896 Nothing -> doInsert Nothing db -- we need to create a new sig 1934 Nothing -> doInsert Nothing -- we need to create a new sig
1897 Just (True,sig) -> -- we can deduce is_new == False 1935 Just (True,sig) -> -- we can deduce is_new == False
1898 -- we may need to add a tor id 1936 -- we may need to add a tor id
1899 return $ KikiSuccess ( Map.insert kk (KeyData top topsigs uids' subs') db 1937 return $ KikiSuccess ( KeyData top topsigs uids' subs'
1900 , report ) 1938 , report )
1901 Just (False,sig) -> doInsert (Just sig) db -- We have a sig, but is missing usage@ tag 1939 Just (False,sig) -> doInsert (Just sig) -- We have a sig, but is missing usage@ tag
1902 1940
1903isCryptoCoinKey :: Packet -> Bool 1941isCryptoCoinKey :: Packet -> Bool
1904isCryptoCoinKey p = 1942isCryptoCoinKey p =
@@ -3350,8 +3388,8 @@ getCrossSignedSubkeys topk subs tag = do
3350 return torsig 3388 return torsig
3351 guard (not $ null sigs') 3389 guard (not $ null sigs')
3352 return subk 3390 return subk
3353 where 3391
3354 has_tag tag p = isSignaturePacket p 3392has_tag tag p = isSignaturePacket p
3355 && or [ tag `elem` mapMaybe usage (hashed_subpackets p) 3393 && or [ tag `elem` mapMaybe usage (hashed_subpackets p)
3356 , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ] 3394 , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ]
3357 3395