← Back to branch summary

~ubuntu-branches/debian/experimental/sks/experimental

« back to all changes in this revision

Viewing changes to index.ml

  • Committer: Package Import Robot
  • Author(s): Daniel Kahn Gillmor
  • Date: 2013-06-27 16:39:02 UTC
  • mfrom: (1.1.4)
  • Revision ID: package-import@ubuntu.com-20130627163902-qqic4va2187boeji
Tags: 1.1.4-1
http://bugs.debian.org/690135
http://bugs.debian.org/709322
* New Upstream Release (Closes: #690135)
* added myself to Uploaders.
* convert to dh 9
* Standards-Version: bump to 3.9.4 (no changes needed)
* debian/rules: clean up
* refresh and clean up debian/patches
* switch packaging vcs to git
* avoid trying to upgrade DB_CONFIG (Closes: #709322)

Show diffs side-by-side

added added

removed removed

Lines of Context:
index.ml
1
 
(************************************************************************)
2
 
(* This file is part of SKS.  SKS is free software; you can
3
 
   redistribute it and/or modify it under the terms of the GNU General
4
 
   Public License as published by the Free Software Foundation; either
5
 
   version 2 of the License, or (at your option) any later version.
6
 
 
7
 
   This program is distributed in the hope that it will be useful, but
8
 
   WITHOUT ANY WARRANTY; without even the implied warranty of
9
 
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
10
 
   General Public License for more details.
11
 
 
12
 
   You should have received a copy of the GNU General Public License
13
 
   along with this program; if not, write to the Free Software
14
 
   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
15
 
   USA *)
16
 
(***********************************************************************)
17
 
 
18
 
(** code for generating pretty PGP key indices *)
 
1
(***********************************************************************)
 
2
(* index.ml - code for generating pretty PGP key indices               *)
 
3
(*                                                                     *)
 
4
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
 
5
(*               2011, 2012  Yaron Minsky and Contributors             *)
 
6
(*                                                                     *)
 
7
(* This file is part of SKS.  SKS is free software; you can            *)
 
8
(* redistribute it and/or modify it under the terms of the GNU General *)
 
9
(* Public License as published by the Free Software Foundation; either *)
 
10
(* version 2 of the License, or (at your option) any later version.    *)
 
11
(*                                                                     *)
 
12
(* This program is distributed in the hope that it will be useful, but *)
 
13
(* WITHOUT ANY WARRANTY; without even the implied warranty of          *)
 
14
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU   *)
 
15
(* General Public License for more details.                            *)
 
16
(*                                                                     *)
 
17
(* You should have received a copy of the GNU General Public License   *)
 
18
(* along with this program; if not, write to the Free Software         *)
 
19
(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 *)
 
20
(* USA or see <http://www.gnu.org/licenses/>.                          *)
 
21
(***********************************************************************)
19
22
 
20
23
open StdLabels
21
24
open MoreLabels
30
33
(********************************************************************)
31
34
 
32
35
type siginfo = { mutable userid: string option;
33
 
                 mutable policy_url: string option;
34
 
                 mutable notation_data: (string * string) option;
35
 
                 mutable revocation_key: string option;
36
 
                 mutable is_primary_uid: bool;
37
 
                 mutable keyid: string option;
38
 
                 mutable sigtype: int;
39
 
                 mutable sig_creation_time: int64 option;
40
 
                 mutable sig_expiration_time: int64 option;
41
 
                 mutable key_expiration_time: int64 option;
42
 
               }
 
36
                 mutable policy_url: string option;
 
37
                 mutable notation_data: (string * string) option;
 
38
                 mutable revocation_key: string option;
 
39
                 mutable is_primary_uid: bool;
 
40
                 mutable keyid: string option;
 
41
                 mutable sigtype: int;
 
42
                 mutable sig_creation_time: int64 option;
 
43
                 mutable sig_expiration_time: int64 option;
 
44
                 mutable key_expiration_time: int64 option;
 
45
               }
43
46
 
44
47
(********************************************************************)
45
48
 
46
 
let empty_siginfo () = 
 
49
let empty_siginfo () =
47
50
  { userid = None;
48
51
    policy_url = None;
49
52
    notation_data = None;
55
58
    sig_expiration_time = None;
56
59
    key_expiration_time = None;
57
60
  }
58
 
  
 
61
 
59
62
(********************************************************************)
60
63
 
61
 
let keyinfo_header request = 
 
64
let keyinfo_header request =
62
65
  if request.kind = VIndex then
63
66
    "Type bits/keyID     cr. time   exp time   key expir"
64
67
  else
66
69
 
67
70
(********************************************************************)
68
71
 
69
 
let sig_to_siginfo sign = 
 
72
let sig_to_siginfo sign =
70
73
  let siginfo = empty_siginfo () in
71
74
  begin
72
75
    match ParsePGP.parse_signature sign with
73
76
      | V3sig s ->
74
 
          siginfo.sigtype <- s.v3s_sigtype;
75
 
          siginfo.keyid <- Some s.v3s_keyid;
76
 
          siginfo.sig_creation_time <- Some s.v3s_ctime
 
77
          siginfo.sigtype <- s.v3s_sigtype;
 
78
          siginfo.keyid <- Some s.v3s_keyid;
 
79
          siginfo.sig_creation_time <- Some s.v3s_ctime
77
80
      | V4sig s ->
78
 
          let update_siginfo ssp = 
79
 
            match ssp.ssp_type with
80
 
 
81
 
              | 2 -> (* sign. expiration time *)
82
 
                  if ssp.ssp_length = 4 then
83
 
                    siginfo.sig_creation_time <-
84
 
                    Some (ParsePGP.int64_of_string ssp.ssp_body)
85
 
 
86
 
              | 3 -> (* sign. expiration time *)
87
 
                  if ssp.ssp_length = 4 then
88
 
                    siginfo.sig_expiration_time <-
89
 
                    let exp = ParsePGP.int64_of_string ssp.ssp_body in
90
 
                    if Int64.compare exp Int64.zero = 0 
91
 
                    then None else Some exp
92
 
 
93
 
              | 9 -> (* key expiration time *)
94
 
                  if ssp.ssp_length = 4 then
95
 
                    siginfo.key_expiration_time <-
96
 
                    let exp = ParsePGP.int64_of_string ssp.ssp_body in
97
 
                    if Int64.compare exp Int64.zero = 0 
98
 
                    then None else Some exp
99
 
 
100
 
              | 12 -> (* revocation key *)
101
 
                  let cin = new Channel.string_in_channel ssp.ssp_body 0 in
102
 
                  let _revclass = cin#read_int_size 1 in
103
 
                  let _algid = cin#read_int_size 1 in
104
 
                  let fingerprint = cin#read_string 20 in
105
 
                  siginfo.revocation_key <- Some fingerprint
106
 
 
107
 
              | 16 -> (* issuer keyid *)
108
 
                  if ssp.ssp_length = 8 then
109
 
                    siginfo.keyid <- Some ssp.ssp_body 
110
 
                  else
111
 
                    printf "Argh!  that makes no sense: %d\n" ssp.ssp_length 
112
 
 
113
 
              | 20 -> (* notation data *)
114
 
                  let cin = new Channel.string_in_channel ssp.ssp_body 0 in
115
 
                  let flags = cin#read_string 4 in
116
 
                  let name_len = cin#read_int_size 2 in
117
 
                  let value_len = cin#read_int_size 2 in
118
 
                  let name_data = cin#read_string name_len in
119
 
                  let value_data = cin#read_string value_len in
120
 
 
121
 
                  if Char.code flags.[0] = 0x80 then 
122
 
                    (* human-readable notation data *)
123
 
                    siginfo.notation_data <- Some (name_data,value_data)
124
 
 
125
 
              | 25 -> (* primary userid (bool) *)
126
 
                  if ssp.ssp_length = 1 then
127
 
                    let v = int_of_char ssp.ssp_body.[0] in
128
 
                    siginfo.is_primary_uid <- v <> 0
129
 
 
130
 
              | 26 -> (* policy URL *)
131
 
                  siginfo.policy_url <- Some ssp.ssp_body
132
 
 
133
 
              | 28 -> (* signer's userid *)
134
 
                  siginfo.userid <- Some ssp.ssp_body
135
 
 
136
 
              | _ -> (* miscellaneous other packet *)
137
 
                  ()
138
 
          in
139
 
          siginfo.sigtype <- s.v4s_sigtype;
140
 
          List.iter (s.v4s_hashed_subpackets @ s.v4s_unhashed_subpackets)
141
 
            ~f:(fun ssp -> try update_siginfo ssp with End_of_file -> ())
 
81
          let update_siginfo ssp =
 
82
            match ssp.ssp_type with
 
83
 
 
84
              | 2 -> (* sign. expiration time *)
 
85
                  if ssp.ssp_length = 4 then
 
86
                    siginfo.sig_creation_time <-
 
87
                    Some (ParsePGP.int64_of_string ssp.ssp_body)
 
88
 
 
89
              | 3 -> (* sign. expiration time *)
 
90
                  if ssp.ssp_length = 4 then
 
91
                    siginfo.sig_expiration_time <-
 
92
                    let exp = ParsePGP.int64_of_string ssp.ssp_body in
 
93
                    if Int64.compare exp Int64.zero = 0
 
94
                    then None else Some exp
 
95
 
 
96
              | 9 -> (* key expiration time *)
 
97
                  if ssp.ssp_length = 4 then
 
98
                    siginfo.key_expiration_time <-
 
99
                    let exp = ParsePGP.int64_of_string ssp.ssp_body in
 
100
                    if Int64.compare exp Int64.zero = 0
 
101
                    then None else Some exp
 
102
 
 
103
              | 12 -> (* revocation key *)
 
104
                  let cin = new Channel.string_in_channel ssp.ssp_body 0 in
 
105
                  let _revclass = cin#read_int_size 1 in
 
106
                  let _algid = cin#read_int_size 1 in
 
107
                  let fingerprint = cin#read_string 20 in
 
108
                  siginfo.revocation_key <- Some fingerprint
 
109
 
 
110
              | 16 -> (* issuer keyid *)
 
111
                  if ssp.ssp_length = 8 then
 
112
                    siginfo.keyid <- Some ssp.ssp_body
 
113
                  else
 
114
                    printf "Argh!  that makes no sense: %d\n" ssp.ssp_length
 
115
 
 
116
              | 20 -> (* notation data *)
 
117
                  let cin = new Channel.string_in_channel ssp.ssp_body 0 in
 
118
                  let flags = cin#read_string 4 in
 
119
                  let name_len = cin#read_int_size 2 in
 
120
                  let value_len = cin#read_int_size 2 in
 
121
                  let name_data = cin#read_string name_len in
 
122
                  let value_data = cin#read_string value_len in
 
123
 
 
124
                  if Char.code flags.[0] = 0x80 then
 
125
                    (* human-readable notation data *)
 
126
                    siginfo.notation_data <- Some (name_data,value_data)
 
127
 
 
128
              | 25 -> (* primary userid (bool) *)
 
129
                  if ssp.ssp_length = 1 then
 
130
                    let v = int_of_char ssp.ssp_body.[0] in
 
131
                    siginfo.is_primary_uid <- v <> 0
 
132
 
 
133
              | 26 -> (* policy URL *)
 
134
                  siginfo.policy_url <- Some ssp.ssp_body
 
135
 
 
136
              | 28 -> (* signer's userid *)
 
137
                  siginfo.userid <- Some ssp.ssp_body
 
138
 
 
139
              | _ -> (* miscellaneous other packet *)
 
140
                  ()
 
141
          in
 
142
          siginfo.sigtype <- s.v4s_sigtype;
 
143
          List.iter (s.v4s_hashed_subpackets @ s.v4s_unhashed_subpackets)
 
144
            ~f:(fun ssp -> try update_siginfo ssp with End_of_file -> ())
142
145
  end;
143
146
  siginfo
144
147
 
145
148
(********************************************************************)
146
149
 
147
150
(** sort signatures in ascending time order *)
148
 
let sort_siginfo_list list = 
 
151
let sort_siginfo_list list =
149
152
  List.stable_sort list
150
153
    ~cmp:(fun x y -> compare x.sig_creation_time y.sig_creation_time)
151
154
 
156
159
(********************************************************************)
157
160
 
158
161
let is_primary ~keyid (uid,siginfo_list) =
159
 
  List.exists ~f:(fun siginfo -> 
160
 
                    is_selfsig ~keyid siginfo
161
 
                    && siginfo.is_primary_uid 
162
 
                    && uid.packet_type = User_ID_Packet
163
 
                 )
 
162
  List.exists ~f:(fun siginfo ->
 
163
                    is_selfsig ~keyid siginfo
 
164
                    && siginfo.is_primary_uid
 
165
                    && uid.packet_type = User_ID_Packet
 
166
                 )
164
167
    siginfo_list
165
168
 
166
169
(********************************************************************)
167
170
 
168
171
(** returns time of most recent self-sig on uid *)
169
 
let max_selfsig_time ~keyid (uid,siginfo_list) = 
170
 
  let selfsigs = List.filter ~f:(fun si -> is_selfsig ~keyid si) 
171
 
                   siginfo_list in
 
172
let max_selfsig_time ~keyid (uid,siginfo_list) =
 
173
  let selfsigs = List.filter ~f:(fun si -> is_selfsig ~keyid si)
 
174
                   siginfo_list in
172
175
  let times = filter_opts
173
 
                (List.map selfsigs
174
 
                   ~f:(function x -> match x.sig_creation_time with
175
 
                           None -> None
176
 
                         | Some time -> Some (Int64.to_float time)))
 
176
                (List.map selfsigs
 
177
                   ~f:(function x -> match x.sig_creation_time with
 
178
                           None -> None
 
179
                         | Some time -> Some (Int64.to_float time)))
177
180
  in
178
181
  List.fold_left ~init:min_float ~f:max times
179
182
 
180
183
(********************************************************************)
181
184
 
182
 
let split_list ~f l = 
 
185
let split_list ~f l =
183
186
  let rec loop l a b = match l with
184
187
      [] -> (List.rev a, List.rev b)
185
188
    | hd::tl ->
186
 
        if f hd then loop tl (hd::a) b
187
 
        else loop tl a (hd::b)
 
189
        if f hd then loop tl (hd::a) b
 
190
        else loop tl a (hd::b)
188
191
  in
189
192
  loop l [] []
190
193
 
191
194
(********************************************************************)
192
195
 
193
 
let move_primary_to_front ~keyid uids = 
 
196
let move_primary_to_front ~keyid uids =
194
197
  let (primary,normal) = split_list ~f:(is_primary ~keyid) uids in
195
198
  let primary = List.stable_sort primary
196
 
               ~cmp:(fun x y -> compare
197
 
                       (max_selfsig_time ~keyid y)
198
 
                       (max_selfsig_time ~keyid x)
199
 
                    )
 
199
               ~cmp:(fun x y -> compare
 
200
                       (max_selfsig_time ~keyid y)
 
201
                       (max_selfsig_time ~keyid x)
 
202
                    )
200
203
  in
201
204
  primary @ normal
202
205
 
203
206
(********************************************************************)
204
207
 
205
 
let convert_sigpair (uid,sigs) = 
 
208
let convert_sigpair (uid,sigs) =
206
209
  (uid,List.map ~f:sig_to_siginfo sigs)
207
210
 
208
211
(********************************************************************)
209
212
 
210
213
let blank_datestr = "__________"
211
214
let no_datestr =    "          "
212
 
let datestr_of_int64 i = 
 
215
let datestr_of_int64 i =
213
216
  let tm = Unix.gmtime (Int64.to_float i) in
214
 
  sprintf "%04d-%02d-%02d" (1900 + tm.Unix.tm_year) (1 + tm.Unix.tm_mon) 
 
217
  sprintf "%04d-%02d-%02d" (1900 + tm.Unix.tm_year) (1 + tm.Unix.tm_mon)
215
218
    (tm.Unix.tm_mday)
216
219
 
217
220
(********************************************************************)
218
221
 
219
 
let siginfo_to_lines ~get_uid ?key_creation_time request self_keyid today siginfo = 
 
222
let siginfo_to_lines ~get_uid ?key_creation_time request self_keyid today siginfo =
220
223
 
221
224
  let sig_creation_string = match siginfo.sig_creation_time with
222
225
    | None -> blank_datestr
223
226
    | Some time -> datestr_of_int64 time
224
227
  in
225
228
 
226
 
  let key_expiration_string = 
 
229
  let key_expiration_string =
227
230
    match (key_creation_time,
228
 
           siginfo.key_expiration_time) 
 
231
           siginfo.key_expiration_time)
229
232
    with
230
233
    | (None,_) | (_,None) -> blank_datestr
231
234
    | (Some x,Some y) -> datestr_of_int64 (Int64.add x y)
232
235
  in
233
 
  
234
 
  let sig_expiration_string = 
 
236
 
 
237
  let sig_expiration_string =
235
238
    match (siginfo.sig_creation_time,
236
 
           siginfo.sig_expiration_time) 
 
239
           siginfo.sig_expiration_time)
237
240
    with
238
241
    | (None,_) | (_,None) -> blank_datestr
239
242
    | (Some x,Some y) -> datestr_of_int64 (Int64.add x y)
240
243
  in
241
 
  
 
244
 
242
245
  let sig_expired =
243
246
    match (siginfo.sig_creation_time,
244
247
           siginfo.sig_expiration_time)
246
249
    | (None,_) | (_,None) -> false
247
250
    | (Some x,Some y) -> (Int64.to_float (Int64.add x y)) < today
248
251
  in
249
 
  
250
 
  let sigtype_string = 
 
252
 
 
253
  let sigtype_string =
251
254
    match siginfo.sigtype with
252
 
      | 0x10 -> 
 
255
      | 0x10 ->
253
256
         if sig_expired then "<span class=\"warn\"> exp  </span>"
254
257
         else " sig  "
255
 
      | 0x11 -> 
 
258
      | 0x11 ->
256
259
         if sig_expired then "<span class=\"warn\"> exp1 </span>"
257
260
         else " sig1 "
258
 
      | 0x12 -> 
 
261
      | 0x12 ->
259
262
         if sig_expired then "<span class=\"warn\"> exp2 </span>"
260
263
         else " sig2 "
261
 
      | 0x13 -> 
 
264
      | 0x13 ->
262
265
         if sig_expired then "<span class=\"warn\"> exp3 </span>"
263
266
         else " sig3 "
264
267
      | 0x20 | 0x28 | 0x30 -> "<span class=\"warn\">revok </span>"
269
272
 
270
273
  let uid_string = match siginfo.userid with
271
274
    | Some s -> s
272
 
    | None -> 
273
 
        if Some self_keyid = siginfo.keyid then "[selfsig]"
274
 
        else 
275
 
          match apply_opt get_uid siginfo.keyid with
276
 
            | None | Some None -> "[]"
277
 
            | Some (Some uid) -> uid
 
275
    | None ->
 
276
        if Some self_keyid = siginfo.keyid then "[selfsig]"
 
277
        else
 
278
          match apply_opt get_uid siginfo.keyid with
 
279
            | None | Some None -> "[]"
 
280
            | Some (Some uid) -> uid
278
281
  in
279
282
  let uid_string = HtmlTemplates.html_quote uid_string in
280
283
  let uid_string = match siginfo.keyid with
281
284
      None -> uid_string
282
285
    | Some keyid ->
283
 
        if uid_string = "" then ""
284
 
        else
285
 
          let long = Fingerprint.keyid_to_string ~short:false keyid in
286
 
          let link = 
287
 
            HtmlTemplates.link ~op:"vindex" 
288
 
              ~hash:request.hash ~fingerprint:request.fingerprint ~keyid:long
289
 
          in
290
 
          sprintf "<a href=\"%s\">%s</a>" link uid_string
 
286
        if uid_string = "" then ""
 
287
        else
 
288
          let long = Fingerprint.keyid_to_string ~short:false keyid in
 
289
          let link =
 
290
            HtmlTemplates.link ~op:"vindex"
 
291
              ~hash:request.hash ~fingerprint:request.fingerprint ~keyid:long
 
292
          in
 
293
          sprintf "<a href=\"%s\">%s</a>" link uid_string
291
294
  in
292
 
  
 
295
 
293
296
  let keyid_string = match siginfo.keyid with
294
 
    | Some keyid -> 
295
 
        let short = Fingerprint.keyid_to_string ~short:true keyid in
296
 
        let long = Fingerprint.keyid_to_string ~short:false keyid in
297
 
        let link = 
298
 
          HtmlTemplates.link ~op:"get" 
299
 
            ~hash:request.hash ~fingerprint:request.fingerprint ~keyid:long
300
 
        in
301
 
        sprintf "<a href=\"%s\">%s</a>" link short
302
 
    | None -> 
303
 
        "no keyid"
 
297
    | Some keyid ->
 
298
        let short = Fingerprint.keyid_to_string ~short:true keyid in
 
299
        let long = Fingerprint.keyid_to_string ~short:false keyid in
 
300
        let link =
 
301
          HtmlTemplates.link ~op:"get"
 
302
            ~hash:request.hash ~fingerprint:request.fingerprint ~keyid:long
 
303
        in
 
304
        sprintf "<a href=\"%s\">%s</a>" link short
 
305
    | None ->
 
306
        "no keyid"
304
307
  in
305
308
 
306
309
  let firstline = sprintf "sig %-6s %s %s %s %s %s"
307
 
                    sigtype_string keyid_string
308
 
                    sig_creation_string sig_expiration_string 
309
 
                    key_expiration_string
310
 
                    uid_string
 
310
                    sigtype_string keyid_string
 
311
                    sig_creation_string sig_expiration_string
 
312
                    key_expiration_string
 
313
                    uid_string
311
314
  in
312
315
 
313
 
  let policy_url_opt = 
 
316
  let policy_url_opt =
314
317
    apply_opt siginfo.policy_url
315
 
      ~f:(fun policy_url -> 
316
 
            let policy_url = HtmlTemplates.html_quote policy_url in
317
 
            sprintf "    Policy URL: <a href=\"%s\">%s</a>" 
318
 
              policy_url policy_url
319
 
         )
 
318
      ~f:(fun policy_url ->
 
319
            let policy_url = HtmlTemplates.html_quote policy_url in
 
320
            sprintf "    Policy URL: <a href=\"%s\">%s</a>"
 
321
              policy_url policy_url
 
322
         )
320
323
  in
321
 
  let notation_data_opt = 
 
324
  let notation_data_opt =
322
325
    apply_opt siginfo.notation_data
323
326
      ~f:(fun (name,value) ->
324
 
            sprintf "    Notation data: <span class=\"text-decoration: underline;\">%s</span> %s"
325
 
            (HtmlTemplates.html_quote name)
326
 
            (HtmlTemplates.html_quote value)
327
 
         )
 
327
              sprintf "    Notation data: <span class=\"text-decoration: underline;\">%s</span> %s"
 
328
            (HtmlTemplates.html_quote name)
 
329
            (HtmlTemplates.html_quote value)
 
330
         )
