3 files changed, 92 insertions, 90 deletions

diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs
index 24b39b1..dd204d1 100644
--- a/lib/KeyRing/BuildKeyDB.hs
+++ b/lib/KeyRing/BuildKeyDB.hs
@@ -199,7 +199,7 @@ buildKeyDB ctx grip0 keyring = do
             accs = fmap (access . fst) ringPackets
         return (spilled,mwk,grip,accs,keys,fmap snd unspilled)
 
-    transcode <- makeMemoizingDecrypter keyring ctx (mwk,keyqs)
+    transcode <- makeMemoizingDecrypter (opPassphrases keyring) ctx (mwk,keyqs)
     let doDecrypt = transcode (Unencrypted,S2K 100 "")
 
     let wk = fmap packet mwk
diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index e67c805..eabd8ed 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -14,6 +14,7 @@ import           Data.ASN1.Types
 import           Data.Binary
 import           Data.Bool
 import           Data.Char
+import           Data.Functor
 import           Data.List
 import           Data.Maybe
 import           Data.OpenPGP
@@ -155,6 +156,35 @@ mkdirFor path = do
     let dir = takeDirectory path
     createDirectoryIfMissing True dir
 
+
+-- | Useful default KeyRingFile StreamInfo.
+strm :: StreamInfo
+strm = StreamInfo
+              { typ         = KeyRingFile
+              , fill        = KF_None
+              , spill       = KF_All
+              , access      = AutoAccess
+              , initializer = NoCreate
+              , transforms  = []
+              }
+
+-- | Convenience constructor for StreamInfo
+buildStreamInfo :: KeyFilter -> FileType -> StreamInfo
+buildStreamInfo rtyp ftyp = strm { typ = ftyp , fill = rtyp }
+
+-- | Convenience constuctor for Streaminfo generating a tagged subkey.
+peminfo :: Int       -- ^ bits
+           -> String -- ^ subkey tag.
+           -> StreamInfo
+peminfo bits usage = StreamInfo
+              { typ         = PEMFile
+              , fill        = KF_None -- KF_Match usage
+              , spill       = KF_Match usage
+              , access      = Sec
+              , initializer = Internal (GenRSA $ bits `div` 8)
+              , transforms  = []
+              }
+
 importAndRefresh :: (FilePath -> FilePath) -> CommonArgsParsed -> SymmetricAlgorithm -> IO ()
 importAndRefresh root cmn cipher = do
   let rootdir = do guard (root "x" /= "x")
@@ -165,54 +195,57 @@ importAndRefresh root cmn cipher = do
   bool id (error "--chroot requires an argument") (rootdir==Just "") $ do
     let homespec = mplus (slash <$> rootdir <*> cap_homespec cmn)
                          (fmap (++"/root/.gnupg") rootdir)
+        passfd = cap_passfd cmn
     (home,secring,pubring,mbwk) <- unconditionally $ getHomeDir homespec
     osHomeDir <- if bUnprivileged then getHomeDirectory else return "/root"
 
-    old_umask <- setFileCreationMask(0o077);
-    -- Generate secring.gpg if it does not exist...
+    old_umask <- setFileCreationMask 0o077 -- Keyring files need to be created with proper mask.
     gotsec <- doesFileExist secring
-
-    let passfd = cap_passfd cmn
-
     (torgen,pwds) <- bool id (const $ return (Generate 0 $ GenRSA $ 1024 `div` 8, [])) gotsec $ do
-        {-  ssh-keygen to create master key...
-        let mkpath = home ++ "/master-key"
-        mkdirFor mkpath
-        e <- systemEnv [ ("file",mkpath) ] (fromJust $ sshkeygen 4096)
-        case e of
-            ExitFailure num -> error "ssh-keygen failed to create master key"
-            ExitSuccess     -> return ()
-        [PEMPacket mk] <- readSecretPEMFile (ArgFile mkpath)
-        writeInputFileL (InputFileContext secring pubring)
-                        HomeSec
-                        ( encode $ Message [mk { is_subkey = False }] )
-        -}
-        master_un <- (\k -> MappedPacket (k { is_subkey = False }) Map.empty) <$> generateKey (GenRSA $ 4096 `div` 8 )
+        -- We have no secring.gpg (and thus no master key).
+        -- Since 'runKeyRing' cannot currently cope with this situation, we will
+        -- generate a master-key and very minimal secring.gpg file.
+        master_un <- generateKey (GenRSA $ 4096 `div` 8 )
+            <&> \k -> MappedPacket (k { is_subkey = False }) -- Set as master-key.
+                                   Map.empty                 -- Packet occurs in no files.
+        -- The user may desire the master key is encrypted on disk but this
+        -- requires a password prompt.  In order to have a decent prompt, it'd
+        -- be nice if we could display the .onion hostname for the key.
+        -- Therefore, we generate the tor key early.
         tor_un <- generateKey (GenRSA $ 1024 `div` 8 )
