From e15e036f89a2c48b762f901e063d86417345287b Mon Sep 17 00:00:00 2001 From: joe Date: Thu, 1 Sep 2016 22:01:20 -0400 Subject: Password handling overhaul: * More agressively search gpg-agent cache. * Allow key-specific passphrase fds. --- lib/GnuPGAgent.hs | 4 +- lib/KeyRing.hs | 13 -- lib/PacketTranscoder.hs | 313 +++++++++++++++++++++++++----------------------- lib/Types.hs | 38 +++++- 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 | 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 - -- 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 -- cgit v1.2.3