blob: bfbdf656c19c5822d82f1805bab9c9a4f91af98d (
plain) (
blame)
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
|
(* Low-level ctypes bindings to RNT_C_API.h.
This module is internal to Nt — never import it anywhere else. *)
open Ctypes
open Foreign
let fn name typ = foreign name typ
(* Runtime ----------------------------------------------------------------- *)
let rnt_init =
fn "rnt_init" (string @-> string @-> returning int)
(* Auth -------------------------------------------------------------------- *)
let rnt_firewall =
fn "rnt_firewall" (string @-> ptr (ptr char) @-> returning int)
(* Session lifecycle ------------------------------------------------------- *)
let rnt_session_open =
fn "rnt_session_open" (ptr void @-> ptr (ptr char) @-> returning int)
let rnt_session_close =
fn "rnt_session_close" (string @-> returning int)
let rnt_session_set_branch =
fn "rnt_session_set_branch"
(string @-> string @-> string @-> returning int)
(* Handle lifecycle -------------------------------------------------------- *)
let rnt_open_handle =
fn "rnt_open_handle" (string @-> ptr void @-> returning (ptr void))
let rnt_close_handle =
fn "rnt_close_handle" (ptr void @-> returning int)
(* Branch hash-pointer ----------------------------------------------------- *)
let rnt_branch_target =
fn "rnt_branch_target"
(ptr void @-> ptr (ptr char) @-> returning int)
let rnt_branch_advance =
fn "rnt_branch_advance" (string @-> string @-> returning int)
(* Object registration ----------------------------------------------------- *)
let rnt_register_relation =
fn "rnt_register_relation" (string @-> returning int)
let rnt_register_branch =
fn "rnt_register_branch" (string @-> string @-> returning int)
(* Branch / snapshot relation enumeration ----------------------------------- *)
let rnt_list_relations =
fn "rnt_list_relations" (string @-> ptr (ptr char) @-> returning int)
let rnt_list_branch_multigroups =
fn "rnt_list_branch_multigroups" (string @-> ptr (ptr char) @-> returning int)
let rnt_list_snapshot_relations =
fn "rnt_list_snapshot_relations" (string @-> ptr (ptr char) @-> returning int)
(* Tuple storage ----------------------------------------------------------- *)
let rnt_link_tuple =
fn "rnt_link_tuple"
(string @-> string @-> ptr (ptr char) @-> returning int)
let rnt_unlink_tuple =
fn "rnt_unlink_tuple" (string @-> string @-> returning int)
let rnt_clear_relation =
fn "rnt_clear_relation" (string @-> returning int)
let rnt_relation_root =
fn "rnt_relation_root"
(string @-> ptr (ptr char) @-> returning int)
(* Cursor and VM ----------------------------------------------------------- *)
let rnt_cursor_open =
fn "rnt_cursor_open" (ptr void @-> returning (ptr void))
let rnt_cursor_next =
fn "rnt_cursor_next" (ptr void @-> ptr (ptr char) @-> returning int)
let rnt_cursor_close =
fn "rnt_cursor_close" (ptr void @-> returning int)
(* VM plan builder --------------------------------------------------------- *)
type operation = Scan | Join | Take | Project
let int_of_operation = function
| Scan -> 1 | Join -> 2 | Take -> 3 | Project -> 4
let operation_of_int = function
| 1 -> Scan | 2 -> Join | 3 -> Take | 4 -> Project
| _ -> failwith "Bad operation" (* FIXME *)
let operation = view ~read:operation_of_int ~write:int_of_operation int
type plan_args_scan
let plan_args_scan : plan_args_scan structure typ = structure "plan_args_scan"
let pas_relation_path = field plan_args_scan "pas_relation_path" string
let () = seal plan_args_scan
type plan_args_join
let plan_args_join : plan_args_join structure typ = structure "plan_args_join"
let paj_left = field plan_args_join "paj_left" (ptr void)
let paj_right = field plan_args_join "paj_right" (ptr void)
let () = seal plan_args_join
type plan_args_take
let plan_args_take : plan_args_take structure typ = structure "plan_args_take"
let pat_source = field plan_args_take "pat_source" (ptr void)
let pat_limit = field plan_args_take "pat_limit" size_t
let () = seal plan_args_take
type plan_args_project
let plan_args_project : plan_args_project structure typ = structure "plan_args_project"
let pap_source = field plan_args_project "pap_source" (ptr void)
let pap_attrs = field plan_args_project "pap_attrs" (ptr (ptr char))
let () = seal plan_args_project
type plan_action
let plan_action : plan_action structure typ = structure "plan_action"
let pa_operation = field plan_action "pa_operation" operation
let pa_scan = field plan_action "pa_scan" plan_args_scan
let pa_join = field plan_action "pa_join" plan_args_join
let pa_take = field plan_action "pa_take" plan_args_take
let pa_project = field plan_action "pa_project" plan_args_project
let () = seal plan_action
let rnt_plan_assemble = fn "rnt_plan_assemble" (plan_action @-> returning (ptr void))
let ( &-> ) = getf
let rnt_plan_scan str =
let plan = make plan_action in
setf plan pa_operation Scan;
setf (plan &-> pa_scan) pas_relation_path str;
rnt_plan_assemble plan
let rnt_plan_join left right =
let plan = make plan_action in
setf plan pa_operation Join;
setf (plan &-> pa_join) paj_left left;
setf (plan &-> pa_join) paj_right right;
rnt_plan_assemble plan
let rnt_plan_take source limit =
let plan = make plan_action in
setf plan pa_operation Take;
setf (plan &-> pa_take) pat_source source;
setf (plan &-> pa_take) pat_limit limit;
rnt_plan_assemble plan
let rnt_plan_free =
fn "rnt_plan_free" (ptr void @-> returning void)
let rnt_vm_execute_plan =
fn "rnt_vm_execute_plan" (ptr void @-> returning (ptr void))
let rnt_vm_cursor_next =
fn "rnt_vm_cursor_next" (ptr void @-> ptr (ptr char) @-> returning int)
let rnt_vm_cursor_close =
fn "rnt_vm_cursor_close" (ptr void @-> returning int)
(* Memory management ------------------------------------------------------- *)
let rnt_free_string =
fn "rnt_free_string" (ptr char @-> returning void)
let rnt_free_bytes =
fn "rnt_free_bytes" (ptr uint8_t @-> returning void)
(* --------------------------------------------------------------------------
Helpers shared by Nt (not exported from the library module)
-------------------------------------------------------------------------- *)
let null_char_ptr : char ptr = from_voidp char null
(* Reads a null-terminated C string from a char pointer, then frees it. *)
let consume_cstring (p : char ptr) : string =
let n = ref 0 in
while !@(p +@ !n) <> '\000' do incr n done;
let s = string_from_ptr p ~length:!n in
rnt_free_string p;
s
(* Allocates a char* out-parameter, calls [f], returns the rc and string. *)
let with_out_string (f : char ptr ptr -> int) : int * string option =
let pp = allocate (ptr char) null_char_ptr in
let rc = f pp in
let p = !@ pp in
if is_null p then (rc, None)
else (rc, Some (consume_cstring p))
(* Converts a void* (returned from open_handle / cursor_open) to nativeint.
Returns None when the pointer is NULL (failure). *)
let ptr_to_opt (p : unit ptr) : nativeint option =
if is_null p then None
else Some (raw_address_of_ptr p)
(* Converts a stored nativeint back to a void* for API calls. *)
let nint_to_ptr (n : nativeint) : unit ptr =
ptr_of_raw_address n
|