+        -- However, we'll postpone writing the tor key to the keyring and
+        -- instead have the later all-in-one call to runKeyRing take care of
+        -- it.  That interface does not currently provide a way to accept
+        -- in-memory input, so we'll create a fifo stream for it to read the
+        -- key in PEM format.
         (read_tor,write_tor) <- Posix.createPipe
-        do rs <- writeKeyToFile (streaminfo { typ = PEMFile, access = Sec, spill = KF_Match "tor", fill = KF_All }) (FileDesc write_tor) tor_un
-           -- outputReport $ map (first show) rs
-           return ()
-        cipher's2k <- do
-            IteratedSaltedS2K _ salt _ <- randomS2K SHA1
-            -- (cipher {- AES128 -}, IteratedSaltedS2K SHA1 4073382889203176146 7864320)
-            return $ (cipher {- AES128 -}, IteratedSaltedS2K SHA1 salt (15 * 2^19))
+        rs <- writeKeyToFile (streaminfo { typ    = PEMFile
+                                         , access = Sec
+                                         , spill  = KF_Match "tor"
+                                         , fill   = KF_All })
+                             (FileDesc write_tor)
+                             tor_un
+        -- -- Currently disabled: show warnings and errors from the PEM generation.
+        -- outputReport $ map (first show) rs
+
         let ctx = InputFileContext secring pubring
-            main_passwds = withAgent $ do pfd <- maybeToList passfd
-                                          return $ PassphraseSpec Nothing Nothing pfd
-            passwordop = KeyRingOperation
-                            { opFiles = Map.empty
-                            , opPassphrases = main_passwds
-                            , opHome = homespec
-                            , opTransforms = []
-                            }
-        let uidentry = Map.singleton (keykey $ packet master_un)
-                        $ master_un { packet = Query (packet master_un)
-                                                     (torUIDFromKey tor_un)
-                                                     Nothing
-                                    }
-        transcoder <- makeMemoizingDecrypter passwordop ctx (Just master_un, uidentry)
-        master0 <- transcoder cipher's2k master_un
+        -- Here we encrypt the master-key if neccessary.  If no --passphrase-fd option
+        -- was used, the user will receive prompts from gpg-agent.
+        (master0,transcoder) <- do
+            let main_passwds = withAgent $ do pfd <- maybeToList passfd
+                                              return $ PassphraseSpec Nothing Nothing pfd
+                uidentry = Map.singleton (keykey $ packet master_un)
+                            $ master_un { packet = Query (packet master_un)
+                                                         (torUIDFromKey tor_un)
+                                                         Nothing }
+            cipher's2k <- do
+                IteratedSaltedS2K _ salt _ <- randomS2K SHA1
+                return $ (cipher {- AES128 -}, IteratedSaltedS2K SHA1 salt (15 * 2^19))
+            transcoder <- makeMemoizingDecrypter main_passwds ctx (Just master_un, uidentry)
+            master <- transcoder cipher's2k master_un
+            return (master,transcoder)
+
+        -- Finally, we write-out the secring.gpg file.
         case master0 of
             KikiSuccess master -> do
                 mkdirFor secring
@@ -229,7 +262,17 @@ importAndRefresh root cmn cipher = do
                                 HomeSec
                                 $ encode $ Message [packet master_un]
                 putStrLn "Wrote master key"
+                -- FIXME: Why are we re-generating the tor key here?  Does this
+                -- code get triggered when the user cancels the agent prompt?
+                -- If so, he's likely canceling encryption, not the .onion name
+                -- he was already shown.
                 return (Generate 0 (GenRSA $ 1024 `div` 8 ), [])
+
+    -- If the public ring does not exist, then creating an empty file is
+    -- sufficient to satisfy 'runKeyRing'.  However, as we've already generated
+    -- a key above, GnuPG will not like the unsynced state we are leaving these
+    -- files.  It's important at this point that, 'runKeyRing' actually occurs
+    -- to fix things up.
     gotpub <- doesFileExist pubring
     when (not gotpub) $ do
         mkdirFor pubring
