KeyRingOperation: internal key generation supported.

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
     , KeyDB
     , KeyData(..)
     , SubKey(..)
-    , packet
-    , locations
     , keyflags
     -- * Miscelaneous Utilities
     , isKey
@@ -117,7 +115,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)
+import Data.OpenPGP.Util (verify,fingerprint,decryptSecretKey,pgpSign, generateKey, GenerateKeyParams(..))
 import Data.ByteString.Lazy   ( ByteString )
 import Text.Show.Pretty as PP ( ppShow )
 import Data.Binary {- decode, decodeOrFail -}
@@ -244,6 +242,9 @@ data InputFile = HomeSec
                -- ^ Contents will be read from the first descriptor and updated
                -- content will be writen to the second. Note: Don't use Pipe
                -- for 'Wallet' files. (TODO: Wallet support)
+               | Generate GenerateKeyParams
+               -- ^ New key packets will be generated if there is no
+               -- matching content already in the key pool.
  deriving (Eq,Ord,Show)
 
 -- type UsageTag = String
@@ -1288,6 +1289,24 @@ cachedContents maybePrompt ctx fd = do
             writeIORef ref (Just pw)
             return pw
 
+generateSubkey ::
+  (MappedPacket -> IO (KikiCondition Packet)) -- decrypt[
+  -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db
+  -> (GenerateKeyParams, StreamInfo)
+  -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)]))
+generateSubkey doDecrypt kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
+    try kd' $ \(kd,report0) -> do
+    let subs = do
+            SubKey p sigs <- Map.elems $ keySubKeys kd
+            filter (has_tag tag) $ map (packet . fst) sigs
+    if null subs
+      then do
+        newkey <- generateKey genparam
+        kdr <- insertSubkey doDecrypt (keykey (keyPacket kd)) kd [mkUsage tag] "" newkey
+        try kdr $ \(newkd,report) -> do
+        return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)])
+      else return $ KikiSuccess (kd,report0)
+
 importSecretKey ::
   (MappedPacket -> IO (KikiCondition Packet))
   -> KikiCondition
@@ -1418,12 +1437,16 @@ buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation
                                    ,[(FilePath,KikiReportAction)]))
 buildKeyDB ctx grip0 keyring = do
     let 
-        files isring = do
+        files istyp = do
             (f,stream) <- Map.toList (opFiles keyring)
-            guard (isring $ typ stream)
+            guard (istyp $ typ stream)
             resolveInputFile ctx f
 
-        ringMap = Map.filter (isring . typ) $ opFiles keyring
+        ringMap0 = Map.filter (isring . typ) $ opFiles keyring
+        (genMap,ringMap) = Map.partitionWithKey isgen ringMap0
+            where
+                isgen (Generate _) _ = True
+                isgen _            _ = False
 
         readp f stream = fmap readp0 $ readPacketsFromFile ctx f
          where
@@ -1541,11 +1564,24 @@ buildKeyDB ctx grip0 keyring = do
     db <- foldM (importSecretKey doDecrypt) (KikiSuccess (db,[])) imports
     try db $ \(db,reportPEMs) -> do
 
+    -- generate keys
+    let gens = mapMaybe g $ Map.toList genMap
+                where g (Generate params,v) = Just (params,v)
+                      g _                   = Nothing
+    db <- case mwk >>= \wk -> Map.lookup (keykey $ packet wk) db of
+            Just kd0 -> do
+                kd <- foldM (generateSubkey doDecrypt) (KikiSuccess (kd0,[])) gens
+                try kd $ \(kd,reportGens) -> do
+                let kk = keykey $ packet $ fromJust mwk
+                return $ KikiSuccess (Map.insert kk kd db,reportGens)
+            Nothing -> return $ KikiSuccess (db,[])
+    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)
-                         , reportTrans ++ reportWallets ++ reportPEMs ++ reportHosts )
+                         , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts )
 
 torhash :: Packet -> String
 torhash key = fromMaybe "" $ derToBase32 <$> derRSA key
