From 1eff837423de69ece2a85430a7ad433b7c1a504a Mon Sep 17 00:00:00 2001 From: joe Date: Mon, 29 Aug 2016 01:15:25 -0400 Subject: Better gpg-agent support. --- lib/PacketTranscoder.hs | 137 ++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 114 insertions(+), 23 deletions(-) (limited to 'lib/PacketTranscoder.hs') 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 | countfirsttime = AskAgain "Bad passphrase" + | count==firsttime = initial_ask + where + initial_ask | Unencrypted <- alg = AskNew + | otherwise = AskExisting + + actual_qry | 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 -- cgit v1.2.3