summaryrefslogtreecommitdiff
path: root/lib/PacketTranscoder.hs
blob: f4b4ccefe59faac71346cd0d8fe43e653fa849fb (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
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
module PacketTranscoder where

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 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



makeMemoizingDecrypter :: KeyRingOperation -> 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
 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
        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
                (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,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

            getpws = (map (const . fmap (,Nothing)) $ mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw) ++ [ agentpw | agent_requested ]

            agentpw (count,qry) = do
                    s <- session
                    fromMaybe (return ("",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 | count<firsttime  = AskNot
                            | count>firsttime  = AskAgain "Bad passphrase"
                            | count==firsttime = initial_ask
                            where
                               initial_ask | Unencrypted <- alg = AskNew
                                           | otherwise          = AskExisting

                        actual_qry | count<firsttime = qry { queryPacket = maink, queryMainKey = Nothing }
                                   | otherwise       = qry

                    let clear | 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, guard (ask /= AskNew) >> Just clear )

        calls <- currentCallStack
        putStrLn $ concat [fingerprint wk," ", show (symmetric_algorithm wk,s2k wk)," --> ",show (dest_alg,dest_s2k)]
        mapM_ putStrLn calls
        if symmetric_algorithm wk == dest_alg && s2k wk == dest_s2k'
            then return (KikiSuccess wk)
            else maybe (decryptIt getpws)
                       (return . KikiSuccess)
                    $ Map.lookup (kk,dest_alg,dest_s2k') 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