summaryrefslogtreecommitdiff
path: root/lib/PacketTranscoder.hs
diff options
context:
space:
mode:
Diffstat (limited to 'lib/PacketTranscoder.hs')
-rw-r--r--lib/PacketTranscoder.hs204
1 files changed, 204 insertions, 0 deletions
diff --git a/lib/PacketTranscoder.hs b/lib/PacketTranscoder.hs
new file mode 100644
index 0000000..651b00c
--- /dev/null
+++ b/lib/PacketTranscoder.hs
@@ -0,0 +1,204 @@
1{-# LANGUAGE TupleSections #-}
2{-# LANGUAGE OverloadedStrings #-}
3module PacketTranscoder where
4
5import Control.Monad
6import Data.IORef
7import Data.List
8import Data.Maybe
9import Data.OpenPGP
10import Data.OpenPGP.Util
11import GnuPGAgent
12import qualified Data.ByteString as S
13import qualified Data.ByteString.Char8 as S8
14import qualified Data.Map as Map
15import qualified Data.Traversable as Traversable
16import System.IO ( stderr)
17import System.Posix.IO ( fdToHandle )
18import Text.Show.Pretty as PP ( ppShow )
19import Types
20
21-- | Merge two representations of the same key, prefering secret version
22-- because they have more information.
23mergeKeyPacket :: String -> MappedPacket -> MappedPacket -> MappedPacket
24mergeKeyPacket what key p =
25 key { packet = minimumBy (keyCompare what) [packet key,packet p]
26 , locations = Map.union (locations key) (locations p)
27 }
28
29-- | Compare different versions if the same key pair. Public versions
30-- are considered greater. If the two packets do not represent the same
31-- key or the packets are not keys at all, an error will result that
32-- includes the context provided as the first argument.
33keyCompare :: String -> Packet -> Packet -> Ordering
34keyCompare what (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
35keyCompare what (PublicKeyPacket {}) (SecretKeyPacket {}) = GT
36keyCompare what a b | keykey a==keykey b = EQ
37keyCompare what a b = error $ unlines ["Unable to merge "++what++":"
38 , if isKey a then fingerprint a else ""
39 , PP.ppShow a
40 , if isKey b then fingerprint b else ""
41 , PP.ppShow b
42 ]
43
44resolveInputFile :: InputFileContext -> InputFile -> [FilePath]
45resolveInputFile ctx = resolve
46 where
47 resolve HomeSec = return (homesecPath ctx)
48 resolve HomePub = return (homepubPath ctx)
49 resolve (ArgFile f) = return f
50 resolve _ = []
51
52resolveForReport :: Maybe InputFileContext -> InputFile -> FilePath
53resolveForReport mctx (Pipe fdr fdw) = resolveForReport mctx (ArgFile str)
54 where str = case (fdr,fdw) of
55 (0,1) -> "-"
56 _ -> "&pipe" ++ show (fdr,fdw)
57resolveForReport mctx (FileDesc fd) = resolveForReport mctx (ArgFile str)
58 where str = "&" ++ show fd
59resolveForReport mctx f = concat $ resolveInputFile ctx f
60 where ctx = fromMaybe (InputFileContext "&secret" "&public") mctx
61
62readInputFileS :: InputFileContext -> InputFile -> IO S.ByteString
63readInputFileS ctx (Pipe fd _) = fdToHandle fd >>= S.hGetContents
64readInputFileS ctx (FileDesc fd) = fdToHandle fd >>= S.hGetContents
65readInputFileS ctx inp = do
66 let fname = resolveInputFile ctx inp
67 fmap S.concat $ mapM S.readFile fname
68
69
70
71-- | Reads contents of an 'InputFile' or returns the cached content from a prior call.
72-- An optional prompt is provided and will be printed on stdout only in the case that
73-- the provided 'InputFile' is 'FileDesc' 0 (i.e. stdin).
74cachedContents :: Maybe S.ByteString -> InputFileContext -> InputFile -> IO (IO S.ByteString)
75cachedContents maybePrompt ctx fd = do
76 ref <- newIORef Nothing
77 return $ get maybePrompt ref fd
78 where
79 trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs
80
81 get maybePrompt ref fd = do
82 pw <- readIORef ref
83 flip (flip maybe return) pw $ do
84 if fd == FileDesc 0 then case maybePrompt of
85 Just prompt -> S.hPutStr stderr prompt
86 Nothing -> return ()
87 else return ()
88 pw <- fmap trimCR $ readInputFileS ctx fd
89 writeIORef ref (Just pw)
90 return pw
91
92
93
94makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext
95 -> Map.Map KeyKey (OriginMapped Query)
96 -> IO PacketTranscoder
97makeMemoizingDecrypter operation ctx keys = do
98 if null chains then do
99 -- (*) Notice we do not pass ctx to resolveForReport.
100 -- This is because the merge function does not currently use a context
101 -- and the pws map keys must match the MappedPacket locations.
102 -- TODO: Perhaps these should both be of type InputFile rather than
103 -- FilePath?
104 -- pws :: Map.Map FilePath (IO S.ByteString)
105 {-
106 -- This disabled code obtained password sources from StreamInfo records.
107 pws <-
108 Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ)
109 (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above
110 $ Map.filter (isJust . pwfile . typ) $ opFiles operation)
111 -}
112 let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n"
113 -- List of file-specific password sources.
114 pws2 <-
115 Traversable.mapM (cachedContents prompt ctx)
116 $ Map.fromList $ mapMaybe
117 (\spec -> (,passSpecPassFile spec) `fmap` do
118 guard $ isNothing $ passSpecKeySpec spec
119 passSpecRingFile spec)
120 passspecs
121 -- List of general password sources.
122 defpw <- do
123 Traversable.mapM (cachedContents prompt ctx . passSpecPassFile)
124 $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp)
125 && isNothing (passSpecKeySpec sp))
126 $ passspecs
127 unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet)
128 return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw (not $ null agentspec)
129 else let PassphraseMemoizer f = head chains
130 in return f
131 where
132 (chains,passspecs0) = partition isChain $ opPassphrases operation
133 where isChain (PassphraseMemoizer {}) = True
134 isChain _ = False
135 (agentspec,passspecs) = partition isAgent passspecs0
136 where isAgent PassphraseAgent = True
137 isAgent _ = False
138 doDecrypt :: IORef (Map.Map KeyKey Packet)
139 -> Map.Map FilePath (IO S.ByteString)
140 -> Maybe (IO S.ByteString)
141 -> Bool
142 -> (SymmetricAlgorithm,S2K)
143 -> MappedPacket
144 -> IO (KikiCondition Packet)
145 doDecrypt unkeysRef pws defpw agent_requested (dest_alg,dest_s2k) mp0 = do
146 unkeys <- readIORef unkeysRef
147 let (mp,qry) = fromMaybe (mp0,Query (packet mp0) "anonymous2" Nothing) $ do
148 k <- Map.lookup kk keys
149 return (mergeKeyPacket "decrypt" mp0 (fmap queryPacket k), packet k)
150 wk = packet mp0
151 kk = keykey wk
152 fs = Map.keys $ locations mp
153
154 decryptIt [] = return BadPassphrase
155 decryptIt (getpw:getpws) = tries 1 getpw (decryptIt getpws)
156 where
157 tries count getpw recurse = do
158 -- TODO: This function should use mergeKeyPacket to
159 -- combine the packet with it's unspilled version before
160 -- attempting to decrypt it. Note: We are uninterested
161 -- in the 'locations' field, so this would effectively
162 -- allow you to run 'decryptIt' on an unencrypted public key
163 -- to obtain it's secret key.
164 (pw,wants_retry) <- getpw (if count>1 then AskAgain "Bad pasphrase." else Ask,qry)
165 let wkun = fromMaybe wk $ do
166 guard $ symmetric_algorithm (packet mp) /= Unencrypted
167 decryptSecretKey pw (packet mp)
168
169 case symmetric_algorithm wkun of
170
171 Unencrypted -> do
172 writeIORef unkeysRef (Map.insert kk wkun unkeys)
173 ek <- if dest_alg==Unencrypted
174 then return $ Just wkun
175 else encryptSecretKey pw dest_s2k dest_alg wkun
176 case ek of
177 Nothing | wants_retry && count<3 -> tries (count+1) getpw recurse
178 Nothing -> recurse
179 Just wken -> return $ KikiSuccess wken
180
181 _ -> recurse
182
183 getpws = (map (const . fmap (,False)) $ mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw) ++ [ agentpw | agent_requested ]
184
185 -- TODO: First we should try the master key with AskNot.
186 -- If that fails, we should try the subkey.
187 agentpw (ask,qry) = do
188 s <- session
189 fromMaybe (return ("",False)) $ do
190 s <- s
191 Just $ do
192 case ask of AskAgain _ -> clearPassphrase s (queryPacket qry)
193 _ -> return ()
194 mbpw <- getPassphrase s ask qry
195 quit s
196 return ( maybe "" S8.pack mbpw, True)
197
198 if symmetric_algorithm wk == dest_alg
199 && ( symmetric_algorithm wk == Unencrypted || s2k wk == dest_s2k )
200 then return (KikiSuccess wk)
201 else maybe (decryptIt getpws)
202 (return . KikiSuccess)
203 $ Map.lookup kk unkeys
204