OCaml: Implement configuration parser, bind lexer tokens with schema

ocaml/README.md

@@ -14,31 +14,28 @@ Grammar v0.2:
     break       = "\n"
     space       = " " | "\t"
 
-Written using the ISO 14977 EBNF Notation <https://www.cl.cam.ac.uk/~mgk25/iso-14977.pdf>. In this grammar, `digit` implies `decimal digit`.
+Written using the ISO 14977 EBNF Notation.
 
-
+In this grammar, `digit` implies `decimal digit`. Spaces between the key and the `=` operator are lexed but meaningless. Spaces between the `=` operator and the first non-space character of the value are lexed and considered as part of the value. Spaces before the key and between the value and the newline are not lexed.
-Spaces between the key and the `=` operator are lexed but meaningless. Spaces between the `=` operator and the first non-space character of the value are lexed and considered as part of the value. Spaces before the key and between the value and the newline are not lexed.
 
 - Note: non-terminals `key` and `value` are ambiguous.
     - Resolved by specifying what character terminates each
 
-See also:
-
 ## Task list
 
-- Comparison of BNF notations: <https://www.cs.man.ac.uk/~pjj/bnf/ebnf.html>
-- W3C ABNF Notation: <https://www.w3.org/Notation.html>
-- IETF RFC 5234 ABNF Notation (replaces 4234, 2234): <https://www.rfc-editor.org/rfc/rfc5234>
 - [ ] Spec requirements integration test coverage
     - [x] Add log function
         - [x] Output begins with ` [log] `
         - [x] Only prints if `DEBUG` is set
     - [ ] Add interactive pkg tests (INS v0 B2.5)
-        - [ ] Get su command from `$XDG_CONFIG_HOME/tori/tori.conf`
+    - [x] Get su command from `$XDG_CONFIG_HOME/tori/tori.conf`
         - [ ] Default to `su -c`
-            - [ ] Validation
+            - [ ] Handle fatal `Sys_error` if `tori.conf` doesn't exist
-                - [ ] Valid path or in `PATH`
+            - [ ] Handle checking `su -c` default with `which` when `tori.conf` exists but `su_command` is absent in it
-                - [ ] Executability
+            - [ ] Properly handle a compose `su_command` such as `su -c` in `System.Package`
+        - [x] Validation
+            - [x] Valid path or in `PATH`
+            - [x] Executability
             - ~~`true` exits with status 0 (see note 3)~~
     - [x] Add logging
         - [x] Logs only if DEBUG is set
@@ -56,7 +53,7 @@ See also:
     - [ ] Simplify Reader
 
 - [ ] Additionals
-    - [ ] Create interface files
+    - [ ] Create remaining interface files
     - [ ] Expand unit tests coverage
     - [ ] Try out doc generation
 
@@ -79,3 +76,9 @@ See also:
     without user input
  3. As per item 3 above, INS v0.2 drops "run 'true' with exit code 0" from A3.4
 
+## References
+
+- ISO 14977 EBNF Notation: <https://www.cl.cam.ac.uk/~mgk25/iso-14977.pdf>
+- Comparison of BNF notations: <https://www.cs.man.ac.uk/~pjj/bnf/ebnf.html>
+- W3C ABNF Notation: <https://www.w3.org/Notation.html>
+- IETF RFC 5234 ABNF Notation (replaces 4234, 2234): <https://www.rfc-editor.org/rfc/rfc5234>

ocaml/bin/main.ml

@@ -1,9 +1,23 @@
 open Tori.Utilities.Aliases
 
+module ConfigLexer = Tori.Parsers.Config.Lexer
+module ConfigParser = Tori.Parsers.Config.Parser
+
+let config_file =
+    ConfigLexer.read $ Unix.getenv "HOME" ^ "/.config/tori/tori.conf"
+
 let () =
+
+    (* TODO: extract *)
+    let tokens = ConfigLexer.scan config_file in
+    (* elog $ ConfigLexer.string_of_tokens tokens; *)
+    let config = ConfigParser.parse (List.concat tokens) in
+    (* elog $ ConfigParser.string_of_config config; *)
+
     match Array.to_list Sys.argv with
     | _ :: tail ->
-        let future = Tori.Parsers.Argument.interpret Tori.Schema.seed tail in
+        let past = ConfigParser.apply Tori.Schema.origin config in
+        let future = Tori.Parsers.Argument.interpret past tail in
         if future.output.main <> "" then print_endline future.output.main;
         if future.output.log <> "" then elog future.output.log;
         exit future.meta.status

ocaml/lib/parsers/argument.ml

@@ -1,12 +1,19 @@
 let interpret (past : Schema.schema) (input : string list) : Schema.schema =
