-
Notifications
You must be signed in to change notification settings - Fork 16
/
fixkey.ml
172 lines (146 loc) · 6.11 KB
/
fixkey.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
(***********************************************************************)
(* fixkey.ml *)
(* *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(* 2011, 2012, 2013 Yaron Minsky and Contributors *)
(* *)
(* This file is part of SKS. SKS is free software; you can *)
(* redistribute it and/or modify it under the terms of the GNU General *)
(* Public License as published by the Free Software Foundation; either *)
(* version 2 of the License, or (at your option) any later version. *)
(* *)
(* This program is distributed in the hope that it will be useful, but *)
(* WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *)
(* General Public License for more details. *)
(* *)
(* You should have received a copy of the GNU General Public License *)
(* along with this program; if not, write to the Free Software *)
(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 *)
(* USA or see <http://www.gnu.org/licenses/>. *)
(***********************************************************************)
open StdLabels
open MoreLabels
open Common
open Packet
module Map = PMap.Map
exception Bad_key
exception Standalone_revocation_certificate
(** list of filters currently applied on incoming keys. Filter types are
included in comma-separated list, and should not include commas or
whitespace
meaning of filter types:
- yminsky.merge:
Merges all keys in database that can be merged.
- yminsky.dedup:
Parses all keys and removes duplicates. Unparseable keys
are removed from the database.
*)
let filters = [ "yminsky.dedup"; "yminsky.merge" ]
(**********************************************************************)
(*** Key Merging ****************************************************)
(**********************************************************************)
let get_keypacket pkey = pkey.KeyMerge.key
let ( |= ) map key = Map.find key map
let ( |< ) map (key,data) = Map.add ~key ~data map
let rec join_by_keypacket map keylist = match keylist with
| [] -> map
| key::tl ->
let keypacket = get_keypacket key in
let map =
try
let keylist_ref = map |= keypacket in
keylist_ref := key::!keylist_ref;
map
with
Not_found ->
map |< (keypacket,ref [key])
in
join_by_keypacket map tl
(** Given a list of parsed keys, returns a list of parsed key lists,
grouped by keypacket *)
let join_by_keypacket keys =
Map.fold ~f:(fun ~key ~data list -> !data::list) ~init:[]
(join_by_keypacket Map.empty keys)
(** merges a list of pkeys, throwing a failure if the merge cannot procede *)
let merge_pkeys pkeys = match pkeys with
| [] -> failwith "Attempt to merge empty list of keys"
| hd::tl ->
List.fold_left ~init:hd tl
~f:(fun key1 key2 ->
match KeyMerge.merge_pkeys key1 key2 with
None -> failwith "PKey merge failed"
| Some key -> key
)
(** Accepts collection of keys, which should comprise all keys in the
database with the same keyid. Returns list of pairs, first part of pair
being a list of keys to delete, last part being a list of keys to add
*)
let compute_merge_replacements keys =
let pkeys = List.map ~f:KeyMerge.key_to_pkey keys in
(* put parsed keys into list of lists, grouped by key packet *)
let kp_list = join_by_keypacket pkeys in
let replacements =
List.fold_left ~init:[] kp_list
~f:(fun list pkeys ->
if List.length pkeys > 1 then
(Some (List.map ~f:KeyMerge.flatten pkeys,
KeyMerge.flatten (merge_pkeys pkeys)))::list
else
None::list
)
in
strip_opt replacements
(**********************************************************************)
(*** Key Canonicalization *******************************************)
(**********************************************************************)
(** Returns canonicalized version of key. Raises Bad_key if key should simply
be discarded
*)
let is_revocation_signature pack =
match pack.packet_type with
| Signature_Packet ->
let parsed_signature = ParsePGP.parse_signature pack in
let sigtype = match parsed_signature with
| V3sig s -> s.v3s_sigtype
| V4sig s -> s.v4s_sigtype
in
let result = match (int_to_sigtype sigtype) with
| Key_revocation_signature | Subkey_revocation_signature
| Certification_revocation_signature -> true
| _ -> false
in
result
| _ -> false
let canonicalize key =
if is_revocation_signature (List.hd key)
then raise Standalone_revocation_certificate;
try KeyMerge.dedup_key key
with KeyMerge.Unparseable_packet_sequence -> raise Bad_key
open KeyMerge
let good_key pack =
try ignore (ParsePGP.parse_pubkey_info pack); true
with e -> false
let good_signature pack =
try ignore (ParsePGP.parse_signature pack); true
with e -> false
let drop_bad_sigs packlist =
List.filter ~f:good_signature packlist
let sig_filter_sigpair (pack,sigs) =
let sigs = List.filter ~f:good_signature sigs in
if sigs = [] then None
else Some (pack,sigs)
let presentation_filter key =
let pkey = key_to_pkey key in
if not (good_key pkey.key)
then None
else
let selfsigs = drop_bad_sigs pkey.selfsigs in
let subkeys = Utils.filter_map ~f:sig_filter_sigpair pkey.subkeys in
let uids = Utils.filter_map ~f:sig_filter_sigpair pkey.uids in
let subkeys = List.filter ~f:(fun (key,_) -> good_key key) subkeys in
Some (flatten { pkey with
selfsigs = selfsigs;
uids = uids;
subkeys = subkeys;
})