328
331
  in
329
 
  let revocation_key_opt = 
330
 
    apply_opt siginfo.revocation_key 
 
332
  let revocation_key_opt =
 
333
    apply_opt siginfo.revocation_key
331
334
      ~f:(fun fingerprint ->
332
 
            sprintf "    Revocation key fingerprint: <a href=\"%s\">%s</a>"
333
 
            (HtmlTemplates.link ~hash:request.hash ~op:"vindex" 
334
 
               ~fingerprint:request.fingerprint 
335
 
               ~keyid:(Utils.hexstring fingerprint)
336
 
            )
337
 
            (Fingerprint.fp_to_string fingerprint)
338
 
         )
 
335
            sprintf "    Revocation key fingerprint: <a href=\"%s\">%s</a>"
 
336
            (HtmlTemplates.link ~hash:request.hash ~op:"vindex"
 
337
               ~fingerprint:request.fingerprint
 
338
               ~keyid:(Utils.hexstring fingerprint)
 
339
            )
 
340
            (Fingerprint.fp_to_string fingerprint)
 
341
         )
339
342
  in
340
343
  firstline :: filter_opts [policy_url_opt; notation_data_opt;
341
 
                            revocation_key_opt]
 
344
                            revocation_key_opt]
342
345
 
343
346
 
