Merge pull request #20 from robur-coop/options

more options to parse

dnsvizor.opam

@@ -24,7 +24,8 @@ depends: [
   "fmt" {>= "0.9.0"}
   "ipaddr" {>= "5.6.0"}
   "cmdliner" {>= "1.2.0"}
+  "logs" {>= "0.7.0"}
 
   "alcotest" {with-test & >= "1.8.0"}
-  "logs" {with-test & >= "0.7.0"}
 ]
+available: arch != "arm32" & arch != "x86_32"

mirage/.ocamlformat

@@ -0,0 +1 @@
+../.ocamlformat

mirage/unikernel.ml

@@ -28,12 +28,6 @@ module K = struct
     Mirage_runtime.register_arg
       (Mirage_runtime_network.V6.accept_router_advertisements ())
 
-  (* TODO support multiple dhcp-range statements *)
-  let dhcp_range =
-    let doc = Arg.info ~doc:"Enable DHCP server." [ "dhcp-range" ] in
-    Mirage_runtime.register_arg
-      Arg.(value & opt Config_parser.(some dhcp_range_c) None doc)
-
   let dns_cache =
     let doc = Arg.info ~doc:"DNS cache size" [ "dns-cache" ] in
     Mirage_runtime.register_arg Arg.(value & opt (some int) None doc)
@@ -47,6 +41,58 @@ module K = struct
         [ "dns-upstream" ]
     in
     Mirage_runtime.register_arg Arg.(value & opt (some string) None doc)
+
+  (* DNSmasq configuration options *)
+  (* TODO support multiple dhcp-range statements *)
+  let dhcp_range =
+    let doc =
+      Arg.info ~doc:"Enable DHCP server." ~docv:Config_parser.dhcp_range_docv
+        [ "dhcp-range" ]
+    in
+    Mirage_runtime.register_arg
+      Arg.(value & opt Config_parser.(some dhcp_range_c) None doc)
+
+  let interface =
+    let doc =
+      Arg.info ~docs:Manpage.s_none ~doc:"Interface to listen on."
+        [ "interface" ]
+    in
+    Mirage_runtime.register_arg
+      Arg.(value & opt Config_parser.(some (ignore_c "interface")) None doc)
+
+  let except_interface =
+    let doc =
+      Arg.info ~docs:Manpage.s_none ~doc:"Interface to not listen on."
+        [ "except-interface" ]
+    in
+    Mirage_runtime.register_arg
+      Arg.(
+        value & opt Config_parser.(some (ignore_c "except-interface")) None doc)
+
+  let listen_address =
+    let doc =
+      Arg.info ~docs:Manpage.s_none ~doc:"IP address to listen on."
+        [ "listen-address" ]
+    in
+    Mirage_runtime.register_arg
+      Arg.(
+        value & opt Config_parser.(some (ignore_c "listen-address")) None doc)
+
+  let no_dhcp_interface =
+    let doc =
+      Arg.info ~docs:Manpage.s_none ~doc:"Only provide DNS service on."
+        [ "no-dhcp-interface" ]
+    in
+    Mirage_runtime.register_arg
+      Arg.(
+        value & opt Config_parser.(some (ignore_c "no-dhcp-interface")) None doc)
+
+  let bind_interfaces =
+    let doc =
+      Arg.info ~docs:Manpage.s_none ~doc:"Bind to interface IP address only."
+        [ "bind_interfaces" ]
+    in
+    Mirage_runtime.register_arg Arg.(value & flag doc)
 end
 
 module Main

src/config_parser.ml

@@ -1,18 +1,17 @@
 open Angstrom
 
-(* TODO revise the error handling, since rule may output an error *)
-let parse_one rule config_str =
-  parse_string ~consume:Consume.All
-    (rule
-    <|> ( available >>| min 100 >>= peek_string >>= fun context ->
-          pos >>= fun pos ->
-          fail (Printf.sprintf "Error at byte offset %d: %S" pos context) ))
-    config_str
+module Log =
+  (val Logs.(
+         src_log
+         @@ Src.create ~doc:"DNSvizor configuration module" "dnsvizor.config")
+      : Logs.LOG)
 
