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. creation 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);
[]
|