blob: 7f6cb7612f45ad741b891eb07306bb9e11dc24ec (
plain)
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
|
open Ctypes
open Foreign
open Vyos1x
module CT = Config_tree
module CD = Config_diff
let error_message = ref ""
let make_syntax_error pos err =
match pos with
| None -> Printf.sprintf "Syntax error: %s" err
| Some (l, c) ->
Printf.sprintf "Syntax error on line %d, character %d: %s" l c err
let to_json_str = fun s -> `String s
let split_on_whitespace s = Re.split (Re.Perl.compile_pat "\\s+") s
let make_config_tree name = Ctypes.Root.create (CT.make name)
let destroy c_ptr =
Root.release c_ptr
let from_string s =
try
error_message := "";
let config = Parser.from_string s in
Ctypes.Root.create config
with
| Failure s -> error_message := s; Ctypes.null
| Util.Syntax_error (pos, err) ->
let msg = make_syntax_error pos err in
error_message := msg; Ctypes.null
| _ -> error_message := "Parse error"; Ctypes.null
let get_error () = !error_message
let render_config c_ptr =
CT.render_config (Root.get c_ptr)
let render_json c_ptr =
CT.render_json (Root.get c_ptr)
let render_json_ast c_ptr =
CT.render_json_ast (Root.get c_ptr)
let render_commands c_ptr op =
match op with
| "delete" ->
CT.render_commands ~op:CT.Delete (Root.get c_ptr) []
| _ ->
CT.render_commands ~op:CT.Set (Root.get c_ptr) []
let set_add_value c_ptr path value =
let ct = Root.get c_ptr in
let path = split_on_whitespace path in
try
let new_ct = CT.set ct path (Some value) CT.AddValue in
Root.set c_ptr new_ct;
0 (* return 0 *)
with CT.Duplicate_value -> 1
let set_replace_value c_ptr path value =
let ct = Root.get c_ptr in
let path = split_on_whitespace path in
let new_ct = Config_tree.set ct path (Some value) Config_tree.ReplaceValue in
Root.set c_ptr new_ct;
0 (* return 0 *)
let set_valueless c_ptr path =
let ct = Root.get c_ptr in
let path = split_on_whitespace path in
try
let new_ct = Config_tree.set ct path None CT.AddValue in
Root.set c_ptr new_ct;
0 (* return 0 *)
with CT.Useless_set -> 1
let delete_value c_ptr path value =
let ct = Root.get c_ptr in
let path = split_on_whitespace path in
try
let new_ct = CT.delete ct path (Some value) in
Root.set c_ptr new_ct;
0 (* return 0 *)
with CT.No_such_value -> 1
let delete_node c_ptr path =
let ct = Root.get c_ptr in
let path = split_on_whitespace path in
if not (Vytree.exists ct path) then 1 else
let new_ct = Config_tree.delete ct path None in
Root.set c_ptr new_ct;
0 (* return 0 *)
let rename_node c_ptr path newname =
let ct = Root.get c_ptr in
let path = split_on_whitespace path in
if not (Vytree.exists ct path) then 1 else
let new_ct = Vytree.rename ct path newname in
Root.set c_ptr new_ct;
0 (* return 0 *)
let set_tag c_ptr path =
let ct = Root.get c_ptr in
let path = split_on_whitespace path in
try
Root.set c_ptr (CT.set_tag ct path true);
0 (* return 0 *)
with _ -> 1
let is_tag c_ptr path =
let ct = Root.get c_ptr in
let path = split_on_whitespace path in
if (CT.is_tag ct path) then 1 else 0
let get_subtree c_ptr path with_node =
let ct = Root.get c_ptr in
let path = split_on_whitespace path in
let subt = CT.get_subtree ~with_node:with_node ct path in
Ctypes.Root.create subt
let exists c_ptr path =
let ct = Root.get c_ptr in
let path = split_on_whitespace path in
if (Vytree.exists ct path) then 1 else 0
let list_nodes c_ptr path =
let ct = Root.get c_ptr in
let path = split_on_whitespace path in
try
let nodes = Vytree.children_of_path ct path in
let nodes_json = `List (List.map to_json_str nodes) in
Yojson.Safe.to_string nodes_json
with _ -> Yojson.Safe.to_string `Null
let return_value c_ptr path =
let ct = Root.get c_ptr in
let path = split_on_whitespace path in
try
Yojson.Safe.to_string (`String (CT.get_value ct path))
with
| CT.Node_has_no_value -> Yojson.Safe.to_string (`String "")
| _ -> Yojson.Safe.to_string `Null
let return_values c_ptr path =
let ct = Root.get c_ptr in
let path = split_on_whitespace path in
let to_json_str = fun s -> `String s in
try
let values = CT.get_values ct path in
let values_json = `List (List.map to_json_str values) in
Yojson.Safe.to_string values_json
with _ -> Yojson.Safe.to_string `Null
let copy_node c_ptr old_path new_path =
let ct = Root.get c_ptr in
let old_path_str = old_path in
let old_path = split_on_whitespace old_path in
let new_path = split_on_whitespace new_path in
try
let new_ct = Vytree.copy ct old_path new_path in
Root.set c_ptr new_ct;
0
with
| Vytree.Nonexistent_path ->
let s = Printf.sprintf "Non-existent path \'%s\'" old_path_str in
error_message := s; 1
| Vytree.Insert_error s -> error_message := s; 1
let diff_tree path c_ptr_l c_ptr_r =
let path = split_on_whitespace path in
let ct_l = Root.get c_ptr_l in
let ct_r = Root.get c_ptr_r in
try
let ct_ret = CD.diff_tree path ct_l ct_r in
Ctypes.Root.create ct_ret
with
| CD.Incommensurable -> error_message := "Incommensurable"; Ctypes.null
| CD.Empty_comparison -> error_message := "Empty comparison"; Ctypes.null
let trim_tree c_ptr_l c_ptr_r =
let ct_l = Root.get c_ptr_l in
let ct_r = Root.get c_ptr_r in
try
let ct_ret = CD.trim_tree ct_l ct_r in
Ctypes.Root.create ct_ret
with
| CD.Incommensurable -> error_message := "Incommensurable"; Ctypes.null
| CD.Empty_comparison -> error_message := "Empty comparison"; Ctypes.null
let show_diff cmds path c_ptr_l c_ptr_r =
let path = split_on_whitespace path in
let ct_l = Root.get c_ptr_l in
let ct_r = Root.get c_ptr_r in
try
CD.show_diff ~cmds:cmds path ct_l ct_r
with
| CD.Incommensurable -> error_message := "Incommensurable"; "#1@"
| CD.Empty_comparison -> error_message := "Empty comparison"; "#1@"
module Stubs(I : Cstubs_inverted.INTERNAL) =
struct
let () = I.internal "make" (string @-> returning (ptr void)) make_config_tree
let () = I.internal "destroy" ((ptr void) @-> returning void) destroy
let () = I.internal "from_string" (string @-> returning (ptr void)) from_string
let () = I.internal "get_error" (void @-> returning string) get_error
let () = I.internal "to_string" ((ptr void) @-> returning string) render_config
let () = I.internal "to_json" ((ptr void) @-> returning string) render_json
let () = I.internal "to_json_ast" ((ptr void) @-> returning string) render_json_ast
let () = I.internal "to_commands" ((ptr void) @-> string @-> returning string) render_commands
let () = I.internal "set_add_value" ((ptr void) @-> string @-> string @-> returning int) set_add_value
let () = I.internal "set_replace_value" ((ptr void) @-> string @-> string @-> returning int) set_replace_value
let () = I.internal "set_valueless" ((ptr void) @-> string @-> returning int) set_valueless
let () = I.internal "delete_value" ((ptr void) @-> string @-> string @-> returning int) delete_value
let () = I.internal "delete_node" ((ptr void) @-> string @-> returning int) delete_node
let () = I.internal "rename_node" ((ptr void) @-> string @-> string @-> returning int) rename_node
let () = I.internal "copy_node" ((ptr void) @-> string @-> string @-> returning int) copy_node
let () = I.internal "set_tag" ((ptr void) @-> string @-> returning int) set_tag
let () = I.internal "is_tag" ((ptr void) @-> string @-> returning int) is_tag
let () = I.internal "get_subtree" ((ptr void) @-> string @-> bool @-> returning (ptr void)) get_subtree
let () = I.internal "exists" ((ptr void) @-> string @-> returning int) exists
let () = I.internal "list_nodes" ((ptr void) @-> string @-> returning string) list_nodes
let () = I.internal "return_value" ((ptr void) @-> string @-> returning string) return_value
let () = I.internal "return_values" ((ptr void) @-> string @-> returning string) return_values
let () = I.internal "diff_tree" (string @-> (ptr void) @-> (ptr void) @-> returning (ptr void)) diff_tree
let () = I.internal "trim_tree" ((ptr void) @-> (ptr void) @-> returning (ptr void)) trim_tree
let () = I.internal "show_diff" (bool @-> string @-> (ptr void) @-> (ptr void) @-> returning string) show_diff
end
|