344
347
(********************************************************************)
345
348
 
346
 
let selfsigs_to_lines request key_creation_time keyid selfsigs today = 
347
 
  let lines = 
 
349
let selfsigs_to_lines request key_creation_time keyid selfsigs today =
 
350
  let lines =
348
351
    List.map ~f:(fun sign -> siginfo_to_lines ~get_uid:(fun _ -> None)
349
 
                   ~key_creation_time request keyid today  
350
 
                   (sig_to_siginfo sign))
 
352
                   ~key_creation_time request keyid today
 
353
                   (sig_to_siginfo sign))
351
354
      selfsigs
352
355
  in
353
356
  List.concat lines
355
358
(********************************************************************)
356
359
 
357
360
let uid_to_lines ~get_uid request key_creation_time keyid today
358
 
  (uid,siginfo_list) = 
 
361
  (uid,siginfo_list) =
359
362
  let siginfo_list = sort_siginfo_list siginfo_list in
360
363
  let uid_line = match uid.packet_type with
361
 
    | User_ID_Packet -> 
362
 
        sprintf "<strong>uid</strong> <span class=\"uid\">%s</span>" 
363
 
        (HtmlTemplates.html_quote uid.packet_body)
 
364
    | User_ID_Packet ->
 
365
        sprintf "<strong>uid</strong> <span class=\"uid\">%s</span>"
 
