OCaml: Handle some edge cases; refactor parser, main.ml; add config fetcher

ocaml/README.md

@@ -27,12 +27,12 @@ In this grammar, `digit` implies `decimal digit`. Spaces between the key and the
     - [x] Add log function
         - [x] Output begins with ` [log] `
         - [x] Only prints if `DEBUG` is set
-    - [ ] Add interactive pkg tests (INS[^1] v0 B2.5[^2])
     - [x] Get su command from `$XDG_CONFIG_HOME/tori/tori.conf`
         - [ ] Default to `su -c`
-            - [ ] Handle fatal `Sys_error` if `tori.conf` doesn't exist
-            - [ ] Handle checking `su -c` default with `which` when `tori.conf` exists but `su_command` is absent in it
-            - [ ] Properly handle a compose `su_command` such as `su -c` in `System.Package`
+            - [x] Handle fatal `Sys_error` if `tori.conf` doesn't exist
+            - [x] Handle checking `su -c` default with `which` when `tori.conf` exists but `su_command` is absent in it
+            - [x] Properly handle a compose `su_command` such as `su -c` in `System.Package`
+            - [ ] Properly handle dependent options
         - [x] Validation
             - [x] Valid path or in `PATH`
             - [x] Executability
@@ -55,7 +55,10 @@ In this grammar, `digit` implies `decimal digit`. Spaces between the key and the
 - [ ] Additionals
     - [ ] Create remaining interface files
     - [ ] Expand unit tests coverage
+    - [ ] Add interactive pkg tests (INS[^1] v0 B2.5[^2])
     - [ ] Try out doc generation
+    - [ ] Detect `su_command` from PATH before falling back to su
+    - [ ] Raise on duplicate keys, currently shadowing
 
 - [ ] Check out
     - [ ] <https://github.com/janestreet/shexp>

ocaml/bin/main.ml

@@ -1,24 +1,14 @@
-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"
+module ConfigFetcher = Tori.Parsers.Config.Fetcher
 
 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 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;
+        let past = ConfigFetcher.fetch Tori.Schema.origin
+            |> Tori.Checks.post_config
+        in
+        let future = Tori.Parsers.Argument.interpret past tail
+            |> Tori.Checks.exit
+        in
         exit future.meta.status
     | [] -> assert false

ocaml/lib/checks/checks.ml

@@ -0,0 +1,22 @@
+open Utilities.Aliases
+
+(*
+   The purpose of this module is to run multiple checks at appropriate times.
+   All functions should end with a call to exit, which will print error messages
+   and quit with code schema.meta.status if schema.meta.error_level is Fatal.
+
+   When adding checks, consider that the error message will be overriten if exit
+   is not called between schema changes. This should be improved later so that a
+   list instead is printed entirely by exit, and then emptied.
+*)
+
+let exit (schema: Schema.schema): Schema.schema =
+    if schema.output.main <> "" then print_endline schema.output.main;
+    if schema.output.log <> "" then elog schema.output.log;
+    if schema.meta.error_level == Fatal then exit schema.meta.status
+    else schema
+
+let post_config (schema: Schema.schema): Schema.schema =
+    System.Process.Su.is_executable schema
+    |> exit
+

ocaml/lib/parsers/argument.ml

@@ -1,40 +1,30 @@
-let interpret (past : Schema.schema) (input : string list) : Schema.schema =
-    let present : Schema.schema =
-        { past with output = { past.output with main = "" } }
-    in
+let interpret (past : Schema.schema) (arguments : string list) : Schema.schema =
 
     let say (message : string) : Schema.schema =
