File: merge_keyfiles.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 (153 lines) | stat: -rw-r--r-- 5,432 bytes parent folder | download | duplicates (5)
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
(***********************************************************************)
(* merge_keyfiles.ml - Executable: Adds keys from key files to         *)
(*                     existing database.                              *)
(*                                                                     *)
(* 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/>.                          *)
(***********************************************************************)

module F(M:sig end) =
struct
  open StdLabels
  open MoreLabels
  open Printf
  open Arg
  open Common
  module Set = PSet.Set
  open Packet

  let settings = {
    Keydb.withtxn = false;
    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;
  }

  module Keydb = Keydb.Safe

  let n = match !Settings.n with 0 -> 1 | x -> x
  let maxkeys = n * 15000
  let fnames = List.filter ~f:(fun x -> x <> "") (List.rev !Settings.anonlist)

  let timestr sec =
    sprintf "%.2f min" (sec /. 60.)

  (* ******************************************************************** *)
  (** data type and functions for dealing with collection of files as
    one big stream *)

  type keydump_stream =
      { getkey: unit -> packet list;
        current: in_channel;
        fnames: string list;
        ctr: int;
      }

  let create_keydump_stream ctr fnames =
    match fnames with
      | [] -> raise End_of_file
      | hd::tl ->
          let file = open_in hd in
          let cin = new Channel.sys_in_channel file in
          let getkey = Key.get_of_channel cin in
          { getkey = getkey;
            current = file;
            fnames = tl;
            ctr = ctr;
          }

  let rec get_key stream =
    try (!stream).getkey ()
    with Not_found | End_of_file ->
      close_in (!stream).current;
      stream := create_keydump_stream ((!stream).ctr + 1) (!stream).fnames;
      get_key stream

  let create_keydump_stream fnames = ref (create_keydump_stream 0 fnames)

  let lpush el list = list := el::!list

  let get_n_keys stream n =
    let data = ref [] in
    (try
       for i = 1 to n do
         lpush (get_key stream) data
       done
     with
         End_of_file ->
           stream := { !stream with getkey = (fun () -> raise End_of_file) }
    );
    !data

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

  let dbtimer = MTimer.create ()
  let timer = MTimer.create ()
  let run () =
    set_logfile "merge";
        perror "Running SKS %s%s" Common.version Common.version_suffix;
    if not (Sys.file_exists (Lazy.force Settings.dbdir)) then (
      printf "No existing KeyDB database.  Exiting.\n";
      exit (-1)
    );

    Keydb.open_dbs settings;
    if fnames = [] then failwith "No files provided";
    let finished = ref false in
    let stream = create_keydump_stream fnames in
    try
      protect
        ~f:(fun () ->
              while not !finished do

                MTimer.start timer;

                printf "Loading keys...\n"; flush stdout;
                let keys = get_n_keys stream maxkeys in
                if keys = [] then raise Exit;
                printf "   %d keys loaded, %d files left\n"
                  (List.length keys) (List.length !stream.fnames);
                flush stdout;

                MTimer.start dbtimer;
                Keydb.add_keys_merge keys;
                MTimer.stop dbtimer;

                MTimer.stop timer;

                printf "   DB time:  %s.  Total time: %s.\n"
                  (timestr (MTimer.read dbtimer))
                  (timestr (MTimer.read timer));
                flush stdout;
              done
           )
        ~finally:(fun () ->
                    perror "closing database...";
                    Keydb.close_dbs ();
                    perror "...database closed";
                 )
    with
        Exit -> ()
end