File: common.ml

package info (click to toggle)
sks 1.1.6-14
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 2,296 kB
  • sloc: ml: 15,228; ansic: 1,069; sh: 358; makefile: 347
file content (246 lines) | stat: -rw-r--r-- 8,649 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
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
(***********************************************************************)
(* 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/>.                          *)
(***********************************************************************)

(** Common services, including error reporting, logging,
  exception handling and port definitions  *)

open Printf
open StdLabels
open MoreLabels
module Unix = UnixLabels

exception Bug of string
exception Transaction_aborted of string
exception Argument_error of string
exception Unit_test_failure of string

module Map = PMap.Map
let (|<) map key = (fun data -> Map.add ~key ~data map)
let (|=) map key = Map.find key map

(** Function sequencing *)
let (|!) x f = f x

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

(** filters applied to all incoming keys *)
let enforced_filters = ["yminsky.dedup"]

let version_tuple = (__VERSION__)
(* for Release versions, COMMONCAMLFLAGS in Makefile should include          *)
(* '-warn-error a'. Development work should use '-warn-error A' for stricter *)
(* language checking. This affects the Ocaml compiler beginning with v4.01.0 *)
let version_suffix = "" (* + for development branch *)
let compatible_version_tuple = (0,1,5)
let version =
  let (maj_version,min_version,release) = version_tuple in
  sprintf "%d.%d.%d" maj_version min_version release

let compatible_version_string =
        let (maj_version,min_version,release) = compatible_version_tuple in
        sprintf "%d.%d.%d" maj_version min_version release

let period_regexp = Str.regexp "[.]"

let parse_version_string vstr =
  let ar = Array.of_list (Str.bounded_split period_regexp vstr 3) in
  (int_of_string ar.(0), int_of_string ar.(1), int_of_string ar.(2))

let err_to_string err = match err with
    Unix.Unix_error (enum,fname,param) ->
      sprintf "Unix error: %s - %s(%s)"
      (Unix.error_message enum) fname param
  | e -> Printexc.to_string e

(**************************************************************************)
(** Logfile control *)

let logfile = ref stdout
let stored_logfile_name = ref None

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

let plerror level format =
  kprintf (fun s ->
             if !Settings.debug && level  <= !Settings.debuglevel
             then  (
               let tm = Unix.localtime (Unix.time ()) in
               fprintf !logfile "%04d-%02d-%02d %02d:%02d:%02d "
                 (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1)
                 tm.Unix.tm_mday (* date *)
                 tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec; (* time *)
               output_string !logfile s;
               output_string !logfile "\n";
               flush !logfile;
             ) )
    format

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

let set_logfile extension =
  if !Settings.filelog then
    let fname = (Filename.concat !Settings.basedir "/var/log/sks/") ^ extension ^ ".log" in
    stored_logfile_name := Some fname;
    logfile := open_out_gen [ Open_wronly; Open_creat; Open_append; ]
      0o600 fname;
    plerror 0 "Opening log"

let reopen_logfile () =
  match !stored_logfile_name with
    | None -> ()
    | Some name ->
        close_out !logfile;
        logfile := open_out_gen [ Open_wronly; Open_creat; Open_append; ]
          0o600 name

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

let perror x = plerror 3 x

let eplerror level e format =
  kprintf (fun s ->
             if !Settings.debug && level  <= !Settings.debuglevel
             then  (
               let tm = Unix.localtime (Unix.time ()) in
               fprintf !logfile "%04d-%02d-%02d %02d:%02d:%02d "
                 (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1)
                 tm.Unix.tm_mday (* date *)
                 tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec;
               output_string !logfile s;
               fprintf !logfile ": %s\n" (err_to_string e);
               flush !logfile;
             )
          )
    format

let eperror x = eplerror 3 x

(********************************************************************)
(** Setup signals.  In particular, most of the time we want to catch and
  gracefully handle both sigint and sigterm *)

let catch_break = ref false
let handle_interrupt i =
  if !catch_break
  then raise Sys.Break


let () = Sys.set_signal Sys.sigterm (Sys.Signal_handle handle_interrupt)
let () = Sys.set_signal Sys.sigint (Sys.Signal_handle handle_interrupt)
let () = Sys.set_signal Sys.sigpipe Sys.Signal_ignore
let () = Sys.set_signal Sys.sigusr2 Sys.Signal_ignore
let () = Sys.set_signal Sys.sighup
           (Sys.Signal_handle (fun _ -> reopen_logfile ()))

let set_catch_break bool =
  catch_break := bool
  (* Sys.catch_break bool; *)

let () = set_catch_break true

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

let protect ~f ~finally =
  let result = ref None in
  let pfinally () =
    set_catch_break false;
    (try (finally () : unit)
     with ee ->
       set_catch_break true;
       raise ee);
    set_catch_break true;
  in
  try
    result := Some (f ());
    raise Exit
  with
      Exit as e ->
        pfinally ();
        (match !result with Some x -> x | None -> raise e)
    | e ->
        pfinally ();
        raise e

let fprotect ~f ~finally () = protect ~f ~finally

let rec filter_opts optlist = match optlist with
    [] -> []
  | (Some x)::tl -> x::(filter_opts tl)
  | None::tl -> filter_opts tl

let decomment l =
  try
    let pos = String.index l '#' in
    String.sub l ~pos:0 ~len:pos
  with
      Not_found -> l

let rec strip_opt list = match list with
    [] -> []
  | None::tl -> strip_opt tl
  | (Some hd)::tl -> hd::(strip_opt tl)

let apply_opt ~f opt = match opt with
    None -> None
  | Some x -> Some (f x)

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

type event = | Add of string
             | Delete of string

type timestamp = float

(************************************************************)
(************************************************************)
(**  Network Related definitions   *)

let whitespace = Str.regexp "[ \t\n]+"
let make_addr_list address_string port =
  let addrlist = Str.split whitespace address_string in
  let servname = if port = 0 then "" else (string_of_int port) in
  let resolver host = List.map ~f:(fun ai -> ai.Unix.ai_addr)
      (Unix.getaddrinfo host servname [Unix.AI_SOCKTYPE Unix.SOCK_STREAM]) in
  List.flatten (List.map ~f:resolver addrlist)

let recon_port = !Settings.recon_port
let recon_address = !Settings.recon_address
let http_port = !Settings.hkp_port
let http_address = !Settings.hkp_address
let db_command_name = Filename.concat !Settings.basedir "/var/run/sks/db_com_sock"
let recon_command_name = Filename.concat !Settings.basedir "/var/run/sks/recon_com_sock"

let db_command_addr = Unix.ADDR_UNIX db_command_name
let recon_command_addr = Unix.ADDR_UNIX recon_command_name

let recon_addr_to_http_addr addr = match addr with
    Unix.ADDR_UNIX _ -> failwith "Can't convert UNIX address"
  | Unix.ADDR_INET (inet_addr,port) -> Unix.ADDR_INET (inet_addr,port + 1)


let get_client_recon_addr () =
  make_addr_list recon_address 0
let get_client_recon_addr =
  Utils.unit_memoize get_client_recon_addr

let match_client_recon_addr addr =
  let family = Unix.domain_of_sockaddr addr in
  List.find ~f:(fun caddr -> family = Unix.domain_of_sockaddr caddr)
    (get_client_recon_addr ())