-    let future : Schema.schema =
+    let present : Schema.schema =
         { past with output = { past.output with main = "" } }
     in
 
     let say (message : string) : Schema.schema =
-        { future with output = { future.output with main = message } }
+        { present with output = { present.output with main = message } }
     in
 
+    let configured_present = System.Process.Command.check_su_command present in
+
+    (* poor legibility, but otherwise flagged as non-exhaustive *)
+    match configured_present.meta.status with
+    | n when n <> 0 -> configured_present
+    | _ ->
+
     (*
        TODO: return a schema with orders, instead of calling side-effects
        directly, making this more of a parser and less of a glorified switch
@@ -17,17 +24,17 @@ let interpret (past : Schema.schema) (input : string list) : Schema.schema =
     | "user" :: _ -> say (System.Process.Reader.read [||] "whoami").output
     | "echo" :: tail -> say (String.concat " " tail)
     | ("version" | "-v" | "--version") :: _ ->
-        say (Schema.format_version future.meta.version)
+        say (Schema.format_version present.meta.version)
-    | ("help" | "-h" | "--help") :: _ -> say future.meta.help.long
+    | ("help" | "-h" | "--help") :: _ -> say present.meta.help.long
     | head :: _ ->
         {
-          future with
+          present with
           output =
             {
-              future.output with
+              present.output with
               main =
-                "Unrecognized command: " ^ head ^ "\n" ^ future.meta.help.short;
+                "Unknown command: " ^ head ^ "\n" ^ present.meta.help.short;
             };
-          meta = { future.meta with status = 1 };
+          meta = { present.meta with status = 1 };
         }
-    | _ -> future
+    | _ -> present

ocaml/lib/parsers/config/lexer.ml

@@ -1,6 +1,6 @@
 open Utilities.Aliases
 
-type key = SuCommand | Unknown
+type key = Schema.configuration_key
 type token =
     | Key of key
     | Equal

ocaml/lib/parsers/config/lexer.mli

@@ -1,4 +1,16 @@
-type token
+type key = Schema.configuration_key
+
+type token =
+    | Key of key
+    | Equal
+    | Value of string
+    | Space
+    | LineBreak
+    | Unknown of char
+    | End
+
 val read : string -> char list list
 val scan : char list list -> token list list
 val string_of_tokens : token list list -> string
+
+exception Malformed_source of string

ocaml/lib/parsers/config/parser.ml

@@ -0,0 +1,55 @@
+(* open Utilities.Aliases *)
+open Lexer
+
+type schema = Schema.schema
+type token = Lexer.token
+type config = Schema.main
+
+let default_config: config = Schema.origin.input.configuration.main
+
+(*
+    TODO: The `elog` calls in this module's functions cause cram tests
+    to fail. Separate logging levels can be implemented to solve this.
+*)
+
+let update config key value: config =
+    match key with
+    | Schema.SuCommand ->
+        (* elog $ "[c.parser.update] Setting value '" ^ value ^ "'"; *)
+        { config with Schema.su_command = value }
+    | Unknown ->
+        (* elog $ "[c.parser.update] Dropping value: unknown key"; *)
+        config
+
+let parse tokens =
+    let rec parse_tokens tokens config ready_key =
+        match tokens with
+        | [] -> config
+        | Key key :: tail ->
+            (* elog $ "[c.parser.parse ] Picked key '" ^ *)
+            (*     Schema.string_of_key key ^ "'"; *)
+            parse_tokens tail config (Some key)
+        | Value value :: tail ->
+            (* elog $ "[c.parser.parse ] Picked value '" ^ value ^ "'"; *)
+            (match ready_key with
+                | Some key -> parse_tokens tail (update config key value) None
+                | None -> raise (Malformed_source "Value lacks preceding key"))
+        | Unknown _char :: tail ->
+            (* elog $ "[c.parser.parse ] Dropping unknown token " ^ str_char char; *)
+            parse_tokens tail config ready_key
+        | (Space|Equal|LineBreak|End) :: tail ->
+            parse_tokens tail config ready_key
+
+    in
+    parse_tokens tokens default_config None
+
+let apply (origin: Schema.schema) (config: config): Schema.schema =
+    { origin with input = {
+        origin.input with configuration = {
+            origin.input.configuration with main = config
+        }
+    }}
+
+let string_of_config (config: config): string =
+    "su_command = " ^ config.su_command ^ "\n" ^
+    ""

ocaml/lib/parsers/config/parser.mli

@@ -0,0 +1,7 @@
+type token = Lexer.token
+type schema = Schema.schema
+type config = Schema.main
+
+val parse : token list -> config
+val apply : schema -> config -> schema
+val string_of_config : config -> string

ocaml/lib/schema/schema.ml

@@ -9,9 +9,14 @@ type output = { main : string; log : string }
 type os = Unknown | FreeBSD | Void | Alpine
 type host = { os : os; name : string }
 
-type schema = { meta : meta; output : output; host : host }
+type configuration_key = SuCommand | Unknown
+type main = { su_command : string; }
+type configuration = { main : main; }
+type input = { configuration: configuration; }
 
-let seed : schema = {
+type schema = { meta : meta; output : output; input : input; host : host }
+
+let origin : schema = {
     meta = {
         version = {
             major = 0;
@@ -24,6 +29,13 @@ let seed : schema = {
         };
         status = 0;
     };
+    input = {
+        configuration = {
+            main = {
+                su_command = "su -c"
+            };
+        };
+    };
     output = {
         (* could be lists of strings or lists of a dedicated type with message,
            log level, time and origin in code (e.g. module and function) *)
@@ -40,3 +52,8 @@ let format_version (version : version) : string =
     "v" ^ str_int version.major ^
     "." ^ str_int version.minor ^
     "." ^ str_int version.patch
+
+let string_of_key key =
+    match key with
+        | SuCommand -> "su_command"
+        | Unknown -> "<unknown key>"

ocaml/lib/system/package.ml

@@ -6,16 +6,17 @@ let merge (schema : Schema.schema) (packages : string list) : Schema.schema =
           output = { schema.output with main = "No packages provided" };
         }
     | _ ->
+        let su_command = schema.input.configuration.main.su_command in
         let commands : Process.Command.command list =
             [
               {
-                name = "doas";
+                name = su_command;
-                arguments = [ "doas"; "apk"; "-i"; "add" ] @ packages;
+                arguments = [ su_command; "apk"; "-i"; "add" ] @ packages;
                 status = Unevaluated;
               };
               {
-                name = "doas";
+                name = su_command;
-                arguments = [ "doas"; "apk"; "-i"; "del" ] @ packages;
+                arguments = [ su_command; "apk"; "-i"; "del" ] @ packages;
                 status = Unevaluated;
               };
             ]

ocaml/lib/system/process/command.ml

@@ -1,8 +1,11 @@
 open Utilities.Aliases
 
+type schema = Schema.schema
+
 type status = Exit of int | Unevaluated
 type command = { name : string; arguments : string list; status : status }
 
+
 let format (command : command) : string =
     command.name ^ " with arguments: "
     ^ String.concat " " command.arguments
@@ -14,3 +17,22 @@ let format (command : command) : string =
 
 let format_many (commands : command list) : string list =
     List.map format commands
+
+let check_su_command (schema: schema): schema =
+    let command = schema.input.configuration.main.su_command in
+    let path = Reader.read [||] ("which " ^ command) in
+    try Unix.access path.output [Unix.X_OK]; schema
+    with Unix.Unix_error _ -> elog "";
+        {
+            schema with
+            output =
+                {
+                    schema.output with
+                    main =
+                        "Super user command " ^ command ^
+                        " not executable at path '" ^ path.output ^
+                        "' (exit status " ^ path.status ^ ", stderr: '" ^
+                        path.error ^ "')\n"
+                };
+            meta = { schema.meta with status = 1 };
+        }

ocaml/lib/utilities/aliases.ml

@@ -8,6 +8,7 @@ let elog = Log.elog
 let str_int = string_of_int
 let chars_str = Text.chars_of_string
 let str_chars = Text.string_of_chars
+let str_char = String.make 1
 
 (* control flow & precedence *)
 let ($) = (@@)

ocaml/test/cram.t

@@ -1,4 +1,4 @@
-This file tests this tori implementation against the Iganaq Napkin Spec v0.1
+This file tests this tori implementation against the Iganaq Napkin Spec v0.2
 
 A2. 'log' MUST print only if DEBUG is set and MUST be preceded by ' [log] '
 
@@ -8,6 +8,14 @@ A2. 'log' MUST print only if DEBUG is set and MUST be preceded by ' [log] '
   $ echo "$with_debug" | grep -Fq " [log] "
   $ echo "$without_debug" | grep -Fqv " [log] "
 
+A3.4. [config] su_command must be validated for presence at the provided path
+or a path obtained from $PATH and filesystem permission to execute
+
+  $ echo 'su_command=sudo' > $HOME/.config/tori/tori.conf
+  $ ! which sudo >/dev/null || tori smoke 2>&1 >/dev/null
+  $ echo 'su_command=doas' > $HOME/.config/tori/tori.conf
+  $ ! which doas >/dev/null || tori smoke 2>&1 >/dev/null
+
 B2.1. version | -v | --version -> MUST print the version as in v0.8.0
 
   $ tori version
@@ -72,4 +80,3 @@ a newline, '<short help>' and exit with status code 1
   Unrecognized command: unrecognized_command
   <short help>
   [1]
-