Progress toward encrypting keys.

1 files changed, 47 insertions, 33 deletions

diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index 2c174b3..80b7826 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -128,7 +128,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, generateKey, GenerateKeyParams(..))
+import Data.OpenPGP.Util
 import Data.ByteString.Lazy   ( ByteString )
 import Text.Show.Pretty as PP ( ppShow )
 import Data.Binary {- decode, decodeOrFail -}
@@ -379,6 +379,11 @@ usageFromFilter :: MonadPlus m => KeyFilter -> m String
 usageFromFilter (KF_Match usage) = return usage
 usageFromFilter _                = mzero
 
+
+type PacketTranscoder = (SymmetricAlgorithm,S2K) -> MappedPacket -> IO (KikiCondition Packet)
+
+type PacketDecrypter = MappedPacket -> IO (KikiCondition Packet)
+
 data KeyRingRuntime = KeyRingRuntime
                         { rtPubring :: FilePath
                         -- ^ Path to the file represented by 'HomePub'
@@ -399,7 +404,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 :: MappedPacket -> IO (KikiCondition Packet)
+                        , rtPassphrases :: PacketDecrypter
                         }
 
 -- | Roster-entry level actions
@@ -418,7 +423,7 @@ data PassphraseSpec = PassphraseSpec
     -- ^ The passphrase will be read from this file or file descriptor.
     }
     -- | Use this to carry pasphrases from a previous run.
-    | PassphraseMemoizer (MappedPacket -> IO (KikiCondition Packet))
+    | PassphraseMemoizer PacketTranscoder
 
 instance Show PassphraseSpec where
     show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c)
@@ -1442,11 +1447,11 @@ cachedContents maybePrompt ctx fd = do
             return pw
 
 generateSubkey ::
-  (MappedPacket -> IO (KikiCondition Packet)) -- decrypt[
+  PacketTranscoder
   -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db
   -> (GenerateKeyParams, StreamInfo)
   -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)]))
-generateSubkey doDecrypt kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
+generateSubkey transcode kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
     try kd' $ \(kd,report0) -> do
     let subs = do
             SubKey p sigs <- Map.elems $ keySubKeys kd
@@ -1454,6 +1459,7 @@ generateSubkey doDecrypt 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
         try kdr $ \(newkd,report) -> do
         return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)])
@@ -1462,7 +1468,7 @@ generateSubkey doDecrypt kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
 generateSubkey _ kd _ = return kd
 
 importSecretKey ::
-  (MappedPacket -> IO (KikiCondition Packet))
+  (PacketDecrypter)
   -> KikiCondition
        (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])
   -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t)
@@ -1595,7 +1601,7 @@ buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation
                                                       {- gpgnames -}[(SockAddr, (KeyKey, KeyKey))],
                                                       {- outgoing_names -}[SockAddr])
                                     ,{- accs      -} Map.Map InputFile Access
-                                    ,{- doDecrypt -} MappedPacket -> IO (KikiCondition Packet)
+                                    ,{- doDecrypt -} PacketTranscoder
                                     ,{- unspilled -} Map.Map InputFile Message
                                     )
                                    ,{- report_imports -} [(FilePath,KikiReportAction)]))
@@ -1675,7 +1681,8 @@ buildKeyDB ctx grip0 keyring = do
             accs = fmap (access . fst) ringPackets
         return (spilled,mwk,grip,accs,keys,fmap snd unspilled)
 
-    doDecrypt <- makeMemoizingDecrypter keyring ctx keys
+    transcode <- makeMemoizingDecrypter keyring ctx keys
+    let doDecrypt = transcode (Unencrypted,S2K 100 "")
 
     let wk = fmap packet mwk
         rt0 = KeyRingRuntime { rtPubring = homepubPath ctx
@@ -1758,25 +1765,25 @@ buildKeyDB ctx grip0 keyring = do
                 where g (Generate _ params,v) = Just (params,v)
                       g _                     = Nothing
 
-    db <- generateInternals doDecrypt mwk db gens
+    db <- generateInternals transcode mwk db gens
     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)
