diff options
Diffstat (limited to 'lib/PacketTranscoder.hs')
-rw-r--r-- | lib/PacketTranscoder.hs | 313 |
1 files changed, 165 insertions, 148 deletions
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 @@ | |||
3 | {-# LANGUAGE PatternGuards #-} | 3 | {-# LANGUAGE PatternGuards #-} |
4 | module PacketTranscoder where | 4 | module PacketTranscoder where |
5 | 5 | ||
6 | import Debug.Trace | ||
6 | import GHC.Stack | 7 | import GHC.Stack |
7 | import Control.Monad | 8 | import Control.Monad |
8 | import Data.IORef | 9 | import Data.IORef |
@@ -94,161 +95,177 @@ cachedContents maybePrompt ctx fd = do | |||
94 | return pw | 95 | return pw |
95 | 96 | ||
96 | 97 | ||
98 | data PassphraseResponse = ObtainedPassphrase S.ByteString | ||
99 | | CanceledPassphrase | ||
100 | | NextPassphrase | ||
101 | deriving Show | ||
97 | 102 | ||
98 | makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext | 103 | type PassphraseSource = (SymmetricAlgorithm,S2K) -> MappedPacket -> [IO PassphraseResponse] |
104 | |||
105 | interpretPassSpec :: InputFileContext | ||
99 | -> (Maybe MappedPacket, Map.Map KeyKey (OriginMapped Query)) | 106 | -> (Maybe MappedPacket, Map.Map KeyKey (OriginMapped Query)) |
100 | -> IO PacketTranscoder | 107 | -> PassphraseSpec |
101 | makeMemoizingDecrypter operation ctx (workingkey,keys) = do | 108 | -> IO (KikiCondition (PassphraseSource, IO ()) ) |
102 | if null chains then do | 109 | interpretPassSpec ctx keys PassphraseSpec { passSpecPassFile = fd |
103 | -- (*) Notice we do not pass ctx to resolveForReport. | 110 | , passSpecKeySpec = keyspec |
104 | -- This is because the merge function does not currently use a context | 111 | , passSpecRingFile = inputfile } = do |
105 | -- and the pws map keys must match the MappedPacket locations. | 112 | getpw <- |
106 | -- TODO: Perhaps these should both be of type InputFile rather than | 113 | cachedContents (Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n") |
107 | -- FilePath? | 114 | ctx |
108 | -- pws :: Map.Map FilePath (IO S.ByteString) | 115 | fd |
109 | {- | 116 | let matchkey fp mp = matchpr fp (packet mp) == fp |
110 | -- This disabled code obtained password sources from StreamInfo records. | 117 | matchfile file mp = Map.member file (locations mp) |
111 | pws <- | 118 | specializers = [ fmap matchkey keyspec, fmap matchfile inputfile] |
112 | Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ) | 119 | specialize alg mp = |
113 | (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above | 120 | if and $ map (\f -> f mp) $ catMaybes specializers |
114 | $ Map.filter (isJust . pwfile . typ) $ opFiles operation) | 121 | then [ObtainedPassphrase <$> getpw] |
115 | -} | 122 | else [] |
116 | let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n" | 123 | return $ KikiSuccess (specialize, return ()) |
117 | -- List of file-specific password sources. | 124 | |
118 | pws2 <- | 125 | interpretPassSpec ctx keys PassphraseAgent = do |
119 | Traversable.mapM (cachedContents prompt ctx) | 126 | mb <- session |
120 | $ Map.fromList $ mapMaybe | 127 | fromMaybe (return AgentConnectionFailure) $ do |
121 | (\spec -> (,passSpecPassFile spec) `fmap` do | 128 | agent <- mb |
122 | guard $ isNothing $ passSpecKeySpec spec | 129 | Just $ do |
123 | passSpecRingFile spec) | 130 | let cacheSearch alg mp = |
124 | passspecs | 131 | case getQueries keys mp of |
125 | -- List of general password sources. | 132 | [] -> [] |
126 | defpw <- do | 133 | kqry:qs -> trace ("queries="++show (kqry:qs)) $ |
127 | Traversable.mapM (cachedContents prompt ctx . passSpecPassFile) | 134 | map (sendQuery agent (AskNot,NextPassphrase)) (kqry:qs) |
128 | $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp) | 135 | ++ sendQuery agent (initial_ask,CanceledPassphrase) kqry |
129 | && isNothing (passSpecKeySpec sp)) | 136 | : replicate 3 (sendQuery agent (AskAgain "Bad passphrase",CanceledPassphrase) kqry) |
130 | $ passspecs | 137 | where |
131 | unkeysRef <- newIORef (Map.empty :: Map.Map (KeyKey,SymmetricAlgorithm,S2K) Packet) | 138 | srcalg = symmetric_algorithm $ packet mp |
132 | return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw (not $ null agentspec) | 139 | |
133 | else let PassphraseMemoizer f = head chains | 140 | initial_ask | Unencrypted <- srcalg = AskNew |
134 | in return f | 141 | | otherwise = AskExisting |
142 | |||
143 | return $ KikiSuccess (cacheSearch, quit agent) | ||
144 | |||
145 | sendQuery :: GnuPGAgent -> (QueryMode,PassphraseResponse) -> OriginMapped Query -> IO PassphraseResponse | ||
146 | sendQuery agent (ask,failure) qry = do | ||
147 | mbpw <- getPassphrase agent ask (packet qry) | ||
148 | case mbpw of | ||
149 | Nothing -> do | ||
150 | S8.hPutStr stderr $ S8.pack $ "Failed to get passphrase "++show failure | ||
151 | return failure | ||
152 | Just pw -> do | ||
153 | -- S8.hPutStrLn stderr $ S8.pack $ "received pw: "++pw | ||
154 | return $ ObtainedPassphrase $ S8.pack pw | ||
155 | |||
156 | getQueries :: (Maybe MappedPacket,Map KeyKey (OriginMapped Query)) -> OriginMapped Packet -> [OriginMapped Query] | ||
157 | getQueries (workingkey,keys) mp = | ||
158 | let kk = keykey $ packet mp | ||
159 | in case Map.lookup kk keys of | ||
160 | Just qryk -> | ||
161 | case queryMainKey (packet qryk) of | ||
162 | Just maink -> | ||
163 | let kkmain = keykey maink | ||
164 | in case Map.lookup kkmain keys of | ||
165 | Just qrym -> qryk : qrym : (Map.elems . Map.delete kkmain . Map.delete kk) keys | ||
166 | Nothing -> [ qryk ] | ||
167 | Nothing -> [ qryk ] | ||
168 | Nothing -> | ||
169 | -- This is probably a newly imported key. We'll treat the current working key as it's main key. | ||
170 | -- trace ("getQueries cache miss "++show (fingerprint $ packet mp)) [] | ||
171 | let (qryk,qrym) | ||
172 | = fromMaybe (Query (packet mp) "anonymous2" Nothing,Nothing) $ do | ||
173 | guard $ is_subkey (packet mp) | ||
174 | working <- fmap packet workingkey | ||
175 | q <- Map.lookup (keykey working) keys | ||
176 | return ( Query (packet mp) (queryUID $ packet q) (Just working), Just q) | ||
177 | delm = case workingkey of | ||
178 | Nothing -> id | ||
179 | Just wk -> Map.delete (keykey $ packet wk) | ||
180 | in [ fmap (const qryk) mp ] ++ maybeToList qrym ++ (Map.elems . delm . Map.delete kk) keys | ||
181 | |||
182 | |||
183 | makeTranscoder :: IORef (Map.Map (KeyKey,SymmetricAlgorithm,S2K) Packet) | ||
184 | -> IO (KikiCondition (PassphraseSource, IO ())) | ||
185 | -> ( (SymmetricAlgorithm,S2K) -> MappedPacket -> IO (KikiCondition Packet) ) | ||
186 | -> ( (SymmetricAlgorithm,S2K) -> MappedPacket -> IO (KikiCondition Packet) ) | ||
187 | makeTranscoder unkeysRef source next alg mp = do | ||
188 | ssr <- source | ||
189 | case ssr of | ||
190 | KikiSuccess (getqs, quit) -> tries (quit >> next alg mp) $ getqs alg mp | ||
191 | er -> return $ fmap (error "makeTranscoder") er | ||
135 | where | 192 | where |
136 | (chains,passspecs0) = partition isChain $ opPassphrases operation | 193 | tries fin [] = fin |
137 | where isChain (PassphraseMemoizer {}) = True | 194 | tries fin (src:srcs) = do |
138 | isChain _ = False | 195 | S8.hPutStrLn stderr "trying..." |
139 | (agentspec,passspecs) = partition isAgent passspecs0 | 196 | resp <- src |
140 | where isAgent PassphraseAgent = True | 197 | case resp of |
141 | isAgent _ = False | 198 | CanceledPassphrase -> return OperationCanceled |
142 | doDecrypt :: IORef (Map.Map (KeyKey,SymmetricAlgorithm,S2K) Packet) | 199 | NextPassphrase -> tries fin srcs |
143 | -> Map.Map FilePath (IO S.ByteString) | 200 | ObtainedPassphrase pw -> do |
144 | -> Maybe (IO S.ByteString) | 201 | let wkun = fromMaybe (packet mp) $ do |
145 | -> Bool | 202 | guard $ symmetric_algorithm (packet mp) /= Unencrypted |
146 | -> (SymmetricAlgorithm,S2K) | 203 | decryptSecretKey pw (packet mp) |
147 | -> MappedPacket | 204 | kk = keykey (packet mp) |
148 | -> IO (KikiCondition Packet) | 205 | retryOrFail = tries fin srcs |
149 | doDecrypt unkeysRef pws defpw agent_requested (dest_alg,dest_s2k) mp0 = do | 206 | case symmetric_algorithm wkun of |
207 | Unencrypted -> do | ||
208 | modifyIORef unkeysRef (Map.insert (kk,Unencrypted,S2K 100 "") wkun) | ||
209 | ek <- case fst alg of | ||
210 | Unencrypted -> do | ||
211 | S8.hPutStrLn stderr "decrypted packet" | ||
212 | return $ Just wkun | ||
213 | _ -> encryptSecretKey pw (snd alg) (fst alg) wkun | ||
214 | case ek of | ||
215 | Nothing -> do | ||
216 | S8.hPutStrLn stderr "failed to encrypt" | ||
217 | retryOrFail | ||
218 | Just wken -> do | ||
219 | S8.hPutStrLn stderr "success encrypted" | ||
220 | let (a,s) = alg | ||
221 | modifyIORef unkeysRef (Map.insert (kk,a,s) wken) | ||
222 | return $ KikiSuccess wken | ||
223 | _ -> do S8.hPutStrLn stderr "failed to decrypt" | ||
224 | retryOrFail | ||
225 | |||
226 | normalizeAlgorithm :: (SymmetricAlgorithm,S2K) -> (SymmetricAlgorithm,S2K) | ||
227 | normalizeAlgorithm (Unencrypted,_) = (Unencrypted,S2K 100 "") | ||
228 | normalizeAlgorithm alg = alg | ||
229 | |||
230 | transcodeWithCache :: IORef (Map (KeyKey, SymmetricAlgorithm, S2K) Packet) | ||
231 | -> ( (SymmetricAlgorithm,S2K) -> MappedPacket -> IO (KikiCondition Packet) ) | ||
232 | -> ( (SymmetricAlgorithm,S2K) -> MappedPacket -> IO (KikiCondition Packet) ) | ||
233 | transcodeWithCache unkeysRef miss alg0 mp@MappedPacket{ packet = wk } = do | ||
234 | let alg = normalizeAlgorithm alg0 | ||
150 | unkeys <- readIORef unkeysRef | 235 | unkeys <- readIORef unkeysRef |
151 | let (mp,qry) = fromMaybe (mp0,Query (packet mp0) "anonymous2" Nothing) | ||
152 | $ mplus (do k <- Map.lookup kk keys | ||
153 | return (mergeKeyPacket "decrypt" mp0 (fmap queryPacket k), packet k)) | ||
154 | (do guard $ is_subkey (packet mp0) | ||
155 | working <- fmap packet workingkey | ||
156 | q <- fmap packet $ Map.lookup (keykey working) keys | ||
157 | return (mp0, Query (packet mp0) (queryUID q) (Just working))) | ||
158 | |||
159 | dest_s2k' | dest_alg==Unencrypted = S2K 100 "" | ||
160 | | otherwise = dest_s2k | ||
161 | |||
162 | wk = packet mp0 | ||
163 | kk = keykey wk | ||
164 | fs = Map.keys $ locations mp | ||
165 | |||
166 | decryptIt [] = return BadPassphrase | ||
167 | decryptIt (getpw:getpws) = tries 1 getpw (decryptIt getpws) | ||
168 | where | ||
169 | tries count getpw recurse = do | ||
170 | -- TODO: This function should use mergeKeyPacket to | ||
171 | -- combine the packet with it's unspilled version before | ||
172 | -- attempting to decrypt it. Note: We are uninterested | ||
173 | -- in the 'locations' field, so this would effectively | ||
174 | -- allow you to run 'decryptIt' on an unencrypted public key | ||
175 | -- to obtain it's secret key. | ||
176 | handleIO_ (decryptIt []) $ do | ||
177 | (pw0,wants_retry) <- getpw (count,qry) | ||
178 | case pw0 of | ||
179 | KikiSuccess pw -> do | ||
180 | let wkun = fromMaybe wk $ do | ||
181 | guard $ symmetric_algorithm (packet mp) /= Unencrypted | ||
182 | decryptSecretKey pw (packet mp) | ||
183 | |||
184 | retryOrFail | ||
185 | | Just clear <- wants_retry = if count < 4 | ||
186 | then tries (count+1) getpw recurse | ||
187 | else clear >> recurse | ||
188 | | otherwise = recurse | ||
189 | |||
190 | case symmetric_algorithm wkun of | ||
191 | |||
192 | Unencrypted -> do | ||
193 | writeIORef unkeysRef (Map.insert (kk,Unencrypted,S2K 100 "") wkun unkeys) | ||
194 | ek <- case dest_alg of | ||
195 | Unencrypted -> return $ Just wkun | ||
196 | _ -> encryptSecretKey pw dest_s2k' dest_alg wkun | ||
197 | |||
198 | case ek of | ||
199 | Nothing -> retryOrFail | ||
200 | Just wken -> do | ||
201 | modifyIORef unkeysRef (Map.insert (kk,dest_alg,dest_s2k') wken) | ||
202 | return $ KikiSuccess wken | ||
203 | |||
204 | _ -> retryOrFail | ||
205 | err -> return $ fmap (error "pasphrase error") err | ||
206 | |||
207 | getpws = (map (const . fmap (\pw -> (KikiSuccess pw,Nothing))) | ||
208 | $ mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw) ++ [ agentpw | agent_requested ] | ||
209 | |||
210 | agentpw (count,qry) = do | ||
211 | s <- session | ||
212 | fromMaybe (return (AgentConnectionFailure,Nothing)) $ do | ||
213 | s <- s | ||
214 | Just $ do | ||
215 | let (firsttime,maink) | Just k <- (queryMainKey qry) = (2,k) | ||
216 | | otherwise = (1,error "bug in makeMemoizingDecrypter") | ||
217 | |||
218 | alg = symmetric_algorithm (queryPacket qry) | ||
219 | |||
220 | ask | count<firsttime = AskNot | ||
221 | | count>firsttime = AskAgain "Bad passphrase" | ||
222 | | count==firsttime = initial_ask | ||
223 | where | ||
224 | initial_ask | Unencrypted <- alg = AskNew | ||
225 | | otherwise = AskExisting | ||
226 | |||
227 | actual_qry | count<firsttime = qry { queryPacket = maink, queryMainKey = Nothing } | ||
228 | | otherwise = qry | ||
229 | |||
230 | let clear | count > firsttime = clearPassphrase s (queryPacket qry) | ||
231 | | otherwise = return () | ||
232 | clear | ||
233 | let sanitizeQry qry = (fingerprint $ queryPacket qry, queryUID qry, fmap fingerprint $ queryMainKey qry) | ||
234 | -- putStrLn $ "(count,firsttime,ask,qry,actual_qry)="++show (count,firsttime,ask,sanitizeQry qry, sanitizeQry actual_qry) | ||
235 | mbpw <- getPassphrase s ask actual_qry | ||
236 | quit s | ||
237 | -- putStrLn $ "mbpw = " ++show mbpw | ||
238 | return ( maybe (if count >=firsttime then OperationCanceled | ||
239 | else KikiSuccess "") -- No cached data. | ||
240 | (KikiSuccess . S8.pack) | ||
241 | mbpw | ||
242 | , guard (ask /= AskNew) >> Just clear ) | ||
243 | |||
244 | calls <- currentCallStack | 236 | calls <- currentCallStack |
245 | putStrLn $ concat [fingerprint wk," ", show (symmetric_algorithm wk,s2k wk)," --> ",show (dest_alg,dest_s2k)] | 237 | putStrLn $ concat [fingerprint wk," ", show (symmetric_algorithm wk,s2k wk)," --> ",show alg] |
246 | mapM_ putStrLn calls | 238 | mapM_ putStrLn calls |
247 | if symmetric_algorithm wk == dest_alg && s2k wk == dest_s2k' | 239 | if (symmetric_algorithm wk,s2k wk) == alg |
248 | then return (KikiSuccess wk) | 240 | then return (KikiSuccess wk) |
249 | else maybe (decryptIt getpws) | 241 | else maybe (miss alg mp) (return . KikiSuccess) |
250 | (return . KikiSuccess) | 242 | $ Map.lookup (keykey wk,fst alg, snd alg) unkeys |
251 | $ Map.lookup (kk,dest_alg,dest_s2k') unkeys | 243 | |
244 | tryInOrder [] _ _ = return BadPassphrase | ||
245 | tryInOrder [f] alg mp = f alg mp | ||
246 | tryInOrder (f:fs) alg mp = do | ||
247 | r <- f alg mp | ||
248 | case r of | ||
249 | KikiSuccess _ -> return r | ||
250 | e -> do | ||
251 | S8.hPutStrLn stderr $ S8.pack ("got "++errorString e++", trying next") | ||
252 | tryInOrder fs alg mp | ||
253 | |||
254 | -- The transcoder works on 'MappedPacket' instead of 'Packet' so that | ||
255 | -- file-specific passphrases can be utilized. | ||
256 | makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext | ||
257 | -> (Maybe MappedPacket, Map.Map KeyKey (OriginMapped Query)) | ||
258 | -> IO PacketTranscoder | ||
259 | makeMemoizingDecrypter operation ctx (workingkey,keys) = do | ||
260 | unkeysRef <- newIORef (Map.empty :: Map.Map (KeyKey,SymmetricAlgorithm,S2K) Packet) | ||
261 | return $ tryInOrder $ map passSpecTranscoder chains ++ [ trans unkeysRef ] | ||
262 | where | ||
263 | (chains,passpecs) = span isChain $ sort $ opPassphrases operation | ||
264 | where isChain (PassphraseMemoizer {}) = True | ||
265 | isChain _ = False | ||
266 | srcs = map (interpretPassSpec ctx (workingkey,keys)) passpecs | ||
267 | |||
268 | trans unkeysRef = transcodeWithCache unkeysRef (foldr (makeTranscoder unkeysRef) (\_ _ -> return BadPassphrase) srcs) | ||
252 | 269 | ||
253 | keyQueries :: Maybe String -> Map InputFile (StreamInfo,Message) -> (Maybe MappedPacket, Map KeyKey (OriginMapped Query)) | 270 | keyQueries :: Maybe String -> Map InputFile (StreamInfo,Message) -> (Maybe MappedPacket, Map KeyKey (OriginMapped Query)) |
254 | keyQueries grip ringPackets = (mwk, fmap makeQuery keys) | 271 | keyQueries grip ringPackets = (mwk, fmap makeQuery keys) |