-        { present with output = { present.output with main = message } }
+        { past with output = { past.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
     *)
-    match input with
+    match arguments with
     | "pkg" :: tail -> System.Package.merge past tail
     | "os" :: _ -> say System.Os.identify
     | "user" :: _ -> say (System.Process.Reader.read [||] "whoami").output
     | "echo" :: tail -> say (String.concat " " tail)
     | ("version" | "-v" | "--version") :: _ ->
-        say (Schema.format_version present.meta.version)
-    | ("help" | "-h" | "--help") :: _ -> say present.meta.help.long
+        say (Schema.format_version past.meta.version)
+    | ("help" | "-h" | "--help") :: _ -> say past.meta.help.long
     | head :: _ ->
         {
-          present with
+          past with
           output =
             {
-              present.output with
+              past.output with
               main =
-                "Unknown command: " ^ head ^ "\n" ^ present.meta.help.short;
+                "Unknown command: " ^ head ^ "\n" ^ past.meta.help.short;
             };
-          meta = { present.meta with status = 1 };
+          meta = { past.meta with status = 1 };
         }
-    | _ -> present
+    | _ -> past

ocaml/lib/parsers/config/fetcher.ml

@@ -0,0 +1,14 @@
+let fetch ?clean (origin: Schema.schema): Schema.schema =
+    let config = Lexer.read origin.meta.defaults.paths.configuration
+    |> Lexer.scan
+    |> List.concat
+    |> Parser.parse
+    in
+
+    if Option.value clean ~default:false then {
+        Schema.origin with input = {
+            origin.input with configuration = {
+                origin.input.configuration with main = config
+            }
+        }
+    } else Parser.apply origin config

ocaml/lib/parsers/config/lexer.ml

@@ -10,19 +10,26 @@ type token =
     | Unknown of char
     | End
 
+    (*
+        TODO: This module's functions rely too much on matching a string, so
+        there are no exhaustion checks and it's entirely up to the human to
+        not overlook a variant, possibly leading to unhandled cases. Either
+        refactor, add tests that will fail if a variant is unhandled, or both
+    *)
+
 let lex_keyword (literal: string): token =
     match literal with
     | "su_command" -> Key SuCommand
+    | "su_command_quoted" -> Key SuCommandQuoted
     | _ -> Key Unknown
 
 let lex_keyvalue (literal: string): token = Value literal
 
-exception Malformed_source of string
-
 let string_of_token (token: token): string =
     match token with
     | Key k -> (match k with
         | SuCommand -> "[ KEY: su_command ]"
+        | SuCommandQuoted -> "[ KEY: su_command_quoted ]"
         | Unknown -> "[ UNKNOWN KEY ]")
     | Equal -> "[ OP: equal ]"
     | Value v -> "[ VAL: " ^ v ^ " ]"
@@ -66,6 +73,7 @@ let lex (chars: char list) (position: int): token * int =
         | c -> Unknown c, position + 1
 
 let read (path: string): char lists =
+    if not $ System.File.can_read path then [[]] else
     let lines = System.File.read path
     |> String.split_on_char '\n'
     |> List.map String.trim in
@@ -89,4 +97,6 @@ let scan_line (input: char list): token list =
     reverse $ to_tokens input 0 []
 
 let scan (char_lists: char lists): token lists =
-    rmap (scan_line) char_lists $: [End]
+    let tokens = rmap (scan_line) char_lists $: [End] in
+    elog $ string_of_tokens tokens;
+    tokens

ocaml/lib/parsers/config/lexer.mli

@@ -12,5 +12,4 @@ type token =
 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
+val string_of_token : token -> string

ocaml/lib/parsers/config/parser.ml

@@ -1,41 +1,83 @@
 (* open Utilities.Aliases *)
 open Lexer
+open Utilities.Aliases
 
-type schema = Schema.schema
-type token = Lexer.token
-type config = Schema.main
-
-let default_config: config = Schema.origin.input.configuration.main
+let default_config: Schema.main = 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 =
+let parse_boolean (key: key) (value: string): Schema.default_bool =
+    match value with
+    | "true" -> true
+    | "false" -> false
+    | _ -> raise $ Malformed_source
+        (Schema.string_of_key key ^ " must be either true or false")
+
+let update_and_log ?message config key (value: string) : Schema.main =
+    let message = match message with
+        | Some s -> " (" ^ s  ^ ")"
+        | None -> ""
+    in
+    elog $ "[c.parser.update] " ^ Schema.string_of_key key ^ " <- " ^ value ^ message;
+    config
+
+let update (past_config: Schema.main) key (value: string): Schema.main =
+    let default = Schema.origin.input.configuration.main in
     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 default = Schema.origin.input.configuration.main in
+        let as_list = String.split_on_char ' ' value in
+        (* user set su_command, but not if it's quoted -> default to unquoted *)
 
-let parse tokens =
+        elog $ "value -> '" ^ value ^ "' <> '" ^
+            String.concat " " default.su_command ^ "' <- default";
+        elog $ "past_config.su_command_quoted -> '" ^
+            str_dbool past_config.su_command_quoted ^ "' == '" ^
+            str_dbool default.su_command_quoted ^ "' <- default";
+
+        if value <> String.concat " " default.su_command &&
+            past_config.su_command_quoted == default.su_command_quoted
+        then
+            update_and_log {
+                past_config with su_command = as_list;
+                su_command_quoted = false
+            } key value ~message:("Defaulting to unquoted: set su_command_quoted to true if your su command needs quoting"
+                )
+        else
+            update_and_log { past_config with su_command = as_list } key value ~message:("both su_command and su_command_quoted set by user")
+
+
+    | SuCommandQuoted -> (
+        if past_config.su_command == default.su_command then
+            update_and_log { past_config with su_command_quoted = true }
+                key "true" ~message: ("configuration value ignored: " ^
+                "su_command is the default and 'su' requires quoting")
+        else
+            let parsed_boolean = parse_boolean key value in
+            update_and_log
+                { past_config with su_command_quoted = parsed_boolean }
+                key (str_dbool parsed_boolean))
+    | Unknown ->
+        update_and_log past_config key value
+
+let parse tokens: Schema.main =
     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 ^ "'"; *)
+            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 ^ "'"; *)
+            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; *)
+                | 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
@@ -43,13 +85,14 @@ let parse tokens =
     in
     parse_tokens tokens default_config None
 