366
        (HtmlTemplates.html_quote uid.packet_body)
364
367
 
365
368
    | _ -> sprintf "<strong>uat</strong> [contents omitted]"
366
369
  in
367
 
  let siginfo_lines = 
368
 
    List.concat 
 
370
  let siginfo_lines =
 
371
    List.concat
369
372
      (List.map ~f:(siginfo_to_lines ~get_uid ~key_creation_time
370
 
                    request keyid today)
371
 
         siginfo_list)   
 
373
                    request keyid today)
 
374
         siginfo_list)
372
375
  in
373
376
  ""::uid_line::siginfo_lines
374
377
 
375
378
let uids_to_lines ~get_uid request key_creation_time keyid uids today =
376
 
  List.concat 
 
379
  List.concat
377
380
    (List.map ~f:(uid_to_lines ~get_uid request key_creation_time keyid today) uids)
378
381
 
379
382
(********************************************************************)
380
383
 
381
 
let key_packet_to_line ~is_subkey pki keyid = 
 
384
let key_packet_to_line ~is_subkey pki keyid =
382
385
  let prefix = if is_subkey then "<strong>sub</strong>" else "<strong>pub</strong>" in
383
386
  let creation_string = datestr_of_int64 pki.pk_ctime in
384
 
  let expiration_string = 
 
