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
|
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
module PacketTranscoder where
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 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
-- | 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
-> Map.Map KeyKey (OriginMapped Query)
-> IO PacketTranscoder
makeMemoizingDecrypter operation ctx 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 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 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) $ do
k <- Map.lookup kk keys
return (mergeKeyPacket "decrypt" mp0 (fmap queryPacket k), packet k)
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.
(pw,wants_retry) <- getpw (if count>1 then AskAgain "Bad pasphrase." else Ask,qry)
let wkun = fromMaybe wk $ do
guard $ symmetric_algorithm (packet mp) /= Unencrypted
decryptSecretKey pw (packet mp)
case symmetric_algorithm wkun of
Unencrypted -> do
writeIORef unkeysRef (Map.insert kk wkun unkeys)
ek <- if dest_alg==Unencrypted
then return $ Just wkun
else encryptSecretKey pw dest_s2k dest_alg wkun
case ek of
Nothing | wants_retry && count<3 -> tries (count+1) getpw recurse
Nothing -> recurse
Just wken -> return $ KikiSuccess wken
_ -> recurse
getpws = (map (const . fmap (,False)) $ mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw) ++ [ agentpw | agent_requested ]
-- TODO: First we should try the master key with AskNot.
-- If that fails, we should try the subkey.
agentpw (ask,qry) = do
s <- session
fromMaybe (return ("",False)) $ do
s <- s
Just $ do
case ask of AskAgain _ -> clearPassphrase s (queryPacket qry)
_ -> return ()
mbpw <- getPassphrase s ask qry
quit s
return ( maybe "" S8.pack mbpw, True)
if symmetric_algorithm wk == dest_alg
&& ( symmetric_algorithm wk == Unencrypted || s2k wk == dest_s2k )
then return (KikiSuccess wk)
else maybe (decryptIt getpws)
(return . KikiSuccess)
$ Map.lookup kk unkeys
|