-let apply (origin: Schema.schema) (config: config): Schema.schema =
+let apply (origin: Schema.schema) (config: Schema.main): 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" ^
-    ""
+let string_of_config (config: Schema.main): string =
+    (* TODO: extract, use pattern matching for exhaustion checks *)
+    "su_command = " ^ String.concat " " config.su_command ^ "\n" ^
+    "su_command_quoted = " ^ str_dbool config.su_command_quoted

ocaml/lib/parsers/config/parser.mli

@@ -1,7 +1,3 @@
-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
+val parse : Lexer.token list -> Schema.main
+val apply : Schema.schema -> Schema.main -> Schema.schema
+val string_of_config : Schema.main -> string

ocaml/lib/schema/schema.ml

@@ -1,16 +1,24 @@
-open Utilities.Aliases
-
 type version = { major : int; minor : int; patch : int }
 type help = { short : string; long : string }
-type meta = { version : version; help : help; status : int }
+type error_level = Clear | Warning | Error | Fatal
+type paths = { configuration : string }
+type defaults = { paths: paths }
+type meta = {
+    version : version;
+    help : help;
+    error_level: error_level;
+    status : int;
+    defaults : defaults;
+}
 
 type output = { main : string; log : string }
 
 type os = Unknown | FreeBSD | Void | Alpine
 type host = { os : os; name : string }
 
-type configuration_key = SuCommand | Unknown
-type main = { su_command : string; }
+type default_bool = Default | true | false
+type configuration_key = SuCommand | SuCommandQuoted | Unknown
+type main = { su_command : string list; su_command_quoted: default_bool }
 type configuration = { main : main; }
 type input = { configuration: configuration; }
 
@@ -27,12 +35,19 @@ let origin : schema = {
             short = "<short help>";
             long = "<long help>";
         };
+        error_level = Clear;
         status = 0;
+        defaults = {
+            paths = {
+                configuration = Unix.getenv "HOME" ^ "/.config/tori/tori.conf";
+            };
+        };
     };
     input = {
         configuration = {
             main = {
-                su_command = "su -c"
+                su_command = [ "su"; "-c" ];
+                su_command_quoted = Default;
             };
         };
     };