387
  let expiration_string =
385
388
    if pki.pk_version = 4 then no_datestr
386
389
    else
387
390
      match pki.pk_expiration with
388
 
        | None -> blank_datestr
389
 
        | Some days -> 
390
 
            let time = Int64.add (Int64.of_int (days * 24 * 60 * 60))
391
 
                         pki.pk_ctime in  
392
 
            datestr_of_int64 time
 
391
        | None -> blank_datestr
 
392
        | Some days ->
 
393
            let time = Int64.add (Int64.of_int (days * 24 * 60 * 60))
 
394
                         pki.pk_ctime in
 
395
            datestr_of_int64 time
393
396
  in
394
397
  let keyid = keyid in
395
398
  let keyid_short = Fingerprint.keyid_to_string ~short:true keyid in
396
399
  let keyid_long = Fingerprint.keyid_to_string ~short:false keyid in
397
400
 
398
 
  let keyid_string = 
 
401
  let keyid_string =
399
402
    if is_subkey then sprintf "%8s" keyid_short
400
403
    else
401
404
      sprintf "<a href=\"%s\">%8s</a>"
402
 
        (HtmlTemplates.link ~op:"get" ~hash:false ~fingerprint:false
403
 
           ~keyid:keyid_long ) 
404
 
        keyid_short
 
