Password handling overhaul:

        * More agressively search gpg-agent cache.

        * Allow key-specific passphrase fds.

4 files changed, 204 insertions, 164 deletions

diff --git a/lib/GnuPGAgent.hs b/lib/GnuPGAgent.hs
index 067e3bc..9e0bacf 100644
--- a/lib/GnuPGAgent.hs
+++ b/lib/GnuPGAgent.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE PatternGuards #-}
 module GnuPGAgent
     ( session
+    , GnuPGAgent
     , Query(..)
     , QueryMode(..)
     , getPassphrase
@@ -99,7 +100,8 @@ getPassphrase agent ask (Query key uid masterkey) = do
     r0 <- hGetLine (agentHandle agent)
     -- hPutStrLn stderr $ "agent says: " ++ r0
     case takeWhile (/=' ') r0 of
-        "OK" -> hGetLine (agentHandle agent) >>= unhex . drop 3
+        "OK" | not (null $ drop 3 r0) -> return r0 >>= unhex . drop 3 -- . (\x -> trace (show x) x)
+             | otherwise              -> hGetLine (agentHandle agent) >>= unhex . drop 3 -- . (\x -> trace (show x) x)
             where
 #if defined(VERSION_memory)
                 unhex hx = case convertFromBase Base16 (S8.pack hx) of
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index 87b38bf..1aed50e 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -409,22 +409,9 @@ instance ASN1Object RSAPrivateKey where
 
 
 
-uncamel :: String -> String
-uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args
-  where
-    (.:) = fmap . fmap
-    ( firstWord  ,
-      otherWords ) = splitAt 1 ws
-    ws             = camel >>= groupBy (\_ c -> isLower c)
-    ( camel, args) = splitAt 1 $ words str
-
 reportString :: KikiReportAction -> String
 reportString x = uncamel $ show x
 
-errorString :: KikiCondition a -> String
-errorString (KikiSuccess {}) = "success"
-errorString e = uncamel . show $ fmap (const ()) e
-
 -- | Errors in kiki are indicated by the returning of this record.
 data KikiResult a = KikiResult
     { kikiCondition :: KikiCondition a
diff --git a/lib/PacketTranscoder.hs b/lib/PacketTranscoder.hs
index afbf55b..eaa8366 100644
--- a/lib/PacketTranscoder.hs
+++ b/lib/PacketTranscoder.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE PatternGuards #-}
 module PacketTranscoder where
 
+import Debug.Trace
 import GHC.Stack
 import Control.Monad
 import Data.IORef
@@ -94,161 +95,177 @@ cachedContents maybePrompt ctx fd = do
             return pw
 
 
+data PassphraseResponse = ObtainedPassphrase S.ByteString
+                        | CanceledPassphrase
+                        | NextPassphrase
+ deriving Show
 
-makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext
+type PassphraseSource = (SymmetricAlgorithm,S2K) -> MappedPacket -> [IO PassphraseResponse]
+
+interpretPassSpec :: InputFileContext
                         -> (Maybe MappedPacket, Map.Map KeyKey (OriginMapped Query))
-                        -> IO PacketTranscoder
-makeMemoizingDecrypter operation ctx (workingkey,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
-    -- and the pws map keys must match the MappedPacket locations.
-    -- TODO: Perhaps these should both be of type InputFile rather than
-    -- FilePath?
-    -- pws :: Map.Map FilePath (IO S.ByteString)
-    {-
-    -- This disabled code obtained password sources from StreamInfo records.
-    pws <-
-        Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ)
-                         (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above
-                            $ Map.filter (isJust . pwfile . typ) $ opFiles operation)
-    -}
-        let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n"
-        -- List of file-specific password sources.
-        pws2 <-
-            Traversable.mapM (cachedContents prompt ctx)
-             $ Map.fromList $ mapMaybe
-                    (\spec -> (,passSpecPassFile spec) `fmap` do
-                        guard $ isNothing $ passSpecKeySpec spec
-                        passSpecRingFile spec)
-                    passspecs
-        -- List of general password sources.
-        defpw <- do
-            Traversable.mapM (cachedContents prompt ctx . passSpecPassFile)
-             $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp)
-                                            && isNothing (passSpecKeySpec sp))
-                                        $ passspecs
-        unkeysRef <- newIORef (Map.empty :: Map.Map (KeyKey,SymmetricAlgorithm,S2K) Packet)
-        return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw (not $ null agentspec)
-    else let PassphraseMemoizer f = head chains
-         in return f
+                        -> PassphraseSpec
+                        -> IO (KikiCondition (PassphraseSource, IO ()) )
+interpretPassSpec ctx keys PassphraseSpec { passSpecPassFile = fd
+                                          , passSpecKeySpec = keyspec
+                                          , passSpecRingFile = inputfile } = do
+    getpw <-
+        cachedContents (Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n")
+                       ctx
+                       fd
+    let matchkey fp mp = matchpr fp (packet mp) == fp
+        matchfile file mp = Map.member file (locations mp)
+        specializers = [ fmap matchkey keyspec, fmap matchfile inputfile]
+        specialize alg mp =
+            if and $ map (\f -> f mp) $ catMaybes specializers
+                then [ObtainedPassphrase <$> getpw]
+                else []
+    return $ KikiSuccess (specialize, return ())
+
+interpretPassSpec ctx keys PassphraseAgent = do
+    mb <- session
+    fromMaybe (return AgentConnectionFailure) $ do
+    agent <- mb
+    Just $ do
+    let cacheSearch alg mp =
+            case getQueries keys mp of
+                [] -> []
+                kqry:qs -> trace ("queries="++show (kqry:qs)) $
+                            map (sendQuery agent (AskNot,NextPassphrase)) (kqry:qs)
+                            ++ sendQuery agent (initial_ask,CanceledPassphrase) kqry
+                                : replicate 3 (sendQuery agent (AskAgain "Bad passphrase",CanceledPassphrase) kqry)
+                 where
+                   srcalg = symmetric_algorithm $ packet mp
+
+                   initial_ask | Unencrypted <- srcalg = AskNew
+                               | otherwise             = AskExisting
+
+    return $ KikiSuccess (cacheSearch, quit agent)
+
+sendQuery :: GnuPGAgent -> (QueryMode,PassphraseResponse) -> OriginMapped Query -> IO PassphraseResponse
+sendQuery agent (ask,failure) qry = do
+    mbpw <- getPassphrase agent ask (packet qry)
+    case mbpw of
+        Nothing -> do
+            S8.hPutStr stderr $ S8.pack $ "Failed to get passphrase "++show failure
+            return failure
+        Just pw -> do
+            -- S8.hPutStrLn stderr $ S8.pack $ "received pw: "++pw
+            return $ ObtainedPassphrase $ S8.pack pw
+
+getQueries :: (Maybe MappedPacket,Map KeyKey (OriginMapped Query)) -> OriginMapped Packet -> [OriginMapped Query]
+getQueries (workingkey,keys) mp =
+ let kk = keykey $ packet mp
+ in case Map.lookup kk keys of
+     Just qryk ->
+         case queryMainKey (packet qryk) of
+            Just maink ->
+                let kkmain = keykey maink
+                in case Map.lookup kkmain keys of
+                    Just qrym -> qryk : qrym : (Map.elems . Map.delete kkmain . Map.delete kk) keys
+                    Nothing -> [ qryk ]
+            Nothing -> [ qryk ]
+     Nothing ->
+        -- This is probably a newly imported key.  We'll treat the current working key as it's main key.
+        -- trace ("getQueries cache miss "++show (fingerprint $ packet mp)) []
+        let (qryk,qrym)
+             = fromMaybe (Query (packet mp) "anonymous2" Nothing,Nothing) $ do
+                    guard $ is_subkey (packet mp)
+                    working <- fmap packet workingkey
+                    q <- Map.lookup (keykey working) keys
+                    return ( Query (packet mp) (queryUID $ packet q) (Just working), Just q)
+            delm = case workingkey of
+                      Nothing -> id
+                      Just wk -> Map.delete (keykey $ packet wk)
+        in [ fmap (const qryk) mp ] ++ maybeToList qrym ++ (Map.elems . delm . Map.delete kk) keys
+
+
+makeTranscoder :: IORef (Map.Map (KeyKey,SymmetricAlgorithm,S2K) Packet)
+                -> IO (KikiCondition (PassphraseSource, IO ()))
+                -> ( (SymmetricAlgorithm,S2K) -> MappedPacket -> IO (KikiCondition Packet) )
+                -> ( (SymmetricAlgorithm,S2K) -> MappedPacket -> IO (KikiCondition Packet) )
+makeTranscoder unkeysRef source next alg mp = do
+    ssr <- source
+    case ssr of
+        KikiSuccess (getqs, quit) -> tries (quit >> next alg mp) $ getqs alg mp
+        er                        -> return $ fmap (error "makeTranscoder") er
  where
-    (chains,passspecs0) = partition isChain $ opPassphrases operation
-                            where isChain (PassphraseMemoizer {}) = True
-                                  isChain _                       = False
-    (agentspec,passspecs) = partition isAgent passspecs0
-                            where isAgent PassphraseAgent = True
-                                  isAgent _               = False
-    doDecrypt :: IORef (Map.Map (KeyKey,SymmetricAlgorithm,S2K) Packet)
-                -> Map.Map FilePath (IO S.ByteString)
-                -> Maybe (IO S.ByteString)
-                -> Bool
-                -> (SymmetricAlgorithm,S2K)
-                -> MappedPacket
-                -> IO (KikiCondition Packet)
-    doDecrypt unkeysRef pws defpw agent_requested (dest_alg,dest_s2k) mp0 = do
+    tries fin [] = fin
+    tries fin (src:srcs) = do
+        S8.hPutStrLn stderr "trying..."
+        resp <- src
+        case resp of
+            CanceledPassphrase    -> return OperationCanceled
+            NextPassphrase        -> tries fin srcs
+            ObtainedPassphrase pw -> do
+                let wkun = fromMaybe (packet mp) $ do
+                                guard $ symmetric_algorithm (packet mp) /= Unencrypted
+                                decryptSecretKey pw (packet mp)
+                    kk = keykey (packet mp)
+                    retryOrFail = tries fin srcs
+                case symmetric_algorithm wkun of
+                    Unencrypted -> do
+                        modifyIORef unkeysRef (Map.insert (kk,Unencrypted,S2K 100 "") wkun)
+                        ek <- case fst alg of
+                                Unencrypted -> do
+                                    S8.hPutStrLn stderr "decrypted packet"
+                                    return $ Just wkun
+                                _           -> encryptSecretKey pw (snd alg) (fst alg) wkun
+                        case ek of
+                            Nothing   -> do
+                                S8.hPutStrLn stderr "failed to encrypt"
+                                retryOrFail
+                            Just wken -> do
+                                S8.hPutStrLn stderr "success encrypted"
+                                let (a,s) = alg
+                                modifyIORef unkeysRef (Map.insert (kk,a,s) wken)
+                                return $ KikiSuccess wken
+                    _ -> do S8.hPutStrLn stderr "failed to decrypt"
+                            retryOrFail
+
+normalizeAlgorithm :: (SymmetricAlgorithm,S2K) -> (SymmetricAlgorithm,S2K)
+normalizeAlgorithm (Unencrypted,_) = (Unencrypted,S2K 100 "")
+normalizeAlgorithm alg             = alg
+
+transcodeWithCache :: IORef (Map (KeyKey, SymmetricAlgorithm, S2K) Packet)
+                      -> ( (SymmetricAlgorithm,S2K) -> MappedPacket -> IO (KikiCondition Packet) )
+                      -> ( (SymmetricAlgorithm,S2K) -> MappedPacket -> IO (KikiCondition Packet) )
+transcodeWithCache unkeysRef miss alg0 mp@MappedPacket{ packet = wk } = do
+        let alg = normalizeAlgorithm alg0
         unkeys <- readIORef unkeysRef
-        let (mp,qry) = fromMaybe (mp0,Query (packet mp0) "anonymous2" Nothing)
-                        $ mplus (do k <- Map.lookup kk keys
-                                    return (mergeKeyPacket "decrypt" mp0 (fmap queryPacket k), packet k))
-                                (do guard $ is_subkey (packet mp0)
-                                    working <- fmap packet workingkey
-                                    q <- fmap packet $ Map.lookup (keykey working) keys
-                                    return (mp0, Query (packet mp0) (queryUID q) (Just working)))
-
-            dest_s2k' | dest_alg==Unencrypted = S2K 100 ""
-                      | otherwise             = dest_s2k
-
-            wk = packet mp0
-            kk = keykey wk
-            fs = Map.keys $ locations mp
-
-            decryptIt [] = return BadPassphrase
-            decryptIt (getpw:getpws) = tries 1 getpw (decryptIt getpws)
-             where
-              tries count getpw recurse = do
-                -- TODO: This function should use mergeKeyPacket to
-                --  combine the packet with it's unspilled version before
-                --  attempting to decrypt it.  Note: We are uninterested
-                --  in the 'locations' field, so this would effectively
-                --  allow you to run 'decryptIt' on an unencrypted public key
-                --  to obtain it's secret key.
-                handleIO_ (decryptIt []) $ do
-                (pw0,wants_retry) <- getpw (count,qry)
-                case pw0 of
-                  KikiSuccess pw -> do
-                    let wkun = fromMaybe wk $ do
-                                    guard $ symmetric_algorithm (packet mp) /= Unencrypted
-                                    decryptSecretKey pw (packet mp)
-
-                        retryOrFail
-                            | Just clear <- wants_retry = if count < 4
-                                                            then tries (count+1) getpw recurse
-                                                            else clear >> recurse
-                            | otherwise                 = recurse
-
-                    case symmetric_algorithm wkun of
-
-                        Unencrypted -> do
-                            writeIORef unkeysRef (Map.insert (kk,Unencrypted,S2K 100 "") wkun unkeys)
-                            ek <- case dest_alg of
-                                    Unencrypted -> return $ Just wkun
-                                    _           -> encryptSecretKey pw dest_s2k' dest_alg wkun
-
-                            case ek of
-                                Nothing   -> retryOrFail
-                                Just wken -> do
-                                    modifyIORef unkeysRef (Map.insert (kk,dest_alg,dest_s2k') wken)
-                                    return $ KikiSuccess wken
-
-                        _ -> retryOrFail
-                  err -> return $ fmap (error "pasphrase error") err
-
-            getpws = (map (const . fmap (\pw -> (KikiSuccess pw,Nothing)))
-                        $ mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw) ++ [ agentpw | agent_requested ]
-
-            agentpw (count,qry) = do
-                    s <- session
-                    fromMaybe (return (AgentConnectionFailure,Nothing)) $ do
-                    s <- s
-                    Just $ do
-                    let (firsttime,maink) | Just k <- (queryMainKey qry) = (2,k)
-                                          | otherwise                    = (1,error "bug in makeMemoizingDecrypter")
-
-                        alg  = symmetric_algorithm (queryPacket qry)
-
-                        ask | count<firsttime  = AskNot
-                            | count>firsttime  = AskAgain "Bad passphrase"
-                            | count==firsttime = initial_ask
-                            where
-                               initial_ask | Unencrypted <- alg = AskNew
-                                           | otherwise          = AskExisting
-
-                        actual_qry | count<firsttime = qry { queryPacket = maink, queryMainKey = Nothing }
-                                   | otherwise       = qry
-
-                    let clear | count > firsttime = clearPassphrase s (queryPacket qry)
-                              | otherwise         = return ()
-                    clear
-                    let sanitizeQry qry = (fingerprint $ queryPacket qry, queryUID qry, fmap fingerprint $ queryMainKey qry)
-                    -- putStrLn $ "(count,firsttime,ask,qry,actual_qry)="++show (count,firsttime,ask,sanitizeQry qry, sanitizeQry actual_qry)
-                    mbpw <- getPassphrase s ask actual_qry
-                    quit s
-                    -- putStrLn $ "mbpw = " ++show mbpw
-                    return ( maybe (if count >=firsttime then OperationCanceled
-                                                         else KikiSuccess "") -- No cached data.
-                                   (KikiSuccess . S8.pack)
-                                   mbpw
-                           , guard (ask /= AskNew) >> Just clear )
-
         calls <- currentCallStack
-        putStrLn $ concat [fingerprint wk," ", show (symmetric_algorithm wk,s2k wk)," --> ",show (dest_alg,dest_s2k)]
+        putStrLn $ concat [fingerprint wk," ", show (symmetric_algorithm wk,s2k wk)," --> ",show alg]
         mapM_ putStrLn calls
-        if symmetric_algorithm wk == dest_alg && s2k wk == dest_s2k'
+        if (symmetric_algorithm wk,s2k wk) == alg
             then return (KikiSuccess wk)
-            else maybe (decryptIt getpws)
-                       (return . KikiSuccess)
-                    $ Map.lookup (kk,dest_alg,dest_s2k') unkeys
+            else maybe (miss alg mp) (return . KikiSuccess)
+                    $ Map.lookup (keykey wk,fst alg, snd alg) unkeys
+
+tryInOrder [] _ _        = return BadPassphrase
+tryInOrder [f] alg mp    = f alg mp
+tryInOrder (f:fs) alg mp = do
+    r <- f alg mp
+    case r of
+        KikiSuccess _ -> return r
+        e -> do
+            S8.hPutStrLn stderr $ S8.pack ("got "++errorString e++", trying next")
+            tryInOrder fs alg mp
+
+-- The transcoder works on 'MappedPacket' instead of 'Packet' so that
+-- file-specific passphrases can be utilized.
+makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext
+                        -> (Maybe MappedPacket, Map.Map KeyKey (OriginMapped Query))
+                        -> IO PacketTranscoder
+makeMemoizingDecrypter operation 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
+                        where isChain (PassphraseMemoizer {}) = True
+                              isChain _                       = False
+    srcs = map (interpretPassSpec ctx (workingkey,keys)) passpecs
+
+    trans unkeysRef = transcodeWithCache unkeysRef (foldr (makeTranscoder unkeysRef) (\_ _ -> return BadPassphrase) srcs)
 
 keyQueries :: Maybe String -> Map InputFile (StreamInfo,Message) -> (Maybe MappedPacket, Map KeyKey (OriginMapped Query))
 keyQueries grip ringPackets = (mwk, fmap makeQuery keys)
diff --git a/lib/Types.hs b/lib/Types.hs
index 686614e..dd519de 100644
--- a/lib/Types.hs
+++ b/lib/Types.hs
@@ -1,6 +1,8 @@
 {-# LANGUAGE DeriveFunctor #-}
 module Types where
 
+import           Data.Char (isLower,toLower)
+import           Data.List (groupBy)
 import           Data.Map as Map (Map)
 import qualified Data.Map as Map
 import           Data.OpenPGP
@@ -113,7 +115,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 PacketTranscoder
+    | PassphraseMemoizer { passSpecTranscoder :: PacketTranscoder }
     | PassphraseAgent
 
 instance Show PassphraseSpec where
@@ -125,7 +127,24 @@ instance Eq PassphraseSpec where
     _ == _
         = False
 
-
+-- Ord instance for PassphraseSpec generally orders by generality with the most
+-- general being greatest and the least general being least.  The one exception
+-- is the 'PassphraseMemoizer' which is considered least of all even though it
+-- is very general.  This is so an existing memoizer will be tried first, and
+-- if there is none, one will be created that tries the others in order of
+-- increasing generality.  Key-specialization is considered less general than
+-- file-specialization.
+instance Ord PassphraseSpec where
+    compare (PassphraseMemoizer _) (PassphraseMemoizer _) = EQ
+    compare PassphraseAgent PassphraseAgent               = EQ
+    compare (PassphraseMemoizer _) _                      = LT
+    compare (PassphraseSpec a b c) (PassphraseSpec d e f)
+        | fmap (const ()) a == fmap (const ()) d
+          && fmap (const ()) b == fmap (const ()) e       = compare (a,b,c) (d,e,f)
+    compare (PassphraseSpec (Just _) (Just _) _)  _       = LT
+    compare (PassphraseSpec Nothing (Just _) _) _         = LT
+    compare (PassphraseSpec (Just _) _  _) _              = LT
+    compare PassphraseAgent _                             = GT
 
 data Transform =
         Autosign
@@ -253,6 +272,21 @@ instance Applicative KikiCondition where
                             Left err -> err
             Left err -> err
 
+uncamel :: String -> String
+uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args
+  where
+    (.:) = fmap . fmap
+    ( firstWord  ,
+      otherWords ) = splitAt 1 ws
+    ws             = camel >>= groupBy (\_ c -> isLower c)
+    ( camel, args) = splitAt 1 $ words str
+
+errorString :: KikiCondition a -> String
+errorString (KikiSuccess {}) = "success"
+errorString e = uncamel . show $ fmap (const ()) e
+
+
+
 data InputFileContext = InputFileContext
     { homesecPath :: FilePath
     , homepubPath :: FilePath