@@ -49,11 +64,18 @@ let origin : schema = {
 }
 
 let format_version (version : version) : string =
-    "v" ^ str_int version.major ^
-    "." ^ str_int version.minor ^
-    "." ^ str_int version.patch
+    "v" ^ string_of_int version.major ^
+    "." ^ string_of_int version.minor ^
+    "." ^ string_of_int version.patch
 
 let string_of_key key =
     match key with
         | SuCommand -> "su_command"
+        | SuCommandQuoted -> "su_command_quoted"
         | Unknown -> "<unknown key>"
+
+let string_of_default_bool (b: default_bool) =
+    match b with
+    | true -> "true"
+    | false -> "false"
+    | Default -> "default"

ocaml/lib/system/file.ml

@@ -1,3 +1,5 @@
+open Utilities.Aliases
+
 let read_channel channel =
     let buffer = Buffer.create 4096 in
     let rec read () =
@@ -8,6 +10,12 @@ let read_channel channel =
     in
     try read () with End_of_file -> Buffer.contents buffer
 
+let can_read (path: string): bool =
+    try Unix.access path [Unix.R_OK]; true
+    with Unix.Unix_error _ ->
+        elog $ "Failed to read file " ^ path;
+        false
+
 let read path =
     let channel = open_in path in
     read_channel channel

ocaml/lib/system/package.ml

@@ -1,3 +1,7 @@
+open Utilities.Aliases
+
+let su = Process.Su.elevate_wrapped
+
 let merge (schema : Schema.schema) (packages : string list) : Schema.schema =
     match packages with
     | [] ->
@@ -6,17 +10,18 @@ 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 su_command_line = schema.input.configuration.main.su_command in
+        let su_command = Process.Su.head_of_su_command su_command_line in
         let commands : Process.Command.command list =
             [
               {
                 name = su_command;
-                arguments = [ su_command; "apk"; "-i"; "add" ] @ packages;
+                arguments = su schema $ [ "apk"; "-i"; "add" ] @ packages;
                 status = Unevaluated;
               };
               {
                 name = su_command;
-                arguments = [ su_command; "apk"; "-i"; "del" ] @ packages;
+                arguments = su schema $ [ "apk"; "-i"; "del" ] @ packages;
                 status = Unevaluated;
               };
             ]

ocaml/lib/system/process/command.ml

@@ -17,22 +17,3 @@ 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/system/process/su.ml

@@ -0,0 +1,34 @@
+open Utilities.Aliases
+type schema = Schema.schema
+
+let head_of_su_command command_line =
+    match command_line with
+    | head :: _ -> head
+    | [] -> raise $ Malformed_source "su_command is set to an empty value"
+
+let elevate_wrapped (schema: schema) (command: string list): string list =
+    let su_command = schema.input.configuration.main.su_command in
+    match schema.input.configuration.main.su_command_quoted with
+    | true|Default -> List.concat [ su_command; [(String.concat " " command)]; ]
+    | false -> List.concat [ su_command; ["--"]; (command); ]
+
+let is_executable (schema: schema): schema =
+    let command = head_of_su_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 =
+                        "The configured super user command " ^ command ^
+                        " either could not be found at path '" ^ path.output ^
+                        "' or you lack permissions to execute it ("
+                        ^ path.status ^ ", stderr: '" ^ path.error ^ "')\n"
+                };
+            meta = { schema.meta with status = 1; error_level = Fatal };
+        }
+

ocaml/lib/utilities/aliases.ml

@@ -1,5 +1,9 @@
 (* an 'alias' is an alternate name with minor or no alterations to behavior *)
 
+(* exceptions *)
+exception Malformed_source = Exceptions.Malformed_source
+exception Malformed_state = Exceptions.Malformed_state
+
 (* logging *)
 let print = print_endline
 let elog = Log.elog
@@ -9,6 +13,7 @@ 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
+let str_dbool = Schema.string_of_default_bool
 
 (* control flow & precedence *)
 let ($) = (@@)

ocaml/lib/utilities/exceptions.ml

@@ -0,0 +1,2 @@
+exception Malformed_source of string
+exception Malformed_state of string