File: gnutls.ml

package info (click to toggle)
ocamlnet 4.1.2-1
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 51,764 kB
  • ctags: 16,446
  • sloc: ml: 148,419; ansic: 10,989; sh: 1,885; makefile: 1,355
file content (151 lines) | stat: -rw-r--r-- 4,615 bytes parent folder | download | duplicates (3)
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
(* This file is included into nettls_gnutls_bindings.ml *)

exception Null_pointer
exception Error of error_code
exception Short_memory_buffer of int

type memory = 
    (char,Bigarray.int8_unsigned_elt,Bigarray.c_layout) Bigarray.Array1.t

type gnutls_credentials =
    [ `Certificate of gnutls_certificate_credentials_t
    | `Srp_client of gnutls_srp_client_credentials_t
    | `Srp_server of gnutls_srp_server_credentials_t
    | `Psk_client of gnutls_psk_client_credentials_t
    | `Psk_server of gnutls_psk_server_credentials_t
    | `Anon_client of gnutls_anon_client_credentials_t
    | `Anon_server of gnutls_anon_server_credentials_t
    ]

external gnutls_credentials_set : gnutls_session_t -> gnutls_credentials -> unit
  = "net_gnutls_credentials_set" "net_gnutls_credentials_set"

type 'a unix_code =
  | ESUCCESS of 'a
  | EINTR
  | EAGAIN
  | EMSGSIZE
  | EPERM

external net_b_set_pull_callback : 
  gnutls_session_t -> (memory -> int unix_code) -> unit
  = "net_b_set_pull_callback" "net_b_set_pull_callback"

external net_b_set_push_callback : 
  gnutls_session_t -> (memory -> int -> int unix_code) -> unit
  = "net_b_set_push_callback" "net_b_set_push_callback"

external net_b_set_pull_timeout_callback : 
  gnutls_session_t -> (int -> bool unix_code) -> unit
  = "net_b_set_pull_timeout_callback" "net_b_set_pull_timeout_callback"

external net_b_set_verify_callback : 
  gnutls_session_t -> (unit -> bool) -> unit
  = "net_b_set_verify_callback" "net_b_set_verify_callback"


let protect f arg =
  try
    ESUCCESS(f arg)
  with
    | Unix.Unix_error(Unix.EINTR, _, _) ->
         EINTR
    | Unix.Unix_error((Unix.EAGAIN | Unix.EWOULDBLOCK), _, _) ->
         EAGAIN
    | Unix.Unix_error(Unix.EMSGSIZE, _, _) ->
         EMSGSIZE
    | Unix.Unix_error(_, _, _) ->
         EPERM
    | e ->
         Netlog.logf `Crit "Exception in Nettls_gnutls_bindings: %s"
                     (Netexn.to_string e);
         EPERM


let b_set_pull_callback s f =
  net_b_set_pull_callback s (protect f)


let b_set_push_callback s f =
  net_b_set_push_callback s (fun buf size -> protect (f buf) size)


let b_set_pull_timeout_callback s f =
  net_b_set_pull_timeout_callback s (protect f)


let b_set_verify_callback s f =
  net_b_set_verify_callback s (fun () -> f s)


external b_set_db_callbacks :
  gnutls_session_t ->
  (string -> string -> unit) ->
  (string -> unit) ->
  (string -> string) ->
  unit
  = "net_b_set_db_callbacks" "net_b_set_db_callbacks"


let set_fd s fd =
  let recv mem =
    Netsys_mem.mem_recv fd mem 0 (Bigarray.Array1.dim mem) [] in
  let send mem size =
    Netsys_mem.mem_send fd mem 0 size [] in
  let timeout ms =
    Netsys_posix.poll_single fd true false false (0.001 *. float ms) in
  b_set_pull_callback s recv;
  b_set_push_callback s send;
  b_set_pull_timeout_callback s timeout;
  ()

let string_of_verification_status_flag =
  function
    | `Invalid -> "INVALID"
    | `Revoked -> "REVOKED"
    | `Signer_not_found -> "SIGNER_NOT_FOUND"
    | `Signer_not_ca -> "SIGNER_NOT_CA"
    | `Insecure_algorithm -> "INSECURE_ALGORITHM"
    | `Not_activated -> "NOT_ACTIVATED"
    | `Expired -> "EXPIRED"
    | `Signature_failure -> "SIGNATURE_FAILURE"
    | `Revocation_data_superseded -> "REVOCATION_DATA_SUPERSEDED"
    | `Unexpected_owner -> "UNEXPECTED_OWNER"
    | `Revocation_data_issued_in_future -> "REVOCATION_DATA_ISSUED_IN_FUTURE"
    | `Signer_constraints_failure -> "SIGNER_CONSTRAINTS_FAILURE"
    | `Mismatch -> "MISMATCH"
    | `Purpose_mismatch -> "PURPOSE_MISMATCH"

external gnutls_x509_crt_list_import : string -> gnutls_x509_crt_fmt_t ->
                                  gnutls_certificate_import_flags ->
                                  gnutls_x509_crt_t array
  = "net_gnutls_x509_crt_list_import" "net_gnutls_x509_crt_list_import"

external gnutls_x509_crl_list_import : string -> gnutls_x509_crt_fmt_t ->
                                  gnutls_certificate_import_flags ->
                                  gnutls_x509_crl_t array
  = "net_gnutls_x509_crl_list_import" "net_gnutls_x509_crl_list_import"


let () =
  Callback.register_exception
    "Nettls_gnutls_bindings.Null_pointer"
    Null_pointer;
  Callback.register_exception
    "Nettls_gnutls_bindings.Error"
    (Error `Success);
  Callback.register_exception
    "Nettls_gnutls_bindings.Short_memory_buffer"
    (Short_memory_buffer 0)


let () =
  Netexn.register_printer
    (Error `Success)
    (function
      | Error code ->
           Printf.sprintf
             "Nettls_gnutls_bindings.Error(%s)" (gnutls_strerror_name code)
      | _ ->
           assert false
    )