Better gpg-agent support.

5 files changed, 229 insertions, 159 deletions

diff --git a/lib/GnuPGAgent.hs b/lib/GnuPGAgent.hs
index 4a0e8c8..5878357 100644
--- a/lib/GnuPGAgent.hs
+++ b/lib/GnuPGAgent.hs
@@ -60,15 +60,15 @@ percentPlusEscape :: String -> String
 percentPlusEscape s = do
     c <- s
     case c of
-        ' ' -> "+"
-        '+' -> "%2B"
-        '"' -> "%22"
-        '%' -> "%25"
+        ' '         -> "+"
+        '+'         -> "%2B"
+        '"'         -> "%22"
+        '%'         -> "%25"
         _ | c < ' ' -> printf "%%%02X" (ord c)
-        _ -> return c
+        _           -> return c
 
 clearPassphrase agent key = do
-    let cmd = "clear_passphrase "++fingerprint key
+    let cmd = "clear_passphrase --mode=normal "++fingerprint key
     hPutStrLn (agentHandle agent) cmd
 
 data Query = Query
@@ -78,21 +78,22 @@ data Query = Query
     }
  deriving Show
 
-data QueryMode = AskNot | AskAgain String | Ask
+data QueryMode = AskNot | AskAgain String | AskExisting | AskNew
  deriving (Show,Eq,Ord)
 
 getPassphrase :: GnuPGAgent -> QueryMode -> Query -> IO (Maybe String)
 getPassphrase agent ask (Query key uid masterkey) = do
     let (er0,pr,desc) = prompts key uid masterkey
         (er,askopt) = case ask of
-                        AskNot         -> (er0,"--no-ask")
+                        AskNot         -> (er0,"--no-ask ")
                         AskAgain ermsg -> (ermsg,"")
-                        Ask            -> (er0,"")
+                        AskExisting    -> (er0,"")
+                        AskNew         -> (er0,"--repeat=1 ")
         cmd = "get_passphrase "++askopt++fingerprint key++" "++unwords (map percentPlusEscape [er,pr,desc])
-    -- putStrLn cmd
+    hPutStrLn stderr $ "gpg-agent <- " ++ cmd
     hPutStrLn (agentHandle agent) cmd
     r0 <- hGetLine (agentHandle agent)
-    -- putStrLn $ "agent says: " ++ r0
+    -- hPutStrLn stderr $ "agent says: " ++ r0
     case takeWhile (/=' ') r0 of
         "OK" -> hGetLine (agentHandle agent) >>= unhex . drop 3
             where
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index 313258d..e084fcd 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -23,6 +23,7 @@
 {-# LANGUAGE DoAndIfThenElse #-}
 {-# LANGUAGE PatternGuards #-}
 {-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE LambdaCase #-}
 module KeyRing
     (
     -- * Error Handling
@@ -84,6 +85,7 @@ module KeyRing
     , accBindings
     , isSubkeySignature
     , torhash
+    , torUIDFromKey
     , ParsedCert(..)
     , parseCertBlob
     , packetFromPublicRSAKey
@@ -186,7 +188,7 @@ import Foreign.C.Error ( throwErrnoIfMinus1_ )
 import Foreign.Storable
 #endif
 import System.FilePath ( takeDirectory )
-import System.IO (hPutStrLn,withFile,IOMode(..), Handle, hPutStr, stderr)
+import System.IO (hPutStrLn,withFile,IOMode(..), Handle, hPutStr, stderr, hClose)
 import Data.IORef
 import System.Posix.IO ( fdToHandle )
 import qualified Data.Traversable as Traversable
@@ -624,14 +626,6 @@ usageString flgs =
 
 
 
--- matchpr computes the fingerprint of the given key truncated to
--- be the same lenght as the given fingerprint for comparison.
---
--- matchpr fp = Data.List.Extra.takeEnd (length fp)
---
-matchpr :: String -> Packet -> String
-matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp
-
 keyFlags :: t -> [Packet] -> [SignatureSubpacket]
 keyFlags  wkun uids = keyFlags0 wkun (filter isSignaturePacket uids)
 
@@ -1181,7 +1175,7 @@ writeStampedL ctx f stamp bs = writeStamped0 ctx f stamp (either L.hPut L.writeF
 -}
 
 writeStamped :: InputFileContext -> InputFile -> Posix.EpochTime -> String -> IO ()
-writeStamped ctx f stamp str = writeStamped0 ctx f stamp (either hPutStr writeFile) str
+writeStamped ctx f stamp str = writeStamped0 ctx f stamp (either (\h x-> hPutStr h x >> hClose h)  writeFile) str
 
 getInputFileTime :: InputFileContext -> InputFile -> IO CTime
 getInputFileTime ctx (Pipe fdr fdw) = do
@@ -1222,7 +1216,7 @@ generateSubkey transcode kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
     if null subs
       then do
         newkey <- generateKey genparam
-        kdr <- insertSubkey transcode (keykey (keyPacket kd)) kd [mkUsage tag] "" newkey
+        kdr <- insertSubkey transcode (keykey (keyPacket kd)) kd [mkUsage tag] (ArgFile "") newkey
         try kdr $ \(newkd,report) -> do
         return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)])
       else do
@@ -1233,7 +1227,7 @@ importSecretKey ::
   (PacketTranscoder)
   -> KikiCondition
        (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])
