From f747fe973e226bb90d90460f3d74981c796d0a8f Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Wed, 30 Nov 2016 14:00:01 -0500 Subject: [PATCH 01/27] Improve test failure display --- src/test-lib/test_lib.ml | 52 ++++++++++++++++++++++++---------------- 1 file changed, 32 insertions(+), 20 deletions(-) diff --git a/src/test-lib/test_lib.ml b/src/test-lib/test_lib.ml index 76d2985..f1f112f 100644 --- a/src/test-lib/test_lib.ml +++ b/src/test-lib/test_lib.ml @@ -13,26 +13,38 @@ let babble fmt = else ()) fmt let check_command s ~verifies = - babble "check_command\n %s\n%!" (String.sub s ~index:0 ~length:100 |> Option.value ~default:s); - Pvem_lwt_unix.System.Shell.execute s - >>= fun (out, err, exit_status) -> - List.fold verifies ~init:(return []) ~f:(fun prev_m v -> - prev_m >>= fun prev -> - match v with - | `Exits_with i -> - let l = - if exit_status = `Exited i - then (true, "exited well") :: prev - else ( - false, - sprintf "%s:\nout:\n%s\nerr:\n%s\ncall:\n%s\n" - (Pvem_lwt_unix.System.Shell.status_to_string exit_status) - out - err - s - ) :: prev - in - return l) + babble "check_command (%s)\n %s\n%!" + (List.map ~f:(function `Exits_with n -> sprintf "exits with %d" n) verifies + |> String.concat ~sep:", ") + (String.sub s ~index:0 ~length:300 |> Option.value ~default:s); + begin + Pvem_lwt_unix.System.with_timeout 5. ~f:begin fun () -> + Pvem_lwt_unix.System.Shell.execute s + end + >>< begin function + | `Ok (out, err, exit_status) -> + List.fold verifies ~init:(return []) ~f:(fun prev_m v -> + prev_m >>= fun prev -> + match v with + | `Exits_with i -> + let l = + if exit_status = `Exited i + then (true, "exited well") :: prev + else ( + false, + sprintf "%s (instead of %d):\nout:\n%s\nerr:\n%s\ncall:\n%s\n" + (Pvem_lwt_unix.System.Shell.status_to_string exit_status) + i out err s + ) :: prev + in + return l) + | `Error (`System (`With_timeout _, _)) -> assert false + | `Error (`Shell (_, `Exn e)) -> + return [false, sprintf "Shell EXN : %s" (Printexc.to_string e)] + | `Error (`Timeout _) -> + return [false, sprintf "Timeout !!"] + end + end >>= fun results -> List.filter ~f:(fun (t, _) -> t = false) results |> return From 7155fa1fcb09fd61a1636d197cea26656d1b9e49 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Wed, 30 Nov 2016 14:01:42 -0500 Subject: [PATCH 02/27] Implement `EDSL.call` Now `EDSL.exec` is implemented with `call`. --- src/lib/EDSL.mli | 9 +++++++ src/lib/language.ml | 57 ++++++++++++++++++++++++--------------------- src/test/main.ml | 14 ++++++++--- 3 files changed, 50 insertions(+), 30 deletions(-) diff --git a/src/lib/EDSL.mli b/src/lib/EDSL.mli index 3bd6b6e..eb049d6 100644 --- a/src/lib/EDSL.mli +++ b/src/lib/EDSL.mli @@ -7,7 +7,16 @@ type ('a, 'b) cli_options = ('a, 'b) Language.cli_options val fail: unit t (** Abort the script/command immediately. *) +val call : string t list -> unit t +(** Call a command from its list of “arguments” (including the first + argument being the actual command). *) + val exec : string list -> unit t +(** Like {!call} but with string literals; i.e. [exec ["a"; "b"]] is + actually [call [string "a"; string "b"]] which is the usual shell command + ["a b"] (with proper escaping). *) + + val ( &&& ) : bool t -> bool t -> bool t val ( ||| ) : bool t -> bool t -> bool t val ( =$= ) : string t -> string t -> bool t diff --git a/src/lib/language.ml b/src/lib/language.ml index 3d26a03..c9f99c1 100644 --- a/src/lib/language.ml +++ b/src/lib/language.ml @@ -19,6 +19,19 @@ module Literal = struct end |> fst | Bool true -> "0" | Bool false -> "1" + + module String = struct + let easy_to_escape s = + String.for_all s + ~f:(function + | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '-' | '_' | '*' | '&' | '^' + | '=' | '+' | '%' | '$' | '"' | '\'' | '/' | '#' | '@' | '!' | ' ' + | '~' | '`' | '\\' | '|' | '?' | '>' | '<' | '.' | ',' | ':' | ';' + | '{' | '}' | '(' | ')' | '[' | ']' -> true + | other -> false) + let impossible_to_escape_for_variable = String.exists ~f:((=) '\x00') + end + end type cli_option = { @@ -32,7 +45,7 @@ and (_, _) cli_options = | Opt_end: string -> ('a, 'a) cli_options | Opt_cons: 'c option_spec * ('a, 'b) cli_options -> ('c -> 'a, 'b) cli_options and _ t = - | Exec: string list -> unit t + | Exec: string t list -> unit t | Raw_cmd: string -> unit t | Bool_operator: bool t * [ `And | `Or ] * bool t -> bool t | String_operator: string t * [ `Eq | `Neq ] * string t -> bool t @@ -58,7 +71,8 @@ and _ t = | Fail: unit t module Construct = struct - let exec l = Exec l + let exec l = Exec (List.map l ~f:(fun s -> Literal (Literal.String s))) + let call l = Exec l let (&&&) a b = Bool_operator (a, `And, b) let (|||) a b = Bool_operator (a, `Or, b) let (=$=) a b = String_operator (a, `Eq, b) @@ -132,40 +146,29 @@ let rec to_shell: type a. _ -> a t -> string = sprintf {sh| printf "$(printf '%%s' %s | sed -e 's/\(.\{3\}\)/\\\1/g')" |sh} s in - (* let expand_output_to_string = *) - (* sprintf "\"$(%s)\"" in *) match e with | Exec l -> - let easy_to_escape = - function - | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '-' | '_' | '*' | '&' | '^' - | '=' | '+' | '%' | '$' | '"' | '\'' | '/' | '#' | '@' | '!' | ' ' - | '~' | '`' | '\\' | '|' | '?' | '>' | '<' | '.' | ',' | ':' | ';' - | '{' | '}' | '(' | ')' | '[' | ']' -> true - | other -> false in - let impossible_to_escape = String.exists ~f:((=) '\x00') in let variables = ref [] in let args = List.mapi l ~f:(fun index -> function - | arg when String.for_all arg ~f:easy_to_escape -> - Filename.quote arg - | arg when impossible_to_escape arg -> - ksprintf failwith "to_shell: sorry %S is impossible to escape as \ - `exec` argument" arg - | arg -> - let var, () = - with_buffer begin fun str -> - ksprintf str "argument_%d=$(printf '" index; - String.iter arg ~f:(fun c -> - Char.code c |> sprintf "\\%03o" |> str - ); - str "'; printf 'x') ; " - end in + | Literal (Literal.String s) when Literal.String.easy_to_escape s -> + Filename.quote s + | Literal (Literal.String s) when + Literal.String.impossible_to_escape_for_variable s -> + ksprintf failwith "to_shell: sorry literal %S is impossible to \ + escape as `exec` argument" s + | v -> + let var = + sprintf "argument_%d=$(%s; printf 'x') ; " + index (continue v |> expand_octal); + in variables := var :: !variables; sprintf "\"${argument_%d%%?}\"" index ) in - (List.rev !variables) @ args |> String.concat ~sep:" " + (List.rev !variables) @ args + |> String.concat ~sep:" " + |> sprintf " { %s ; } " | Raw_cmd s -> s | Returns {expr; value} -> sprintf " { %s ; [ $? -eq %d ] ; }" (continue expr) value diff --git a/src/test/main.ml b/src/test/main.ml index 8a9fbd0..4b90edb 100644 --- a/src/test/main.ml +++ b/src/test/main.ml @@ -18,7 +18,6 @@ let tests = let return n = Construct.exec ["sh"; "-c"; sprintf "exit %d" n] in List.concat [ - exits 0 (Compile.Exec ["ls"]); exits 0 Construct.( succeeds (exec ["ls"]) &&& returns ~value:18 (seq [ @@ -132,20 +131,21 @@ let tests = (return 10) (return 11) ); - exits 10 Construct.( + exits 13 Construct.( let tmp = "/tmp/test_loop_while" in let cat_potentially_empty = if_then_else (exec ["cat"; tmp] |> succeeds) nop (printf "") in seq [ + exec ["rm"; "-f"; tmp]; exec ["rm"; "-f"; tmp]; loop_while (cat_potentially_empty |> output_as_string <$> string "nnnn") ~body:begin exec ["sh"; "-c"; sprintf "printf n >> %s" tmp]; end; - return 10; + return 13; ]; ); begin @@ -293,6 +293,14 @@ let tests = (return 12); ]; ); + (* Use of the `call` constructor: *) + exits 28 Construct.( + if_then_else + (call [string "cat"; output_as_string (printf "/does not exist")] + |> succeeds) + (return 11) + (return 28); + ); ] From 680f46b1589cda3c806cfa9f912b6b0172cf8ac0 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Wed, 30 Nov 2016 16:06:17 -0500 Subject: [PATCH 03/27] Add first (partial) example Examples are also meant to guide the development of the API. --- myocamlbuild.ml | 6 ++- src/test/examples.ml | 96 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 101 insertions(+), 1 deletion(-) create mode 100644 src/test/examples.ml diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 932284d..f47e1ff 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -44,7 +44,11 @@ let test : Project.item list = Project.app (project_name ^ "-test") ~thread:() ~file:"src/test/main.ml" - ~internal_deps:[lib; test_lib] + ~internal_deps:[lib; test_lib]; + Project.app (project_name ^ "-examples") + ~thread:() + ~file:"src/test/examples.ml" + ~internal_deps:[lib; test_lib]; ] else [] diff --git a/src/test/examples.ml b/src/test/examples.ml new file mode 100644 index 0000000..e9a5796 --- /dev/null +++ b/src/test/examples.ml @@ -0,0 +1,96 @@ + +open Nonstd +module String = Sosa.Native_string + +let downloader () = + let open Genspio.EDSL in + let sayf ?(strings = []) fmt = + ksprintf (fun s -> + let say ?(prompt = false) s = + let prompt = + if prompt then "downloader: " else " " in + call (string "printf" + :: string (prompt ^ "%s\\n") + :: s :: []) in + seq (say ~prompt:true (string s) :: List.map strings ~f:say) + ) fmt in + let failf fmt = ksprintf (fun s -> seq [sayf "ERROR: %s" s; fail]) fmt in + let (//) = Filename.concat in + let silence ~name unit = + let stdout = "/tmp" // sprintf "output-of-%s-%s" name "-out" in + let stderr = "/tmp" // sprintf "output-of-%s-%s" name "-err" in + seq [ + sayf "Silent %s (%s, %s)" name stdout stderr; + write_output unit ~stdout ~stderr; + ] in + let download ~url ~output = + switch [ + exec ["wget"; "--help"] |> silence ~name:"wget-help" |> succeeds, + seq [ + sayf "Using WGET."; + call [ + string "wget"; url; string "--output-document"; output; + ]; + ]; + exec ["curl"; "--help"] |> silence ~name:"curl-help" |> succeeds, + seq [ + sayf "Using CURL."; + call [ + string "curl"; url; string "--output"; output; + ]; + ]; + ] + ~default:(failf "Can't find a downloading application") + in + let string_matches_any string regexp_list = + (* Cf. http://pubs.opengroup.org/onlinepubs/009695399/utilities/grep.html *) + let options = List.concat_map regexp_list ~f:(fun r -> ["-e"; r]) in + string >> exec (["grep"; "-q"] @ options) |> succeeds in + let string_concat sl = + let out s = call [string "printf"; string "%s"; s] in + seq (List.map sl ~f:out) |> output_as_string in + parse_command_line + Option_list.( + string ~doc:"The URL to the stuff" 'u' + & usage "$0 -u URL" + ) + begin fun url -> + let filename = + url >> exec ["sed"; "s:.*/\\([^\\?\\/]*\\)\\?.*:\\1:"] |> output_as_string in + let tmpdir = "/tmp/genspio-downloader" in + let output_of_download = + string_concat [string tmpdir; string "/"; filename] in + seq [ + exec ["mkdir"; "-p"; tmpdir]; + if_then_else + (string_matches_any url ["^http://"; "^https://"; "^ftp://"]) + (seq [ + download ~url ~output:output_of_download; + sayf "Downloaded " ~strings:[output_of_download]; + ]) + (failf "URL not in Http(s) or FTP: NOT IMPLEMENTED") + ] + end + + +let () = + match Sys.argv |> Array.to_list |> List.tl_exn with + | "dl" :: path :: [] -> + let script = Genspio.Language.to_many_lines (downloader ()) in + let content = + sprintf + "#!/bin/sh\n\n# Generated by Genspio Example Tests\n\n%s\n%!" script in + begin match path with + | "-" -> printf "\n`````\n%s`````\n%!" content + | other -> + let o = open_out other in + fprintf o "%s%!" content; + close_out o + end + | other -> + eprintf "Wrong command line: [%s]\n" + (List.map ~f:(sprintf "%S") other |> String.concat ~sep:"; "); + eprintf "Usage:\n\ + %s dl \n\ + \ Create the downloader script.\n%!" Sys.argv.(0); + exit 1 From f30d6637cfeeb613603b07ff195e640f35eed81c Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Wed, 30 Nov 2016 16:07:38 -0500 Subject: [PATCH 04/27] Update `.gitignore` file --- .gitignore | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index b6fb7b6..842f940 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,6 @@ /_build/ -/genspio.byte \ No newline at end of file +/genspio.byte +/.merlin +/.ocamlinit +/genspio-examples.byte +/genspio-test.byte From 9ca004137b805ed054511ab88d9ac6b02a2754ea Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Wed, 30 Nov 2016 17:06:52 -0500 Subject: [PATCH 05/27] Add `?default` arguments to CLI-options --- src/lib/EDSL.ml | 2 +- src/lib/EDSL.mli | 20 ++++++++++++++------ src/lib/language.ml | 22 ++++++++++++++-------- 3 files changed, 29 insertions(+), 15 deletions(-) diff --git a/src/lib/EDSL.ml b/src/lib/EDSL.ml index 42e67b7..96daf0e 100644 --- a/src/lib/EDSL.ml +++ b/src/lib/EDSL.ml @@ -1,5 +1,5 @@ type 'a t = 'a Language.t -type cli_option = Language.cli_option +type 'a cli_option = 'a Language.cli_option type 'a option_spec = 'a Language.option_spec type ('a, 'b) cli_options = ('a, 'b) Language.cli_options include Language.Construct diff --git a/src/lib/EDSL.mli b/src/lib/EDSL.mli index eb049d6..281f049 100644 --- a/src/lib/EDSL.mli +++ b/src/lib/EDSL.mli @@ -1,7 +1,4 @@ type 'a t = 'a Language.t -type cli_option = Language.cli_option -type 'a option_spec = 'a Language.option_spec -type ('a, 'b) cli_options = ('a, 'b) Language.cli_options val fail: unit t @@ -45,18 +42,29 @@ val write_output : ?return_value:string -> unit t -> unit t val write_stdout : path:string -> unit t -> unit t +(** {3 Literals } *) + val string : string -> string t val int : int -> int t -val bool : bool t +val bool : bool -> bool t + val output_as_string : unit t -> string t val feed : string:string t -> unit t -> unit t val ( >> ) : string t -> unit t -> unit t val loop_while : bool t -> body:unit t -> unit t +type 'a cli_option = 'a Language.cli_option +type 'a option_spec = 'a Language.option_spec +type ('a, 'b) cli_options = ('a, 'b) Language.cli_options module Option_list : sig val string : - doc:string -> char -> string t option_spec - val flag : doc:string -> char -> bool t option_spec + ?default: string t -> + doc:string -> char -> + string t option_spec + val flag : + ?default: bool t -> + doc:string -> char -> + bool t option_spec val ( & ) : 'a option_spec -> ('b, 'c) cli_options -> ('a -> 'b, 'c) cli_options diff --git a/src/lib/language.ml b/src/lib/language.ml index c9f99c1..87867a5 100644 --- a/src/lib/language.ml +++ b/src/lib/language.ml @@ -34,13 +34,14 @@ module Literal = struct end -type cli_option = { +type 'a cli_option = { switch: char; doc: string; + default: 'a; } type _ option_spec = - | Opt_flag: cli_option -> bool t option_spec - | Opt_string: cli_option -> string t option_spec + | Opt_flag: bool t cli_option -> bool t option_spec + | Opt_string: string t cli_option -> string t option_spec and (_, _) cli_options = | Opt_end: string -> ('a, 'a) cli_options | Opt_cons: 'c option_spec * ('a, 'b) cli_options -> ('c -> 'a, 'b) cli_options @@ -110,7 +111,7 @@ module Construct = struct let literal l = Literal l let string s = Literal.String s |> literal let int s = Literal.Int s |> literal - let bool = Literal.Bool true |> literal + let bool t = Literal.Bool t |> literal let output_as_string e = Output_as_string e @@ -120,8 +121,10 @@ module Construct = struct let loop_while condition ~body = While {condition; body} module Option_list = struct - let string ~doc switch = Opt_string {switch; doc} - let flag ~doc switch = Opt_flag {switch; doc} + let string ?(default = string "") ~doc switch = + Opt_string {switch; doc; default} + let flag ?(default = bool false) ~doc switch = + Opt_flag {switch; doc; default} let (&) x y = Opt_cons (x, y) let usage s = Opt_end s @@ -242,7 +245,8 @@ let rec to_shell: type a. _ -> a t -> string = f | Opt_cons (Opt_string x, more) -> let var = variable x in - to_init (sprintf "export %s= " var); + to_init (sprintf "export %s=$(%s)" + var (continue x.default |> expand_octal)); to_case (sprintf "-%c) %s ;;" x.switch (seq [ @@ -259,7 +263,9 @@ let rec to_shell: type a. _ -> a t -> string = loop (f (string_of_var var)) more | Opt_cons (Opt_flag x, more) -> let var = variable x in - to_init (sprintf "export %s=1 " var); + to_init (sprintf + "export %s=$(if %s then printf '0' else printf '1')" var + (continue x.default)); to_case ( sprintf "-%c) %s ;;" x.switch (seq [ From 5e9b159b4244028d29474913f3d5eda92c6bdf3f Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Wed, 30 Nov 2016 17:07:22 -0500 Subject: [PATCH 06/27] Improve error & display management (`downloader`) --- src/test/examples.ml | 47 ++++++++++++++++++++++++++++++-------------- 1 file changed, 32 insertions(+), 15 deletions(-) diff --git a/src/test/examples.ml b/src/test/examples.ml index e9a5796..7a1ed99 100644 --- a/src/test/examples.ml +++ b/src/test/examples.ml @@ -4,17 +4,23 @@ module String = Sosa.Native_string let downloader () = let open Genspio.EDSL in - let sayf ?(strings = []) fmt = - ksprintf (fun s -> - let say ?(prompt = false) s = - let prompt = - if prompt then "downloader: " else " " in - call (string "printf" - :: string (prompt ^ "%s\\n") - :: s :: []) in - seq (say ~prompt:true (string s) :: List.map strings ~f:say) - ) fmt in - let failf fmt = ksprintf (fun s -> seq [sayf "ERROR: %s" s; fail]) fmt in + let say strings = + let sayone ?(prompt = false) s = + let prompt = + if prompt then "downloader: " else "" in + call (string "printf" :: string (prompt ^ "%s") :: s :: []) in + match strings with + | [] -> nop + | s :: more -> + seq ( + sayone ~prompt:true s :: List.map more ~f:sayone @ [ + sayone (string "\n"); + ] + ) + in + let sayf fmt = ksprintf (fun s -> say [string s]) fmt in + let fail l = seq [say (string "ERROR: " :: l); fail] in + let failf fmt = ksprintf (fun s -> fail [string s]) fmt in let (//) = Filename.concat in let silence ~name unit = let stdout = "/tmp" // sprintf "output-of-%s-%s" name "-out" in @@ -49,26 +55,37 @@ let downloader () = let string_concat sl = let out s = call [string "printf"; string "%s"; s] in seq (List.map sl ~f:out) |> output_as_string in + let no_value = sprintf "none_%x" (Random.int 100_000) |> string in parse_command_line Option_list.( - string ~doc:"The URL to the stuff" 'u' + string + ~doc:"The URL to the stuff" 'u' + ~default:no_value & usage "$0 -u URL" ) begin fun url -> let filename = - url >> exec ["sed"; "s:.*/\\([^\\?\\/]*\\)\\?.*:\\1:"] |> output_as_string in + url >> exec ["sed"; "s:.*/\\([^\\?\\/]*\\)\\?.*:\\1:"] + |> output_as_string in let tmpdir = "/tmp/genspio-downloader" in let output_of_download = string_concat [string tmpdir; string "/"; filename] in seq [ exec ["mkdir"; "-p"; tmpdir]; + if_then (url =$= no_value) + (failf "Argument URL is mandatory"); if_then_else (string_matches_any url ["^http://"; "^https://"; "^ftp://"]) (seq [ download ~url ~output:output_of_download; - sayf "Downloaded " ~strings:[output_of_download]; + say [string "Downloaded "; output_of_download]; + ]) + (seq [ + fail [ + string "URL: "; url; + string " -> not HTTP(s) or FTP: NOT IMPLEMENTED"; + ] ]) - (failf "URL not in Http(s) or FTP: NOT IMPLEMENTED") ] end From 288386837098cc20d0ed49f8bcb2040e5a9de646 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Wed, 30 Nov 2016 17:35:18 -0500 Subject: [PATCH 07/27] Add documentation blob about non-C strings --- src/lib/EDSL.mli | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/lib/EDSL.mli b/src/lib/EDSL.mli index 281f049..f4f8510 100644 --- a/src/lib/EDSL.mli +++ b/src/lib/EDSL.mli @@ -6,7 +6,15 @@ val fail: unit t val call : string t list -> unit t (** Call a command from its list of “arguments” (including the first - argument being the actual command). *) + argument being the actual command). + + Note that UNIX does not allow strings passed as arguments to + executables to contain NUL-characters (['\x00']). + The function {!Language.to_many_lines} raises an exception + if an argument is a literal and contains a NUL, but if the + argument is the result of some other expression the behavior is + for now undefined. +*) val exec : string list -> unit t (** Like {!call} but with string literals; i.e. [exec ["a"; "b"]] is From 655d3dc2ebd65e661b98bd5752d03e1584cf3fd9 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Thu, 1 Dec 2016 08:11:32 -0500 Subject: [PATCH 08/27] Fix compilation bug introduced in `9ca004137b` Bug [caught](https://travis-ci.org/hammerlab/genspio/builds/180239928) by Travis. --- src/lib/language.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lib/language.ml b/src/lib/language.ml index 87867a5..5af299f 100644 --- a/src/lib/language.ml +++ b/src/lib/language.ml @@ -264,7 +264,7 @@ let rec to_shell: type a. _ -> a t -> string = | Opt_cons (Opt_flag x, more) -> let var = variable x in to_init (sprintf - "export %s=$(if %s then printf '0' else printf '1')" var + "export %s=$(if %s ; then printf '0' ; else printf '1' ; fi)" var (continue x.default)); to_case ( sprintf "-%c) %s ;;" From f89f51c3084c9f7e704e4eaf720dff06613a7958 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Fri, 2 Dec 2016 17:41:06 -0500 Subject: [PATCH 09/27] Fix representation of boolean literals --- src/lib/language.ml | 6 +++--- src/test/main.ml | 14 ++++++++++++-- 2 files changed, 15 insertions(+), 5 deletions(-) diff --git a/src/lib/language.ml b/src/lib/language.ml index 5af299f..bb6bd50 100644 --- a/src/lib/language.ml +++ b/src/lib/language.ml @@ -17,8 +17,8 @@ module Literal = struct ); str "'" end |> fst - | Bool true -> "0" - | Bool false -> "1" + | Bool true -> "true" + | Bool false -> "false" module String = struct let easy_to_escape s = @@ -264,7 +264,7 @@ let rec to_shell: type a. _ -> a t -> string = | Opt_cons (Opt_flag x, more) -> let var = variable x in to_init (sprintf - "export %s=$(if %s ; then printf '0' ; else printf '1' ; fi)" var + "export %s=$(if %s ; then printf 'true' ; else printf 'false' ; fi)" var (continue x.default)); to_case ( sprintf "-%c) %s ;;" diff --git a/src/test/main.ml b/src/test/main.ml index 4b90edb..3ae84ae 100644 --- a/src/test/main.ml +++ b/src/test/main.ml @@ -298,8 +298,18 @@ let tests = if_then_else (call [string "cat"; output_as_string (printf "/does not exist")] |> succeeds) - (return 11) - (return 28); + (return 11) + (return 28); + ); + exits 17 Construct.( + if_then_else (bool true) (return 17) (return 16) + ); + exits 16 Construct.( + if_then_else (bool true &&& bool false) (return 17) (return 16) + ); + exits 16 Construct.( + if_then_else + (bool true &&& not (bool false)) (return 16) (return 17) ); ] From a9f8b9be6affe3996ea910d64bce4c51b2bcccf4 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Fri, 2 Dec 2016 17:42:09 -0500 Subject: [PATCH 10/27] =?UTF-8?q?Improve=20the=20=E2=80=9Cdownloader?= =?UTF-8?q?=E2=80=9D=20example?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The generated script now extracts GPG, Gzip, and Tar files (in a loop). Error management has also been improved. --- src/test/examples.ml | 146 +++++++++++++++++++++++++++++++++++-------- 1 file changed, 121 insertions(+), 25 deletions(-) diff --git a/src/test/examples.ml b/src/test/examples.ml index 7a1ed99..0949297 100644 --- a/src/test/examples.ml +++ b/src/test/examples.ml @@ -22,31 +22,69 @@ let downloader () = let fail l = seq [say (string "ERROR: " :: l); fail] in let failf fmt = ksprintf (fun s -> fail [string s]) fmt in let (//) = Filename.concat in + let module Switch = struct + let case condition body = `Case (condition, seq body) + let default d = `Default d + let switch l = + let default = ref None in + let cases = + List.filter_map l ~f:(function + | `Default d when !default <> None -> + failwith "Cannot build switch with >1 defaults" + | `Default d -> default := (Some (seq d)); None + | `Case t -> Some t) + in + switch ~default:(Option.value ~default:nop !default) cases + end in + let module If = struct + let make ~t ?e c = + match e with + | None -> if_then c (seq t) + | Some f -> if_then_else c (seq t) (seq f) + end in + let silent ~name unit = + object (self) + method stdout = "/tmp" // sprintf "output-of-%s-%s" name "-out" + method stderr = "/tmp" // sprintf "output-of-%s-%s" name "-err" + method exec = + seq [ + (* sayf "Silent %s (%s, %s)" name self#stdout self#stderr; *) + write_output (seq unit) ~stdout:self#stdout ~stderr:self#stderr; + ] + method succeed_or_fail = + If.(make + (self#exec|> succeeds) + ~t:[sayf "%s: Success" name] + ~e:[ + sayf "Expression %s failed!" name; + exec ["cat"; self#stderr]; + failf "Fatal failure of %s" name; + ]) + end in let silence ~name unit = - let stdout = "/tmp" // sprintf "output-of-%s-%s" name "-out" in - let stderr = "/tmp" // sprintf "output-of-%s-%s" name "-err" in - seq [ - sayf "Silent %s (%s, %s)" name stdout stderr; - write_output unit ~stdout ~stderr; - ] in + let s = silent ~name [unit] in + s#exec in + let succeed_in_silence_or_fail ~name units = + let s = silent ~name units in + s#succeed_or_fail in let download ~url ~output = - switch [ - exec ["wget"; "--help"] |> silence ~name:"wget-help" |> succeeds, - seq [ - sayf "Using WGET."; - call [ - string "wget"; url; string "--output-document"; output; - ]; - ]; - exec ["curl"; "--help"] |> silence ~name:"curl-help" |> succeeds, - seq [ - sayf "Using CURL."; - call [ - string "curl"; url; string "--output"; output; - ]; - ]; - ] - ~default:(failf "Can't find a downloading application") + let try_help ?(opt = "--help") cmd = + exec [cmd; opt] |> silence ~name:(cmd ^ opt) |> succeeds in + let do_call exec args = [ + sayf "Using `%s`." exec; + succeed_in_silence_or_fail ~name:exec [ + call (string exec :: args); + ] + ] in + Switch.( + switch [ + case (try_help "wget") + (do_call "wget" [url; string "--output-document"; output]); + case (try_help "curl") + (do_call "wget" [url; string "--output-document"; output]); + default [failf "Can't find a downloading application"]; + ] + ) in let string_matches_any string regexp_list = (* Cf. http://pubs.opengroup.org/onlinepubs/009695399/utilities/grep.html *) @@ -61,17 +99,34 @@ let downloader () = string ~doc:"The URL to the stuff" 'u' ~default:no_value - & usage "$0 -u URL" + & flag 'c' ~doc:"Do everything in the temp-dir" + & usage "$0 -u URL [-c]" ) - begin fun url -> + begin fun url all_in_tmp -> let filename = url >> exec ["sed"; "s:.*/\\([^\\?\\/]*\\)\\?.*:\\1:"] |> output_as_string in let tmpdir = "/tmp/genspio-downloader" in let output_of_download = string_concat [string tmpdir; string "/"; filename] in + let current_name = + let path = tmpdir // "current-name" in + let tmp = path ^ "-tmp" in + object + method get = output_as_string (exec ["cat"; path]) + method set v = + seq [ + v >> exec ["cat"] |> write_output ~stdout:tmp; + exec ["mv"; "-f"; tmp; path]; + ] + end in + let remove_suffix v suf = + v >> exec ["sed"; sprintf "s:^\\(.*\\)%s$:\\1:" suf] + |> output_as_string in seq [ exec ["mkdir"; "-p"; tmpdir]; + if_then all_in_tmp + (seq [sayf "Going to the tmpdir"; call [string "cd"; string tmpdir]]); if_then (url =$= no_value) (failf "Argument URL is mandatory"); if_then_else @@ -79,6 +134,47 @@ let downloader () = (seq [ download ~url ~output:output_of_download; say [string "Downloaded "; output_of_download]; + current_name#set output_of_download; + loop_while + (string_matches_any current_name#get [".gpg$"; ".tgz$"; ".tar$"; ".gz$"]) + ~body:begin + let make_case ~ext ~verb commands = + Switch.case (string_matches_any + current_name#get [sprintf ".%s$" ext]) [ + say [ksprintf string "%s: " verb; current_name#get]; + succeed_in_silence_or_fail + ~name:(sprintf "%s-%s" verb ext) commands; + current_name#set + (remove_suffix current_name#get (sprintf "\\.%s" ext)); + ] in + seq [ + say [string "Extract loop: "; current_name#get]; + Switch.(switch [ + make_case ~ext:"gz" ~verb:"Gunzipping" [ + call [string "gunzip"; current_name#get]; + ]; + make_case ~ext:"tar" ~verb:"Untarring" [ + call [string "tar"; string "xf"; current_name#get]; + ]; + make_case ~ext:"tgz" ~verb:"Untar-gzip-ing" [ + call [string "tar"; string "zxf"; current_name#get]; + ]; + make_case ~ext:"gpg" ~verb:"Decyphering" [ + call [string "gpg"; + string "--output"; + (remove_suffix current_name#get "\\.gpg"); + string "-d"; current_name#get;]; + ]; + default [ + fail [ + string "File: "; current_name#get; + string " didn't match any option???" + ]; + ]; + ]; + ); + ] + end ]) (seq [ fail [ From e8736820571a81158d4c8031a138dea8fdc230b3 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Fri, 2 Dec 2016 18:16:20 -0500 Subject: [PATCH 11/27] Improve `switch` statements in the EDSL MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The implementation is adapted from what was inline in the “downloader” example. --- src/lib/EDSL.ml | 17 ++++++++++ src/lib/EDSL.mli | 27 ++++++++++++++-- src/lib/language.ml | 2 +- src/test/examples.ml | 77 +++++++++++++++++--------------------------- src/test/main.ml | 2 +- 5 files changed, 74 insertions(+), 51 deletions(-) diff --git a/src/lib/EDSL.ml b/src/lib/EDSL.ml index 96daf0e..2e45aac 100644 --- a/src/lib/EDSL.ml +++ b/src/lib/EDSL.ml @@ -2,5 +2,22 @@ type 'a t = 'a Language.t type 'a cli_option = 'a Language.cli_option type 'a option_spec = 'a Language.option_spec type ('a, 'b) cli_options = ('a, 'b) Language.cli_options + include Language.Construct +open Nonstd + +let case condition body = `Case (condition, seq body) +let default d = `Default (seq d) +let switch l = + let default = ref None in + let cases = + List.filter_map l ~f:(function + | `Default d when !default <> None -> + failwith "Cannot build switch with >1 defaults" + | `Default d -> default := (Some d); None + | `Case t -> Some t) + in + make_switch ~default:(Option.value ~default:nop !default) cases + + diff --git a/src/lib/EDSL.mli b/src/lib/EDSL.mli index f4f8510..73adbc8 100644 --- a/src/lib/EDSL.mli +++ b/src/lib/EDSL.mli @@ -41,9 +41,32 @@ val seq : unit t list -> unit t val not : bool t -> bool t val printf : ('a, unit, string, unit t) format4 -> 'a val file_exists : string -> bool t + +(** {3 Switch Statements } *) + val switch : - (bool t * unit t) list -> - default:unit t -> unit t + [ `Case of bool t * unit t | `Default of unit t ] list -> unit t +(** Create a switch statement from a list of {!case} and optionally a + {!default} (the function raises an exception if there are more + than one default cases). *) + +val case : + bool t -> + unit t list -> + [> `Case of bool t * unit t ] +(** Create a normal case for a {!switch} statement. *) + +val default : unit t list -> [> `Default of unit t ] +(** Create the default case for a {!switch} statement. *) + + +(**/**) +val make_switch : + (bool Language.t * unit Language.t) list -> + default:unit Language.t -> unit Language.t +(**/**) + + val write_output : ?stdout:string -> ?stderr:string -> diff --git a/src/lib/language.ml b/src/lib/language.ml index bb6bd50..33f2767 100644 --- a/src/lib/language.ml +++ b/src/lib/language.ml @@ -98,7 +98,7 @@ module Construct = struct let fail = Fail - let switch: type a. (bool t * unit t) list -> default: unit t -> unit t = + let make_switch: type a. (bool t * unit t) list -> default: unit t -> unit t = fun conds ~default -> List.fold_right conds ~init:default ~f:(fun (x, body) prev -> if_then_else x body prev) diff --git a/src/test/examples.ml b/src/test/examples.ml index 0949297..26374b9 100644 --- a/src/test/examples.ml +++ b/src/test/examples.ml @@ -22,20 +22,6 @@ let downloader () = let fail l = seq [say (string "ERROR: " :: l); fail] in let failf fmt = ksprintf (fun s -> fail [string s]) fmt in let (//) = Filename.concat in - let module Switch = struct - let case condition body = `Case (condition, seq body) - let default d = `Default d - let switch l = - let default = ref None in - let cases = - List.filter_map l ~f:(function - | `Default d when !default <> None -> - failwith "Cannot build switch with >1 defaults" - | `Default d -> default := (Some (seq d)); None - | `Case t -> Some t) - in - switch ~default:(Option.value ~default:nop !default) cases - end in let module If = struct let make ~t ?e c = match e with @@ -76,15 +62,13 @@ let downloader () = call (string exec :: args); ] ] in - Switch.( - switch [ - case (try_help "wget") - (do_call "wget" [url; string "--output-document"; output]); - case (try_help "curl") - (do_call "wget" [url; string "--output-document"; output]); - default [failf "Can't find a downloading application"]; - ] - ) + switch [ + case (try_help "wget") + (do_call "wget" [url; string "--output-document"; output]); + case (try_help "curl") + (do_call "wget" [url; string "--output-document"; output]); + default [failf "Can't find a downloading application"]; + ] in let string_matches_any string regexp_list = (* Cf. http://pubs.opengroup.org/onlinepubs/009695399/utilities/grep.html *) @@ -139,8 +123,8 @@ let downloader () = (string_matches_any current_name#get [".gpg$"; ".tgz$"; ".tar$"; ".gz$"]) ~body:begin let make_case ~ext ~verb commands = - Switch.case (string_matches_any - current_name#get [sprintf ".%s$" ext]) [ + case (string_matches_any + current_name#get [sprintf ".%s$" ext]) [ say [ksprintf string "%s: " verb; current_name#get]; succeed_in_silence_or_fail ~name:(sprintf "%s-%s" verb ext) commands; @@ -149,30 +133,29 @@ let downloader () = ] in seq [ say [string "Extract loop: "; current_name#get]; - Switch.(switch [ - make_case ~ext:"gz" ~verb:"Gunzipping" [ - call [string "gunzip"; current_name#get]; - ]; - make_case ~ext:"tar" ~verb:"Untarring" [ - call [string "tar"; string "xf"; current_name#get]; - ]; - make_case ~ext:"tgz" ~verb:"Untar-gzip-ing" [ - call [string "tar"; string "zxf"; current_name#get]; - ]; - make_case ~ext:"gpg" ~verb:"Decyphering" [ - call [string "gpg"; - string "--output"; - (remove_suffix current_name#get "\\.gpg"); - string "-d"; current_name#get;]; - ]; - default [ - fail [ - string "File: "; current_name#get; - string " didn't match any option???" - ]; + switch [ + make_case ~ext:"gz" ~verb:"Gunzipping" [ + call [string "gunzip"; current_name#get]; + ]; + make_case ~ext:"tar" ~verb:"Untarring" [ + call [string "tar"; string "xf"; current_name#get]; + ]; + make_case ~ext:"tgz" ~verb:"Untar-gzip-ing" [ + call [string "tar"; string "zxf"; current_name#get]; + ]; + make_case ~ext:"gpg" ~verb:"Decyphering" [ + call [string "gpg"; + string "--output"; + (remove_suffix current_name#get "\\.gpg"); + string "-d"; current_name#get;]; + ]; + default [ + fail [ + string "File: "; current_name#get; + string " didn't match any option???" ]; ]; - ); + ]; ] end ]) diff --git a/src/test/main.ml b/src/test/main.ml index 3ae84ae..74a2203 100644 --- a/src/test/main.ml +++ b/src/test/main.ml @@ -41,7 +41,7 @@ let tests = ] ); exits 20 Construct.( - switch ~default:(return 18) [ + make_switch ~default:(return 18) [ file_exists "/djlsjdseij", return 19; file_exists "/etc/passwd", return 20; file_exists "/djlsjdseij", return 21; From 5c8994c6a7cdeff876b2794be295ba4f4c6a3150 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Fri, 2 Dec 2016 18:51:37 -0500 Subject: [PATCH 12/27] Make `write_output` take `string t` arguments This fixes #16, the function `file_exists` gets the same treatment. --- src/lib/EDSL.mli | 12 ++++---- src/lib/language.ml | 70 ++++++++++++++++++++++++++++---------------- src/test/examples.ml | 10 +++---- src/test/main.ml | 30 +++++++++---------- 4 files changed, 71 insertions(+), 51 deletions(-) diff --git a/src/lib/EDSL.mli b/src/lib/EDSL.mli index 73adbc8..494a67d 100644 --- a/src/lib/EDSL.mli +++ b/src/lib/EDSL.mli @@ -40,7 +40,8 @@ val if_then : bool t -> unit t -> unit t val seq : unit t list -> unit t val not : bool t -> bool t val printf : ('a, unit, string, unit t) format4 -> 'a -val file_exists : string -> bool t + +val file_exists : string t -> bool t (** {3 Switch Statements } *) @@ -68,10 +69,11 @@ val make_switch : val write_output : - ?stdout:string -> - ?stderr:string -> - ?return_value:string -> unit t -> unit t -val write_stdout : path:string -> unit t -> unit t + ?stdout:string t -> + ?stderr:string t -> + ?return_value:string t -> unit t -> unit t + +val write_stdout : path: string t -> unit t -> unit t (** {3 Literals } *) diff --git a/src/lib/language.ml b/src/lib/language.ml index 33f2767..ee5d29b 100644 --- a/src/lib/language.ml +++ b/src/lib/language.ml @@ -59,9 +59,9 @@ and _ t = | Output_as_string: unit t -> string t | Write_output: { expr: unit t; - stdout: string option; - stderr: string option; - return_value: string option; + stdout: string t option; + stderr: string t option; + return_value: string t option; } -> unit t | Feed: string t * unit t -> unit t | While: {condition: bool t; body: unit t} -> unit t @@ -93,9 +93,6 @@ module Construct = struct let printf fmt = ksprintf (fun s -> exec ["printf"; "%s"; s]) fmt - let file_exists p = - exec ["test"; "-f"; p] |> succeeds - let fail = Fail let make_switch: type a. (bool t * unit t) list -> default: unit t -> unit t = @@ -113,6 +110,9 @@ module Construct = struct let int s = Literal.Int s |> literal let bool t = Literal.Bool t |> literal + let file_exists p = + call [string "test"; string "-f"; p] |> succeeds + let output_as_string e = Output_as_string e let feed ~string e = Feed (string, e) @@ -149,26 +149,32 @@ let rec to_shell: type a. _ -> a t -> string = sprintf {sh| printf "$(printf '%%s' %s | sed -e 's/\(.\{3\}\)/\\\1/g')" |sh} s in + let to_argument varname = + function + | Literal (Literal.String s) when Literal.String.easy_to_escape s -> + None, Filename.quote s + | Literal (Literal.String s) when + Literal.String.impossible_to_escape_for_variable s -> + ksprintf failwith "to_shell: sorry literal %S is impossible to \ + escape as `exec` argument" s + | v -> + let var = + sprintf "%s=$(%s; printf 'x')" + varname (continue v |> expand_octal) + in + Some var, sprintf "\"${%s%%?}\"" varname + in match e with | Exec l -> let variables = ref [] in let args = - List.mapi l ~f:(fun index -> function - | Literal (Literal.String s) when Literal.String.easy_to_escape s -> - Filename.quote s - | Literal (Literal.String s) when - Literal.String.impossible_to_escape_for_variable s -> - ksprintf failwith "to_shell: sorry literal %S is impossible to \ - escape as `exec` argument" s - | v -> - let var = - sprintf "argument_%d=$(%s; printf 'x') ; " - index (continue v |> expand_octal); - in - variables := var :: !variables; - sprintf "\"${argument_%d%%?}\"" index - ) - in + List.mapi l ~f:(fun index v -> + let varname = sprintf "argument_%d" index in + match to_argument varname v with + | None, v -> v + | Some vardef, v -> + variables := sprintf "%s ; " vardef :: !variables; + v) in (List.rev !variables) @ args |> String.concat ~sep:" " |> sprintf " { %s ; } " @@ -203,13 +209,25 @@ let rec to_shell: type a. _ -> a t -> string = | Not t -> sprintf "! { %s ; }" (continue t) | Write_output { expr; stdout; stderr; return_value } -> - sprintf " ( %s %s ) %s %s" + let make_argument name option = + Option.value_map ~default:(None, None) option ~f:(fun v -> + let v, e = to_argument name v in + v, Some e) in + let varstdout, exprstdout = make_argument "stdoutfile" stdout in + let varstderr, exprstderr = make_argument "stderrfile" stderr in + let varret, exprret = make_argument "retfile" return_value in + let vars = + List.filter_map [varstdout; varstderr; varret] + ~f:(Option.map ~f:(sprintf "export %s")) + |> String.concat ~sep:" ; " in + sprintf "%s ( %s %s ) %s %s" + vars (continue expr) - (Option.value_map return_value ~default:"" ~f:(fun path -> + (Option.value_map exprret ~default:"" ~f:(fun path -> sprintf "; echo \"$?\" > %s" path)) - (Option.value_map stdout ~default:"" ~f:(fun path -> + (Option.value_map exprstdout ~default:"" ~f:(fun path -> sprintf " > %s" path)) - (Option.value_map stderr ~default:"" ~f:(fun path -> + (Option.value_map exprstderr ~default:"" ~f:(fun path -> sprintf "2> %s" path)) | Literal lit -> Literal.to_shell lit diff --git a/src/test/examples.ml b/src/test/examples.ml index 26374b9..f0fe167 100644 --- a/src/test/examples.ml +++ b/src/test/examples.ml @@ -30,8 +30,8 @@ let downloader () = end in let silent ~name unit = object (self) - method stdout = "/tmp" // sprintf "output-of-%s-%s" name "-out" - method stderr = "/tmp" // sprintf "output-of-%s-%s" name "-err" + method stdout = "/tmp" // sprintf "output-of-%s-%s" name "-out" |> string + method stderr = "/tmp" // sprintf "output-of-%s-%s" name "-err" |> string method exec = seq [ (* sayf "Silent %s (%s, %s)" name self#stdout self#stderr; *) @@ -43,7 +43,7 @@ let downloader () = ~t:[sayf "%s: Success" name] ~e:[ sayf "Expression %s failed!" name; - exec ["cat"; self#stderr]; + call [string "cat"; self#stderr]; failf "Fatal failure of %s" name; ]) end in @@ -95,13 +95,13 @@ let downloader () = string_concat [string tmpdir; string "/"; filename] in let current_name = let path = tmpdir // "current-name" in - let tmp = path ^ "-tmp" in + let tmp = path ^ "-tmp" |> string in object method get = output_as_string (exec ["cat"; path]) method set v = seq [ v >> exec ["cat"] |> write_output ~stdout:tmp; - exec ["mv"; "-f"; tmp; path]; + call [string "mv"; string "-f"; tmp; string path]; ] end in let remove_suffix v suf = diff --git a/src/test/main.ml b/src/test/main.ml index 74a2203..d881061 100644 --- a/src/test/main.ml +++ b/src/test/main.ml @@ -26,7 +26,7 @@ let tests = ); exits 23 Construct.( seq [ - if_then_else (file_exists "/etc/passwd") + if_then_else (file_exists (string "/etc/passwd")) (exit 23) (exit 1); exit 2; @@ -34,7 +34,7 @@ let tests = ); exits 23 Construct.( seq [ - if_then_else (file_exists "/etc/passwd" |> not) + if_then_else (file_exists (string "/etc/passwd") |> not) (exit 1) (exit 23); exit 2; @@ -42,17 +42,17 @@ let tests = ); exits 20 Construct.( make_switch ~default:(return 18) [ - file_exists "/djlsjdseij", return 19; - file_exists "/etc/passwd", return 20; - file_exists "/djlsjdseij", return 21; + file_exists @@ string "/djlsjdseij", return 19; + file_exists @@ string "/etc/passwd", return 20; + file_exists @@ string "/djlsjdseij", return 21; ] ); exits 0 Construct.( - let path = "/tmp/bouh" in + let path = string "/tmp/bouh" in seq [ if_then (file_exists path) begin - exec ["rm"; "-f"; path] + call [string "rm"; string "-f"; path] end; write_stdout ~path (seq [ printf "bouh"; @@ -64,16 +64,16 @@ let tests = end; ]); exits 11 Construct.( - let stdout = "/tmp/p1_out" in - let stderr = "/tmp/p1_err" in - let return_value_path = "/tmp/p1_ret" in + let stdout = string "/tmp/p1_out" in + let stderr = string "/tmp/p1_err" in + let return_value_path = string "/tmp/p1_ret" in let return_value_value = 31 in let will_be_escaped = "newline:\n tab: \t \x42\b" in let will_not_be_escaped = "spaces, a;c -- ' - '' \\ ''' # '''' @ ${nope} & ` ~" in seq [ - exec ["rm"; "-f"; stdout; stderr; return_value_path]; + call [string "rm"; string "-f"; stdout; stderr; return_value_path]; write_output ~stdout ~stderr ~return_value:return_value_path (seq [ @@ -83,15 +83,15 @@ let tests = return return_value_value; ]); if_then_else ( - output_as_string (exec ["cat"; stdout]) + output_as_string (call [string "cat"; stdout]) =$= string (will_be_escaped ^ will_not_be_escaped) ) ( if_then_else - (output_as_string (exec ["cat"; stderr]) <$> string "err") + (output_as_string (call [string "cat"; stderr]) <$> string "err") ( if_then_else - (output_as_string (exec ["cat"; return_value_path]) + (output_as_string (call [string "cat"; return_value_path]) =$= ksprintf string "%d\n" return_value_value) (return 11) (return 22) @@ -198,7 +198,7 @@ let tests = exits 77 ~name:"cannot capture death itself" Construct.( seq [ write_output - ~return_value:"/tmp/dieretval" + ~return_value:(string "/tmp/dieretval") (seq [ printf "Going to die\n"; fail; From 34a09f44d9f452fc466270b61eff567ff1cfbe86 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Mon, 5 Dec 2016 12:46:52 -0500 Subject: [PATCH 13/27] =?UTF-8?q?Add=20=E2=80=9Coverride=20filename?= =?UTF-8?q?=E2=80=9D=20option=20to=20the=20example?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/test/examples.ml | 33 ++++++++++++++++++++++++--------- 1 file changed, 24 insertions(+), 9 deletions(-) diff --git a/src/test/examples.ml b/src/test/examples.ml index f0fe167..50cb1ff 100644 --- a/src/test/examples.ml +++ b/src/test/examples.ml @@ -84,15 +84,13 @@ let downloader () = ~doc:"The URL to the stuff" 'u' ~default:no_value & flag 'c' ~doc:"Do everything in the temp-dir" + & string 'f' + ~doc:"Override the downloaded file-name" + ~default:no_value & usage "$0 -u URL [-c]" ) - begin fun url all_in_tmp -> - let filename = - url >> exec ["sed"; "s:.*/\\([^\\?\\/]*\\)\\?.*:\\1:"] - |> output_as_string in + begin fun url all_in_tmp filename_ov -> let tmpdir = "/tmp/genspio-downloader" in - let output_of_download = - string_concat [string tmpdir; string "/"; filename] in let current_name = let path = tmpdir // "current-name" in let tmp = path ^ "-tmp" |> string in @@ -104,6 +102,23 @@ let downloader () = call [string "mv"; string "-f"; tmp; string path]; ] end in + let set_output_of_download () = + If.make (filename_ov =$= no_value) + ~t:begin + let filename = + url >> exec ["sed"; "s:.*/\\([^\\?\\/]*\\)\\?.*:\\1:"] + |> output_as_string + in + let output_path = + string_concat [string tmpdir; string "/"; filename] in + [current_name#set output_path] + end + ~e:begin + let output_path = + string_concat [string tmpdir; string "/"; filename_ov] in + [current_name#set output_path] + end + in let remove_suffix v suf = v >> exec ["sed"; sprintf "s:^\\(.*\\)%s$:\\1:" suf] |> output_as_string in @@ -116,9 +131,9 @@ let downloader () = if_then_else (string_matches_any url ["^http://"; "^https://"; "^ftp://"]) (seq [ - download ~url ~output:output_of_download; - say [string "Downloaded "; output_of_download]; - current_name#set output_of_download; + set_output_of_download (); + download ~url ~output:current_name#get; + say [string "Downloaded "; current_name#get]; loop_while (string_matches_any current_name#get [".gpg$"; ".tgz$"; ".tar$"; ".gz$"]) ~body:begin From d2478e9dfa655887e6c7e95bc8f1b0d773869b58 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Mon, 5 Dec 2016 13:01:42 -0500 Subject: [PATCH 14/27] Add function `EDSL.tmp_file` --- src/lib/EDSL.ml | 19 +++++++++++++++++++ src/lib/EDSL.mli | 10 ++++++++++ 2 files changed, 29 insertions(+) diff --git a/src/lib/EDSL.ml b/src/lib/EDSL.ml index 2e45aac..16daaeb 100644 --- a/src/lib/EDSL.ml +++ b/src/lib/EDSL.ml @@ -2,10 +2,12 @@ type 'a t = 'a Language.t type 'a cli_option = 'a Language.cli_option type 'a option_spec = 'a Language.option_spec type ('a, 'b) cli_options = ('a, 'b) Language.cli_options +let (//) = Filename.concat include Language.Construct open Nonstd +module String = Sosa.Native_string let case condition body = `Case (condition, seq body) let default d = `Default (seq d) @@ -21,3 +23,20 @@ let switch l = make_switch ~default:(Option.value ~default:nop !default) cases +let tmp_file ?(tmp_dir = "/tmp") name = + let path = + let clean = + String.map name ~f:(function + | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-' as c -> c + | other -> '_') in + tmp_dir + // sprintf "genspio-tmp-file-%s-%s" clean Digest.(string name |> to_hex) in + let tmp = path ^ "-tmp" |> string in + object + method get = output_as_string (exec ["cat"; path]) + method set v = + seq [ + v >> exec ["cat"] |> write_output ~stdout:tmp; + call [string "mv"; string "-f"; tmp; string path]; + ] + end diff --git a/src/lib/EDSL.mli b/src/lib/EDSL.mli index 494a67d..8c27e33 100644 --- a/src/lib/EDSL.mli +++ b/src/lib/EDSL.mli @@ -106,3 +106,13 @@ end val parse_command_line : ('a, unit t) cli_options -> 'a -> unit t + +val tmp_file: + ?tmp_dir:string -> + string -> + < + get : string Language.t; + set : string Language.t -> unit Language.t; + > +(** Create a temporary file that may contain arbitrary strings (can be + used as variable containing [string t] values). *) From b4fafb4859cd4fe6abb1bfc8930cb7c313e3c11e Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Mon, 5 Dec 2016 13:02:05 -0500 Subject: [PATCH 15/27] Use `EDSL.tmp_file` in the example --- src/test/examples.ml | 22 ++++++---------------- 1 file changed, 6 insertions(+), 16 deletions(-) diff --git a/src/test/examples.ml b/src/test/examples.ml index 50cb1ff..86da367 100644 --- a/src/test/examples.ml +++ b/src/test/examples.ml @@ -90,18 +90,8 @@ let downloader () = & usage "$0 -u URL [-c]" ) begin fun url all_in_tmp filename_ov -> - let tmpdir = "/tmp/genspio-downloader" in - let current_name = - let path = tmpdir // "current-name" in - let tmp = path ^ "-tmp" |> string in - object - method get = output_as_string (exec ["cat"; path]) - method set v = - seq [ - v >> exec ["cat"] |> write_output ~stdout:tmp; - call [string "mv"; string "-f"; tmp; string path]; - ] - end in + let tmp_dir = "/tmp/genspio-downloader" in + let current_name = tmp_file ~tmp_dir "current-name" in let set_output_of_download () = If.make (filename_ov =$= no_value) ~t:begin @@ -110,12 +100,12 @@ let downloader () = |> output_as_string in let output_path = - string_concat [string tmpdir; string "/"; filename] in + string_concat [string tmp_dir; string "/"; filename] in [current_name#set output_path] end ~e:begin let output_path = - string_concat [string tmpdir; string "/"; filename_ov] in + string_concat [string tmp_dir; string "/"; filename_ov] in [current_name#set output_path] end in @@ -123,9 +113,9 @@ let downloader () = v >> exec ["sed"; sprintf "s:^\\(.*\\)%s$:\\1:" suf] |> output_as_string in seq [ - exec ["mkdir"; "-p"; tmpdir]; + exec ["mkdir"; "-p"; tmp_dir]; if_then all_in_tmp - (seq [sayf "Going to the tmpdir"; call [string "cd"; string tmpdir]]); + (seq [sayf "Going to the tmpdir"; call [string "cd"; string tmp_dir]]); if_then (url =$= no_value) (failf "Argument URL is mandatory"); if_then_else From b14887fb5677310a481aba986de29cfe550e0d71 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Mon, 5 Dec 2016 21:39:53 -0500 Subject: [PATCH 16/27] Fix use of boolean representation in CLI parsing --- src/lib/language.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/lib/language.ml b/src/lib/language.ml index ee5d29b..f611bdd 100644 --- a/src/lib/language.ml +++ b/src/lib/language.ml @@ -252,7 +252,7 @@ let rec to_shell: type a. _ -> a t -> string = let string_of_var var = Output_as_string (Raw_cmd (sprintf "printf \"${%s}\"" var)) in let bool_of_var var = - Construct.succeeds (Raw_cmd (sprintf "[ \"${%s}\" -eq 0 ]" var)) in + Construct.succeeds (Raw_cmd (sprintf "{ ${%s} ; } " var)) in let unit_t = let rec loop : type a b. @@ -287,7 +287,7 @@ let rec to_shell: type a. _ -> a t -> string = to_case ( sprintf "-%c) %s ;;" x.switch (seq [ - sprintf "export %s=0" var; + sprintf "export %s=true" var; "shift"; ]) ); @@ -306,7 +306,7 @@ let rec to_shell: type a. _ -> a t -> string = [ "while :;"; " do case $1 in"; "-h|-help|--help) "; - sprintf "export %s_help=0 ; " prefix; + sprintf "export %s_help=true ; " prefix; sprintf "%s ;" (continue Construct.(string help_msg >> exec ["cat"])); @@ -332,7 +332,7 @@ let rec to_shell: type a. _ -> a t -> string = in seq ( sprintf "export %s_args=" prefix - :: sprintf "export %s_help=1" prefix + :: sprintf "export %s_help=false" prefix :: List.rev !inits @ [ while_loop; continue Construct.( From 1ebeb6e26fd00d23d6ad145f68076008b8e28ea1 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Tue, 6 Dec 2016 10:37:27 -0500 Subject: [PATCH 17/27] Fix compilation of `Write_output` This also adds a bunch test of various combinations of the optional arguments. --- src/lib/language.ml | 4 ++-- src/test/main.ml | 42 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 44 insertions(+), 2 deletions(-) diff --git a/src/lib/language.ml b/src/lib/language.ml index f611bdd..a36c98f 100644 --- a/src/lib/language.ml +++ b/src/lib/language.ml @@ -218,8 +218,8 @@ let rec to_shell: type a. _ -> a t -> string = let varret, exprret = make_argument "retfile" return_value in let vars = List.filter_map [varstdout; varstderr; varret] - ~f:(Option.map ~f:(sprintf "export %s")) - |> String.concat ~sep:" ; " in + ~f:(Option.map ~f:(sprintf "export %s ; ")) + |> String.concat ~sep:" " in sprintf "%s ( %s %s ) %s %s" vars (continue expr) diff --git a/src/test/main.ml b/src/test/main.ml index d881061..0d17ab4 100644 --- a/src/test/main.ml +++ b/src/test/main.ml @@ -63,6 +63,48 @@ let tests = exit 1 end; ]); + exits 42 Construct.( + (* Many variation on `write_output` *) + let stdout = string "/tmp/p1_out" in + let stderr = string "/tmp/p1_err" in + let return_value = string "/tmp/p1_ret" in + seq [ + write_output + ~stdout ~stderr ~return_value + (seq [ + printf "%s" "hello"; + exec ["sh"; "-c"; "printf \"olleh\" 1>&2"]; + return 12; + ]); + write_output + ~stderr ~return_value + (seq [ + printf "%s" "hello"; + exec ["sh"; "-c"; "printf \"olleh\" 1>&2"]; + return 12; + ]); + write_output + ~return_value + (seq [ + printf "%s" "hello"; + exec ["sh"; "-c"; "printf \"olleh\" 1>&2"]; + return 12; + ]); + write_output ~stdout + (seq [ + printf "%s" "hello"; + exec ["sh"; "-c"; "printf \"olleh\" 1>&2"]; + return 12; + ]); + write_output + (seq [ + printf "%s" "hello"; + exec ["sh"; "-c"; "printf \"olleh\" 1>&2"]; + return 12; + ]); + return 42; + ] + ); exits 11 Construct.( let stdout = string "/tmp/p1_out" in let stderr = string "/tmp/p1_err" in From 7a11b36b8c3d84229c4091f4f45714b6945437db Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Tue, 6 Dec 2016 10:38:41 -0500 Subject: [PATCH 18/27] Add `EDSL.string_concat` improve `EDSL.tmp_file` Now the tmp-directory can be a `string t` --- src/lib/EDSL.ml | 23 +++++++++++++++++------ src/lib/EDSL.mli | 4 +++- src/test/examples.ml | 25 ++++++++++++------------- 3 files changed, 32 insertions(+), 20 deletions(-) diff --git a/src/lib/EDSL.ml b/src/lib/EDSL.ml index 16daaeb..beacdd4 100644 --- a/src/lib/EDSL.ml +++ b/src/lib/EDSL.ml @@ -22,21 +22,32 @@ let switch l = in make_switch ~default:(Option.value ~default:nop !default) cases +let string_concat sl = + (* This is a pretty unefficient implementation: *) + let out s = call [string "printf"; string "%s"; s] in + seq (List.map sl ~f:out) |> output_as_string -let tmp_file ?(tmp_dir = "/tmp") name = +let tmp_file ?(tmp_dir = string "/tmp") name = let path = let clean = String.map name ~f:(function | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-' as c -> c | other -> '_') in - tmp_dir - // sprintf "genspio-tmp-file-%s-%s" clean Digest.(string name |> to_hex) in - let tmp = path ^ "-tmp" |> string in + string_concat [ + tmp_dir; + string "/"; + string + (sprintf "genspio-tmp-file-%s-%s" clean Digest.(string name |> to_hex)); + ] + in + let tmp = string_concat [path; string "-tmp"] in object - method get = output_as_string (exec ["cat"; path]) + method get = output_as_string (call [string "cat"; path]) method set v = seq [ + call [string "echo"; string "Setting"]; + call [string "echo"; tmp]; v >> exec ["cat"] |> write_output ~stdout:tmp; - call [string "mv"; string "-f"; tmp; string path]; + call [string "mv"; string "-f"; tmp; path]; ] end diff --git a/src/lib/EDSL.mli b/src/lib/EDSL.mli index 8c27e33..b4df03f 100644 --- a/src/lib/EDSL.mli +++ b/src/lib/EDSL.mli @@ -107,8 +107,10 @@ end val parse_command_line : ('a, unit t) cli_options -> 'a -> unit t +val string_concat: string t list -> string t + val tmp_file: - ?tmp_dir:string -> + ?tmp_dir: string t -> string -> < get : string Language.t; diff --git a/src/test/examples.ml b/src/test/examples.ml index 86da367..87cbcc5 100644 --- a/src/test/examples.ml +++ b/src/test/examples.ml @@ -30,11 +30,11 @@ let downloader () = end in let silent ~name unit = object (self) - method stdout = "/tmp" // sprintf "output-of-%s-%s" name "-out" |> string - method stderr = "/tmp" // sprintf "output-of-%s-%s" name "-err" |> string + method stdout = "/tmp" // sprintf "output-of-%s-%s" name "out" |> string + method stderr = "/tmp" // sprintf "output-of-%s-%s" name "err" |> string method exec = seq [ - (* sayf "Silent %s (%s, %s)" name self#stdout self#stderr; *) + (* say [string "Silent "; string name; self#stdout; self#stderr;]; *) write_output (seq unit) ~stdout:self#stdout ~stderr:self#stderr; ] method succeed_or_fail = @@ -74,9 +74,6 @@ let downloader () = (* Cf. http://pubs.opengroup.org/onlinepubs/009695399/utilities/grep.html *) let options = List.concat_map regexp_list ~f:(fun r -> ["-e"; r]) in string >> exec (["grep"; "-q"] @ options) |> succeeds in - let string_concat sl = - let out s = call [string "printf"; string "%s"; s] in - seq (List.map sl ~f:out) |> output_as_string in let no_value = sprintf "none_%x" (Random.int 100_000) |> string in parse_command_line Option_list.( @@ -87,10 +84,12 @@ let downloader () = & string 'f' ~doc:"Override the downloaded file-name" ~default:no_value + & string 't' + ~doc:"Use as temp-dir" + ~default:(Genspio.EDSL.string "/tmp/genspio-downloader-tmpdir") & usage "$0 -u URL [-c]" ) - begin fun url all_in_tmp filename_ov -> - let tmp_dir = "/tmp/genspio-downloader" in + begin fun url all_in_tmp filename_ov tmp_dir -> let current_name = tmp_file ~tmp_dir "current-name" in let set_output_of_download () = If.make (filename_ov =$= no_value) @@ -100,12 +99,12 @@ let downloader () = |> output_as_string in let output_path = - string_concat [string tmp_dir; string "/"; filename] in + string_concat [tmp_dir; string "/"; filename] in [current_name#set output_path] end ~e:begin let output_path = - string_concat [string tmp_dir; string "/"; filename_ov] in + string_concat [tmp_dir; string "/"; filename_ov] in [current_name#set output_path] end in @@ -113,9 +112,9 @@ let downloader () = v >> exec ["sed"; sprintf "s:^\\(.*\\)%s$:\\1:" suf] |> output_as_string in seq [ - exec ["mkdir"; "-p"; tmp_dir]; + call [string "mkdir"; string "-p"; tmp_dir]; if_then all_in_tmp - (seq [sayf "Going to the tmpdir"; call [string "cd"; string tmp_dir]]); + (seq [sayf "Going to the tmpdir"; call [string "cd"; tmp_dir]]); if_then (url =$= no_value) (failf "Argument URL is mandatory"); if_then_else @@ -140,7 +139,7 @@ let downloader () = say [string "Extract loop: "; current_name#get]; switch [ make_case ~ext:"gz" ~verb:"Gunzipping" [ - call [string "gunzip"; current_name#get]; + call [string "gunzip"; string "-f"; current_name#get]; ]; make_case ~ext:"tar" ~verb:"Untarring" [ call [string "tar"; string "xf"; current_name#get]; From b8296c715ed2ffb42e99abf812933d237cd3a557 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Mon, 12 Dec 2016 17:13:01 -0500 Subject: [PATCH 19/27] Fix regular expressions in example --- src/test/examples.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/test/examples.ml b/src/test/examples.ml index 87cbcc5..83c80dd 100644 --- a/src/test/examples.ml +++ b/src/test/examples.ml @@ -123,12 +123,13 @@ let downloader () = set_output_of_download (); download ~url ~output:current_name#get; say [string "Downloaded "; current_name#get]; - loop_while - (string_matches_any current_name#get [".gpg$"; ".tgz$"; ".tar$"; ".gz$"]) + loop_while + (string_matches_any current_name#get + ["\\.gpg$"; "\\.tgz$"; "\\.tar$"; "\\.gz$"]) ~body:begin let make_case ~ext ~verb commands = case (string_matches_any - current_name#get [sprintf ".%s$" ext]) [ + current_name#get [sprintf "\\.%s$" ext]) [ say [ksprintf string "%s: " verb; current_name#get]; succeed_in_silence_or_fail ~name:(sprintf "%s-%s" verb ext) commands; From 20e402e9157c6cfe31a84a6f07d3dd48213d7b14 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Mon, 12 Dec 2016 17:35:13 -0500 Subject: [PATCH 20/27] Add function `EDSL.if_seq` --- src/lib/EDSL.ml | 5 +++++ src/lib/EDSL.mli | 10 ++++++++++ 2 files changed, 15 insertions(+) diff --git a/src/lib/EDSL.ml b/src/lib/EDSL.ml index beacdd4..01b6ee5 100644 --- a/src/lib/EDSL.ml +++ b/src/lib/EDSL.ml @@ -51,3 +51,8 @@ let tmp_file ?(tmp_dir = string "/tmp") name = call [string "mv"; string "-f"; tmp; path]; ] end + +let if_seq ~t ?e c = + match e with + | None -> if_then c (seq t) + | Some f -> if_then_else c (seq t) (seq f) diff --git a/src/lib/EDSL.mli b/src/lib/EDSL.mli index b4df03f..badd1db 100644 --- a/src/lib/EDSL.mli +++ b/src/lib/EDSL.mli @@ -37,6 +37,16 @@ val nop : unit t val if_then_else : bool t -> unit t -> unit t -> unit t val if_then : bool t -> unit t -> unit t + +val if_seq: + t:unit t list -> + ?e:unit t list -> + bool t -> + unit t +(** [condition c ~t ~e] is an alternate API for {!if_then_else} (when + [?e] is provided) or {!if_then} (otherwise) that assumes “then” + and “else” bodies to be lists for {!seq} construct. *) + val seq : unit t list -> unit t val not : bool t -> bool t val printf : ('a, unit, string, unit t) format4 -> 'a From 3790144656221e55933bd16f72f285a8654dfd7e Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Mon, 12 Dec 2016 17:35:25 -0500 Subject: [PATCH 21/27] Use `EDSL.if_seq` in `examples.ml` --- src/test/examples.ml | 23 ++++++++--------------- 1 file changed, 8 insertions(+), 15 deletions(-) diff --git a/src/test/examples.ml b/src/test/examples.ml index 83c80dd..9ba6fec 100644 --- a/src/test/examples.ml +++ b/src/test/examples.ml @@ -22,12 +22,6 @@ let downloader () = let fail l = seq [say (string "ERROR: " :: l); fail] in let failf fmt = ksprintf (fun s -> fail [string s]) fmt in let (//) = Filename.concat in - let module If = struct - let make ~t ?e c = - match e with - | None -> if_then c (seq t) - | Some f -> if_then_else c (seq t) (seq f) - end in let silent ~name unit = object (self) method stdout = "/tmp" // sprintf "output-of-%s-%s" name "out" |> string @@ -38,14 +32,13 @@ let downloader () = write_output (seq unit) ~stdout:self#stdout ~stderr:self#stderr; ] method succeed_or_fail = - If.(make - (self#exec|> succeeds) - ~t:[sayf "%s: Success" name] - ~e:[ - sayf "Expression %s failed!" name; - call [string "cat"; self#stderr]; - failf "Fatal failure of %s" name; - ]) + if_seq (self#exec|> succeeds) + ~t:[sayf "%s: Success" name] + ~e:[ + sayf "Expression %s failed!" name; + call [string "cat"; self#stderr]; + failf "Fatal failure of %s" name; + ] end in let silence ~name unit = let s = silent ~name [unit] in @@ -92,7 +85,7 @@ let downloader () = begin fun url all_in_tmp filename_ov tmp_dir -> let current_name = tmp_file ~tmp_dir "current-name" in let set_output_of_download () = - If.make (filename_ov =$= no_value) + if_seq (filename_ov =$= no_value) ~t:begin let filename = url >> exec ["sed"; "s:.*/\\([^\\?\\/]*\\)\\?.*:\\1:"] From d1852a74370a92e629078d49c6be4417d6f674e4 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Mon, 12 Dec 2016 18:07:24 -0500 Subject: [PATCH 22/27] Name output type of `EDSL.tmp_file` --- src/lib/EDSL.ml | 6 +++++- src/lib/EDSL.mli | 9 +++++---- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/src/lib/EDSL.ml b/src/lib/EDSL.ml index 01b6ee5..3dddfde 100644 --- a/src/lib/EDSL.ml +++ b/src/lib/EDSL.ml @@ -27,7 +27,11 @@ let string_concat sl = let out s = call [string "printf"; string "%s"; s] in seq (List.map sl ~f:out) |> output_as_string -let tmp_file ?(tmp_dir = string "/tmp") name = +type string_variable = < + get : string Language.t; + set : string Language.t -> unit Language.t; + > +let tmp_file ?(tmp_dir = string "/tmp") name : string_variable = let path = let clean = String.map name ~f:(function diff --git a/src/lib/EDSL.mli b/src/lib/EDSL.mli index badd1db..89abc49 100644 --- a/src/lib/EDSL.mli +++ b/src/lib/EDSL.mli @@ -119,12 +119,13 @@ val parse_command_line : val string_concat: string t list -> string t -val tmp_file: - ?tmp_dir: string t -> - string -> - < +type string_variable = < get : string Language.t; set : string Language.t -> unit Language.t; > +val tmp_file: + ?tmp_dir: string t -> + string -> + string_variable (** Create a temporary file that may contain arbitrary strings (can be used as variable containing [string t] values). *) From 20707a6e2ae07555518e58664045fff131f9cfda Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Mon, 12 Dec 2016 18:23:16 -0500 Subject: [PATCH 23/27] Add support for `zip`, `bz2`, and `tbz2` files MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit In the downloader example, we have a better a organized code generator and it can “unwrap” with `unzip`, `bunzip2`, and `tar xfj`. Tested with two funny files: `test.tar.gz.zip.bz2.tbz2` and `test.tar.gz.zip.bz2.tbz2.gpg`. --- src/test/examples.ml | 109 ++++++++++++++++++++++++++----------------- 1 file changed, 66 insertions(+), 43 deletions(-) diff --git a/src/test/examples.ml b/src/test/examples.ml index 9ba6fec..cad2d53 100644 --- a/src/test/examples.ml +++ b/src/test/examples.ml @@ -67,6 +67,71 @@ let downloader () = (* Cf. http://pubs.opengroup.org/onlinepubs/009695399/utilities/grep.html *) let options = List.concat_map regexp_list ~f:(fun r -> ["-e"; r]) in string >> exec (["grep"; "-q"] @ options) |> succeeds in + + let module Unwrapper = struct + + type cmd = unit t + type t = { + extension: string; + verb: string; + commands: string_variable -> cmd list; + } + let make ~ext ~verb commands = + {extension = ext; verb; commands} + + let remove_suffix v suf = + v >> exec ["sed"; sprintf "s:^\\(.*\\)%s$:\\1:" suf] + |> output_as_string + + let to_switch name_variable t_list = + let make_case t = + case (string_matches_any + name_variable#get [sprintf "\\.%s$" t.extension]) [ + say [ksprintf string "%s: " t.verb; name_variable#get]; + succeed_in_silence_or_fail + ~name:(sprintf "%s-%s" t.verb t.extension) + (t.commands name_variable); + name_variable#set + (remove_suffix name_variable#get (sprintf "\\.%s" t.extension)); + ] in + seq [ + say [string "Extract loop: "; name_variable#get]; + switch (List.map t_list ~f:make_case) + ] + + let to_loop name_variable t_list = + loop_while + (string_matches_any name_variable#get + (List.map t_list (fun t -> sprintf "\\.%s$" t.extension))) + ~body:(to_switch name_variable t_list) + + let all = [ + make ~ext:"gz" ~verb:"Gunzipping" (fun current_name -> [ + call [string "gunzip"; string "-f"; current_name#get]; + ]); + make ~ext:"bz2" ~verb:"Bunzip2-ing" (fun current_name -> [ + call [string "bunzip2"; string "-f"; current_name#get]; + ]); + make ~ext:"zip" ~verb:"Unzipping" (fun current_name -> [ + call [string "unzip"; current_name#get]; + ]); + make ~ext:"tar" ~verb:"Untarring" (fun current_name -> [ + call [string "tar"; string "xf"; current_name#get]; + ]); + make ~ext:"tgz" ~verb:"Untar-gzip-ing" (fun name -> [ + call [string "tar"; string "zxf"; name#get]; + ]); + make ~ext:"tbz2" ~verb:"Untar-bzip2-ing" (fun name -> [ + call [string "tar"; string "xfj"; name#get]; + ]); + make ~ext:"gpg" ~verb:"Decyphering" (fun name -> [ + call [string "gpg"; + string "--output"; + (remove_suffix name#get "\\.gpg"); + string "-d"; name#get;]; + ]); + ] + end in let no_value = sprintf "none_%x" (Random.int 100_000) |> string in parse_command_line Option_list.( @@ -101,9 +166,6 @@ let downloader () = [current_name#set output_path] end in - let remove_suffix v suf = - v >> exec ["sed"; sprintf "s:^\\(.*\\)%s$:\\1:" suf] - |> output_as_string in seq [ call [string "mkdir"; string "-p"; tmp_dir]; if_then all_in_tmp @@ -116,46 +178,7 @@ let downloader () = set_output_of_download (); download ~url ~output:current_name#get; say [string "Downloaded "; current_name#get]; - loop_while - (string_matches_any current_name#get - ["\\.gpg$"; "\\.tgz$"; "\\.tar$"; "\\.gz$"]) - ~body:begin - let make_case ~ext ~verb commands = - case (string_matches_any - current_name#get [sprintf "\\.%s$" ext]) [ - say [ksprintf string "%s: " verb; current_name#get]; - succeed_in_silence_or_fail - ~name:(sprintf "%s-%s" verb ext) commands; - current_name#set - (remove_suffix current_name#get (sprintf "\\.%s" ext)); - ] in - seq [ - say [string "Extract loop: "; current_name#get]; - switch [ - make_case ~ext:"gz" ~verb:"Gunzipping" [ - call [string "gunzip"; string "-f"; current_name#get]; - ]; - make_case ~ext:"tar" ~verb:"Untarring" [ - call [string "tar"; string "xf"; current_name#get]; - ]; - make_case ~ext:"tgz" ~verb:"Untar-gzip-ing" [ - call [string "tar"; string "zxf"; current_name#get]; - ]; - make_case ~ext:"gpg" ~verb:"Decyphering" [ - call [string "gpg"; - string "--output"; - (remove_suffix current_name#get "\\.gpg"); - string "-d"; current_name#get;]; - ]; - default [ - fail [ - string "File: "; current_name#get; - string " didn't match any option???" - ]; - ]; - ]; - ] - end + Unwrapper.to_loop current_name Unwrapper.all ]) (seq [ fail [ From d4961b1822122917111322a23e45cc576f28d682 Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Tue, 13 Dec 2016 10:40:45 -0500 Subject: [PATCH 24/27] Fix Travis build (for `solvuu-build` 0.2.0) Solvuu-build does not create symbolic-links anymore so we call directly into `_build/`. --- tools/travis_ci_test.sh | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/tools/travis_ci_test.sh b/tools/travis_ci_test.sh index 3a9bb46..dabbe50 100644 --- a/tools/travis_ci_test.sh +++ b/tools/travis_ci_test.sh @@ -66,4 +66,9 @@ export WITH_TESTS=true make byte make native -./genspio-test.byte +gennspio_test=_build/src/test/genspio-test.byte +genspio_examples=_build/src/test/genspio-examples.byte + +$genspio_test + +$genspio_examples dl - From 0e92a9573e5b6400b280b6efe313931cf4594ddb Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Fri, 16 Dec 2016 15:56:36 -0500 Subject: [PATCH 25/27] Remove the construct `EDSL.printf` --- src/lib/EDSL.mli | 1 - src/lib/language.ml | 3 --- src/test/main.ml | 4 ++-- 3 files changed, 2 insertions(+), 6 deletions(-) diff --git a/src/lib/EDSL.mli b/src/lib/EDSL.mli index 89abc49..af4beff 100644 --- a/src/lib/EDSL.mli +++ b/src/lib/EDSL.mli @@ -49,7 +49,6 @@ val if_seq: val seq : unit t list -> unit t val not : bool t -> bool t -val printf : ('a, unit, string, unit t) format4 -> 'a val file_exists : string t -> bool t diff --git a/src/lib/language.ml b/src/lib/language.ml index a36c98f..b3b47ff 100644 --- a/src/lib/language.ml +++ b/src/lib/language.ml @@ -90,9 +90,6 @@ module Construct = struct let not t = Not t - let printf fmt = - ksprintf (fun s -> exec ["printf"; "%s"; s]) fmt - let fail = Fail let make_switch: type a. (bool t * unit t) list -> default: unit t -> unit t = diff --git a/src/test/main.ml b/src/test/main.ml index 0d17ab4..e66c403 100644 --- a/src/test/main.ml +++ b/src/test/main.ml @@ -15,8 +15,8 @@ let exits ?name ?args n c = [ let tests = let exit n = Construct.exec ["exit"; Int.to_string n] in - let return n = - Construct.exec ["sh"; "-c"; sprintf "exit %d" n] in + let return n = Construct.exec ["sh"; "-c"; sprintf "exit %d" n] in + let printf fmt = ksprintf (fun s -> Construct.exec ["printf"; "%s"; s]) fmt in List.concat [ exits 0 Construct.( succeeds (exec ["ls"]) From 728ea4f044e906681f838c7d481af4fd8d1e3b3f Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Mon, 19 Dec 2016 15:09:32 -0500 Subject: [PATCH 26/27] Fix documentation and oredering in `EDSL.mli` Cf. comments in PR #11. --- src/lib/EDSL.mli | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/lib/EDSL.mli b/src/lib/EDSL.mli index af4beff..3f199f9 100644 --- a/src/lib/EDSL.mli +++ b/src/lib/EDSL.mli @@ -38,16 +38,18 @@ val if_then_else : bool t -> unit t -> unit t -> unit t val if_then : bool t -> unit t -> unit t +val seq : unit t list -> unit t +(** Sequence a list of expressions into an expression. *) + val if_seq: t:unit t list -> ?e:unit t list -> bool t -> unit t -(** [condition c ~t ~e] is an alternate API for {!if_then_else} (when +(** [if_seq c ~t ~e] is an alternate API for {!if_then_else} (when [?e] is provided) or {!if_then} (otherwise) that assumes “then” and “else” bodies to be lists for {!seq} construct. *) -val seq : unit t list -> unit t val not : bool t -> bool t val file_exists : string t -> bool t From 38a5e58b6caeec8562cd5a28e6f6c476173f51ff Mon Sep 17 00:00:00 2001 From: Sebastien Mondet Date: Mon, 19 Dec 2016 15:16:26 -0500 Subject: [PATCH 27/27] Make CLI-parsing types more readable Cf. comments in #11. Also, the change in `examples.ml` allows people exploring the example to easily just get the interesting type from Merlin: ```ocaml (string Genspio.EDSL.t -> bool Genspio.EDSL.t -> string Genspio.EDSL.t -> string Genspio.EDSL.t -> unit Genspio.EDSL.t, unit Genspio.EDSL.t) Genspio.EDSL.cli_options ``` --- src/lib/EDSL.mli | 15 ++++++++------- src/test/examples.ml | 5 +++-- 2 files changed, 11 insertions(+), 9 deletions(-) diff --git a/src/lib/EDSL.mli b/src/lib/EDSL.mli index 3f199f9..b432c8c 100644 --- a/src/lib/EDSL.mli +++ b/src/lib/EDSL.mli @@ -97,9 +97,9 @@ val feed : string:string t -> unit t -> unit t val ( >> ) : string t -> unit t -> unit t val loop_while : bool t -> body:unit t -> unit t -type 'a cli_option = 'a Language.cli_option -type 'a option_spec = 'a Language.option_spec -type ('a, 'b) cli_options = ('a, 'b) Language.cli_options +type 'argument_type cli_option = 'argument_type Language.cli_option +type 'argument_type option_spec = 'argument_type Language.option_spec +type ('parse_function, 'return_type) cli_options = ('parse_function, 'return_type) Language.cli_options module Option_list : sig val string : ?default: string t -> @@ -110,13 +110,14 @@ module Option_list : sig doc:string -> char -> bool t option_spec val ( & ) : - 'a option_spec -> - ('b, 'c) cli_options -> ('a -> 'b, 'c) cli_options - val usage : string -> ('a, 'a) cli_options + 'argument_type option_spec -> + ('parse_function, 'return_type) cli_options -> + ('argument_type -> 'parse_function, 'return_type) cli_options + val usage : string -> ('last_return_type, 'last_return_type) cli_options end val parse_command_line : - ('a, unit t) cli_options -> 'a -> unit t + ('parse_function, unit t) cli_options -> 'parse_function -> unit t val string_concat: string t list -> string t diff --git a/src/test/examples.ml b/src/test/examples.ml index cad2d53..4cc38ab 100644 --- a/src/test/examples.ml +++ b/src/test/examples.ml @@ -133,7 +133,7 @@ let downloader () = ] end in let no_value = sprintf "none_%x" (Random.int 100_000) |> string in - parse_command_line + let cli_spec = Option_list.( string ~doc:"The URL to the stuff" 'u' @@ -146,7 +146,8 @@ let downloader () = ~doc:"Use as temp-dir" ~default:(Genspio.EDSL.string "/tmp/genspio-downloader-tmpdir") & usage "$0 -u URL [-c]" - ) + ) in + parse_command_line cli_spec begin fun url all_in_tmp filename_ov tmp_dir -> let current_name = tmp_file ~tmp_dir "current-name" in let set_output_of_download () =