Implemented key encryption.

3 files changed, 77 insertions, 34 deletions

diff --git a/kiki.hs b/kiki.hs
index 0dedc03..3eb1d2a 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -1683,7 +1683,7 @@ tarC (sargs,margs) = do
     decrypt :: KeyRingRuntime -> Packet -> IO (Maybe Packet)
     decrypt rt k@SecretKeyPacket { symmetric_algorithm = Unencrypted } = return $ Just k
     decrypt rt k = do
-        r <- rtPassphrases rt (MappedPacket k Map.empty)
+        r <- rtPassphrases rt (Unencrypted,S2K 100 "") (MappedPacket k Map.empty)
         case r of
             KikiSuccess p -> return $ Just p
             _ -> do
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)
diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index f1bb27d..ef7b913 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -126,7 +126,13 @@ importAndRefresh root cmn = do
     old_umask <- setFileCreationMask(0o077);
     -- Generate secring.gpg if it does not exist...
     gotsec <- doesFileExist secring
-    when (not gotsec) $ do
+
+    let passfd = cap_passfd cmn
+
+    pwds <-
+     if gotsec
+      then return []
+      else do
         {-  ssh-keygen to create master key...
         let mkpath = home ++ "/master-key"
         mkdirFor mkpath
@@ -139,12 +145,35 @@ importAndRefresh root cmn = do
                         HomeSec
                         ( encode $ Message [mk { is_subkey = False }] )
         -}
-        master <- (\k -> k { is_subkey = False }) <$> generateKey (GenRSA $ 4096 `div` 8 )
-        mkdirFor secring
-        writeInputFileL (InputFileContext secring pubring)
-                        HomeSec
-                        $ encode $ Message [master { is_subkey = False}]
-
+        master_un <- (\k -> k { is_subkey = False }) <$> generateKey (GenRSA $ 4096 `div` 8 )
+        let default_cipher = (CAST5, IteratedSaltedS2K SHA1 4073382889203176146 7864320)
+            ctx = InputFileContext secring pubring
+            passwordop = KeyRingOperation
+                            { opFiles = Map.empty
+                            , opPassphrases = do pfd <- maybeToList passfd
+                                                 return $ PassphraseSpec Nothing Nothing pfd
+                            , opHome = homespec
+                            , opTransforms = []
+                            }
+        transcoder <- makeMemoizingDecrypter passwordop ctx Map.empty
+        master0 <- transcoder default_cipher $ MappedPacket master_un Map.empty
+        case master0 of
+            KikiSuccess master -> do
+                mkdirFor secring
+                writeInputFileL ctx
+                                HomeSec
+                                $ encode $ Message [master { is_subkey = False}]
+                putStrLn "Wrote master key"
+                return [PassphraseMemoizer transcoder]
+            er -> do
+                hPutStrLn stderr ("warning: " ++ errorString er)
+                hPutStrLn stderr "warning: keys will not be encrypted.";
+                mkdirFor secring
+                writeInputFileL ctx
+                                HomeSec
+                                $ encode $ Message [master_un { is_subkey = False}]
+                putStrLn "Wrote master key"
+                return []
     gotpub <- doesFileExist pubring
     when (not gotpub) $ do
         mkdirFor pubring
@@ -168,8 +197,7 @@ importAndRefresh root cmn = do
 
     -- First, we ensure that the tor key exists and is imported
     -- so that we know where to put the strongswan key.
-    let passfd = cap_passfd cmn
-        strm = StreamInfo { typ = KeyRingFile
+    let strm = StreamInfo { typ = KeyRingFile
                           , fill = KF_None
                           , spill = KF_All
                           , access = AutoAccess
@@ -200,8 +228,8 @@ importAndRefresh root cmn = do
                 , ( ArgFile sshcpath, (peminfo 2048 "ssh-client") )
                 , ( ArgFile sshspath, (peminfo 2048 "ssh-server") )
                 ]
-             , opPassphrases = do pfd <- maybeToList passfd
-                                  return $ PassphraseSpec Nothing Nothing pfd
+             , opPassphrases = pwds ++ do pfd <- maybeToList passfd
+                                          return $ PassphraseSpec Nothing Nothing pfd
              , opHome = homespec
              , opTransforms = []
              }
@@ -304,7 +332,11 @@ refreshCache rt rootdir = do
         let my_ks :: [Packet]
             my_ks = getSecret "ipsec"
         case my_ks of
-            sec:_ -> do report <- writeKeyToFile streaminfo { typ = PEMFile
+            se0:_ -> do sc1 <- rtPassphrases rt (Unencrypted,S2K 100 "") $ MappedPacket se0 Map.empty
+                        let sec = case sc1 of
+                                    KikiSuccess s -> s
+                                    _             -> se0
+                        report <- writeKeyToFile streaminfo { typ = PEMFile
                                                             , access = Sec
                                                             , spill = KF_All
                                                             }