├── filename_extended ├── dune ├── README.md └── src │ ├── dune │ ├── filename_extended.mli │ └── filename_extended.ml ├── dune-project ├── .ocamlformat ├── .gitignore ├── test ├── import.ml ├── shell_test.ml ├── dune └── test_shell.ml ├── unix_extended ├── test │ ├── import.ml │ ├── test_unix_extended.mli │ ├── unix_extended_test.ml │ ├── dune │ └── test_unix_extended.ml ├── README.md ├── example │ └── quotactl │ │ ├── dune │ │ └── quotactl.ml └── src │ ├── dune │ ├── fork_exec.h │ ├── unix_extended.mli │ ├── unix_extended_stubs.c │ ├── fork_exec.c │ └── unix_extended.ml ├── shell_internal ├── README.md └── src │ ├── dune │ ├── shell_internal.mli │ └── shell_internal.ml ├── string_extended ├── test │ ├── test_string_extended.mli │ ├── string_extended_test.ml │ ├── dune │ └── test_string_extended.ml ├── README.md └── src │ ├── dune │ ├── string_extended.mli │ └── string_extended.ml ├── low_level_process ├── README.md ├── src │ ├── dune │ ├── low_level_process.mli │ └── low_level_process.ml └── test-bin │ ├── dune │ └── test_low_level_process.ml ├── src ├── dune ├── shell__line_buffer.mli ├── shell__line_buffer.ml ├── shell.mli └── shell.ml ├── CHANGES.md ├── Makefile ├── README.md ├── shell.opam ├── LICENSE.md └── CONTRIBUTING.md /filename_extended/dune: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.17) 2 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install 3 | *.merlin 4 | _opam 5 | 6 | -------------------------------------------------------------------------------- /test/import.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | include Expect_test_helpers_core 3 | -------------------------------------------------------------------------------- /unix_extended/test/import.ml: -------------------------------------------------------------------------------- 1 | include Expect_test_helpers_core 2 | -------------------------------------------------------------------------------- /test/shell_test.ml: -------------------------------------------------------------------------------- 1 | module Import = Import 2 | module Test_shell = Test_shell 3 | -------------------------------------------------------------------------------- /unix_extended/test/test_unix_extended.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /shell_internal/README.md: -------------------------------------------------------------------------------- 1 | # Shell_internal 2 | 3 | A library internal to the `Shell` library. 4 | -------------------------------------------------------------------------------- /string_extended/test/test_string_extended.mli: -------------------------------------------------------------------------------- 1 | (*_ This signature is deliberately empty. *) 2 | -------------------------------------------------------------------------------- /unix_extended/README.md: -------------------------------------------------------------------------------- 1 | # Unix_extended 2 | 3 | Unix functions that aren't in `Core_unix`. 4 | -------------------------------------------------------------------------------- /string_extended/test/string_extended_test.ml: -------------------------------------------------------------------------------- 1 | module Test_string_extended = Test_string_extended 2 | -------------------------------------------------------------------------------- /unix_extended/test/unix_extended_test.ml: -------------------------------------------------------------------------------- 1 | module Import = Import 2 | module Test_unix_extended = Test_unix_extended 3 | -------------------------------------------------------------------------------- /string_extended/README.md: -------------------------------------------------------------------------------- 1 | # String_extended 2 | 3 | A single-module library with some extensions of the `String` module. 4 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name shell_test) 3 | (libraries core expect_test_helpers_core shell) 4 | (preprocess 5 | (pps ppx_jane))) 6 | -------------------------------------------------------------------------------- /low_level_process/README.md: -------------------------------------------------------------------------------- 1 | # Low_level_process 2 | 3 | A `run` function for running an executable with arguments in a 4 | subprocess. 5 | -------------------------------------------------------------------------------- /filename_extended/README.md: -------------------------------------------------------------------------------- 1 | # Filename_extended 2 | 3 | An extension of the `Filename` module with additional functions for 4 | dealing with filenames. 5 | -------------------------------------------------------------------------------- /string_extended/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name string_extended) 3 | (public_name shell.string_extended) 4 | (libraries core) 5 | (preprocess 6 | (pps ppx_jane))) 7 | -------------------------------------------------------------------------------- /unix_extended/test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name unix_extended_test) 3 | (libraries core expect_test_helpers_core unix_extended) 4 | (preprocess 5 | (pps ppx_jane))) 6 | -------------------------------------------------------------------------------- /string_extended/test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name string_extended_test) 3 | (libraries core expect_test_helpers_core string_extended) 4 | (preprocess 5 | (pps ppx_jane))) 6 | -------------------------------------------------------------------------------- /shell_internal/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name shell_internal) 3 | (public_name shell.shell_internal) 4 | (libraries core core_unix core_unix.sys_unix) 5 | (preprocess 6 | (pps ppx_jane))) 7 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name shell) 3 | (public_name shell) 4 | (libraries textutils.console core core_unix low_level_process shell_internal 5 | core_unix.sys_unix) 6 | (preprocess 7 | (pps ppx_jane))) 8 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## Release v0.16.0 2 | 3 | - Remove functions from `String_extended`: 4 | * Deprecated `String_extended.is_substring_deprecated` 5 | * `String_extended.pad_left` and `String_extended.pad_right` 6 | 7 | - Add `Unix_extended.terminal_height` 8 | -------------------------------------------------------------------------------- /unix_extended/example/quotactl/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (modes byte exe) 3 | (names quotactl) 4 | (libraries core_unix.command_unix core core_unix core_unix.filename_unix 5 | core_unix.time_float_unix unix_extended) 6 | (preprocess 7 | (pps ppx_jane))) 8 | -------------------------------------------------------------------------------- /filename_extended/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name filename_extended) 3 | (public_name shell.filename_extended) 4 | (libraries core core_unix core_unix.filename_unix shell_internal 5 | string_extended core_unix.sys_unix) 6 | (preprocess 7 | (pps ppx_jane))) 8 | -------------------------------------------------------------------------------- /low_level_process/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name low_level_process) 3 | (public_name shell.low_level_process) 4 | (libraries core core_unix.linux_ext shell_internal unix_extended core_unix 5 | core_unix.signal_unix core_unix.time_float_unix) 6 | (preprocess 7 | (pps ppx_jane))) 8 | -------------------------------------------------------------------------------- /low_level_process/test-bin/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (deps 3 | (:first_dep test_low_level_process.exe)) 4 | (action 5 | (bash ./%{first_dep})) 6 | (alias runtest)) 7 | 8 | (executables 9 | (modes byte exe) 10 | (names test_low_level_process) 11 | (libraries core low_level_process oUnit) 12 | (preprocess 13 | (pps ppx_jane))) 14 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) 2 | 3 | default: 4 | dune build 5 | 6 | install: 7 | dune install $(INSTALL_ARGS) 8 | 9 | uninstall: 10 | dune uninstall $(INSTALL_ARGS) 11 | 12 | reinstall: uninstall install 13 | 14 | clean: 15 | dune clean 16 | 17 | .PHONY: default install uninstall reinstall clean 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | "Shell" 2 | ======= 3 | 4 | Functions for invoking executables and for running bash in a 5 | subprocess. 6 | 7 | Warning: this library is unloved and not actively maintained: consider 8 | using `Async.Process.run` and related functions, instead. 9 | Or if you really need a synchronous process spawning API, use 10 | `Core_unix.create_process`, or `Spawn.spawn` directly. 11 | -------------------------------------------------------------------------------- /unix_extended/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (foreign_stubs 3 | (language c) 4 | (names fork_exec unix_extended_stubs)) 5 | (name unix_extended) 6 | (public_name shell.unix_extended) 7 | (libraries core core_unix shell_internal spawn core_unix.time_float_unix) 8 | (preprocessor_deps config.h) 9 | (preprocess 10 | (pps ppx_jane))) 11 | 12 | (rule 13 | (targets config.h) 14 | (deps) 15 | (action 16 | (bash "cp %{lib:jst-config:config.h} %{targets}"))) 17 | -------------------------------------------------------------------------------- /shell_internal/src/shell_internal.mli: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | (* This is an internal module; it shouldn't be used by anything not in core_extended *) 4 | (* some of the core functions of the "Shell" go in here because they are 5 | needed by other modules which are in turn required by the full shell module *) 6 | 7 | val extra_path : string list Dynamic.t 8 | val whoami : ?real:bool -> unit -> string 9 | val is_executable : string -> bool 10 | val which : ?use_extra_path:bool -> string -> string option 11 | val path_expand : ?use_extra_path:bool -> string -> string 12 | -------------------------------------------------------------------------------- /low_level_process/test-bin/test_low_level_process.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open OUnit 3 | 4 | exception Got_the_first_line 5 | 6 | let test = 7 | "process" 8 | >::: [ ("early-exit" 9 | >:: fun () -> 10 | match 11 | Low_level_process.run 12 | ~prog:"bash" 13 | ~args:[ "-c"; "trap '' TERM; echo hello; sleep 46" ] 14 | ~stdoutf:(fun s len -> 15 | if String.mem (Bytes.To_string.subo ~len s) '\n' 16 | then raise Got_the_first_line) 17 | () 18 | with 19 | | exception Got_the_first_line -> () 20 | | _ -> failwith "should have Got_the_first_line") 21 | ] 22 | ;; 23 | 24 | let () = ignore (run_test_tt_main test) 25 | -------------------------------------------------------------------------------- /unix_extended/src/fork_exec.h: -------------------------------------------------------------------------------- 1 | /* value extended_ml_create_process */ 2 | extern CAMLprim value extended_ml_spawn 3 | ( 4 | value v_stdin, /* Fd to connect to the forked stdin... */ 5 | value v_stdout, 6 | value v_stderr, 7 | value v_working_dir, /* A directory we want to chdir too. [String option] */ 8 | value v_setuid, /* setuid on the fork side [int option] */ 9 | value v_setgid, /* setgid on the fork side [int option] */ 10 | value v_env, /* The Environment to set for execve. pass None to call an 11 | execv instead. [string array option]*/ 12 | value v_prog, /* Program name [string] */ 13 | value v_args /* Full list of args passed to executable [string array] */ 14 | ); 15 | 16 | extern CAMLprim value extended_ml_spawn_bc(value *argv, int argn); 17 | -------------------------------------------------------------------------------- /test/test_shell.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | module Sh = Shell 3 | 4 | let%expect_test "run_one_line" = 5 | printf !"%{sexp:string Or_error.t}\n" (Sh.sh_one_line "echo 'hi there'"); 6 | [%expect {| (Ok "hi there") |}]; 7 | printf !"%{sexp:string Or_error.t}\n" (Sh.sh_one_line "true"); 8 | [%expect {| (Error "expected one line, got empty output") |}]; 9 | printf !"%{sexp:string Or_error.t}\n" (Sh.sh_one_line "echo hi; echo there"); 10 | [%expect 11 | {| 12 | (Error 13 | ("One line expected, got at least two lines of output" (first_line hi) 14 | (second_line there))) 15 | |}]; 16 | printf !"%{sexp:string Or_error.t}\n" (Sh.sh_one_line "yes yes"); 17 | [%expect 18 | {| 19 | (Error 20 | ("One line expected, got at least two lines of output" (first_line yes) 21 | (second_line yes))) 22 | |}] 23 | ;; 24 | -------------------------------------------------------------------------------- /src/shell__line_buffer.mli: -------------------------------------------------------------------------------- 1 | (** String buffers that automatically get flushed at every line return. *) 2 | 3 | type t 4 | 5 | (** [create ~eol f] Create a new line buffer where f will be called once on every line. 6 | Eol is the endline character (it's possible to use a Linebuffer to process null 7 | separated strings ) *) 8 | val create : ?eol:char -> (string -> unit) -> t 9 | 10 | (** [flush b] Flushes any pending output to the callback function. This causes unfinished 11 | newlines to be flushed out so adding more characters after flushing might result in 12 | there looking as though there are more lines than there really were. *) 13 | val flush : t -> unit 14 | 15 | val add_char : t -> char -> unit 16 | val add_string : t -> string -> unit 17 | 18 | (** [add_substring b s ofs len] takes [len] characters from offset [ofs] in string [s] and 19 | appends them at the end of the buffer [b]. *) 20 | val add_substring : t -> string -> pos:int -> len:int -> unit 21 | 22 | val add_subbytes : t -> Bytes.t -> pos:int -> len:int -> unit 23 | -------------------------------------------------------------------------------- /shell.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Jane Street developers" 3 | authors: ["Jane Street Group, LLC"] 4 | homepage: "https://github.com/janestreet/shell" 5 | bug-reports: "https://github.com/janestreet/shell/issues" 6 | dev-repo: "git+https://github.com/janestreet/shell.git" 7 | doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/shell/index.html" 8 | license: "MIT" 9 | build: [ 10 | ["dune" "build" "-p" name "-j" jobs] 11 | ] 12 | depends: [ 13 | "ocaml" {>= "5.1.0"} 14 | "core" 15 | "core_unix" 16 | "jst-config" 17 | "ppx_jane" 18 | "textutils" 19 | "dune" {>= "3.17.0"} 20 | "spawn" {>= "v0.15"} 21 | ] 22 | available: arch != "arm32" & arch != "x86_32" 23 | synopsis: "Yet another implementation of fork&exec and related functionality" 24 | description: " 25 | This library is a relatively featureful and flexible implementation of fork&exec with related functionality, including some basic support for asynchronous I/O. This is an old and unmaintained code. New users are advised to try using [Async.Process] for certain use cases and [Shexp_process] for certain other use cases. 26 | " 27 | depexts: ["linux-headers"] {os-family = "alpine"} 28 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License 2 | 3 | Copyright (c) 2018--2025 Jane Street Group, LLC 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /low_level_process/src/low_level_process.mli: -------------------------------------------------------------------------------- 1 | (** Low-level process handling 2 | 3 | This is low-level enough that you should probably be using [Shell] instead to dispatch 4 | processes. *) 5 | 6 | open! Core 7 | 8 | module Status : sig 9 | type t = 10 | [ `Timeout of Time_float.Span.t 11 | | `Exited of int 12 | | `Signaled of Signal.t (* WStopped is impossible*) 13 | ] 14 | [@@deriving sexp_of] 15 | 16 | val to_string : t -> string 17 | end 18 | 19 | module Command_result : sig 20 | type t = 21 | { status : Status.t 22 | ; stdout_tail : string 23 | ; stderr_tail : string 24 | } 25 | end 26 | 27 | (** kills a process by sending [signal]; waiting for [wait_for] and then sending a 28 | [sigkill]. You need to set is_child to true when killing child processes or run 29 | waitpid on them in another. 30 | @raise Failure 31 | if the target program hangs for more that [wait_for] after receiving the [sigkill]. 32 | 33 | caveat: [is_child:false] (the default) is racy: it can both send signals to wrong 34 | processes and it can also fail to notice that the target died. *) 35 | val kill 36 | : ?is_child:bool 37 | -> ?wait_for:Time_float.Span.t 38 | -> ?signal:Signal.t 39 | -> Pid.t 40 | -> unit 41 | 42 | (** Runs the process. 43 | 44 | [stdoutf s len] and [stderrf s len] should only inspect the [String.subo s ~len] 45 | component of [s]. *) 46 | val run 47 | : ?timeout:Time_float.Span.t 48 | -> ?use_extra_path:bool 49 | -> ?working_dir:string 50 | -> ?setuid:int 51 | -> ?setgid:int 52 | -> ?env:[ `Extend of (string * string) list | `Replace of (string * string) list ] 53 | -> ?input:string 54 | -> ?keep_open:bool 55 | -> ?stdoutf:(Bytes.t -> int -> unit) 56 | -> ?stderrf:(Bytes.t -> int -> unit) 57 | -> ?tail_len:int 58 | -> prog:string 59 | -> args:string list 60 | -> unit 61 | -> Command_result.t 62 | -------------------------------------------------------------------------------- /shell_internal/src/shell_internal.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Poly 3 | module Unix = Core_unix 4 | 5 | let extra_path = Dynamic.make ([ "/bin"; "/usr/bin"; "/usr/local/bin" ] : string list) 6 | 7 | let get_path ?(use_extra_path = true) () = 8 | let env_path = 9 | Sys.getenv "PATH" 10 | |> Option.map ~f:(String.split ~on:':') 11 | |> Option.value ~default:[] 12 | |> List.filter ~f:(( <> ) "") 13 | in 14 | let path = if use_extra_path then env_path @ Dynamic.get extra_path else env_path in 15 | List.stable_dedup ~compare:String.compare path 16 | ;; 17 | 18 | let is_executable path = 19 | try 20 | let stat = Unix.stat path in 21 | stat.Unix.st_kind = Unix.S_REG (* Is file *) && stat.Unix.st_perm land 0o111 > 0 22 | (* Is executable*) 23 | with 24 | | Unix.Unix_error ((ENOENT | ENOTDIR), _, _) -> false (* File not found *) 25 | ;; 26 | 27 | let path_lookup ?use_extra_path bin = 28 | let rec loop = function 29 | | [] -> None 30 | | h :: t -> 31 | let file = h ^/ bin in 32 | (try if is_executable file then Some file else raise Exit with 33 | | Unix.Unix_error _ | Exit -> loop t) 34 | in 35 | loop (get_path ?use_extra_path ()) 36 | ;; 37 | 38 | let which ?use_extra_path bin = 39 | if not (String.contains bin '/') 40 | then path_lookup ?use_extra_path bin 41 | else if not (is_executable bin) 42 | then None 43 | else Some bin 44 | ;; 45 | 46 | let path_expand ?use_extra_path prog = 47 | if not (String.contains prog '/') 48 | then ( 49 | match path_lookup ?use_extra_path prog with 50 | | None -> 51 | failwithf 52 | "executable %s not found in $PATH (%s)" 53 | prog 54 | (String.concat ~sep:":" (get_path ())) 55 | () 56 | | Some v -> v) 57 | else if Filename.is_relative prog 58 | then Sys_unix.getcwd () ^/ prog 59 | else prog 60 | ;; 61 | 62 | (* "real" switches between real and effective uids. sudo sets both real and 63 | effective uids, so this will not work, though you should be able to use 64 | $SUDO_UID *) 65 | let whoami ?(real = false) () = 66 | let uid = if real then Unix.getuid () else Unix.geteuid () in 67 | match Unix.Passwd.getbyuid uid with 68 | | Some user -> user.Unix.Passwd.name 69 | | None -> failwith "unable to determine username" 70 | ;; 71 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | This repository contains open source software that is developed and 2 | maintained by [Jane Street][js]. 3 | 4 | Contributions to this project are welcome and should be submitted via 5 | GitHub pull requests. 6 | 7 | Signing contributions 8 | --------------------- 9 | 10 | We require that you sign your contributions. Your signature certifies 11 | that you wrote the patch or otherwise have the right to pass it on as 12 | an open-source patch. The rules are pretty simple: if you can certify 13 | the below (from [developercertificate.org][dco]): 14 | 15 | ``` 16 | Developer Certificate of Origin 17 | Version 1.1 18 | 19 | Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 20 | 1 Letterman Drive 21 | Suite D4700 22 | San Francisco, CA, 94129 23 | 24 | Everyone is permitted to copy and distribute verbatim copies of this 25 | license document, but changing it is not allowed. 26 | 27 | 28 | Developer's Certificate of Origin 1.1 29 | 30 | By making a contribution to this project, I certify that: 31 | 32 | (a) The contribution was created in whole or in part by me and I 33 | have the right to submit it under the open source license 34 | indicated in the file; or 35 | 36 | (b) The contribution is based upon previous work that, to the best 37 | of my knowledge, is covered under an appropriate open source 38 | license and I have the right under that license to submit that 39 | work with modifications, whether created in whole or in part 40 | by me, under the same open source license (unless I am 41 | permitted to submit under a different license), as indicated 42 | in the file; or 43 | 44 | (c) The contribution was provided directly to me by some other 45 | person who certified (a), (b) or (c) and I have not modified 46 | it. 47 | 48 | (d) I understand and agree that this project and the contribution 49 | are public and that a record of the contribution (including all 50 | personal information I submit with it, including my sign-off) is 51 | maintained indefinitely and may be redistributed consistent with 52 | this project or the open source license(s) involved. 53 | ``` 54 | 55 | Then you just add a line to every git commit message: 56 | 57 | ``` 58 | Signed-off-by: Joe Smith 59 | ``` 60 | 61 | Use your real name (sorry, no pseudonyms or anonymous contributions.) 62 | 63 | If you set your `user.name` and `user.email` git configs, you can sign 64 | your commit automatically with git commit -s. 65 | 66 | [dco]: http://developercertificate.org/ 67 | [js]: https://opensource.janestreet.com/ 68 | -------------------------------------------------------------------------------- /string_extended/src/string_extended.mli: -------------------------------------------------------------------------------- 1 | (** Extensions to [Core.Core_String]. *) 2 | 3 | open! Core 4 | 5 | (** [collate s1 s2] sorts string in an order that's usually more suited for human 6 | consumption by treating ints specially, e.g. it will output: 7 | [["rfc1.txt";"rfc822.txt";"rfc2086.txt"]]. 8 | 9 | It works by splitting the strings in numerical and non-numerical chunks and comparing 10 | chunks two by two from left to right (and starting on a non numerical chunk): 11 | 12 | - Non_numerical chunks are compared using lexicographical ordering. 13 | - Numerical chunks are compared based on the values of the represented ints and the 14 | number of trailing zeros. 15 | 16 | It is a total order. *) 17 | val collate : string -> string -> int 18 | 19 | (** [unescaped_exn s] is the inverse operation of [escaped]: it takes a string where all 20 | the special characters are escaped following the lexical convention of OCaml and 21 | returns an unescaped copy. The [strict] switch is on by default and makes the function 22 | treat illegal backslashes as errors. When [strict] is [false] every illegal backslash 23 | except escaped numeral greater than [255] is copied literally. The aforementioned 24 | numerals still raise errors. This mimics the behaviour of the ocaml lexer. *) 25 | val unescaped_exn : ?strict:bool -> string -> string 26 | [@@deprecated 27 | "[since 2021-08] Consider using [Scanf.unescaped] instead. Be aware it behaves \ 28 | differently on inputs containing double-quote characters."] 29 | 30 | (** [squeeze str] reduces all sequences of spaces, newlines, tabs, and carriage returns to 31 | single spaces. *) 32 | val squeeze : string -> string 33 | 34 | val line_break : len:int -> string -> string list 35 | [@@deprecated "[since 2021-08] Use [word_wrap] instead."] 36 | 37 | (** [word_wrap ~soft_limit s] 38 | 39 | Wraps the string so that it fits the length [soft_limit]. It doesn't break words 40 | unless we go over [hard_limit]. 41 | 42 | if [nl] is passed it is inserted instead of the normal newline character. *) 43 | val word_wrap 44 | : ?trailing_nl:bool 45 | -> ?soft_limit:int 46 | -> ?hard_limit:int 47 | -> ?nl:string 48 | -> string 49 | -> string 50 | 51 | (** Gives the Levenshtein distance between 2 strings, which is the number of insertions, 52 | deletions, and substitutions necessary to turn either string into the other. With the 53 | [transpose] argument, it also considers transpositions (Damerau-Levenshtein distance). *) 54 | val edit_distance : ?transpose:unit -> string -> string -> int 55 | -------------------------------------------------------------------------------- /filename_extended/src/filename_extended.mli: -------------------------------------------------------------------------------- 1 | (** Extensions to [Core.Core_filename]. *) 2 | 3 | (** [normalize path] Removes as much "." and ".." from the path as possible. If the path 4 | is absolute they will all be removed. *) 5 | val normalize : string -> string 6 | 7 | (** [parent path] The parent of the root directory is the root directory 8 | @return the path to the parent of [path]. *) 9 | val parent : string -> string 10 | 11 | (** [make_relative ~to_:src f] returns [f] relative to [src]. 12 | 13 | @raise Failure if [is_relative f <> is_relative src] *) 14 | val make_relative : ?to_:string -> string -> string 15 | 16 | (** [make_absolute src] Turn [src] into an absolute path expanded from the current working 17 | directory. *) 18 | val make_absolute : string -> string 19 | 20 | (** [expand] Makes a path absolute and expands [~] [~username] to home directories. In 21 | case of error (e.g.: path home of a none existing user) raises [Failure] with a 22 | (hopefully) helpful message. *) 23 | val expand : ?from:string -> string -> string 24 | 25 | (** Splits a given path into a list of strings. *) 26 | val explode : string -> string list 27 | 28 | (** dual to explode *) 29 | val implode : string list -> string 30 | 31 | (**/**) 32 | 33 | (* this is exported because it is used by core_extended.filename. *) 34 | val normalize_path : string list -> string list 35 | 36 | (**/**) 37 | 38 | (** Filename.compare is a comparison that normalizes filenames ("./a" = "a"), uses a more 39 | human ready algorithm based on [String_extended.collate] ("rfc02.txt > rfc1.txt") and 40 | extenstions ("a.c" > "a.h"). 41 | 42 | It is a total comparison on normalized filenames. *) 43 | val compare : string -> string -> int 44 | 45 | (** [with_open_temp_file ~write ~f prefix suffix] create a temporary file; runs [write] on 46 | its [out_channel] and then [f] on the resulting file. The file is removed once [f] is 47 | done running. *) 48 | val with_open_temp_file 49 | : ?in_dir:string 50 | -> ?write:(out_channel -> unit) 51 | -> f:(string -> 'a) 52 | -> string 53 | -> string 54 | -> 'a 55 | 56 | (** Runs [f] with a temporary dir as option and removes the directory afterwards. *) 57 | val with_temp_dir : ?in_dir:string -> string -> string -> f:(string -> 'a) -> 'a 58 | 59 | (** [is_parent dir1 dir2] returns [true] if [dir1] is a parent of [dir2] 60 | 61 | Note: This function is context independent, use [expand] if you want to consider 62 | relatives paths from a given point. 63 | 64 | In particular: 65 | - A directory is always the parent of itself. 66 | - The root is the parent of any directory 67 | - An absolute path is never the parent of relative one and vice versa. 68 | - ["../../a"] is never the parent of ["."] even if this could be true given form the 69 | current working directory. *) 70 | val is_parent : string -> string -> bool 71 | -------------------------------------------------------------------------------- /src/shell__line_buffer.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Poly 3 | 4 | (** Look for a newline in a given substring and returns its absolute position. Returns 5 | None if no newlines are found. *) 6 | let rec nl_between 7 | (get : 'a -> int -> char) 8 | (s : 'a) 9 | ~(eol : char) 10 | ~(pos : int) 11 | ~(len : int) 12 | : int option 13 | = 14 | if len = 0 15 | then None 16 | else if get s pos = eol 17 | then Some pos 18 | else nl_between get s ~eol ~pos:(pos + 1) ~len:(len - 1) 19 | ;; 20 | 21 | let%test _ = nl_between String.get "abcd" ~eol:'\n' ~pos:0 ~len:4 = None 22 | let%test _ = nl_between String.get "a\nb\ncd" ~eol:'\n' ~pos:0 ~len:6 = Some 1 23 | let%test _ = nl_between String.get "a\nb\ncd" ~eol:'\n' ~pos:3 ~len:3 = Some 3 24 | let%test _ = nl_between String.get "a\nb\ncd" ~eol:'\n' ~pos:4 ~len:2 = None 25 | 26 | (** Type for line buffers. [flush] will be called back on every fully read newline or when 27 | the buffer itself is flushed by the user. *) 28 | type t = 29 | { buffer : Buffer.t 30 | ; eol : char 31 | ; flush : string -> unit 32 | } 33 | 34 | (* *) 35 | let create ?(eol = '\n') flush = { buffer = Buffer.create 0; eol; flush } 36 | 37 | let flush b = 38 | if Buffer.length b.buffer > 0 39 | then ( 40 | b.flush (Buffer.contents b.buffer); 41 | Buffer.reset b.buffer) 42 | ;; 43 | 44 | let add_char b c = 45 | if c = b.eol 46 | then ( 47 | b.flush (Buffer.contents b.buffer); 48 | Buffer.reset b.buffer) 49 | else Buffer.add_char b.buffer c 50 | ;; 51 | 52 | let rec add_substring' blit get buffer_add b s ~pos ~len = 53 | match nl_between get s ~eol:b.eol ~pos ~len with 54 | | None -> buffer_add b.buffer s ~pos ~len 55 | | Some suffix_end_pos -> 56 | (* whatever is in the buffer + this suffix is our newline*) 57 | let suffix_len = suffix_end_pos - pos 58 | and prefix_len = Buffer.length b.buffer in 59 | let line = Bytes.create (prefix_len + suffix_len) in 60 | Buffer.blit ~src:b.buffer ~src_pos:0 ~dst:line ~dst_pos:0 ~len:prefix_len; 61 | blit ~src:s ~src_pos:pos ~dst:line ~dst_pos:prefix_len ~len:suffix_len; 62 | Buffer.reset b.buffer; 63 | b.flush (Bytes.unsafe_to_string ~no_mutation_while_string_reachable:line); 64 | add_substring' 65 | blit 66 | get 67 | buffer_add 68 | b 69 | s 70 | ~pos:(suffix_end_pos + 1) 71 | ~len:(len - suffix_len - 1) 72 | ;; 73 | 74 | let add_substring = add_substring' Bytes.From_string.blit String.get Buffer.add_substring 75 | 76 | let add_subbytes = 77 | add_substring' Bytes.blit (fun b i -> Bytes.get b i) Buffer.add_subbytes 78 | ;; 79 | 80 | let add_string b s = add_substring b s ~pos:0 ~len:(String.length s) 81 | 82 | (** [test_list l]: adds all the strings in [l] to a new blank buffer and returns all the 83 | lines that the callback function was called on. *) 84 | let test_list l = 85 | let lines = ref [] in 86 | let b = create (fun s -> lines := s :: !lines) in 87 | List.iter ~f:(fun s -> add_string b s) l; 88 | flush b; 89 | List.rev !lines 90 | ;; 91 | 92 | let%test _ = test_list [ "abcd\nas\nere\n" ] = [ "abcd"; "as"; "ere" ] 93 | let%test _ = test_list [ "ab"; "cd"; "\nas\n"; "ere\n" ] = [ "abcd"; "as"; "ere" ] 94 | let%test _ = test_list [ "no new\nline"; " at the end" ] = [ "no new"; "line at the end" ] 95 | let%test _ = test_list [ "a new line"; " at the end\n" ] = [ "a new line at the end" ] 96 | -------------------------------------------------------------------------------- /string_extended/test/test_string_extended.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open Expect_test_helpers_core 3 | 4 | module%test [@name "collate"] _ = struct 5 | let collate = String_extended.collate 6 | let ( require (not (s require ((a (a require (String.( <> ) a b ==> (a unescaped_exn "\\a"); 64 | [%expect 65 | {| 66 | (Invalid_argument 67 | "String_extended.unescaped_exn error at position 2 of \\a: got invalid escape character: a") 68 | |}]; 69 | (* non-strict *) 70 | require_equal 71 | (module String) 72 | ~message:"non-strict" 73 | (unescaped_exn ~strict:false "\\a") 74 | "\\a"; 75 | (* non-strict, illegal escape *) 76 | require_does_raise (fun () -> unescaped_exn ~strict:false "\\512"); 77 | [%expect 78 | {| 79 | (Invalid_argument 80 | "String_extended.unescaped_exn error at position 4 of \\512: got invalid escape code 512") 81 | |}] 82 | ;; 83 | 84 | let%expect_test "[unescaped_exn ~strict:true] is equivalent to [Scanf.unescaped], \ 85 | modulo exception constructor" 86 | = 87 | Quickcheck.test_can_generate 88 | String.quickcheck_generator 89 | ~sexp_of:[%sexp_of: string] 90 | ~f:(fun s -> Exn.does_raise (fun () -> unescaped_exn ~strict:true s)); 91 | quickcheck_m (module String) ~f:(fun s -> 92 | let s = 93 | unstage (String.Escaping.escape ~escapeworthy:[ '\"' ] ~escape_char:'\\') s 94 | in 95 | Expect_test_helpers_core.require_equal 96 | (module struct 97 | type t = (string, (exn[@equal.ignore])) Result.t [@@deriving equal, sexp_of] 98 | end) 99 | (Result.try_with (fun () -> unescaped_exn s ~strict:true)) 100 | (Result.try_with (fun () -> Scanf.unescaped s))) 101 | ;; 102 | end 103 | -------------------------------------------------------------------------------- /unix_extended/test/test_unix_extended.ml: -------------------------------------------------------------------------------- 1 | open! Core 2 | open! Import 3 | open! Unix_extended 4 | 5 | let%expect_test "[Mount_entry.parse_line]" = 6 | List.iter 7 | [ "/dev/mapper/vg01-root / ext4 defaults 0 0" 8 | ; "/dev/mapper/vg01-swap swap swap defaults" 9 | ; " extra_whitespace\t\t\t /extra_whitespace \t\t ext4 rw 0 \t " 10 | ; "weird_comments /weird_comments ext4 defaults 0 0 # comment # another" 11 | ; "embedded_space /embedded\\040space ext4 defaults" 12 | ; "# leading comment" 13 | ; " # space then comment" 14 | ; " " 15 | ; "LABEL=boot /boot ext4 defaults 0" 16 | ; "missing_escape \\999 xfs defaults" (* Errors follow *) 17 | ; "almost enough fields" 18 | ; "even fewer" 19 | ; "just_one" 20 | ; "\\" 21 | ] 22 | ~f:(fun input -> 23 | print_s 24 | [%message 25 | "" 26 | (input : string) 27 | ~output:(Mount_entry.parse_line input : Mount_entry.t option Or_error.t)]); 28 | [%expect 29 | {| 30 | ((input "/dev/mapper/vg01-root / ext4 defaults 0 0") 31 | (output ( 32 | Ok (( 33 | (fsname /dev/mapper/vg01-root) 34 | (directory /) 35 | (fstype ext4) 36 | (options defaults)))))) 37 | ((input "/dev/mapper/vg01-swap swap swap defaults") 38 | (output ( 39 | Ok (( 40 | (fsname /dev/mapper/vg01-swap) 41 | (directory swap) 42 | (fstype swap) 43 | (options defaults)))))) 44 | ((input " extra_whitespace\t\t\t /extra_whitespace \t\t ext4 rw 0 \t ") 45 | (output ( 46 | Ok (( 47 | (fsname extra_whitespace) 48 | (directory /extra_whitespace) 49 | (fstype ext4) 50 | (options rw)))))) 51 | ((input 52 | "weird_comments /weird_comments ext4 defaults 0 0 # comment # another") 53 | (output ( 54 | Ok (( 55 | (fsname weird_comments) 56 | (directory /weird_comments) 57 | (fstype ext4) 58 | (options defaults)))))) 59 | ((input "embedded_space /embedded\\040space ext4 defaults") 60 | (output ( 61 | Ok (( 62 | (fsname embedded_space) 63 | (directory "/embedded space") 64 | (fstype ext4) 65 | (options defaults)))))) 66 | ((input "# leading comment") (output (Ok ()))) 67 | ((input " # space then comment") (output (Ok ()))) 68 | ((input " ") (output (Ok ()))) 69 | ((input "LABEL=boot /boot ext4 defaults 0") 70 | (output ( 71 | Ok (( 72 | (fsname LABEL=boot) 73 | (directory /boot) 74 | (fstype ext4) 75 | (options defaults)))))) 76 | ((input "missing_escape \\999 xfs defaults") 77 | (output ( 78 | Ok (( 79 | (fsname missing_escape) 80 | (directory "\\999") 81 | (fstype xfs) 82 | (options defaults)))))) 83 | ((input "almost enough fields") 84 | (output (Error ("wrong number of fields" "almost enough fields")))) 85 | ((input "even fewer") 86 | (output (Error ("wrong number of fields" "even fewer")))) 87 | ((input just_one) (output (Error ("wrong number of fields" just_one)))) 88 | ((input \) (output (Error ("wrong number of fields" \)))) 89 | |}] 90 | ;; 91 | 92 | let%expect_test "[Mount_entry.visible_filesystem]" = 93 | let mount_entries = 94 | List.filter_map 95 | ~f:(Fn.compose Or_error.ok_exn Mount_entry.parse_line) 96 | [ "# a comment" 97 | ; "/dev/mapper/vg01-root / ext4 rw 0 0" 98 | ; "/dev/mapper/vg01-var /var ext4 rw 0 0" 99 | ; "/dev/mapper/vg01-tmp /tmp ext4 rw 0 0" 100 | ; "/dev/mapper/vg01-swap swap swap rw 0 0" 101 | ; "some-server1:/some/mount/point /mnt/something/else nfs \ 102 | some-option,ro,vers=3,hard,intr 0 0" 103 | ] 104 | in 105 | let visible_filesystem = Mount_entry.visible_filesystem mount_entries in 106 | print_s ([%sexp_of: Mount_entry.t String.Map.t] visible_filesystem); 107 | [%expect 108 | {| 109 | ((/ ( 110 | (fsname /dev/mapper/vg01-root) 111 | (directory /) 112 | (fstype ext4) 113 | (options rw))) 114 | (/mnt/something/else ( 115 | (fsname some-server1:/some/mount/point) 116 | (directory /mnt/something/else) 117 | (fstype nfs) 118 | (options some-option,ro,vers=3,hard,intr))) 119 | (/tmp ( 120 | (fsname /dev/mapper/vg01-tmp) 121 | (directory /tmp) 122 | (fstype ext4) 123 | (options rw))) 124 | (/var ( 125 | (fsname /dev/mapper/vg01-var) 126 | (directory /var) 127 | (fstype ext4) 128 | (options rw)))) 129 | |}] 130 | ;; 131 | 132 | let%expect_test "[terminal_width]" = 133 | let width = Lazy.force terminal_width in 134 | let height = Lazy.force terminal_height in 135 | (* we just assert that we got some positive/non-zero width and height. *) 136 | print_s ([%sexp_of: bool] (width > 0)); 137 | print_s ([%sexp_of: bool] (height > 0)); 138 | [%expect 139 | {| 140 | true 141 | true 142 | |}] 143 | ;; 144 | -------------------------------------------------------------------------------- /unix_extended/example/quotactl/quotactl.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Poly 3 | module Unix = Core_unix 4 | module Time = Time_float_unix 5 | module Quota = Unix_extended.Quota 6 | 7 | let id_kind_and_lookup = function 8 | | `User -> "user", fun name -> (Unix.Passwd.getbyname_exn name).Unix.Passwd.uid 9 | | `Group -> "group", fun name -> (Unix.Group.getbyname_exn name).Unix.Group.gid 10 | ;; 11 | 12 | module Query = struct 13 | let make_named_command user_or_group = 14 | let id_kind, lookup_id = id_kind_and_lookup user_or_group in 15 | ( id_kind 16 | , Command.basic_spec 17 | ~summary:(sprintf "Query a %s's quota" id_kind) 18 | Command.Spec.( 19 | step (fun f v -> f ~id:(lookup_id v)) 20 | +> anon (String.uppercase id_kind %: string) 21 | +> anon ("DEVICE" %: Filename_unix.arg_type)) 22 | (fun ~id device () -> 23 | let bytes_limit, bytes_usage, inodes_limit, inodes_usage = 24 | Or_error.ok_exn (Quota.query user_or_group ~id ~path:device) 25 | in 26 | printf "== Usage ==\n"; 27 | printf 28 | " - Bytes : %s\n" 29 | (Int63.to_string (bytes_usage : Quota.bytes Quota.usage :> Int63.t)); 30 | printf 31 | " - Inodes : %s\n" 32 | (Int63.to_string (inodes_usage : Quota.inodes Quota.usage :> Int63.t)); 33 | printf "== Limits ==\n"; 34 | printf 35 | " - Bytes : %s\n" 36 | (Sexp.to_string ([%sexp_of: Quota.bytes Quota.limit] bytes_limit)); 37 | printf 38 | " - Inodes : %s\n" 39 | (Sexp.to_string ([%sexp_of: Quota.inodes Quota.limit] inodes_limit))) ) 40 | ;; 41 | 42 | let named_command = 43 | ( "query" 44 | , Command.group 45 | ~summary:"Query quotas" 46 | [ make_named_command `User; make_named_command `Group ] ) 47 | ;; 48 | end 49 | 50 | module Modify = struct 51 | let make_named_command user_or_group = 52 | let id_kind, lookup_id = id_kind_and_lookup user_or_group in 53 | ( id_kind 54 | , Command.basic_spec 55 | ~summary:(sprintf "Modify a %s's quota" id_kind) 56 | Command.Spec.( 57 | let make_nullable_arg_type ~zero parse = 58 | Arg_type.create (function 59 | | "" | "0" -> None 60 | | s when String.lowercase s = "none" -> None 61 | | s -> 62 | let x = parse s in 63 | if x = zero then None else Some x) 64 | in 65 | let bytes = 66 | make_nullable_arg_type ~zero:(Quota.bytes Int63.zero) (fun s -> 67 | s |> Byte_units.of_string |> Byte_units.bytes_int63 |> Quota.bytes) 68 | in 69 | let inodes = 70 | make_nullable_arg_type ~zero:(Quota.inodes Int63.zero) (fun s -> 71 | Quota.inodes (Int63.of_string s)) 72 | in 73 | let grace = 74 | make_nullable_arg_type ~zero:Time.epoch (fun s -> 75 | try Time.of_string s with 76 | | exn -> 77 | (try Time.add (Time.now ()) (Time.Span.of_string s) with 78 | | _ -> raise exn)) 79 | in 80 | step (fun f v -> f ~id:(lookup_id v)) 81 | +> anon (String.uppercase id_kind %: string) 82 | +> flag "-bytes-soft" (optional bytes) ~doc:"byte usage soft limit" 83 | +> flag "-bytes-hard" (optional bytes) ~doc:"byte usage hard limit" 84 | +> flag "-bytes-grace" (optional grace) ~doc:"byte usage grace period" 85 | +> flag "-inodes-soft" (optional inodes) ~doc:"inode usage soft limit" 86 | +> flag "-inodes-hard" (optional inodes) ~doc:"inode usage hard limit" 87 | +> flag "-inodes-grace" (optional grace) ~doc:"inode usage grace period" 88 | +> anon ("DEVICE" %: Filename_unix.arg_type)) 89 | (fun ~id bsoft bhard bgrace isoft ihard igrace device () -> 90 | let bytes_limit, _bytes_usage, inodes_limit, _inodes_usage = 91 | Or_error.ok_exn (Quota.query user_or_group ~id ~path:device) 92 | in 93 | let update_limit limit soft hard grace = 94 | let optional_update field update = 95 | match field with 96 | | None -> Fn.id 97 | | Some v -> fun l -> update l v 98 | in 99 | List.fold 100 | ~init:limit 101 | ~f:(fun acc update -> update acc) 102 | [ optional_update soft (fun acc soft -> { acc with Quota.soft }) 103 | ; optional_update hard (fun acc hard -> { acc with Quota.hard }) 104 | ; optional_update grace (fun acc grace -> { acc with Quota.grace }) 105 | ] 106 | in 107 | let bytes_limit = update_limit bytes_limit bsoft bhard bgrace in 108 | let inodes_limit = update_limit inodes_limit isoft ihard igrace in 109 | Or_error.ok_exn 110 | (Quota.set user_or_group ~id ~path:device bytes_limit inodes_limit)) ) 111 | ;; 112 | 113 | let named_command = 114 | ( "modify" 115 | , Command.group 116 | ~summary:"Modify quotas" 117 | [ make_named_command `User; make_named_command `Group ] ) 118 | ;; 119 | end 120 | 121 | let command = 122 | Command.group ~summary:"Set/query quotas" [ Query.named_command; Modify.named_command ] 123 | ;; 124 | 125 | let () = Exn.handle_uncaught ~exit:true (fun () -> Command_unix.run command) 126 | -------------------------------------------------------------------------------- /unix_extended/src/unix_extended.mli: -------------------------------------------------------------------------------- 1 | (** Extensions to [Core_unix]. *) 2 | open! Core 3 | 4 | module Unix := Core_unix 5 | 6 | (** [fork_exec prog args ~stdin ~stdout ~stderr ~setuid ~setgid] forks a new process that 7 | executes the program in file [prog], with arguments [args]. The pid of the new process 8 | is returned immediately; the new process executes concurrently with the current 9 | process. 10 | 11 | The function raises EPERM if when using [set{gid,uid}] and the user id is not 0. 12 | 13 | The standard input and outputs of the new process are connected to the descriptors 14 | [stdin], [stdout] and [stderr]. 15 | 16 | The close_on_exec flag is cleared from [stderr] [stdout] and [stdin] so it's safe to 17 | pass in fds with [close_on_exec] set. 18 | 19 | @param path_lookup 20 | if [true] than we use PATH to find the process to exec. \@env specifies the 21 | environment the process runs in 22 | 23 | ERRORS: Unix.unix_error. This function should not raise EINTR; it will restart 24 | itself automatically. 25 | 26 | RATIONAL: [setuid] and [setgid] do not do a full id drop (e.g.: they save the id in 27 | saved id) when the user does not have the privileges required to setuid to anyone. 28 | 29 | By default all file descriptors should be set_closexec ASAP after being open to 30 | avoid being captured in parallel execution of fork_exec; resetting the closexec flag 31 | on the forked flag is a cleaner and more thread safe approach. 32 | 33 | BUGS: The capabilities for setuid in linux are not tied to the uid 0 (man 7 34 | capabilities). It is still fair to assume that under most system this capability is 35 | there IFF uid == 0. A more fine grain permissionning approach would make this 36 | function non-portable and be hard to implement in an async-signal-way. 37 | 38 | Because this function keeps the lock for most of its lifespan and restarts 39 | automatically on EINTR it might prevent the OCaml signal handlers to run in that 40 | thread. *) 41 | val fork_exec 42 | : ?stdin:Unix.File_descr.t 43 | -> ?stdout:Unix.File_descr.t 44 | -> ?stderr:Unix.File_descr.t 45 | -> ?path_lookup:bool 46 | -> ?env:[ `Extend of (string * string) list | `Replace of (string * string) list ] 47 | -> ?working_dir:string 48 | -> ?setuid:int 49 | -> ?setgid:int 50 | -> string 51 | -> string list 52 | -> Pid.t 53 | 54 | val seteuid : int -> unit 55 | val setreuid : uid:int -> euid:int -> unit 56 | 57 | (** Network to host order long, like C. *) 58 | external ntohl : Int32.t -> Int32.t = "extended_ml_ntohl" 59 | 60 | (** Host to network order long, like C. *) 61 | external htonl : Int32.t -> Int32.t = "extended_ml_htonl" 62 | 63 | (** get load averages *) 64 | external getloadavg : unit -> float * float * float = "getloadavg_stub" 65 | 66 | module Extended_passwd : sig 67 | open Unix.Passwd 68 | 69 | (** [of_passwd_line] parse a passwd-like line *) 70 | val of_passwd_line : string -> t option 71 | 72 | (** [of_passwd_line_exn] parse a passwd-like line *) 73 | val of_passwd_line_exn : string -> t 74 | 75 | (** [of_passwd_file] parse a passwd-like file *) 76 | val of_passwd_file : string -> t list option 77 | 78 | (** [of_passwd_file_exn] parse a passwd-like file *) 79 | val of_passwd_file_exn : string -> t list 80 | end 81 | 82 | val strptime 83 | : ?locale:Unix.Locale.t 84 | -> ?allow_trailing_input:bool 85 | -> fmt:string 86 | -> string 87 | -> Unix.tm 88 | [@@deprecated "[since 2019-07] use Core_unix.strptime"] 89 | 90 | (** The CIDR module moved into Core_unix *) 91 | 92 | (** Simple int wrapper to be explicit about ports. *) 93 | module Inet_port : sig 94 | type t [@@deriving sexp_of, compare, hash] 95 | 96 | val of_int : int -> t option 97 | val of_int_exn : int -> t 98 | val of_string : string -> t option 99 | val of_string_exn : string -> t 100 | val to_int : t -> int 101 | val to_string : t -> string 102 | val arg_type : t Command.Arg_type.t 103 | 104 | include Comparable.S_plain with type t := t 105 | 106 | module Stable : sig 107 | module V1 : 108 | Stable_comparable.V1 109 | with type t = t 110 | and type comparator_witness = comparator_witness 111 | end 112 | end 113 | 114 | (* the code for [Unix_extended.Mac_address] has been moved to 115 | [Mac_address_deprecated] (in lib/mac_address/src/deprecated) *) 116 | module Mac_address = Nothing 117 | [@@deprecated 118 | "[since 2020-11] New code should use the [Mac_address] library. Existing code can use \ 119 | [Mac_address_deprecated] as a quick fix (which is an exact drop-in replacement)."] 120 | 121 | module Quota : sig 122 | type bytes = private Int63.t [@@deriving sexp] 123 | type inodes = private Int63.t [@@deriving sexp] 124 | 125 | val bytes : Int63.t -> bytes 126 | val inodes : Int63.t -> inodes 127 | 128 | type 'units limit = 129 | { soft : 'units option 130 | ; hard : 'units option 131 | ; grace : Time_float.t option 132 | } 133 | [@@deriving sexp] 134 | 135 | type 'units usage = private 'units 136 | 137 | val query 138 | : [ `User | `Group ] 139 | -> id:int 140 | -> path:string 141 | -> (bytes limit * bytes usage * inodes limit * inodes usage) Or_error.t 142 | 143 | val set 144 | : [ `User | `Group ] 145 | -> id:int 146 | -> path:string 147 | -> bytes limit 148 | -> inodes limit 149 | -> unit Or_error.t 150 | end 151 | 152 | module Mount_entry : sig 153 | (* see: man 3 getmntent *) 154 | type t [@@deriving sexp] 155 | 156 | val parse_line : string -> t option Or_error.t 157 | val fsname : t -> string 158 | val directory : t -> string 159 | val fstype : t -> string 160 | val options : t -> string 161 | val dump_freq : t -> int option 162 | val fsck_pass : t -> int option 163 | val visible_filesystem : t list -> t String.Map.t 164 | end 165 | 166 | val terminal_width : int Lazy.t 167 | val terminal_height : int Lazy.t 168 | -------------------------------------------------------------------------------- /unix_extended/src/unix_extended_stubs.c: -------------------------------------------------------------------------------- 1 | /* Core_unix support functions written in C. */ 2 | 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | 16 | #if defined (__FreeBSD__) || defined (__OpenBSD__) 17 | #include 18 | #include 19 | #else 20 | #include 21 | #endif 22 | 23 | #include 24 | 25 | #ifndef __USE_ISOC99 26 | # define __USE_ISOC99 27 | #endif 28 | #include 29 | #include 30 | 31 | #include "config.h" 32 | #include "ocaml_utils.h" 33 | 34 | #define MAX_ERROR_LEN 4096 35 | 36 | CAMLprim value extended_ml_seteuid(value euid) 37 | { 38 | if (seteuid(Int_val(euid))) uerror("seteuid", Nothing); 39 | return Val_unit; 40 | } 41 | 42 | CAMLprim value extended_ml_setreuid(value uid, value euid) 43 | { 44 | if (setreuid(Int_val(uid),Int_val(euid))) uerror("setreuid", Nothing); 45 | return Val_unit; 46 | } 47 | 48 | CAMLprim value extended_ml_setegid(value egid) 49 | { 50 | if (seteuid(Int_val(egid)) == -1) uerror("setegid", Nothing); 51 | return Val_unit; 52 | } 53 | 54 | CAMLprim value getloadavg_stub (value v_unit __unused) 55 | { 56 | CAMLparam0(); 57 | CAMLlocal1(v_ret); 58 | double loadavg[3]; 59 | int ret = getloadavg(loadavg,3); 60 | if (ret < 0) uerror("getloadavg",Nothing); 61 | v_ret = caml_alloc_tuple(3); 62 | Store_field(v_ret, 2, caml_copy_double(ret >= 3 ? loadavg[2] : NAN)); 63 | Store_field(v_ret, 1, caml_copy_double(ret >= 2 ? loadavg[1] : NAN)); 64 | Store_field(v_ret, 0, caml_copy_double(ret >= 1 ? loadavg[0] : NAN)); 65 | CAMLreturn(v_ret); 66 | } 67 | 68 | #if defined (__FreeBSD__) || defined (__OpenBSD__) /* BSD */ 69 | 70 | # define quota_control(device, cmd, id, parg) \ 71 | quotactl((device), (cmd), (id), (parg)) 72 | # define QUOTA_BYTES_PER_SPACE_UNIT DEV_BSIZE 73 | # define QUOTA_SPACE_USED(quota) ((quota).dqb_curblocks) 74 | # define QUOTA_MODIFY_COMMAND Q_SETQUOTA 75 | # define QUOTA_SET_VALID_FIELDS(quota) ((void)quota) 76 | 77 | #elif defined (__APPLE__) /* Mac OS */ 78 | 79 | # define quota_control(device, cmd, id, parg) \ 80 | quotactl((device), (cmd), (id), (parg)) 81 | # define QUOTA_BYTES_PER_SPACE_UNIT 1 82 | # define QUOTA_SPACE_USED(quota) ((quota).dqb_curbytes) 83 | # define QUOTA_MODIFY_COMMAND Q_SETQUOTA 84 | # define QUOTA_SET_VALID_FIELDS(quota) ((void)quota) 85 | 86 | #elif defined (_LINUX_QUOTA_VERSION) && _LINUX_QUOTA_VERSION < 2 87 | 88 | #include /* needed to build with musl */ 89 | # define quota_control(device, cmd, id, parg) \ 90 | quotactl((cmd), (device), (id), (parg)) 91 | # define QUOTA_BYTES_PER_SPACE_UNIT BLOCK_SIZE 92 | # define QUOTA_SPACE_USED(quota) ((quota).dqb_curblocks) 93 | # define QUOTA_MODIFY_COMMAND Q_SETQLIM 94 | # define QUOTA_SET_VALID_FIELDS(quota) ((void)quota) 95 | 96 | #else /* _LINUX_QUOTA_VERSION >= 2 or not defined, GLIBC 2.25+ */ 97 | 98 | #include /* needed to build with musl */ 99 | # define quota_control(device, cmd, id, parg) \ 100 | quotactl((cmd), (device), (id), (parg)) 101 | # define QUOTA_BYTES_PER_SPACE_UNIT BLOCK_SIZE 102 | # define QUOTA_SPACE_USED(quota) ((quota).dqb_curspace) 103 | # define QUOTA_MODIFY_COMMAND Q_SETQUOTA 104 | # define QUOTA_SET_VALID_FIELDS(quota) \ 105 | do { (quota).dqb_valid = QIF_LIMITS | QIF_TIMES; } while (0) 106 | 107 | #endif 108 | 109 | int quota_command (value v_user_or_group, int command) { 110 | if (v_user_or_group == caml_hash_variant("User")) 111 | return QCMD(command, USRQUOTA); 112 | 113 | if (v_user_or_group == caml_hash_variant("Group")) 114 | return QCMD(command, GRPQUOTA); 115 | 116 | caml_failwith("Unix.Quota: I only know about `User and `Group"); 117 | } 118 | 119 | CAMLprim value quota_query (value v_user_or_group, value v_id, value v_path) 120 | { 121 | int id, cmd; 122 | struct dqblk quota; 123 | int64_t bytes_used, bytes_soft, bytes_hard; 124 | CAMLparam3(v_user_or_group, v_id, v_path); 125 | CAMLlocal3(v_ret, v_bytes_limit, v_inodes_limit); 126 | 127 | id = Int_val(v_id); 128 | cmd = quota_command(v_user_or_group, Q_GETQUOTA); 129 | 130 | memset("a, 0, sizeof(quota)); 131 | if (quota_control(String_val(v_path), cmd, id, (caddr_t)"a)) 132 | unix_error(errno, "Unix.Quota: unable to query quota", v_path); 133 | 134 | bytes_used = QUOTA_BYTES_PER_SPACE_UNIT * (int64_t) QUOTA_SPACE_USED(quota); 135 | bytes_soft = QUOTA_BYTES_PER_SPACE_UNIT * (int64_t) quota.dqb_bsoftlimit; 136 | bytes_hard = QUOTA_BYTES_PER_SPACE_UNIT * (int64_t) quota.dqb_bhardlimit; 137 | 138 | v_bytes_limit = caml_alloc_small(3, 0); 139 | Store_field(v_bytes_limit, 0, caml_alloc_int63(bytes_soft)); 140 | Store_field(v_bytes_limit, 1, caml_alloc_int63(bytes_hard)); 141 | Store_field(v_bytes_limit, 2, caml_copy_double((double)quota.dqb_btime)); 142 | 143 | v_inodes_limit = caml_alloc_small(3, 0); 144 | Store_field(v_inodes_limit, 0, caml_alloc_int63(quota.dqb_isoftlimit)); 145 | Store_field(v_inodes_limit, 1, caml_alloc_int63(quota.dqb_ihardlimit)); 146 | Store_field(v_inodes_limit, 2, caml_copy_double((double)quota.dqb_itime)); 147 | 148 | v_ret = caml_alloc_small(4, 0); 149 | Store_field(v_ret, 0, v_bytes_limit); 150 | Store_field(v_ret, 1, caml_alloc_int63(bytes_used)); 151 | Store_field(v_ret, 2, v_inodes_limit); 152 | Store_field(v_ret, 3, caml_alloc_int63(quota.dqb_curinodes)); 153 | 154 | CAMLreturn(v_ret); 155 | } 156 | 157 | CAMLprim value quota_modify (value v_user_or_group, value v_id, 158 | value v_path, value v_bytes_limit, value v_inodes_limit) 159 | { 160 | int id, cmd; 161 | struct dqblk quota; 162 | CAMLparam5(v_user_or_group, v_id, v_path, v_bytes_limit, v_inodes_limit); 163 | 164 | id = Int_val(v_id); 165 | cmd = quota_command(v_user_or_group, QUOTA_MODIFY_COMMAND); 166 | 167 | memset("a, 0, sizeof(quota)); 168 | 169 | quota.dqb_bsoftlimit = Int63_val(Field(v_bytes_limit, 0)) / QUOTA_BYTES_PER_SPACE_UNIT; 170 | quota.dqb_bhardlimit = Int63_val(Field(v_bytes_limit, 1)) / QUOTA_BYTES_PER_SPACE_UNIT; 171 | quota.dqb_btime = (time_t) Double_val(Field(v_bytes_limit, 2)); 172 | 173 | quota.dqb_isoftlimit = Int63_val(Field(v_inodes_limit, 0)); 174 | quota.dqb_ihardlimit = Int63_val(Field(v_inodes_limit, 1)); 175 | quota.dqb_itime = (time_t) Double_val(Field(v_inodes_limit, 2)); 176 | 177 | QUOTA_SET_VALID_FIELDS(quota); 178 | 179 | if (quota_control(String_val(v_path), cmd, id, (caddr_t)"a)) 180 | unix_error(errno, "Unix.Quota: unable to set quota", v_path); 181 | 182 | CAMLreturn(Val_unit); 183 | } 184 | 185 | CAMLprim value extended_ml_htonl (value v_num) { 186 | return caml_copy_int32(htonl(Int32_val(v_num))); 187 | } 188 | 189 | CAMLprim value extended_ml_ntohl (value v_num) { 190 | return caml_copy_int32(ntohl(Int32_val(v_num))); 191 | } 192 | -------------------------------------------------------------------------------- /filename_extended/src/filename_extended.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Filename 3 | module Unix = Core_unix 4 | 5 | (** Path *) 6 | 7 | let explode path = 8 | let rec aux = function 9 | | "" | "." -> [] 10 | | "/" -> [ "/" ] 11 | | path -> 12 | let dirname, basename = split path in 13 | basename :: aux dirname 14 | in 15 | List.rev (aux path) 16 | ;; 17 | 18 | let implode = function 19 | | [] -> "." 20 | | "/" :: rest -> "/" ^ String.concat ~sep:"/" rest 21 | | l -> String.concat ~sep:"/" l 22 | ;; 23 | 24 | (* Takes out all "../" and "./" in a path, except that if it's a relative path it may 25 | start with some "../../" stuff at the front. *) 26 | let normalize_path p = 27 | List.fold p ~init:[] ~f:(fun acc path_element -> 28 | match path_element, acc with 29 | (* parent of root is root, and root can only appear as first part of path *) 30 | | "..", [ "/" ] -> [ "/" ] 31 | (* just pop the stack, e.g. /foo/bar/../ becomes just /foo/ *) 32 | | "..", h :: rest when h <> ".." -> rest 33 | | ".", v -> v 34 | | _ -> path_element :: acc 35 | (* accumulate regular dirs or chains of ... at the beginning of a 36 | relative path*)) 37 | |> List.rev 38 | ;; 39 | 40 | let make_relative ?to_ f = 41 | if Option.is_none to_ && is_relative f 42 | then f 43 | else ( 44 | let to_ = 45 | match to_ with 46 | | Some dir -> 47 | if Bool.( <> ) (is_relative f) (is_relative dir) 48 | then 49 | failwithf 50 | "make_relative ~to_:%s %s: cannot work on an absolute path and a relative one" 51 | dir 52 | f 53 | (); 54 | dir 55 | | None -> Sys_unix.getcwd () 56 | in 57 | let rec aux = function 58 | | h :: t, h' :: t' when String.equal h h' -> aux (t, t') 59 | | ".." :: _, _ -> 60 | failwithf 61 | "make_relative ~to_:%s %s: negative lookahead (ie goes \"above\" the current \ 62 | directory)" 63 | to_ 64 | f 65 | () 66 | | p, p' -> List.map ~f:(fun _ -> parent_dir_name) p @ p' 67 | in 68 | let to_ = normalize_path (explode to_) 69 | and f = normalize_path (explode f) in 70 | implode (aux (to_, f))) 71 | ;; 72 | 73 | module%test [@name "make_relative"] _ = struct 74 | let make_relative ~to_ f = 75 | try Some (make_relative ~to_ f) with 76 | | Failure _ -> None 77 | ;; 78 | 79 | let is_none = Option.is_none 80 | 81 | let is_some s = function 82 | | Some s' when equal s s' -> true 83 | | None | Some _ -> false 84 | ;; 85 | 86 | let%test _ = make_relative ~to_:".." "a" |> is_none 87 | let%test _ = make_relative ~to_:".." "../a" |> is_some "a" 88 | let%test _ = make_relative ~to_:"c" "a/b" |> is_some "../a/b" 89 | let%test _ = make_relative ~to_:"/" "a/b" |> is_none 90 | end 91 | 92 | let normalize p = implode (normalize_path (explode p)) 93 | 94 | module%test [@name "normalize"] _ = struct 95 | let%test "id" = normalize "/mnt/local" = "/mnt/local" 96 | let%test "dot_dotdot" = normalize "/mnt/./../local" = "/local" 97 | let%test _ = normalize "/mnt/local/../global/foo" = "/mnt/global/foo" 98 | let%test "beyond_root" = normalize "/mnt/local/../../.." = "/" 99 | let%test "negative_lookahead" = normalize "../a/../../b" = "../../b" 100 | end 101 | 102 | (* The "^" in these operator names is to make them right-associative. 103 | It's important for them to be right-associative so that the short-circuiting works 104 | correctly if you chain them. *) 105 | let ( ^/// ) src p = if is_absolute p then p else concat (src ()) p 106 | let ( ^// ) src p = (fun () -> src) ^/// p 107 | let make_absolute p = Sys_unix.getcwd ^/// p 108 | 109 | let user_home username = 110 | match Unix.Passwd.getbyname username with 111 | | Some user -> 112 | let pw_dir = user.Unix.Passwd.dir in 113 | if Int.( = ) (String.length pw_dir) 0 114 | then failwithf "user's \"%s\"'s home is an empty string" username () 115 | else pw_dir 116 | | None -> failwithf "user \"%s\" not found" username () 117 | ;; 118 | 119 | let expand_user s = 120 | let expand_home = function 121 | | "~" -> user_home (Shell_internal.whoami ()) 122 | | s -> user_home (String.chop_prefix_exn s ~prefix:"~") 123 | in 124 | if String.is_prefix ~prefix:"~" s 125 | then ( 126 | match String.lsplit2 ~on:'/' s with 127 | | Some (base, rest) -> expand_home base ^ "/" ^ rest 128 | | None -> expand_home s) 129 | else s 130 | ;; 131 | 132 | let expand ?(from = ".") p = normalize (Sys_unix.getcwd ^/// from ^// expand_user p) 133 | 134 | let rec is_parent_path p1 p2 = 135 | match p1, p2 with 136 | | [ "/" ], _ -> true 137 | | (h1 :: p1 as l), h2 :: p2 -> 138 | (h1 = h2 && is_parent_path p1 p2) 139 | || (h2 <> ".." && h2 <> "/" && List.for_all l ~f:(( = ) parent_dir_name)) 140 | | l, [] -> List.for_all l ~f:(( = ) parent_dir_name) 141 | | [], h :: _ -> h <> ".." && h <> "/" 142 | ;; 143 | 144 | let is_parent f1 f2 = 145 | is_parent_path (normalize_path (explode f1)) (normalize_path (explode f2)) 146 | ;; 147 | 148 | (** Filename comparison *) 149 | 150 | (* 151 | Extension comparison: 152 | We have a list of lists of extension that should appear consecutive to one 153 | another. Our comparison function works by mapping extensions to 154 | (extension*int) couples, for instance "c" is mapped to "h,1" meaning it 155 | should come right after h. 156 | *) 157 | let create_extension_map l = 158 | List.fold 159 | l 160 | ~f:(fun init l -> 161 | match l with 162 | | [] -> init 163 | | idx :: _ -> 164 | List.foldi 165 | l 166 | ~f:(fun pos map v -> 167 | if Core.Map.mem map v then failwithf "Extension %s is defined twice" v (); 168 | Core.Map.set map ~key:v ~data:(idx, pos)) 169 | ~init) 170 | ~init:Map.empty 171 | ;; 172 | 173 | let extension_cmp map h1 h2 = 174 | let lookup e = Option.value (Core.Map.find map e) ~default:(e, 0) in 175 | Tuple2.compare (lookup h1) (lookup h2) ~cmp1:String_extended.collate ~cmp2:Int.compare 176 | ;; 177 | 178 | let basename_compare map f1 f2 = 179 | let ext_split s = Option.value (String.lsplit2 ~on:'.' s) ~default:(s, "") in 180 | Tuple2.compare 181 | (ext_split f1) 182 | (ext_split f2) 183 | ~cmp1:String_extended.collate 184 | ~cmp2:(extension_cmp map) 185 | ;; 186 | 187 | let filename_compare map v1 v2 = 188 | let v1 = explode v1 189 | and v2 = explode v2 in 190 | List.compare (basename_compare map) v1 v2 191 | ;; 192 | 193 | let parent p = normalize (concat p parent_dir_name) 194 | 195 | module%test [@name "parent"] _ = struct 196 | let%test _ = parent "/mnt/local" = "/mnt" 197 | let%test _ = parent "/mnt/local/../global/foo" = "/mnt/global" 198 | let%test _ = parent "/mnt/local/../../global" = "/" 199 | end 200 | 201 | let extension_map = create_extension_map [ [ "h"; "c" ]; [ "mli"; "ml" ] ] 202 | let compare = filename_compare extension_map 203 | 204 | let with_open_temp_file ?in_dir ?(write = ignore) ~f prefix suffix = 205 | protectx 206 | (Filename_unix.open_temp_file ?in_dir prefix suffix) 207 | ~f:(fun (fname, oc) -> 208 | protectx oc ~f:write ~finally:Out_channel.close; 209 | f fname) 210 | ~finally:(fun (fname, _) -> Unix.unlink fname) 211 | ;; 212 | 213 | let with_temp_dir ?in_dir prefix suffix ~f = 214 | protectx (Filename_unix.temp_dir ?in_dir prefix suffix) ~f ~finally:(fun dirname -> 215 | ignore (Sys_unix.command (sprintf "rm -rf '%s'" dirname) : int)) 216 | ;; 217 | -------------------------------------------------------------------------------- /unix_extended/src/fork_exec.c: -------------------------------------------------------------------------------- 1 | /* Core_unix support functions written in C. */ 2 | 3 | #undef Hide_upstream_size_macros 4 | 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | #include 16 | #include 17 | #include 18 | #include 19 | #include 20 | 21 | #include "fork_exec.h" 22 | 23 | #define PIPE_READ 0 24 | #define PIPE_WRITE 1 25 | 26 | /* 27 | If you want to turn on debugging you may use: 28 | 29 | #define fork_side_assert(v) assert(v) 30 | 31 | Note that assert uses non async-signal-safe functions. Do not leave this on 32 | in any production code 33 | */ 34 | 35 | #define fork_side_assert(ignore) ((void) 0) 36 | 37 | #define SYSCALL(x) \ 38 | while ((x) == -1) { \ 39 | if (errno != EINTR) { \ 40 | report_errno_on_pipe (pfd[PIPE_WRITE],errno);\ 41 | } \ 42 | } \ 43 | 44 | #define NONINTR(x) \ 45 | while ((x) == -1){ assert(errno == EINTR); } \ 46 | 47 | /* Copy an ocaml string array in a c string array terminated by 48 | a null pointer the result need to be free'd with a stat_free 49 | It is a copy of cstringvect in the ocaml unix's module. 50 | */ 51 | static const char ** copy_stringvect(const value arg) 52 | { 53 | const char ** res; 54 | mlsize_t size, i; 55 | 56 | size = Wosize_val(arg); 57 | res = (const char **) caml_stat_alloc((size + 1) * sizeof(const char *)); 58 | for (i = 0; i < size; i++) res[i] = String_val(Field(arg, i)); 59 | res[size] = NULL; 60 | return res; 61 | } 62 | 63 | #ifdef __GNUC__ 64 | /* Giving Gcc as much info as possible */ 65 | static void report_errno_on_pipe (int fd,int my_err) __attribute__((noreturn)); 66 | #endif 67 | 68 | /* 69 | Write an int to an fd. 70 | This function is designed to be used on the fork side and therefore only uses 71 | async-signal-safe functions. 72 | */ 73 | static void report_errno_on_pipe (int fd, int my_err) { 74 | size_t offset = 0; 75 | ssize_t out_chars; 76 | while (offset < sizeof(int)) {; 77 | switch (out_chars=write (fd, 78 | (char *) &my_err + offset, 79 | sizeof(int) - offset)) { 80 | case -1: 81 | fork_side_assert (errno==EINTR); 82 | continue; 83 | default: 84 | offset += (size_t) out_chars; 85 | } 86 | } 87 | fork_side_assert (offset == sizeof(int)); 88 | _exit(254); 89 | } 90 | 91 | static void clear_sigprocmask(void){ 92 | sigset_t empty; 93 | (void) sigemptyset (&empty); 94 | (void) sigprocmask (SIG_SETMASK, &empty, (sigset_t *) NULL); 95 | } 96 | 97 | 98 | /* 99 | Returns 0 if there was no errno printed on the pipe and -1 if there was one. 100 | */ 101 | static int errno_from_pipe (int fd,int *my_errno) { 102 | ssize_t in_chars; 103 | size_t offset = 0; 104 | while (true) { 105 | in_chars=read(fd, 106 | (((char *) my_errno) + offset), 107 | sizeof(int) - offset); 108 | switch (in_chars) { 109 | case -1 : 110 | assert (errno==EINTR); 111 | continue; 112 | case 0: 113 | if (offset == 0) { 114 | /* The fd was closed with nothing written to it; no error */ 115 | return 0; 116 | }; 117 | assert (offset == sizeof(int)); 118 | return -1; 119 | default: 120 | offset += (size_t)in_chars; 121 | } 122 | }; 123 | } 124 | 125 | 126 | /* 127 | [set_cloexec(fd,value)] 128 | Set the close on exec flag of fd to value. Is async-signal-safe. 129 | Returns 0 on success and -1 on error. Sets errno in case of errors. 130 | */ 131 | static int set_cloexec (int fd,int v) { 132 | int flags,new_flags; 133 | if ((flags = fcntl(fd, F_GETFD)) == -1) return -1; 134 | 135 | new_flags = (v ? flags | FD_CLOEXEC : flags & ~FD_CLOEXEC); 136 | 137 | if(new_flags == flags) 138 | return 0; 139 | 140 | return fcntl(fd, F_SETFD, new_flags); 141 | } 142 | 143 | CAMLprim value extended_ml_spawn 144 | ( 145 | value v_stdin, /* Fd to connect to the forked stdin... */ 146 | value v_stdout, 147 | value v_stderr, 148 | value v_working_dir, /* A directory we want to chdir too. [String option] */ 149 | value v_setuid, /* setuid on the fork side [int option] */ 150 | value v_setgid, /* setgid on the fork side [int option] */ 151 | value v_env, /* The Environment to set for execve. pass None to call an 152 | execv instead. [string array option]*/ 153 | value v_prog, /* Program name [string] */ 154 | value v_args /* Full list of args passed to executable [string array] */ 155 | ) 156 | { 157 | CAMLparam5(v_prog, v_args, v_stdin, v_stdout, v_stderr); 158 | CAMLxparam4(v_working_dir,v_setuid,v_setgid,v_env); 159 | int stdin_fd = Int_val (v_stdin); 160 | int stdout_fd = Int_val (v_stdout); 161 | int stderr_fd = Int_val (v_stderr); 162 | const char** envp = NULL; 163 | int my_errno,forked_error; 164 | int pfd[2]; /* The pipe used to report errors.. */ 165 | 166 | /* It's ok to hold pointers into the O'Caml heap, since the memory 167 | space gets duplicated upon the fork, during which we keep the 168 | O'Caml lock. */ 169 | const char* prog = String_val(v_prog); 170 | const char* working_dir = NULL; 171 | 172 | pid_t child_pid; 173 | 174 | const char** args; 175 | 176 | /* We use a pipe to report errors on the forked side */ 177 | if (pipe(pfd) == -1) uerror("extended_ml_spawn::pipe",Nothing); 178 | 179 | /* Set both side of the pipe close_on_exec... */ 180 | (void) set_cloexec(pfd[PIPE_WRITE],true); 181 | (void) set_cloexec(pfd[PIPE_READ],true); 182 | 183 | args = copy_stringvect(v_args); 184 | 185 | if (Is_block(v_env)) 186 | envp = copy_stringvect(Field(v_env,0)); 187 | 188 | if (Is_block(v_working_dir)) 189 | working_dir = String_val(Field(v_working_dir,0)); 190 | 191 | /* This function deliberately doesn't release the O'Caml lock (i.e. it 192 | doesn't call caml_enter_blocking_section) during the fork. This is 193 | because we hold pointers into the ML heap across a fork, and 194 | releasing the lock immediately before the fork could theoretically 195 | cause the GC to run and move blocks before the fork duplicates the 196 | memory space. */ 197 | switch (child_pid = fork()) { 198 | case -1: 199 | my_errno = errno; 200 | caml_stat_free(args); 201 | if (envp) 202 | caml_stat_free(envp); 203 | NONINTR(close(pfd[PIPE_READ])); 204 | NONINTR(close(pfd[PIPE_WRITE])); 205 | unix_error(my_errno,"extended_ml_spawn: fork failed", Nothing); 206 | case 0: 207 | /* Child process. 208 | Since we've just lost all of our threads we need to be very careful 209 | not to call any function that might use a thread lock. This includes 210 | malloc,setenv and stdio functions... This is stated in the POSIX norm as: 211 | 212 | If a multi-threaded process calls fork(), the new process shall contain a 213 | replica of the calling thread and its entire address space, possibly 214 | including the states of mutexes and other resources. Consequently, to 215 | avoid errors, the child process may only execute async-signal-safe 216 | operations until such time as one of the exec functions is called. 217 | 218 | [http://pubs.opengroup.org/onlinepubs/009695399/functions/fork.html] 219 | 220 | The list of functions that we can call on the fork side can be found 221 | here: 222 | [http://pubs.opengroup.org/onlinepubs/009695399/functions/xsh_chap02_04.html] 223 | 224 | We also need to use _exit instead of [exit] because we do not want 225 | [at_exit] registered functions to be called. 226 | */ 227 | 228 | /* Reset the sigmask to get rid of the inherited one */ 229 | clear_sigprocmask(); 230 | 231 | /* Just in case any of the pipes' file descriptors are 0, 1 or 2 232 | (not inconceivable, especially when running as a daemon), 233 | duplicate all three descriptors we need in the child to fresh 234 | descriptors before duplicating them onto stdin, stdout and stderr. 235 | 236 | This will ensure that there is one and only one copy of the file 237 | descriptors passed as arguments with id's higher than 2. 238 | 239 | F_DUPFD cannot get EINTR so we'll go only once through the 240 | loop 241 | */ 242 | SYSCALL(stdin_fd = fcntl(stdin_fd,F_DUPFD,3)); 243 | SYSCALL(stdout_fd= fcntl(stdout_fd,F_DUPFD,3)); 244 | SYSCALL(stderr_fd= fcntl(stderr_fd,F_DUPFD,3)); 245 | 246 | /* We clear out the close on exec on the fds... */ 247 | SYSCALL(set_cloexec(stdin_fd,false)); 248 | SYSCALL(set_cloexec(stdout_fd,false)); 249 | SYSCALL(set_cloexec(stderr_fd,false)); 250 | 251 | /* We must dup2 the descriptors back in place... */ 252 | SYSCALL(dup2(stdin_fd,0)); 253 | SYSCALL(dup2(stdout_fd,1)); 254 | SYSCALL(dup2(stderr_fd,2)); 255 | 256 | /* And close the old fds... */ 257 | SYSCALL(close(stdin_fd)); 258 | SYSCALL(close(stdout_fd)); 259 | SYSCALL(close(stderr_fd)); 260 | 261 | if (working_dir) { 262 | SYSCALL(chdir(working_dir)); 263 | } 264 | 265 | if (Is_block(v_setuid)) { 266 | uid_t uid = (uid_t) Int_val(Field(v_setuid,0)); 267 | if (getuid() != 0) 268 | report_errno_on_pipe (pfd[PIPE_WRITE],EPERM); 269 | SYSCALL(setuid(uid)); 270 | } 271 | 272 | if (Is_block(v_setgid)) { 273 | gid_t gid = (gid_t) Int_val(Field(v_setgid,0)); 274 | if (getuid() != 0) 275 | report_errno_on_pipe (pfd[PIPE_WRITE],EPERM); 276 | SYSCALL(setgid(gid)); 277 | } 278 | 279 | if (envp) { 280 | /* path lookups should be done on the parent side of the fork so no 281 | execvp*/ 282 | SYSCALL(execve(prog,(char **) args,(char **) envp)); 283 | }else { 284 | SYSCALL(execv(prog,(char **) args)); 285 | }; 286 | /* FALLTHRU */ 287 | 288 | default: /* Parent process */ 289 | 290 | caml_enter_blocking_section(); 291 | NONINTR(close (pfd[PIPE_WRITE])); /* Close unused write end */ 292 | /* C side cleanup and looking for errors */ 293 | forked_error = errno_from_pipe(pfd[PIPE_READ],&my_errno); 294 | NONINTR(close (pfd[PIPE_READ])); 295 | if (forked_error) 296 | NONINTR(waitpid(child_pid, 0, 0)); 297 | 298 | caml_leave_blocking_section(); 299 | 300 | /* Caml side cleanup */ 301 | caml_stat_free(args); 302 | if (envp) 303 | caml_stat_free(envp); 304 | 305 | /* Returning the result */ 306 | if (forked_error) 307 | unix_error(my_errno,"extended_ml_spawn::forked_side" , 308 | Nothing); 309 | 310 | /* Reading the pipe.. */ 311 | CAMLreturn(Val_int(child_pid)); 312 | } 313 | } 314 | 315 | CAMLprim value extended_ml_spawn_bc(value *argv, int argn) 316 | { 317 | if (argn != 9) { 318 | caml_failwith("Unix.ml_spawn_bc got the wrong number of \ 319 | arguments. This is due to an error in the FFI."); 320 | } 321 | return 322 | extended_ml_spawn(argv[0], argv[1], argv[2], 323 | argv[3], argv[4], argv[5], 324 | argv[6], argv[7], argv[8]); 325 | } 326 | -------------------------------------------------------------------------------- /string_extended/src/string_extended.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | (* Natural ordering like found in gnome nautilus, the mac finder etc... 4 | Refer to Mli for more documentation 5 | *) 6 | let collate s1 s2 = 7 | let pos1 = ref 0 8 | and pos2 = ref 0 in 9 | let next ~ok s pos = 10 | if !pos = String.length s 11 | then None 12 | else ( 13 | let c = s.[!pos] in 14 | if ok c 15 | then ( 16 | incr pos; 17 | Some c) 18 | else None) 19 | in 20 | let compare_non_numerical () = 21 | let ok c = not (Char.is_digit c) in 22 | let rec loop () = 23 | match next ~ok s1 pos1, next ~ok s2 pos2 with 24 | | Some _, None -> 1 25 | | None, Some _ -> -1 26 | | None, None -> 0 27 | | Some c1, Some c2 when Char.equal c1 c2 -> loop () 28 | | Some c1, Some c2 -> Char.compare c1 c2 29 | in 30 | loop () 31 | in 32 | let compare_numerical () = 33 | let rec consume0 s pos = 34 | match next ~ok:(Char.equal '0') s pos with 35 | | Some _ -> consume0 s pos 36 | | None -> () 37 | in 38 | (* Our main loop works on string representation of ints where all the 39 | trailing zeros have been chopped of. Their magnitude is given by the 40 | length of their representation. If they have the same magnitude the 41 | lexical order is correct. Bias is used to save that information. 42 | *) 43 | let ok = Char.is_digit in 44 | let bias = ref 0 in 45 | let rec loop () = 46 | match next ~ok s1 pos1, next ~ok s2 pos2 with 47 | | Some _, None -> 1 48 | | None, Some _ -> -1 49 | | None, None when !bias <> 0 -> !bias 50 | | None, None -> 51 | (* Both ints have the same value, The one with the shortest 52 | representation (i.e. the least trailing zeroes) is 53 | considered to be the smallest*) 54 | !pos1 - !pos2 55 | | Some c1, Some c2 when !bias = 0 -> 56 | bias := Char.compare c1 c2; 57 | loop () 58 | | Some _, Some _ -> loop () 59 | in 60 | consume0 s1 pos1; 61 | consume0 s2 pos2; 62 | loop () 63 | in 64 | let s1_length = String.length s1 in 65 | let s2_length = String.length s2 in 66 | let rec loop () = 67 | let r = compare_non_numerical () in 68 | let r' = compare_numerical () in 69 | match r, r' with 70 | | 0, 0 when !pos1 = s1_length && !pos2 = s2_length -> 0 71 | | 0, 0 -> loop () 72 | | 0, i | i, _ -> i 73 | in 74 | loop () 75 | ;; 76 | 77 | (** Inverse operation of [String.escaped] *) 78 | exception Unescape_error of bool * int * string 79 | 80 | (* The stdlib's escaped does a lot of fancy wazoo magic to avoid 81 | using a buffer: 82 | It works in two passes, the first one calculates the length of the string to 83 | allocate and the second one does the actual escaping. 84 | 85 | This would be more cumbersome to do here but might be worth the hassle if 86 | performance ever gets to be an issue *) 87 | let unescaped' ?(strict = true) s = 88 | let len = String.length s in 89 | let pos = ref 0 in 90 | let error ?(fatal = false) message = raise (Unescape_error (fatal, !pos, message)) in 91 | let consume () = 92 | let i = !pos in 93 | if i = len then error "unexpectedly reached end of string"; 94 | let c = s.[i] in 95 | pos := i + 1; 96 | c 97 | in 98 | let res = Buffer.create len in 99 | let emit c = Buffer.add_char res c in 100 | let emit_code code = 101 | match Char.of_int code with 102 | | Some c -> emit c 103 | | None -> error ~fatal:true (Printf.sprintf "got invalid escape code %d" code) 104 | in 105 | let rec loop () = 106 | if !pos < len 107 | then ( 108 | let c = consume () in 109 | if Char.( <> ) c '\\' 110 | then emit c 111 | else ( 112 | let mark = !pos in 113 | try 114 | let c = consume () in 115 | match c with 116 | | '\\' | '\"' -> emit c 117 | | 'b' -> emit '\b' 118 | | 'n' -> emit '\n' 119 | | 'r' -> emit '\r' 120 | | 't' -> emit '\t' 121 | | '\n' -> 122 | let rec consume_blank () = 123 | if !pos < len 124 | then ( 125 | match consume () with 126 | | ' ' | '\t' -> consume_blank () 127 | | _ -> decr pos) 128 | in 129 | consume_blank () 130 | | 'x' -> 131 | let c2hex c = 132 | let open Char.O in 133 | if c >= 'A' && c <= 'F' 134 | then Char.to_int c + 10 - Char.to_int 'A' 135 | else if c >= 'a' && c <= 'f' 136 | then Char.to_int c + 10 - Char.to_int 'a' 137 | else if c >= '0' && c <= '9' 138 | then Char.to_int c - Char.to_int '0' 139 | else error (Printf.sprintf "expected hex digit, got: %c" c) 140 | in 141 | let c1 = consume () in 142 | let c2 = consume () in 143 | emit_code ((16 * c2hex c1) + c2hex c2) 144 | | c when Char.is_digit c -> 145 | let char_to_num c = 146 | match Char.get_digit c with 147 | | None -> error (Printf.sprintf "expected digit,got: %c" c) 148 | | Some i -> i 149 | in 150 | let i1 = char_to_num c in 151 | let i2 = char_to_num (consume ()) in 152 | let i3 = char_to_num (consume ()) in 153 | emit_code ((100 * i1) + (10 * i2) + i3) 154 | | c -> error (Printf.sprintf "got invalid escape character: %c" c) 155 | with 156 | | Unescape_error (false, _, _) when not strict -> 157 | emit '\\'; 158 | pos := mark); 159 | loop ()) 160 | else Buffer.contents res 161 | in 162 | loop () 163 | ;; 164 | 165 | let unescaped_exn ?strict s = 166 | try unescaped' ?strict s with 167 | | Unescape_error (_, pos, message) -> 168 | invalid_argf 169 | "String_extended.unescaped_exn error at position %d of %s: %s" 170 | pos 171 | s 172 | message 173 | () 174 | ;; 175 | 176 | let squeeze str = 177 | let len = String.length str in 178 | let buf = Buffer.create len in 179 | let rec skip_spaces i = 180 | if i >= len 181 | then Buffer.contents buf 182 | else ( 183 | let c = str.[i] in 184 | if Char.O.(c = ' ' || c = '\n' || c = '\t' || c = '\r') 185 | then skip_spaces (i + 1) 186 | else ( 187 | Buffer.add_char buf c; 188 | copy_chars (i + 1))) 189 | and copy_chars i = 190 | if i >= len 191 | then Buffer.contents buf 192 | else ( 193 | let c = str.[i] in 194 | if Char.O.(c = ' ' || c = '\n' || c = '\t' || c = '\r') 195 | then ( 196 | Buffer.add_char buf ' '; 197 | skip_spaces (i + 1)) 198 | else ( 199 | Buffer.add_char buf c; 200 | copy_chars (i + 1))) 201 | in 202 | copy_chars 0 203 | ;; 204 | 205 | let line_break ~len s = 206 | let buf = Buffer.create len in 207 | let flush_buf () = 208 | let res = Buffer.contents buf in 209 | Buffer.reset buf; 210 | res 211 | in 212 | let rec loop acc = function 213 | | [] -> 214 | let acc = 215 | if Buffer.length buf <> 0 216 | then flush_buf () :: acc 217 | else if List.is_empty acc 218 | then [ "" ] 219 | else acc 220 | in 221 | List.rev acc 222 | | h :: t when Buffer.length buf = 0 -> 223 | Buffer.add_string buf h; 224 | loop acc t 225 | | h :: t when Buffer.length buf + 1 + String.length h < len -> 226 | Buffer.add_char buf ' '; 227 | Buffer.add_string buf h; 228 | loop acc t 229 | | l -> loop (flush_buf () :: acc) l 230 | in 231 | List.concat_map (String.split ~on:'\n' s) ~f:(fun s -> loop [] (String.split ~on:' ' s)) 232 | ;; 233 | 234 | (* Finds out where to break a given line; returns the len of the line to break 235 | and the staring position of the next line.*) 236 | let rec word_wrap__break_one ~hard_limit ~soft_limit ~previous_match s ~pos ~len = 237 | if pos = String.length s 238 | then len, pos 239 | else if previous_match > 0 && len >= soft_limit 240 | then previous_match, pos - len + previous_match + 1 241 | else if len >= hard_limit 242 | then len, pos 243 | else ( 244 | match s.[pos] with 245 | (* Detect \r\n as one newline and not two... *) 246 | | '\r' when pos < String.length s - 1 && Char.equal s.[pos + 1] '\n' -> len, pos + 2 247 | | '\r' | '\n' -> len, pos + 1 248 | | ' ' | '\t' -> 249 | word_wrap__break_one 250 | s 251 | ~hard_limit 252 | ~soft_limit 253 | ~previous_match:len 254 | ~pos:(pos + 1) 255 | ~len:(len + 1) 256 | | _ -> 257 | word_wrap__break_one 258 | s 259 | ~previous_match 260 | ~hard_limit 261 | ~soft_limit 262 | ~pos:(pos + 1) 263 | ~len:(len + 1)) 264 | ;; 265 | 266 | (* Returns an pos*length list of all the lines (as substrings of the argument 267 | passed in) *) 268 | let rec word_wrap__find_substrings ~hard_limit ~soft_limit s acc pos = 269 | if pos < String.length s 270 | then ( 271 | let len, new_pos = 272 | word_wrap__break_one s ~hard_limit ~soft_limit ~previous_match:0 ~pos ~len:0 273 | in 274 | word_wrap__find_substrings ~hard_limit ~soft_limit s ((pos, len) :: acc) new_pos) 275 | else acc 276 | ;; 277 | 278 | let word_wrap 279 | ?(trailing_nl = false) 280 | ?(soft_limit = 80) 281 | ?(hard_limit = Int.max_value) 282 | ?(nl = "\n") 283 | s 284 | = 285 | let soft_limit = min soft_limit hard_limit in 286 | let lines = word_wrap__find_substrings ~soft_limit ~hard_limit s [] 0 in 287 | match lines with 288 | | [] | [ _ ] -> if trailing_nl then s ^ nl else s 289 | | (hpos, hlen) :: t -> 290 | let nl_len = String.length nl in 291 | let body_len = List.fold_left t ~f:(fun acc (_, len) -> acc + nl_len + len) ~init:0 in 292 | let res_len = if trailing_nl then body_len + hlen + nl_len else body_len + hlen in 293 | let res = Bytes.create res_len in 294 | if trailing_nl 295 | then 296 | Bytes.From_string.blit 297 | ~src:nl 298 | ~dst:res 299 | ~len:nl_len 300 | ~src_pos:0 301 | ~dst_pos:(body_len + hlen); 302 | Bytes.From_string.blit ~src:s ~dst:res ~len:hlen ~src_pos:hpos ~dst_pos:body_len; 303 | let rec blit_loop dst_end_pos = function 304 | | [] -> () 305 | | (src_pos, len) :: rest -> 306 | let dst_pos = dst_end_pos - len - nl_len in 307 | Bytes.From_string.blit ~src:s ~dst:res ~len ~src_pos ~dst_pos; 308 | Bytes.From_string.blit 309 | ~src:nl 310 | ~dst:res 311 | ~len:nl_len 312 | ~src_pos:0 313 | ~dst_pos:(dst_pos + len); 314 | blit_loop dst_pos rest 315 | in 316 | blit_loop body_len t; 317 | Bytes.unsafe_to_string ~no_mutation_while_string_reachable:res 318 | ;; 319 | 320 | let edit_distance_matrix ?transpose s1 s2 = 321 | let transpose = Option.is_some transpose in 322 | let l1, l2 = String.length s1, String.length s2 in 323 | let d = Array.make_matrix 0 ~dimx:(l1 + 1) ~dimy:(l2 + 1) in 324 | for x = 0 to l1 do 325 | d.(x).(0) <- x 326 | done; 327 | for y = 0 to l2 do 328 | d.(0).(y) <- y 329 | done; 330 | for y = 1 to l2 do 331 | for x = 1 to l1 do 332 | let min_d = 333 | if Char.equal s1.[x - 1] s2.[y - 1] 334 | then d.(x - 1).(y - 1) 335 | else 336 | List.reduce_exn 337 | ~f:min 338 | [ d.(x - 1).(y) + 1; d.(x).(y - 1) + 1; d.(x - 1).(y - 1) + 1 ] 339 | in 340 | let min_d = 341 | if transpose 342 | && x > 1 343 | && y > 1 344 | && Char.equal s1.[x - 1] s2.[y - 2] 345 | && Char.equal s1.[x - 2] s2.[y - 1] 346 | then min min_d (d.(x - 2).(y - 2) + 1) 347 | else min_d 348 | in 349 | d.(x).(y) <- min_d 350 | done 351 | done; 352 | d 353 | ;; 354 | 355 | let edit_distance ?transpose s1 s2 = 356 | (edit_distance_matrix ?transpose s1 s2).(String.length s1).(String.length s2) 357 | ;; 358 | -------------------------------------------------------------------------------- /src/shell.mli: -------------------------------------------------------------------------------- 1 | (** Shell scripting in OCaml. 2 | 3 | This module contains basic blocks for shell scripting in OCaml. It tends to be safer 4 | than just using [Unix.system] because it handles errors more strictly. *) 5 | open! Core 6 | 7 | module Unix := Core_unix 8 | 9 | (** {6 Process handling} *) 10 | 11 | (** This type is an umbrella type for all the command that dispatch a process. It comes 12 | with a list of arguments whose default value can be tweaked by set_defaults. 13 | 14 | - [use_extra_path] : if we fail to find the command in the path then we look for it 15 | [extra_path] 16 | - [timeout] : the command will raise [Failed] if the program doesn't do any IO for 17 | this period of time 18 | - [working_dir] : run the command in this directory 19 | - [verbose] : prints the output of the command 20 | - [echo] : print out the command before running it 21 | - [input] : a string to pipe through the program's standard in 22 | - [env] : controls the environment variables passed to the command 23 | - [preserve_euid] : pass the '-p' option to bash when running the command; this should 24 | disable the default bash behavior of replacing the effective user ID with the 25 | current value of the real user ID, useful in programs where privileges are escalated 26 | and de-escalated using seteuid(2) 27 | - [strict_errors] : pass '-eu -o pipefail' options to bash when running the command 28 | 29 | WARNING: the input argument to this function should not be used because it can 30 | deadlock if the input is too big (~160kb?) *) 31 | type 'a with_process_flags = 32 | ?use_extra_path:bool 33 | -> ?timeout:Time_float.Span.t option 34 | -> ?working_dir:string (* rename to run_in? *) 35 | -> ?setuid:int 36 | -> ?setgid:int 37 | -> ?env:[ `Extend of (string * string) list | `Replace of (string * string) list ] 38 | -> ?verbose:bool 39 | -> ?echo:bool 40 | -> ?input:string 41 | -> ?keep_open:bool 42 | -> ?tail_len:int 43 | -> 'a 44 | 45 | (** This is the list of flags for normal process dispatch. It is an extension of 46 | [with_process_flags]. 47 | 48 | - [expect] : an int list of valid return codes. default value is [[0]], if the return 49 | code of the dispatched is not in this list we will blowup with [Process.Failure] *) 50 | type 'a with_run_flags = ?expect:int list -> 'a with_process_flags 51 | 52 | (** {9 Basic run functions} 53 | 54 | In all the functions below the command is specified with two arguments. The first one 55 | is a string representing the process to run. The second one is the list of arguments 56 | to pass. 57 | 58 | Although the arguments do not need to be escaped there is still a risk that they might 59 | be interpreted as flags when they aren't. Most basic unix utilities provide the 60 | ability to pass arguments after "--" to avoid this. 61 | 62 | Usage example: 63 | {[ 64 | let patch = run_full ~expect:[ 0; 1 ] "diff" [ "-u"; "--"; file1; file2 ] 65 | ]} *) 66 | 67 | type 'a cmd = string -> string list -> 'a 68 | 69 | (** Runs a command and discards its output. *) 70 | val run : unit cmd with_run_flags 71 | 72 | (** Runs a command and returns its output line separated. Note: most commands print a 73 | newline at the end of their output so the shell prompt appears on its own line. If the 74 | output ends in a newline, it is stripped before splitting the output into a string 75 | list to avoid there being a final element in the list containing just the empty 76 | string. 77 | 78 | In some cases, the newline should not be stripped (e.g., "cat" will not "add" a 79 | newline). If you care, use [run_full] for the entire buffer. *) 80 | val run_lines : ?eol:char -> string list cmd with_run_flags 81 | 82 | (** Returns the first line of the command's output. 83 | 84 | This function might terminate the program early the same way that piping through 85 | [head -n 1] would. When that happens, exit code of the program gets ignored! *) 86 | val run_first_line : ?eol:char -> string option cmd with_run_flags 87 | 88 | val run_first_line_exn : ?eol:char -> string cmd with_run_flags 89 | 90 | (** Returns the only line of the command's output. If the command prints zero or multiple 91 | lines this returns an [Error]. 92 | 93 | If the command exits with non-zero exit code it raises an exception. *) 94 | val run_one_line : ?eol:char -> string Or_error.t cmd with_run_flags 95 | 96 | val run_one_line_exn : ?eol:char -> string cmd with_run_flags 97 | 98 | val run_one : ?eol:char -> string option cmd with_run_flags 99 | [@@deprecated 100 | "[since 2017-11] Use [run_one_line] to get a different behavior or [run_first_line] to \ 101 | get the old behavior"] 102 | 103 | val run_one_exn : ?eol:char -> string cmd with_run_flags 104 | [@@deprecated 105 | "[since 2017-11] Use [run_one_line_exn] to get a different behavior or \ 106 | [run_first_line_exn] to get the old behavior"] 107 | 108 | (** Return the full command's output in one string. See the note in [run_lines]. *) 109 | val run_full : string cmd with_run_flags 110 | 111 | (** Fold over the lines in the stdout of a process; The `Continue/`Stop argument is there 112 | to allow early returning. [eol] specifies the end of line character used to separate 113 | the lines outputted by the the program *) 114 | val run_fold 115 | : ?eol:char 116 | -> init:'a 117 | -> f:('a -> string -> 'a * [ `Continue | `Stop ]) 118 | -> 'a cmd with_run_flags 119 | 120 | (** {9 Dispatch to /bin/bash} 121 | 122 | All these function take a format (like printf) and run it through the shell. 123 | 124 | Usage example: 125 | {[ 126 | sh "cp -- %s %s" (Filename.quote file1) (Filename.quote file2) 127 | ]} 128 | 129 | In general it is recommended to avoid using those too much and to prefer the run* 130 | family of function instead because it avoids pitfall like escaping issues and is much 131 | more straightforward to think about. *) 132 | 133 | type ('a, 'ret) sh_cmd = ('a, unit, string, 'ret) format4 -> 'a 134 | type 'a with_sh_flags = ?strict_errors:bool -> 'a 135 | 136 | val sh : ('a, unit) sh_cmd with_run_flags with_sh_flags 137 | val sh_lines : ('a, string list) sh_cmd with_run_flags with_sh_flags 138 | val sh_full : ('a, string) sh_cmd with_run_flags with_sh_flags 139 | 140 | val sh_one : ('a, string option) sh_cmd with_run_flags with_sh_flags 141 | [@@deprecated 142 | "[since 2017-11] Use [sh_one_line] to get a different behavior or [sh_first_line] to \ 143 | get the old behavior"] 144 | 145 | val sh_one_exn : ('a, string) sh_cmd with_run_flags with_sh_flags 146 | [@@deprecated 147 | "[since 2017-11] Use [sh_one_line_exn] to get a different behavior or \ 148 | [sh_first_line_exn] to get the old behavior"] 149 | 150 | val sh_one_line : ('a, string Or_error.t) sh_cmd with_run_flags with_sh_flags 151 | val sh_one_line_exn : ('a, string) sh_cmd with_run_flags with_sh_flags 152 | val sh_first_line : ('a, string option) sh_cmd with_run_flags with_sh_flags 153 | val sh_first_line_exn : ('a, string) sh_cmd with_run_flags with_sh_flags 154 | 155 | (* Magic invocation to avoid asking for password if we can. These arguments are 156 | passed to ssh in the [ssh_*] functions below. They're exposed in case you 157 | want to use them in a different context. *) 158 | val noninteractive_ssh_options : string list 159 | val noninteractive_no_hostkey_checking_options : string list 160 | 161 | type 'a with_ssh_flags = ?ssh_options:string list -> ?user:string -> host:string -> 'a 162 | 163 | val ssh : ('a, unit) sh_cmd with_run_flags with_ssh_flags 164 | val ssh_lines : ('a, string list) sh_cmd with_run_flags with_ssh_flags 165 | val ssh_full : ('a, string) sh_cmd with_run_flags with_ssh_flags 166 | 167 | val ssh_one : ('a, string option) sh_cmd with_run_flags with_ssh_flags 168 | [@@deprecated 169 | "[since 2017-11] Use [ssh_one_line] to get a different behavior or [ssh_first_line] to \ 170 | get the old behavior"] 171 | 172 | val ssh_one_exn : ('a, string) sh_cmd with_run_flags with_ssh_flags 173 | [@@deprecated 174 | "[since 2017-11] Use [ssh_one_line_exn] to get a different behavior or \ 175 | [ssh_first_line_exn] to get the old behavior"] 176 | 177 | val ssh_one_line : ('a, string Or_error.t) sh_cmd with_run_flags with_ssh_flags 178 | val ssh_one_line_exn : ('a, string) sh_cmd with_run_flags with_ssh_flags 179 | val ssh_first_line : ('a, string option) sh_cmd with_run_flags with_ssh_flags 180 | val ssh_first_line_exn : ('a, string) sh_cmd with_run_flags with_ssh_flags 181 | 182 | (** {9 Test dispatches} 183 | 184 | Usage example: 185 | {[ 186 | if Shell.test "diff" [ "-q"; "--"; file1; file2 ] 187 | then Printf.printf "Files %S and %S are the same\n%!" file1 file2 188 | ]} *) 189 | 190 | (** This is the list of flags for dispatching processes in test mode. This is used to test 191 | the return code of the dispatched program. The return value of these functions will be 192 | : 193 | - [true] if the exit code is in [true_v]. 194 | - [false] if the exit code is in [false_v] and not in [true_v]. 195 | - Raises [Process.Failure] otherwise 196 | 197 | The default values are: 198 | - [true_v]: default value [[0]] 199 | - [false_v]: default_value [[1]] *) 200 | type 'a with_test_flags = ?true_v:int list -> ?false_v:int list -> 'a with_process_flags 201 | 202 | val test : bool cmd with_test_flags 203 | val sh_test : ('a, bool) sh_cmd with_test_flags with_sh_flags 204 | val ssh_test : ('a, bool) sh_cmd with_test_flags with_ssh_flags 205 | 206 | (** variable used by dispatch command to find binaries not in the path. The default values 207 | contains only directory which should be in PATH and is only useful in environments 208 | where the PATH variable has been blown away. *) 209 | val extra_path : string list Dynamic.t 210 | 211 | (** Process dispatching *) 212 | module Process : sig 213 | (** The termination status of a process. This is an extension of [Unix.Process_status.t] 214 | to allow timeouts. *) 215 | type status = 216 | [ `Timeout of Time_float.Span.t 217 | | `Exited of int 218 | | `Signaled of Signal.t (* WStopped is impossible*) 219 | ] 220 | 221 | type t 222 | 223 | type result = 224 | { command : t 225 | ; status : status 226 | ; stdout : string 227 | ; stderr : string 228 | } 229 | [@@unsafe_allow_any_mode_crossing] 230 | 231 | exception Failed of result 232 | 233 | val to_string : t -> string 234 | val status_to_string : status -> string 235 | 236 | val set_defaults 237 | : ?timeout:Time_float.Span.t option 238 | -> ?verbose:bool 239 | -> ?echo:bool 240 | -> ?preserve_euid:bool 241 | -> ?strict_errors:bool 242 | -> unit 243 | -> unit 244 | 245 | val format_failed : result -> string 246 | val cmd : string -> string list -> t 247 | val shell : ?strict_errors:bool -> string -> t 248 | 249 | val make_ssh_command 250 | : ?ssh_options:string list 251 | -> ?quote_args:bool 252 | -> ?user:string 253 | -> host:string 254 | -> string list 255 | -> t 256 | 257 | val remote 258 | : ?ssh_options:string list 259 | -> ?quote_args:bool 260 | -> ?user:string 261 | -> host:string 262 | -> t 263 | -> t 264 | 265 | type 'a reader 266 | 267 | val content : string reader 268 | val content_and_stderr : (string * string) reader 269 | val discard : unit reader 270 | val lines : ?eol:char -> unit -> string list reader 271 | val head : ?eol:char -> unit -> string option reader 272 | 273 | exception Empty_head 274 | 275 | val head_exn : ?eol:char -> unit -> string reader 276 | val one_line : ?eol:char -> unit -> string Or_error.t reader 277 | val one_line_exn : ?eol:char -> unit -> string reader 278 | val callback : add:(Bytes.t -> int -> unit) -> flush:(unit -> unit) -> unit reader 279 | 280 | val callback_with_stderr 281 | : add:(Bytes.t -> int -> unit) 282 | -> add_err:(Bytes.t -> int -> unit) 283 | -> flush:(unit -> unit) 284 | -> unit reader 285 | 286 | val run : (t -> 'a reader -> 'a) with_run_flags 287 | val run_k : ((t -> 'a reader -> 'a) -> 'b) -> 'b with_run_flags 288 | val test : (t -> bool) with_test_flags 289 | val test_k : ((t -> bool) -> 'a) -> 'a with_test_flags 290 | end 291 | 292 | (** {6 Small helper commands} *) 293 | 294 | val mkdir : ?p:unit -> ?perm:int -> string -> unit 295 | val cp : ?overwrite:bool -> ?perm:Unix.file_perm -> string -> string -> unit 296 | val ln : ?s:unit -> ?f:unit -> string -> string -> unit 297 | 298 | (** Behavior of flags for [rm] function differs slightly from what you may expect: 299 | 300 | - When called on a read-only file, [rm file] will remove that file, even if [~f:()] 301 | flag is not passed, which is not the case for an interactive usage of a shell "rm" 302 | command; 303 | - When called on a non-existent file, [rm file] would raise, while [rm ~f:() file] 304 | would succeed. *) 305 | val rm : ?r:unit -> ?f:unit -> string -> unit 306 | 307 | (** Raises "Failed_command" *) 308 | val mv : string -> string -> unit 309 | 310 | (** Get the username. By default, the effective username. If real is true, get the real 311 | username. *) 312 | val whoami : ?real:bool -> unit -> string 313 | 314 | val which : ?use_extra_path:bool -> string -> string option 315 | 316 | (** [scp user host from to] copy local file from to to *) 317 | val scp 318 | : ?compress:bool 319 | -> ?recurse:bool 320 | -> ?user:string 321 | -> host:string 322 | -> string 323 | -> string 324 | -> unit 325 | -------------------------------------------------------------------------------- /unix_extended/src/unix_extended.ml: -------------------------------------------------------------------------------- 1 | module Stable0 = struct 2 | open Core.Core_stable 3 | 4 | module Inet_port = struct 5 | module V1 = struct 6 | module T = struct 7 | type t = int [@@deriving compare, equal, hash] 8 | 9 | let of_int_exn x = 10 | if x > 0 && x < 65536 11 | then x 12 | else failwith (Core.sprintf "%d is not a valid port number." x) 13 | ;; 14 | 15 | let to_int x = x 16 | 17 | include%template 18 | Sexpable.Of_sexpable.V1 [@mode portable] 19 | (Int.V1) 20 | (struct 21 | type nonrec t = t 22 | 23 | let of_sexpable = of_int_exn 24 | let to_sexpable = to_int 25 | end) 26 | 27 | include%template 28 | Binable.Of_binable.V1 [@alert "-legacy"] [@mode portable] 29 | (Int.V1) 30 | (struct 31 | type nonrec t = t 32 | 33 | let of_binable = of_int_exn 34 | let to_binable = to_int 35 | end) 36 | 37 | include%template (val (Comparator.V1.make [@mode portable]) ~compare ~sexp_of_t) 38 | 39 | let%expect_test _ = 40 | print_string [%bin_digest: t]; 41 | [%expect {| 698cfa4093fe5e51523842d37b92aeac |}] 42 | ;; 43 | end 44 | 45 | include T 46 | 47 | include%template Comparable.V1.Make [@mode portable] (T) 48 | end 49 | end 50 | end 51 | 52 | open Core 53 | open Poly 54 | module Unix = Core_unix 55 | open Unix 56 | module Time = Time_float_unix 57 | 58 | external raw_fork_exec 59 | : stdin:File_descr.t 60 | -> stdout:File_descr.t 61 | -> stderr:File_descr.t 62 | -> ?working_dir:string 63 | -> ?setuid:int 64 | -> ?setgid:int 65 | -> ?env:string array 66 | -> string 67 | -> string array 68 | -> Pid.t 69 | = "extended_ml_spawn_bc" "extended_ml_spawn" 70 | 71 | let raw_fork_exec ~stdin ~stdout ~stderr ?working_dir ?setuid ?setgid ?env prog argv = 72 | (* [spawn] is generally preferred: it seems better tested and more actively maintained. 73 | It also uses [vfork] so it's more efficient. For now we still must fall back to 74 | [extended_ml_spawn] for the case when [setuid] or [setgid] is requested, 75 | but we should completely switch to [spawn] when/if it supports that. *) 76 | match setuid, setgid with 77 | | None, None -> 78 | let env = Option.map ~f:(fun env -> Spawn.Env.of_list (Array.to_list env)) env in 79 | let cwd = 80 | Option.value_map 81 | ~default:Spawn.Working_dir.Inherit 82 | ~f:(fun cwd -> Path cwd) 83 | working_dir 84 | in 85 | let argv = Array.to_list argv in 86 | Pid.of_int (Spawn.spawn ?env ~cwd ~prog ~argv ~stdin ~stdout ~stderr ()) 87 | | Some _, _ | _, Some _ -> 88 | raw_fork_exec ~stdin ~stdout ~stderr ?working_dir ?setuid ?setgid ?env prog argv 89 | ;; 90 | 91 | module Env = struct 92 | open String.Map 93 | 94 | type t = string String.Map.t 95 | 96 | let empty : t = empty 97 | 98 | let get () = 99 | Array.fold (Unix.environment ()) ~init:empty ~f:(fun env str -> 100 | match String.lsplit2 ~on:'=' str with 101 | | Some (key, data) -> Map.set ~key ~data env 102 | | None -> 103 | failwithf "extended_unix.Env.get %S is not in the form of key=value" str ()) 104 | ;; 105 | 106 | let add ~key ~data env = 107 | if String.mem key '=' 108 | then 109 | failwithf 110 | "extended_unix.Env.add:variable to export in the environment %S contains an \ 111 | equal sign" 112 | key 113 | () 114 | else if String.mem key '\000' 115 | then 116 | failwithf 117 | "extended_unix.Env.add:variable to export in the environment %S contains an null \ 118 | character" 119 | key 120 | () 121 | else if String.mem data '\000' 122 | then 123 | failwithf 124 | "extended_unix.Env.add:value (%S) to export in the environment for %S contains \ 125 | an null character" 126 | data 127 | key 128 | () 129 | else Map.set ~key ~data (env : _ String.Map.t) 130 | ;; 131 | 132 | let to_string_array env = 133 | Map.to_alist (env : _ String.Map.t) 134 | |> List.map ~f:(fun (k, v) -> k ^ "=" ^ v) 135 | |> List.to_array 136 | ;; 137 | end 138 | 139 | let fork_exec 140 | ?(stdin = Unix.stdin) 141 | ?(stdout = Unix.stdout) 142 | ?(stderr = Unix.stderr) 143 | ?(path_lookup = true) 144 | ?env 145 | ?working_dir 146 | ?setuid 147 | ?setgid 148 | prog 149 | args 150 | = 151 | let env = 152 | Option.map env ~f:(fun e -> 153 | let init, l = 154 | match e with 155 | | `Extend l -> Env.get (), l 156 | | `Replace l -> Env.empty, l 157 | in 158 | List.fold_left l ~init ~f:(fun env (key, data) -> Env.add ~key ~data env) 159 | |> Env.to_string_array) 160 | and full_prog = 161 | if path_lookup 162 | then ( 163 | match Shell_internal.which prog with 164 | | Some s -> s 165 | | None -> failwithf "fork_exec: File not found %s" prog ()) 166 | else prog 167 | in 168 | raw_fork_exec 169 | ~stdin 170 | ~stdout 171 | ~stderr 172 | ?working_dir 173 | ?setuid 174 | ?setgid 175 | ?env 176 | full_prog 177 | (Array.of_list (prog :: args)) 178 | ;; 179 | 180 | external seteuid : int -> unit = "extended_ml_seteuid" 181 | external setreuid : uid:int -> euid:int -> unit = "extended_ml_setreuid" 182 | external htonl : Int32.t -> Int32.t = "extended_ml_htonl" 183 | external ntohl : Int32.t -> Int32.t = "extended_ml_ntohl" 184 | 185 | let%test _ = htonl (ntohl 0xdeadbeefl) = 0xdeadbeefl 186 | 187 | (** get load averages *) 188 | external getloadavg : unit -> float * float * float = "getloadavg_stub" 189 | 190 | module Extended_passwd = struct 191 | open Passwd 192 | 193 | let of_passwd_line_exn s = 194 | match String.split s ~on:':' with 195 | | [ name; passwd; uid; gid; gecos; dir; shell ] -> 196 | { name 197 | ; passwd 198 | ; uid = Int.of_string uid 199 | ; gid = Int.of_string gid 200 | ; gecos 201 | ; dir 202 | ; shell 203 | } 204 | | _ -> failwithf "of_passwd_line: failed to parse: %s" s () 205 | ;; 206 | 207 | let of_passwd_line s = Option.try_with (fun () -> of_passwd_line_exn s) 208 | 209 | let of_passwd_file_exn fn = 210 | Exn.protectx 211 | (In_channel.create fn) 212 | ~f:(fun chan -> List.map (In_channel.input_lines chan) ~f:of_passwd_line_exn) 213 | ~finally:In_channel.close 214 | ;; 215 | 216 | let of_passwd_file f = Option.try_with (fun () -> of_passwd_file_exn f) 217 | end 218 | 219 | let strptime = Core_unix.strptime 220 | 221 | module Inet_port = struct 222 | module Stable = Stable0.Inet_port 223 | 224 | module T = struct 225 | type t = int [@@deriving compare, equal, hash] 226 | type comparator_witness = Stable.V1.comparator_witness 227 | 228 | let comparator = Stable.V1.comparator 229 | let sexp_of_t = Stable.V1.sexp_of_t 230 | end 231 | 232 | include T 233 | 234 | let of_int_exn = Stable.V1.of_int_exn 235 | 236 | let of_int x = 237 | try Some (of_int_exn x) with 238 | | _ -> None 239 | ;; 240 | 241 | let of_string_exn x = Int.of_string x |> of_int_exn 242 | 243 | let of_string x = 244 | try Some (of_string_exn x) with 245 | | _ -> None 246 | ;; 247 | 248 | let to_string x = Int.to_string x 249 | let to_int x = x 250 | let arg_type = (Command.Spec.Arg_type.create [@mode portable]) of_string_exn 251 | 252 | include%template Comparable.Make_plain_using_comparator [@mode portable] (T) 253 | end 254 | 255 | let%test _ = Inet_port.of_string "88" = Some 88 256 | let%test _ = Inet_port.of_string "2378472398572" = None 257 | let%test _ = Inet_port.of_int 88 = Some 88 258 | let%test _ = Inet_port.of_int 872342 = None 259 | 260 | (* the code for [Unix_extended.Mac_address] has been moved to 261 | [Mac_address_deprecated] (in lib/mac_address/src/deprecated) *) 262 | module Mac_address = Nothing 263 | [@@deprecated 264 | "[since 2020-11] New code should use the [Mac_address] library. Existing code can use \ 265 | [Mac_address_deprecated] as a quick fix (which is an exact drop-in replacement)."] 266 | 267 | module Quota = struct 268 | type bytes = Int63.t [@@deriving sexp] 269 | type inodes = Int63.t [@@deriving sexp] 270 | 271 | let bytes x = x 272 | let inodes x = x 273 | 274 | type 'units limit = 275 | { soft : 'units option [@sexp.option] 276 | ; hard : 'units option [@sexp.option] 277 | ; grace : Time.t option [@sexp.option] 278 | } 279 | [@@deriving sexp] 280 | 281 | type 'units usage = private 'units 282 | 283 | (* None is encoded as zero *) 284 | type 'units c_limit = 285 | { c_soft : 'units 286 | ; c_hard : 'units 287 | ; c_grace : Time.t 288 | } 289 | 290 | let zero_bytes = bytes Int63.zero 291 | let zero_inodes = inodes Int63.zero 292 | 293 | let ml_limit_of_c_limit ~zero { c_soft; c_hard; c_grace } = 294 | { soft = (if c_soft = zero then None else Some c_soft) 295 | ; hard = (if c_hard = zero then None else Some c_hard) 296 | ; grace = (if c_grace = Time.epoch then None else Some c_grace) 297 | } 298 | ;; 299 | 300 | let c_limit_of_ml_limit ~zero { soft; hard; grace } = 301 | { c_soft = 302 | (match soft with 303 | | None -> zero 304 | | Some x -> x) 305 | ; c_hard = 306 | (match hard with 307 | | None -> zero 308 | | Some x -> x) 309 | ; c_grace = 310 | (match grace with 311 | | None -> Time.epoch 312 | | Some x -> x) 313 | } 314 | ;; 315 | 316 | external quota_query 317 | : [ `User | `Group ] 318 | -> id:int 319 | -> path:string 320 | -> bytes c_limit * bytes usage * inodes c_limit * inodes usage 321 | = "quota_query" 322 | 323 | external quota_modify 324 | : [ `User | `Group ] 325 | -> id:int 326 | -> path:string 327 | -> bytes c_limit 328 | -> inodes c_limit 329 | -> unit 330 | = "quota_modify" 331 | 332 | let query user_or_group ~id ~path = 333 | try 334 | let blimit, busage, ilimit, iusage = quota_query user_or_group ~id ~path in 335 | Ok 336 | ( ml_limit_of_c_limit ~zero:zero_bytes blimit 337 | , busage 338 | , ml_limit_of_c_limit ~zero:zero_inodes ilimit 339 | , iusage ) 340 | with 341 | | Unix.Unix_error _ as exn -> Or_error.of_exn exn 342 | ;; 343 | 344 | let set user_or_group ~id ~path byte_limit inode_limit = 345 | try 346 | Ok 347 | (quota_modify 348 | user_or_group 349 | ~id 350 | ~path 351 | (c_limit_of_ml_limit ~zero:zero_bytes byte_limit) 352 | (c_limit_of_ml_limit ~zero:zero_inodes inode_limit)) 353 | with 354 | | Unix.Unix_error _ as exn -> Or_error.of_exn exn 355 | ;; 356 | end 357 | 358 | module Mount_entry = struct 359 | (* see: man 3 getmntent *) 360 | type t = 361 | { fsname : string 362 | ; directory : string 363 | ; fstype : string 364 | ; options : string 365 | ; dump_freq : int option [@sexp.option] 366 | ; fsck_pass : int option [@sexp.option] 367 | } 368 | [@@deriving sexp, fields ~getters] 369 | 370 | let escape_seqs = [ "040", " "; "011", "\t"; "012", "\n"; "134", "\\"; "\\", "\\" ] 371 | 372 | let unescape s = 373 | let find_and_drop_prefix s (prefix, replacement) = 374 | Option.map (String.chop_prefix ~prefix s) ~f:(fun s -> replacement, s) 375 | in 376 | let rec loop s = 377 | match String.lsplit2 s ~on:'\\' with 378 | | None -> [ s ] 379 | | Some (l, r) -> 380 | (match List.find_map escape_seqs ~f:(find_and_drop_prefix r) with 381 | | None -> l :: "\\" :: loop r 382 | | Some (x, r) -> l :: x :: loop r) 383 | in 384 | String.concat (loop s) 385 | ;; 386 | 387 | let parse_optional_int s = 388 | match Int.of_string s with 389 | | 0 -> None 390 | | n -> Some n 391 | ;; 392 | 393 | let split_and_normalize line = 394 | let inside_comment = ref false in 395 | let whitespace = ' ' in 396 | String.map line ~f:(fun x -> 397 | if Char.equal x '#' then inside_comment := true; 398 | if Char.is_whitespace x || !inside_comment then whitespace else x) 399 | |> String.split ~on:whitespace 400 | |> List.filter ~f:(fun x -> not (String.is_empty x)) 401 | ;; 402 | 403 | let parse_line line = 404 | match split_and_normalize line |> List.map ~f:unescape with 405 | | [] -> Ok None 406 | | fsname 407 | :: directory 408 | :: fstype 409 | :: options 410 | :: (([] | [ _ ] | [ _; _ ]) as dump_freq_and_fsck_pass) -> 411 | let dump_freq, fsck_pass = 412 | match dump_freq_and_fsck_pass with 413 | | [] -> None, None 414 | | [ dump_freq ] -> Some dump_freq, None 415 | | [ dump_freq; fsck_pass ] -> Some dump_freq, Some fsck_pass 416 | | _ -> assert false 417 | in 418 | Or_error.try_with (fun () -> 419 | let dump_freq = Option.bind dump_freq ~f:parse_optional_int in 420 | let fsck_pass = Option.bind fsck_pass ~f:parse_optional_int in 421 | if String.equal fstype "ignore" 422 | then None 423 | else Some { fsname; directory; fstype; options; dump_freq; fsck_pass }) 424 | | _ -> Or_error.error "wrong number of fields" line String.sexp_of_t 425 | ;; 426 | 427 | let visible_filesystem ts = 428 | let add_slash_if_needed s = if String.is_suffix s ~suffix:"/" then s else s ^ "/" in 429 | let overlay map t = 430 | let remove_prefix = add_slash_if_needed (directory t) in 431 | let rec loop map = 432 | match Map.closest_key (map : _ String.Map.t) `Greater_than remove_prefix with 433 | | None -> map 434 | | Some (key, _) -> 435 | if not (String.is_prefix ~prefix:remove_prefix key) 436 | then map 437 | else loop (Map.remove (map : _ String.Map.t) key) 438 | in 439 | Map.set (loop map : _ String.Map.t) ~key:(directory t) ~data:t 440 | in 441 | List.fold 442 | ts 443 | ~init:(Map.empty (module String)) 444 | ~f:(fun map t -> 445 | if not (String.is_prefix ~prefix:"/" (directory t)) then map else overlay map t) 446 | ;; 447 | end 448 | 449 | let tput_property ~default prop = 450 | (* When both stdout and stderr are not terminals, tput outputs 80 (cols) or 451 | 24 (lines) rather than the actual size, so we can't use [Process.run]. 452 | Instead, we use [open_process_in] so that stderr is still the terminal. 453 | But, we don't want tput's error messages to be sent to stderr and seen by 454 | the user, so we first run tput with no output to see if it succeeds, and 455 | only then do we run it with stderr not redirected. *) 456 | try 457 | Exn.protectx 458 | (Core_unix.open_process_in 459 | (Core.sprintf "/usr/bin/tput %s &> /dev/null && /usr/bin/tput %s" prop prop)) 460 | ~f:(fun in_channel -> 461 | In_channel.input_line in_channel |> Option.value_exn |> Int.of_string) 462 | ~finally:In_channel.close 463 | with 464 | | _ -> default 465 | ;; 466 | 467 | let terminal_width = lazy (tput_property ~default:90 "cols") 468 | let terminal_height = lazy (tput_property ~default:24 "lines") 469 | -------------------------------------------------------------------------------- /low_level_process/src/low_level_process.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Poly 3 | module Unix = Core_unix 4 | module Time = Time_float_unix 5 | 6 | module Sys = struct 7 | include Stdlib.Sys 8 | include Basement.Stdlib_shim.Sys.Safe 9 | end 10 | 11 | let rec temp_failure_retry f = 12 | try f () with 13 | | Unix.Unix_error (EINTR, _, _) -> temp_failure_retry f 14 | ;; 15 | 16 | let close_non_intr fd = temp_failure_retry (fun () -> Unix.close fd) 17 | 18 | (* Creates a unix pipe with both sides set close on exec *) 19 | let cloexec_pipe () = 20 | let ((fd1, fd2) as res) = Unix.pipe () in 21 | Unix.set_close_on_exec fd1; 22 | Unix.set_close_on_exec fd2; 23 | res 24 | ;; 25 | 26 | module Process_info = struct 27 | type t = 28 | { pid : Pid.t 29 | ; stdin : Unix.File_descr.t 30 | ; stdout : Unix.File_descr.t 31 | ; stderr : Unix.File_descr.t 32 | } 33 | end 34 | 35 | (* We use a slightly more powerful version of create process than the one in 36 | core. This version is not quite as carefuly code reviewed but allows us to 37 | have more control over the forked side of the process (e.g.: chdir). 38 | *) 39 | let internal_create_process ?working_dir ?setuid ?setgid ~env ~prog ~args () = 40 | let close_on_err = ref [] in 41 | try 42 | let in_read, in_write = cloexec_pipe () in 43 | close_on_err := in_read :: in_write :: !close_on_err; 44 | let out_read, out_write = cloexec_pipe () in 45 | close_on_err := out_read :: out_write :: !close_on_err; 46 | let err_read, err_write = cloexec_pipe () in 47 | close_on_err := err_read :: err_write :: !close_on_err; 48 | let pid = 49 | Unix_extended.fork_exec 50 | prog 51 | args 52 | ?working_dir 53 | ?setuid 54 | ?setgid 55 | ~env 56 | ~stdin:in_read 57 | ~stdout:out_write 58 | ~stderr:err_write 59 | in 60 | close_non_intr in_read; 61 | close_non_intr out_write; 62 | close_non_intr err_write; 63 | { Process_info.pid; stdin = in_write; stdout = out_read; stderr = err_read } 64 | with 65 | | e -> 66 | List.iter 67 | ~f:(fun fd -> 68 | try close_non_intr fd with 69 | | _ -> ()) 70 | !close_on_err; 71 | raise e 72 | ;; 73 | 74 | (** Remembers the last n-characters appended to it.... *) 75 | module Tail_buffer = struct 76 | (** remembers the output in a circular buffer. looped is used to tell whether we loop 77 | around the boundary of the buffer. *) 78 | type t = 79 | { buffer : Bytes.t 80 | ; length : int 81 | ; mutable looped : bool 82 | ; mutable position : int 83 | } 84 | 85 | let contents b = 86 | if not b.looped 87 | then Bytes.To_string.sub b.buffer ~pos:0 ~len:b.position 88 | else ( 89 | let dst = Bytes.create (b.length + 3) in 90 | Bytes.set dst 0 '.'; 91 | Bytes.set dst 1 '.'; 92 | Bytes.set dst 2 '.'; 93 | Bytes.blit 94 | ~src:b.buffer 95 | ~dst 96 | ~dst_pos:3 97 | ~src_pos:b.position 98 | ~len:(b.length - b.position); 99 | Bytes.blit 100 | ~src:b.buffer 101 | ~dst 102 | ~dst_pos:(b.length - b.position + 3) 103 | ~src_pos:0 104 | ~len:b.position; 105 | Bytes.unsafe_to_string ~no_mutation_while_string_reachable:dst) 106 | ;; 107 | 108 | let create len = 109 | { buffer = Bytes.create len; length = len; looped = false; position = 0 } 110 | ;; 111 | 112 | let add b src len = 113 | if b.length <= len 114 | then ( 115 | Bytes.blit ~src ~dst:b.buffer ~dst_pos:0 ~src_pos:(len - b.length) ~len:b.length; 116 | b.looped <- true; 117 | b.position <- 0) 118 | else ( 119 | let leftover = b.length - b.position in 120 | if len < leftover 121 | then ( 122 | Bytes.blit ~src ~dst:b.buffer ~dst_pos:b.position ~src_pos:0 ~len; 123 | b.position <- b.position + len) 124 | else ( 125 | Bytes.blit ~src ~dst:b.buffer ~dst_pos:b.position ~src_pos:0 ~len:leftover; 126 | b.looped <- true; 127 | let len = len - leftover in 128 | Bytes.blit ~src ~dst:b.buffer ~dst_pos:0 ~src_pos:leftover ~len; 129 | b.position <- len)) 130 | ;; 131 | end 132 | 133 | module Status = struct 134 | type t = 135 | [ `Timeout of Time.Span.t 136 | | `Exited of int 137 | | `Signaled of Signal.t (* WStopped is impossible*) 138 | ] 139 | [@@deriving sexp_of] 140 | 141 | let to_string = function 142 | | `Exited i -> sprintf "exited with code %d" i 143 | | `Signaled s -> 144 | sprintf 145 | !"died after receiving %{Signal} (signal number %d)" 146 | s 147 | (Signal_unix.to_system_int s) 148 | | `Timeout s -> sprintf !"Timed out (ran for %{Time.Span})" s 149 | ;; 150 | end 151 | 152 | module Command_result = struct 153 | type t = 154 | { status : Status.t 155 | ; stdout_tail : string 156 | ; stderr_tail : string 157 | } 158 | end 159 | 160 | let waitpid_nohang pid = 161 | match Unix.wait_nohang (`Pid pid) with 162 | | None -> None 163 | | Some (v, res) -> 164 | assert (Pid.(v = pid)); 165 | Some res 166 | ;; 167 | 168 | (** wait for a given pid to exit; returns true when the process exits and false if the 169 | process is still runing after waiting for [span] *) 170 | let wait_for_exit ~is_child span pid = 171 | let end_time = Time.add (Time.now ()) span in 172 | let exited () = 173 | if is_child 174 | then ( 175 | match waitpid_nohang pid with 176 | | None -> true 177 | | Some _ -> false) 178 | else ( 179 | (* This is the equivalent of calling the C kill with 0 (test whether a process 180 | exists) *) 181 | match Signal_unix.send (Signal_unix.of_system_int 0) (`Pid pid) with 182 | | `Ok -> true 183 | | `No_such_process -> false) 184 | in 185 | let rec loop () = 186 | if Time.( > ) (Time.now ()) end_time 187 | then 188 | false 189 | (*We need to explicitely waitpid the child otherwise we are sending 190 | signals to a zombie*) 191 | else if not (exited ()) 192 | then true 193 | else ( 194 | Time.pause (sec 0.1); 195 | loop ()) 196 | in 197 | loop () 198 | ;; 199 | 200 | let kill ?(is_child = false) ?(wait_for = sec 2.0) ?(signal = Signal.term) pid = 201 | Signal_unix.send_exn signal (`Pid pid); 202 | if not (wait_for_exit ~is_child wait_for pid) 203 | then ( 204 | (match Signal_unix.send Signal.kill (`Pid pid) with 205 | | `No_such_process -> 206 | if is_child 207 | then 208 | failwith 209 | "Process.kill got `No_such_process even though the process was a child we \ 210 | never waited for" 211 | | `Ok -> ()); 212 | if not (wait_for_exit ~is_child wait_for pid) 213 | then 214 | failwithf 215 | "Process.kill failed to kill %i%s" 216 | (Pid.to_int pid) 217 | (if is_child then "" else " (or the process wasn't collected by its parent)") 218 | ()) 219 | ;; 220 | 221 | type t = 222 | { mutable open_fds : Unix.File_descr.t list 223 | ; mutable in_fds : Unix.File_descr.t list 224 | ; mutable out_fds : Unix.File_descr.t list 225 | ; keep_open : bool 226 | ; buf : Bytes.t 227 | ; in_cnt : String.t 228 | ; in_len : int 229 | ; out_callbacks : (Unix.File_descr.t * (Bytes.t -> int -> unit)) list 230 | ; pid : Pid.t 231 | ; mutable in_pos : int 232 | } 233 | 234 | let close_pooled state fd = 235 | if List.mem state.open_fds fd ~equal:Unix.File_descr.equal then close_non_intr fd; 236 | state.open_fds <- List.filter ~f:(( <> ) fd) state.open_fds; 237 | state.out_fds <- List.filter ~f:(( <> ) fd) state.out_fds; 238 | state.in_fds <- List.filter ~f:(( <> ) fd) state.in_fds 239 | ;; 240 | 241 | let process_io ~read ~write state = 242 | List.iter write ~f:(fun fd -> 243 | try 244 | let len = 245 | temp_failure_retry (fun () -> 246 | Unix.single_write_substring 247 | fd 248 | ~buf:state.in_cnt 249 | ~pos:state.in_pos 250 | ~len:(state.in_len - state.in_pos)) 251 | in 252 | state.in_pos <- state.in_pos + len; 253 | (* Close the process's in_channel iff we are done writing to it*) 254 | if len = 0 255 | then 256 | if state.keep_open 257 | then state.in_fds <- List.filter ~f:(( <> ) fd) state.in_fds 258 | else close_pooled state fd 259 | with 260 | | Unix.Unix_error (EPIPE, _, _) -> close_pooled state fd); 261 | List.iter read ~f:(fun fd -> 262 | let len = 263 | temp_failure_retry (fun () -> 264 | Unix.read fd ~buf:state.buf ~pos:0 ~len:(Bytes.length state.buf)) 265 | in 266 | if len = 0 267 | then close_pooled state fd 268 | else ( 269 | let callback = 270 | List.Assoc.find_exn ~equal:Unix.File_descr.equal state.out_callbacks fd 271 | in 272 | callback state.buf len)) 273 | ;; 274 | 275 | let available_fds = 276 | let use_select state ~timeout = 277 | let { Unix.Select_fds.read; write; _ } = 278 | temp_failure_retry (fun () -> 279 | Unix.select ~read:state.out_fds ~write:state.in_fds ~except:[] ~timeout ()) 280 | in 281 | read, write 282 | in 283 | let use_epoll epoll_create state ~timeout = 284 | let module Epoll = Linux_ext.Epoll in 285 | let timeout = 286 | match timeout with 287 | | (`Immediately | `Never) as timeout -> timeout 288 | | `After span -> `After span 289 | in 290 | let epoll_t = 291 | let fds = List.map ~f:Unix.File_descr.to_int (state.in_fds @ state.out_fds) in 292 | let max_ready_events = List.length fds in 293 | let num_file_descrs = 1 + List.fold ~init:max_ready_events ~f:Int.max fds in 294 | epoll_create ~num_file_descrs ~max_ready_events 295 | in 296 | List.iter state.in_fds ~f:(fun fd -> Epoll.set epoll_t fd Epoll.Flags.out); 297 | List.iter state.out_fds ~f:(fun fd -> Epoll.set epoll_t fd Epoll.Flags.in_); 298 | let read, write = 299 | match temp_failure_retry (fun () -> Epoll.wait epoll_t ~timeout) with 300 | | `Timeout -> [], [] 301 | | `Ok -> 302 | Epoll.fold_ready epoll_t ~init:([], []) ~f:(fun (read, write) fd flags -> 303 | let take_matching_flags acc fd flags ~wanted = 304 | if Epoll.Flags.do_intersect wanted flags then fd :: acc else acc 305 | in 306 | let read = take_matching_flags read fd flags ~wanted:Epoll.Flags.in_ in 307 | let write = take_matching_flags write fd flags ~wanted:Epoll.Flags.out in 308 | read, write) 309 | in 310 | Epoll.close epoll_t; 311 | read, write 312 | in 313 | match Linux_ext.Epoll.create with 314 | | Error _ -> use_select 315 | | Ok epoll_create -> [%eta (use_epoll epoll_create : _ -> timeout:_ -> _)] 316 | ;; 317 | 318 | let create 319 | ~keep_open 320 | ~use_extra_path 321 | ~working_dir 322 | ~setuid 323 | ~setgid 324 | ~prog 325 | ~args 326 | ~stdoutf 327 | ~stderrf 328 | ~input_string 329 | ~env 330 | = 331 | let full_prog = Shell_internal.path_expand ?use_extra_path prog in 332 | let process_info = 333 | internal_create_process ?working_dir ?setuid ?setgid ~env ~prog:full_prog ~args () 334 | in 335 | let out_fd = process_info.Process_info.stdout 336 | and in_fd = process_info.Process_info.stdin 337 | and err_fd = process_info.Process_info.stderr 338 | and pid = process_info.Process_info.pid in 339 | { keep_open 340 | ; open_fds = [ in_fd; out_fd; err_fd ] 341 | ; in_fds = [ in_fd ] 342 | ; out_fds = [ err_fd; out_fd ] 343 | ; buf = Bytes.create 4096 344 | ; in_cnt = input_string 345 | ; in_pos = 0 346 | ; in_len = String.length input_string 347 | ; out_callbacks = [ out_fd, stdoutf; err_fd, stderrf ] 348 | ; pid 349 | } 350 | ;; 351 | 352 | let rec finish_reading state = 353 | match available_fds state ~timeout:`Immediately with 354 | | [], _ -> () 355 | | read, _ -> 356 | process_io state ~read ~write:[]; 357 | finish_reading state 358 | ;; 359 | 360 | let rec run_loop ~start_time ~timeout state = 361 | let read, write = available_fds state ~timeout:(`After (Time_ns.Span.of_sec 0.1)) in 362 | (try process_io state ~read ~write with 363 | | e -> 364 | kill ~is_child:true state.pid; 365 | raise e); 366 | let elapsed = Time.diff (Time.now ()) start_time in 367 | match timeout with 368 | | Some timeout when Time.Span.(elapsed > timeout) -> 369 | kill ~is_child:true state.pid; 370 | finish_reading state; 371 | `Timeout elapsed 372 | | None | Some _ -> 373 | (match waitpid_nohang state.pid with 374 | | None -> run_loop ~start_time ~timeout state 375 | | Some status -> 376 | finish_reading state; 377 | (match status with 378 | | Ok () -> `Exited 0 379 | | Error (`Exit_non_zero i) -> `Exited i 380 | | Error (`Signal s) -> `Signaled s)) 381 | ;; 382 | 383 | let run 384 | ?timeout 385 | ?use_extra_path 386 | ?working_dir 387 | ?setuid 388 | ?setgid 389 | ?(env = `Extend []) 390 | ?input:(input_string = "") 391 | ?(keep_open = false) 392 | ?(stdoutf = fun _string _len -> ()) 393 | ?(stderrf = fun _string _len -> ()) 394 | ?(tail_len = 2048) 395 | ~prog 396 | ~args 397 | () 398 | = 399 | let stdout_tail = Tail_buffer.create tail_len 400 | and stderr_tail = Tail_buffer.create tail_len in 401 | let stdoutf sbuf len = 402 | stdoutf sbuf len; 403 | Tail_buffer.add stdout_tail sbuf len 404 | and stderrf sbuf len = 405 | stderrf sbuf len; 406 | Tail_buffer.add stderr_tail sbuf len 407 | in 408 | let status = 409 | protectx 410 | ( { portable = Sys.signal Sys.sigpipe Sys.Signal_ignore } 411 | , create 412 | ~keep_open 413 | ~use_extra_path 414 | ~working_dir 415 | ~setuid 416 | ~setgid 417 | ~stderrf 418 | ~stdoutf 419 | ~prog 420 | ~args 421 | ~env 422 | ~input_string ) 423 | ~f:(fun (_old_sigpipe, state) -> run_loop state ~start_time:(Time.now ()) ~timeout) 424 | ~finally:(fun ({ portable = old_sigpipe }, state) -> 425 | List.iter state.open_fds ~f:close_non_intr; 426 | ignore (Sys.signal Sys.sigpipe old_sigpipe : Sys.signal_behavior)) 427 | in 428 | { Command_result.status 429 | ; stdout_tail = Tail_buffer.contents stdout_tail 430 | ; stderr_tail = Tail_buffer.contents stderr_tail 431 | } 432 | ;; 433 | 434 | (* Externally export this *) 435 | let kill ?is_child ?wait_for ?(signal = Signal.term) pid = 436 | kill ?is_child ?wait_for ~signal pid 437 | ;; 438 | 439 | module%test _ = struct 440 | let with_fds n ~f = 441 | let restore_max_fds = 442 | let module RLimit = Core_unix.RLimit in 443 | let max_fds = RLimit.get RLimit.num_file_descriptors in 444 | match max_fds.RLimit.cur with 445 | | RLimit.Infinity -> None 446 | | RLimit.Limit limit when Int64.(of_int Int.(2 * n) < limit) -> None 447 | | RLimit.Limit _ -> 448 | RLimit.set 449 | RLimit.num_file_descriptors 450 | { max_fds with RLimit.cur = RLimit.Limit (Int64.of_int (2 * n)) }; 451 | Some max_fds 452 | in 453 | let fds = 454 | List.init n ~f:(fun _ -> Unix.openfile ~mode:[ Unix.O_RDONLY ] "/dev/null") 455 | in 456 | let retval = Or_error.try_with f in 457 | List.iter fds ~f:(fun fd -> Unix.close fd); 458 | Option.iter restore_max_fds ~f:(fun max_fds -> 459 | let module RLimit = Core_unix.RLimit in 460 | RLimit.set RLimit.num_file_descriptors max_fds); 461 | Or_error.ok_exn retval 462 | ;; 463 | 464 | let run_process () = ignore (run ~prog:"true" ~args:[] ()) 465 | let%test_unit _ = with_fds 10 ~f:run_process 466 | 467 | let%test_unit _ = 468 | with_fds 1055 ~f:(fun () -> 469 | [%test_eq: bool] 470 | (Result.is_ok Linux_ext.Epoll.create) 471 | (Result.is_ok (Result.try_with run_process))) 472 | ;; 473 | end 474 | -------------------------------------------------------------------------------- /src/shell.ml: -------------------------------------------------------------------------------- 1 | (* TODO: Ron wants the ability to run interactive commands and to expose the fd 2 | version of process handling.*) 3 | open Core 4 | open Poly 5 | module Unix = Core_unix 6 | module Line_buffer = Shell__line_buffer 7 | 8 | let extra_path = Shell_internal.extra_path 9 | 10 | module Process = struct 11 | exception Early_exit [@@deriving sexp] 12 | 13 | type status = 14 | [ `Timeout of Time_float.Span.t 15 | | Low_level_process.Status.t 16 | ] 17 | [@@deriving sexp_of] 18 | (* type status = (unit, error) Result.t with sexp_of *) 19 | 20 | type t = 21 | { program : string 22 | ; arguments : string list 23 | } 24 | [@@deriving sexp_of] 25 | 26 | type result = 27 | { command : t 28 | ; status : status 29 | ; stdout : string 30 | ; stderr : string 31 | } 32 | [@@deriving sexp_of] [@@unsafe_allow_any_mode_crossing] 33 | 34 | exception Failed of result [@@deriving sexp] 35 | 36 | let to_string { program = prog; arguments = args } = 37 | let f s = 38 | if (not (String.contains s ' ')) && not (String.contains s '"') 39 | then s 40 | else sprintf "%S" s 41 | in 42 | String.concat ~sep:" " (List.map ~f (prog :: args)) 43 | ;; 44 | 45 | let status_to_string = function 46 | | `Timeout t -> sprintf !"Timed out (ran for %{Time_float.Span})" t 47 | | #Low_level_process.Status.t as s -> Low_level_process.Status.to_string s 48 | ;; 49 | 50 | let format_failed c = 51 | String.concat 52 | ~sep:" " 53 | [ "Command failed:" 54 | ; to_string c.command 55 | ; "Exit status:" 56 | ; status_to_string c.status 57 | ; "stderr:" 58 | ; c.stderr 59 | ] 60 | ;; 61 | 62 | let () = 63 | (Stdlib.Printexc.register_printer [@ocaml.alert "-unsafe_multidomain"]) (function 64 | | Failed r -> Some (format_failed r) 65 | | _ -> None) 66 | ;; 67 | 68 | module Defaults = struct 69 | type t = 70 | { timeout : Time_float.Span.t option 71 | ; verbose : bool 72 | ; echo : bool 73 | ; preserve_euid : bool 74 | ; strict_errors : bool 75 | } 76 | [@@deriving fields ~fields] 77 | end 78 | 79 | let defaults = 80 | Atomic.make 81 | ({ timeout = None 82 | ; verbose = false 83 | ; echo = false 84 | ; preserve_euid = false 85 | ; strict_errors = false 86 | } 87 | : Defaults.t) 88 | ;; 89 | 90 | let set_defaults ?timeout ?verbose ?echo ?preserve_euid ?strict_errors () = 91 | let set_one field opt defaults = 92 | match opt with 93 | | None -> defaults 94 | | Some value -> Fieldslib.Field.fset field defaults value 95 | in 96 | Atomic.update defaults ~pure_f:(fun (defaults : Defaults.t) -> 97 | defaults 98 | |> set_one Defaults.Fields.timeout timeout 99 | |> set_one Defaults.Fields.verbose verbose 100 | |> set_one Defaults.Fields.echo echo 101 | |> set_one Defaults.Fields.preserve_euid preserve_euid 102 | |> set_one Defaults.Fields.strict_errors strict_errors) 103 | ;; 104 | 105 | let cmd program arguments = { program; arguments } 106 | 107 | let shell ?strict_errors s = 108 | let defaults = Atomic.get defaults in 109 | let addtl_args = 110 | let preserve_euid_args = if defaults.preserve_euid then [ "-p" ] else [] in 111 | let strict_errors_args = 112 | if Option.value strict_errors ~default:defaults.strict_errors 113 | then [ "-e"; "-u"; "-o"; "pipefail" ] 114 | else [] 115 | in 116 | preserve_euid_args @ strict_errors_args 117 | in 118 | { program = "bash"; arguments = addtl_args @ [ "-c"; s ] } 119 | ;; 120 | 121 | (* avoid asking for the password at all costs. *) 122 | let noninteractive_ssh_options = [ "-o"; "BatchMode yes" ] 123 | 124 | let noninteractive_no_hostkey_checking_options = 125 | [ "-n" 126 | ; "-q" 127 | ; "-x" 128 | ; "-o" 129 | ; "ConnectTimeout=10" 130 | ; "-o" 131 | ; "CheckHostIP=no" 132 | ; "-o" 133 | ; "StrictHostKeyChecking=no" 134 | ; "-o" 135 | ; "BatchMode=yes" 136 | ] 137 | ;; 138 | 139 | (* Passes the remote command to ssh *) 140 | 141 | let make_ssh_command 142 | ?(ssh_options = noninteractive_ssh_options) 143 | ?(quote_args = true) 144 | ?user 145 | ~host 146 | args 147 | = 148 | (* quote_args quotes all arguments to the shell. We need to escape all the 149 | arguments because ssh is passing this to the remote shell which will 150 | unescape all of that before passing it over to our program.*) 151 | let url = 152 | match user with 153 | | None -> host 154 | | Some user -> user ^ "@" ^ host 155 | in 156 | let args = if quote_args then List.map ~f:Filename.quote args else args in 157 | { program = "ssh"; arguments = ssh_options @ [ url; "--" ] @ args } 158 | ;; 159 | 160 | let remote ?ssh_options ?quote_args ?user ~host cmd = 161 | make_ssh_command ?ssh_options ?quote_args ?user ~host (cmd.program :: cmd.arguments) 162 | ;; 163 | 164 | type 'res acc = 165 | { add_stdout : Bytes.t -> int -> [ `Stop | `Continue ] 166 | ; add_stderr : Bytes.t -> int -> [ `Stop | `Continue ] 167 | ; flush : unit -> 'res 168 | } 169 | 170 | type 'res reader = unit -> 'res acc 171 | 172 | let run_k' 173 | k 174 | ?use_extra_path 175 | ?timeout 176 | ?working_dir 177 | ?setuid 178 | ?setgid 179 | ?env 180 | ?verbose 181 | ?echo 182 | ?input 183 | ?keep_open 184 | ?tail_len 185 | = 186 | let timeout, verbose, echo = 187 | match timeout, verbose, echo with 188 | | Some timeout, Some verbose, Some echo -> timeout, verbose, echo 189 | | _ -> 190 | let defaults = Atomic.get defaults in 191 | let timeout = Option.value timeout ~default:defaults.timeout in 192 | let verbose = Option.value verbose ~default:defaults.verbose in 193 | let echo = Option.value echo ~default:defaults.echo in 194 | timeout, verbose, echo 195 | in 196 | k (fun cmd stdoutf stderrf -> 197 | if echo then Console.Ansi.printf [ `Underscore ] !"Shell: %{}\n%!" cmd; 198 | let stderrf = 199 | if verbose 200 | then fun s len -> Console.Ansi.output [ `Red ] stderr s 0 len 201 | else stderrf 202 | and stdoutf = 203 | if verbose 204 | then (fun s len -> 205 | Console.Ansi.output [ `Green ] stdout s 0 len; 206 | stdoutf s len) 207 | else stdoutf 208 | in 209 | Low_level_process.run 210 | ?timeout 211 | ?input 212 | ?keep_open 213 | ?working_dir 214 | ?setuid 215 | ?setgid 216 | ?use_extra_path 217 | ?env 218 | ?tail_len 219 | ~stdoutf 220 | ~stderrf 221 | ~prog:cmd.program 222 | ~args:cmd.arguments 223 | ()) 224 | ;; 225 | 226 | let%template run_k k ?(expect = [ 0 ]) = 227 | run_k' (fun f -> 228 | k (fun cmd reader -> 229 | let acc = reader () in 230 | let stdoutf s len = 231 | match acc.add_stdout s len with 232 | | `Continue -> () 233 | | `Stop -> raise Early_exit 234 | in 235 | let stderrf s len = 236 | match acc.add_stderr s len with 237 | | `Continue -> () 238 | | `Stop -> raise Early_exit 239 | in 240 | try 241 | let r = f cmd stdoutf stderrf in 242 | let module Res = Low_level_process.Command_result in 243 | match r.Res.status with 244 | | `Exited i when List.mem expect i ~equal:Int.equal -> acc.flush () 245 | | status -> 246 | raise 247 | (Failed 248 | { command = cmd 249 | ; status :> status 250 | ; stderr = r.Res.stderr_tail 251 | ; stdout = r.Res.stdout_tail 252 | }) 253 | with 254 | | Early_exit -> acc.flush ())) 255 | [@@mode p = (nonportable, portable)] 256 | ;; 257 | 258 | let run ?expect = run_k (fun f cmd reader -> f cmd reader) ?expect 259 | 260 | let test_k k ?(true_v = [ 0 ]) ?(false_v = [ 1 ]) = 261 | run_k' (fun f -> 262 | k (fun cmd -> 263 | let r = f cmd (fun _ _ -> ()) (fun _ _ -> ()) in 264 | let module Res = Low_level_process.Command_result in 265 | match r.Res.status with 266 | | `Exited i when List.mem true_v i ~equal:Int.equal -> true 267 | | `Exited i when List.mem false_v i ~equal:Int.equal -> false 268 | | #status as status -> 269 | raise 270 | (Failed 271 | { command = cmd 272 | ; status :> status 273 | ; stderr = r.Res.stderr_tail 274 | ; stdout = r.Res.stdout_tail 275 | }))) 276 | ;; 277 | 278 | let test ?true_v = test_k (fun f cmd -> f cmd) ?true_v 279 | 280 | let discard () = 281 | { add_stdout = (fun _ _ -> `Continue) 282 | ; add_stderr = (fun _ _ -> `Continue) 283 | ; flush = (fun () -> ()) 284 | } 285 | ;; 286 | 287 | let callback ~add ~flush () = 288 | { add_stdout = 289 | (fun s len -> 290 | add s len; 291 | `Continue) 292 | ; add_stderr = (fun _ _ -> `Continue) 293 | ; flush 294 | } 295 | ;; 296 | 297 | let callback_with_stderr ~add ~add_err ~flush () = 298 | { add_stdout = 299 | (fun s len -> 300 | add s len; 301 | `Continue) 302 | ; add_stderr = 303 | (fun s len -> 304 | add_err s len; 305 | `Continue) 306 | ; flush 307 | } 308 | ;; 309 | 310 | let content () = 311 | let buffer = Buffer.create 16 in 312 | { add_stdout = 313 | (fun s len -> 314 | Buffer.add_subbytes buffer s ~pos:0 ~len; 315 | `Continue) 316 | ; add_stderr = (fun _ _ -> `Continue) 317 | ; flush = (fun () -> Buffer.contents buffer) 318 | } 319 | ;; 320 | 321 | let content_and_stderr () = 322 | let stdout_buffer = Buffer.create 16 in 323 | let buffer_stderr = Buffer.create 16 in 324 | { add_stdout = 325 | (fun s len -> 326 | Buffer.add_subbytes stdout_buffer s ~pos:0 ~len; 327 | `Continue) 328 | ; add_stderr = 329 | (fun s len -> 330 | Buffer.add_subbytes buffer_stderr s ~pos:0 ~len; 331 | `Continue) 332 | ; flush = (fun () -> Buffer.contents stdout_buffer, Buffer.contents buffer_stderr) 333 | } 334 | ;; 335 | 336 | let fold_lines 337 | (type ret v) 338 | ?eol 339 | ~(init : v) 340 | ~(f : v -> string -> v * [ `Continue | `Stop ]) 341 | ~(flush : v -> ret) 342 | () 343 | : ret acc 344 | = 345 | let acc = ref init 346 | and continue = ref `Continue in 347 | let lb = 348 | Line_buffer.create ?eol (fun line -> 349 | match !continue with 350 | | `Stop -> () 351 | | `Continue -> 352 | let acc_v, continue_v = f !acc line in 353 | acc := acc_v; 354 | continue := continue_v) 355 | in 356 | { add_stdout = 357 | (fun s len -> 358 | Line_buffer.add_subbytes lb s ~pos:0 ~len; 359 | !continue) 360 | ; add_stderr = (fun _ _ -> `Continue) 361 | ; flush = 362 | (fun () -> 363 | Line_buffer.flush lb; 364 | flush !acc) 365 | } 366 | ;; 367 | 368 | let lines ?eol () = 369 | fold_lines ?eol ~flush:List.rev ~init:[] ~f:(fun acc line -> line :: acc, `Continue) 370 | ;; 371 | 372 | let aux_head ~flush ?eol () = 373 | fold_lines ?eol ~flush ~init:None ~f:(fun _acc line -> Some line, `Stop) 374 | ;; 375 | 376 | let head ?eol () = aux_head ~flush:(fun x -> x) ?eol () 377 | 378 | exception Empty_head 379 | 380 | let head_exn ?eol () = 381 | aux_head 382 | ~flush:(function 383 | | Some x -> x 384 | | None -> raise Empty_head) 385 | ?eol 386 | () 387 | ;; 388 | 389 | let aux_one_line ~flush ?eol () = 390 | fold_lines 391 | ?eol 392 | ~flush:(function 393 | | Some result -> flush result 394 | | None -> 395 | flush (Or_error.error_s [%message "expected one line, got empty output"])) 396 | ~init:None 397 | ~f:(fun acc line -> 398 | match acc with 399 | | Some (Ok first_line) -> 400 | let second_line = line in 401 | ( Some 402 | (Or_error.error_s 403 | [%message 404 | "One line expected, got at least two lines of output" 405 | ~first_line 406 | ~second_line]) 407 | , `Stop ) 408 | | Some (Error _e) -> 409 | (* didn't we say `Stop?! *) 410 | assert false 411 | | None -> Some (Ok line), `Continue) 412 | ;; 413 | 414 | let one_line_exn ?eol () = aux_one_line ~flush:Or_error.ok_exn ?eol () 415 | let one_line ?eol () = aux_one_line ~flush:Fn.id ?eol () 416 | end 417 | 418 | let%test_unit _ = 419 | [%test_result: string] 420 | ~expect:"hello" 421 | (Process.run (Process.cmd "echo" [ "hello\nworld" ]) (Process.head_exn ())) 422 | ;; 423 | 424 | type 'a with_process_flags = 425 | ?use_extra_path:bool 426 | -> ?timeout:Time_float.Span.t option 427 | -> ?working_dir:string (* rename to run_in? *) 428 | -> ?setuid:int 429 | -> ?setgid:int 430 | -> ?env:[ `Extend of (string * string) list | `Replace of (string * string) list ] 431 | -> ?verbose:bool 432 | -> ?echo:bool 433 | -> ?input:string 434 | -> ?keep_open:bool 435 | -> ?tail_len:int 436 | -> 'a 437 | 438 | type 'a with_run_flags = ?expect:(* Defaults to [0]*) 439 | int list -> 'a with_process_flags 440 | 441 | type 'a with_test_flags = ?true_v:int list -> ?false_v:int list -> 'a with_process_flags 442 | type 'a cmd = string -> string list -> 'a 443 | type ('a, 'ret) sh_cmd = ('a, unit, string, 'ret) format4 -> 'a 444 | 445 | let%template run_gen reader = 446 | (Process.run_k [@mode p]) (fun f prog args -> f (Process.cmd prog args) reader) 447 | [@@mode p = (nonportable, portable)] 448 | ;; 449 | 450 | let%template run = (run_gen [@mode portable]) Process.discard 451 | let run_lines ?eol = run_gen (Process.lines ?eol ()) 452 | let run_one ?eol = run_gen (Process.head ?eol ()) 453 | let run_one_exn ?eol = run_gen (Process.head_exn ?eol ()) 454 | let run_first_line ?eol = run_gen (Process.head ?eol ()) 455 | let run_first_line_exn ?eol = run_gen (Process.head_exn ?eol ()) 456 | let run_one_line ?eol = run_gen (Process.one_line ?eol ()) 457 | let run_one_line_exn ?eol = run_gen (Process.one_line_exn ?eol ()) 458 | let run_full = run_gen Process.content 459 | let run_fold ?eol ~init ~f = run_gen (Process.fold_lines ?eol ~init ~f ~flush:Fn.id) 460 | 461 | (* 462 | TEST_UNIT = 463 | (* This should not hand because the stdin is closed... *) 464 | run ~timeout:(Some (sec 0.5)) "cat" [] 465 | TEST_UNIT = 466 | try 467 | run ~timeout:(Some (sec 0.5)) "cat" [] 468 | with Process. 469 | *) 470 | 471 | let test = Process.test_k (fun f prog args -> f (Process.cmd prog args)) 472 | 473 | let k_shell_command k f ?strict_errors fmt = 474 | ksprintf (fun command -> k f (Process.shell ?strict_errors command)) fmt 475 | ;; 476 | 477 | let sh_gen reader ?strict_errors = 478 | Process.run_k (k_shell_command ?strict_errors (fun f cmd -> f cmd reader)) 479 | ;; 480 | 481 | type 'a with_sh_flags = ?strict_errors:(* Defaults to [false]*) 482 | bool -> 'a 483 | 484 | let sh ?strict_errors = sh_gen Process.discard ?strict_errors 485 | let sh_lines ?strict_errors = sh_gen (Process.lines ()) ?strict_errors 486 | let sh_full ?strict_errors = sh_gen Process.content ?strict_errors 487 | let sh_one ?strict_errors = sh_gen (Process.head ()) ?strict_errors 488 | let sh_one_exn ?strict_errors = sh_gen (Process.head_exn ()) ?strict_errors 489 | let sh_first_line ?strict_errors = sh_gen (Process.head ()) ?strict_errors 490 | let sh_first_line_exn ?strict_errors = sh_gen (Process.head_exn ()) ?strict_errors 491 | let sh_one_line ?strict_errors = sh_gen (Process.one_line ()) ?strict_errors 492 | let sh_one_line_exn ?strict_errors = sh_gen (Process.one_line_exn ()) ?strict_errors 493 | 494 | let%test _ = 495 | sh_lines "yes yes | head -n 200000" = List.init 200_000 ~f:(fun _num -> "yes") 496 | ;; 497 | 498 | let%test _ = 499 | try 500 | sh ~strict_errors:true "false | true"; 501 | true 502 | with 503 | | Process.Failed _ -> true 504 | ;; 505 | 506 | let sh_test ?strict_errors = 507 | Process.test_k (k_shell_command ?strict_errors (fun f cmd -> f cmd)) 508 | ;; 509 | 510 | type 'a with_ssh_flags = ?ssh_options:string list -> ?user:string -> host:string -> 'a 511 | 512 | let noninteractive_ssh_options = Process.noninteractive_ssh_options 513 | 514 | let noninteractive_no_hostkey_checking_options = 515 | Process.noninteractive_no_hostkey_checking_options 516 | ;; 517 | 518 | let k_remote_command k f ?ssh_options ?user ~host fmt = 519 | ksprintf 520 | (fun command -> 521 | k 522 | f 523 | (Process.make_ssh_command ~quote_args:false ?ssh_options ?user ~host [ command ])) 524 | fmt 525 | ;; 526 | 527 | let ssh_gen reader ?ssh_options ?user ~host = 528 | Process.run_k (k_remote_command (fun f cmd -> f cmd reader) ?ssh_options ?user ~host) 529 | ;; 530 | 531 | let ssh ?ssh_options = ssh_gen Process.discard ?ssh_options 532 | let ssh_lines ?ssh_options = ssh_gen (Process.lines ()) ?ssh_options 533 | let ssh_full ?ssh_options = ssh_gen Process.content ?ssh_options 534 | let ssh_one ?ssh_options = ssh_gen (Process.head ()) ?ssh_options 535 | let ssh_one_exn ?ssh_options = ssh_gen (Process.head_exn ()) ?ssh_options 536 | let ssh_first_line ?ssh_options = ssh_gen (Process.head ()) ?ssh_options 537 | let ssh_first_line_exn ?ssh_options = ssh_gen (Process.head_exn ()) ?ssh_options 538 | let ssh_one_line ?ssh_options = ssh_gen (Process.one_line ()) ?ssh_options 539 | let ssh_one_line_exn ?ssh_options = ssh_gen (Process.one_line_exn ()) ?ssh_options 540 | 541 | let ssh_test ?ssh_options ?user ~host = 542 | Process.test_k (k_remote_command (fun f cmd -> f cmd) ?ssh_options ?user ~host) 543 | ;; 544 | 545 | let whoami = Shell_internal.whoami 546 | let which = Shell_internal.which 547 | 548 | let ln ?s ?f src dst = 549 | let s = Option.map s ~f:(fun () -> "-s") in 550 | let f = Option.map f ~f:(fun () -> "-f") in 551 | run "ln" (List.filter_map ~f:Fn.id [ s; f ] @ [ "-n"; "--"; src; dst ]) 552 | ;; 553 | 554 | let rm ?r ?f path = 555 | let r = Option.map r ~f:(fun () -> "-r") in 556 | let f = Option.map f ~f:(fun () -> "-f") in 557 | run "rm" (List.filter_map ~f:Fn.id [ r; f; Some "--"; Some path ]) 558 | ;; 559 | 560 | let mv src dst = run "mv" [ "--"; src; dst ] 561 | 562 | let mkdir ?p ?perm path = 563 | let p = Option.map p ~f:(fun () -> "-p") in 564 | let mode = Option.map perm ~f:(sprintf "--mode=%o") in 565 | run "mkdir" (List.filter_map ~f:Fn.id [ p; mode; Some "--"; Some path ]) 566 | ;; 567 | 568 | (* TODO: Deal with atomicity *) 569 | let cp ?(overwrite = true) ?perm src dst = 570 | let perm = 571 | match perm with 572 | | Some p -> p 573 | | None -> (Unix.lstat src).Unix.st_perm 574 | in 575 | let dst = 576 | if Sys_unix.is_directory dst = `Yes then dst ^/ Filename.basename src else dst 577 | in 578 | let out_mode = 579 | if overwrite 580 | then [ Unix.O_WRONLY; Unix.O_NOCTTY; Unix.O_CREAT; Unix.O_TRUNC ] 581 | else [ Unix.O_WRONLY; Unix.O_NOCTTY; Unix.O_CREAT; Unix.O_EXCL ] 582 | in 583 | protectx 584 | (Unix.openfile src ~mode:[ Unix.O_RDONLY; Unix.O_NOCTTY ] ~perm:0) 585 | ~f:(fun infh -> 586 | protectx 587 | (Unix.openfile dst ~mode:out_mode ~perm) 588 | ~f:(fun outfh -> 589 | let buflen = 4096 in 590 | let buf = Bytes.create buflen in 591 | let rec loop () = 592 | let rlen = Unix.read infh ~buf ~pos:0 ~len:buflen in 593 | if rlen <> 0 594 | then ( 595 | let wlen = Unix.write outfh ~buf ~pos:0 ~len:rlen in 596 | if rlen <> wlen 597 | then 598 | failwithf 599 | "Short write: tried to write %d bytes, only wrote %d bytes" 600 | rlen 601 | wlen 602 | (); 603 | loop ()) 604 | in 605 | loop ()) 606 | ~finally:Unix.close) 607 | ~finally:Unix.close 608 | ;; 609 | 610 | let scp ?(compress = false) ?(recurse = false) ?user ~host f t = 611 | let user_arg = Option.value_map user ~default:"" ~f:(fun user -> user ^ "@") in 612 | let args = [ f; user_arg ^ host ^ ":" ^ t ] in 613 | let args = if recurse then "-r" :: args else args in 614 | let args = if compress then "-C" :: args else args in 615 | run "scp" args 616 | ;; 617 | --------------------------------------------------------------------------------