diff options
Diffstat (limited to 'lib/PacketTranscoder.hs')
-rw-r--r-- | lib/PacketTranscoder.hs | 137 |
1 files changed, 114 insertions, 23 deletions
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 @@ | |||
1 | {-# LANGUAGE TupleSections #-} | 1 | {-# LANGUAGE TupleSections #-} |
2 | {-# LANGUAGE OverloadedStrings #-} | 2 | {-# LANGUAGE OverloadedStrings #-} |
3 | {-# LANGUAGE PatternGuards #-} | ||
3 | module PacketTranscoder where | 4 | module PacketTranscoder where |
4 | 5 | ||
5 | import Control.Monad | 6 | import Control.Monad |
@@ -11,7 +12,8 @@ import Data.OpenPGP.Util | |||
11 | import GnuPGAgent | 12 | import GnuPGAgent |
12 | import qualified Data.ByteString as S | 13 | import qualified Data.ByteString as S |
13 | import qualified Data.ByteString.Char8 as S8 | 14 | import qualified Data.ByteString.Char8 as S8 |
14 | import qualified Data.Map as Map | 15 | import Data.Map as Map (Map) |
16 | import qualified Data.Map as Map | ||
15 | import qualified Data.Traversable as Traversable | 17 | import qualified Data.Traversable as Traversable |
16 | import System.IO ( stderr) | 18 | import System.IO ( stderr) |
17 | import System.Posix.IO ( fdToHandle ) | 19 | import System.Posix.IO ( fdToHandle ) |
@@ -92,9 +94,9 @@ cachedContents maybePrompt ctx fd = do | |||
92 | 94 | ||
93 | 95 | ||
94 | makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext | 96 | makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext |
95 | -> Map.Map KeyKey (OriginMapped Query) | 97 | -> (Maybe MappedPacket, Map.Map KeyKey (OriginMapped Query)) |
96 | -> IO PacketTranscoder | 98 | -> IO PacketTranscoder |
97 | makeMemoizingDecrypter operation ctx keys = do | 99 | makeMemoizingDecrypter operation ctx (workingkey,keys) = do |
98 | if null chains then do | 100 | if null chains then do |
99 | -- (*) Notice we do not pass ctx to resolveForReport. | 101 | -- (*) Notice we do not pass ctx to resolveForReport. |
100 | -- This is because the merge function does not currently use a context | 102 | -- This is because the merge function does not currently use a context |
@@ -144,9 +146,14 @@ makeMemoizingDecrypter operation ctx keys = do | |||
144 | -> IO (KikiCondition Packet) | 146 | -> IO (KikiCondition Packet) |
145 | doDecrypt unkeysRef pws defpw agent_requested (dest_alg,dest_s2k) mp0 = do | 147 | doDecrypt unkeysRef pws defpw agent_requested (dest_alg,dest_s2k) mp0 = do |
146 | unkeys <- readIORef unkeysRef | 148 | unkeys <- readIORef unkeysRef |
147 | let (mp,qry) = fromMaybe (mp0,Query (packet mp0) "anonymous2" Nothing) $ do | 149 | let (mp,qry) = fromMaybe (mp0,Query (packet mp0) "anonymous2" Nothing) |
148 | k <- Map.lookup kk keys | 150 | $ mplus (do k <- Map.lookup kk keys |
149 | return (mergeKeyPacket "decrypt" mp0 (fmap queryPacket k), packet k) | 151 | return (mergeKeyPacket "decrypt" mp0 (fmap queryPacket k), packet k)) |
152 | (do guard $ is_subkey (packet mp0) | ||
153 | working <- fmap packet workingkey | ||
154 | q <- fmap packet $ Map.lookup (keykey working) keys | ||
155 | return (mp0, Query (packet mp0) (queryUID q) (Just working))) | ||
156 | |||
150 | wk = packet mp0 | 157 | wk = packet mp0 |
151 | kk = keykey wk | 158 | kk = keykey wk |
152 | fs = Map.keys $ locations mp | 159 | fs = Map.keys $ locations mp |
@@ -161,39 +168,60 @@ makeMemoizingDecrypter operation ctx keys = do | |||
161 | -- in the 'locations' field, so this would effectively | 168 | -- in the 'locations' field, so this would effectively |
162 | -- allow you to run 'decryptIt' on an unencrypted public key | 169 | -- allow you to run 'decryptIt' on an unencrypted public key |
163 | -- to obtain it's secret key. | 170 | -- to obtain it's secret key. |
164 | (pw,wants_retry) <- getpw (if count>1 then AskAgain "Bad pasphrase." else Ask,qry) | 171 | (pw,wants_retry) <- getpw (count,qry) |
165 | let wkun = fromMaybe wk $ do | 172 | let wkun = fromMaybe wk $ do |
166 | guard $ symmetric_algorithm (packet mp) /= Unencrypted | 173 | guard $ symmetric_algorithm (packet mp) /= Unencrypted |
167 | decryptSecretKey pw (packet mp) | 174 | decryptSecretKey pw (packet mp) |
168 | 175 | ||
176 | retryOrFail | ||
177 | | Just clear <- wants_retry = if count < 4 | ||
178 | then tries (count+1) getpw recurse | ||
179 | else clear >> recurse | ||
180 | | otherwise = recurse | ||
181 | |||
169 | case symmetric_algorithm wkun of | 182 | case symmetric_algorithm wkun of |
170 | 183 | ||
171 | Unencrypted -> do | 184 | Unencrypted -> do |
172 | writeIORef unkeysRef (Map.insert kk wkun unkeys) | 185 | writeIORef unkeysRef (Map.insert kk wkun unkeys) |
173 | ek <- if dest_alg==Unencrypted | 186 | ek <- case dest_alg of |
174 | then return $ Just wkun | 187 | Unencrypted -> return $ Just wkun |
175 | else encryptSecretKey pw dest_s2k dest_alg wkun | 188 | _ -> encryptSecretKey pw dest_s2k dest_alg wkun |
176 | case ek of | 189 | case ek of |
177 | Nothing | wants_retry && count<3 -> tries (count+1) getpw recurse | 190 | Nothing -> retryOrFail |
178 | Nothing -> recurse | 191 | Just wken -> return $ KikiSuccess wken |
179 | Just wken -> return $ KikiSuccess wken | ||
180 | 192 | ||
181 | _ -> recurse | 193 | _ -> retryOrFail |
182 | 194 | ||
183 | getpws = (map (const . fmap (,False)) $ mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw) ++ [ agentpw | agent_requested ] | 195 | getpws = (map (const . fmap (,Nothing)) $ mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw) ++ [ agentpw | agent_requested ] |
184 | 196 | ||
185 | -- TODO: First we should try the master key with AskNot. | 197 | agentpw (count,qry) = do |
186 | -- If that fails, we should try the subkey. | ||
187 | agentpw (ask,qry) = do | ||
188 | s <- session | 198 | s <- session |
189 | fromMaybe (return ("",False)) $ do | 199 | fromMaybe (return ("",Nothing)) $ do |
190 | s <- s | 200 | s <- s |
191 | Just $ do | 201 | Just $ do |
192 | case ask of AskAgain _ -> clearPassphrase s (queryPacket qry) | 202 | let (firsttime,maink) | Just k <- (queryMainKey qry) = (2,k) |
193 | _ -> return () | 203 | | otherwise = (1,error "bug in makeMemoizingDecrypter") |
194 | mbpw <- getPassphrase s ask qry | 204 | |
205 | alg = symmetric_algorithm (queryPacket qry) | ||
206 | |||
207 | ask | count<firsttime = AskNot | ||
208 | | count>firsttime = AskAgain "Bad passphrase" | ||
209 | | count==firsttime = initial_ask | ||
210 | where | ||
211 | initial_ask | Unencrypted <- alg = AskNew | ||
212 | | otherwise = AskExisting | ||
213 | |||
214 | actual_qry | count<firsttime = qry { queryPacket = maink, queryMainKey = Nothing } | ||
215 | | otherwise = qry | ||
216 | |||
217 | let clear | count > firsttime = clearPassphrase s (queryPacket qry) | ||
218 | | otherwise = return () | ||
219 | clear | ||
220 | let sanitizeQry qry = (fingerprint $ queryPacket qry, queryUID qry, fmap fingerprint $ queryMainKey qry) | ||
221 | putStrLn $ "(count,firsttime,ask,qry,actual_qry)="++show (count,firsttime,ask,sanitizeQry qry, sanitizeQry actual_qry) | ||
222 | mbpw <- getPassphrase s ask actual_qry | ||
195 | quit s | 223 | quit s |
196 | return ( maybe "" S8.pack mbpw, True) | 224 | return ( maybe "" S8.pack mbpw, guard (ask /= AskNew) >> Just clear ) |
197 | 225 | ||
198 | if symmetric_algorithm wk == dest_alg | 226 | if symmetric_algorithm wk == dest_alg |
199 | && ( symmetric_algorithm wk == Unencrypted || s2k wk == dest_s2k ) | 227 | && ( symmetric_algorithm wk == Unencrypted || s2k wk == dest_s2k ) |
@@ -202,3 +230,66 @@ makeMemoizingDecrypter operation ctx keys = do | |||
202 | (return . KikiSuccess) | 230 | (return . KikiSuccess) |
203 | $ Map.lookup kk unkeys | 231 | $ Map.lookup kk unkeys |
204 | 232 | ||
233 | keyQueries :: Maybe String -> Map InputFile (StreamInfo,Message) -> (Maybe MappedPacket, Map KeyKey (OriginMapped Query)) | ||
234 | keyQueries grip ringPackets = (mwk, fmap makeQuery keys) | ||
235 | where | ||
236 | makeQuery (maink,mp,us) = mp { packet = q } | ||
237 | where q = Query { queryPacket = packet mp | ||
238 | , queryUID = concat $ take 1 $ Map.keys $ Map.union us (getUIDS maink) | ||
239 | , queryMainKey = if is_subkey (packet mp) | ||
240 | then maink `mplus` fmap packet mwk | ||
241 | else Nothing | ||
242 | } | ||
243 | |||
244 | getUIDS maink = fromMaybe Map.empty $ do | ||
245 | k <- maink | ||
246 | (_,_,mus) <- Map.lookup (keykey k) keys | ||
247 | return mus | ||
248 | |||
249 | -- | mwk | ||
250 | -- first master key matching the provided grip | ||
251 | -- (the m is for "MappedPacket", wk for working key) | ||
252 | mwk :: Maybe MappedPacket | ||
253 | mwk = listToMaybe $ do | ||
254 | fp <- maybeToList grip | ||
255 | let matchfp mp | ||
256 | | not (is_subkey p) && matchpr fp p == fp = Just mp | ||
257 | | otherwise = Nothing | ||
258 | where p = packet mp | ||
259 | Map.elems $ Map.mapMaybe matchfp $ fmap (\(_,p,_) -> p) $ keys | ||
260 | |||
261 | keys = Map.foldl slurpkeys Map.empty | ||
262 | $ Map.mapWithKey filterSecrets ringPackets | ||
263 | where | ||
264 | filterSecrets :: InputFile -> (a,Message) -> [[MappedPacket]] | ||
265 | filterSecrets f (_,Message ps) = keygroups | ||
266 | -- filter (isSecretKey . packet) mps | ||
267 | where | ||
268 | mps = zipWith (mappedPacketWithHint fname) ps [1..] | ||
269 | fname = resolveForReport Nothing f -- (Just ctx) f | ||
270 | keygroups = dropWhile (not . isSecretKey . packet . head) | ||
271 | $ groupBy (const $ not . isSecretKey . packet) mps | ||
272 | slurpkeys :: (Map KeyKey (Maybe Packet,MappedPacket,Map String [Packet])) | ||
273 | -> [[MappedPacket]] | ||
274 | -> (Map KeyKey (Maybe Packet, MappedPacket,Map String [Packet])) | ||
275 | slurpkeys m pss = Map.unionWith combineKeyKey m m2 | ||
276 | where | ||
277 | |||
278 | m2 :: Map.Map KeyKey (Maybe Packet, MappedPacket, (Map.Map String [Packet])) | ||
279 | m2 = Map.fromList | ||
280 | $ drop 1 | ||
281 | $ scanl' build ([],(Nothing,error "bug in PacketTranscoder (1)", error "bug in PacketTranscoder (2)")) pss | ||
282 | where | ||
283 | build (_,(main0,_,_)) ps = (kk,(main,kp,uidmap ps')) | ||
284 | where | ||
285 | main | is_subkey (packet kp) = main0 | ||
286 | | otherwise = Just $ packet kp | ||
287 | (kpkt,ps') = splitAt 1 ps | ||
288 | kp = head kpkt | ||
289 | kk = keykey . packet $ kp | ||
290 | combineKeyKey (master1,mp,um) (master2,mp2,um2) = (master1 `mplus` master2,mp,Map.unionWith (++) um um2) | ||
291 | uidmap ps = um2 | ||
292 | where | ||
293 | ugs = dropWhile (not . isUserID . packet .head) $ groupBy (const $ not . isUserID . packet) ps | ||
294 | um2 = Map.fromList | ||
295 | $ map (\(MappedPacket (UserIDPacket s) _:sigs)->(s,takeWhile isSignaturePacket $ map packet sigs)) ugs | ||