Better gpg-agent support.

1 files changed, 114 insertions, 23 deletions

diff --git a/lib/PacketTranscoder.hs b/lib/PacketTranscoder.hs
index 651b00c..07f235c 100644
--- a/lib/PacketTranscoder.hs
+++ b/lib/PacketTranscoder.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternGuards #-}
 module PacketTranscoder where
 
 import Control.Monad
@@ -11,7 +12,8 @@ import Data.OpenPGP.Util
 import GnuPGAgent
 import qualified Data.ByteString       as S
 import qualified Data.ByteString.Char8 as S8
-import qualified Data.Map              as Map
+import           Data.Map as Map (Map)
+import qualified Data.Map as Map
 import qualified Data.Traversable      as Traversable
 import System.IO              ( stderr)
 import System.Posix.IO        ( fdToHandle )
@@ -92,9 +94,9 @@ cachedContents maybePrompt ctx fd = do
 
 
 makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext
-                        -> Map.Map KeyKey (OriginMapped Query)
+                        -> (Maybe MappedPacket, Map.Map KeyKey (OriginMapped Query))
                         -> IO PacketTranscoder
-makeMemoizingDecrypter operation ctx keys = do
+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
@@ -144,9 +146,14 @@ makeMemoizingDecrypter operation ctx keys = do
                 -> IO (KikiCondition Packet)
     doDecrypt unkeysRef pws defpw agent_requested (dest_alg,dest_s2k) mp0 = do
         unkeys <- readIORef unkeysRef
-        let (mp,qry) = fromMaybe (mp0,Query (packet mp0) "anonymous2" Nothing) $ do
-                        k <- Map.lookup kk keys
-                        return (mergeKeyPacket "decrypt" mp0 (fmap queryPacket k), packet k)
+        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)))
+
             wk = packet mp0
             kk = keykey wk
             fs = Map.keys $ locations mp
@@ -161,39 +168,60 @@ makeMemoizingDecrypter operation ctx keys = do
                 --  in the 'locations' field, so this would effectively
                 --  allow you to run 'decryptIt' on an unencrypted public key
                 --  to obtain it's secret key.
-                (pw,wants_retry) <- getpw (if count>1 then AskAgain "Bad pasphrase." else Ask,qry)
+                (pw,wants_retry) <- getpw (count,qry)
                 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 wkun unkeys)
-                        ek <- if dest_alg==Unencrypted
-                                then return $ Just wkun
-                                else encryptSecretKey pw dest_s2k dest_alg wkun
+                        ek <- case dest_alg of
+                                Unencrypted -> return $ Just wkun
+                                _           -> encryptSecretKey pw dest_s2k dest_alg wkun
                         case ek of
-                            Nothing | wants_retry && count<3 -> tries (count+1) getpw recurse
-                            Nothing                          -> recurse
-                            Just wken                        -> return $ KikiSuccess wken
+                            Nothing   -> retryOrFail
+                            Just wken -> return $ KikiSuccess wken
 
-                    _ -> recurse
+                    _ -> retryOrFail
 
-            getpws = (map (const . fmap (,False)) $ mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw) ++ [ agentpw | agent_requested ]
+            getpws = (map (const . fmap (,Nothing)) $ mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw) ++ [ agentpw | agent_requested ]
 
-            -- TODO: First we should try the master key with AskNot.
-            -- If that fails, we should try the subkey.
-            agentpw (ask,qry) = do
+            agentpw (count,qry) = do
                     s <- session
-                    fromMaybe (return ("",False)) $ do
+                    fromMaybe (return ("",Nothing)) $ do
                     s <- s
                     Just $ do
-                    case ask of AskAgain _ -> clearPassphrase s (queryPacket qry)
-                                _          -> return ()
-                    mbpw <- getPassphrase s ask qry
+                    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
-                    return ( maybe "" S8.pack mbpw, True)
+                    return ( maybe "" S8.pack mbpw, guard (ask /= AskNew) >> Just clear )
 
         if symmetric_algorithm wk == dest_alg
             && ( symmetric_algorithm wk == Unencrypted || s2k wk == dest_s2k )