405
        (HtmlTemplates.link ~op:"get" ~hash:false ~fingerprint:false
 
406
           ~keyid:keyid_long )
 
407
        keyid_short
405
408
  in
406
409
  let algo = pk_alg_to_ident pki.pk_alg in
407
410
  let line = sprintf "%s  %4d%s/%s %s %s "
408
 
               prefix
409
 
               pki.pk_keylen algo
410
 
               keyid_string
411
 
               creation_string expiration_string
 
411
               prefix
 
412
               pki.pk_keylen algo
 
413
               keyid_string
 
414
               creation_string expiration_string
412
415
  in
413
416
  (line,keyid)
414
417
 
415
418
(********************************************************************)
416
419
 
417
 
let subkey_to_lines request today (subkey,siginfo_list) = 
 
420
let subkey_to_lines request today (subkey,siginfo_list) =
418
421
  let pki = ParsePGP.parse_pubkey_info subkey in
419
422
  let keyid = (Fingerprint.from_packet subkey).Fingerprint.keyid in
420
423
  let (subkey_line,keyid) = key_packet_to_line ~is_subkey:true pki keyid in
421
424
  let key_creation_time = pki.pk_ctime in
422
 
  let siginfo_lines = 
 
425
  let siginfo_lines =
423
426
    List.concat (List.map ~f:(siginfo_to_lines ~get_uid:(fun _ -> None)
424
 
                                ~key_creation_time request keyid today) 
425
 
                   siginfo_list) 
 
427
                                ~key_creation_time request keyid today)
 
428
                   siginfo_list)
426
429
  in
427
430
  ""::subkey_line::siginfo_lines
428
431
 
429
 
let subkeys_to_lines request subkeys today = 
 
432
let subkeys_to_lines request subkeys today =
430
433
  List.concat (List.map ~f:(subkey_to_lines request today) subkeys)
