summaryrefslogtreecommitdiff
path: root/lib/PacketTranscoder.hs
blob: 6eadfe4e10c14e7ae6ec361695e05407cb2b42a3 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
module PacketTranscoder where

import Debug.Trace
import GHC.Stack
import Control.Monad
import Data.IORef
import Data.List
import Data.Maybe
import Data.OpenPGP
import Data.OpenPGP.Util
import GnuPGAgent
import qualified Data.ByteString       as S
import qualified Data.ByteString.Char8 as S8
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 )
import Text.Show.Pretty as PP ( ppShow )
import KeyRing.Types
import ControlMaybe (handleIO_)

-- | Merge two representations of the same key, prefering secret version
-- because they have more information.
mergeKeyPacket :: String -> MappedPacket -> MappedPacket -> MappedPacket
mergeKeyPacket what key p =
    key { packet = minimumBy (keyCompare what) [packet key,packet p]
        , locations = Map.union (locations key) (locations p)
        }

-- | 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++":"
                              , if isKey a then fingerprint a else ""
                              , PP.ppShow a
                              , if isKey b then fingerprint b else ""
                              , PP.ppShow b
                              ]

resolveInputFile :: InputFileContext -> InputFile -> [FilePath]
resolveInputFile ctx = resolve
 where
    resolve HomeSec = return (homesecPath ctx)
    resolve HomePub = return (homepubPath ctx)
    resolve (ArgFile f) = return f
    resolve _ = []

resolveForReport :: Maybe InputFileContext -> InputFile -> FilePath
resolveForReport mctx (Pipe fdr fdw) = resolveForReport mctx (ArgFile str)
 where str = case (fdr,fdw) of
                (0,1) -> "-"
                _     -> "&pipe" ++ show (fdr,fdw)
resolveForReport mctx (FileDesc fd) = resolveForReport mctx (ArgFile str)
 where str = "&" ++ show fd
resolveForReport mctx f = concat $ resolveInputFile ctx f
 where ctx = fromMaybe (InputFileContext "&secret" "&public") mctx

readInputFileS :: InputFileContext -> InputFile -> IO S.ByteString
readInputFileS ctx (Pipe fd _)   = fdToHandle fd >>= S.hGetContents
readInputFileS ctx (FileDesc fd) = fdToHandle fd >>= S.hGetContents
readInputFileS ctx inp = do
    let fname = resolveInputFile ctx inp
    fmap S.concat $ mapM S.readFile fname



-- | 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
    return $ get maybePrompt ref fd
 where
    trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs

    get maybePrompt ref fd = do
        pw <- readIORef ref
        flip (flip maybe return) pw $ do
            if fd == FileDesc 0 then case maybePrompt of
                                    Just prompt -> S.hPutStr stderr prompt
                                    Nothing -> return ()
                               else return ()
            pw <- fmap trimCR $ readInputFileS ctx fd
            writeIORef ref (Just pw)
            return pw


data PassphraseResponse = ObtainedPassphrase S.ByteString
                        | CanceledPassphrase
                        | NextPassphrase
 deriving Show

type PassphraseSource = (SymmetricAlgorithm,S2K) -> MappedPacket -> [IO PassphraseResponse]

interpretPassSpec :: InputFileContext
                        -> (Maybe MappedPacket, Map.Map KeyKey (OriginMapped Query))
                        -> 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.hPutStrLn 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
    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
        calls <- currentCallStack
        putStrLn $ concat [fingerprint wk," ", show (symmetric_algorithm wk,s2k wk)," --> ",show alg]
        mapM_ putStrLn calls
        if (symmetric_algorithm wk,s2k wk) == alg
            then return (KikiSuccess wk)
            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)
 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