Basic gpg-agent support.

1 files changed, 120 insertions, 37 deletions

diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index ae2d14d..a055dad 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -47,7 +47,8 @@ module KeyRing
     , KeyFilter(..)
     -- * Results of a KeyRing Operation
     , KeyRingRuntime(..)
-    , MappedPacket(..)
+    , OriginMapped(..)
+    , MappedPacket
     , KeyDB
     , KeyData(..)
     , SubKey(..)
@@ -209,6 +210,7 @@ import Base58
 import FunctorToMaybe
 import DotLock
 import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) )
+import GnuPGAgent as Agent
 
 -- DER-encoded elliptic curve ids
 -- nistp256_id  = 0x2a8648ce3d030107
@@ -429,6 +431,7 @@ data PassphraseSpec = PassphraseSpec
     }
     -- | Use this to carry pasphrases from a previous run.
     | PassphraseMemoizer PacketTranscoder
+    | PassphraseAgent
 
 instance Show PassphraseSpec where
     show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c)
@@ -1433,6 +1436,9 @@ doesInputFileExist ctx f = do
 -}
 
 
+-- | Reads contents of an 'InputFile' or returns the cached content from a prior call.
+-- An optional prompt is provided and will be printed on stdout only in the case that
+-- the provided 'InputFile' is 'FileDesc' 0 (i.e. stdin).
 cachedContents :: Maybe S.ByteString -> InputFileContext -> InputFile -> IO (IO S.ByteString)
 cachedContents maybePrompt ctx fd = do
     ref <- newIORef Nothing
@@ -1637,7 +1643,7 @@ buildKeyDB ctx grip0 keyring = do
         readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n))
 
     -- KeyRings (todo: KikiCondition reporting?)
-    (spilled,mwk,grip,accs,keys,unspilled) <- do
+    (spilled,mwk,grip,accs,keyqs,unspilled) <- do
 #if MIN_VERSION_containers(0,5,0)
         ringPackets <- Map.traverseWithKey readp ringMap
 #else
@@ -1660,32 +1666,69 @@ 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
+            keys :: Map.Map KeyKey (MappedPacket,Map.Map String [Packet])
             keys = Map.foldl slurpkeys Map.empty
                         $ Map.mapWithKey filterSecrets ringPackets
                     where
-                          filterSecrets f (_,Message ps) =
-                            filter (isSecretKey . packet)
-                                $ zipWith (mappedPacketWithHint fname) ps [1..]
-                            where fname = resolveForReport (Just ctx) f
-                          slurpkeys m ps = m `Map.union` Map.fromList ps'
-                            where ps' = zip (map (keykey . packet) ps) ps
+                          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 :: Maybe MappedPacket
-            mwk = listToMaybe $ do
+            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 = not (is_subkey p) && matchpr fp p == fp
+                    let matchfp (mp,us)
+                         | not (is_subkey p) && matchpr fp p == fp = Just (mp,query p us)
+                         | otherwise                               = Nothing
                             where p = packet mp
-                    Map.elems $ Map.filter matchfp keys
+                                  -- 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
+
             -- | accs
             -- file access(Sec | Pub) lookup table
             accs :: Map.Map InputFile Access
             accs = fmap (access . fst) ringPackets
-        return (spilled,mwk,grip,accs,keys,fmap snd unspilled)
+        return (spilled,mwk,grip,accs,keyqs,fmap snd unspilled)
 
-    transcode <- makeMemoizingDecrypter keyring ctx keys
+    putStrLn $ ppShow keyqs
+    transcode <- makeMemoizingDecrypter keyring ctx keyqs
     let doDecrypt = transcode (Unencrypted,S2K 100 "")
 
     let wk = fmap packet mwk
@@ -1707,6 +1750,9 @@ buildKeyDB ctx grip0 keyring = do
                 r <- performManipulations doDecrypt rt1 mwk manip
                 try r $ \(rt2,report) -> do
                 return $ KikiSuccess (report,rtKeyDB rt2)
+        -- XXX: Unspilled keys are not obtainable from rtKeyDB.
+        --  If the working key is marked non spillable, then how
+        --  would we look up it's UID and such?
 #if MIN_VERSION_containers(0,5,0)
         in fmap sequenceA $ Map.traverseWithKey trans spilled
 #else
@@ -2544,7 +2590,7 @@ writePEMKeys doDecrypt db exports = do
         return $ KikiSuccess (fname,stream,pun)
 
 makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext
-                        -> Map.Map KeyKey MappedPacket
+                        -> Map.Map KeyKey (OriginMapped Query)
                         -> IO PacketTranscoder
 makeMemoizingDecrypter operation ctx keys = do
    if null chains then  do
@@ -2555,12 +2601,14 @@ makeMemoizingDecrypter operation ctx keys = do
     -- 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
@@ -2568,55 +2616,80 @@ makeMemoizingDecrypter operation ctx keys = 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))
-                                        $ opPassphrases operation
+                                        $ passspecs
         unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet)