-  -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t)
+  -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t)
   -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
 importSecretKey transcode db' tup = do
             try db' $ \(db',report0) -> do
@@ -1345,10 +1339,6 @@ writeHostsFiles krd ctx (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do
         return $ map (first $ resolveForReport $ Just ctx) rs
     return $ concat rss
 
-isSecretKey :: Packet -> Bool
-isSecretKey (SecretKeyPacket {}) = True
-isSecretKey _                    = False
-
 -- | buildKeyDB
 --
 --   merge all keyrings, PEM files, and wallets into process memory.
@@ -1368,11 +1358,10 @@ buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation
                                     )
                                    ,{- report_imports -} [(FilePath,KikiReportAction)]))
 buildKeyDB ctx grip0 keyring = do
-    let 
-        files istyp = do
+    let files istyp = do
             (f,stream) <- Map.toList (opFiles keyring)
             guard (istyp $ typ stream)
-            resolveInputFile ctx f
+            return f -- resolveInputFile ctx f
 
         ringMap0 = Map.filter (isring . typ) $ opFiles keyring
         (genMap,ringMap) = Map.partitionWithKey isgen ringMap0
@@ -1392,7 +1381,7 @@ buildKeyDB ctx grip0 keyring = do
                                     _                                -> AutoAccess
                             acc -> acc
 
-        readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n))
+        readw wk n = fmap (n,) (readPacketsFromWallet wk n)
 
     -- KeyRings (todo: KikiCondition reporting?)
     (spilled,mwk,grip,accs,keyqs,unspilled) <- do
@@ -1418,69 +1407,17 @@ buildKeyDB ctx grip0 keyring = do
             -- | keys
             -- process ringPackets, and get a map of fingerprint info to 
             -- to a packet, remembering it's original file, access.