+    return $ KikiSuccess ( (db, grip, mwk, hs, accs, transcode, unspilled)
                          , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts )
 
 generateInternals ::
-    (MappedPacket -> IO (KikiCondition Packet))
+    PacketTranscoder
     -> Maybe MappedPacket
     -> Map.Map KeyKey KeyData
     -> [(GenerateKeyParams,StreamInfo)]
     -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
-generateInternals doDecrypt mwk db gens = do
+generateInternals transcode mwk db gens = do
     case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) db of
         Just kd0 -> do
-            kd <- foldM (generateSubkey doDecrypt) (KikiSuccess (kd0,[])) gens
+            kd <- foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens
             try kd $ \(kd,reportGens) -> do
             let kk = keykey $ packet $ fromJust mwk
             return $ KikiSuccess (Map.insert kk kd db,reportGens)
@@ -2003,7 +2010,7 @@ readSecretPEMFile fname = do
     return $ dta
 
 doImport
-  :: (MappedPacket -> IO (KikiCondition Packet))
+  :: (PacketDecrypter)
      -> Map.Map KeyKey KeyData
      -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t)
      -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
@@ -2046,7 +2053,7 @@ doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do
                 return $ KikiSuccess (db',report++report')
 
 doImportG
-  :: (MappedPacket -> IO (KikiCondition Packet))
+  :: (PacketDecrypter)
      -> Map.Map KeyKey KeyData
      -> [KeyKey] -- m0,  only head is used
      -> [SignatureSubpacket] -- tags
@@ -2478,7 +2485,7 @@ writeKeyToFile StreamInfo { typ = DNSPresentation } fname packet = do
             return [(fname, ExportedSubkey)]
      algo -> return [(fname, UnableToExport algo $ fingerprint packet)]
 
-writePEMKeys :: (MappedPacket -> IO (KikiCondition Packet))
+writePEMKeys :: (PacketDecrypter)
                 -> KeyDB
                 -> [(FilePath,Maybe String,[MappedPacket],StreamInfo)]
                 -> IO (KikiCondition [(FilePath,KikiReportAction)])
@@ -2502,8 +2509,8 @@ writePEMKeys doDecrypt db exports = do
 
 makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext
                         -> Map.Map KeyKey MappedPacket
-                        -> IO (MappedPacket -> IO (KikiCondition Packet))
-makeMemoizingDecrypter operation ctx keys =
+                        -> IO PacketTranscoder
+makeMemoizingDecrypter operation ctx keys = do
    if null chains then  do
     -- (*) Notice we do not pass ctx to resolveForReport.
     -- This is because the merge function does not currently use a context
@@ -2518,7 +2525,7 @@ makeMemoizingDecrypter operation ctx keys =
                             $ Map.filter (isJust . pwfile . typ) $ opFiles operation)
     -}
         let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n"
