diff options
-rw-r--r-- | lib/GnuPGAgent.hs | 4 | ||||
-rw-r--r-- | lib/KeyRing.hs | 13 | ||||
-rw-r--r-- | lib/PacketTranscoder.hs | 313 | ||||
-rw-r--r-- | lib/Types.hs | 38 |
4 files changed, 204 insertions, 164 deletions
diff --git a/lib/GnuPGAgent.hs b/lib/GnuPGAgent.hs index 067e3bc..9e0bacf 100644 --- a/lib/GnuPGAgent.hs +++ b/lib/GnuPGAgent.hs | |||
@@ -3,6 +3,7 @@ | |||
3 | {-# LANGUAGE PatternGuards #-} | 3 | {-# LANGUAGE PatternGuards #-} |
4 | module GnuPGAgent | 4 | module GnuPGAgent |
5 | ( session | 5 | ( session |
6 | , GnuPGAgent | ||
6 | , Query(..) | 7 | , Query(..) |
7 | , QueryMode(..) | 8 | , QueryMode(..) |
8 | , getPassphrase | 9 | , getPassphrase |
@@ -99,7 +100,8 @@ getPassphrase agent ask (Query key uid masterkey) = do | |||
99 | r0 <- hGetLine (agentHandle agent) | 100 | r0 <- hGetLine (agentHandle agent) |
100 | -- hPutStrLn stderr $ "agent says: " ++ r0 | 101 | -- hPutStrLn stderr $ "agent says: " ++ r0 |
101 | case takeWhile (/=' ') r0 of | 102 | case takeWhile (/=' ') r0 of |
102 | "OK" -> hGetLine (agentHandle agent) >>= unhex . drop 3 | 103 | "OK" | not (null $ drop 3 r0) -> return r0 >>= unhex . drop 3 -- . (\x -> trace (show x) x) |
104 | | otherwise -> hGetLine (agentHandle agent) >>= unhex . drop 3 -- . (\x -> trace (show x) x) | ||
103 | where | 105 | where |
104 | #if defined(VERSION_memory) | 106 | #if defined(VERSION_memory) |
105 | unhex hx = case convertFromBase Base16 (S8.pack hx) of | 107 | unhex hx = case convertFromBase Base16 (S8.pack hx) of |
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs index 87b38bf..1aed50e 100644 --- a/lib/KeyRing.hs +++ b/lib/KeyRing.hs | |||
@@ -409,22 +409,9 @@ instance ASN1Object RSAPrivateKey where | |||
409 | 409 | ||
410 | 410 | ||
411 | 411 | ||
412 | uncamel :: String -> String | ||
413 | uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args | ||
414 | where | ||
415 | (.:) = fmap . fmap | ||
416 | ( firstWord , | ||
417 | otherWords ) = splitAt 1 ws | ||
418 | ws = camel >>= groupBy (\_ c -> isLower c) | ||
419 | ( camel, args) = splitAt 1 $ words str | ||
420 | |||
421 | reportString :: KikiReportAction -> String | 412 | reportString :: KikiReportAction -> String |
422 | reportString x = uncamel $ show x | 413 | reportString x = uncamel $ show x |
423 | 414 | ||
424 | errorString :: KikiCondition a -> String | ||
425 | errorString (KikiSuccess {}) = "success" | ||
426 | errorString e = uncamel . show $ fmap (const ()) e | ||
427 | |||
428 | -- | Errors in kiki are indicated by the returning of this record. | 415 | -- | Errors in kiki are indicated by the returning of this record. |
429 | data KikiResult a = KikiResult | 416 | data KikiResult a = KikiResult |
430 | { kikiCondition :: KikiCondition a | 417 | { kikiCondition :: KikiCondition a |
diff --git a/lib/PacketTranscoder.hs b/lib/PacketTranscoder.hs index afbf55b..eaa8366 100644 --- a/lib/PacketTranscoder.hs +++ b/lib/PacketTranscoder.hs | |||
@@ -3,6 +3,7 @@ | |||
3 | {-# LANGUAGE PatternGuards #-} | 3 | {-# LANGUAGE PatternGuards #-} |
4 | module PacketTranscoder where | 4 | module PacketTranscoder where |
5 | 5 | ||
6 | import Debug.Trace | ||
6 | import GHC.Stack | 7 | import GHC.Stack |
7 | import Control.Monad | 8 | import Control.Monad |
8 | import Data.IORef | 9 | import Data.IORef |
@@ -94,161 +95,177 @@ cachedContents maybePrompt ctx fd = do | |||
94 | return pw | 95 | return pw |
95 | 96 | ||
96 | 97 | ||
98 | data PassphraseResponse = ObtainedPassphrase S.ByteString | ||
99 | | CanceledPassphrase | ||
100 | | NextPassphrase | ||
101 | deriving Show | ||
97 | 102 | ||
98 | makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext | 103 | type PassphraseSource = (SymmetricAlgorithm,S2K) -> MappedPacket -> [IO PassphraseResponse] |
104 | |||
105 | interpretPassSpec :: InputFileContext | ||
99 | -> (Maybe MappedPacket, Map.Map KeyKey (OriginMapped Query)) | 106 | -> (Maybe MappedPacket, Map.Map KeyKey (OriginMapped Query)) |
100 | -> IO PacketTranscoder | 107 | -> PassphraseSpec |
101 | makeMemoizingDecrypter operation ctx (workingkey,keys) = do | 108 | -> IO (KikiCondition (PassphraseSource, IO ()) ) |
102 | if null chains then do | 109 | interpretPassSpec ctx keys PassphraseSpec { passSpecPassFile = fd |
103 | -- (*) Notice we do not pass ctx to resolveForReport. | 110 | , passSpecKeySpec = keyspec |
104 | -- This is because the merge function does not currently use a context | 111 | , passSpecRingFile = inputfile } = do |
105 | -- and the pws map keys must match the MappedPacket locations. | 112 | getpw <- |
106 | -- TODO: Perhaps these should both be of type InputFile rather than | 113 | cachedContents (Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n") |
107 | -- FilePath? | 114 | ctx |
108 | -- pws :: Map.Map FilePath (IO S.ByteString) | 115 | fd |
109 | {- | 116 | let matchkey fp mp = matchpr fp (packet mp) == fp |
110 | -- This disabled code obtained password sources from StreamInfo records. | 117 | matchfile file mp = Map.member file (locations mp) |
111 | pws <- | 118 | specializers = [ fmap matchkey keyspec, fmap matchfile inputfile] |
112 | Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ) | 119 | specialize alg mp = |
113 | (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above | 120 | if and $ map (\f -> f mp) $ catMaybes specializers |
114 | $ Map.filter (isJust . pwfile . typ) $ opFiles operation) | 121 | then [ObtainedPassphrase <$> getpw] |
115 | -} | 122 | else [] |
116 | let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n" | 123 | return $ KikiSuccess (specialize, return ()) |
117 | -- List of file-specific password sources. | 124 | |
118 | pws2 <- | 125 | interpretPassSpec ctx keys PassphraseAgent = do |
119 | Traversable.mapM (cachedContents prompt ctx) | 126 | mb <- session |
120 | $ Map.fromList $ mapMaybe | 127 | fromMaybe (return AgentConnectionFailure) $ do |
121 | (\spec -> (,passSpecPassFile spec) `fmap` do | 128 | agent <- mb |
122 | guard $ isNothing $ passSpecKeySpec spec | 129 | Just $ do |
123 | passSpecRingFile spec) | 130 | let cacheSearch alg mp = |
124 | passspecs | 131 | case getQueries keys mp of |
125 | -- List of general password sources. | 132 | [] -> [] |
126 | defpw <- do | 133 | kqry:qs -> trace ("queries="++show (kqry:qs)) $ |
127 | Traversable.mapM (cachedContents prompt ctx . passSpecPassFile) | 134 | map (sendQuery agent (AskNot,NextPassphrase)) (kqry:qs) |
128 | $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp) | 135 | ++ sendQuery agent (initial_ask,CanceledPassphrase) kqry |
129 | && isNothing (passSpecKeySpec sp)) | 136 | : replicate 3 (sendQuery agent (AskAgain "Bad passphrase",CanceledPassphrase) kqry) |
130 | $ passspecs | 137 | where |
131 | unkeysRef <- newIORef (Map.empty :: Map.Map (KeyKey,SymmetricAlgorithm,S2K) Packet) | 138 | srcalg = symmetric_algorithm $ packet mp |
132 | return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw (not $ null agentspec) | 139 | |
133 | else let PassphraseMemoizer f = head chains | 140 | initial_ask | Unencrypted <- srcalg = AskNew |
134 | in return f | 141 | | otherwise = AskExisting |
142 | |||
143 | return $ KikiSuccess (cacheSearch, quit agent) | ||
144 | |||
145 | sendQuery :: GnuPGAgent -> (QueryMode,PassphraseResponse) -> OriginMapped Query -> IO PassphraseResponse | ||
146 | sendQuery agent (ask,failure) qry = do | ||
147 | mbpw <- getPassphrase agent ask (packet qry) | ||
148 | case mbpw of | ||
149 | Nothing -> do | ||
150 | S8.hPutStr stderr $ S8.pack $ "Failed to get passphrase "++show failure | ||
151 | return failure | ||
152 | Just pw -> do | ||
153 | -- S8.hPutStrLn stderr $ S8.pack $ "received pw: "++pw | ||
154 | return $ ObtainedPassphrase $ S8.pack pw | ||
155 | |||
156 | getQueries :: (Maybe MappedPacket,Map KeyKey (OriginMapped Query)) -> OriginMapped Packet -> [OriginMapped Query] | ||
157 | getQueries (workingkey,keys) mp = | ||
158 | let kk = keykey $ packet mp | ||
159 | in case Map.lookup kk keys of | ||
160 | Just qryk -> | ||
161 | case queryMainKey (packet qryk) of | ||
162 | Just maink -> | ||
163 | let kkmain = keykey maink | ||
164 | in case Map.lookup kkmain keys of | ||
165 | Just qrym -> qryk : qrym : (Map.elems . Map.delete kkmain . Map.delete kk) keys | ||
166 | Nothing -> [ qryk ] | ||
167 | Nothing -> [ qryk ] | ||
168 | Nothing -> | ||
169 | -- This is probably a newly imported key. We'll treat the current working key as it's main key. | ||
170 | -- trace ("getQueries cache miss "++show (fingerprint $ packet mp)) [] | ||
171 | let (qryk,qrym) | ||
172 | = fromMaybe (Query (packet mp) "anonymous2" Nothing,Nothing) $ do | ||
173 | guard $ is_subkey (packet mp) | ||
174 | working <- fmap packet workingkey | ||
175 | q <- Map.lookup (keykey working) keys | ||
176 | return ( Query (packet mp) (queryUID $ packet q) (Just working), Just q) | ||
177 | delm = case workingkey of | ||
178 | Nothing -> id | ||
179 | Just wk -> Map.delete (keykey $ packet wk) | ||
180 | in [ fmap (const qryk) mp ] ++ maybeToList qrym ++ (Map.elems . delm . Map.delete kk) keys | ||
181 | |||
182 | |||
183 | makeTranscoder :: IORef (Map.Map (KeyKey,SymmetricAlgorithm,S2K) Packet) | ||
184 | -> IO (KikiCondition (PassphraseSource, IO ())) | ||
185 | -> ( (SymmetricAlgorithm,S2K) -> MappedPacket -> IO (KikiCondition Packet) ) | ||
186 | -> ( (SymmetricAlgorithm,S2K) -> MappedPacket -> IO (KikiCondition Packet) ) | ||
187 | makeTranscoder unkeysRef source next alg mp = do | ||
188 | ssr <- source | ||
189 | case ssr of | ||
190 | KikiSuccess (getqs, quit) -> tries (quit >> next alg mp) $ getqs alg mp | ||
191 | er -> return $ fmap (error "makeTranscoder") er | ||
135 | where | 192 | where |
136 | (chains,passspecs0) = partition isChain $ opPassphrases operation | 193 | tries fin [] = fin |
137 | where isChain (PassphraseMemoizer {}) = True | 194 | tries fin (src:srcs) = do |
138 | isChain _ = False | 195 | S8.hPutStrLn stderr "trying..." |
139 | (agentspec,passspecs) = partition isAgent passspecs0 | 196 | resp <- src |
140 | where isAgent PassphraseAgent = True | 197 | case resp of |
141 | isAgent _ = False | 198 | CanceledPassphrase -> return OperationCanceled |
142 | doDecrypt :: IORef (Map.Map (KeyKey,SymmetricAlgorithm,S2K) Packet) | 199 | NextPassphrase -> tries fin srcs |
143 | -> Map.Map FilePath (IO S.ByteString) | 200 | ObtainedPassphrase pw -> do |
144 | -> Maybe (IO S.ByteString) | 201 | let wkun = fromMaybe (packet mp) $ do |
145 | -> Bool | 202 | guard $ symmetric_algorithm (packet mp) /= Unencrypted |
146 | -> (SymmetricAlgorithm,S2K) | 203 | decryptSecretKey pw (packet mp) |
147 | -> MappedPacket | 204 | kk = keykey (packet mp) |
148 | -> IO (KikiCondition Packet) | 205 | retryOrFail = tries fin srcs |
149 | doDecrypt unkeysRef pws defpw agent_requested (dest_alg,dest_s2k) mp0 = do | 206 | case symmetric_algorithm wkun of |
207 | Unencrypted -> do | ||
208 | modifyIORef unkeysRef (Map.insert (kk,Unencrypted,S2K 100 "") wkun) | ||
209 | ek <- case fst alg of | ||
210 | Unencrypted -> do | ||
211 | S8.hPutStrLn stderr "decrypted packet" | ||
212 | return $ Just wkun | ||
213 | _ -> encryptSecretKey pw (snd alg) (fst alg) wkun | ||
214 | case ek of | ||
215 | Nothing -> do | ||
216 | S8.hPutStrLn stderr "failed to encrypt" | ||
217 | retryOrFail | ||
218 | Just wken -> do | ||
219 | S8.hPutStrLn stderr "success encrypted" | ||
220 | let (a,s) = alg | ||
221 | modifyIORef unkeysRef (Map.insert (kk,a,s) wken) | ||
222 | return $ KikiSuccess wken | ||
223 | _ -> do S8.hPutStrLn stderr "failed to decrypt" | ||
224 | retryOrFail | ||
225 | |||
226 | normalizeAlgorithm :: (SymmetricAlgorithm,S2K) -> (SymmetricAlgorithm,S2K) | ||
227 | normalizeAlgorithm (Unencrypted,_) = (Unencrypted,S2K 100 "") | ||
228 | normalizeAlgorithm alg = alg | ||
229 | |||
230 | transcodeWithCache :: IORef (Map (KeyKey, SymmetricAlgorithm, S2K) Packet) | ||
231 | -> ( (SymmetricAlgorithm,S2K) -> MappedPacket -> IO (KikiCondition Packet) ) | ||
232 | -> ( (SymmetricAlgorithm,S2K) -> MappedPacket -> IO (KikiCondition Packet) ) | ||
233 | transcodeWithCache unkeysRef miss alg0 mp@MappedPacket{ packet = wk } = do | ||
234 | let alg = normalizeAlgorithm alg0 | ||
150 | unkeys <- readIORef unkeysRef | 235 | unkeys <- readIORef unkeysRef |
151 | let (mp,qry) = fromMaybe (mp0,Query (packet mp0) "anonymous2" Nothing) | ||
152 | $ mplus (do k <- Map.lookup kk keys | ||
153 | return (mergeKeyPacket "decrypt" mp0 (fmap queryPacket k), packet k)) | ||
154 | (do guard $ is_subkey (packet mp0) | ||
155 | working <- fmap packet workingkey | ||
156 | q <- fmap packet $ Map.lookup (keykey working) keys | ||
157 | return (mp0, Query (packet mp0) (queryUID q) (Just working))) | ||
158 | |||
159 | dest_s2k' | dest_alg==Unencrypted = S2K 100 "" | ||
160 | | otherwise = dest_s2k | ||
161 | |||
162 | wk = packet mp0 | ||
163 | kk = keykey wk | ||
164 | fs = Map.keys $ locations mp | ||
165 | |||
166 | decryptIt [] = return BadPassphrase | ||
167 | decryptIt (getpw:getpws) = tries 1 getpw (decryptIt getpws) | ||
168 | where | ||
169 | tries count getpw recurse = do | ||
170 | -- TODO: This function should use mergeKeyPacket to | ||
171 | -- combine the packet with it's unspilled version before | ||
172 | -- attempting to decrypt it. Note: We are uninterested | ||
173 | -- in the 'locations' field, so this would effectively | ||
174 | -- allow you to run 'decryptIt' on an unencrypted public key | ||
175 | -- to obtain it's secret key. | ||
176 | handleIO_ (decryptIt []) $ do | ||
177 | (pw0,wants_retry) <- getpw (count,qry) | ||
178 | case pw0 of | ||
179 | KikiSuccess pw -> do | ||
180 | let wkun = fromMaybe wk $ do | ||
181 | guard $ symmetric_algorithm (packet mp) /= Unencrypted | ||
182 | decryptSecretKey pw (packet mp) | ||
183 | |||
184 | retryOrFail | ||
185 | | Just clear <- wants_retry = if count < 4 | ||
186 | then tries (count+1) getpw recurse | ||
187 | else clear >> recurse | ||
188 | | otherwise = recurse | ||
189 | |||
190 | case symmetric_algorithm wkun of | ||
191 | |||
192 | Unencrypted -> do | ||
193 | writeIORef unkeysRef (Map.insert (kk,Unencrypted,S2K 100 "") wkun unkeys) | ||
194 | ek <- case dest_alg of | ||
195 | Unencrypted -> return $ Just wkun | ||
196 | _ -> encryptSecretKey pw dest_s2k' dest_alg wkun | ||
197 | |||
198 | case ek of | ||
199 | Nothing -> retryOrFail | ||
200 | Just wken -> do | ||
201 | modifyIORef unkeysRef (Map.insert (kk,dest_alg,dest_s2k') wken) | ||
202 | return $ KikiSuccess wken | ||
203 | |||
204 | _ -> retryOrFail | ||
205 | err -> return $ fmap (error "pasphrase error") err | ||
206 | |||
207 | getpws = (map (const . fmap (\pw -> (KikiSuccess pw,Nothing))) | ||
208 | $ mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw) ++ [ agentpw | agent_requested ] | ||
209 | |||
210 | agentpw (count,qry) = do | ||
211 | s <- session | ||
212 | fromMaybe (return (AgentConnectionFailure,Nothing)) $ do | ||
213 | s <- s | ||
214 | Just $ do | ||
215 | let (firsttime,maink) | Just k <- (queryMainKey qry) = (2,k) | ||
216 | | otherwise = (1,error "bug in makeMemoizingDecrypter") | ||
217 | |||
218 | alg = symmetric_algorithm (queryPacket qry) | ||
219 | |||
220 | ask | count<firsttime = AskNot | ||
221 | | count>firsttime = AskAgain "Bad passphrase" | ||
222 | | count==firsttime = initial_ask | ||
223 | where | ||
224 | initial_ask | Unencrypted <- alg = AskNew | ||
225 | | otherwise = AskExisting | ||
226 | |||
227 | actual_qry | count<firsttime = qry { queryPacket = maink, queryMainKey = Nothing } | ||
228 | | otherwise = qry | ||
229 | |||
230 | let clear | count > firsttime = clearPassphrase s (queryPacket qry) | ||
231 | | otherwise = return () | ||
232 | clear | ||
233 | let sanitizeQry qry = (fingerprint $ queryPacket qry, queryUID qry, fmap fingerprint $ queryMainKey qry) | ||
234 | -- putStrLn $ "(count,firsttime,ask,qry,actual_qry)="++show (count,firsttime,ask,sanitizeQry qry, sanitizeQry actual_qry) | ||
235 | mbpw <- getPassphrase s ask actual_qry | ||
236 | quit s | ||
237 | -- putStrLn $ "mbpw = " ++show mbpw | ||
238 | return ( maybe (if count >=firsttime then OperationCanceled | ||
239 | else KikiSuccess "") -- No cached data. | ||
240 | (KikiSuccess . S8.pack) | ||
241 | mbpw | ||
242 | , guard (ask /= AskNew) >> Just clear ) | ||
243 | |||
244 | calls <- currentCallStack | 236 | calls <- currentCallStack |
245 | putStrLn $ concat [fingerprint wk," ", show (symmetric_algorithm wk,s2k wk)," --> ",show (dest_alg,dest_s2k)] | 237 | putStrLn $ concat [fingerprint wk," ", show (symmetric_algorithm wk,s2k wk)," --> ",show alg] |
246 | mapM_ putStrLn calls | 238 | mapM_ putStrLn calls |
247 | if symmetric_algorithm wk == dest_alg && s2k wk == dest_s2k' | 239 | if (symmetric_algorithm wk,s2k wk) == alg |
248 | then return (KikiSuccess wk) | 240 | then return (KikiSuccess wk) |
249 | else maybe (decryptIt getpws) | 241 | else maybe (miss alg mp) (return . KikiSuccess) |
250 | (return . KikiSuccess) | 242 | $ Map.lookup (keykey wk,fst alg, snd alg) unkeys |
251 | $ Map.lookup (kk,dest_alg,dest_s2k') unkeys | 243 | |
244 | tryInOrder [] _ _ = return BadPassphrase | ||
245 | tryInOrder [f] alg mp = f alg mp | ||
246 | tryInOrder (f:fs) alg mp = do | ||
247 | r <- f alg mp | ||
248 | case r of | ||
249 | KikiSuccess _ -> return r | ||
250 | e -> do | ||
251 | S8.hPutStrLn stderr $ S8.pack ("got "++errorString e++", trying next") | ||
252 | tryInOrder fs alg mp | ||
253 | |||
254 | -- The transcoder works on 'MappedPacket' instead of 'Packet' so that | ||
255 | -- file-specific passphrases can be utilized. | ||
256 | makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext | ||
257 | -> (Maybe MappedPacket, Map.Map KeyKey (OriginMapped Query)) | ||
258 | -> IO PacketTranscoder | ||
259 | makeMemoizingDecrypter operation ctx (workingkey,keys) = do | ||
260 | unkeysRef <- newIORef (Map.empty :: Map.Map (KeyKey,SymmetricAlgorithm,S2K) Packet) | ||
261 | return $ tryInOrder $ map passSpecTranscoder chains ++ [ trans unkeysRef ] | ||
262 | where | ||
263 | (chains,passpecs) = span isChain $ sort $ opPassphrases operation | ||
264 | where isChain (PassphraseMemoizer {}) = True | ||
265 | isChain _ = False | ||
266 | srcs = map (interpretPassSpec ctx (workingkey,keys)) passpecs | ||
267 | |||
268 | trans unkeysRef = transcodeWithCache unkeysRef (foldr (makeTranscoder unkeysRef) (\_ _ -> return BadPassphrase) srcs) | ||
252 | 269 | ||
253 | keyQueries :: Maybe String -> Map InputFile (StreamInfo,Message) -> (Maybe MappedPacket, Map KeyKey (OriginMapped Query)) | 270 | keyQueries :: Maybe String -> Map InputFile (StreamInfo,Message) -> (Maybe MappedPacket, Map KeyKey (OriginMapped Query)) |
254 | keyQueries grip ringPackets = (mwk, fmap makeQuery keys) | 271 | keyQueries grip ringPackets = (mwk, fmap makeQuery keys) |
diff --git a/lib/Types.hs b/lib/Types.hs index 686614e..dd519de 100644 --- a/lib/Types.hs +++ b/lib/Types.hs | |||
@@ -1,6 +1,8 @@ | |||
1 | {-# LANGUAGE DeriveFunctor #-} | 1 | {-# LANGUAGE DeriveFunctor #-} |
2 | module Types where | 2 | module Types where |
3 | 3 | ||
4 | import Data.Char (isLower,toLower) | ||
5 | import Data.List (groupBy) | ||
4 | import Data.Map as Map (Map) | 6 | import Data.Map as Map (Map) |
5 | import qualified Data.Map as Map | 7 | import qualified Data.Map as Map |
6 | import Data.OpenPGP | 8 | import Data.OpenPGP |
@@ -113,7 +115,7 @@ data PassphraseSpec = PassphraseSpec | |||
113 | -- ^ The passphrase will be read from this file or file descriptor. | 115 | -- ^ The passphrase will be read from this file or file descriptor. |
114 | } | 116 | } |
115 | -- | Use this to carry pasphrases from a previous run. | 117 | -- | Use this to carry pasphrases from a previous run. |
116 | | PassphraseMemoizer PacketTranscoder | 118 | | PassphraseMemoizer { passSpecTranscoder :: PacketTranscoder } |
117 | | PassphraseAgent | 119 | | PassphraseAgent |
118 | 120 | ||
119 | instance Show PassphraseSpec where | 121 | instance Show PassphraseSpec where |
@@ -125,7 +127,24 @@ instance Eq PassphraseSpec where | |||
125 | _ == _ | 127 | _ == _ |
126 | = False | 128 | = False |
127 | 129 | ||
128 | 130 | -- Ord instance for PassphraseSpec generally orders by generality with the most | |
131 | -- general being greatest and the least general being least. The one exception | ||
132 | -- is the 'PassphraseMemoizer' which is considered least of all even though it | ||
133 | -- is very general. This is so an existing memoizer will be tried first, and | ||
134 | -- if there is none, one will be created that tries the others in order of | ||
135 | -- increasing generality. Key-specialization is considered less general than | ||
136 | -- file-specialization. | ||
137 | instance Ord PassphraseSpec where | ||
138 | compare (PassphraseMemoizer _) (PassphraseMemoizer _) = EQ | ||
139 | compare PassphraseAgent PassphraseAgent = EQ | ||
140 | compare (PassphraseMemoizer _) _ = LT | ||
141 | compare (PassphraseSpec a b c) (PassphraseSpec d e f) | ||
142 | | fmap (const ()) a == fmap (const ()) d | ||
143 | && fmap (const ()) b == fmap (const ()) e = compare (a,b,c) (d,e,f) | ||
144 | compare (PassphraseSpec (Just _) (Just _) _) _ = LT | ||
145 | compare (PassphraseSpec Nothing (Just _) _) _ = LT | ||
146 | compare (PassphraseSpec (Just _) _ _) _ = LT | ||
147 | compare PassphraseAgent _ = GT | ||
129 | 148 | ||
130 | data Transform = | 149 | data Transform = |
131 | Autosign | 150 | Autosign |
@@ -253,6 +272,21 @@ instance Applicative KikiCondition where | |||
253 | Left err -> err | 272 | Left err -> err |
254 | Left err -> err | 273 | Left err -> err |
255 | 274 | ||
275 | uncamel :: String -> String | ||
276 | uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args | ||
277 | where | ||
278 | (.:) = fmap . fmap | ||
279 | ( firstWord , | ||
280 | otherWords ) = splitAt 1 ws | ||
281 | ws = camel >>= groupBy (\_ c -> isLower c) | ||
282 | ( camel, args) = splitAt 1 $ words str | ||
283 | |||
284 | errorString :: KikiCondition a -> String | ||
285 | errorString (KikiSuccess {}) = "success" | ||
286 | errorString e = uncamel . show $ fmap (const ()) e | ||
287 | |||
288 | |||
289 | |||
256 | data InputFileContext = InputFileContext | 290 | data InputFileContext = InputFileContext |
257 | { homesecPath :: FilePath | 291 | { homesecPath :: FilePath |
258 | , homepubPath :: FilePath | 292 | , homepubPath :: FilePath |