Source

sks-keyserver-with-async / index.ml

Full commit
  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
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
(***********************************************************************)
(* index.ml - code for generating pretty PGP key indices               *)
(*                                                                     *)
(* 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 Printf
open Common
open Packet
open Request
open Pstyle

module Map = PMap.Map

(********************************************************************)

type siginfo = { mutable userid: string option;
                 mutable policy_url: string option;
                 mutable notation_data: (string * string) option;
                 mutable revocation_key: string option;
                 mutable is_primary_uid: bool;
                 mutable keyid: string option;
                 mutable sigtype: int;
                 mutable sig_creation_time: int64 option;
                 mutable sig_expiration_time: int64 option;
                 mutable key_expiration_time: int64 option;
               }

(********************************************************************)

let empty_siginfo () =
  { userid = None;
    policy_url = None;
    notation_data = None;
    revocation_key = None;
    is_primary_uid = false;
    keyid = None;
    sigtype = 0;
    sig_creation_time = None;
    sig_expiration_time = None;
    key_expiration_time = None;
  }

(********************************************************************)

let keyinfo_header request =
  if request.kind = VIndex then
    "Type bits/keyID     cr. time   exp time   key expir"
  else
    HtmlTemplates.keyinfo_header

(********************************************************************)

let sig_to_siginfo sign =
  let siginfo = empty_siginfo () in
  begin
    match ParsePGP.parse_signature sign with
      | V3sig s ->
          siginfo.sigtype <- s.v3s_sigtype;
          siginfo.keyid <- Some s.v3s_keyid;
          siginfo.sig_creation_time <- Some s.v3s_ctime
      | V4sig s ->
          let update_siginfo ssp =
            match ssp.ssp_type with

              | 2 -> (* sign. expiration time *)
                  if ssp.ssp_length = 4 then
                    siginfo.sig_creation_time <-
                    Some (ParsePGP.int64_of_string ssp.ssp_body)

              | 3 -> (* sign. expiration time *)
                  if ssp.ssp_length = 4 then
                    siginfo.sig_expiration_time <-
                    let exp = ParsePGP.int64_of_string ssp.ssp_body in
                    if Int64.compare exp Int64.zero = 0
                    then None else Some exp

              | 9 -> (* key expiration time *)
                  if ssp.ssp_length = 4 then
                    siginfo.key_expiration_time <-
                    let exp = ParsePGP.int64_of_string ssp.ssp_body in
                    if Int64.compare exp Int64.zero = 0
                    then None else Some exp

              | 12 -> (* revocation key *)
                  let cin = new Channel.string_in_channel ssp.ssp_body 0 in
                  let _revclass = cin#read_int_size 1 in
                  let _algid = cin#read_int_size 1 in
                  let fingerprint = cin#read_string 20 in
                  siginfo.revocation_key <- Some fingerprint

              | 16 -> (* issuer keyid *)
                  if ssp.ssp_length = 8 then
                    siginfo.keyid <- Some ssp.ssp_body
                  else
                    printf "Argh!  that makes no sense: %d\n" ssp.ssp_length

              | 20 -> (* notation data *)
                  let cin = new Channel.string_in_channel ssp.ssp_body 0 in
                  let flags = cin#read_string 4 in
                  let name_len = cin#read_int_size 2 in
                  let value_len = cin#read_int_size 2 in
                  let name_data = cin#read_string name_len in
                  let value_data = cin#read_string value_len in

                  if Char.code flags.[0] = 0x80 then
                    (* human-readable notation data *)
                    siginfo.notation_data <- Some (name_data,value_data)

              | 25 -> (* primary userid (bool) *)
                  if ssp.ssp_length = 1 then
                    let v = int_of_char ssp.ssp_body.[0] in
                    siginfo.is_primary_uid <- v <> 0

              | 26 -> (* policy URL *)
                  siginfo.policy_url <- Some ssp.ssp_body

              | 28 -> (* signer's userid *)
                  siginfo.userid <- Some ssp.ssp_body

              | _ -> (* miscellaneous other packet *)
                  ()
          in
          siginfo.sigtype <- s.v4s_sigtype;
          List.iter (s.v4s_hashed_subpackets @ s.v4s_unhashed_subpackets)
            ~f:(fun ssp -> try update_siginfo ssp with End_of_file -> ())
  end;
  siginfo

(********************************************************************)

(** sort signatures in ascending time order *)
let sort_siginfo_list list =
  List.stable_sort list
    ~cmp:(fun x y -> compare x.sig_creation_time y.sig_creation_time)

(********************************************************************)

let is_selfsig ~keyid siginfo = siginfo.keyid = Some keyid

(********************************************************************)

let is_primary ~keyid (uid,siginfo_list) =
  List.exists ~f:(fun siginfo ->
                    is_selfsig ~keyid siginfo
                    && siginfo.is_primary_uid
                    && uid.packet_type = User_ID_Packet
                 )
    siginfo_list

(********************************************************************)

(** returns time of most recent self-sig on uid *)
let max_selfsig_time ~keyid (uid,siginfo_list) =
  let selfsigs = List.filter ~f:(fun si -> is_selfsig ~keyid si)
                   siginfo_list in
  let times = filter_opts
                (List.map selfsigs
                   ~f:(function x -> match x.sig_creation_time with
                           None -> None
                         | Some time -> Some (Int64.to_float time)))
  in
  List.fold_left ~init:min_float ~f:max times

(********************************************************************)

let split_list ~f l =
  let rec loop l a b = match l with
      [] -> (List.rev a, List.rev b)
    | hd::tl ->
        if f hd then loop tl (hd::a) b
        else loop tl a (hd::b)
  in
  loop l [] []

(********************************************************************)

let move_primary_to_front ~keyid uids =
  let (primary,normal) = split_list ~f:(is_primary ~keyid) uids in
  let primary = List.stable_sort primary
               ~cmp:(fun x y -> compare
                       (max_selfsig_time ~keyid y)
                       (max_selfsig_time ~keyid x)
                    )
  in
  primary @ normal

(********************************************************************)

let convert_sigpair (uid,sigs) =
  (uid,List.map ~f:sig_to_siginfo sigs)

(********************************************************************)

let blank_datestr = "__________"
let no_datestr =    "          "
let datestr_of_int64 i =
  let tm = Unix.gmtime (Int64.to_float i) in
  sprintf "%04d-%02d-%02d" (1900 + tm.Unix.tm_year) (1 + tm.Unix.tm_mon)
    (tm.Unix.tm_mday)

(********************************************************************)

let siginfo_to_lines ~get_uid ?key_creation_time request self_keyid today siginfo =

  let sig_creation_string = match siginfo.sig_creation_time with
    | None -> blank_datestr
    | Some time -> datestr_of_int64 time
  in

  let key_expiration_string =
    match (key_creation_time,
           siginfo.key_expiration_time)
    with
    | (None,_) | (_,None) -> blank_datestr
    | (Some x,Some y) -> datestr_of_int64 (Int64.add x y)
  in

  let sig_expiration_string =
    match (siginfo.sig_creation_time,
           siginfo.sig_expiration_time)
    with
    | (None,_) | (_,None) -> blank_datestr
    | (Some x,Some y) -> datestr_of_int64 (Int64.add x y)
  in

  let sig_expired =
    match (siginfo.sig_creation_time,
           siginfo.sig_expiration_time)
    with
    | (None,_) | (_,None) -> false
    | (Some x,Some y) -> (Int64.to_float (Int64.add x y)) < today
  in

  let sigtype_string =
    match siginfo.sigtype with
      | 0x10 ->
         if sig_expired then "<span class=\"warn\"> exp  </span>"
         else " sig  "
      | 0x11 ->
         if sig_expired then "<span class=\"warn\"> exp1 </span>"
         else " sig1 "
      | 0x12 ->
         if sig_expired then "<span class=\"warn\"> exp2 </span>"
         else " sig2 "
      | 0x13 ->
         if sig_expired then "<span class=\"warn\"> exp3 </span>"
         else " sig3 "
      | 0x20 | 0x28 | 0x30 -> "<span class=\"warn\">revok </span>"
      | 0x1f -> "dirct "
      | 0x18 -> "sbind "
      | x -> sprintf " 0x%02x" x
  in

  let uid_string = match siginfo.userid with
    | Some s -> s
    | None ->
        if Some self_keyid = siginfo.keyid then "[selfsig]"
        else
          match apply_opt get_uid siginfo.keyid with
            | None | Some None -> "[]"
            | Some (Some uid) -> uid
  in
  let uid_string = HtmlTemplates.html_quote uid_string in
  let uid_string = match siginfo.keyid with
      None -> uid_string
    | Some keyid ->
        if uid_string = "" then ""
        else
          let long = Fingerprint.keyid_to_string ~short:false keyid in
          let link =
            HtmlTemplates.link ~op:"vindex"
              ~hash:request.hash ~fingerprint:request.fingerprint ~keyid:long
          in
          sprintf "<a href=\"%s\">%s</a>" link uid_string
  in

  let keyid_string = match siginfo.keyid with
    | Some keyid ->
        let short = Fingerprint.keyid_to_string ~short:true keyid in
        let long = Fingerprint.keyid_to_string ~short:false keyid in
        let link =
          HtmlTemplates.link ~op:"get"
            ~hash:request.hash ~fingerprint:request.fingerprint ~keyid:long
        in
        sprintf "<a href=\"%s\">%s</a>" link short
    | None ->
        "no keyid"
  in

  let firstline = sprintf "sig %-6s %s %s %s %s %s"
                    sigtype_string keyid_string
                    sig_creation_string sig_expiration_string
                    key_expiration_string
                    uid_string
  in

  let policy_url_opt =
    apply_opt siginfo.policy_url
      ~f:(fun policy_url ->
            let policy_url = HtmlTemplates.html_quote policy_url in
            sprintf "    Policy URL: <a href=\"%s\">%s</a>"
              policy_url policy_url
         )
  in
  let notation_data_opt =
    apply_opt siginfo.notation_data
      ~f:(fun (name,value) ->
              sprintf "    Notation data: <span class=\"text-decoration: underline;\">%s</span> %s"
            (HtmlTemplates.html_quote name)
            (HtmlTemplates.html_quote value)
         )
  in
  let revocation_key_opt =
    apply_opt siginfo.revocation_key
      ~f:(fun fingerprint ->
            sprintf "    Revocation key fingerprint: <a href=\"%s\">%s</a>"
            (HtmlTemplates.link ~hash:request.hash ~op:"vindex"
               ~fingerprint:request.fingerprint
               ~keyid:(Utils.hexstring fingerprint)
            )
            (Fingerprint.fp_to_string fingerprint)
         )
  in
  firstline :: filter_opts [policy_url_opt; notation_data_opt;
                            revocation_key_opt]


(********************************************************************)

let selfsigs_to_lines request key_creation_time keyid selfsigs today =
  let lines =
    List.map ~f:(fun sign -> siginfo_to_lines ~get_uid:(fun _ -> None)
                   ~key_creation_time request keyid today
                   (sig_to_siginfo sign))
      selfsigs
  in
  List.concat lines

(********************************************************************)

let uid_to_lines ~get_uid request key_creation_time keyid today
  (uid,siginfo_list) =
  let siginfo_list = sort_siginfo_list siginfo_list in
  let uid_line = match uid.packet_type with
    | User_ID_Packet ->
        sprintf "<strong>uid</strong> <span class=\"uid\">%s</span>"
        (HtmlTemplates.html_quote uid.packet_body)

    | _ -> sprintf "<strong>uat</strong> [contents omitted]"
  in
  let siginfo_lines =
    List.concat
      (List.map ~f:(siginfo_to_lines ~get_uid ~key_creation_time
                    request keyid today)
         siginfo_list)
  in
  ""::uid_line::siginfo_lines

let uids_to_lines ~get_uid request key_creation_time keyid uids today =
  List.concat
    (List.map ~f:(uid_to_lines ~get_uid request key_creation_time keyid today) uids)

(********************************************************************)

let key_packet_to_line ~is_subkey pki keyid =
  let prefix = if is_subkey then "<strong>sub</strong>" else "<strong>pub</strong>" in
  let creation_string = datestr_of_int64 pki.pk_ctime in
  let expiration_string =
    if pki.pk_version = 4 then no_datestr
    else
      match pki.pk_expiration with
        | None -> blank_datestr
        | Some days ->
            let time = Int64.add (Int64.of_int (days * 24 * 60 * 60))
                         pki.pk_ctime in
            datestr_of_int64 time
  in
  let keyid = keyid in
  let keyid_short = Fingerprint.keyid_to_string ~short:true keyid in
  let keyid_long = Fingerprint.keyid_to_string ~short:false keyid in

  let keyid_string =
    if is_subkey then sprintf "%8s" keyid_short
    else
      sprintf "<a href=\"%s\">%8s</a>"
        (HtmlTemplates.link ~op:"get" ~hash:false ~fingerprint:false
           ~keyid:keyid_long )
        keyid_short
  in
  let algo = pk_alg_to_ident pki.pk_alg in
  let line = sprintf "%s  %4d%s/%s %s %s "
               prefix
               pki.pk_keylen algo
               keyid_string
               creation_string expiration_string
  in
  (line,keyid)

(********************************************************************)

let subkey_to_lines request today (subkey,siginfo_list) =
  let pki = ParsePGP.parse_pubkey_info subkey in
  let keyid = (Fingerprint.from_packet subkey).Fingerprint.keyid in
  let (subkey_line,keyid) = key_packet_to_line ~is_subkey:true pki keyid in
  let key_creation_time = pki.pk_ctime in
  let siginfo_lines =
    List.concat (List.map ~f:(siginfo_to_lines ~get_uid:(fun _ -> None)
                                ~key_creation_time request keyid today)
                   siginfo_list)
  in
  ""::subkey_line::siginfo_lines

let subkeys_to_lines request subkeys today =
  List.concat (List.map ~f:(subkey_to_lines request today) subkeys)

(********************************************************************)
(* new style verbose key index **************************************)
(********************************************************************)

(** if f is true for any element of list, then return (Some x,newlist), where
  x is one such element, and newlist is list with x removed.  Otherwise,
  return (None,list)
*)
let rec extract ~f list = match list with
    [] -> (None,[])
  | hd::tl ->
      if f hd then (Some hd,tl)
      else let (x,new_tl) =  extract ~f tl in (x,hd::new_tl)

(** if there is an element in list for which f returns true, then return list
  with one such element moved to the front. *)
let move_to_front ~f list =
  match extract ~f list with
    | (None,list) -> list
    | (Some x,list) -> x::list

(********************************************************************)

(** fetches UID from keyid, stopping fater first [max_uid_fetches] *)
let get_uid get_uids =
  let ctr = ref 0 in
  (fun keyid ->
     try
       incr ctr;
       if !ctr > !Settings.max_uid_fetches then None
       else
         let uids = get_uids keyid in
         let uids = List.filter uids
                      ~f:(fun (uid,_) -> uid.packet_type = User_ID_Packet) in
         let uids = List.map ~f:convert_sigpair uids in
         match move_primary_to_front ~keyid uids with
           | [] -> None
           | (uid,_)::tl -> Some uid.packet_body
     with
       | e ->
           eplerror 3 e
             "Error fetching uid during VIndex for keyid 0x%s"
             (KeyHash.hexify keyid);
           None
  )

(********************************************************************)

(** computes fingerprint and hash lines if required *)
let get_extra_lines request key hash meta =

  let extra_lines =
    if request.fingerprint then
      [HtmlTemplates.fingerprint ~fp:(Fingerprint.fp_to_string
                                        meta.Fingerprint.fp)]
    else []
  in

  let extra_lines =
    if request.hash then
      let hash_line = HtmlTemplates.hash ~hash:(KeyHash.hexify hash) in
      hash_line::extra_lines
    else
      extra_lines
  in

  extra_lines

(********************************************************************)

(** computes key to verbose set of lines.  Note that these lines should be
  embedded inside of a <pre></pre> environment *)
let key_to_lines_verbose ~get_uids request key hash =
  try
    let get_uid = get_uid get_uids in
    let pkey = KeyMerge.key_to_pkey key in
    let selfsigs = pkey.KeyMerge.selfsigs
    and uids = List.map ~f:convert_sigpair pkey.KeyMerge.uids
    and subkeys = List.map ~f:convert_sigpair pkey.KeyMerge.subkeys
    and pubkey = pkey.KeyMerge.key in

    (* sort subkeys by creation time in ascending order *)
    let subkeys =
      List.map ~f:(fun (uid,siginfo) ->
                     (uid,sort_siginfo_list siginfo)) subkeys
    in

    let pki = ParsePGP.parse_pubkey_info pubkey in
    let meta = Fingerprint.from_packet pubkey in
    let keyid = meta.Fingerprint.keyid in
    let key_creation_time = pki.pk_ctime in

    let today = Stats.round_up_to_day (Unix.gettimeofday ()) in


    (** move primary keyid to front of the list *)
    let uids = move_primary_to_front ~keyid uids in

    (* let primary_uid_string = (fst (List.hd uids)).packet_body in *)
    let (pubkey_line,keyid) =
      key_packet_to_line ~is_subkey:false pki keyid in

    let extra_lines = get_extra_lines request key hash meta in

    (* note: ugly hack here. </pre> and <pre> are used to allow for an <hr>
       inside of a pre-formatted region.  So this code only works if the
       lines are being generated to be put inside of a <pre></pre> block> *)
    ("</pre><hr /><pre>" ^ pubkey_line) ::
    List.concat [
      selfsigs_to_lines request key_creation_time keyid selfsigs today;
      extra_lines;
      uids_to_lines ~get_uid request key_creation_time keyid uids today;
      subkeys_to_lines request subkeys today;
    ]

  with
    | Sys.Break | Eventloop.SigAlarm as e -> raise e
    | e ->
        eplerror 2 e
          "Unable to print key from query '%s'"
          (String.concat ~sep:" " request.search);
        []


(********************************************************************)
(* old style key index **********************************************)
(********************************************************************)

let sig_is_revok siginfo =
  match siginfo.sigtype with
    | 0x20 | 0x28 | 0x30 -> true
    | _ -> false

let is_revoked key =
  let pkey = KeyMerge.key_to_pkey key in
  let selfsigs = pkey.KeyMerge.selfsigs in
  List.exists ~f:(fun sign ->
                   sig_is_revok (sig_to_siginfo sign)
                 )
    selfsigs

(** oldstyle index lines *)
let key_to_lines_normal request key hash =
  try
    let pkey = KeyMerge.key_to_pkey key in
    let uids = List.map ~f:convert_sigpair pkey.KeyMerge.uids in

    let meta = Fingerprint.from_key key in
    let keyid = meta.Fingerprint.keyid in
    let keyid_short = Fingerprint.keyid_to_string ~short:true keyid in
    let keyid_long = Fingerprint.keyid_to_string ~short:false keyid in
    let link = HtmlTemplates.link ~op:"get" ~hash:false ~fingerprint:false
                 ~keyid:keyid_long in
    let ilink = HtmlTemplates.link ~op:"vindex"
                  ~hash:request.hash ~fingerprint:request.fingerprint
                  ~keyid:keyid_long in

    let uids = move_primary_to_front ~keyid uids in

    let userids =
      List.map ~f:(fun (uid,sigs) ->
                     match uid.packet_type with
                         User_ID_Packet ->
                           HtmlTemplates.html_quote uid.packet_body
                       | User_Attribute_Packet -> "[user attribute packet]"
                       | _ -> "[unexpected packet type]"
                  )
        uids
    in
    let userids = match userids with [] -> []
      | hd::tl -> (sprintf "<a href=\"%s\">%s</a>" ilink hd)::tl in
    let pki = ParsePGP.parse_pubkey_info (List.hd key) in
    let keystr = HtmlTemplates.keyinfo_pks pki (is_revoked key)
                    ~keyid:keyid_short ~link ~userids in
    let lines = [] in
    let lines =
      if request.fingerprint then
        let fingerprint = HtmlTemplates.fingerprint
                            ~fp:(Fingerprint.fp_to_string
                                   (meta.Fingerprint.fp))
        in
        fingerprint::lines
      else
        lines
    in
    let lines =
      if request.hash then
        let hash = HtmlTemplates.hash ~hash:(KeyHash.hexify hash) in
        hash::lines
      else
        lines
    in
    let lines =
        keystr::lines
    in
    "</pre><hr /><pre>"::lines
  with
    | Sys.Break | Eventloop.SigAlarm as e -> raise e
    | e ->
        eplerror 2 e
          "Unable to print key from query '%s'"
          (String.concat ~sep:" " request.search);
        []