diff options
author | James Crayne <jim.crayne@gmail.com> | 2014-05-06 20:42:06 -0400 |
---|---|---|
committer | James Crayne <jim.crayne@gmail.com> | 2014-05-06 20:42:06 -0400 |
commit | cd074ee590e82bfc9449072c78c97db2d3c1e064 (patch) | |
tree | 04c0b3156f9bb0824efa06dece836d75dc52fc0b /KeyRing.hs | |
parent | ea39ec6b1e8f99ffde158639486246e7aef0d62c (diff) | |
parent | 08787650f5d99bb9110bb9d7ef92ac249be865ad (diff) |
Merge branch 'master' of jotunheim:samizdat/kiki
Diffstat (limited to 'KeyRing.hs')
-rw-r--r-- | KeyRing.hs | 284 |
1 files changed, 192 insertions, 92 deletions
@@ -5,12 +5,15 @@ | |||
5 | -- Maintainer : joe@jerkface.net | 5 | -- Maintainer : joe@jerkface.net |
6 | -- Stability : experimental | 6 | -- Stability : experimental |
7 | -- | 7 | -- |
8 | -- kiki is a command-line utility for manipulating GnuPG's keyring files. | 8 | -- kiki is a command-line utility for manipulating GnuPG's keyring files. This |
9 | -- This module is the programmer-facing API it uses to do that. | 9 | -- module is the programmer-facing API it uses to do that. |
10 | -- | 10 | -- |
11 | -- Note: This is *not* a public facing API. I (the author) consider this | 11 | -- Note: This is *not* a public facing API. I (the author) consider this |
12 | -- library to be internal to kiki and subject to change at my whim. | 12 | -- library to be internal to kiki and subject to change at my whim. |
13 | -- | 13 | -- |
14 | -- Typically, a client to this module would prepare a 'KeyRingOperation' | ||
15 | -- describing what he wants done, and then invoke 'runKeyRing' to make it | ||
16 | -- happen. | ||
14 | {-# LANGUAGE CPP #-} | 17 | {-# LANGUAGE CPP #-} |
15 | {-# LANGUAGE TupleSections #-} | 18 | {-# LANGUAGE TupleSections #-} |
16 | {-# LANGUAGE ViewPatterns #-} | 19 | {-# LANGUAGE ViewPatterns #-} |
@@ -25,27 +28,30 @@ module KeyRing | |||
25 | KikiResult(..) | 28 | KikiResult(..) |
26 | , KikiCondition(..) | 29 | , KikiCondition(..) |
27 | , KikiReportAction(..) | 30 | , KikiReportAction(..) |
31 | , errorString | ||
32 | , reportString | ||
28 | -- * Manipulating Keyrings | 33 | -- * Manipulating Keyrings |
29 | , runKeyRing | 34 | , runKeyRing |
35 | , KeyRingOperation(..) | ||
36 | , PassphraseSpec(..) | ||
37 | , Transform(..) | ||
38 | -- , PacketUpdate(..) | ||
39 | -- , guardAuthentic | ||
40 | -- * Describing File Operations | ||
30 | , StreamInfo(..) | 41 | , StreamInfo(..) |
31 | , Access(..) | 42 | , Access(..) |
43 | , FileType(..) | ||
44 | , InputFile(..) | ||
32 | , KeyFilter(..) | 45 | , KeyFilter(..) |
33 | , KeyRingOperation(..) | 46 | -- * Results of a KeyRing Operation |
34 | , PassphraseSpec(..) | ||
35 | , errorString | ||
36 | , reportString | ||
37 | , KeyRingRuntime(..) | 47 | , KeyRingRuntime(..) |
38 | , InputFile(..) | ||
39 | , FileType(..) | ||
40 | , importPublic | ||
41 | , importSecret | ||
42 | , subkeysOnly | ||
43 | , PacketUpdate(..) | ||
44 | , noManip | ||
45 | , KeyDB | 48 | , KeyDB |
46 | , KeyData(..) | 49 | , KeyData(..) |
47 | , SubKey(..) | 50 | , SubKey(..) |
48 | , packet | 51 | , packet |
52 | , locations | ||
53 | , keyflags | ||
54 | -- * Miscelaneous Utilities | ||
49 | , isKey | 55 | , isKey |
50 | , derRSA | 56 | , derRSA |
51 | , derToBase32 | 57 | , derToBase32 |
@@ -53,21 +59,18 @@ module KeyRing | |||
53 | , filterMatches | 59 | , filterMatches |
54 | , flattenKeys | 60 | , flattenKeys |
55 | , flattenTop | 61 | , flattenTop |
56 | , guardAuthentic | ||
57 | , Hosts.Hosts | 62 | , Hosts.Hosts |
58 | , isCryptoCoinKey | 63 | , isCryptoCoinKey |
59 | , keyflags | ||
60 | , locations | ||
61 | , matchpr | 64 | , matchpr |
62 | , parseSpec | 65 | , parseSpec |
63 | , parseUID | 66 | , parseUID |
67 | , UserIDRecord(..) | ||
64 | , pkcs8 | 68 | , pkcs8 |
65 | , RSAPublicKey(..) | 69 | , RSAPublicKey(..) |
66 | , rsaKeyFromPacket | 70 | , rsaKeyFromPacket |
67 | , secretToPublic | 71 | , secretToPublic |
68 | , selectPublicKey | 72 | , selectPublicKey |
69 | , selectSecretKey | 73 | , selectSecretKey |
70 | , UserIDRecord(..) | ||
71 | , usage | 74 | , usage |
72 | , usageString | 75 | , usageString |
73 | , walletImportFormat | 76 | , walletImportFormat |
@@ -129,7 +132,6 @@ import Foreign.Storable | |||
129 | #endif | 132 | #endif |
130 | import System.FilePath ( takeDirectory ) | 133 | import System.FilePath ( takeDirectory ) |
131 | import System.IO (hPutStrLn,withFile,IOMode(..), Handle, hPutStr) | 134 | import System.IO (hPutStrLn,withFile,IOMode(..), Handle, hPutStr) |
132 | import Foreign.C.Types ( CTime ) | ||
133 | import Data.IORef | 135 | import Data.IORef |
134 | import System.Posix.IO ( fdToHandle ) | 136 | import System.Posix.IO ( fdToHandle ) |
135 | import qualified Data.Traversable as Traversable ( mapM ) | 137 | import qualified Data.Traversable as Traversable ( mapM ) |
@@ -185,28 +187,42 @@ home = HomeDir | |||
185 | } | 187 | } |
186 | 188 | ||
187 | data InputFile = HomeSec | 189 | data InputFile = HomeSec |
190 | -- ^ A file named secring.gpg located in the home directory. | ||
191 | -- See 'opHome'. | ||
188 | | HomePub | 192 | | HomePub |
193 | -- ^ A file named pubring.gpg located in the home directory. | ||
194 | -- See 'opHome'. | ||
189 | | ArgFile FilePath | 195 | | ArgFile FilePath |
196 | -- ^ Contents will be read or written from the specified path. | ||
190 | | FileDesc Posix.Fd | 197 | | FileDesc Posix.Fd |
198 | -- ^ Contents will be read or written from the specified file | ||
199 | -- descriptor. | ||
191 | | Pipe Posix.Fd Posix.Fd | 200 | | Pipe Posix.Fd Posix.Fd |
192 | -- ^ Note: Don't use Pipe for wallet files. (TODO) | 201 | -- ^ Contents will be read from the first descriptor and updated |
202 | -- content will be writen to the second. Note: Don't use Pipe | ||
203 | -- for 'Wallet' files. (TODO: Wallet support) | ||
193 | deriving (Eq,Ord) | 204 | deriving (Eq,Ord) |
194 | 205 | ||
195 | -- type UsageTag = String | 206 | -- type UsageTag = String |
196 | type Initializer = String | 207 | type Initializer = String |
197 | type PasswordFile = InputFile | ||
198 | 208 | ||
199 | data FileType = KeyRingFile (Maybe PasswordFile) | 209 | data FileType = KeyRingFile |
200 | -- ^ PasswordFile parameter is deprecated in favor | ||
201 | -- of kPassphrases. TODO: remove it. | ||
202 | | PEMFile | 210 | | PEMFile |
203 | | WalletFile -- (Maybe UsageTag) | 211 | | WalletFile |
204 | | Hosts | 212 | | Hosts |
205 | 213 | ||
206 | data Access = AutoAccess -- ^ secret or public as appropriate based on existing content | 214 | -- | Use this type to indicate whether a file of type 'KeyRingFile' is expected |
215 | -- to contain secret or public PGP key packets. Note that it is not supported | ||
216 | -- to mix both in the same file and that the secret key packets include all of | ||
217 | -- the information contained in their corresponding public key packets. | ||
218 | data Access = AutoAccess -- ^ secret or public as appropriate based on existing content. | ||
219 | -- (see 'rtRingAccess') | ||
207 | | Sec -- ^ secret information | 220 | | Sec -- ^ secret information |
208 | | Pub -- ^ public information | 221 | | Pub -- ^ public information |
222 | deriving (Eq,Ord,Show) | ||
209 | 223 | ||
224 | -- | Note that the documentation here is intended for when this value is | ||
225 | -- assigned to 'fill'. For other usage, see 'spill'. | ||
210 | data KeyFilter = KF_None -- ^ No keys will be imported. | 226 | data KeyFilter = KF_None -- ^ No keys will be imported. |
211 | | KF_Match String -- ^ Only the key that matches the spec will be imported. | 227 | | KF_Match String -- ^ Only the key that matches the spec will be imported. |
212 | | KF_Subkeys -- ^ Subkeys will be imported if their owner key is | 228 | | KF_Subkeys -- ^ Subkeys will be imported if their owner key is |
@@ -216,18 +232,54 @@ data KeyFilter = KF_None -- ^ No keys will be imported. | |||
216 | -- identity (signed or self-authenticating). | 232 | -- identity (signed or self-authenticating). |
217 | | KF_All -- ^ All keys will be imported. | 233 | | KF_All -- ^ All keys will be imported. |
218 | 234 | ||
219 | data StreamInfo = StreamInfo | 235 | -- | This type describes how 'runKeyRing' will treat a file. |
220 | { access :: Access | 236 | data StreamInfo = StreamInfo { access :: Access |
237 | -- ^ Indicates whether the file is allowed to contain secret information. | ||
221 | , typ :: FileType | 238 | , typ :: FileType |
239 | -- ^ Indicates the format and content type of the file. | ||
222 | , fill :: KeyFilter | 240 | , fill :: KeyFilter |
223 | , spill :: KeyFilter -- ^ Currently respected for PEMFile and KeyRingFile. | 241 | -- ^ This filter controls what packets will be inserted into a file. |
224 | -- (TODO: WalletFile and Hosts) | 242 | , spill :: KeyFilter |
225 | -- Note that this is currently treated as a boolean | 243 | -- |
226 | -- flag. KF_None means the file is not spillable | 244 | -- ^ Use this to indicate whether or not a file's contents should be |
227 | -- and anything else means that it is. | 245 | -- available for updating other files. Note that although its type is |
246 | -- 'KeyFilter', it is usually interpretted as a boolean flag. Details | ||
247 | -- depend on 'typ' and are as follows: | ||
248 | -- | ||
249 | -- 'KeyRingFile': | ||
250 | -- | ||
251 | -- * 'KF_None' - The file's contents will not be shared. | ||
252 | -- | ||
253 | -- * otherwise - The file's contents will be shared. | ||
254 | -- | ||
255 | -- 'PEMFile': | ||
256 | -- | ||
257 | -- * 'KF_None' - The file's contents will not be shared. | ||
258 | -- | ||
259 | -- * 'KF_Match' - The file's key will be shared with the specified owner | ||
260 | -- key and usage tag. If 'fill' is also a 'KF_Match', then it must be | ||
261 | -- equal to this value; changing the usage or owner of a key is not | ||
262 | -- supported via the fill/spill mechanism. | ||
263 | -- | ||
264 | -- * otherwise - Unspecified. Do not use. | ||
265 | -- | ||
266 | -- 'WalletFile': | ||
267 | -- | ||
268 | -- * The 'spill' setting is ignored and the file's contents are shared. | ||
269 | -- (TODO) | ||
270 | -- | ||
271 | -- 'Hosts': | ||
272 | -- | ||
273 | -- * The 'spill' setting is ignored and the file's contents are shared. | ||
274 | -- (TODO) | ||
275 | -- | ||
228 | , initializer :: Maybe String | 276 | , initializer :: Maybe String |
277 | -- ^ If 'typ' is 'PEMFile' and an 'initializer' string is set, then it is | ||
278 | -- interpretted as a shell command that may be used to create the key if it | ||
279 | -- does not exist. | ||
229 | , transforms :: [Transform] | 280 | , transforms :: [Transform] |
230 | -- ^ TODO: currently ignored | 281 | -- ^ Per-file transformations that occur before the contents of a file are |
282 | -- spilled into the common pool. | ||
231 | } | 283 | } |
232 | 284 | ||
233 | 285 | ||
@@ -247,9 +299,11 @@ ispem :: FileType -> Bool | |||
247 | ispem (PEMFile {}) = True | 299 | ispem (PEMFile {}) = True |
248 | ispem _ = False | 300 | ispem _ = False |
249 | 301 | ||
250 | pwfile :: FileType -> Maybe PasswordFile | 302 | {- |
303 | pwfile :: FileType -> Maybe InputFile | ||
251 | pwfile (KeyRingFile f) = f | 304 | pwfile (KeyRingFile f) = f |
252 | pwfile _ = Nothing | 305 | pwfile _ = Nothing |
306 | -} | ||
253 | 307 | ||
254 | iswallet :: FileType -> Bool | 308 | iswallet :: FileType -> Bool |
255 | iswallet (WalletFile {}) = True | 309 | iswallet (WalletFile {}) = True |
@@ -261,11 +315,24 @@ usageFromFilter _ = mzero | |||
261 | 315 | ||
262 | data KeyRingRuntime = KeyRingRuntime | 316 | data KeyRingRuntime = KeyRingRuntime |
263 | { rtPubring :: FilePath | 317 | { rtPubring :: FilePath |
318 | -- ^ Path to the file represented by 'HomePub' | ||
264 | , rtSecring :: FilePath | 319 | , rtSecring :: FilePath |
320 | -- ^ Path to the file represented by 'HomeSec' | ||
265 | , rtGrip :: Maybe String | 321 | , rtGrip :: Maybe String |
322 | -- ^ Fingerprint or portion of a fingerprint used | ||
323 | -- to identify the working GnuPG identity used to | ||
324 | -- make signatures. | ||
266 | , rtWorkingKey :: Maybe Packet | 325 | , rtWorkingKey :: Maybe Packet |
326 | -- ^ The master key of the working GnuPG identity. | ||
267 | , rtKeyDB :: KeyDB | 327 | , rtKeyDB :: KeyDB |
268 | , rtRingAccess :: Map.Map FilePath Access | 328 | -- ^ The common information pool where files spilled |
329 | -- their content and from which they received new | ||
330 | -- content. | ||
331 | , rtRingAccess :: Map.Map InputFile Access | ||
332 | -- ^ The 'Access' values used for files of type | ||
333 | -- 'KeyRingFile'. If 'AutoAccess' was specified | ||
334 | -- for a file, this 'Map.Map' will indicate the | ||
335 | -- detected value that was used by the algorithm. | ||
269 | } | 336 | } |
270 | 337 | ||
271 | -- | TODO: Packet Update should have deletion action | 338 | -- | TODO: Packet Update should have deletion action |
@@ -273,9 +340,6 @@ data KeyRingRuntime = KeyRingRuntime | |||
273 | -- action. | 340 | -- action. |
274 | data PacketUpdate = InducerSignature String [SignatureSubpacket] | 341 | data PacketUpdate = InducerSignature String [SignatureSubpacket] |
275 | 342 | ||
276 | noManip :: KeyRingRuntime -> KeyData -> [PacketUpdate] | ||
277 | noManip _ _ = [] | ||
278 | |||
279 | -- | This type is used to indicate where to obtain passphrases. | 343 | -- | This type is used to indicate where to obtain passphrases. |
280 | data PassphraseSpec = PassphraseSpec | 344 | data PassphraseSpec = PassphraseSpec |
281 | { passSpecRingFile :: Maybe FilePath | 345 | { passSpecRingFile :: Maybe FilePath |
@@ -288,16 +352,31 @@ data PassphraseSpec = PassphraseSpec | |||
288 | -- ^ The passphrase will be read from this file or file descriptor. | 352 | -- ^ The passphrase will be read from this file or file descriptor. |
289 | } | 353 | } |
290 | 354 | ||
291 | data Transform = Autosign | 355 | data Transform = |
356 | Autosign | ||
357 | -- ^ This operation will make signatures for any tor-style UID | ||
358 | -- that matches a tor subkey and thus can be authenticated without | ||
359 | -- requring the judgement of a human user. | ||
360 | -- | ||
361 | -- A tor-style UID is one of the following form: | ||
362 | -- | ||
363 | -- > Anonymous <root@HOSTNAME.onion> | ||
292 | deriving (Eq,Ord) | 364 | deriving (Eq,Ord) |
293 | 365 | ||
366 | -- | This type describes an idempotent transformation (merge or import) on a | ||
367 | -- set of GnuPG keyrings and other key files. | ||
294 | data KeyRingOperation = KeyRingOperation | 368 | data KeyRingOperation = KeyRingOperation |
295 | { kFiles :: Map.Map InputFile StreamInfo | 369 | { opFiles :: Map.Map InputFile StreamInfo |
296 | , kPassphrases :: [PassphraseSpec] | 370 | -- ^ Indicates files to be read or updated. |
297 | , kTransform :: [Transform] | 371 | , opPassphrases :: [PassphraseSpec] |
298 | , kManip :: KeyRingRuntime -> KeyData -> [PacketUpdate]--[KeyRingAddress PacketUpdate] | 372 | -- ^ Indicates files or file descriptors where passphrases can be found. |
299 | -- ^ TODO: this is deprecated in favor of kTransform (remove it) | 373 | , opTransforms :: [Transform] |
300 | , homeSpec :: Maybe String | 374 | -- ^ Transformations to be performed on the key pool after all files have |
375 | -- been read and before any have been written. | ||
376 | , opHome :: Maybe FilePath | ||
377 | -- ^ If provided, this is the directory where the 'HomeSec' and 'HomePub' | ||
378 | -- files reside. Otherwise, the evironment variable $GNUPGHOME is consulted | ||
379 | -- and if that is not set, it falls back to $HOME/.gnupg. | ||
301 | } | 380 | } |
302 | 381 | ||
303 | resolveInputFile :: InputFileContext -> InputFile -> [FilePath] | 382 | resolveInputFile :: InputFileContext -> InputFile -> [FilePath] |
@@ -321,7 +400,7 @@ resolveForReport mctx f = concat $ resolveInputFile ctx f | |||
321 | filesToLock :: | 400 | filesToLock :: |
322 | KeyRingOperation -> InputFileContext -> [FilePath] | 401 | KeyRingOperation -> InputFileContext -> [FilePath] |
323 | filesToLock k ctx = do | 402 | filesToLock k ctx = do |
324 | (f,stream) <- Map.toList (kFiles k) | 403 | (f,stream) <- Map.toList (opFiles k) |
325 | case fill stream of | 404 | case fill stream of |
326 | KF_None -> [] | 405 | KF_None -> [] |
327 | _ -> resolveInputFile ctx f | 406 | _ -> resolveInputFile ctx f |
@@ -473,13 +552,14 @@ instance Applicative KikiCondition where | |||
473 | Left err -> err | 552 | Left err -> err |
474 | Left err -> err | 553 | Left err -> err |
475 | 554 | ||
476 | -- | This type is used to describe events triggered by a | 555 | -- | This type is used to describe events triggered by 'runKeyRing'. In |
477 | -- 'runKeyRing'. In addition to normal feedback | 556 | -- addition to normal feedback (e.g. 'NewPacket'), it also may indicate |
478 | -- (e.g. 'NewPacket'), it also may indicate non-fatal | 557 | -- non-fatal IO exceptions (e.g. 'FailedExternal'). Because a |
479 | -- IO exceptions (e.g. FailedExternal). Because a 'KeyRingOperation' | 558 | -- 'KeyRingOperation' may describe a very intricate multifaceted algorithm with |
480 | -- may describe a very intricate multifaceted algorithm with many | 559 | -- many inputs and outputs, an operation may be partially (or even mostly) |
481 | -- inputs and outputs, an operation may be partially (or even mostly) | 560 | -- successful even when I/O failures occured. In this situation, the files may |
482 | -- successful even when some aspect failed. | 561 | -- not have all the information they were intended to store, but they will be |
562 | -- in a valid format for GnuPG or kiki to operate on in the future. | ||
483 | data KikiReportAction = | 563 | data KikiReportAction = |
484 | NewPacket String | 564 | NewPacket String |
485 | | MissingPacket String | 565 | | MissingPacket String |
@@ -957,8 +1037,11 @@ writeStamped0 ctx inp stamp dowrite bs = do | |||
957 | dowrite (Right fname) bs | 1037 | dowrite (Right fname) bs |
958 | setFileTimes fname stamp stamp | 1038 | setFileTimes fname stamp stamp |
959 | 1039 | ||
1040 | {- This may be useful later. Commented for now, as it is not used. | ||
1041 | - | ||
960 | writeStampedL :: InputFileContext -> InputFile -> Posix.EpochTime -> L.ByteString -> IO () | 1042 | writeStampedL :: InputFileContext -> InputFile -> Posix.EpochTime -> L.ByteString -> IO () |
961 | writeStampedL ctx f stamp bs = writeStamped0 ctx f stamp (either L.hPut L.writeFile) bs | 1043 | writeStampedL ctx f stamp bs = writeStamped0 ctx f stamp (either L.hPut L.writeFile) bs |
1044 | -} | ||
962 | 1045 | ||
963 | writeStamped :: InputFileContext -> InputFile -> Posix.EpochTime -> String -> IO () | 1046 | writeStamped :: InputFileContext -> InputFile -> Posix.EpochTime -> String -> IO () |
964 | writeStamped ctx f stamp str = writeStamped0 ctx f stamp (either hPutStr writeFile) str | 1047 | writeStamped ctx f stamp str = writeStamped0 ctx f stamp (either hPutStr writeFile) str |
@@ -978,11 +1061,15 @@ getInputFileTime ctx (resolveInputFile ctx -> [fname]) = do | |||
978 | handleIO_ (error $ fname++": modificaiton time?") $ | 1061 | handleIO_ (error $ fname++": modificaiton time?") $ |
979 | modificationTime <$> getFileStatus fname | 1062 | modificationTime <$> getFileStatus fname |
980 | 1063 | ||
1064 | {- | ||
1065 | - This may be useful later. Commented for now as it is not used. | ||
1066 | - | ||
981 | doesInputFileExist :: InputFileContext -> InputFile -> IO Bool | 1067 | doesInputFileExist :: InputFileContext -> InputFile -> IO Bool |
982 | doesInputFileExist ctx f = do | 1068 | doesInputFileExist ctx f = do |
983 | case resolveInputFile ctx f of | 1069 | case resolveInputFile ctx f of |
984 | [n] -> doesFileExist n | 1070 | [n] -> doesFileExist n |
985 | _ -> return True | 1071 | _ -> return True |
1072 | -} | ||
986 | 1073 | ||
987 | 1074 | ||
988 | cachedContents :: InputFileContext -> InputFile -> IO (IO S.ByteString) | 1075 | cachedContents :: InputFileContext -> InputFile -> IO (IO S.ByteString) |
@@ -1029,7 +1116,7 @@ mergeHostFiles krd db ctx = do | |||
1029 | ishosts Hosts = True | 1116 | ishosts Hosts = True |
1030 | ishosts _ = False | 1117 | ishosts _ = False |
1031 | files istyp = do | 1118 | files istyp = do |
1032 | (f,stream) <- Map.toList (kFiles krd) | 1119 | (f,stream) <- Map.toList (opFiles krd) |
1033 | guard (istyp $ typ stream) | 1120 | guard (istyp $ typ stream) |
1034 | return f | 1121 | return f |
1035 | 1122 | ||
@@ -1086,7 +1173,7 @@ writeHostsFiles krd ctx (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do | |||
1086 | isMutableHosts (typ -> Hosts) = True | 1173 | isMutableHosts (typ -> Hosts) = True |
1087 | isMutableHosts _ = False | 1174 | isMutableHosts _ = False |
1088 | files istyp = do | 1175 | files istyp = do |
1089 | (f,stream) <- Map.toList (kFiles krd) | 1176 | (f,stream) <- Map.toList (opFiles krd) |
1090 | guard (istyp stream) | 1177 | guard (istyp stream) |
1091 | return f -- resolveInputFile ctx f | 1178 | return f -- resolveInputFile ctx f |
1092 | 1179 | ||
@@ -1119,7 +1206,7 @@ buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation | |||
1119 | Hosts.Hosts, | 1206 | Hosts.Hosts, |
1120 | [(SockAddr, (KeyKey, KeyKey))], | 1207 | [(SockAddr, (KeyKey, KeyKey))], |
1121 | [SockAddr]) | 1208 | [SockAddr]) |
1122 | ,Map.Map FilePath Access | 1209 | ,Map.Map InputFile Access |
1123 | ,MappedPacket -> IO (KikiCondition Packet) | 1210 | ,MappedPacket -> IO (KikiCondition Packet) |
1124 | ,Map.Map InputFile Message | 1211 | ,Map.Map InputFile Message |
1125 | ) | 1212 | ) |
@@ -1127,11 +1214,11 @@ buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation | |||
1127 | buildKeyDB ctx grip0 keyring = do | 1214 | buildKeyDB ctx grip0 keyring = do |
1128 | let | 1215 | let |
1129 | files isring = do | 1216 | files isring = do |
1130 | (f,stream) <- Map.toList (kFiles keyring) | 1217 | (f,stream) <- Map.toList (opFiles keyring) |
1131 | guard (isring $ typ stream) | 1218 | guard (isring $ typ stream) |
1132 | resolveInputFile ctx f | 1219 | resolveInputFile ctx f |
1133 | 1220 | ||
1134 | (ringMap,nonRingMap) = Map.partition (isring . typ) $ kFiles keyring | 1221 | ringMap = Map.filter (isring . typ) $ opFiles keyring |
1135 | 1222 | ||
1136 | readp f stream = fmap readp0 $ readPacketsFromFile ctx f | 1223 | readp f stream = fmap readp0 $ readPacketsFromFile ctx f |
1137 | where | 1224 | where |
@@ -1147,7 +1234,7 @@ buildKeyDB ctx grip0 keyring = do | |||
1147 | readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n)) | 1234 | readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n)) |
1148 | 1235 | ||
1149 | -- KeyRings (todo: KikiCondition reporting?) | 1236 | -- KeyRings (todo: KikiCondition reporting?) |
1150 | (db_rings,mwk,grip,accs,keys,unspilled) <- do | 1237 | (spilled,mwk,grip,accs,keys,unspilled) <- do |
1151 | ringPackets <- Map.traverseWithKey readp ringMap | 1238 | ringPackets <- Map.traverseWithKey readp ringMap |
1152 | let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message) | 1239 | let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message) |
1153 | 1240 | ||
@@ -1157,8 +1244,6 @@ buildKeyDB ctx grip0 keyring = do | |||
1157 | (_,Message ps) <- Map.lookup HomeSec ringPackets | 1244 | (_,Message ps) <- Map.lookup HomeSec ringPackets |
1158 | listToMaybe ps | 1245 | listToMaybe ps |
1159 | (spilled,unspilled) = Map.partition (spillable . fst) ringPackets | 1246 | (spilled,unspilled) = Map.partition (spillable . fst) ringPackets |
1160 | db_rings = Map.foldlWithKey mergeIt Map.empty spilled | ||
1161 | where mergeIt db f (_,ps) = merge db f ps | ||
1162 | keys :: Map.Map KeyKey MappedPacket | 1247 | keys :: Map.Map KeyKey MappedPacket |
1163 | keys = Map.foldl slurpkeys Map.empty | 1248 | keys = Map.foldl slurpkeys Map.empty |
1164 | $ Map.mapWithKey filterSecrets ringPackets | 1249 | $ Map.mapWithKey filterSecrets ringPackets |
@@ -1175,13 +1260,33 @@ buildKeyDB ctx grip0 keyring = do | |||
1175 | let matchfp mp = not (is_subkey p) && matchpr fp p == fp | 1260 | let matchfp mp = not (is_subkey p) && matchpr fp p == fp |
1176 | where p = packet mp | 1261 | where p = packet mp |
1177 | Map.elems $ Map.filter matchfp keys | 1262 | Map.elems $ Map.filter matchfp keys |
1178 | accs = Map.mapKeys (concat . resolveInputFile ctx) | 1263 | accs = fmap (access . fst) ringPackets |
1179 | $ fmap (access . fst) ringPackets | 1264 | return (spilled,wk,grip,accs,keys,fmap snd unspilled) |
1180 | return (db_rings,wk,grip,accs,keys,fmap snd unspilled) | ||
1181 | 1265 | ||
1182 | doDecrypt <- makeMemoizingDecrypter keyring ctx keys | 1266 | doDecrypt <- makeMemoizingDecrypter keyring ctx keys |
1183 | 1267 | ||
1184 | let wk = fmap packet mwk | 1268 | let wk = fmap packet mwk |
1269 | rt0 = KeyRingRuntime { rtPubring = homepubPath ctx | ||
1270 | , rtSecring = homesecPath ctx | ||
1271 | , rtGrip = grip | ||
1272 | , rtWorkingKey = wk | ||
1273 | , rtRingAccess = accs | ||
1274 | , rtKeyDB = Map.empty | ||
1275 | } | ||
1276 | transformed0 <- | ||
1277 | let trans f (info,ps) = do | ||
1278 | let manip = combineTransforms (transforms info) | ||
1279 | rt1 = rt0 { rtKeyDB = merge Map.empty f ps } | ||
1280 | acc = Just Sec /= Map.lookup f accs | ||
1281 | r <- performManipulations doDecrypt rt1 mwk manip | ||
1282 | try r $ \(rt2,report) -> do | ||
1283 | return $ KikiSuccess (report,(info,flattenKeys acc $ rtKeyDB rt2)) | ||
1284 | in fmap sequenceA $ Map.traverseWithKey trans spilled | ||
1285 | try transformed0 $ \transformed -> do | ||
1286 | let db_rings = Map.foldlWithKey' mergeIt Map.empty transformed | ||
1287 | where | ||
1288 | mergeIt db f (_,(info,ps)) = merge db f ps | ||
1289 | reportTrans = concat $ Map.elems $ fmap fst transformed | ||
1185 | 1290 | ||
1186 | -- Wallets | 1291 | -- Wallets |
1187 | let importWalletKey wk db' (top,fname,sub,tag) = do | 1292 | let importWalletKey wk db' (top,fname,sub,tag) = do |
@@ -1207,7 +1312,7 @@ buildKeyDB ctx grip0 keyring = do | |||
1207 | 1312 | ||
1208 | -- PEM files | 1313 | -- PEM files |
1209 | let pems = do | 1314 | let pems = do |
1210 | (n,stream) <- Map.toList $ kFiles keyring | 1315 | (n,stream) <- Map.toList $ opFiles keyring |
1211 | grip <- maybeToList grip | 1316 | grip <- maybeToList grip |
1212 | n <- resolveInputFile ctx n | 1317 | n <- resolveInputFile ctx n |
1213 | guard $ spillable stream && ispem (typ stream) | 1318 | guard $ spillable stream && ispem (typ stream) |
@@ -1227,7 +1332,7 @@ buildKeyDB ctx grip0 keyring = do | |||
1227 | try r $ \((db,hs),reportHosts) -> do | 1332 | try r $ \((db,hs),reportHosts) -> do |
1228 | 1333 | ||
1229 | return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled) | 1334 | return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled) |
1230 | , reportWallets ++ reportPEMs ) | 1335 | , reportTrans ++ reportWallets ++ reportPEMs ++ reportHosts ) |
1231 | 1336 | ||
1232 | torhash :: Packet -> String | 1337 | torhash :: Packet -> String |
1233 | torhash key = fromMaybe "" $ derToBase32 <$> derRSA key | 1338 | torhash key = fromMaybe "" $ derToBase32 <$> derRSA key |
@@ -1448,7 +1553,7 @@ writeWalletKeys krd db wk = do | |||
1448 | isMutableWallet (typ -> WalletFile {}) = True | 1553 | isMutableWallet (typ -> WalletFile {}) = True |
1449 | isMutableWallet _ = False | 1554 | isMutableWallet _ = False |
1450 | files pred = do | 1555 | files pred = do |
1451 | (f,stream) <- Map.toList (kFiles krd) | 1556 | (f,stream) <- Map.toList (opFiles krd) |
1452 | guard (pred stream) | 1557 | guard (pred stream) |
1453 | resolveInputFile (InputFileContext "" "") f | 1558 | resolveInputFile (InputFileContext "" "") f |
1454 | let writeWallet report n = do | 1559 | let writeWallet report n = do |
@@ -1494,10 +1599,6 @@ importPublic = Just True | |||
1494 | importSecret :: Maybe Bool | 1599 | importSecret :: Maybe Bool |
1495 | importSecret = Just False | 1600 | importSecret = Just False |
1496 | 1601 | ||
1497 | -- | returns Nothing to indicate that no new master | ||
1498 | -- keys will be imported. | ||
1499 | subkeysOnly :: Maybe Bool | ||
1500 | subkeysOnly = Nothing | ||
1501 | 1602 | ||
1502 | -- TODO: Do we need to memoize this? | 1603 | -- TODO: Do we need to memoize this? |
1503 | guardAuthentic :: KeyRingRuntime -> KeyData -> Maybe () | 1604 | guardAuthentic :: KeyRingRuntime -> KeyData -> Maybe () |
@@ -1536,7 +1637,7 @@ writeRingKeys krd rt {- db wk secring pubring -} unspilled = do | |||
1536 | ctx = InputFileContext secring pubring | 1637 | ctx = InputFileContext secring pubring |
1537 | let s = do | 1638 | let s = do |
1538 | (f,f0,stream) <- do | 1639 | (f,f0,stream) <- do |
1539 | (f0,stream) <- Map.toList (kFiles krd) | 1640 | (f0,stream) <- Map.toList (opFiles krd) |
1540 | guard (isring $ typ stream) | 1641 | guard (isring $ typ stream) |
1541 | f <- resolveInputFile ctx f0 | 1642 | f <- resolveInputFile ctx f0 |
1542 | return (f,f0,stream) | 1643 | return (f,f0,stream) |
@@ -1564,7 +1665,7 @@ writeRingKeys krd rt {- db wk secring pubring -} unspilled = do | |||
1564 | importByExistingMaster kd@(KeyData p _ _ _) = | 1665 | importByExistingMaster kd@(KeyData p _ _ _) = |
1565 | fmap originallyPublic $ Map.lookup f $ locations p | 1666 | fmap originallyPublic $ Map.lookup f $ locations p |
1566 | d <- sortByHint f keyMappedPacket (Map.elems db') | 1667 | d <- sortByHint f keyMappedPacket (Map.elems db') |
1567 | acc <- maybeToList $ Map.lookup f (rtRingAccess rt) | 1668 | acc <- maybeToList $ Map.lookup f0 (rtRingAccess rt) |
1568 | only_public <- maybeToList $ wantedForFill acc (fill stream) d | 1669 | only_public <- maybeToList $ wantedForFill acc (fill stream) d |
1569 | case fill stream of | 1670 | case fill stream of |
1570 | KF_Match usage -> do grip <- maybeToList $ rtGrip rt | 1671 | KF_Match usage -> do grip <- maybeToList $ rtGrip rt |
@@ -1708,24 +1809,26 @@ makeMemoizingDecrypter operation ctx keys = do | |||
1708 | -- TODO: Perhaps these should both be of type InputFile rather than | 1809 | -- TODO: Perhaps these should both be of type InputFile rather than |
1709 | -- FilePath? | 1810 | -- FilePath? |
1710 | -- pws :: Map.Map FilePath (IO S.ByteString) | 1811 | -- pws :: Map.Map FilePath (IO S.ByteString) |
1812 | {- | ||
1711 | pws <- | 1813 | pws <- |
1712 | Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ) | 1814 | Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ) |
1713 | (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above | 1815 | (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above |
1714 | $ Map.filter (isJust . pwfile . typ) $ kFiles operation) | 1816 | $ Map.filter (isJust . pwfile . typ) $ opFiles operation) |
1817 | -} | ||
1715 | pws2 <- | 1818 | pws2 <- |
1716 | Traversable.mapM (cachedContents ctx) | 1819 | Traversable.mapM (cachedContents ctx) |
1717 | $ Map.fromList $ mapMaybe | 1820 | $ Map.fromList $ mapMaybe |
1718 | (\spec -> (,passSpecPassFile spec) `fmap` do | 1821 | (\spec -> (,passSpecPassFile spec) `fmap` do |
1719 | guard $ isNothing $ passSpecKeySpec spec | 1822 | guard $ isNothing $ passSpecKeySpec spec |
1720 | passSpecRingFile spec) | 1823 | passSpecRingFile spec) |
1721 | (kPassphrases operation) | 1824 | (opPassphrases operation) |
1722 | defpw <- do | 1825 | defpw <- do |
1723 | Traversable.mapM (cachedContents ctx . passSpecPassFile) | 1826 | Traversable.mapM (cachedContents ctx . passSpecPassFile) |
1724 | $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp) | 1827 | $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp) |
1725 | && isNothing (passSpecKeySpec sp)) | 1828 | && isNothing (passSpecKeySpec sp)) |
1726 | $ kPassphrases operation | 1829 | $ opPassphrases operation |
1727 | unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet) | 1830 | unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet) |
1728 | return $ doDecrypt unkeysRef (pws `Map.union` pws2) defpw | 1831 | return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw |
1729 | where | 1832 | where |
1730 | doDecrypt :: IORef (Map.Map KeyKey Packet) | 1833 | doDecrypt :: IORef (Map.Map KeyKey Packet) |
1731 | -> Map.Map FilePath (IO S.ByteString) | 1834 | -> Map.Map FilePath (IO S.ByteString) |
@@ -1764,12 +1867,11 @@ makeMemoizingDecrypter operation ctx keys = do | |||
1764 | 1867 | ||
1765 | performManipulations :: | 1868 | performManipulations :: |
1766 | (MappedPacket -> IO (KikiCondition Packet)) | 1869 | (MappedPacket -> IO (KikiCondition Packet)) |
1767 | -> KeyRingOperation | ||
1768 | -> KeyRingRuntime | 1870 | -> KeyRingRuntime |
1769 | -> Maybe MappedPacket | 1871 | -> Maybe MappedPacket |
1770 | -> (KeyRingRuntime -> KeyData -> [PacketUpdate]) | 1872 | -> (KeyRingRuntime -> KeyData -> [PacketUpdate]) |
1771 | -> IO (KikiCondition (KeyRingRuntime,[(FilePath,KikiReportAction)])) | 1873 | -> IO (KikiCondition (KeyRingRuntime,[(FilePath,KikiReportAction)])) |
1772 | performManipulations doDecrypt operation rt wk manip = do | 1874 | performManipulations doDecrypt rt wk manip = do |
1773 | let db = rtKeyDB rt | 1875 | let db = rtKeyDB rt |
1774 | performAll kd = foldM perform (KikiSuccess kd) $ manip rt kd | 1876 | performAll kd = foldM perform (KikiSuccess kd) $ manip rt kd |
1775 | r <- Traversable.mapM performAll db | 1877 | r <- Traversable.mapM performAll db |
@@ -1830,7 +1932,7 @@ initializeMissingPEMFiles :: | |||
1830 | initializeMissingPEMFiles operation ctx grip decrypt db = do | 1932 | initializeMissingPEMFiles operation ctx grip decrypt db = do |
1831 | nonexistents <- | 1933 | nonexistents <- |
1832 | filterM (fmap not . doesFileExist . fst) | 1934 | filterM (fmap not . doesFileExist . fst) |
1833 | $ do (f,t) <- Map.toList (kFiles operation) | 1935 | $ do (f,t) <- Map.toList (opFiles operation) |
1834 | f <- resolveInputFile ctx f | 1936 | f <- resolveInputFile ctx f |
1835 | return (f,t) | 1937 | return (f,t) |
1836 | 1938 | ||
@@ -1892,12 +1994,12 @@ interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo" | |||
1892 | interpretManip kd manip = return kd | 1994 | interpretManip kd manip = return kd |
1893 | -} | 1995 | -} |
1894 | 1996 | ||
1895 | combineTransforms :: KeyRingOperation -> KeyRingRuntime -> KeyData -> [PacketUpdate] | 1997 | combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate] |
1896 | combineTransforms operation rt kd = updates | 1998 | combineTransforms trans rt kd = updates |
1897 | where | 1999 | where |
1898 | updates = kManip operation rt kd | 2000 | updates = -- kManip operation rt kd ++ |
1899 | ++ concatMap (\t -> resolveTransform t rt kd) sanitized | 2001 | concatMap (\t -> resolveTransform t rt kd) sanitized |
1900 | sanitized = group (sort (kTransform operation)) >>= take 1 | 2002 | sanitized = group (sort trans) >>= take 1 |
1901 | 2003 | ||
1902 | isSubkeySignature (SubkeySignature {}) = True | 2004 | isSubkeySignature (SubkeySignature {}) = True |
1903 | isSubkeySignature _ = False | 2005 | isSubkeySignature _ = False |
@@ -2024,9 +2126,10 @@ resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops | |||
2024 | gs = groupBy sameMaster (sortBy (comparing code) bindings') | 2126 | gs = groupBy sameMaster (sortBy (comparing code) bindings') |
2025 | 2127 | ||
2026 | 2128 | ||
2129 | -- | Load and update key files according to the specified 'KeyRingOperation'. | ||
2027 | runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime) | 2130 | runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime) |
2028 | runKeyRing operation = do | 2131 | runKeyRing operation = do |
2029 | homedir <- getHomeDir (homeSpec operation) | 2132 | homedir <- getHomeDir (opHome operation) |
2030 | let try' :: KikiCondition a -> (a -> IO (KikiResult b)) -> IO (KikiResult b) | 2133 | let try' :: KikiCondition a -> (a -> IO (KikiResult b)) -> IO (KikiResult b) |
2031 | -- FIXME: try' should probably accept a list of KikiReportActions. | 2134 | -- FIXME: try' should probably accept a list of KikiReportActions. |
2032 | -- This would be useful for reporting on disk writes that have already | 2135 | -- This would be useful for reporting on disk writes that have already |
@@ -2074,10 +2177,9 @@ runKeyRing operation = do | |||
2074 | } | 2177 | } |
2075 | 2178 | ||
2076 | r <- performManipulations decrypt | 2179 | r <- performManipulations decrypt |
2077 | operation | ||
2078 | rt | 2180 | rt |
2079 | wk | 2181 | wk |
2080 | (combineTransforms operation) | 2182 | (combineTransforms $ opTransforms operation) |
2081 | try' r $ \(rt,report_manips) -> do | 2183 | try' r $ \(rt,report_manips) -> do |
2082 | 2184 | ||
2083 | r <- writeWalletKeys operation (rtKeyDB rt) (fmap packet wk) | 2185 | r <- writeWalletKeys operation (rtKeyDB rt) (fmap packet wk) |
@@ -2485,10 +2587,8 @@ type SigAndTrust = ( MappedPacket | |||
2485 | type KeyKey = [ByteString] | 2587 | type KeyKey = [ByteString] |
2486 | data SubKey = SubKey MappedPacket [SigAndTrust] | 2588 | data SubKey = SubKey MappedPacket [SigAndTrust] |
2487 | 2589 | ||
2488 | -- | This is a GPG Identity. It's poorly named | 2590 | -- | This is a GPG Identity which includes a master key and all its UIDs and |
2489 | -- but we are keeping the name around until | 2591 | -- subkeys and associated signatures. |
2490 | -- we're sure we wont be cutting and pasting | ||
2491 | -- code with master any more. | ||
2492 | data KeyData = KeyData { keyMappedPacket :: MappedPacket -- main key | 2592 | data KeyData = KeyData { keyMappedPacket :: MappedPacket -- main key |
2493 | , keySigAndTrusts :: [SigAndTrust] -- sigs on main key | 2593 | , keySigAndTrusts :: [SigAndTrust] -- sigs on main key |
2494 | , keyUids :: (Map.Map String ([SigAndTrust],OriginMap)) -- uids | 2594 | , keyUids :: (Map.Map String ([SigAndTrust],OriginMap)) -- uids |