@@ -1768,11 +1804,10 @@ readSecretPEMFile fname = do
     return $ dta
 
 doImport
-  :: Ord k =>
-     (MappedPacket -> IO (KikiCondition Packet))
-     -> Map.Map k KeyData
-     -> (FilePath, Maybe [Char], [k], StreamInfo, t)
-     -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)]))
+  :: (MappedPacket -> IO (KikiCondition Packet))
+     -> 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
     flip (maybe $ return CannotImportMasterKey)
          subspec $ \tag -> do
@@ -1812,18 +1847,21 @@ doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do
                 return $ KikiSuccess (db',report++report')
 
 doImportG
-  :: Ord k =>
-     (MappedPacket -> IO (KikiCondition Packet))
-     -> Map.Map k KeyData
-     -> [k]
-     -> [SignatureSubpacket]
-     -> [Char]
+  :: (MappedPacket -> IO (KikiCondition Packet))
+     -> Map.Map KeyKey KeyData
+     -> [KeyKey] -- m0,  only head is used
+     -> [SignatureSubpacket] -- tags
+     -> FilePath
      -> Packet
-     -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)]))
+     -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
 doImportG doDecrypt db m0 tags fname key = do
     let kk = head m0
-        Just (KeyData top topsigs uids subs) = Map.lookup kk db
-        subkk = keykey key
+        Just kd@(KeyData top topsigs uids subs) = Map.lookup kk db
+    kdr <- insertSubkey doDecrypt 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
+    let subkk = keykey key
         (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key)
                                                [])
                                  ( (False,) . addOrigin )
@@ -1876,7 +1914,7 @@ doImportG doDecrypt db m0 tags fname key = do
     let SubKey subkey_p subsigs = subkey
         wk = packet top
         (xs',minsig,ys') = findTag tags wk key subsigs
-        doInsert mbsig db = do
+        doInsert mbsig = do
             -- NEW SUBKEY BINDING SIGNATURE
             sig' <- makeSig doDecrypt top fname subkey_p tags mbsig
             try sig' $ \(sig',report) -> do
@@ -1884,7 +1922,7 @@ doImportG doDecrypt db m0 tags fname key = do
             let subs' = Map.insert subkk
                                    (SubKey subkey_p $ xs'++[sig']++ys')
                                    subs
-            return $ KikiSuccess ( Map.insert kk (KeyData top topsigs uids' subs') db
+            return $ KikiSuccess ( KeyData top topsigs uids' subs'
                                  , report )
 
     report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)])
@@ -1893,12 +1931,12 @@ doImportG doDecrypt db m0 tags fname key = do
               in return (f report)
 
     case minsig of
-        Nothing          -> doInsert Nothing db    -- we need to create a new sig
+        Nothing          -> doInsert Nothing -- we need to create a new sig
         Just (True,sig)  -> -- we can deduce is_new == False
                             -- we may need to add a tor id
-                            return $ KikiSuccess ( Map.insert kk (KeyData top topsigs uids' subs') db
+                            return $ KikiSuccess ( KeyData top topsigs uids' subs'
                                                  , report )
-        Just (False,sig) -> doInsert (Just sig) db -- We have a sig, but is missing usage@ tag
+        Just (False,sig) -> doInsert (Just sig) -- We have a sig, but is missing usage@ tag
 
 isCryptoCoinKey :: Packet -> Bool
 isCryptoCoinKey p =
@@ -3350,8 +3388,8 @@ getCrossSignedSubkeys topk subs tag = do
                 return torsig
         guard (not $ null sigs')
         return subk
- where
-    has_tag tag p = isSignaturePacket p
+
+has_tag tag p = isSignaturePacket p
                     && or [ tag `elem` mapMaybe usage (hashed_subpackets p)
                           , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ]