├── .config.in ├── .configure_or_autoconf ├── .gitattributes ├── CHANGES.adoc ├── CHANGES_devel.adoc ├── INSTALL.md ├── META.in ├── Makefile ├── README.adoc ├── _tags ├── configure.ac ├── create_cgroup.sh ├── doc ├── biblio.md ├── design.md ├── first_step.md └── mockup.md ├── licences ├── CEA_LGPL ├── LGPLv2.1 ├── WHY3_LGPL └── headache_config.txt ├── myocamlbuild.ml ├── opam └── opam ├── src ├── .config.in ├── Oci_Artefact.ml ├── Oci_Artefact.mli ├── Oci_Artefact_Api.ml ├── Oci_Client.ml ├── Oci_Client.mli ├── Oci_Cmd_Runner.ml ├── Oci_Cmd_Runner_Api.ml ├── Oci_Common.ml ├── Oci_Common.mli ├── Oci_Copyhard.ml ├── Oci_Data.ml ├── Oci_Data.mli ├── Oci_Default_Master.ml ├── Oci_Default_Masters.mllib ├── Oci_Filename.ml ├── Oci_Generic_Masters.ml ├── Oci_Generic_Masters.mllib ├── Oci_Generic_Masters_Api.ml ├── Oci_Generic_Masters_Runner.ml ├── Oci_Git.ml ├── Oci_Git.mli ├── Oci_Log.ml ├── Oci_Log.mli ├── Oci_Master.ml ├── Oci_Master.mli ├── Oci_Master_Tools.ml ├── Oci_Monitor.ml ├── Oci_Queue.ml ├── Oci_Queue.mli ├── Oci_Rootfs.ml ├── Oci_Rootfs.mli ├── Oci_Rootfs_Api.ml ├── Oci_Rootfs_Api.mli ├── Oci_Runner.ml ├── Oci_Runner.mli ├── Oci_Simple_Exec.ml ├── Oci_Simple_Exec_Api.ml ├── Oci_Std.ml ├── Oci_Wget.ml ├── Oci_Wget.mli ├── Oci_Wrapper.ml ├── Oci_Wrapper_Api.ml ├── Oci_Wrapper_Lib.ml ├── Oci_pp.ml ├── Oci_pp.mli ├── liboci_stubs.clib ├── monitor_rpc.mli └── oci_stubs.c └── tests ├── images ├── tests_oci_sort1_1.png ├── tests_oci_sort2_1.png └── tests_oci_sort3_1.png ├── library ├── oci_default_client.ml └── oci_default_master.ml ├── tests_api.ml ├── tests_client.ml ├── tests_master.ml ├── tests_oci_sort0.bench ├── tests_oci_sort0.commits ├── tests_oci_sort1.bench ├── tests_oci_sort1.commits ├── tests_oci_sort2.bench ├── tests_oci_sort2.commits ├── tests_oci_sort3.commits ├── tests_runner.ml └── tests_time.ml /.config.in: -------------------------------------------------------------------------------- 1 | DESTDIR ?= 2 | prefix ?=@prefix@ 3 | exec_prefix ?=@exec_prefix@ 4 | datarootdir ?=@datarootdir@ 5 | datadir ?=@datadir@ 6 | BINDIR ?="$(DESTDIR)@bindir@" 7 | LIBDIR ?="$(DESTDIR)@libdir@" 8 | DATADIR ?="$(DESTDIR)@datarootdir@" 9 | VARDIR ?="$(DESTDIR)@localstatedir@" 10 | MANDIR ?="$(DESTDIR)@mandir@" 11 | 12 | LIB_INSTALL_DIR ?=@ocamlfind_install_dir@ 13 | OCIUSER=@ociuser@ 14 | VERSION=@PACKAGE_VERSION@ -------------------------------------------------------------------------------- /.configure_or_autoconf: -------------------------------------------------------------------------------- 1 | #!/bin/sh -eu 2 | 3 | if test \! -e ./configure; then 4 | autoconf 5 | fi 6 | 7 | exec ./configure "$@" 8 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | /src/**/*.c header-cea 2 | /src/**/*.ml header-cea 3 | /src/**/*.mli header-cea 4 | /tests/**/*.ml header-cea 5 | /tests/**/*.mli header-cea 6 | /src/Oci_pp.ml -header-cea header-why3 7 | /src/Oci_pp.mli -header-cea header-why3 8 | 9 | /.in_git_repository export-ignore 10 | /.gitignore export-ignore 11 | /.gitattribute export-ignore 12 | /.gitlab-ci.yml export-ignore 13 | /.package export-ignore 14 | 15 | /CHANGES_devel.adoc merge=union -------------------------------------------------------------------------------- /CHANGES.adoc: -------------------------------------------------------------------------------- 1 | 2 | :toc: 3 | 4 | The changes in the developpment version are in link:CHANGES_devel.adoc (for 5 | simpler changes tracking) 6 | 7 | 8 | === 0.4 release 9 | 10 | * [Client] Simplify the API of parameteres 11 | * [Monitor] Fix when cgroups are not used 12 | * [Monitor] When forwarding the standard output and error of runners, the 13 | monitor now prefixed it with the runner id 14 | * [Doc] Spelling and typos in README.adoc (Gabriel Scherer, Andre Maroneze) 15 | * [Master] Fix file-descriptor leaks in saved log reading 16 | 17 | 18 | === Initial 0.3 release -------------------------------------------------------------------------------- /CHANGES_devel.adoc: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /INSTALL.md: -------------------------------------------------------------------------------- 1 | ## Installation instructions ## 2 | 3 | ### System Requirements ### 4 | 5 | - shadow (aka uidmap on Debian) 6 | - cgmanager (optional) 7 | - xpra (optional, useful to get access to a shell in the container when tests 8 | go wrong) 9 | - linux (>= 3.18) 10 | - git (>= 2.1) 11 | 12 | ### Installation with opam 13 | 14 | There will be an opam package for oci. Thus, you will be able to install 15 | it directly through opam with the following command: 16 | 17 | ``` 18 | opam install oci 19 | ``` 20 | 21 | or for the developpement version 22 | 23 | ``` 24 | opam pin add oci --kind=git "https://github.com/bobot/oci.git#master" 25 | ``` 26 | 27 | ### Installation without opam ### 28 | #### Package requirements #### 29 | The following opam packages are required to compile the various components of 30 | OCI: 31 | 32 | - async_shell 33 | - core 34 | - core_extended 35 | - extunix 36 | - fileutils 37 | - textutils 38 | - ocamlbuild 39 | - ppx_here 40 | - ppx_fields_conv 41 | - ppx_compare 42 | - ppx_sexp_conv 43 | - ppx_bin_prot 44 | 45 | Of course, opam will take care of installing their dependencies as well. 46 | Please ensure that you truly have the latest version available of OCaml 47 | and each package. OCI loves to use bleeding edge stuff. Note that these 48 | packages might not be installed at their latest version after an 49 | `opam install pkg`: they have complex interdependencies and the whole 50 | JaneStreet libraries are sometimes 51 | re-split in a new set of packages in a manner that can confuse 52 | opam. **Ensure that `opam upgrade` does not tell you that some packages have 53 | not been upgraded because of dependencies before continuing.** This can be 54 | done by explicitly asking `opam upgrade pkg` to tell that you truly want the 55 | latest version of `pkg`. Repeat that for all packages until 56 | `opam upgrade` stays silent. 57 | 58 | #### Compilation step 59 | 60 | You can customize some part of the compilation process by running 61 | `./configure` in the top directory of oci. Libraries will 62 | be handled by `ocamlfind`. 63 | 64 | - `./configure` 65 | - `make` 66 | - `make install` 67 | 68 | ### Tests 69 | - You don't need to install oci for the simple tests 70 | - Be sure that your kernel can provide unprivileged usernamespaces: 71 | `sysctl kernel.unprivileged_userns_clone=1` as root if 72 | needed 73 | - In the repository create the directory for the permanent database and the containers 74 | temporary directories 75 | ``` 76 | mkdir test-oci-data 77 | ``` 78 | - In the repository: 79 | ``` 80 | bin/Oci_Monitor.native --binaries bin --binaries bin-test --master bin-test/tests_master.native --oci-data test-oci-data 81 | ``` 82 | 83 | ### Usage 84 | 85 | - All commands and sub-commands mentioned below have a `--help` option. 86 | In what follows, only the most important options are provided. See 87 | the corresponding `--help` for more information. 88 | - Be sure that your kernel can provide unprivileged usernamespaces: 89 | `echo 1 > /proc/sys/kernel/unprivileged_userns_clone` as root if needed 90 | - Optional: configure cgroups, needed for cpu partitionning. In the current shell: 91 | 92 | ``` 93 | sudo cgm create all oci 94 | sudo cgm chown all oci $(id -u) $(id -g) 95 | cgm movepid all oci $$ 96 | ``` 97 | 98 | - launch a new monitor 99 | 100 | ```shell 101 | oci_monitor \ 102 | --oci-data=/path/to/data \ 103 | --binaries=INSTALLED_LIB/bin \ 104 | --master=INSTALLED_LIB/bin/oci_default_master \ 105 | ``` 106 | 107 | - Get a list of available rootfs from lxc, and download an appropriate one 108 | (defaults to debian jessie amd64) 109 | - `bf_client list-download-rootfs` 110 | - `bf_client download-rootfs --socket OCI_DATA/oci.socket [rootfs-opts]` 111 | where `rootfs-opts` can be chosen among `--arch`, `--distribution` and 112 | `--release` if you're not satisfied with default ones. This should get you 113 | the ID of the created rootfs (typically `0`) 114 | - Add necessary packages (for usual ocaml package with gui) to the initial rootfs: 115 | ```shell 116 | bf_client add-package --rootfs ID --socket OCI_DATA/oci.socket \ 117 | autotools-dev binutils-dev libiberty-dev libncurses5-dev pkg-config \ 118 | zlib1g-dev git gcc build-essential m4 autoconf time libgmp-dev xpra tmux \ 119 | strace xterm libexpat1-dev libgmp-dev libgnomecanvas2-dev libgtk2.0-dev \ 120 | libgtksourceview2.0-dev m4 ncurses-dev xsltproc libxml2-utils 121 | ``` 122 | This will give you a new rootfs of id `NID` (typically `1`). 123 | - Optional: check that the rootfs is known to the monitor: 124 | `bf_client list-rootfs --socket OCI_DATA/oci.socket NID` where 125 | `NID` is the ID you have retrieved at previous step. Note that if you do not 126 | provide an ID, nothing will be output. 127 | - launch a specific test, e.g. the ones for frama-c: 128 | 129 | ```shell 130 | bf_client \ 131 | run \ 132 | --rootfs NID \ 133 | --socket OCI_DATA/oci.socket \ 134 | frama-c 135 | ``` 136 | 137 | - If things go wrong, you can use the following commands to get an xterm on 138 | the corresponding container: 139 | 140 | ```shell 141 | bf_client \ 142 | xpra \ 143 | --rootfs ID \ 144 | --socket OCI_DATA/oci.socket \ 145 | frama-c 146 | ``` 147 | The log will contain something like 148 | ``` 149 | [hh:mm:ss] Run locally: XPRA_SOCKET_HOSTNAME=oci xpra attach :100 --socket-dir "/bla/xpra_socket" 150 | [hh:mm:ss] Run remotely: xpra attach --remote-xpra "/bla/xpra_socket/remote-xpra.sh" ssh:HOST:100 151 | ``` 152 | copy the appropriate command (on a machine where xpra itself is installed of course) 153 | 154 | - If you want to restart a run on the exact same set of commits, 155 | first launch the `run` command with `OCIFORGET` environment variable set, 156 | then launch it as usual. Note that this will only forget the repository asked 157 | on the command line, not the ones it depends upon. 158 | -------------------------------------------------------------------------------- /META.in: -------------------------------------------------------------------------------- 1 | description = "OCI: Continuous Integration and Benchmark Library" 2 | 3 | package "master" ( 4 | requires = "@(REQUIRES)" 5 | version = "@(VERSION)" 6 | description = "OCI: Continuous Integration and Benchmark Library (master)" 7 | archive(native) = "Oci_Master.cmxa Oci_Default_Masters.cmxa" 8 | ) 9 | 10 | package "client" ( 11 | requires = "@(REQUIRES)" 12 | version = "@(VERSION)" 13 | description = "OCI: Continuous Integration and Benchmark Library (client)" 14 | archive(native) = "Oci_Client.cmxa" 15 | ) 16 | 17 | package "runner" ( 18 | requires = "@(REQUIRES)" 19 | version = "@(VERSION)" 20 | description = "OCI: Continuous Integration and Benchmark Library (runner)" 21 | archive(native) = "Oci_Runner.cmxa" 22 | ) 23 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | PACKAGES=async fileutils ppx_core ppx_bin_prot ppx_sexp_conv async_shell extunix core core_extended textutils cmdliner ppx_compare ppx_fields_conv ppx_here 2 | # I don't understand warning 18 3 | OCAML_WARNING=+a-4-9-18-41-30-42-44-40 4 | OCAML_WARN_ERROR=+5+10+8+12+20+11 5 | OPTIONS=-no-sanitize -no-links -tag debug -use-ocamlfind \ 6 | -cflags -w,$(OCAML_WARNING) -cflags \ 7 | -warn-error,$(OCAML_WARN_ERROR) -cflag -bin-annot -j 8 -tag thread \ 8 | -tag principal 9 | #OPTIONS += -cflags -warn-error,+a 10 | DIRECTORIES=tests src 11 | OCAMLBUILD=ocamlbuild \ 12 | $(addprefix -package ,$(PACKAGES)) \ 13 | $(OPTIONS) \ 14 | $(addprefix -I ,$(DIRECTORIES)) \ 15 | 16 | .PHONY: tests monitor.native tests_table.native tests_table.byte 17 | 18 | INTERNAL_BINARY=Oci_Copyhard Oci_Default_Master \ 19 | Oci_Wrapper Oci_Cmd_Runner Oci_Simple_Exec \ 20 | Oci_Generic_Masters_Runner 21 | 22 | EXTERNAL_BINARY=Oci_Monitor Oci_Master_Tools 23 | #For testing the library 24 | EXTERNALLY_COMPILED_BINARY=oci_default_master oci_default_client 25 | 26 | BINARY=$(INTERNAL_BINARY) $(EXTERNAL_BINARY) 27 | 28 | LIBRARY=Oci_Master Oci_Runner Oci_Client 29 | 30 | TESTS = tests_runner tests_client tests_master tests_time 31 | 32 | LIB= Oci_Common.cmi Oci_Filename.cmi Oci_Std.cmi Oci_pp.cmi \ 33 | Oci_Default_Masters.cmxa Oci_Default_Masters.a \ 34 | Oci_Generic_Masters.cmi Oci_Generic_Masters_Api.cmi \ 35 | Oci_Rootfs.cmi Oci_Rootfs_Api.cmi Oci_Cmd_Runner_Api.cmi \ 36 | $(addsuffix .cmxa, $(LIBRARY)) \ 37 | $(addsuffix .cmi, $(LIBRARY)) \ 38 | $(addsuffix .a, $(LIBRARY)) \ 39 | liboci_stubs.a 40 | 41 | TOCOMPILE= $(addprefix src/, $(addsuffix .native,$(BINARY)) $(LIB)) \ 42 | $(addprefix tests/, $(addsuffix .native,$(TESTS))) 43 | 44 | all: compile $(addprefix bin/, $(EXTERNALLY_COMPILED_BINARY)) 45 | 46 | include .config 47 | sinclude .in_git_repository 48 | 49 | compile: .merlin src/Oci_Version.ml META 50 | @rm -rf bin/ lib/ bin-test/ 51 | $(OCAMLBUILD) $(TOCOMPILE) 52 | @mkdir -m 777 -p bin/ bin-test/ 53 | @mkdir -p lib/oci/ 54 | @cp $(addprefix _build/,$(addprefix src/, $(addsuffix .native, $(BINARY)))) \ 55 | bin 56 | @cp $(addprefix _build/,$(addprefix tests/, $(addsuffix .native, $(TESTS)))) \ 57 | bin-test 58 | @cp $(addprefix _build/,$(addprefix src/, $(LIB))) META lib/oci 59 | 60 | install: 61 | rm -rf $(LIB_INSTALL_DIR)/bin 62 | ocamlfind remove oci 63 | @mkdir -p $(VARDIR)/oci-data 64 | @chown $(OCIUSER): $(VARDIR)/oci-data 65 | ocamlfind install oci lib/oci/* 66 | @mkdir -p $(LIB_INSTALL_DIR)/bin $(BINDIR) 67 | install $(addprefix bin/, $(addsuffix .native, $(INTERNAL_BINARY))) $(LIB_INSTALL_DIR)/bin 68 | install bin/oci_default_master $(LIB_INSTALL_DIR)/bin/oci-default-master 69 | install bin/Oci_Monitor.native $(BINDIR)/oci-monitor 70 | install bin/Oci_Master_Tools.native $(BINDIR)/oci-master-tools 71 | install bin/Oci_Master_Tools.native $(VARDIR)/oci-master-tools 72 | install bin/oci_default_client $(BINDIR)/oci-default-client 73 | 74 | uninstall: 75 | rm -rf $(LIB_INSTALL_DIR)/bin 76 | ocamlfind remove oci 77 | rm -f $(addprefix $(BINDIR),oci-monitor oci-default-client oci-master-tools) 78 | 79 | #force allows to always run the rules that depends on it 80 | .PHONY: force 81 | 82 | src/Oci_Version.ml: .config Makefile 83 | @echo "Generating $@ for version $(VERSION)" 84 | @rm -f $@.tmp 85 | @echo "(** Autogenerated by Makefile *)" > $@.tmp 86 | @echo "let version = \"$(VERSION)\"" >> $@.tmp 87 | @echo "let prefix = \"$(prefix)\"" >> $@.tmp 88 | @echo "let lib_install_dir = \"$(LIB_INSTALL_DIR)\"" >> $@.tmp 89 | @echo "let var_dir = \"$(VARDIR)\"" >> $@.tmp 90 | @echo "let default_oci_data = Filename.concat var_dir \"oci-data\" " >> $@.tmp 91 | @echo "let oci_user = \"$(OCIUSER)\"" >> $@.tmp 92 | @chmod a=r $@.tmp 93 | @mv -f $@.tmp $@ 94 | 95 | bin/%.native: src/version.ml force 96 | @mkdir -p `dirname bin/$*.native` 97 | @rm -f $@ 98 | @$(OCAMLBUILD) src/$*.native 99 | @ln -rs _build/src/$*.native $@ 100 | 101 | monitor.byte: 102 | $(OCAMLBUILD) src/monitor/monitor.byte 103 | 104 | tests_table.byte: 105 | $(OCAMLBUILD) tests/tests_table.byte 106 | 107 | 108 | #Because ocamlbuild doesn't give to ocamldoc the .ml when a .mli is present 109 | dep: 110 | cd _build; \ 111 | ocamlfind ocamldoc -o dependencies.dot $$(find src -name "*.ml" -or -name "*.mli") \ 112 | $(addprefix -package ,$(PACKAGES)) \ 113 | $(addprefix -I ,$(DIRECTORIES)) \ 114 | -dot -dot-reduce 115 | sed -i -e "s/ \(size\|ratio\|rotate\|fontsize\).*$$//" _build/dependencies.dot 116 | dot _build/dependencies.dot -T svg > dependencies.svg 117 | 118 | clean: 119 | rm -rf bin src/Oci_Version.ml 120 | $(OCAMLBUILD) -clean 121 | 122 | .merlin: Makefile 123 | @echo "Generating Merlin file" 124 | @rm -f .merlin.tmp 125 | @for PKG in $(PACKAGES); do echo PKG $$PKG >> .merlin.tmp; done 126 | @for SRC in $(DIRECTORIES); do echo S $$SRC >> .merlin.tmp; done 127 | @for SRC in $(DIRECTORIES); do echo B _build/$$SRC >> .merlin.tmp; done 128 | @echo FLG -w $(OCAML_WARNING) >> .merlin.tmp 129 | @echo FLG -w $(OCAML_WARN_ERROR) >> .merlin.tmp 130 | @mv .merlin.tmp .merlin 131 | 132 | META: .config Makefile META.in 133 | @echo "Generating META file" 134 | @rm -f $@.tmp 135 | @sed -e "s/@(REQUIRES)/$(PACKAGES)/" -e "s/@(VERSION)/$(VERSION)/" $@.in > $@.tmp 136 | @mv $@.tmp $@ 137 | 138 | # We test that the library contains the needed modules 139 | bin/%:tests/library/%.ml force compile 140 | OCAMLPATH=lib:$(OCAMLPATH) \ 141 | ocamlfind ocamlopt -thread -linkpkg -package oci.$(patsubst oci_default_%,%,$*) $< -o $@ 142 | 143 | tests: compile 144 | bin/Oci_Monitor.native --binaries bin-test --master \ 145 | bin-test/tests_master.native --oci-data test-oci-data \ 146 | --cpuinfo --verbose Debug 147 | 148 | .PHONY: headers 149 | 150 | define make-header 151 | git ls-files | xargs git check-attr $1 | sed -n -e "s/^\([^:]*\): $1: set/\1/p" \ 152 | | xargs headache -c licences/headache_config.txt -h licences/$2 153 | endef 154 | headers: 155 | $(call make-header,header-cea,CEA_LGPL) 156 | $(call make-header,header-why3,WHY3_LGPL) 157 | 158 | .config: config.status 159 | ./config.status --file .config 160 | 161 | config.status: configure 162 | ./config.status --recheck 163 | 164 | GIT_TARNAME = oci-$(VERSION) 165 | archive: 166 | git archive --format=tar --prefix=$(GIT_TARNAME)/ -o $(GIT_TARNAME).tar HEAD^{tree} 167 | @rm -rf $(GIT_TARNAME) 168 | @mkdir -p $(GIT_TARNAME) 169 | cp configure $(GIT_TARNAME)/ 170 | tar rf $(GIT_TARNAME).tar $(GIT_TARNAME)/configure 171 | @rm -r $(GIT_TARNAME) 172 | gzip -f -9 $(GIT_TARNAME).tar 173 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | : -traverse 2 | : -traverse 3 | : -traverse 4 | : -traverse 5 | : -traverse 6 | : -package(async), -package(async_shell), -package(cmdliner) 7 | <*.tmp> : -traverse 8 | 9 | : use_liboci_stubs 10 | <{src,tests}/*.native>: link_liboci_stubs -------------------------------------------------------------------------------- /configure.ac: -------------------------------------------------------------------------------- 1 | # -*- Autoconf -*- 2 | # Process this file with autoconf to produce a configure script. 3 | 4 | AC_PREREQ([2.69]) 5 | AC_INIT(OCI, 0.5~dev) 6 | 7 | AC_CHECK_FUNC(wait4,,AC_MSG_ERROR(wait4 function not available)) 8 | 9 | ocamlfind_install_dir=$(ocamlfind printconf destdir)/oci 10 | 11 | ociuser=$(id --user --name) 12 | 13 | AC_SUBST(ociuser) 14 | AC_SUBST(ocamlfind_install_dir) 15 | 16 | AC_CONFIG_FILES(.config) 17 | AC_OUTPUT 18 | -------------------------------------------------------------------------------- /create_cgroup.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh -eux 2 | 3 | 4 | 5 | sudo cgm create all oci 6 | sudo cgm chown all oci $(id -u) $(id -g) 7 | cgm movepid all oci $PPID 8 | -------------------------------------------------------------------------------- /doc/biblio.md: -------------------------------------------------------------------------------- 1 | 2 | Sharing mounts with a container 3 | - http://s3hh.wordpress.com/2011/09/22/sharing-mounts-with-a-container/ 4 | -------------------------------------------------------------------------------- /doc/design.md: -------------------------------------------------------------------------------- 1 | # OCI # 2 | 3 | ## Architecture ## 4 | 5 | OCI is composed by four different type of components: 6 | 7 | - one conductor which coordinate the work to do and maintain the global state 8 | - many monitors who run on remote computers, execute the workers, take their output 9 | and save the artifacts 10 | - many workers who sequentially execute a task and can depend on the 11 | outputs of other workers 12 | - user interface (command line or website) for requesting a task or 13 | looking at the result 14 | 15 | ## Main Ideas ## 16 | 17 | - Tasks are just usual ocaml functions (cf Richard Jones goaljobs [1](https://rwmj.wordpress.com/2013/09/19/goaljobs-part-1/) [2](https://rwmj.wordpress.com/2013/09/20/goaljobs-part-2/) [3](https://rwmj.wordpress.com/2013/09/20/goaljobs-part-3/) [4](https://rwmj.wordpress.com/2013/09/20/goaljobs-part-4/)): 18 | - they are not automatically memoized 19 | - but there is tools for doing this memoization 20 | 21 | - Run tests in isolation using "versioned" filesystem with [LXC](http://linuxcontainers.org/) and [AUFS](http://en.wikipedia.org/wiki/Aufs) (cf https://www.docker.io/) 22 | - Make the filesystem version first class value 23 | - Modify them using [shared mount](http://s3hh.wordpress.com/2011/09/22/sharing-mounts-with-a-container/) 24 | 25 | - Use a real databases that can be read by different components for 26 | simple information sharing (cf [genet](http://zoggy.github.io/genet/)) 27 | - use a simple framework for using postgresql 28 | - every important type of the system can be used as database 29 | column (artifacts, result, filesystem) 30 | - for big data (filesystem) the information can be stored separately 31 | and moved or recomputed when needed 32 | 33 | - All the configurations (ini or ml) are versionned on git 34 | 35 | ## Difference with a Build System ## 36 | 37 | - The input of a worker is completely fixed. So there is no reason to 38 | redo the same worker if something has changed since nothing change. 39 | - Some outputs will never be forgetted, it is normally small data 40 | (if the test is succesfull, time taken, artifact) -------------------------------------------------------------------------------- /doc/first_step.md: -------------------------------------------------------------------------------- 1 | # First step # 2 | 3 | Present: 4 | 5 | - layer efficient in memory (hardlink) 6 | - userland container 7 | - A sort of task is modelized as a function `'query -> 'result`, a 8 | task is the application (`'query` and `'result` must have a binprot 9 | type class defined (`with bin_type_class`)). 10 | 11 | Absent: 12 | 13 | - Database 14 | - Multi-server 15 | - master in a standalone program 16 | 17 | ## Components ## 18 | 19 | There are five kind of components (4 components and a multiple of runners): 20 | 21 | - one monitor, Oci_Monitor, which is the first program to run and that only launch 22 | the master and the runners when the master ask to. It is in no 23 | user namespace (it is a program like any other) 24 | - a wrapper that execute programs inside their own user namespace. 25 | This is a separated program because it is hard to fork correctly 26 | inside a program that use Async. It is used only by the monitor 27 | - one simple program `Oci_Simple_Exec` which is in a user namespace 28 | that contains all the users. It is used for the creation of the 29 | environment for the master or cleaning. 30 | - one master, Oci_Artefact+specific user test (frama-c, zarith, 31 | e-acsl, ocaml. It is run in a user namespace with the `superroot` as 32 | `root`. It does: 33 | - ask the monitor to the runners when needed 34 | - keep track of which test have been run and save this information 35 | to disk 36 | - save the artefacts (directory in the filesystem) 37 | - add an artefacts inside a runner usernamespace 38 | - one runner by task (eg. Frama-C commit abcdef12345 with ocaml 4.02.0, zarith 0.10, gui) 39 | 40 | Oci use four different users: 41 | 42 | - original user: The usual one, the one in the shell, eg. your user 43 | - superroot: The first additional id given in `/etc/subuid` 44 | - root: The second one 45 | - user: The 1001th one 46 | 47 | 48 | | | original user | superroot | root | user | 49 | |---------|:-------------:|:---------:|:----:|:----:| 50 | | `Oci_Monitor` |X| | | | 51 | | wrapper |X| | | | 52 | | `Oci_Simple_Exec` |X|X|X|X| 53 | | `Oci_Artefact` | |X|X|X| 54 | | runners | | |X|X| 55 | 56 | ## Technique ## 57 | 58 | For the artefacts adding a layer inside a usernamespace we use simply 59 | hardlinks (fast and very simple). In order to forbid modification of these 60 | file the owner is set to a superroot (just a user not present in the 61 | usernamespace) 62 | 63 | A proof of concept of the wrapper (usernamespace, chroot, binding of 64 | /proc /dev, ...) is present as test in the master of extunix (on github). 65 | 66 | For the communication we use Rpc from Async (Core). It is typed and 67 | quite straigh forward. We use named unix socket for the communication, 68 | simpler to pass to the runner than file descriptor. 69 | 70 | ## Structure ## 71 | 72 | - `Oci_Common` is shared by the monitor, the masters and the runner. 73 | It contains the typed RPC interface. 74 | - `Oci_Data` is shared by the masters and the runners. It contains API 75 | for registering sort of tasks 76 | - `Oci_Master` is used only by the masters. It contains its API 77 | - `Oci_Runner` is used only by the runners. It contains its API, 78 | request creation of artifacts, linking or copy. 79 | - `Oci_Artefact` is used only by the monitor for handling artifacts. 80 | 81 | Not yet present: 82 | 83 | - `Oci_Monitor` main part of the monitor 84 | - `Oci_Wrapper` wrapper that creates usernamespace 85 | 86 | 88 | -------------------------------------------------------------------------------- /doc/mockup.md: -------------------------------------------------------------------------------- 1 | ## Mockups ## 2 | 3 | * [run frama-c on an examples with some options](frama-c-test.ml) 4 | -------------------------------------------------------------------------------- /licences/CEA_LGPL: -------------------------------------------------------------------------------- 1 | 2 | This file is part of OCI. 3 | 4 | Copyright (C) 2015-2016 5 | CEA (Commissariat à l'énergie atomique et aux énergies 6 | alternatives) 7 | 8 | you can redistribute it and/or modify it under the terms of the GNU 9 | Lesser General Public License as published by the Free Software 10 | Foundation, version 2.1. 11 | 12 | It is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | GNU Lesser General Public License for more details. 16 | 17 | See the GNU Lesser General Public License version 2.1 18 | for more details (enclosed in the file licenses/LGPLv2.1). 19 | 20 | -------------------------------------------------------------------------------- /licences/WHY3_LGPL: -------------------------------------------------------------------------------- 1 | 2 | The Why3 Verification Platform / The Why3 Development Team 3 | Copyright 2010-2015 -- INRIA - CNRS - Paris-Sud University 4 | 5 | This software is distributed under the terms of the GNU Lesser 6 | General Public License version 2.1, with the special exception 7 | on linking described in file LICENSE. 8 | 9 | -------------------------------------------------------------------------------- /licences/headache_config.txt: -------------------------------------------------------------------------------- 1 | ################## 2 | # Objective Caml # 3 | ################## 4 | | ".*\.mly" -> frame open:"/*" line:"*" close:"*/" 5 | | ".*\.ml[il4]?.*" -> frame open:"(*" line:"*" close:"*)" 6 | 7 | ############ 8 | # C source # 9 | ############ 10 | | ".*\.h" -> frame open:"/*" line:"*" close:"*/" 11 | | ".*\.i" -> frame open:"/*" line:"*" close:"*/" 12 | | ".*\.c" -> frame open:"/*" line:"*" close:"*/" 13 | | ".*\.ast" -> frame open:"//" line:" " close:" " 14 | | ".*\.cc" -> frame open:"/*" line:"*" close:"*/" 15 | | "perfcount.c.in" -> frame open: "/*" line: "*" close: "*/" 16 | 17 | ####### 18 | # Asm # 19 | ####### 20 | | ".*\.S" -> frame open:"/*" line:"*" close:"*/" 21 | 22 | ############# 23 | # Configure # 24 | ############# 25 | | ".*config\.h\.in" -> frame open:"/*" line:"*" close:"*/" 26 | | ".*configure\..*" -> frame open:"#" line:"#" close:"#" 27 | 28 | ############ 29 | # Makefile # 30 | ############ 31 | | ".*Make.*" -> frame open:"#" line:"#" close:"#" 32 | 33 | ################# 34 | # Shell scripts # 35 | ################# 36 | | ".*\.sh" -> frame open:"#" line:"#" close:"#" 37 | 38 | ################ 39 | # Perl scripts # 40 | ################ 41 | | ".*\.perl" -> frame open:"#" line:"#" close:"#" 42 | 43 | ######################### 44 | # MS-Windows Ressources # 45 | ######################### 46 | | ".*\.rc" -> frame open:"#" line:"#" close:"#" 47 | 48 | ############# 49 | # man pages # 50 | ############# 51 | | ".*\.[1-9]" -> frame open:".\\\"" line: "-" close:"" 52 | 53 | ############# 54 | # Why files # 55 | ############# 56 | | ".*\.why" -> frame open: "(*" line: "*" close: "*)" 57 | | ".*\.why\.src" -> frame open: "(*" line: "*" close: "*)" 58 | 59 | ############# 60 | # Alt-Ergo files # 61 | ############# 62 | | ".*\.mlw" -> frame open: "(*" line: "*" close: "*)" 63 | 64 | ############# 65 | # Coq files # 66 | ############# 67 | | ".*\.v" -> frame open: "(*" line: "*" close: "*)" 68 | 69 | ############# 70 | # WP files # 71 | ############# 72 | | ".*\.driver" -> frame open: "/*" line: "*" close: "*/" 73 | 74 | ##################### 75 | # Why3 driver files # 76 | ##################### 77 | | ".*\.drv" -> frame open: "(*" line: "*" close: "*)" 78 | 79 | ######## 80 | # HTML # 81 | ######## 82 | | ".*\.htm.*" -> frame open: "" 83 | 84 | ####### 85 | # DTD # 86 | ####### 87 | | ".*\.dtd" -> frame open: "" 88 | 89 | ####### 90 | # XSL # 91 | ####### 92 | | ".*\.xsl" -> frame open: "" 93 | 94 | ####### 95 | # CSS # 96 | ####### 97 | | ".*\.css" -> frame open: "/*" line: "*" close: "*/" 98 | # plug-in's ocamldoc introductions 99 | | "intro_.*\.txt" -> frame open: "#*" line: "*" close: "#" 100 | 101 | ########## 102 | # PROLOG # 103 | ########## 104 | | ".*\.pl" -> frame open: "%" line: "%" close: "%" 105 | 106 | ############## 107 | # Emacs Lisp # 108 | ############## 109 | | ".*\.el" -> frame open: ";" line: ";" close:";" 110 | 111 | ############## 112 | # Misc files # 113 | ############## 114 | | "make_release" -> frame open:"#" line:"#" close:"#" 115 | | "FAQ" -> frame open:"#" line:"#" close:"#" 116 | | "frama-c" -> frame open:"#" line:"#" close:"#" 117 | | "frama-c-gui" -> frame open:"#" line:"#" close:"#" 118 | | "frama-c-gui.byte" -> frame open:"#" line:"#" close:"#" 119 | | "frama-c.byte" -> frame open:"#" line:"#" close:"#" 120 | | "frama-c.top" -> frame open:"#" line:"#" close:"#" 121 | -------------------------------------------------------------------------------- /myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | open Ocamlbuild_plugin 2 | open! Command 3 | 4 | let () = 5 | dispatch begin function 6 | | After_rules -> 7 | 8 | flag ["link"; "library"; "ocaml"; "native"; "use_liboci_stubs"] 9 | (S[A"-cclib"; A"-loci_stubs"]); 10 | 11 | dep ["link"; "ocaml"; "link_liboci_stubs"] ["src/liboci_stubs.a"] 12 | | _ -> () 13 | end 14 | -------------------------------------------------------------------------------- /opam/opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | name: "oci" 3 | version: "0.5~dev" 4 | maintainer: "francois.bobot@cea.fr" 5 | authors: ["François Bobot"] 6 | homepage: "https://github.com/bobot/oci" 7 | dev-repo: "https://github.com/bobot/oci" 8 | bug-reports: "https://github.com/bobot/oci/issues" 9 | license: "LGPL-2+ with OCaml linking exception" 10 | 11 | build: [ 12 | ["./.configure_or_autoconf" "--prefix=%{prefix}%"] 13 | [make] 14 | ] 15 | install: [ 16 | [make "install"] 17 | ] 18 | remove: [ 19 | ["./.configure_or_autoconf" "--prefix=%{prefix}%"] 20 | [make "uninstall"] 21 | ] 22 | 23 | depends: [ 24 | "ocamlfind" 25 | "cmdliner" 26 | "async_shell" {>= "113.33.00" & < "113.34.00"} 27 | "core" {>= "113.33.00" & < "113.34.00"} 28 | "core_extended" 29 | "extunix" {>= "0.1.3"} 30 | "fileutils" "textutils" "ocamlbuild" 31 | "ppx_sexp_conv" "ppx_bin_prot" "ppx_here" "ppx_fields_conv" "ppx_compare" 32 | ] 33 | 34 | available: [ ( ocaml-version = "4.02.1" | ocaml-version >= "4.02.3" ) & os = "linux" ] 35 | -------------------------------------------------------------------------------- /src/.config.in: -------------------------------------------------------------------------------- 1 | LIB_INSTALL_DIR ?= @ocamlfind_install_dir@ 2 | DESTDIR ?= 3 | PREFIX ?= $(DESTDIR)/@prefix@ 4 | DATADIR ?= $(DESTDIR)/@datadir@ 5 | VARDIR ?= $(DESTDIR)/@localstatedir@ 6 | OCIUSER ?= @ociuser@ 7 | -------------------------------------------------------------------------------- /src/Oci_Artefact.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | (** Manage directory resulting from a task execution *) 24 | open Core.Std 25 | open Async.Std 26 | 27 | type t = Oci_Common.Artefact.t 28 | 29 | type runner 30 | val runner_id: runner -> int 31 | 32 | val create: 33 | prune:Oci_Filename.t list -> 34 | rooted_at:Oci_Filename.t -> 35 | only_new:Bool.t -> 36 | src:Oci_Filename.t -> 37 | t Deferred.t 38 | 39 | val base_directory_to_prune: Oci_Filename.t list 40 | (** Tmpfs directory created *) 41 | 42 | val link_to: Oci_Common.user_kind -> t -> Oci_Filename.t -> unit Deferred.t 43 | (** ro only *) 44 | 45 | val copy_to: Oci_Common.user_kind -> t -> Oci_Filename.t -> unit Deferred.t 46 | (** rw *) 47 | 48 | val is_available: t -> bool Deferred.t 49 | 50 | val remove_dir: Oci_Filename.t -> unit Deferred.t 51 | 52 | 53 | val register_master: 54 | ?forget: ('query -> unit Or_error.t Deferred.t) -> 55 | ('query,'result) Oci_Data.t -> 56 | ('query -> 'result Oci_Log.reader) -> 57 | unit 58 | 59 | val register_saver: 60 | name:string -> 61 | loader:(unit -> unit Deferred.t) -> 62 | saver:(unit -> unit Deferred.t) -> 63 | unit 64 | 65 | val run: unit -> never_returns 66 | 67 | type slot 68 | 69 | val alloc_slot: unit -> slot Async.Std.Deferred.t 70 | 71 | val start_runner: 72 | ?slot:slot -> 73 | debug_info:string -> 74 | binary_name:string -> 75 | unit -> 76 | (unit Or_error.t Deferred.t * runner) Async.Std.Deferred.t 77 | (** Start the given runner in a namespace and start an Rpc connection. 78 | `start_runner ~binary_name` start the executable 79 | [binary_name^".native"] located in the directory of binaries *) 80 | 81 | val runner_conn: runner -> Async.Std.Rpc.Connection.t Deferred.t option 82 | val runner_conn_or_never: runner -> Async.Std.Rpc.Connection.t Deferred.t 83 | 84 | val freeze_runner: runner -> unit Deferred.t 85 | val unfreeze_runner: runner -> slot -> unit Deferred.t 86 | 87 | val stop_runner: runner -> unit Deferred.t 88 | 89 | val permanent_directory: 90 | ('query,'result) Oci_Data.t -> Oci_Filename.t Deferred.t 91 | (** Give the permanent directory for this master *) 92 | 93 | 94 | val dispatch_master: 95 | ('query,'result) Oci_Data.t -> 96 | 'query -> 'result Or_error.t Deferred.t 97 | 98 | val dispatch_master_exn: 99 | ('query,'result) Oci_Data.t -> 100 | 'query -> 'result Deferred.t 101 | 102 | 103 | val dispatch_master_log: 104 | ('query,'result) Oci_Data.t -> 105 | 'query -> 'result Oci_Log.reader 106 | -------------------------------------------------------------------------------- /src/Oci_Artefact_Api.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | open Async.Std 25 | open Oci_Common 26 | open Oci_Std 27 | 28 | (** master to monitor *) 29 | 30 | type artefact_api = { 31 | binaries : Oci_Filename.t list; 32 | oci_data : Oci_Filename.t; 33 | first_user_mapped: User.t; 34 | debug_level : Bool.t; 35 | cleanup_rootfs: Bool.t; 36 | identity_file: string option; 37 | proc: Int.t List.t List.t; 38 | master_proc: Int.t List.t; 39 | } [@@deriving sexp, bin_io] 40 | 41 | let get_configuration = Rpc.Rpc.create 42 | ~name:"Oci_Artefact.start" 43 | ~version:1 44 | ~bin_query:Unit.bin_t 45 | ~bin_response:bin_artefact_api 46 | 47 | let rpc_kill_runner = Rpc.Rpc.create 48 | ~name:"Oci_Monitor.kill_runner" 49 | ~version:1 50 | ~bin_query:Int.bin_t (* runner_id *) 51 | ~bin_response:Unit.bin_t 52 | 53 | let exec_in_namespace = Rpc.Rpc.create 54 | ~name:"Oci_Monitor.exec_in_namespace" 55 | ~version:1 56 | ~bin_query:Oci_Wrapper_Api.bin_parameters 57 | ~bin_response:(Or_error.bin_t Unit.bin_t) 58 | 59 | let heartbeat_config = 60 | Rpc.Connection.Heartbeat_config.create 61 | ~timeout:(Time_ns.Span.create ~min:10 ()) 62 | ~send_every:(Time_ns.Span.create ~sec:10 ()) 63 | 64 | let start_in_namespace 65 | ?implementations ~initial_state 66 | ~exec_in_namespace ~parameters ~named_pipe () = 67 | let named_pipe_in = named_pipe^".in" in 68 | let named_pipe_out = named_pipe^".out" in 69 | unlink_no_fail named_pipe_in 70 | >>= fun () -> 71 | unlink_no_fail named_pipe_out 72 | >>= fun () -> 73 | Unix.mkfifo named_pipe_in 74 | >>= fun () -> 75 | Unix.mkfifo named_pipe_out 76 | >>= fun () -> 77 | Unix.chmod ~perm:0o666 named_pipe_in 78 | >>= fun () -> 79 | Unix.chmod ~perm:0o666 named_pipe_out 80 | >>= fun () -> 81 | debug "Pipe created at %s and %s" named_pipe_in named_pipe_out; 82 | let conn = 83 | Writer.open_file named_pipe_in 84 | >>= fun writer -> 85 | Reader.open_file named_pipe_out 86 | >>= fun reader -> 87 | Unix.unlink named_pipe_in 88 | >>= fun () -> 89 | Unix.unlink named_pipe_out 90 | >>= fun () -> 91 | let description = 92 | Info.create ~here:[%here] 93 | (sprintf "runner %i" parameters.Oci_Wrapper_Api.runner_id) 94 | parameters Oci_Wrapper_Api.sexp_of_parameters 95 | in 96 | Rpc.Connection.create 97 | ~connection_state:(fun _ -> initial_state) 98 | ~description 99 | ~heartbeat_config:heartbeat_config 100 | ?implementations 101 | reader 102 | writer 103 | >>= fun conn -> 104 | let conn = Result.ok_exn conn in 105 | Deferred.upon 106 | (Rpc.Connection.close_reason conn) 107 | (fun reason -> 108 | debug "Connection in %s{.in/.out} is closed : %s" 109 | named_pipe 110 | (Info.to_string_hum reason) 111 | ); 112 | return conn 113 | in 114 | let error = exec_in_namespace (parameters:Oci_Wrapper_Api.parameters) in 115 | return (error,conn) 116 | 117 | type set_cpuset = { 118 | cgroup: string; 119 | cpuset: Int.t list; 120 | } [@@deriving bin_io] 121 | 122 | let set_cpuset = Rpc.Rpc.create 123 | ~name:"Oci_Artefact.set_cpuset" 124 | ~version:1 125 | ~bin_query:bin_set_cpuset 126 | ~bin_response:Unit.bin_t 127 | 128 | (** runner to master *) 129 | 130 | type rpc_create_query = { 131 | src: Oci_Filename.t; 132 | prune: Oci_Filename.t list; 133 | rooted_at: Oci_Filename.t; 134 | only_new: bool; 135 | } [@@deriving sexp, bin_io] 136 | 137 | let rpc_create = 138 | Rpc.Rpc.create 139 | ~name:"Oci_Artefact.create" 140 | ~version:1 141 | ~bin_query:bin_rpc_create_query 142 | ~bin_response:Artefact.bin_t 143 | 144 | type rpc_link_to_query = 145 | Oci_Common.user_kind * Artefact.t * Oci_Filename.t [@@deriving bin_io] 146 | 147 | let rpc_link_to = 148 | Rpc.Rpc.create 149 | ~name:"Oci_Artefact.link_to" 150 | ~version:1 151 | ~bin_query:bin_rpc_link_to_query 152 | ~bin_response:Unit.bin_t 153 | 154 | let rpc_copy_to = 155 | Rpc.Rpc.create 156 | ~name:"Oci_Artefact.copy_to" 157 | ~version:1 158 | ~bin_query:bin_rpc_link_to_query 159 | ~bin_response:Unit.bin_t 160 | 161 | let rpc_get_internet = 162 | Rpc.Rpc.create 163 | ~name:"Oci_Artefact.get_internet" 164 | ~version:1 165 | ~bin_query:Unit.bin_t 166 | ~bin_response:Unit.bin_t 167 | 168 | type rpc_git_clone_query = { 169 | url : String.t; 170 | dst: Oci_Filename.t; 171 | user: Oci_Common.user_kind; 172 | commit: Oci_Common.Commit.t; 173 | } [@@deriving bin_io] 174 | 175 | let rpc_git_clone = 176 | Rpc.Rpc.create 177 | ~name:"Oci_Artefact.git_clone" 178 | ~version:1 179 | ~bin_query:bin_rpc_git_clone_query 180 | ~bin_response:Unit.bin_t 181 | 182 | type rpc_git_copy_file_query = { 183 | url : String.t; 184 | src: Oci_Filename.t; 185 | dst: Oci_Filename.t; 186 | user: Oci_Common.user_kind; 187 | commit: Oci_Common.Commit.t; 188 | } [@@deriving bin_io] 189 | 190 | let rpc_git_copy_file = 191 | Rpc.Rpc.create 192 | ~name:"Oci_Artefact.git_copy_file" 193 | ~version:1 194 | ~bin_query:bin_rpc_git_copy_file_query 195 | ~bin_response:Unit.bin_t 196 | 197 | type rpc_get_file = { 198 | kind : [`MD5]; 199 | checksum: String.t; 200 | dst : Oci_Filename.t; 201 | } [@@deriving bin_io] 202 | 203 | let rpc_get_file = 204 | Rpc.Rpc.create 205 | ~name:"Oci_Artefact.get_file" 206 | ~version:1 207 | ~bin_query:bin_rpc_get_file 208 | ~bin_response:Unit.bin_t 209 | 210 | (** ask a runner to stop nicely *) 211 | let rpc_stop_runner = 212 | Rpc.Rpc.create 213 | ~name:"Oci_Runner.stop_runner" 214 | ~version:1 215 | ~bin_query:Unit.bin_t 216 | ~bin_response:Unit.bin_t 217 | 218 | let rpc_get_or_release_proc = 219 | Rpc.Rpc.create 220 | ~name:"Oci_Artefact.get_or_release_proc" 221 | ~version:1 222 | ~bin_query:Int.bin_t 223 | ~bin_response:Int.bin_t 224 | 225 | let rpc_give_external_access = 226 | Rpc.Rpc.create 227 | ~name:"Oci_Artefact.give_external_access" 228 | ~version:1 229 | ~bin_query:Oci_Filename.bin_t 230 | ~bin_response:Oci_Filename.bin_t 231 | 232 | 233 | let oci_at_shutdown,oci_shutdown,oci_shutting_down = 234 | let s = Stack.create () in 235 | let r = ref false in 236 | (fun d -> Stack.push s d), 237 | (fun status -> 238 | if status = 0 239 | then debug "Shutting down" 240 | else error "Shutting down unexpectedly"; 241 | if !r then begin 242 | debug "Already shutting down"; 243 | never () 244 | end 245 | else begin 246 | r := true; 247 | s 248 | |> Stack.fold ~init:[] ~f:(fun acc d -> d ()::acc) 249 | |> Deferred.all_unit 250 | >>= fun () -> 251 | debug "Shutting down tasks finished"; 252 | Log.Global.flushed () 253 | >>= fun () -> 254 | Shutdown.exit status 255 | end 256 | ), 257 | (fun () -> !r) 258 | -------------------------------------------------------------------------------- /src/Oci_Cmd_Runner.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | open Oci_Cmd_Runner_Api 25 | 26 | let () = 27 | never_returns ( 28 | Oci_Runner.start 29 | ~implementations:[ 30 | Oci_Runner.implement run 31 | (fun t d -> Oci_Runner.run_exn t ~prog:d.prog ~args:d.args 32 | ~env:(d.env :> Async.Std.Process.env) ()); 33 | Oci_Runner.implement create_artefact 34 | (fun t dir -> Oci_Runner.create_artefact t ~dir); 35 | Oci_Runner.implement link_to 36 | (fun t d -> Oci_Runner.link_artefact t d.artefact ~dir:d.dst); 37 | Oci_Runner.implement copy_to 38 | (fun t d -> Oci_Runner.copy_artefact t d.artefact ~dir:d.dst); 39 | Oci_Runner.implement get_internet 40 | (fun t () -> Oci_Runner.get_internet t); 41 | ] 42 | ) 43 | -------------------------------------------------------------------------------- /src/Oci_Cmd_Runner_Api.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | 25 | type run_query = { 26 | prog: string; 27 | args: string list; 28 | env: [`Extend of (string * string) list | `Replace of (string * string) list]; 29 | runas: Oci_Common.user_kind; 30 | } [@@deriving sexp, bin_io] 31 | 32 | let run = Oci_Data.register 33 | ~name:"Oci_Cmd_Runner_Api.run" 34 | ~version:1 35 | ~bin_query:bin_run_query 36 | ~bin_result:Unit.bin_t 37 | 38 | 39 | let create_artefact = Oci_Data.register 40 | ~name:"Oci_Cmd_Runner.create" 41 | ~version:1 42 | ~bin_query:Oci_Filename.bin_t 43 | ~bin_result:Oci_Common.Artefact.bin_t 44 | 45 | type link_copy_query = { 46 | user: Oci_Common.user_kind; 47 | artefact: Oci_Common.Artefact.t; 48 | dst: Oci_Filename.t; 49 | } [@@deriving sexp, bin_io] 50 | 51 | let link_to = Oci_Data.register 52 | ~name:"Oci_Cmd_Runner_Api.link_to" 53 | ~version:1 54 | ~bin_query:bin_link_copy_query 55 | ~bin_result:Unit.bin_t 56 | 57 | let copy_to = Oci_Data.register 58 | ~name:"Oci_Cmd_Runner_Api.copy_to" 59 | ~version:1 60 | ~bin_query:bin_link_copy_query 61 | ~bin_result:Unit.bin_t 62 | 63 | let get_internet = 64 | Oci_Data.register 65 | ~name:"Oci_Cmd_Runner_Api.get_internet" 66 | ~version:1 67 | ~bin_query:Unit.bin_t 68 | ~bin_result:Unit.bin_t 69 | -------------------------------------------------------------------------------- /src/Oci_Common.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | 25 | module Artefact = struct 26 | type t = Int.t [@@deriving sexp, compare, bin_io] 27 | (* let bin_t = Int.bin_t *) 28 | let to_string = Int.to_string 29 | let pp = Int.pp 30 | let empty = -1 (** special value *) 31 | let hash = Int.hash 32 | 33 | let of_int_exn i = if i < 0 then invalid_arg "Artefact.of_int" else i 34 | 35 | end 36 | 37 | module Commit = struct 38 | exception BadGitCommitFormat of string [@@deriving sexp] 39 | type t = String.t [@@deriving sexp, compare, bin_io] 40 | let invariant x = 41 | String.length x = 40 && 42 | String.for_all ~f:(function 43 | | 'a' | 'b' | 'c' | 'd' | 'e' | 'f' 44 | | '0' | '1' | '2' | '3' | '4' | '5' 45 | | '6' | '7' | '8' | '9' -> true 46 | | _ -> false) x 47 | 48 | let to_string = Fn.id 49 | let of_string_exn x = 50 | if invariant x then x else raise (BadGitCommitFormat x) 51 | let of_string x = 52 | if invariant x then Some x else None 53 | end 54 | 55 | module User = struct 56 | type t = {uid : int; gid : int} [@@deriving sexp, compare, bin_io] 57 | 58 | let equal a b = a.uid = b.uid && a.gid = b.gid 59 | let pp_t fmt u = Format.fprintf fmt "%i,%i" u.uid u.gid 60 | let pp_chown u = Printf.sprintf "%i:%i" u.uid u.gid 61 | end 62 | open User 63 | (** user in different namespace *) 64 | 65 | type user_kind = 66 | | Superroot 67 | (** A user outside the usernamespace of the runners stronger than the 68 | root, In Artifact run with superroot as root *) 69 | | Root 70 | | User 71 | [@@deriving sexp, compare, bin_io] 72 | 73 | let master_user = function 74 | | Superroot -> {uid=0;gid=0} 75 | | Root -> {uid=1;gid=1} 76 | | User -> {uid=1001;gid=1001} 77 | 78 | let runner_user = function 79 | | Superroot -> invalid_arg "No superroot in runner namespace" 80 | | Root -> {uid=0;gid=0} 81 | | User -> {uid=1000;gid=1000} 82 | 83 | let outside_user ~first_user_mapped = function 84 | | Superroot -> {uid=first_user_mapped.uid; gid=first_user_mapped.gid} 85 | | Root -> {uid=first_user_mapped.uid+1; gid=first_user_mapped.gid+1} 86 | | User -> {uid=first_user_mapped.uid+1001;gid=first_user_mapped.gid+1001} 87 | 88 | module Formatted (X:sig 89 | type 'a arg 90 | val template: (string arg, unit, string) format 91 | end) = struct 92 | type t = string 93 | [@@deriving sexp, bin_io, compare] 94 | 95 | let mk x = string_of_format x 96 | let get x = Scanf.format_from_string x X.template 97 | let pp = String.pp 98 | end 99 | 100 | module Timed = struct 101 | type t = { 102 | cpu_kernel: Time.Span.t; (* S *) 103 | cpu_user: Time.Span.t; (* U *) 104 | wall_clock: Time.Span.t; (* e *) 105 | } [@@deriving sexp, bin_io, compare] 106 | 107 | let pp fmt e = 108 | Format.fprintf fmt "{kernel:%a; user:%a; wall:%a}" 109 | Time.Span.pp e.cpu_kernel 110 | Time.Span.pp e.cpu_user 111 | Time.Span.pp e.wall_clock 112 | 113 | end 114 | -------------------------------------------------------------------------------- /src/Oci_Common.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | module Artefact : sig 24 | type t [@@deriving sexp, bin_io, compare] 25 | val to_string: t -> string 26 | val pp: t Oci_pp.printer 27 | val empty: t 28 | val hash: t -> int 29 | (* For Oci_Artefact.ml *) 30 | val of_int_exn: int -> t 31 | 32 | end 33 | 34 | module Commit : sig 35 | type t [@@deriving sexp, bin_io, compare] 36 | val invariant: t -> bool 37 | val to_string: t -> string 38 | val of_string_exn: string -> t 39 | val of_string: string -> t option 40 | end 41 | 42 | module User: sig 43 | type t = {uid : int; gid : int} [@@deriving sexp, compare, bin_io] 44 | 45 | val equal: t -> t -> bool 46 | val pp_t: Format.formatter -> t -> unit 47 | val pp_chown: t -> string 48 | end 49 | 50 | type user_kind = 51 | | Superroot 52 | (** A user outside the usernamespace of the runners stronger than the 53 | root, In Artifact run with superroot as root *) 54 | | Root 55 | (** root in the usernamespace of the runners *) 56 | | User 57 | (** A simple user in the usernamespace of the runners *) 58 | [@@deriving sexp, compare, bin_io] 59 | 60 | val master_user: user_kind -> User.t 61 | val runner_user: user_kind -> User.t 62 | val outside_user: first_user_mapped:User.t -> user_kind -> User.t 63 | 64 | module Formatted (X:sig 65 | type 'a arg 66 | val template: (string arg, unit, string) format 67 | end) : sig 68 | type t [@@deriving sexp, bin_io, compare] 69 | val mk : (string X.arg, unit, string) format -> t 70 | val get: t -> (string X.arg, unit, string) format 71 | val pp: t Oci_pp.printer 72 | end 73 | 74 | 75 | module Timed : sig 76 | type t = { 77 | cpu_kernel: Core.Time.Span.t; (* S *) 78 | cpu_user: Core.Time.Span.t; (* U *) 79 | wall_clock: Core.Time.Span.t; (* e *) 80 | } [@@deriving sexp, bin_io, compare] 81 | 82 | val pp: t Oci_pp.printer 83 | end 84 | -------------------------------------------------------------------------------- /src/Oci_Copyhard.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | open Oci_Common 25 | 26 | 27 | exception Can't_copy_this_file of Oci_Filename.t 28 | 29 | open Core_extended 30 | 31 | let unlink_no_fail filename = 32 | try Unix.unlink filename 33 | with _ -> () 34 | 35 | let rec copydir 36 | ~hardlink ~prune_file ~prune_user 37 | ~chown:({User.uid;gid} as chown) src dst = 38 | (** This function run as superroot (like all masters), 39 | so it is root in its usernamespace *) 40 | let dst_exist = Sys.file_exists_exn dst in 41 | begin if dst_exist 42 | then () 43 | else 44 | Unix.mkdir dst; 45 | Unix.chown ~uid ~gid dst; 46 | end; 47 | let files = Sys.ls_dir src in 48 | List.iter files ~f:(fun file -> 49 | let src' = Oci_Filename.make_absolute src file in 50 | let dst' = Oci_Filename.make_absolute dst file in 51 | if List.mem ~equal:Oci_Filename.equal prune_file src' 52 | then () 53 | else begin 54 | let stat = Unix.lstat src' in 55 | match (stat: Unix.stats) with 56 | | { st_uid = 65534 } (* nobody *) | { st_gid = 65534 } (* nogroup *) -> 57 | () 58 | | {st_kind = S_DIR} -> 59 | copydir ~hardlink ~prune_file ~prune_user ~chown src' dst' 60 | | {st_kind = (S_REG | S_LNK); st_uid; st_gid} 61 | when List.mem ~equal:User.equal prune_user 62 | {User.uid=st_uid;gid=st_gid} 63 | -> () 64 | | {st_kind = S_REG} -> 65 | unlink_no_fail dst'; 66 | if hardlink 67 | then Unix.link ~target:src' ~link_name:dst' () 68 | else begin 69 | Shell.run "cp" ["-a";"--";src';dst']; 70 | Unix.chown ~uid ~gid dst' 71 | end 72 | | {st_kind = S_LNK} -> 73 | unlink_no_fail dst'; 74 | let tgt = Unix.readlink src' in 75 | Unix.symlink ~src:tgt ~dst:dst'; 76 | assert (not (Oci_Filename.is_relative dst')); 77 | if hardlink 78 | then () (** keep superroot uid *) 79 | else 80 | ExtUnix.Specific.fchownat 81 | (ExtUnix.Specific.file_descr_of_int 0) (** dumb *) 82 | dst' uid gid 83 | [ExtUnix.Specific.AT_SYMLINK_NOFOLLOW] 84 | | {st_kind = S_BLK|S_FIFO|S_SOCK|S_CHR } -> 85 | raise (Can't_copy_this_file src') 86 | end 87 | ) 88 | 89 | let prune_file = ref[] 90 | let prune_user = ref [] 91 | let hardlink = ref false 92 | let chown = ref {User.uid= -1;gid= -1} 93 | let src = ref "" 94 | let dst = ref "" 95 | 96 | let parse_user s = 97 | match String.split ~on:':' s with 98 | | [uid;gid] -> {User.uid = int_of_string uid; gid = int_of_string gid} 99 | | _ -> raise (Arg.Bad "user format (uid,gid)") 100 | 101 | let descr = 102 | Arg.align [ 103 | "--prune-file",Arg.String (fun s -> prune_file := s::!prune_file), 104 | "file to prune"; 105 | "--prune-user",Arg.String (fun s -> 106 | let u = parse_user s in 107 | prune_user := u::!prune_user), 108 | "file that are own by this user is pruned"; 109 | "--hardlink",Arg.Set hardlink, 110 | "To copy or use hardlink"; 111 | "--chown", Arg.String (fun s -> chown := parse_user s) , 112 | "chown to apply to created file (not hardlinked one)"; 113 | "--src", Arg.Set_string src, 114 | "source directory"; 115 | "--dst", Arg.Set_string dst, 116 | "destination directory"; 117 | ] 118 | 119 | let () = 120 | Caml.Arg.parse descr 121 | (fun _ -> raise (Arg.Bad "doesn't accept anonymous argument")) 122 | "copyhard_link"; 123 | copydir 124 | ~hardlink:(!hardlink) 125 | ~prune_file:(!prune_file) 126 | ~prune_user:(!prune_user) 127 | ~chown:(!chown) 128 | !src 129 | !dst 130 | -------------------------------------------------------------------------------- /src/Oci_Data.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | open Async.Std 25 | open Rpc 26 | 27 | 28 | type ('query,'result) t = { 29 | rpc: ('query,'result Or_error.t) Rpc.t; 30 | log: ('query, 'result Oci_Log.line, Error.t) Pipe_rpc.t; 31 | forget: ('query,unit Or_error.t) Rpc.t; 32 | id : ('query * 'result) Type_equal.Id.t; 33 | } [@@deriving fields] 34 | 35 | exception NoResult 36 | 37 | let register ~name ~version ~bin_query ~bin_result = { 38 | rpc = Rpc.create ~name ~version 39 | ~bin_query ~bin_response:(Or_error.bin_t bin_result); 40 | log = Pipe_rpc.create ~name:(name^" Oci.log") ~version 41 | ~bin_query 42 | ~bin_response:(Oci_Log.bin_line bin_result) 43 | ~bin_error:Error.bin_t 44 | (); 45 | forget = Rpc.create ~name:(name ^ " Oci.forget") 46 | ~version 47 | ~bin_query ~bin_response:(Or_error.bin_t Unit.bin_t); 48 | id = Type_equal.Id.create ~name sexp_of_opaque; 49 | } 50 | 51 | let name t = Rpc.name t.rpc 52 | let version t = Rpc.version t.rpc 53 | -------------------------------------------------------------------------------- /src/Oci_Data.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | 25 | type ('query,'result) t 26 | 27 | val register: 28 | name:string -> 29 | version:int -> 30 | bin_query:'query Core.Std.Bin_prot.Type_class.t -> 31 | bin_result:'result Core.Std.Bin_prot.Type_class.t -> 32 | ('query,'result) t 33 | 34 | open Async.Std 35 | 36 | exception NoResult 37 | 38 | 39 | val name: ('query,'result) t -> string 40 | val version: ('query,'result) t -> int 41 | val rpc: ('query,'result) t -> ('query,'result Or_error.t) Rpc.Rpc.t 42 | (* return the first data of the log, or raise {!NoResult} if none *) 43 | val log: ('query,'result) t -> 44 | ('query, 'result Oci_Log.line, Error.t) Rpc.Pipe_rpc.t 45 | val forget: ('query,'result) t -> ('query, unit Or_error.t) Rpc.Rpc.t 46 | (* If the 'query are memoized forget the previous computation. 47 | does nothing if there is nothing to forget *) 48 | 49 | 50 | val id: ('query,'result) t -> ('query * 'result) Type_equal.Id.t 51 | 52 | -------------------------------------------------------------------------------- /src/Oci_Default_Master.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | 25 | let () = 26 | Oci_Rootfs.init (); 27 | Oci_Generic_Masters.init_compile_git_repo () 28 | 29 | let () = never_returns (Oci_Master.run ()) 30 | -------------------------------------------------------------------------------- /src/Oci_Default_Masters.mllib: -------------------------------------------------------------------------------- 1 | Oci_Generic_Masters 2 | Oci_Generic_Masters_Api 3 | Oci_Rootfs 4 | Oci_Rootfs_Api 5 | Oci_Cmd_Runner_Api -------------------------------------------------------------------------------- /src/Oci_Filename.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | 25 | include FilePath 26 | open Core.Std 27 | 28 | (* include FilePath.UnixPath *) 29 | 30 | type t = String.t [@@deriving sexp, bin_io, compare] 31 | 32 | let pp = String.pp 33 | 34 | let equal = String.equal 35 | 36 | (* let t_of_sexp x = filename_of_string (String.t_of_sexp x) *) 37 | (* let sexp_of_t x = String.sexp_of_t (string_of_filename x) *) 38 | 39 | (* let bin_size_t x = String.bin_size_t (string_of_filename x) *) 40 | (* let bin_write_t c x = String.bin_write_t c (string_of_filename x) *) 41 | 42 | (* let mk = filename_of_string *) 43 | (* let get = string_of_filename *) 44 | 45 | let mk x = x 46 | let get x = x 47 | 48 | let is_subdir ~parent ~children = 49 | equal parent children || is_subdir children parent 50 | let reparent ~oldd ~newd file = reparent oldd newd file 51 | -------------------------------------------------------------------------------- /src/Oci_Generic_Masters.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | open Async.Std 25 | 26 | let binary_name = "Oci_Generic_Masters_Runner" 27 | 28 | (** {2 Git Repo} *) 29 | 30 | module MasterCompileGitRepoArtefact = 31 | Oci_Master.Make 32 | (Oci_Generic_Masters_Api.CompileGitRepo.Query) 33 | (Oci_Generic_Masters_Api.CompileGitRepo.Result) 34 | 35 | exception Dependency_error 36 | 37 | let run_dependency dep dep_name = 38 | let open Oci_Generic_Masters_Api.CompileGitRepo in 39 | let r = Oci_Master.dispatch_master_log ~msg:dep_name rpc dep in 40 | Oci_Log.reader_get_first r 41 | ~f:(function 42 | | `Artefact _ -> true 43 | | `Dependency_error _ -> true 44 | | _ -> false ) (* always the first result *) 45 | >>= function 46 | | `Found (`Artefact artefact) -> 47 | Oci_Master.cha_log "Dependency %s done" dep_name; 48 | return (`Artefact artefact) 49 | | `Found (`Dependency_error s) -> 50 | Oci_Master.err_log 51 | "Some dependencies of %s failed" dep_name; 52 | return (`Dependency_error s) 53 | | `Incomplete -> 54 | Oci_Master.err_log 55 | "Log of dependency %s is incomplete" dep_name; 56 | return (`Error (Error.of_string "incomplete dependency")) 57 | | `Error _ -> 58 | Oci_Master.err_log 59 | "Anomaly for the dependency %s" dep_name; 60 | return (`Error (Error.of_string "anomaly in a dependency")) 61 | | `NotFound | `Found _ -> 62 | Oci_Master.err_log 63 | "Dependency %s failed" dep_name; 64 | return (`Dependency_error (String.Set.singleton dep_name)) 65 | 66 | 67 | let compile_deps = 68 | let open Oci_Generic_Masters_Api.CompileGitRepo in 69 | fun (q:Query.t) -> 70 | let deps = String.Map.remove (Query.used_repos q) q.name in 71 | Deferred.List.map (String.Map.keys deps) 72 | ~how:`Parallel 73 | ~f:(fun dep_name -> 74 | let dep = Query.filter_deps_for {q with name = dep_name} in 75 | run_dependency dep dep_name 76 | ) 77 | (* The order of the application of the artefact is not relevant *) 78 | >>= fun artefacts -> 79 | let result = 80 | List.fold artefacts ~init:(`Artefact []) ~f:(fun acc x -> 81 | match x, acc with 82 | | _, `Error _ -> acc 83 | | `Artefact x, `Artefact acc -> `Artefact (x::acc) 84 | | `Dependency_error x, `Artefact _ -> `Dependency_error x 85 | | `Dependency_error x, `Dependency_error acc -> 86 | `Dependency_error (String.Set.union x acc) 87 | | `Artefact _, `Dependency_error _ -> acc 88 | | `Error err, _ -> `Error err 89 | ) 90 | in 91 | return result 92 | 93 | let exec_runner map_type rpc log runner todo = 94 | let log' = Pipe.init (fun log' -> 95 | Oci_Master.dispatch_runner_log log' rpc runner todo) 96 | in 97 | Pipe.transfer log' log 98 | ~f:(Oci_Log.map_line map_type) 99 | 100 | let artefact_list_hashable = 101 | {Hashtbl.Hashable.sexp_of_t = 102 | [%sexp_of: (string * Oci_Common.Artefact.t list)]; 103 | hash = (fun (s,al) -> 5 * String.hash s + 104 | List.fold_left al ~init:65535 105 | ~f:(fun acc e -> 106 | 7*(Oci_Common.Artefact.hash e) + 9 * acc)); 107 | compare = [%compare: (string * Oci_Common.Artefact.t list)]; 108 | } 109 | 110 | 111 | let run_runner = 112 | let reusable = Oci_Master.reusable_runner 113 | ~debug_info:(fun (name,_) -> sprintf "Run Repo %s" name) 114 | ~hashable_key:artefact_list_hashable 115 | ~binary_name:(fun _ -> binary_name) 116 | (fun ~first runner _ 117 | (log,(todo:Oci_Generic_Masters_Api.CompileGitRepoRunner.Query.t)) -> 118 | let todo = if first then todo else {todo with artefacts = []} in 119 | exec_runner 120 | (fun (x : Oci_Generic_Masters_Api.CompileGitRepoRunner.Result.t) -> 121 | (x :> Oci_Generic_Masters_Api.CompileGitRepo.Result.t)) 122 | Oci_Generic_Masters_Api.CompileGitRepoRunner.rpc 123 | log runner todo) 124 | in 125 | fun name log todo -> 126 | match (todo:Oci_Generic_Masters_Api.CompileGitRepoRunner.Query.t) with 127 | | { save_artefact = false (* todo precise the criteria *) } -> 128 | reusable (name,todo.Oci_Generic_Masters_Api. 129 | CompileGitRepoRunner.Query.artefacts) 130 | (log,todo) 131 | | _ -> 132 | Oci_Master.simple_runner 133 | ~debug_info:(sprintf "Run Repo %s" name) 134 | ~binary_name 135 | (fun runner -> exec_runner 136 | (fun (x : Oci_Generic_Masters_Api.CompileGitRepoRunner.Result.t) -> 137 | (x :> Oci_Generic_Masters_Api.CompileGitRepo.Result.t)) 138 | Oci_Generic_Masters_Api.CompileGitRepoRunner.rpc 139 | log 140 | runner todo) 141 | 142 | let xpra_runner name log todo = 143 | Oci_Master.simple_runner 144 | ~debug_info:(sprintf "Xpra Repo %s" name) 145 | ~binary_name 146 | (fun runner -> 147 | exec_runner 148 | (fun (x : Oci_Generic_Masters_Api.XpraRunner.Result.t) -> 149 | (x :> Oci_Generic_Masters_Api.XpraGitRepo.Result.t)) 150 | Oci_Generic_Masters_Api.XpraRunner.rpc 151 | log 152 | runner todo) 153 | 154 | let run_git_repo q log get_runner = 155 | compile_deps q 156 | >>= function 157 | | `Artefact results -> 158 | let repo = String.Map.find_exn q.repos q.name in 159 | let todo = { 160 | Oci_Generic_Masters_Api.CompileGitRepoRunner.Query.cmds=repo.cmds; 161 | tests=repo.tests; 162 | save_artefact = repo.save_artefact; 163 | artefacts = q.rootfs.rootfs::results; 164 | } in 165 | get_runner q.name log todo 166 | | `Dependency_error s -> 167 | Pipe.write log (Oci_Log.data (`Dependency_error s)) 168 | | `Error err -> Error.raise err 169 | 170 | let compile_git_repo q log = 171 | run_git_repo q log run_runner 172 | 173 | let xpra_git_repo q log = 174 | run_git_repo q log xpra_runner 175 | 176 | let init_compile_git_repo () = 177 | MasterCompileGitRepoArtefact.create_master_unit 178 | Oci_Generic_Masters_Api.CompileGitRepo.rpc 179 | compile_git_repo; 180 | 181 | (* Xpra *) 182 | Oci_Master.register Oci_Generic_Masters_Api.XpraGitRepo.rpc 183 | (Oci_Master.simple_master_unit xpra_git_repo); 184 | 185 | let register_simple_rpc rpc f= 186 | Oci_Master.register rpc 187 | (fun q -> 188 | Oci_Log.init_writer (fun log -> 189 | Monitor.try_with_or_error ~here:[%here] (fun () -> f q) 190 | >>= fun res -> 191 | Oci_Log.write_and_close log res 192 | )) 193 | in 194 | 195 | (* Commit of revspec *) 196 | register_simple_rpc 197 | Oci_Generic_Masters_Api.GitCommitOfRevSpec.rpc 198 | (fun q -> 199 | Oci_Git.commit_of_revspec ~url:q.url ~revspec:q.revspec); 200 | 201 | (* Commit of branch *) 202 | register_simple_rpc 203 | Oci_Generic_Masters_Api.GitCommitOfBranch.rpc 204 | (fun q -> 205 | Oci_Git.commit_of_branch ~url:q.url ~branch:q.branch); 206 | 207 | (* merge base *) 208 | register_simple_rpc 209 | Oci_Generic_Masters_Api.GitMergeBase.rpc 210 | (fun q -> 211 | Oci_Git.merge_base ~url:q.url q.commit1 q.commit1); 212 | 213 | (* last commit before *) 214 | register_simple_rpc 215 | Oci_Generic_Masters_Api.GitLastCommitBefore.rpc 216 | (fun q -> 217 | Oci_Git.last_commit_before ~url:q.url ~branch:q.branch 218 | ~time:q.time); 219 | 220 | (* time of commit *) 221 | register_simple_rpc 222 | Oci_Generic_Masters_Api.GitTimeOfCommit.rpc 223 | (fun q -> 224 | Oci_Git.time_of_commit ~url:q.url ~commit:q.commit); 225 | 226 | (* download_file *) 227 | register_simple_rpc 228 | Oci_Generic_Masters_Api.WgetDownloadFile.rpc 229 | (fun q -> 230 | Oci_Wget.download_file ~url:q.url ~kind:q.kind 231 | ~checksum:q.checksum 232 | ) 233 | 234 | -------------------------------------------------------------------------------- /src/Oci_Generic_Masters.mllib: -------------------------------------------------------------------------------- 1 | Oci_Generic_Masters 2 | Oci_Generic_Masters_Api -------------------------------------------------------------------------------- /src/Oci_Generic_Masters_Runner.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | open Async.Std 25 | 26 | open Oci_Generic_Masters_Api.CompileGitRepoRunner 27 | 28 | let create_dir t (q:Query.t) = 29 | let working_dir = "/checkout" in 30 | Oci_Runner.cha_log t "Link Artefacts"; 31 | Deferred.List.iter 32 | ~f:(fun artefact -> 33 | Oci_Runner.link_artefact t artefact ~dir:"/" 34 | ) q.artefacts 35 | >>= fun () -> 36 | Unix.mkdir ~p:() working_dir 37 | >>= fun () -> 38 | Oci_Runner.run_exn t 39 | ~prog:"mount" 40 | ~args:["-t";"tmpfs";"tmpfs";working_dir] () 41 | >>= fun () -> 42 | return working_dir 43 | 44 | let memory_resource = 45 | match Core.Std.Unix.RLimit.virtual_memory with 46 | | Ok r -> r 47 | | Error _ -> Core.Std.Unix.RLimit.data_segment 48 | 49 | (** work because we don't run tests in parallel, 50 | and because we suppose this runner doesn't take too much memory *) 51 | let memlimit f m = 52 | let setrlimit m = 53 | In_thread.syscall_exn ~name:"setrlimit" 54 | Core.Std.Unix.RLimit.(fun () -> 55 | set memory_resource m) 56 | in 57 | let getrlimit () = 58 | In_thread.syscall_exn ~name:"getrlimit" 59 | Core.Std.Unix.RLimit.(fun () -> 60 | get memory_resource) 61 | in 62 | getrlimit () 63 | >>= fun old -> 64 | setrlimit {old with cur= Limit (Int64.of_float (Byte_units.bytes m))} 65 | >>= fun () -> 66 | f () 67 | >>= fun r -> 68 | setrlimit old 69 | >>= fun () -> 70 | return r 71 | 72 | 73 | let run_cmds t kind working_dir 74 | (x:Oci_Generic_Masters_Api.CompileGitRepoRunner.cmd) = 75 | match x with 76 | | `CopyFile copy -> 77 | Oci_Runner.cha_log t "Copy file %s" copy.checksum; 78 | Oci_Runner.get_file t 79 | ~checksum:copy.checksum 80 | ~kind:copy.kind 81 | ~dst:(Oci_Filename.make_absolute working_dir copy.dst) 82 | | `GitClone clone -> 83 | Oci_Runner.cha_log t "Clone repository at %s" 84 | (Oci_Common.Commit.to_string clone.commit); 85 | Oci_Runner.git_clone t 86 | ~user:Root 87 | ~url:clone.url 88 | ~dst:(Oci_Filename.make_absolute working_dir clone.directory) 89 | ~commit:clone.commit 90 | | `GitCopyFile show_file -> 91 | Oci_Runner.cha_log t "Show file %s at %s to %s" 92 | show_file.src 93 | (Oci_Common.Commit.to_string show_file.commit) 94 | show_file.dst; 95 | Oci_Runner.git_copy_file t 96 | ~user:Root 97 | ~url:show_file.url 98 | ~src:show_file.src 99 | ~dst:(Oci_Filename.make_absolute working_dir show_file.dst) 100 | ~commit:show_file.commit 101 | | `Exec cmd -> 102 | Oci_Runner.get_release_proc t cmd.proc_requested 103 | (fun got -> 104 | let args = 105 | List.map cmd.args 106 | ~f:(function 107 | | `S s -> s 108 | | `Proc s -> 109 | let fmt = (Oci_Generic_Masters_Api. 110 | CompileGitRepoRunner.Formatted_proc.get s) in 111 | Printf.sprintf fmt got) 112 | in 113 | let wrap f = 114 | match cmd.memlimit with 115 | | None -> f () 116 | | Some m -> memlimit f m 117 | in 118 | wrap (fun () -> 119 | Oci_Runner.run_timed t 120 | ?timelimit:cmd.timelimit 121 | ~working_dir:(Oci_Filename.make_absolute working_dir 122 | cmd.working_dir) 123 | ~prog:cmd.cmd ~args 124 | ~env:(cmd.env :> Async.Std.Process.env) () 125 | ) 126 | >>= fun r -> 127 | match kind, r with 128 | | `Test, (r,i) -> 129 | Oci_Runner.data_log t (`Cmd (cmd,r,i)); 130 | return () 131 | | `Required, (Ok () as r,i) -> 132 | Oci_Runner.data_log t (`Cmd (cmd,r,i)); 133 | return () 134 | | `Required, (r,i) -> 135 | Oci_Runner.data_log t (`Cmd (cmd,r,i)); 136 | raise Oci_Runner.StopQuery 137 | ) 138 | 139 | 140 | let compile_git_repo_runner t q = 141 | create_dir t q 142 | >>= fun working_dir -> 143 | Deferred.List.iter ~f:(run_cmds t `Required working_dir) q.cmds 144 | >>= fun () -> begin 145 | if q.save_artefact 146 | then Oci_Runner.create_artefact t 147 | ~dir:"/" 148 | ~prune:[working_dir] 149 | else Deferred.return Oci_Common.Artefact.empty 150 | end 151 | >>= fun artefact -> 152 | Oci_Runner.data_log t (`Artefact artefact); 153 | Deferred.List.iter ~f:(run_cmds t `Test working_dir) q.tests 154 | >>= fun () -> 155 | Oci_Runner.run_exn t ~prog:"umount" ~args:[working_dir] () 156 | 157 | 158 | (* 159 | let tmux_runner t q = 160 | create_dir_and_run t q 161 | >>= fun (working_dir,_) -> 162 | let tmux_socket = Oci_Filename.make_absolute working_dir "tmux_socket" in 163 | Oci_Runner.cha_log t "Run TMux"; 164 | Oci_Runner.run_exn t ~working_dir ~prog:"ls" 165 | ~args:["-l";"/"] () 166 | >>= fun () -> 167 | (* Oci_Runner.run_exn t ~working_dir ~prog:"strace" *) 168 | (* ~args:["-f";"-v";"tmux";"-vvv"; *) 169 | (* "-S";tmux_socket;"start-server";";";"new-session";"-d"; *) 170 | (* ";";"wait-for";"test"] () *) 171 | (* >>= fun () -> *) 172 | (* Oci_Runner.run_exn t ~working_dir ~prog:"tmux" *) 173 | (* ~args:["-vvv"; *) 174 | (* "-S";tmux_socket;"start-server";";";"new-session";"-d"; *) 175 | (* ";";"wait-for";"test"] () *) 176 | Unix.mkdir ~p:() ~perm:0o777 (Oci_Filename.concat working_dir ".xpra") 177 | >>= fun () -> 178 | Oci_Runner.run_exn t ~working_dir ~prog:"xpra" 179 | ~args:["start";":7";"--no-daemon";"--socket-dir";working_dir;"--no-mmap"; 180 | "--start-child=xterm";"--exit-with-children";"--no-mdns"; 181 | "--no-notifications";"--no-speaker";"--no-microphone"] () 182 | >>= fun () -> 183 | (* Unix.chmod tmux_socket ~perm:0o666 *) 184 | (* >>= fun () -> *) 185 | (* Oci_Runner.run_exn t ~working_dir ~prog:"tmux" *) 186 | (* ~args:["-S";tmux_socket;"has";";";"wait-for";"test"] () *) 187 | (* >>= fun () -> *) 188 | Oci_Runner.give_external_access t tmux_socket 189 | *) 190 | 191 | let xpra_runner t q = 192 | create_dir t q 193 | >>= fun working_dir -> 194 | Deferred.List.iter ~f:(run_cmds t `Required working_dir) q.cmds 195 | >>= fun () -> 196 | Deferred.List.iter ~f:(run_cmds t `Test working_dir) q.tests 197 | >>= fun () -> 198 | let xpra_dir = Oci_Filename.make_absolute "/oci" "xpra_socket" in 199 | Unix.mkdir ~p:() ~perm:0o777 xpra_dir 200 | >>= fun () -> 201 | Unix.mkdir ~p:() ~perm:0o777 202 | (Oci_Filename.make_absolute working_dir ".xpra") 203 | >>= fun () -> 204 | let xpra = 205 | Oci_Runner.run_exn t 206 | ~working_dir 207 | ~prog:"xpra" 208 | ~args:["start";":100";"--no-daemon";"--socket-dir";xpra_dir; 209 | "--start-child=xterm";"--exit-with-children"; 210 | "--no-mmap";"--no-mdns"; 211 | "--no-notifications"; 212 | "--no-speaker";"--no-microphone"] 213 | ~env:(`Extend ["XPRA_SOCKET_HOSTNAME","oci"]) 214 | () 215 | in 216 | let xpra_socket = Oci_Filename.make_absolute xpra_dir "oci-100" in 217 | Sys.when_file_exists xpra_socket 218 | >>= fun () -> 219 | Unix.chmod ~perm:0o666 xpra_socket 220 | >>= fun () -> 221 | Oci_Runner.give_external_access t xpra_dir 222 | >>= fun external_dir -> 223 | let xpra_script = "remote-xpra.sh" in 224 | let remote_xpra = Oci_Filename.make_absolute xpra_dir xpra_script in 225 | Writer.open_file remote_xpra 226 | >>= fun writer -> 227 | Writer.writef writer "#!/bin/sh -ue\n\n"; 228 | Writer.writef writer "export XPRA_SOCKET_HOSTNAME=oci\n"; 229 | Writer.writef writer "export XPRA_SOCKET_DIR=%s\n\n" external_dir; 230 | Writer.writef writer "exec xpra \"$@\""; 231 | Writer.close writer 232 | >>= fun () -> 233 | Unix.chmod ~perm:0o555 remote_xpra 234 | >>= fun () -> 235 | Oci_Runner.data_log t (`XpraDir external_dir); 236 | Oci_Runner.cha_log t 237 | "Run locally: XPRA_SOCKET_HOSTNAME=oci xpra attach :100 --socket-dir %S" 238 | external_dir; 239 | Oci_Runner.cha_log t 240 | "Run remotely: xpra attach --remote-xpra %S ssh:HOST:100" 241 | (Oci_Filename.make_absolute external_dir xpra_script); 242 | xpra 243 | 244 | 245 | let () = 246 | never_returns begin 247 | Oci_Runner.start 248 | ~implementations:[ 249 | Oci_Runner.implement_unit 250 | Oci_Generic_Masters_Api.CompileGitRepoRunner.rpc 251 | compile_git_repo_runner; 252 | Oci_Runner.implement_unit 253 | Oci_Generic_Masters_Api.XpraRunner.rpc 254 | xpra_runner; 255 | ] 256 | end 257 | -------------------------------------------------------------------------------- /src/Oci_Git.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | open Async.Std 25 | 26 | 27 | val clone: 28 | user:Oci_Common.user_kind -> 29 | url:String.t -> 30 | dst:Oci_Filename.t -> 31 | commit:Oci_Common.Commit.t -> 32 | unit Deferred.t 33 | 34 | val copy_file: 35 | user:Oci_Common.user_kind -> 36 | url:String.t -> 37 | src:Oci_Filename.t -> 38 | dst:Oci_Filename.t -> 39 | commit:Oci_Common.Commit.t -> 40 | unit Deferred.t 41 | 42 | val read_file: 43 | url:String.t -> 44 | src:Oci_Filename.t -> 45 | commit:Oci_Common.Commit.t -> 46 | string Deferred.t 47 | 48 | val merge_base: 49 | url:String.t -> 50 | Oci_Common.Commit.t -> 51 | Oci_Common.Commit.t -> 52 | Oci_Common.Commit.t Deferred.t 53 | 54 | val commit_of_revspec: 55 | url:String.t -> 56 | revspec:String.t -> 57 | Oci_Common.Commit.t option Deferred.t 58 | 59 | val commit_of_branch: 60 | url:String.t -> 61 | branch:String.t -> 62 | Oci_Common.Commit.t option Deferred.t 63 | 64 | val last_commit_before: 65 | url:String.t -> 66 | branch:String.t -> 67 | time:Time.t -> 68 | Oci_Common.Commit.t option Deferred.t 69 | 70 | val time_of_commit: 71 | url:String.t -> 72 | commit:Oci_Common.Commit.t -> 73 | Time.t Deferred.t 74 | 75 | val init: 76 | dir:string -> 77 | register_saver:(loader:(unit -> unit Deferred.t) -> 78 | saver:(unit -> unit Deferred.t) -> 79 | unit) -> 80 | identity_file:string option -> 81 | unit 82 | -------------------------------------------------------------------------------- /src/Oci_Log.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | open Async.Std 25 | 26 | let version = 2 27 | 28 | type kind = 29 | | Standard | Error | Chapter | Command 30 | [@@deriving sexp, bin_io] 31 | 32 | type 'a data = 33 | | Std of kind * string 34 | | Extra of 'a 35 | | End of unit Or_error.t 36 | [@@deriving sexp, bin_io] 37 | 38 | type 'a line = { 39 | data : 'a data; 40 | time : Time.t; 41 | } [@@deriving sexp, bin_io] 42 | 43 | (* let line_invariant line = not (String.contains line.line '\n') *) 44 | 45 | let line kind line = 46 | {data=Std(kind,line);time=Time.now ()} 47 | let data data = 48 | {data=Extra data;time=Time.now ()} 49 | let _end e = 50 | {data=End e;time=Time.now ()} 51 | 52 | let map_line f = function 53 | | { data = Extra x; time } -> {data = Extra(f x); time } 54 | | { data = (Std _ | End _) } as x -> x 55 | 56 | let color_of_kind = function 57 | | Standard -> `Black 58 | | Error -> `Red 59 | | Chapter -> `Underscore 60 | | Command -> `Blue 61 | 62 | type 'result writer = 'result line Pipe.Writer.t 63 | let close_writer w e = 64 | Pipe.write w (_end e) 65 | >>= fun () -> 66 | Pipe.close w; 67 | Deferred.unit 68 | 69 | let write_and_close w e = 70 | begin match (e:'r Or_error.t) with 71 | | Ok r -> 72 | Pipe.write w (data r) 73 | >>= fun () -> 74 | Pipe.write w (_end (Ok ())) 75 | | Error e -> 76 | Pipe.write w (_end (Error e)) 77 | end 78 | >>= fun () -> 79 | Pipe.close w; 80 | Deferred.unit 81 | 82 | type 'result reader = {mutable state: (unit -> 'result line Pipe.Reader.t)} 83 | 84 | let reader t = {state = fun () -> Oci_Queue.reader t} 85 | let read t = t.state () 86 | let create () = Oci_Queue.create () 87 | let close = Oci_Queue.close 88 | let init f = 89 | let log = create () in 90 | don't_wait_for (f log >>= fun () -> close log); 91 | reader log 92 | let init_writer f = 93 | init (fun log -> f (Oci_Queue.writer log)) 94 | 95 | let reader_stop_after ~f t = { 96 | state = fun () -> 97 | let reached = ref false in 98 | Pipe.filter (t.state ()) ~f:(function 99 | | _ when !reached -> false 100 | | { data = (Std _ | End _) } -> true 101 | | { data= Extra e } -> 102 | if f e then reached := true; 103 | true 104 | ) 105 | } 106 | 107 | let reader_get_first ~f t = 108 | let rec aux r = 109 | Pipe.read' r 110 | >>= function 111 | | `Eof -> return `Incomplete 112 | | `Ok q -> 113 | match 114 | Queue.find_map q ~f:(function 115 | | { data = Extra e } when f e -> Some (`Found e) 116 | | { data = End (Ok ()) } -> Some `NotFound 117 | | { data = End (Error err) } -> Some (`Error err) 118 | | _ -> None) 119 | with 120 | | None -> aux r 121 | | Some x -> return x 122 | in 123 | aux (t.state ()) 124 | 125 | exception Closed_Log 126 | 127 | module Make(S: sig 128 | val dir: Oci_Filename.t Deferred.t 129 | val register_saver: 130 | loader:(unit -> unit Deferred.t) -> 131 | saver:(unit -> unit Deferred.t) -> 132 | unit 133 | type t [@@deriving bin_io] 134 | end) = struct 135 | module Log_Id : Int_intf.S = Int 136 | 137 | include Log_Id 138 | 139 | let next_id = ref (of_int_exn 0) 140 | let null : t = (of_int_exn 0) 141 | 142 | (** The database of log being currently, the one that already ended 143 | (in this session or a previous one) are stored on disk 144 | *) 145 | let db_log: (S.t line Oci_Queue.t * S.t reader) Table.t = Table.create () 146 | 147 | let dir = S.dir 148 | >>= fun dir -> 149 | let dir = Oci_Filename.make_absolute dir (sprintf "v%i" version) in 150 | Unix.mkdir ~p:() dir 151 | >>= fun () -> return dir 152 | 153 | let log_file id = 154 | dir 155 | >>= fun d -> 156 | return (Oci_Filename.make_absolute d (to_string id)) 157 | 158 | let read_from_file id = 159 | Pipe.init (fun w -> 160 | log_file id 161 | >>= fun file -> 162 | Reader.open_file file 163 | >>= fun reader -> 164 | let pipe,_ = Unpack_sequence.unpack_into_pipe 165 | ~from:(Unpack_sequence.Unpack_from.Reader reader) 166 | ~using:(Unpack_buffer.create_bin_prot 167 | (bin_reader_line S.bin_reader_t)) in 168 | Pipe.transfer_id pipe w 169 | >>= fun () -> 170 | Reader.close reader 171 | ) 172 | 173 | let read id = 174 | match Table.find db_log id with 175 | | None -> read_from_file id 176 | | Some (q,_) -> Oci_Queue.reader q 177 | 178 | let reader id = 179 | match Table.find db_log id with 180 | | None -> { state = fun () -> read_from_file id } 181 | | Some (_,r) -> r 182 | 183 | let writer id = 184 | match Table.find db_log id with 185 | | None -> raise Closed_Log 186 | | Some (q,_) -> Oci_Queue.writer q 187 | 188 | let create () = 189 | incr next_id; 190 | let id = !next_id in 191 | (* create the queue storage *) 192 | let q = Oci_Queue.create () in 193 | let r = { state = fun () -> Oci_Queue.reader q } in 194 | Table.add_exn db_log ~key:id ~data:(q,r); 195 | (* write to disk *) 196 | don't_wait_for begin 197 | log_file id 198 | >>= fun log_file -> 199 | let log_file_part = Oci_Filename.add_extension log_file "part" in 200 | Writer.open_file log_file_part 201 | >>= fun writer -> 202 | (* When the log end, new readers will read from the file *) 203 | Writer.transfer writer 204 | (Oci_Queue.reader q) 205 | (Writer.write_bin_prot writer 206 | (bin_writer_line S.bin_writer_t)) 207 | >>= fun () -> 208 | Writer.close writer 209 | >>= fun () -> 210 | Unix.rename ~src:log_file_part ~dst:log_file 211 | >>= fun () -> 212 | r.state <- (fun () -> read_from_file id); 213 | Table.remove db_log id; 214 | return () 215 | end; 216 | id 217 | 218 | let transfer id p = 219 | match Table.find db_log id with 220 | | None -> raise Closed_Log 221 | | Some (q,_) -> Oci_Queue.transfer_id q p 222 | 223 | let add_without_pushback id line = 224 | match Table.find db_log id with 225 | | None -> raise Closed_Log 226 | | Some (q,_) -> Oci_Queue.add_without_pushback q line 227 | 228 | let close id = 229 | match Table.find db_log id with 230 | | None -> return () 231 | | Some (q,_) -> Oci_Queue.close q 232 | 233 | let is_closed id = not (Table.mem db_log id) 234 | 235 | let () = 236 | let data = 237 | dir 238 | >>= fun dir -> 239 | return (Oci_Filename.make_absolute dir "data") in 240 | S.register_saver 241 | ~loader:(fun () -> 242 | data >>= fun data -> 243 | Oci_Std.read_if_exists data bin_reader_t 244 | (fun x -> next_id := x; return ()) 245 | >>= fun () -> 246 | (* create null file *) 247 | log_file null 248 | >>= fun log_file -> 249 | Writer.open_file log_file 250 | >>= fun writer -> 251 | Writer.close writer 252 | ) 253 | ~saver:(fun () -> 254 | data >>= fun data -> 255 | Oci_Std.backup_and_open_file data 256 | >>= fun writer -> 257 | Writer.write_bin_prot writer bin_writer_t !next_id; 258 | Writer.close writer 259 | ) 260 | 261 | end 262 | -------------------------------------------------------------------------------- /src/Oci_Log.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | open Async.Std 25 | 26 | type kind = 27 | | Standard | Error | Chapter | Command 28 | [@@deriving sexp, bin_io] 29 | 30 | val color_of_kind: kind -> [> `Black | `Underscore | `Red | `Blue] 31 | 32 | type 'a data = 33 | | Std of kind * string 34 | | Extra of 'a 35 | | End of unit Or_error.t 36 | [@@deriving sexp, bin_io] 37 | 38 | type 'a line = { 39 | data : 'a data; 40 | time : Time.t; 41 | } [@@deriving sexp, bin_io] 42 | 43 | val line: kind -> string -> 'a line 44 | val data: 'a -> 'a line 45 | val _end: unit Or_error.t -> 'a line 46 | 47 | val map_line: ('a -> 'b) -> 'a line -> 'b line 48 | 49 | type 'result writer = 'result line Pipe.Writer.t 50 | val close_writer: 'result writer -> unit Or_error.t -> unit Deferred.t 51 | val write_and_close: 'result writer -> 'result Or_error.t -> unit Deferred.t 52 | 53 | (** alive log *) 54 | 55 | type 'result reader 56 | val read: 'result reader -> 'result line Pipe.Reader.t 57 | val init_writer: ('result writer -> unit Deferred.t) -> 'result reader 58 | 59 | val reader_stop_after: 60 | f:('result -> bool) -> 'result reader -> 'result reader 61 | val reader_get_first: 62 | f:('result -> bool) -> 'result reader -> 63 | [`Found of 'result | `Incomplete | `NotFound | `Error of Error.t] Deferred.t 64 | 65 | exception Closed_Log 66 | 67 | module Make(S: sig 68 | val dir: Oci_Filename.t Deferred.t 69 | val register_saver: 70 | loader:(unit -> unit Deferred.t) -> 71 | saver:(unit -> unit Deferred.t) -> 72 | unit 73 | type t [@@deriving bin_io] 74 | end): sig 75 | 76 | type t 77 | (** saved log *) 78 | 79 | include Binable.S with type t := t 80 | 81 | val create: unit -> t 82 | val null: t 83 | (** a log without any line *) 84 | 85 | val transfer: t -> S.t line Pipe.Reader.t -> unit Deferred.t 86 | val add_without_pushback: t -> S.t line -> unit 87 | val close: t -> unit Deferred.t 88 | 89 | val read: t -> S.t line Pipe.Reader.t 90 | val reader: t -> S.t reader 91 | val writer: t -> S.t writer 92 | val is_closed: t -> bool 93 | end 94 | -------------------------------------------------------------------------------- /src/Oci_Master.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | open Async.Std 25 | 26 | (** {2 Simple API} *) 27 | 28 | val run: unit -> never_returns 29 | (** Once all the masters have been registered *) 30 | 31 | type runner 32 | 33 | module Make (Query: Hashtbl.Key_binable) (Result : Binable.S) : sig 34 | 35 | val create_master: 36 | (Query.t,Result.t) Oci_Data.t -> 37 | (Query.t -> Result.t Deferred.t) -> 38 | unit 39 | 40 | val create_master_unit: 41 | (Query.t,Result.t) Oci_Data.t -> 42 | (Query.t -> Result.t Oci_Log.writer -> unit Deferred.t) -> 43 | unit 44 | 45 | val create_master_and_runner: 46 | (Query.t,Result.t) Oci_Data.t -> 47 | ?binary_name:string -> 48 | ?error:(Error.t -> Result.t) -> 49 | (runner -> Query.t -> Result.t Deferred.t) -> 50 | unit 51 | 52 | val create_master_and_reusable_runner: 53 | (Query.t,Result.t) Oci_Data.t -> 54 | ?binary_name:string -> 55 | ?error:(Error.t -> Result.t) -> 56 | hashable_key:'k Hashtbl.Hashable.t -> 57 | extract_key:(Query.t -> 'k) -> 58 | ?timeout:Time.Span.t -> 59 | (first:bool -> runner -> Query.t -> Result.t Deferred.t) -> 60 | unit 61 | 62 | end 63 | 64 | val dispatch_runner: 65 | ?msg:string -> 66 | ('query,'result) Oci_Data.t -> 67 | runner -> 68 | 'query -> 'result Or_error.t Deferred.t 69 | val dispatch_runner_exn: 70 | ?msg:string -> 71 | ('query,'result) Oci_Data.t -> 72 | runner -> 73 | 'query -> 'result Deferred.t 74 | 75 | val dispatch_runner_log: 76 | ?msg:string -> 77 | 'result Oci_Log.writer -> 78 | ('query,'result) Oci_Data.t -> 79 | runner -> 80 | 'query -> unit Deferred.t 81 | 82 | val dispatch_master: 83 | ?msg:string -> 84 | ('query,'result) Oci_Data.t -> 85 | 'query -> 'result Or_error.t Deferred.t 86 | val dispatch_master_exn: 87 | ?msg:string -> 88 | ('query,'result) Oci_Data.t -> 89 | 'query -> 'result Deferred.t 90 | val dispatch_master_log: 91 | ?msg:string -> 92 | ('query,'result) Oci_Data.t -> 93 | 'query -> 'result Oci_Log.reader 94 | 95 | 96 | val attach_log: 'a Oci_Log.writer -> (unit -> 'b) -> 'b 97 | val std_log: ('a, unit, string, unit) format4 -> 'a 98 | val err_log: ('a, unit, string, unit) format4 -> 'a 99 | val cha_log: ('a, unit, string, unit) format4 -> 'a 100 | val cmd_log: ('a, unit, string, unit) format4 -> 'a 101 | 102 | (** {2 Expert API} *) 103 | 104 | val oci_at_shutdown: (unit -> unit Deferred.t) -> unit 105 | (** Run when the masters will stop *) 106 | 107 | val register: 108 | ?forget: ('query -> unit Or_error.t Deferred.t) -> 109 | ('query,'result) Oci_Data.t -> 110 | ('query -> 'result Oci_Log.reader) -> 111 | unit 112 | (** There is only one master of a given sort by session. It must keep 113 | track of which tasks are running, and which tasks have been 114 | already run. *) 115 | 116 | val simple_register_saver: 117 | ?init:(unit -> unit Deferred.t) -> 118 | basename:string -> 119 | loader:('data_to_save -> unit Deferred.t) -> 120 | saver:(unit -> 'data_to_save Deferred.t) -> 121 | ('query, 'result) Oci_Data.t -> 122 | 'data_to_save Bin_prot.Type_class.t -> 123 | unit 124 | 125 | val simple_runner: 126 | debug_info:string -> 127 | binary_name:string -> 128 | ?error:(Error.t -> 'a) -> 129 | (runner -> 'a Deferred.t) -> 130 | 'a Deferred.t 131 | 132 | val simple_master: 133 | ('a -> 'b Deferred.t) -> 134 | 'a -> 'b Oci_Log.reader 135 | 136 | val simple_master_unit: 137 | ('a -> 'result Oci_Log.writer -> unit Deferred.t) -> 138 | 'a -> 'result Oci_Log.reader 139 | 140 | val register_saver: 141 | name:string -> 142 | loader:(unit -> unit Deferred.t) -> 143 | saver:(unit -> unit Deferred.t) -> 144 | unit 145 | 146 | type slot 147 | 148 | val start_runner: 149 | debug_info:string -> 150 | binary_name:string -> 151 | ?slot:slot -> 152 | unit -> 153 | (unit Or_error.t Deferred.t * runner) Async.Std.Deferred.t 154 | (** Start the given runner in a namespace and start an Rpc connection. 155 | `start_runner ~binary_name` start the executable 156 | [binary_name^".native"] located in the directory of binaries. 157 | Return a pair of defered the first one is determined in case of 158 | error of the process, the second one is determined when the 159 | connection is established. 160 | *) 161 | 162 | val reusable_runner: 163 | hashable_key:'k Hashtbl.Hashable.t -> 164 | debug_info:('k -> string) -> 165 | binary_name:('k -> string) -> 166 | ?timeout:Time.Span.t -> 167 | ?error:('k -> 'd -> Error.t -> 'a) -> 168 | (first:bool -> runner -> 'k -> 'd -> 'a Deferred.t) -> 169 | (* partial application *) 170 | 'k -> 'd -> 'a Deferred.t 171 | 172 | 173 | val stop_runner: runner -> unit Deferred.t 174 | (** Ask or force the runner to stop *) 175 | 176 | val alloc_slot: unit -> slot Async.Std.Deferred.t 177 | 178 | val freeze_runner: runner -> unit Deferred.t 179 | val unfreeze_runner: runner -> slot -> unit Deferred.t 180 | 181 | val permanent_directory: 182 | ('query,'result) Oci_Data.t -> Oci_Filename.t Deferred.t 183 | (** Give the permanent directory for this master *) 184 | 185 | val oci_version: string 186 | -------------------------------------------------------------------------------- /src/Oci_Master_Tools.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | 24 | open Core.Std 25 | open Oci_Common 26 | open ExtUnix.Specific 27 | open Oci_Wrapper_Lib 28 | 29 | 30 | let get_etc_sub_config ~user ~file = 31 | let l = In_channel.read_lines file in 32 | match List.find_map l ~f:(fun s -> 33 | match String.split s ~on:':' with 34 | | [u;start;len] when String.equal u user -> 35 | Some (Int.of_string start,Int.of_string len) 36 | | _ -> None 37 | ) with 38 | | Some s -> s 39 | | None -> 40 | eprintf "This user doesn't have subuid or subgid configured (cf %s) \n%!" 41 | file; 42 | exit 1 43 | 44 | let default_env = ["PATH","/usr/local/bin:/usr/bin:/bin"] 45 | let rungid = 0 46 | let runuid = 0 47 | 48 | let first_user_mapped = 49 | let ug = User_and_group.for_this_process_exn () in 50 | let ustart,ulen = 51 | get_etc_sub_config ~user:(User_and_group.user ug) ~file:"/etc/subuid" in 52 | let gstart, glen = 53 | get_etc_sub_config ~user:(User_and_group.user ug) ~file:"/etc/subgid" in 54 | if ulen < 1001 || glen < 1001 then begin 55 | eprintf 56 | "This user doesn't have enough subuid or \ 57 | subgid configured (1001 needed)\n%!"; 58 | exit 1 59 | end; 60 | {User.uid=ustart;gid=gstart} 61 | 62 | let idmaps = 63 | Oci_Wrapper_Api.idmaps 64 | ~first_user_mapped:first_user_mapped 65 | ~in_user:master_user 66 | [Superroot,1;Root,1000;User,1] 67 | 68 | let run_inside f = 69 | if Unix.getuid () = 0 then begin 70 | Printf.eprintf "This program shouldn't be run as root!\n%!"; 71 | exit 1 72 | end; 73 | Unix.handle_unix_error begin fun () -> 74 | (* remove the process from the group of the process monitor, and 75 | detach it from the controlling terminal. It allows to manage the 76 | shutdown nicely *) 77 | let _sessionid = Core.Std.Caml.Unix.setsid () in 78 | test_userns_availability (); 79 | (* Option.iter rootfs ~f:(mkdir ~perm:0o750); *) 80 | go_in_userns idmaps; 81 | (* group must be changed before uid... *) 82 | setresgid rungid rungid rungid; 83 | setresuid runuid runuid runuid; 84 | let _sessionid = Core.Std.Caml.Unix.setsid () in 85 | f () 86 | end () 87 | 88 | 89 | let exec prog args = 90 | run_inside (fun () -> 91 | never_returns 92 | (Unix.exec 93 | ~prog 94 | ~env:(`Replace default_env) 95 | ~args:(prog::args) ())) 96 | 97 | let clean dryrun = 98 | let prog = "rm" in 99 | let args = ["-r";"-f";Oci_Version.default_oci_data] in 100 | if dryrun 101 | then exec "echo" (prog::args) 102 | else exec prog args 103 | 104 | open Cmdliner 105 | 106 | let exec = 107 | let prog = 108 | Arg.(value & pos 0 string "bash" & info [] 109 | ~docv:"prog" 110 | ~doc:"command to execute.") 111 | in 112 | let args = 113 | Arg.(value & pos_right 0 string [] & info [] 114 | ~docv:"arg" 115 | ~doc:"parameter of the command to execute.") 116 | in 117 | let doc = "execute the command with the same right than a master" in 118 | let man = [ 119 | `S "DESCRIPTION"; 120 | `P "Execute the given command with the given arguments inside the same \ 121 | kind of container that the one used by masters. Mainly for debugging. \ 122 | As usual options placed after a double hyphen (--) could start with an \ 123 | hyphen (-)."] 124 | in 125 | Term.(const exec $ prog $ args), 126 | Term.info "exec" ~doc ~man 127 | 128 | 129 | let clean = 130 | let dryrun = 131 | Arg.(value & flag & info ["n";"dry-run"] 132 | ~doc:"Create the container and print the command that would be run.") 133 | in 134 | let doc = "remove the data created by the master" in 135 | let man = [ 136 | `S "DESCRIPTION"; 137 | `P "The data created by the master use the subuid of the user. \ 138 | So one can't remove them with just an rm. This command run the command \ 139 | inside a container correctly configured"] 140 | in 141 | Term.(const clean $ dryrun), 142 | Term.info "clean" ~doc ~man 143 | 144 | 145 | let cmds = [exec;clean] 146 | 147 | let default_cmd = 148 | Term.(ret (const (`Help (`Pager, None)))), 149 | Term.info "oci_master_tools" ~version:Oci_Version.version 150 | 151 | let () = 152 | match Term.eval_choice default_cmd cmds with 153 | | `Error _ -> exit 1 154 | | `Ok () -> exit 0 155 | | `Help | `Version -> exit 0 156 | -------------------------------------------------------------------------------- /src/Oci_Queue.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | (** Queue on which reader can wait *) 24 | 25 | (** I was not able to find something like that in Core/Async 26 | Async_stream seems deprecated and doesn't keep previous value 27 | *) 28 | 29 | open Core.Std 30 | open Async.Std 31 | 32 | type 'a queue = 33 | | Eof 34 | | Next of 'a queue Deferred.t * 'a 35 | 36 | type 'a t = { 37 | source: 'a Pipe.Writer.t; 38 | first: 'a queue Deferred.t; 39 | mutable next: 'a queue Ivar.t; 40 | } 41 | 42 | 43 | let rec transfer_from_source t r = 44 | Pipe.read' r 45 | >>= function 46 | | `Eof -> Ivar.fill t.next Eof; Deferred.unit 47 | | `Ok q -> 48 | assert (Ivar.is_empty t.next); (* 49 | otherwise used after eof *) 50 | let new_next = Queue.fold 51 | ~f:(fun next v -> 52 | let new_next = Ivar.create () in 53 | let new_last = Next(Ivar.read new_next,v) in 54 | Ivar.fill next new_last; 55 | new_next 56 | ) ~init:t.next q in 57 | t.next <- new_next; 58 | transfer_from_source t r 59 | 60 | let create () = 61 | let first = Ivar.create () in 62 | let reader, source = Pipe.create () in 63 | let t = { 64 | source; 65 | first = Ivar.read first; 66 | next = first; 67 | } in 68 | don't_wait_for (transfer_from_source t reader); 69 | t 70 | 71 | 72 | let reader t = 73 | Pipe.init (fun writer -> 74 | let rec get q = 75 | q 76 | >>= function 77 | | Eof -> return () 78 | | Next (q,v) -> 79 | if Pipe.is_closed writer 80 | then return () 81 | else 82 | Pipe.write writer v 83 | >>= fun () -> 84 | get q 85 | in 86 | get t.first 87 | ) 88 | 89 | 90 | let transfer_id t p = Pipe.transfer_id p t.source 91 | let add t v = 92 | assert (not (Pipe.is_closed t.source)); 93 | Pipe.write t.source v 94 | let add_without_pushback t v = Pipe.write_without_pushback t.source v 95 | let writer t = t.source 96 | 97 | let close t = 98 | Pipe.downstream_flushed t.source 99 | >>= fun _ -> 100 | Pipe.close t.source; 101 | Deferred.unit 102 | -------------------------------------------------------------------------------- /src/Oci_Queue.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Async.Std 24 | 25 | (** A queue where elements can't be removed. Can be also seen as a 26 | pipe that return the same elements to all the readers. Keep in 27 | memory all the elements previously inserted 28 | *) 29 | 30 | type 'a t 31 | 32 | val create: unit -> 'a t 33 | val reader: 'a t -> 'a Pipe.Reader.t 34 | val writer: 'a t -> 'a Pipe.Writer.t 35 | val add: 'a t -> 'a -> unit Deferred.t 36 | val add_without_pushback: 'a t -> 'a -> unit 37 | (** add an element *) 38 | val transfer_id: 'a t -> 'a Pipe.Reader.t -> unit Deferred.t 39 | (** add all the elements read from the pipe *) 40 | val close: 'a t -> unit Deferred.t 41 | (** Close the queue, no more elements can be added *) 42 | -------------------------------------------------------------------------------- /src/Oci_Rootfs.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | open Async.Std 25 | 26 | open Oci_Rootfs_Api 27 | 28 | (** The rootfs master is special because it create the environnement, 29 | so it need to runs in masters task that should be done in a runner *) 30 | 31 | let rootfs_next_id = ref (-1) 32 | let db_rootfs : Rootfs.t Rootfs_Id.Table.t ref = ref (Rootfs_Id.Table.create ()) 33 | 34 | let testdir () = 35 | Oci_Master.permanent_directory Oci_Rootfs_Api.create_rootfs 36 | >>= fun dir -> 37 | return (Oci_Filename.make_absolute dir "testdir") 38 | 39 | 40 | let () = 41 | let module M = struct 42 | type t = {rootfs_next_id: Int.t; 43 | db_rootfs: (Rootfs_Id.t * Rootfs.t) list; 44 | } [@@deriving bin_io] 45 | end in 46 | Oci_Master.simple_register_saver 47 | Oci_Rootfs_Api.create_rootfs 48 | M.bin_t 49 | ~basename:"rootfs_next_id" 50 | ~saver:(fun () -> 51 | let db_rootfs = Rootfs_Id.Table.to_alist !db_rootfs in 52 | return {M.rootfs_next_id = !rootfs_next_id; 53 | db_rootfs}) 54 | ~loader:(fun r -> 55 | rootfs_next_id := r.M.rootfs_next_id; 56 | db_rootfs := Rootfs_Id.Table.of_alist_exn r.M.db_rootfs; 57 | return ()) 58 | ~init:(fun () -> 59 | testdir () 60 | >>= fun testdir -> 61 | Async_shell.run "rm" ["-rf";"--";testdir] 62 | >>= fun () -> 63 | Unix.mkdir ~p:() testdir) 64 | 65 | let create_new_rootfs rootfs_query = 66 | testdir () 67 | >>= fun testdir -> 68 | incr rootfs_next_id; 69 | let id = Rootfs_Id.of_int_exn (!rootfs_next_id) in 70 | let testdir = Oci_Filename.make_absolute testdir (Rootfs_Id.to_string id) in 71 | Monitor.protect ~here:[%here] 72 | ~finally:(fun () -> Async_shell.run "rm" ["-rf";"--";testdir]) 73 | (fun () -> 74 | Unix.mkdir testdir 75 | >>= fun () -> begin 76 | match rootfs_query.meta_tar with 77 | | None -> return None 78 | | Some meta_tar -> 79 | Oci_Master.cha_log "Extract meta archive: %s" meta_tar; 80 | let metadir = Oci_Filename.make_absolute testdir "meta" in 81 | Unix.mkdir metadir 82 | >>= fun () -> 83 | Async_shell.run "tar" ["Jxf";meta_tar;"-C";metadir] 84 | >>= fun () -> 85 | let exclude = Oci_Filename.make_absolute metadir "excludes-user" in 86 | Sys.file_exists_exn exclude 87 | >>= fun exi -> 88 | if exi 89 | then return (Some exclude) 90 | else return None 91 | end 92 | >>= fun exclude -> 93 | Oci_Master.cha_log 94 | "Extract rootfs archive: %s" rootfs_query.rootfs_tar; 95 | let rootfsdir = Oci_Filename.make_absolute testdir "rootfs" in 96 | Unix.mkdir rootfsdir 97 | >>= fun () -> 98 | Async_shell.run "tar" (["xf";rootfs_query.rootfs_tar; "--xz"; 99 | "-C";rootfsdir; 100 | "--preserve-order"; 101 | "--no-same-owner"; 102 | ]@ 103 | (match exclude with 104 | | None -> [] 105 | | Some exclude -> ["--exclude-from";exclude] 106 | )) 107 | >>= fun () -> 108 | Oci_Master.cha_log "Create artefact"; 109 | Oci_Artefact.create 110 | ~prune:(List.map ~f:(Oci_Filename.make_absolute rootfsdir) 111 | Oci_Artefact.base_directory_to_prune) 112 | ~only_new:false 113 | ~rooted_at:rootfsdir 114 | ~src:rootfsdir 115 | >>= fun a -> 116 | let rootfs = { 117 | Rootfs.id; 118 | info = rootfs_query.rootfs_info; 119 | rootfs = a 120 | } in 121 | Rootfs_Id.Table.add_exn !db_rootfs ~key:id ~data:rootfs; 122 | Oci_Master.cha_log "New rootfs created"; 123 | return rootfs 124 | ) 125 | >>= fun s -> 126 | Deferred.Or_error.return s 127 | 128 | let find_rootfs key = 129 | Deferred.Or_error.return (Rootfs_Id.Table.find_exn !db_rootfs key) 130 | 131 | let add_packages (d:add_packages_query) = 132 | let rootfs = Rootfs_Id.Table.find_exn !db_rootfs d.id in 133 | Oci_Master.start_runner 134 | ~debug_info:"add packages" 135 | ~binary_name:"Oci_Cmd_Runner" () 136 | >>= fun (err,runner) -> 137 | choose [ 138 | choice (err >>= function 139 | | Ok () -> never () 140 | | Error _ as s -> return s) (fun x -> x); 141 | choice begin 142 | Monitor.protect ~here:[%here] 143 | ~finally:(fun () -> Oci_Master.stop_runner runner) 144 | ~name:"add_packages" 145 | (fun () -> 146 | Oci_Master.cha_log "Runner started"; 147 | Oci_Master.dispatch_runner_exn 148 | Oci_Cmd_Runner_Api.copy_to runner { 149 | user=Oci_Common.Root; 150 | artefact=rootfs.rootfs; 151 | dst="/"; 152 | } 153 | >>= fun () -> 154 | Oci_Master.dispatch_runner_exn 155 | Oci_Cmd_Runner_Api.get_internet runner () 156 | >>= fun () -> 157 | Oci_Master.cha_log "Update Apt Database"; 158 | Oci_Master.dispatch_runner_exn 159 | Oci_Cmd_Runner_Api.run runner { 160 | prog = "apt-get"; 161 | args = ["update"; 162 | (* We disable privilege dropping because it work not well 163 | with the current hardlink overlay technique. 164 | And we are already sandboxed. *) 165 | "--option";"APT::Sandbox::User=root"; 166 | "--option";"Acquire::Retries=3"; 167 | ]; 168 | env = `Extend []; 169 | runas = Root; 170 | } 171 | >>= fun () -> 172 | Oci_Master.cha_log "Install Package"; 173 | Oci_Master.dispatch_runner_exn 174 | Oci_Cmd_Runner_Api.run runner { 175 | prog = "apt-get"; 176 | args = "install":: 177 | "--yes":: 178 | "--option"::"Apt::Install-Recommends=false":: 179 | "--option"::"APT::Sandbox::User=root":: 180 | "--option"::"Acquire::Retries=3":: 181 | d.packages; 182 | env = `Extend ["DEBIAN_FRONTEND","noninteractive"]; 183 | runas = Root; 184 | } 185 | >>= fun () -> 186 | Oci_Master.cha_log "Clean Package Data"; 187 | Oci_Master.dispatch_runner_exn 188 | Oci_Cmd_Runner_Api.run runner { 189 | prog = "apt-get"; 190 | args = ["clean"; 191 | "--option";"APT::Sandbox::User=root"]; 192 | env = `Extend ["DEBIAN_FRONTEND","noninteractive"]; 193 | runas = Root; 194 | } 195 | >>= fun () -> 196 | Oci_Master.dispatch_runner_exn 197 | Oci_Cmd_Runner_Api.create_artefact runner "/" 198 | >>= fun artefact -> 199 | incr rootfs_next_id; 200 | let id = Rootfs_Id.of_int_exn (!rootfs_next_id) in 201 | let rootfs = { 202 | Rootfs.id; 203 | info = 204 | {rootfs.info with packages = d.packages @ rootfs.info.packages}; 205 | rootfs = artefact; 206 | } in 207 | Rootfs_Id.Table.add_exn !db_rootfs ~key:id ~data:rootfs; 208 | Oci_Master.cha_log "New rootfs created"; 209 | Deferred.Or_error.return rootfs 210 | ) 211 | end Fn.id] 212 | 213 | let init () = 214 | let register d f = 215 | Oci_Master.register d 216 | (fun s -> Oci_Log.init_writer (fun log -> 217 | Deferred.Or_error.try_with_join 218 | (fun () -> Oci_Master.attach_log log 219 | (fun () -> f s)) 220 | >>= fun res -> 221 | Oci_Log.write_and_close log res 222 | )) 223 | in 224 | register Oci_Rootfs_Api.create_rootfs create_new_rootfs; 225 | register Oci_Rootfs_Api.find_rootfs find_rootfs; 226 | register Oci_Rootfs_Api.add_packages add_packages 227 | -------------------------------------------------------------------------------- /src/Oci_Rootfs.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | val init: unit -> unit 24 | -------------------------------------------------------------------------------- /src/Oci_Rootfs_Api.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | 25 | type rootfs_info = { 26 | distribution: string; 27 | release: string; 28 | arch: string; 29 | packages: string list; 30 | (** additional packages that have been installed *) 31 | comment: string; 32 | } [@@deriving sexp, bin_io] 33 | 34 | module Rootfs_Id = Int 35 | 36 | module Rootfs = struct 37 | module T = struct 38 | type t = { 39 | id: Rootfs_Id.t; 40 | info: rootfs_info; 41 | rootfs: Oci_Common.Artefact.t; 42 | } [@@deriving sexp, bin_io] 43 | 44 | let compare x y = Rootfs_Id.compare x.id y.id 45 | let hash x = Rootfs_Id.hash x.id 46 | end 47 | module Hash = Hashable.Make(T) 48 | include T 49 | include Hash 50 | end 51 | 52 | type create_rootfs_query = { 53 | rootfs_info : rootfs_info; 54 | rootfs_tar: Oci_Filename.t; (** absolute pathname *) 55 | meta_tar: Oci_Filename.t option; (** absolute pathname *) 56 | } [@@deriving sexp, bin_io] 57 | 58 | let create_rootfs = Oci_Data.register 59 | ~name:"Oci.Rootfs.create" 60 | ~version:1 61 | ~bin_query:bin_create_rootfs_query 62 | ~bin_result:Rootfs.bin_t 63 | 64 | let find_rootfs = Oci_Data.register 65 | ~name:"Oci.Rootfs.find" 66 | ~version:1 67 | ~bin_query:Int.bin_t 68 | ~bin_result:Rootfs.bin_t 69 | 70 | 71 | type add_packages_query = { 72 | id: Rootfs_Id.t; 73 | packages: string list; 74 | } [@@deriving sexp, bin_io] 75 | 76 | let add_packages = 77 | Oci_Data.register 78 | ~name:"Oci.Rootfs.add_packages" 79 | ~version:1 80 | ~bin_query:bin_add_packages_query 81 | ~bin_result:Rootfs.bin_t 82 | -------------------------------------------------------------------------------- /src/Oci_Rootfs_Api.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | 25 | type rootfs_info = { 26 | distribution: string; 27 | release: string; 28 | arch: string; 29 | packages: string list; 30 | (** additional packages that have been installed *) 31 | comment: string; 32 | } [@@deriving sexp, bin_io] 33 | 34 | module Rootfs_Id: sig 35 | type t 36 | include Interfaces.Intable with type t := t 37 | include Interfaces.Stringable with type t := t 38 | include Interfaces.Comparable with type t := t 39 | include Interfaces.Hashable with type t := t 40 | include Interfaces.Sexpable with type t := t 41 | include Interfaces.Binable with type t := t 42 | end 43 | 44 | module Rootfs : sig 45 | type t = { 46 | id: Rootfs_Id.t; 47 | info: rootfs_info; 48 | rootfs: Oci_Common.Artefact.t; 49 | } [@@deriving sexp, bin_io] 50 | 51 | include Hashable.S with type t := t 52 | end 53 | 54 | type create_rootfs_query = { 55 | rootfs_info : rootfs_info; 56 | rootfs_tar: Oci_Filename.t; (** absolute pathname *) 57 | meta_tar: Oci_Filename.t option; (** absolute pathname *) 58 | } [@@deriving sexp, bin_io] 59 | 60 | val create_rootfs: (create_rootfs_query,Rootfs.t) Oci_Data.t 61 | val find_rootfs: (Rootfs_Id.t,Rootfs.t) Oci_Data.t 62 | 63 | type add_packages_query = { 64 | id: Rootfs_Id.t; 65 | packages: string list; 66 | } [@@deriving sexp, bin_io] 67 | 68 | val add_packages: (add_packages_query,Rootfs.t) Oci_Data.t 69 | -------------------------------------------------------------------------------- /src/Oci_Runner.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | open Async.Std 25 | 26 | type 'r t 27 | 28 | val start: 29 | implementations: 30 | Async.Std.Rpc.Connection.t Rpc.Implementation.t list -> 31 | never_returns 32 | (** The runner waits for request. *) 33 | 34 | exception StopQuery 35 | (** Stop the query. It is not an error in itself. The log sent to 36 | master to here *) 37 | 38 | val implement: 39 | ('query,'result) Oci_Data.t -> 40 | ('result t -> 'query -> 'result Deferred.t) -> 41 | Async.Std.Rpc.Connection.t Rpc.Implementation.t 42 | 43 | val implement_unit: 44 | ('query,'result) Oci_Data.t -> 45 | ('result t -> 'query -> unit Deferred.t) -> 46 | Async.Std.Rpc.Connection.t Rpc.Implementation.t 47 | 48 | type artefact = Oci_Common.Artefact.t [@@deriving sexp, bin_io] 49 | 50 | val create_artefact: 51 | ?rooted_at:Oci_Filename.t -> 52 | (** default: "/" *) 53 | ?prune:Oci_Filename.t list -> 54 | ?only_new:bool -> 55 | (** specifies if linked files should be forgotten (default: true) *) 56 | 'r t -> 57 | dir:string -> artefact Deferred.t 58 | val link_artefact: 59 | 'r t -> ?user:Oci_Common.user_kind 60 | -> artefact -> dir:string -> unit Deferred.t 61 | (** ro *) 62 | val copy_artefact: 63 | 'r t -> ?user:Oci_Common.user_kind 64 | -> artefact -> dir:string -> unit Deferred.t 65 | (** rw *) 66 | 67 | val get_internet: 'r t -> unit Deferred.t 68 | val git_clone: 'r t -> 69 | ?user:Oci_Common.user_kind -> 70 | url:string -> 71 | dst:Oci_Filename.t -> 72 | commit:Oci_Common.Commit.t -> 73 | unit Deferred.t 74 | val git_copy_file: 'r t -> 75 | ?user:Oci_Common.user_kind -> 76 | url:string -> 77 | src:Oci_Filename.t -> 78 | dst:Oci_Filename.t -> 79 | commit:Oci_Common.Commit.t -> 80 | unit Deferred.t 81 | val get_file: 'r t -> 82 | kind:[`MD5] -> 83 | checksum:string -> 84 | dst:Oci_Filename.t -> 85 | unit Deferred.t 86 | val give_external_access: 'r t -> Oci_Filename.t -> Oci_Filename.t Deferred.t 87 | 88 | val get_proc: 'r t -> int -> int Deferred.t 89 | val release_proc: 'r t -> int -> unit Deferred.t 90 | val get_release_proc: 'r t -> int -> (int -> 'a Deferred.t) -> 'a Deferred.t 91 | 92 | 93 | val dispatch: 94 | 'r t -> ('query,'result) Oci_Data.t -> 'query -> 'result Or_error.t Deferred.t 95 | val dispatch_exn: 96 | 'r t -> ('query,'result) Oci_Data.t -> 'query -> 'result Deferred.t 97 | 98 | 99 | val std_log: 'r t -> ('a, unit, string, unit) format4 -> 'a 100 | val err_log: 'r t -> ('a, unit, string, unit) format4 -> 'a 101 | val cha_log: 'r t -> ('a, unit, string, unit) format4 -> 'a 102 | val cmd_log: 'r t -> ('a, unit, string, unit) format4 -> 'a 103 | val data_log: 'result t -> 'result -> unit 104 | 105 | val process_log: 'r t -> Process.t -> unit Deferred.t 106 | 107 | type 'a process_create 108 | = ?env : Process.env (** default is [`Extend []] *) 109 | -> ?working_dir : string 110 | -> prog : string 111 | -> args : string list 112 | -> unit 113 | -> 'a Deferred.t 114 | 115 | val print_cmd: string -> string list -> string 116 | 117 | val run: 'r t -> 118 | Core.Std.Unix.Exit_or_signal.t process_create 119 | 120 | val run_timed: 'r t -> 121 | ?timelimit:Time.Span.t -> (* soft limit, wall clock *) 122 | (Core.Std.Unix.Exit_or_signal.t * Oci_Common.Timed.t) 123 | process_create 124 | 125 | exception CommandFailed 126 | val run_exn: 'r t -> unit process_create 127 | (** Same as {!run} but raise CommandFailed in case of error *) 128 | 129 | val run_timed_exn: 130 | 'r t -> Oci_Common.Timed.t process_create 131 | 132 | val oci_version: string 133 | -------------------------------------------------------------------------------- /src/Oci_Simple_Exec.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | open Async.Std 25 | 26 | open Oci_Simple_Exec_Api 27 | 28 | let run = Rpc.Rpc.implement run 29 | (fun () param -> Deferred.Or_error.try_with ~name:"Oci_Simple_Exec.run" 30 | (fun () -> Async_shell.run 31 | ~setuid:param.runas.uid 32 | ~setgid:param.runas.gid 33 | param.prog param.args)) 34 | 35 | let implementations = 36 | Rpc.Implementations.create_exn 37 | ~implementations:[run] 38 | ~on_unknown_rpc:`Raise 39 | 40 | let () = 41 | Tcp.connect (Tcp.to_file Sys.argv.(1)) 42 | >>> fun (_,reader,writer) -> 43 | Rpc.Connection.create 44 | ~heartbeat_config:Oci_Artefact_Api.heartbeat_config 45 | ~implementations 46 | ~connection_state:(fun _ -> ()) 47 | ~description:(Info.of_string "Oci_Simple_Exec <-> Master") 48 | reader writer 49 | >>> fun _ -> 50 | () 51 | 52 | let () = never_returns (Scheduler.go ()) 53 | -------------------------------------------------------------------------------- /src/Oci_Simple_Exec_Api.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | open Async.Std 25 | 26 | type run_query = { 27 | prog: string; 28 | args: string list; 29 | runas: Oci_Common.User.t; 30 | } [@@deriving sexp, bin_io] 31 | 32 | type run_response = unit Or_error.t [@@deriving sexp, bin_io] 33 | 34 | let run: (run_query, unit Or_error.t) Rpc.Rpc.t = 35 | Rpc.Rpc.create 36 | ~name:"run" 37 | ~version:1 38 | ~bin_query:bin_run_query 39 | ~bin_response:bin_run_response 40 | -------------------------------------------------------------------------------- /src/Oci_Std.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | open Async.Std 25 | 26 | 27 | module Pp = Oci_pp 28 | include Log.Global 29 | 30 | let unlink_no_fail filename = 31 | (* Sys.file_exists follows symlink *) 32 | Monitor.try_with ~here:[%here] 33 | (fun () -> Unix.lstat filename) 34 | >>= function 35 | | Ok _ -> Unix.unlink filename 36 | | Error _ -> return () 37 | (* | Error (Unix.Unix_error _) -> return () *) 38 | (* | Error exn -> raise exn *) 39 | 40 | let unlink_no_fail_blocking filename = 41 | let open Core.Std in 42 | (* Sys.file_exists follows symlink *) 43 | try 44 | ignore (Unix.lstat filename); 45 | Unix.unlink filename 46 | with _ -> () 47 | 48 | let backup_and_open_file file = 49 | let file_bak = Oci_Filename.add_extension file "bak" in 50 | Sys.file_exists_exn file 51 | >>= fun exi -> 52 | begin if exi then begin 53 | unlink_no_fail file_bak 54 | >>= fun () -> 55 | Unix.rename ~src:file ~dst:file_bak 56 | end 57 | else return () 58 | end 59 | >>= fun () -> 60 | Writer.open_file file 61 | 62 | let open_if_exists file f = 63 | Sys.file_exists_exn file 64 | >>= fun exi -> 65 | if exi then begin 66 | Reader.open_file file 67 | >>= fun reader -> 68 | f reader 69 | >>= fun () -> 70 | Reader.close reader 71 | end 72 | else return () 73 | 74 | let read_if_exists file bin_reader_t f = 75 | open_if_exists file 76 | (fun reader -> 77 | Reader.read_bin_prot reader bin_reader_t 78 | >>= function 79 | | `Eof -> return () 80 | | `Ok r -> f r 81 | ) 82 | 83 | external wait4: Caml.Unix.wait_flag list -> int -> 84 | int * Caml.Unix.process_status * Core.Core_unix.Resource_usage.t = "oci_wait4" 85 | let wait4 pid = 86 | let pid = (Pid.to_int pid) in 87 | In_thread.syscall_exn ~name:"wait4" 88 | (fun () -> wait4 [] pid) 89 | >>= fun (pid',status,ru) -> 90 | assert (pid' = pid); 91 | return (Core.Core_unix.Exit_or_signal.of_unix status, ru) 92 | -------------------------------------------------------------------------------- /src/Oci_Wget.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | open Async.Std 25 | 26 | 27 | let permanent_dir = ref "" 28 | let tmp_path = 29 | let i = ref (-1) in 30 | fun () -> incr i; 31 | Oci_Filename.make_absolute 32 | (Oci_Filename.make_absolute !permanent_dir "tmp_dir") 33 | (Int.to_string !i) 34 | 35 | let path_of_checksum s = function 36 | | `MD5 -> Oci_Filename.make_absolute 37 | (Oci_Filename.make_absolute !permanent_dir "md5") 38 | s 39 | 40 | let db_md5sum 41 | : unit Sequencer.t String.Table.t = String.Table.create () 42 | 43 | 44 | let download_file_aux ~kind ~checksum ~url = 45 | let tmp = tmp_path () in 46 | Unix.mkdir ~p:() (Oci_Filename.dirname tmp) 47 | >>= fun () -> 48 | Oci_Std.unlink_no_fail tmp 49 | >>= fun () -> 50 | Async_shell.test 51 | ~true_v:[0] 52 | ~false_v:[1;4;8;2;3;5;6;7] 53 | "wget" ["-T";"30";"--quiet";"-O";tmp;url] 54 | >>= fun ok -> 55 | if not (ok) 56 | then invalid_argf "Can't download at %s" url () 57 | else 58 | begin 59 | match kind with 60 | | `MD5 -> Async_shell.test 61 | ~input:(sprintf "%s %s" checksum tmp) 62 | "md5sum" ["--check";"--quiet";"--status";"--strict"] 63 | end 64 | >>= fun b -> 65 | if b 66 | then begin 67 | let store = path_of_checksum checksum kind in 68 | Unix.mkdir ~p:() (Oci_Filename.dirname store) 69 | >>= fun () -> 70 | Unix.rename ~src:tmp ~dst:store 71 | end 72 | else begin 73 | Unix.unlink tmp 74 | >>= fun () -> 75 | invalid_argf "Checksum %s failed for %s" checksum url () 76 | end 77 | 78 | let download_file ~kind ~checksum ~url = 79 | let store = path_of_checksum checksum kind in 80 | Sys.file_exists_exn store 81 | >>= fun b -> begin 82 | if b then Deferred.unit 83 | else 84 | let seq = 85 | match String.Table.find db_md5sum checksum with 86 | | Some seq -> seq 87 | | None -> 88 | let seq = Sequencer.create ~continue_on_error:true () in 89 | String.Table.add_exn db_md5sum ~key:checksum ~data:seq; 90 | seq 91 | in 92 | Throttle.enqueue seq (fun () -> 93 | Sys.file_exists_exn store 94 | >>= fun b -> begin 95 | if b then Deferred.unit 96 | else download_file_aux ~kind ~checksum ~url 97 | end) 98 | end 99 | 100 | let get_file ~kind ~checksum ~dst = 101 | let store = path_of_checksum checksum kind in 102 | Sys.file_exists_exn store 103 | >>= fun b -> 104 | if not b 105 | then invalid_argf "File with checksum %s have not been downloaded" checksum () 106 | else Unix.link ~target:store ~link_name:dst () 107 | 108 | let init ~dir = 109 | permanent_dir := dir; 110 | -------------------------------------------------------------------------------- /src/Oci_Wget.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Async.Std 24 | 25 | val download_file: 26 | kind:[`MD5] -> checksum:string -> url:string -> 27 | unit Deferred.t 28 | (** Download a file with the specified checksum. The file is cached 29 | using the checksum *) 30 | 31 | val get_file: 32 | kind:[`MD5] -> checksum:string -> dst:string -> unit Deferred.t 33 | (** Put the previously downloaded file at the specified destination. 34 | The file is retrieved using the checksum *) 35 | 36 | 37 | val init: 38 | dir:string -> 39 | unit 40 | -------------------------------------------------------------------------------- /src/Oci_Wrapper.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | open Oci_Wrapper_Api 25 | open ExtUnix.Specific 26 | open Oci_Wrapper_Lib 27 | 28 | let named_pipe_in = Sys.argv.(1)^".in" 29 | let named_pipe_out = Sys.argv.(1)^".out" 30 | 31 | let param : parameters = 32 | let cin = In_channel.create named_pipe_in in 33 | let param = 34 | Bin_prot.Utils.bin_read_stream 35 | ~read:(fun buf ~pos ~len -> 36 | Bigstring.really_input ~pos ~len cin buf) 37 | bin_reader_parameters 38 | in 39 | In_channel.close cin; 40 | param 41 | 42 | let send_pid pid = 43 | let cout = Out_channel.create named_pipe_out in 44 | let buf = Bin_prot.Utils.bin_dump ~header:true Pid.bin_writer_t pid in 45 | Bigstring.really_output cout buf; 46 | Out_channel.close cout 47 | 48 | let () = 49 | if Unix.getuid () = 0 then begin 50 | Printf.eprintf "This program shouldn't be run as root!\n%!"; 51 | exit 1 52 | end; 53 | Unix.handle_unix_error begin fun () -> 54 | (* remove the process from the group of the process monitor, and 55 | detach it from the controlling terminal. It allows to manage the 56 | shutdown nicely *) 57 | let _sessionid = Core.Std.Caml.Unix.setsid () in 58 | begin match param.cgroup with 59 | | None -> () 60 | | Some cgroup -> 61 | move_to_cgroup cgroup; 62 | Option.iter ~f:(set_cpuset ".") param.initial_cpuset; 63 | end; 64 | test_userns_availability (); 65 | (* Option.iter param.rootfs ~f:(mkdir ~perm:0o750); *) 66 | go_in_userns ~send_pid param.idmaps; 67 | (* make the mount private and mount basic directories *) 68 | if param.bind_system_mount then 69 | mount_base param.rootfs; 70 | (* chroot in the directory *) 71 | Unix.chdir param.rootfs; 72 | (* group must be changed before uid... *) 73 | setresgid param.rungid param.rungid param.rungid; 74 | setresuid param.runuid param.runuid param.runuid; 75 | if not (Sys.file_exists_exn param.command) then begin 76 | Printf.eprintf "Error: file %s doesn't exists" param.command; 77 | exit 1 78 | end; 79 | let _sessionid = Core.Std.Caml.Unix.setsid () in 80 | never_returns 81 | (Unix.exec 82 | ~prog:param.command 83 | ~env:(`Replace param.env) 84 | ~args:(param.command::param.argv) ()); 85 | end () 86 | -------------------------------------------------------------------------------- /src/Oci_Wrapper_Api.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | 25 | type idmap = { 26 | extern_id: Oci_Common.User.t; 27 | intern_id: Oci_Common.User.t; 28 | length_id: int; 29 | } [@@deriving sexp, bin_io] 30 | 31 | let idmaps ~in_user ~first_user_mapped = 32 | List.map ~f:(fun (u,length_id) -> { 33 | extern_id = Oci_Common.outside_user ~first_user_mapped u; 34 | intern_id = in_user u; 35 | length_id; 36 | }) 37 | 38 | type parameters = { 39 | rootfs: Oci_Filename.t; 40 | idmaps: idmap list; 41 | command: string; 42 | argv: string list; 43 | env: (string * string) list; 44 | runuid: Int.t; 45 | rungid: Int.t; 46 | bind_system_mount: bool; 47 | (** proc, dev, run *) 48 | prepare_network: bool; 49 | workdir: Oci_Filename.t option; 50 | cgroup: string option; 51 | (** move to the given cgroup *) 52 | initial_cpuset: Int.t List.t option; 53 | runner_id: Int.t; 54 | } [@@deriving sexp, bin_io] 55 | -------------------------------------------------------------------------------- /src/Oci_Wrapper_Lib.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | (** execute a program in a new usernamespace *) 24 | 25 | (** We can't use Async since we must play with forks and async doesn't 26 | like that *) 27 | open Core.Std 28 | open ExtUnix.Specific 29 | 30 | let mkdir ?(perm=0o750) dir = 31 | if not (Sys.file_exists_exn dir) then Unix.mkdir dir ~perm 32 | 33 | let mount_inside ~dir ~src ~tgt ?(fstype="") ~flags ?(option="") () = 34 | let tgt = Filename.concat dir tgt in 35 | mkdir tgt; 36 | mount ~source:src ~target:tgt ~fstype flags ~data:option 37 | 38 | let mount_base dir = 39 | (* 40 | mount ~source:dir ~target:dir ~fstype:"" [MS_BIND;MS_PRIVATE;MS_REC] ~data:""; 41 | *) 42 | mount_inside ~dir ~src:"proc" ~tgt:"proc" ~fstype:"proc" 43 | ~flags:[MS_NOSUID; MS_NOEXEC; MS_NODEV] (); 44 | mount_inside ~dir ~src:"/sys" ~tgt:"sys" ~flags:[MS_BIND; MS_REC] (); 45 | 46 | mount_inside ~dir ~src:"tmpfs" ~tgt:"dev" ~fstype:"tmpfs" 47 | ~flags:[MS_NOSUID; MS_STRICTATIME] 48 | ~option:"mode=755,uid=0,gid=0" (); 49 | 50 | mount_inside ~dir ~src:"devpts" ~tgt:"dev/pts" ~fstype:"devpts" 51 | ~flags:[MS_NOSUID;MS_NOEXEC] 52 | ~option:"newinstance,ptmxmode=0666,mode=0620,gid=5" (); 53 | 54 | mount_inside ~dir ~src:"tmpfs" ~tgt:"dev/shm" ~fstype:"tmpfs" 55 | ~flags:[MS_NOSUID; MS_STRICTATIME; MS_NODEV] 56 | ~option:"mode=1777,uid=0,gid=0" (); 57 | 58 | List.iter ~f:(fun (src,dst) -> 59 | Unix.symlink ~src ~dst:(Filename.concat dir dst)) 60 | [ "/proc/kcore", "/dev/core"; 61 | "/proc/self/fd", "/dev/fd"; 62 | "/proc/self/fd/0", "/dev/stdin"; 63 | "/proc/self/fd/1", "/dev/stdout"; 64 | "/proc/self/fd/2", "/dev/stderr"; 65 | "/dev/pts/ptmx", "/dev/ptmx"; 66 | ]; 67 | 68 | List.iter ~f:(fun src -> 69 | let dst = Filename.concat dir src in 70 | let fd = 71 | Unix.openfile ~perm:0o644 ~mode:[O_WRONLY;O_CREAT;O_CLOEXEC] 72 | dst 73 | in 74 | mount ~source:src ~target:dst ~fstype:"" ~data:"" [MS_BIND]; 75 | Unix.close fd; 76 | ) 77 | [ "/dev/console"; 78 | "/dev/tty"; 79 | "/dev/full"; 80 | "/dev/null"; 81 | "/dev/zero"; 82 | "/dev/random"; 83 | "/dev/urandom"; 84 | ]; 85 | 86 | mount_inside ~dir ~src:"tmpfs" ~tgt:"run" ~fstype:"tmpfs" 87 | ~flags:[MS_NOSUID; MS_STRICTATIME; MS_NODEV] 88 | ~option:"mode=755,uid=0,gid=0" (); 89 | 90 | mount_inside ~dir ~src:"tmpfs" ~tgt:"tmp" ~fstype:"tmpfs" 91 | ~flags:[MS_NOSUID; MS_STRICTATIME; MS_NODEV] 92 | ~option:"mode=1777,uid=0,gid=0" (); 93 | 94 | (* for aptitude *) 95 | mkdir (Filename.concat dir "/run/lock") 96 | 97 | let do_chroot dest = 98 | Sys.chdir dest; 99 | chroot "."; 100 | Sys.chdir "/" 101 | 102 | let read_in_file fmt = 103 | Printf.ksprintf (fun file -> 104 | let c = open_in file in 105 | let v = input_line c in 106 | In_channel.close c; 107 | v 108 | ) fmt 109 | 110 | 111 | let test_userns_availability () = 112 | let unpriviledge_userns_clone = 113 | "/proc/sys/kernel/unprivileged_userns_clone" in 114 | if Sys.file_exists_exn unpriviledge_userns_clone then begin 115 | let v = read_in_file "%s" unpriviledge_userns_clone in 116 | if v <> "1" then begin 117 | Printf.eprintf "This kernel is configured to disable unpriviledge user\ 118 | namespace: %s must be 1\n" unpriviledge_userns_clone; 119 | exit 1 120 | end 121 | end 122 | 123 | let write_in_file fmt = 124 | Printf.ksprintf (fun file -> 125 | Printf.ksprintf (fun towrite -> 126 | try 127 | let cout = open_out file in 128 | output_string cout towrite; 129 | Out_channel.close cout 130 | with _ -> 131 | Printf.eprintf "Error during write of %s in %s\n" 132 | towrite file; 133 | exit 1 134 | ) 135 | ) fmt 136 | 137 | let command fmt = Printf.ksprintf (fun cmd -> Sys.command cmd = 0) fmt 138 | 139 | let command_no_fail ?(error=(fun () -> ())) fmt = 140 | Printf.ksprintf (fun cmd -> 141 | let c = Sys.command cmd in 142 | if c <> 0 then begin 143 | Printf.eprintf "Error during: %s\n%!" cmd; 144 | error (); 145 | exit 1; 146 | end 147 | ) fmt 148 | 149 | (** {2 CGroup} *) 150 | let move_to_cgroup name = 151 | command_no_fail 152 | "cgm movepid all %s %i" name (Pid.to_int (Unix.getpid ())) 153 | 154 | let set_cpuset cgroupname cpuset = 155 | command_no_fail 156 | "cgm setvalue cpuset %s cpuset.cpus %s" 157 | cgroupname 158 | (String.concat ~sep:"," (List.map ~f:Int.to_string cpuset)) 159 | 160 | (** {2 User namespace} *) 161 | open Oci_Wrapper_Api 162 | 163 | let set_usermap idmaps pid = 164 | assert (idmaps <> []); 165 | let call cmd proj = 166 | (* newuidmap pid uid loweruid count [uid loweruid count [ ... ]] *) 167 | let argv = List.fold_left ~f:(fun acc idmap -> 168 | idmap.length_id::(proj idmap.extern_id)::(proj idmap.intern_id)::acc 169 | ) ~init:[Pid.to_int pid] idmaps in 170 | let argv = List.rev_map ~f:string_of_int argv in 171 | Core_extended.Shell.run ~expect:[0] cmd argv in 172 | call "newuidmap" (fun u -> u.uid); 173 | call "newgidmap" (fun u -> u.gid) 174 | 175 | let do_as_the_child_on_error pid = 176 | match Unix.waitpid pid with 177 | | Ok () -> () 178 | | Error (`Exit_non_zero i) -> exit i 179 | | Error (`Signal s) -> 180 | Signal.send_i s (`Pid (Unix.getpid ())); assert false 181 | 182 | let goto_child ~exec_in_parent = 183 | let fin,fout = Unix.pipe () in 184 | match Unix.fork () with 185 | | `In_the_child -> (* child *) 186 | Unix.close fout; 187 | ignore (Unix.read fin ~buf:(Bytes.create 1) ~pos:0 ~len:1); 188 | Unix.close fin 189 | | `In_the_parent pid -> 190 | (* execute the command and wait *) 191 | Unix.close fin; 192 | (exec_in_parent pid: unit); 193 | ignore (Unix.write fout ~buf:(Bytes.create 1) ~pos:0 ~len:1); 194 | Unix.close fout; 195 | do_as_the_child_on_error pid; 196 | exit 0 197 | 198 | let exec_in_child (type a) f = 199 | let fin,fout = Unix.pipe () in 200 | match Unix.fork () with 201 | | `In_the_child -> (* child *) 202 | Unix.close fout; 203 | let cin = Unix.in_channel_of_descr fin in 204 | let arg = (Marshal.from_channel cin : a) in 205 | In_channel.close cin; 206 | f arg; 207 | exit 0 208 | | `In_the_parent pid -> 209 | Unix.close fin; 210 | let cout = Unix.out_channel_of_descr fout in 211 | let call_in_child (arg:a) = 212 | Marshal.to_channel cout arg []; 213 | Out_channel.close cout; 214 | do_as_the_child_on_error pid 215 | in 216 | call_in_child 217 | 218 | let exec_now_in_child f arg = 219 | match Unix.fork () with 220 | | `In_the_child -> (* child *) 221 | f arg; 222 | exit 0 223 | | `In_the_parent pid -> 224 | do_as_the_child_on_error pid 225 | 226 | let just_goto_child () = 227 | match Unix.fork () with 228 | | `In_the_child -> (* child *) () 229 | | `In_the_parent pid -> 230 | do_as_the_child_on_error pid; 231 | exit 0 232 | 233 | 234 | let go_in_userns ?(send_pid=(fun _ -> ())) idmaps = 235 | (* the usermap can be set only completely outside the namespace, so we 236 | keep a child for doing that when we have a pid completely inside the 237 | namespace *) 238 | let call_set_usermap = exec_in_child (set_usermap idmaps) in 239 | unshare [ CLONE_NEWNS; 240 | CLONE_NEWIPC; 241 | CLONE_NEWPID; 242 | CLONE_NEWUTS; 243 | CLONE_NEWUSER; 244 | ]; 245 | (* only the child will be in the new pid namespace, the parent is in an 246 | intermediary state not interesting *) 247 | goto_child ~exec_in_parent:(fun pid -> 248 | send_pid pid; 249 | call_set_usermap pid) 250 | (* Printf.printf "User: %i (%i)\n%!" (Unix.getuid ()) (Unix.geteuid ()); *) 251 | (* Printf.printf "Pid: %i\n%!" (Unix.getpid ()); *) 252 | (* Printf.printf "User: %i (%i)\n%!" (Unix.getuid ()) (Unix.geteuid ()); *) 253 | 254 | let test_overlay () = 255 | (* for test *) 256 | let test = "/overlay" in 257 | let ro = Filename.concat test "ro" in 258 | let rw = Filename.concat test "rw" in 259 | let wd = Filename.concat test "wd" in 260 | let ov = Filename.concat test "ov" in 261 | mkdir test; mkdir ro; mkdir rw; mkdir wd; mkdir ov; 262 | mount ~source:"overlay" ~target:ov ~fstype:"overlay" 263 | [] 264 | ~data:(Printf.sprintf "lowerdir=%s,upperdir=%s,workdir=%s" ro rw wd) 265 | 266 | -------------------------------------------------------------------------------- /src/Oci_pp.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* The Why3 Verification Platform / The Why3 Development Team *) 4 | (* Copyright 2010-2015 -- INRIA - CNRS - Paris-Sud University *) 5 | (* *) 6 | (* This software is distributed under the terms of the GNU Lesser *) 7 | (* General Public License version 2.1, with the special exception *) 8 | (* on linking described in file LICENSE. *) 9 | (* *) 10 | (**************************************************************************) 11 | 12 | (*s Pretty-print library *) 13 | 14 | open Core.Std 15 | open Format 16 | 17 | type 'a printer = formatter -> 'a -> unit 18 | type formatter = Format.formatter 19 | 20 | let print_option f fmt = function 21 | | None -> () 22 | | Some x -> f fmt x 23 | 24 | let print_option_or_default default f fmt = function 25 | | None -> fprintf fmt "%s" default 26 | | Some x -> f fmt x 27 | 28 | let rec print_list sep print fmt = function 29 | | [] -> () 30 | | [x] -> print fmt x 31 | | x :: r -> print fmt x; sep fmt (); print_list sep print fmt r 32 | 33 | let print_list_or_default default sep print fmt = function 34 | | [] -> fprintf fmt "%s" default 35 | | l -> print_list sep print fmt l 36 | 37 | let print_list_par sep pr fmt l = 38 | print_list sep (fun fmt x -> fprintf fmt "(%a)" pr x) fmt l 39 | 40 | let print_list_delim ~start ~stop ~sep pr fmt = function 41 | | [] -> () 42 | | l -> fprintf fmt "%a%a%a" start () (print_list sep pr) l stop () 43 | 44 | 45 | let print_iter1 iter sep print fmt l = 46 | let first = ref true in 47 | iter (fun x -> 48 | if !first 49 | then first := false 50 | else sep fmt (); 51 | print fmt x ) l 52 | 53 | let print_iter2 iter sep1 sep2 print1 print2 fmt l = 54 | let first = ref true in 55 | iter (fun x y -> 56 | if !first 57 | then first := false 58 | else sep1 fmt (); 59 | print1 fmt x;sep2 fmt (); print2 fmt y) l 60 | 61 | 62 | let print_iteri2 iter sep1 sep2 print1 print2 fmt l = 63 | let first = ref true in 64 | iter (fun x y -> 65 | if !first 66 | then first := false 67 | else sep1 fmt (); 68 | print1 fmt x;sep2 fmt (); print2 x fmt y) l 69 | 70 | 71 | let print_iter22 iter sep print fmt l = 72 | let first = ref true in 73 | iter (fun x y -> 74 | if !first 75 | then first := false 76 | else sep fmt (); 77 | print fmt x y) l 78 | 79 | 80 | let print_pair_delim start sep stop pr1 pr2 fmt (a,b) = 81 | fprintf fmt "%a%a%a%a%a" start () pr1 a sep () pr2 b stop () 82 | 83 | 84 | type formatted = (unit, unit, unit, unit, unit, unit) format6 85 | let empty_formatted : formatted = "" 86 | 87 | let dot fmt () = fprintf fmt ".@ " 88 | let comma fmt () = fprintf fmt ",@ " 89 | let star fmt () = fprintf fmt "*@ " 90 | let simple_comma fmt () = fprintf fmt ", " 91 | let underscore fmt () = fprintf fmt "_" 92 | let semi fmt () = fprintf fmt ";@ " 93 | let colon fmt () = fprintf fmt ":@ " 94 | let space fmt () = fprintf fmt "@ " 95 | let alt fmt () = fprintf fmt "|@ " 96 | let alt2 fmt () = fprintf fmt "@ | " 97 | let equal fmt () = fprintf fmt "@ =@ " 98 | let newline fmt () = fprintf fmt "@\n" 99 | let newline2 fmt () = fprintf fmt "@\n@\n" 100 | let arrow fmt () = fprintf fmt "@ -> " 101 | let lbrace fmt () = fprintf fmt "{" 102 | let rbrace fmt () = fprintf fmt "}" 103 | let lsquare fmt () = fprintf fmt "[" 104 | let rsquare fmt () = fprintf fmt "]" 105 | let lparen fmt () = fprintf fmt "(" 106 | let rparen fmt () = fprintf fmt ")" 107 | let lchevron fmt () = fprintf fmt "<" 108 | let rchevron fmt () = fprintf fmt ">" 109 | let nothing _fmt _ = () 110 | let string = pp_print_string 111 | let float = pp_print_float 112 | let int = pp_print_int 113 | let constant_string s fmt () = string fmt s 114 | let formatted fmt x = Format.fprintf fmt "%( %)" x 115 | let constant_formatted f fmt () = formatted fmt f 116 | let print0 fmt () = pp_print_string fmt "\000" 117 | let add_flush sep fmt x = sep fmt x; pp_print_flush fmt () 118 | 119 | let asd f fmt x = fprintf fmt "\"%a\"" f x 120 | 121 | let print_pair pr1 = print_pair_delim lparen comma rparen pr1 122 | 123 | let hov n f fmt x = pp_open_hovbox fmt n; f fmt x; pp_close_box fmt () 124 | let indent n f fmt x = 125 | for _i = 0 to n do 126 | pp_print_char fmt ' ' 127 | done; 128 | hov 0 f fmt x 129 | 130 | let open_formatter ?(margin=78) cout = 131 | let fmt = formatter_of_out_channel cout in 132 | pp_set_margin fmt margin; 133 | pp_open_box fmt 0; 134 | fmt 135 | 136 | let close_formatter fmt = 137 | pp_close_box fmt (); 138 | pp_print_flush fmt () 139 | 140 | let open_file_and_formatter ?(margin=78) f = 141 | let cout = open_out f in 142 | let fmt = open_formatter ~margin cout in 143 | cout,fmt 144 | 145 | let close_file_and_formatter (cout,fmt) = 146 | close_formatter fmt; 147 | Out_channel.close cout 148 | 149 | let print_in_file_no_close ?(margin=78) p f = 150 | let cout,fmt = open_file_and_formatter ~margin f in 151 | p fmt; 152 | close_formatter fmt; 153 | cout 154 | 155 | let print_in_file ?(margin=78) p f = 156 | let cout = print_in_file_no_close ~margin p f in 157 | Out_channel.close cout 158 | 159 | 160 | 161 | (* With optional separation *) 162 | let rec print_list_opt sep print fmt = function 163 | | [] -> false 164 | | [x] -> print fmt x 165 | | x :: r -> 166 | let notempty1 = print fmt x in 167 | if notempty1 then sep fmt (); 168 | let notempty2 = print_list_opt sep print fmt r in 169 | notempty1 || notempty2 170 | 171 | 172 | let string_of p x = 173 | let b = Buffer.create 100 in 174 | let fmt = formatter_of_buffer b in 175 | fprintf fmt "%a@?" p x; 176 | Buffer.contents b 177 | 178 | let wnl fmt = 179 | let conf = 180 | Format.pp_get_formatter_out_functions fmt () in 181 | Format.pp_set_formatter_out_functions fmt 182 | {conf with out_newline = (fun () -> conf.out_spaces 1)} 183 | 184 | 185 | let string_of_wnl p x = 186 | let b = Buffer.create 100 in 187 | let fmt = formatter_of_buffer b in 188 | wnl fmt; 189 | fprintf fmt "%a@?" p x; 190 | Buffer.contents b 191 | 192 | let sprintf p = 193 | let b = Buffer.create 100 in 194 | let fmt = formatter_of_buffer b in 195 | kfprintf (fun fmt -> Format.pp_print_flush fmt (); Buffer.contents b) fmt p 196 | 197 | let sprintf_wnl p = 198 | let b = Buffer.create 100 in 199 | let fmt = formatter_of_buffer b in 200 | wnl fmt; 201 | kfprintf (fun fmt -> Format.pp_print_flush fmt (); Buffer.contents b) fmt p 202 | 203 | 204 | let to_sexp to_sexp = fun fmt x -> 205 | String.pp fmt (Sexp.to_string_hum (to_sexp x)) 206 | 207 | module Ansi = 208 | struct 209 | 210 | let set_column fmt n = fprintf fmt "\027[%iG" n 211 | end 212 | -------------------------------------------------------------------------------- /src/Oci_pp.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* The Why3 Verification Platform / The Why3 Development Team *) 4 | (* Copyright 2010-2015 -- INRIA - CNRS - Paris-Sud University *) 5 | (* *) 6 | (* This software is distributed under the terms of the GNU Lesser *) 7 | (* General Public License version 2.1, with the special exception *) 8 | (* on linking described in file LICENSE. *) 9 | (* *) 10 | (**************************************************************************) 11 | 12 | (*i $Id: pp.mli,v 1.22 2009-10-19 11:55:33 bobot Exp $ i*) 13 | 14 | type formatter = Format.formatter 15 | type 'a printer = formatter -> 'a -> unit 16 | 17 | val print_option : 'a printer -> 'a option printer 18 | val print_option_or_default : 19 | string -> 'a printer -> 'a option printer 20 | val print_list : 21 | unit printer -> 22 | 'a printer -> 'a list printer 23 | val print_list_or_default : 24 | string -> unit printer -> 25 | 'a printer -> 'a list printer 26 | val print_list_par : 27 | (formatter -> unit -> unit) -> 28 | 'b printer -> 'b list printer 29 | val print_list_delim : 30 | start:unit printer -> 31 | stop:unit printer -> 32 | sep:unit printer -> 33 | 'b printer -> 'b list printer 34 | 35 | val print_pair_delim : 36 | unit printer -> 37 | unit printer -> 38 | unit printer -> 39 | 'a printer -> 40 | 'b printer -> ('a * 'b) printer 41 | val print_pair : 42 | 'a printer -> 43 | 'b printer -> ('a * 'b) printer 44 | 45 | val print_iter1 : 46 | (('a -> unit) -> 'b -> unit) -> 47 | unit printer -> 48 | 'a printer -> 49 | 'b printer 50 | 51 | val print_iter2: 52 | (('a -> 'b -> unit) -> 'c -> unit) -> 53 | unit printer -> 54 | unit printer -> 55 | 'a printer -> 56 | 'b printer -> 57 | 'c printer 58 | (** [print_iter2 iter sep1 sep2 print1 print2 fmt t] 59 | iter iterator on [t : 'c] 60 | print1 k sep2 () print2 v sep1 () print1 sep2 () ... 61 | *) 62 | 63 | 64 | val print_iteri2: 65 | (('a -> 'b -> unit) -> 'c -> unit) -> 66 | unit printer -> 67 | unit printer -> 68 | 'a printer -> 69 | ('a -> 'b printer) -> 70 | 'c printer 71 | (** [print_iter2 iter sep1 sep2 print1 print2 fmt t] 72 | iter iterator on [t : 'c] 73 | print1 k sep2 () print2 v sep1 () print1 sep2 () ... 74 | *) 75 | 76 | val print_iter22: 77 | (('a -> 'b -> unit) -> 'c -> unit) -> 78 | unit printer -> 79 | (formatter -> 'a -> 'b -> unit) -> 80 | 'c printer 81 | (** [print_iter22 iter sep print fmt t] 82 | iter iterator on [t : 'c] 83 | print k v sep () print k v sep () ... 84 | *) 85 | 86 | (** formatted: string which is formatted "@ " allow to cut the line if 87 | too long *) 88 | type formatted = (unit, unit, unit, unit, unit, unit) format6 89 | val empty_formatted : formatted 90 | 91 | val space : unit printer 92 | val alt : unit printer 93 | val alt2 : unit printer 94 | val newline : unit printer 95 | val newline2 : unit printer 96 | val dot : unit printer 97 | val comma : unit printer 98 | val star : unit printer 99 | val simple_comma : unit printer 100 | val semi : unit printer 101 | val colon : unit printer 102 | val underscore : unit printer 103 | val equal : unit printer 104 | val arrow : unit printer 105 | val lbrace : unit printer 106 | val rbrace : unit printer 107 | val lsquare : unit printer 108 | val rsquare : unit printer 109 | val lparen : unit printer 110 | val rparen : unit printer 111 | val lchevron : unit printer 112 | val rchevron : unit printer 113 | val nothing : 'a printer 114 | val string : string printer 115 | val float : float printer 116 | val int : int printer 117 | val constant_string : string -> unit printer 118 | val formatted : formatted printer 119 | val constant_formatted : formatted -> unit printer 120 | val print0 : unit printer 121 | val hov : int -> 'a printer -> 'a printer 122 | val indent : int -> 'a printer -> 'a printer 123 | (** add the indentation at the first line *) 124 | 125 | val add_flush : 'a printer -> 'a printer 126 | 127 | val asd : 'a printer -> 'a printer 128 | (** add string delimiter " " *) 129 | 130 | val open_formatter : ?margin:int -> out_channel -> formatter 131 | val close_formatter : formatter -> unit 132 | val open_file_and_formatter : ?margin:int -> string -> out_channel * formatter 133 | val close_file_and_formatter : out_channel * formatter -> unit 134 | val print_in_file_no_close : 135 | ?margin:int -> (formatter -> unit) -> string -> out_channel 136 | val print_in_file : ?margin:int -> (formatter -> unit) -> string -> unit 137 | 138 | 139 | val print_list_opt : 140 | unit printer -> 141 | (formatter -> 'a -> bool) -> formatter -> 'a list -> bool 142 | 143 | 144 | val string_of : 'a printer -> 'a -> string 145 | val string_of_wnl : 'a printer -> 'a -> string 146 | (** same as {!string_of} but without newline *) 147 | 148 | val wnl : formatter -> unit 149 | 150 | val sprintf : 151 | ('b, formatter, unit, string) Pervasives.format4 -> 'b 152 | 153 | val sprintf_wnl : 154 | ('b, formatter, unit, string) Pervasives.format4 -> 'b 155 | 156 | val to_sexp: ('a -> Core.Std.Sexp.t) -> Format.formatter -> 'a -> unit 157 | 158 | module Ansi : 159 | sig 160 | val set_column : int printer 161 | end 162 | -------------------------------------------------------------------------------- /src/liboci_stubs.clib: -------------------------------------------------------------------------------- 1 | oci_stubs.o -------------------------------------------------------------------------------- /src/monitor_rpc.mli: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | type run = { 24 | 25 | } 26 | -------------------------------------------------------------------------------- /src/oci_stubs.c: -------------------------------------------------------------------------------- 1 | /**************************************************************************/ 2 | /* */ 3 | /* This file is part of OCI. */ 4 | /* */ 5 | /* Copyright (C) 2015-2016 */ 6 | /* CEA (Commissariat à l'énergie atomique et aux énergies */ 7 | /* alternatives) */ 8 | /* */ 9 | /* you can redistribute it and/or modify it under the terms of the GNU */ 10 | /* Lesser General Public License as published by the Free Software */ 11 | /* Foundation, version 2.1. */ 12 | /* */ 13 | /* It is distributed in the hope that it will be useful, */ 14 | /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ 15 | /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ 16 | /* GNU Lesser General Public License for more details. */ 17 | /* */ 18 | /* See the GNU Lesser General Public License version 2.1 */ 19 | /* for more details (enclosed in the file licenses/LGPLv2.1). */ 20 | /* */ 21 | /**************************************************************************/ 22 | 23 | 24 | #include 25 | #include 26 | #include 27 | #include 28 | #include 29 | #include 30 | #include 31 | #include 32 | #include 33 | 34 | /** This function or alloc_process_status should be exported by 35 | ocaml runtime */ 36 | CAMLextern int caml_rev_convert_signal_number(int); 37 | 38 | #define TAG_WEXITED 0 39 | #define TAG_WSIGNALED 1 40 | #define TAG_WSTOPPED 2 41 | 42 | static value alloc_process_status(int pid, int status, value ru) 43 | { 44 | CAMLparam1(ru); 45 | CAMLlocal2(st,res); 46 | 47 | if (WIFEXITED(status)) { 48 | st = alloc_small(1, TAG_WEXITED); 49 | Field(st, 0) = Val_int(WEXITSTATUS(status)); 50 | } 51 | else if (WIFSTOPPED(status)) { 52 | st = alloc_small(1, TAG_WSTOPPED); 53 | Field(st, 0) = Val_int(caml_rev_convert_signal_number(WSTOPSIG(status))); 54 | } 55 | else { 56 | st = alloc_small(1, TAG_WSIGNALED); 57 | Field(st, 0) = Val_int(caml_rev_convert_signal_number(WTERMSIG(status))); 58 | } 59 | res = alloc_small(3, 0); 60 | Field(res, 0) = Val_int(pid); 61 | Field(res, 1) = st; 62 | Field(res, 2) = ru; 63 | CAMLreturn(res); 64 | } 65 | 66 | static int wait_flag_table[] = { 67 | WNOHANG, WUNTRACED 68 | }; 69 | 70 | CAMLprim value oci_wait4(value flags, value pid_req) 71 | { 72 | CAMLparam0(); 73 | CAMLlocal1(v_usage); 74 | int pid, status, cv_flags; 75 | struct rusage ru; 76 | 77 | cv_flags = convert_flag_list(flags, wait_flag_table); 78 | enter_blocking_section(); 79 | pid = wait4(Int_val(pid_req), &status, cv_flags, &ru); 80 | leave_blocking_section(); 81 | if (pid == -1) uerror("wait4", pid_req); 82 | 83 | v_usage = caml_alloc(16, 0); 84 | Store_field(v_usage, 0, 85 | caml_copy_double((double) ru.ru_utime.tv_sec + 86 | (double) ru.ru_utime.tv_usec / 1e6)); 87 | Store_field(v_usage, 1, 88 | caml_copy_double((double) ru.ru_stime.tv_sec + 89 | (double) ru.ru_stime.tv_usec / 1e6)); 90 | Store_field(v_usage, 2, caml_copy_int64(ru.ru_maxrss)); 91 | Store_field(v_usage, 3, caml_copy_int64(ru.ru_ixrss)); 92 | Store_field(v_usage, 4, caml_copy_int64(ru.ru_idrss)); 93 | Store_field(v_usage, 5, caml_copy_int64(ru.ru_isrss)); 94 | Store_field(v_usage, 6, caml_copy_int64(ru.ru_minflt)); 95 | Store_field(v_usage, 7, caml_copy_int64(ru.ru_majflt)); 96 | Store_field(v_usage, 8, caml_copy_int64(ru.ru_nswap)); 97 | Store_field(v_usage, 9, caml_copy_int64(ru.ru_inblock)); 98 | Store_field(v_usage, 10, caml_copy_int64(ru.ru_oublock)); 99 | Store_field(v_usage, 11, caml_copy_int64(ru.ru_msgsnd)); 100 | Store_field(v_usage, 12, caml_copy_int64(ru.ru_msgrcv)); 101 | Store_field(v_usage, 13, caml_copy_int64(ru.ru_nsignals)); 102 | Store_field(v_usage, 14, caml_copy_int64(ru.ru_nvcsw)); 103 | Store_field(v_usage, 15, caml_copy_int64(ru.ru_nivcsw)); 104 | 105 | CAMLreturn(alloc_process_status(pid, status,v_usage)); 106 | } 107 | -------------------------------------------------------------------------------- /tests/images/tests_oci_sort1_1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bobot/oci/3bab64183025bc28c6db917e1edb28bb5d7e7b99/tests/images/tests_oci_sort1_1.png -------------------------------------------------------------------------------- /tests/images/tests_oci_sort2_1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bobot/oci/3bab64183025bc28c6db917e1edb28bb5d7e7b99/tests/images/tests_oci_sort2_1.png -------------------------------------------------------------------------------- /tests/images/tests_oci_sort3_1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/bobot/oci/3bab64183025bc28c6db917e1edb28bb5d7e7b99/tests/images/tests_oci_sort3_1.png -------------------------------------------------------------------------------- /tests/library/oci_default_client.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | open Async.Std 25 | 26 | let () = 27 | don't_wait_for (Oci_Client.Cmdline.default_cmdline 28 | ~doc:"Oci client with masters by default" 29 | ~version:Oci_Client.oci_version 30 | "oci_default_client"); 31 | never_returns (Scheduler.go ()) 32 | -------------------------------------------------------------------------------- /tests/library/oci_default_master.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | 25 | let () = 26 | Oci_Rootfs.init (); 27 | Oci_Generic_Masters.init_compile_git_repo () 28 | 29 | let () = never_returns (Oci_Master.run ()) 30 | -------------------------------------------------------------------------------- /tests/tests_api.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | 25 | let test_succ = Oci_Data.register 26 | ~name:"succ" 27 | ~version:1 28 | ~bin_query:Int.bin_t 29 | ~bin_result:Int.bin_t 30 | 31 | let test_fibo = Oci_Data.register 32 | ~name:"fibo" 33 | ~version:1 34 | ~bin_query:Int.bin_t 35 | ~bin_result:Int.bin_t 36 | 37 | let test_fibo_artefact_aux = Oci_Data.register 38 | ~name:"fibo_artefact_aux" 39 | ~version:1 40 | ~bin_query:Int.bin_t 41 | ~bin_result:Oci_Common.Artefact.bin_t 42 | 43 | let test_fibo_artefact = Oci_Data.register 44 | ~name:"fibo_artefact" 45 | ~version:1 46 | ~bin_query:Int.bin_t 47 | ~bin_result:Int.bin_t 48 | 49 | let test_fibo_error_artefact = Oci_Data.register 50 | ~name:"fibo_error_artefact" 51 | ~version:1 52 | ~bin_query:Int.bin_t 53 | ~bin_result:Int.bin_t 54 | 55 | 56 | let test_collatz = Oci_Data.register 57 | ~name:"collatz" 58 | ~version:1 59 | ~bin_query:Int.bin_t 60 | ~bin_result:Int.bin_t 61 | -------------------------------------------------------------------------------- /tests/tests_client.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | 24 | open Core.Std 25 | open Async.Std 26 | 27 | open Oci_Client.Cmdline 28 | 29 | open Cmdliner 30 | 31 | let cmds_with_connections = 32 | let test name rpc = 33 | let arg = 34 | Arg.(required & pos 0 (some int) None & info [] 35 | ~docv:"i" 36 | ~doc:("compute the result of "^name^" for the given number")) 37 | in 38 | Term.(Term.const 39 | (fun i -> 40 | exec rpc i 41 | Int.sexp_of_t Format.pp_print_int) $ arg), 42 | Term.info name 43 | in 44 | [ 45 | test "succ" Tests_api.test_succ; 46 | test "fibo" Tests_api.test_fibo; 47 | test "fibo_artefact" Tests_api.test_fibo_artefact; 48 | test "fibo_error_artefact" Tests_api.test_fibo_error_artefact; 49 | test "collatz" Tests_api.test_collatz; 50 | ] 51 | 52 | (** CI tests *) 53 | open Oci_Client.Git 54 | 55 | let oci_sort_url = 56 | "https://github.com/bobot/oci-repository-for-tutorial.git" 57 | 58 | let oci_sort_bak = mk_repo 59 | "oci-sort_bak" 60 | ~url:oci_sort_url 61 | ~deps:Oci_Client.Cmdline.Predefined.[ocaml;ocamlbuild;ocamlfind] 62 | ~cmds:[ 63 | run "autoconf" []; 64 | run "./configure" []; 65 | make []; 66 | make ["install"]; 67 | ] 68 | ~tests:[ 69 | make ["tests"]; 70 | ] 71 | 72 | let oci_sort_ocamlparam = 73 | WP.mk_param ~default:None "oci-sort-ocamlparam" 74 | ~sexp_of:[%sexp_of: string option] 75 | ~of_sexp:[%of_sexp: string option] 76 | ~cmdliner:Arg.(value & (opt (some (some string)) None) 77 | & info ["oci-sort-ocamlparam"] 78 | ~docv:"ARG" 79 | ~doc:"Determine the argument to give to ocaml \ 80 | OCAMLPARAM") 81 | ~to_option_hum:(function None -> "" | Some s -> "--oci-sort-ocamlparam="^s) 82 | let oci_sort_revspec = 83 | mk_revspec_param ~url:oci_sort_url "oci-sort" 84 | 85 | let oci_sort = 86 | add_repo_with_param "oci-sort" 87 | WP.(const (fun commit ocamlparam -> 88 | Oci_Client.Git.repo 89 | ~deps:Oci_Client.Cmdline.Predefined.[ocaml;ocamlbuild; 90 | ocamlfind] 91 | ~cmds:[ 92 | Oci_Client.Git.git_clone ~url:oci_sort_url commit; 93 | run "autoconf" []; 94 | run "./configure" []; 95 | make ?env:(match ocamlparam with 96 | | None -> None 97 | | Some v -> Some (`Extend ["OCAMLPARAM", v])) []; 98 | make ["install"]; 99 | ] 100 | ~tests:[ 101 | make ["tests"]; 102 | ] 103 | ()) 104 | $? oci_sort_revspec 105 | $? oci_sort_ocamlparam); 106 | "oci-sort" 107 | 108 | (** benchmark tests *) 109 | 110 | let () = mk_compare 111 | ~deps:[oci_sort] 112 | ~x_of_sexp:Oci_Common.Commit.t_of_sexp 113 | ~sexp_of_x:Oci_Common.Commit.sexp_of_t 114 | ~y_of_sexp:Oci_Filename.t_of_sexp 115 | ~sexp_of_y:Oci_Filename.sexp_of_t 116 | ~cmds:(fun conn revspecs x y -> 117 | let revspecs = WP.ParamValue.set revspecs 118 | oci_sort_revspec (Oci_Common.Commit.to_string x) in 119 | commit_of_revspec conn ~url:oci_sort_url ~revspec:"master" 120 | >>= fun master -> 121 | return 122 | (revspecs, 123 | [Oci_Client.Git.git_copy_file ~url:oci_sort_url ~src:y 124 | ~dst:(Oci_Filename.basename y) 125 | (Option.value_exn ~here:[%here] master)], 126 | (run 127 | ~memlimit:(Byte_units.create `Megabytes 500.) 128 | ~timelimit:(Time.Span.create ~sec:10 ()) 129 | "oci-sort" [Oci_Filename.basename y]))) 130 | ~analyse:(fun _ timed -> 131 | Some (Time.Span.to_sec timed.Oci_Common.Timed.cpu_user)) 132 | "oci-sort" 133 | 134 | 135 | let () = mk_compare 136 | ~deps:[oci_sort] 137 | ~x_of_sexp:WP.ParamValue.t_of_sexp 138 | ~sexp_of_x:WP.ParamValue.sexp_of_t 139 | ~y_of_sexp:Oci_Filename.t_of_sexp 140 | ~sexp_of_y:Oci_Filename.sexp_of_t 141 | ~cmds:(fun conn revspecs x y -> 142 | let revspecs = WP.ParamValue.replace_by revspecs x in 143 | commit_of_revspec conn ~url:oci_sort_url ~revspec:"master" 144 | >>= fun master -> 145 | return 146 | (revspecs, 147 | [Oci_Client.Git.git_copy_file ~url:oci_sort_url ~src:y 148 | ~dst:(Oci_Filename.basename y) 149 | (Option.value_exn ~here:[%here] master)], 150 | (run 151 | ~memlimit:(Byte_units.create `Megabytes 500.) 152 | ~timelimit:(Time.Span.create ~sec:10 ()) 153 | "oci-sort" [Oci_Filename.basename y])) 154 | ) 155 | ~analyse:(fun _ timed -> 156 | Some (Time.Span.to_sec timed.Oci_Common.Timed.cpu_user)) 157 | "oci-sort_ocaml" 158 | 159 | 160 | let () = 161 | don't_wait_for (Oci_Client.Cmdline.default_cmdline 162 | ~cmds_with_connections 163 | ~doc:"Oci client for tests" 164 | ~version:Oci_Client.oci_version 165 | "oci_default_client"); 166 | never_returns (Scheduler.go ()) 167 | -------------------------------------------------------------------------------- /tests/tests_master.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | 25 | let binary_name = "tests_runner" 26 | 27 | module MasterInt = Oci_Master.Make(Int)(Int) 28 | 29 | let () = 30 | MasterInt.create_master_and_reusable_runner 31 | Tests_api.test_succ 32 | ~error:(fun _ -> Int.min_value) 33 | ~binary_name 34 | ~hashable_key:Unit.hashable 35 | ~extract_key:(fun _ -> ()) 36 | (fun ~first:_ -> Oci_Master.dispatch_runner_exn Tests_api.test_succ) 37 | 38 | let () = 39 | MasterInt.create_master_and_reusable_runner 40 | Tests_api.test_fibo 41 | ~error:(fun _ -> Int.min_value) 42 | ~binary_name 43 | ~hashable_key:Unit.hashable 44 | ~extract_key:(fun _ -> ()) 45 | (fun ~first:_ -> Oci_Master.dispatch_runner_exn Tests_api.test_fibo) 46 | 47 | let () = 48 | MasterInt.create_master_and_reusable_runner 49 | Tests_api.test_collatz 50 | ~error:(fun _ -> Int.min_value) 51 | ~binary_name 52 | ~hashable_key:Unit.hashable 53 | ~extract_key:(fun _ -> ()) 54 | (fun ~first:_ -> Oci_Master.dispatch_runner_exn Tests_api.test_collatz) 55 | 56 | let () = 57 | MasterInt.create_master_and_runner 58 | Tests_api.test_fibo_artefact 59 | ~error:(fun _ -> Int.min_value) 60 | ~binary_name 61 | (Oci_Master.dispatch_runner_exn Tests_api.test_fibo_artefact) 62 | 63 | let () = 64 | MasterInt.create_master_and_runner 65 | Tests_api.test_fibo_error_artefact 66 | ~error:(fun _ -> Int.min_value) 67 | ~binary_name 68 | (Oci_Master.dispatch_runner_exn Tests_api.test_fibo_error_artefact) 69 | 70 | module MasterIntArtefact = Oci_Master.Make(Int)(Oci_Common.Artefact) 71 | 72 | let () = 73 | MasterIntArtefact.create_master_and_runner 74 | Tests_api.test_fibo_artefact_aux 75 | ~binary_name 76 | (Oci_Master.dispatch_runner_exn Tests_api.test_fibo_artefact_aux) 77 | 78 | let () = 79 | Oci_Rootfs.init (); 80 | Oci_Generic_Masters.init_compile_git_repo () 81 | 82 | let () = never_returns (Oci_Master.run ()) 83 | -------------------------------------------------------------------------------- /tests/tests_oci_sort0.bench: -------------------------------------------------------------------------------- 1 | tests/example_1000_0.sort 2 | tests/example_1000_1.sort 3 | tests/example_1000_2.sort 4 | tests/example_1000_3.sort 5 | tests/example_1000_4.sort 6 | tests/example_1000_5.sort 7 | tests/example_1000_6.sort 8 | tests/example_1000_7.sort 9 | tests/example_1000_8.sort 10 | tests/example_1000_9.sort 11 | tests/example_100_0.sort 12 | tests/example_100_1.sort 13 | tests/example_100_2.sort 14 | tests/example_100_3.sort 15 | tests/example_100_4.sort 16 | tests/example_100_5.sort 17 | tests/example_100_6.sort 18 | tests/example_100_7.sort 19 | tests/example_100_8.sort 20 | tests/example_100_9.sort 21 | tests/example_10_0.sort 22 | tests/example_10_1.sort 23 | tests/example_10_2.sort 24 | tests/example_10_3.sort 25 | tests/example_10_4.sort 26 | tests/example_10_5.sort 27 | tests/example_10_6.sort 28 | tests/example_10_7.sort 29 | tests/example_10_8.sort 30 | tests/example_10_9.sort 31 | -------------------------------------------------------------------------------- /tests/tests_oci_sort0.commits: -------------------------------------------------------------------------------- 1 | master 2 | master~1 3 | master~2 -------------------------------------------------------------------------------- /tests/tests_oci_sort1.bench: -------------------------------------------------------------------------------- 1 | tests/example_1000000_0.sort 2 | tests/example_1000000_1.sort 3 | tests/example_1000000_2.sort 4 | tests/example_1000000_3.sort 5 | tests/example_1000000_4.sort 6 | tests/example_1000000_5.sort 7 | tests/example_1000000_6.sort 8 | tests/example_1000000_7.sort 9 | tests/example_1000000_8.sort 10 | tests/example_1000000_9.sort 11 | tests/example_100000_0.sort 12 | tests/example_100000_1.sort 13 | tests/example_100000_2.sort 14 | tests/example_100000_3.sort 15 | tests/example_100000_4.sort 16 | tests/example_100000_5.sort 17 | tests/example_100000_6.sort 18 | tests/example_100000_7.sort 19 | tests/example_100000_8.sort 20 | tests/example_100000_9.sort 21 | tests/example_10000_0.sort 22 | tests/example_10000_1.sort 23 | tests/example_10000_2.sort 24 | tests/example_10000_3.sort 25 | tests/example_10000_4.sort 26 | tests/example_10000_5.sort 27 | tests/example_10000_6.sort 28 | tests/example_10000_7.sort 29 | tests/example_10000_8.sort 30 | tests/example_10000_9.sort 31 | tests/example_1000_0.sort 32 | tests/example_1000_1.sort 33 | tests/example_1000_2.sort 34 | tests/example_1000_3.sort 35 | tests/example_1000_4.sort 36 | tests/example_1000_5.sort 37 | tests/example_1000_6.sort 38 | tests/example_1000_7.sort 39 | tests/example_1000_8.sort 40 | tests/example_1000_9.sort 41 | tests/example_100_0.sort 42 | tests/example_100_1.sort 43 | tests/example_100_2.sort 44 | tests/example_100_3.sort 45 | tests/example_100_4.sort 46 | tests/example_100_5.sort 47 | tests/example_100_6.sort 48 | tests/example_100_7.sort 49 | tests/example_100_8.sort 50 | tests/example_100_9.sort 51 | tests/example_10_0.sort 52 | tests/example_10_1.sort 53 | tests/example_10_2.sort 54 | tests/example_10_3.sort 55 | tests/example_10_4.sort 56 | tests/example_10_5.sort 57 | tests/example_10_6.sort 58 | tests/example_10_7.sort 59 | tests/example_10_8.sort 60 | tests/example_10_9.sort 61 | -------------------------------------------------------------------------------- /tests/tests_oci_sort1.commits: -------------------------------------------------------------------------------- 1 | master 2 | master~1 -------------------------------------------------------------------------------- /tests/tests_oci_sort2.bench: -------------------------------------------------------------------------------- 1 | tests/example_1000000_0.sort 2 | -------------------------------------------------------------------------------- /tests/tests_oci_sort2.commits: -------------------------------------------------------------------------------- 1 | master~2 -------------------------------------------------------------------------------- /tests/tests_oci_sort3.commits: -------------------------------------------------------------------------------- 1 | ((oci-sort master)(oci-sort-ocamlparam (Some "_,O3="))(ocaml-configure (-flambda))) 2 | ((oci-sort master)) 3 | -------------------------------------------------------------------------------- /tests/tests_runner.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* This file is part of OCI. *) 4 | (* *) 5 | (* Copyright (C) 2015-2016 *) 6 | (* CEA (Commissariat à l'énergie atomique et aux énergies *) 7 | (* alternatives) *) 8 | (* *) 9 | (* you can redistribute it and/or modify it under the terms of the GNU *) 10 | (* Lesser General Public License as published by the Free Software *) 11 | (* Foundation, version 2.1. *) 12 | (* *) 13 | (* It is distributed in the hope that it will be useful, *) 14 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 15 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *) 16 | (* GNU Lesser General Public License for more details. *) 17 | (* *) 18 | (* See the GNU Lesser General Public License version 2.1 *) 19 | (* for more details (enclosed in the file licenses/LGPLv2.1). *) 20 | (* *) 21 | (**************************************************************************) 22 | 23 | open Core.Std 24 | open Async.Std 25 | 26 | let test_succ _ q = return (q + 1) 27 | 28 | let test_fibo conn q = 29 | match q with 30 | | q when q < 0 -> return Int.min_value 31 | | 0 -> return 1 32 | | 1 -> return 1 33 | | q -> 34 | Oci_Runner.release_proc conn 1 35 | >>= fun () -> 36 | let q_1 = Oci_Runner.dispatch_exn 37 | conn Tests_api.test_fibo (q-1) in 38 | let q_2 = Oci_Runner.dispatch_exn 39 | conn Tests_api.test_fibo (q-2) in 40 | Deferred.both q_1 q_2 41 | >>= fun (q_1,q_2) -> 42 | return (q_1 + q_2) 43 | 44 | let test_collatz conn q = 45 | match q with 46 | | q when q < 0 -> return Int.min_value 47 | | 0 -> return 1 48 | | 1 -> return 1 49 | | q -> 50 | Oci_Runner.release_proc conn 1 51 | >>= fun () -> 52 | let collatz x = 53 | if (x mod 2) = 0 54 | then x/2 55 | else succ (x*3) 56 | in 57 | Oci_Runner.dispatch_exn 58 | conn Tests_api.test_collatz (collatz q) 59 | >>= fun r -> 60 | return (r + 1) 61 | 62 | let test_fibo_artefact_aux conn q = 63 | let save_fibo v = 64 | Unix.mkdir "/fibo" 65 | >>= fun () -> 66 | Writer.open_file "/fibo/result" 67 | >>= fun writer -> 68 | Writer.write_bin_prot writer Int.bin_writer_t v; 69 | Writer.close writer 70 | >>= fun () -> 71 | Oci_Runner.create_artefact conn ~dir:"/fibo" 72 | in 73 | let read_fibo file = 74 | Reader.open_file file 75 | >>= fun reader -> 76 | Reader.read_bin_prot reader Int.bin_reader_t 77 | >>= function 78 | | `Eof -> invalid_arg "Bad fibo file" 79 | | `Ok r -> return r 80 | in 81 | match q with 82 | | q when q < 0 -> save_fibo Int.min_value 83 | | 0 -> save_fibo 1 84 | | 1 -> save_fibo 1 85 | | q -> 86 | Oci_Runner.release_proc conn 1 87 | >>= fun () -> 88 | Oci_Runner.dispatch_exn 89 | conn Tests_api.test_fibo_artefact_aux (q-1) 90 | >>= fun a_1 -> 91 | Oci_Runner.dispatch_exn 92 | conn Tests_api.test_fibo_artefact_aux (q-2) 93 | >>= fun a_2 -> 94 | Oci_Runner.get_proc conn 1 95 | >>= fun _ -> 96 | Oci_Runner.link_artefact conn a_1 ~dir:"/fibo_1" 97 | >>= fun () -> 98 | Oci_Runner.link_artefact conn a_2 ~dir:"/fibo_2" 99 | >>= fun () -> 100 | read_fibo "/fibo_1/result" 101 | >>= fun q_1 -> 102 | read_fibo "/fibo_2/result" 103 | >>= fun q_2 -> 104 | save_fibo (q_1 + q_2) 105 | 106 | let test_fibo_artefact conn q = 107 | let read_fibo file = 108 | Reader.open_file file 109 | >>= fun reader -> 110 | Reader.read_bin_prot reader Int.bin_reader_t 111 | >>= function 112 | | `Eof -> invalid_arg "Bad fibo file" 113 | | `Ok r -> return r 114 | in 115 | Oci_Runner.release_proc conn 1 116 | >>= fun () -> 117 | Oci_Runner.dispatch_exn 118 | conn Tests_api.test_fibo_artefact_aux q 119 | >>= fun a -> 120 | Oci_Runner.get_proc conn 1 121 | >>= fun _ -> 122 | Oci_Runner.link_artefact conn a ~dir:"/fibo" 123 | >>= fun () -> 124 | read_fibo "/fibo/result" 125 | >>= fun q_2 -> 126 | return q_2 127 | 128 | 129 | 130 | let test_fibo_error_artefact conn q = 131 | Oci_Runner.dispatch_exn 132 | conn Tests_api.test_fibo_artefact_aux q 133 | >>= fun a -> 134 | Oci_Runner.link_artefact conn a ~dir:"/fibo" 135 | >>= fun () -> 136 | Writer.open_file ~append:true "/fibo/result" 137 | >>= fun writer -> 138 | Writer.write_line writer "C'est une erreur!"; 139 | Writer.close writer; 140 | >>= fun _ -> 141 | return (-1) 142 | 143 | let () = 144 | never_returns begin 145 | Oci_Runner.start 146 | ~implementations:[ 147 | Oci_Runner.implement 148 | Tests_api.test_succ test_succ; 149 | Oci_Runner.implement 150 | Tests_api.test_fibo test_fibo; 151 | Oci_Runner.implement 152 | Tests_api.test_fibo_artefact test_fibo_artefact; 153 | Oci_Runner.implement 154 | Tests_api.test_fibo_artefact_aux test_fibo_artefact_aux; 155 | Oci_Runner.implement 156 | Tests_api.test_fibo_error_artefact test_fibo_error_artefact; 157 | Oci_Runner.implement 158 | Tests_api.test_collatz test_collatz; 159 | ] 160 | end 161 | -------------------------------------------------------------------------------- /tests/tests_time.ml: -------------------------------------------------------------------------------- 1 | 2 | 3 | open! Core.Std 4 | open! Async.Std 5 | open Oci_Std 6 | 7 | let prog, args = 8 | match Array.to_list Sys.argv with 9 | | [] | [_] -> "sleep", ["0"] 10 | | _::prog::args -> prog, args 11 | 12 | let () = 13 | never_returns begin 14 | Scheduler.go_main 15 | ~main:(fun () -> 16 | Process.create_exn ~prog ~args () 17 | >>> fun p -> 18 | printf "process started\n%!"; 19 | wait4 (Process.pid p) 20 | >>> fun (status, ru) -> 21 | printf "process stopped\n%s\n%s\n%!" 22 | (Unix.Exit_or_signal.to_string_hum status) 23 | (Sexp.to_string_hum 24 | (Core.Core_unix.Resource_usage.sexp_of_t ru)); 25 | Shutdown.shutdown 0 26 | ) () 27 | end 28 | --------------------------------------------------------------------------------