-        pws2 <- 
+        pws2 <-
             Traversable.mapM (cachedContents prompt ctx)
              $ Map.fromList $ mapMaybe
                     (\spec -> (,passSpecPassFile spec) `fmap` do
@@ -2541,9 +2548,10 @@ makeMemoizingDecrypter operation ctx keys =
     doDecrypt :: IORef (Map.Map KeyKey Packet)
                 -> Map.Map FilePath (IO S.ByteString)
                 -> Maybe (IO S.ByteString)
+                -> (SymmetricAlgorithm,S2K)
                 -> MappedPacket
                 -> IO (KikiCondition Packet)
-    doDecrypt unkeysRef pws defpw mp0 = do
+    doDecrypt unkeysRef pws defpw (dest_alg,dest_s2k) mp0 = do
         unkeys <- readIORef unkeysRef
         let mp = fromMaybe mp0 $ do
                     k <- Map.lookup kk keys
@@ -2562,19 +2570,23 @@ makeMemoizingDecrypter operation ctx keys =
                 case symmetric_algorithm wkun of
                     Unencrypted -> do
                         writeIORef unkeysRef (Map.insert kk wkun unkeys)
-                        return $ KikiSuccess wkun
-                    _ -> decryptIt getpws
+                        ek <- encryptSecretKey pw dest_s2k dest_alg wkun
+                        case ek of
+                            Nothing   -> return $ BadPassphrase
+                            Just wken -> return $ KikiSuccess wken
+                    _                 -> decryptIt getpws
 
             getpws = mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw
 
-        case symmetric_algorithm wk of
-            Unencrypted -> return (KikiSuccess wk)
-            _ -> maybe (decryptIt getpws)
+        if symmetric_algorithm wk == dest_alg
+            && ( symmetric_algorithm wk == Unencrypted || s2k wk == dest_s2k )
+            then return (KikiSuccess wk)
+            else maybe (decryptIt getpws)
                        (return . KikiSuccess)
                     $ Map.lookup kk unkeys
 
 performManipulations ::
-                (MappedPacket -> IO (KikiCondition Packet))
+                (PacketDecrypter)
                 -> KeyRingRuntime
                 -> Maybe MappedPacket
                 -> (KeyRingRuntime -> KeyData -> [PacketUpdate])
@@ -2647,14 +2659,15 @@ initializeMissingPEMFiles ::
       -> InputFileContext
       -> Maybe String
       -> Maybe MappedPacket
-      -> (MappedPacket -> IO (KikiCondition Packet))
+      -> PacketTranscoder
       -> KeyDB
       -> IO (KikiCondition ( (KeyDB,[( FilePath
                                      , Maybe String
                                      , [MappedPacket]
                                      , StreamInfo )])
                            , [(FilePath,KikiReportAction)]))
-initializeMissingPEMFiles operation ctx grip mwk decrypt db = do
+initializeMissingPEMFiles operation ctx grip mwk transcode db = do
+        let decrypt = transcode (Unencrypted,S2K 100 "")
         nonexistents <-
            filterM (fmap not . doesFileExist . fst)
                $ do (f,t) <- Map.toList (opFiles operation)
@@ -2731,7 +2744,7 @@ initializeMissingPEMFiles operation ctx grip mwk decrypt db = do
                         , spill       = KF_Match tag } = Just tag
                     internalInitializer _              = Nothing
 
-           v <- generateInternals decrypt mwk db internals
+           v <- generateInternals transcode mwk db internals
 
            try v $ \(db,internals_rs) -> do
 
@@ -2930,17 +2943,18 @@ runKeyRing operation = do
 
         -- merge all keyrings, PEM files, and wallets
         bresult <- buildKeyDB ctx grip0 operation
-        try' bresult $ \((db,grip,wk,hs,accs,decrypt,unspilled),report_imports) -> do
+        try' bresult $ \((db,grip,wk,hs,accs,transcode,unspilled),report_imports) -> do
 
         externals_ret <- initializeMissingPEMFiles operation
                                                    ctx
                                                    grip
                                                    wk
-                                                   decrypt
+                                                   transcode
                                                    db
         try' externals_ret $ \((db,exports),report_externals) -> do
 
-        let rt = KeyRingRuntime
+        let decrypt = transcode (Unencrypted,S2K 100 "")
+            rt = KeyRingRuntime
                        { rtPubring = homepubPath ctx
                        , rtSecring = homesecPath ctx
                        , rtGrip = grip
@@ -3276,7 +3290,7 @@ mkUsage tag = NotationDataPacket
                 }
 
 makeSig ::
-  (MappedPacket -> IO (KikiCondition Packet))
+  (PacketDecrypter)
   -> MappedPacket
   -> [Char]
   -> MappedPacket