Implemented key encryption.

1 files changed, 32 insertions, 21 deletions

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)