@@ -237,49 +280,9 @@ importAndRefresh root cmn cipher = do
                         HomePub
                         ( encode $ Message [] )
 
-    setFileCreationMask(old_umask);
-    -- Old paths..
-    --
-    -- Private
-    -- pem tor        /var/lib/tor/samizdat/private_key
-    -- pem ssh-client %(home)/.ssh/id_rsa
-    -- pem ssh-server /etc/ssh/ssh_host_rsa_key
-    -- pem ipsec      /etc/ipsec.d/private/%(onion).pem
-
-    -- Public
-    -- ssh-client %(home)/.ssh/id_rsa.pub
-    -- ssh-server /etc/ssh/ssh_host_rsa_key.pub
-    -- ipsec      /etc/ipsec.d/certs/%(onion).pem
-
-    -- First, we ensure that the tor key exists and is imported
-    -- so that we know where to put the strongswan key.
-    let strm =
-          StreamInfo
-          { typ = KeyRingFile
-          , fill = KF_None
-          , spill = KF_All
-          , access = AutoAccess
-          , initializer = NoCreate
-          , transforms = []
-          }
-        buildStreamInfo rtyp ftyp =
-          StreamInfo
-          { typ = ftyp
-          , fill = rtyp
-          , spill = KF_All
-          , access = AutoAccess
-          , initializer = NoCreate
-          , transforms = [] }
-        peminfo bits usage =
-          StreamInfo
-          { typ = PEMFile
-          , fill = KF_None -- KF_Match usage
-          , spill = KF_Match usage
-          , access = Sec
-          , initializer = Internal (GenRSA $ bits `div` 8)
-          , transforms = []
-          }
-        sshcpath = fromMaybe "" rootdir ++ osHomeDir ++ ".ssh/id_rsa"
+    setFileCreationMask old_umask -- We're done creating keyring files, so restore umask.
+
+    let sshcpath = fromMaybe "" rootdir ++ osHomeDir ++ ".ssh/id_rsa"
         sshspath = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key"
         op =
           KeyRingOperation
@@ -306,7 +309,6 @@ importAndRefresh root cmn cipher = do
           , opHome = homespec
           , opTransforms = []
           }
-        -- doNothing = return ()
         nop =
           KeyRingOperation
           { opFiles = Map.empty
@@ -314,14 +316,14 @@ importAndRefresh root cmn cipher = do
                                            return $ PassphraseSpec Nothing Nothing pfd
           , opHome=homespec, opTransforms = []
           }
-    -- if bUnprivileged then doNothing else mkdirFor torpath
+    -- Run the all-in-one operation that generates or imports all subkeys.
     KikiResult rt report <- runKeyRing (if bUnprivileged then nop else op)
     outputReport report
     rt <- case rt of
         BadPassphrase ->
             error "Operation requires correct passphrase. (Hint: Use --passphrase-fd=0 to input it on stdin.)"
         _ -> unconditionally $ return rt
-
+    -- Finally, we update /var/cache/kiki.
     when (not bUnprivileged) $ refreshCache rt rootdir
 
 -- Installs the cert file for the peer to the filesystem, and returns an
diff --git a/lib/PacketTranscoder.hs b/lib/PacketTranscoder.hs
index 03b219b..830ec2f 100644
--- a/lib/PacketTranscoder.hs
+++ b/lib/PacketTranscoder.hs
@@ -253,14 +253,14 @@ tryInOrder (f:fs) alg mp = do
 
 -- The transcoder works on 'MappedPacket' instead of 'Packet' so that
 -- file-specific passphrases can be utilized.
-makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext
+makeMemoizingDecrypter :: [PassphraseSpec] -> InputFileContext
                         -> (Maybe MappedPacket, Map.Map KeyKey (OriginMapped Query))
                         -> IO PacketTranscoder
-makeMemoizingDecrypter operation ctx (workingkey,keys) = do
+makeMemoizingDecrypter passwdspec ctx (workingkey,keys) = do
     unkeysRef <- newIORef (Map.empty :: Map.Map (KeyKey,SymmetricAlgorithm,S2K) Packet)
     return $ tryInOrder $ map passSpecTranscoder chains ++ [ trans unkeysRef ]
  where
-    (chains,passpecs) = span isChain $ sort $ opPassphrases operation
+    (chains,passpecs) = span isChain $ sort passwdspec
                         where isChain (PassphraseMemoizer {}) = True
                               isChain _                       = False
     srcs = map (interpretPassSpec ctx (workingkey,keys)) passpecs