Source

sks-keyserver-with-async / dbserver.ml

  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
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
(***********************************************************************)
(* dbserver.ml - Executable: server process that handles database and  *)
(*               database queries.                                     *)
(*                                                                     *)
(* 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 Common
  open Packet
  module Unix = UnixLabels
  open Unix
  open DbMessages
  open Request
  open Pstyle
  open Sys

  let () =
    set_logfile "db";
    plerror 0 "sks_db, SKS version %s%s" version version_suffix;
    plerror 0 "Using BerkelyDB version %s" (Bdb.version(););
    plerror 0 "Copyright Yaron Minsky 2002, 2003, 2004";
    plerror 0 "Licensed under GPL. See LICENSE file for details";
    plerror 3 "http port: %d" http_port

  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;
  }
  module Keydb = Keydb.Safe

  (* Simple server code for handling DB requests.  This is the main control
     code for the DB. *)

  let withtxn = !Settings.transactions
  let dbdir = Lazy.force Settings.dbdir
  let () =
    if not withtxn then
      failwith "Running sks_db without transactions is no longer supported."

  let websocks =
    List.map ~f:Eventloop.create_sock
      ((if !Settings.use_port_80 then make_addr_list http_address 80 else [])
       @ make_addr_list http_address http_port)

  let () =
    if Sys.file_exists db_command_name
    then Unix.unlink db_command_name
  let comsock = Eventloop.create_sock db_command_addr


  (*********************************************************************)
  (** Database checkpointing and syncing *)

  let sync () =
    perror "Syncing database";
    Keydb.sync ();
    perror "Syncing complete"

  let sync_interval = !Settings.db_sync_interval

  let checkpoint () =
    perror "Checkpointing database";
    Keydb.checkpoint ();
    perror "Checkpointing complete"

  let checkpoint_interval = !Settings.checkpoint_interval

  (***************************************************************)
  (*  Helper functions for http request handler   ****************)
  (***************************************************************)

  let ascending = compare
  let descending x y = compare y x

  (** sorts keys by time, dropping keys with no time *)
  let tsort_keys keys =
    let kpairs =
      List.fold_left ~init:[] keys
        ~f:(fun list key ->
              try
                let ki = ParsePGP.parse_pubkey_info (List.hd key) in
                (ki.pk_ctime,key)::list
              with
                | Sys.Break as e -> raise e
                | e -> list
           )
    in
    let kpairs = List.sort ~cmp:descending kpairs in
    List.map ~f:snd kpairs

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

  let get_stats () =
    let today = Stats.round_up_to_day (Unix.gettimeofday ()) in
    let log =
      let maxsize = 90000 in
      let last_month = today -. (31. *. 24. *. 60. *. 60.) in
      Keydb.reverse_logquery ~maxsize last_month
    in
    let size = Keydb.get_num_keys () in
    (log,size)

  let last_stat_page = ref (Stats.generate_html_stats_page_nostats ())

  let calculate_stats_page () =
    plerror 3 "Calculating DB stats";
    let (log,size) = get_stats () in
    last_stat_page := Stats.generate_html_stats_page log size;
    plerror 3 "Done calculating DB stats";
    []

  let get_keys_by_keyid keyid =
    let keyid_length = String.length keyid in
    let short_keyid = String.sub ~pos:(keyid_length - 4) ~len:4 keyid in
    let keys = Keydb.get_by_short_subkeyid short_keyid in
    match keyid_length with
      | 4 -> (* 32-bit keyid.  No further filtering required. *)
          keys

      | 8 -> (* 64-bit keyid *)
          List.filter keys
          ~f:(fun key -> keyid = (Fingerprint.from_key key).Fingerprint.keyid ||
          (** Return keys i& subkeys with matching long keyID *)
             let (mainkeyid,subkeyids) = Fingerprint.keyids_from_key ~short:false key in
             List.exists (fun x -> x = keyid) subkeyids)

      | 20 -> (* 160-bit v. 4 fingerprint *)
          List.filter keys
          ~f:(fun key -> keyid = (Fingerprint.from_key key).Fingerprint.fp ||
          (** Return keys & subkeys with matching fingerprints *)
              let (mainkeyfp,subkeyfps) = Fingerprint.fps_from_key key in
              List.exists (fun x -> x = keyid) subkeyfps)

      | 16 -> (* 128-bit v3 fingerprint.  Not supported *)
          failwith "128-bit v3 fingerprints not implemented"

      | _ -> failwith "unknown keyid type"


  (** returns list of keys readied for presentation *)
  let clean_keys request keys =
    if request.clean
    then Utils.filter_map ~f:Fixkey.presentation_filter keys
    else keys

  (** return uid given keyid *)
  let get_uids request keyid =
    let keys = get_keys_by_keyid keyid in
    let keys = clean_keys request keys in
    match keys with
      | [] | _::_::_ -> []
      | key::tl ->
          let pkey = KeyMerge.key_to_pkey key in
          pkey.KeyMerge.uids

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

  let check_prefix string prefix =
    String.length string >= String.length prefix &&
    (String.sub ~pos:0 ~len:(String.length prefix) string = prefix)

  let lookup_keys search_terms =
    let keys =
      match search_terms with
        | [] -> []
        | first::rest ->
            if check_prefix first "0x" then
              (* keyid search *)
              let keyid_string_length = String.length first - 2 in
              let keyid =
                try
                  KeyHash.dehexify
                    (String.sub ~pos:2 ~len:keyid_string_length first)
                with                e ->
                  let exn_str = sprintf "Unable to parse hash string: %s"
                    (Printexc.to_string e) in
                  raise (Wserver.Misc_error exn_str)
              in
              let keys = (try get_keys_by_keyid keyid
                          with Failure s -> raise (Wserver.Misc_error s))
              in
              keys
            else
              let keys = Keydb.get_by_words ~max:!Settings.max_matches
                           search_terms
              in
              tsort_keys keys
    in
    if keys = [] then raise (Wserver.No_results "No keys found")
    else keys


  (******************************************************************)
  let truncate count keys =
    let rec trunc_c result orig num =
      match orig with
        | [] -> result
        | h::tail ->
            if (num = 0)
            then result
            else (trunc_c (result @ [h]) tail (num-1))
    in
    if count >= 0
    then trunc_c [] keys count
    else keys

  let handle_get_request request =
    match request.kind with
      | Stats ->
          plerror 4 "/pks/lookup: DB Stats request";
          ("text/html; charset=UTF-8", -1, !last_stat_page)
      | Get ->
          plerror 4 "/pks/lookup: Get request (%s)"
            (String.concat " " request.search);
          let keys = lookup_keys request.search in
          let keys = clean_keys request keys in
          let count = List.length keys in
          let keys = truncate request.limit keys in
          let aakeys =
            if keys = [] then ""
            else Armor.encode_pubkey_string (Key.to_string_multiple keys)
          in
          if request.machine_readable then
            ("application/pgp-keys; charset=UTF-8", count, aakeys)
          else
            ("text/html; charset=UTF-8",
             count,
             HtmlTemplates.page
               ~title:(sprintf "Public Key Server -- Get ``%s ''"
                         (String.concat ~sep:" " request.search))
               ~body:(sprintf "\r\n<pre>\r\n%s\r\n</pre>\r\n" aakeys)
            )
      | HGet ->
          let hash_str = List.hd request.search in
          plerror 4 "/pks/lookup: Hash search: %s" hash_str;
          let hash = KeyHash.dehexify hash_str in
          flush Pervasives.stdout;
          let key =
            try Keydb.get_by_hash hash with Not_found ->
              raise (Wserver.Misc_error "Requested hash not found")
          in
          let key =
            if request.clean then
              match Fixkey.presentation_filter key with
                  None -> raise (Wserver.Misc_error "No valid key found for hash")
                | Some key -> key
            else key
          in
          let keystr = Key.to_string key in
          let aakeys = Armor.encode_pubkey_string keystr in
          ("text/html; charset=UTF-8",
           1,
           HtmlTemplates.page
             ~title:(sprintf "Public Key Server -- Get ``%s ''" hash_str)
             ~body:(sprintf "\r\n<pre>\r\n%s\r\n</pre>\r\n" aakeys)
          )

      | Index | VIndex ->
          (* VIndex requests are treated indentically to index requests *)
          plerror 4 "/pks/lookup: Index request: (%s)"
            (String.concat " " request.search);
          let keys = lookup_keys request.search in
          let count = List.length keys in
          let keys = truncate request.limit keys in
          let keys = clean_keys request keys in
          let hashes = List.map ~f:KeyHash.hash keys in
          if request.machine_readable then
            ("text/plain",
             count,
             MRindex.keys_to_index keys)
          else
            begin
              try
                let output =
                  if request.kind = VIndex then
                    List.map2 keys hashes
                      ~f:(Index.key_to_lines_verbose
                            ~get_uids:(get_uids request) request)
                  else
                    List.map2 keys hashes
                      ~f:(Index.key_to_lines_normal request)
                in
                let output = List.flatten output in
                let pre = HtmlTemplates.preformat_list
                            (Index.keyinfo_header request :: output)
                in
                ("text/html; charset=UTF-8",
                 count,
                 HtmlTemplates.page ~body:pre
                   ~title:(sprintf "Search results for '%s'"
                             (String.concat ~sep:" " request.search))
                )

              with
                | Invalid_argument "Insufficiently specific words" ->
                    raise (Wserver.Misc_error
                             ("Insufficiently specific words: provide " ^
                              "at least one more specific keyword"))

                | Invalid_argument "Too many responses" ->
                    raise (Wserver.Misc_error
                             "Too many responses, unable to process query")
            end

  let string_to_oplist s =
    let s = Wserver.strip s in
    try
      let (base,op_string) = chsplit '?' s in
      let oplist = Str.split amp op_string in
      let pairs = List.map ~f:(chsplit '=') oplist in
      let oplist =
        List.map pairs
          ~f:(fun (key,value) -> (key, Wserver.decode value))
      in
      (base,oplist)
    with
        Not_found -> (s,[])

  let get_extension s =
    let pos = String.rindex s '.' in
    s </> (pos,0)

  let bool_to_string b = if b then "true" else "false"
  let print_request cout r =
    fprintf cout "   kind: %s\n" (
      (function
           Index -> "index" | VIndex -> "vindex" | Stats -> "stats"
         | Get -> "get" | HGet -> "hashget")
      r.kind);
    fprintf cout "   fingerprint: %s\n" (bool_to_string r.fingerprint);
    fprintf cout "   exact: %s\n" (bool_to_string r.exact);
    fprintf cout "   search: %s\n"
      (MList.to_string ~f:(fun x -> x) r.search)

  let get_keystrings_from_hashes hashes =
    let rec loop hashes keystrings = match hashes with
        [] -> keystrings
      | hash::tl ->
          try
            let keystring = Keydb.get_keystring_by_hash hash in
            loop tl (keystring::keystrings)
          with
              e ->
                eplerror 2 e "Error fetching key from hash %s"
                (KeyHash.hexify hash);
                loop tl keystrings
    in
    loop hashes []

  let read_file ?(binary=false) fname =
    if not (Sys.file_exists fname) then raise (Wserver.Page_not_found fname);
    let f = (if binary then open_in_bin else open_in) fname in
    protect ~f:(fun () ->
                  let length = in_channel_length f in
                  let buf = String.create length in
                  really_input f buf 0 length;
                  buf
               )
      ~finally:(fun () -> close_in f)


  let is_safe char =
    (char >= 'A' && char <= 'Z') || (char >= 'a' && char <= 'z') ||
    (char >= '0' && char <= '9') || (char = '.') || (char = '-')


  let verify_web_fname fname =
    let bad = ref false in
    let pos = ref 0 in
    while not !bad && !pos < String.length fname do
      if not (is_safe fname.[!pos]) then bad := true;
      incr pos
    done;
    not !bad

  let convert_web_fname fname =
    if verify_web_fname fname then
      Filename.concat !Settings.basedir (Filename.concat "web" fname)
    else raise (Wserver.Misc_error "Malformed requst")

  let supported_extensions =
    [ ".jpg",   "image/jpeg";
      ".jpeg",  "image/jpeg";
      ".gif",   "image/gif";
      ".ico",   "image/x-icon";
      ".png",   "image/png";
      ".htm",   "text/html";
      ".html",  "text/html";
      ".txt",   "text/plain";
      ".css",   "text/css";
      ".xhtml", "application/xhtml+xml";
      ".xhtm",  "application/xhtml+xml";
      ".xml",   "application/xhtml+xml";
      ".es",    "application/ecmascript";
      ".js",    "application/javascript";
    ]

  (* Search list for web page index files *)
  let index_files =
    [ "index.html";
      "index.htm";
      "index.xhtml";
      "index.xhtm";
      "index.xml";
    ]

  (** Returns the first element of [index_files] that exists, returning "index.html" if
      none of them exists.  *)
  let index_page_filename =
    let found_files = List.filter index_files
      ~f:(fun x -> Sys.file_exists (convert_web_fname x))
    in
    match found_files with
    | [] -> "index.html"
    | hd :: _ -> hd

  let index_page_mime =
    let period = Str.regexp_string "." in
    let err () =
      raise (Wserver.Misc_error "No mime type found for index page")
    in
    match Str.split period index_page_filename with
    | _ :: ext :: _ ->
      (try List.assoc ("." ^ ext) supported_extensions
       with Not_found -> err ())
    | _ -> err ()

  let webhandler addr msg cout =
    match msg with
      | Wserver.GET (request,headers) ->
          plerror 5 "Get request: %s => %s"
            (sockaddr_to_string addr) request;
          let (base,oplist) = string_to_oplist request in
          if base = "/pks/lookup" then (
            let request = request_of_oplist oplist in
            let (mimetype,count,body) = handle_get_request request in
            cout#write_string body;
            (mimetype, count)
          ) else (
            if (base = "/index.html" || base = "/index.htm"
                || base = "/" || base = "" || base = "/index.xhtml" )
            then
              let fname = convert_web_fname index_page_filename in
              let text = read_file fname in
              cout#write_string text;
              (index_page_mime ^ "; charset=UTF-8", -1)
            else
              (try
                 let extension = get_extension base in
                 let mimetype =
                   try List.assoc extension supported_extensions
                   with Not_found ->
                     raise (Wserver.Misc_error
                              ("internal error: no mimetype " ^
                               "for given extension"))
                 in
                 let base = base </> (1,0) in
                 let data = read_file ~binary:true (convert_web_fname base) in
                 cout#write_string data;
                 (mimetype, -1)
               with
                   Not_found -> raise (Wserver.Page_not_found base)
              )
          )
      | Wserver.POST (request,headers,body) ->
          let request = Wserver.strip request in
          match request with
              "/pks/add" ->
                let keytext = Scanf.sscanf body "keytext=%s" (fun s -> s) in
                let keytext = Wserver.decode keytext in
                let keys = Armor.decode_pubkey keytext in
                plerror 3 "Handling /pks/add for %d keys"
                  (List.length keys);
                cout#write_string "<html><body>";
                let ctr = ref 0 in
                List.iter keys
                  ~f:(fun origkey ->
                        try
                          let key = Fixkey.canonicalize origkey in
                          plerror 3 "/pks/add: key %s added to database"
                            (KeyHash.hexify (KeyHash.hash key));
                          Keydb.add_key_merge ~newkey:true key;
                          incr ctr;
                        with
                          | Fixkey.Bad_key | KeyMerge.Unparseable_packet_sequence ->
                              cout#write_string
                              ("Add failed: Malformed Key --- unexpected packet " ^
                               "type and/or order of packets<br>");
                              plerror 2 "key %s %s"
                                (KeyHash.hexify (KeyHash.hash origkey))
                                "could not be parsed by KeyMerge.canonicalize"
                          | Fixkey.Standalone_revocation_certificate ->
                               cout#write_string ("Add failed: This is a stand-alone " ^
                                                  "revocation certificate. A revocation " ^
                                                  "certificates should be imported to the " ^
                                                  "respective public key before being " ^
                                                  "published to a keyserver");
                          | Bdb.Key_exists as e ->
                              cout#write_string
                              ("Add failed: identical key already " ^
                               "exists in database<br>");
                              eperror e "Key add failed"
                          | e ->
                              Eventloop.reraise e;
                              cout#write_string "Add failed<br>";
                              eperror e "Key add failed"
                     );
                if !ctr > 0 then (
                  cout#write_string
                    ("Key block added to key server database.\n  " ^
                     "New public keys added: <br>");
                  cout#write_string (sprintf "%d key(s) added successfully.<br>" !ctr)
                );
                cout#write_string "</html></body>";
                ("text/html; charset=UTF-8", List.length keys)
            | "/pks/hashquery" ->
                plerror 4 "Handling /pks/hashquery";
                let sin = new Channel.string_in_channel body 0 in
                let hashes =
                  CMarshal.unmarshal_list ~f:CMarshal.unmarshal_string sin
                in
                let keystrings = get_keystrings_from_hashes hashes in
                perror "%d keys found" (List.length keystrings);
                CMarshal.marshal_list ~f:CMarshal.marshal_string cout
                  keystrings;
                ("pgp/keys" (* This is a bogus content-type *),
                 List.length keystrings)
            | _ ->
                cout#write_string (HtmlTemplates.page
                                     ~title:"Unexpected POST request"
                                     ~body:"");
                ("text/html; charset=UTF-8", -1)


  (** Prepare handler for use with eventloop by transforming system
    channels to Channel objects and by returning empty list instead
    of unit *)
  let eventify_handler handle =
    (fun addr cin cout ->
       let cin = (new Channel.sys_in_channel cin)
       and cout = (new Channel.sys_out_channel cout) in
       handle addr cin cout;
       []
    )

  let get_filters =
    Utils.unit_memoize
      (fun () ->
         try Str.split comma_rxp (Keydb.get_meta "filters")
         with Not_found -> []
      )


  (** Handler for commands coming off of the db_command_addr *)
  let command_handler addr cin cout =
    match (unmarshal cin).msg with
      | LogQuery (count,timestamp) ->
          let logresp = Keydb.logquery ~maxsize:count timestamp in
          let length = List.length logresp in
          if length > 0 then
            plerror 3 "Sending LogResp size %d" length;
          marshal cout (LogResp logresp)

      | WordQuery words ->
          plerror 3 "Handling WordQuery";
          let keys = Keydb.get_by_words ~max:!Settings.max_matches words in
          marshal cout (Keys keys)

      | Keys keys ->
          let keys = List.fold_left ~init:[] keys
                       ~f:(fun list key ->
                             try (Fixkey.canonicalize key)::list
                             with KeyMerge.Unparseable_packet_sequence | Fixkey.Bad_key -> list
                          )
          in
          marshal cout (Ack 0);
          (try Keydb.add_keys_merge keys
           with e -> eplerror 2 e "Key addition failed")

      | DeleteKey hash ->
          plerror 3 "Handling DeleteKey";
          ( try
              let hash = RMisc.truncate hash KeyHash.hash_bytes in
              let key = Keydb.get_by_hash hash in
              Keydb.delete_key ~hash key;
              marshal cout (Ack 0);
            with
                e ->
                  marshal cout (Ack (-1));
                  raise e
          )
      | HashRequest hashes ->
          plerror 3 "Handling HashRequest";
          let keys =
            List.fold_left hashes ~init:[]
              ~f:(fun list hash ->
                    try (Keydb.get_by_hash hash)::list
                    with
                        Not_found ->
                          plerror 2 "Requested key %s not found"
                          (Utils.hexstring hash);
                          list
                 )
          in
          plerror 3 "Returning set of %d keys" (List.length keys);
          marshal cout (Keys keys)


      | Config (s,cvar) ->
          plerror 4 "Received config message";
          (match (s,cvar) with
             | ("checkpoint", `none) ->
                 checkpoint ()
             | ("filters", `none) ->
                 marshal cout (Filters (get_filters ()))
             | (str,value) ->
                 perror "Unexpected config request <%s>" str
          )


      | m ->
          marshal cout ProtocolError;
          perror "Unexpected (%s) message" (msg_to_string m)


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

  (** dequeues and transmits single key.  Returns true if there
    might be more keys to be handled. *)
  let rec transmit_single_key () =
    let txn = Keydb.txn_begin () in
    try
      match (try Some (Keydb.dequeue_key ~txn)
             with Not_found -> None)
      with
        | Some (time,key) ->
            let body = Armor.encode_pubkey key in
            let to_header = ("To", String.concat ~sep:", "
                               (Membership.get_mailsync_partners ()))
            in
            let msg = { Sendmail.headers =
                          [ to_header;
                            "From", Settings.get_from_addr ();
                            "Reply-To", Settings.get_from_addr ();
                            "Errors-To", Settings.get_from_addr ();
                            "Subject","incremental";
                            "Precedence","list";
                            "Content-type", "application/pgp-keys";
                            "X-KeyServer-Sent", Settings.get_from_addr ();
                          ] ;
                        Sendmail.body = body;
                      }
            in
            let string = Sendmail.msg_to_string msg in
            plerror 3 "Message transmitted for key %s"
              (KeyHash.hexify (KeyHash.hash key));
            plerror 6 "%s" string;
            Sendmail.send msg;
            Keydb.txn_commit txn;
            plerror 5 "transmission queue transaction committed";
            true
        | None ->
            (* nothing was done, so commiting and aborting are same here *)
            Keydb.txn_abort txn;
            false
      with
          e ->
            Keydb.txn_abort txn;
            raise e


  (** Transmit all enqueued keys to other hosts *)
  let transmit_keys () =
    while transmit_single_key () do () done;
    []

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

  let sync_db_on_sig () =
    sync ();
    checkpoint ()

  let () = Sys.set_signal Sys.sigusr1
          (Sys.Signal_handle (fun _ -> sync_db_on_sig ()))

  let () = Sys.set_signal Sys.sigusr2
      (Sys.Signal_handle (fun _ ->
        Eventloop.add_events Eventloop.heap
          [Eventloop.Event(0.0, Eventloop.Callback calculate_stats_page)]))

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

  let run () =
    Keydb.open_dbs settings;
    if !Settings.initial_stat then ignore (calculate_stats_page ());
    plerror 2 "Database opened";
    plerror 0 "Applied filters: %s" (String.concat ~sep:", "
                                       (get_filters ()));
    Eventloop.evloop

      (
        (if withtxn
         then (Ehandlers.repeat_forever_simple checkpoint_interval checkpoint)
         else (Ehandlers.repeat_forever_simple sync_interval sync))
        @
          Ehandlers.repeat_forever_simple !Settings.membership_reload_time
          Membership.reset_membership_time
        @
          (if !Settings.send_mailsyncs then
             (Ehandlers.repeat_forever 10.
                (Eventloop.make_tc ~cb:transmit_keys ~timeout:0
                   ~name:"mail transmit keys" )
             )
           else [])
        @
          (Ehandlers.repeat_forever 10.
             (Eventloop.make_tc ~name:"mailsync" ~timeout:0
                ~cb:(Mailsync.load_mailed_keys
                       ~addkey:(Keydb.add_key_merge ~newkey:false)))
          )
        @
          (Ehandlers.repeat_at_hour !Settings.stat_calc_hour
             calculate_stats_page)
      )

      (
         (comsock, Eventloop.make_th ~name:"command handler"
            ~timeout:!Settings.command_timeout
            ~cb:(eventify_handler command_handler))
        ::
         (List.map websocks
            ~f:(fun sock ->
                  (sock, Eventloop.make_th ~name:"webserver"
                     ~timeout:!Settings.wserver_timeout
                     ~cb:(Wserver.accept_connection webhandler ~recover_timeout:1))))
      )



  let run () =
    protect ~f:run
      ~finally:(fun () ->
                  set_catch_break false;
                  plerror 0 "Shutting down database";
                  Keydb.sync ();
                  plerror 0 "Database sync'd";
                  Keydb.unconditional_checkpoint ();
                  plerror 0 "Database checkpointed";
                  Keydb.close_dbs ();
                  plerror 0 "Database closed"
               )
end
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.