├── .ocamlformat ├── dune-project ├── src ├── test-lib │ ├── dune │ └── test_lib.ml ├── test │ └── dune ├── lib │ ├── dune │ ├── common.ml │ ├── transform.mli │ ├── compile.ml │ ├── compile.mli │ ├── language.ml │ ├── EDSL_v0.ml │ ├── transform.ml │ ├── standard_compiler.ml │ ├── EDSL_v0.mli │ └── EDSL.ml └── examples │ ├── dune │ ├── downloader.ml │ ├── small.ml │ └── vm_tester.ml ├── .gitignore ├── genspio.opam ├── .github └── workflows │ └── main.yml ├── doc ├── exec-return-issue.md └── extra-testing.md ├── tools ├── env-var-tst.sh ├── multigit-test.sh ├── ci_test.sh └── build-doc.sh ├── README.md └── LICENSE /.ocamlformat: -------------------------------------------------------------------------------- 1 | version=0.19.0 2 | profile=compact 3 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.8) 2 | (name genspio) 3 | -------------------------------------------------------------------------------- /src/test-lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name tests) 3 | (libraries genspio uri base fmt)) 4 | -------------------------------------------------------------------------------- /src/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries genspio tests base fmt)) 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /_build/ 2 | /.merlin 3 | /.ocamlinit 4 | genspio.install 5 | src/examples/.merlin 6 | src/examples/jbuild 7 | src/lib/.merlin 8 | src/lib/jbuild 9 | src/test-lib/.merlin 10 | src/test-lib/jbuild 11 | src/test/.merlin 12 | src/test/jbuild -------------------------------------------------------------------------------- /src/lib/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (targets meta.ml) 3 | (action 4 | (progn 5 | (write-file 6 | "meta.ml" 7 | "(** Metadata Module Generated by the Build System *)\n\nlet version = \"0.0.3\"")))) 8 | 9 | (library 10 | (name genspio) 11 | (public_name genspio) 12 | (libraries base fmt)) 13 | -------------------------------------------------------------------------------- /src/lib/common.ml: -------------------------------------------------------------------------------- 1 | include Base 2 | 3 | module Unique_name = struct 4 | let x = ref 0 5 | 6 | let create prefix = 7 | Caml.incr x ; 8 | Fmt.str "%s_%d_%d" prefix !x (Random.int 100_000) 9 | 10 | let variable = create 11 | end 12 | 13 | let with_buffer ?(size = 42) f = 14 | let b = Buffer.create size in 15 | let str = Buffer.add_string b in 16 | let res = f str in 17 | (Buffer.contents b, res) 18 | -------------------------------------------------------------------------------- /src/examples/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name downloader) 3 | (libraries genspio base fmt) 4 | (modules downloader)) 5 | 6 | (executable 7 | (name vm_tester) 8 | (libraries genspio base fmt) 9 | (modules vm_tester)) 10 | 11 | (executable 12 | (name service_composer) 13 | (libraries unix genspio base fmt) 14 | (modules service_composer)) 15 | 16 | (executable 17 | (name multigit) 18 | (libraries unix genspio base fmt) 19 | (modules multigit)) 20 | 21 | (executable 22 | (name small) 23 | (libraries genspio base fmt) 24 | (modules small)) 25 | 26 | (rule 27 | (targets small_examples.ml) 28 | (deps small.exe) 29 | (action 30 | (progn 31 | (run ./small.exe small_examples.ml)))) 32 | 33 | (executable 34 | (name small_examples) 35 | (libraries genspio tests base fmt) 36 | (modules small_examples)) 37 | -------------------------------------------------------------------------------- /genspio.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Seb Mondet " 3 | authors: [ 4 | "Seb Mondet " 5 | ] 6 | homepage: "https://github.com/hammerlab/genspio/" 7 | bug-reports: "https://github.com/hammerlab/genspio/issues" 8 | dev-repo: "git+https://github.com/hammerlab/genspio.git" 9 | license: "Apache 2.0" 10 | version: "0.0.3" 11 | build: [ 12 | ["dune" "build" "-p" name "-j" jobs ] 13 | ] 14 | depends: [ 15 | "ocaml" { >= "4.03.0" } 16 | "dune" 17 | "base" 18 | "fmt" 19 | ] 20 | synopsis: "Typed EDSL to generate POSIX Shell scripts" 21 | description: """ 22 | Genspio is a typed EDSL used to generate shell scripts and commands from OCaml. 23 | 24 | The idea is to build values of type `'a Genspio.EDSL.t` with the 25 | combinators in the `Genspio.EDSL` module, and compile them to POSIX 26 | shell scripts (or one-liners) with functions from `Genspio.Compile`. 27 | 28 | Genspio's documentation root is at . 29 | """ 30 | -------------------------------------------------------------------------------- /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: build 2 | on: [push, pull_request] 3 | jobs: 4 | run: 5 | name: Build 6 | runs-on: ${{ matrix.operating-system }} 7 | strategy: 8 | matrix: 9 | #operating-system: [ubuntu-latest] 10 | operating-system: [macos-latest, ubuntu-latest] #, windows-latest] 11 | #ocaml-compiler: [ '4.09.1' , '4.10.1', '4.11.1', '4.12.1', '4.13.0' ] 12 | ocaml-compiler: [ '4.09.1' , '4.13.0' ] 13 | steps: 14 | - uses: actions/checkout@v2 15 | - name: Set up OCaml ${{ matrix.ocaml-compiler }} 16 | uses: ocaml/setup-ocaml@v2 17 | with: 18 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 19 | - run: opam install . --deps-only 20 | # Dependencies for the examples/tests: 21 | - run: opam install uri ocamlformat 22 | - run: opam exec -- dune build @check 23 | - if: ${{ matrix.ocaml-compiler == '4.13.0' }} 24 | run: opam exec -- dune build @fmt 25 | - if: ${{ matrix.ocaml-compiler == '4.13.0' && matrix.operating-system == 'ubuntu-latest' }} 26 | run: opam exec -- bash ./tools/ci_test.sh 27 | 28 | 29 | -------------------------------------------------------------------------------- /doc/exec-return-issue.md: -------------------------------------------------------------------------------- 1 | Implementation Notes 2 | ==================== 3 | 4 | 5 | The `exec` Schism 6 | ----------------- 7 | 8 | Specification 9 | of 10 | [`exec`](http://pubs.opengroup.org/onlinepubs/009695399/utilities/exec.html). 11 | 12 | > If command is specified, exec shall not return to the shell; rather, the exit 13 | > status of the process shall be the exit status of the program implementing 14 | > command, which overlaid the shell. If command is not found, the exit status 15 | > shall be 127. If command is found, but it is not an executable utility, the 16 | > exit status shall be 126. **If a redirection error occurs (see 17 | > [Consequences of Shell Errors](http://pubs.opengroup.org/onlinepubs/009695399/utilities/xcu_chap02.html#tag_02_08_01)), 18 | > the shell shall exit with a value in the range > 1-125**. 19 | > Otherwise, exec shall return a zero exit status. 20 | 21 | 22 | For a given `shell`, trying: 23 | 24 | $shell -c ' exec 4>&3 ; echo "Exec-returns: $?"' ; echo "Shell-returns: $?" 25 | 26 | The POSIX ones: 27 | 28 | * `shell=dash`, `shell=sh`, `shell='busbox ash'`: `Shell-returns: 2` 29 | * `shell=ksh`, `shell=mksh`: `Shell-returns: 1` 30 | 31 | The non-POSIX ones: 32 | 33 | * `shell=bash`, `shell=zsh`: 34 | `Exec-returns: 1 Shell-returns: 0` 35 | -------------------------------------------------------------------------------- /tools/env-var-tst.sh: -------------------------------------------------------------------------------- 1 | 2 | showmd () { 3 | echo "File: $1" 4 | echo '````' 5 | head -n $2 "$1" 6 | echo "...." 7 | tail -n $2 "$1" 8 | echo '````' 9 | } 10 | 11 | env_var_test_script=/tmp/env-var-run-test.sh 12 | echo "Preparing $env_var_test_script" 13 | printf "set -e\n" > $env_var_test_script 14 | for i in $(seq 100 1000) ; do 15 | printf "export test_$i=\"" >> $env_var_test_script 16 | for j in $(seq 1 $i) ; do 17 | printf "S" >> $env_var_test_script 18 | done 19 | printf "\"" >> $env_var_test_script 20 | printf "\nprintf \"\${test_$i}\" > /tmp/evt-res-$i.txt" >> $env_var_test_script 21 | printf "\nexport res1_$i=\"\$(wc -c /tmp/evt-res-$i.txt)\"" >> $env_var_test_script 22 | printf "\nexport res2_$i=\"\$(printf \"\${test_$i}\" | wc -c)\"" >> $env_var_test_script 23 | printf "\nexport res3_$i=\"\$(env | wc -c)\"" >> $env_var_test_script 24 | printf "\necho \"Done with $i: \$res1_$i - \$res2_$i chars ... env \$res3_$i\"\n" >> $env_var_test_script 25 | done 26 | 27 | showmd "$env_var_test_script" 5 28 | 29 | printf "\n\nRunning $env_var_test_script with dash\n\n" 30 | dash $env_var_test_script > /tmp/dash-env-var-tst.out 2> /tmp/dash-env-var-tst.err 31 | 32 | echo "" 33 | showmd /tmp/dash-env-var-tst.out 5 34 | echo "" 35 | showmd /tmp/dash-env-var-tst.err 5 36 | 37 | # printf "\n\nRunning $env_var_test_script with bash\n\n" 38 | # bash $env_var_test_script | tail 39 | # 40 | # printf "\n\nRunning $env_var_test_script with sh\n\n" 41 | # sh $env_var_test_script | tail 42 | 43 | -------------------------------------------------------------------------------- /tools/multigit-test.sh: -------------------------------------------------------------------------------- 1 | #! /bin/sh 2 | 3 | set -e 4 | 5 | tmpdir=/tmp/multigittest/ 6 | 7 | rm -fr $tmpdir 8 | 9 | try_cmd () { 10 | echo "================================================================================" 11 | echo "==== Running: [ $1 ]" 12 | sh -c "$1" 13 | } 14 | 15 | try_cmd 'git multi-status -h' 16 | 17 | try_cmd "git multi-status --version" 18 | 19 | moregits=$tmpdir/moregits 20 | mkdir -p $moregits 21 | ( 22 | cd $moregits 23 | git clone https://github.com/hammerlab/ketrew.git 24 | git clone https://github.com/hammerlab/biokepi.git 25 | echo "GREEEAAAT" >> biokepi/README.md 26 | echo "Boooo" >> biokepi/LICENSE 27 | git clone https://github.com/hammerlab/coclobas.git 28 | echo "GREEEAAAT" >> coclobas/README.md 29 | echo "Stuff" > coclobas/doeas-not-exist 30 | git clone https://gitlab.com/smondet/genspio-doc.git 31 | ) 32 | 33 | gms="git multi-status --no-config" 34 | 35 | try_cmd "$gms $moregits" 36 | try_cmd "$gms $moregits --show-modified" 37 | 38 | gmstest="$gms $moregits 2>&1" 39 | sedstuff="sed 's/[a-zA-Z\.: ]*//g'" 40 | 41 | try_cmd "$gmstest | grep ketrew | $sedstuff | grep '^|0|0|0|0|0|0|0|$' " 42 | try_cmd "$gmstest | grep biokepi | $sedstuff | grep '^|0|2|0|0|0|0|0|$' " 43 | try_cmd "$gmstest | grep coclobas | $sedstuff | grep '^|1|1|0|0|0|0|0|$' " 44 | try_cmd "$gmstest --show-modified | grep 'README.md'" 45 | try_cmd "$gmstest --show-modified | grep 'LICENSE'" 46 | try_cmd "$gmstest | grep 'GHub::coclobas'" 47 | try_cmd "$gmstest | grep 'GLab::genspio-doc'" 48 | 49 | gar="git activity-report --no-config" 50 | 51 | try_cmd "$gar $moregits --version" 52 | 53 | try_cmd "$gar $moregits" 54 | 55 | try_cmd "$gar $moregits --since 2018-07-01" 56 | 57 | try_cmd "$gar $moregits --since 2018-08-01 --section-base '###'" 58 | 59 | 60 | -------------------------------------------------------------------------------- /src/lib/transform.mli: -------------------------------------------------------------------------------- 1 | (** Manipulate the AST (['a EDST.t] values). *) 2 | 3 | (** A generic AST visitor pattern, which by default does nothing. *) 4 | module Visitor : sig 5 | class nothing_doer : 6 | ?trace:Format.formatter 7 | -> unit 8 | -> object 9 | method bool_operator : 10 | bool Language.t * [`And | `Or] * bool Language.t -> bool Language.t 11 | 12 | method bool_to_string : bool Language.t -> Language.c_string Language.t 13 | 14 | method byte_array_concat : 15 | Language.byte_array list Language.t -> Language.byte_array Language.t 16 | 17 | method byte_array_to_c_string : 18 | Language.byte_array Language.t -> Language.c_string Language.t 19 | 20 | method c_string_concat : 21 | Language.c_string list Language.t -> Language.c_string Language.t 22 | 23 | method c_string_to_byte_array : 24 | Language.c_string Language.t -> Language.byte_array Language.t 25 | 26 | method comment : string * 'a Language.t -> 'a Language.t 27 | method exec : Language.c_string Language.t list -> unit Language.t 28 | method expression : 'a Language.t -> 'a Language.t 29 | method fail : string -> unit Language.t 30 | 31 | method feed : 32 | Language.byte_array Language.t * unit Language.t -> unit Language.t 33 | 34 | method getenv : 35 | Language.c_string Language.t -> Language.c_string Language.t 36 | 37 | method if_ : 38 | bool Language.t * unit Language.t * unit Language.t 39 | -> unit Language.t 40 | 41 | method int_bin_comparison : 42 | int Language.t 43 | * [`Eq | `Ge | `Gt | `Le | `Lt | `Ne] 44 | * int Language.t 45 | -> bool Language.t 46 | 47 | method int_bin_op : 48 | int Language.t 49 | * [`Div | `Minus | `Mod | `Mult | `Plus] 50 | * int Language.t 51 | -> int Language.t 52 | 53 | method int_to_string : int Language.t -> Language.c_string Language.t 54 | method list : 'a Language.t list -> 'a list Language.t 55 | 56 | method list_append : 57 | 'a list Language.t * 'a list Language.t -> 'a list Language.t 58 | 59 | method list_iter : 60 | 'a list Language.t * ((unit -> 'a Language.t) -> unit Language.t) 61 | -> unit Language.t 62 | 63 | method list_to_string : 64 | 'a list Language.t 65 | * ('a Language.t -> Language.byte_array Language.t) 66 | -> Language.byte_array Language.t 67 | 68 | method literal : 'a Language.Literal.t -> 'a Language.t 69 | method no_op : unit Language.t 70 | method not : bool Language.t -> bool Language.t 71 | 72 | method output_as_string : 73 | unit Language.t -> Language.byte_array Language.t 74 | 75 | method pipe : unit Language.t list -> unit Language.t 76 | 77 | method raw_cmd : 78 | Language.raw_command_annotation option * string -> 'a Language.t 79 | 80 | method redirect_output : 81 | unit Language.t * Language.fd_redirection list -> unit Language.t 82 | 83 | method returns : expr:'a Language.t -> value:int -> bool Language.t 84 | method seq : unit Language.t list -> unit Language.t 85 | 86 | method setenv : 87 | Language.c_string Language.t * Language.c_string Language.t 88 | -> unit Language.t 89 | 90 | method string_operator : 91 | Language.byte_array Language.t 92 | * [`Eq | `Neq] 93 | * Language.byte_array Language.t 94 | -> bool Language.t 95 | 96 | method string_to_bool : Language.c_string Language.t -> bool Language.t 97 | method string_to_int : Language.c_string Language.t -> int Language.t 98 | 99 | method string_to_list : 100 | Language.byte_array Language.t 101 | * (Language.byte_array Language.t -> 'a Language.t) 102 | -> 'a list Language.t 103 | 104 | method while_ : 105 | condition:bool Language.t -> body:unit Language.t -> unit Language.t 106 | 107 | method write_output : 108 | expr:unit Language.t 109 | -> stdout:Language.c_string Language.t option 110 | -> stderr:Language.c_string Language.t option 111 | -> return_value:Language.c_string Language.t option 112 | -> unit Language.t 113 | end 114 | end 115 | 116 | (** A basic implementation of constant propagation. *) 117 | module Constant_propagation : sig 118 | val process : ?trace:Format.formatter -> 'a Language.t -> 'a Language.t 119 | (** Simplify an ['a EDSL.t] expression by propagating some of the 120 | constant values. *) 121 | 122 | val test : unit -> unit 123 | (** Some tests specific to the module, see option 124 | ["--run-constant-propagation-tests"] of the main tests. *) 125 | end 126 | -------------------------------------------------------------------------------- /src/lib/compile.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | 3 | let default_max_argument_length = Some 100_000 4 | 5 | module To_posix = struct 6 | open Standard_compiler 7 | 8 | type internal_error_details = Standard_compiler.internal_error_details = 9 | {variable: string; content: string; code: string} 10 | 11 | type death_message = Standard_compiler.death_message = 12 | | User of string 13 | | C_string_failure of internal_error_details 14 | | String_to_int_failure of internal_error_details 15 | 16 | type death_function = comment_stack:string list -> death_message -> string 17 | 18 | type compilation_error = Standard_compiler.compilation_error = 19 | { error: 20 | [ `No_fail_configured of death_message (* Argument of fail *) 21 | | `Max_argument_length of string (* Incriminated argument *) 22 | | `Not_a_c_string of string (* The actual string *) ] 23 | ; code: string option 24 | ; comment_backtrace: string list } 25 | 26 | let pp_error = Standard_compiler.pp_error 27 | let error_to_string = Fmt.str "%a" pp_error 28 | 29 | type parameters = 30 | { style: [`One_liner | `Multi_line] 31 | ; max_argument_length: int option 32 | ; fail_with: [`Nothing | `Trap_and_kill of int * string | `Kill of string] 33 | ; print_failure: death_function } 34 | 35 | let failure_to_stderr : death_function = 36 | fun ~comment_stack msg -> 37 | let summary s = 38 | match String.sub s ~pos:0 ~len:65 with s -> s ^ " …" | exception _ -> s 39 | in 40 | let open Fmt in 41 | let big_string ppf s = pf ppf "@[%s@]" (summary s) in 42 | let msg_str = 43 | str "@[Error:@ @[%a@]%a@]" 44 | (Standard_compiler.pp_death_message ~style:`User ~big_string) 45 | msg 46 | (fun ppf () -> 47 | match comment_stack with 48 | | [] -> pf ppf "" 49 | | more -> 50 | pf ppf ";@ Comment-stack:@ @[[%a]@]" 51 | (list 52 | ~sep:(fun ppf () -> pf ppf ",@ ") 53 | (fun ppf s -> pf ppf "@[`%s`@]" s) ) 54 | more ) 55 | () 56 | |> Caml.Filename.quote in 57 | str " printf -- '%%s\\n' %s >&2 " msg_str 58 | 59 | let one_liner = 60 | { style= `One_liner 61 | ; max_argument_length= Some 100_000 62 | ; fail_with= `Trap_and_kill (78, "USR2") 63 | ; print_failure= failure_to_stderr } 64 | 65 | let multi_line = {one_liner with style= `Multi_line} 66 | let default_options = one_liner 67 | 68 | let string_exn ?(options = default_options) term = 69 | let statement_separator = 70 | match options.style with `Multi_line -> "\n" | `One_liner -> " ; " in 71 | let {max_argument_length; print_failure; _} = options in 72 | match options.fail_with with 73 | | `Nothing -> 74 | to_shell 75 | {statement_separator; die_command= None; max_argument_length} 76 | term 77 | | `Kill signal_name -> 78 | with_die_function ~print_failure ~statement_separator ~signal_name 79 | (fun ~die -> 80 | to_shell 81 | {statement_separator; die_command= Some die; max_argument_length} 82 | term ) 83 | | `Trap_and_kill (ret, signal) -> 84 | with_die_function ~print_failure ~statement_separator 85 | ~signal_name:signal ~trap:(`Exit_with ret) (fun ~die -> 86 | to_shell 87 | {statement_separator; die_command= Some die; max_argument_length} 88 | term ) 89 | 90 | let string ?options term = 91 | match string_exn ?options term with 92 | | s -> Ok s 93 | | exception Standard_compiler.Compilation ce -> Error ce 94 | end 95 | 96 | module To_slow_flow = struct 97 | module Script = To_slow_flow.Script 98 | 99 | let compile = To_slow_flow.compile 100 | end 101 | 102 | let to_legacy style ?(max_argument_length = default_max_argument_length) 103 | ?(no_trap = false) e = 104 | To_posix.string e 105 | ~options: 106 | { style 107 | ; max_argument_length 108 | ; fail_with= (if no_trap then `Nothing else `Trap_and_kill (77, "USR1")) 109 | ; print_failure= To_posix.failure_to_stderr } 110 | |> function Ok s -> s | Error e -> failwith @@ To_posix.error_to_string e 111 | 112 | let to_one_liner ?max_argument_length ?no_trap e = 113 | to_legacy `One_liner ?max_argument_length ?no_trap e 114 | 115 | let to_many_lines ?max_argument_length ?no_trap e = 116 | to_legacy `Multi_line ?max_argument_length ?no_trap e 117 | 118 | let quick_run_exn ?max_argument_length ?no_trap e = 119 | match to_many_lines ?max_argument_length ?no_trap e |> Caml.Sys.command with 120 | | 0 -> () 121 | | other -> Fmt.failwith "Command returned %d" other 122 | 123 | let pp_hum = Language.pp 124 | let to_string_hum e = Fmt.str "%a" pp_hum e 125 | 126 | let to_one_line_hum e = 127 | let buf = Buffer.create 42 in 128 | let formatter = Caml.Format.formatter_of_buffer buf in 129 | Caml.Format.pp_set_margin formatter 10_000_000 ; 130 | Caml.Format.fprintf formatter "@[%a@]@?" pp_hum e ; 131 | Buffer.contents buf 132 | -------------------------------------------------------------------------------- /tools/ci_test.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # configure and view settings 4 | export OPAMYES=1 5 | #echo "ocaml -version" 6 | #ocaml -version 7 | echo "opam --version" 8 | opam --version 9 | echo "git --version" 10 | git --version 11 | 12 | echo "Which bash" 13 | which bash 14 | echo "bash --version" 15 | bash --version 16 | echo "/bin/bash --version" 17 | /bin/bash --version || echo "NO /bin/bash version" 18 | echo "/bin/sh --version" 19 | /bin/sh --version || echo "NO /bin/sh version" 20 | echo ">>> getconf ARG_MAX:" 21 | getconf ARG_MAX 22 | echo ">>> getconf -a:" 23 | getconf -a || echo "Not on OSX...?" 24 | echo ">>> xargs shows the limits:" 25 | echo "$(xargs --show-limits & { sleep 1 ; exit 0 ; } )" 26 | echo ">>> ULimits:" 27 | ulimit -a 28 | 29 | export important_shells=bash 30 | export main_shell=bash 31 | 32 | genspio_test=src/test/main.exe 33 | genspio_downloader_maker=src/examples/downloader.exe 34 | genspio_small_examples=src/examples/small_examples.exe 35 | genspio_vm_tester=src/examples/vm_tester.exe 36 | genspio_service_composer=src/examples/service_composer.exe 37 | genspio_multigit=src/examples/multigit.exe 38 | 39 | echo "================== BUILD ALL ===================================================" 40 | dune build @install 41 | 42 | dune build $genspio_test 43 | dune build $genspio_downloader_maker 44 | dune build $genspio_small_examples 45 | dune build $genspio_vm_tester 46 | dune build $genspio_service_composer 47 | dune build $genspio_multigit 48 | 49 | echo "================== TESTS =======================================================" 50 | 51 | dune exec $genspio_test -- --run-constant-propagation-tests \ 52 | --important-shells $important_shells _test/ 53 | ( 54 | cd _test 55 | ## case $TRAVIS_OS_NAME in 56 | ## osx) 57 | ## ( 58 | ## echo "On OSX we do less tests because they take too long on Travis" 59 | ## cd $main_shell-StdML 60 | ## echo "Make $main_shell-StdML" 61 | ## make 62 | ## echo "Make Check" 63 | ## make check 64 | ## cd ../sh-SlowFlow/ 65 | ## echo "Make sh-SlowFlow" 66 | ## make 67 | ## echo "Make Check" 68 | ## make check 69 | ## ) ;; 70 | ## linux) 71 | make run-all 72 | make check 73 | ## ;; 74 | ## *) echo "Unknown $TRAVIS_OS_NAME"; exit 1 75 | ## esac 76 | ) 77 | 78 | 79 | echo "================== EXAMPLES: TEST 1 ============================================" 80 | genspio_downloader=/tmp/genspio-downloader 81 | dune exec $genspio_downloader_maker -- make $genspio_downloader 82 | 83 | $main_shell $genspio_downloader -h 84 | 85 | $main_shell $genspio_downloader -c -t /tmp/test1 -f k3.0.0.tar.gz -u https://github.com/hammerlab/ketrew/archive/ketrew.3.0.0.tar.gz 86 | ls -la /tmp/test1 87 | test -f /tmp/test1/k3.0.0.tar 88 | test -f /tmp/test1/ketrew-ketrew.3.0.0/README.md 89 | 90 | 91 | echo "================== EXAMPLES: TEST 2 ============================================" 92 | $main_shell $genspio_downloader -c -t /tmp/genstest2 -u https://www.dropbox.com/s/h16b8ak9smkgw3g/test.tar.gz.zip.bz2.tbz2?raw=1 93 | ls -la /tmp/genstest2 94 | test -f /tmp/genstest2/src/lib/EDSL.ml 95 | 96 | echo "================== EXAMPLES: TEST 3 ============================================" 97 | # like -t /tmp/test2, without -c (which is fragile w.r.t. tar) 98 | ( 99 | mkdir -p /tmp/test3 100 | cd /tmp/test3 101 | $main_shell $genspio_downloader -u https://github.com/hammerlab/ketrew/archive/ketrew.3.0.0.tar.gz 102 | ls -la /tmp/test3 103 | test -f /tmp/test3/ketrew-ketrew.3.0.0/README.md 104 | ) 105 | 106 | echo "================== EXAMPLES: SMALL ONES ============================================" 107 | 108 | dune exec $genspio_small_examples 109 | 110 | echo "================== EXAMPLES: vm_tester ============================================" 111 | 112 | dune exec $genspio_vm_tester -- --vm arm-owrt /tmp/vmt/arm-owrt/ ; ( cd /tmp/vmt/arm-owrt/ ; make help ; ) 113 | dune exec $genspio_vm_tester -- --vm arm-dw /tmp/vmt/arm-dw/ ; ( cd /tmp/vmt/arm-dw/ ; make help ; ) 114 | dune exec $genspio_vm_tester -- --vm amd64-fb /tmp/vmt/amd64-fb/ ; ( cd /tmp/vmt/amd64-fb ; make help ; ) 115 | 116 | 117 | echo "================== EXAMPLES: Service-composer=======================================" 118 | 119 | dune exec $genspio_service_composer -- --name cosc --output-path $HOME/bin 120 | 121 | echo "================== EXAMPLES: Multigit =======================================" 122 | 123 | dune exec $genspio_multigit -- $HOME/bin 124 | export PATH=$HOME/bin:$PATH 125 | ./tools/multigit-test.sh 126 | 127 | 128 | ##echo "================== Trigger Docker build ======================================" 129 | ## 130 | ##git branch --all 131 | ## 132 | ##echo "TRAVIS_BRANCH: $TRAVIS_BRANCH" 133 | ##echo "DOCKER_BUILD: $DOCKER_BUILD" 134 | ## 135 | ##if [ "$TRAVIS_BRANCH" = "master" ] && [ "$DOCKER_BUILD" = "true" ] ; then 136 | ## curl -H "Content-Type: application/json" \ 137 | ## --data '{"source_type": "Branch", "source_name": "apps406"}' \ 138 | ## -X POST \ 139 | ## https://registry.hub.docker.com/u/smondet/genspio-doc-dockerfiles/trigger/f113ff75-c7d4-446d-9a71-2e4d7db63389/ 140 | ##else 141 | ## echo "Not triggering the Docker build this time." 142 | ##fi 143 | 144 | 145 | -------------------------------------------------------------------------------- /doc/extra-testing.md: -------------------------------------------------------------------------------- 1 | Additional Testing 2 | ================== 3 | 4 | FreeBSD Box on Google Cloud 5 | --------------------------- 6 | 7 | We can easily create FreeBSD nodes (i.e. without creating/uploading custom 8 | images, cf. [forum](https://forums.freebsd.org/threads/56664/)): 9 | 10 | ```bash 11 | gcloud compute instances create testing-fbsd \ 12 | --image freebsd-10-3-release-amd64 \ 13 | --image-project=freebsd-org-cloud-dev 14 | ``` 15 | 16 | Then, a function to get the IP address assigned by gcloud: 17 | 18 | ```bash 19 | freebsd_ip_address () { 20 | gcloud compute instances describe testing-fbsd | awk -F ':' ' /natIP:/ { print $2 }' 21 | } 22 | freebsd_test () { 23 | ssh -i ~/.ssh/google_compute_engine $(freebsd_ip_address) 'uname -a' 24 | } 25 | ``` 26 | 27 | You can just: 28 | 29 | $genspio_test --important-shells sh /tmp/gtests/ 30 | cd /tmp/gtests/ 31 | tar czf sh-tests.tgz sh/* 32 | 33 | `sh-tests.tgz` contains everything needed to run the tests (only requires 34 | `make`). 35 | 36 | 37 | OpenWRT/ARM with Qemu 38 | --------------------- 39 | 40 | The OpenWRt project provides a nice 41 | wiki [page](https://wiki.openwrt.org/doc/howto/qemu) on running with Qemu. 42 | 43 | This function downloads the required data and starts the virtual machine: 44 | 45 | ```bash 46 | qemu_openwrt () { 47 | local tmp=/tmp/qemu_openwrt/ 48 | mkdir -p $tmp 49 | cd $tmp 50 | if ! [ -f openwrt-realview-vmlinux-initramfs.elf ] ; then 51 | wget https://downloads.openwrt.org/snapshots/trunk/realview/generic/openwrt-realview-vmlinux-initramfs.elf 52 | fi 53 | if ! [ -f openwrt-realview-vmlinux.elf ] ; then 54 | wget https://downloads.openwrt.org/snapshots/trunk/realview/generic/openwrt-realview-vmlinux.elf 55 | fi 56 | if ! [ -f openwrt-realview-sdcard.img ] ; then 57 | wget https://downloads.openwrt.org/snapshots/trunk/realview/generic/openwrt-realview-sdcard.img 58 | fi 59 | qemu-system-arm -M realview-pbx-a9 -m 1024M \ 60 | -kernel openwrt-realview-vmlinux.elf \ 61 | -net nic \ 62 | -net user,hostfwd=tcp::10022-:22 \ 63 | -nographic \ 64 | -sd openwrt-realview-sdcard.img \ 65 | -append "console=ttyAMA0 verbose debug root=/dev/mmcblk0p1" 66 | } 67 | ``` 68 | 69 | The default installation does not contain the POSIX utility `od` nor `make` 70 | (required for the tests), we can install it with `opkg` (here over SSH for the 71 | sake of the example): 72 | 73 | ```bash 74 | qemu_openwrt_depedencies () { 75 | ssh -oStrictHostKeyChecking=no -p 10022 root@localhost 'opkg update ; opkg install make coreutils-od' 76 | } 77 | ``` 78 | 79 | You may just run the tests as above. 80 | 81 | Note that this setup is also handled by the `vm_tests` example. 82 | 83 | Using the VM-Tester Example 84 | --------------------------- 85 | 86 | The file `src/examples/vm_tester.ml` is an example of use of Genspio which 87 | provides a command line tool to generate “Qemu” environments. 88 | 89 | You can build it with: 90 | 91 | export genspio_vm_tester=_build/default/src/examples/vm_tester.exe 92 | dune build $genspio_vm_tester 93 | 94 | A version is also available in the genspio-doc docker-images (note that the 95 | [build](https://hub.docker.com/r/smondet/genspio-doc-dockerfiles/builds/) 96 | of the docker images sometimes lags behind Genspio's `master` branch): 97 | 98 | docker pull smondet/genspio-doc-dockerfiles:apps406 99 | docker run -it smondet/genspio-doc-dockerfiles:apps406 genspio-vm-tester --help 100 | 101 | See the list of available virtual machines from: 102 | 103 | $genspio_vm_tester --help 104 | 105 | As an example let's run some of the test suite in a Darwin VM. We need to first 106 | generate the test-suite: 107 | 108 | $genspio_test --important-shells sh /tmp/Genspio-tests/ 109 | 110 | then we build the VM “environment” in `/tmp/vme-amd64-dw/`: 111 | 112 | $genspio_vm_tester --vm amd64-dw /tmp/vme-amd64-dw/ --ssh-port 20101 \ 113 | --copy /tmp/Genspio-tests/sh-SlowFlow-cp/:genspio-sh-slcp \ 114 | --copy /tmp/Genspio-tests/sh-StdML/:genspio-sh-stdml 115 | 116 | A few files have been generated in `/tmp/vme-amd64-dw/`: 117 | 118 | Makefile 119 | _scripts/ 120 | _tmp_Genspio-tests_sh-SlowFlow-cp_/ 121 | _tmp_Genspio-tests_sh-StdML_/ 122 | 123 | This directory is mostly self-contained, independent from Genspio/OCaml/Opam, it 124 | can be copied to any Unix host (requires `qemu` and `sshpass`). 125 | 126 | See `make help` within the directory for a list of useful targets. 127 | 128 | Start with `make configure` to check that the system has the right executables. 129 | The output should look like: 130 | 131 | ```markdown 132 | Configuration Report 133 | ==================== 134 | 135 | * `qemu-system-x86_64`: found. 136 | * `sshpass`: found. 137 | 138 | *Success!* 139 | ``` 140 | 141 | The, in one terminal, start the VM: `make start` (depending on the Operating 142 | system the output will be more or less verbose/informative; Darwin being the 143 | worst …). 144 | 145 | Once the VM has booted you can test connecting to it: 146 | 147 | $(make ssh) uname -a 148 | 149 | Darwin charles.local 8.0.1 Darwin Kernel Version 8.0.1: Fri Apr 29 12:18:40 PDT 2005; root:xnu-792.obj/RELEASE_I386 x86 i386 150 | 151 | 152 | → the command `make ssh` **outputs** a valid `sshpass`/`ssh` command, we 153 | actually excute the command with a `$( ... )` construct. 154 | 155 | The next step is `make setup`, it runs the additional setup instructions as well 156 | as the directory copies specified while generating the environment (`--copy …`). 157 | 158 | Then to run the tests, just jump on the VM: 159 | 160 | `make ssh` 161 | 162 | and run them (see the first `--copy` argument ⮥): 163 | 164 | cd genspio-sh-slcp 165 | make # takes a long time... 166 | make report 167 | ... 168 | 169 | You can always kill a VM with `make kill` 170 | 171 | 172 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Genspio: Generate Shell Phrases In OCaml 2 | ======================================== 3 | 4 | Genspio is a typed EDSL to generate shell scripts and commands from OCaml. 5 | 6 | The idea is to build values of type `'a EDSL.t` with the 7 | combinators in the `Genspio.EDSL` module, and compile them to POSIX 8 | shell scripts (or one-liners) with functions from `Genspio.Compile`. 9 | See the file 10 | [`src/examples/small.ml`](https://github.com/hammerlab/genspio/blob/master/src/examples/small.ml) 11 | which generates a useful list of usage examples, or the 12 | section [“Getting Started”](#getting-started) below. 13 | 14 | The tests run the output of the compiler against a few shells that it tries to 15 | find on the host (e.g. `dash`, `bash`, `busybox`, `mksh`, `zsh` … cf. the 16 | example test results summary below). 17 | 18 | If you have any questions, do not hesitate to submit an 19 | [issue](https://github.com/hammerlab/genspio/issues). 20 | 21 | Genspio's documentation root is at . 22 | 23 | Build 24 | ----- 25 | 26 | You can install the library though `opam`: 27 | 28 | opam install genspio 29 | 30 | Or get the development version with `opam pin`: 31 | 32 | opam pin add genspio https://github.com/hammerlab/genspio.git 33 | 34 | You can also build locally: 35 | 36 | You need OCaml ≥ 4.03.0 together with `base`, `fmt`, and 37 | [`dune`](https://github.com/janestreet/dune): 38 | 39 | dune build @install 40 | 41 | Getting Started 42 | --------------- 43 | 44 | Here is a quick example: 45 | 46 | ```ocaml 47 | utop> open Genspio.EDSL;; 48 | 49 | utop> 50 | let c = 51 | let username_one_way : str t = 52 | (* We lift the string "USER" to EDSL-land and use function `getenv`: *) 53 | getenv (str "USER") in 54 | let username_the_other_way : str t = 55 | (* The shell-pipe operator is `||>` *) 56 | (exec ["whoami"] ||> exec ["tr"; "-d"; "\\n"]) 57 | (* `get_stdout` takes `stdout` from a `unit t` as a `byte_array t` *) 58 | |> get_stdout 59 | in 60 | let my_printf : string -> str t list -> unit t = fun fmt args -> 61 | (* The function `call` is like `exec` but operates on `str t` values 62 | instead of just OCaml strings: *) 63 | call (str "printf" :: str fmt :: args) in 64 | (* The operator `=$=` is `str t` equality, it returns a `bool t` that 65 | we can use with `if_seq`: *) 66 | if_seq Str.(username_one_way =$= username_the_other_way) 67 | ~t:[ 68 | my_printf "Username matches: `%s`\\n" [username_one_way]; 69 | ] 70 | ~e:[ 71 | my_printf "Usernames do not match: `%s` Vs `%s`\\n" 72 | [username_one_way; username_the_other_way]; 73 | ] 74 | ;; 75 | val c : unit t 76 | 77 | utop> Sys.command (Genspio.Compile.to_one_liner c);; 78 | Username matches: `smondet` 79 | - : int = 0 80 | ``` 81 | 82 | ### Important Modules 83 | 84 | - `Genspio.EDSL` provides the Embedded Domain Specific Language API to build 85 | shell script expressions (there is also a lower-level, *not recommended*, 86 | `Genspio.EDSL_v0` API). 87 | - `Genspio.Compile` has the 3 “compilers” provided by the library: 88 | - The pretty printer outputs `'a EDSL.t` values as expressions of a 89 | lisp-like pseudo-language. 90 | - The default “`To_posix`” compiler generates POSIX-compliant shell 91 | scripts (with the option of avoiding new-lines).
92 | ⤷ Note that MacOSX's default `bash` version is buggy and has been 93 | witnessed to choke on generated POSIX-valid scripts. 94 | - The newer “`To_slow_flow`” compiler generates POSIX shell scripts which 95 | are much simpler, hence more portable across shell implementations, but 96 | use (*a lot of*) temporary files and are generally slower. 97 | - `Genspio.Transform` implements code transformations: 98 | - The module `Visitor` provides an extensible AST visitor. 99 | - The module `Constant_propagation` does some basic constant propagation 100 | (using the visitor). 101 | 102 | 103 | ### More Examples 104 | 105 | - There are many examples in 106 | [`src/examples/small.ml`](https://github.com/hammerlab/genspio/blob/master/src/examples/small.ml) 107 | which are used to generate the usage examples documentation webpage. 108 | - The file 109 | [`src/examples/service_composer.ml`](https://github.com/hammerlab/genspio/blob/master/src/examples/service_composer.ml) 110 | is the code generator for the “COSC” project (Github: 111 | [`smondet/cosc`](https://github.com/smondet/cosc)), a family of scripts which 112 | manage long-running processes in a GNU-Screen session. 113 | - The file 114 | [`src/examples/downloader.ml`](https://github.com/hammerlab/genspio/blob/master/src/examples/downloader.ml) 115 | contains another big example: a script that downloads and unpacks archives 116 | from URLs. 117 | - The file 118 | [`src/examples/vm_tester.ml`](https://github.com/hammerlab/genspio/blob/master/src/examples/vm_tester.ml) 119 | is a *“Makefile + scripts”* generator to setup Qemu virtual machines, they can 120 | be for instance used to run the tests on more exotic platforms. 121 | - The project 122 | [`hammerlab/secotrec`](https://github.com/hammerlab/secotrec) is a real-world, 123 | larger-scale use of Genspio (uses Genspio version 0.0.0). 124 | 125 | ### Additional Documentation 126 | 127 | From here, one can explore: 128 | 129 | - Some implementation [notes](./doc/exec-return-issue.md). 130 | - More [information](./doc/extra-testing.md) on testing, e.g. on more exotic 131 | operating systems. 132 | - The module `Genspio.EDSL_v0` is an older version of the API, which can still 133 | be useful as it is lower-level: it gives full access to the two “string-like” 134 | types, byte-arrays and C-strings while of course becoming more cumbersome to 135 | use. 136 | 137 | 138 | 139 | 140 | 141 | Testing 142 | ------- 143 | 144 | To run the tests you also need `make` and there is an additional dependency on 145 | the `uri` library, see: 146 | 147 | genspio_test=_build/default/src/test/main.exe 148 | dune build $genspio_test 149 | $genspio_test --help 150 | 151 | 152 | Try this: 153 | 154 | $genspio_test --important-shells bash,dash /tmp/gtests/ 155 | cd /tmp/gtests/ 156 | make run-all # Attempts to run all the tests on all the shells 157 | make check # Checks that all the tests for the important ones succeeded 158 | 159 | You can generate a markdown report with `make report` and check `report.md`. 160 | 161 | Some failures are expected with not-really-POSIX or buggy shells like 162 | [KSH93](https://en.wikipedia.org/wiki/Korn_shell), or on some corner cases 163 | cf. [`#35`](https://github.com/hammerlab/genspio/issues/35). 164 | 165 | You can check failures in the `/failures.md` files, see for instance 166 | `ksh-StdML/failures.md` for the failures of the “KSH with standard Genspio 167 | compilation to multi-line scripts” (similarly there are 168 | `/successes.md` files). 169 | 170 | 171 | Building The Documentation 172 | -------------------------- 173 | 174 | To build the documentation one needs `pandoc` and `caml2html`: 175 | 176 | sh tools/build-doc.sh 177 | 178 | The build of the whole website, including the 179 | [web-based demo](https://smondet.gitlab.io/genspio-doc/demo/master/index.html), 180 | happens in a different repository: 181 | . 182 | 183 | License 184 | ------- 185 | 186 | It's [Apache 2.0](http://www.apache.org/licenses/LICENSE-2.0). 187 | -------------------------------------------------------------------------------- /tools/build-doc.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | genspio_small_examples_name=src/examples/small_examples.exe 6 | genspio_small_examples=_build/default/$genspio_small_examples_name 7 | 8 | dune build @install 9 | dune build @doc 10 | dune build $genspio_small_examples_name 11 | 12 | export output_path=_build/doc/html/ 13 | rm -fr $output_path 14 | mkdir -p $output_path 15 | odoc_result=_build/default/_doc/_html/ 16 | cp -r $odoc_result/* $output_path/ || { 17 | find _build/default/ | sed 's/^/ /' 18 | echo "Copying '$odoc_result/' failed :(" 19 | exit 2 20 | } 21 | 22 | css_file=ssc.css 23 | css_path=$output_path/$css_file 24 | 25 | cat >> $output_path/odoc.css < $css_path 32 | more_css () { 33 | cat >> $1 < /tmp/morecode.css < $output_path/caml2html.css 148 | cat /tmp/c2h.css >> $output_path/caml2html.css 149 | cat /tmp/morecode.css >> $output_path/caml2html.css 150 | more_css $output_path/caml2html.css 151 | caml2html $input_file -charset UTF-8 \ 152 | -t -cssurl caml2html.css \ 153 | -ext md:'cat | { printf "
" ; pandoc -w html ; printf "
" ; } ' \ 154 | -o $output_file 155 | sed -i "s:${input_file}:${title}:" $output_file 156 | sed -i 's@This document was generated using@Back to home.@' $output_file 157 | sed -i 's@caml2html@@' $output_file 158 | echo "Made $output_file" 159 | } 160 | 161 | call_caml2html src/lib/to_slow_flow.ml $output_path/to-slow-flow.html \ 162 | "The Slow-flow Compiler" 163 | call_caml2html src/lib/transform.ml $output_path/transform-module.html \ 164 | "The AST Transformations" 165 | call_caml2html src/examples/service_composer.ml $output_path/service-composer-example.html \ 166 | "The Service Composer Example" 167 | call_caml2html src/examples/multigit.ml $output_path/multigit-example.html \ 168 | "The “Multi-Git” Example" 169 | 170 | 171 | pandocify () { 172 | local title="$(head -n 1 $1)" 173 | echo "$1 -> $2 -> $title" 174 | tail -n +3 $1 \ 175 | | sed 's:(./doc/\(.*\)\.md):(\1.html):g' \ 176 | | sed 's:(./\([^/]*\)\.md):(\1.html):g' \ 177 | | sed 's:\(`Genspio.\([^`]*\)`\):[\1](genspio/Genspio/\2/index.html):g' \ 178 | | sed 's:usage examples:[usage examples](./small-examples.html):' \ 179 | | sed 's::- Code [documentation](./to-slow-flow.html) for the `To_slow_flow` *compiler.*:' \ 180 | | sed 's::- Code [documentation](./transform-module.html) for the `Transform` module (AST *optimizations*).:' \ 181 | | sed 's::- Code [documentation](./service-composer-example.html) for the *“Service-composer Example”*.:' \ 182 | | sed 's::- Code [documentation](./multigit-example.html) for the *“Multi-Git Example”*.:' \ 183 | | pandoc -c $css_file -s \ 184 | --variable title="$title" --variable pagetitle="$title" \ 185 | --toc -o $output_path/$2.html 186 | } 187 | pandocify README.md index 188 | for f in $(find doc -type f -name '*.md') ; do 189 | pandocify $f $(basename ${f%.md}) 190 | done 191 | 192 | $genspio_small_examples > /tmp/examples.md 193 | pandocify /tmp/examples.md small-examples 194 | 195 | echo "Done cf. file://$PWD/$output_path/index.html" 196 | -------------------------------------------------------------------------------- /src/examples/downloader.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | module Filename = Caml.Filename 3 | 4 | let downloader () = 5 | let open Genspio.EDSL in 6 | let say strings = 7 | let sayone ?(prompt = false) s = 8 | let prompt = if prompt then "downloader: " else "" in 9 | call [string "printf"; string (prompt ^ "%s"); s] in 10 | match strings with 11 | | [] -> nop 12 | | s :: more -> 13 | seq 14 | ( (sayone ~prompt:true s :: List.map more ~f:sayone) 15 | @ [sayone (string "\n")] ) in 16 | let sayf fmt = Fmt.kstr (fun s -> say [string s]) fmt in 17 | let fail l = seq [say (string "ERROR: " :: l); fail "fail-list"] in 18 | let failf fmt = Fmt.kstr (fun s -> fail [string s]) fmt in 19 | let ( // ) = Filename.concat in 20 | let silent ~name unit = 21 | object (self) 22 | method stdout = "/tmp" // Fmt.str "output-of-%s-%s" name "out" |> string 23 | method stderr = "/tmp" // Fmt.str "output-of-%s-%s" name "err" |> string 24 | 25 | method exec = 26 | seq 27 | [ (* say [string "Silent "; string name; self#stdout; self#stderr;]; *) 28 | write_output (seq unit) ~stdout:self#stdout ~stderr:self#stderr ] 29 | 30 | method succeed_or_fail = 31 | if_seq (self#exec |> succeeds) ~t:[sayf "%s: Success" name] 32 | ~e: 33 | [ sayf "Expression %s failed!" name; call [string "cat"; self#stderr] 34 | ; failf "Fatal failure of %s" name ] 35 | end in 36 | let silence ~name unit = 37 | let s = silent ~name [unit] in 38 | s#exec in 39 | let succeed_in_silence_or_fail ~name units = 40 | let s = silent ~name units in 41 | s#succeed_or_fail in 42 | let download ~url ~output = 43 | let try_help ?(opt = "--help") cmd = 44 | exec [cmd; opt] |> silence ~name:(cmd ^ opt) |> succeeds in 45 | let do_call exec args = 46 | [ sayf "Using `%s`." exec 47 | ; succeed_in_silence_or_fail ~name:exec [call (string exec :: args)] ] 48 | in 49 | switch 50 | [ case (try_help "wget") 51 | (do_call "wget" [url; string "--output-document"; output]) 52 | ; case (try_help "curl") 53 | (do_call "curl" [string "-L"; string "-o"; output; url]) 54 | ; default [failf "Can't find a downloading application"] ] in 55 | let string_matches_any string regexp_list = 56 | (* Cf. http://pubs.opengroup.org/onlinepubs/009695399/utilities/grep.html *) 57 | let options = List.concat_map regexp_list ~f:(fun r -> ["-e"; r]) in 58 | string >> exec (["grep"; "-q"] @ options) |> succeeds in 59 | let no_newline_sed ~input expr = 60 | let with_potential_newline = 61 | Str.concat_list [input; string "\n"] >> exec ["sed"; expr] |> get_stdout 62 | in 63 | with_potential_newline >> exec ["tr"; "-d"; "\\n"] |> get_stdout in 64 | let module Unwrapper = struct 65 | type cmd = unit t 66 | type t = {extension: string; verb: string; commands: file -> cmd list} 67 | 68 | let make ~ext ~verb commands = {extension= ext; verb; commands} 69 | 70 | let remove_suffix v suf = 71 | no_newline_sed ~input:v (Fmt.str "s:^\\(.*\\)%s$:\\1:" suf) 72 | 73 | let to_switch name_variable t_list = 74 | let make_case t = 75 | case 76 | (string_matches_any name_variable#get [Fmt.str "\\.%s$" t.extension]) 77 | [ say [Fmt.kstr string "%s: " t.verb; name_variable#get] 78 | ; succeed_in_silence_or_fail 79 | ~name:(Fmt.str "%s-%s" t.verb t.extension) 80 | (t.commands name_variable) 81 | ; name_variable#set 82 | (remove_suffix name_variable#get (Fmt.str "\\.%s" t.extension)) ] 83 | in 84 | seq 85 | [ say [string "Extract loop: "; name_variable#get] 86 | ; switch (List.map t_list ~f:make_case) ] 87 | 88 | let to_loop name_variable t_list = 89 | loop_while 90 | (string_matches_any name_variable#get 91 | (List.map t_list ~f:(fun t -> Fmt.str "\\.%s$" t.extension)) ) 92 | ~body:(to_switch name_variable t_list) 93 | 94 | let all = 95 | [ make ~ext:"gz" ~verb:"Gunzipping" (fun current_name -> 96 | [call [string "gunzip"; string "-f"; current_name#get]] ) 97 | ; make ~ext:"bz2" ~verb:"Bunzip2-ing" (fun current_name -> 98 | [call [string "bunzip2"; string "-f"; current_name#get]] ) 99 | ; make ~ext:"zip" ~verb:"Unzipping" (fun current_name -> 100 | [call [string "unzip"; current_name#get]] ) 101 | ; make ~ext:"tar" ~verb:"Untarring" (fun current_name -> 102 | [call [string "tar"; string "xf"; current_name#get]] ) 103 | ; make ~ext:"tgz" ~verb:"Untar-gzip-ing" (fun name -> 104 | [call [string "tar"; string "zxf"; name#get]] ) 105 | ; make ~ext:"tbz2" ~verb:"Untar-bzip2-ing" (fun name -> 106 | [call [string "tar"; string "xfj"; name#get]] ) 107 | ; make ~ext:"gpg" ~verb:"Decyphering" (fun name -> 108 | [ call 109 | [ string "gpg"; string "--output" 110 | ; remove_suffix name#get "\\.gpg"; string "-d"; name#get ] ] ) 111 | ] 112 | end in 113 | let no_value = Fmt.str "none_%x" (Random.int 100_000) |> string in 114 | let cli_spec = 115 | let open Command_line.Arg in 116 | string ~doc:"The URL to the stuff" ["-u"; "--url"] ~default:no_value 117 | & flag ["-c"; "--all-in-tmp"] ~doc:"Do everything in the temp-dir" 118 | & string ["-f"; "--local-filename"] ~doc:"Override the downloaded file-name" 119 | ~default:no_value 120 | & string ["-t"; "--tmp-dir"] ~doc:"Use as temp-dir" 121 | ~default:(str "/tmp/genspio-downloader-tmpdir") 122 | & usage 123 | "Download archives and decrypt/unarchive them.\n\ 124 | ./downloader -u URL [-c] [-f ] [-t ]" in 125 | Command_line.parse cli_spec (fun ~anon:_ url all_in_tmp filename_ov tmp_dir -> 126 | let current_name = tmp_file ~tmp_dir "current-name" in 127 | let set_output_of_download () = 128 | if_seq 129 | Str.(filename_ov =$= no_value) 130 | ~t: 131 | (let filename = 132 | no_newline_sed ~input:url "s/.*\\/\\([^?\\/]*\\).*/\\1/" in 133 | let output_path = Str.concat_list [tmp_dir; string "/"; filename] in 134 | [current_name#set output_path] ) 135 | ~e: 136 | (let output_path = 137 | Str.concat_list [tmp_dir; string "/"; filename_ov] in 138 | [current_name#set output_path] ) in 139 | seq 140 | [ call [string "mkdir"; string "-p"; tmp_dir] 141 | ; if_then all_in_tmp 142 | (seq [sayf "Going to the tmpdir"; call [string "cd"; tmp_dir]]) 143 | ; if_then Str.(url =$= no_value) (failf "Argument URL is mandatory") 144 | ; if_then_else 145 | (string_matches_any url ["^http://"; "^https://"; "^ftp://"]) 146 | (seq 147 | [ set_output_of_download () 148 | ; download ~url ~output:current_name#get 149 | ; say [string "Downloaded "; current_name#get] 150 | ; Unwrapper.to_loop current_name Unwrapper.all ] ) 151 | (seq 152 | [ fail 153 | [ string "URL: "; url 154 | ; string " -> not HTTP(s) or FTP: NOT IMPLEMENTED" ] ] ) ] ) 155 | 156 | let () = 157 | match Caml.Sys.argv |> Array.to_list |> List.tl_exn with 158 | | ["make"; path] -> ( 159 | let script = Genspio.Compile.to_many_lines (downloader ()) in 160 | let content = 161 | Fmt.str "#!/bin/sh\n\n# Generated by Genspio Example Tests\n\n%s\n%!" 162 | script in 163 | match path with 164 | | "-" -> Fmt.pr "\n`````\n%s`````\n%!" content 165 | | other -> 166 | let o = Caml.open_out other in 167 | Caml.Printf.fprintf o "%s%!" content ; 168 | Caml.close_out o ) 169 | | other -> 170 | Fmt.epr "Wrong command line: [%s]\n" 171 | (List.map ~f:(Fmt.str "%S") other |> String.concat ~sep:"; ") ; 172 | Fmt.epr "Usage:\n%s make \n Create the downloader script.\n%!" 173 | Caml.Sys.argv.(0) ; 174 | Caml.exit 1 175 | -------------------------------------------------------------------------------- /src/lib/compile.mli: -------------------------------------------------------------------------------- 1 | (** Compilers of the {!EDSL.t} values. *) 2 | 3 | (** {3 Pretty-printing Output} *) 4 | 5 | val pp_hum : Format.formatter -> 'a EDSL.t -> unit 6 | (** Pretty print a Genspio expression with the {!Format} module. *) 7 | 8 | val to_string_hum : 'a EDSL.t -> string 9 | (** Pretty print a Genspio expression to [string]. *) 10 | 11 | val to_one_line_hum : 'a EDSL.t -> string 12 | (** Like [to_string_hum] but avoiding new-lines. *) 13 | 14 | (** {3 Compilation to POSIX Shell Scripts} *) 15 | 16 | (** Compiler from {!EDSL.t} to POSIX shell scripts (one-liners or 17 | multiline scripts). *) 18 | module To_posix : sig 19 | (** When a compiled script runs into an error, these details are 20 | accessible to the user. *) 21 | type internal_error_details = Standard_compiler.internal_error_details = 22 | { variable: string 23 | (** The incriminated issue was stored in a shell variable. *) 24 | ; content: string (** The shell-code that produced the [variable]. *) 25 | ; code: string (** Pretty-printed version of the above EDSL code. *) } 26 | 27 | (** The kinds of messages that can be output or stored before 28 | exiting a script. *) 29 | type death_message = Standard_compiler.death_message = 30 | | User of string 31 | (** The argument of the {!EDSL.fail} is the “user” case. *) 32 | | C_string_failure of internal_error_details 33 | (** The checking that a byte-array {i is} a C-String can fail when 34 | the byte-array contains ['\x00']. *) 35 | | String_to_int_failure of internal_error_details 36 | (** {!string_to_int} can obviously fail.*) 37 | 38 | (** When failing (either with {!EDSL.fail} or because of internal 39 | reasons) the compiler uses a customizable function to output the “error” 40 | message and then quiting the process. *) 41 | type death_function = comment_stack:string list -> death_message -> string 42 | 43 | (** The potential compilation error. *) 44 | type compilation_error = Standard_compiler.compilation_error = 45 | { error: 46 | [ `No_fail_configured of death_message 47 | (** Argument of the 48 | {!death_function}. *) 49 | | `Max_argument_length of string (** Incriminated argument. *) 50 | | `Not_a_c_string of string (** The actual problematic string. *) ] 51 | (** Error description. *) 52 | ; code: string option (** Chunk of relevant, pretty-printed EDSL code. *) 53 | ; comment_backtrace: string list 54 | (** Stack of `Comment` constructs at the point of the error. *) } 55 | 56 | val pp_error : Format.formatter -> compilation_error -> unit 57 | (** Printer for error values. *) 58 | 59 | val error_to_string : compilation_error -> string 60 | (** Convenience display of error values. *) 61 | 62 | (** Configuration of the compilation to POSIX shell scripts. *) 63 | type parameters = 64 | { style: [`Multi_line | `One_liner] 65 | (** The kind of script to output: in one-liners sequences are 66 | separated with [";"], in multi-line scripts, sequences are 67 | separated with new lines. *) 68 | ; max_argument_length: int option 69 | (** A limit on the length of the literal command line arguments 70 | generated by the compiler. 71 | 72 | - [None] means “do not check.” 73 | - The default value for is [Some 100_000], meaning that ≥ 74 | 100 000 B arguments will make the compiler fail with an 75 | exception. *) 76 | ; fail_with: [`Kill of string | `Nothing | `Trap_and_kill of int * string] 77 | (** How to implement the [EDSL.fail] construct (which appears also 78 | internally e.g. when {!EDSL.to_c_string} fails.). 79 | 80 | - [`Nothing]: the compiler will fail to compile [fail] constructs. 81 | - [`Kill signal_name]: the compiler will store the “toplevel” 82 | process id of the script and {!EDSL.fail} will be trying to 83 | kill the script with the signal [signal_name] 84 | (e.g. ["USR2"]). 85 | - [`Trap_and_kill (exit_status, signal_name)]: the 86 | {!EDSL.fail} construct will kill the script with 87 | [signal_name] {b and} the signal will be caught with the 88 | POSIX ["trap"] command in order to exit with [exit_status]. 89 | *) 90 | ; print_failure: death_function 91 | (** How to deal with the {!death_message} in case of failure. 92 | The function should return a shell command, like the result of 93 | compiling a [unit EDSL.t] expression or what {!Sys.command} 94 | can work with. *) 95 | } 96 | 97 | val failure_to_stderr : death_function 98 | (** The default {!death_function} just prints to [stderr]. *) 99 | 100 | val one_liner : parameters 101 | (** The default parameters for one-liners: {[ 102 | { 103 | style = `One_liner; 104 | max_argument_length = Some 100_000; 105 | fail_with = `Trap_and_kill (78, "USR2"); 106 | print_failure = failure_to_stderr; 107 | }]} *) 108 | 109 | val multi_line : parameters 110 | (** The default parameters for multi-liners (similar to {!one_liner}). *) 111 | 112 | val default_options : parameters 113 | (** The default value for [?option] in {!string}, which is {!one_liner}. *) 114 | 115 | val string : 116 | ?options:parameters -> 'a EDSL.t -> (string, compilation_error) result 117 | (** Compile a Genspio expression to a POSIX shell “phrase” 118 | (one-liner or multi-line) according to the [?options] (see 119 | {!parameters}). 120 | *) 121 | end 122 | 123 | (** Compile {!EDSL.t} values to much slower but more portable scripts 124 | (which use temporary-files). 125 | 126 | Usage example: 127 | {[ 128 | let expression = 129 | Genspio.EDSL.(printf (str "Hello %s\\n") [get_stdout (exec ["whoami"])]) 130 | in 131 | let (compiled : Genspio.Compile.To_slow_flow.Script.t) = 132 | Genspio.Compile.To_slow_flow.compile expression 133 | in 134 | let outchan = open_out "/tmp/my-script.sh" in 135 | Format.fprintf 136 | (Format.formatter_of_out_channel outchan) 137 | "#!/bin/sh\n\n%a\n" 138 | Genspio.Compile.To_slow_flow.Script.pp_posix compiled; 139 | close_out outchan 140 | ]} 141 | 142 | *) 143 | module To_slow_flow : sig 144 | (** The result of {!compile} function is a {!Script.t}. *) 145 | module Script : sig 146 | type t 147 | 148 | val pp_posix : Format.formatter -> t -> unit 149 | (** Print the value as a POSIX shell script. *) 150 | end 151 | 152 | val compile : 153 | ?default_tmpdir:[`Fresh | `Use of string] 154 | -> ?signal_name:string 155 | -> ?trap:[`Exit_with of int | `None] 156 | -> 'a EDSL.t 157 | -> Script.t 158 | (** Compile and {!EDSL.t} value to a script. 159 | 160 | - [?default_tmpdir]: set the value of the of the directory to 161 | create temporary files in, generated scripts still obey the 162 | ["$TMPDIR"] variable which takes precedence (default: [`Fresh] 163 | which means that it will create a fresh directory within 164 | ["/tmp"]). 165 | - [?trap]: whether to setup a call to ["trap"] to handle the 166 | calls to [fail] (default: [`Exit_with 77])). 167 | - [?signal_name]: if [trap] is not [`None], this is the signal 168 | to use to self-kill the script on calling [fail] (default: 169 | ["USR1"]). 170 | *) 171 | end 172 | 173 | (** {3 Legacy API} 174 | 175 | These functions are here for backwards compatibility, please use now 176 | the {!To_posix} module. 177 | 178 | *) 179 | 180 | val default_max_argument_length : int option 181 | (** See argument [?max_argument_length] of {!to_one_liner}. *) 182 | 183 | val to_one_liner : 184 | ?max_argument_length:int option -> ?no_trap:bool -> 'a EDSL.t -> string 185 | (** Compile a Genspio expression to a single-line POSIX shell command. 186 | 187 | The shell command starts by using ["trap"] to allow the script to 188 | abort thorugh the {!EDSL.fail} construct; one can avoid this setup 189 | with [~no_trap:true] 190 | 191 | If [~no_trap:true] is used and the script used the {!EDSL.fail} 192 | construct, [to_one_liner] fails with an exception. 193 | {[ 194 | utop # Genspio.Compile.to_one_liner 195 | ~no_trap:true 196 | Genspio.EDSL.( 197 | seq [ 198 | eprintf (str "Hello\\n") []; 199 | fail "Foo" 200 | ]);; 201 | Exception: 202 | Failure 203 | "Error: Call to `fail (user Foo)` while no “die” command is configured.; 204 | Code: NONE; Comment-backtrace: [] ". 205 | ]} 206 | 207 | The default value for [max_argument_length] is 208 | {!default_max_argument_length} ([Some 100_000]); it is a limit on 209 | the length of the literal command line arguments generated by the compiler. 210 | [None] means “do not check.” 211 | 212 | If the compilation fails, the function raises a [Failure] 213 | exception containing the error message. 214 | *) 215 | 216 | val to_many_lines : 217 | ?max_argument_length:int option -> ?no_trap:bool -> 'a EDSL.t -> string 218 | (** Compile a Genspio expression to a multi-line POSIX shell script, 219 | slightly more readable than {!to_one_liner}. 220 | *) 221 | 222 | val quick_run_exn : 223 | ?max_argument_length:int option -> ?no_trap:bool -> 'a EDSL.t -> unit 224 | (** Compile an expression and use [Sys.command] on it; if the overall 225 | command does not return 0 an exception is raised. *) 226 | -------------------------------------------------------------------------------- /src/examples/small.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | 3 | let examples = ref ([] : (Caml.out_channel -> unit) list) 4 | 5 | let example ?show name description code = 6 | let f o = 7 | Caml.Printf.fprintf o 8 | "let () = examples := Example.make ~ocaml:%S %s %S %S %s :: !examples\n" 9 | code 10 | (match show with None -> "" | Some s -> Fmt.str "~show:%s" s) 11 | name description code in 12 | examples := f :: !examples 13 | 14 | let intro_blob = 15 | "EDSL Usage Examples\n\ 16 | ===================\n\n\ 17 | The following examples show gradually complex uses of the EDSL.\n" 18 | 19 | let () = 20 | example "Exec" "Simple call to the `exec` construct." 21 | {ocaml| 22 | Genspio.EDSL.( 23 | exec ["ls"; "-la"] 24 | ) 25 | |ocaml} 26 | 27 | let () = 28 | example "Exec with Comment" ~show:"[`Pretty_printed; `Compiled]" 29 | "Adding comments with the `%%%` operator, we can see them in the compiled \ 30 | output." 31 | {ocaml| 32 | Genspio.EDSL.( 33 | "This is a very simple command" %%% 34 | exec ["ls"; "-la"] 35 | ) 36 | |ocaml} 37 | 38 | let () = 39 | example ~show:"[`Stderr]" "Failure with Comment" 40 | "When an expression is wrapped with *“comments”* they also appear in some \ 41 | error messages (compilation *and* run-time when using the default \ 42 | compiler) as “the comment stack.”" 43 | {ocaml| 44 | Genspio.EDSL.( 45 | "This is a very simple comment" %%% seq [ 46 | exec ["ls"; "-la"]; 47 | "This comment provides a more precise pseudo-location" %%% seq [ 48 | (* Here we use the `fail` EDSL facility: *) 49 | fail "asserting False ☺"; 50 | ]; 51 | ] 52 | ) 53 | |ocaml} 54 | 55 | let () = 56 | example "Call a command with Shell-Strings" ~show:"[`Stdout; `Pretty_printed]" 57 | "The `call` construct is a more general version of `exec` that can take \ 58 | any EDSL string. As with `exec` the string will be checked for C-String \ 59 | compatibilty, hence the calls to `byte-array-to-c-string` in the \ 60 | pretty-printed output." 61 | {ocaml| 62 | Genspio.EDSL.( 63 | call [ 64 | str "echo"; 65 | Str.concat_list [str "foo"; str "bar"]; (* A concatenation at run-time. *) 66 | ] 67 | ) 68 | |ocaml} 69 | 70 | let () = 71 | example "C-String Compilation Failure" ~show:"[]" 72 | "When a string literal cannot be converted to a “C-String” the default \ 73 | compiler tries to catch the error at compile-time." 74 | {ocaml| 75 | Genspio.EDSL.( 76 | "A sequence that will fail" %%% seq [ 77 | call [str "ls"; str "foo\x00bar"]; (* A string containing `NUL` *) 78 | ] 79 | ) 80 | |ocaml} 81 | 82 | let () = 83 | example "Playing with the output of a command" 84 | ~show:"[`Pretty_printed; `Stdout]" 85 | {md|Here we use the constructs: 86 | 87 | ```ocaml 88 | val get_stdout : unit t -> str t 89 | val (||>) : unit t -> unit t -> unit t 90 | ``` 91 | 92 | We use `let (s : …) = …` to show the types. 93 | 94 | We then “pipe” the output to another `exec` call with `||>` (which is 95 | a 2-argument shortcut for `EDSL.pipe`). 96 | |md} 97 | {ocaml| 98 | Genspio.EDSL.( 99 | let (s : str t) = get_stdout (exec ["cat"; "README.md"]) in 100 | call [str "printf"; str "%s"; s] ||> exec ["wc"; "-l"]; 101 | ) 102 | |ocaml} 103 | 104 | let () = 105 | example "Feeding a string to a command's stdin" 106 | ~show:"[`Pretty_printed; `Stdout]" 107 | "The operator `>>` puts any byte-array into the `stdin` of any `unit t` \ 108 | expression." 109 | {ocaml| 110 | Genspio.EDSL.( 111 | (* Let's see wether `wc -l` is fine with a NUL in the middle of a “line:” *) 112 | str "one\ntwo\nth\000ree\n" >> exec ["wc"; "-l"]; 113 | ) 114 | |ocaml} 115 | 116 | let () = 117 | example "Comparing byte-arrays, using conditionals" 118 | ~show:"[`Pretty_printed; `Stdout]" 119 | "We show that `str .. >> cat` is not changing anything and we try \ 120 | `if_seq`; a version of `EDSL.if_then_else` more practical for \ 121 | sequences/imperative code." 122 | {ocaml| 123 | Genspio.EDSL.( 124 | (* With a 🐱: *) 125 | let original = str "one\ntwo\nth\000ree\n" in 126 | let full_cycle = original >> exec ["cat"] |> get_stdout in 127 | if_seq 128 | Str.(full_cycle =$= original) 129 | ~t:[ 130 | exec ["echo"; "They are the same"]; 131 | ] 132 | ~e:[ 133 | exec ["echo"; "They are NOT the same"]; 134 | ] 135 | ) 136 | |ocaml} 137 | 138 | let () = 139 | example "“While” loops" ~show:"[`Stdout]" 140 | "The default and simplest loop construct is `loop_while`, the EDSL has \ 141 | also a simple API to manage temporary files and use them as \ 142 | pseudo-global-variables." 143 | {ocaml| 144 | Genspio.EDSL.( 145 | let tmp = tmp_file "genspio-example" in 146 | let body = 147 | seq [ 148 | if_then_else Str.(tmp#get =$= str "") 149 | (tmp#set (str "magic-")) 150 | (if_then_else Str.(tmp#get =$= str "magic-") 151 | (tmp#append (str "string")) 152 | nop); 153 | call [str "printf"; str "Currently '%s'\\n"; tmp#get]; 154 | ] in 155 | seq [ 156 | tmp#set (str ""); 157 | loop_while Str.(tmp#get <$> str "magic-string") ~body 158 | ] 159 | ) 160 | |ocaml} 161 | 162 | let () = 163 | example "Arbitrary Redirections" ~show:"[`Pretty_printed; `Stdout]" 164 | {md|The function `EDSL.with_redirections` follows POSIX's `exec` 165 | [semantics](http://pubs.opengroup.org/onlinepubs/9699919799/utilities/V3_chap02.html#exec). 166 | 167 | The `printf` call will output to the file `/tmp/genspio-two` because 168 | redirections are set in that order: 169 | 170 | - file-descriptor `3` is set to output to `/tmp/genspio-one`, 171 | - file-descriptor `3` is *then* set to output to `/tmp/genspio-two` 172 | (overriding the previous redirection), 173 | - file-descriptor `2` is redirected to file-descriptor `3`, 174 | - file-descriptor `1` is redirected to file-descriptor `2`, 175 | - then, `printf` outputs to `1`. 176 | |md} 177 | {ocaml| 178 | Genspio.EDSL.( 179 | seq [ 180 | with_redirections (exec ["printf"; "%s"; "hello"]) [ 181 | to_file (int 3) (str "/tmp/genspio-one"); 182 | to_file (int 3) (str "/tmp/genspio-two"); 183 | to_fd (int 2) (int 3); 184 | to_fd (int 1) (int 2); 185 | ]; 186 | call [str "printf"; str "One: '%s'\\nTwo: '%s'\\n"; 187 | exec ["cat"; "/tmp/genspio-one"] |> get_stdout; 188 | exec ["cat"; "/tmp/genspio-two"] |> get_stdout]; 189 | ] 190 | ) 191 | |ocaml} 192 | 193 | let () = 194 | example "Lists" ~show:"[`Pretty_printed; `Stdout]" 195 | {md|The module `EList` provides lists within the EDSL. 196 | 197 | |md} 198 | {ocaml| 199 | Genspio.EDSL.( 200 | let l = Elist.make [ 201 | str "One"; 202 | str "Two"; 203 | ] in 204 | Elist.iter l ~f:begin fun current -> 205 | printf (str "Current: %s\\n") [current ()]; 206 | end 207 | ) 208 | |ocaml} 209 | 210 | let () = 211 | example "Loop until something is true" ~show:"[`Stdout]" 212 | {md|The EDSL also provides high-level utilities implemented with 213 | the API (like a standard library). 214 | 215 | Here is an example with `loop_until_true` that fails after 4 attempts 216 | (i.e. (4 - 1) × 1 = 3 seconds), 217 | unless there is line containing `godot` in `/etc/passwd`. 218 | 219 | We customize the output with an `~on_failed_attempt` function that (on 220 | most terminals) erases the previous display (with `\r`). 221 | 222 |
226 | 227 | |md} 228 | {ocaml| 229 | Genspio.EDSL.( 230 | let the_condition who = 231 | exec ["cat"; "/etc/passwd"] ||> exec ["grep"; "^" ^ who] 232 | |> returns ~value:0 233 | in 234 | let the_wait who = 235 | loop_until_true 236 | ~attempts:4 237 | ~sleep:1 238 | ~on_failed_attempt:(fun nth -> 239 | printf (str "\rWaiting for '%s: %s-th attempt.") 240 | [str who; Integer.to_str nth]) 241 | (the_condition who) 242 | in 243 | if_seq (the_wait "godot") ~t:[ 244 | printf (str "It was worth waiting\\n") []; 245 | ] 246 | ~e:[ 247 | printf (str "It was NOT worth waiting\\n") []; 248 | ] 249 | ) 250 | |ocaml} 251 | 252 | let () = 253 | example "Check Sequence" ~show:"[`Stdout]" 254 | {md|Another function from the “extra constructs:” 255 | [`check_sequence`](genspio/Genspio/EDSL/index.html#val-check_sequence). 256 | 257 | We customize its output with the `~verbosity` (by adding a nice prompt) and 258 | `~on_success` arguments. 259 | |md} 260 | {ocaml| 261 | Genspio.EDSL.( 262 | check_sequence 263 | ~verbosity:(`Announce "♦ Check-seq-example → ") (* Try also `Output_all or `Silent *) 264 | ~on_success:begin fun ~step:(name, expr) ~stdout ~stderr -> 265 | let code = Genspio.Compile.to_one_line_hum expr in 266 | printf (str " ↳ Extra “On Success” for command `%s`\\n\ 267 | \ code: `%s`\\n\ 268 | \ stdout: `%s`\\n\ 269 | \ stderr: `%s`\\n") 270 | [str name; str code; stdout; stderr] 271 | end 272 | [ 273 | "This will succeed", exec ["ls"; "/tmp"]; 274 | "This too", exec ["ls"; "/"]; 275 | "BUT NOT THIS", exec ["ls"; "/somecrazy path"]; 276 | "This won't happen", exec ["ls"; "/etc"]; 277 | ] 278 | ) 279 | |ocaml} 280 | 281 | let () = 282 | example "Read `stdin` Line by Line" ~show:"[`Stdout]" 283 | {md|Let's try now the 284 | [`on_stdin_lines`](genspio/Genspio/EDSL/index.html#val-on_stdin_lines) 285 | function, to read a *stream* of lines. 286 | 287 | Note that for the word “lines” to really make sense, the input should 288 | be proper “text,” in the example below the `'\000'` character is just 289 | silently forgotten, not counted. 290 | |md} 291 | {ocaml| 292 | Genspio.EDSL.( 293 | printf (str "123\\n12345\\n1234\\00056\\n12\\n") [] 294 | ||> on_stdin_lines begin fun line -> 295 | printf (str "→ %s bytes\\n") 296 | [line 297 | >> exec ["wc"; "-c"] ||> exec ["tr"; "-d"; "\\n"] 298 | |> get_stdout] 299 | end 300 | ) 301 | |ocaml} 302 | 303 | (******************************************************************************) 304 | 305 | let () = 306 | let open Caml in 307 | let open Printf in 308 | let o = open_out Sys.argv.(1) in 309 | fprintf o "%s" 310 | {ocaml| 311 | open! Base 312 | open Tests.Test_lib 313 | 314 | let examples = ref [] 315 | |ocaml} ; 316 | fprintf o "let () = Fmt.pr \"%%s\" %S\n" intro_blob ; 317 | Base.List.iter (List.rev !examples) ~f:(fun f -> f o) ; 318 | fprintf o "%s" 319 | {ocaml| 320 | let () = 321 | List.iter (List.rev !examples) ~f:(Example.run Caml.Format.std_formatter) 322 | |ocaml} ; 323 | close_out o ; 324 | printf "%s: Done.\n%!" Sys.argv.(0) 325 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "{}" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright {yyyy} {name of copyright owner} 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | 203 | -------------------------------------------------------------------------------- /src/lib/language.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | 3 | (* Here we use the legacy module (too much code to change at once): *) 4 | module Format = Caml.Format 5 | 6 | type c_string = C_string 7 | type byte_array = Byte_Array 8 | 9 | module Literal = struct 10 | type _ t = 11 | | Int : int -> int t 12 | | String : string -> byte_array t 13 | | Bool : bool -> bool t 14 | 15 | let pp : type a. _ -> a t -> unit = 16 | let open Fmt in 17 | fun fmt -> function 18 | | Int i -> pf fmt "@[(int@ %d)@]" i 19 | | String s -> pf fmt "@[(string@ %S)@]" s 20 | | Bool b -> pf fmt "@[(bool@ %b)@]" b 21 | 22 | module Str = struct 23 | let easy_to_escape s = 24 | String.for_all s ~f:(function 25 | | 'a' .. 'z' 26 | |'A' .. 'Z' 27 | |'0' .. '9' 28 | |'-' | '_' | '*' | '&' | '^' | '=' | '+' | '%' | '$' | '"' | '\'' 29 | |'/' | '#' | '@' | '!' | ' ' | '~' | '`' | '\\' | '|' | '?' | '>' 30 | |'<' | '.' | ',' | ':' | ';' | '{' | '}' | '(' | ')' | '[' | ']' -> 31 | true 32 | | _ -> false ) 33 | 34 | let impossible_to_escape_for_variable = String.exists ~f:Char.(( = ) '\x00') 35 | end 36 | end 37 | 38 | type raw_command_annotation = .. 39 | type raw_command_annotation += Magic_unit 40 | 41 | type fd_redirection = 42 | { take: int t 43 | ; redirect_to: [`Path of c_string t | `Fd of int t (* | `Input_of of unit t *)] 44 | } 45 | 46 | and _ t = 47 | | Exec : c_string t list -> unit t 48 | | Raw_cmd : (raw_command_annotation option * string) -> 'a t 49 | | Bool_operator : bool t * [`And | `Or] * bool t -> bool t 50 | | String_operator : byte_array t * [`Eq | `Neq] * byte_array t -> bool t 51 | | Not : bool t -> bool t 52 | | Returns : {expr: 'a t; value: int} -> bool t 53 | | No_op : unit t 54 | | If : bool t * unit t * unit t -> unit t 55 | | Seq : unit t list -> unit t 56 | | Literal : 'a Literal.t -> 'a t 57 | | Output_as_string : unit t -> byte_array t 58 | | Redirect_output : unit t * fd_redirection list -> unit t 59 | | Write_output : 60 | { expr: unit t 61 | ; stdout: c_string t option 62 | ; stderr: c_string t option 63 | ; return_value: c_string t option } 64 | -> unit t 65 | | Feed : byte_array t * unit t -> unit t 66 | | Pipe : unit t list -> unit t 67 | | While : {condition: bool t; body: unit t} -> unit t 68 | | Fail : string -> unit t 69 | | Int_to_string : int t -> c_string t 70 | | String_to_int : c_string t -> int t 71 | | Bool_to_string : bool t -> c_string t 72 | | String_to_bool : c_string t -> bool t 73 | | List_to_string : 'a list t * ('a t -> byte_array t) -> byte_array t 74 | | String_to_list : byte_array t * (byte_array t -> 'a t) -> 'a list t 75 | | List : 'a t list -> 'a list t 76 | | C_string_concat : c_string list t -> c_string t 77 | | Byte_array_concat : byte_array list t -> byte_array t 78 | | List_append : ('a list t * 'a list t) -> 'a list t 79 | | List_iter : 'a list t * ((unit -> 'a t) -> unit t) -> unit t 80 | | Byte_array_to_c_string : byte_array t -> c_string t 81 | | C_string_to_byte_array : c_string t -> byte_array t 82 | | Int_bin_op : int t * [`Plus | `Minus | `Mult | `Div | `Mod] * int t -> int t 83 | | Int_bin_comparison : 84 | int t * [`Eq | `Ne | `Gt | `Ge | `Lt | `Le] * int t 85 | -> bool t 86 | | Getenv : c_string t -> c_string t 87 | (* See [man execve]. *) 88 | | Setenv : c_string t * c_string t -> unit t 89 | | Comment : string * 'a t -> 'a t 90 | 91 | let pp_in_expr fmt pp = 92 | let open Format in 93 | pp_open_box fmt 2 ; fprintf fmt "(%a)" pp () ; pp_close_box fmt () ; () 94 | 95 | let pp_fun_call fmt name pp_arg args = 96 | let open Format in 97 | pp_open_box fmt 2 ; 98 | fprintf fmt "(%s@ %a)" name 99 | (pp_print_list ~pp_sep:(fun fmt () -> pp_print_space fmt ()) pp_arg) 100 | args ; 101 | pp_close_box fmt () ; 102 | () 103 | 104 | let rec pp : type a. Format.formatter -> a t -> unit = 105 | let open Format in 106 | fun fmt -> function 107 | | Exec l -> pp_fun_call fmt "exec" pp l 108 | | Raw_cmd (_, s) -> 109 | pp_fun_call fmt "raw-command" (fun fmt -> fprintf fmt "%S") [s] 110 | | Bool_operator (a, op, b) -> 111 | pp_fun_call fmt (match op with `And -> "and" | `Or -> "or") pp [a; b] 112 | | String_operator (a, op, b) -> 113 | pp_fun_call fmt 114 | (match op with `Eq -> "string-eq" | `Neq -> "string-neq") 115 | pp [a; b] 116 | | Int_bin_comparison (a, op, b) -> 117 | let sop = 118 | match op with 119 | | `Eq -> "int-eq" 120 | | `Ne -> "int-neq" 121 | | `Gt -> "gt" 122 | | `Ge -> "ge" 123 | | `Lt -> "lt" 124 | | `Le -> "le" in 125 | pp_fun_call fmt sop pp [a; b] 126 | | Int_bin_op (a, op, b) -> 127 | let sop = 128 | match op with 129 | | `Plus -> "+" 130 | | `Minus -> "-" 131 | | `Mult -> "×" 132 | | `Div -> "÷" 133 | | `Mod -> "%" in 134 | pp_fun_call fmt sop pp [a; b] 135 | | Not b -> pp_fun_call fmt "not" pp [b] 136 | | Returns {expr; value: int} -> 137 | pp_fun_call fmt (sprintf "returns-{%d}" value) pp [expr] 138 | | No_op -> fprintf fmt "(noop)" 139 | | If (c, t, e) -> 140 | pp_open_box fmt 1 ; 141 | fprintf fmt "(if@ %a@ then: %a@ else: %a)" pp c pp t pp e ; 142 | pp_close_box fmt () 143 | | Seq l -> pp_fun_call fmt "seq" pp l 144 | | Literal l -> Literal.pp fmt l 145 | | Output_as_string u -> pp_fun_call fmt "as-string" pp [u] 146 | | Redirect_output (u, l) -> 147 | let redirs fmt {take; redirect_to} = 148 | fprintf fmt "@[(%a@ >@ %a)@]" pp take 149 | (fun fmt -> function 150 | | `Fd f -> fprintf fmt "%a" pp f 151 | | `Path f -> fprintf fmt "%a" pp f ) 152 | redirect_to in 153 | pp_in_expr fmt (fun fmt () -> 154 | fprintf fmt "redirect@ %a@ %a" pp u 155 | (pp_print_list ~pp_sep:pp_print_space redirs) 156 | l ) 157 | | Write_output {expr; stdout; stderr; return_value} -> 158 | let o name fmt opt = 159 | match opt with 160 | | None -> () 161 | | Some c -> fprintf fmt "@ @[(%s → %a)@]" name pp c in 162 | pp_in_expr fmt (fun fmt () -> 163 | fprintf fmt "write-output@ %a%a%a%a" pp expr (o "stdout") stdout 164 | (o "stderr") stderr (o "return-value") return_value ) 165 | | Feed (s, u) -> 166 | pp_in_expr fmt (fun fmt () -> fprintf fmt "%a@ >>@ %a" pp s pp u) 167 | | Pipe l -> 168 | pp_in_expr fmt (fun fmt () -> 169 | fprintf fmt "pipe:@ %a" 170 | (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@ |@ ") pp) 171 | l ) 172 | | While {condition; body} -> 173 | pp_in_expr fmt (fun fmt () -> 174 | fprintf fmt "while@ %a@ do:@ %a" pp condition pp body ) 175 | | Fail s -> pp_in_expr fmt (fun fmt () -> fprintf fmt "FAIL@ %S" s) 176 | | Int_to_string i -> pp_fun_call fmt "int-to-string" pp [i] 177 | | String_to_int i -> pp_fun_call fmt "string-to-int" pp [i] 178 | | Bool_to_string b -> pp_fun_call fmt "bool-to-string" pp [b] 179 | | String_to_bool b -> pp_fun_call fmt "string-to-bool" pp [b] 180 | | List_to_string (l, _) -> pp_fun_call fmt "list-to-string" pp [l] 181 | (* : 'a list t * ('a t -> byte_array t) -> byte_array t *) 182 | | String_to_list (s, _) -> pp_fun_call fmt "string-to-list" pp [s] 183 | | List l -> pp_fun_call fmt "list" pp l 184 | | C_string_concat t -> pp_fun_call fmt "c-string-concat" pp [t] 185 | | Byte_array_concat t -> pp_fun_call fmt "byte-array-concat" pp [t] 186 | | List_append (la, lb) -> pp_fun_call fmt "list-append" pp [la; lb] 187 | | List_iter (l, f) -> 188 | let body = f (fun () -> Raw_cmd (None, "VARIABLE")) in 189 | pp_open_box fmt 1 ; 190 | fprintf fmt "(list-iter@ list: %a@ f: @[(fun VARIABLE ->@ %a)@])" 191 | pp l pp body ; 192 | pp_close_box fmt () 193 | (* : 'a list t * ((unit -> 'a t) -> unit t) -> unit t *) 194 | | Byte_array_to_c_string ba -> 195 | pp_fun_call fmt "byte-array-to-c-string" pp [ba] 196 | | C_string_to_byte_array c -> pp_fun_call fmt "c-string-to-byte-array" pp [c] 197 | | Getenv s -> pp_fun_call fmt "getenv" pp [s] 198 | | Setenv (s, v) -> pp_fun_call fmt "setenv" pp [s; v] 199 | | Comment (cmt, expr) -> 200 | fprintf fmt "@[(comment@ %S@ %a)@]" cmt pp expr 201 | 202 | module Construct = struct 203 | let to_c_string ba = Byte_array_to_c_string ba 204 | let to_byte_array c = C_string_to_byte_array c 205 | 206 | module C_string = struct 207 | let equals a b = String_operator (to_byte_array a, `Eq, to_byte_array b) 208 | let ( =$= ) a b = String_operator (to_byte_array a, `Eq, to_byte_array b) 209 | let ( <$> ) a b = String_operator (to_byte_array a, `Neq, to_byte_array b) 210 | let to_byte_array c = C_string_to_byte_array c 211 | let to_bytes c = C_string_to_byte_array c 212 | let concat_elist l = C_string_concat l 213 | let concat_list sl = concat_elist (List sl) 214 | end 215 | 216 | module Byte_array = struct 217 | let ( =$= ) a b = String_operator (a, `Eq, b) 218 | let ( <$> ) a b = String_operator (a, `Neq, b) 219 | let to_c_string ba = Byte_array_to_c_string ba 220 | let to_c ba = Byte_array_to_c_string ba 221 | end 222 | 223 | module Base = struct 224 | let literal l = Literal l 225 | let byte_array s = Literal.String s |> literal 226 | let int s = Literal.Int s |> literal 227 | let bool t = Literal.Bool t |> literal 228 | let c_string s = byte_array s |> to_c_string 229 | let string = c_string 230 | let exec l = Exec (List.map l ~f:(fun s -> string s)) 231 | let call l = Exec l 232 | let ( &&& ) a b = Bool_operator (a, `And, b) 233 | let ( ||| ) a b = Bool_operator (a, `Or, b) 234 | let returns expr ~value = Returns {expr; value} 235 | let succeeds expr = returns expr ~value:0 236 | let nop = No_op 237 | let if_then_else a b c = If (a, b, c) 238 | let if_then a b = if_then_else a b nop 239 | let seq l = Seq l 240 | let not t = Not t 241 | let fail s = Fail s 242 | let comment s u = Comment (s, u) 243 | let ( %%% ) s u = comment s u 244 | 245 | let make_switch : (bool t * unit t) list -> default:unit t -> unit t = 246 | fun conds ~default -> 247 | List.fold_right conds ~init:default ~f:(fun (x, body) prev -> 248 | if_then_else x body prev ) 249 | 250 | let write_output ?stdout ?stderr ?return_value expr = 251 | Write_output {expr; stdout; stderr; return_value} 252 | 253 | let write_stdout ~path expr = write_output expr ~stdout:path 254 | let to_fd take fd = {take; redirect_to= `Fd fd} 255 | let to_file take file = {take; redirect_to= `Path file} 256 | let with_redirections cmd l = Redirect_output (cmd, l) 257 | let file_exists p = call [c_string "test"; c_string "-f"; p] |> succeeds 258 | let getenv v = Getenv v 259 | let setenv ~var v = Setenv (var, v) 260 | let get_stdout e = Output_as_string e 261 | let feed ~string e = Feed (string, e) 262 | let ( >> ) string e = feed ~string e 263 | let pipe l = Pipe l 264 | let ( ||> ) a b = Pipe [a; b] 265 | let loop_while condition ~body = While {condition; body} 266 | let loop_seq_while condition body = While {condition; body= Seq body} 267 | let byte_array_concat_list l = Byte_array_concat l 268 | end 269 | 270 | include Base 271 | 272 | module Bool = struct 273 | let of_string s = String_to_bool s let to_string b = Bool_to_string b 274 | end 275 | 276 | module Integer = struct 277 | let to_string i = Int_to_string i 278 | let to_byte_array i = C_string_to_byte_array (Int_to_string i) 279 | let of_string s = String_to_int s 280 | let of_byte_array s = String_to_int (Byte_array_to_c_string s) 281 | let bin_op a o b = Int_bin_op (a, o, b) 282 | let add a b = bin_op a `Plus b 283 | let ( + ) = add 284 | let sub a b = bin_op a `Minus b 285 | let ( - ) = sub 286 | let mul a b = bin_op a `Mult b 287 | let ( * ) = mul 288 | let div a b = bin_op a `Div b 289 | let ( / ) = div 290 | let modulo a b = bin_op a `Mod b 291 | let ( mod ) = modulo 292 | let cmp op a b = Int_bin_comparison (a, op, b) 293 | let eq = cmp `Eq 294 | let ne = cmp `Ne 295 | let lt = cmp `Lt 296 | let le = cmp `Le 297 | let ge = cmp `Ge 298 | let gt = cmp `Gt 299 | let ( = ) = eq 300 | let ( <> ) = ne 301 | let ( < ) = lt 302 | let ( <= ) = le 303 | let ( >= ) = ge 304 | let ( > ) = gt 305 | end 306 | 307 | module Magic = struct let unit s : unit t = Raw_cmd (Some Magic_unit, s) end 308 | 309 | module Elist = struct 310 | let make l = List l 311 | let append la lb = List_append (la, lb) 312 | let iter l ~f = List_iter (l, f) 313 | let to_string f l = List_to_string (l, f) 314 | let of_string f l = String_to_list (l, f) 315 | 316 | let serialize_byte_array_list : byte_array list t -> byte_array t = 317 | to_string (fun e -> e) 318 | 319 | let deserialize_to_byte_array_list : byte_array t -> byte_array list t = 320 | of_string (fun e -> e) 321 | 322 | let serialize_c_string_list : c_string list t -> byte_array t = 323 | to_string (fun e -> to_byte_array e) 324 | 325 | let deserialize_to_c_string_list : byte_array t -> c_string list t = 326 | of_string (fun e -> to_c_string e) 327 | 328 | let serialize_int_list : int list t -> byte_array t = 329 | to_string Integer.to_byte_array 330 | 331 | let deserialize_to_int_list : byte_array t -> int list t = 332 | of_string Integer.of_byte_array 333 | 334 | let to_string _ = `Do_not_use 335 | let of_string _ = `Do_not_use 336 | end 337 | end 338 | -------------------------------------------------------------------------------- /src/lib/EDSL_v0.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | 3 | type 'a t = 'a Language.t 4 | type c_string = Language.c_string 5 | type byte_array = Language.byte_array 6 | type fd_redirection = Language.fd_redirection 7 | 8 | let ( // ) = Caml.Filename.concat 9 | 10 | include Language.Construct 11 | 12 | let case condition body = `Case (condition, seq body) 13 | let default d = `Default (seq d) 14 | 15 | let switch l = 16 | let default = ref None in 17 | let cases = 18 | List.filter_map l ~f:(function 19 | | `Default _ when Poly.(!default <> None) -> 20 | failwith "Cannot build switch with >1 defaults" 21 | | `Default d -> 22 | default := Some d ; 23 | None 24 | | `Case t -> Some t ) in 25 | make_switch ~default:(Option.value ~default:nop !default) cases 26 | 27 | (* 28 | let string_list_to_string l = 29 | Elist.to_string ~f:(fun e -> to_byte_array e) l |> to_c_string 30 | 31 | let string_list_of_string s = 32 | Elist.of_string ~f:(fun e -> to_c_string e) (to_byte_array s) 33 | *) 34 | 35 | type file = 36 | < get: byte_array t 37 | ; get_c: c_string t 38 | ; set: byte_array t -> unit t 39 | ; set_c: c_string t -> unit t 40 | ; append: byte_array t -> unit t 41 | ; delete: unit t 42 | ; path: c_string t > 43 | 44 | let tmp_file ?tmp_dir name : file = 45 | let default_tmp_dir = "/tmp" in 46 | let get_tmp_dir = 47 | Option.value tmp_dir 48 | ~default: 49 | ( get_stdout 50 | ((* https://en.wikipedia.org/wiki/TMPDIR *) 51 | if_then_else 52 | C_string.(getenv (c_string "TMPDIR") <$> c_string "") 53 | (call 54 | [c_string "printf"; c_string "%s"; getenv (c_string "TMPDIR")] ) 55 | (exec ["printf"; "%s"; default_tmp_dir]) ) 56 | |> to_c_string ) in 57 | let path = 58 | let clean = 59 | String.map name ~f:(function 60 | | ('a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-') as c -> c 61 | | _ -> '_' ) in 62 | C_string.concat_list 63 | [ get_tmp_dir; c_string "/" 64 | ; c_string 65 | (Fmt.str "genspio-tmp-file-%s-%s" clean 66 | Caml.Digest.(string name |> to_hex) ) ] in 67 | let tmp = C_string.concat_list [path; string "-tmp"] in 68 | object (self) 69 | method get = get_stdout (call [string "cat"; path]) 70 | method get_c = self#get |> to_c_string 71 | method path = path 72 | 73 | method set v = 74 | seq 75 | [ (* call [string "echo"; string "Setting "; string name]; *) 76 | (* call [string "echo"; string "Setting "; path; string " to "; v]; *) 77 | (* call [string "echo"; tmp]; *) 78 | v >> exec ["cat"] |> write_output ~stdout:tmp 79 | ; call [string "mv"; string "-f"; tmp; path] ] 80 | 81 | method set_c c = self#set (to_byte_array c) 82 | 83 | method append v = 84 | seq 85 | [ seq [call [string "cat"; path]; v >> exec ["cat"]] 86 | |> write_output ~stdout:tmp 87 | ; call [string "mv"; string "-f"; tmp; path] ] 88 | 89 | method delete = call [string "rm"; string "-f"; path; tmp] 90 | end 91 | 92 | let if_seq ~t ?e c = 93 | match e with 94 | | None -> if_then c (seq t) 95 | | Some f -> if_then_else c (seq t) (seq f) 96 | 97 | let printf fmt l = call (string "printf" :: string "--" :: fmt :: l) 98 | let eprintf fmt l = with_redirections (printf fmt l) [to_fd (int 1) (int 2)] 99 | 100 | module Command_line = struct 101 | type 'a cli_option = {switches: string list; doc: string; default: 'a} 102 | 103 | type _ option_spec = 104 | | Opt_flag : bool t cli_option -> bool t option_spec 105 | | Opt_string : c_string t cli_option -> c_string t option_spec 106 | 107 | and (_, _) cli_options = 108 | | Opt_end : string -> ('a, 'a) cli_options 109 | | Opt_cons : 110 | 'c option_spec * ('a, 'b) cli_options 111 | -> ('c -> 'a, 'b) cli_options 112 | 113 | module Arg = struct 114 | let string ?(default = string "") ~doc switches = 115 | Opt_string {switches; doc; default} 116 | 117 | let flag ?(default = bool false) ~doc switches = 118 | Opt_flag {switches; doc; default} 119 | 120 | let ( & ) x y = Opt_cons (x, y) 121 | let usage s = Opt_end s 122 | end 123 | 124 | let parse (options : ('a, unit t) cli_options) 125 | (action : anon:c_string list t -> 'a) : unit t = 126 | let prefix = Common.Unique_name.variable "getopts" in 127 | let variable {switches; _} = 128 | Fmt.str "%s_%s" prefix 129 | ( String.concat ~sep:"" switches 130 | |> Caml.Digest.string |> Caml.Digest.to_hex ) in 131 | let inits = ref [] in 132 | let to_init s = inits := s :: !inits in 133 | let cases = ref [] in 134 | let to_case s = cases := s :: !cases in 135 | let help_intro = ref "" in 136 | let help = ref [] in 137 | let to_help s = help := s :: !help in 138 | let string_of_var var = getenv (string var) in 139 | let bool_of_var var = getenv (string var) |> Bool.of_string in 140 | let anon_tmp = 141 | Fmt.kstr tmp_file "parse-cli-%s" 142 | Caml.(Marshal.to_string options [] |> Digest.string |> Digest.to_hex) 143 | in 144 | let anon = anon_tmp#get |> Elist.deserialize_to_c_string_list in 145 | let applied_action = 146 | (* 147 | The [loop] function below is building 3 pieces of Genspio code at once: 148 | 149 | - variable initializations 150 | - individual case statements (including variable assignments) 151 | that are part of the ["while true { switch { .... } }"] loop 152 | that incrementally interprets each command line argument. 153 | - [applied_action] (of type [unit t]) is the 154 | the result of applying the [action] function to all the elements of 155 | [options] + the list of anonymous arguments. 156 | It is hence the (user-provided) code that uses the parsed arguments. 157 | The [loop] function builds the closure as the loop goes since 158 | [options] is a “difference list”, see also: 159 | {{:https://drup.github.io/2016/08/02/difflists/}Drup's blog post}. 160 | 161 | The 2 first items are agglomerated in the [inits] and [cases] 162 | references. 163 | *) 164 | let rec loop : type a b. a -> (a, b) cli_options -> b = 165 | fun f -> function 166 | | Opt_end doc -> 167 | help_intro := doc ; 168 | f 169 | | Opt_cons (Opt_string x, more) -> 170 | let var = variable x in 171 | to_init (setenv ~var:(string var) x.default) ; 172 | to_case 173 | (case 174 | (List.fold ~init:(bool false) x.switches ~f:(fun p s -> 175 | p ||| C_string.(c_string s =$= getenv (c_string "1")) ) ) 176 | [ if_seq 177 | C_string.(getenv (string "2") =$= string "") 178 | ~t: 179 | [ eprintf 180 | (string "ERROR option '%s' requires an argument\\n") 181 | [getenv (string "1")]; fail "Wrong command line" ] 182 | ~e:[setenv ~var:(string var) (getenv (string "2"))] 183 | ; exec ["shift"]; exec ["shift"] ] ) ; 184 | Fmt.kstr to_help "* `%s `: %s" 185 | (String.concat ~sep:"," x.switches) 186 | x.doc ; 187 | loop (f (string_of_var var)) more 188 | | Opt_cons (Opt_flag x, more) -> 189 | let var = variable x in 190 | to_init (setenv ~var:(string var) (Bool.to_string x.default)) ; 191 | to_case 192 | (case 193 | (List.fold ~init:(bool false) x.switches ~f:(fun p s -> 194 | p ||| C_string.equals (string s) (getenv (string "1")) ) 195 | ) 196 | [ setenv ~var:(string var) (Bool.to_string (bool true)) 197 | ; exec ["shift"] ] ) ; 198 | Fmt.kstr to_help "* `%s`: %s" 199 | (String.concat ~sep:"," x.switches) 200 | x.doc ; 201 | loop (f (bool_of_var var)) more in 202 | loop (action ~anon) options in 203 | let help_msg = 204 | Fmt.str "%s\n\nOptions:\n\n%s\n" !help_intro 205 | (String.concat ~sep:"\n" (List.rev !help)) in 206 | let help_flag_var = Fmt.kstr string "%s_help" prefix in 207 | let while_loop = 208 | let body = 209 | let append_anon_arg_to_list = 210 | seq 211 | [ anon_tmp#set 212 | ( Elist.append 213 | (anon_tmp#get |> Elist.deserialize_to_byte_array_list) 214 | (Elist.make [getenv (string "1") |> C_string.to_byte_array]) 215 | |> Elist.serialize_byte_array_list ) ] in 216 | let help_case = 217 | let help_switches = ["-h"; "-help"; "--help"] in 218 | case 219 | (List.fold ~init:(bool false) help_switches ~f:(fun p s -> 220 | p ||| C_string.(c_string s =$= getenv (c_string "1")) ) ) 221 | [ setenv ~var:help_flag_var (Bool.to_string (bool true)) 222 | ; byte_array help_msg >> exec ["cat"]; exec ["break"] ] in 223 | let dash_dash_case = 224 | case 225 | C_string.(getenv (c_string "1") =$= c_string "--") 226 | [ exec ["shift"] 227 | ; loop_while 228 | C_string.(getenv (c_string "#") <$> c_string "0") 229 | ~body:(seq [append_anon_arg_to_list; exec ["shift"]]) 230 | ; exec ["break"] ] in 231 | let anon_case = 232 | case 233 | C_string.(getenv (c_string "#") <$> c_string "0") 234 | [append_anon_arg_to_list; exec ["shift"]] in 235 | let default_case = default [exec ["break"]] in 236 | let cases = 237 | (help_case :: List.rev !cases) 238 | @ [dash_dash_case; anon_case; default_case] in 239 | seq [switch cases] in 240 | loop_while (bool true) ~body in 241 | seq 242 | [ setenv ~var:help_flag_var (Bool.to_string (bool false)) 243 | ; anon_tmp#set (Elist.serialize_byte_array_list (Elist.make [])) 244 | ; seq (List.rev !inits); while_loop 245 | ; if_then_else (bool_of_var (Fmt.str "%s_help" prefix)) nop applied_action 246 | ] 247 | end 248 | 249 | let loop_until_true ?(attempts = 20) ?(sleep = 2) 250 | ?(on_failed_attempt = 251 | fun nth -> printf (string "%d.") [Integer.to_string nth]) cmd = 252 | let intvar = 253 | let varname = string "C_ATTEMPTS" in 254 | object 255 | method set v = setenv ~var:varname (Integer.to_string v) 256 | method get = getenv varname |> Integer.of_string 257 | end in 258 | seq 259 | [ intvar#set (int 1) 260 | ; loop_while 261 | (Integer.(intvar#get <= int attempts) &&& not cmd) 262 | ~body: 263 | (seq 264 | [ on_failed_attempt intvar#get 265 | ; intvar#set Integer.(intvar#get + int 1) 266 | ; if_then 267 | Integer.(intvar#get <= int attempts) 268 | (exec ["sleep"; Fmt.str "%d" sleep]) ] ); exec ["printf"; "\\n"] 269 | ; if_then_else 270 | Integer.(intvar#get > int attempts) 271 | (seq 272 | [(* Fmt.str "Command failed %d times!" attempts; *) exec ["false"]] ) 273 | (seq [(* Fmt.str "Command failed %d times!" attempts; *) exec ["true"]]) 274 | ] 275 | |> returns ~value:0 276 | 277 | let silently u = 278 | let dev_null = string "/dev/null" in 279 | write_output ~stdout:dev_null ~stderr:dev_null u 280 | 281 | let succeeds_silently u = silently u |> succeeds 282 | let seq_and l = List.fold l ~init:(bool true) ~f:(fun u v -> u &&& succeeds v) 283 | 284 | let output_markdown_code tag f = 285 | seq 286 | [ exec ["printf"; Fmt.str "``````````%s\\n" tag]; f 287 | ; exec ["printf"; Fmt.str "\\n``````````\\n"] ] 288 | 289 | let cat_markdown tag file = output_markdown_code tag @@ call [string "cat"; file] 290 | 291 | let fresh_name suf = 292 | let x = 293 | object 294 | method v = 42 295 | end in 296 | Fmt.str "g-%d-%d-%s" (Caml.Oo.id x) (Random.int 100_000) suf 297 | 298 | let sanitize_name n = 299 | String.map n ~f:(function 300 | | ('0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' | '-') as c -> c 301 | | _ -> '_' ) 302 | 303 | let default_on_failure ~step:(i, _) ~stdout ~stderr = 304 | seq 305 | [ printf (Fmt.kstr c_string "Step '%s' FAILED:\\n" i) [] 306 | ; cat_markdown "stdout" stdout; cat_markdown "stderr" stderr; exec ["false"] 307 | ] 308 | 309 | let check_sequence ?(verbosity = `Announce ">> ") 310 | ?(on_failure = default_on_failure) 311 | ?(on_success = fun ~step:_ ~stdout:_ ~stderr:_ -> nop) ?(tmpdir = "/tmp") 312 | cmds = 313 | let tmp_prefix = fresh_name "-cmd" in 314 | let tmpout which id = 315 | c_string 316 | ( tmpdir 317 | // Fmt.str "genspio-check-sequence-%s-%s-%s" tmp_prefix which 318 | (sanitize_name id) ) in 319 | let stdout id = tmpout "stdout" id in 320 | let stderr id = tmpout "stderr" id in 321 | let log id u = 322 | match verbosity with 323 | | `Silent -> write_output ~stdout:(stdout id) ~stderr:(stderr id) u 324 | | `Announce prompt -> 325 | seq 326 | [ printf (Fmt.kstr c_string "%s %s\\n" prompt id) [] 327 | ; write_output ~stdout:(stdout id) ~stderr:(stderr id) u ] 328 | | `Output_all -> u in 329 | let check idx (nam, u) next = 330 | let id = Fmt.str "%d. %s" idx nam in 331 | if_seq 332 | (log id u |> succeeds) 333 | ~t:[on_success ~step:(id, u) ~stdout:(stdout id) ~stderr:(stderr id); next] 334 | ~e:[on_failure ~step:(id, u) ~stdout:(stdout id) ~stderr:(stderr id)] 335 | in 336 | let rec loop i = function 337 | | one :: more -> check i one (loop (i + 1) more) 338 | | [] -> exec ["true"] in 339 | loop 1 cmds 340 | 341 | let on_stdin_lines body = 342 | let fresh = Common.Unique_name.variable "read_stdin" in 343 | loop_while 344 | (exec ["read"; "-r"; fresh] |> succeeds) 345 | ~body:(seq [exec ["export"; fresh]; body (getenv (string fresh))]) 346 | -------------------------------------------------------------------------------- /src/test-lib/test_lib.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | 3 | let ( // ) = Caml.Filename.concat 4 | 5 | module Filename = Caml.Filename 6 | module Sys = Caml.Sys 7 | 8 | module Test = struct 9 | type t = 10 | | Exits of 11 | { no_trap: bool 12 | ; name: string 13 | ; args: string list 14 | ; returns: int 15 | ; script: unit Genspio.Language.t } 16 | 17 | let exits ?(no_trap = false) ?name ?(args = []) returns script = 18 | let name = Option.value name ~default:(Fmt.str "no-name-%d" returns) in 19 | [Exits {no_trap; name; args; returns; script}] 20 | end 21 | 22 | open Test 23 | 24 | module Shell = struct 25 | type t = 26 | { name: string 27 | ; command: string -> string list -> string list 28 | ; get_version: string } 29 | 30 | let make_shell name ~command ~get_version = {name; command; get_version} 31 | let to_string t = t.name 32 | 33 | let known_shells () = 34 | (* let exec l = *) 35 | (* List.map ~f:Filename.quote l |> String.concat ~sep:" " in *) 36 | let dash_like bin ~get_version = 37 | make_shell (Filename.basename bin) 38 | ~command:(fun s args -> [bin; "-x"; s] @ args) 39 | ~get_version in 40 | let busybox = 41 | make_shell "busybox" 42 | ~command:(fun s args -> ["busybox"; "ash"; "-x"; s] @ args) 43 | ~get_version:"busybox | head -n 1" in 44 | let package_version package = 45 | (* for when there is no `--version`, `-V`, etc. we go the “debian” way *) 46 | Fmt.str "dpkg -s %s | grep ^Version" package in 47 | [ dash_like "dash" ~get_version:(package_version "dash") 48 | ; dash_like "bash" ~get_version:"bash --version | head -n 1" 49 | ; dash_like "sh" ~get_version:(package_version "sh"); busybox 50 | ; dash_like "ksh" ~get_version:"ksh --version 2>&1" 51 | ; dash_like "mksh" ~get_version:(package_version "mksh") 52 | ; dash_like "posh" ~get_version:(package_version "posh") 53 | ; dash_like "zsh" ~get_version:"zsh --version" ] 54 | end 55 | 56 | module Shell_directory = struct 57 | type t = 58 | { shell: Shell.t 59 | ; compilation: [`Std_one_liner | `Std_multi_line | `Slow_stack] 60 | ; optimization_passes: [`Cst_prop] list 61 | ; verbose: bool } 62 | 63 | let name t = 64 | let opti = 65 | List.map t.optimization_passes ~f:(function `Cst_prop -> "-cp") 66 | |> String.concat ~sep:"" in 67 | Fmt.str "%s-%s%s" (Shell.to_string t.shell) 68 | ( match t.compilation with 69 | | `Std_multi_line -> "StdML" 70 | | `Std_one_liner -> "Std1L" 71 | | `Slow_stack -> "SlowFlow" ) 72 | opti 73 | 74 | let unique_name = function 75 | | Exits {no_trap; name; args; returns; script} -> 76 | Fmt.str "test-%s-%s-A%d-R%d-%s" 77 | (if no_trap then "noT" else "T") 78 | (let long = 79 | String.map name ~f:(function 80 | | ('a' .. 'z' | 'A' .. 'Z' | '0' .. '9') as c -> c 81 | | _ -> '_' ) in 82 | if String.length long > 30 then String.sub long ~pos:0 ~len:30 83 | else long ) 84 | (List.length args) returns 85 | Caml.( 86 | Marshal.to_string script [Marshal.Closures] 87 | |> Digest.string |> Digest.to_hex 88 | |> fun s -> String.sub s 0 10) 89 | 90 | (* 91 | let optimize : type a. _ -> a Genspio.Language.t -> _ = 92 | fun t script -> 93 | List.fold t.optimization_passes ~init:script ~f:(fun prev -> function 94 | | `Cst_prop -> Genspio.Transform.Constant_propagation.process prev ) 95 | *) 96 | 97 | let script_path test = "script" // Fmt.str "%s-script.sh" (unique_name test) 98 | 99 | let run_test_path test = 100 | "script" // Fmt.str "%s-run-test.sh" (unique_name test) 101 | 102 | let script_display test = 103 | "script" // Fmt.str "%s-display.scm" (unique_name test) 104 | 105 | let script_opti_display test = 106 | "script" // Fmt.str "%s-opti-display.scm" (unique_name test) 107 | 108 | let success_path test = Fmt.str "_success/%s.txt" @@ unique_name test 109 | let failure_path test = Fmt.str "_failure/%s.txt" @@ unique_name test 110 | let stdout_path test = Fmt.str "_log/%s/stdout.txt" @@ unique_name test 111 | let stderr_path test = Fmt.str "_log/%s/stderr.txt" @@ unique_name test 112 | 113 | let display_script _t = function 114 | | Exits {script; _} -> Genspio.Compile.to_string_hum script 115 | 116 | let display_opti_script t = function 117 | | Exits {script; _} -> 118 | List.fold t.optimization_passes ~init:script ~f:(fun prev -> function 119 | | `Cst_prop -> Genspio.Transform.Constant_propagation.process prev ) 120 | |> Genspio.Compile.to_string_hum 121 | 122 | let run_test_script t = 123 | let test_name = name t in 124 | function 125 | | Exits {name; args; returns; _} as test -> 126 | let fill_result_file which = 127 | let echos = 128 | [ Fmt.str "- Returns $RRR (expected: %d)." returns 129 | ; Fmt.str "- Script: \\`%s\\`" (script_path test) 130 | ; Fmt.str "- Pretty-printed: \\`%s\\`" (script_display test) 131 | ; Fmt.str "- Pretty-printed after optimizations: \\`%s\\`" 132 | (script_opti_display test) 133 | ; Fmt.str "- Test-runner: \\`%s\\`" (run_test_path test) 134 | ; Fmt.str "- STDOUT: \\`%s\\`" (stdout_path test) 135 | ; Fmt.str "- STDERR: \\`%s\\`" (stderr_path test) ] in 136 | let file, first_line = 137 | match which with 138 | | `OK -> 139 | ( success_path test 140 | , Fmt.str "- **OK**: \\`%s\\`" (unique_name test) ) 141 | | `KO -> 142 | ( failure_path test 143 | , Fmt.str "- **KO**: \\`%s\\`" (unique_name test) ) in 144 | let lines = 145 | Fmt.str "printf -- \"%s\\n\" > %s" first_line file 146 | :: List.map echos ~f:(fun l -> 147 | Fmt.str "printf -- \" %s\\n\" >> %s" l file ) in 148 | String.concat ~sep:"\n" lines in 149 | Fmt.str 150 | "mkdir -p _success _failure %s\n\ 151 | export TMPDIR=$PWD/_tmp/%s\n\ 152 | mkdir -p ${TMPDIR}\n\ 153 | %s > %s 2> %s\n\ 154 | export RRR=$?\n\ 155 | if [ $RRR -eq %d ] ; then\n\ 156 | %s\n\ 157 | else\n\ 158 | %s\n\ 159 | \ %s\n\ 160 | fi\n" 161 | (stdout_path test |> Filename.dirname) 162 | (unique_name test) 163 | ( t.shell.Shell.command (script_path test) args 164 | |> List.map ~f:Filename.quote |> String.concat ~sep:" " ) 165 | (stdout_path test) (stderr_path test) returns 166 | (fill_result_file `OK) 167 | (fill_result_file `KO) 168 | ( if t.verbose then 169 | Fmt.str "printf 'Test %s with [%s] FAILED\\n' >&2" name test_name 170 | else "" ) 171 | 172 | let script_content t = function 173 | | Exits {no_trap; script; _} -> ( 174 | let script = 175 | List.fold t.optimization_passes ~init:script ~f:(fun prev -> function 176 | | `Cst_prop -> Genspio.Transform.Constant_propagation.process prev ) 177 | in 178 | match t.compilation with 179 | | `Std_one_liner -> Genspio.Compile.to_one_liner ~no_trap script 180 | | `Std_multi_line -> Genspio.Compile.to_many_lines ~no_trap script 181 | | `Slow_stack -> 182 | Genspio.Compile.To_slow_flow.compile script 183 | ~trap:(if no_trap then `None else `Exit_with 77) 184 | |> Fmt.str "%a\n" Genspio.Compile.To_slow_flow.Script.pp_posix ) 185 | 186 | let make_report_path _ = "script" // "make_report.sh" 187 | 188 | let make_report_content t testlist = 189 | (let open Genspio.EDSL_v0 in 190 | let count_files dir = 191 | if_then_else 192 | (exec ["test"; "-d"; dir] |> succeeds) 193 | (exec ["ls"; "-1"; dir] ||> exec ["wc"; "-l"]) 194 | (exec ["echo"; "No-dir"]) 195 | ||> exec ["tr"; "-d"; "\\n"] 196 | |> get_stdout |> Byte_array.to_c in 197 | seq 198 | [ exec 199 | [ "printf" 200 | ; Fmt.str "* Shell: %s, compilation; %s, opti: %s, total tests: %d\\n" 201 | (Shell.to_string t.shell) 202 | ( match t.compilation with 203 | | `Std_one_liner -> "Standard-one-liner" 204 | | `Std_multi_line -> "Standard-multi-line" 205 | | `Slow_stack -> "Slow-stack" ) 206 | ( List.map t.optimization_passes ~f:(function `Cst_prop -> 207 | "cst-prop" ) 208 | |> String.concat ~sep:"→" ) 209 | (List.length testlist) ] 210 | ; call 211 | [ string "printf"; string " * Failures: %s.\\n" 212 | ; count_files "_failure/" ] 213 | ; call 214 | [ string "printf"; string " * Successes: %s.\\n" 215 | ; count_files "_success" ] ]) 216 | |> Genspio.Compile.to_many_lines 217 | 218 | let makefile t testlist = 219 | Fmt.str ".PHONY: all clean report check\nall: %s\n\n" 220 | (List.map testlist ~f:success_path |> String.concat ~sep:" ") 221 | :: Fmt.str "clean:\n\trm -fr _success _failure _log _tmp *.md\n\n" 222 | :: Fmt.str 223 | "failures.md:\n\t@@{ cat _failure/* ; echo '' ; } > failures.md\n\n" 224 | :: Fmt.str 225 | "successes.md:\n\t@@{ cat _success/* ; echo '' ; } > successes.md\n\n" 226 | :: Fmt.str "report: failures.md successes.md\n\t@@sh %s > report.md\n\n" 227 | (make_report_path t) 228 | :: Fmt.str "check:\n\t@@%s\n\n" 229 | ( List.map testlist ~f:(fun tst -> 230 | Fmt.str "test -f '%s'" (success_path tst) ) 231 | |> String.concat ~sep:" \\\n && " ) 232 | :: List.map testlist ~f:(fun test -> 233 | Fmt.str "# Test %s with %s\n%s:\n\t%ssh %s" (unique_name test) 234 | (Shell.to_string t.shell) (success_path test) 235 | (if t.verbose then "" else "@") 236 | (run_test_path test) ) 237 | |> String.concat ~sep:"\n" 238 | 239 | let scripts t testlist = 240 | List.concat_map testlist ~f:(fun test -> 241 | [ (script_path test, script_content t test) 242 | ; (run_test_path test, run_test_script t test) 243 | ; (script_display test, display_script t test) 244 | ; (script_opti_display test, display_opti_script t test) ] ) 245 | 246 | let contents t ~path testlist = 247 | let test_path = path in 248 | let makefile_path = Fmt.str "%s/Makefile" test_path in 249 | [ `Directory test_path; `Directory (test_path // "script") 250 | ; `File (makefile_path, makefile t testlist) 251 | ; `File (test_path // make_report_path t, make_report_content t testlist) ] 252 | @ List.map (scripts t testlist) ~f:(fun (spath, content) -> 253 | `File (Fmt.str "%s/%s" test_path spath, content) ) 254 | end 255 | 256 | module Test_directory = struct 257 | type t = 258 | { shell_tests: Shell_directory.t list 259 | ; important_shells: string list 260 | ; verbose: bool } 261 | 262 | let help t = 263 | let shell_names = List.map t.shell_tests ~f:Shell_directory.name in 264 | let code_list l = 265 | List.map l ~f:(Fmt.str "`%s`") |> String.concat ~sep:", " in 266 | Fmt.str 267 | "Genspio Tests Master Makefile\n\ 268 | =============================\n\n\ 269 | Type `make` to see this help.\n\n\ 270 | Other targets include:\n\n\ 271 | * `make run-` where `shell-name` can be one of:\n\ 272 | \ %s.\n\ 273 | * `make run-all` to attempt to run all the tests on all the shells.\n\ 274 | * `make report` generate the `report.md` file.\n\ 275 | * `make check`: check the success of the test for all the important \n\ 276 | \ shells (%s).\n" 277 | (code_list shell_names) 278 | (code_list t.important_shells) 279 | 280 | let makefile t = 281 | let shell_reports = 282 | List.map t.shell_tests ~f:(fun sh -> 283 | Shell_directory.name sh // "report.md" ) 284 | |> String.concat ~sep:" " in 285 | let shell_names = List.map t.shell_tests ~f:Shell_directory.name in 286 | let shell_run_targets = 287 | List.map shell_names ~f:(Fmt.str "run-%s") |> String.concat ~sep:" " in 288 | [ Fmt.str ".PHONY: run-all all clean clean-reports report check %s\n" 289 | shell_run_targets; Fmt.str "all:\n\t@@cat help.md" 290 | ; Fmt.str "check: %s\n" 291 | ( List.filter_map t.shell_tests ~f:(fun sht -> 292 | if 293 | List.mem t.important_shells ~equal:String.equal 294 | (sht.Shell_directory.shell |> Shell.to_string) 295 | then Some (Fmt.str "check-%s" (Shell_directory.name sht)) 296 | else None ) 297 | |> String.concat ~sep:" " ); "report: report.md" 298 | ; Fmt.str "report.md: %s\n\tcat %s > report.md" shell_reports shell_reports 299 | ; Fmt.str "clean-reports:\n\t@@rm report.md %s" shell_reports 300 | ; Fmt.str "clean: clean-reports\n\t@@%s" 301 | ( List.map shell_names ~f:(Fmt.str "( cd %s ; $(MAKE) clean ; )") 302 | |> String.concat ~sep:" ; " ); Fmt.str "run-all: %s" shell_run_targets 303 | ] 304 | @ List.concat_map t.shell_tests ~f:(fun shtest -> 305 | let dir = Shell_directory.name shtest in 306 | [ Fmt.str "%s/report.md:\n\t@@ ( cd %s ; $(MAKE) report ; )" dir dir 307 | ; Fmt.str "run-%s:\n\t@@ ( cd %s ; $(MAKE) ; )" dir dir 308 | ; Fmt.str "check-%s:\n\t@@ ( cd %s ; $(MAKE) check ; )" dir dir ] ) 309 | |> String.concat ~sep:"\n" 310 | 311 | let contents t ~path testlist = 312 | [ `Directory path; `File (path // "help.md", help t) 313 | ; `File (path // "Makefile", makefile t) ] 314 | @ List.concat_map t.shell_tests ~f:(fun shtest -> 315 | (* let comp = Shell_directory.{ shell; verbose = t.verbose } in *) 316 | Shell_directory.contents shtest 317 | ~path:(path // Shell_directory.name shtest) 318 | testlist ) 319 | end 320 | 321 | module Example = struct 322 | type t = 323 | | EDSL : 324 | { name: string 325 | ; description: string 326 | ; code: 'a Genspio.EDSL.t 327 | ; ocaml_code: string 328 | ; show: [`Stdout | `Stderr | `Pretty_printed | `Compiled] list } 329 | -> t 330 | 331 | let make ?(show = [`Pretty_printed]) ~ocaml name description code = 332 | EDSL {name; description; code; show; ocaml_code= ocaml} 333 | 334 | let default_demo_url = 335 | "https://smondet.gitlab.io/genspio-web-demo/genspio-master/index.html" 336 | 337 | let run fmt = 338 | let ff = Fmt.pf in 339 | function 340 | | EDSL {code; description; ocaml_code; name; show} -> 341 | let md_code_block lang code = 342 | let fence = String.make 50 '`' in 343 | ff fmt "%s%s@\n%s@\n%s@\n@\n" fence lang (String.strip code) fence 344 | in 345 | let if_show s f = 346 | if List.mem show s ~equal:Poly.equal then f () else () in 347 | let try_url = 348 | let base = 349 | try Sys.getenv "genspio_demo_url" with _ -> default_demo_url in 350 | Fmt.str "%s?input=%s" base (Uri.pct_encode ocaml_code) in 351 | ff fmt "@\n%s@\n%s@\n@\n%s@ [[Try-Online](%s)]@\n@\n" name 352 | (String.map name ~f:(fun _ -> '-')) 353 | description try_url ; 354 | md_code_block "ocaml" ocaml_code ; 355 | if_show `Pretty_printed (fun () -> 356 | ff fmt "Pretty-printed:@\n@\n" ; 357 | md_code_block "scheme" (Genspio.Compile.to_string_hum code) ) ; 358 | ( match Genspio.Compile.To_posix.(string ~options:multi_line) code with 359 | | Ok script -> 360 | let tmp = Filename.temp_file "genspio-example" ".sh" in 361 | let o = Caml.open_out tmp in 362 | Caml.Printf.fprintf o "\n%s\n" script ; 363 | Caml.close_out o ; 364 | (* ff fmt "@[* Compiled:@ `%s`@ (%d bytes)@]@\n" tmp (String.length script); *) 365 | let out = Filename.temp_file "genspio-example" ".out" in 366 | let err = Filename.temp_file "genspio-example" ".err" in 367 | let result = 368 | Sys.command (Fmt.str "bash %s > %s 2> %s" tmp out err) in 369 | (* ff fmt " *@[ Std-OUT:@ `%s`@]@\n" out; *) 370 | (* ff fmt " *@[ Std-ERR:@ `%s`@]@\n" err; *) 371 | let show_file name path = 372 | let fence = String.make 50 '`' in 373 | ff fmt "@\n%s:@\n@\n%s@\n" name fence ; 374 | let i = Caml.open_in path in 375 | let rec loop () = 376 | try 377 | ff fmt "%c" @@ Caml.input_char i ; 378 | loop () 379 | with _ -> () in 380 | loop () ; ff fmt "@\n%s@\n@\n" fence in 381 | if_show `Compiled (fun () -> 382 | ff fmt "Compiled to POSIX (%d bytes):@\n@\n" 383 | (String.length script) ; 384 | md_code_block "shell" script ) ; 385 | ff fmt "@[Running@ *it*@ " ; 386 | ( match result with 387 | | 0 -> ff fmt "**succeeds**." 388 | | other -> ff fmt "**fails**;@ returns %d." other ) ; 389 | ff fmt "@]@\n@\n" ; 390 | if_show `Stdout (fun () -> show_file "Standard output" out) ; 391 | if_show `Stderr (fun () -> show_file "Standard error" err) 392 | | Error e -> 393 | ff fmt "Compilation **fails** with:@\n@\n" ; 394 | md_code_block "" (Genspio.Compile.To_posix.error_to_string e) ) ; 395 | ff fmt "%!" 396 | end 397 | -------------------------------------------------------------------------------- /src/lib/transform.ml: -------------------------------------------------------------------------------- 1 | (*md 2 | 3 | This module implements basic AST (type-preserving) transformations. 4 | 5 | - The class `Visitor.nothing_doer` is an “open-recursion” AST visitor 6 | (cf. 7 | [chapter 12](https://v1.realworldocaml.org/v1/en/html/classes.html#open-recursion) 8 | of RWO). 9 | - The module `Constant_propagation` implements many constant 10 | propagation transformations using the visitor. 11 | *) 12 | open Common 13 | 14 | module Visitor = struct 15 | open Language 16 | 17 | class nothing_doer ?(trace : Format.formatter option) () = 18 | object (self) 19 | method exec : c_string t list -> unit t = 20 | fun e -> Exec (List.map ~f:self#expression e) 21 | 22 | method raw_cmd : type a. raw_command_annotation option * string -> a t = 23 | fun e -> Raw_cmd e 24 | 25 | method bool_operator : bool t * [`And | `Or] * bool t -> bool t = 26 | fun (a, op, b) -> 27 | Bool_operator (self#expression a, op, self#expression b) 28 | 29 | method string_operator 30 | : byte_array t * [`Eq | `Neq] * byte_array t -> bool t = 31 | fun (a, op, b) -> 32 | String_operator (self#expression a, op, self#expression b) 33 | 34 | method not : bool t -> bool t = fun e -> Not (self#expression e) 35 | 36 | method returns : type a. expr:a t -> value:int -> bool t = 37 | fun ~expr ~value -> Returns {expr= self#expression expr; value} 38 | 39 | method no_op : unit t = No_op 40 | 41 | method if_ : bool t * unit t * unit t -> unit t = 42 | fun (a, t, e) -> 43 | If (self#expression a, self#expression t, self#expression e) 44 | 45 | method seq : unit t list -> unit t = 46 | fun e -> Seq (List.map ~f:self#expression e) 47 | 48 | method literal : type a. a Literal.t -> a t = fun e -> Literal e 49 | 50 | method output_as_string : unit t -> byte_array t = 51 | fun e -> Output_as_string (self#expression e) 52 | 53 | method redirect_output : unit t * fd_redirection list -> unit t = 54 | fun (u, l) -> Redirect_output (self#expression u, l) 55 | 56 | method write_output 57 | : expr:unit t 58 | -> stdout:c_string t option 59 | -> stderr:c_string t option 60 | -> return_value:c_string t option 61 | -> unit t = 62 | fun ~expr ~stdout ~stderr ~return_value -> 63 | let opt f o = Option.map ~f o in 64 | Write_output 65 | { expr= self#expression expr 66 | ; stdout= opt self#expression stdout 67 | ; stderr= opt self#expression stderr 68 | ; return_value= opt self#expression return_value } 69 | 70 | method feed : byte_array t * unit t -> unit t = 71 | fun (s, u) -> Feed (self#expression s, self#expression u) 72 | 73 | method pipe : unit t list -> unit t = 74 | fun e -> Pipe (List.map ~f:self#expression e) 75 | 76 | method while_ : condition:bool t -> body:unit t -> unit t = 77 | fun ~condition ~body -> 78 | While 79 | {condition= self#expression condition; body= self#expression body} 80 | 81 | method fail : string -> unit t = fun e -> Fail e 82 | 83 | method int_to_string : int t -> c_string t = 84 | fun e -> Int_to_string (self#expression e) 85 | 86 | method string_to_int : c_string t -> int t = 87 | fun e -> String_to_int (self#expression e) 88 | 89 | method bool_to_string : bool t -> c_string t = 90 | fun e -> Bool_to_string (self#expression e) 91 | 92 | method string_to_bool : c_string t -> bool t = 93 | fun e -> String_to_bool (self#expression e) 94 | 95 | method list_to_string : type a. 96 | a list t * (a t -> byte_array t) -> byte_array t = 97 | fun (l, f) -> List_to_string (self#expression l, f) 98 | 99 | method string_to_list : type a. 100 | byte_array t * (byte_array t -> a t) -> a list t = 101 | fun (l, f) -> String_to_list (self#expression l, f) 102 | 103 | method list : type a. a t list -> a list t = 104 | fun e -> List (List.map ~f:self#expression e) 105 | 106 | method c_string_concat : c_string list t -> c_string t = 107 | fun e -> C_string_concat (self#expression e) 108 | 109 | method byte_array_concat : byte_array list t -> byte_array t = 110 | fun e -> Byte_array_concat (self#expression e) 111 | 112 | method list_append : type a. a list t * a list t -> a list t = 113 | fun (a, b) -> List_append (self#expression a, self#expression b) 114 | 115 | method list_iter : type a. a list t * ((unit -> a t) -> unit t) -> unit t 116 | = 117 | fun (l, f) -> 118 | let newf (* : type a. (unit -> a t) -> unit t *) item = 119 | self#expression (f item) in 120 | List_iter (self#expression l, newf) 121 | 122 | method byte_array_to_c_string : byte_array t -> c_string t = 123 | fun e -> Byte_array_to_c_string (self#expression e) 124 | 125 | method c_string_to_byte_array : c_string t -> byte_array t = 126 | fun e -> C_string_to_byte_array (self#expression e) 127 | 128 | method int_bin_op 129 | : int t * [`Plus | `Minus | `Mult | `Div | `Mod] * int t -> int t = 130 | fun (a, op, b) -> Int_bin_op (self#expression a, op, self#expression b) 131 | 132 | method int_bin_comparison 133 | : int t * [`Eq | `Ne | `Gt | `Ge | `Lt | `Le] * int t -> bool t = 134 | fun (a, op, b) -> 135 | Int_bin_comparison (self#expression a, op, self#expression b) 136 | 137 | method getenv : c_string t -> c_string t = 138 | fun e -> Getenv (self#expression e) 139 | 140 | method setenv : c_string t * c_string t -> unit t = 141 | fun (k, v) -> Setenv (self#expression k, self#expression v) 142 | 143 | method comment : type a. string * a t -> a t = 144 | fun (c, e) -> Comment (c, self#expression e) 145 | 146 | method expression : type a. a Language.t -> a Language.t = 147 | fun e -> 148 | Option.iter trace ~f:(fun formatter -> 149 | Format.fprintf formatter "-> %a\n" pp e ) ; 150 | match e with 151 | | Exec l -> self#exec (List.map l ~f:self#expression) 152 | | Raw_cmd (x, y) -> self#raw_cmd (x, y) 153 | | Bool_operator (x, y, z) -> self#bool_operator (x, y, z) 154 | | String_operator (x, y, z) -> self#string_operator (x, y, z) 155 | | Not x -> self#not x 156 | | Returns {expr; value} -> self#returns ~expr ~value 157 | | No_op -> self#no_op 158 | | If (x, y, z) -> self#if_ (x, y, z) 159 | | Seq x -> self#seq x 160 | | Literal x -> self#literal x 161 | | Output_as_string x -> self#output_as_string x 162 | | Redirect_output (x, y) -> self#redirect_output (x, y) 163 | | Write_output {expr; stdout; stderr; return_value} -> 164 | self#write_output ~expr ~stdout ~stderr ~return_value 165 | | Feed (x, y) -> self#feed (x, y) 166 | | Pipe x -> self#pipe x 167 | | While {condition; body} -> self#while_ ~condition ~body 168 | | Fail x -> self#fail x 169 | | Int_to_string x -> self#int_to_string x 170 | | String_to_int x -> self#string_to_int x 171 | | Bool_to_string x -> self#bool_to_string x 172 | | String_to_bool x -> self#string_to_bool x 173 | | List_to_string (x, y) -> self#list_to_string (x, y) 174 | | String_to_list (x, y) -> self#string_to_list (x, y) 175 | | List x -> self#list x 176 | | C_string_concat x -> self#c_string_concat x 177 | | Byte_array_concat x -> self#byte_array_concat x 178 | | List_append x -> self#list_append x 179 | | List_iter (x, y) -> self#list_iter (x, y) 180 | | Byte_array_to_c_string x -> self#byte_array_to_c_string x 181 | | C_string_to_byte_array x -> self#c_string_to_byte_array x 182 | | Int_bin_op (x, y, z) -> self#int_bin_op (x, y, z) 183 | | Int_bin_comparison (x, y, z) -> self#int_bin_comparison (x, y, z) 184 | | Getenv x -> self#getenv x 185 | | Setenv (x, y) -> self#setenv (x, y) 186 | | Comment (x, y) -> self#comment (x, y) 187 | end 188 | end 189 | 190 | module Constant_propagation = struct 191 | open Language 192 | 193 | (*md 194 | 195 | The `propagator` class inherits from `Visitor.nothing_doer` and overwrites only the constructs that matter. 196 | *) 197 | class propagator ?trace () = 198 | object (self) 199 | inherit Visitor.nothing_doer ?trace () as _super 200 | 201 | (*md 202 | Boolean operators are not commutative, the left side has to be 203 | evaluated first and may break the execution flow (e.g. with `fail`). 204 | *) 205 | method! bool_operator (a, op, b) = 206 | let ga = self#expression a in 207 | let gb = self#expression b in 208 | match (ga, op, gb) with 209 | | Literal (Literal.Bool true), `And, b -> b 210 | | Literal (Literal.Bool false), `Or, b -> b 211 | | _ -> Bool_operator (ga, op, gb) 212 | 213 | (*md 214 | We can only know how to simplify expressions when they are about 215 | literals (all non-literals can be non-deterministic and 216 | side-effectful). 217 | *) 218 | method! string_operator (a, op, b) = 219 | let ga = self#expression a in 220 | let gb = self#expression b in 221 | match (ga, op, gb) with 222 | | Literal (Literal.String sa), op, Literal (Literal.String sb) -> 223 | Literal 224 | ( match op with 225 | | `Neq -> Literal.Bool String.(sa <> sb) 226 | | `Eq -> Literal.Bool String.(sa = sb) ) 227 | | _ -> String_operator (ga, op, gb) 228 | 229 | method! returns : type a. expr:a t -> _ = 230 | fun ~expr ~value -> 231 | let e = self#expression expr in 232 | match (e, value) with 233 | | No_op, 0 -> Construct.bool true 234 | | No_op, _ -> Construct.bool false 235 | | _ -> Returns {expr; value} 236 | 237 | method! if_ (c, t, e) = 238 | let gc = self#expression c in 239 | let gt = self#expression t in 240 | let ge = self#expression e in 241 | match gc with 242 | | Literal (Literal.Bool true) -> gt 243 | | Literal (Literal.Bool false) -> ge 244 | | _ -> If (gc, gt, ge) 245 | 246 | method! while_ ~condition ~body = 247 | match self#expression condition with 248 | | Literal (Literal.Bool false) -> No_op 249 | | cond -> While {condition= cond; body= self#expression body} 250 | 251 | method! not b = 252 | let gb = self#expression b in 253 | match gb with 254 | | Literal (Literal.Bool b) -> Literal (Literal.Bool (not b)) 255 | | other -> Not other 256 | 257 | method! seq l = 258 | let transformed = 259 | List.map ~f:self#expression l |> List.filter ~f:Poly.(( <> ) No_op) 260 | in 261 | match transformed with [] -> No_op | [one] -> one | l -> Seq l 262 | 263 | method! pipe l = 264 | let tr = List.map ~f:self#expression l in 265 | match tr with Pipe l :: more -> Pipe (l @ more) | other -> Pipe other 266 | 267 | method! c_string_concat l = 268 | let gl = self#expression l in 269 | match gl with 270 | | List [] -> Construct.c_string "" 271 | | List more -> ( 272 | let build = 273 | List.fold more ~init:[] ~f:(fun prev item -> 274 | match (prev, item) with 275 | | [], _ -> [item] 276 | | _, Byte_array_to_c_string (Literal (Literal.String "")) -> 277 | prev 278 | | ( Byte_array_to_c_string (Literal (Literal.String pstring)) 279 | :: more 280 | , Byte_array_to_c_string (Literal (Literal.String sitem)) ) 281 | -> 282 | Byte_array_to_c_string 283 | (Literal (Literal.String (pstring ^ sitem))) 284 | :: more 285 | | _, _ -> item :: prev ) 286 | |> List.rev in 287 | match build with [one] -> one | more -> C_string_concat (List more) 288 | ) 289 | | default -> C_string_concat default 290 | 291 | method! byte_array_concat l = 292 | let gl = self#expression l in 293 | match gl with 294 | | List [] -> Construct.byte_array "" 295 | | List more -> ( 296 | let build = 297 | List.fold more ~init:[] ~f:(fun prev item -> 298 | match (prev, item) with 299 | | [], _ -> [item] 300 | | _, Literal (Literal.String "") -> prev 301 | | ( Literal (Literal.String pstring) :: more 302 | , Literal (Literal.String sitem) ) -> 303 | Literal (Literal.String (pstring ^ sitem)) :: more 304 | | _, _ -> item :: prev ) 305 | |> List.rev in 306 | match build with 307 | | [one] -> one 308 | | more -> Byte_array_concat (List more) ) 309 | | default -> Byte_array_concat default 310 | 311 | method! list_append (a, b) = 312 | let la = self#expression a in 313 | let lb = self#expression b in 314 | match (la, lb) with 315 | | List [], _ -> lb 316 | | _, List [] -> la 317 | | List lla, List llb -> List (lla @ llb) 318 | | _, _ -> List_append (la, lb) 319 | 320 | method! list_iter (l, f) = 321 | let gl = self#expression l in 322 | match gl with List [] -> No_op | _ -> List_iter (gl, f) 323 | 324 | method! int_bin_op (a, op, b) = 325 | let ga = self#expression a in 326 | let gb = self#expression b in 327 | let default = Int_bin_op (ga, op, gb) in 328 | let lit n = Literal (Literal.Int n) in 329 | match (ga, op, gb) with 330 | (* Any non-literal may have side effects that we cannot eliminate. 331 | Most operations cannot be ocamlized because of unknown semantics.*) 332 | | Literal (Literal.Int na), op, Literal (Literal.Int nb) -> ( 333 | match (na, op, nb) with 334 | | 0, `Plus, _ -> lit nb 335 | | 0, (`Mult | `Div | `Mod), _ -> lit 0 336 | | _, `Plus, 0 -> lit na 337 | | _, `Mult, 0 -> lit 0 338 | | 1, `Mult, _ -> lit nb 339 | | _, `Mult, 1 -> lit na 340 | | _ -> default ) 341 | | _ -> default 342 | 343 | method! int_bin_comparison (a, op, b) = 344 | let ga = self#expression a in 345 | let gb = self#expression b in 346 | let default = Int_bin_comparison (ga, op, gb) in 347 | match (ga, op, gb) with 348 | | Literal (Literal.Int na), op, Literal (Literal.Int nb) -> 349 | Literal 350 | (Literal.Bool 351 | (( match op with 352 | | `Ge -> ( >= ) 353 | | `Lt -> ( < ) 354 | | `Eq -> ( = ) 355 | | `Le -> ( <= ) 356 | | `Gt -> ( > ) 357 | | `Ne -> ( <> ) ) 358 | na nb ) ) 359 | | _ -> default 360 | end 361 | 362 | let process ?trace e = 363 | let p = new propagator ?trace () in 364 | p#expression e 365 | 366 | type forget = Forget : 'a t -> forget 367 | 368 | let test () = 369 | let failures = ref [] in 370 | let count = ref 0 in 371 | let check ?trace name e res = 372 | let p = process ?trace e in 373 | Caml.incr count ; 374 | match Poly.(p = res) with 375 | | true -> () 376 | | false -> 377 | failures := 378 | (!count, name, Forget e, Forget res, Forget p) :: !failures in 379 | check "no-op" No_op No_op ; 380 | check "some bool" 381 | Construct.(bool true &&& bool false) 382 | Construct.(bool false) ; 383 | check "some bool" Construct.(bool false ||| bool true) Construct.(bool true) ; 384 | check "some bool and string" 385 | Construct.( 386 | if_then_else 387 | (not 388 | (bool false ||| Byte_array.(byte_array "bouh" =$= byte_array "bah")) ) 389 | (fail "then") (fail "else")) 390 | Construct.(fail "then") ; 391 | check "seq []" Construct.(seq []) Construct.(nop) ; 392 | check "seq [nops]" Construct.(seq [seq []; seq [seq []]]) Construct.(nop) ; 393 | check "seq [one-thing]" 394 | Construct.(seq [seq [nop]; seq [seq [fail "bouh"]]]) 395 | Construct.(fail "bouh") ; 396 | let e n = Construct.exec [Int.to_string n] in 397 | check "pipes" 398 | Construct.(e 1 ||> e 2 ||> e 3 ||> e 4) 399 | Construct.(pipe [e 1; e 2; e 3; e 4]) ; 400 | check "concat one-two" 401 | Construct.(C_string.concat_list [string "one"; string "-"; string "two"]) 402 | Construct.(string "one-two") ; 403 | let s n = 404 | Construct.(get_stdout (exec [Int.to_string n]) |> Byte_array.to_c) in 405 | check "concat one-two" 406 | Construct.( 407 | C_string.concat_list 408 | [ string "before"; s 0; string "one"; string "-"; string "two"; s 1 409 | ; string "" ]) 410 | Construct.( 411 | C_string.concat_list [string "before"; s 0; string "one-two"; s 1]) ; 412 | check "list-append" 413 | Construct.( 414 | Elist.append 415 | (Elist.append (Elist.make []) (Elist.make [s 0; s 1])) 416 | (Elist.make [s 2])) 417 | Construct.(Elist.make [s 0; s 1; s 2]) ; 418 | let make_deep expr = 419 | Construct.( 420 | seq 421 | [ e 42 422 | ; loop_seq_while 423 | ("Comment on the success" %%% succeeds (s 0)) 424 | [ e 1 425 | ; "Comment on the `setenv`" %%% setenv ~var:(string "bouh") expr 426 | ] ]) in 427 | check "deep1" 428 | Construct.(make_deep Integer.(to_string (int 1 + int 0))) 429 | Construct.(make_deep Integer.(to_string (int 1))) ; 430 | check "deep int comparison" 431 | Construct.(make_deep Integer.(int 42 > int 44 |> Bool.to_string)) 432 | Construct.(make_deep (bool false |> Bool.to_string)) ; 433 | match !failures with 434 | | [] -> () 435 | | more -> 436 | List.iter (List.rev more) 437 | ~f:(fun (nth, name, Forget e, Forget res, Forget p) -> 438 | let open Format in 439 | eprintf 440 | "## Test %d failure %s:\n\ 441 | Input:\n\ 442 | %a\n\ 443 | Expected:\n\ 444 | %a\n\ 445 | Result:\n\ 446 | %a\n\ 447 | %!" 448 | nth name pp e pp res pp p ) ; 449 | let nb = List.length more in 450 | Fmt.failwith "There %s %d test failure%s" 451 | (if nb > 1 then "were" else "was") 452 | nb 453 | (if nb > 1 then "s" else "") 454 | end 455 | -------------------------------------------------------------------------------- /src/lib/standard_compiler.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | 3 | type internal_error_details = {variable: string; content: string; code: string} 4 | 5 | let pp_internal_error_details ~big_string fmt {variable; content; code} = 6 | Fmt.pf fmt "@[<2>{variable:@ %a;@ content:@ %a;@ code:@ %a}@]" big_string 7 | variable big_string content big_string code 8 | 9 | type death_message = 10 | | User of string 11 | | C_string_failure of internal_error_details 12 | | String_to_int_failure of internal_error_details 13 | 14 | let pp_death_message ?(style = `Lispy) ~big_string ppf dm = 15 | let open Fmt in 16 | match style with 17 | | `Lispy -> ( 18 | match dm with 19 | | User s -> pf ppf "@[(user@ %a)@]" big_string s 20 | | C_string_failure ied -> 21 | pf ppf "@[(c-string-failure@ %a)@]" 22 | (pp_internal_error_details ~big_string) 23 | ied 24 | | String_to_int_failure ied -> 25 | pf ppf "@[(string-to-int-failure@ %a)@]" 26 | (pp_internal_error_details ~big_string) 27 | ied ) 28 | | `User -> ( 29 | match dm with 30 | | User s -> pf ppf "@[%s@]" s 31 | | C_string_failure ied -> 32 | pf ppf "@[Byte-array cannot be converted to a C-string:@ @[<2>%a@]@]" 33 | (pp_internal_error_details ~big_string) 34 | ied 35 | | String_to_int_failure ied -> 36 | pf ppf "@[String cannot be converted to an Integer@ @[<2>%a@]@]" 37 | (pp_internal_error_details ~big_string) 38 | ied ) 39 | 40 | type death_function = comment_stack:string list -> death_message -> string 41 | 42 | type output_parameters = 43 | { statement_separator: string 44 | ; die_command: death_function option 45 | ; max_argument_length: int option } 46 | 47 | type internal_representation = 48 | | Unit of string 49 | | Octostring of string 50 | | Int of string 51 | | Bool of string 52 | | List of string 53 | | Death of string 54 | 55 | let ir_unit s = Unit s 56 | let ir_octostring s = Octostring s 57 | let ir_int s = Int s 58 | let ir_bool s = Bool s 59 | let ir_death s = Death s 60 | let ir_list s = List s 61 | 62 | let ir_to_shell = function 63 | | Unit s -> s 64 | | Octostring s -> s 65 | | Int s -> s 66 | | Bool s -> s 67 | | List s -> s 68 | | Death s -> s 69 | 70 | type compilation_error = 71 | { error: 72 | [ `No_fail_configured of death_message (* Argument of fail *) 73 | | `Max_argument_length of string (* Incriminated argument *) 74 | | `Not_a_c_string of string (* The actual string *) ] 75 | ; code: string option 76 | ; comment_backtrace: string list } 77 | 78 | exception Compilation of compilation_error 79 | 80 | let error ?code ~comment_backtrace error = 81 | raise (Compilation {code; comment_backtrace; error}) 82 | 83 | let pp_error ppf {code; comment_backtrace; error= the_error} = 84 | let open Fmt in 85 | let summary s = 86 | match String.sub s ~pos:0 ~len:70 with s -> s ^ " …" | exception _ -> s 87 | in 88 | let big_string ppf s = pf ppf "@[%s@]" (summary s) in 89 | pf ppf "@[" ; 90 | pf ppf "Error:@ @[%a@];@ " 91 | (fun ppf -> function 92 | | `Max_argument_length s -> 93 | pf ppf "Comand-line argument too long:@ %d bytes,@ %S." 94 | (String.length s) (summary s) 95 | | `Not_a_c_string s -> 96 | pf ppf "String literal is not a valid/escapable C-string:@ %S." 97 | (summary s) 98 | | `No_fail_configured msg -> 99 | pf ppf "Call to `fail %a`@ while no “die” command is configured." 100 | (pp_death_message ~style:`Lispy ~big_string) 101 | msg ) 102 | the_error ; 103 | pf ppf "Code:@ @[%s@];@ " 104 | (match code with None -> "NONE" | Some c -> summary c) ; 105 | pf ppf "Comment-backtrace:@ @[[%a]@]@ " 106 | (list ~sep:(fun ppf () -> pf ppf ";@ ") (fun ppf -> pf ppf "%S")) 107 | comment_backtrace ; 108 | pf ppf "@]" ; 109 | () 110 | 111 | let rec to_ir : type a. _ -> _ -> a Language.t -> internal_representation = 112 | fun comments params e -> 113 | let open Language in 114 | let continue_match ?add_comment e = 115 | let cmts = 116 | match add_comment with Some c -> c :: comments | None -> comments in 117 | to_ir cmts params e in 118 | let continue e = continue_match e |> ir_to_shell in 119 | let seq = function 120 | | [] -> ":" 121 | | l -> String.concat ~sep:params.statement_separator l in 122 | let die s = 123 | match params.die_command with 124 | | Some f -> f ~comment_stack:comments s 125 | | None -> error ~comment_backtrace:comments (`No_fail_configured s) in 126 | let expand_octal s = 127 | Fmt.str 128 | {sh| printf -- "$(printf -- '%%s\n' %s | sed -e 's/\(.\{3\}\)/\\\1/g')" |sh} 129 | s in 130 | let to_argument ~error_loc varprefix = 131 | let argument ?declaration ?variable_name argument = 132 | object 133 | method declaration = declaration 134 | method export = Option.map ~f:(Fmt.str "export %s ; ") declaration 135 | method variable_name = variable_name 136 | method argument = argument 137 | end in 138 | let check_length s = 139 | match params.max_argument_length with 140 | | None -> s 141 | | Some m when String.length s > m -> 142 | error ~comment_backtrace:comments (`Max_argument_length s) 143 | ~code:(Fmt.str "%a" pp error_loc) 144 | | Some _ -> s in 145 | function 146 | | `C_string (c_str : c_string t) -> ( 147 | match c_str with 148 | | Byte_array_to_c_string (Literal (Literal.String s)) 149 | when Literal.Str.easy_to_escape s -> 150 | argument (Caml.Filename.quote s |> check_length) 151 | | Byte_array_to_c_string (Literal (Literal.String s)) 152 | when Literal.Str.impossible_to_escape_for_variable s -> 153 | error ~comment_backtrace:comments (`Not_a_c_string s) 154 | ~code:(Format.asprintf "%a" pp error_loc) 155 | | other -> 156 | let variable_name = Unique_name.variable varprefix in 157 | let declaration = 158 | Fmt.str "%s=$(%s; printf 'x')" variable_name 159 | (continue other |> expand_octal |> check_length) in 160 | argument ~variable_name ~declaration 161 | (Fmt.str "\"${%s%%?}\"" variable_name) ) 162 | | `Int (Literal (Literal.Int s)) -> argument (Int.to_string s) 163 | | `Int other -> 164 | let variable_name = Unique_name.variable varprefix in 165 | let declaration = 166 | Fmt.str "%s=%s" variable_name (continue other |> check_length) in 167 | argument ~variable_name ~declaration 168 | (Fmt.str "\"${%s%%?}\"" variable_name) in 169 | match e with 170 | | Exec l -> 171 | let variables = ref [] in 172 | let args = 173 | List.mapi l ~f:(fun index v -> 174 | let varname = Fmt.str "argument_%d" index in 175 | let arg = to_argument ~error_loc:e varname (`C_string v) in 176 | match arg#declaration with 177 | | None -> arg#argument 178 | | Some vardef -> 179 | variables := Fmt.str "%s ; " vardef :: !variables ; 180 | arg#argument ) in 181 | List.rev !variables @ args 182 | |> String.concat ~sep:" " |> Fmt.str " { %s ; } " |> ir_unit 183 | | Raw_cmd (_, s) -> s |> ir_unit 184 | | Byte_array_to_c_string ba -> 185 | let bac = continue ba in 186 | let var = Unique_name.variable "byte_array_to_c_string" in 187 | let value = Fmt.str "\"$%s\"" var in 188 | let value_n = Fmt.str "\"$%s\\n\"" var in 189 | (* We store the internal octal representation in a variable, then 190 | we use `sed` to check that there are no `'\000'` characters. 191 | If OK we re-export with printf, if not we fail hard. 192 | The initial attempt was 's/\(000\)\|\(.\{3\}\)/\1/g' but 193 | BSD-ish `sed`s do not support “or”s in regular expressions. 194 | Cf. http://pubs.opengroup.org/onlinepubs/9699919799/utilities/sed.html 195 | *) 196 | Fmt.str "\"$(%s ; )\"" 197 | @@ seq 198 | [ Fmt.str " %s=%s" var bac 199 | ; Fmt.str 200 | {sh|if [ "$(printf -- %s | sed -e 's/\(.\{3\}\)/@\1/g' | grep @000)" = "" ] |sh} 201 | value_n; Fmt.str "then printf -- %s" value 202 | ; Fmt.str "else %s" 203 | (die 204 | (C_string_failure 205 | {variable= var; content= bac; code= Fmt.str "%a" pp ba} ) ) 206 | ; (* (Fmt.str "Byte_array_to_c_string: error, $%s is not a C string" *) 207 | (* var)); *) "fi" ] 208 | |> ir_octostring 209 | | C_string_to_byte_array c -> continue c |> ir_octostring 210 | | Returns {expr; value} -> 211 | Fmt.str " { %s ; [ $? -eq %d ] ; }" (continue expr) value |> ir_bool 212 | | Bool_operator (a, op, b) -> 213 | Fmt.str "{ %s %s %s ; }" (continue a) 214 | (match op with `And -> "&&" | `Or -> "||") 215 | (continue b) 216 | |> ir_bool 217 | | String_operator (a, op, b) -> 218 | Fmt.str "[ \"%s\" %s \"%s\" ]" (continue a) 219 | (match op with `Eq -> "=" | `Neq -> "!=") 220 | (continue b) 221 | |> ir_bool 222 | | No_op -> ":" |> ir_unit 223 | | If (c, t, e) -> 224 | seq 225 | [ Fmt.str "if { %s ; }" (continue c); Fmt.str "then %s" (continue t) 226 | ; Fmt.str "else %s" (continue e); "fi" ] 227 | |> ir_unit 228 | | While {condition; body} -> 229 | seq 230 | [ Fmt.str "while { %s ; }" (continue condition) 231 | ; Fmt.str "do %s" (continue body); "done" ] 232 | |> ir_unit 233 | | Seq l -> seq (List.map l ~f:continue) |> ir_unit 234 | | Not t -> Fmt.str "! { %s ; }" (continue t) |> ir_bool 235 | | Redirect_output (unit_t, redirections) -> 236 | (* 237 | We're here compiling the redirections into `exec` statements which 238 | set up global redirections; we limit their scope with `( .. )`. 239 | E.g. 240 | ( exec 3>/tmp/output-of-ls ; exec 2>&3 ; exec 1>&2 ; ls ; ) ; 241 | *) 242 | let make_redirection {take; redirect_to} = 243 | let takearg = to_argument ~error_loc:e "redirection_take" (`Int take) in 244 | let retoarg = 245 | to_argument ~error_loc:e "redirection_to" 246 | (match redirect_to with `Fd i -> `Int i | `Path p -> `C_string p) 247 | in 248 | let variables = [takearg#export; retoarg#export] |> List.filter_opt in 249 | let exec = 250 | Fmt.str "\"exec %%s>%s%%s\" %s %s" 251 | (match redirect_to with `Fd _ -> "&" | `Path _ -> "") 252 | takearg#argument retoarg#argument in 253 | Fmt.str 254 | "%s eval \"$(printf -- %s)\" || { echo 'Exec %s failed' >&2 ; } " 255 | (String.concat variables ~sep:"") 256 | exec exec in 257 | ( match redirections with 258 | | [] -> continue unit_t 259 | | one :: more -> 260 | continue 261 | (Seq 262 | ( Raw_cmd (None, Fmt.str "( %s" (make_redirection one)) 263 | :: List.map more ~f:(fun r -> 264 | Raw_cmd (None, make_redirection r) ) 265 | @ [unit_t] 266 | @ [Raw_cmd (None, ")")] ) ) ) 267 | |> ir_unit 268 | | Write_output {expr; stdout; stderr; return_value} -> 269 | let ret_arg = 270 | Option.map return_value ~f:(fun v -> 271 | to_argument ~error_loc:e "retval" (`C_string v) ) in 272 | let var = 273 | Option.(ret_arg >>= (fun ra -> ra#export) |> value ~default:"") in 274 | let with_potential_return = 275 | Fmt.str "%s { %s %s ; }" var (continue expr) 276 | (Option.value_map ret_arg ~default:"" ~f:(fun r -> 277 | Fmt.str "; printf -- \"$?\" > %s" r#argument ) ) in 278 | let redirections = 279 | let make fd = 280 | Option.map ~f:(fun p -> 281 | {take= Construct.int fd; redirect_to= `Path p} ) in 282 | [make 1 stdout; make 2 stderr] |> List.filter_opt in 283 | continue 284 | (Redirect_output (Raw_cmd (None, with_potential_return), redirections)) 285 | |> ir_unit 286 | | Literal lit -> ( 287 | let open Literal in 288 | match lit with 289 | | Int i -> Fmt.str "%d" i |> ir_int 290 | | String s -> 291 | with_buffer (fun str -> 292 | String.iter s ~f:(fun c -> 293 | Char.to_int c |> Fmt.str "%03o" |> str ) ) 294 | |> fst |> ir_octostring 295 | | Bool true -> ir_bool "true" 296 | | Bool false -> ir_bool "false" ) 297 | | Output_as_string e -> 298 | Fmt.str "\"$( { %s ; } | od -t o1 -An -v | tr -d ' \\n' )\"" (continue e) 299 | |> ir_octostring 300 | | Int_to_string i -> 301 | continue 302 | (Output_as_string 303 | (Raw_cmd (None, Fmt.str "printf -- '%%d' %s" (continue i))) ) 304 | |> ir_octostring 305 | | String_to_int s -> 306 | let var = Unique_name.variable "string_to_int" in 307 | let value = Fmt.str "\"$%s\"" var in 308 | let content = continue s |> expand_octal in 309 | (* We put the result of the string expression in a variable to 310 | evaluate it once; then we test that the result is an integer 311 | (i.e. ["test ... -eq ...."] parses it as an integer). *) 312 | Fmt.str 313 | " $( %s=$( %s ) ; if [ %s -eq %s ] ; then printf -- %s ; else %s ; fi \ 314 | ; ) " 315 | var content value value value 316 | (die 317 | (String_to_int_failure 318 | {variable= var; content; code= Format.asprintf "%a" pp s} ) ) 319 | |> ir_int 320 | | Bool_to_string b -> 321 | continue 322 | (Output_as_string 323 | (Raw_cmd 324 | ( None 325 | , Fmt.str 326 | "{ if %s ; then printf true ; else printf false ; fi ; }" 327 | (continue b) ) ) ) 328 | |> ir_octostring 329 | | String_to_bool s -> 330 | continue 331 | (If 332 | ( String_operator 333 | (C_string_to_byte_array s, `Eq, Literal (Literal.String "true")) 334 | , Raw_cmd (None, "true") 335 | , If 336 | ( String_operator 337 | ( C_string_to_byte_array s 338 | , `Eq 339 | , Literal (Literal.String "false") ) 340 | , Raw_cmd (None, "false") 341 | , Fail (Fmt.str "String_to_bool") ) ) ) 342 | |> ir_bool 343 | | List l -> 344 | (* Lists are space-separated internal represetations, 345 | prefixed by `G`. *) 346 | let output o = Fmt.str "printf -- 'G%%s' \"%s\"" (continue o) in 347 | let outputs = List.map l ~f:output in 348 | let rec build = function 349 | | [] -> [] 350 | | [one] -> [one] 351 | | one :: two :: t -> one :: "printf -- ' '" :: build (two :: t) in 352 | seq (build outputs) |> ir_list 353 | | List_to_string (l, _) -> 354 | continue (Output_as_string (Raw_cmd (None, continue l))) |> ir_octostring 355 | | String_to_list (s, _) -> 356 | continue s |> expand_octal 357 | |> Fmt.str "printf -- '%%s' \"$(%s)\"" 358 | |> ir_list 359 | | C_string_concat sl -> 360 | let outputing_list = continue sl in 361 | Fmt.str "$( { %s ; } | tr -d 'G ' )" outputing_list |> ir_octostring 362 | | Byte_array_concat sl -> 363 | let outputing_list = continue sl in 364 | Fmt.str "$( { %s ; } | tr -d 'G ' )" outputing_list |> ir_octostring 365 | | List_append (la, lb) -> 366 | seq [continue la; "printf -- ' '"; continue lb] |> ir_list 367 | | List_iter (l, f) -> 368 | let variter = Unique_name.variable "list_iter_var" in 369 | let outputing_list = continue l in 370 | seq 371 | [ Fmt.str "for %s in $(%s) " variter outputing_list; "do : " 372 | ; (* we cannot put a `;` after do so the first command is no-op *) 373 | continue 374 | (f (fun () -> 375 | (* Here we remove the `G` from the internal represetation: *) 376 | Raw_cmd (None, Fmt.str "${%s#G}" variter) ) ); "done" ] 377 | |> ir_unit 378 | | Int_bin_op (ia, op, ib) -> 379 | Fmt.str "$(( %s %s %s ))" (continue ia) 380 | ( match op with 381 | | `Div -> "/" 382 | | `Minus -> "-" 383 | | `Mult -> "*" 384 | | `Plus -> "+" 385 | | `Mod -> "%" ) 386 | (continue ib) 387 | |> ir_int 388 | | Int_bin_comparison (ia, op, ib) -> 389 | Fmt.str "[ %s %s %s ]" (continue ia) 390 | ( match op with 391 | | `Eq -> "-eq" 392 | | `Ge -> "-ge" 393 | | `Gt -> "-gt" 394 | | `Le -> "-le" 395 | | `Lt -> "-lt" 396 | | `Ne -> "-ne" ) 397 | (continue ib) 398 | |> ir_int 399 | | Feed (string, e) -> 400 | Fmt.str {sh| %s | %s |sh} (continue string |> expand_octal) (continue e) 401 | |> ir_unit 402 | | Pipe [] -> ":" |> ir_unit 403 | | Pipe l -> 404 | Fmt.str " %s " (List.map l ~f:continue |> String.concat ~sep:" | ") 405 | |> ir_unit 406 | | Getenv s -> 407 | let var = Unique_name.variable "getenv" in 408 | let value = Fmt.str "\"$%s\"" var in 409 | let cmd_outputs_value = 410 | (* We need to get the output of the `string t` and then do a `$` 411 | on it: 412 | f () { printf "HOME" ;} 413 | aa=$(printf "\${%s}" $(f)) ; eval "printf \"$aa\"" 414 | And the `` | tr -d '\\n' `` part is because `\n` in the variable name 415 | just “cuts” it, it wouldn't fail and `${HOME\nBOUH}` would be 416 | equal to `${HOME}` 417 | *) 418 | Fmt.str 419 | "{ %s=$(printf \\\"\\${%%s}\\\" $(%s | tr -d '\\n')) ; eval \"printf \ 420 | -- '%%s' %s\" ; } " 421 | var 422 | (continue s |> expand_octal) 423 | value in 424 | continue (Output_as_string (Raw_cmd (None, cmd_outputs_value))) 425 | |> ir_octostring 426 | | Setenv (variable, value) -> 427 | Fmt.str "export $(%s)=\"$(%s)\"" 428 | (continue variable |> expand_octal) 429 | (continue value |> expand_octal) 430 | |> ir_unit 431 | | Fail s -> die (User s) |> ir_death 432 | | Comment (cmt, expr) -> ( 433 | match continue_match ~add_comment:cmt expr with 434 | | Unit u -> 435 | Fmt.str " { %s ; %s ; }" Construct.(exec [":"; cmt] |> continue) u 436 | |> ir_unit 437 | | (Octostring _ | Int _ | Bool _ | List _ | Death _) as d -> d ) 438 | 439 | let to_shell options expr = to_ir [] options expr |> ir_to_shell 440 | 441 | (* 442 | POSIX does not have ["set -o pipefail"]. 443 | We implement it by killing the toplevel process with SIGUSR1, then we use 444 | ["trap"] to choose the exit status. 445 | *) 446 | let with_die_function ~print_failure ~statement_separator ~signal_name 447 | ?(trap = `Exit_with 77) script = 448 | let variable_name = Unique_name.variable "genspio_trap" in 449 | let die ~comment_stack s = 450 | let pr = print_failure ~comment_stack s in 451 | Fmt.str " { %s ; kill -s %s ${%s} ; } " pr signal_name variable_name in 452 | String.concat ~sep:statement_separator 453 | [ Fmt.str "export %s=$$" variable_name 454 | ; ( match trap with 455 | | `Exit_with ex -> Fmt.str "trap 'exit %d' %s" ex signal_name 456 | | `None -> ": 'No Trap'" ); script ~die ] 457 | -------------------------------------------------------------------------------- /src/lib/EDSL_v0.mli: -------------------------------------------------------------------------------- 1 | (** The “legacy” Embedded Domain Specific Lanaguage.” 2 | 3 | This is the 0.1.0 version of the EDSL. It is lower-level than {!EDSL} 4 | as it explicitly separates the types {!byte_array} and {!c_string} 5 | while the functions in the {!EDSL} module {i “hide”} the conversions 6 | {!byte_array} → {!c_string} in the API. 7 | 8 | *) 9 | 10 | (** The type of a Genspio expression. *) 11 | type 'a t = 'a Language.t 12 | 13 | (** Type to encode arbitrary byte-arrays in the EDSL as 14 | [byte_array t] values, OCaml literal strings or the outputs (as in 15 | [stdout]) of processes are byte-arrays. *) 16 | type byte_array = Language.byte_array 17 | 18 | (** Type to encode NUL-terminated strings in the EDSL as 19 | [c_string t] values. C-strings cannot contain the ['\x00'] character. 20 | The command line arguments of commands as well as the contents of 21 | environment variables must be C-strings. *) 22 | type c_string = Language.c_string 23 | 24 | (** {3 Literals } *) 25 | 26 | val c_string : string -> c_string t 27 | (** Create a {!type:c_string} literal. *) 28 | 29 | val string : string -> c_string t 30 | (** [string] is an alias for {!function:c_string}. *) 31 | 32 | val byte_array : string -> byte_array t 33 | (** Create a {!type:byte_array} literal. *) 34 | 35 | val int : int -> int t 36 | val bool : bool -> bool t 37 | 38 | (** {3 Comments} *) 39 | 40 | val comment : string -> 'a t -> 'a t 41 | (** Add a “comment” string to an expression (will be displayed in 42 | error messages happening inside the expression). *) 43 | 44 | val ( %%% ) : string -> 'a t -> 'a t 45 | (** ["Some comment" %%% expr] is an alias for [comment "Some comment" expr]. *) 46 | 47 | (** {3 Basic system Commands} *) 48 | 49 | val call : c_string t list -> unit t 50 | (** Call a command from its list of “arguments” (including the first 51 | argument being the actual command). *) 52 | 53 | val exec : string list -> unit t 54 | (** Like {!call} but with string literals; i.e. [exec ["a"; "b"]] is 55 | actually [call [string "a"; string "b"]] which is the usual shell command 56 | ["a b"] (with proper escaping). *) 57 | 58 | val getenv : c_string t -> c_string t 59 | (** Get the value of an environment variable as a string; 60 | it returns the empty string when the variable is not defined. 61 | If the argument is not a valid variable name, behavior is 62 | undefined. 63 | *) 64 | 65 | val setenv : var:c_string t -> c_string t -> unit t 66 | (** Set the value of an environment variable as a string; 67 | it returns the empty string is the variable is not defined. 68 | 69 | If the [~var] argument is not a valid variable name or if the value does 70 | not fit in a shell variable (e.g. newlines), behavior is undefined. 71 | 72 | Also, the total environment of a UNIX process counts towards the 73 | total size of the arguments passed on to a sub-process (see 74 | usually the result of ["getconf ARG_MAX"]). Genspio does not check 75 | for that limit which is not that high in some operating systems 76 | (e.g. about 200 KiB on the {i MacOSX Sierra} that the Travis CI 77 | runs …). You might prefer putting or accumulating things in a 78 | {!tmp_file}. 79 | *) 80 | 81 | (** {3 Boolean Expressions} *) 82 | 83 | val ( &&& ) : bool t -> bool t -> bool t 84 | val ( ||| ) : bool t -> bool t -> bool t 85 | val not : bool t -> bool t 86 | 87 | val returns : 'a t -> value:int -> bool t 88 | (** Check the return value of a command/expression/script. *) 89 | 90 | val succeeds : 'a t -> bool t 91 | (** [succeeds expr] is equivalent to [returns expr ~value:0]. *) 92 | 93 | val file_exists : c_string t -> bool t 94 | (** Check whether a file exists, i.e. a shortcut for 95 | [call [c_string "test"; c_string "-f"; path] |> succeeds]. *) 96 | 97 | (** Conversions of the [bool t] type. *) 98 | module Bool : sig 99 | val to_string : bool t -> c_string t val of_string : c_string t -> bool t 100 | end 101 | 102 | (** {3 Integer Arithmetic} *) 103 | 104 | (** Functions on [int t] values (arithmetic, comparisons, conversions, etc.). *) 105 | module Integer : sig 106 | val to_string : int t -> c_string t 107 | val to_byte_array : int t -> byte_array t 108 | val of_string : c_string t -> int t 109 | val of_byte_array : byte_array t -> int t 110 | val bin_op : int t -> [`Div | `Minus | `Mult | `Plus | `Mod] -> int t -> int t 111 | val add : int t -> int t -> int t 112 | val ( + ) : int t -> int t -> int t 113 | val sub : int t -> int t -> int t 114 | val ( - ) : int t -> int t -> int t 115 | val mul : int t -> int t -> int t 116 | val ( * ) : int t -> int t -> int t 117 | val div : int t -> int t -> int t 118 | val ( / ) : int t -> int t -> int t 119 | val modulo : int t -> int t -> int t 120 | val ( mod ) : int t -> int t -> int t 121 | val cmp : [`Eq | `Ge | `Gt | `Le | `Lt | `Ne] -> int t -> int t -> bool t 122 | val eq : int t -> int t -> bool t 123 | val ne : int t -> int t -> bool t 124 | val lt : int t -> int t -> bool t 125 | val le : int t -> int t -> bool t 126 | val ge : int t -> int t -> bool t 127 | val gt : int t -> int t -> bool t 128 | val ( = ) : int t -> int t -> bool t 129 | val ( <> ) : int t -> int t -> bool t 130 | val ( < ) : int t -> int t -> bool t 131 | val ( <= ) : int t -> int t -> bool t 132 | val ( >= ) : int t -> int t -> bool t 133 | val ( > ) : int t -> int t -> bool t 134 | end 135 | 136 | (** {3 EDSL Lists} *) 137 | 138 | (** Functions on ['a list t] values. *) 139 | module Elist : sig 140 | val make : 'a t list -> 'a list t 141 | (** Make an EDSL list out of an OCaml list. *) 142 | 143 | val append : 'a list t -> 'a list t -> 'a list t 144 | (** Concatenate two EDSL lists. *) 145 | 146 | val iter : 'a list t -> f:((unit -> 'a t) -> unit t) -> unit t 147 | (** Iterate over a list, the body of the loop [~f] takes as argument 148 | function that returns the current eletment at the EDSL level. *) 149 | 150 | val serialize_byte_array_list : byte_array list t -> byte_array t 151 | val deserialize_to_byte_array_list : byte_array t -> byte_array list t 152 | val serialize_c_string_list : c_string list t -> byte_array t 153 | val deserialize_to_c_string_list : byte_array t -> c_string list t 154 | val serialize_int_list : int list t -> byte_array t 155 | val deserialize_to_int_list : byte_array t -> int list t 156 | end 157 | 158 | (** {3 String Manipulation} *) 159 | 160 | module Byte_array : sig 161 | val ( =$= ) : byte_array t -> byte_array t -> bool t 162 | val ( <$> ) : byte_array t -> byte_array t -> bool t 163 | val to_c_string : byte_array t -> c_string t 164 | val to_c : byte_array t -> c_string t 165 | end 166 | 167 | module C_string : sig 168 | val equals : c_string t -> c_string t -> bool t 169 | val ( =$= ) : c_string t -> c_string t -> bool t 170 | val ( <$> ) : c_string t -> c_string t -> bool t 171 | val to_byte_array : c_string t -> byte_array t 172 | val to_bytes : c_string t -> byte_array t 173 | 174 | val concat_list : c_string t list -> c_string t 175 | (** Concatenate an (OCaml) list of [c_string t] values. *) 176 | 177 | val concat_elist : c_string list t -> c_string t 178 | (** Concatenate a Genspio list of strings [c_string list t]. *) 179 | end 180 | 181 | (** {3 Control Flow} *) 182 | 183 | val nop : unit t 184 | (** The silent “no-operation.” *) 185 | 186 | val if_then_else : bool t -> unit t -> unit t -> unit t 187 | val if_then : bool t -> unit t -> unit t 188 | 189 | val seq : unit t list -> unit t 190 | (** Sequence a list of expressions into an expression. *) 191 | 192 | val loop_while : bool t -> body:unit t -> unit t 193 | (** Build a while loop. *) 194 | 195 | val loop_seq_while : bool t -> unit t list -> unit t 196 | (** [loop_seq_while condition body] is a shortcut for 197 | [loop_while condition ~body:(seq body)]. *) 198 | 199 | val if_seq : t:unit t list -> ?e:unit t list -> bool t -> unit t 200 | (** [if_seq c ~t ~e] is an alternate API for {!if_then_else} (when 201 | [?e] is provided) or {!if_then} (otherwise) that takes “then” 202 | and “else” bodies which are lists for the {!seq} construct. *) 203 | 204 | (** {3 Switch Statements } *) 205 | 206 | val switch : [`Case of bool t * unit t | `Default of unit t] list -> unit t 207 | (** Create a switch statement from a list of {!case} and optionally a 208 | {!default} (the function raises an exception if there are more 209 | than one default cases). *) 210 | 211 | val case : bool t -> unit t list -> [> `Case of bool t * unit t] 212 | (** Create a normal case for a {!switch} statement. *) 213 | 214 | val default : unit t list -> [> `Default of unit t] 215 | (** Create the default case for a {!switch} statement. *) 216 | 217 | (**/**) 218 | 219 | val make_switch : 220 | (bool Language.t * unit Language.t) list 221 | -> default:unit Language.t 222 | -> unit Language.t 223 | 224 | (**/**) 225 | 226 | (** {3 Redirections and File Descriptors } *) 227 | 228 | (** Abstract type of file-descriptor redirections. *) 229 | type fd_redirection 230 | 231 | val to_fd : int t -> int t -> fd_redirection 232 | (** Create a file-descriptor to file-descriptor redirection. *) 233 | 234 | val to_file : int t -> c_string t -> fd_redirection 235 | (** Create a file-descriptor to file redirection. *) 236 | 237 | val with_redirections : unit t -> fd_redirection list -> unit t 238 | (** 239 | Run a [unit t] expression after applying a list of file-descriptor 240 | redirections. 241 | 242 | The redirections are applied in the list's order (which means they 243 | can be more easily {i followed} in reverse order), see the 244 | “Arbitrary Redirections” example. 245 | 246 | Invalid cases, like redirecting to a file-descriptor has not been 247 | opened, lead to undefined behavior; see 248 | {{:https://github.com/hammerlab/genspio/issues/41}issue #41}. 249 | If the shell is POSIX, the whole expression [with_redirections expr redirs] 250 | exits and its return value is in [[1, 125]]; if the shell is 251 | ["bash"] or ["zsh"], the failing redirection is just ignored and [expr] is 252 | executed with the remaining redirections if any. 253 | *) 254 | 255 | val write_output : 256 | ?stdout:c_string t 257 | -> ?stderr:c_string t 258 | -> ?return_value:c_string t 259 | -> unit t 260 | -> unit t 261 | (** Redirect selected streams or the return value to files ([stdout], 262 | [stderr], [return_value] are paths). *) 263 | 264 | val write_stdout : path:c_string t -> unit t -> unit t 265 | (** [write_stdout ~path expr] is [write_output expr ~stdout:path]. *) 266 | 267 | val pipe : unit t list -> unit t 268 | (** Pipe commands together (["stdout"] into ["stdin"] exactly like the 269 | [" | "] operator). *) 270 | 271 | val ( ||> ) : unit t -> unit t -> unit t 272 | (** [a ||> b] is a shortcut for [pipe [a; b]]. *) 273 | 274 | val get_stdout : unit t -> byte_array t 275 | (** Get the contents of [stdout] into a byte array (in previous 276 | versions this function was called [output_as_string]). *) 277 | 278 | val feed : string:byte_array t -> unit t -> unit t 279 | (** Feed some content ([~string]) into the ["stdin"] filedescriptor of 280 | a [unit t] expression. *) 281 | 282 | val ( >> ) : byte_array t -> unit t -> unit t 283 | (** [str >> cmd] is [feed ~string:str cmd]. *) 284 | 285 | val printf : c_string t -> c_string t list -> unit t 286 | (** [printf fmt l] is [call (string "printf" :: string "--" :: fmt :: l)]. *) 287 | 288 | val eprintf : c_string t -> c_string t list -> unit t 289 | (** Like {!printf} but redirected to ["stderr"]. *) 290 | 291 | (** {3 Escaping The Execution Flow } *) 292 | 293 | val fail : string -> unit t 294 | (** Expression that aborts the whole script/command immediately, it 295 | will try to output its argument to [stderr] (but this may be 296 | silent depending on the redirections active at a given time). *) 297 | 298 | (** {3 Temporary Files} *) 299 | 300 | (** Abstraction of a file, cf. {!tmp_file}. *) 301 | type file = 302 | < get: byte_array t (** Get the current contents of the file *) 303 | ; get_c: c_string t 304 | ; set: byte_array t -> unit t 305 | ; set_c: c_string t -> unit t 306 | ; append: byte_array t -> unit t 307 | ; delete: unit t 308 | ; path: c_string t > 309 | 310 | val tmp_file : ?tmp_dir:c_string t -> string -> file 311 | (** Create a temporary file that may contain arbitrary strings (can be 312 | used as variable containing [string t] values). 313 | 314 | [tmp_file "foo"] points to a path that is a {b function} 315 | of the string ["foo"]; it does not try to make temporary-files 316 | unique, on the contrary: two calls to [tmp_file "foo"] ensure that 317 | it is the same file. 318 | *) 319 | 320 | (** {3 Command Line Parsing} *) 321 | 322 | (** Typed command-line parsing for your shell scripts, à la {!Printf.scanf}. *) 323 | module Command_line : sig 324 | (** 325 | 326 | Use this module like OCaml's {!Printf.scanf} function. 327 | 328 | - Build a command-line “format specification” using the {!Arg} module. 329 | - Call the {!parse} function with an appropriately typed function. 330 | 331 | Example: 332 | Here is a potential argument specification for a shell script 333 | that downloads and unarchives them (see also ["src/test/examples.ml"]). 334 | {[ 335 | let cli_spec = 336 | Command_line.Arg.( 337 | string 338 | ~doc:"The URL to the stuff" ["-u"; "--url"] 339 | ~default:no_value 340 | & flag ["-d"; "--remove-intermediary-files"] 341 | ~doc:"Remove intermediary files." 342 | & string ["-f"; "--local-filename"] 343 | ~doc:"Override the downloaded file-name" 344 | ~default:no_value 345 | & string ["-t"; "--tmp-dir"] 346 | ~doc:"Use as temp-dir" 347 | ~default:(Genspio.EDSL.string "/tmp/genspio-downloader-tmpdir") 348 | & usage "Download archives and decrypt/unarchive them.\n\ 349 | ./downloader -u URL [-c] [-f ] [-t ]" 350 | ) in 351 | (* 352 | `cli_spec` has type: 353 | 354 | (string Genspio.EDSL.t -> 355 | bool Genspio.EDSL.t -> 356 | string Genspio.EDSL.t -> string Genspio.EDSL.t -> unit Genspio.EDSL.t, 357 | unit Genspio.EDSL.t) 358 | Genspio.EDSL.Command_line.cli_options 359 | 360 | so the action function (the second argument to parse) must have type: 361 | 362 | anon:string list Genspio.EDSL.t -> 363 | string Genspio.EDSL.t -> 364 | bool Genspio.EDSL.t -> 365 | string Genspio.EDSL.t -> 366 | string Genspio.EDSL.t -> 367 | unit Genspio.EDSL.t 368 | *) 369 | Command_line.parse cli_spec 370 | (fun ~anon url all_in_tmp filename_ov tmp_dir -> 371 | (* 372 | ... 373 | your code 374 | ... 375 | *) 376 | ]} 377 | *) 378 | 379 | type 'a cli_option = {switches: string list; doc: string; default: 'a} 380 | 381 | type _ option_spec = 382 | | Opt_flag : bool t cli_option -> bool t option_spec 383 | | Opt_string : c_string t cli_option -> c_string t option_spec 384 | 385 | and (_, _) cli_options = 386 | | Opt_end : string -> ('a, 'a) cli_options 387 | | Opt_cons : 388 | 'c option_spec * ('a, 'b) cli_options 389 | -> ('c -> 'a, 'b) cli_options 390 | 391 | module Arg : sig 392 | val string : 393 | ?default:c_string t -> doc:string -> string list -> c_string t option_spec 394 | 395 | val flag : 396 | ?default:bool t -> doc:string -> string list -> bool t option_spec 397 | 398 | val ( & ) : 399 | 'a option_spec -> ('b, 'c) cli_options -> ('a -> 'b, 'c) cli_options 400 | 401 | val usage : string -> ('a, 'a) cli_options 402 | end 403 | 404 | val parse : ('a, unit t) cli_options -> (anon:c_string list t -> 'a) -> unit t 405 | end 406 | 407 | (** {3 Additional Higher-Level Utilities} *) 408 | 409 | val loop_until_true : 410 | ?attempts:int 411 | -> ?sleep:int 412 | -> ?on_failed_attempt:(int t -> unit t) 413 | -> bool t 414 | -> bool t 415 | (** [loop_until_true eval_condition] tries to run [eval_condition] 416 | in a loop until it succeeds. It makes [~attempts] attemps 417 | (default 20), and sleeps for [sleep] seconds (default 2) after 418 | each failed attempt. The argument [~on_failed_attempt] can be 419 | used for instance to display something between each failed 420 | attempt and the call to [sleep], the default is {[ 421 | fun nth -> printf (string "%d.") [Integer.to_string nth] 422 | ]}. 423 | *) 424 | 425 | val silently : unit t -> unit t 426 | (** [silently expr] is [expr] with [stdout] and [stderr] redirected to ["/dev/null"]. *) 427 | 428 | val succeeds_silently : unit t -> bool t 429 | (** [succeeds_silently u] {i is} [silently u |> succeeds]. *) 430 | 431 | val seq_and : 'a t list -> bool t 432 | (** [seq_and [a; b; c]] is like [succeeds a &&& succeeds b &&& succeeds c]. *) 433 | 434 | val output_markdown_code : string -> unit t -> unit t 435 | (** [output_markdown_code "ocaml" (exec ["echo"; "let x = 42"])] 436 | runs its second argument within markdown-like code fences. *) 437 | 438 | val cat_markdown : string -> c_string t -> unit t 439 | (** [cat_markdown tag path] outputs the contents of the file at 440 | [path] (with ["cat"]) within a markdown code bloc. *) 441 | 442 | val check_sequence : 443 | ?verbosity:[`Announce of string | `Output_all | `Silent] 444 | -> ?on_failure: 445 | (step:string * unit t -> stdout:c_string t -> stderr:c_string t -> unit t) 446 | -> ?on_success: 447 | (step:string * unit t -> stdout:c_string t -> stderr:c_string t -> unit t) 448 | -> ?tmpdir:string 449 | -> (string * unit t) list 450 | -> unit t 451 | (** Run a sequence of expressions until the first that fails: 452 | 453 | {ul 454 | {li [?verbosity] configures the output behavior, {ul 455 | {li [`Announce prompt] uses [prompt] to output the name-tag 456 | of the command, the output of the command is redirected 457 | to temporary files (accessible through the [~on_success] and 458 | [~on_failure] functions). 459 | The default value is [`Announce ">> "].} 460 | {li [`Output_all] lets all the output of the commands go through.} 461 | {li [`Silent] is like [`Announce _] but without even the 462 | “prompt” command annoucement.} 463 | } 464 | } 465 | {li [?on_failure] configures what to do when encountering the 466 | first failure, the default is to display on stdout the 467 | name-tag of the failing command and outputting the 468 | contents of its [stdout] and [stderr] log-files (if any) 469 | {b and then} call [exec ["false"]].} 470 | {li [?on_success] is a similar function as [?on_failure], 471 | called before starting the next command, the default is to 472 | do nothing.} 473 | {li [?tmpdir] configures where to create the logging files.} 474 | } 475 | 476 | 477 | *) 478 | 479 | val on_stdin_lines : (c_string t -> unit t) -> unit t 480 | (** [on_stdin_lines body] builds a loop that iterates over the lines of the [stdin] 481 | file descriptor. The argument of `body` is the current line. 482 | Note that this is for text-like input, ['\000'] 483 | characters in the input lead to undefined behavior. *) 484 | 485 | (** {3 Very Unsafe Operations} *) 486 | 487 | (** The {!Magic} module is like OCaml's {!Obj.magic} function for the 488 | EDSL; it allows one to bypass typing. *) 489 | module Magic : sig 490 | val unit : string -> unit t 491 | (** Put any string as a [unit t] command inline ([Magic.unit s] 492 | is different from [exec ["sh"; "-c"; s]] there is no escaping or 493 | protection). *) 494 | end 495 | -------------------------------------------------------------------------------- /src/lib/EDSL.ml: -------------------------------------------------------------------------------- 1 | open Common 2 | 3 | type 'a t = 'a Language.t 4 | type c_string = Language.c_string 5 | type byte_array = Language.byte_array 6 | type fd_redirection = Language.fd_redirection 7 | 8 | let ( // ) = Caml.Filename.concat 9 | 10 | open Language.Construct 11 | include Language.Construct.Base 12 | module Magic = Magic 13 | 14 | type str = Language.byte_array 15 | 16 | let str = byte_array 17 | let string = str 18 | 19 | module Str = struct 20 | include Byte_array 21 | 22 | let equals = ( =$= ) 23 | let concat_elist e = byte_array_concat_list e 24 | let concat_list l = concat_elist (Elist.make l) 25 | end 26 | 27 | let call l = call @@ List.map ~f:to_c_string l 28 | let strs l = List.map ~f:str l 29 | let exec l = call (strs l) 30 | let getenv str = getenv (to_c_string str) |> to_byte_array 31 | let setenv ~var v = setenv ~var:(to_c_string var) (to_c_string v) 32 | let file_exists s = file_exists (to_c_string s) 33 | 34 | let write_output ?stdout ?stderr ?return_value u = 35 | let stdout = Option.map stdout ~f:to_c_string in 36 | let stderr = Option.map stderr ~f:to_c_string in 37 | let return_value = Option.map return_value ~f:to_c_string in 38 | write_output ?stdout ?stderr ?return_value u 39 | 40 | let to_file take file = to_file take (to_c_string file) 41 | let write_stdout ~path expr = write_output expr ~stdout:path 42 | 43 | module Elist = struct 44 | include Elist 45 | 46 | let serialize_str_list sl = serialize_byte_array_list sl 47 | let deserialize_to_str_list sl = deserialize_to_byte_array_list sl 48 | end 49 | 50 | module Bool = struct 51 | let of_string s = Bool.of_string (to_c_string s) 52 | let to_string b = Bool.to_string b |> to_byte_array 53 | end 54 | 55 | module Integer = struct 56 | include Integer 57 | 58 | let to_str = to_byte_array 59 | let of_str = of_byte_array 60 | end 61 | 62 | let case condition body = `Case (condition, seq body) 63 | let default d = `Default (seq d) 64 | 65 | let switch l = 66 | let default = ref None in 67 | let cases = 68 | List.filter_map l ~f:(function 69 | | `Default _ when Poly.(!default <> None) -> 70 | failwith "Cannot build switch with >1 defaults" 71 | | `Default d -> 72 | default := Some d ; 73 | None 74 | | `Case t -> Some t ) in 75 | make_switch ~default:(Option.value ~default:nop !default) cases 76 | 77 | (* 78 | let string_list_to_string l = 79 | Elist.to_string ~f:(fun e -> to_byte_array e) l |> to_c_string 80 | 81 | let string_list_of_string s = 82 | Elist.of_string ~f:(fun e -> to_c_string e) (to_byte_array s) 83 | *) 84 | 85 | type file = 86 | < get: str t 87 | ; set: str t -> unit t 88 | ; append: str t -> unit t 89 | ; delete: unit t 90 | ; path: str t > 91 | 92 | let tmp_file ?tmp_dir name : file = 93 | let default_tmp_dir = "/tmp" in 94 | let get_tmp_dir = 95 | Option.value tmp_dir 96 | ~default: 97 | (get_stdout 98 | ((* https://en.wikipedia.org/wiki/TMPDIR *) 99 | if_then_else 100 | Str.(getenv (str "TMPDIR") <$> str "") 101 | (call [str "printf"; str "%s"; getenv (str "TMPDIR")]) 102 | (exec ["printf"; "%s"; default_tmp_dir]) ) ) in 103 | let path = 104 | let clean = 105 | String.map name ~f:(function 106 | | ('a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-') as c -> c 107 | | _ -> '_' ) in 108 | Str.concat_list 109 | [ get_tmp_dir; str "/" 110 | ; str 111 | (Fmt.str "genspio-tmp-file-%s-%s" clean 112 | Caml.Digest.(string name |> to_hex) ) ] in 113 | let tmp = Str.concat_list [path; string "-tmp"] in 114 | object (_self) 115 | method get = get_stdout (call [string "cat"; path]) 116 | method path = path 117 | 118 | method set v = 119 | seq 120 | [ (* call [string "echo"; string "Setting "; string name]; *) 121 | (* call [string "echo"; string "Setting "; path; string " to "; v]; *) 122 | (* call [string "echo"; tmp]; *) 123 | v >> exec ["cat"] |> write_output ~stdout:tmp 124 | ; call [string "mv"; string "-f"; tmp; path] ] 125 | 126 | (* method set_c c = self#set (to_byte_array c) *) 127 | method append v = 128 | seq 129 | [ seq [call [string "cat"; path]; v >> exec ["cat"]] 130 | |> write_output ~stdout:tmp 131 | ; call [string "mv"; string "-f"; tmp; path] ] 132 | 133 | method delete = call [string "rm"; string "-f"; path; tmp] 134 | end 135 | 136 | let if_seq ~t ?e c = 137 | match e with 138 | | None -> if_then c (seq t) 139 | | Some f -> if_then_else c (seq t) (seq f) 140 | 141 | let printf fmt l = call (string "printf" :: string "--" :: fmt :: l) 142 | let with_stdout_to_stderr cmd = with_redirections cmd [to_fd (int 1) (int 2)] 143 | let eprintf fmt l = with_stdout_to_stderr (printf fmt l) 144 | 145 | module Command_line = struct 146 | type 'a cli_option = {switches: string list; doc: string; default: 'a} 147 | 148 | type _ option_spec = 149 | | Opt_flag : bool t cli_option -> bool t option_spec 150 | | Opt_string : str t cli_option -> str t option_spec 151 | 152 | and (_, _) cli_options = 153 | | Opt_end : string -> ('a, 'a) cli_options 154 | | Opt_cons : 155 | 'c option_spec * ('a, 'b) cli_options 156 | -> ('c -> 'a, 'b) cli_options 157 | 158 | module Arg = struct 159 | let string ?(default = string "") ~doc switches = 160 | Opt_string {switches; doc; default} 161 | 162 | let flag ?(default = bool false) ~doc switches = 163 | Opt_flag {switches; doc; default} 164 | 165 | let ( & ) x y = Opt_cons (x, y) 166 | let usage s = Opt_end s 167 | end 168 | 169 | let parse (options : ('a, unit t) cli_options) (action : anon:str list t -> 'a) 170 | : unit t = 171 | let prefix = Common.Unique_name.variable "getopts" in 172 | let variable {switches; _} = 173 | Fmt.str "%s_%s" prefix 174 | ( String.concat ~sep:"" switches 175 | |> Caml.Digest.string |> Caml.Digest.to_hex ) in 176 | let inits = ref [] in 177 | let to_init s = inits := s :: !inits in 178 | let cases = ref [] in 179 | let to_case s = cases := s :: !cases in 180 | let help_intro = ref "" in 181 | let help = ref [] in 182 | let to_help s = help := s :: !help in 183 | let string_of_var var = getenv (string var) in 184 | let bool_of_var var = getenv (string var) |> Bool.of_string in 185 | let anon_var = Fmt.kstr str "%s_anon" prefix in 186 | let anon = anon_var |> getenv |> Elist.deserialize_to_str_list in 187 | let applied_action = 188 | (* 189 | The [loop] function below is building 3 pieces of Genspio code at once: 190 | 191 | - variable initializations 192 | - individual case statements (including variable assignments) 193 | that are part of the ["while true { switch { .... } }"] loop 194 | that incrementally interprets each command line argument. 195 | - [applied_action] (of type [unit t]) is the 196 | the result of applying the [action] function to all the elements of 197 | [options] + the list of anonymous arguments. 198 | It is hence the (user-provided) code that uses the parsed arguments. 199 | The [loop] function builds the closure as the loop goes since 200 | [options] is a “difference list”, see also: 201 | {{:https://drup.github.io/2016/08/02/difflists/}Drup's blog post}. 202 | 203 | The 2 first items are agglomerated in the [inits] and [cases] 204 | references. 205 | *) 206 | let rec loop : type a b. a -> (a, b) cli_options -> b = 207 | fun f -> function 208 | | Opt_end doc -> 209 | help_intro := doc ; 210 | f 211 | | Opt_cons (Opt_string x, more) -> 212 | let var = variable x in 213 | to_init (setenv ~var:(string var) x.default) ; 214 | to_case 215 | (case 216 | (List.fold ~init:(bool false) x.switches ~f:(fun p s -> 217 | p ||| Str.(str s =$= getenv (str "1")) ) ) 218 | [ if_seq 219 | Str.(getenv (string "2") =$= string "") 220 | ~t: 221 | [ eprintf 222 | (string "ERROR option '%s' requires an argument\\n") 223 | [getenv (string "1")]; fail "Wrong command line" ] 224 | ~e:[setenv ~var:(string var) (getenv (string "2"))] 225 | ; exec ["shift"]; exec ["shift"] ] ) ; 226 | Fmt.kstr to_help "* `%s `: %s" 227 | (String.concat ~sep:"," x.switches) 228 | x.doc ; 229 | loop (f (string_of_var var)) more 230 | | Opt_cons (Opt_flag x, more) -> 231 | let var = variable x in 232 | to_init (setenv ~var:(string var) (Bool.to_string x.default)) ; 233 | to_case 234 | (case 235 | (List.fold ~init:(bool false) x.switches ~f:(fun p s -> 236 | p ||| Str.equals (string s) (getenv (string "1")) ) ) 237 | [ setenv ~var:(string var) (Bool.to_string (bool true)) 238 | ; exec ["shift"] ] ) ; 239 | Fmt.kstr to_help "* `%s`: %s" 240 | (String.concat ~sep:"," x.switches) 241 | x.doc ; 242 | loop (f (bool_of_var var)) more in 243 | loop (action ~anon) options in 244 | let help_msg = 245 | Fmt.str "%s\n\nOptions:\n\n%s\n" !help_intro 246 | (String.concat ~sep:"\n" (List.rev !help)) in 247 | let help_flag_var = Fmt.kstr string "%s_help" prefix in 248 | let while_loop = 249 | let body = 250 | let append_anon_arg_to_list = 251 | setenv ~var:anon_var 252 | ( Elist.append anon (Elist.make [getenv (string "1")]) 253 | |> Elist.serialize_str_list ) in 254 | let help_case = 255 | let help_switches = ["-h"; "-help"; "--help"] in 256 | case 257 | (List.fold ~init:(bool false) help_switches ~f:(fun p s -> 258 | p ||| Str.(str s =$= getenv (str "1")) ) ) 259 | [ setenv ~var:help_flag_var (Bool.to_string (bool true)) 260 | ; byte_array help_msg >> exec ["cat"]; exec ["break"] ] in 261 | let dash_dash_case = 262 | case 263 | Str.(getenv (str "1") =$= str "--") 264 | [ exec ["shift"] 265 | ; loop_while 266 | Str.(getenv (str "#") <$> str "0") 267 | ~body:(seq [append_anon_arg_to_list; exec ["shift"]]) 268 | ; exec ["break"] ] in 269 | let anon_case = 270 | case 271 | Str.(getenv (str "#") <$> str "0") 272 | [append_anon_arg_to_list; exec ["shift"]] in 273 | let default_case = default [exec ["break"]] in 274 | let cases = 275 | (help_case :: List.rev !cases) 276 | @ [dash_dash_case; anon_case; default_case] in 277 | seq [switch cases] in 278 | loop_while (bool true) ~body in 279 | seq 280 | [ setenv ~var:help_flag_var (Bool.to_string (bool false)) 281 | ; setenv ~var:anon_var (Elist.serialize_byte_array_list (Elist.make [])) 282 | ; seq (List.rev !inits); while_loop 283 | ; if_then_else (bool_of_var (Fmt.str "%s_help" prefix)) nop applied_action 284 | ] 285 | end 286 | 287 | let loop_until_true ?(attempts = 20) ?(sleep = 2) 288 | ?(on_failed_attempt = fun nth -> printf (string "%d.") [Integer.to_str nth]) 289 | cmd = 290 | let intvar = 291 | let varname = string "C_ATTEMPTS" in 292 | object 293 | method set v = setenv ~var:varname (Integer.to_str v) 294 | method get = getenv varname |> Integer.of_str 295 | end in 296 | seq 297 | [ intvar#set (int 1) 298 | ; loop_while 299 | (Integer.(intvar#get <= int attempts) &&& not cmd) 300 | ~body: 301 | (seq 302 | [ on_failed_attempt intvar#get 303 | ; intvar#set Integer.(intvar#get + int 1) 304 | ; if_then 305 | Integer.(intvar#get <= int attempts) 306 | (exec ["sleep"; Fmt.str "%d" sleep]) ] ) 307 | ; if_then_else 308 | Integer.(intvar#get > int attempts) 309 | (seq 310 | [(* Fmt.str "Command failed %d times!" attempts; *) exec ["false"]] ) 311 | (seq [(* Fmt.str "Command failed %d times!" attempts; *) exec ["true"]]) 312 | ] 313 | |> returns ~value:0 314 | 315 | let silently u = 316 | let dev_null = string "/dev/null" in 317 | write_output ~stdout:dev_null ~stderr:dev_null u 318 | 319 | let succeeds_silently u = silently u |> succeeds 320 | let seq_and l = List.fold l ~init:(bool true) ~f:(fun u v -> u &&& succeeds v) 321 | 322 | let output_markdown_code tag f = 323 | seq 324 | [ exec ["printf"; Fmt.str "``````````%s\\n" tag]; f 325 | ; exec ["printf"; Fmt.str "\\n``````````\\n"] ] 326 | 327 | let cat_markdown tag file = output_markdown_code tag @@ call [string "cat"; file] 328 | 329 | let fresh_name suf = 330 | let x = 331 | object 332 | method v = 42 333 | end in 334 | Fmt.str "g-%d-%d-%s" (Caml.Oo.id x) (Random.int 100_000) suf 335 | 336 | let sanitize_name n = 337 | String.map n ~f:(function 338 | | ('0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' | '-') as c -> c 339 | | _ -> '_' ) 340 | 341 | let default_on_failure ~step:(i, _) ~stdout ~stderr = 342 | seq 343 | [ printf (Fmt.kstr str "Step '%s' FAILED:\\n" i) [] 344 | ; cat_markdown "stdout" stdout; cat_markdown "stderr" stderr; exec ["false"] 345 | ] 346 | 347 | let check_sequence ?(verbosity = `Announce ">> ") 348 | ?(on_failure = default_on_failure) 349 | ?(on_success = fun ~step:_ ~stdout:_ ~stderr:_ -> nop) ?(tmpdir = "/tmp") 350 | cmds = 351 | let tmp_prefix = fresh_name "-cmd" in 352 | let tmpout which id = 353 | str 354 | ( tmpdir 355 | // Fmt.str "genspio-check-sequence-%s-%s-%s" tmp_prefix which 356 | (sanitize_name id) ) in 357 | let stdout id = tmpout "stdout" id in 358 | let stderr id = tmpout "stderr" id in 359 | let log id u = 360 | match verbosity with 361 | | `Silent -> write_output ~stdout:(stdout id) ~stderr:(stderr id) u 362 | | `Announce prompt -> 363 | seq 364 | [ eprintf (Fmt.kstr str "%s %s\\n" prompt id) [] 365 | ; write_output ~stdout:(stdout id) ~stderr:(stderr id) u ] 366 | | `Output_all -> u in 367 | let check idx (nam, u) next = 368 | let id = Fmt.str "%d. %s" idx nam in 369 | if_seq 370 | (log id u |> succeeds) 371 | ~t:[on_success ~step:(id, u) ~stdout:(stdout id) ~stderr:(stderr id); next] 372 | ~e:[on_failure ~step:(id, u) ~stdout:(stdout id) ~stderr:(stderr id)] 373 | in 374 | let rec loop i = function 375 | | one :: more -> check i one (loop (i + 1) more) 376 | | [] -> exec ["true"] in 377 | loop 1 cmds 378 | 379 | let on_stdin_lines body = 380 | let fresh = Common.Unique_name.variable "read_stdin" in 381 | loop_while 382 | (exec ["read"; "-r"; fresh] |> succeeds) 383 | ~body:(seq [exec ["export"; fresh]; body (getenv (string fresh))]) 384 | 385 | let command_available executable = 386 | succeeds_silently (call [str "command"; str "-v"; executable]) 387 | 388 | let get_stdout_one_line ?(first_line = false) ?(remove_spaces = false) u = 389 | get_stdout 390 | ( (if first_line then u ||> exec ["head"; "-n"; "1"] else u) 391 | ||> exec ["tr"; "-d"; (if remove_spaces then " \\n" else "\\n")] ) 392 | 393 | let verbose_call ?(prefix = "CALL: ") ?(verbose = bool true) l = 394 | if_seq verbose 395 | ~t: 396 | [ eprintf (Fmt.kstr str "%s[" prefix) [] 397 | ; seq @@ List.map l ~f:(fun ex -> eprintf (string "%s ") [ex]) 398 | ; eprintf (string "]\\n") []; call l ] 399 | ~e:[call l] 400 | 401 | let check_sequence_with_output l = 402 | check_sequence ~verbosity:`Output_all 403 | (List.mapi l ~f:(fun i c -> (Fmt.str "Step-%d" i, c))) 404 | 405 | let is_regular_file path = 406 | call [string "test"; string "-f"; path] |> succeeds_silently 407 | 408 | let is_directory path = 409 | call [string "test"; string "-d"; path] |> succeeds_silently 410 | 411 | let is_executable path = succeeds_silently @@ call [str "test"; str "-x"; path] 412 | let is_readable path = succeeds_silently @@ call [str "test"; str "-r"; path] 413 | let mkdir_p path = call [str "mkdir"; str "-p"; path] 414 | let exit n = exec ["exit"; Int.to_string n] 415 | let home_path () = getenv (str "HOME") 416 | let ( ^$^ ) a b = Str.concat_list [a; b] 417 | let ( /// ) a b = Str.concat_list [a; str "/"; b] 418 | let say fmt l = eprintf (Fmt.kstr string "%s\\n" fmt) l 419 | 420 | let ensure what ~condition ~how = 421 | if_seq condition 422 | ~t:[Fmt.kstr say "%s -> already done" what []] 423 | ~e: 424 | [ check_sequence 425 | ~verbosity:(`Announce (Fmt.str "-> %s: in-progress" what)) 426 | ~on_failure:(fun ~step ~stdout ~stderr -> 427 | seq 428 | [ say "FAILURE: %s" [str (fst step)] 429 | ; with_stdout_to_stderr (cat_markdown "stdout" stdout) 430 | ; with_stdout_to_stderr (cat_markdown "stderr" stderr) 431 | ; fail "FATAL ERROR" ] ) 432 | how 433 | ; if_then_else condition nop 434 | (seq 435 | [ say "FAILURE: %s did not ensure condition!" [str what] 436 | ; fail "FATAL ERROR" ] ) ] 437 | 438 | let greps_to ?(extended_re = false) re u = 439 | let c = [string "grep"] @ (if extended_re then [string "-E"] else []) @ [re] in 440 | succeeds_silently (u ||> call c) 441 | 442 | let pager ?(file_descriptor = str "1") ?disable 443 | ?(default_command = exec ["more"]) () = 444 | let with_disable = 445 | Option.value_map disable ~default:[] ~f:(fun cond -> 446 | [case cond [exec ["cat"]]] ) in 447 | switch 448 | ( with_disable 449 | @ [ case 450 | (call [str "test"; str "-t"; file_descriptor] |> succeeds_silently) 451 | [exec ["cat"]] 452 | ; case 453 | Str.(getenv (str "PAGER") <$> str "") 454 | [call [str "sh"; str "-c"; getenv (str "PAGER")]] 455 | ; default [default_command] ] ) 456 | 457 | module Script_with_describe (P : sig 458 | val name : string val description : string 459 | end) = 460 | struct 461 | include P 462 | 463 | let describe_option_and_usage ?(more_usage = []) () = 464 | let open Command_line.Arg in 465 | flag ["--describe"] ~doc:P.description 466 | & Fmt.kstr usage "usage: %s \n%s.%s" P.name P.description 467 | (List.map more_usage ~f:(Fmt.str "\n%s") |> String.concat ~sep:"") 468 | 469 | let deal_with_describe describe more = 470 | if_seq describe 471 | ~t:[printf (Fmt.kstr string "%s\\n" P.description) []] 472 | ~e:more 473 | end 474 | 475 | module Dispatcher_script = struct 476 | let make ?(aliases = []) ~name ~description () = 477 | let eq_or ~eq s1 l = 478 | match l with 479 | | [] -> bool true 480 | | h :: t -> 481 | List.fold 482 | ~init:(eq s1 (string h)) 483 | t 484 | ~f:(fun p v -> p ||| eq s1 (string v)) in 485 | let pr_usage = 486 | seq 487 | [ printf 488 | (Fmt.kstr string 489 | "usage: %s [OPTIONS/ARGS]\\n\\n%s.\\n\\nSub-commands:\\n" 490 | name description ) 491 | [] 492 | ; (let findgrep = 493 | Fmt.kstr Magic.unit 494 | "{ ls -1 $(echo $PATH | tr ':' ' ') | grep -E '%s-[^-]*$' | \ 495 | sort -u ; } 2> /dev/null" 496 | name in 497 | findgrep 498 | ||> on_stdin_lines (fun line -> 499 | printf (string "* %s: %s\\n") 500 | [ line 501 | ; get_stdout 502 | ( call [line; string "--describe"] 503 | ||> exec ["tr"; "-d"; "\\n"] ) ] ) ) 504 | ; printf (str "Aliases:\\n") [] 505 | ; seq 506 | (List.map aliases ~f:(fun (a, v) -> 507 | printf (str "* %s -> %s\\n") [a; v] ) ) ] in 508 | let dollar_one_empty = Str.(getenv (string "1") =$= string "") in 509 | let tmp = Fmt.kstr tmp_file "%s-call" name in 510 | seq 511 | [ if_seq 512 | ( dollar_one_empty 513 | ||| eq_or ~eq:Str.( =$= ) 514 | (getenv (string "1")) 515 | ["-h"; "--help"; "help"] ) 516 | ~t:[pr_usage] 517 | ~e: 518 | [ if_seq 519 | Str.(getenv (string "1") =$= string "--describe") 520 | ~t:[printf (Fmt.kstr string "%s\\n" description) []] 521 | ~e: 522 | [ write_stdout ~path:tmp#path 523 | (seq 524 | [ printf (str "%s-") [str name] 525 | ; switch 526 | ( List.map aliases ~f:(fun (a, v) -> 527 | case 528 | Str.(a =$= getenv (string "1")) 529 | [printf (str "%s") [v]] ) 530 | @ [default [printf (str "%s") [getenv (str "1")]]] 531 | ); exec ["shift"] 532 | ; loop_seq_while (not dollar_one_empty) 533 | [ printf (str " '") [] 534 | ; getenv (string "1") 535 | >> exec ["sed"; "s/'/'\\\\''/g"] 536 | ; printf (str "'") []; exec ["shift"] ] ] ) 537 | ; call [string "sh"; tmp#path] ] ] ] 538 | end 539 | -------------------------------------------------------------------------------- /src/examples/vm_tester.ml: -------------------------------------------------------------------------------- 1 | open! Base 2 | module Filename = Caml.Filename 3 | 4 | let ( // ) = Filename.concat 5 | 6 | module Shell_script = struct 7 | type t = {name: string; content: unit Genspio.EDSL.t; dependencies: t list} 8 | 9 | open Genspio.EDSL 10 | 11 | let make ?(dependencies = []) name content = {name; content; dependencies} 12 | 13 | let sanitize_name n = 14 | let m = 15 | String.map n ~f:(function 16 | | ('0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' | '-') as c -> c 17 | | _ -> '_' ) in 18 | try String.sub ~pos:0 ~len:40 m with _ -> m 19 | 20 | let path {name; content; _} = 21 | let open Caml in 22 | let hash = Marshal.to_string content [] |> Digest.string |> Digest.to_hex in 23 | let tag = String.sub hash 0 8 in 24 | "_scripts" // Fmt.str "%s_%s.sh" (sanitize_name name) tag 25 | 26 | let call f = exec ["sh"; path f] 27 | 28 | type compiled = {files: (string * string list) list; call: unit Genspio.EDSL.t} 29 | 30 | let rec compile ({name; content; dependencies} as s) = 31 | let filename = path s in 32 | let dep_scripts = List.map ~f:compile dependencies in 33 | (* dbg "name %s filename: %s" name filename; *) 34 | { files= 35 | ( filename 36 | , [ "# Script %s"; "# Generated by Genspio" 37 | ; Fmt.str "echo 'Genspio.Shell_script: %s (%s)'" name filename 38 | ; Genspio.Compile.to_many_lines content ] ) 39 | :: List.concat_map dep_scripts ~f:(fun c -> c.files) 40 | ; call= call s } 41 | end 42 | 43 | module Run_environment = struct 44 | module File = struct 45 | type t = Http of string * [`Xz] option 46 | 47 | let local_file_name = 48 | let noquery url = String.split ~on:'?' url |> List.hd_exn in 49 | function 50 | | Http (url, None) -> "_cache" // Filename.basename (noquery url) 51 | | Http (url, Some `Xz) -> 52 | "_cache" 53 | // Filename.(basename (noquery url) |> fun f -> chop_suffix f ".xz") 54 | 55 | let tmp_name_of_url = function 56 | | Http (url, ext) -> 57 | ("_cache" // Caml.Digest.(string url |> to_hex)) 58 | ^ Option.value_map ~default:"" ext ~f:(fun `Xz -> ".xz") 59 | 60 | let make_files files = 61 | List.map files ~f:(function Http (url, act) as t -> 62 | let base = local_file_name t in 63 | let wget = 64 | let open Genspio.EDSL in 65 | check_sequence 66 | [ ("mkdir", exec ["mkdir"; "-p"; "_cache"]) 67 | ; ( "wget" 68 | , exec ["wget"; url; "--output-document"; tmp_name_of_url t] ) 69 | ; ( "act-and-mv" 70 | , match act with 71 | | None -> exec ["mv"; "-f"; tmp_name_of_url t; base] 72 | | Some `Xz -> 73 | seq 74 | [ exec ["unxz"; "-k"; tmp_name_of_url t] 75 | ; exec 76 | [ "mv"; "-f" 77 | ; Filename.chop_suffix (tmp_name_of_url t) ".xz" 78 | ; base ] ] ) ] in 79 | (base, [], wget) ) 80 | end 81 | 82 | module Ssh = struct 83 | let ssh_options = 84 | [ "-oStrictHostKeyChecking=no"; "-oGlobalKnownHostsFile=/dev/null" 85 | ; "-oUserKnownHostsFile=/dev/null" ] 86 | 87 | let host_file f = Fmt.str "root@@localhost:%s" f 88 | 89 | let sshpass ?password cmd = 90 | match password with None -> cmd | Some p -> ["sshpass"; "-p"; p] @ cmd 91 | 92 | let scp ?password ~ssh_port () = 93 | sshpass ?password @@ ["scp"] @ ssh_options @ ["-P"; Int.to_string ssh_port] 94 | 95 | let script_over_ssh ?root_password ~ssh_port ~name script = 96 | let open Shell_script in 97 | let open Genspio.EDSL in 98 | let script_path = path script in 99 | let tmp = "/tmp" // Filename.basename script_path in 100 | make ~dependencies:[script] (Fmt.str "SSH exec %s" name) 101 | @@ check_sequence 102 | [ ( "scp" 103 | , exec 104 | ( scp ?password:root_password ~ssh_port () 105 | @ [script_path; host_file tmp] ) ) 106 | ; ( "ssh-exec" 107 | , exec 108 | ( sshpass ?password:root_password 109 | @@ ["ssh"] @ ssh_options 110 | @ [ "-p"; Int.to_string ssh_port; "root@localhost" 111 | ; Fmt.str "sh %s" tmp ] ) ) ] 112 | end 113 | 114 | type vm = 115 | | Qemu_arm of 116 | { kernel: File.t 117 | ; sd_card: File.t 118 | ; machine: string 119 | ; initrd: File.t option 120 | ; root_device: string } 121 | | Qemu_amd46 of {hda: File.t; ui: [`No_graphic | `Curses]} 122 | 123 | module Setup = struct 124 | type t = 125 | | Ssh_to_vm of unit Genspio.EDSL.t 126 | | Copy_relative of string * string 127 | 128 | let ssh_to_vm u = [Ssh_to_vm u] 129 | let copy (`Relative src) (`Relative dst) = Copy_relative (src, dst) 130 | end 131 | 132 | type t = 133 | { name: string 134 | ; root_password: string option 135 | ; setup: Setup.t list 136 | ; ssh_port: int 137 | ; local_dependencies: [`Command of string] list 138 | ; vm: vm } 139 | 140 | let make vm ?root_password ?(setup = []) ~local_dependencies ~ssh_port name = 141 | {vm; root_password; setup; local_dependencies; name; ssh_port} 142 | 143 | let qemu_arm ~kernel ~sd_card ~machine ?initrd ~root_device = 144 | make (Qemu_arm {kernel; sd_card; machine; initrd; root_device}) 145 | 146 | let qemu_amd46 ?(ui = `No_graphic) ~hda = make (Qemu_amd46 {hda; ui}) 147 | let http ?act uri = File.Http (uri, act) 148 | 149 | let start_qemu_vm : t -> Shell_script.t = function 150 | | { ssh_port 151 | ; vm= Qemu_arm {kernel; machine; sd_card; root_device; initrd; _} 152 | ; _ } -> 153 | let open Shell_script in 154 | let open Genspio.EDSL in 155 | make "Start-qemu-arm" 156 | (exec 157 | ( [ "qemu-system-arm"; "-M"; machine; "-m"; "1024M"; "-kernel" 158 | ; File.local_file_name kernel ] 159 | @ Option.value_map initrd ~default:[] ~f:(fun f -> 160 | ["-initrd"; File.local_file_name f] ) 161 | @ [ "-pidfile"; "qemu.pid"; "-net"; "nic"; "-net" 162 | ; Fmt.str "user,hostfwd=tcp::%d-:22" ssh_port; "-nographic" 163 | ; "-sd"; File.local_file_name sd_card; "-append" 164 | ; Fmt.str "console=ttyAMA0 verbose debug root=%s" root_device ] 165 | ) ) 166 | | {ssh_port; vm= Qemu_amd46 {hda; ui}; _} -> 167 | (* See https://wiki.qemu.org/Hosts/BSD 168 | qemu-system-x86_64 -m 2048 \ 169 | -hda FreeBSD-11.0-RELEASE-amd64.qcow2 -enable-kvm \ 170 | -netdev user,id=mynet0,hostfwd=tcp:127.0.0.1:7722-:22 \ 171 | -device e1000,netdev=mynet0 *) 172 | let open Shell_script in 173 | let open Genspio.EDSL in 174 | make "Start-qemu" 175 | (exec 176 | ( [ "qemu-system-x86_64" 177 | (* ; "-M" 178 | * ; machine *); "-m" 179 | ; "1024M" (* ; "-enable-kvm" → requires `sudo`?*); "-hda" 180 | ; File.local_file_name hda ] 181 | @ [ "-pidfile"; "qemu.pid"; "-netdev" 182 | ; Fmt.str "user,id=mynet0,hostfwd=tcp::%d-:22" ssh_port 183 | ; ( match ui with 184 | | `Curses -> "-curses" 185 | | `No_graphic -> "-nographic" ); "-device" 186 | ; "e1000,netdev=mynet0" ] ) ) 187 | 188 | let kill_qemu_vm : t -> Shell_script.t = function 189 | | {name; _} -> 190 | let open Genspio.EDSL in 191 | let pid = get_stdout (exec ["cat"; "qemu.pid"]) in 192 | Shell_script.(make (Fmt.str "kill-qemu-%s" name)) 193 | @@ check_sequence 194 | (* ~name:(Fmt.str "Killing Qemu VM") 195 | * ~clean_up:[fail "kill_qemu_vm"] *) 196 | [ ( "Kill-qemu-vm" 197 | , if_seq 198 | (file_exists (string "qemu.pid")) 199 | ~t: 200 | [ if_seq 201 | (call [string "kill"; pid] |> succeeds) 202 | ~t:[exec ["rm"; "qemu.pid"]] 203 | ~e: 204 | [ printf 205 | (string 206 | "PID file here (PID: %s) but Kill failed, \ 207 | deleting `qemu.pid`" ) 208 | [pid]; exec ["rm"; "qemu.pid"]; exec ["false"] ] 209 | ] 210 | ~e:[printf (string "No PID file") []; exec ["false"]] ) ] 211 | 212 | let configure : t -> Shell_script.t = function 213 | | {name; local_dependencies; _} -> 214 | let open Genspio.EDSL in 215 | let report = tmp_file "configure-report.md" in 216 | let there_was_a_failure = tmp_file "bool-failure" in 217 | let cmds = 218 | [ report#set (str "Configuration Report\n====================\n\n") 219 | ; there_was_a_failure#set (bool false |> Bool.to_string) ] 220 | @ List.map local_dependencies ~f:(function `Command name -> 221 | if_seq 222 | (exec ["which"; name] |> silently |> succeeds) 223 | ~t:[report#append (Fmt.kstr str "* `%s`: found.\n" name)] 224 | ~e: 225 | [ report#append (Fmt.kstr str "* `%s`: NOT FOUND!\n" name) 226 | ; there_was_a_failure#set (bool true |> Bool.to_string) ] ) 227 | @ [ call [string "cat"; report#path] 228 | ; if_seq 229 | (there_was_a_failure#get |> Bool.of_string) 230 | ~t: 231 | [ exec ["printf"; "\\nThere were *failures* :(\\n"] 232 | ; exec ["false"] ] 233 | ~e:[exec ["printf"; "\\n*Success!*\\n"]] ] in 234 | Shell_script.(make (Fmt.str "configure-%s" name)) 235 | @@ check_sequence ~verbosity:`Output_all 236 | (List.mapi cmds ~f:(fun i c -> (Fmt.str "config-%s-%d" name i, c))) 237 | 238 | let make_dependencies = function 239 | | {vm= Qemu_amd46 {hda; _}; _} -> File.make_files [hda] 240 | | {vm= Qemu_arm {kernel; sd_card; initrd; _}; _} -> 241 | File.make_files 242 | ( [kernel; sd_card] 243 | @ Option.value_map initrd ~default:[] ~f:(fun x -> [x]) ) 244 | 245 | let setup_dir_content tvm = 246 | let {root_password; setup; ssh_port; _} = tvm in 247 | let other_files = ref [] in 248 | let dependencies = make_dependencies tvm in 249 | let start_deps = List.map dependencies ~f:(fun (base, _, _) -> base) in 250 | let help_entries = ref [] in 251 | let make_entry ?doc ?(phony = false) ?(deps = []) target action = 252 | help_entries := (target, doc) :: !help_entries ; 253 | (if phony then [Fmt.str ".PHONY: %s" target] else []) 254 | @ [ Fmt.str "# %s: %s" target 255 | (Option.value_map 256 | ~f:(String.map ~f:(function '\n' -> ' ' | c -> c)) 257 | doc ~default:"NOT DOCUMENTED" ) 258 | ; Fmt.str "%s: %s" target (String.concat ~sep:" " deps) 259 | ; Fmt.str "\t@@%s" (Genspio.Compile.to_one_liner ~no_trap:true action) 260 | ] in 261 | let make_script_entry ?doc ?phony ?deps target script = 262 | let open Shell_script in 263 | let {files; call} = Shell_script.compile script in 264 | other_files := !other_files @ files ; 265 | make_entry ?doc ?phony ?deps target call in 266 | let setup_entries = 267 | List.mapi setup ~f:(fun idx -> 268 | let name = Fmt.str "setup-%d" idx in 269 | let deps = List.init idx ~f:(fun i -> Fmt.str "setup-%d" i) in 270 | function 271 | | Ssh_to_vm cmds -> 272 | ( name 273 | , make_script_entry ~phony:true name ~deps 274 | (Ssh.script_over_ssh ?root_password ~ssh_port ~name 275 | (Shell_script.make (Fmt.str "setup-%s" name) cmds) ) ) 276 | | Copy_relative (src, dst) -> 277 | ( name 278 | , make_entry ~phony:true name ~deps 279 | Genspio.EDSL.( 280 | exec ["tar"; "c"; src] 281 | ||> exec 282 | ( Ssh.sshpass ?password:root_password 283 | @@ ["ssh"; "-p"; Int.to_string ssh_port] 284 | @ Ssh.ssh_options 285 | @ [ "root@localhost" 286 | ; Fmt.str "tar -x -f - ; mv %s %s" src dst ] )) ) ) 287 | in 288 | let makefile = 289 | ["# Makefile genrated by Genspio's VM-Tester"] 290 | @ List.concat_map dependencies ~f:(fun (base, deps, cmd) -> 291 | Shell_script.(make (Fmt.str "get-%s" (sanitize_name base)) cmd) 292 | |> make_script_entry ~deps base ) 293 | @ make_script_entry ~phony:true "configure" (configure tvm) 294 | ~doc:"Configure this local-host (i.e. check for requirements)." 295 | @ make_script_entry ~deps:start_deps ~phony:true "start" 296 | ~doc:"Start the Qemu VM (this grabs the terminal)." 297 | (start_qemu_vm tvm) 298 | @ make_script_entry ~phony:true "kill" (kill_qemu_vm tvm) 299 | ~doc:"Kill the Qemu VM." 300 | @ List.concat_map setup_entries ~f:snd 301 | @ make_entry ~phony:true "setup" 302 | ~deps:(List.map setup_entries ~f:fst) 303 | Genspio.EDSL.(seq [exec ["echo"; "Setup done"]]) 304 | ~doc: 305 | "Run the “setup” recipe on the Qemu VM (requires the VM\n\ 306 | \ started in another terminal)." 307 | @ make_entry ~phony:true "ssh" ~doc:"Display an SSH command" 308 | Genspio.EDSL.( 309 | let prefix = 310 | Ssh.sshpass ?password:root_password [] |> String.concat ~sep:" " 311 | in 312 | printf 313 | (Fmt.kstr string "%s ssh -p %d %s root@@localhost" prefix ssh_port 314 | (String.concat ~sep:" " Ssh.ssh_options) ) 315 | []) in 316 | let help = 317 | make_script_entry ~phony:true "help" 318 | Shell_script.( 319 | make "Display help message" 320 | Genspio.EDSL.( 321 | exec 322 | [ "printf" 323 | ; "\\nHelp\\n====\\n\\nThis a generated Makefile (by \ 324 | Genspio-VM-Tester):\\n\\n%s\\n\\n%s\\n" 325 | ; List.map 326 | (("help", Some "Display this help message") :: !help_entries) 327 | ~f:(function 328 | | _, None -> "" 329 | | target, Some doc -> Fmt.str "* `make %s`: %s\n" target doc ) 330 | |> String.concat ~sep:"" 331 | ; Fmt.str 332 | "SSH: the command `make ssh` *outputs* an SSH command \ 333 | (%s). Examples:\n\n\ 334 | $ `make ssh` uname -a\n\ 335 | $ tar c some/dir/ | $(make ssh) 'tar x'\n\n\ 336 | (may need to be `tar -x -f -` for BSD tar).\n" 337 | (Option.value_map ~default:"No root-password" root_password 338 | ~f:(Fmt.str "Root-password: %S") ) ])) in 339 | ("Makefile", ("all: help" :: makefile) @ help @ [""]) :: !other_files 340 | 341 | module Example = struct 342 | let qemu_arm_openwrt ~ssh_port more_setup = 343 | let setup = 344 | let open Genspio.EDSL in 345 | Setup.ssh_to_vm 346 | (check_sequence 347 | [ ("opkg-update", exec ["opkg"; "update"]) 348 | ; ("install-od", exec ["opkg"; "install"; "coreutils-od"]) 349 | ; ("install-make", exec ["opkg"; "install"; "make"]) ] ) 350 | @ more_setup in 351 | let base_url = 352 | "https://downloads.openwrt.org/snapshots/trunk/realview/generic/" in 353 | qemu_arm "qemu_arm_openwrt" ~ssh_port ~machine:"realview-pbx-a9" 354 | ~kernel:(http (base_url // "openwrt-realview-vmlinux.elf")) 355 | ~sd_card:(http (base_url // "openwrt-realview-sdcard.img")) 356 | ~root_device:"/dev/mmcblk0p1" ~setup 357 | ~local_dependencies:[`Command "qemu-system-arm"] 358 | 359 | let qemu_arm_wheezy ~ssh_port more_setup = 360 | (* 361 | See {{:https://people.debian.org/~aurel32/qemu/armhf/}}. 362 | *) 363 | let aurel32 file = 364 | http ("https://people.debian.org/~aurel32/qemu/armhf" // file) in 365 | let setup = 366 | let open Genspio.EDSL in 367 | Setup.ssh_to_vm 368 | (check_sequence 369 | [("apt-get-make", exec ["apt-get"; "install"; "--yes"; "make"])] ) 370 | @ more_setup in 371 | qemu_arm "qemu_arm_wheezy" ~ssh_port ~machine:"vexpress-a9" 372 | ~kernel:(aurel32 "vmlinuz-3.2.0-4-vexpress") 373 | ~sd_card:(aurel32 "debian_wheezy_armhf_standard.qcow2") 374 | ~initrd:(aurel32 "initrd.img-3.2.0-4-vexpress") 375 | ~root_device:"/dev/mmcblk0p2" ~root_password:"root" ~setup 376 | ~local_dependencies:[`Command "qemu-system-arm"; `Command "sshpass"] 377 | 378 | let qemu_amd64_freebsd ~ssh_port more_setup = 379 | let qcow = 380 | http ~act:`Xz 381 | (* This qcow2 was created following the instructions at 382 | https://wiki.qemu.org/Hosts/BSD#FreeBSD *) 383 | "https://www.dropbox.com/s/ni7u0k6auqh2lya/FreeBSD11-amd64-rootssh.qcow2.xz?raw=1" 384 | in 385 | let setup = more_setup in 386 | let root_password = "root" in 387 | qemu_amd46 "qemu_amd64_freebsd" ~hda:qcow ~setup ~root_password 388 | ~ui:`Curses 389 | ~local_dependencies:[`Command "qemu-system-x86_64"; `Command "sshpass"] 390 | ~ssh_port 391 | 392 | let qemu_amd64_darwin ~ssh_port more_setup = 393 | (* 394 | Made with these instructions: http://althenia.net/notes/darwin 395 | from http://www.opensource.apple.com/static/iso/darwinx86-801.iso.gz 396 | *) 397 | let qcow = 398 | http ~act:`Xz 399 | "https://www.dropbox.com/s/2oeuya0isvorsam/darwin-disk-20180730.qcow2.xz?raw=1" 400 | in 401 | let setup = more_setup in 402 | let root_password = "root" in 403 | qemu_amd46 "qemu_amd64_darwin" ~hda:qcow ~setup ~root_password 404 | ~ui:`No_graphic 405 | ~local_dependencies:[`Command "qemu-system-x86_64"; `Command "sshpass"] 406 | ~ssh_port 407 | end 408 | end 409 | 410 | let cmdf fmt = 411 | Fmt.kstr 412 | (fun cmd -> 413 | match Caml.Sys.command cmd with 414 | | 0 -> () 415 | | other -> Fmt.kstr failwith "Command %S did not return 0: %d" cmd other 416 | ) 417 | fmt 418 | 419 | let write_lines p l = 420 | let open Caml in 421 | let o = open_out p in 422 | Base.List.iter l ~f:(Printf.fprintf o "%s\n") ; 423 | close_out o 424 | 425 | let () = 426 | let fail fmt = 427 | Fmt.kstr 428 | (fun s -> 429 | Fmt.epr "Wrong CLI: %s\n%!" s ; 430 | Caml.exit 2 ) 431 | fmt in 432 | let example = ref None in 433 | let path = ref None in 434 | let ssh_port = ref 20202 in 435 | let copy_directories = ref [] in 436 | let examples = 437 | [ ( "arm-owrt" 438 | , Run_environment.Example.qemu_arm_openwrt 439 | , "Qemu ARM VM with OpenWRT." ) 440 | ; ( "arm-dw" 441 | , Run_environment.Example.qemu_arm_wheezy 442 | , "Qemu ARM with Debian Wheezy." ) 443 | ; ( "amd64-fb" 444 | , Run_environment.Example.qemu_amd64_freebsd 445 | , "Qemu x86_64 with FreeBSD." ) 446 | ; ( "amd64-dw" 447 | , Run_environment.Example.qemu_amd64_darwin 448 | , "Qemu x86_64 with Darwin 8 (old Mac OSX)." ) ] in 449 | let set_example arg = 450 | match !example with 451 | | Some _ -> fail "Too many arguments (%S)!" arg 452 | | None -> 453 | example := 454 | Some 455 | ( match 456 | List.find_map examples ~f:(fun (e, v, _) -> 457 | if String.(e = arg) then Some v else None ) 458 | with 459 | | Some s -> s 460 | | None -> fail "Don't know VM %S" arg ) in 461 | let module Arg = Caml.Arg in 462 | let args = 463 | Arg.align 464 | [ ( "--ssh-port" 465 | , Arg.Int (fun s -> ssh_port := s) 466 | , Fmt.str " Set the SSH-port (default: %d)." !ssh_port ) 467 | ; ( "--vm" 468 | , Arg.String set_example 469 | , Fmt.str " The Name of the VM, one of:\n%s" 470 | (String.concat ~sep:"\n" 471 | (List.map 472 | ~f:(fun (n, _, d) -> 473 | Fmt.str "%s* `%s`: %s" (String.make 25 ' ') n d ) 474 | examples ) ) ) 475 | ; ( "--copy" 476 | , Arg.String 477 | (fun s -> 478 | let add p lp = 479 | let local_rel = 480 | String.map p ~f:(function '/' -> '_' | c -> c) in 481 | copy_directories := (p, local_rel, lp) :: !copy_directories 482 | in 483 | match Base.String.split ~on:':' s with 484 | | [] | [_] -> fail "Error in --copy: need a `:` separator (%S)" s 485 | | [p; lp] -> add p lp 486 | | p :: more -> add p (String.concat ~sep:":" more) ) 487 | , " Copy in the output directory and add its \ 488 | upload to the VM to the `make setup` target as a relative path \ 489 | ." ) ] in 490 | let usage = Fmt.str "vm-tester --vm " in 491 | let anon arg = 492 | match !path with 493 | | Some _ -> fail "Too many arguments (%S)!" arg 494 | | None -> path := Some arg in 495 | Arg.parse args anon usage ; 496 | let more_setup = 497 | List.map !copy_directories ~f:(fun (_, locrel, hostp) -> 498 | Run_environment.Setup.copy (`Relative locrel) (`Relative hostp) ) in 499 | let re = 500 | match !example with 501 | | Some e -> e ~ssh_port:!ssh_port more_setup 502 | | None -> fail "Missing VM name\nUsage: %s" usage in 503 | let content = Run_environment.setup_dir_content re in 504 | let path = 505 | match !path with 506 | | Some p -> p 507 | | None -> fail "Missing path!\nUsage: %s" usage in 508 | List.iter content ~f:(fun (filepath, content) -> 509 | let full = path // filepath in 510 | cmdf "mkdir -p %s" (Filename.dirname full) ; 511 | write_lines full content ) ; 512 | List.iter !copy_directories ~f:(fun (p, local_rel, _) -> 513 | cmdf "rsync -az %s %s/%s" p path local_rel ) 514 | --------------------------------------------------------------------------------