-            keys :: Map.Map KeyKey (MappedPacket,Map.Map String [Packet])
-            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 (Just ctx) f
-                              keygroups = dropWhile (not . isSecretKey . packet . head)
-                                          $ groupBy (const $ not . isSecretKey . packet) mps
-                          slurpkeys :: (Map.Map KeyKey (MappedPacket,Map.Map String [Packet]))
-                                        -> [[MappedPacket]]
-                                        -> (Map.Map KeyKey (MappedPacket,Map.Map String [Packet]))
-                          slurpkeys m pss = Map.unionWith combineKeyKey m m2
-                            where
-                                m2 :: Map.Map KeyKey (MappedPacket, (Map.Map String [Packet]))
-                                m2 = Map.fromList $ map build pss
-                                    where
-                                        build ps = (kk,(kp,uidmap ps'))
-                                         where
-                                            (kpkt,ps') = splitAt 1 ps
-                                            kp = head kpkt
-                                            kk = keykey . packet $ kp
-                                combineKeyKey (mp,um) (mp2,um2) = (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
-            -- | mwk 
-            -- first master key matching the provided grip
-            -- (the m is for "MappedPacket", wk for working key)
-            mwk = fst <$> mwkq
-
-            main_query = fromMaybe (Query MarkerPacket "anonymous1" Nothing) $ snd <$> mwkq
-
-            keyqs :: Map.Map KeyKey (OriginMapped Query)
-            keyqs = fmap (\(mp,us) -> mp { packet = main_query { queryPacket = packet mp} }) keys
-
-            mwkq :: Maybe (MappedPacket,Query)
-            mwkq = listToMaybe $ do
-                    fp <- maybeToList grip
-                    let matchfp (mp,us)
-                         | not (is_subkey p) && matchpr fp p == fp = Just (mp,query p us)
-                         | otherwise                               = Nothing
-                            where p = packet mp
-                                  -- TODO: check signature on UID packet?
-                                  -- TODO: custom queries for subkeys?
-                                  query p us = Query p
-                                                     (fromMaybe "" $ listToMaybe $ Map.keys us)
-                                                     Nothing -- No subkey queries for now.
-                    Map.elems $ Map.mapMaybe matchfp keys
+            keys :: Map.Map KeyKey (OriginMapped Query)
+            mwk :: Maybe MappedPacket
+            (mwk, keys) = keyQueries grip ringPackets
 
             -- | accs
             -- file access(Sec | Pub) lookup table
             accs :: Map.Map InputFile Access
             accs = fmap (access . fst) ringPackets
-        return (spilled,mwk,grip,accs,keyqs,fmap snd unspilled)
+        return (spilled,mwk,grip,accs,keys,fmap snd unspilled)
 
-    putStrLn $ ppShow keyqs
-    transcode <- makeMemoizingDecrypter keyring ctx keyqs
+    transcode <- makeMemoizingDecrypter keyring ctx (mwk,keyqs)
     let doDecrypt = transcode (Unencrypted,S2K 100 "")
 
     let wk = fmap packet mwk
@@ -1548,7 +1485,6 @@ buildKeyDB ctx grip0 keyring = do
     let pems = do
             (n,stream) <- Map.toList $ opFiles keyring
             grip <- maybeToList grip
-            n <- resolveInputFile ctx n
             guard $ spillable stream && isSecretKeyFile (typ stream)
             let us = mapMaybe usageFromFilter [fill stream,spill stream]
             usage <- take 1 us
@@ -1559,7 +1495,10 @@ buildKeyDB ctx grip0 keyring = do
                 ms = map fst $ filterMatches topspec (Map.toList db)
                 cmd = initializer stream
             return (n,subspec,ms,stream, cmd)
-    imports <- filterM (\(n,_,_,_,_) -> doesFileExist n) pems
+
+    imports <- filterM (\case (ArgFile n,_,_,_,_) -> doesFileExist n
+                              _                   -> return True)
+                       pems
     db <- foldM (importSecretKey transcode) (KikiSuccess (db,[])) imports
     try db $ \(db,reportPEMs) -> do
 
@@ -1595,6 +1534,9 @@ generateInternals transcode mwk db gens = do
 torhash :: Packet -> String
 torhash key = fromMaybe "" $ derToBase32 <$> derRSA key
 
+torUIDFromKey :: Packet -> String
+torUIDFromKey key = "Anonymous <root@" ++ take 16 (torhash key) ++ ".onion>"
+
 derToBase32 :: ByteString -> String
 derToBase32 = map toLower . base32 . sha1
  where
@@ -1827,19 +1769,19 @@ readSecretPEMFile fname = do
 doImport
   :: PacketTranscoder
      -> Map.Map KeyKey KeyData
-     -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t)
+     -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t)
      -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
 doImport transcode db (fname,subspec,ms,typ -> typ,_) = do
     flip (maybe $ return CannotImportMasterKey)
          subspec $ \tag -> do
     (certs,keys) <- case typ of
         PEMFile -> do
-            ps <- readSecretPEMFile (ArgFile fname)
+            ps <- readSecretPEMFile fname
             let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys)
                     = partition (isJust . spemCert) ps
             return (certs,keys)
         DNSPresentation -> do
-            p <- readSecretDNSFile (ArgFile fname)
+            p <- readSecretDNSFile fname
             return ([],[p])
     -- TODO Probably we need to move to a new design where signature
     -- packets are merged into the database in one phase with null
@@ -1852,7 +1794,7 @@ doImport transcode db (fname,subspec,ms,typ -> typ,_) = do
         try prior $ \(db,report) -> do
         let (m0,tailms) = splitAt 1 ms
         if (not (null tailms) || null m0)
-            then return $ AmbiguousKeySpec fname
+            then return $ AmbiguousKeySpec (resolveForReport Nothing fname)
             else do
                 let kk = keykey key
                     cs = filter (\c -> kk==keykey (pcertKey c)) certs
@@ -1872,7 +1814,7 @@ doImportG
      -> Map.Map KeyKey KeyData
      -> [KeyKey] -- m0,  only head is used
      -> [SignatureSubpacket] -- tags
-     -> FilePath
+     -> InputFile
      -> Packet
      -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
 doImportG transcode db m0 tags fname key = do
@@ -1881,13 +1823,16 @@ doImportG transcode db m0 tags fname key = do
     kdr <- insertSubkey transcode kk kd tags fname key
     try kdr $ \(kd',rrs) -> return $ KikiSuccess (Map.insert kk kd' db, rrs)
 
-insertSubkey transcode kk (KeyData top topsigs uids subs) tags fname key0 = do
+insertSubkey transcode kk (KeyData top topsigs uids subs) tags inputfile key0 = do
     let topcipher = symmetric_algorithm $ packet top
         tops2k    = s2k $ packet top
+        doDecrypt = transcode (Unencrypted,S2K 100 "")
+        fname = resolveForReport Nothing inputfile
+    wkun <- doDecrypt top
+    try wkun $ \wkun -> do
     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 )