-let lift_err = function Ok _ as o -> o | Error e -> Error (`Msg e)
+let parse_one rule config_str =
+  match parse_string ~consume:Consume.All rule config_str with
+  | Ok _ as o -> o
+  | Error msg -> Error (`Msg (Fmt.str "Parse error in %S: %s" config_str msg))
 
-let conv_cmdliner ?docv rule pp =
-  Cmdliner.Arg.conv ?docv ((fun x -> parse_one rule x |> lift_err), pp)
+let conv_cmdliner ?docv rule pp = Cmdliner.Arg.conv ?docv (parse_one rule, pp)
 
 (* some basic rules *)
 
@@ -30,22 +29,41 @@ let week = 7 * day
 let infinite = 1 lsl 32 (* DHCP has 32 bits for this *)
 
 let lease_time =
-  (* TODO check that the time fits into 32 bits *)
   take_while1 (function '0' .. '9' -> true | _ -> false)
   >>= (fun dur ->
         match int_of_string_opt dur with
         | None -> fail (Fmt.str "Couldn't convert %S to an integer" dur)
-        | Some dur ->
-            choice
+        | Some n ->
+            choice ~failure_msg:"bad lease time"
               [
-                string "w" *> return (dur * week);
-                string "d" *> return (dur * day);
-                string "h" *> return (dur * hour);
-                string "m" *> return (dur * minute);
-                end_of_input *> return dur;
-              ])
+                string "w" *> return ("w", n * week);
+                string "d" *> return ("d", n * day);
+                string "h" *> return ("h", n * hour);
+                string "m" *> return ("m", n * minute);
+                return ("", n);
+              ]
+            >>= fun (c, r) ->
+            if r > 0 && r < infinite then return r
+            else
+              fail
+                (Fmt.str "Value %u (from %S%s) does not fit into 32 bits" r dur
+                   c))
   <|> string "infinite" *> return infinite
 
+let line =
+  take_while (function '\n' -> false | _ -> true)
+  <* (end_of_line <|> end_of_input)
+
+let ignore_line key =
+  line >>= fun txt ->
+  Log.warn (fun m -> m "ignoring %S %S" key txt);
+  return txt
+
+let pp_ignored_line key ppf data = Fmt.pf ppf "--%s=%s" key data
+
+let ignore_c key =
+  conv_cmdliner ~docv:"IGNORED" (ignore_line key) (pp_ignored_line key)
+
 (* real grammars *)
 
 type dhcp_range = {
@@ -84,7 +102,9 @@ let pp_dhcp_range ppf
     lease_time
 
 let mode =
-  choice [ string "static" *> return `Static; string "proxy" *> return `Proxy ]
+  choice
+    [ string "static" *> return `Static; string "proxy" *> return `Proxy ]
+    ~failure_msg:"bad mode"
 
 let dhcp_range =
   (* TODO prefix: [tag:<tag>[,tag:<tag>],][set:<tag>,]
@@ -103,7 +123,8 @@ let dhcp_range =
       >>| fun broadcast -> (netmask, broadcast) )
   >>= fun net_broad ->
   option None (string "," *> lease_time >>| fun l -> Some l)
-  >>| fun lease_time ->
+  >>= fun lease_time ->
+  end_of_line <|> end_of_input >>| fun () ->
   let end_addr, mode =
     match mode_or_end with
     | `Mode m -> (None, Some m)
@@ -116,3 +137,37 @@ let dhcp_range_c =
   conv_cmdliner
     ~docv:"<start>[,<end>|<mode>[,<netmask>[,<broadcast>]]][,<lease-time>]"
     dhcp_range pp_dhcp_range
+
+let parse_file data =
+  let rules =
+    let ignore_directive key =
+      string (key ^ "=") *> commit *> ignore_line key >>| fun _ -> `Ignored
+    in
+    let ignore_flag key =
+      string key *> (end_of_line <|> end_of_input) >>| fun _ -> `Ignored
+    in
+    let isspace = function
+      | ' ' | '\x0c' | '\n' | '\r' | '\t' | '\x0b' -> true
+      | _ -> false
+    in
+    skip_while isspace *> commit
+    *> choice ~failure_msg:"bad configuration directive"
+         [
+           ( string "dhcp-range=" *> commit *> dhcp_range >>| fun range ->
+             `Dhcp_range range );
+           ignore_directive "interface";
+           ignore_directive "except-interface";
+           ignore_directive "listen-address";
+           ignore_directive "no-dhcp-interface";
+           ignore_flag "bind-interfaces";
+           (string "#" *> ignore_line "#" >>| fun _ -> `Ignored);
+         ]
+  in
+  let top =
+    fix (fun r ->
+        rules >>= fun e ->
+        commit *> end_of_input *> return [ e ] <|> (List.cons e <$> r))
+  in
+  match parse_string ~consume:Consume.All top data with
+  | Ok x -> Ok (List.filter (function `Ignored -> false | _ -> true) x)
+  | Error msg -> Error (`Msg msg)

src/dune

@@ -1,4 +1,4 @@
 (library
  (name dnsvizor)
  (public_name dnsvizor)
- (libraries angstrom fmt ipaddr cmdliner))
+ (libraries angstrom fmt ipaddr cmdliner logs))

test/config_tests.ml

@@ -1,5 +1,9 @@
 open Dnsvizor.Config_parser
 
+let msg_t =
+  let pp ppf (`Msg s) = Fmt.string ppf s in
+  Alcotest.testable pp (fun (`Msg a) (`Msg b) -> String.equal a b)
+
 let opt_eq f a b =
   match (a, b) with
   | None, None -> true
