summaryrefslogtreecommitdiff
path: root/lib/bindings.ml
blob: d9d2051710f8b54cd323b0eceb664d8258bf6c2f (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
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 = 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 -> 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

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
end