File: update_subkeys.ml

package info (click to toggle)
sks 1.1.6-14
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 2,296 kB
  • sloc: ml: 15,228; ansic: 1,069; sh: 358; makefile: 347
file content (143 lines) | stat: -rw-r--r-- 5,070 bytes parent folder | download | duplicates (7)
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
(***********************************************************************)
(* update_subkeys.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 Printf
open Arg
open Common
module Set = PSet.Set
module Map = PMap.Map
module Unix = UnixLabels
open Packet
open Bdb

let settings = {
  Keydb.withtxn = !Settings.transactions;
  Keydb.cache_bytes = !Settings.cache_bytes;
  Keydb.pagesize = !Settings.pagesize;
  Keydb.keyid_pagesize = !Settings.keyid_pagesize;
  Keydb.meta_pagesize = !Settings.meta_pagesize;
  Keydb.subkeyid_pagesize = !Settings.subkeyid_pagesize;
  Keydb.time_pagesize = !Settings.time_pagesize;
  Keydb.tqueue_pagesize = !Settings.tqueue_pagesize;
  Keydb.word_pagesize = !Settings.word_pagesize;
  Keydb.dbdir = Lazy.force Settings.dbdir;
  Keydb.dumpdir = Lazy.force Settings.dumpdir;
}

(** we need full keydb access because we're playing directly with
  databases and cursors and such
*)
module Keydb = Keydb.Unsafe

type update = { keyid: string;
                hash: string;
              }

let ( |= ) map key = Map.find key map
let ( |< ) map (key,data) = Map.add ~key ~data map

let at_once = match !Settings.n with
    0 -> 10000
  | n -> n * 1000

let subkeyids_from_key key =
  let (keyid,subkey_keyids) = Fingerprint.keyids_from_key ~short:true key in
  subkey_keyids

(** returns a copy of the list without duplicates in sorted order *)
let sort_dedup list =
  let list = List.sort ~cmp:(fun x y -> compare y x) list in
  let rec dedup list partial = match list with
    | [] -> partial
    | hd::[] -> dedup [] (hd::partial)
    | hd1::hd2::tl ->
        if hd1 = hd2 then dedup (hd2::tl) partial
        else dedup (hd2::tl) (hd1::partial)
  in
  dedup list []


(** takes a list of updates and applies them to the database *)
let apply_updates updates =
  let dbs = Keydb.get_dbs () in
  perror "%d updates found.  Applying to database" (List.length updates);
  let updates = sort_dedup updates  in
  let txn = Keydb.txn_begin () in
  try
    List.iter ~f:(fun update ->
                    try Db.put ?txn dbs.Keydb.subkey_keyid ~key:update.keyid
                      ~data:update.hash [Db.NODUPDATA]
                    with
                        Key_exists -> ()
                 )
      updates;
    Keydb.txn_commit txn;
    perror "Application of updates complete."
  with
    | Bdb.DBError s as e ->
        eplerror 0 e "Fatal database error";
        raise Sys.Break
    | e ->
        eplerror 1 e "apply_md_updates failed -- aborting txn";
        Keydb.txn_abort txn;
        raise e

(** iterate through the database, extracting updates that need to be
  applied and applies them *)
let fix_keyids () =
  perror "Beginning subkeyid update process";
  let updates = ref [] in
  let ctr = ref 0 in

  let process_key ~hash ~key =
    let subkeyids = subkeyids_from_key key in
    let new_updates =
      List.map subkeyids
        ~f:(fun subkeyid -> { keyid = subkeyid; hash = hash })
    in
    updates := List.rev_append new_updates !updates;
    ctr := !ctr + List.length new_updates;
    if !ctr >= at_once then (
      apply_updates !updates;
      ctr := 0;
      updates := []
    )
  in
  Keydb.iter process_key;
  (* need one more call to apply_updates to add the final batch *)
  apply_updates !updates

let run () =
  set_logfile "update_subkeys";
  perror "Running SKS %s%s" Common.version Common.version_suffix;
  Keydb.open_dbs settings;
  perror "Keydb opened";

  fix_keyids ();
  perror "Subkey update complete. Checkpointing database.";
  Keydb.checkpoint ();
  perror "Checkpoint complete.  Closing.";
  Keydb.close_dbs ();
  perror "Database closed.";