@@ -38,7 +42,7 @@ let ok_dhcp_range () =
   in
   Alcotest.(
     check
-      (result dhcp_range_t string)
+      (result dhcp_range_t msg_t)
       "DHCP range is good" (Ok expected)
       (parse_one dhcp_range input))
 
@@ -56,7 +60,7 @@ let ok_dhcp_range_with_netmask () =
   in
   Alcotest.(
     check
-      (result dhcp_range_t string)
+      (result dhcp_range_t msg_t)
       "DHCP range with netmask is good" (Ok expected)
       (parse_one dhcp_range input))
 
@@ -76,7 +80,7 @@ let ok_dhcp_range_static () =
   in
   Alcotest.(
     check
-      (result dhcp_range_t string)
+      (result dhcp_range_t msg_t)
       "DHCP range with static is good" (Ok expected)
       (parse_one dhcp_range input))
 
@@ -87,7 +91,29 @@ let tests =
     ("DHCP range static", `Quick, ok_dhcp_range_static);
   ]
 
-let tests = [ ("Config tests", tests) ]
+let string_of_file filename =
+  let config_dir = "sample-configuration-files" in
+  let file = Filename.concat config_dir filename in
+  try
+    let fh = open_in file in
+    let content = really_input_string fh (in_channel_length fh) in
+    close_in_noerr fh;
+    content
+  with _ -> Alcotest.failf "Error reading file %S" file
+
+let test_configuration config file () =
+  match parse_file (string_of_file file) with
+  | Error (`Msg msg) -> Alcotest.failf "Error parsing %S: %s" file msg
+  | Ok data ->
+      Alcotest.(check int)
+        "Number of configuration items matches" (List.length config)
+        (List.length data)
+
+let config_file_tests =
+  [ ("First example", `Quick, test_configuration [] "simple.conf") ]
+
+let tests =
+  [ ("Config tests", tests); ("Configuration file tests", config_file_tests) ]
 
 let () =
   Logs.set_reporter @@ Logs_fmt.reporter ~dst:Format.std_formatter ();

test/dune

@@ -1,4 +1,6 @@
 (test
  (name config_tests)
  (modules config_tests)
- (libraries alcotest fmt logs.fmt dnsvizor))
+ (libraries alcotest fmt logs.fmt dnsvizor)
+ (deps
+  (source_tree sample-configuration-files)))

test/sample-configuration-files/simple.conf

@@ -0,0 +1,6 @@
+# This is a comment
+listen-address=127.0.0.1,10.8.0.1
+  # this is also a comment with leading whitespace
+    # and configuration directives can also be indented with whitespace
+      bind-interfaces
+# Comments are only allowed on a line by themselves (with optional leading whitespace)