@@ -1903,7 +1848,7 @@ insertSubkey transcode kk (KeyData top topsigs uids subs) tags fname key0 = do
 
         istor = do
             guard ("tor" `elem` mapMaybe usage tags)
-            return $ "Anonymous <root@" ++ take 16 (torhash key) ++ ".onion>"
+            return $ torUIDFromKey key
 
     uids' <- flip (maybe $ return $ KikiSuccess (uids,[])) istor $ \idstr -> do
                 let has_torid = do
@@ -1913,9 +1858,6 @@ insertSubkey transcode kk (KeyData top topsigs uids subs) tags fname key0 = do
                          s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts))
                          signatures_over $ verify (Message [packet top]) s
                 flip (flip maybe $ const $ return $ KikiSuccess (uids,[])) has_torid $ do
-                wkun <- doDecrypt top
-
-                try wkun $ \wkun -> do
 
                 let keyflags = keyFlags wkun (map packet $ flattenAllUids fname True uids)
                     uid = UserIDPacket idstr
@@ -2482,7 +2424,7 @@ initializeMissingPEMFiles operation ctx grip mwk transcode db = do
                     guard $ case r of
                        ExternallyGeneratedFile -> True
                        _ -> False
-                    return (f,subspec,map fst ms,stream,cmd)
+                    return (ArgFile f,subspec,map fst ms,stream,cmd)
 
            try v $ \(db,import_rs) -> do
 
