diff --git a/ocaml/README.md b/ocaml/README.md index 063ae88..69dc623 100644 --- a/ocaml/README.md +++ b/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 - [ ] diff --git a/ocaml/bin/main.ml b/ocaml/bin/main.ml index 4dfd434..9bf5a0b 100644 --- a/ocaml/bin/main.ml +++ b/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 diff --git a/ocaml/lib/checks/checks.ml b/ocaml/lib/checks/checks.ml new file mode 100644 index 0000000..778ae36 --- /dev/null +++ b/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 + diff --git a/ocaml/lib/parsers/argument.ml b/ocaml/lib/parsers/argument.ml index 19e7727..3be10c8 100644 --- a/ocaml/lib/parsers/argument.ml +++ b/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 diff --git a/ocaml/lib/parsers/config/fetcher.ml b/ocaml/lib/parsers/config/fetcher.ml new file mode 100644 index 0000000..bc0404a --- /dev/null +++ b/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 diff --git a/ocaml/lib/parsers/config/lexer.ml b/ocaml/lib/parsers/config/lexer.ml index dc4ca8b..d977519 100644 --- a/ocaml/lib/parsers/config/lexer.ml +++ b/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 diff --git a/ocaml/lib/parsers/config/lexer.mli b/ocaml/lib/parsers/config/lexer.mli index e24451f..a5f29a0 100644 --- a/ocaml/lib/parsers/config/lexer.mli +++ b/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 diff --git a/ocaml/lib/parsers/config/parser.ml b/ocaml/lib/parsers/config/parser.ml index 932b88d..99a3cc6 100644 --- a/ocaml/lib/parsers/config/parser.ml +++ b/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 diff --git a/ocaml/lib/parsers/config/parser.mli b/ocaml/lib/parsers/config/parser.mli index c79296e..48e499e 100644 --- a/ocaml/lib/parsers/config/parser.mli +++ b/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 diff --git a/ocaml/lib/schema/schema.ml b/ocaml/lib/schema/schema.ml index 8e6266c..80dbc2e 100644 --- a/ocaml/lib/schema/schema.ml +++ b/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 = ""; long = ""; }; + 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 -> "" + +let string_of_default_bool (b: default_bool) = + match b with + | true -> "true" + | false -> "false" + | Default -> "default" diff --git a/ocaml/lib/system/file.ml b/ocaml/lib/system/file.ml index 970fd0f..c164bb0 100644 --- a/ocaml/lib/system/file.ml +++ b/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 diff --git a/ocaml/lib/system/package.ml b/ocaml/lib/system/package.ml index ab2a67c..0dac4e6 100644 --- a/ocaml/lib/system/package.ml +++ b/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; }; ] diff --git a/ocaml/lib/system/process/command.ml b/ocaml/lib/system/process/command.ml index 638da19..975d202 100644 --- a/ocaml/lib/system/process/command.ml +++ b/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 }; - } diff --git a/ocaml/lib/system/process/su.ml b/ocaml/lib/system/process/su.ml new file mode 100644 index 0000000..ecd8ced --- /dev/null +++ b/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 }; + } + diff --git a/ocaml/lib/utilities/aliases.ml b/ocaml/lib/utilities/aliases.ml index 6c2e4b7..46121f8 100644 --- a/ocaml/lib/utilities/aliases.ml +++ b/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 ($) = (@@) diff --git a/ocaml/lib/utilities/exceptions.ml b/ocaml/lib/utilities/exceptions.ml new file mode 100644 index 0000000..f9b3248 --- /dev/null +++ b/ocaml/lib/utilities/exceptions.ml @@ -0,0 +1,2 @@ +exception Malformed_source of string +exception Malformed_state of string