-        return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw
+        return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw (not $ null agentspec)
     else let PassphraseMemoizer f = head chains
          in return f
  where
-    (chains,passspecs) = partition isChain $ opPassphrases operation
+    (chains,passspecs0) = partition isChain $ opPassphrases operation
                             where isChain (PassphraseMemoizer {}) = True
-                                  isChain _ = False
+                                  isChain _                       = False
+    (agentspec,passspecs) = partition isAgent $ opPassphrases operation
+                            where isAgent PassphraseAgent = True
+                                  isAgent _               = False
     doDecrypt :: IORef (Map.Map KeyKey Packet)
                 -> Map.Map FilePath (IO S.ByteString)
                 -> Maybe (IO S.ByteString)
+                -> Bool
                 -> (SymmetricAlgorithm,S2K)
                 -> MappedPacket
                 -> IO (KikiCondition Packet)
-    doDecrypt unkeysRef pws defpw (dest_alg,dest_s2k) mp0 = do
+    doDecrypt unkeysRef pws defpw agent_requested (dest_alg,dest_s2k) mp0 = do
         unkeys <- readIORef unkeysRef
-        let mp = fromMaybe mp0 $ do
-                    k <- Map.lookup kk keys
-                    return $ mergeKeyPacket "decrypt" mp0 k
+        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)
             wk = packet mp0
             kk = keykey wk
             fs = Map.keys $ locations mp
 
             decryptIt [] = return BadPassphrase
-            decryptIt (getpw:getpws) = do
-                -- TODO: This function should use mergeKeyPacket to 
+            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.
-                pw <- getpw
+                --  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.
+                (pw,wants_retry) <- getpw (if count>1 then AskAgain "Bad pasphrase." else Ask,qry)
                 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)
                         ek <- if dest_alg==Unencrypted
                                 then return $ Just wkun
                                 else encryptSecretKey pw dest_s2k dest_alg wkun
                         case ek of
-                            Nothing   -> return $ BadPassphrase
-                            Just wken -> return $ KikiSuccess wken
-                    _                 -> decryptIt getpws
+                            Nothing | wants_retry && count<3 -> tries (count+1) getpw recurse
+                            Nothing                          -> recurse
+                            Just wken                        -> return $ KikiSuccess wken
+
+                    _ -> recurse
 
-            getpws = mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw
+            getpws = (map (const . fmap (,False)) $ mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw) ++ [ agentpw | agent_requested ]
+
+            agentpw (ask,qry) = do
+                    s <- session
+                    fromMaybe (return ("",False)) $ do
+                    s <- s
+                    Just $ do
+                    case ask of AskAgain _ -> clearPassphrase s (queryPacket qry)
+                                _          -> return ()
+                    mbpw <- getPassphrase s ask qry
+                    quit s
+                    return ( maybe "" S8.pack mbpw, True)
 
         if symmetric_algorithm wk == dest_alg
             && ( symmetric_algorithm wk == Unencrypted || s2k wk == dest_s2k )
@@ -3434,10 +3507,13 @@ data OriginFlags = OriginFlags
 
 type OriginMap = Map.Map FilePath OriginFlags
 
-data MappedPacket = MappedPacket
-        { packet :: Packet
+type MappedPacket = OriginMapped Packet
+data OriginMapped a = MappedPacket
+        { packet :: a
         , locations :: OriginMap
         } deriving Show
+instance Functor OriginMapped where
+    fmap f (MappedPacket x ls) = MappedPacket (f x) ls
 
 type TrustMap = Map.Map FilePath Packet
 type SigAndTrust = ( MappedPacket
@@ -3521,19 +3597,26 @@ onionName kd = (addr,name)
  where
     (addr,(name:_,_)) = getHostnames kd
 -}
+
+-- | Compare different versions if the same key pair.  Public versions
+-- are considered greater.  If the two packets do not represent the same
+-- key or the packets are not keys at all, an error will result that
+-- includes the context provided as the first argument.
 keyCompare :: String -> Packet -> Packet -> Ordering
 keyCompare what (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
 keyCompare what (PublicKeyPacket {}) (SecretKeyPacket {}) = GT
 keyCompare what a b | keykey a==keykey b = EQ
 keyCompare what a b = error $ unlines ["Unable to merge "++what++":"
-                              , fingerprint a
+                              , if isKey a then fingerprint a else ""
                               , PP.ppShow a
-                              , fingerprint b
+                              , if isKey b then fingerprint b else ""
                               , PP.ppShow b
                               ]
 
+-- | Merge two representations of the same key, prefering secret version
+-- because they have more information.
 mergeKeyPacket :: String -> MappedPacket -> MappedPacket -> MappedPacket
-mergeKeyPacket what key p = 
+mergeKeyPacket what key p =
     key { packet = minimumBy (keyCompare what) [packet key,packet p]
         , locations = Map.union (locations key) (locations p)
         }