summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.gitignore9
-rw-r--r--.merlin9
-rw-r--r--.ocamlinit29
-rw-r--r--Makefile49
-rw-r--r--_oasis179
-rw-r--r--_tags150
-rwxr-xr-xbuild-setup.sh2
-rwxr-xr-xconfigure27
-rw-r--r--dune-project3
-rw-r--r--myocamlbuild.ml906
-rw-r--r--setup.ml39
-rw-r--r--src/config_tree.ml345
-rw-r--r--src/config_tree.mli78
-rw-r--r--src/curly_lexer.mll90
-rw-r--r--src/curly_parser.mly114
-rw-r--r--src/dune5
-rw-r--r--src/reference_tree.ml237
-rw-r--r--src/reference_tree.mli51
-rw-r--r--src/session.ml31
-rw-r--r--src/session.mli12
-rw-r--r--src/startup.ml16
-rw-r--r--src/startup.mli6
-rw-r--r--src/util.ml2
-rw-r--r--src/value_checker.ml39
-rw-r--r--src/value_checker.mli7
-rw-r--r--src/vycli.ml4
-rw-r--r--src/vyconf_client.ml18
-rw-r--r--src/vyconf_config.ml4
-rw-r--r--src/vyconf_pb.ml162
-rw-r--r--src/vyconfd.ml25
-rw-r--r--src/vylist.ml46
-rw-r--r--src/vylist.mli7
-rw-r--r--src/vytree.ml192
-rw-r--r--src/vytree.mli50
-rw-r--r--vyconf.opam (renamed from opam)18
35 files changed, 167 insertions, 2794 deletions
diff --git a/.gitignore b/.gitignore
index c070d95..c5c64e1 100644
--- a/.gitignore
+++ b/.gitignore
@@ -7,13 +7,10 @@
*.cmx
*.cmxs
*.cmxa
-*.native
-*.byte
*.mllib
*.mldylib
*.rej
-setup.log
-setup.data
.ocp-indent
-_build
-META
+_build/*
+*.merlin
+*.install
diff --git a/.merlin b/.merlin
deleted file mode 100644
index 81f4e4a..0000000
--- a/.merlin
+++ /dev/null
@@ -1,9 +0,0 @@
-S src
-S test
-B _build/src
-B _build/test
-PKG lwt lwt.unix
-PKG ppx_deriving.runtime ppx_deriving.show
-PKG fileutils pcre toml xml-light batteries
-PKG oUnit
-EXT lwt oUnit
diff --git a/.ocamlinit b/.ocamlinit
deleted file mode 100644
index 58bfe4a..0000000
--- a/.ocamlinit
+++ /dev/null
@@ -1,29 +0,0 @@
-(* Vyconf development environment for OCaml toplevel
- *
- * NOTE: To keep this functioning as expected, we will need to register new
- * package dependencies here as they are added to the project.
- *
- * TODO: Automate the addition of dependencies via an _oasis plugin.
- *)
-
-let () =
- try Topdirs.dir_directory (Sys.getenv "OCAML_TOPLEVEL_PATH")
- with Not_found -> ()
-;;
-
-#use "topfind";;
-
-#require "lwt";;
-#require "lwt.unix";;
-#require "lwt.ppx";;
-#require "ppx_deriving.show";;
-#require "ppx_deriving_yojson";;
-#require "fileutils";;
-#require "pcre";;
-#require "toml";;
-#require "xml-light";;
-#require "batteries";;
-
-#cd "_build/src";;
-
-print_string "VyConf .ocamlinit has been successfully loaded\n";;
diff --git a/Makefile b/Makefile
deleted file mode 100644
index dcda8bd..0000000
--- a/Makefile
+++ /dev/null
@@ -1,49 +0,0 @@
-# OASIS_START
-# DO NOT EDIT (digest: a3c674b4239234cbbe53afe090018954)
-
-SETUP = ocaml setup.ml
-
-build: setup.data
- $(SETUP) -build $(BUILDFLAGS)
-
-doc: setup.data build
- $(SETUP) -doc $(DOCFLAGS)
-
-test: setup.data build
- $(SETUP) -test $(TESTFLAGS)
-
-all:
- $(SETUP) -all $(ALLFLAGS)
-
-install: setup.data
- $(SETUP) -install $(INSTALLFLAGS)
-
-uninstall: setup.data
- $(SETUP) -uninstall $(UNINSTALLFLAGS)
-
-reinstall: setup.data
- $(SETUP) -reinstall $(REINSTALLFLAGS)
-
-clean:
- $(SETUP) -clean $(CLEANFLAGS)
-
-distclean:
- $(SETUP) -distclean $(DISTCLEANFLAGS)
-
-setup.data:
- $(SETUP) -configure $(CONFIGUREFLAGS)
-
-configure:
- $(SETUP) -configure $(CONFIGUREFLAGS)
-
-.PHONY: build doc test all install uninstall reinstall clean distclean configure
-
-# OASIS_STOP
-
-.PHONY:
-schema:
- scripts/rnc2rng.sh all data/schemata/
-
-.PHONY:
-protobuf:
- ocaml-protoc -ml_out src/ data/vyconf.proto
diff --git a/_oasis b/_oasis
deleted file mode 100644
index 6b9f408..0000000
--- a/_oasis
+++ /dev/null
@@ -1,179 +0,0 @@
-Name: VyConf
-Version: 0.1
-Synopsis: Appliance configuration framework
-Authors: VyOS maintainers <maintainers@vyos.net>
-License: LGPL with OCaml linking exception
-
-Description: VyConf
-Homepage: http://vyos.net
-
-OASISFormat: 0.4
-BuildTools: ocamlbuild
-Plugins: META (0.4), DevFiles (0.4)
-
-Library "vyconf"
- Path: src
- Modules: Config_tree, Reference_tree, Curly_parser, Curly_lexer, Value_checker, Vytree
- InternalModules: Util, Vylist
- BuildDepends: fileutils, pcre, ppx_deriving.show, ppx_deriving_yojson, xml-light, batteries
-
-Library "vyconfd-config"
- Path: src
- Modules: Vyconf_config
- FindlibParent: vyconf
- Install: false
- BuildDepends: toml, fileutils, ppx_deriving.show, batteries
-
-Library "client"
- Path: src
- Modules: Vyconf_client
- InternalModules: Vyconf_pb, Vyconf_types, Message, Util, Vylist
- FindlibParent: vyconf
- BuildDepends: lwt, lwt_ppx, lwt_log, ocaml-protoc, ocplib-endian, batteries, fileutils, yojson
-
-Executable "vyconfd"
- Path: src
- MainIs: vyconfd.ml
- CompiledObject: best
- BuildDepends: lwt, lwt.unix, lwt_ppx, lwt_log, ocaml-protoc, ocplib-endian, sha, batteries, vyconf, vyconf.vyconfd-config
-
-Executable "vycli"
- Path: src
- MainIs: vycli.ml
- CompiledObject: best
- BuildDepends: lwt, lwt.unix, lwt_ppx, ocaml-protoc, ocplib-endian, pcre, vyconf.client
-
-Executable "vytree_test"
- Path: test
- MainIs: vytree_test.ml
- Build$: flag(tests)
- CompiledObject: best
- Install: false
- BuildDepends: oUnit, vyconf
-
-Executable "reference_tree_test"
- Path: test
- MainIs: reference_tree_test.ml
- Build$: flag(tests)
- CompiledObject: best
- Install: false
- BuildDepends: oUnit, vyconf
-
-Executable "config_tree_test"
- Path: test
- MainIs: config_tree_test.ml
- Build$: flag(tests)
- CompiledObject: best
- Install: false
- BuildDepends: oUnit, vyconf, batteries
-
-Executable "vylist_test"
- Path: test
- MainIs: vylist_test.ml
- Build$: flag(tests)
- CompiledObject: best
- Install: false
- BuildDepends: oUnit
-
-Executable "value_checker_test"
- Path: test
- MainIs: value_checker_test.ml
- Build$: flag(tests)
- CompiledObject: best
- Install: false
- BuildDepends: oUnit, vyconf
-
-Executable "util_test"
- Path: test
- MainIs: util_test.ml
- Build$: flag(tests)
- CompiledObject: best
- Install: false
- BuildDepends: oUnit, vyconf
-
-Executable "vyconf_config_test"
- Path: test
- MainIs: vyconf_config_test.ml
- Build$: flag(tests)
- CompiledObject: best
- Install: false
- BuildDepends: oUnit, vyconf.vyconfd-config
-
-Executable "curly_parser_test"
- Path: test
- MainIs: curly_parser_test.ml
- Build$: flag(tests)
- CompiledObject: best
- Install: false
- BuildDepends: oUnit, vyconf
-
-Executable "session_test"
- Path: test
- MainIs: session_test.ml
- Build$: flag(tests)
- CompiledObject: best
- Install: false
- BuildDepends: oUnit, vyconf, vyconf.vyconfd-config
-
-Executable "vytree_load_test"
- Path: test
- MainIs: vytree_load_test.ml
- Build$: flag(tests)
- CompiledObject: best
- Install: false
- BuildDepends: vyconf
-
-Test "vytree_test"
- Run$: flag(tests)
- TestTools: vytree_test
- Command: $vytree_test
- WorkingDirectory: test
-
-Test "reference_tree_test"
- Run$: flag(tests)
- TestTools: reference_tree_test
- Command: $reference_tree_test
- WorkingDirectory: test
-
-Test "config_tree_test"
- Run$: flag(tests)
- TestTools: config_tree_test
- Command: $config_tree_test
- WorkingDirectory: test
-
-Test "vylist_test"
- Run$: flag(tests)
- TestTools: vylist_test
- Command: $vylist_test
- WorkingDirectory: test
-
-Test "value_checker_test"
- Run$: flag(tests)
- TestTools: value_checker_test
- Command: $value_checker_test
- WorkingDirectory: test
-
-Test "vyconf_config_test"
- Run$: flag(tests)
- TestTools: vyconf_config_test
- Command: $vyconf_config_test
- WorkingDirectory: test
-
-Test "curly_parser_test"
- Run$: flag(tests)
- TestTools: curly_parser_test
- Command: $curly_parser_test
- WorkingDirectory: test
-
-Test "util_test"
- Run$: flag(tests)
- TestTools: util_test
- Command: $util_test
- WorkingDirectory: test
-
-Test "session_test"
- Run$: flag(tests)
- TestTools: session_test
- Command: $session_test
- WorkingDirectory: test
-
diff --git a/_tags b/_tags
deleted file mode 100644
index d553ae2..0000000
--- a/_tags
+++ /dev/null
@@ -1,150 +0,0 @@
-# OASIS_START
-# DO NOT EDIT (digest: 4f1983ffc92b04ffaba30b6e019eb870)
-# Ignore VCS directories, you can use the same kind of rule outside
-# OASIS_START/STOP if you want to exclude directories that contains
-# useless stuff for the build process
-true: annot, bin_annot
-<**/.svn>: -traverse
-<**/.svn>: not_hygienic
-".bzr": -traverse
-".bzr": not_hygienic
-".hg": -traverse
-".hg": not_hygienic
-".git": -traverse
-".git": not_hygienic
-"_darcs": -traverse
-"_darcs": not_hygienic
-# Library vyconf
-"src/vyconf.cmxs": use_vyconf
-# Library vyconf-config
-"src/vyconf-config.cmxs": use_vyconf-config
-# Library vyconf-client
-"src/vyconf-client.cmxs": use_vyconf-client
-# Executable vyconfd
-<src/vyconfd.{native,byte}>: pkg_batteries
-<src/vyconfd.{native,byte}>: pkg_fileutils
-<src/vyconfd.{native,byte}>: pkg_lwt
-<src/vyconfd.{native,byte}>: pkg_lwt.ppx
-<src/vyconfd.{native,byte}>: pkg_lwt.unix
-<src/vyconfd.{native,byte}>: pkg_ocaml-protoc
-<src/vyconfd.{native,byte}>: pkg_ocplib-endian
-<src/vyconfd.{native,byte}>: pkg_pcre
-<src/vyconfd.{native,byte}>: pkg_ppx_deriving.show
-<src/vyconfd.{native,byte}>: pkg_ppx_deriving_yojson
-<src/vyconfd.{native,byte}>: pkg_sha
-<src/vyconfd.{native,byte}>: pkg_toml
-<src/vyconfd.{native,byte}>: pkg_xml-light
-<src/vyconfd.{native,byte}>: use_vyconf
-<src/vyconfd.{native,byte}>: use_vyconf-config
-<src/*.ml{,i,y}>: pkg_batteries
-<src/*.ml{,i,y}>: pkg_fileutils
-<src/*.ml{,i,y}>: pkg_lwt
-<src/*.ml{,i,y}>: pkg_lwt.ppx
-<src/*.ml{,i,y}>: pkg_lwt.unix
-<src/*.ml{,i,y}>: pkg_ocaml-protoc
-<src/*.ml{,i,y}>: pkg_ocplib-endian
-<src/*.ml{,i,y}>: pkg_pcre
-<src/*.ml{,i,y}>: pkg_ppx_deriving.show
-<src/*.ml{,i,y}>: pkg_ppx_deriving_yojson
-<src/*.ml{,i,y}>: pkg_sha
-<src/*.ml{,i,y}>: pkg_toml
-<src/*.ml{,i,y}>: pkg_xml-light
-<src/*.ml{,i,y}>: use_vyconf
-<src/*.ml{,i,y}>: use_vyconf-config
-# Executable vytree_test
-<test/vytree_test.{native,byte}>: pkg_batteries
-<test/vytree_test.{native,byte}>: pkg_fileutils
-<test/vytree_test.{native,byte}>: pkg_oUnit
-<test/vytree_test.{native,byte}>: pkg_pcre
-<test/vytree_test.{native,byte}>: pkg_ppx_deriving.show
-<test/vytree_test.{native,byte}>: pkg_ppx_deriving_yojson
-<test/vytree_test.{native,byte}>: pkg_xml-light
-<test/vytree_test.{native,byte}>: use_vyconf
-# Executable reference_tree_test
-<test/reference_tree_test.{native,byte}>: pkg_batteries
-<test/reference_tree_test.{native,byte}>: pkg_fileutils
-<test/reference_tree_test.{native,byte}>: pkg_oUnit
-<test/reference_tree_test.{native,byte}>: pkg_pcre
-<test/reference_tree_test.{native,byte}>: pkg_ppx_deriving.show
-<test/reference_tree_test.{native,byte}>: pkg_ppx_deriving_yojson
-<test/reference_tree_test.{native,byte}>: pkg_xml-light
-<test/reference_tree_test.{native,byte}>: use_vyconf
-# Executable config_tree_test
-<test/config_tree_test.{native,byte}>: pkg_batteries
-<test/config_tree_test.{native,byte}>: pkg_fileutils
-<test/config_tree_test.{native,byte}>: pkg_oUnit
-<test/config_tree_test.{native,byte}>: pkg_pcre
-<test/config_tree_test.{native,byte}>: pkg_ppx_deriving.show
-<test/config_tree_test.{native,byte}>: pkg_ppx_deriving_yojson
-<test/config_tree_test.{native,byte}>: pkg_xml-light
-<test/config_tree_test.{native,byte}>: use_vyconf
-# Executable vylist_test
-<test/vylist_test.{native,byte}>: pkg_oUnit
-# Executable value_checker_test
-<test/value_checker_test.{native,byte}>: pkg_batteries
-<test/value_checker_test.{native,byte}>: pkg_fileutils
-<test/value_checker_test.{native,byte}>: pkg_oUnit
-<test/value_checker_test.{native,byte}>: pkg_pcre
-<test/value_checker_test.{native,byte}>: pkg_ppx_deriving.show
-<test/value_checker_test.{native,byte}>: pkg_ppx_deriving_yojson
-<test/value_checker_test.{native,byte}>: pkg_xml-light
-<test/value_checker_test.{native,byte}>: use_vyconf
-# Executable util_test
-<test/util_test.{native,byte}>: pkg_batteries
-<test/util_test.{native,byte}>: pkg_fileutils
-<test/util_test.{native,byte}>: pkg_oUnit
-<test/util_test.{native,byte}>: pkg_pcre
-<test/util_test.{native,byte}>: pkg_ppx_deriving.show
-<test/util_test.{native,byte}>: pkg_ppx_deriving_yojson
-<test/util_test.{native,byte}>: pkg_xml-light
-<test/util_test.{native,byte}>: use_vyconf
-# Executable vyconf_config_test
-<test/vyconf_config_test.{native,byte}>: pkg_batteries
-<test/vyconf_config_test.{native,byte}>: pkg_fileutils
-<test/vyconf_config_test.{native,byte}>: pkg_oUnit
-<test/vyconf_config_test.{native,byte}>: pkg_ppx_deriving.show
-<test/vyconf_config_test.{native,byte}>: pkg_toml
-<test/vyconf_config_test.{native,byte}>: use_vyconf-config
-# Executable curly_parser_test
-<test/curly_parser_test.{native,byte}>: pkg_batteries
-<test/curly_parser_test.{native,byte}>: pkg_fileutils
-<test/curly_parser_test.{native,byte}>: pkg_oUnit
-<test/curly_parser_test.{native,byte}>: pkg_pcre
-<test/curly_parser_test.{native,byte}>: pkg_ppx_deriving.show
-<test/curly_parser_test.{native,byte}>: pkg_ppx_deriving_yojson
-<test/curly_parser_test.{native,byte}>: pkg_xml-light
-<test/curly_parser_test.{native,byte}>: use_vyconf
-# Executable session_test
-<test/session_test.{native,byte}>: pkg_batteries
-<test/session_test.{native,byte}>: pkg_fileutils
-<test/session_test.{native,byte}>: pkg_oUnit
-<test/session_test.{native,byte}>: pkg_pcre
-<test/session_test.{native,byte}>: pkg_ppx_deriving.show
-<test/session_test.{native,byte}>: pkg_ppx_deriving_yojson
-<test/session_test.{native,byte}>: pkg_toml
-<test/session_test.{native,byte}>: pkg_xml-light
-<test/session_test.{native,byte}>: use_vyconf
-<test/session_test.{native,byte}>: use_vyconf-config
-<test/*.ml{,i,y}>: pkg_oUnit
-<test/*.ml{,i,y}>: pkg_toml
-<test/*.ml{,i,y}>: use_vyconf-config
-# Executable vytree_load_test
-<test/vytree_load_test.{native,byte}>: pkg_batteries
-<test/vytree_load_test.{native,byte}>: pkg_fileutils
-<test/vytree_load_test.{native,byte}>: pkg_pcre
-<test/vytree_load_test.{native,byte}>: pkg_ppx_deriving.show
-<test/vytree_load_test.{native,byte}>: pkg_ppx_deriving_yojson
-<test/vytree_load_test.{native,byte}>: pkg_xml-light
-<test/vytree_load_test.{native,byte}>: use_vyconf
-<test/*.ml{,i,y}>: pkg_batteries
-<test/*.ml{,i,y}>: pkg_fileutils
-<test/*.ml{,i,y}>: pkg_pcre
-<test/*.ml{,i,y}>: pkg_ppx_deriving.show
-<test/*.ml{,i,y}>: pkg_ppx_deriving_yojson
-<test/*.ml{,i,y}>: pkg_xml-light
-<test/*.ml{,i,y}>: use_vyconf
-# OASIS_STOP
-
-true: strict_sequence
-true: bin_annot
-true: use_menhir, explain
diff --git a/build-setup.sh b/build-setup.sh
deleted file mode 100755
index b10e06b..0000000
--- a/build-setup.sh
+++ /dev/null
@@ -1,2 +0,0 @@
-#!/bin/sh
-oasis setup -setup-update dynamic
diff --git a/configure b/configure
deleted file mode 100755
index 6acfaeb..0000000
--- a/configure
+++ /dev/null
@@ -1,27 +0,0 @@
-#!/bin/sh
-
-# OASIS_START
-# DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499)
-set -e
-
-FST=true
-for i in "$@"; do
- if $FST; then
- set --
- FST=false
- fi
-
- case $i in
- --*=*)
- ARG=${i%%=*}
- VAL=${i##*=}
- set -- "$@" "$ARG" "$VAL"
- ;;
- *)
- set -- "$@" "$i"
- ;;
- esac
-done
-
-ocaml setup.ml -configure "$@"
-# OASIS_STOP
diff --git a/dune-project b/dune-project
new file mode 100644
index 0000000..41c3051
--- /dev/null
+++ b/dune-project
@@ -0,0 +1,3 @@
+(lang dune 2.0)
+(using menhir 2.0)
+(name vyconf)
diff --git a/myocamlbuild.ml b/myocamlbuild.ml
deleted file mode 100644
index 859c97a..0000000
--- a/myocamlbuild.ml
+++ /dev/null
@@ -1,906 +0,0 @@
-(* OASIS_START *)
-(* DO NOT EDIT (digest: bdb3fd5d41e0b702a74a64a780ae3714) *)
-module OASISGettext = struct
-(* # 22 "src/oasis/OASISGettext.ml" *)
-
-
- let ns_ str = str
- let s_ str = str
- let f_ (str: ('a, 'b, 'c, 'd) format4) = str
-
-
- let fn_ fmt1 fmt2 n =
- if n = 1 then
- fmt1^^""
- else
- fmt2^^""
-
-
- let init = []
-end
-
-module OASISString = struct
-(* # 22 "src/oasis/OASISString.ml" *)
-
-
- (** Various string utilities.
-
- Mostly inspired by extlib and batteries ExtString and BatString libraries.
-
- @author Sylvain Le Gall
- *)
-
-
- let nsplitf str f =
- if str = "" then
- []
- else
- let buf = Buffer.create 13 in
- let lst = ref [] in
- let push () =
- lst := Buffer.contents buf :: !lst;
- Buffer.clear buf
- in
- let str_len = String.length str in
- for i = 0 to str_len - 1 do
- if f str.[i] then
- push ()
- else
- Buffer.add_char buf str.[i]
- done;
- push ();
- List.rev !lst
-
-
- (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the
- separator.
- *)
- let nsplit str c =
- nsplitf str ((=) c)
-
-
- let find ~what ?(offset=0) str =
- let what_idx = ref 0 in
- let str_idx = ref offset in
- while !str_idx < String.length str &&
- !what_idx < String.length what do
- if str.[!str_idx] = what.[!what_idx] then
- incr what_idx
- else
- what_idx := 0;
- incr str_idx
- done;
- if !what_idx <> String.length what then
- raise Not_found
- else
- !str_idx - !what_idx
-
-
- let sub_start str len =
- let str_len = String.length str in
- if len >= str_len then
- ""
- else
- String.sub str len (str_len - len)
-
-
- let sub_end ?(offset=0) str len =
- let str_len = String.length str in
- if len >= str_len then
- ""
- else
- String.sub str 0 (str_len - len)
-
-
- let starts_with ~what ?(offset=0) str =
- let what_idx = ref 0 in
- let str_idx = ref offset in
- let ok = ref true in
- while !ok &&
- !str_idx < String.length str &&
- !what_idx < String.length what do
- if str.[!str_idx] = what.[!what_idx] then
- incr what_idx
- else
- ok := false;
- incr str_idx
- done;
- if !what_idx = String.length what then
- true
- else
- false
-
-
- let strip_starts_with ~what str =
- if starts_with ~what str then
- sub_start str (String.length what)
- else
- raise Not_found
-
-
- let ends_with ~what ?(offset=0) str =
- let what_idx = ref ((String.length what) - 1) in
- let str_idx = ref ((String.length str) - 1) in
- let ok = ref true in
- while !ok &&
- offset <= !str_idx &&
- 0 <= !what_idx do
- if str.[!str_idx] = what.[!what_idx] then
- decr what_idx
- else
- ok := false;
- decr str_idx
- done;
- if !what_idx = -1 then
- true
- else
- false
-
-
- let strip_ends_with ~what str =
- if ends_with ~what str then
- sub_end str (String.length what)
- else
- raise Not_found
-
-
- let replace_chars f s =
- let buf = Buffer.create (String.length s) in
- String.iter (fun c -> Buffer.add_char buf (f c)) s;
- Buffer.contents buf
-
- let lowercase_ascii =
- replace_chars
- (fun c ->
- if (c >= 'A' && c <= 'Z') then
- Char.chr (Char.code c + 32)
- else
- c)
-
- let uncapitalize_ascii s =
- if s <> "" then
- (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1))
- else
- s
-
- let uppercase_ascii =
- replace_chars
- (fun c ->
- if (c >= 'a' && c <= 'z') then
- Char.chr (Char.code c - 32)
- else
- c)
-
- let capitalize_ascii s =
- if s <> "" then
- (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1))
- else
- s
-
-end
-
-module OASISUtils = struct
-(* # 22 "src/oasis/OASISUtils.ml" *)
-
-
- open OASISGettext
-
-
- module MapExt =
- struct
- module type S =
- sig
- include Map.S
- val add_list: 'a t -> (key * 'a) list -> 'a t
- val of_list: (key * 'a) list -> 'a t
- val to_list: 'a t -> (key * 'a) list
- end
-
- module Make (Ord: Map.OrderedType) =
- struct
- include Map.Make(Ord)
-
- let rec add_list t =
- function
- | (k, v) :: tl -> add_list (add k v t) tl
- | [] -> t
-
- let of_list lst = add_list empty lst
-
- let to_list t = fold (fun k v acc -> (k, v) :: acc) t []
- end
- end
-
-
- module MapString = MapExt.Make(String)
-
-
- module SetExt =
- struct
- module type S =
- sig
- include Set.S
- val add_list: t -> elt list -> t
- val of_list: elt list -> t
- val to_list: t -> elt list
- end
-
- module Make (Ord: Set.OrderedType) =
- struct
- include Set.Make(Ord)
-
- let rec add_list t =
- function
- | e :: tl -> add_list (add e t) tl
- | [] -> t
-
- let of_list lst = add_list empty lst
-
- let to_list = elements
- end
- end
-
-
- module SetString = SetExt.Make(String)
-
-
- let compare_csl s1 s2 =
- String.compare (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2)
-
-
- module HashStringCsl =
- Hashtbl.Make
- (struct
- type t = string
- let equal s1 s2 = (compare_csl s1 s2) = 0
- let hash s = Hashtbl.hash (OASISString.lowercase_ascii s)
- end)
-
- module SetStringCsl =
- SetExt.Make
- (struct
- type t = string
- let compare = compare_csl
- end)
-
-
- let varname_of_string ?(hyphen='_') s =
- if String.length s = 0 then
- begin
- invalid_arg "varname_of_string"
- end
- else
- begin
- let buf =
- OASISString.replace_chars
- (fun c ->
- if ('a' <= c && c <= 'z')
- ||
- ('A' <= c && c <= 'Z')
- ||
- ('0' <= c && c <= '9') then
- c
- else
- hyphen)
- s;
- in
- let buf =
- (* Start with a _ if digit *)
- if '0' <= s.[0] && s.[0] <= '9' then
- "_"^buf
- else
- buf
- in
- OASISString.lowercase_ascii buf
- end
-
-
- let varname_concat ?(hyphen='_') p s =
- let what = String.make 1 hyphen in
- let p =
- try
- OASISString.strip_ends_with ~what p
- with Not_found ->
- p
- in
- let s =
- try
- OASISString.strip_starts_with ~what s
- with Not_found ->
- s
- in
- p^what^s
-
-
- let is_varname str =
- str = varname_of_string str
-
-
- let failwithf fmt = Printf.ksprintf failwith fmt
-
-
- let rec file_location ?pos1 ?pos2 ?lexbuf () =
- match pos1, pos2, lexbuf with
- | Some p, None, _ | None, Some p, _ ->
- file_location ~pos1:p ~pos2:p ?lexbuf ()
- | Some p1, Some p2, _ ->
- let open Lexing in
- let fn, lineno = p1.pos_fname, p1.pos_lnum in
- let c1 = p1.pos_cnum - p1.pos_bol in
- let c2 = c1 + (p2.pos_cnum - p1.pos_cnum) in
- Printf.sprintf (f_ "file %S, line %d, characters %d-%d") fn lineno c1 c2
- | _, _, Some lexbuf ->
- file_location
- ~pos1:(Lexing.lexeme_start_p lexbuf)
- ~pos2:(Lexing.lexeme_end_p lexbuf)
- ()
- | None, None, None ->
- s_ "<position undefined>"
-
-
- let failwithpf ?pos1 ?pos2 ?lexbuf fmt =
- let loc = file_location ?pos1 ?pos2 ?lexbuf () in
- Printf.ksprintf (fun s -> failwith (Printf.sprintf "%s: %s" loc s)) fmt
-
-
-end
-
-module OASISExpr = struct
-(* # 22 "src/oasis/OASISExpr.ml" *)
-
-
- open OASISGettext
- open OASISUtils
-
-
- type test = string
- type flag = string
-
-
- type t =
- | EBool of bool
- | ENot of t
- | EAnd of t * t
- | EOr of t * t
- | EFlag of flag
- | ETest of test * string
-
-
- type 'a choices = (t * 'a) list
-
-
- let eval var_get t =
- let rec eval' =
- function
- | EBool b ->
- b
-
- | ENot e ->
- not (eval' e)
-
- | EAnd (e1, e2) ->
- (eval' e1) && (eval' e2)
-
- | EOr (e1, e2) ->
- (eval' e1) || (eval' e2)
-
- | EFlag nm ->
- let v =
- var_get nm
- in
- assert(v = "true" || v = "false");
- (v = "true")
-
- | ETest (nm, vl) ->
- let v =
- var_get nm
- in
- (v = vl)
- in
- eval' t
-
-
- let choose ?printer ?name var_get lst =
- let rec choose_aux =
- function
- | (cond, vl) :: tl ->
- if eval var_get cond then
- vl
- else
- choose_aux tl
- | [] ->
- let str_lst =
- if lst = [] then
- s_ "<empty>"
- else
- String.concat
- (s_ ", ")
- (List.map
- (fun (cond, vl) ->
- match printer with
- | Some p -> p vl
- | None -> s_ "<no printer>")
- lst)
- in
- match name with
- | Some nm ->
- failwith
- (Printf.sprintf
- (f_ "No result for the choice list '%s': %s")
- nm str_lst)
- | None ->
- failwith
- (Printf.sprintf
- (f_ "No result for a choice list: %s")
- str_lst)
- in
- choose_aux (List.rev lst)
-
-
-end
-
-
-# 443 "myocamlbuild.ml"
-module BaseEnvLight = struct
-(* # 22 "src/base/BaseEnvLight.ml" *)
-
-
- module MapString = Map.Make(String)
-
-
- type t = string MapString.t
-
-
- let default_filename = Filename.concat (Sys.getcwd ()) "setup.data"
-
-
- let load ?(allow_empty=false) ?(filename=default_filename) ?stream () =
- let line = ref 1 in
- let lexer st =
- let st_line =
- Stream.from
- (fun _ ->
- try
- match Stream.next st with
- | '\n' -> incr line; Some '\n'
- | c -> Some c
- with Stream.Failure -> None)
- in
- Genlex.make_lexer ["="] st_line
- in
- let rec read_file lxr mp =
- match Stream.npeek 3 lxr with
- | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] ->
- Stream.junk lxr; Stream.junk lxr; Stream.junk lxr;
- read_file lxr (MapString.add nm value mp)
- | [] -> mp
- | _ ->
- failwith
- (Printf.sprintf "Malformed data file '%s' line %d" filename !line)
- in
- match stream with
- | Some st -> read_file (lexer st) MapString.empty
- | None ->
- if Sys.file_exists filename then begin
- let chn = open_in_bin filename in
- let st = Stream.of_channel chn in
- try
- let mp = read_file (lexer st) MapString.empty in
- close_in chn; mp
- with e ->
- close_in chn; raise e
- end else if allow_empty then begin
- MapString.empty
- end else begin
- failwith
- (Printf.sprintf
- "Unable to load environment, the file '%s' doesn't exist."
- filename)
- end
-
- let rec var_expand str env =
- let buff = Buffer.create ((String.length str) * 2) in
- Buffer.add_substitute
- buff
- (fun var ->
- try
- var_expand (MapString.find var env) env
- with Not_found ->
- failwith
- (Printf.sprintf
- "No variable %s defined when trying to expand %S."
- var
- str))
- str;
- Buffer.contents buff
-
-
- let var_get name env = var_expand (MapString.find name env) env
- let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst
-end
-
-
-# 523 "myocamlbuild.ml"
-module MyOCamlbuildFindlib = struct
-(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *)
-
-
- (** OCamlbuild extension, copied from
- * https://ocaml.org/learn/tutorials/ocamlbuild/Using_ocamlfind_with_ocamlbuild.html
- * by N. Pouillard and others
- *
- * Updated on 2016-06-02
- *
- * Modified by Sylvain Le Gall
- *)
- open Ocamlbuild_plugin
-
-
- type conf = {no_automatic_syntax: bool}
-
-
- let run_and_read = Ocamlbuild_pack.My_unix.run_and_read
-
-
- let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings
-
-
- let exec_from_conf exec =
- let exec =
- let env = BaseEnvLight.load ~allow_empty:true () in
- try
- BaseEnvLight.var_get exec env
- with Not_found ->
- Printf.eprintf "W: Cannot get variable %s\n" exec;
- exec
- in
- let fix_win32 str =
- if Sys.os_type = "Win32" then begin
- let buff = Buffer.create (String.length str) in
- (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'.
- *)
- String.iter
- (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c))
- str;
- Buffer.contents buff
- end else begin
- str
- end
- in
- fix_win32 exec
-
-
- let split s ch =
- let buf = Buffer.create 13 in
- let x = ref [] in
- let flush () =
- x := (Buffer.contents buf) :: !x;
- Buffer.clear buf
- in
- String.iter
- (fun c ->
- if c = ch then
- flush ()
- else
- Buffer.add_char buf c)
- s;
- flush ();
- List.rev !x
-
-
- let split_nl s = split s '\n'
-
-
- let before_space s =
- try
- String.before s (String.index s ' ')
- with Not_found -> s
-
- (* ocamlfind command *)
- let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x]
-
- (* This lists all supported packages. *)
- let find_packages () =
- List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list"))
-
-
- (* Mock to list available syntaxes. *)
- let find_syntaxes () = ["camlp4o"; "camlp4r"]
-
-
- let well_known_syntax = [
- "camlp4.quotations.o";
- "camlp4.quotations.r";
- "camlp4.exceptiontracer";
- "camlp4.extend";
- "camlp4.foldgenerator";
- "camlp4.listcomprehension";
- "camlp4.locationstripper";
- "camlp4.macro";
- "camlp4.mapgenerator";
- "camlp4.metagenerator";
- "camlp4.profiler";
- "camlp4.tracer"
- ]
-
-
- let dispatch conf =
- function
- | After_options ->
- (* By using Before_options one let command line options have an higher
- * priority on the contrary using After_options will guarantee to have
- * the higher priority override default commands by ocamlfind ones *)
- Options.ocamlc := ocamlfind & A"ocamlc";
- Options.ocamlopt := ocamlfind & A"ocamlopt";
- Options.ocamldep := ocamlfind & A"ocamldep";
- Options.ocamldoc := ocamlfind & A"ocamldoc";
- Options.ocamlmktop := ocamlfind & A"ocamlmktop";
- Options.ocamlmklib := ocamlfind & A"ocamlmklib"
-
- | After_rules ->
-
- (* Avoid warnings for unused tag *)
- flag ["tests"] N;
-
- (* When one link an OCaml library/binary/package, one should use
- * -linkpkg *)
- flag ["ocaml"; "link"; "program"] & A"-linkpkg";
-
- (* For each ocamlfind package one inject the -package option when
- * compiling, computing dependencies, generating documentation and
- * linking. *)
- List.iter
- begin fun pkg ->
- let base_args = [A"-package"; A pkg] in
- (* TODO: consider how to really choose camlp4o or camlp4r. *)
- let syn_args = [A"-syntax"; A "camlp4o"] in
- let (args, pargs) =
- (* Heuristic to identify syntax extensions: whether they end in
- ".syntax"; some might not.
- *)
- if not (conf.no_automatic_syntax) &&
- (Filename.check_suffix pkg "syntax" ||
- List.mem pkg well_known_syntax) then
- (syn_args @ base_args, syn_args)
- else
- (base_args, [])
- in
- flag ["ocaml"; "compile"; "pkg_"^pkg] & S args;
- flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args;
- flag ["ocaml"; "doc"; "pkg_"^pkg] & S args;
- flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args;
- flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args;
-
- (* TODO: Check if this is allowed for OCaml < 3.12.1 *)
- flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs;
- flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs;
- flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs;
- flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs;
- end
- (find_packages ());
-
- (* Like -package but for extensions syntax. Morover -syntax is useless
- * when linking. *)
- List.iter begin fun syntax ->
- flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
- flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
- flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
- flag ["ocaml"; "infer_interface"; "syntax_"^syntax] &
- S[A"-syntax"; A syntax];
- end (find_syntaxes ());
-
- (* The default "thread" tag is not compatible with ocamlfind.
- * Indeed, the default rules add the "threads.cma" or "threads.cmxa"
- * options when using this tag. When using the "-linkpkg" option with
- * ocamlfind, this module will then be added twice on the command line.
- *
- * To solve this, one approach is to add the "-thread" option when using
- * the "threads" package using the previous plugin.
- *)
- flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]);
- flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]);
- flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]);
- flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]);
- flag ["c"; "pkg_threads"; "compile"] (S[A "-thread"]);
- flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]);
- flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]);
- flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]);
- flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]);
- flag ["c"; "package(threads)"; "compile"] (S[A "-thread"]);
-
- | _ ->
- ()
-end
-
-module MyOCamlbuildBase = struct
-(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *)
-
-
- (** Base functions for writing myocamlbuild.ml
- @author Sylvain Le Gall
- *)
-
-
- open Ocamlbuild_plugin
- module OC = Ocamlbuild_pack.Ocaml_compiler
-
-
- type dir = string
- type file = string
- type name = string
- type tag = string
-
-
- type t =
- {
- lib_ocaml: (name * dir list * string list) list;
- lib_c: (name * dir * file list) list;
- flags: (tag list * (spec OASISExpr.choices)) list;
- (* Replace the 'dir: include' from _tags by a precise interdepends in
- * directory.
- *)
- includes: (dir * dir list) list;
- }
-
-
-(* # 110 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *)
-
-
- let env_filename = Pathname.basename BaseEnvLight.default_filename
-
-
- let dispatch_combine lst =
- fun e ->
- List.iter
- (fun dispatch -> dispatch e)
- lst
-
-
- let tag_libstubs nm =
- "use_lib"^nm^"_stubs"
-
-
- let nm_libstubs nm =
- nm^"_stubs"
-
-
- let dispatch t e =
- let env = BaseEnvLight.load ~allow_empty:true () in
- match e with
- | Before_options ->
- let no_trailing_dot s =
- if String.length s >= 1 && s.[0] = '.' then
- String.sub s 1 ((String.length s) - 1)
- else
- s
- in
- List.iter
- (fun (opt, var) ->
- try
- opt := no_trailing_dot (BaseEnvLight.var_get var env)
- with Not_found ->
- Printf.eprintf "W: Cannot get variable %s\n" var)
- [
- Options.ext_obj, "ext_obj";
- Options.ext_lib, "ext_lib";
- Options.ext_dll, "ext_dll";
- ]
-
- | After_rules ->
- (* Declare OCaml libraries *)
- List.iter
- (function
- | nm, [], intf_modules ->
- ocaml_lib nm;
- let cmis =
- List.map (fun m -> (OASISString.uncapitalize_ascii m) ^ ".cmi")
- intf_modules in
- dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis
- | nm, dir :: tl, intf_modules ->
- ocaml_lib ~dir:dir (dir^"/"^nm);
- List.iter
- (fun dir ->
- List.iter
- (fun str ->
- flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir]))
- ["compile"; "infer_interface"; "doc"])
- tl;
- let cmis =
- List.map (fun m -> dir^"/"^(OASISString.uncapitalize_ascii m)^".cmi")
- intf_modules in
- dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"]
- cmis)
- t.lib_ocaml;
-
- (* Declare directories dependencies, replace "include" in _tags. *)
- List.iter
- (fun (dir, include_dirs) ->
- Pathname.define_context dir include_dirs)
- t.includes;
-
- (* Declare C libraries *)
- List.iter
- (fun (lib, dir, headers) ->
- (* Handle C part of library *)
- flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib]
- (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib";
- A("-l"^(nm_libstubs lib))]);
-
- flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib]
- (S[A"-cclib"; A("-l"^(nm_libstubs lib))]);
-
- if bool_of_string (BaseEnvLight.var_get "native_dynlink" env) then
- flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib]
- (S[A"-dllib"; A("dll"^(nm_libstubs lib))]);
-
- (* When ocaml link something that use the C library, then one
- need that file to be up to date.
- This holds both for programs and for libraries.
- *)
- dep ["link"; "ocaml"; tag_libstubs lib]
- [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)];
-
- dep ["compile"; "ocaml"; tag_libstubs lib]
- [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)];
-
- (* TODO: be more specific about what depends on headers *)
- (* Depends on .h files *)
- dep ["compile"; "c"]
- headers;
-
- (* Setup search path for lib *)
- flag ["link"; "ocaml"; "use_"^lib]
- (S[A"-I"; P(dir)]);
- )
- t.lib_c;
-
- (* Add flags *)
- List.iter
- (fun (tags, cond_specs) ->
- let spec = BaseEnvLight.var_choose cond_specs env in
- let rec eval_specs =
- function
- | S lst -> S (List.map eval_specs lst)
- | A str -> A (BaseEnvLight.var_expand str env)
- | spec -> spec
- in
- flag tags & (eval_specs spec))
- t.flags
- | _ ->
- ()
-
-
- let dispatch_default conf t =
- dispatch_combine
- [
- dispatch t;
- MyOCamlbuildFindlib.dispatch conf;
- ]
-
-
-end
-
-
-# 884 "myocamlbuild.ml"
-open Ocamlbuild_plugin;;
-let package_default =
- {
- MyOCamlbuildBase.lib_ocaml =
- [
- ("vyconf", ["src"], []);
- ("vyconf-config", ["src"], []);
- ("vyconf-client", ["src"], [])
- ];
- lib_c = [];
- flags = [];
- includes = [("test", ["src"])]
- }
- ;;
-
-let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false}
-
-let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;;
-
-# 905 "myocamlbuild.ml"
-(* OASIS_STOP *)
-Ocamlbuild_plugin.dispatch dispatch_default;;
diff --git a/setup.ml b/setup.ml
deleted file mode 100644
index 6958297..0000000
--- a/setup.ml
+++ /dev/null
@@ -1,39 +0,0 @@
-(* setup.ml generated for the first time by OASIS v0.4.8 *)
-
-(* OASIS_START *)
-(* DO NOT EDIT (digest: a426e2d026defb34183b787d31fbdcff) *)
-(******************************************************************************)
-(* OASIS: architecture for building OCaml libraries and applications *)
-(* *)
-(* Copyright (C) 2011-2016, Sylvain Le Gall *)
-(* Copyright (C) 2008-2011, OCamlCore SARL *)
-(* *)
-(* This library is free software; you can redistribute it and/or modify it *)
-(* under the terms of the GNU Lesser General Public License as published by *)
-(* the Free Software Foundation; either version 2.1 of the License, or (at *)
-(* your option) any later version, with the OCaml static compilation *)
-(* exception. *)
-(* *)
-(* This library 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 file COPYING for more *)
-(* details. *)
-(* *)
-(* You should have received a copy of the GNU Lesser General Public License *)
-(* along with this library; if not, write to the Free Software Foundation, *)
-(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *)
-(******************************************************************************)
-
-let () =
- try
- Topdirs.dir_directory (Sys.getenv "OCAML_TOPLEVEL_PATH")
- with Not_found -> ()
-;;
-#use "topfind";;
-#require "oasis.dynrun";;
-open OASISDynRun;;
-
-let setup_t = BaseCompat.Compat_0_4.adapt_setup_t setup_t
-open BaseCompat.Compat_0_4
-(* OASIS_STOP *)
-let () = setup ();;
diff --git a/src/config_tree.ml b/src/config_tree.ml
deleted file mode 100644
index 28cfcdd..0000000
--- a/src/config_tree.ml
+++ /dev/null
@@ -1,345 +0,0 @@
-type value_behaviour = AddValue | ReplaceValue
-
-exception Duplicate_value
-exception Node_has_no_value
-exception No_such_value
-exception Useless_set
-
-type config_node_data = {
- values: string list;
- comment: string option;
- inactive: bool;
- ephemeral: bool;
-} [@@deriving yojson]
-
-type t = config_node_data Vytree.t [@@deriving yojson]
-
-let default_data = {
- values = [];
- comment = None;
- inactive = false;
- ephemeral = false;
-}
-
-let make name = Vytree.make default_data name
-
-let replace_value node path value =
- let data = {default_data with values=[value]} in
- Vytree.update node path data
-
-let add_value node path value =
- let node' = Vytree.get node path in
- let data = Vytree.data_of_node node' in
- let values = data.values in
- match (Vylist.find (fun x -> x = value) values) with
- | Some _ -> raise Duplicate_value
- | None ->
- let values = values @ [value] in
- Vytree.update node path ({data with values=values})
-
-let delete_value node path value =
- let data = Vytree.data_of_node @@ Vytree.get node path in
- let values = Vylist.remove (fun x -> x = value) data.values in
- Vytree.update node path {data with values=values}
-
-let set_value node path value behaviour =
- match behaviour with
- | AddValue -> add_value node path value
- | ReplaceValue -> replace_value node path value
-
-let set node path value behaviour =
- if (Vytree.exists node path) then
- (match value with
- | None -> raise Useless_set
- | Some v -> set_value node path v behaviour)
- else
- let path_existing = Vytree.get_existent_path node path in
- let path_remaining = Vylist.complement path path_existing in
- let values = match value with None -> [] | Some v -> [v] in
- Vytree.insert_multi_level default_data node path_existing path_remaining {default_data with values=values}
-
-let get_values node path =
- let node' = Vytree.get node path in
- let data = Vytree.data_of_node node' in
- data.values
-
-let get_value node path =
- let values = get_values node path in
- match values with
- | [] -> raise Node_has_no_value
- | x :: _ -> x
-
-let delete node path value =
- match value with
- | Some v ->
- (let values = get_values node path in
- if Vylist.in_list values v then
- (match values with
- | [_] -> Vytree.delete node path
- | _ -> delete_value node path v)
- else raise No_such_value)
- | None ->
- Vytree.delete node path
-
-let set_comment node path comment =
- let data = Vytree.get_data node path in
- Vytree.update node path {data with comment=comment}
-
-let get_comment node path =
- let data = Vytree.get_data node path in
- data.comment
-
-let set_inactive node path inactive =
- let data = Vytree.get_data node path in
- Vytree.update node path {data with inactive=inactive}
-
-let is_inactive node path =
- let data = Vytree.get_data node path in
- data.inactive
-
-let set_ephemeral node path ephemeral =
- let data = Vytree.get_data node path in
- Vytree.update node path {data with ephemeral=ephemeral}
-
-let is_ephemeral node path =
- let data = Vytree.get_data node path in
- data.ephemeral
-
-module Renderer =
-struct
- (* TODO Replace use of Printf with Format *)
-
- module L = List
- module S = String
- module PF = Printf
- module VT = Vytree
- module RT = Reference_tree
-
- (* Nodes are ordered based on a comarison of their names *)
- let compare cmp node1 node2 =
- let name1 = VT.name_of_node node1 in
- let name2 = VT.name_of_node node2 in
- cmp name1 name2
-
- let indentation indent level = S.make (level * indent) ' '
-
- let render_inactive data = if data.inactive then "#INACTIVE " else ""
- let render_ephemeral data = if data.ephemeral then "#EPHEMERAL " else ""
-
- let render_comment data indents =
- match data.comment with
- | None -> ""
- (* Trailing indentation for the rest of the material on the next line *)
- | Some c -> PF.sprintf "/*%s*/\n%s" c indents
-
- let render_tag = function
- | None -> ""
- | Some tag -> PF.sprintf "%s " tag
-
- let render_outer indents data name tag =
- [render_comment data indents ;
- render_inactive data;
- render_ephemeral data;
- render_tag tag;
- name]
- |> S.concat ""
-
- let render_values ?(valueless=false) values =
- let quote_if_needed s =
- try
- let _ = Pcre.exec ~pat:"[\\s;{}#\\[\\]\"\']" s in
- Printf.sprintf "\"%s\"" s
- with Not_found -> s
- in
- match values with
- | [] -> if valueless then ";" else "{ }"
- | [v] -> PF.sprintf "%s;" (quote_if_needed v)
- | _ as vs -> S.concat "; " (List.map quote_if_needed vs) |> PF.sprintf "[%s];"
-
- let render_inner_and_outer indents inner outer =
- if inner = ""
- (* Hidden or empty descendents yield empty nodes *)
- then PF.sprintf "%s%s { }" indents outer
- else PF.sprintf "%s%s %s" indents outer inner
-
- let render
- ?(indent=4)
- ?(reftree=None)
- ?(cmp=BatString.numeric_compare)
- ?(showephemeral=false)
- ?(showinactive=false)
- (config_tree:t)
- =
- let is_hidden data =
- (not showephemeral && data.ephemeral) ||
- (not showinactive && data.inactive)
- in
- let rec render_node level ?tag node =
- let data = VT.data_of_node node in
- let name = VT.name_of_node node in
- (* Hide inactive and ephemeral when necessary *)
- if is_hidden data then ""
- else
- let indents = indentation indent level in
- let outer = render_outer indents data name tag in
- let inner = (* Children are ignored if the node has values *)
- match data.values with
- | [] -> VT.children_of_node node |> render_children level
- | values -> render_values values
- in
- PF.sprintf "%s%s %s" indents outer inner
- and render_children level = function
- | [] -> "{ }"
- | children ->
- let indents = indentation indent level in
- let render_child node = render_node (level + 1) node in
- let rendered_children = L.map render_child children |> S.concat "\n"
- in
- if rendered_children = "" then "{ }"
- else PF.sprintf "{\n%s\n%s}" rendered_children indents
- in
- (* Walks the reftree and config_tree side-by-side *)
- let rec render_node_rt level tag rt node =
- let data = VT.data_of_node node in
- let name = VT.name_of_node node in
- let rt_data = VT.data_of_node rt in
- let rt_name = VT.name_of_node rt in
- (* Hide inactive and ephemeral when necessary *)
- if is_hidden data then ""
- else
- (* TODO refactor this ugly approach*)
- let (outer_name, level', inner) =
- let open RT in
- let children = VT.children_of_node node in
- let ordered = rt_data.keep_order in
- match rt_data.node_type with
- | Tag ->
- ("", 0, render_children_rt level (Some name) ordered rt children)
- | Other ->
- (name, level, render_children_rt level None ordered rt children)
- | Leaf ->
- (name, level, render_values ~valueless:rt_data.valueless data.values)
- in
- let indents = indentation indent level' in
- let outer = render_outer indents data outer_name tag in
- (* Do not insert a space before ; for valueless nodes *)
- if rt_data.valueless then PF.sprintf "%s%s%s" indents outer inner
- else PF.sprintf "%s%s %s" indents outer inner
- and render_children_rt level tag ordered rt = function
- | [] -> "{ }"
- | children ->
- let is_tagged = BatOption.is_some tag in
- let indents = indentation indent level in
- let reorder nodes =
- if ordered then nodes
- else L.sort (compare cmp) nodes
- in
- let render_child node =
- let level' = if is_tagged then level else level + 1 in
- let node_reftree = VT.find rt (VT.name_of_node node) in
- (* If there is no reftree for a node, default to stand-alone *)
- match node_reftree with
- | Some rt' -> render_node_rt level' tag rt' node
- | None -> render_node level' ?tag node
- in
- let rendered_children = children
- |> reorder
- |> L.map render_child
- |> S.concat "\n"
- in
- if rendered_children = "" then "{ }"
- else if is_tagged
- then rendered_children
- else PF.sprintf "{\n%s\n%s}" rendered_children indents
- in
- match reftree with
- | None -> render_node 0 config_tree
- | Some rt -> render_node_rt 0 None rt config_tree
-
-
- (* Rendering configs as set commands *)
- let render_set_path path value =
- let v = Printf.sprintf "\'%s\'" value in
- List.append path [v] |> String.concat " " |> Printf.sprintf "set %s"
-
- let rec render_commands ?(reftree=None) ?(alwayssort=false) path ct =
- let new_path = List.append path [Vytree.name_of_node ct] in
- let new_path_str = String.concat " " new_path in
- let data = Vytree.data_of_node ct in
- (* Get the node comment, if any *)
- let comment = BatOption.default "" data.comment in
- let comment_cmd = (if comment = "" then "" else Printf.sprintf "comment %s \'%s\'" new_path_str comment) in
- (* Sort child names, if required *)
- let child_names = Vytree.list_children ct in
- let child_names =
- begin
- match reftree with
- | Some rt ->
- if ((RT.get_keep_order rt path) && (not alwayssort)) then child_names
- else (List.sort BatString.numeric_compare child_names)
- | None ->
- if alwayssort then (List.sort BatString.numeric_compare child_names)
- else child_names
- end
- in
- (* Now handle the different cases for nodes with and without children *)
- match child_names with
- | [] ->
- (* This is a leaf node *)
- let values = List.map String.escaped data.values in
- let cmds =
- begin
- match values with
- | [] ->
- (* Valueless leaf node *)
- String.concat " " new_path |> Printf.sprintf "set %s"
- | [v] ->
- (* Single value, just one command *)
- render_set_path new_path v
- | vs ->
- (* A leaf node with multiple values *)
- List.map (render_set_path new_path) vs |> String.concat "\n"
- end
- in
- if comment_cmd = "" then cmds else Printf.sprintf "%s\n%s" cmds comment_cmd
- | children ->
- (* A node with children *)
- let children = List.map (fun n -> Vytree.get ct [n]) child_names in
- let rendered_children = List.map (render_commands ~reftree:reftree ~alwayssort:alwayssort new_path) children in
- let cmds = String.concat "\n" rendered_children in
- if comment_cmd = "" then cmds else Printf.sprintf "%s\n%s" cmds comment_cmd
-
-
-end (* Renderer *)
-
-let render = Renderer.render
-
-let render_at_level
- ?(indent=4)
- ?(reftree=None)
- ?(cmp=BatString.numeric_compare)
- ?(showephemeral=false)
- ?(showinactive=false)
- node
- path =
- let node =
- match path with
- | [] -> node
- | _ -> Vytree.get node path
- in
- let children = Vytree.children_of_node node in
- let child_configs = List.map (render ~indent:indent ~reftree:reftree ~cmp:cmp ~showephemeral:showephemeral ~showinactive:showinactive) children in
- String.concat "\n" child_configs
-
-let render_commands ?(reftree=None) ?(alwayssort=false) ?(sortchildren=false) node path =
- let node =
- match path with
- | [] -> node
- | _ -> Vytree.get node path
- in
- let children =
- if sortchildren then Vytree.sorted_children_of_node (BatString.numeric_compare) node
- else Vytree.children_of_node node
- in
- let commands = List.map (Renderer.render_commands ~reftree:reftree ~alwayssort:alwayssort path) children in
- String.concat "\n" commands
diff --git a/src/config_tree.mli b/src/config_tree.mli
deleted file mode 100644
index 79426e3..0000000
--- a/src/config_tree.mli
+++ /dev/null
@@ -1,78 +0,0 @@
-type value_behaviour = AddValue | ReplaceValue
-
-exception Duplicate_value
-exception Node_has_no_value
-exception No_such_value
-exception Useless_set
-
-type config_node_data = {
- values : string list;
- comment : string option;
- inactive : bool;
- ephemeral : bool;
-} [@@deriving yojson]
-
-type t = config_node_data Vytree.t [@@deriving yojson]
-
-val default_data : config_node_data
-
-val make : string -> t
-
-val set : t -> string list -> string option -> value_behaviour -> t
-
-val delete : t -> string list -> string option -> t
-
-val get_values : t -> string list -> string list
-
-val get_value : t -> string list -> string
-
-val set_comment : t -> string list -> string option -> t
-
-val get_comment : t -> string list -> string option
-
-val set_inactive : t -> string list -> bool -> t
-
-val is_inactive : t -> string list -> bool
-
-val set_ephemeral : t -> string list -> bool -> t
-
-val is_ephemeral : t -> string list -> bool
-
-(** Interface to two rendering routines:
- 1. The stand-alone routine, when [reftree] is not provided
- 2. The reference-tree guided routine, when [reftree] is provided.
-
- If an {i incomplete} reftree is supplied, then the remaining portion of the
- config tree will be rendered according to the stand-alone routine.
-
- If an {i incompatible} reftree is supplied (i.e., the name of the nodes of
- the reftree do not match the name of the nodes in the config tree), then the
- exception {! Config_tree.Renderer.Inapt_reftree} is raised.
-
- @param indent spaces by which each level of nesting should be indented
- @param reftree optional reference tree used to instruct rendering
- @param cmp function used to sort the order of children, overruled
- if [reftree] specifies [keep_order] for a node
- @param showephemeral boolean determining whether ephemeral nodes are shown
- @param showinactive boolean determining whether inactive nodes are shown
-*)
-val render :
- ?indent:int ->
- ?reftree:(Reference_tree.t option)->
- ?cmp:(string -> string -> int) ->
- ?showephemeral:bool ->
- ?showinactive:bool ->
- t ->
- string
-
-val render_at_level :
- ?indent:int ->
- ?reftree:(Reference_tree.t option)->
- ?cmp:(string -> string -> int) ->
- ?showephemeral:bool ->
- ?showinactive:bool ->
- t ->
- string list ->
- string
-
-val render_commands: ?reftree:(Reference_tree.t option) -> ?alwayssort:bool -> ?sortchildren:bool -> t -> string list -> string
diff --git a/src/curly_lexer.mll b/src/curly_lexer.mll
deleted file mode 100644
index 32e566a..0000000
--- a/src/curly_lexer.mll
+++ /dev/null
@@ -1,90 +0,0 @@
-{
-
-open Curly_parser
-
-exception Error of string
-
-}
-
-rule token = parse
-| [' ' '\t' '\r']
- { token lexbuf }
-| '\n'
- { Lexing.new_line lexbuf; token lexbuf }
-| '"'
- { read_string (Buffer.create 16) lexbuf }
-| '''
- { read_single_quoted_string (Buffer.create 16) lexbuf }
-| "//" [^ '\n']+ '\n'
- { Lexing.new_line lexbuf ; token lexbuf }
-| "/*"
- { read_comment (Buffer.create 16) lexbuf }
-| "#INACTIVE"
- { INACTIVE }
-| "#EPHEMERAL"
- { EPHEMERAL }
-| '{'
- { LEFT_BRACE }
-| '}'
- { RIGHT_BRACE }
-| '['
- { LEFT_BRACKET }
-| ']'
- { RIGHT_BRACKET }
-| ';'
- { SEMI }
-| [^ ' ' '\t' '\n' '\r' '{' '}' '[' ']' ';' '#' '"' ''' ]+ as s
- { IDENTIFIER s}
-| eof
- { EOF }
-| _
-{ raise (Error (Printf.sprintf "At offset %d: unexpected character.\n" (Lexing.lexeme_start lexbuf))) }
-
-and read_string buf =
- parse
- | '"' { STRING (Buffer.contents buf) }
- | '\\' '/' { Buffer.add_char buf '/'; read_string buf lexbuf }
- | '\\' '\\' { Buffer.add_char buf '\\'; read_string buf lexbuf }
- | '\\' 'b' { Buffer.add_char buf '\b'; read_string buf lexbuf }
- | '\\' 'f' { Buffer.add_char buf '\012'; read_string buf lexbuf }
- | '\\' 'n' { Buffer.add_char buf '\n'; read_string buf lexbuf }
- | '\\' 'r' { Buffer.add_char buf '\r'; read_string buf lexbuf }
- | '\\' 't' { Buffer.add_char buf '\t'; read_string buf lexbuf }
- | '\\' '\'' { Buffer.add_char buf '\''; read_string buf lexbuf }
- | '\\' '"' { Buffer.add_char buf '"'; read_string buf lexbuf }
- | '\n' { Lexing.new_line lexbuf; Buffer.add_char buf '\n'; read_string buf lexbuf }
- | [^ '"' '\\']+
- { Buffer.add_string buf (Lexing.lexeme lexbuf);
- read_string buf lexbuf
- }
- | _ { raise (Error (Printf.sprintf "Illegal string character: %s" (Lexing.lexeme lexbuf))) }
- | eof { raise (Error ("String is not terminated")) }
-
-and read_single_quoted_string buf =
- parse
- | ''' { STRING (Buffer.contents buf) }
- | '\\' '/' { Buffer.add_char buf '/'; read_string buf lexbuf }
- | '\\' '\\' { Buffer.add_char buf '\\'; read_string buf lexbuf }
- | '\\' 'b' { Buffer.add_char buf '\b'; read_string buf lexbuf }
- | '\\' 'f' { Buffer.add_char buf '\012'; read_string buf lexbuf }
- | '\\' 'n' { Buffer.add_char buf '\n'; read_string buf lexbuf }
- | '\\' 'r' { Buffer.add_char buf '\r'; read_string buf lexbuf }
- | '\\' 't' { Buffer.add_char buf '\t'; read_string buf lexbuf }
- | '\\' '\'' { Buffer.add_char buf '\''; read_string buf lexbuf }
- | '\\' '"' { Buffer.add_char buf '"'; read_string buf lexbuf }
- | '\n' { Lexing.new_line lexbuf; Buffer.add_char buf '\n'; read_string buf lexbuf }
- | [^ ''' '\\']+
- { Buffer.add_string buf (Lexing.lexeme lexbuf);
- read_single_quoted_string buf lexbuf
- }
- | _ { raise (Error (Printf.sprintf "Illegal string character: %s" (Lexing.lexeme lexbuf))) }
- | eof { raise (Error ("String is not terminated")) }
-
-and read_comment buf =
- parse
- | "*/"
- { COMMENT (Buffer.contents buf) }
- | _
- { Buffer.add_string buf (Lexing.lexeme lexbuf);
- read_comment buf lexbuf
- }
diff --git a/src/curly_parser.mly b/src/curly_parser.mly
deleted file mode 100644
index be5aadc..0000000
--- a/src/curly_parser.mly
+++ /dev/null
@@ -1,114 +0,0 @@
-%{
- open Config_tree
-
- exception Duplicate_child of (string * string)
-
- (* Used for checking if after merging immediate children,
- any of them have duplicate children inside,
- e.g. "interfaces { ethernet eth0 {...} ethernet eth0 {...} }" *)
- let find_duplicate_children n =
- let rec aux xs =
- let xs = List.sort compare xs in
- match xs with
- | [] | [_] -> ()
- | x :: x' :: xs ->
- if x = x' then raise (Duplicate_child (Vytree.name_of_node n, x))
- else aux (x' :: xs)
- in
- aux @@ Vytree.list_children n
-
- (* When merging nodes with values, append values of subsequent nodes to the
- first one *)
- let merge_data l r = {l with values=(List.append l.values r.values)}
-%}
-
-%token <string> IDENTIFIER
-%token <string> STRING
-%token <string> COMMENT
-%token INACTIVE
-%token EPHEMERAL
-%token LEFT_BRACE
-%token RIGHT_BRACE
-%token LEFT_BRACKET
-%token RIGHT_BRACKET
-%token SEMI
-%token EOF
-
-%start <Config_tree.t> config
-%%
-
-opt_comment:
- | (* empty *) { None }
- | c = COMMENT { Some (String.trim c) }
-;
-
-value:
- | v = STRING
- { v }
- | v = IDENTIFIER
- { v }
-;
-
-values:
- | v = value { [v] }
- | LEFT_BRACKET; vs = separated_nonempty_list(SEMI, value); RIGHT_BRACKET
- { (List.rev vs) }
-;
-
-leaf_node:
- | comment = opt_comment; inactive = boption(INACTIVE); ephemeral = boption(EPHEMERAL);
- name = IDENTIFIER; values = values; SEMI
- { Vytree.make_full {values=(List.rev values); comment=comment; inactive=inactive; ephemeral=ephemeral} name []}
- | comment = opt_comment; inactive = boption(INACTIVE); ephemeral = boption(EPHEMERAL);
- name = IDENTIFIER; SEMI (* valueless node *)
- { Vytree.make_full {default_data with comment=comment; inactive=inactive; ephemeral=ephemeral} name [] }
-;
-
-node:
- | comment = opt_comment; inactive = boption(INACTIVE); ephemeral = boption(EPHEMERAL);
- name = IDENTIFIER; LEFT_BRACE; children = list(node_content); RIGHT_BRACE
- {
- let node =
- Vytree.make_full {default_data with comment=comment; inactive=inactive; ephemeral=ephemeral} name [] in
- let node = List.fold_left Vytree.adopt node (List.rev children) |> Vytree.merge_children merge_data in
- try
- List.iter find_duplicate_children (Vytree.children_of_node node);
- node
- with
- | Duplicate_child (child, dup) ->
- failwith (Printf.sprintf "Node \"%s %s\" has two children named \"%s\"" name child dup)
- }
-;
-
-tag_node:
- | comment = opt_comment; inactive = boption(INACTIVE); ephemeral = boption(EPHEMERAL);
- name = IDENTIFIER; tag = IDENTIFIER; LEFT_BRACE; children = list(node_content); RIGHT_BRACE
- {
- let outer_node = Vytree.make_full default_data name [] in
- let inner_node =
- Vytree.make_full {default_data with comment=comment; inactive=inactive; ephemeral=ephemeral} tag [] in
- let inner_node = List.fold_left Vytree.adopt inner_node (List.rev children) |> Vytree.merge_children merge_data in
- let node = Vytree.adopt outer_node inner_node in
- try
- List.iter find_duplicate_children (Vytree.children_of_node inner_node);
- node
- with
- | Duplicate_child (child, dup) ->
- failwith (Printf.sprintf "Node \"%s %s %s\" has two children named \"%s\"" name tag child dup)
- }
-
-node_content: n = node { n } | n = leaf_node { n } | n = tag_node { n };
-
-%public config:
- | ns = list(node); EOF
- {
- let root = make "root" in
- let root = List.fold_left Vytree.adopt root (List.rev ns) |> Vytree.merge_children merge_data in
- try
- List.iter find_duplicate_children (Vytree.children_of_node root);
- root
- with
- | Duplicate_child (child, dup) ->
- failwith (Printf.sprintf "Node \"%s\" has two children named \"%s\"" child dup)
- }
-;
diff --git a/src/dune b/src/dune
new file mode 100644
index 0000000..ff86052
--- /dev/null
+++ b/src/dune
@@ -0,0 +1,5 @@
+(library
+ (name vyconf)
+ (public_name vyconf)
+ (libraries vyos1x-config lwt lwt.unix lwt_log lwt_ppx ocaml-protoc toml sha yojson ppx_deriving.show ppx_deriving_yojson)
+ (preprocess (pps lwt_ppx ppx_deriving.show ppx_deriving_yojson)))
diff --git a/src/reference_tree.ml b/src/reference_tree.ml
deleted file mode 100644
index 45789eb..0000000
--- a/src/reference_tree.ml
+++ /dev/null
@@ -1,237 +0,0 @@
-type node_type = Leaf | Tag | Other
-
-type ref_node_data = {
- node_type: node_type;
- constraints: (Value_checker.value_constraint list);
- help: string;
- value_help: (string * string) list;
- constraint_error_message: string;
- multi: bool;
- valueless: bool;
- owner: string option;
- keep_order: bool;
- hidden: bool;
- secret: bool;
-}
-
-type t = ref_node_data Vytree.t
-
-exception Bad_interface_definition of string
-
-exception Validation_error of string
-
-let default_data = {
- node_type = Other;
- constraints = [];
- help = "No help available";
- value_help = [];
- constraint_error_message = "Invalid value";
- multi = false;
- valueless = false;
- owner = None;
- keep_order = false;
- hidden = false;
- secret = false;
-}
-
-let default = Vytree.make default_data "root"
-
-(* Loading from XML *)
-
-let node_type_of_string s =
- match s with
- | "node" -> Other
- | "tagNode" -> Tag
- | "leafNode" -> Leaf
- | _ -> raise (Bad_interface_definition
- (Printf.sprintf "node, tagNode, or leafNode expected, %s found" s))
-
-let load_constraint_from_xml d c =
- let aux d c =
- match c with
- | Xml.Element ("regex", _, [Xml.PCData s]) ->
- let cs = (Value_checker.Regex s) :: d.constraints in
- {d with constraints=cs}
- | Xml.Element ("validator", [("name", n); ("argument", a)], _) ->
- let cs = (Value_checker.External (n, Some a)) :: d.constraints in
- {d with constraints=cs}
- | Xml.Element ("validator", [("name", n)], _) ->
- let cs = (Value_checker.External (n, None)) :: d.constraints in
- {d with constraints=cs}
- | _ -> raise (Bad_interface_definition "Malformed constraint")
- in Xml.fold aux d c
-
-let data_from_xml d x =
- let aux d x =
- match x with
- | Xml.Element ("help", _, [Xml.PCData s]) -> {d with help=s}
- | Xml.Element ("valueHelp", _,
- [Xml.Element ("format", _, [Xml.PCData fmt]);
- Xml.Element ("description", _, [Xml.PCData descr])]) ->
- let vhs = d.value_help in
- let vhs' = (fmt, descr) :: vhs in
- {d with value_help=vhs'}
- | Xml.Element ("multi", _, _) -> {d with multi=true}
- | Xml.Element ("valueless", _, _) -> {d with valueless=true}
- | Xml.Element ("constraintErrorMessage", _, [Xml.PCData s]) ->
- {d with constraint_error_message=s}
- | Xml.Element ("constraint", _, _) -> load_constraint_from_xml d x
- | Xml.Element ("hidden", _, _) -> {d with hidden=true}
- | Xml.Element ("secret", _, _) -> {d with secret=true}
- | Xml.Element ("keepChildOrder", _, _) -> {d with keep_order=true}
- | _ -> raise (Bad_interface_definition "Malformed property tag")
- in Xml.fold aux d x
-
-let rec insert_from_xml basepath reftree xml =
- match xml with
- | Xml.Element (tag, _, _) ->
- let props = Util.find_xml_child "properties" xml in
- let data =
- (match props with
- | None -> default_data
- | Some p -> data_from_xml default_data p)
- in
- let node_type = node_type_of_string (Xml.tag xml) in
- let node_owner = try let o = Xml.attrib xml "owner" in Some o
- with _ -> None
- in
- let data = {data with node_type=node_type; owner=node_owner} in
- let name = Xml.attrib xml "name" in
- let path = basepath @ [name] in
- let new_tree = Vytree.insert reftree path data in
- (match node_type with
- | Leaf -> new_tree
- | _ ->
- let children = Util.find_xml_child "children" xml in
- (match children with
- | None -> raise (Bad_interface_definition (Printf.sprintf "Node %s has no children" name))
- | Some c -> List.fold_left (insert_from_xml path) new_tree (Xml.children c)))
- | _ -> raise (Bad_interface_definition "PCData not allowed here")
-
-let load_from_xml reftree file =
- let xml_to_reftree xml reftree =
- match xml with
- | Xml.Element ("interfaceDefinition", attrs, children) ->
- List.fold_left (insert_from_xml []) reftree children
- | _ -> raise (Bad_interface_definition "Should start with <interfaceDefinition>")
- in
- try
- let xml = Xml.parse_file file in
- xml_to_reftree xml reftree
- with
- | Xml.File_not_found msg -> raise (Bad_interface_definition msg)
- | Xml.Error e -> raise (Bad_interface_definition (Xml.error e))
-
-(* Validation function *)
-
-let has_illegal_characters name =
- (** Checks if string name has illegal characters in it.
- All whitespace, curly braces, square brackets, and quotes
- are disallowed due to their special significance to the curly config
- format parser *)
- try Some (Pcre.get_substring (Pcre.exec ~pat:"[\\s\\{\\}\\[\\]\"\'#]" name) 0)
- with Not_found -> None
-
-(** Takes a list of string that represents a configuration path that may have
- node value at the end, validates it, and splits it into path and value parts.
-
- A list of strings is a valid path that can be created in the config tree unless:
- 1. It's a tag node without a child
- 2. It's a non-valueless leaf node without a value
- 3. It's a valueless node with a value
- 4. It's a non-valueless leaf node with garbage after the value
- 5. It's a non-leaf, non-tag node with a name that doesn't exist
- in the reference tree
- *)
-let rec validate_path validators_dir node path =
- let show_path p = Printf.sprintf "[%s]" @@ Util.string_of_list (List.rev p) in
- let rec aux node path acc =
- let data = Vytree.data_of_node node in
- match data.node_type with
- | Leaf ->
- (match path with
- | [] ->
- if data.valueless then (List.rev acc, None)
- else raise (Validation_error
- (Printf.sprintf "Node %s requires a value" (show_path acc) ))
- | [p] ->
- if not data.valueless then
- (if (Value_checker.validate_any validators_dir data.constraints p) then (List.rev acc, Some p)
- else raise (Validation_error data.constraint_error_message))
- else raise (Validation_error
- (Printf.sprintf "Node %s cannot have a value" (show_path acc)))
- | p :: ps -> raise (Validation_error (Printf.sprintf "Path %s is too long" (show_path acc))))
- | Tag ->
- (match path with
- | p :: p' :: ps ->
- (match (has_illegal_characters p) with
- | Some c -> raise (Validation_error (Printf.sprintf "Illegal character \"%s\" in node name \"%s\"" c p))
- | None ->
- if (Value_checker.validate_any validators_dir data.constraints p) then
- let child = Vytree.find node p' in
- (match child with
- | Some c -> aux c ps (p' :: p :: acc)
- | None -> raise (Validation_error (Printf.sprintf "Node %s has no child %s" (show_path acc) p')))
- else raise (Validation_error (Printf.sprintf "%s is not a valid child name for node %s" p (show_path acc))))
- | [p] -> if (Value_checker.validate_any validators_dir data.constraints p) then (List.rev acc, None)
- else raise (Validation_error (Printf.sprintf "Node %s has no child %s" (show_path acc) p))
- | _ -> raise (Validation_error (Printf.sprintf "Path %s is incomplete" (show_path acc))))
- | Other ->
- (match path with
- | [] -> (List.rev acc, None)
- | p :: ps ->
- let child = Vytree.find node p in
- (match child with
- | Some c -> aux c ps (p :: acc)
- | None -> raise (Validation_error ((Printf.sprintf "Path %s is incomplete" (show_path acc))))))
- in aux node path []
-
-let is_multi reftree path =
- let data = Vytree.get_data reftree path in
- data.multi
-
-let is_hidden reftree path =
- let data = Vytree.get_data reftree path in
- data.hidden
-
-let is_secret reftree path =
- let data = Vytree.get_data reftree path in
- data.secret
-
-let is_tag reftree path =
- let data = Vytree.get_data reftree path in
- match data.node_type with
- | Tag -> true
- | _ -> false
-
-let is_leaf reftree path =
- let data = Vytree.get_data reftree path in
- match data.node_type with
- | Leaf -> true
- | _ -> false
-
-let is_valueless reftree path =
- let data = Vytree.get_data reftree path in
- data.valueless
-
-let get_keep_order reftree path =
- let data = Vytree.get_data reftree path in
- data.keep_order
-
-let get_owner reftree path =
- let data = Vytree.get_data reftree path in
- data.owner
-
-let get_help_string reftree path =
- let data = Vytree.get_data reftree path in
- data.help
-
-let get_value_help reftree path =
- let data = Vytree.get_data reftree path in
- data.value_help
-
-let get_completion_data reftree path =
- let aux node =
- let data = Vytree.data_of_node node in
- (data.node_type, data.multi, data.help)
- in List.map aux (Vytree.children_of_node @@ Vytree.get reftree path)
diff --git a/src/reference_tree.mli b/src/reference_tree.mli
deleted file mode 100644
index 33813d5..0000000
--- a/src/reference_tree.mli
+++ /dev/null
@@ -1,51 +0,0 @@
-type node_type = Leaf | Tag | Other
-
-type ref_node_data = {
- node_type: node_type;
- constraints: (Value_checker.value_constraint list);
- help: string;
- value_help: (string * string) list;
- constraint_error_message: string;
- multi: bool;
- valueless: bool;
- owner: string option;
- keep_order: bool;
- hidden: bool;
- secret: bool;
-}
-
-exception Bad_interface_definition of string
-
-exception Validation_error of string
-
-type t = ref_node_data Vytree.t
-
-val default_data : ref_node_data
-
-val default : t
-
-val load_from_xml : t -> string -> t
-
-val validate_path : string -> t -> string list -> string list * string option
-
-val is_multi : t -> string list -> bool
-
-val is_hidden : t -> string list -> bool
-
-val is_secret : t -> string list -> bool
-
-val is_tag : t -> string list -> bool
-
-val is_leaf : t -> string list -> bool
-
-val is_valueless : t -> string list -> bool
-
-val get_keep_order : t -> string list -> bool
-
-val get_owner : t -> string list -> string option
-
-val get_help_string : t -> string list -> string
-
-val get_value_help : t -> string list -> (string * string) list
-
-val get_completion_data : t -> string list -> (node_type * bool * string) list
diff --git a/src/session.ml b/src/session.ml
index 832bfe6..7624bb0 100644
--- a/src/session.ml
+++ b/src/session.ml
@@ -1,5 +1,6 @@
-module CT = Config_tree
-module RT = Reference_tree
+module CT = Vyos1x.Config_tree
+module VT = Vyos1x.Vytree
+module RT = Vyos1x.Reference_tree
module D = Directories
exception Session_error of string
@@ -16,7 +17,7 @@ type world = {
}
type session_data = {
- proposed_config : Config_tree.t;
+ proposed_config : CT.t;
modified: bool;
conf_mode: bool;
changeset: cfg_op list;
@@ -64,20 +65,22 @@ let rec apply_changes changeset config =
| c :: cs -> apply_changes cs (apply_cfg_op c config)
let set w s path =
- let path, value = RT.validate_path D.(w.dirs.validators) w.reference_tree path in
+ let path, value = RT.validate_path D.(w.dirs.validators)
+ w.reference_tree path in
let value_behaviour = if RT.is_multi w.reference_tree path then CT.AddValue else CT.ReplaceValue in
let op = CfgSet (path, value, value_behaviour) in
let config = apply_cfg_op op s.proposed_config in
{s with proposed_config=config; changeset=(op :: s.changeset)}
let delete w s path =
- let path, value = RT.validate_path D.(w.dirs.validators) w.reference_tree path in
+ let path, value = RT.validate_path D.(w.dirs.validators)
+ w.reference_tree path in
let op = CfgDelete (path, value) in
let config = apply_cfg_op op s.proposed_config in
{s with proposed_config=config; changeset=(op :: s.changeset)}
let get_value w s path =
- if not (Vytree.exists s.proposed_config path) then
+ if not (VT.exists s.proposed_config path) then
raise (Session_error ("Path does not exist"))
else if not (RT.is_leaf w.reference_tree path) then
raise (Session_error "Cannot get a value of a non-leaf node")
@@ -88,7 +91,7 @@ let get_value w s path =
else CT.get_value s.proposed_config path
let get_values w s path =
- if not (Vytree.exists s.proposed_config path) then
+ if not (VT.exists s.proposed_config path) then
raise (Session_error ("Path does not exist"))
else if not (RT.is_leaf w.reference_tree path) then
raise (Session_error "Cannot get a value of a non-leaf node")
@@ -97,18 +100,18 @@ let get_values w s path =
else CT.get_values s.proposed_config path
let list_children w s path =
- if not (Vytree.exists s.proposed_config path) then
+ if not (VT.exists s.proposed_config path) then
raise (Session_error ("Path does not exist"))
else if (RT.is_leaf w.reference_tree path) then
raise (Session_error "Cannot list children of a leaf node")
- else Vytree.children_of_path s.proposed_config path
+ else VT.children_of_path s.proposed_config path
-let exists w s path =
- Vytree.exists s.proposed_config path
+let exists _w s path =
+ VT.exists s.proposed_config path
-let show_config w s path fmt =
+let show_config _w s path fmt =
let open Vyconf_types in
- if (path <> []) && not (Vytree.exists s.proposed_config path) then
+ if (path <> []) && not (VT.exists s.proposed_config path) then
raise (Session_error ("Path does not exist"))
else
let node = s.proposed_config in
@@ -117,5 +120,5 @@ let show_config w s path fmt =
| Json ->
let node =
(match path with [] -> s.proposed_config |
- _ as ps -> Vytree.get s.proposed_config ps) in
+ _ as ps -> VT.get s.proposed_config ps) in
CT.to_yojson node |> Yojson.Safe.pretty_to_string
diff --git a/src/session.mli b/src/session.mli
index 299f2ca..f59ea7b 100644
--- a/src/session.mli
+++ b/src/session.mli
@@ -1,16 +1,16 @@
type cfg_op =
- | CfgSet of string list * string option * Config_tree.value_behaviour
+ | CfgSet of string list * string option * Vyos1x.Config_tree.value_behaviour
| CfgDelete of string list * string option
type world = {
- running_config: Config_tree.t;
- reference_tree: Reference_tree.t;
+ running_config: Vyos1x.Config_tree.t;
+ reference_tree: Vyos1x.Reference_tree.t;
vyconf_config: Vyconf_config.t;
dirs: Directories.t
}
type session_data = {
- proposed_config : Config_tree.t;
+ proposed_config : Vyos1x.Config_tree.t;
modified: bool;
conf_mode: bool;
changeset: cfg_op list;
@@ -22,6 +22,10 @@ exception Session_error of string
val make : world -> string -> string -> session_data
+val set_modified : session_data -> session_data
+
+val apply_changes : cfg_op list -> Vyos1x.Config_tree.t -> Vyos1x.Config_tree.t
+
val set : world -> session_data -> string list -> session_data
val delete : world -> session_data -> string list -> session_data
diff --git a/src/startup.ml b/src/startup.ml
index cea5f02..4cf109c 100644
--- a/src/startup.ml
+++ b/src/startup.ml
@@ -75,11 +75,21 @@ let create_server accept_connection sock =
let load_config file =
try
let chan = open_in file in
- let config = Curly_parser.config Curly_lexer.token (Lexing.from_channel chan) in
+ let s = really_input_string chan (in_channel_length chan) in
+ let config = Vyos1x.Parser.from_string s in
Ok config
with
| Sys_error msg -> Error msg
- | Curly_parser.Error -> Error "Parse error"
+ | Vyos1x.Util.Syntax_error (opt, msg) ->
+ begin
+ match opt with
+ | None ->
+ let out = Printf.sprintf "Parse error: %s\n" msg
+ in Error out
+ | Some (line, pos) ->
+ let out = Printf.sprintf "Parse error: %s line %d pos %d\n" msg line pos
+ in Error out
+ end
(** Load the appliance configuration file or the fallback config *)
let load_config_failsafe main fallback =
@@ -99,7 +109,7 @@ let load_config_failsafe main fallback =
(* Load interface definitions from a directory into a reference tree *)
let load_interface_definitions dir =
- let open Reference_tree in
+ let open Vyos1x.Reference_tree in
let relative_paths = FileUtil.ls dir in
let absolute_paths =
try Ok (List.map Util.absolute_path relative_paths)
diff --git a/src/startup.mli b/src/startup.mli
index c32ddea..abe731f 100644
--- a/src/startup.mli
+++ b/src/startup.mli
@@ -12,8 +12,8 @@ val create_server :
(Lwt_unix.file_descr * Lwt_unix.sockaddr -> unit Lwt.t) ->
Lwt_unix.file_descr -> unit -> 'a Lwt.t
-val load_config : string -> (Config_tree.t, string) result
+val load_config : string -> (Vyos1x.Config_tree.t, string) result
-val load_config_failsafe : string -> string -> Config_tree.t
+val load_config_failsafe : string -> string -> Vyos1x.Config_tree.t
-val load_interface_definitions : string -> (Reference_tree.t, string) result
+val load_interface_definitions : string -> (Vyos1x.Reference_tree.t, string) result
diff --git a/src/util.ml b/src/util.ml
index c4bbd96..ec988e9 100644
--- a/src/util.ml
+++ b/src/util.ml
@@ -8,7 +8,7 @@ let find_xml_child name xml =
| _ -> false
in
match xml with
- | Xml.Element (_, _, children) -> Vylist.find find_aux children
+ | Xml.Element (_, _, children) -> Vyos1x.Vylist.find find_aux children
| Xml.PCData _ -> None
(** Convert a list of strings to a string of unquoted, space separated words *)
diff --git a/src/value_checker.ml b/src/value_checker.ml
deleted file mode 100644
index aa88f7b..0000000
--- a/src/value_checker.ml
+++ /dev/null
@@ -1,39 +0,0 @@
-module F = Filename
-
-type value_constraint = Regex of string | External of string * string option
-
-exception Bad_validator of string
-
-let validate_value dir value_constraint value =
- match value_constraint with
- | Regex s ->
- (try
- let _ = Pcre.exec ~pat:s value in true
- with Not_found -> false)
- | External (v, c) ->
- (* XXX: Using Unix.system is a bad idea on multiple levels,
- especially when the input comes directly from the user...
- We should do something about it.
- *)
- let validator = F.concat dir v in
- let arg = BatOption.default "" c in
- let safe_arg = Printf.sprintf "'%s'" (Pcre.qreplace ~pat:"\"" ~templ:"\\\"" arg) in
- let result = Unix.system (Printf.sprintf "%s %s %s" validator safe_arg value) in
- match result with
- | Unix.WEXITED 0 -> true
- | Unix.WEXITED 127 -> raise (Bad_validator (Printf.sprintf "Could not execute validator %s" validator))
- | _ -> false
-
-(* If no constraints given, consider it valid.
- Otherwise consider it valid if it satisfies at least
- one constraint *)
-let validate_any validators constraints value =
- let rec aux validators constraints value =
- match constraints with
- | [] -> false
- | c :: cs -> if validate_value validators c value then true
- else aux validators cs value
- in
- match constraints with
- | [] -> true
- | _ -> aux validators constraints value
diff --git a/src/value_checker.mli b/src/value_checker.mli
deleted file mode 100644
index d786f5e..0000000
--- a/src/value_checker.mli
+++ /dev/null
@@ -1,7 +0,0 @@
-type value_constraint = Regex of string | External of string * string option
-
-exception Bad_validator of string
-
-val validate_value : string -> value_constraint -> string -> bool
-
-val validate_any : string -> value_constraint list -> string -> bool
diff --git a/src/vycli.ml b/src/vycli.ml
index e00a4e3..6c1ed0c 100644
--- a/src/vycli.ml
+++ b/src/vycli.ml
@@ -60,7 +60,7 @@ let main socket op path out_format config_format =
begin
match resp.status with
| Success -> Ok "" |> Lwt.return
- | _ -> Error (BatOption.default "" resp.error) |> Lwt.return
+ | _ -> Error (Option.value resp.error ~default:"") |> Lwt.return
end
| OpSetupSession ->
let%lwt resp = setup_session client "vycli" in
@@ -81,7 +81,7 @@ let main socket op path out_format config_format =
| Error e -> let%lwt () = Lwt_io.write Lwt_io.stderr (Printf.sprintf "%s\n" e) in Lwt.return 1
let _ =
- let () = Arg.parse args (fun f -> ()) usage in
+ let () = Arg.parse args (fun _ -> ()) usage in
let path = String.trim !path_opt |> Pcre.split ~pat:"\\s+" in
let out_format = output_format_of_string !out_format_opt in
let config_format = config_format_of_string !conf_format_opt in
diff --git a/src/vyconf_client.ml b/src/vyconf_client.ml
index db7d9c1..63ff121 100644
--- a/src/vyconf_client.ml
+++ b/src/vyconf_client.ml
@@ -22,8 +22,8 @@ let create ?(token=None) sockfile out_format conf_format =
let open Lwt_unix in
let sock = socket PF_UNIX SOCK_STREAM 0 in
let%lwt () = connect sock (ADDR_UNIX sockfile) in
- let ic = Lwt_io.of_fd Lwt_io.Input sock in
- let oc = Lwt_io.of_fd Lwt_io.Output sock in
+ let ic = Lwt_io.of_fd ~mode:Lwt_io.Input sock in
+ let oc = Lwt_io.of_fd ~mode:Lwt_io.Output sock in
Lwt.return {
sock=sock; ic=ic; oc=oc;
enc=(Pbrt.Encoder.create ()); closed=false;
@@ -55,7 +55,7 @@ let get_status client =
Lwt.return resp
let setup_session ?(on_behalf_of=None) client client_app =
- if BatOption.is_some client.session then Lwt.return (Error "Client is already associated with a session") else
+ if Option.is_some client.session then Lwt.return (Error "Client is already associated with a session") else
let id = on_behalf_of |> (function None -> None | Some x -> (Some (Int32.of_int x))) in
let req = Setup_session {client_application=(Some client_app); on_behalf_of=id} in
let%lwt resp = do_request client req in
@@ -64,7 +64,7 @@ let setup_session ?(on_behalf_of=None) client client_app =
(match resp.output with
| Some token -> Ok {client with session=(Some token)}
| None -> Error "setup_session did not return a session token!") |> Lwt.return
- | _ -> Error (BatOption.default "Unknown error" resp.error) |> Lwt.return
+ | _ -> Error (Option.value resp.error ~default:"Unknown error") |> Lwt.return
let exists client path =
let req = Exists {path=path} in
@@ -72,33 +72,33 @@ let exists client path =
match resp.status with
| Success -> Lwt.return (Ok "")
| Fail -> Lwt.return (Error "")
- | _ -> Error (BatOption.default "" resp.error) |> Lwt.return
+ | _ -> Error (Option.value resp.error ~default:"") |> Lwt.return
let get_value client path =
let req = Get_value {path=path; output_format=(Some client.out_format)} in
let%lwt resp = do_request client req in
match resp.status with
| Success -> unwrap resp.output |> Lwt.return
- | _ -> Error (BatOption.default ""resp.error) |> Lwt.return
+ | _ -> Error (Option.value resp.error ~default:"") |> Lwt.return
let get_values client path =
let req = Get_values {path=path; output_format=(Some client.out_format)} in
let%lwt resp = do_request client req in
match resp.status with
| Success -> unwrap resp.output |> Lwt.return
- | _ -> Error (BatOption.default "" resp.error) |> Lwt.return
+ | _ -> Error (Option.value resp.error ~default:"") |> Lwt.return
let list_children client path =
let req = List_children {path=path; output_format=(Some client.out_format)} in
let%lwt resp = do_request client req in
match resp.status with
| Success -> unwrap resp.output |> Lwt.return
- | _ -> Error (BatOption.default "" resp.error) |> Lwt.return
+ | _ -> Error (Option.value resp.error ~default:"") |> Lwt.return
let show_config client path =
let req = Show_config {path=path; format=(Some client.conf_format)} in
let%lwt resp = do_request client req in
match resp.status with
| Success -> unwrap resp.output |> Lwt.return
- | _ -> Error (BatOption.default "" resp.error) |> Lwt.return
+ | _ -> Error (Option.value resp.error ~default:"") |> Lwt.return
diff --git a/src/vyconf_config.ml b/src/vyconf_config.ml
index 7a87c1a..07ab3ef 100644
--- a/src/vyconf_config.ml
+++ b/src/vyconf_config.ml
@@ -37,7 +37,7 @@ let get_field conf tbl_name field_name =
(* NB: TomlLenses module uses "table" and "field" names for function names,
hence tbl_name and field_name
*)
- TomlLenses.(get conf (key tbl_name |-- table |-- key field_name |-- string))
+ Toml.Lenses.(get conf (key tbl_name |-- table |-- key field_name |-- string))
let mandatory_field conf table field =
let value = get_field conf table field in
@@ -47,7 +47,7 @@ let mandatory_field conf table field =
let optional_field default conf table field =
let value = get_field conf table field in
- BatOption.default default value
+ Option.value value ~default:default
let load filename =
try
diff --git a/src/vyconf_pb.ml b/src/vyconf_pb.ml
index 4dced0f..c6155da 100644
--- a/src/vyconf_pb.ml
+++ b/src/vyconf_pb.ml
@@ -806,13 +806,13 @@ let rec encode_request_output_format (v:Vyconf_types.request_output_format) enco
let rec encode_request_setup_session (v:Vyconf_types.request_setup_session) encoder =
begin match v.Vyconf_types.client_application with
| Some x ->
- Pbrt.Encoder.key (1, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 1 Pbrt.Bytes encoder;
Pbrt.Encoder.string x encoder;
| None -> ();
end;
begin match v.Vyconf_types.on_behalf_of with
| Some x ->
- Pbrt.Encoder.key (2, Pbrt.Varint) encoder;
+ Pbrt.Encoder.key 2 Pbrt.Varint encoder;
Pbrt.Encoder.int32_as_varint x encoder;
| None -> ();
end;
@@ -820,12 +820,12 @@ let rec encode_request_setup_session (v:Vyconf_types.request_setup_session) enco
let rec encode_request_set (v:Vyconf_types.request_set) encoder =
List.iter (fun x ->
- Pbrt.Encoder.key (1, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 1 Pbrt.Bytes encoder;
Pbrt.Encoder.string x encoder;
) v.Vyconf_types.path;
begin match v.Vyconf_types.ephemeral with
| Some x ->
- Pbrt.Encoder.key (3, Pbrt.Varint) encoder;
+ Pbrt.Encoder.key 3 Pbrt.Varint encoder;
Pbrt.Encoder.bool x encoder;
| None -> ();
end;
@@ -833,96 +833,96 @@ let rec encode_request_set (v:Vyconf_types.request_set) encoder =
let rec encode_request_delete (v:Vyconf_types.request_delete) encoder =
List.iter (fun x ->
- Pbrt.Encoder.key (1, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 1 Pbrt.Bytes encoder;
Pbrt.Encoder.string x encoder;
) v.Vyconf_types.path;
()
let rec encode_request_rename (v:Vyconf_types.request_rename) encoder =
List.iter (fun x ->
- Pbrt.Encoder.key (1, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 1 Pbrt.Bytes encoder;
Pbrt.Encoder.string x encoder;
) v.Vyconf_types.edit_level;
- Pbrt.Encoder.key (2, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 2 Pbrt.Bytes encoder;
Pbrt.Encoder.string v.Vyconf_types.from encoder;
- Pbrt.Encoder.key (3, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 3 Pbrt.Bytes encoder;
Pbrt.Encoder.string v.Vyconf_types.to_ encoder;
()
let rec encode_request_copy (v:Vyconf_types.request_copy) encoder =
List.iter (fun x ->
- Pbrt.Encoder.key (1, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 1 Pbrt.Bytes encoder;
Pbrt.Encoder.string x encoder;
) v.Vyconf_types.edit_level;
- Pbrt.Encoder.key (2, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 2 Pbrt.Bytes encoder;
Pbrt.Encoder.string v.Vyconf_types.from encoder;
- Pbrt.Encoder.key (3, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 3 Pbrt.Bytes encoder;
Pbrt.Encoder.string v.Vyconf_types.to_ encoder;
()
let rec encode_request_comment (v:Vyconf_types.request_comment) encoder =
List.iter (fun x ->
- Pbrt.Encoder.key (1, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 1 Pbrt.Bytes encoder;
Pbrt.Encoder.string x encoder;
) v.Vyconf_types.path;
- Pbrt.Encoder.key (2, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 2 Pbrt.Bytes encoder;
Pbrt.Encoder.string v.Vyconf_types.comment encoder;
()
let rec encode_request_commit (v:Vyconf_types.request_commit) encoder =
begin match v.Vyconf_types.confirm with
| Some x ->
- Pbrt.Encoder.key (1, Pbrt.Varint) encoder;
+ Pbrt.Encoder.key 1 Pbrt.Varint encoder;
Pbrt.Encoder.bool x encoder;
| None -> ();
end;
begin match v.Vyconf_types.confirm_timeout with
| Some x ->
- Pbrt.Encoder.key (2, Pbrt.Varint) encoder;
+ Pbrt.Encoder.key 2 Pbrt.Varint encoder;
Pbrt.Encoder.int32_as_varint x encoder;
| None -> ();
end;
begin match v.Vyconf_types.comment with
| Some x ->
- Pbrt.Encoder.key (3, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 3 Pbrt.Bytes encoder;
Pbrt.Encoder.string x encoder;
| None -> ();
end;
()
let rec encode_request_rollback (v:Vyconf_types.request_rollback) encoder =
- Pbrt.Encoder.key (1, Pbrt.Varint) encoder;
+ Pbrt.Encoder.key 1 Pbrt.Varint encoder;
Pbrt.Encoder.int32_as_varint v.Vyconf_types.revision encoder;
()
let rec encode_request_load (v:Vyconf_types.request_load) encoder =
- Pbrt.Encoder.key (1, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 1 Pbrt.Bytes encoder;
Pbrt.Encoder.string v.Vyconf_types.location encoder;
begin match v.Vyconf_types.format with
| Some x ->
- Pbrt.Encoder.key (2, Pbrt.Varint) encoder;
+ Pbrt.Encoder.key 2 Pbrt.Varint encoder;
encode_request_config_format x encoder;
| None -> ();
end;
()
let rec encode_request_merge (v:Vyconf_types.request_merge) encoder =
- Pbrt.Encoder.key (1, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 1 Pbrt.Bytes encoder;
Pbrt.Encoder.string v.Vyconf_types.location encoder;
begin match v.Vyconf_types.format with
| Some x ->
- Pbrt.Encoder.key (2, Pbrt.Varint) encoder;
+ Pbrt.Encoder.key 2 Pbrt.Varint encoder;
encode_request_config_format x encoder;
| None -> ();
end;
()
let rec encode_request_save (v:Vyconf_types.request_save) encoder =
- Pbrt.Encoder.key (1, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 1 Pbrt.Bytes encoder;
Pbrt.Encoder.string v.Vyconf_types.location encoder;
begin match v.Vyconf_types.format with
| Some x ->
- Pbrt.Encoder.key (2, Pbrt.Varint) encoder;
+ Pbrt.Encoder.key 2 Pbrt.Varint encoder;
encode_request_config_format x encoder;
| None -> ();
end;
@@ -930,12 +930,12 @@ let rec encode_request_save (v:Vyconf_types.request_save) encoder =
let rec encode_request_show_config (v:Vyconf_types.request_show_config) encoder =
List.iter (fun x ->
- Pbrt.Encoder.key (1, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 1 Pbrt.Bytes encoder;
Pbrt.Encoder.string x encoder;
) v.Vyconf_types.path;
begin match v.Vyconf_types.format with
| Some x ->
- Pbrt.Encoder.key (2, Pbrt.Varint) encoder;
+ Pbrt.Encoder.key 2 Pbrt.Varint encoder;
encode_request_config_format x encoder;
| None -> ();
end;
@@ -943,19 +943,19 @@ let rec encode_request_show_config (v:Vyconf_types.request_show_config) encoder
let rec encode_request_exists (v:Vyconf_types.request_exists) encoder =
List.iter (fun x ->
- Pbrt.Encoder.key (1, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 1 Pbrt.Bytes encoder;
Pbrt.Encoder.string x encoder;
) v.Vyconf_types.path;
()
let rec encode_request_get_value (v:Vyconf_types.request_get_value) encoder =
List.iter (fun x ->
- Pbrt.Encoder.key (1, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 1 Pbrt.Bytes encoder;
Pbrt.Encoder.string x encoder;
) v.Vyconf_types.path;
begin match v.Vyconf_types.output_format with
| Some x ->
- Pbrt.Encoder.key (2, Pbrt.Varint) encoder;
+ Pbrt.Encoder.key 2 Pbrt.Varint encoder;
encode_request_output_format x encoder;
| None -> ();
end;
@@ -963,12 +963,12 @@ let rec encode_request_get_value (v:Vyconf_types.request_get_value) encoder =
let rec encode_request_get_values (v:Vyconf_types.request_get_values) encoder =
List.iter (fun x ->
- Pbrt.Encoder.key (1, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 1 Pbrt.Bytes encoder;
Pbrt.Encoder.string x encoder;
) v.Vyconf_types.path;
begin match v.Vyconf_types.output_format with
| Some x ->
- Pbrt.Encoder.key (2, Pbrt.Varint) encoder;
+ Pbrt.Encoder.key 2 Pbrt.Varint encoder;
encode_request_output_format x encoder;
| None -> ();
end;
@@ -976,12 +976,12 @@ let rec encode_request_get_values (v:Vyconf_types.request_get_values) encoder =
let rec encode_request_list_children (v:Vyconf_types.request_list_children) encoder =
List.iter (fun x ->
- Pbrt.Encoder.key (1, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 1 Pbrt.Bytes encoder;
Pbrt.Encoder.string x encoder;
) v.Vyconf_types.path;
begin match v.Vyconf_types.output_format with
| Some x ->
- Pbrt.Encoder.key (2, Pbrt.Varint) encoder;
+ Pbrt.Encoder.key 2 Pbrt.Varint encoder;
encode_request_output_format x encoder;
| None -> ();
end;
@@ -989,100 +989,100 @@ let rec encode_request_list_children (v:Vyconf_types.request_list_children) enco
let rec encode_request_run_op_mode (v:Vyconf_types.request_run_op_mode) encoder =
List.iter (fun x ->
- Pbrt.Encoder.key (1, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 1 Pbrt.Bytes encoder;
Pbrt.Encoder.string x encoder;
) v.Vyconf_types.path;
begin match v.Vyconf_types.output_format with
| Some x ->
- Pbrt.Encoder.key (2, Pbrt.Varint) encoder;
+ Pbrt.Encoder.key 2 Pbrt.Varint encoder;
encode_request_output_format x encoder;
| None -> ();
end;
()
let rec encode_request_enter_configuration_mode (v:Vyconf_types.request_enter_configuration_mode) encoder =
- Pbrt.Encoder.key (1, Pbrt.Varint) encoder;
+ Pbrt.Encoder.key 1 Pbrt.Varint encoder;
Pbrt.Encoder.bool v.Vyconf_types.exclusive encoder;
- Pbrt.Encoder.key (2, Pbrt.Varint) encoder;
+ Pbrt.Encoder.key 2 Pbrt.Varint encoder;
Pbrt.Encoder.bool v.Vyconf_types.override_exclusive encoder;
()
let rec encode_request (v:Vyconf_types.request) encoder =
begin match v with
| Vyconf_types.Status ->
- Pbrt.Encoder.key (1, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 1 Pbrt.Bytes encoder;
Pbrt.Encoder.empty_nested encoder
| Vyconf_types.Setup_session x ->
- Pbrt.Encoder.key (2, Pbrt.Bytes) encoder;
- Pbrt.Encoder.nested (encode_request_setup_session x) encoder;
+ Pbrt.Encoder.key 2 Pbrt.Bytes encoder;
+ Pbrt.Encoder.nested encode_request_setup_session x encoder;
| Vyconf_types.Set x ->
- Pbrt.Encoder.key (3, Pbrt.Bytes) encoder;
- Pbrt.Encoder.nested (encode_request_set x) encoder;
+ Pbrt.Encoder.key 3 Pbrt.Bytes encoder;
+ Pbrt.Encoder.nested encode_request_set x encoder;
| Vyconf_types.Delete x ->
- Pbrt.Encoder.key (4, Pbrt.Bytes) encoder;
- Pbrt.Encoder.nested (encode_request_delete x) encoder;
+ Pbrt.Encoder.key 4 Pbrt.Bytes encoder;
+ Pbrt.Encoder.nested encode_request_delete x encoder;
| Vyconf_types.Rename x ->
- Pbrt.Encoder.key (5, Pbrt.Bytes) encoder;
- Pbrt.Encoder.nested (encode_request_rename x) encoder;
+ Pbrt.Encoder.key 5 Pbrt.Bytes encoder;
+ Pbrt.Encoder.nested encode_request_rename x encoder;
| Vyconf_types.Copy x ->
- Pbrt.Encoder.key (6, Pbrt.Bytes) encoder;
- Pbrt.Encoder.nested (encode_request_copy x) encoder;
+ Pbrt.Encoder.key 6 Pbrt.Bytes encoder;
+ Pbrt.Encoder.nested encode_request_copy x encoder;
| Vyconf_types.Comment x ->
- Pbrt.Encoder.key (7, Pbrt.Bytes) encoder;
- Pbrt.Encoder.nested (encode_request_comment x) encoder;
+ Pbrt.Encoder.key 7 Pbrt.Bytes encoder;
+ Pbrt.Encoder.nested encode_request_comment x encoder;
| Vyconf_types.Commit x ->
- Pbrt.Encoder.key (8, Pbrt.Bytes) encoder;
- Pbrt.Encoder.nested (encode_request_commit x) encoder;
+ Pbrt.Encoder.key 8 Pbrt.Bytes encoder;
+ Pbrt.Encoder.nested encode_request_commit x encoder;
| Vyconf_types.Rollback x ->
- Pbrt.Encoder.key (9, Pbrt.Bytes) encoder;
- Pbrt.Encoder.nested (encode_request_rollback x) encoder;
+ Pbrt.Encoder.key 9 Pbrt.Bytes encoder;
+ Pbrt.Encoder.nested encode_request_rollback x encoder;
| Vyconf_types.Merge x ->
- Pbrt.Encoder.key (10, Pbrt.Bytes) encoder;
- Pbrt.Encoder.nested (encode_request_merge x) encoder;
+ Pbrt.Encoder.key 10 Pbrt.Bytes encoder;
+ Pbrt.Encoder.nested encode_request_merge x encoder;
| Vyconf_types.Save x ->
- Pbrt.Encoder.key (11, Pbrt.Bytes) encoder;
- Pbrt.Encoder.nested (encode_request_save x) encoder;
+ Pbrt.Encoder.key 11 Pbrt.Bytes encoder;
+ Pbrt.Encoder.nested encode_request_save x encoder;
| Vyconf_types.Show_config x ->
- Pbrt.Encoder.key (12, Pbrt.Bytes) encoder;
- Pbrt.Encoder.nested (encode_request_show_config x) encoder;
+ Pbrt.Encoder.key 12 Pbrt.Bytes encoder;
+ Pbrt.Encoder.nested encode_request_show_config x encoder;
| Vyconf_types.Exists x ->
- Pbrt.Encoder.key (13, Pbrt.Bytes) encoder;
- Pbrt.Encoder.nested (encode_request_exists x) encoder;
+ Pbrt.Encoder.key 13 Pbrt.Bytes encoder;
+ Pbrt.Encoder.nested encode_request_exists x encoder;
| Vyconf_types.Get_value x ->
- Pbrt.Encoder.key (14, Pbrt.Bytes) encoder;
- Pbrt.Encoder.nested (encode_request_get_value x) encoder;
+ Pbrt.Encoder.key 14 Pbrt.Bytes encoder;
+ Pbrt.Encoder.nested encode_request_get_value x encoder;
| Vyconf_types.Get_values x ->
- Pbrt.Encoder.key (15, Pbrt.Bytes) encoder;
- Pbrt.Encoder.nested (encode_request_get_values x) encoder;
+ Pbrt.Encoder.key 15 Pbrt.Bytes encoder;
+ Pbrt.Encoder.nested encode_request_get_values x encoder;
| Vyconf_types.List_children x ->
- Pbrt.Encoder.key (16, Pbrt.Bytes) encoder;
- Pbrt.Encoder.nested (encode_request_list_children x) encoder;
+ Pbrt.Encoder.key 16 Pbrt.Bytes encoder;
+ Pbrt.Encoder.nested encode_request_list_children x encoder;
| Vyconf_types.Run_op_mode x ->
- Pbrt.Encoder.key (17, Pbrt.Bytes) encoder;
- Pbrt.Encoder.nested (encode_request_run_op_mode x) encoder;
+ Pbrt.Encoder.key 17 Pbrt.Bytes encoder;
+ Pbrt.Encoder.nested encode_request_run_op_mode x encoder;
| Vyconf_types.Confirm ->
- Pbrt.Encoder.key (18, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 18 Pbrt.Bytes encoder;
Pbrt.Encoder.empty_nested encoder
| Vyconf_types.Configure x ->
- Pbrt.Encoder.key (19, Pbrt.Bytes) encoder;
- Pbrt.Encoder.nested (encode_request_enter_configuration_mode x) encoder;
+ Pbrt.Encoder.key 19 Pbrt.Bytes encoder;
+ Pbrt.Encoder.nested encode_request_enter_configuration_mode x encoder;
| Vyconf_types.Exit_configure ->
- Pbrt.Encoder.key (20, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 20 Pbrt.Bytes encoder;
Pbrt.Encoder.empty_nested encoder
| Vyconf_types.Teardown x ->
- Pbrt.Encoder.key (21, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 21 Pbrt.Bytes encoder;
Pbrt.Encoder.string x encoder;
end
let rec encode_request_envelope (v:Vyconf_types.request_envelope) encoder =
begin match v.Vyconf_types.token with
| Some x ->
- Pbrt.Encoder.key (1, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 1 Pbrt.Bytes encoder;
Pbrt.Encoder.string x encoder;
| None -> ();
end;
- Pbrt.Encoder.key (2, Pbrt.Bytes) encoder;
- Pbrt.Encoder.nested (encode_request v.Vyconf_types.request) encoder;
+ Pbrt.Encoder.key 2 Pbrt.Bytes encoder;
+ Pbrt.Encoder.nested encode_request v.Vyconf_types.request encoder;
()
let rec encode_status (v:Vyconf_types.status) encoder =
@@ -1098,23 +1098,23 @@ let rec encode_status (v:Vyconf_types.status) encoder =
| Vyconf_types.Path_already_exists -> Pbrt.Encoder.int_as_varint 8 encoder
let rec encode_response (v:Vyconf_types.response) encoder =
- Pbrt.Encoder.key (1, Pbrt.Varint) encoder;
+ Pbrt.Encoder.key 1 Pbrt.Varint encoder;
encode_status v.Vyconf_types.status encoder;
begin match v.Vyconf_types.output with
| Some x ->
- Pbrt.Encoder.key (2, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 2 Pbrt.Bytes encoder;
Pbrt.Encoder.string x encoder;
| None -> ();
end;
begin match v.Vyconf_types.error with
| Some x ->
- Pbrt.Encoder.key (3, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 3 Pbrt.Bytes encoder;
Pbrt.Encoder.string x encoder;
| None -> ();
end;
begin match v.Vyconf_types.warning with
| Some x ->
- Pbrt.Encoder.key (4, Pbrt.Bytes) encoder;
+ Pbrt.Encoder.key 4 Pbrt.Bytes encoder;
Pbrt.Encoder.string x encoder;
| None -> ();
end;
diff --git a/src/vyconfd.ml b/src/vyconfd.ml
index d79bda9..f3816d4 100644
--- a/src/vyconfd.ml
+++ b/src/vyconfd.ml
@@ -5,6 +5,7 @@ open Vyconf_pb
open Vyconf_types
module FP = FilePath
+module CT = Vyos1x.Config_tree
(* On UNIX, self_init uses /dev/random for seed *)
let () = Random.self_init ()
@@ -43,7 +44,7 @@ let make_session_token () =
let setup_session world req =
let token = make_session_token () in
let user = "unknown user" in
- let client_app = BatOption.default "unknown client" req.client_application in
+ let client_app = Option.value req.client_application ~default:"unknown client" in
let () = Hashtbl.add sessions token (Session.make world client_app user) in
{response_tmpl with output=(Some token)}
@@ -95,7 +96,7 @@ let get_value world token (req: request_get_value) =
try
let () = (Lwt_log.debug @@ Printf.sprintf "[%s]\n" (Util.string_of_list req.path)) |> Lwt.ignore_result in
let value = Session.get_value world (find_session token) req.path in
- let fmt = BatOption.default Out_plain req.output_format in
+ let fmt = Option.value req.output_format ~default:Out_plain in
let value_str =
(match fmt with
| Out_plain -> value
@@ -106,7 +107,7 @@ let get_value world token (req: request_get_value) =
let get_values world token (req: request_get_values) =
try
let values = Session.get_values world (find_session token) req.path in
- let fmt = BatOption.default Out_plain req.output_format in
+ let fmt = Option.value req.output_format ~default:Out_plain in
let values_str =
(match fmt with
| Out_plain -> Util.string_of_list @@ List.map (Printf.sprintf "\'%s\'") values
@@ -117,7 +118,7 @@ let get_values world token (req: request_get_values) =
let list_children world token (req: request_list_children) =
try
let children = Session.list_children world (find_session token) req.path in
- let fmt = BatOption.default Out_plain req.output_format in
+ let fmt = Option.value req.output_format ~default:Out_plain in
let children_str =
(match fmt with
| Out_plain -> Util.string_of_list @@ List.map (Printf.sprintf "\'%s\'") children
@@ -127,7 +128,7 @@ let list_children world token (req: request_list_children) =
let show_config world token (req: request_show_config) =
try
- let fmt = BatOption.default Curly req.format in
+ let fmt = Option.value req.format ~default:Curly in
let conf_str = Session.show_config world (find_session token) req.path fmt in
{response_tmpl with output=(Some conf_str)}
with Session.Session_error msg -> {response_tmpl with status=Fail; error=(Some msg)}
@@ -179,14 +180,14 @@ let rec handle_connection world ic oc fd () =
let accept_connection world conn =
let fd, _ = conn in
- let ic = Lwt_io.of_fd Lwt_io.Input fd in
- let oc = Lwt_io.of_fd Lwt_io.Output fd in
+ let ic = Lwt_io.of_fd ~mode:Lwt_io.Input fd in
+ let oc = Lwt_io.of_fd ~mode:Lwt_io.Output fd in
Lwt.on_failure (handle_connection world ic oc fd ()) (fun e -> Lwt_log.ign_error (Printexc.to_string e));
Lwt_log.info "New connection" >>= return
let main_loop basepath world () =
let open Session in
- let log_file = BatOption.bind !log_file (fun s -> Some (FP.concat basepath s)) in
+ let log_file = Option.bind !log_file (fun s -> Some (FP.concat basepath s)) in
let%lwt () = Startup.setup_logger !daemonize log_file world.vyconf_config.log_template in
let%lwt () = Lwt_log.notice @@ Printf.sprintf "Starting VyConf for %s" world.vyconf_config.app_name in
let%lwt sock = Startup.create_socket (FP.concat basepath world.vyconf_config.socket) in
@@ -194,7 +195,7 @@ let main_loop basepath world () =
serve ()
let load_interface_definitions dir =
- let open Session in
+(* let open Session in *)
let reftree = Startup.load_interface_definitions dir in
match reftree with
| Ok r -> r
@@ -204,11 +205,11 @@ let make_world config dirs =
let open Directories in
let open Session in
let reftree = load_interface_definitions dirs.interface_definitions in
- let running_config = Config_tree.make "root" in
+ let running_config = CT.make "root" in
{running_config=running_config; reference_tree=reftree; vyconf_config=config; dirs=dirs}
let () =
- let () = Arg.parse args (fun f -> ()) usage in
+ let () = Arg.parse args (fun _ -> ()) usage in
let vc = Startup.load_daemon_config !config_file in
let () = Lwt_log.load_rules ("* -> " ^ vc.log_level) in
let dirs = Directories.make !basepath vc in
@@ -218,5 +219,5 @@ let () =
(FP.concat vc.config_dir vc.primary_config)
(FP.concat vc.config_dir vc.fallback_config) in
let world = Session.{world with running_config=config} in
- let () = print_endline (Config_tree.render world.running_config) in
+ let () = print_endline (CT.render_config world.running_config) in
Lwt_main.run @@ main_loop !basepath world ()
diff --git a/src/vylist.ml b/src/vylist.ml
deleted file mode 100644
index cd4a32e..0000000
--- a/src/vylist.ml
+++ /dev/null
@@ -1,46 +0,0 @@
-let rec find p xs =
- match xs with
- | [] -> None
- | y :: ys -> if (p y) then (Some y)
- else find p ys
-
-let rec remove p xs =
- match xs with
- | [] -> []
- | y :: ys -> if (p y) then ys
- else y :: (remove p ys)
-
-let rec replace p x xs =
- match xs with
- | [] -> raise Not_found
- | y :: ys -> if (p y) then x :: ys
- else y :: (replace p x ys)
-
-let rec insert_before p x xs =
- match xs with
- | [] -> raise Not_found
- | y :: ys -> if (p y) then x :: y :: ys
- else y :: (insert_before p x ys)
-
-let rec insert_after p x xs =
- match xs with
- | [] -> raise Not_found
- | y :: ys -> if (p y) then y :: x :: ys
- else y :: (insert_after p x ys)
-
-let complement xs ys =
- let rec aux xs ys =
- match xs, ys with
- | [], _ -> ys
- | _, [] -> assert false (* Can't happen *)
- | p :: ps, q :: qs -> if p = q then aux ps qs
- else []
- in
- if List.length xs < List.length ys then aux xs ys
- else aux ys xs
-
-let in_list xs x =
- let x' = find ((=) x) xs in
- match x' with
- | None -> false
- | Some _ -> true
diff --git a/src/vylist.mli b/src/vylist.mli
deleted file mode 100644
index 9135bf6..0000000
--- a/src/vylist.mli
+++ /dev/null
@@ -1,7 +0,0 @@
-val find : ('a -> bool) -> 'a list -> 'a option
-val remove : ('a -> bool) -> 'a list -> 'a list
-val replace : ('a -> bool) -> 'a -> 'a list -> 'a list
-val insert_before : ('a -> bool) -> 'a -> 'a list -> 'a list
-val insert_after : ('a -> bool) -> 'a -> 'a list -> 'a list
-val complement : 'a list -> 'a list -> 'a list
-val in_list : 'a list -> 'a -> bool
diff --git a/src/vytree.ml b/src/vytree.ml
deleted file mode 100644
index a3e2750..0000000
--- a/src/vytree.ml
+++ /dev/null
@@ -1,192 +0,0 @@
-type 'a t = {
- name: string;
- data: 'a;
- children: 'a t list
-} [@@deriving yojson]
-
-type position = Before of string | After of string | End | Default
-
-exception Empty_path
-exception Duplicate_child
-exception Nonexistent_path
-exception Insert_error of string
-
-let make data name = { name = name; data = data; children = [] }
-
-let make_full data name children = { name = name; data = data; children = children }
-
-let name_of_node node = node.name
-let data_of_node node = node.data
-let children_of_node node = node.children
-
-let insert_immediate ?(position=Default) node name data children =
- let new_node = make_full data name children in
- let children' =
- match position with
- | Default -> new_node :: node.children
- | End -> node.children @ [new_node]
- | Before s -> Vylist.insert_before (fun x -> x.name = s) new_node node.children
- | After s -> Vylist.insert_after (fun x -> x.name = s) new_node node.children
- in { node with children = children' }
-
-let delete_immediate node name =
- let children' = Vylist.remove (fun x -> x.name = name) node.children in
- { node with children = children' }
-
-let adopt node child =
- { node with children = child :: node.children }
-
-let replace node child =
- let children = node.children in
- let name = child.name in
- let children' = Vylist.replace (fun x -> x.name = name) child children in
- { node with children = children' }
-
-let replace_full node child name =
- let children = node.children in
- let children' = Vylist.replace (fun x -> x.name = name) child children in
- { node with children = children' }
-
-let find node name =
- Vylist.find (fun x -> x.name = name) node.children
-
-let find_or_fail node name =
- let child = find node name in
- match child with
- | None -> raise Nonexistent_path
- | Some child' -> child'
-
-let list_children node =
- List.map (fun x -> x.name) node.children
-
-let rec do_with_child fn node path =
- match path with
- | [] -> raise Empty_path
- | [name] -> fn node name
- | name :: names ->
- let next_child = find_or_fail node name in
- let new_node = do_with_child fn next_child names in
- replace node new_node
-
-let rec insert ?(position=Default) ?(children=[]) node path data =
- match path with
- | [] -> raise Empty_path
- | [name] ->
- (let last_child = find node name in
- match last_child with
- | None -> insert_immediate ~position:position node name data children
- | (Some _) -> raise Duplicate_child)
- | name :: names ->
- let next_child = find node name in
- match next_child with
- | Some next_child' ->
- let new_node = insert ~position:position ~children:children next_child' names data in
- replace node new_node
- | None ->
- raise (Insert_error "Path does not exist")
-
-(** Given a node N check if it has children with duplicate names,
- and merge subsequent children's children into the first child by
- that name.
-
- While all insert functions maintain the "every child has unique name"
- invariant, for nodes constructed manually with make/make_full and adopt
- it may not hold, and constructing nodes this way is a sensible approach
- for config parsing. Depending on the config format, duplicate node names
- may be normal and even expected, such as "ethernet eth0" and "ethernet eth1"
- in the "curly" format.
- *)
-let merge_children merge_data node =
- (* Given a node N and a list of nodes NS, find all nodes in NS that
- have the same name as N and merge their children into N *)
- let rec merge_into n ns =
- match ns with
- | [] -> n
- | n' :: ns' ->
- if n.name = n'.name then
- let children = List.append n.children n'.children in
- let data = merge_data n.data n'.data in
- let n = {n with children=children; data=data} in
- merge_into n ns'
- else merge_into n ns'
- in
- (* Given a list of nodes, for every node, find subsequent children with
- the same name and merge them into the first node, then delete remaining
- nodes from the list *)
- let rec aux ns =
- match ns with
- | [] -> []
- | n :: ns ->
- let n = merge_into n ns in
- let ns = List.filter (fun x -> x.name <> n.name) ns in
- n :: (aux ns)
- in {node with children=(aux node.children)}
-
-(* When inserting at a path that, entirely or partially,
- does not exist yet, create missing nodes on the way with default data *)
-let rec insert_multi_level default_data node path_done path_remaining data =
- match path_remaining with
- | [] | [_] -> insert node (path_done @ path_remaining) data
- | name :: names ->
- let path_done = path_done @ [name] in
- let node = insert node path_done default_data in
- insert_multi_level default_data node path_done names data
-
-let delete node path =
- do_with_child delete_immediate node path
-
-let rename node path newname =
- let rename_immediate newname' node' name' =
- let child = find_or_fail node' name' in
- let child = { child with name=newname' } in
- replace_full node' child name'
- in do_with_child (rename_immediate newname) node path
-
-let update node path data =
- let update_data data' node' name =
- let child = find_or_fail node' name in
- let child = { child with data=data' } in
- replace node' child
- in do_with_child (update_data data) node path
-
-let rec get node path =
- match path with
- | [] -> raise Empty_path
- | [name] -> find_or_fail node name
- | name :: names -> get (find_or_fail node name) names
-
-let get_data node path = data_of_node @@ get node path
-
-let exists node path =
- try ignore (get node path); true
- with Nonexistent_path -> false
-
-let get_existent_path node path =
- let rec aux node path acc =
- match path with
- | [] -> acc
- | name :: names ->
- let child = find node name in
- match child with
- | None -> acc
- | Some c -> aux c names (name :: acc)
- in List.rev (aux node path [])
-
-let children_of_path node path =
- let node' = get node path in
- list_children node'
-
-let sorted_children_of_node cmp node =
- let names = list_children node in
- let names = List.sort cmp names in
- List.map (find_or_fail node) names
-
-let copy node old_path new_path =
- if exists node new_path then raise Duplicate_child else
- let child = get node old_path in
- insert ~position:End ~children:child.children node new_path child.data
-
-let move node path position =
- let child = get node path in
- let node = delete node path in
- insert ~position:position ~children:child.children node path child.data
diff --git a/src/vytree.mli b/src/vytree.mli
deleted file mode 100644
index 451e130..0000000
--- a/src/vytree.mli
+++ /dev/null
@@ -1,50 +0,0 @@
-type 'a t [@@deriving yojson]
-
-exception Empty_path
-exception Duplicate_child
-exception Nonexistent_path
-exception Insert_error of string
-
-type position = Before of string | After of string | End | Default
-
-val make : 'a -> string -> 'a t
-val make_full : 'a -> string -> ('a t) list -> 'a t
-
-val name_of_node : 'a t -> string
-val data_of_node : 'a t -> 'a
-val children_of_node : 'a t -> 'a t list
-
-val find : 'a t -> string -> 'a t option
-val find_or_fail : 'a t -> string -> 'a t
-
-val adopt : 'a t -> 'a t -> 'a t
-
-val insert : ?position:position -> ?children:('a t list) -> 'a t -> string list -> 'a -> 'a t
-
-val insert_multi_level : 'a -> 'a t -> string list -> string list -> 'a -> 'a t
-
-val merge_children : ('a -> 'a -> 'a) -> 'a t -> 'a t
-
-val delete : 'a t -> string list -> 'a t
-
-val update : 'a t -> string list -> 'a -> 'a t
-
-val rename : 'a t -> string list -> string -> 'a t
-
-val list_children : 'a t -> string list
-
-val get : 'a t -> string list -> 'a t
-
-val get_existent_path : 'a t -> string list -> string list
-
-val get_data : 'a t -> string list -> 'a
-
-val exists : 'a t -> string list -> bool
-
-val children_of_path : 'a t -> string list -> string list
-
-val sorted_children_of_node : (string -> string -> int) -> 'a t -> ('a t) list
-
-val copy : 'a t -> string list -> string list -> 'a t
-
-val move : 'a t -> string list -> position -> 'a t
diff --git a/opam b/vyconf.opam
index ce5e890..68e8d45 100644
--- a/opam
+++ b/vyconf.opam
@@ -1,26 +1,22 @@
-opam-version: "1.2"
+opam-version: "2.0"
name: "vyconf"
version: "0.1"
maintainer: "Daniil Baturin <daniil@baturin.org>"
authors: "VyOS maintainers and contributors <maintainers@vyos.net>"
homepage: "https://github.com/vyos/vyconf"
-bug-reports: "https://phabricator.vyos.net/maniphest"
+bug-reports: "https://phabricator.vyos.net"
license: "LGPL with OCaml linking exception"
description: "An appliance configuration framework"
-dev-repo: "git+https://github.com/vyos/vyconf"
+dev-repo: "git+https://github.com/vyos/vyconf/"
build: [
- ["./configure" "--prefix=%{prefix}%"]
- [make]
+ ["dune" "subst"] {pinned}
+ ["dune" "build" "-p" name]
]
-install: [make "install"]
-remove: ["ocamlfind" "remove" "vyconf"]
depends: [
- "ocamlfind" {build}
- "oasis" {build}
"menhir" {build}
+ "dune" {build & >= "1.4.0"}
"ocaml-protoc" {build}
"ounit" {build}
- "batteries" {build}
"lwt" {build & >= "4.1.0"}
"lwt_ppx" {build}
"lwt_log" {build}
@@ -33,4 +29,4 @@ depends: [
"sha" {build}
"pcre" {build}
]
-available: ocaml-version >= "4.03.0"
+available: ocaml-version >= "4.14.2"
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-14 03:56:33 +0000