431
434
 
432
435
(********************************************************************)
439
442
*)
440
443
let rec extract ~f list = match list with
441
444
    [] -> (None,[])
442
 
  | hd::tl -> 
 
445
  | hd::tl ->
443
446
      if f hd then (Some hd,tl)
444
447
      else let (x,new_tl) =  extract ~f tl in (x,hd::new_tl)
445
448
 
446
449
(** if there is an element in list for which f returns true, then return list
447
450
  with one such element moved to the front. *)
448
 
let move_to_front ~f list = 
 
451
let move_to_front ~f list =
449
452
  match extract ~f list with
450
453
    | (None,list) -> list
451
454
    | (Some x,list) -> x::list
453
456
(********************************************************************)
454
457
 
455
458
(** fetches UID from keyid, stopping fater first [max_uid_fetches] *)
456
 
let get_uid get_uids = 
 
459
let get_uid get_uids =
457
460
  let ctr = ref 0 in
458
 
  (fun keyid -> 
 
461
  (fun keyid ->
459
462
     try
460
463
       incr ctr;
461
464
       if !ctr > !Settings.max_uid_fetches then None
462
465
       else
463
 
         let uids = get_uids keyid in
464
 
         let uids = List.filter uids
465
 
                      ~f:(fun (uid,_) -> uid.packet_type = User_ID_Packet) in
466
 
         let uids = List.map ~f:convert_sigpair uids in
467
 
         match move_primary_to_front ~keyid uids with
468
 
           | [] -> None
469
 
           | (uid,_)::tl -> Some uid.packet_body
 
466
         let uids = get_uids keyid in
 
467
         let uids = List.filter uids
 
468
                      ~f:(fun (uid,_) -> uid.packet_type = User_ID_Packet) in
 
469
         let uids = List.map ~f:convert_sigpair uids in
 
470
         match move_primary_to_front ~keyid uids with
 
471
           | [] -> None
 
472
           | (uid,_)::tl -> Some uid.packet_body
470
473
     with
471
 
       | e -> 
472
 
           eplerror 3 e 
473
 
             "Error fetching uid during VIndex for keyid 0x%s"
474
 
             (KeyHash.hexify keyid);
475
 
           None
 
474
       | e ->
 
475
           eplerror 3 e
 
476
             "Error fetching uid during VIndex for keyid 0x%s"
 
477
             (KeyHash.hexify keyid);
 
478
           None
476
479
  )
477
 
  
 
480
 
478
481
(********************************************************************)
479
482
 
480
483
(** computes fingerprint and hash lines if required *)
481
 
let get_extra_lines request key hash meta = 
482
 
  
483
 
  let extra_lines = 
 
484
let get_extra_lines request key hash meta =
 
485
 
 
486
  let extra_lines =
484
487
    if request.fingerprint then
485
488
      [HtmlTemplates.fingerprint ~fp:(Fingerprint.fp_to_string
486
 
                                        meta.Fingerprint.fp)]
 
489
                                        meta.Fingerprint.fp)]
487
490
    else []
488
491
  in
489
492
 
490
 
  let extra_lines = 
 
493
  let extra_lines =
491
494
    if request.hash then
492
495
      let hash_line = HtmlTemplates.hash ~hash:(KeyHash.hexify hash) in
493
496
      hash_line::extra_lines
494
 
    else 
 
497
    else
495
498
      extra_lines
496
499
  in
497
500
 
505
508
  try
506
509
    let get_uid = get_uid get_uids in
507
510
    let pkey = KeyMerge.key_to_pkey key in
508
 
    let selfsigs = pkey.KeyMerge.selfsigs 
509
 
    and uids = List.map ~f:convert_sigpair pkey.KeyMerge.uids 
 
511
    let selfsigs = pkey.KeyMerge.selfsigs
 
512
    and uids = List.map ~f:convert_sigpair pkey.KeyMerge.uids
510
513
    and subkeys = List.map ~f:convert_sigpair pkey.KeyMerge.subkeys
511
514
    and pubkey = pkey.KeyMerge.key in
512
515
 
513
516
    (* sort subkeys by creation time in ascending order *)
514
 
    let subkeys = 
515
 
      List.map ~f:(fun (uid,siginfo) -> 
516
 
                     (uid,sort_siginfo_list siginfo)) subkeys
 
517
    let subkeys =
 
518
      List.map ~f:(fun (uid,siginfo) ->
 
519
                     (uid,sort_siginfo_list siginfo)) subkeys
517
520
    in
518
521
 
519
522
    let pki = ParsePGP.parse_pubkey_info pubkey in
547
550
  with
548
551
    | Sys.Break | Eventloop.SigAlarm as e -> raise e
549
552
    | e ->
550
 
        eplerror 2 e
551
 
          "Unable to print key from query '%s'"
552
 
          (String.concat ~sep:" " request.search);
553
 
        []
 
553
        eplerror 2 e
 
554
          "Unable to print key from query '%s'"
 
555
          (String.concat ~sep:" " request.search);
 
556
        []
554
557
 
555
558
 