@@ -202,3 +230,66 @@ makeMemoizingDecrypter operation ctx keys = do
                        (return . KikiSuccess)
                     $ Map.lookup kk unkeys
 
+keyQueries :: Maybe String -> Map InputFile (StreamInfo,Message) -> (Maybe MappedPacket, Map KeyKey (OriginMapped Query))
+keyQueries grip ringPackets = (mwk, fmap makeQuery keys)
+ where
+    makeQuery (maink,mp,us) = mp { packet = q }
+        where q = Query { queryPacket = packet mp
+                        , queryUID = concat $ take 1 $ Map.keys $ Map.union us (getUIDS maink)
+                        , queryMainKey = if is_subkey (packet mp)
+                                            then maink `mplus` fmap packet mwk
+                                            else Nothing
+                        }
+
+    getUIDS maink = fromMaybe Map.empty $ do
+        k <- maink
+        (_,_,mus) <- Map.lookup (keykey k) keys
+        return mus
+
+    -- | mwk 
+    -- first master key matching the provided grip
+    -- (the m is for "MappedPacket", wk for working key)
+    mwk :: Maybe MappedPacket
+    mwk = listToMaybe $ do
+            fp <- maybeToList grip
+            let matchfp mp
+                 | not (is_subkey p) && matchpr fp p == fp = Just mp
+                 | otherwise                               = Nothing
+                    where p = packet mp
+            Map.elems $ Map.mapMaybe matchfp $ fmap (\(_,p,_) -> p) $ keys
+
+    keys = Map.foldl slurpkeys Map.empty
+                        $ Map.mapWithKey filterSecrets ringPackets
+     where
+      filterSecrets :: InputFile -> (a,Message) -> [[MappedPacket]]
+      filterSecrets f (_,Message ps)  = keygroups
+        -- filter (isSecretKey . packet) mps
+        where
+          mps = zipWith (mappedPacketWithHint fname) ps [1..]
+          fname = resolveForReport Nothing f -- (Just ctx) f
+          keygroups = dropWhile (not . isSecretKey . packet . head)
+                      $ groupBy (const $ not . isSecretKey . packet) mps
+      slurpkeys :: (Map KeyKey (Maybe Packet,MappedPacket,Map String [Packet]))
+                    -> [[MappedPacket]]
+                    -> (Map KeyKey (Maybe Packet, MappedPacket,Map String [Packet]))
+      slurpkeys m pss = Map.unionWith combineKeyKey m m2
+        where
+
+            m2 :: Map.Map KeyKey (Maybe Packet, MappedPacket, (Map.Map String [Packet]))
+            m2 = Map.fromList
+                    $ drop 1
+                    $ scanl' build ([],(Nothing,error "bug in PacketTranscoder (1)", error "bug in PacketTranscoder (2)")) pss
+                where
+                    build (_,(main0,_,_)) ps = (kk,(main,kp,uidmap ps'))
+                     where
+                        main | is_subkey (packet kp) = main0
+                             | otherwise             = Just $ packet kp
+                        (kpkt,ps') = splitAt 1 ps
+                        kp = head kpkt
+                        kk = keykey . packet $ kp
+            combineKeyKey (master1,mp,um) (master2,mp2,um2) = (master1 `mplus` master2,mp,Map.unionWith (++) um um2)
+            uidmap ps = um2
+             where
+                ugs = dropWhile (not . isUserID . packet .head) $ groupBy (const $ not . isUserID . packet) ps
+                um2 = Map.fromList
+                        $ map (\(MappedPacket (UserIDPacket s) _:sigs)->(s,takeWhile isSignaturePacket $ map packet sigs)) ugs