diff options
-rw-r--r-- | KeyRing.hs | 284 | ||||
-rw-r--r-- | kiki.hs | 225 |
2 files changed, 365 insertions, 144 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 |
@@ -32,7 +32,6 @@ import qualified Data.ByteString as S | |||
32 | import qualified Data.ByteString.Lazy as L | 32 | import qualified Data.ByteString.Lazy as L |
33 | import qualified Data.ByteString.Lazy.Char8 as Char8 | 33 | import qualified Data.ByteString.Lazy.Char8 as Char8 |
34 | import qualified Data.Map as Map | 34 | import qualified Data.Map as Map |
35 | import qualified Data.Text as T | ||
36 | import Control.Arrow (first,second) | 35 | import Control.Arrow (first,second) |
37 | import Data.Binary.Get (runGet) | 36 | import Data.Binary.Get (runGet) |
38 | import Data.Binary.Put (putWord32be,runPut,putByteString) | 37 | import Data.Binary.Put (putWord32be,runPut,putByteString) |
@@ -598,37 +597,6 @@ kiki_usage bSecret cmd = putStr $ | |||
598 | ," 5E24CD442AA6965D2012E62A905C24185D5379C2" | 597 | ," 5E24CD442AA6965D2012E62A905C24185D5379C2" |
599 | ] | 598 | ] |
600 | 599 | ||
601 | doAutosign rt kd@(KeyData k ksigs umap submap) = ops | ||
602 | where | ||
603 | ops = map (\u -> InducerSignature u []) us | ||
604 | us = filter torStyle $ Map.keys umap | ||
605 | torStyle str = and [ uid_topdomain parsed == "onion" | ||
606 | , uid_realname parsed `elem` ["","Anonymous"] | ||
607 | , uid_user parsed == "root" | ||
608 | , fmap (match . fst) (lookup (packet k) torbindings) | ||
609 | == Just True ] | ||
610 | where parsed = parseUID str | ||
611 | match = (==subdom) . take (fromIntegral len) | ||
612 | subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)] | ||
613 | subdom = Char8.unpack subdom0 | ||
614 | len = T.length (uid_subdomain parsed) | ||
615 | torbindings = getTorKeys (map packet $ flattenTop "" True kd) | ||
616 | getTorKeys pub = do | ||
617 | xs <- groupBindings pub | ||
618 | (_,(top,sub),us,_,_) <- xs | ||
619 | guard ("tor" `elem` us) | ||
620 | let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub | ||
621 | return (top,(torhash,sub)) | ||
622 | |||
623 | groupBindings pub = gs | ||
624 | where (_,bindings) = getBindings pub | ||
625 | bindings' = accBindings bindings | ||
626 | code (c,(m,s),_,_,_) = (fingerprint_material m,-c) | ||
627 | ownerkey (_,(a,_),_,_,_) = a | ||
628 | sameMaster (ownerkey->a) (ownerkey->b) | ||
629 | = fingerprint_material a==fingerprint_material b | ||
630 | gs = groupBy sameMaster (sortBy (comparing code) bindings') | ||
631 | |||
632 | processArgs sargspec polyVariadicArgs defaultPoly args_raw = (sargs,margs) | 600 | processArgs sargspec polyVariadicArgs defaultPoly args_raw = (sargs,margs) |
633 | where | 601 | where |
634 | (args,trail1) = break (=="--") args_raw | 602 | (args,trail1) = break (=="--") args_raw |
@@ -725,7 +693,9 @@ sync bExport bImport bSecret cmdarg args_raw = do | |||
725 | , spill = KF_Match usage | 693 | , spill = KF_Match usage |
726 | , typ = PEMFile | 694 | , typ = PEMFile |
727 | , access = Sec | 695 | , access = Sec |
728 | , initializer = cmd' }) | 696 | , initializer = cmd' |
697 | , transforms = [] | ||
698 | } ) | ||
729 | else if isNothing cmd' | 699 | else if isNothing cmd' |
730 | then ( ArgFile path | 700 | then ( ArgFile path |
731 | , (buildStreamInfo KF_None PEMFile) | 701 | , (buildStreamInfo KF_None PEMFile) |
@@ -735,18 +705,10 @@ sync bExport bImport bSecret cmdarg args_raw = do | |||
735 | , (buildStreamInfo reftyp WalletFile) { access = Sec })) | 705 | , (buildStreamInfo reftyp WalletFile) { access = Sec })) |
736 | wallets | 706 | wallets |
737 | rings = map (\fname -> ( ArgFile fname | 707 | rings = map (\fname -> ( ArgFile fname |
738 | , buildStreamInfo reftyp $ KeyRingFile passfd)) | 708 | , buildStreamInfo reftyp KeyRingFile )) |
739 | keyrings_ | 709 | keyrings_ |
740 | hosts = maybe [] (map decorate) $ Map.lookup "--hosts" margs | 710 | hosts = maybe [] (map decorate) $ Map.lookup "--hosts" margs |
741 | where decorate fname = (ArgFile fname, buildStreamInfo reftyp Hosts) | 711 | where decorate fname = (ArgFile fname, buildStreamInfo reftyp Hosts) |
742 | importStyle = maybe (\_ _ -> subkeysOnly) | ||
743 | (\f rt kd -> f rt kd >> importPublic) | ||
744 | $ mplus import_f importifauth_f | ||
745 | where | ||
746 | import_f = do Map.lookup "--import" margs | ||
747 | return $ \rt kd -> Just () | ||
748 | importifauth_f = do Map.lookup "--import-if-authentic" margs | ||
749 | return guardAuthentic | ||
750 | pubfill = maybe KF_Subkeys id | 712 | pubfill = maybe KF_Subkeys id |
751 | $ mplus import_f importifauth_f | 713 | $ mplus import_f importifauth_f |
752 | where | 714 | where |
@@ -758,22 +720,25 @@ sync bExport bImport bSecret cmdarg args_raw = do | |||
758 | , fill = rtyp | 720 | , fill = rtyp |
759 | , spill = KF_All | 721 | , spill = KF_All |
760 | , access = AutoAccess | 722 | , access = AutoAccess |
761 | , initializer = Nothing } | 723 | , initializer = Nothing |
724 | , transforms = [] } | ||
762 | kikiOp = KeyRingOperation | 725 | kikiOp = KeyRingOperation |
763 | { kFiles = Map.fromList $ | 726 | { opFiles = Map.fromList $ |
764 | [ ( HomeSec, buildStreamInfo (if bSecret && bImport then KF_All | 727 | [ ( HomeSec, buildStreamInfo (if bSecret && bImport then KF_All |
765 | else KF_None) | 728 | else KF_None) |
766 | (KeyRingFile passfd) ) | 729 | KeyRingFile ) |
767 | , ( HomePub, buildStreamInfo (if bImport then pubfill | 730 | , ( HomePub, buildStreamInfo (if bImport then pubfill |
768 | else KF_None) | 731 | else KF_None) |
769 | (KeyRingFile Nothing) ) | 732 | KeyRingFile ) |
770 | ] | 733 | ] |
771 | ++ rings | 734 | ++ rings |
772 | ++ if bSecret then pems else [] | 735 | ++ if bSecret then pems else [] |
773 | ++ if bSecret then walts else [] | 736 | ++ if bSecret then walts else [] |
774 | ++ hosts | 737 | ++ hosts |
775 | , kManip = maybe noManip (const doAutosign) $ Map.lookup "--autosign" margs | 738 | , opPassphrases = do pfile <- maybeToList passfd |
776 | , homeSpec = homespec | 739 | return $ PassphraseSpec Nothing Nothing pfile |
740 | , opTransforms = maybe [] (const [Autosign]) $ Map.lookup "--autosign" margs | ||
741 | , opHome = homespec | ||
777 | } | 742 | } |
778 | 743 | ||
779 | (\f -> maybe f (const $ kiki_usage bSecret cmdarg) $ Map.lookup "--help" margs) $ do | 744 | (\f -> maybe f (const $ kiki_usage bSecret cmdarg) $ Map.lookup "--help" margs) $ do |
@@ -860,13 +825,14 @@ kiki "show" args = do | |||
860 | hosts = [] | 825 | hosts = [] |
861 | walts = [] | 826 | walts = [] |
862 | streaminfo = StreamInfo { fill = KF_None | 827 | streaminfo = StreamInfo { fill = KF_None |
863 | , typ = KeyRingFile passfd | 828 | , typ = KeyRingFile |
864 | , spill = KF_All | 829 | , spill = KF_All |
865 | , initializer = Nothing | 830 | , initializer = Nothing |
866 | , access = AutoAccess | 831 | , access = AutoAccess |
832 | , transforms = [] | ||
867 | } | 833 | } |
868 | kikiOp = KeyRingOperation | 834 | kikiOp = KeyRingOperation |
869 | { kFiles = Map.fromList $ | 835 | { opFiles = Map.fromList $ |
870 | [ ( HomeSec, streaminfo { access = Sec }) | 836 | [ ( HomeSec, streaminfo { access = Sec }) |
871 | , ( HomePub, streaminfo { access = Pub }) | 837 | , ( HomePub, streaminfo { access = Pub }) |
872 | ] | 838 | ] |
@@ -874,8 +840,10 @@ kiki "show" args = do | |||
874 | ++ pems | 840 | ++ pems |
875 | ++ walts | 841 | ++ walts |
876 | ++ hosts | 842 | ++ hosts |
877 | , kManip = noManip | 843 | , opPassphrases = do pfile <- maybeToList passfd |
878 | , homeSpec = homespec | 844 | return $ PassphraseSpec Nothing Nothing pfile |
845 | , opTransforms = [] | ||
846 | , opHome = homespec | ||
879 | } | 847 | } |
880 | 848 | ||
881 | (\f -> maybe f (const $ kiki_usage False "show") $ Map.lookup "--help" margs) $ do | 849 | (\f -> maybe f (const $ kiki_usage False "show") $ Map.lookup "--help" margs) $ do |
@@ -904,6 +872,158 @@ kiki "show" args = do | |||
904 | forM_ report $ \(fname,act) -> do | 872 | forM_ report $ \(fname,act) -> do |
905 | putStrLn $ fname ++ ": " ++ reportString act | 873 | putStrLn $ fname ++ ": " ++ reportString act |
906 | 874 | ||
875 | kiki "merge" [] = do | ||
876 | putStr . unlines $ | ||
877 | [ "kiki merge [ --passphrase-fd=FD ... ]" | ||
878 | , " ( --home[=HOMEDIR]" | ||
879 | , " | --type=(keyring|pem|wallet|hosts)" | ||
880 | , " | --access=[auto|secret|public]" | ||
881 | , " | --flow=(fill|spill|sync)[,(subkeys|match=SPEC)]" | ||
882 | , " | --create=CMD" | ||
883 | , " | --autosign[=no]" | ||
884 | , " | --" | ||
885 | , " | FILE ) ..."] | ||
886 | kiki "merge" args | "--help" `elem` args = do | ||
887 | kiki "merge" [] | ||
888 | -- TODO: more help | ||
889 | kiki "merge" args = do | ||
890 | KikiResult rt report <- runKeyRing op | ||
891 | case rt of | ||
892 | KikiSuccess rt -> return () | ||
893 | err -> putStrLn $ errorString err | ||
894 | forM_ report $ \(fname,act) -> do | ||
895 | putStrLn $ fname ++ ": " ++ reportString act | ||
896 | where | ||
897 | (_,(_,op)) = foldl' buildOp (True,(flow,noop)) args | ||
898 | noop = KeyRingOperation | ||
899 | { opFiles = Map.empty | ||
900 | , opTransforms = [] | ||
901 | , opHome = Nothing | ||
902 | , opPassphrases = [] | ||
903 | } | ||
904 | flow = StreamInfo | ||
905 | { access = AutoAccess | ||
906 | , typ = KeyRingFile | ||
907 | , spill = KF_None | ||
908 | , fill = KF_None | ||
909 | , initializer = Nothing | ||
910 | , transforms = [] | ||
911 | } | ||
912 | updateFlow fil spil mtch flow = spill' $ fill' $ flow | ||
913 | where | ||
914 | fill' flow = flow { fill = if fil then val else KF_None } | ||
915 | spill' flow = flow { spill = if spil then val else KF_None } | ||
916 | val = either (\subkeys -> if subkeys then KF_Subkeys else KF_All) | ||
917 | KF_Match | ||
918 | mtch | ||
919 | parseFlow spec = | ||
920 | if null bads | ||
921 | then Just ( ( "spill" `elem` goods | ||
922 | || "sync" `elem` goods | ||
923 | , "fill" `elem` goods | ||
924 | || "sync" `elem` goods ) | ||
925 | , maybe (Left $ "subkeys" `elem` goods) | ||
926 | Right | ||
927 | match ) | ||
928 | else Nothing | ||
929 | where | ||
930 | ws = case groupBy (\_ c->c/=',') spec of | ||
931 | w:xs -> w:map (drop 1) xs | ||
932 | [] -> [] | ||
933 | (goods,bads) = partition acceptable ws | ||
934 | acceptable "spill" = True | ||
935 | acceptable "fill" = True | ||
936 | acceptable "sync" = True | ||
937 | acceptable "subkeys" = True | ||
938 | acceptable s | "match=" `isPrefixOf` s = True | ||
939 | acceptable _ = False | ||
940 | match = listToMaybe $ do | ||
941 | m <- filter ("match=" `isPrefixOf`) goods | ||
942 | return $ drop 6 m | ||
943 | |||
944 | doFile :: StreamInfo -> KeyRingOperation -> FilePath -> (StreamInfo,KeyRingOperation) | ||
945 | doFile flow op fname = | ||
946 | ( flow | ||
947 | , op { opFiles= Map.insert (ArgFile fname) flow (opFiles op) }) | ||
948 | |||
949 | doAutosign :: Bool -> StreamInfo -> KeyRingOperation -> (StreamInfo,KeyRingOperation) | ||
950 | doAutosign True flow op = | ||
951 | if Map.null (opFiles op) | ||
952 | then (flow, op { opTransforms = opTransforms op ++ [Autosign] }) | ||
953 | else (flow { transforms = transforms flow ++ [Autosign] }, op) | ||
954 | doAutosign False flow op = | ||
955 | ( flow { transforms = filter (/=Autosign) (transforms flow) } | ||
956 | , op { opTransforms = filter (/=Autosign) (opTransforms op) } ) | ||
957 | |||
958 | doPassphrase :: StreamInfo -> KeyRingOperation -> String -> (StreamInfo,KeyRingOperation) | ||
959 | doPassphrase flow op pass = | ||
960 | if Map.null (opFiles op) | ||
961 | then ( flow | ||
962 | , op { opPassphrases = PassphraseSpec Nothing Nothing pfd | ||
963 | : opPassphrases op } ) | ||
964 | else error "passphrase-fd must come before any file arguments or --home" | ||
965 | where | ||
966 | pfd = FileDesc (read pass) | ||
967 | |||
968 | buildOp (False,(flow,op)) fname = (False,doFile flow op fname) | ||
969 | buildOp (True,(flow,op)) arg@(splitArg->parsed) = | ||
970 | case parsed of | ||
971 | Left ("",Nothing) -> (False,(flow,op)) | ||
972 | _ -> (True,) dispatch | ||
973 | where | ||
974 | dispatch = | ||
975 | case parsed of | ||
976 | Right fname -> doFile flow op fname | ||
977 | Left ("autosign",Nothing) -> doAutosign True flow op | ||
978 | Left ("autosign",Just "y") -> doAutosign True flow op | ||
979 | Left ("autosign",Just "yes") -> doAutosign True flow op | ||
980 | Left ("autosign",Just "true") -> doAutosign True flow op | ||
981 | Left ("autosign",Just "n") -> doAutosign False flow op | ||
982 | Left ("autosign",Just "no") -> doAutosign False flow op | ||
983 | Left ("autosign",Just "false")-> doAutosign False flow op | ||
984 | Left ("passphrase-fd",Just pass) -> doPassphrase flow op pass | ||
985 | Left ("create",Just cmd) -> | ||
986 | ( flow { initializer = if null cmd then Nothing else Just cmd } | ||
987 | , op ) | ||
988 | Left ("type",Just "keyring") -> ( flow { typ = KeyRingFile }, op ) | ||
989 | Left ("type",Just "pem" ) -> ( flow { typ = PEMFile }, op ) | ||
990 | Left ("type",Just "wallet" ) -> ( flow { typ = WalletFile }, op ) | ||
991 | Left ("type",Just "hosts" ) -> ( flow { typ = Hosts }, op ) | ||
992 | Left ("access",Just "public") -> ( flow { access = Pub }, op ) | ||
993 | Left ("access",Just "secret") -> ( flow { access = Sec }, op ) | ||
994 | Left ("access",Just "auto") -> ( flow { access = AutoAccess }, op ) | ||
995 | Left ("home",mb) -> | ||
996 | ( flow | ||
997 | , op { opFiles = Map.insert HomePub flow { typ=KeyRingFile | ||
998 | , access=Pub } | ||
999 | $ Map.insert HomeSec flow { typ=KeyRingFile | ||
1000 | , access=Sec } | ||
1001 | $ opFiles op | ||
1002 | , opHome = opHome op `mplus` mb | ||
1003 | } | ||
1004 | ) | ||
1005 | Left ("flow",Just flowspec) -> | ||
1006 | case parseFlow flowspec of | ||
1007 | Just ( (fil,spil), mtch ) -> | ||
1008 | ( updateFlow fil spil mtch flow | ||
1009 | , op ) | ||
1010 | Nothing -> error "Valid flow words are: spill,fill,sync,subkeys or match=KEYSPEC" | ||
1011 | Left (option,_) -> error $ "Unrecognized option: " ++ option | ||
1012 | |||
1013 | splitArg :: String -> Either (String,Maybe String) String | ||
1014 | splitArg arg = | ||
1015 | case hyphens of | ||
1016 | "" -> Right name | ||
1017 | "-" -> error $ "Unrecognized option: " ++ arg | ||
1018 | _ -> Left $ parseLongOption name | ||
1019 | where | ||
1020 | (hyphens, name) = span (=='-') arg | ||
1021 | parseLongOption name = (key,val v) | ||
1022 | where | ||
1023 | (key,v) = break (=='=') name | ||
1024 | val ('=':vs) = Just vs | ||
1025 | val _ = Nothing | ||
1026 | |||
907 | commands :: [(String,String)] | 1027 | commands :: [(String,String)] |
908 | commands = | 1028 | commands = |
909 | [ ( "help", "display usage information" ) | 1029 | [ ( "help", "display usage information" ) |
@@ -916,6 +1036,7 @@ commands = | |||
916 | , ( "export-secret", "export (both public and secret) information into your keyring" ) | 1036 | , ( "export-secret", "export (both public and secret) information into your keyring" ) |
917 | , ( "export-public", "import (public) information into your keyring" ) | 1037 | , ( "export-public", "import (public) information into your keyring" ) |
918 | , ( "working-key", "show the current working master key and its subkeys" ) | 1038 | , ( "working-key", "show the current working master key and its subkeys" ) |
1039 | , ( "merge", "low level import/export operation" ) | ||
919 | ] | 1040 | ] |
920 | 1041 | ||
921 | main = do | 1042 | main = do |