@@ -3143,25 +3085,6 @@ data KeyData = KeyData { keyMappedPacket :: MappedPacket    -- main key
 
 type KeyDB = Map.Map KeyKey KeyData
 
-origin :: Packet -> Int -> OriginFlags
-origin p n = OriginFlags ispub n
- where
-    ispub = case p of
-                    SecretKeyPacket {} -> False
-                    _                  -> True
-
-mappedPacket :: FilePath -> Packet -> MappedPacket
-mappedPacket filename p = MappedPacket
-    { packet = p
-    , locations = Map.singleton filename (origin p (-1))
-    }
-
-mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket
-mappedPacketWithHint filename p hint = MappedPacket
-    { packet = p
-    , locations = Map.singleton filename (origin p hint)
-    }
-
 uidkey :: Packet -> String
 uidkey (UserIDPacket str) = str
 
diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index 25c98e2..c042540 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -2,9 +2,10 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Kiki where
 
-import Control.Exception
 import Control.Applicative
 import Control.Arrow
+import Control.Concurrent
+import Control.Exception
 import Control.Monad
 import Data.ASN1.BinaryEncoding
 import Data.ASN1.Encoding
@@ -22,6 +23,7 @@ import System.FilePath.Posix
 import System.IO
 import System.IO.Temp
 import System.IO.Error
+import System.Posix.IO as Posix (createPipe)
 import System.Posix.User
 import System.Process
 import System.Posix.Files
@@ -37,6 +39,7 @@ import qualified Data.ByteString.Lazy.Char8 as Char8
 import qualified Data.Map.Strict as Map
 import qualified SSHKey as SSH
 
+import GnuPGAgent (Query(..))
 import CommandLine
 import KeyRing
 import DotLock
@@ -138,9 +141,9 @@ importAndRefresh root cmn = do
 
     let passfd = cap_passfd cmn
 
-    pwds <-
+    (torgen,pwds) <-
      if gotsec
-      then return []
+      then return (Generate 0 $ GenRSA $ 1024 `div` 8, [])
       else do
         {-  ssh-keygen to create master key...
         let mkpath = home ++ "/master-key"
@@ -154,36 +157,47 @@ importAndRefresh root cmn = do
                         HomeSec
                         ( encode $ Message [mk { is_subkey = False }] )
         -}
-        master_un <- (\k -> k { is_subkey = False }) <$> generateKey (GenRSA $ 4096 `div` 8 )
+        master_un <- (\k -> MappedPacket (k { is_subkey = False }) Map.empty) <$> generateKey (GenRSA $ 4096 `div` 8 )
+        tor_un <- generateKey (GenRSA $ 1024 `div` 8 )
+        (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 ()
         let default_cipher = (CAST5 {- AES128 -}, IteratedSaltedS2K SHA1 4073382889203176146 7864320)
             ctx = InputFileContext secring pubring
+            main_passwds = withAgent $ do pfd <- maybeToList passfd
+                                          return $ PassphraseSpec Nothing Nothing pfd
             passwordop = KeyRingOperation
                             { opFiles = Map.empty
                             -- TODO: ask agent for new passphrase
-                            , opPassphrases = do pfd <- maybeToList passfd
-                                                 return $ PassphraseSpec Nothing Nothing pfd
+                            , opPassphrases = main_passwds
                             , opHome = homespec
                             , opTransforms = []
                             }
-        transcoder <- makeMemoizingDecrypter passwordop ctx Map.empty
-        master0 <- transcoder default_cipher $ MappedPacket master_un Map.empty
+        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 default_cipher master_un
         case master0 of
             KikiSuccess master -> do
                 mkdirFor secring
                 writeInputFileL ctx
                                 HomeSec
-                                $ encode $ Message [master { is_subkey = False}]
+                                $ encode $ Message [master]
                 putStrLn "Wrote master key"
-                return [PassphraseMemoizer transcoder]
+                return (FileDesc read_tor, [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}]
+                                $ encode $ Message [packet master_un]
                 putStrLn "Wrote master key"
-                return []
+                return (Generate 0 (GenRSA $ 1024 `div` 8 ), [])
     gotpub <- doesFileExist pubring
     when (not gotpub) $ do
         mkdirFor pubring
@@ -233,7 +247,14 @@ importAndRefresh root cmn = do
              { opFiles = Map.fromList $
                 [ ( HomeSec, buildStreamInfo KF_All KeyRingFile )
                 , ( HomePub, (buildStreamInfo KF_All KeyRingFile) { access = Pub } )
-                , ( Generate 0 (GenRSA (1024 `div` 8)), strm { spill = KF_Match "tor" })
+                , ( torgen , case torgen of
+                                FileDesc _ -> StreamInfo { typ = PEMFile
+                                                         , fill = KF_Match "tor"
+                                                         , spill = KF_Match "tor"
+                                                         , access = Sec
+                                                         , initializer = NoCreate
+                                                         , transforms = [] }
+                                _          -> strm { spill = KF_Match "tor" })
                 , ( Generate 1 (GenRSA (1024 `div` 8)), strm { spill = KF_Match "ipsec" })
                 , ( ArgFile sshcpath, (peminfo 2048 "ssh-client") )
                 , ( ArgFile sshspath, (peminfo 2048 "ssh-server") )
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
diff --git a/lib/Types.hs b/lib/Types.hs
index 9aa0340..767ee98 100644
--- a/lib/Types.hs
+++ b/lib/Types.hs
@@ -1,12 +1,13 @@
 {-# LANGUAGE DeriveFunctor #-}
 module Types where
 
-import           Data.Map           as Map (Map)
+import           Data.Map as Map (Map)
+import qualified Data.Map as Map
 import           Data.OpenPGP
 import           Data.OpenPGP.Util
 import           FunctorToMaybe
-import qualified System.Posix.Types as Posix
 import qualified Data.ByteString.Lazy as L
+import qualified System.Posix.Types as Posix
 
 -- | This type describes an idempotent transformation (merge or import) on a
 -- set of GnuPG keyrings and other key files.
@@ -199,6 +200,26 @@ data OriginMapped a = MappedPacket
 instance Functor OriginMapped where
     fmap f (MappedPacket x ls) = MappedPacket (f x) ls
 
+origin :: Packet -> Int -> OriginFlags
+origin p n = OriginFlags ispub n
+ where
+    ispub = case p of
+                    SecretKeyPacket {} -> False
+                    _                  -> True
+
+mappedPacket :: FilePath -> Packet -> MappedPacket
+mappedPacket filename p = MappedPacket
+    { packet = p
+    , locations = Map.singleton filename (origin p (-1))
+    }
+
+mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket
+mappedPacketWithHint filename p hint = MappedPacket
+    { packet = p
+    , locations = Map.singleton filename (origin p hint)
+    }
+
+
 -- | This type is used to indicate success or failure
 -- and in the case of success, return the computed object.
 -- The 'FunctorToMaybe' class is implemented to facilitate
@@ -252,6 +273,11 @@ isKey (PublicKeyPacket {}) = True
 isKey (SecretKeyPacket {}) = True
 isKey _                    = False
 
+isSecretKey :: Packet -> Bool
+isSecretKey (SecretKeyPacket {}) = True
+isSecretKey _                    = False
+
+
 isUserID :: Packet -> Bool
 isUserID (UserIDPacket {}) = True
 isUserID _                 = False
@@ -260,4 +286,12 @@ isTrust :: Packet -> Bool
 isTrust (TrustPacket {}) = True
 isTrust _                = False
 
+-- matchpr computes the fingerprint of the given key truncated to
+-- be the same lenght as the given fingerprint for comparison.
+--
+-- matchpr fp = Data.List.Extra.takeEnd (length fp)
+--
+matchpr :: String -> Packet -> String
+matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp
+