556
559
(********************************************************************)
562
565
    | 0x20 | 0x28 | 0x30 -> true
563
566
    | _ -> false
564
567
 
565
 
let is_revoked key = 
 
568
let is_revoked key =
566
569
  let pkey = KeyMerge.key_to_pkey key in
567
570
  let selfsigs = pkey.KeyMerge.selfsigs in
568
 
  List.exists ~f:(fun sign -> 
 
571
  List.exists ~f:(fun sign ->
569
572
                   sig_is_revok (sig_to_siginfo sign)
570
573
                 )
571
574
    selfsigs
572
575
 
573
576
(** oldstyle index lines *)
574
 
let key_to_lines_normal request key hash = 
 
577
let key_to_lines_normal request key hash =
575
578
  try
576
579
    let pkey = KeyMerge.key_to_pkey key in
577
580
    let uids = List.map ~f:convert_sigpair pkey.KeyMerge.uids in
580
583
    let keyid = meta.Fingerprint.keyid in
581
584
    let keyid_short = Fingerprint.keyid_to_string ~short:true keyid in
582
585
    let keyid_long = Fingerprint.keyid_to_string ~short:false keyid in
583
 
    let link = HtmlTemplates.link ~op:"get" ~hash:false ~fingerprint:false 
584
 
                 ~keyid:keyid_long in
585
 
    let ilink = HtmlTemplates.link ~op:"vindex" 
586
 
                  ~hash:request.hash ~fingerprint:request.fingerprint 
587
 
                  ~keyid:keyid_long in
 
586
    let link = HtmlTemplates.link ~op:"get" ~hash:false ~fingerprint:false
 
587
                 ~keyid:keyid_long in
 
588
    let ilink = HtmlTemplates.link ~op:"vindex"
 
589
                  ~hash:request.hash ~fingerprint:request.fingerprint
 
590
                  ~keyid:keyid_long in
588
591
 
589
592
    let uids = move_primary_to_front ~keyid uids in
590
593
 
591
 
    let userids = 
592
 
      List.map ~f:(fun (uid,sigs) -> 
593
 
                     match uid.packet_type with
594
 
                         User_ID_Packet -> 
595
 
                           HtmlTemplates.html_quote uid.packet_body
596
 
                       | User_Attribute_Packet -> "[user attribute packet]"
597
 
                       | _ -> "[unexpected packet type]"
598
 
                  )
599
 
        uids 
 
594
    let userids =
 
595
      List.map ~f:(fun (uid,sigs) ->
 
596
                     match uid.packet_type with
 
597
                         User_ID_Packet ->
 
598
                           HtmlTemplates.html_quote uid.packet_body
 
599
                       | User_Attribute_Packet -> "[user attribute packet]"
 
600
                       | _ -> "[unexpected packet type]"
 
601
                  )
 
602
        uids
600
603
    in
601
604
    let userids = match userids with [] -> []
602
605
      | hd::tl -> (sprintf "<a href=\"%s\">%s</a>" ilink hd)::tl in
603
606
    let pki = ParsePGP.parse_pubkey_info (List.hd key) in
604
 
    let keystr = HtmlTemplates.keyinfo_pks pki (is_revoked key) 
605
 
                   ~keyid:keyid_short ~link ~userids in
 
607
    let keystr = HtmlTemplates.keyinfo_pks pki (is_revoked key)
 
608
                    ~keyid:keyid_short ~link ~userids in
606
609
    let lines = [] in
607
 
    let lines = 
 
610
    let lines =
608
611
      if request.fingerprint then
609
 
        let fingerprint = HtmlTemplates.fingerprint 
610
 
                            ~fp:(Fingerprint.fp_to_string 
611
 
                                   (meta.Fingerprint.fp))
612
 
        in
613
 
        fingerprint::lines
 
612
        let fingerprint = HtmlTemplates.fingerprint
 
613
                            ~fp:(Fingerprint.fp_to_string
 
614
                                   (meta.Fingerprint.fp))
 
615
        in
 
616
        fingerprint::lines
614
617
      else
615
 
        lines
 
618
        lines
616
619
    in
617
 
    let lines = 
 
620
    let lines =
618
621
      if request.hash then
619
 
        let hash = HtmlTemplates.hash ~hash:(KeyHash.hexify hash) in
620
 
        hash::lines
621
 
      else 
622
 
        lines
 
622
        let hash = HtmlTemplates.hash ~hash:(KeyHash.hexify hash) in
 
623
        hash::lines
 
624
      else
 
625
        lines
623
626
    in
624
627
    let lines =
625
 
        keystr::lines
 
628
        keystr::lines
626
629
    in
627
630
    "</pre><hr /><pre>"::lines
628
631
  with
629
632
    | Sys.Break | Eventloop.SigAlarm as e -> raise e
630
633
    | e ->
631
 
        eplerror 2 e 
632
 
          "Unable to print key from query '%s'"
633
 
          (String.concat ~sep:" " request.search);
634
 
        []
 
634
        eplerror 2 e
 
635
          "Unable to print key from query '%s'"
 
636
          (String.concat ~sep:" " request.search);
 
637
        []
635
638
 
636
639