├── .gitignore ├── .merlin ├── .travis.yml ├── LICENSE ├── Makefile ├── README.md ├── _oasis ├── _tags ├── bin ├── ciso.ml ├── ciso_add.ml ├── ciso_common.ml ├── ciso_common.mli ├── ciso_publish.ml ├── ciso_schedule.ml ├── ciso_show.ml └── ciso_work.ml ├── ciso.install ├── configure ├── lib ├── META ├── ciso.mldylib ├── ciso.mllib ├── ciso.odocl ├── github │ ├── ciso-github.mldylib │ ├── ciso-github.mllib │ ├── github_pr.ml │ └── github_pr.mli ├── gol.ml ├── gol.mli ├── host.ml ├── host.mli ├── id.ml ├── id.mli ├── job.ml ├── job.mli ├── object.ml ├── object.mli ├── package.ml ├── package.mli ├── scheduler.ml ├── scheduler.mli ├── store.ml ├── store.mli ├── switch.ml ├── switch.mli ├── task.ml ├── task.mli ├── worker.ml ├── worker.mli └── worker │ ├── ciso-worker.mldylib │ ├── ciso-worker.mllib │ ├── common_worker.ml │ ├── common_worker.mli │ ├── job_worker.ml │ ├── job_worker.mli │ ├── opam.ml │ ├── opam.mli │ ├── task_worker.ml │ └── task_worker.mli ├── lib_test ├── test.ml ├── test_common.ml ├── test_scheduler.ml ├── test_scheduler.mli ├── test_simple.ml ├── test_simple.mli └── test_worker.ml ├── myocamlbuild.ml ├── opam ├── setup.ml └── version /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | .#* 3 | \#* 4 | _build/ 5 | setup.data 6 | setup.log 7 | *.native 8 | gh-pages/ 9 | _tests/ 10 | lib/version.ml 11 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | PKG lwt cmdliner nocrypto fmt jsont.jsonm 2 | PKG opam-lib opam-lib.client opam-lib.solver 3 | PKG irmin irmin.unix uuidm rresult 4 | PKG alcotest cstruct.unix 5 | S lib/ 6 | S lib/worker/ 7 | S lib_test/ 8 | S bin/ 9 | B _build/** -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: required 3 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-opam.sh 4 | script: bash -ex .travis-opam.sh 5 | env: 6 | global: 7 | - EXTRA_REMOTES="https://github.com/samoht/ciso-repo.git" 8 | - PACKAGE=ciso 9 | matrix: 10 | - OCAML_VERSION=4.01 11 | - OCAML_VERSION=4.02 12 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2 | 3 | Permission to use, copy, modify, and distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | VERSION = $(shell grep 'Version:' _oasis | sed 's/Version: *//') 2 | VFILE = lib/version.ml 3 | 4 | SETUP = ocaml setup.ml 5 | 6 | build: setup.data $(VFILE) 7 | $(SETUP) -build $(BUILDFLAGS) 8 | 9 | doc: setup.data build 10 | $(SETUP) -doc $(DOCFLAGS) 11 | 12 | test: setup.data build 13 | $(SETUP) -test $(TESTFLAGS) 14 | 15 | all: $(VFILE) 16 | $(SETUP) -all $(ALLFLAGS) 17 | 18 | install: setup.data 19 | $(SETUP) -install $(INSTALLFLAGS) 20 | 21 | uninstall: setup.data 22 | $(SETUP) -uninstall $(UNINSTALLFLAGS) 23 | 24 | reinstall: setup.data 25 | $(SETUP) -reinstall $(REINSTALLFLAGS) 26 | 27 | clean: 28 | $(SETUP) -clean $(CLEANFLAGS) 29 | rm -f $(VFILE) 30 | 31 | distclean: 32 | $(SETUP) -distclean $(DISTCLEANFLAGS) 33 | 34 | setup.data: 35 | $(SETUP) -configure $(CONFIGUREFLAGS) 36 | 37 | configure: 38 | $(SETUP) -configure $(CONFIGUREFLAGS) 39 | 40 | .PHONY: build doc test all install uninstall reinstall clean distclean configure 41 | 42 | $(VFILE): _oasis 43 | echo "(** CISO Version. *)" > $@ 44 | echo "" >> $@ 45 | echo "let current = \"$(VERSION)\"" >> $@ 46 | echo "(** The current version of CISO. *)" >> $@ 47 | 48 | init-doc: 49 | mkdir -p gh-pages 50 | cd gh-pages && ( \ 51 | git init && \ 52 | git remote add origin git@github.com:samoht/ciso.git && \ 53 | git fetch && \ 54 | git checkout -b gh-pages && \ 55 | (git pull origin gh-pages || exit 0)) 56 | 57 | update-doc: doc 58 | rm -f gh-pages/*.html 59 | cd gh-pages && cp ../ciso.docdir/*.html . 60 | cd gh-pages && git add * && (git commit -a -m "Update docs" || exit 0) 61 | cd gh-pages && git push origin gh-pages 62 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## CISO: 2 | 3 | A (distributed) Continuous Integration engine for OPAM. 4 | 5 | [![Build Status](https://travis-ci.org/samoht/ciso.svg)](https://travis-ci.org/samoht/ciso) 6 | [![docs](https://img.shields.io/badge/doc-online-blue.svg)](https://samoht.github.io/ciso/) 7 | 8 | ### Install 9 | 10 | Ciso is not yet properly released so you need to add an OPAM remote to 11 | compile and install the project: 12 | 13 | ```shell 14 | opam repo add ciso https://github.com/samoht/ciso-repo.git 15 | opam install ciso 16 | ``` 17 | 18 | ### Usage 19 | 20 | See `ciso --help` for more information. 21 | 22 | #### Quick configuration 23 | 24 | The `ciso` will look for a `.ciso` file located in the current directory. The 25 | options can be overriden using command-line parameters. 26 | 27 | A typical `.ciso` file contains: 28 | 29 | ``` 30 | local: /tmp/ciso 31 | opam-root: /tmp/xxx 32 | ``` 33 | 34 | - `local` is the local Irmin store used by all the CISO tools It is a normal Git 35 | repositories that can be inspected and modified if needed. 36 | 37 | - `opam-root` is the local OPAM root, used by the CISO workers. It is better to 38 | have a different OPAM root for every worker (because of OPAM lock files) 39 | 40 | - Use `global: http://example.com` instead of `local` to use a remote Irmin 41 | store. 42 | 43 | #### Adding a new task 44 | 45 | ``` 46 | $ ciso add ctypes --rev-deps=* 47 | Task d73d0a4c65bea9c3cd6dc4fd4409381ab01d2f66 added! 48 | ``` 49 | 50 | See `ciso add --help` for more information. 51 | 52 | #### Showing tasks, jobs and workers 53 | 54 | ``` 55 | $ ciso show --id=d73d0a4c65bea9c3cd6dc4fd4409381ab01d2f66 56 | id : d73d0a4c65bea9c3cd6dc4fd4409381ab01d2f66 57 | date : 15:24:47 58 | repo : default:https://github.com/ocaml/opam-repository.git 59 | switches: 3.12.1 4.00.1 4.01.0 4.02.3 60 | hosts : x86_64:linux:ubuntu x86_64:osx:homebrew 61 | packages: ctypes 62 | rev-deps: * 63 | status : new 64 | ``` 65 | 66 | See `ciso show --help` for more information. 67 | 68 | #### Adding a new worker 69 | 70 | ``` 71 | $ ciso work --task # Add a task resolver 72 | $ ciso work # Add a build worker 73 | ``` 74 | 75 | #### Scheduling the work 76 | 77 | Until now, no work has been done. A scheduler needs to connect to the Irmin 78 | database to start scheduling the jobs to the workers. 79 | 80 | ``` 81 | $ ciso schedule 82 | ``` 83 | 84 | ### License 85 | 86 | ISC. See the [LICENSE](./blob/master/LICENSE) file. -------------------------------------------------------------------------------- /_oasis: -------------------------------------------------------------------------------- 1 | OASISFormat: 0.4 2 | Name: ocaml-ci 3 | Version: 0.1.0 4 | Synopsis: distributed integration engine for opam packages 5 | Authors: Qi Li, David Sheets, Thomas Gazagnaire 6 | License: ISC 7 | Plugins: META (0.3), DevFiles (0.3) 8 | BuildTools: ocamlbuild 9 | 10 | Library ciso 11 | Install: false 12 | Path: lib 13 | InternalModules: Gol 14 | Modules: 15 | Id, Task, Job, Object, Package, Host, Switch, Worker, Store, Scheduler, 16 | Version 17 | BuildDepends: 18 | irmin.unix, lwt, uuidm, fmt, nocrypto, uri, jsont.jsonm, hex, bytes 19 | 20 | Library "ciso-worker" 21 | Install: false 22 | Path: lib/worker 23 | FindlibParent: ciso 24 | FindlibName: worker 25 | InternalModules: Opam, Common_worker 26 | Modules: Task_worker, Job_worker 27 | BuildDepends: 28 | ciso, irmin.unix, opam-lib.client, ocamlgraph, threads, cstruct.unix, 29 | rresult 30 | 31 | Document ciso 32 | Title: CISO docs 33 | Type: OCamlbuild (0.4) 34 | BuildTools+: ocamldoc 35 | Install: true 36 | XOCamlbuildPath: lib 37 | XOCamlbuildLibraries: ciso, ciso.worker 38 | 39 | Executable test_ciso 40 | Build$: flag(tests) 41 | Path: lib_test 42 | MainIs: test.ml 43 | CompiledObject: best 44 | Install: false 45 | BuildDepends: alcotest, ciso, ciso.worker 46 | 47 | Test test_ciso 48 | Run$: flag(tests) 49 | Command: $test_ciso -q 50 | WorkingDirectory: lib_test/ 51 | 52 | Executable "ciso-show" 53 | Path: bin 54 | MainIs: ciso_show.ml 55 | CompiledObject: best 56 | BuildDepends: ciso, cmdliner 57 | 58 | Executable "ciso-work" 59 | Path: bin 60 | MainIs: ciso_work.ml 61 | CompiledObject: best 62 | BuildDepends: ciso.worker, cmdliner 63 | 64 | Executable "ciso-schedule" 65 | Path: bin 66 | MainIs: ciso_schedule.ml 67 | CompiledObject: best 68 | BuildDepends: ciso, cmdliner 69 | 70 | Executable "ciso-add" 71 | Path: bin 72 | MainIs: ciso_add.ml 73 | CompiledObject: best 74 | BuildDepends: ciso, cmdliner 75 | 76 | Executable "ciso-publish" 77 | Path: bin 78 | MainIs: ciso_publish.ml 79 | CompiledObject: best 80 | BuildDepends: ciso, cmdliner 81 | 82 | Executable ciso 83 | Path: bin 84 | MainIs: ciso.ml 85 | CompiledObject: best 86 | BuildDepends: ciso, cmdliner 87 | 88 | Library "ciso-github" 89 | Build: false 90 | Path: lib/github 91 | FindlibParent: ciso 92 | FindlibName: github 93 | Modules: Github_pr 94 | BuildDepends: ciso, ciso.worker, github.unix, lwt 95 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 7aaeb7b6938fa5a2fc2a6389bddce196) 3 | # Ignore VCS directories, you can use the same kind of rule outside 4 | # OASIS_START/STOP if you want to exclude directories that contains 5 | # useless stuff for the build process 6 | true: annot, bin_annot 7 | <**/.svn>: -traverse 8 | <**/.svn>: not_hygienic 9 | ".bzr": -traverse 10 | ".bzr": not_hygienic 11 | ".hg": -traverse 12 | ".hg": not_hygienic 13 | ".git": -traverse 14 | ".git": not_hygienic 15 | "_darcs": -traverse 16 | "_darcs": not_hygienic 17 | # Library ciso 18 | "lib/ciso.cmxs": use_ciso 19 | : pkg_bytes 20 | : pkg_fmt 21 | : pkg_hex 22 | : pkg_irmin.unix 23 | : pkg_jsont.jsonm 24 | : pkg_lwt 25 | : pkg_nocrypto 26 | : pkg_uri 27 | : pkg_uuidm 28 | # Library ciso-worker 29 | "lib/worker/ciso-worker.cmxs": use_ciso-worker 30 | : pkg_bytes 31 | : pkg_cstruct.unix 32 | : pkg_fmt 33 | : pkg_hex 34 | : pkg_irmin.unix 35 | : pkg_jsont.jsonm 36 | : pkg_lwt 37 | : pkg_nocrypto 38 | : pkg_ocamlgraph 39 | : pkg_opam-lib.client 40 | : pkg_rresult 41 | : pkg_threads 42 | : pkg_uri 43 | : pkg_uuidm 44 | : use_ciso 45 | # Executable test_ciso 46 | : pkg_alcotest 47 | : pkg_bytes 48 | : pkg_cstruct.unix 49 | : pkg_fmt 50 | : pkg_hex 51 | : pkg_irmin.unix 52 | : pkg_jsont.jsonm 53 | : pkg_lwt 54 | : pkg_nocrypto 55 | : pkg_ocamlgraph 56 | : pkg_opam-lib.client 57 | : pkg_rresult 58 | : pkg_threads 59 | : pkg_uri 60 | : pkg_uuidm 61 | : use_ciso 62 | : use_ciso-worker 63 | : pkg_alcotest 64 | : pkg_bytes 65 | : pkg_cstruct.unix 66 | : pkg_fmt 67 | : pkg_hex 68 | : pkg_irmin.unix 69 | : pkg_jsont.jsonm 70 | : pkg_lwt 71 | : pkg_nocrypto 72 | : pkg_ocamlgraph 73 | : pkg_opam-lib.client 74 | : pkg_rresult 75 | : pkg_threads 76 | : pkg_uri 77 | : pkg_uuidm 78 | : use_ciso 79 | : use_ciso-worker 80 | # Executable ciso-show 81 | : pkg_bytes 82 | : pkg_cmdliner 83 | : pkg_fmt 84 | : pkg_hex 85 | : pkg_irmin.unix 86 | : pkg_jsont.jsonm 87 | : pkg_lwt 88 | : pkg_nocrypto 89 | : pkg_uri 90 | : pkg_uuidm 91 | : use_ciso 92 | # Executable ciso-work 93 | : pkg_bytes 94 | : pkg_cmdliner 95 | : pkg_cstruct.unix 96 | : pkg_fmt 97 | : pkg_hex 98 | : pkg_irmin.unix 99 | : pkg_jsont.jsonm 100 | : pkg_lwt 101 | : pkg_nocrypto 102 | : pkg_ocamlgraph 103 | : pkg_opam-lib.client 104 | : pkg_rresult 105 | : pkg_threads 106 | : pkg_uri 107 | : pkg_uuidm 108 | : use_ciso 109 | : use_ciso-worker 110 | : pkg_cstruct.unix 111 | : pkg_ocamlgraph 112 | : pkg_opam-lib.client 113 | : pkg_rresult 114 | : pkg_threads 115 | : use_ciso-worker 116 | # Executable ciso-schedule 117 | : pkg_bytes 118 | : pkg_cmdliner 119 | : pkg_fmt 120 | : pkg_hex 121 | : pkg_irmin.unix 122 | : pkg_jsont.jsonm 123 | : pkg_lwt 124 | : pkg_nocrypto 125 | : pkg_uri 126 | : pkg_uuidm 127 | : use_ciso 128 | # Executable ciso-add 129 | : pkg_bytes 130 | : pkg_cmdliner 131 | : pkg_fmt 132 | : pkg_hex 133 | : pkg_irmin.unix 134 | : pkg_jsont.jsonm 135 | : pkg_lwt 136 | : pkg_nocrypto 137 | : pkg_uri 138 | : pkg_uuidm 139 | : use_ciso 140 | # Executable ciso-publish 141 | : pkg_bytes 142 | : pkg_cmdliner 143 | : pkg_fmt 144 | : pkg_hex 145 | : pkg_irmin.unix 146 | : pkg_jsont.jsonm 147 | : pkg_lwt 148 | : pkg_nocrypto 149 | : pkg_uri 150 | : pkg_uuidm 151 | : use_ciso 152 | # Executable ciso 153 | : pkg_bytes 154 | : pkg_cmdliner 155 | : pkg_fmt 156 | : pkg_hex 157 | : pkg_irmin.unix 158 | : pkg_jsont.jsonm 159 | : pkg_lwt 160 | : pkg_nocrypto 161 | : pkg_uri 162 | : pkg_uuidm 163 | : use_ciso 164 | : pkg_bytes 165 | : pkg_cmdliner 166 | : pkg_fmt 167 | : pkg_hex 168 | : pkg_irmin.unix 169 | : pkg_jsont.jsonm 170 | : pkg_lwt 171 | : pkg_nocrypto 172 | : pkg_uri 173 | : pkg_uuidm 174 | : use_ciso 175 | # Library ciso-github 176 | "lib/github/ciso-github.cmxs": use_ciso-github 177 | : pkg_bytes 178 | : pkg_cstruct.unix 179 | : pkg_fmt 180 | : pkg_github.unix 181 | : pkg_hex 182 | : pkg_irmin.unix 183 | : pkg_jsont.jsonm 184 | : pkg_lwt 185 | : pkg_nocrypto 186 | : pkg_ocamlgraph 187 | : pkg_opam-lib.client 188 | : pkg_rresult 189 | : pkg_threads 190 | : pkg_uri 191 | : pkg_uuidm 192 | : use_ciso 193 | : use_ciso-worker 194 | # OASIS_STOP 195 | true: debug, bin_annot 196 | true: warn(+A-4-41-44), warn_error(A-4-41-44) 197 | -------------------------------------------------------------------------------- /bin/ciso.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | open Cmdliner 20 | open Ciso_common 21 | 22 | let commands = [ 23 | "show" , "Show the tasks, jobs and workers."; 24 | "add" , "Add a new task."; 25 | "schedule", "Schedule the tasks and jobs to the workers."; 26 | "work" , "Start a new worker."; 27 | "publish" , "Publish the database over HTTP." 28 | ] 29 | 30 | let default = 31 | let doc = "CISO, a (distributed) Continuous Integration engine for OPAM." in 32 | let man = [ 33 | `S "DESCRIPTION"; 34 | `P "TODO"; 35 | `P "Use either $(b,$(mname) --help) or $(b,$(mname) help ) \ 36 | for more information on a specific command."; 37 | ] in 38 | let usage () = 39 | Fmt.(pf stdout) 40 | "usage: ciso [--version]\n\ 41 | \ [--help]\n\ 42 | \ []\n\ 43 | \n\ 44 | The most commonly used subcommands are:\n"; 45 | List.iter (fun (name, doc) -> 46 | Fmt.(pf stdout) " %-10s %s\n" name doc 47 | ) commands; 48 | Fmt.(pf stdout) 49 | "\n\ 50 | See `ciso help ` for more information on a specific \ 51 | command.\n%!" 52 | in 53 | Term.(global usage $ pure ()), 54 | term_info ~doc ~man "ciso" 55 | 56 | let run () = 57 | match Array.to_list Sys.argv with 58 | | [] | [_] -> () 59 | | ciso :: name :: args -> 60 | if String.length name <> 0 && name.[0] <> '-' then ( 61 | let cmd = match ciso with 62 | | "ciso" -> "ciso-" ^ name 63 | | s -> 64 | if Filename.check_suffix s ".native" then 65 | let base = Filename.chop_suffix s ".native" in 66 | base ^ "_" ^ name ^ ".native" 67 | else ( 68 | err "%s: sub-command %s not found" ciso name; 69 | exit 1 70 | ) 71 | in 72 | let exists = 73 | let test = Fmt.strf "/bin/sh -c 'command -v %s' > /dev/null 1>2" cmd in 74 | Sys.command test = 0 75 | in 76 | if exists then ( 77 | let argv = Array.of_list (cmd :: args) in 78 | Unix.execvp cmd argv 79 | ) else ( 80 | err "%s: command not found" cmd; 81 | exit 1 82 | ) 83 | ) 84 | 85 | let commands = 86 | let mk (name, doc) = Term.pure (), term_info ~doc name in 87 | List.map mk commands 88 | 89 | let () = 90 | run (); 91 | match Term.eval_choice default commands with 92 | | `Error _ -> exit 1 93 | | `Ok () | `Version | `Help -> () 94 | -------------------------------------------------------------------------------- /bin/ciso_add.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | 20 | open Cmdliner 21 | open Lwt.Infix 22 | include Ciso_common 23 | 24 | let package_c: Package.t Arg.converter = 25 | let parse str = `Ok (Package.of_string str) in 26 | let print ppf t = Package.pp ppf t in 27 | parse, print 28 | 29 | let repo_c: Task.repo Arg.converter = 30 | let parse str = 31 | let name = String.sub (Id.digest `Repo str |> Id.to_string) 0 8 in 32 | `Ok (name, Uri.of_string str) 33 | in 34 | parse, Task.pp_repo 35 | 36 | let pin_c: Task.pin Arg.converter = 37 | let parse str = 38 | let r = match Stringext.cut str ~on:":" with 39 | | Some (n, r) -> n, Some (Uri.of_string r) 40 | | None -> str, None 41 | in `Ok r 42 | in 43 | parse, Task.pp_pin 44 | 45 | let rev_deps_c: Task.rev_deps Arg.converter = 46 | let parse str = 47 | let r = match Stringext.split str ~on:',' with 48 | | [] -> `None 49 | | ["*"] -> `All 50 | | l -> `Packages (List.map Package.of_string l) 51 | in `Ok r 52 | in 53 | parse, Task.pp_rev_deps 54 | 55 | let packages = 56 | let doc = "The package to install" in 57 | Arg.(value & pos_all package_c [] & info [] ~docv:"PKGS" ~doc) 58 | 59 | let rev_deps = 60 | let doc = 61 | "Disabled by default, use '*' to test every dependent packages allowed by \ 62 | the constraints. If you want to test only specific dependent packages, \ 63 | they may be provided in a comma-separated list." 64 | in 65 | Arg.(value & opt rev_deps_c `None & info ["rev-deps"] ~doc) 66 | 67 | let base_repo = 68 | let doc = "Specify the repository to Initialize OPAM with." in 69 | Arg.(value & opt repo_c Task.default_repo & info ["base-repo"] ~doc) 70 | 71 | let extra_repos = 72 | let doc = 73 | "In addition to changing the initial base repositories (see \ 74 | $(i, --base-repo)) additional OPAM repositories can be layered on top of \ 75 | the base repository and be used to build the OPAM universe that will be \ 76 | loaded by the solver." 77 | in 78 | Arg.(value & opt (list repo_c) [] & info ["repos"] ~docv:"REPOS" ~doc) 79 | 80 | let pins = 81 | let doc = "Specify pinned packages." in 82 | Arg.(value & opt (list pin_c) [] & info ["pins"] ~docv:"PKGS" ~doc) 83 | 84 | let to_option = function 85 | | [] -> None 86 | | l -> Some l 87 | 88 | let main = 89 | let master store packages base_repo extra_repos pins rev_deps = 90 | if rev_deps <> `None then 91 | info "rev-deps" Fmt.(to_to_string Task.pp_rev_deps rev_deps); 92 | if packages = [] then () 93 | else 94 | let repos = base_repo :: extra_repos in 95 | let pins = to_option pins in 96 | let task = Task.create ~rev_deps ?pins ~repos packages in 97 | Lwt_main.run begin 98 | store >>= fun store -> 99 | Store.Task.add store task >|= fun () -> 100 | Fmt.(pf stdout) "Task %a added!\n" 101 | Fmt.(styled `Cyan Id.pp) (Task.id task) 102 | end 103 | in 104 | Term.(global master $ store $ packages $ base_repo $ extra_repos 105 | $ pins $ rev_deps), 106 | term_info ~doc:"Add new tasks to CISO" "ciso-add" ~man:[`P "TODO"] 107 | 108 | let () = 109 | match Term.eval main with 110 | | `Error _ -> exit 1 111 | | `Ok () | `Version | `Help -> () 112 | -------------------------------------------------------------------------------- /bin/ciso_common.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | open Cmdliner 20 | open Lwt.Infix 21 | 22 | let info x y = 23 | if !Gol.verbose then Fmt.(pf stdout "%a %s\n%!" (styled `Cyan string) x y) 24 | 25 | let err fmt = 26 | Fmt.kstrf (fun str -> 27 | Fmt.(pf stderr "%a %s\n%!" (styled `Red string) "Error:" str) 28 | ) fmt 29 | 30 | let () = 31 | Irmin_unix.install_dir_polling_listener 0.2; 32 | Fmt.(set_style_renderer stdout `Ansi_tty); 33 | Fmt.(set_style_renderer stderr `Ansi_tty) 34 | 35 | let opam_root = 36 | let doc = "The OPAM root to use to store the worker state." in 37 | Arg.(value & opt (some string) None & info ["r";"opam-root"] ~docv:"DIR" ~doc) 38 | 39 | let local = 40 | let doc = "The path to the local Irmin store."in 41 | Arg.(value & opt (some string) None & info ["local"] ~docv:"DIR" ~doc) 42 | 43 | let global = 44 | let doc = "The URI of the global Irmin store." in 45 | Arg.(value & opt (some string) None & info ["global"] ~docv:"URI" ~doc) 46 | 47 | let err_invalid_line l = err "invalid line: %S" l 48 | 49 | let config_file () = 50 | let dot_ciso = ".ciso" in 51 | if not (Sys.file_exists dot_ciso) then Lwt.return (fun _ -> None) 52 | else 53 | let lines = Lwt_io.lines_of_file dot_ciso in 54 | Lwt_stream.to_list lines >|= fun lines -> 55 | let kvs = 56 | List.fold_left (fun acc l -> 57 | if String.length l = 0 || l.[0] = '#' then acc 58 | else match Stringext.cut l ~on:" " with 59 | | Some (k, v) -> (k, v) :: acc 60 | | _ -> err_invalid_line l; acc 61 | ) [] lines 62 | in 63 | let find name = 64 | try 65 | let v = List.assoc (name ^ ":") kvs in 66 | Some (String.trim v) 67 | with Not_found -> 68 | None 69 | in 70 | find 71 | 72 | let choose_store local global = match local, global with 73 | | Some l, _ -> info "local " l ; Store.local ~root:l () 74 | | None, Some r -> info "remote" r; Store.remote ~uri:(Uri.of_string r) () 75 | | None, None -> err "no store specified!"; exit 1 76 | 77 | let store = 78 | let mk local global = 79 | match local, global with 80 | | None, None -> 81 | config_file () >>= fun config -> 82 | info "config" ".ciso"; 83 | choose_store (config "local") (config "global") 84 | | _ -> choose_store local global 85 | in 86 | Term.(pure mk $ local $ global) 87 | 88 | let block _ = 89 | let t, _ = Lwt.task () in 90 | t 91 | 92 | (* Global options *) 93 | type global = { verbose: bool; } 94 | 95 | let app_global g = Gol.verbose := g.verbose 96 | 97 | (* Help sections common to all commands *) 98 | let global_option_section = "COMMON OPTIONS" 99 | let help_sections = [ 100 | `S global_option_section; 101 | `P "These options are common to all commands."; 102 | `S "AUTHORS"; 103 | `P "Thomas Gazagnaire "; `Noblank; 104 | `P "David Sheets "; `Noblank; 105 | `P "Qi Li "; 106 | `S "BUGS"; 107 | `P "Check bug reports at https://github.com/samoht/ciso/issues."; 108 | ] 109 | 110 | let global_t = 111 | let verbose = 112 | let doc = 113 | Arg.info ~docs:global_option_section ~doc:"Be verbose." ["v";"verbose"] in 114 | Arg.(value & flag & doc) 115 | in 116 | Term.(pure (fun verbose -> { verbose }) $ verbose) 117 | 118 | let term_info ~doc ?(man=[]) title = 119 | let man = man @ help_sections in 120 | Term.info 121 | ~version:Version.current ~sdocs:global_option_section ~doc ~man title 122 | 123 | let global f = 124 | let g global f = app_global global; f in 125 | Term.(pure g $ global_t $ pure f) 126 | -------------------------------------------------------------------------------- /bin/ciso_common.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | val info: string -> string -> unit 20 | val err: ('a, Format.formatter, unit, unit) format4 -> 'a 21 | val block: 'a -> unit Lwt.t 22 | 23 | val opam_root: string option Cmdliner.Term.t 24 | 25 | val local: string option Cmdliner.Term.t 26 | 27 | val store: Store.t Lwt.t Cmdliner.Term.t 28 | 29 | val config_file: unit -> (string -> string option) Lwt.t 30 | 31 | open Cmdliner 32 | 33 | val term_info: doc:string -> ?man:Manpage.block list -> string -> Term.info 34 | 35 | val global: 'a -> 'a Term.t 36 | -------------------------------------------------------------------------------- /bin/ciso_publish.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | open Cmdliner 20 | open Lwt.Infix 21 | open Irmin_unix 22 | open Ciso_common 23 | 24 | module S = 25 | Irmin_git.FS(Irmin.Contents.String)(Irmin.Ref.String)(Irmin.Hash.SHA1) 26 | module Server = Irmin_http_server.Make(S) 27 | 28 | let server local uri = 29 | Lwt_main.run begin 30 | let root = match local with 31 | | Some r -> Lwt.return r 32 | | None -> 33 | config_file () >|= fun config -> 34 | match config "local" with 35 | | Some r -> r 36 | | None -> err "no store specified!"; exit 1 37 | in 38 | root >>= fun root -> 39 | let config = Irmin_git.config ~root ~bare:true () in 40 | S.Repo.create config >>= S.master Irmin_unix.task >>= fun t -> 41 | let callback = Server.http_spec (t "start server") in 42 | let port = match Uri.port (Uri.of_string uri) with 43 | | None -> 80 44 | | Some p -> p 45 | in 46 | Cohttp_lwt_unix.Server.create ~mode:(`TCP (`Port port)) callback 47 | end 48 | 49 | let uri = 50 | let doc = "Local URI where the database will be published." in 51 | Arg.(required & pos 0 (some string) None & info [] ~doc ~docv:"URI") 52 | 53 | let main () = 54 | Term.(pure server $ local $ uri), 55 | term_info ~doc:"Publish the database over HTTP" "ciso-publish" 56 | 57 | let () = match Term.eval (main ()) with 58 | | `Error _ -> exit 1 59 | | `Help | `Ok _ | `Version -> () 60 | -------------------------------------------------------------------------------- /bin/ciso_schedule.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | open Cmdliner 20 | open Lwt.Infix 21 | include Ciso_common 22 | 23 | let main = 24 | let master store = 25 | Lwt_main.run begin 26 | store >>= fun store -> 27 | Scheduler.start store >>= block 28 | end 29 | in 30 | Term.(global master $ store), 31 | term_info ~doc:"Run the CISO scheduler" "ciso-master" 32 | 33 | let () = 34 | match Term.eval main with `Error _ -> exit 1 | _ -> exit 0 35 | -------------------------------------------------------------------------------- /bin/ciso_show.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | 20 | 21 | open Cmdliner 22 | open Lwt.Infix 23 | include Ciso_common 24 | 25 | let id_t: [`Id] Id.t Arg.converter = 26 | let parse x = `Ok (Id.of_string `Id x) in 27 | let print = Id.pp in 28 | parse, print 29 | 30 | let id = 31 | let doc = "Object identifier" in 32 | Arg.(value & opt (some id_t) None & info ["id"] ~doc ~docv:"HASH") 33 | 34 | let one ?(pad=0) pp pp_status ppf (id, v) = 35 | match v with 36 | | None -> 37 | Fmt.(styled `Cyan Id.pp ppf) id; 38 | Fmt.(pf ppf " --\n") 39 | | Some (v, s) -> 40 | Fmt.box ~indent:2 pp ppf v; 41 | match s with 42 | | None -> () 43 | | Some s -> 44 | let pad = String.make pad ' ' in 45 | let underline = Fmt.(styled `Underline string) in 46 | Fmt.pf ppf "%a%s: %a\n" underline "status" pad pp_status s 47 | 48 | let block ?pad title pp pp_status b = 49 | let bar ppf = Fmt.pf ppf "\n=== %s ===\n\n" in 50 | Fmt.(styled `Yellow bar stdout) title; 51 | match b with 52 | | [] -> Fmt.(string stdout) "None!\n\n" 53 | | _ -> 54 | Fmt.(list (one ?pad pp pp_status) stdout) b; 55 | Fmt.(cut stdout) () 56 | 57 | let find (get, status) t x = 58 | Lwt.catch 59 | (fun () -> 60 | get t x >>= fun y -> 61 | status t x >|= fun s -> 62 | x, Some (y, s)) 63 | (function Invalid_argument _ -> Lwt.return (x, None) | e -> Lwt.fail e) 64 | 65 | let kind = 66 | let doc = "Select the kind of objects to show." in 67 | let choices = [ 68 | "tasks" , `Task; 69 | "workers", `Worker; 70 | "jobs" , `Job; 71 | "hosts" , `Host 72 | ] in 73 | Arg.(value & opt (enum choices) `Task & info ["k";"kind"] ~docv:"KIND" ~doc) 74 | 75 | let cast k id = Id.of_string k (Id.to_string id) 76 | 77 | let list_tasks store = 78 | Store.Task.list store >>= fun task_ids -> 79 | Lwt_list.map_p (find Store.Task.(get, status) store) task_ids 80 | >|= fun tasks -> 81 | block "Tasks" Task.pp Task.pp_status tasks ~pad:2 82 | 83 | let list_jobs store = 84 | Store.Job.list store >>= fun job_ids -> 85 | Lwt_list.map_p (find Store.Job.(get, status) store) job_ids 86 | >|= fun jobs -> 87 | block "Jobs" Job.pp Job.pp_status jobs ~pad:2 88 | 89 | let list_workers store = 90 | Store.Worker.list store >>= fun worker_ids -> 91 | Lwt_list.map_p (find Store.Worker.(get, status) store) worker_ids 92 | >|= fun workers -> 93 | block "Workers" Worker.pp Worker.pp_status workers 94 | 95 | let list_hosts _ = 96 | let hosts = 97 | List.map (fun h -> Host.id h, Some (h, None)) Host.defaults 98 | in 99 | block "Hosts" Host.pp Fmt.string hosts; 100 | Lwt.return_unit 101 | 102 | let task_id store id = 103 | find Store.Task.(get, status) store (cast `Task id) >|= function 104 | | _, None -> None 105 | | x -> Some (fun () -> one Task.pp Task.pp_status Fmt.stdout x ~pad:2) 106 | 107 | let job_id store id = 108 | find Store.Job.(get, status) store (cast `Job id) >|= function 109 | | _, None -> None 110 | | x -> Some (fun () -> one Job.pp Job.pp_status Fmt.stdout x ~pad:2) 111 | 112 | let worker_id store id = 113 | find Store.Worker.(get, status) store (cast `Worker id) >|= function 114 | | _, None -> None 115 | | x -> Some (fun () -> one Worker.pp Worker.pp_status Fmt.stdout x) 116 | 117 | let (>>) x y = 118 | x >>= function 119 | | Some f -> Lwt.return (f ()) 120 | | None -> y () 121 | 122 | let invalid_id id = err "invalid id: %a" Id.pp id; exit 1 123 | 124 | let main = 125 | let list store kind id = 126 | Lwt_main.run begin 127 | store >>= fun store -> 128 | match id with 129 | | Some id -> 130 | task_id store id >> fun () -> 131 | job_id store id >> fun () -> 132 | worker_id store id >> fun () -> 133 | invalid_id id 134 | | None -> 135 | match kind with 136 | | `Task -> list_tasks store 137 | | `Job -> list_jobs store 138 | | `Worker -> list_workers store 139 | | `Host -> list_hosts store 140 | end 141 | in 142 | Term.(global list $ store $ kind $ id), 143 | term_info ~doc:"Show CISO objects" "ciso-show" 144 | 145 | let () = 146 | match Term.eval main with `Error _ -> exit 1 | _ -> exit 0 147 | -------------------------------------------------------------------------------- /bin/ciso_work.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | open Cmdliner 20 | open Lwt.Infix 21 | include Ciso_common 22 | 23 | let (/) = Filename.concat 24 | 25 | let tmp_dir = Filename.get_temp_dir_name () 26 | 27 | let task = 28 | let doc = "Start a task worker." in 29 | Arg.(value & flag & info ["task"] ~doc) 30 | 31 | let start store opam_root = function 32 | | true -> Task_worker.start ~opam_root store >>= block 33 | | false -> Job_worker.start ~opam_root store >>= block 34 | 35 | let mk_opam_root x = 36 | let return x = info "opam " x; Lwt.return x in 37 | let x = match x with 38 | | Some r -> return r 39 | | None -> 40 | config_file () >>= fun config -> 41 | match config "opam-root" with 42 | | None -> return (tmp_dir / (Id.uuid `Worker |> Id.to_string)) 43 | | Some r -> return r 44 | in 45 | x 46 | 47 | let main = 48 | let worker store opam_root task = 49 | info "kind " (if task then "task" else "job"); 50 | Lwt_main.run begin 51 | store >>= fun store -> 52 | mk_opam_root opam_root >>= fun opam_root -> 53 | start store opam_root task 54 | end 55 | in 56 | Term.(global worker $ store $ opam_root $ task), 57 | term_info ~doc:"Start a new CISO worker" "ciso-worker" 58 | 59 | let () = 60 | match Term.eval main with `Error _ -> exit 1 | _ -> exit 0 61 | -------------------------------------------------------------------------------- /ciso.install: -------------------------------------------------------------------------------- 1 | bin: [ 2 | "?_build/bin/ciso_show.byte" {"ciso-show"} 3 | "?_build/bin/ciso_show.native" {"ciso-show"} 4 | "?_build/bin/ciso_add.byte" {"ciso-add"} 5 | "?_build/bin/ciso_add.native" {"ciso-add"} 6 | "?_build/bin/ciso_work.byte" {"ciso-work"} 7 | "?_build/bin/ciso_work.native" {"ciso-work"} 8 | "?_build/bin/ciso_publish.byte" {"ciso-publish"} 9 | "?_build/bin/ciso_publish.native" {"ciso-publish"} 10 | "?_build/bin/ciso_schedule.byte" {"ciso-schedule"} 11 | "?_build/bin/ciso_schedule.native" {"ciso-schedule"} 12 | "?_build/bin/ciso.byte" {"ciso"} 13 | "?_build/bin/ciso.native" {"ciso"} 14 | ] -------------------------------------------------------------------------------- /configure: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # OASIS_START 4 | # DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499) 5 | set -e 6 | 7 | FST=true 8 | for i in "$@"; do 9 | if $FST; then 10 | set -- 11 | FST=false 12 | fi 13 | 14 | case $i in 15 | --*=*) 16 | ARG=${i%%=*} 17 | VAL=${i##*=} 18 | set -- "$@" "$ARG" "$VAL" 19 | ;; 20 | *) 21 | set -- "$@" "$i" 22 | ;; 23 | esac 24 | done 25 | 26 | ocaml setup.ml -configure "$@" 27 | # OASIS_STOP 28 | -------------------------------------------------------------------------------- /lib/META: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: a46dc4ee23013e7e5a125ed29c9d0567) 3 | version = "0.1.0" 4 | description = "distributed integration engine for opam packages" 5 | requires = "irmin.unix lwt uuidm fmt nocrypto uri jsont.jsonm hex bytes" 6 | archive(byte) = "ciso.cma" 7 | archive(byte, plugin) = "ciso.cma" 8 | archive(native) = "ciso.cmxa" 9 | archive(native, plugin) = "ciso.cmxs" 10 | exists_if = "ciso.cma" 11 | package "worker" ( 12 | version = "0.1.0" 13 | description = "distributed integration engine for opam packages" 14 | requires = 15 | "ciso irmin.unix opam-lib.client ocamlgraph threads cstruct.unix rresult" 16 | archive(byte) = "ciso-worker.cma" 17 | archive(byte, plugin) = "ciso-worker.cma" 18 | archive(native) = "ciso-worker.cmxa" 19 | archive(native, plugin) = "ciso-worker.cmxs" 20 | exists_if = "ciso-worker.cma" 21 | ) 22 | 23 | package "github" ( 24 | version = "0.1.0" 25 | description = "distributed integration engine for opam packages" 26 | requires = "ciso ciso.worker github.unix lwt" 27 | archive(byte) = "ciso-github.cma" 28 | archive(byte, plugin) = "ciso-github.cma" 29 | archive(native) = "ciso-github.cmxa" 30 | archive(native, plugin) = "ciso-github.cmxs" 31 | exists_if = "ciso-github.cma" 32 | ) 33 | # OASIS_STOP 34 | 35 | -------------------------------------------------------------------------------- /lib/ciso.mldylib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 31f27d506b6cfb9ecf41c2f017cf2111) 3 | Id 4 | Task 5 | Job 6 | Object 7 | Package 8 | Host 9 | Switch 10 | Worker 11 | Store 12 | Scheduler 13 | Version 14 | Gol 15 | # OASIS_STOP 16 | -------------------------------------------------------------------------------- /lib/ciso.mllib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 31f27d506b6cfb9ecf41c2f017cf2111) 3 | Id 4 | Task 5 | Job 6 | Object 7 | Package 8 | Host 9 | Switch 10 | Worker 11 | Store 12 | Scheduler 13 | Version 14 | Gol 15 | # OASIS_STOP 16 | -------------------------------------------------------------------------------- /lib/ciso.odocl: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: a58b8d40584faefecedee00f29234d66) 3 | Id 4 | Task 5 | Job 6 | Object 7 | Package 8 | Host 9 | Switch 10 | Worker 11 | Store 12 | Scheduler 13 | Version 14 | worker/Task_worker 15 | worker/Job_worker 16 | # OASIS_STOP 17 | -------------------------------------------------------------------------------- /lib/github/ciso-github.mldylib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 9df75573bffb5ba4c9497f524b4bde44) 3 | Github_pr 4 | # OASIS_STOP 5 | -------------------------------------------------------------------------------- /lib/github/ciso-github.mllib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 9df75573bffb5ba4c9497f524b4bde44) 3 | Github_pr 4 | # OASIS_STOP 5 | -------------------------------------------------------------------------------- /lib/github/github_pr.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | type pr = { 20 | pull_num : int; 21 | repo_url : string; 22 | base_sha : string; 23 | head_sha : string; 24 | } 25 | 26 | type t = 27 | | Github of string * string option * pr 28 | (* package name * version * pull *) 29 | 30 | let make_pull num url base head = { 31 | pull_num = num; 32 | repo_url = url; 33 | base_sha = base; 34 | head_sha = head; 35 | } 36 | 37 | let make_gh_task ~name ?version pr = Github (name, version, pr) 38 | 39 | (* 40 | 41 | let user = "ocaml" 42 | let repo = "opam-repository" 43 | let token = ref None 44 | 45 | let init_gh_token name = 46 | Github_cookie_jar.init () 47 | >>= fun jar -> Github_cookie_jar.get jar ~name 48 | >>= function 49 | | Some auth -> Lwt.return (Github.Token.of_auth auth) 50 | | None -> err "None auth" 51 | 52 | (* /packages///{opam, url, descr, files/.., etc} *) 53 | let packages_of_pull token num = 54 | let open Github.Monad in 55 | Github.Pull.files ~token ~user ~repo ~num () |> Github.Stream.to_list 56 | >|= fun files -> 57 | List.fold_left (fun acc file -> 58 | let parts = Array.of_list 59 | (Str.split (Str.regexp "/") file.Github_t.file_filename) in 60 | let pkg = try 61 | if parts.(0) = "packages" && parts.(3) <> "descr" 62 | then parts.(2) else "" 63 | with _ -> "" in 64 | if pkg <> "" && not (List.mem pkg acc) then pkg :: acc else acc) 65 | [] files 66 | 67 | let pull_info token num = 68 | let open Github_t in 69 | let open Github.Monad in 70 | Github.Pull.get ~token ~user ~repo ~num () 71 | >|= fun pull_resp -> 72 | let pull = Github.Response.value pull_resp in 73 | let base = pull.pull_base and head = pull.pull_head in 74 | let base_repo = 75 | match base.branch_repo with Some repo -> repo | None -> failwith "pr_info" 76 | in 77 | Task.make_pull 78 | num base_repo.repository_clone_url base.branch_sha head.branch_sha 79 | 80 | let resolve_and_add s ?pull pkg = 81 | let action_graph = Ci_opam.resolve [pkg] in 82 | let jobs = Ci_opam.jobs_of_graph ?pull action_graph in 83 | update_tables s jobs >|= fun () -> 84 | let r, sum = count_runnables () in 85 | debug "resolve %d/%d jobs" r sum 86 | 87 | let github_hook s num = 88 | (match !token with 89 | | Some t -> Lwt.return t 90 | | None -> begin 91 | init_gh_token "scry" 92 | >>= fun t -> 93 | token := Some t; 94 | Lwt.return t 95 | end) 96 | >>= fun token -> Github.Monad.run (pull_info token num) 97 | >>= fun pull -> Github.Monad.run (packages_of_pull token num) 98 | >>= fun pkgs -> Lwt_list.iter_s (resolve_and_add s ~pull) pkgs 99 | 100 | *) 101 | -------------------------------------------------------------------------------- /lib/github/github_pr.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | type pr 20 | type t 21 | 22 | val make_gh_task: name:string -> ?version:string -> pr -> t 23 | val make_pull: int -> string -> string -> string -> pr 24 | -------------------------------------------------------------------------------- /lib/gol.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | let verbose = ref false 18 | 19 | let timestamp () = 20 | let tm = Unix.localtime (Unix.time ()) in 21 | let open Unix in 22 | Printf.sprintf "%d:%d:%d" tm.tm_hour tm.tm_min tm.tm_sec 23 | 24 | let debug ~section fmt = 25 | let header ppf () = Fmt.(pf ppf "[%s %s]" (timestamp ()) section) in 26 | Fmt.kstrf (fun str -> 27 | if !verbose then 28 | Fmt.(pf stdout "%a %s\n%!" (styled `Magenta header) () str) 29 | ) fmt 30 | 31 | let show_block = 32 | let pp_field ppf (i, k, v) = 33 | let color = if i = 0 then Fmt.(styled `Cyan) else (fun x -> x) in 34 | Fmt.pf ppf "@[%a: @[<4>%a@]@]@." 35 | Fmt.(styled `Bold string) k 36 | Fmt.(color (list ~sep:sp string)) v 37 | in 38 | let pp_fields ppf block = 39 | let block = List.filter (fun (_, l) -> l <> []) block in 40 | let block = List.mapi (fun i (k, v) -> i, k, v) block in 41 | List.iter (pp_field ppf) block 42 | in 43 | fun ppf block -> Fmt.pf ppf "@[%a@]" pp_fields block 44 | -------------------------------------------------------------------------------- /lib/gol.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (** Internal logging module. *) 18 | 19 | val verbose: bool ref 20 | (** Be verbose. *) 21 | 22 | val timestamp: unit -> string 23 | (** Generate a [HH:MM:SS] timestamp. *) 24 | 25 | val debug: section:string -> ('a, Format.formatter, unit, unit) format4 -> 'a 26 | (** Display a debug line on stdout. *) 27 | 28 | val show_block: (string * string list) list Fmt.t 29 | (** Show a block of key/value pairs. *) 30 | -------------------------------------------------------------------------------- /lib/host.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | let verbose = ref false 20 | 21 | (* 22 | From opam-depext: 23 | - https://github.com/ocaml/opam-depext 24 | - tip: fc183489fb9ee2265b6d969fcab846d38bceb937 25 | *) 26 | 27 | let lines_of_channel ic = 28 | let rec aux acc = 29 | let line = try Some (input_line ic) with End_of_file -> None in 30 | match line with 31 | | Some s -> aux (s::acc) 32 | | None -> acc 33 | in 34 | List.rev (aux []) 35 | 36 | let lines_of_command c = 37 | if not !verbose then Printf.eprintf "+ %s\n%!" c; 38 | let ic = Unix.open_process_in c in 39 | let lines = lines_of_channel ic in 40 | close_in ic; 41 | lines 42 | 43 | let lines_of_file f = 44 | let ic = open_in f in 45 | let lines = lines_of_channel ic in 46 | close_in ic; 47 | lines 48 | 49 | let command_output c = 50 | match lines_of_command c with 51 | | [s] -> s 52 | | _ -> failwith (Printf.sprintf "Command %S failed" c) 53 | 54 | let string_split char str = 55 | let rec aux pos = 56 | try 57 | let i = String.index_from str pos char in 58 | String.sub str pos (i - pos) :: aux (succ i) 59 | with Not_found | Invalid_argument _ -> 60 | let l = String.length str in 61 | [ String.sub str pos (l - pos) ] 62 | in 63 | aux 0 64 | 65 | let has_command c = 66 | let cmd = Printf.sprintf "command -v %s >/dev/null" c in 67 | try Sys.command cmd = 0 with Sys_error _ -> false 68 | 69 | (* system detection *) 70 | 71 | let guess_arch () = 72 | match command_output "uname -m" with 73 | | "x86_64" -> `X86_64 74 | | "x86" | "i386" | "i586" | "i686" -> `X86 75 | | "armv7l" -> `Arm7 76 | | "PPC" | "PowerPC" -> `PPC 77 | | s -> `Other s 78 | 79 | let guess_os () = match Sys.os_type with 80 | | "Unix" -> 81 | (match command_output "uname -s" with 82 | | "Darwin" -> `Darwin 83 | | "Linux" -> `Linux 84 | | "FreeBSD" -> `FreeBSD 85 | | "OpenBSD" -> `OpenBSD 86 | | "NetBSD" -> `NetBSD 87 | | "DragonFly" -> `DragonFly 88 | | _ -> `Unix) 89 | | "Win32" -> `Win32 90 | | "Cygwin" -> `Cygwin 91 | | s -> `Other s 92 | 93 | let guess_distrib = function 94 | | `Darwin -> 95 | if has_command "brew" then Some `Homebrew 96 | else if has_command "port" then Some `Macports 97 | else None 98 | | `Linux -> 99 | (try 100 | let name = 101 | if has_command "lsb_release" then 102 | command_output "lsb_release -i -s" 103 | else 104 | let release_file = 105 | List.find Sys.file_exists 106 | ["/etc/redhat-release"; "/etc/centos-release"; 107 | "/etc/gentoo-release"; "/etc/issue"; "/etc/os-release"] 108 | in 109 | List.hd (string_split ' ' (List.hd (lines_of_file release_file))) 110 | in 111 | match String.lowercase name with 112 | | "debian" -> Some `Debian 113 | | "ubuntu" -> Some `Ubuntu 114 | | "centos" -> Some `Centos 115 | | "fedora" -> Some `Fedora 116 | | "mageia" -> Some `Mageia 117 | | "gentoo" -> Some `Gentoo 118 | | "archlinux" -> Some `Archlinux 119 | | s -> Some (`Other s) 120 | with Not_found | Failure _ -> None) 121 | | _ -> None 122 | 123 | type arch = [ 124 | | `X86_64 125 | | `X86 126 | | `Arm7 127 | | `PPC 128 | | `Other of string 129 | ] 130 | 131 | let string_of_arch = function 132 | | `X86_64 -> "x86_64" 133 | | `X86 -> "x86" 134 | | `Arm7 -> "armv7" 135 | | `PPC -> "ppc" 136 | | `Other s -> String.lowercase s 137 | 138 | let arch_of_string = function 139 | | "x86_64" -> `Ok `X86_64 140 | | "x86" -> `Ok `X86 141 | | "armv7" -> `Ok `Arm7 142 | | "ppc" -> `Ok `PPC 143 | | s -> `Ok (`Other s) 144 | 145 | type os = [ 146 | | `Darwin 147 | | `Linux 148 | | `Unix 149 | | `FreeBSD 150 | | `OpenBSD 151 | | `NetBSD 152 | | `DragonFly 153 | | `Win32 154 | | `Cygwin 155 | | `Other of string 156 | ] 157 | 158 | let string_of_os = function 159 | | `Darwin -> "osx" 160 | | `Linux -> "linux" 161 | | `Unix -> "unix" 162 | | `FreeBSD -> "freebsd" 163 | | `OpenBSD -> "openbsd" 164 | | `NetBSD -> "netbsd" 165 | | `DragonFly -> "dragonfly" 166 | | `Win32 -> "win32" 167 | | `Cygwin -> "cygwin" 168 | | `Other s -> String.lowercase s 169 | 170 | let os_of_string = function 171 | | "osx" -> `Ok `Darwin 172 | | "linux" -> `Ok `Linux 173 | | "unix" -> `Ok `Unix 174 | | "freebsd" -> `Ok `FreeBSD 175 | | "openbsd" -> `Ok `OpenBSD 176 | | "netbsd" -> `Ok `NetBSD 177 | | "dragonfly" -> `Ok `DragonFly 178 | | "win32" -> `Ok `Win32 179 | | "cygwin" -> `Ok `Cygwin 180 | | s -> `Ok (`Other s) 181 | 182 | type distr = [ 183 | | `Homebrew 184 | | `Macports 185 | | `Debian 186 | | `Ubuntu 187 | | `Centos 188 | | `Fedora 189 | | `Mageia 190 | | `Archlinux 191 | | `Gentoo 192 | | `Other of string 193 | ] 194 | 195 | let string_of_distr = function 196 | | `Homebrew -> "homebrew" 197 | | `Macports -> "macports" 198 | | `Debian -> "debian" 199 | | `Ubuntu -> "ubuntu" 200 | | `Centos -> "centos" 201 | | `Fedora -> "fedora" 202 | | `Mageia -> "mageia" 203 | | `Archlinux -> "archlinux" 204 | | `Gentoo -> "gentoo" 205 | | `Other s -> String.lowercase s 206 | 207 | let distr_of_string = function 208 | | "homebrew" -> `Ok `Homebrew 209 | | "macports" -> `Ok `Macports 210 | | "debian" -> `Ok `Debian 211 | | "ubuntu" -> `Ok `Ubuntu 212 | | "centos" -> `Ok `Centos 213 | | "fedora" -> `Ok `Fedora 214 | | "mageia" -> `Ok `Mageia 215 | | "archlinux" -> `Ok `Archlinux 216 | | "gentoo" -> `Ok `Gentoo 217 | | s -> `Ok (`Other s) 218 | 219 | (* end of copy-pate *) 220 | 221 | type id = [`Host] Id.t 222 | 223 | type t = { 224 | id: id; 225 | arch: arch; 226 | os: os; 227 | distr: distr option; 228 | } 229 | 230 | let id t = t.id 231 | 232 | let short_aux arch os distr = 233 | Printf.sprintf "%s:%s:%s" 234 | (string_of_arch arch) (string_of_os os) 235 | (match distr with None -> "-" | Some d -> string_of_distr d) 236 | 237 | let short t = short_aux t.arch t.os t.distr 238 | let os t = t.os 239 | 240 | let create arch os distr = 241 | let id = Id.digest `Host (short_aux arch os distr) in 242 | { id; arch; os; distr } 243 | 244 | let detect () = 245 | let os = guess_os () in 246 | create (guess_arch ()) os (guess_distrib os) 247 | 248 | let pp_arch ppf x = Fmt.string ppf (string_of_arch x) 249 | let pp_os ppf x = Fmt.string ppf (string_of_os x) 250 | let pp_distr ppf x = Fmt.string ppf (string_of_distr x) 251 | 252 | let pp ppf t = 253 | let mk pp x = [Fmt.to_to_string pp x] in 254 | let block = [ 255 | "id: ", mk Id.pp t.id; 256 | "arch ", mk pp_arch t.arch; 257 | "os: ", mk pp_os t.os; 258 | "distr", match t.distr with None -> [] | Some d -> mk pp_distr d; 259 | ] in 260 | Gol.show_block ppf block 261 | 262 | let json_arch = Jsont.view (arch_of_string, string_of_arch) Jsont.string 263 | let json_os = Jsont.view (os_of_string, string_of_os) Jsont.string 264 | let json_distr = Jsont.view (distr_of_string, string_of_distr) Jsont.string 265 | 266 | let json = 267 | let o = Jsont.objc ~kind:"host" () in 268 | let arch = Jsont.(mem o "arch" json_arch) in 269 | let os = Jsont.(mem o "os" json_os) in 270 | let distr = Jsont.(mem_opt o "distr" json_distr) in 271 | let c = Jsont.obj ~seal:true o in 272 | let dec o = 273 | let get f = Jsont.get f o in 274 | `Ok (create (get arch) (get os) (get distr)) 275 | in 276 | let enc t = 277 | Jsont.(new_obj c [memv arch t.arch; memv os t.os; memv distr t.distr]) 278 | in 279 | Jsont.view (dec, enc) c 280 | 281 | 282 | let defaults = 283 | List.map (fun (a, o, s) -> create a o s) 284 | [ 285 | (`X86_64, `Linux , Some `Ubuntu); 286 | (`X86_64, `Darwin, Some `Homebrew); 287 | ] 288 | 289 | let equal x y = Id.equal x.id y.id 290 | let compare x y = Id.compare x.id y.id 291 | -------------------------------------------------------------------------------- /lib/host.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Detection of host configuration. *) 20 | 21 | type t 22 | (** The type for host configuration. *) 23 | 24 | type id = [`Host] Id.t 25 | (** The type for deterministic host identifiers. *) 26 | 27 | val id: t -> id 28 | (** [id t] is [t]'s deterministic identifier. Is it obtaining by 29 | hashing a stable representation of [t]'s components. *) 30 | 31 | val detect: unit -> t 32 | (** Detects the host configuration. *) 33 | 34 | val compare: t -> t -> int 35 | (** [compare] compares host configurations. *) 36 | 37 | val equal: t -> t -> bool 38 | (** [equal] is the equality for host configurations. *) 39 | 40 | val short: t -> string 41 | (** [short t] is the short represention of [t], useful to be displayed 42 | on a logging line. *) 43 | 44 | val pp: t Fmt.t 45 | (** [pp] formats a {{!t}host configuration}. *) 46 | 47 | val json: t Jsont.codec 48 | (** [json] is the JSON codec for host configurations. *) 49 | 50 | val defaults: t list 51 | (** [defaults] is the list of host configurations supported by 52 | default. *) 53 | 54 | type os = [ 55 | | `Darwin 56 | | `Linux 57 | | `Unix 58 | | `FreeBSD 59 | | `OpenBSD 60 | | `NetBSD 61 | | `DragonFly 62 | | `Win32 63 | | `Cygwin 64 | | `Other of string 65 | ] 66 | (** The type for OS configuration. *) 67 | 68 | val pp_os: os Fmt.t 69 | (** [pp_os] format OS configurations. *) 70 | 71 | val os: t -> os 72 | (** [os t] is [t]'s OS. *) 73 | -------------------------------------------------------------------------------- /lib/id.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | type 'a t = string 20 | 21 | let compare x y = String.compare x y 22 | let equal x y = compare x y = 0 23 | let json = Jsont.string 24 | let of_string _ x = x 25 | let to_string x = x 26 | let pp = Format.pp_print_string 27 | 28 | let digest_cstruct _kind buf = 29 | let `Hex h = 30 | Hex.of_cstruct (Nocrypto.Hash.SHA1.digest buf) 31 | in 32 | h 33 | 34 | let digest kind str = digest_cstruct kind (Cstruct.of_string str) 35 | 36 | let uuid _kind = 37 | let `Hex h = 38 | Hex.of_string (Uuidm.to_bytes (Uuidm.create `V4)) 39 | in 40 | h 41 | -------------------------------------------------------------------------------- /lib/id.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Unique identifiers. 20 | 21 | This module handle both deterministic identifiers for 22 | {{!module:Object}objects}, {{!module:Job}jobs} and 23 | {{!module:Task}tasks} and randaom unique identifiers for 24 | {{!module:Worker}workers}. 25 | *) 26 | 27 | type 'a t 28 | (** The type for deterministic or random dentifiers. *) 29 | 30 | val uuid: 'a -> 'a t 31 | (** [uuid k] is a a 128 bits universally unique identifiers (UUID) 32 | version 4 (random based) according to 33 | {{:http://tools.ietf.org/html/rfc4122}RFC 4122}. *) 34 | 35 | val digest: 'a -> string -> 'a t 36 | (** [digest k s] is [s]'s SHA1 digest. *) 37 | 38 | val digest_cstruct: 'a -> Cstruct.t -> 'a t 39 | (** [digest_cstruct k s] is [s]'s SHA1 digest. *) 40 | 41 | val compare: 'a t -> 'a t -> int 42 | (** [compare] is the comparison for identifiers. *) 43 | 44 | val equal: 'a t -> 'a t -> bool 45 | (** [equal] is the equality for identifiers. *) 46 | 47 | val pp: 'a t Fmt.t 48 | (** [pp t] formats [t]. *) 49 | 50 | val json: 'a t Jsont.codec 51 | (** [json] is the JSON codec for identifiers. *) 52 | 53 | val of_string: 'a -> string -> 'a t 54 | (** [of_string] is the identity function. *) 55 | 56 | val to_string: 'a t -> string 57 | (** [to_string] is the identity function. *) 58 | -------------------------------------------------------------------------------- /lib/job.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | type id = [`Job] Id.t 20 | 21 | type t = { 22 | id : id; (* the job id *) 23 | inputs : id list; (* the transitive reduction of need jobs *) 24 | switch : Switch.t; (* switch on which to run the job *) 25 | host : Host.t; (* host on which to run the job *) 26 | packages: Package.meta list;(* the list of metadata anout packages to build *) 27 | } 28 | 29 | let equal x y = Id.equal x.id y.id 30 | let compare x y = Id.compare x.id y.id 31 | 32 | let json = 33 | let o = Jsont.objc ~kind:"job" () in 34 | let id = Jsont.mem o "id" Id.json in 35 | let inputs = Jsont.(mem ~opt:`Yes_rem o "inputs" @@ array Id.json) in 36 | let switch = Jsont.(mem o "switch" Switch.json) in 37 | let host = Jsont.(mem o "host" Host.json) in 38 | let packages = Jsont.(mem o "packages" @@ array Package.json_meta) in 39 | let c = Jsont.obj ~seal:true o in 40 | let dec o = 41 | let get m = Jsont.get m o in 42 | `Ok { 43 | id = get id; inputs = get inputs; switch = get switch; 44 | host = get host; packages = get packages 45 | } in 46 | let enc t = 47 | Jsont.(new_obj c [ 48 | memv id t.id; memv inputs t.inputs; 49 | memv switch t.switch; memv host t.host; 50 | memv packages t.packages]) 51 | in 52 | Jsont.view (dec, enc) c 53 | 54 | let pp ppf t = 55 | let mk = Fmt.to_to_string in 56 | let mks pp = List.map (mk pp) in 57 | let short id = String.sub id 0 8 in 58 | let shorts ids = List.map short ids in 59 | let block = [ 60 | "id ", [Id.to_string t.id]; 61 | "inputs ", shorts @@ mks Id.pp t.inputs; 62 | "switch ", [mk Switch.pp t.switch]; 63 | "host ", [Host.short t.host]; 64 | "packages", mks Package.pp @@ List.map Package.pkg t.packages; 65 | ] in 66 | Gol.show_block ppf block 67 | 68 | let id t = t.id 69 | let inputs t = t.inputs 70 | let switch t = t.switch 71 | let host t = t.host 72 | let packages t = t.packages 73 | 74 | let digest buf = Cstruct.to_string (Nocrypto.Hash.SHA1.digest buf) 75 | 76 | let hash ~host ~inputs ~switch ~packages = 77 | let x l = String.concat "+" (List.sort String.compare l) in 78 | let y = String.concat "-" in 79 | let switches = [Fmt.to_to_string Switch.pp switch] in 80 | let hosts = [Fmt.to_to_string Host.pp host] in 81 | let inputs = List.map Id.to_string inputs in 82 | let packages = 83 | List.map (fun m -> 84 | let p = Package.to_string (Package.pkg m) in 85 | let mk f = digest (f m) in 86 | let mko f = match f m with 87 | | None -> [] 88 | | Some k -> [digest k] 89 | in 90 | let mkf (f, c) = f ^ digest c in 91 | let files = List.map mkf (Package.files m) in 92 | y (p :: mk Package.opam :: mko Package.url @ files) 93 | ) packages 94 | in 95 | let str = y [x switches; x hosts; x packages; x inputs] in 96 | Id.digest `Job str 97 | 98 | let create ?(inputs=[]) host switch packages = 99 | let id = hash ~host ~inputs ~switch ~packages in 100 | { id; inputs; switch; host; packages; } 101 | 102 | type core = [ `Pending | `Runnable | `Cancelled ] 103 | type dispatch = [`Pending | `Started] 104 | type complete = [`Success | `Failure] 105 | 106 | type status = [ 107 | | core 108 | | `Complete of complete 109 | | `Dispatched of [`Worker] Id.t * dispatch 110 | ] 111 | 112 | let to_string = function 113 | | `Pending -> "pending" 114 | | `Runnable -> "runnnable" 115 | | `Dispatched -> "dispatched" 116 | | `Started -> "started" 117 | | `Complete -> "complete" 118 | | `Success -> "success" 119 | | `Failure -> "failure" 120 | | `Cancelled -> "cancelled" 121 | 122 | let core = [ `Pending; `Runnable; `Dispatched; `Complete; `Cancelled ] 123 | let dispatch = [ `Pending; `Started] 124 | let complete = [`Success; `Failure] 125 | 126 | let mk_enum status = 127 | let default = List.hd status in 128 | Jsont.enum ~default @@ List.map (fun s -> to_string s, s) status 129 | 130 | (* FIXME: code duplication with Task.json_{params,status} *) 131 | let json_params = 132 | let o = Jsont.objc ~kind:"job-status-params" () in 133 | let worker = Jsont.(mem_opt o "worker" Id.json) in 134 | let status = Jsont.(mem o "status" @@ mk_enum (dispatch @ complete)) in 135 | let c = Jsont.obj ~seal:true o in 136 | let dec o = `Ok (Jsont.get worker o, Jsont.get status o) in 137 | let enc (w, s) = Jsont.(new_obj c [memv worker w; memv status s]) in 138 | Jsont.view (dec, enc) c 139 | 140 | let json_status = 141 | let o = Jsont.objc ~kind:"job-status" () in 142 | let status = Jsont.(mem o "status" @@ mk_enum core) in 143 | let params = Jsont.(mem_opt o "params" json_params) in 144 | let c = Jsont.obj ~seal:true o in 145 | let dec o = 146 | let params = match Jsont.get params o with 147 | | None -> `N 148 | | Some (Some w, (#dispatch as p)) -> `D (w, p) 149 | | Some (None , (#complete as p)) -> `C p 150 | | _ -> `Error "task_params" 151 | in 152 | match Jsont.get status o, params with 153 | | `Dispatched, `D p -> `Ok (`Dispatched p) 154 | | `Complete , `C p -> `Ok (`Complete p) 155 | | #core as x , `N -> `Ok x 156 | | _ -> `Error "task_status" 157 | in 158 | let enc (t:status) = 159 | let cast t = (t :> [dispatch | complete]) in 160 | let s, i = match t with 161 | | `Dispatched (w, p) -> `Dispatched, Some (Some w, cast p) 162 | | `Complete p -> `Complete , Some (None , cast p) 163 | | #core as x -> x , None 164 | in 165 | Jsont.(new_obj c [memv status s; memv params i]) 166 | in 167 | Jsont.view (dec, enc) c 168 | 169 | let is_success = function `Complete `Success -> true | _ -> false 170 | let is_failure = function `Complete `Failure -> true | _ -> false 171 | let is_cancelled = function `Cancelled -> true | _ -> false 172 | 173 | let task_status = function 174 | | [] -> `New 175 | | l -> 176 | if List.for_all is_success l then `Complete `Success 177 | else if List.exists is_failure l then `Complete `Failure 178 | else if List.exists is_cancelled l then `Cancelled 179 | else `Pending 180 | 181 | (* FIXME: code duplication with task.pp_status *) 182 | 183 | let pp_s ppf = Fmt.of_to_string to_string ppf 184 | 185 | let pp_status ppf = function 186 | | `Dispatched (w, s) -> Fmt.pf ppf "dispatched to %a (%a)" Id.pp w pp_s s 187 | | `Complete s -> Fmt.pf ppf "complete: %a" pp_s s 188 | | #core as x -> Fmt.of_to_string to_string ppf x 189 | -------------------------------------------------------------------------------- /lib/job.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Build jobs. 20 | 21 | Jobs are for a given {{!module:Switch}switch} version and 22 | {{!module:Host}host} configurations. Jobs have pre-requisites: 23 | these are {{!module:Object}objects} which needs to be built and be 24 | put into the {{!module:Worker}worker} context before the job could 25 | start. 26 | 27 | Completed jobs produce output {{!module:Object}object(s)} which 28 | will be consummed by other jobs. 29 | *) 30 | 31 | type id = [`Job] Id.t 32 | (** The type for job identifiers. Job identifiers are deterministic, 33 | i.e. similar jobs will have the same identifiers. As for 34 | {{!Task.id}tasks}, the identifier is built by calling {!Id.digest} 35 | on the concatenation of {!create} arguments (after 36 | normalisation). *) 37 | 38 | type t 39 | (** The type for job values. *) 40 | 41 | val create: ?inputs:id list -> Host.t -> Switch.t -> Package.meta list -> t 42 | (** [create h c pkgs] is the job of building the list of packages 43 | [pkgs] using the OCaml compiler switch [c] on a worker having [h] 44 | as host configuration. 45 | 46 | The job will be able to access the outputs objects created by the 47 | (optional) [inputs] jobs. *) 48 | 49 | val id: t -> id 50 | (** [id t] id [t]'s deterministic identifier. It is obtained by hasing 51 | a stable representation of [t]'s components. *) 52 | 53 | val switch: t -> Switch.t 54 | (** [switch t] is [t]'s switch. *) 55 | 56 | val host: t -> Host.t 57 | (** [host t] is [t]'s host. *) 58 | 59 | val inputs: t -> id list 60 | (** [input t] are [t]'s job inputs. *) 61 | 62 | val packages: t -> Package.meta list 63 | (** [packages t] are the package metadata that [t] needs to know 64 | about. *) 65 | 66 | val equal: t -> t -> bool 67 | (** [equal] is the job equality. *) 68 | 69 | val compare: t -> t -> int 70 | (** [compare] compares jobs. *) 71 | 72 | val json: t Jsont.codec 73 | (** [json] is the JSON codec for jobs. *) 74 | 75 | val pp: t Fmt.t 76 | (** [pp] formats jobs. *) 77 | 78 | (** {Job Status} *) 79 | 80 | type status = [ 81 | | `Pending 82 | | `Runnable 83 | | `Dispatched of [`Worker] Id.t * [`Pending | `Started] 84 | | `Complete of [`Success | `Failure] 85 | | `Cancelled 86 | ] 87 | (** The type for job status. *) 88 | 89 | val json_status: status Jsont.codec 90 | (** [json_status] is the JSON codec for job status. *) 91 | 92 | val pp_status: status Fmt.t 93 | (** [pp_status] formats jobs {!status}. *) 94 | 95 | val task_status: status list -> Task.status 96 | (** [task_status s] is the status summary of s. If all status are 97 | [`Success] then it is a [`Success]. If all status are [`Failed] 98 | then it is also [`Failed]. Otherwise it is [`Pending]. *) 99 | -------------------------------------------------------------------------------- /lib/object.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | type id = [`Object] Id.t 20 | 21 | type kind = [ `Archive | `File ] 22 | 23 | type archive = { 24 | files: (string * Digest.t) list; 25 | raw : Cstruct.t; 26 | } 27 | 28 | let pp_file ppf (f, d) = Fmt.pf ppf "%s %s" f (Digest.to_hex d) 29 | let pp_archive ppf t = Fmt.(pf ppf "[@[files: %a@]]" (list pp_file) t.files) 30 | 31 | let json_digest = 32 | let dec o = `Ok (Digest.from_hex o) in 33 | let enc s = Digest.to_hex s in 34 | Jsont.view ~default:(Digest.string "") (dec, enc) Jsont.string 35 | 36 | let json_file_d = 37 | let o = Jsont.objc ~kind:"file" () in 38 | let name = Jsont.mem o "name" Jsont.string in 39 | let digest = Jsont.mem o "digest" json_digest in 40 | let c = Jsont.obj ~seal:true o in 41 | let dec o =`Ok (Jsont.get name o, Jsont.get digest o) in 42 | let enc (n, d) = Jsont.(new_obj c [memv name n; memv digest d]) in 43 | Jsont.view (dec, enc) c 44 | 45 | (* FIXME: it's probably not a good idea to do that. *) 46 | let json_cstruct = 47 | let dec o = `Ok (Cstruct.of_string (Hex.to_string (`Hex o))) in 48 | let enc c = let `Hex h = Hex.of_cstruct c in h in 49 | Jsont.view (dec, enc) Jsont.nat_string 50 | 51 | let json_archive = 52 | let o = Jsont.objc ~kind:"archive" () in 53 | let files = Jsont.(mem o "files" @@ array json_file_d) in 54 | let raw = Jsont.mem o "raw" json_cstruct in 55 | let c = Jsont.obj ~seal:true o in 56 | let dec o = `Ok { files = Jsont.get files o; raw = Jsont.get raw o } in 57 | let enc a = Jsont.(new_obj c [memv files a.files; memv raw a.raw]) in 58 | Jsont.view (dec, enc) c 59 | 60 | type file = string * Cstruct.t 61 | 62 | let pp_file ppf (p, _) = Fmt.string ppf p 63 | 64 | let json_file = 65 | let o = Jsont.objc ~kind:"archive" () in 66 | let name = Jsont.(mem o "name" string) in 67 | let raw = Jsont.(mem o "contents" string) in 68 | let c = Jsont.obj ~seal:true o in 69 | let dec o = `Ok (Jsont.get name o, Cstruct.of_string (Jsont.get raw o)) in 70 | let enc (n, r) = 71 | Jsont.(new_obj c [memv name n; memv raw (Cstruct.to_string r)]) 72 | in 73 | Jsont.view (dec, enc) c 74 | 75 | type contents = Archive of archive | File of file 76 | 77 | let pp_contents ppf = function 78 | | Archive a -> pp_archive ppf a 79 | | File f -> pp_file ppf f 80 | 81 | let json_contents = 82 | let o = Jsont.objc ~kind:"contents" () in 83 | let archive = Jsont.(mem_opt o "archive" json_archive) in 84 | let file = Jsont.(mem_opt o "file" json_file) in 85 | let c = Jsont.obj ~seal:true o in 86 | let dec o = 87 | let get f = Jsont.get f o in 88 | match get archive, get file with 89 | | Some a, None -> `Ok (Archive a) 90 | | None, Some f -> `Ok (File f) 91 | | _ -> `Error "json_contents" 92 | in 93 | let enc t = 94 | Jsont.(new_obj c [match t with 95 | | Archive a -> memv archive (Some a) 96 | | File f -> memv file (Some f) 97 | ]) in 98 | let default = File ("", Cstruct.of_string "") in 99 | Jsont.view ~default (dec, enc) c 100 | 101 | type t = { id : id; contents: contents; } 102 | 103 | let equal x y = Id.equal x.id y.id 104 | 105 | let pp ppf t = Fmt.pf ppf 106 | "@[\ 107 | id: %a@;\ 108 | contents: %a@@]" 109 | Id.pp t.id 110 | pp_contents t.contents 111 | 112 | let json = 113 | let o = Jsont.objc ~kind:"object" () in 114 | let id = Jsont.(mem o "id" Id.json) in 115 | let contents = Jsont.(mem o "contents" json_contents) in 116 | let c = Jsont.obj ~seal:true o in 117 | let dec o = `Ok { id = Jsont.get id o; contents = Jsont.get contents o } in 118 | let enc t = Jsont.(new_obj c [memv id t.id; memv contents t.contents]) in 119 | Jsont.view (dec, enc) c 120 | 121 | let id t = t.id 122 | let contents t = t.contents 123 | 124 | let kind t = match t.contents with 125 | | Archive _ -> `Archive 126 | | File _ -> `File 127 | 128 | let hash k = 129 | let l = match k with 130 | | `File (n, r) -> [n; Cstruct.to_string r] 131 | | `Files files -> 132 | List.map (fun (f, d) -> f ^ ":" ^ Digest.to_hex d) files 133 | |> List.sort String.compare 134 | in 135 | Id.digest `Object (String.concat "+" l) 136 | 137 | let archive files raw = 138 | let id = hash (`Files files) in 139 | { id; contents = Archive { files; raw } } 140 | 141 | let file name raw = 142 | let id = hash (`File (name, raw)) in 143 | { id; contents = File (name, raw) } 144 | -------------------------------------------------------------------------------- /lib/object.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Build objects. 20 | 21 | The objects are built by {{!module:Job}jobs} executed by 22 | {{!module:Worker}workers}. 23 | 24 | *) 25 | 26 | type id = [`Object] Id.t 27 | (** The type for object identifiers. Object identifiers are 28 | deterministic, i.e. two similar objects will have the same 29 | identifiers. The notion of similiraty depends on the object 30 | type. *) 31 | 32 | type archive = { 33 | files: (string * Digest.t) list; 34 | raw : Cstruct.t; 35 | } 36 | (** The type for archive values. *) 37 | 38 | type file = string * Cstruct.t 39 | (** The type for UTF-8 encoded files. *) 40 | 41 | (** The type for object contents. Can either be an UTF-8 encoded 42 | {!file} or an {!archive}. *) 43 | type contents = Archive of archive | File of file 44 | 45 | type kind = [ `Archive | `File ] 46 | (** The type for object kinds. *) 47 | 48 | type t 49 | (** The type for object values. *) 50 | 51 | val id: t -> id 52 | (** [id t] is [t]'s id. *) 53 | 54 | val contents: t -> contents 55 | (** [contents t] is [t]s contents. *) 56 | 57 | val kind: t -> kind 58 | (** [kind t] is [t]'s kind. *) 59 | 60 | val archive: (string * Digest.t) list -> Cstruct.t -> t 61 | (** [archive f c] is the archive containing the files [f] and with raw 62 | contents [c]. *) 63 | 64 | val file: string -> Cstruct.t -> t 65 | (** [file f c] is the file [f] whose contents is [c]. *) 66 | 67 | val equal: t -> t -> bool 68 | (** [equal] is the equality function for objects. *) 69 | 70 | val pp: t Fmt.t 71 | (** [pp] format objects. *) 72 | 73 | val json: t Jsont.codec 74 | (** [json] is the JSON codec for objects. *) 75 | -------------------------------------------------------------------------------- /lib/package.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | type t = { 20 | name: string; 21 | version: string option; 22 | } 23 | 24 | let equal x y = 25 | String.compare x.name y.name = 0 26 | && match x.version, y.version with 27 | | None , None -> true 28 | | Some x, Some y -> String.compare x y = 0 29 | | _ -> false 30 | 31 | let compare x y = 32 | match String.compare x.name y.name with 33 | | 0 -> begin 34 | match x.version, y.version with 35 | | None , None -> 0 36 | | Some _, None -> 1 37 | | None , Some _ -> -1 38 | | Some x, Some y -> String.compare x y 39 | end 40 | | i -> i 41 | 42 | let pp ppf t = match t.version with 43 | | None -> Fmt.string ppf t.name 44 | | Some v -> Fmt.pf ppf "%s.%s" t.name v 45 | 46 | let json = 47 | let o = Jsont.objc ~kind:"package" () in 48 | let name = Jsont.(mem o "name" string) in 49 | let version = Jsont.(mem_opt o "version" string) in 50 | let c = Jsont.obj ~seal:true o in 51 | let dec o = `Ok { name = Jsont.get name o; version = Jsont.get version o } in 52 | let enc t = Jsont.(new_obj c [memv name t.name; memv version t.version]) in 53 | Jsont.view (dec, enc) c 54 | 55 | let name t = t.name 56 | let version t = t.version 57 | let create ?version name = { name; version } 58 | 59 | let of_string s = match Stringext.cut s ~on:"." with 60 | | None -> create s 61 | | Some (n, v) -> create ~version:v n 62 | 63 | let to_string t = match t.version with 64 | | None -> t.name 65 | | Some v -> t.name ^ "." ^ v 66 | 67 | type meta = { 68 | pkg : t; 69 | opam : Cstruct.t; 70 | descr: Cstruct.t option; 71 | url : Cstruct.t option; 72 | files: (string * Cstruct.t) list; 73 | } 74 | 75 | let pp_meta ppf t = 76 | let mk x = Id.digest_cstruct `Foo x |> Id.to_string in 77 | let mko = function None -> [] | Some x -> [mk x] in 78 | let mkf (f, c) = f ^ ":" ^ mk c in 79 | let block = [ 80 | "package", [to_string t.pkg]; 81 | "opam ", [mk t.opam]; 82 | "descr ", mko t.descr; 83 | "url ", mko t.url; 84 | "files ", List.map mkf t.files 85 | ] in 86 | Gol.show_block ppf block 87 | 88 | let json_cstruct = 89 | let dec o = `Ok (Cstruct.of_string o) in 90 | let enc c = Cstruct.to_string c in 91 | Jsont.view (dec, enc) Jsont.nat_string 92 | 93 | let json_file = 94 | let o = Jsont.objc ~kind:"file" () in 95 | let name = Jsont.(mem o "name" string) in 96 | let contents = Jsont.(mem o "contents" json_cstruct) in 97 | let c = Jsont.obj ~seal:true o in 98 | let dec o = `Ok (Jsont.get name o, Jsont.get contents o) in 99 | let enc (n, x) = Jsont.(new_obj c [memv name n; memv contents x]) in 100 | Jsont.view (dec, enc) c 101 | 102 | let json_meta = 103 | let o = Jsont.objc ~kind:"meta" () in 104 | let pkg = Jsont.(mem o) "package" json in 105 | let opam = Jsont.(mem o "opam" json_cstruct) in 106 | let descr = Jsont.(mem_opt o "descr" json_cstruct) in 107 | let url = Jsont.(mem_opt o "url" json_cstruct) in 108 | let files = Jsont.(mem ~opt:`Yes_rem o "files" @@ array json_file) in 109 | let c = Jsont.obj ~seal:true o in 110 | let dec o = 111 | let get x = Jsont.get x o in 112 | let t = 113 | { pkg = get pkg; opam = get opam; url = get url; 114 | descr = get descr; files = get files; } 115 | in 116 | `Ok t 117 | in 118 | let enc t = Jsont.(new_obj c [ 119 | memv pkg t.pkg; 120 | memv opam t.opam; 121 | memv descr t.descr; 122 | memv url t.url; 123 | memv files t.files; 124 | ]) in 125 | Jsont.view (dec, enc) c 126 | 127 | let meta ~opam ?descr ?url ?(files=[]) pkg = { pkg; opam; descr; url; files } 128 | 129 | let pkg m = m.pkg 130 | let opam m = m.opam 131 | let url m = m.url 132 | let descr m = m.descr 133 | let files m = m.files 134 | -------------------------------------------------------------------------------- /lib/package.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Package name with optional version. *) 20 | 21 | type t 22 | (** The type for package names with an optional version. *) 23 | 24 | val name: t -> string 25 | (** [name t] is [t]'s name. *) 26 | 27 | val version: t -> string option 28 | (** [version t] is [t]'s version or [None] it [t] does not have any 29 | version. *) 30 | 31 | val create: ?version:string -> string -> t 32 | (** [create ?version name] is the opam package [name.version]. *) 33 | 34 | val of_string: string -> t 35 | (** [of_string "n.v"] is the package with name [n] and version [v]. If 36 | [s] does not contain any string, it is the package with name [s] 37 | and no version. *) 38 | 39 | val to_string: t -> string 40 | (** [to_string t] is [name t ^ "." v] if [t] has the version [v], 41 | otherwise it is [name t]. *) 42 | 43 | val equal: t -> t -> bool 44 | (** [equal] is the equality for packages. *) 45 | 46 | val compare: t -> t -> int 47 | (** [compare] compares packages. *) 48 | 49 | val json: t Jsont.codec 50 | (** [json] is the JSON codec for packages. *) 51 | 52 | val pp: t Fmt.t 53 | (** [pp] formats packages. *) 54 | 55 | (** {1 Package Metadata} *) 56 | 57 | type meta 58 | (** The type for package metdata. *) 59 | 60 | val meta: 61 | opam:Cstruct.t -> 62 | ?descr:Cstruct.t -> 63 | ?url:Cstruct.t -> 64 | ?files:(string * Cstruct.t) list -> 65 | t -> meta 66 | (** [info ~opam ~descr ~url ~files t] are all the metadata needed to 67 | define a package. All files should contains only valid UTF-8 68 | characters. This is {b not} checked by CISO. *) 69 | 70 | val pkg: meta -> t 71 | (** [pkg m] is the package that [m] describes. *) 72 | 73 | val opam: meta -> Cstruct.t 74 | (** [opam m] is the contents of the {i opam} file. *) 75 | 76 | val descr: meta -> Cstruct.t option 77 | (** [descr m] is the contents of the {i descr} file (if present). *) 78 | 79 | val url: meta -> Cstruct.t option 80 | (** [url m] is the contents of the {i url} file (if present). *) 81 | 82 | val files: meta -> (string * Cstruct.t) list 83 | (** [files m] are the names and contents of files stored under {i 84 | files/} (if present). *) 85 | 86 | val pp_meta: meta Fmt.t 87 | (** [pp_meta] formats package metadata. *) 88 | 89 | val json_meta: meta Jsont.codec 90 | (** [json_meta] is the JSON codec for package metadata. *) 91 | -------------------------------------------------------------------------------- /lib/scheduler.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Scheduler. 20 | 21 | The scheduler looks for task, job and worker events in the store 22 | and distribute work to the workers. 23 | 24 | *) 25 | 26 | (** The signature for schedulers. *) 27 | module type S = sig 28 | 29 | type t 30 | (** The type for schedulers. *) 31 | 32 | type value 33 | (** The type of values which are scheduled. *) 34 | 35 | val start: Store.t -> t Lwt.t 36 | (** [start s] starts the event scheduler. *) 37 | 38 | val stop: t -> unit Lwt.t 39 | (** [stop t] stops the scheduler [t]. *) 40 | 41 | val list: t -> value list 42 | (** [list t] lists the values which are being scheduled. *) 43 | 44 | val is_runnable: t -> value -> bool 45 | (** [is_runnable t v] checks if [v] can be scheduled by [t]. *) 46 | 47 | end 48 | 49 | (** Task scheduler. *) 50 | module Task: sig 51 | 52 | (** Tasks can only be added. When a new task is submitted by the 53 | users, the task scheduler start managing it. A task can later be 54 | cancelled. *) 55 | 56 | include S with type value := Task.t 57 | 58 | val peek: t -> Task.t option 59 | (** [peel t] picks a task if it is available. *) 60 | 61 | val peek_s: t -> Task.t Lwt.t 62 | (** [peek_s t] blocks until a task becomes available. *) 63 | 64 | end 65 | 66 | (** Job scheduler. *) 67 | module Job: sig 68 | (** Jobs can only be added. Jobs are added by workers resolving new 69 | tasks (which then become pending). The job scheduler manages new 70 | jobs and check which ones are runnable. It also manage user 71 | cancellation. *) 72 | 73 | include S with type value := Job.t 74 | 75 | val peek: t -> Host.t -> Job.t option 76 | (** [peek t host] picks a job if it is runnable on the given host 77 | configuration. *) 78 | 79 | val peek_s: t -> Host.t -> Job.t Lwt.t 80 | (** [peek_s t host] blocks until a job become runnable on the given 81 | host configuration. *) 82 | 83 | end 84 | 85 | (** Worker scheduler. *) 86 | module Worker: sig 87 | (** Workers can be added and can become inactive. The worker 88 | scheduler manage new workers, keep track of idle workers and 89 | remove inactive workers. *) 90 | 91 | include S with type value := Worker.t 92 | 93 | val peek: t -> Worker.kind -> Worker. t option 94 | (** [peek t k] picks a worker of kind [k]. *) 95 | 96 | val peek_s: t -> Worker.kind -> Worker.t Lwt.t 97 | (** [peek_s t k] blocks until a worker of kind [k] becomes 98 | available. *) 99 | 100 | end 101 | 102 | type t 103 | (** The type for global schedulers. *) 104 | 105 | val job: t -> Job.t 106 | (** [job t] is [t]'s job scheduler. *) 107 | 108 | val task: t -> Task.t 109 | (** [task t] is [t]'s task scheduler. *) 110 | 111 | val worker: t -> Worker.t 112 | (** [worker t] is [t]'s work scheduler. *) 113 | 114 | val start: Store.t -> t Lwt.t 115 | (** [start s] connects the three schedulers: the {{!Worker.t}worker}, 116 | the {{!Task.t}task} and the {{!Job.t}job} ones. *) 117 | 118 | val stop: t -> unit Lwt.t 119 | (** [stop t] stops the three schdulers. *) 120 | -------------------------------------------------------------------------------- /lib/store.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Store API. *) 20 | 21 | type t 22 | (** The type for store handlers. *) 23 | 24 | val remote: ?uri:Uri.t -> unit -> t Lwt.t 25 | (** Create a remote store handler, using Irmin's HTTP client. [uri] is 26 | the location of the Irmin daemon. *) 27 | 28 | val local: ?root:string -> unit -> t Lwt.t 29 | (** Create a local store handler, using Irmin's Git on-disk 30 | backend. [root] is the filesystem location to the Git repository 31 | holding the store contents. *) 32 | 33 | type 'a callback = 'a -> unit Lwt.t 34 | (** The type for callbacks. *) 35 | 36 | type cancel = unit callback 37 | (** The type for watch cancelling functions. *) 38 | 39 | val with_transaction: 40 | ?retry:int -> t -> string -> (t -> unit Lwt.t) -> unit Lwt.t 41 | (** [with_transaction t f] executes [f t] in a transaction and commit 42 | the final result if the transaction is successful. Will retry 43 | multiple times in case of conflict (default is 5) with an 44 | exponential back-off. Raise [Invalid_argument] if the transaction 45 | is still not successful after all the retries. *) 46 | 47 | val cancel_all_watches: t -> unit Lwt.t 48 | (** [cancel_all_watches t] cancel all the watches set-up on [t]. *) 49 | 50 | val nb_watches: t -> int 51 | (** [nb_watches t] is the number of watches set on [t]. *) 52 | 53 | (** The signature for objects kept in the store. *) 54 | module type S = sig 55 | 56 | type id 57 | (** Type type for stable identifier of values kept in the store. *) 58 | 59 | type value 60 | (** The type for values kept in the store. *) 61 | 62 | val add: t -> value -> unit Lwt.t 63 | (** [add t v] adds [v] to the store [t]. *) 64 | 65 | val mem: t -> id -> bool Lwt.t 66 | (** [mem t id] is true if a value with the stable identifer [id] is 67 | stored in [t]. *) 68 | 69 | val get: t -> id -> value Lwt.t 70 | (** [get t id] is the value stored in [t] with the stable identifier 71 | [id]. Raise [Invalid_argument] if [id] is invalid. *) 72 | 73 | val list: t -> id list Lwt.t 74 | (** [list t] is the list of all the values stored in [t]. *) 75 | 76 | val forget: t -> id -> unit Lwt.t 77 | (** [forget t id] removes all metadata about the value. *) 78 | 79 | end 80 | 81 | (** Persisting state for workers. *) 82 | module Worker: sig 83 | 84 | include S with type id := Worker.id and type value := Worker.t 85 | 86 | val tick: t -> Worker.id -> float -> unit Lwt.t 87 | (** [tick t w f] updates the worker [w]'s status with the timestamp 88 | [f]. [f] is supposed to tbe the local worker time, i.e. the 89 | current time since 00:00:00 GMT, Jan. 1, 1970, in seconds in the 90 | worker referential. *) 91 | 92 | val status: t -> Worker.id -> Worker.status option Lwt.t 93 | (** [job t w] is the worker [w]'s current job. [None] means that the 94 | worker is not alive anymore. *) 95 | 96 | val start_job: t -> Worker.id -> Job.id -> unit Lwt.t 97 | (** [start_job t w j] asks the worker [w] to start working on the 98 | build job [j]. *) 99 | 100 | val start_task: t -> Worker.id -> Task.id -> unit Lwt.t 101 | (** [start_task t w ta] asks the worker [w] to start working on the 102 | task [ta]. *) 103 | 104 | val idle: t -> Worker.id -> unit Lwt.t 105 | (** [idle t w] registers that [w] is idle. *) 106 | 107 | type diff = [`Added of Worker.t | `Removed of Worker.id] 108 | (** The type for worker diffs. *) 109 | 110 | val watch: t -> diff callback -> cancel Lwt.t 111 | (** [watch t f] calls [f] everytime a new worker is added. *) 112 | 113 | val watch_status: t -> Worker.id -> Worker.status option callback -> cancel Lwt.t 114 | (** [watch_status t w f] calls [f] everytime [w]'s status is 115 | updated. [None] means that the worker is not alive anymore. *) 116 | 117 | val watch_ticks: t -> Worker.id -> float callback -> cancel Lwt.t 118 | (** [watch_ticks t w f] calls [f] everytime the worker [w] calls 119 | {!tick}. Return a cancel function. *) 120 | 121 | end 122 | 123 | (** Persisting state for tasks. *) 124 | module Task: sig 125 | 126 | include S with type id := Task.id and type value := Task.t 127 | 128 | val refresh_status: t -> Task.id -> unit Lwt.t 129 | (** [refresh_status t id] refreshes [id]'s status by looking at the 130 | status of its jobs. See {!Job.task_status}. *) 131 | 132 | val update_status: t -> Task.id -> Task.status -> unit Lwt.t 133 | (** [update_status t id s] set [id]'s status to [s]. *) 134 | 135 | val reset: t -> Task.id -> unit Lwt.t 136 | (** [reset t task] resets the status of [t] to be [`New]. *) 137 | 138 | val dispatch_to: t -> Task.id -> [`Worker] Id.t -> unit Lwt.t 139 | (** [dispatch_to t id w] dispatches the task [id] to the worker 140 | [w]. Set [id]'s state to be [`Dispatched (w, `Pending)]. *) 141 | 142 | val ack: t -> Task.id -> [`Worker] Id.t -> unit Lwt.t 143 | (** [ack t id w] is the acknoledgement of [w] that it is starting to 144 | work on [id]. Set [id]'s state to be [`Dispatched (w, 145 | `Started)]. *) 146 | 147 | val status: t -> Task.id -> Task.status option Lwt.t 148 | (** [status t task] is [task]'s status in [t]. *) 149 | 150 | val add_job: t -> Task.id -> Job.id -> unit Lwt.t 151 | (** [add_job t id j] add the job [j] to [id]. *) 152 | 153 | val jobs: t -> Task.id -> Job.id list Lwt.t 154 | (** [jobs t task] are [task]'s jobs in [t]. *) 155 | 156 | val watch: t -> Task.t callback -> cancel Lwt.t 157 | (** [watch t f] calls [f] on every task added in the store. *) 158 | 159 | val watch_status: t -> Task.id -> Task.status option callback -> cancel Lwt.t 160 | (** [watch_status t ta f] calls [f] everytime [ta]'s status is 161 | updated. *) 162 | 163 | end 164 | 165 | (** Persisting state for jobs. *) 166 | module Job: sig 167 | 168 | include S with type id := Job.id and type value := Job.t 169 | 170 | val status: t -> Job.id -> Job.status option Lwt.t 171 | (** [status t job] is [job]'s status in [t]. *) 172 | 173 | val pending: t -> Job.id -> unit Lwt.t 174 | (** [pending t j] sets [j]'s status to [`Pending]. *) 175 | 176 | val runnable: t -> Job.id -> unit Lwt.t 177 | (** [runnable t j] set [j]'s status to [`Runnable]. *) 178 | 179 | val dispatch_to: t -> Job.id -> [`Worker] Id.t -> unit Lwt.t 180 | (** [dispatch_to t j w] sets [j]'s status to [`Dispatched (w, 181 | `Pending)]`. *) 182 | 183 | val ack: t -> Job.id -> [`Worker] Id.t -> unit Lwt.t 184 | (** [start t j w] sets [j]'s status to [`Dispatched (w, 185 | `Started)]. *) 186 | 187 | val success: t -> Job.id -> unit Lwt.t 188 | (** [success t j] sets [j]'s status to [`Success]. *) 189 | 190 | val failure: t -> Job.id -> unit Lwt.t 191 | (** [failure t j] set [j]'s status to [`Failure]. *) 192 | 193 | val add_output: t -> Job.id -> Object.t -> unit Lwt.t 194 | (** [add_output t j o] adds [o] to the object store and to the list 195 | of objects created by the job [j]. *) 196 | 197 | val outputs: t -> Job.id -> Object.id list Lwt.t 198 | (** [outputs t job] are [job]'s output objects. *) 199 | 200 | val watch: t -> Job.t callback -> cancel Lwt.t 201 | (** [watch t f] calls [f] on every job added in the store. *) 202 | 203 | val watch_status: t -> Job.id -> Job.status option callback -> cancel Lwt.t 204 | (** [watch_status t j f] calls [f] everytime [j]'s status is 205 | updated. *) 206 | 207 | end 208 | 209 | (** Persisting state for objects. *) 210 | module Object: S with type id := Object.id and type value := Object.t 211 | -------------------------------------------------------------------------------- /lib/switch.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | type t = string 20 | 21 | let equal x y = String.compare x y = 0 22 | let pp = Fmt.string 23 | let json = Jsont.string 24 | let to_string x = x 25 | let of_string x = x 26 | 27 | let system = "system" 28 | 29 | let defaults = [ 30 | "3.12.1"; 31 | "4.00.1"; 32 | "4.01.0"; 33 | "4.02.3"; 34 | ] 35 | -------------------------------------------------------------------------------- /lib/switch.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Compiler switches. *) 20 | 21 | type t 22 | (** The type for compiler switches. *) 23 | 24 | val system: t 25 | (** The [system] switch. *) 26 | 27 | val defaults: t list 28 | (** [defaults] is the list of default switches. *) 29 | 30 | val of_string: string -> t 31 | (** [of_string] is the identity function. *) 32 | 33 | val to_string: t -> string 34 | (** [to_string] is the identity function. *) 35 | 36 | val equal: t -> t -> bool 37 | (** [equal] is the equality for compiler switches. *) 38 | 39 | val json: t Jsont.codec 40 | (** [json] is the JSON codec for values compiler switches. *) 41 | 42 | val pp: t Fmt.t 43 | (** [pp] formats compiler switches. *) 44 | -------------------------------------------------------------------------------- /lib/task.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (* name, address option *) 20 | type repo = string * Uri.t 21 | 22 | let default_repo = 23 | "default", Uri.of_string "https://github.com/ocaml/opam-repository.git" 24 | 25 | (* package, target *) 26 | type pin = string * Uri.t option 27 | 28 | type rev_deps = [`All | `None | `Packages of Package.t list ] 29 | 30 | let json_uri = 31 | let dec s = `Ok (Uri.of_string s) in 32 | let enc u = Uri.to_string u in 33 | Jsont.(view (dec, enc) string) 34 | 35 | let json_pair kind json_uri = 36 | let o = Jsont.objc ~kind () in 37 | let name = Jsont.mem o "name" Jsont.string in 38 | let uri = Jsont.mem o "uri" json_uri in 39 | let c = Jsont.obj ~seal:true o in 40 | let dec o = `Ok (Jsont.get name o, Jsont.get uri o) in 41 | let enc (n, u) = Jsont.(new_obj c [memv name n; memv uri u]) in 42 | Jsont.view (dec, enc) c 43 | 44 | let pp_uri ppf x = Fmt.string ppf (Uri.to_string x) 45 | 46 | let pp_pair ppf (n, u) pp_uri = Fmt.(pf ppf "%s:%a" n pp_uri u) 47 | 48 | let json_repo = json_pair "repository" json_uri 49 | let json_pin = json_pair "pin" (Jsont.some json_uri) 50 | 51 | let pp_repo ppf s = pp_pair ppf s pp_uri 52 | let pp_pin ppf s = pp_pair ppf s (Fmt.option pp_uri) 53 | 54 | type id = [`Task] Id.t 55 | 56 | type t = { 57 | id: id; 58 | date: float; 59 | repos: repo list; 60 | pins: pin list; 61 | switches: Switch.t list; 62 | hosts: Host.t list; 63 | packages: Package.t list; 64 | rev_deps: rev_deps; 65 | } 66 | 67 | let equal x y = Id.equal x.id y.id 68 | let compare x y = Id.compare x.id y.id 69 | let date t = t.date 70 | let hosts t = t.hosts 71 | let switches t = t.switches 72 | let repos t = t.repos 73 | let pins t = t.pins 74 | let rev_deps t = t.rev_deps 75 | 76 | let json_rev_deps = 77 | let dec = function 78 | | [] -> `Ok `None 79 | | o -> 80 | if List.mem "*" o then `Ok `All 81 | else `Ok (`Packages (List.map Package.of_string o)) 82 | in 83 | let enc = function 84 | | `None -> [] 85 | | `All -> ["*"] 86 | | `Packages pkgs -> List.map Package.to_string pkgs 87 | in 88 | Jsont.(view ~default:`None (dec, enc) (array string)) 89 | 90 | let json = 91 | let o = Jsont.objc ~kind:"task" () in 92 | let id = Jsont.mem o "id" Id.json in 93 | let repos = Jsont.(mem ~opt:`Yes_rem o "repos" @@ array json_repo) in 94 | let pins = Jsont.(mem ~opt:`Yes_rem o "pins" @@ array json_pin) in 95 | let switches = Jsont.(mem ~opt:`Yes_rem o "switches" @@ array Switch.json) in 96 | let hosts = Jsont.(mem o ~opt:`Yes_rem "hosts" @@ array Host.json) in 97 | let packages = Jsont.(mem o "packages" @@ array Package.json) in 98 | let rev_deps = Jsont.(mem o ~opt:`Yes_rem "rev-deps" @@ json_rev_deps ) in 99 | let date = Jsont.(mem o "date" float) in 100 | let c = Jsont.obj ~seal:true o in 101 | let dec o = 102 | let get m = Jsont.get m o in 103 | `Ok { 104 | id = get id; repos = get repos; pins = get pins; 105 | switches = get switches; hosts = get hosts; 106 | packages = get packages; rev_deps = get rev_deps; 107 | date = get date; 108 | } in 109 | let enc t = 110 | Jsont.(new_obj c [ 111 | memv id t.id; memv repos t.repos; memv pins t.pins; 112 | memv switches t.switches; memv hosts t.hosts; 113 | memv packages t.packages; memv rev_deps t.rev_deps; 114 | memv date t.date]) 115 | in 116 | Jsont.view (dec, enc) c 117 | 118 | let strings_of_rev_deps = function 119 | | `None -> [] 120 | | `All -> ["*"] 121 | | `Packages pkgs -> List.map Package.to_string pkgs 122 | 123 | let pp_rev_deps = 124 | Fmt.of_to_string (fun r -> String.concat "," (strings_of_rev_deps r)) 125 | 126 | let string_of_date f = 127 | let tm = Unix.localtime f in 128 | let open Unix in 129 | Printf.sprintf "%d:%d:%d" tm.tm_hour tm.tm_min tm.tm_sec 130 | 131 | let pp ppf t = 132 | let mk pp = List.map (Fmt.to_to_string pp) in 133 | let block = [ 134 | "id ", [Id.to_string t.id]; 135 | "date ", [string_of_date t.date]; 136 | "repo ", mk pp_repo t.repos; 137 | "pins ", mk pp_pin t.pins; 138 | "switches", mk Switch.pp t.switches; 139 | "hosts ", List.map Host.short t.hosts; 140 | "rev-deps", strings_of_rev_deps t.rev_deps; 141 | "packages", mk Package.pp t.packages; 142 | ] in 143 | Gol.show_block ppf block 144 | 145 | let id t = t.id 146 | let packages t = t.packages 147 | 148 | let hash ~date ~repos ~pins ~switches ~hosts ~rev_deps ~packages = 149 | let x l = String.concat "+" (List.sort String.compare l) in 150 | let y = String.concat "-" in 151 | let repos = List.map (Fmt.to_to_string pp_repo) repos in 152 | let pins = List.map (Fmt.to_to_string pp_pin) pins in 153 | let switches = List.map (Fmt.to_to_string Switch.pp) switches in 154 | let hosts = List.map (Fmt.to_to_string Host.pp) hosts in 155 | let packages = List.map Package.to_string packages in 156 | let rev_deps = strings_of_rev_deps rev_deps in 157 | let date = [string_of_date date] in 158 | let str = y [ 159 | y repos; (* the order in which we stack the repos is important *) 160 | x pins; x switches; x hosts; x packages; x rev_deps; x date; 161 | ] in 162 | Id.digest `Task str 163 | 164 | let create ?(repos=[default_repo]) ?(pins=[]) 165 | ?(switches=Switch.defaults) ?(hosts=Host.defaults) 166 | ?(rev_deps=`None) packages = 167 | let date = Unix.gettimeofday () in 168 | let id = hash ~date ~repos ~pins ~switches ~hosts ~rev_deps ~packages in 169 | { id; date; repos; pins; switches; hosts; rev_deps; packages } 170 | 171 | type core = [ `New | `Pending | `Cancelled ] 172 | type dispatch = [`Pending | `Started] 173 | type complete = [`Success | `Failure] 174 | 175 | type status = [ 176 | | core 177 | | `Dispatched of [`Worker] Id.t * dispatch 178 | | `Complete of complete 179 | ] 180 | 181 | let to_string = function 182 | | `New -> "new" 183 | | `Dispatched-> "dispatched" 184 | | `Pending -> "pending" 185 | | `Started -> "started" 186 | | `Resolving -> "resolving" 187 | | `Complete -> "complete" 188 | | `Success -> "success" 189 | | `Failure -> "failure" 190 | | `Cancelled -> "canceled" 191 | 192 | let core = [`New; `Dispatched; `Pending; `Complete; `Cancelled ] 193 | let dispatch = [ `Pending; `Started] 194 | let complete = [`Success; `Failure] 195 | 196 | let mk_enum status = 197 | let default = List.hd status in 198 | Jsont.enum ~default @@ List.map (fun s -> to_string s, s) status 199 | 200 | let json_params = 201 | let o = Jsont.objc ~kind:"task-status-params" () in 202 | let worker = Jsont.(mem_opt o "worker" Id.json) in 203 | let status = Jsont.(mem o "status" @@ mk_enum (dispatch @ complete)) in 204 | let c = Jsont.obj ~seal:true o in 205 | let dec o = `Ok (Jsont.get worker o, Jsont.get status o) in 206 | let enc (w, s) = Jsont.(new_obj c [memv worker w; memv status s]) in 207 | Jsont.view (dec, enc) c 208 | 209 | let json_status = 210 | let o = Jsont.objc ~kind:"worker-status" () in 211 | let status = Jsont.(mem o "status" @@ mk_enum core) in 212 | let params = Jsont.(mem_opt o "params" json_params) in 213 | let c = Jsont.obj ~seal:true o in 214 | let dec o = 215 | let params = match Jsont.get params o with 216 | | None -> `N 217 | | Some (Some id, (#dispatch as p)) -> `D (id, p) 218 | | Some (None , (#complete as p)) -> `C p 219 | | _ -> `Error "task_params" 220 | in 221 | match Jsont.get status o, params with 222 | | `Dispatched, `D p -> `Ok (`Dispatched p) 223 | | `Complete , `C p -> `Ok (`Complete p) 224 | | #core as x , `N -> `Ok x 225 | | _ -> `Error "task_status" 226 | in 227 | let enc t = 228 | let cast t = (t :> [dispatch | complete]) in 229 | let s, i = match t with 230 | | `Dispatched (w, p) -> `Dispatched, Some (Some w, cast p) 231 | | `Complete p -> `Complete , Some (None , cast p) 232 | | #core as x -> x , None 233 | in 234 | Jsont.(new_obj c [memv status s; memv params i]) 235 | in 236 | Jsont.view (dec, enc) c 237 | 238 | let pp_s ppf = Fmt.of_to_string to_string ppf 239 | 240 | let pp_status ppf = function 241 | | `Dispatched (w, s) -> Fmt.pf ppf "dispatched to %a (%a)" Id.pp w pp_s s 242 | | `Complete s -> Fmt.pf ppf "complete: %a" pp_s s 243 | | #core as x -> Fmt.of_to_string to_string ppf x 244 | -------------------------------------------------------------------------------- /lib/task.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** User-defined tasks. 20 | 21 | A task is a high-level description of user intents. It allows to 22 | express things like: 23 | 24 | {i "I want to compiler the package X to all supported host 25 | configurations and all OCaml compiler versions."} 26 | 27 | Tasks are later translated into more specific {{!module:Job}jobs} 28 | by {{!module:Worker}workers}, using the OPAM solver. These jobs 29 | are then processed by other {{!module:Worker}workers} to generate 30 | build {{!module:Object}objects}. The user can then access the jobs 31 | outputs and results, and the genarated objects. 32 | *) 33 | 34 | type id = [`Task] Id.t 35 | (** The type for task identifiers. These identifiers are 36 | deterministic, i.e. similar tasks will have the same 37 | identifiers. This is done by hashing the concatenation of 38 | {!create} arguments (after normalisation) and calling {!Id.digest} 39 | on the result. *) 40 | 41 | type repo = string * Uri.t 42 | (** The type for remote opam repositories. *) 43 | 44 | val pp_repo: repo Fmt.t 45 | (** [pp_repository] formats a repository. *) 46 | 47 | val default_repo: repo 48 | (** [default_repo] is {i https://github.com/ocaml/opam-repository.git}. *) 49 | 50 | type pin = string * Uri.t option 51 | (** The type for pinned packages. The first argument is a package 52 | name, the second one its pin target. It is either a version 53 | string, or a Git repository. The target is similar to what would 54 | be passed to {i opam pin add }. If the target is 55 | not specified, it means {i --dev}. *) 56 | 57 | type rev_deps = [`All | `None | `Packages of Package.t list ] 58 | (** The type for specifying reverse dependencies. *) 59 | 60 | val pp_rev_deps: rev_deps Fmt.t 61 | (** [pp_rev_deps] formats reverse dependencies. *) 62 | 63 | val pp_pin: pin Fmt.t 64 | (** [pp_pin] formats a pin package. *) 65 | 66 | type t 67 | (** The type for task values. *) 68 | 69 | val id: t -> id 70 | (** [id t] is [t]'s deterministic identifier. Is it obtaining by 71 | hashing a stable representation of [t]'s components. *) 72 | 73 | val switches: t -> Switch.t list 74 | (** [switches t] is the list of switches that [t]'s packages need 75 | to be installed on. *) 76 | 77 | val hosts: t -> Host.t list 78 | (** [hosts t] is the list of hosts that [t]'s packages need to be 79 | installed on. *) 80 | 81 | val packages: t -> Package.t list 82 | (** [packages t]'s is the list of packages that [t] wants to 83 | install. *) 84 | 85 | val repos: t -> repo list 86 | (** [repos t] are [t]'s repositories. *) 87 | 88 | val pins: t -> pin list 89 | (** [pins t] are [t]'s pinned packages. *) 90 | 91 | val rev_deps: t -> rev_deps 92 | (** [rev_deps t] is true if [t] has to test reverse dependencies. *) 93 | 94 | val date: t -> float 95 | (** [date t] is [t]'s date of creation. The date is number of seconds 96 | since 12:00 midnight January 1, 1970, UTC without accounting for 97 | leap seconds with an optional timezone info. *) 98 | 99 | val create: 100 | ?repos:repo list -> ?pins:pin list -> 101 | ?switches:Switch.t list -> ?hosts:Host.t list -> 102 | ?rev_deps:rev_deps -> 103 | Package.t list -> t 104 | (** [create pkgs] is the task of building the packages [pkgs] on all 105 | possible compiler switches and on all possible host 106 | configurations. This task can somehow be attenuated by specifying 107 | some optional arguments: 108 | 109 | {ul 110 | {- [repos] is the list of (remote) repositories the the workers 111 | should use.} 112 | {- [pins] is the list of pinned packages that the worker should 113 | use.} 114 | {- [switches] restricts the list of compiler switches to test to 115 | only the ones appearing in the list. An empty list means all 116 | the {{!Switch.defaults}supported} compiler switches.} 117 | {- [hosts] restricts the list of host configurations to test to only 118 | the ones appearing in the list. An empty list means all the 119 | {{!Host.defaults}supported} hosts.} 120 | {- [rev_deps] specifies the reverse dependencies to test (default 121 | is [`None]).} 122 | } 123 | *) 124 | 125 | val equal: t -> t -> bool 126 | (** [equal] is the task equality. *) 127 | 128 | val compare: t -> t -> int 129 | (** [compare] compares tasks. *) 130 | 131 | val pp: t Fmt.t 132 | (** [pp] formats tasks. *) 133 | 134 | val json: t Jsont.codec 135 | (** [json] is the JSON codec for tasks. *) 136 | 137 | (** {1 Task Status} *) 138 | 139 | type status = [ 140 | | `New 141 | | `Dispatched of [`Worker] Id.t * [`Pending | `Started] 142 | | `Pending 143 | | `Complete of [ `Success | `Failure ] 144 | | `Cancelled 145 | ] 146 | (** The type for task status. *) 147 | 148 | val pp_status: status Fmt.t 149 | (** [pp_status] formats tasks {!status}. *) 150 | 151 | val json_status: status Jsont.codec 152 | (** [json_status] is the JSON coded for task status. *) 153 | -------------------------------------------------------------------------------- /lib/worker.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | type id = [`Worker] Id.t 20 | 21 | type kind = [`Job|`Task] 22 | 23 | type t = { id: id; kind: [`Job|`Task]; host: Host.t; } 24 | 25 | let equal x y = Id.equal x.id y.id 26 | let compare x y = Id.compare x.id y.id 27 | 28 | let pp_kind = 29 | let str = function `Job -> "job" | `Task -> "task" in 30 | Fmt.of_to_string str 31 | 32 | let pp ppf t = 33 | let mk pp x = [Fmt.to_to_string pp x] in 34 | let block = [ 35 | "id ", mk Id.pp t.id; 36 | "kind ", mk pp_kind t.kind; 37 | "host ", [Host.short t.host]; 38 | ] in 39 | Gol.show_block ppf block 40 | 41 | let json = 42 | let o = Jsont.objc ~kind:"worker" () in 43 | let id = Jsont.(mem o "id" Id.json) in 44 | let host = Jsont.(mem o "host" Host.json) in 45 | let kind = Jsont.(mem o "kind" @@ enum ["job",`Job; "task",`Task]) in 46 | let c = Jsont.obj ~seal:true o in 47 | let dec o = 48 | let get x = Jsont.get x o in 49 | `Ok { kind = get kind; id = get id; host = get host } in 50 | let enc t = 51 | Jsont.(new_obj c [memv id t.id; memv kind t.kind; memv host t.host]) 52 | in 53 | Jsont.view (dec, enc) c 54 | 55 | let create kind host = 56 | let id = Id.uuid `Worker in 57 | { id; kind; host } 58 | 59 | let id t = t.id 60 | let host t = t.host 61 | let kind t = t.kind 62 | 63 | type status = [ 64 | | `Idle 65 | | `Job of Job.id 66 | | `Task of Task.id 67 | ] 68 | 69 | let pp_status ppf = function 70 | | `Idle -> Fmt.string ppf "idle" 71 | | `Job j -> Fmt.pf ppf "job %a" Id.pp j 72 | | `Task t -> Fmt.pf ppf "task %a" Id.pp t 73 | 74 | let status = [`Idle; `Job; `Task] 75 | 76 | let to_string = function 77 | | `Idle -> "idle" 78 | | `Job -> "job" 79 | | `Task -> "task" 80 | 81 | let status_enum = 82 | Jsont.enum ~default:`Idle @@ List.map (fun s -> to_string s, s) status 83 | 84 | let json_status = 85 | let o = Jsont.objc ~kind:"worker-status" () in 86 | let status = Jsont.(mem o "status" @@ status_enum) in 87 | let id = Jsont.(mem_opt o "id" string) in 88 | let c = Jsont.obj ~seal:true o in 89 | let dec o = 90 | match Jsont.get status o, Jsont.get id o with 91 | | `Idle, None -> `Ok `Idle 92 | | `Job , Some x -> `Ok (`Job (Id.of_string `Job x)) 93 | | `Task, Some x -> `Ok (`Task (Id.of_string `Task x)) 94 | | _ -> `Error "worker_status" 95 | in 96 | let enc t = 97 | let s, i = match t with 98 | | `Idle -> `Idle, None 99 | | `Job x -> `Job , Some (Id.to_string x) 100 | | `Task x -> `Task, Some (Id.to_string x) 101 | in 102 | Jsont.(new_obj c [memv status s; memv id i]) 103 | in 104 | Jsont.view (dec, enc) c 105 | -------------------------------------------------------------------------------- /lib/worker.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Workers. 20 | 21 | The workers process build {{!Job}jobs} to produce build 22 | {{!Object}objects}. A worker has a fixed {{!Host}host} 23 | configuration: an architecture, an operating system and a 24 | distribution. 25 | 26 | *) 27 | 28 | type id = [`Worker] Id.t 29 | (** The type for worker identifiers. *) 30 | 31 | type kind = [`Job|`Task] 32 | (** The type for worker kind. *) 33 | 34 | val pp_kind: kind Fmt.t 35 | (** [pp_kind] formats worker kinds. *) 36 | 37 | type t 38 | (** The type for worker configration .*) 39 | 40 | val create: kind -> Host.t -> t 41 | (** [create k h] is the worker with host configuration [h] and kind 42 | [k]. *) 43 | 44 | val id: t -> id 45 | (** [id t] is [t]'s identifier. It is a 128 bits universally unique 46 | identifiers (UUID) version 4 (random based) according to 47 | {{:http://tools.ietf.org/html/rfc4122}RFC 4122}. *) 48 | 49 | val kind: t -> kind 50 | (** [kind t] is [t]'s kind. *) 51 | 52 | val host: t -> Host.t 53 | (** [host t] is [t]'s host configuration. *) 54 | 55 | val equal: t -> t -> bool 56 | (** [equal] is the equality for workers. *) 57 | 58 | val compare: t -> t -> int 59 | (** [compare] compares workers. *) 60 | 61 | val pp: t Fmt.t 62 | (** [pp] formats workers. *) 63 | 64 | val json: t Jsont.codec 65 | (** [json] is the JSON coded for workers. *) 66 | 67 | (** {1 Worker Status} *) 68 | 69 | type status = [ 70 | | `Idle 71 | | `Job of Job.id 72 | | `Task of Task.id 73 | ] 74 | (** The worker status. Can either be idle, or processing a build job, 75 | or converting a task into a sequence of jobs. *) 76 | 77 | val pp_status: status Fmt.t 78 | (** [pp_status] formats worker status. *) 79 | 80 | val json_status: status Jsont.codec 81 | (** [json_status] is the JSON codec for worker status. *) 82 | -------------------------------------------------------------------------------- /lib/worker/ciso-worker.mldylib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: d2bca9fba1767638774d103253a678cf) 3 | Task_worker 4 | Job_worker 5 | Opam 6 | Common_worker 7 | # OASIS_STOP 8 | -------------------------------------------------------------------------------- /lib/worker/ciso-worker.mllib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: d2bca9fba1767638774d103253a678cf) 3 | Task_worker 4 | Job_worker 5 | Opam 6 | Common_worker 7 | # OASIS_STOP 8 | -------------------------------------------------------------------------------- /lib/worker/common_worker.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | open Lwt.Infix 20 | 21 | let section = ref "worker" 22 | let debug fmt = Gol.debug ~section:!section fmt 23 | 24 | type t = { 25 | worker : Worker.t; (* the worker configuration. *) 26 | store : Store.t; (* the Irmin store. *) 27 | opam_root: string; (* the OPAM root of the worker. *) 28 | tick : float; (* how often do the worker need to tick. *) 29 | mutable heartbeat: int option; 30 | mutable stop: unit -> unit Lwt.t; (* stop the scheduler. *) 31 | } 32 | 33 | let opam t s = Opam.create ~root:t.opam_root s 34 | let store t = t.store 35 | let opam_root t = t.opam_root 36 | let worker t = t.worker 37 | 38 | let create ~tick ~store ~opam_root worker = 39 | let stop () = Lwt.return_unit in 40 | let heartbeat = None in 41 | { worker; store; opam_root; tick; stop; heartbeat; } 42 | 43 | let pids = ref [] 44 | let add_to_kill pid = pids := pid :: !pids 45 | let remove_from_kill pid = pids := List.filter ((<>)pid) !pids 46 | let kill pid = Unix.kill pid Sys.sigkill 47 | 48 | let () = 49 | at_exit (fun () -> List.iter kill !pids) 50 | 51 | let kill_child t = match t.heartbeat with 52 | | None -> () 53 | | Some pid -> remove_from_kill pid; kill pid 54 | 55 | let execution_loop t fn = 56 | Store.Worker.watch_status t.store (Worker.id t.worker) (function 57 | | Some s -> fn t s 58 | | None -> 59 | Fmt.(pf stdout "%a" (styled `Cyan string) "Killed!\n"); 60 | kill_child t; 61 | exit 1 62 | ) 63 | 64 | let heartbeat_loop t = 65 | let rec beat () = 66 | debug "tick %.0fs" t.tick; 67 | let id = Worker.id t.worker in 68 | Lwt_main.run (Store.Worker.tick t.store id (Unix.time ())); 69 | Unix.sleep (int_of_float t.tick); 70 | beat () 71 | in 72 | Lwt_io.flush_all () >>= fun () -> 73 | match Lwt_unix.fork () with 74 | | 0 -> 75 | Store.cancel_all_watches t.store >>= fun () -> 76 | beat () 77 | | pid -> 78 | t.heartbeat <- Some pid; 79 | add_to_kill pid; 80 | Lwt.return_unit 81 | 82 | let start fn ?host ?(tick=5.) ~opam_root ~kind store = 83 | let host = match host with None -> Host.detect () | Some h -> h in 84 | let w = Worker.create kind host in 85 | let t = create ~tick ~store ~opam_root w in 86 | Store.Worker.add t.store w >>= fun () -> 87 | heartbeat_loop t >>= fun () -> 88 | execution_loop t fn >|= fun cancel -> 89 | t.stop <- cancel; 90 | t 91 | 92 | let stop t = 93 | t.stop () >>= fun () -> 94 | Store.Worker.forget t.store (Worker.id t.worker) >|= fun () -> 95 | kill_child t 96 | -------------------------------------------------------------------------------- /lib/worker/common_worker.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | type t 20 | 21 | val debug: ('a, Format.formatter, unit, unit) format4 -> 'a 22 | val section: string ref 23 | val opam: t -> Switch.t option -> Opam.t 24 | val opam_root: t -> string 25 | val store: t -> Store.t 26 | val worker: t -> Worker.t 27 | 28 | val start: 29 | (t -> Worker.status -> unit Lwt.t) -> ?host:Host.t -> 30 | ?tick:float -> opam_root:string -> kind:Worker.kind -> 31 | Store.t -> t Lwt.t 32 | 33 | val stop: t -> unit Lwt.t 34 | -------------------------------------------------------------------------------- /lib/worker/job_worker.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | open Lwt.Infix 20 | include Common_worker 21 | 22 | let debug fmt = 23 | section := "job-worker"; 24 | debug fmt 25 | 26 | let (/) = Filename.concat 27 | 28 | module OSet = Set.Make(struct 29 | type t = Object.id 30 | let compare = Id.compare 31 | end) 32 | 33 | module System = struct 34 | 35 | let debug fmt = Printf.printf fmt 36 | open Lwt.Infix 37 | 38 | (* FIXME: use Bos? *) 39 | 40 | (* from ocaml-git/lib/unix/git_unix.ml *) 41 | 42 | let openfile_pool = Lwt_pool.create 200 (fun () -> Lwt.return_unit) 43 | 44 | let mkdir_pool = Lwt_pool.create 1 (fun () -> Lwt.return_unit) 45 | 46 | let protect_unix_exn = function 47 | | Unix.Unix_error _ as e -> Lwt.fail (Failure (Printexc.to_string e)) 48 | | e -> Lwt.fail e 49 | 50 | let ignore_enoent = function 51 | | Unix.Unix_error (Unix.ENOENT, _, _) -> Lwt.return_unit 52 | | e -> Lwt.fail e 53 | 54 | let protect f x = Lwt.catch (fun () -> f x) protect_unix_exn 55 | 56 | let safe f x = Lwt.catch (fun () -> f x) ignore_enoent 57 | 58 | let remove_file f = safe Lwt_unix.unlink f 59 | 60 | let mkdir dirname = 61 | let rec aux dir = 62 | if Sys.file_exists dir && Sys.is_directory dir then Lwt.return_unit 63 | else ( 64 | let clear = 65 | if Sys.file_exists dir then ( 66 | debug "%s already exists but is a file, removing." dir; 67 | remove_file dir; 68 | ) else 69 | Lwt.return_unit 70 | in 71 | clear >>= fun () -> 72 | aux (Filename.dirname dir) >>= fun () -> 73 | protect (Lwt_unix.mkdir dir) 0o755; 74 | ) in 75 | Lwt_pool.use mkdir_pool (fun () -> aux dirname) 76 | 77 | (* let list_files kind dir = 78 | Lwt_pool.use openfile_pool (fun () -> 79 | if Sys.file_exists dir then ( 80 | let s = Lwt_unix.files_of_directory dir in 81 | let s = Lwt_stream.filter (fun s -> s <> "." && s <> "..") s in 82 | let s = Lwt_stream.map (Filename.concat dir) s in 83 | let s = Lwt_stream.filter kind s in 84 | Lwt_stream.to_list s >>= fun l -> 85 | Lwt.return l 86 | ) else 87 | Lwt.return_nil 88 | ) 89 | 90 | let directories dir = 91 | list_files (fun f -> 92 | try Sys.is_directory f with Sys_error _ -> false 93 | ) dir 94 | 95 | let files dir = 96 | list_files (fun f -> 97 | try not (Sys.is_directory f) with Sys_error _ -> false 98 | ) dir 99 | 100 | let rec_files dir = 101 | let rec aux accu dir = 102 | directories dir >>= fun ds -> 103 | files dir >>= fun fs -> 104 | Lwt_list.fold_left_s aux (fs @ accu) ds 105 | in 106 | aux [] dir 107 | *) 108 | 109 | let write_cstruct fd b = 110 | let rec rwrite fd buf ofs len = 111 | Lwt_bytes.write fd buf ofs len >>= fun n -> 112 | if len = 0 then Lwt.fail End_of_file 113 | else if n < len then rwrite fd buf (ofs + n) (len - n) 114 | else Lwt.return_unit in 115 | match Cstruct.len b with 116 | | 0 -> Lwt.return_unit 117 | | len -> rwrite fd (Cstruct.to_bigarray b) 0 len 118 | 119 | let with_write_file ?temp_dir file fn = 120 | begin match temp_dir with 121 | | None -> Lwt.return_unit 122 | | Some d -> mkdir d 123 | end >>= fun () -> 124 | let dir = Filename.dirname file in 125 | mkdir dir >>= fun () -> 126 | let tmp = Filename.temp_file ?temp_dir (Filename.basename file) "write" in 127 | Lwt_pool.use openfile_pool (fun () -> 128 | Lwt_unix.(openfile tmp [O_WRONLY; O_NONBLOCK; O_CREAT; O_TRUNC] 0o644) 129 | >>= fun fd -> 130 | Lwt.finalize 131 | (fun () -> protect fn fd >>= fun () -> Lwt_unix.rename tmp file) 132 | (fun _ -> Lwt_unix.close fd) 133 | ) 134 | 135 | let write_file file ?temp_dir b = 136 | with_write_file file ?temp_dir (fun fd -> write_cstruct fd b) 137 | 138 | let read_file file = 139 | Unix.handle_unix_error (fun () -> 140 | Lwt_pool.use openfile_pool (fun () -> 141 | debug "Reading %s" file; 142 | let fd = Unix.(openfile file [O_RDONLY; O_NONBLOCK] 0o644) in 143 | let ba = Lwt_bytes.map_file ~fd ~shared:false () in 144 | Unix.close fd; 145 | Lwt.return (Cstruct.of_bigarray ba) 146 | )) 147 | () 148 | 149 | (* end of ocaml-git *) 150 | 151 | 152 | (* 153 | let install_archive (name, content) = 154 | let tmp = "/tmp/ciso-" / name in 155 | if Sys.file_exists tmp then Sys.remove tmp; 156 | write_file tmp content >>= fun () -> 157 | Lwt.return tmp 158 | 159 | let extract_archive tar = 160 | if not (Filename.check_suffix tar ".tar.gz") then 161 | raise (Invalid_argument tar); 162 | let cmd = Printf.sprintf "tar -xzf %s -C /" tar in 163 | let on_failure () = err "extract: cannot untar %s" tar in 164 | let on_success () = debug "extract: OK"; Lwt.return_unit in 165 | exec ~on_success ~on_failure cmd 166 | 167 | let install_files ~src ~dst files = 168 | let cp src dst = 169 | let comm = Printf.sprintf "cp %s %s" src dst in 170 | let on_failure () = err "cp: cannot copy %s to %s" src dst in 171 | let on_success () = debug "%s installed" src; Lwt.return_unit in 172 | exec ~on_success ~on_failure comm 173 | in 174 | Lwt_list.iter_s (fun (f, _) -> 175 | (* FIXME: verify integrity of the digest? *) 176 | let src_path = src / f in 177 | let dst_path = dst / f in 178 | mkdir (Filename.dirname (dst / f)) >>= fun () -> 179 | cp src_path dst_path 180 | ) files 181 | 182 | let name_of_archive name = 183 | assert (Filename.check_suffix name ".tar.gz"); 184 | Filename.chop_extension (Filename.chop_extension name) 185 | 186 | let clean_tmp action name = 187 | let file = "/tmp" / name in 188 | let dir = "/tmp" / name_of_archive name in 189 | let comm = Printf.sprintf "rm -rf %s %s" file dir in 190 | let on_success () = 191 | debug "clean_tmp: %s done (%s %s)!" action file dir; 192 | Lwt.return_unit 193 | in 194 | let on_failure () = err "cannot remove %s and %s" file dir in 195 | exec ~on_failure ~on_success comm 196 | 197 | *) 198 | end 199 | 200 | (* 201 | let archive_of_id id = 202 | Filename.get_temp_dir_name () / Id.to_string id ^ ".tar.gz" 203 | 204 | let prefix_of_job t job = opam_root t / Switch.to_string (Job.switch job) 205 | 206 | let snapshots t ?white_list job = 207 | let prefix = prefix_of_job t job in 208 | let rec loop checksums = function 209 | | [] -> checksums 210 | | path :: tl -> 211 | (* soft link to absent file *) 212 | if not (Sys.file_exists path) then loop checksums tl 213 | else if not (Sys.is_directory path) then 214 | loop ((path, Digest.file path) :: checksums) tl 215 | else 216 | let files = 217 | Sys.readdir path 218 | |> Array.to_list 219 | |> List.rev_map (fun f -> path / f) 220 | in 221 | loop checksums (List.rev_append files tl) 222 | in 223 | if not (Sys.file_exists prefix) then [] 224 | else ( 225 | let sub_dirs = 226 | Sys.readdir prefix 227 | |> Array.to_list 228 | |> (fun lst -> match white_list with 229 | | Some wl -> List.filter (fun n -> List.mem n wl) lst 230 | | None -> lst) 231 | |> List.rev_map (fun n -> prefix / n) 232 | in 233 | loop [] sub_dirs 234 | ) 235 | 236 | let opam_snapshot t job = 237 | let s = Job.switch job in 238 | Opam.read_installed (opam t s) 239 | 240 | let collect_installed t job ~before ~after = 241 | let module CsMap = Map.Make(String) in 242 | let cmap = 243 | List.fold_left 244 | (fun acc (f, checksum) -> CsMap.add f checksum acc) 245 | CsMap.empty before 246 | in 247 | (* TODO: collect deleted files *) 248 | let installed = 249 | List.fold_left (fun acc (f, checksum) -> 250 | if not (CsMap.mem f cmap) then (f, checksum) :: acc else 251 | let cs = CsMap.find f cmap in 252 | if cs <> checksum then (f, checksum) :: acc else acc 253 | ) [] after 254 | in 255 | (* 1 is for the delimiter *) 256 | let prefix = prefix_of_job t job in 257 | let files = List.rev_map (fun (f, d) -> chop_prefix ~prefix f, d) installed in 258 | Lwt.return files 259 | 260 | (* FIXME: console outputs should not be in the archive *) 261 | let create_archive t job files ~old_pkgs ~new_pkgs = 262 | let path = archive_of_id (Job.id job) in 263 | let dst = Filename.dirname path in 264 | let src = prefix_of_job t job in 265 | System.install_files ~src ~dst files >>= fun () -> 266 | let installed = List.filter (fun p -> not (List.mem p old_pkgs)) new_pkgs in 267 | Opam.write_installed (opam t @@ Job.switch job) installed; 268 | let cmd = Printf.sprintf "tar -zcf %s %s" path dst in 269 | System.exec cmd >>= fun () -> 270 | System.read_file path >|= fun content -> 271 | Object.archive files content 272 | 273 | let extract_object t job obj = 274 | match Object.contents obj with 275 | | Object.File (name, raw) -> 276 | let path = prefix_of_job t job / name in 277 | System.write_file path raw 278 | | Object.Archive { Object.files; raw } -> 279 | let path = archive_of_id (Object.id obj) in 280 | System.install_archive (path, raw) >>= fun arch_path -> 281 | System.extract_archive arch_path >>= fun () -> 282 | let src = System.name_of_archive arch_path in 283 | let dst = prefix_of_job t job in 284 | System.install_files ~src ~dst files >>= fun () -> 285 | System.clean_tmp "extract_object" (Filename.basename arch_path) 286 | 287 | (* FIXME: add caching *) 288 | let find_job_deps t j = 289 | let rec aux todo deps = 290 | if JSet.is_empty todo then Lwt.return (JSet.elements deps) 291 | else 292 | let id = JSet.choose todo in 293 | let todo = JSet.remove id todo in 294 | Store.Job.get (store t) id >>= fun job -> 295 | let inputs = JSet.of_list (Job.inputs job) in 296 | let todo = JSet.(union todo (diff inputs deps)) in 297 | let deps = JSet.union inputs deps in 298 | aux todo deps 299 | in 300 | aux JSet.(singleton j) JSet.empty 301 | 302 | let find_obj_deps t j = 303 | find_job_deps t j >>= fun jobs -> 304 | Lwt_list.fold_left_s (fun deps job -> 305 | if j = job then Lwt.return deps 306 | else 307 | Store.Job.outputs (store t) job >|= fun objs -> 308 | List.fold_left (fun s e -> OSet.add e s) deps objs 309 | ) OSet.empty jobs 310 | >|= fun objs -> 311 | OSet.elements objs 312 | 313 | let prepare t job = 314 | find_obj_deps t (Job.id job) >>= fun objs -> 315 | Opam.switch_to (opam t Switch.system) (Job.switch job); 316 | (* URGENT FIXME: installation order IS important *) 317 | Lwt_list.iter_p (fun oid -> 318 | Store.Object.get (store t) oid >>= 319 | extract_object t job 320 | ) objs 321 | 322 | let default_white_list = ["lib"; "bin"; "sbin"; "doc"; "share"; "etc"; "man"] 323 | 324 | let process_job ?(white_list=default_white_list) t job = 325 | let cache = cache t in 326 | let id = Job.id job in 327 | prepare t job >|= fun () -> 328 | debug "build: %s, pre-snapshot" (Id.to_string id); 329 | let before = snapshots t ~white_list job in 330 | let old_pkgs = opam_snapshot t job in 331 | debug "build: %s, install." (Id.to_string id); 332 | (* FIXME: handle the Package.info *) 333 | let pkgs = List.map fst (Job.packages job) in 334 | begin 335 | Lwt.catch 336 | (fun () -> 337 | Opam.install (opam t @@ Job.switch job) pkgs; 338 | Lwt.return `Success) 339 | (fun exn -> 340 | debug "Job %s exited with: %s" (Id.to_string id) (Printexc.to_string exn); 341 | Lwt.return `Failure) 342 | end >>= fun result -> 343 | let () = match result with 344 | | `Success -> debug "build: %s Success!" (Id.to_string id) 345 | | `Failure -> debug "build: %s Failure!" (Id.to_string id) 346 | in 347 | debug "build: %s, post-snapshot" (Id.to_string id); 348 | let after = snapshots t ~white_list job in 349 | let new_pkgs = opam_snapshot t job in 350 | collect_outputs t job >>= fun outputs -> 351 | collect_installed t job ~before ~after >>= fun installed -> 352 | create_archive t job installed ~old_pkgs ~new_pkgs >>= fun archive -> 353 | System.clean_tmp "pkg_build" (archive_of_id id) >>= fun () -> 354 | Opam.remove (opam t @@ Job.switch job) pkgs; 355 | Store.with_transaction (store t) "Job complete" (fun t -> 356 | let add_one obj = 357 | Store.Object.add t obj >>= fun () -> 358 | Store.Job.add_output t id (Object.id obj) 359 | in 360 | let objs = if cache then archive :: outputs else outputs in 361 | Lwt_list.iter_p add_one objs >>= fun () -> 362 | match result with 363 | | `Success -> Store.Job.success t id 364 | | `Failure -> Store.Job.success t id 365 | ) 366 | *) 367 | 368 | (* FIXME: Use Bos *) 369 | let opam t ?output fmt = 370 | let open Rresult in 371 | Fmt.kstrf (fun str -> 372 | let out = match output with 373 | | None -> "" 374 | | Some o -> Printf.sprintf " -vv >>%s 2>&1" o 375 | in 376 | (* FIXME: the OPAMROOT is not necessary but it's good to be 377 | extra-carefull in that case. *) 378 | let cmd = Printf.sprintf "OPAMROOT=%s opam %s%s" (opam_root t) str out in 379 | let err = Sys.command cmd in 380 | if err = 0 then Ok () else Error Fmt.(strf "%s: exit %d" cmd err) 381 | ) fmt 382 | 383 | let add_output t job output = 384 | let id = Job.id job in 385 | System.read_file output >>= fun output -> 386 | let obj = Object.file "output" output in 387 | Store.Job.add_output (store t) id obj 388 | 389 | let default_callback t job = 390 | let id = Job.id job in 391 | let pkgs = Job.packages job in 392 | let switch = Job.switch job in 393 | let pkgs_s = 394 | List.map (fun m -> Package.to_string @@ Package.pkg m) pkgs 395 | |> String.concat " " 396 | in 397 | let o = Opam.create ~root:(opam_root t) (Some switch) in 398 | Opam.switch_install o; 399 | Opam.repo_clean o; 400 | Opam.pin_clean o; 401 | let repo_root = opam_root t / "ciso" / "jobs" / Id.to_string id in 402 | let output = repo_root / "output" in 403 | Lwt_list.iter_s (fun m -> 404 | let p = Package.pkg m in 405 | let dir = repo_root / "packages" / Package.to_string p in 406 | let write (k, v) = match v with 407 | | None -> Lwt.return_unit 408 | | Some v -> System.write_file (dir / k) v 409 | in 410 | let files = 411 | List.map (fun (f, c) -> "files" / f, Some c) (Package.files m) 412 | in 413 | Lwt_list.iter_s write ([ 414 | "opam" , Some (Package.opam m); 415 | "descr", Package.descr m; 416 | "url" , Package.url m; 417 | ] @ files) 418 | ) pkgs 419 | >>= fun () -> 420 | let result = 421 | let open Rresult in 422 | opam t "repo add ciso %s" repo_root >>= fun () -> 423 | opam t "update" >>= fun () -> 424 | opam t "install %s" ~output pkgs_s >>= fun () -> 425 | opam t "remove %s" ~output pkgs_s 426 | in 427 | add_output t job output >|= fun () -> 428 | let _x = opam t "remove --force %s" pkgs_s in 429 | if Rresult.R.is_ok result then `Success else `Failure 430 | 431 | 432 | type result = [`Success | `Failure] 433 | type callback = t -> Job.t -> result Lwt.t 434 | 435 | let worker = worker 436 | 437 | let start ?(callback=default_callback) = 438 | let callback t = function 439 | | `Idle 440 | | `Task _ -> Lwt.return_unit 441 | | `Job id -> 442 | debug "Got a new job: %s" (Id.to_string id); 443 | let wid = Worker.id (worker t) in 444 | let store = store t in 445 | Store.Job.ack store id wid >>= fun () -> 446 | Store.Job.get store id >>= fun job -> 447 | callback t job >>= fun result -> 448 | begin match result with 449 | | `Success -> Store.Job.success store id 450 | | `Failure -> Store.Job.failure store id 451 | end >>= fun () -> 452 | Store.Worker.idle store wid 453 | in 454 | start ~kind:`Job callback 455 | -------------------------------------------------------------------------------- /lib/worker/job_worker.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Job worker. 20 | 21 | A worker has a fixed host configuration. It builds OPAM packages 22 | and store the resultsc. 23 | 24 | *) 25 | 26 | type t 27 | (** The type for job workers. *) 28 | 29 | val worker: t -> Worker.t 30 | (** [worker t] is [t]'s worker value. *) 31 | 32 | type result = [`Success | `Failure] 33 | (** The type for job results. *) 34 | 35 | type callback = t -> Job.t -> result Lwt.t 36 | (** The type for job workers' callback. *) 37 | 38 | val default_callback: callback 39 | (** [default_callback] is the function which builds the jobs using 40 | opam invocations. *) 41 | 42 | val start: ?callback:callback -> ?host:Host.t -> ?tick:float -> 43 | opam_root:string -> Store.t -> t Lwt.t 44 | (** [starts ~opam_root store] starts a job worker. *) 45 | 46 | val stop: t -> unit Lwt.t 47 | (** [stop t] stops the job worker. *) 48 | -------------------------------------------------------------------------------- /lib/worker/opam.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | open OpamTypes 20 | 21 | module OT = OpamState.Types 22 | module OF = OpamFilename 23 | module OSC = OpamStateConfig 24 | module OGraph = OpamSolver.ActionGraph 25 | module OS = OpamSystem 26 | 27 | let (/) = Filename.concat 28 | 29 | type t = { root: string; switch: Switch.t; } 30 | 31 | let pp_t ppf t = Fmt.pf ppf "root:%s switch:%a" t.root Switch.pp t.switch 32 | 33 | type plan = { 34 | g: OGraph.t; 35 | h: Host.t; 36 | s: Switch.t; 37 | } 38 | 39 | let debug fmt = Gol.debug ~section:"opam" fmt 40 | let fail fmt = Printf.ksprintf failwith ("Ciso.Opam: " ^^ fmt) 41 | 42 | let package_s p = OpamPackage.to_string p 43 | 44 | let package_of_opam p = 45 | let name = OpamPackage.(Name.to_string @@ name p) in 46 | let version = OpamPackage.(Version.to_string @@ version p) in 47 | Package.create ~version name 48 | 49 | let opam_of_package p = 50 | let name = OpamPackage.(Name.of_string @@ Package.name p) in 51 | let version = match Package.version p with 52 | | None -> failwith "no version!" 53 | | Some v -> OpamPackage.Version.of_string v 54 | in 55 | OpamPackage.create name version 56 | 57 | let parse_atom str = 58 | match fst OpamArg.atom str with `Ok a -> a | `Error s -> 59 | fail "Cannot parse %s: %s\n%!" str s 60 | 61 | let atom_of_package p = parse_atom (Package.to_string p) 62 | let opam_switch s = OpamSwitch.of_string (Switch.to_string s) 63 | 64 | let with_process_in cmd f = 65 | let ic = Unix.open_process_in cmd in 66 | try 67 | let r = f ic in 68 | ignore (Unix.close_process_in ic); 69 | r 70 | with exn -> 71 | ignore (Unix.close_process_in ic); 72 | raise exn 73 | 74 | let check t o = 75 | let assert_eq got expected = 76 | if got <> expected then ( 77 | let red = Fmt.(styled `Red string) in 78 | let yellow = Fmt.(styled `Yellow string) in 79 | Fmt.(pf stderr) "%a got %a, but was expecting %a.\n%!" 80 | red "Error" yellow got yellow expected; 81 | assert false 82 | ) 83 | in 84 | let check k expected = 85 | let cmd = Fmt.strf "opam config var %s" k in 86 | with_process_in cmd (fun ic -> 87 | let got = String.trim (input_line ic) in 88 | assert_eq got expected 89 | ) 90 | in 91 | check "root" t.root; 92 | check "prefix" (t.root / Switch.to_string t.switch); 93 | check "compiler" (Switch.to_string t.switch); 94 | assert_eq t.root (OF.Dir.to_string OSC.(!r.root_dir)); 95 | assert_eq 96 | (Switch.to_string t.switch) (OpamSwitch.to_string OSC.(!r.current_switch)); 97 | match o with 98 | | None -> () 99 | | Some o -> 100 | assert_eq t.root (OF.Dir.to_string o.OT.root); 101 | assert_eq (Switch.to_string t.switch) (OpamSwitch.to_string o.OT.switch); 102 | assert_eq (Switch.to_string t.switch) (OpamCompiler.to_string o.OT.compiler) 103 | 104 | let init_config t dbg = 105 | debug "init_config: %a %s" pp_t t dbg; 106 | Unix.putenv "OPAMROOT" t.root; 107 | Unix.putenv "OPAMSWITCH" (Switch.to_string t.switch); 108 | let current_switch = opam_switch t.switch in 109 | let root_dir = OF.Dir.of_string t.root in 110 | OpamClientConfig.opam_init 111 | ~root_dir ~current_switch ~strict:false 112 | ~skip_version_checks:true ~answer:None ~keep_build_dir:true 113 | (); 114 | check t None 115 | 116 | (* 117 | let repo t name url = 118 | let repo_name = OpamRepositoryName.of_string name in 119 | let repo_priority = 0 in 120 | let repo_address, repo_kind = OpamTypesBase.parse_url url in 121 | let repo_root = 122 | OpamRepositoryPath.create (OF.Dir.of_string t.root) repo_name 123 | in 124 | { repo_root; repo_name; repo_kind; repo_address; repo_priority } 125 | *) 126 | 127 | let load_state t dbg = 128 | init_config t dbg; 129 | debug "load_state %s" dbg; 130 | let switch = opam_switch t.switch in 131 | let o = OpamState.load_state ~save_cache:true ("ci-opam-" ^ dbg) switch in 132 | check t (Some o); 133 | o 134 | 135 | let create ~root switch = 136 | let t = match switch with 137 | | Some s -> { root; switch = s} 138 | | None -> 139 | let aliases = root / "aliases" in 140 | if Sys.file_exists aliases then 141 | let aliases = OpamFile.Aliases.read (OF.of_string aliases) in 142 | match OpamSwitch.Map.bindings aliases with 143 | | [] -> { root; switch = Switch.system } 144 | | (s, _)::_ -> { root; switch = Switch.of_string (OpamSwitch.to_string s)} 145 | else 146 | { root; switch = Switch.system } 147 | in 148 | if not OF.(exists_dir Dir.(of_string (t.root / "system"))) then ( 149 | (* FIXME: we don't want opam 1.3, so shell out `opam init...`*) 150 | (* let repo = repo t "default" default_repo in 151 | let comp = OpamCompiler.system in 152 | let root = OF.of_string t.root in 153 | OpamClient.SafeAPI.init repo comp `bash root `no; *) 154 | (* FIXME: use Bos *) 155 | let cmd = Printf.sprintf "opam init --root=%s -n" t.root in 156 | match Sys.command cmd with 157 | | 0 -> () 158 | | i -> Printf.ksprintf failwith "%s failed (exit %d)!" cmd i 159 | ); 160 | init_config t "create"; 161 | t 162 | 163 | let get_var t v = 164 | let t = load_state t "get-var" in 165 | OpamVariable.Full.of_string v 166 | |> OpamState.contents_of_variable (lazy t) 167 | |> OpamVariable.string_of_variable_contents 168 | 169 | (* FIXME: this doesn't work as OPAM is caching the env variables 170 | lazily. *) 171 | let _set_env t s h = 172 | let app k v = Unix.putenv ("OPAMVAR_" ^ k) v in 173 | let tts = Fmt.to_to_string in 174 | List.iter (fun (k, v) -> app k v) [ 175 | "os" , tts Host.pp_os @@ Host.os h; 176 | "switch" , Switch.to_string s; 177 | "os" , Switch.to_string s; 178 | "preinstalled", "false"; 179 | ]; 180 | Unix.putenv "OPAMROOT" t.root 181 | 182 | let eval_opam_config_env t = 183 | let env_s = load_state t "opam-eval-env" in 184 | let env = OpamState.get_opam_env ~force_path:true env_s in 185 | List.iter (fun (n, v, _) -> Unix.putenv n v) env 186 | 187 | let resolve t atoms_s = 188 | let state = load_state t "resolve" in 189 | let atoms = List.rev_map parse_atom atoms_s in 190 | let install_set = OpamPackage.Name.Set.of_list (List.rev_map fst atoms) in 191 | let action = Install install_set in 192 | let universe = OpamState.universe state action in 193 | let request = OpamSolver.request ~install:atoms () in 194 | let result = 195 | OpamSolver.resolve ~orphans:OpamPackage.Set.empty universe request 196 | in 197 | let solution = match result with 198 | | Success s -> Some s 199 | | Conflicts c -> 200 | let info = OpamCudf.string_of_conflict OpamFormula.string_of_atom c in 201 | let str = String.concat ";" atoms_s in 202 | debug "no solution for %s: %s" str info; 203 | None 204 | in 205 | match solution with 206 | | None -> None 207 | | Some s -> 208 | let graph = OpamSolver.get_atomic_action_graph s in 209 | let oc = open_out "solver_log" in 210 | OGraph.Dot.output_graph oc graph; close_out oc; 211 | Some graph 212 | 213 | let resolve_packages t pkgs = resolve t (List.map Package.to_string pkgs) 214 | 215 | let rev_deps t pkgs = 216 | let o = load_state t "rev_deps" in 217 | let pkgs = List.map opam_of_package pkgs in 218 | let pkgs = OpamPackage.Set.of_list pkgs in 219 | let universe = OpamState.universe o Depends in 220 | let pkgs = 221 | OpamSolver.reverse_dependencies 222 | ~build:true ~depopts:true ~installed:false ~unavailable:false 223 | universe pkgs 224 | in 225 | List.map package_of_opam pkgs 226 | 227 | let plans t task f = 228 | (* FIXME: we don't really need to resolve the packages on the 229 | current switch. However it is currently not possibe to tweak the 230 | solver API to parametrize the environment in which the variables 231 | appearing in the opam file are resolved. *) 232 | let resolve_switch switch pkgs = 233 | eval_opam_config_env t; 234 | let i = Sys.command (Fmt.strf "opam switch %a" Switch.pp switch) in 235 | if i <> 0 then failwith "error while switching"; 236 | resolve_packages { t with switch } pkgs 237 | in 238 | let resolve pkgs = 239 | let h = Host.detect () in 240 | if not (List.mem h (Task.hosts task)) then ( 241 | debug "Task:%a do not need to be resolved on host %a." 242 | Id.pp (Task.id task) Host.pp h; 243 | () 244 | ) else 245 | let switches = Task.switches task in 246 | List.iter (fun s -> 247 | match resolve_switch s pkgs with 248 | | None -> 249 | (* FIXME: log the conflict properly *) 250 | () 251 | | Some g -> f { g; h; s } 252 | ) switches 253 | in 254 | let rev_deps pkgs = 255 | match Task.rev_deps task with 256 | | `None -> [] 257 | | `All -> List.map (fun d -> d :: pkgs) (rev_deps t pkgs) 258 | | `Packages deps -> List.map (fun d -> d :: pkgs) deps 259 | in 260 | let pkgs = Task.packages task in 261 | List.iter resolve (pkgs :: rev_deps pkgs) 262 | 263 | module IdSet = struct 264 | include Set.Make(struct 265 | type t = Job.id 266 | let compare = Id.compare 267 | end) 268 | end 269 | 270 | let package_meta o pkg = 271 | debug "package_meta %a" Package.pp pkg; 272 | let nv = opam_of_package pkg in 273 | let mk name f x = 274 | let file = Filename.temp_file name "tmp" in 275 | f (OF.of_string file) x; 276 | let fd = Unix.openfile file [Unix.O_RDONLY; Unix.O_NONBLOCK] 0o644 in 277 | let cstruct = Unix_cstruct.of_fd fd in 278 | Unix.close fd; 279 | cstruct 280 | in 281 | let mk_o name f = function None -> None | Some x -> Some (mk name f x) in 282 | let mk_file prefix file = 283 | let fd = Unix.openfile file [Unix.O_RDONLY; Unix.O_NONBLOCK] 0o644 in 284 | let cstruct = Unix_cstruct.of_fd fd in 285 | Unix.close fd; 286 | OpamStd.String.remove_prefix ~prefix file, cstruct 287 | in 288 | let mk_files = function 289 | | None -> None 290 | | Some d -> 291 | let prefix = OF.Dir.to_string d in 292 | let files = OS.rec_files prefix in 293 | Some (List.map (mk_file prefix) files) 294 | in 295 | let opam = OpamState.opam o nv |> mk "opam" OpamFile.OPAM.write in 296 | let descr = OpamState.descr o nv |> mk "descr" OpamFile.Descr.write in 297 | let url = OpamState.url o nv |> mk_o "url" OpamFile.URL.write in 298 | let files = OpamState.files o nv |> mk_files in 299 | Package.meta ~opam ~descr ?url ?files pkg 300 | 301 | let package_of_action (a:OGraph.vertex) = 302 | let o = match a with 303 | | `Install target -> target 304 | | `Change (_, o, t) -> fail "change %s -> %s" (package_s o) (package_s t) 305 | | `Remove p | `Reinstall p | `Build p -> 306 | fail "Not expect delete/recompile %s" (package_s p) 307 | in 308 | package_of_opam o 309 | 310 | module PMap = Map.Make(Package) 311 | 312 | let atomic_jobs_of_plan t plan = 313 | let process_queue = Queue.create () in 314 | let add_stack = Stack.create () in 315 | OGraph.iter_vertex (fun v -> 316 | if OGraph.out_degree plan.g v = 0 then Queue.add v process_queue 317 | ) plan.g; 318 | while not (Queue.is_empty process_queue) do 319 | let v = Queue.pop process_queue in 320 | OGraph.iter_pred (fun pred -> Queue.add pred process_queue) plan.g v; 321 | Stack.push v add_stack; 322 | done; 323 | let id_map = ref PMap.empty in 324 | let j_lst = ref [] in 325 | while not (Stack.is_empty add_stack) do 326 | let v = Stack.pop add_stack in 327 | let p = package_of_action v in 328 | let inputs = OGraph.fold_pred (fun pred i -> 329 | let pred_pkg = package_of_action pred in 330 | let pred_id = PMap.find pred_pkg !id_map in 331 | pred_id :: i 332 | ) plan.g v [] 333 | in 334 | let meta = package_meta t p in 335 | let job = Job.create ~inputs plan.h plan.s [meta] in 336 | id_map := PMap.add p (Job.id job) !id_map; 337 | j_lst := job :: !j_lst 338 | done; 339 | !j_lst 340 | 341 | let jobs_of_plan t plan = 342 | let actions = OGraph.fold_vertex (fun e l -> e :: l) plan.g [] in 343 | let pkgs = List.map (fun a -> package_meta t (package_of_action a)) actions in 344 | Job.create plan.h plan.s pkgs 345 | 346 | let (@@++) x f = 347 | let open OpamProcess.Job.Op in 348 | x @@+ function 349 | | Some err -> raise err 350 | | None -> f () 351 | 352 | let install t pkgs = 353 | let state = load_state t "install" in 354 | if List.length pkgs = 0 then () 355 | else match pkgs with 356 | | [pkg] -> 357 | let nv = opam_of_package pkg in 358 | let job = 359 | let open OpamProcess.Job.Op in 360 | OpamAction.download_package state nv @@+ function 361 | | `Error err -> failwith err 362 | | `Successful source -> 363 | OpamAction.build_package state source nv @@++ fun () -> 364 | OpamAction.install_package state nv @@++ fun () -> 365 | let { OT.installed; installed_roots; reinstall; _ } = state in 366 | let installed = OpamPackage.Set.add nv installed in 367 | OpamAction.update_switch_state 368 | state ~installed_roots ~reinstall ~installed 369 | |> fun _ -> exit 0 370 | in 371 | OpamProcess.Job.run job 372 | | pkgs -> 373 | let atoms = List.map atom_of_package pkgs in 374 | let add_to_root = None in 375 | let deps_only = false in 376 | OpamClient.SafeAPI.install 377 | atoms add_to_root ~deps_only ~upgrade:false 378 | 379 | let remove t = function 380 | | [] -> () 381 | | pkgs -> 382 | init_config t "remove"; 383 | let atoms = List.map atom_of_package pkgs in 384 | OpamClient.SafeAPI.remove ~autoremove:true ~force:true atoms 385 | 386 | (* 387 | 388 | let remove_switch c = 389 | init (); 390 | let switch = OpamSwitch.of_string c in 391 | OpamSwitchCommand.switch ~quiet:false ~warning:false (OpamSwitch.of_string "system"); 392 | OpamSwitchCommand.remove switch; 393 | Lwt.return_unit 394 | 395 | *) 396 | 397 | let switch_install t = 398 | init_config t "install_switch"; 399 | let root = OSC.(!r.root_dir) in 400 | let aliases = OpamFile.Aliases.safe_read (OpamPath.aliases root) in 401 | let switch = OpamSwitch.of_string (Switch.to_string t.switch) in 402 | if OpamSwitch.Map.mem switch aliases then () 403 | else 404 | let compiler = OpamCompiler.of_string (OpamSwitch.to_string switch) in 405 | OpamSwitchCommand.install ~quiet:false ~update_config:true switch compiler 406 | 407 | let repo_clean t = 408 | let t = load_state t "repo_clean" in 409 | let repos = OpamState.sorted_repositories t in 410 | List.iter (fun r -> OpamRepositoryCommand.remove r.repo_name) repos 411 | 412 | let repo_add t repos = 413 | init_config t "repo_add"; 414 | let add_one_repo (name, address) = 415 | let address = Uri.to_string address in 416 | debug "repository: add %s %s" name address; 417 | let name = OpamRepositoryName.of_string name in 418 | let url = OpamUrl.of_string address in 419 | OpamRepositoryCommand.add name url ~priority:None 420 | in 421 | List.iter add_one_repo repos 422 | 423 | let pin_clean t = 424 | let t = load_state t "pin_clean" in 425 | let pins = OpamState.pinned_packages t in 426 | let pkgs = OpamPackage.Set.elements pins in 427 | let names = List.map OpamPackage.name pkgs in 428 | let _ = OpamPinCommand.unpin ~state:t names in 429 | () 430 | 431 | let pin_add t pin = 432 | init_config t "pin_add"; 433 | let add_one (pkg, target) = 434 | let name = OpamPackage.Name.of_string pkg in 435 | match target with 436 | | None -> (* --dev *) 437 | OpamClient.SafeAPI.PIN.pin ~edit:false ~action:false name None 438 | | Some target -> 439 | let target = Uri.to_string target in 440 | let pin_option = OpamTypesBase.pin_option_of_string ?kind:None target in 441 | let kind = OpamTypesBase.kind_of_pin_option pin_option in 442 | let () = assert (kind <> `rsync) in 443 | OpamClient.SafeAPI.PIN.pin 444 | ~edit:false ~action:false name (Some pin_option) 445 | in 446 | List.iter add_one pin 447 | 448 | let update t = 449 | init_config t "update"; 450 | OpamClient.SafeAPI.update ~repos_only:false ~dev_only:false [] 451 | 452 | let read_installed t = 453 | let t = load_state t "read_installed" in 454 | t.OT.installed 455 | |> OpamPackage.Set.elements 456 | |> List.map OpamPackage.to_string 457 | |> List.map Package.of_string 458 | 459 | let write_installed t installed = 460 | let t = load_state t "write-installed" in 461 | let installed = 462 | installed 463 | |> List.map Package.to_string 464 | |> List.map OpamPackage.of_string 465 | |> OpamPackage.Set.of_list 466 | in 467 | let file = OpamPath.Switch.state t.OT.root t.OT.switch in 468 | let state = OpamFile.State.read file in 469 | let state = { state with OpamFile.State.installed } in 470 | OpamFile.State.write file state 471 | 472 | let write_pinned t pinned = 473 | let t = load_state t "write-pinned" in 474 | let pinned = 475 | List.fold_left (fun acc (n, t) -> 476 | let t = match t with None -> failwith "TODO" | Some t -> t in 477 | OpamPackage.Name.Map.add 478 | (OpamPackage.Name.of_string n) 479 | (OpamTypesBase.pin_option_of_string (Uri.to_string t)) 480 | acc 481 | ) OpamPackage.Name.Map.empty pinned 482 | in 483 | let file = OpamPath.Switch.state t.OT.root t.OT.switch in 484 | let state = OpamFile.State.read file in 485 | let state = { state with OpamFile.State.pinned } in 486 | OpamFile.State.write file state 487 | 488 | let atomic_jobs t task f = 489 | let o = load_state t "atomic_jobs" in 490 | plans t task (fun plan -> 491 | let jobs = atomic_jobs_of_plan o plan in 492 | List.iter f jobs 493 | ) 494 | 495 | let jobs t task f = 496 | let o = load_state t "jobs" in 497 | plans t task (fun plan -> 498 | let job = jobs_of_plan o plan in 499 | f job 500 | ) 501 | -------------------------------------------------------------------------------- /lib/worker/opam.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Interaction with OPAM *) 20 | 21 | type t 22 | (** The type for OPAM state. *) 23 | 24 | val create: root:string -> Switch.t option -> t 25 | (** [create ~root s h] create an OPAM state using [root] as OPAM's 26 | root and [s] as the current switch. *) 27 | 28 | val jobs: t -> Task.t -> (Job.t -> unit) -> unit 29 | (** [jobs p] are the jobs needed to execute the plan [p]. *) 30 | 31 | val atomic_jobs: t -> Task.t -> (Job.t -> unit) -> unit 32 | (** [atomic_jobs t] is similar to {!jobs} but it builds jobs with only 33 | one package to install. *) 34 | 35 | (** {1 OPAM files} *) 36 | 37 | val read_installed: t -> Package.t list 38 | (** [read_installed t] is the list of installed packages in on the 39 | current switch or [[]] if the switch does not exist. *) 40 | 41 | val write_installed: t -> Package.t list -> unit 42 | (** [write_installed t pkgs] update [t]'s metadata so that the packages 43 | [pkgs] are considered to be installed. *) 44 | 45 | val write_pinned: t -> Task.pin list -> unit 46 | (** [write_pinned t pkgs] update [t]'s metadata so that the packages 47 | [pkgs] are pinned. *) 48 | 49 | (** {1 OPAM queries} *) 50 | 51 | val rev_deps: t -> Package.t list -> Package.t list 52 | (** [rev_deps t pkgs] is the list of direct reverse dependencies of 53 | the packages [pkgs]. Similar to {i opam list --depends-on 54 | [pkgs]}. *) 55 | 56 | (** {1 OPAM commands} *) 57 | 58 | val install: t -> Package.t list -> unit 59 | (** [install t pkgs] is {i opam install [pkgs]}. *) 60 | 61 | val remove: t -> Package.t list -> unit 62 | (** [remove t pkgs] is {i opam remove [pkgs]}. *) 63 | 64 | val switch_install: t -> unit 65 | (** [switch_install t] is {i opam switch install [t.switch]}. *) 66 | 67 | val update: t -> unit 68 | (** [update t] is {i opam update}. *) 69 | 70 | val eval_opam_config_env: t -> unit 71 | (** [eval_opam_config_env t] is {i eval `opam config env`}. *) 72 | 73 | val repo_clean: t -> unit 74 | (** [repo_clean t] removes all the repositories. *) 75 | 76 | val repo_add: t -> Task.repo list -> unit 77 | (** [repo_add t r] is {i opam repo add r}. *) 78 | 79 | val pin_clean: t -> unit 80 | (** [pin_clean] removes all the pinned packages. *) 81 | 82 | val pin_add: t -> Task.pin list -> unit 83 | (** [repo_add t p] is {i opam pin add p}. *) 84 | 85 | (* FIXME: review the doc *) 86 | 87 | val get_var: t -> string -> string 88 | -------------------------------------------------------------------------------- /lib/worker/task_worker.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | open Lwt.Infix 20 | include Common_worker 21 | 22 | let debug fmt = 23 | section := "task-worker"; 24 | debug fmt 25 | 26 | type callback = t -> Task.t -> (Job.t -> unit Lwt.t) -> unit Lwt.t 27 | 28 | let default_callback t task f = 29 | let o = Opam.create ~root:(opam_root t) None in 30 | Opam.repo_clean o; 31 | Opam.repo_add o (Task.repos task); 32 | Opam.pin_clean o; 33 | Opam.pin_add o (Task.pins task); 34 | Opam.update o; 35 | let stream, push = Lwt_stream.create () in 36 | Opam.jobs (opam t None) task (fun x -> push (Some x)); 37 | push None; 38 | Lwt_stream.iter_p f stream 39 | 40 | let start ?(callback=default_callback) = 41 | let callback t = function 42 | | `Idle 43 | | `Job _ -> Lwt.return_unit 44 | | `Task id -> 45 | debug "Got a new task: %s!" (Id.to_string id); 46 | let store = store t in 47 | let wid = Worker.id (worker t) in 48 | Store.Task.ack store id wid >>= fun () -> 49 | Store.Task.get store id >>= fun task -> 50 | let add job = 51 | Store.Job.add store job >>= fun () -> 52 | Store.Task.add_job store id (Job.id job) 53 | in 54 | callback t task add >>= fun () -> 55 | Store.Task.refresh_status store id >>= fun () -> 56 | Store.Worker.idle store wid 57 | in 58 | start ~kind:`Task callback 59 | -------------------------------------------------------------------------------- /lib/worker/task_worker.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2015 David Sheets 3 | * Copyright (c) 2015 Qi Li 4 | * Copyright (c) 2015 Thomas Gazagnaire 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | (** Task workers. 20 | 21 | A task worker translate tasks into a graph of jobs to run, for the 22 | various host ocnfigurations and compiler switches. 23 | 24 | *) 25 | 26 | type t 27 | (** The type for task workers. *) 28 | 29 | val worker: t -> Worker.t 30 | (** [worker t] is [t]'s worker value. *) 31 | 32 | type callback = t -> Task.t -> (Job.t -> unit Lwt.t) -> unit Lwt.t 33 | (** Type for task workers' callbacks. *) 34 | 35 | val default_callback: callback 36 | (** [default_callback] is the callback calling the OPAM solver to 37 | resolve tasks into jobs. *) 38 | 39 | val start: ?callback:callback -> ?host:Host.t -> ?tick:float -> 40 | opam_root:string -> Store.t -> t Lwt.t 41 | (** [start ~opam_root s] starts a task worker process using the given 42 | OPAM root to store OPAM state. It uses [s] to synchronise with the 43 | scheduler and to store built objects. It also uses [s] to notify 44 | to the scheduler that it is alive. 45 | 46 | [tick] specifies how often the worker write into the store to 47 | notify that it is alive (default is every 5s). If not set, 48 | [callback] is {!default_callback}. If not specified, [host] is 49 | {!Host.detect ()}. 50 | 51 | *) 52 | 53 | val stop: t -> unit Lwt.t 54 | (** [stop t] stops the task worker. *) 55 | -------------------------------------------------------------------------------- /lib_test/test.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | let () = 18 | Alcotest.run "ciso" [ 19 | "simple" , Test_simple.suite; 20 | "scheduler", Test_scheduler.suite; 21 | "worker" , Test_worker.suite; 22 | ] 23 | -------------------------------------------------------------------------------- /lib_test/test_common.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (* FIXME: add in alcotest *) 18 | let bool_t: bool Alcotest.testable = 19 | (module struct type t = bool let equal = (=) let pp = Fmt.bool end) 20 | 21 | let set (type a) (a: a Alcotest.testable) compare: a list Alcotest.testable = 22 | let module A = (val a) in 23 | let module L = (val Alcotest.list a) in 24 | (module struct 25 | type t = A.t list 26 | let equal x y = L.equal (List.sort compare x) (List.sort compare y) 27 | let pp = L.pp 28 | end) 29 | 30 | let of_pp (type a) pp: a Alcotest.testable = 31 | (module struct type t = a let equal = (=) let pp = pp end) 32 | 33 | let pair (type a) (type b) 34 | (a:a Alcotest.testable) (b:b Alcotest.testable): (a * b) Alcotest.testable = 35 | let module A = (val a) in 36 | let module B = (val b) in 37 | (module struct 38 | type t = a * b 39 | let equal (a1, b1) (a2, b2) = A.equal a1 a2 && B.equal b1 b2 40 | let pp = Fmt.pair A.pp B.pp 41 | end) 42 | 43 | let package_t: Package.t Alcotest.testable = (module Package) 44 | let task_t: Task.t Alcotest.testable = (module Task) 45 | let host_t: Host.t Alcotest.testable = (module Host) 46 | let worker_t: Worker.t Alcotest.testable = (module Worker) 47 | let switch_t: Switch.t Alcotest.testable = (module Switch) 48 | let job_t: Job.t Alcotest.testable = (module Job) 49 | let object_t: Object.t Alcotest.testable = (module Object) 50 | let jobs_t = set job_t Job.compare 51 | let tasks_t = set task_t Task.compare 52 | let workers_t = set worker_t Worker.compare 53 | let task_status_t = of_pp Task.pp_status 54 | let job_status_t = of_pp Job.pp_status 55 | let worker_status_t = of_pp Worker.pp_status 56 | 57 | let random_cstruct n = 58 | let t = Unix.gettimeofday () in 59 | let cs = Cstruct.create 8 in 60 | Cstruct.BE.set_uint64 cs 0 Int64.(of_float (t *. 1000.)) ; 61 | Nocrypto.Rng.reseed cs; 62 | Nocrypto.Rng.generate n 63 | 64 | let random_ascii_string n = 65 | let s = Bytes.create n in 66 | for i = 0 to n-1 do 67 | Bytes.set s i (Char.chr (Random.int 128)) 68 | done; 69 | s 70 | 71 | let to_str codec v = 72 | let b = Buffer.create 64 in 73 | let e = Jsonm.encoder (`Buffer b) in 74 | let e = Jsont.encoder e codec v in 75 | match Jsont.encode e with 76 | | `Ok -> Buffer.contents b 77 | | `Partial -> assert false 78 | 79 | let of_str codec s = 80 | let e = Jsonm.decoder (`String s) in 81 | let e = Jsont.decoder e codec in 82 | match Jsont.decode e with 83 | | `Ok (_, v) -> v 84 | | `Await -> assert false 85 | | `Error (_, e) -> 86 | invalid_arg (Jsont.error_to_string e) 87 | 88 | let json codec v = 89 | let s = to_str codec v in 90 | Fmt.(pf stdout) "%s\n" s; 91 | of_str codec s 92 | 93 | let r1 = "example", Uri.of_string "http://example.com" 94 | let r2 = "example2", Uri.of_string "http://example.com/2" 95 | 96 | let p1 = Package.create "foo" 97 | let p2 = Package.create "foo" ~version:"bar" 98 | let t1 = Task.create ~repos:[Task.default_repo; r1; r2] [p1; p2] 99 | let t2 = Task.create ~rev_deps:`All [p1; p2] 100 | 101 | module HSet = Set.Make(Host) 102 | 103 | let hosts = 104 | let set = 105 | List.fold_left 106 | (fun l e -> HSet.add e l) HSet.empty (Host.detect () :: Host.defaults) 107 | in 108 | HSet.elements set 109 | 110 | let job_workers = List.map (Worker.create `Job) hosts 111 | let task_workers = List.map (Worker.create `Task) hosts 112 | let workers = job_workers @ task_workers 113 | 114 | let wj1 = List.hd job_workers 115 | let wt1 = List.hd task_workers 116 | 117 | let jobs = 118 | let info opam url p = 119 | Package.meta 120 | ~opam:(Cstruct.of_string opam) ~url:(Cstruct.of_string url) 121 | p 122 | in 123 | let pkgs = [ 124 | info "build: [make]" "url: http://example.com" p1; 125 | info "build: [make test]" "url: git://example.com" p2; 126 | ] in 127 | List.fold_left (fun acc h -> 128 | List.fold_left (fun jobs c -> 129 | let inputs = 130 | List.filter (fun j -> Job.host j = h) jobs 131 | |> List.map Job.id 132 | in 133 | let job = Job.create ~inputs h c pkgs in 134 | job :: jobs 135 | ) acc Switch.defaults 136 | ) [] hosts 137 | 138 | let j1 = List.hd jobs 139 | let j2 = List.hd (List.rev jobs) 140 | 141 | let job_roots = List.filter (fun j -> Job.inputs j = []) jobs 142 | 143 | let job_root host = 144 | try List.find (fun j -> Host.equal host (Job.host j)) job_roots 145 | with Not_found -> 146 | Alcotest.fail (Fmt.strf "no root for host %a" Host.pp host) 147 | 148 | let jr1 = job_root (Worker.host wj1) 149 | let jnr1 = Job.(create ~inputs:[id jr1] (host jr1) (switch jr1) (packages jr1)) 150 | 151 | let store () = 152 | let _ = Sys.command "rm -rf /tmp/ciso-tests" in 153 | Store.local ~root:"/tmp/ciso-tests" () 154 | 155 | let ts = 0.01 156 | 157 | let retry f = 158 | let open Lwt.Infix in 159 | let c = ref ts in 160 | let rec aux n = 161 | if n <= 1 then f () 162 | else 163 | Lwt.catch f 164 | (fun e -> 165 | Fmt.(pf stderr) "RETRY: got %s (%.2f)\n" (Printexc.to_string e) !c; 166 | c := 2. *. !c; 167 | Lwt_unix.sleep !c >>= fun () -> 168 | aux (n-1)) 169 | in 170 | aux 10 171 | 172 | let run f = 173 | let err e = 174 | Fmt.(pf stdout "%!"); 175 | Fmt.(pf stderr "%!"); 176 | flush stdout; 177 | flush stderr; 178 | raise e 179 | in 180 | Lwt.async_exception_hook := err; 181 | let protect f () = try f () with e -> Lwt.fail e in 182 | Lwt_main.run (Lwt.catch (protect f) err) 183 | 184 | let () = 185 | Irmin_unix.install_dir_polling_listener ts; 186 | Fmt.(set_style_renderer stdout `Ansi_tty) 187 | -------------------------------------------------------------------------------- /lib_test/test_scheduler.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | include Test_common 18 | 19 | open Lwt.Infix 20 | 21 | let rcheck f msg x y = 22 | retry (fun () -> y () >|= fun y -> Alcotest.check f msg x y) 23 | 24 | let mk f x () = Lwt.return (f x) 25 | 26 | let basic_tasks () = 27 | let test () = 28 | store () >>= fun s -> 29 | Scheduler.Task.start s >>= fun t -> 30 | rcheck tasks_t "0 tasks" [] (mk Scheduler.Task.list t) 31 | >>= fun () -> 32 | Store.Task.add s t1 >>= fun () -> 33 | rcheck tasks_t "1 task" [t1] (mk Scheduler.Task.list t) 34 | >>= fun () -> 35 | Scheduler.Task.stop t >>= fun () -> 36 | rcheck Alcotest.int "no more watches" 0 (mk Store.nb_watches s) 37 | >>= fun () -> 38 | Scheduler.Task.start s >>= fun t -> 39 | rcheck tasks_t "2 task" [t1] (mk Scheduler.Task.list t) 40 | >>= fun () -> 41 | rcheck Alcotest.(option task_status_t) "status" (Some `New) 42 | (fun () -> Store.Task.status s (Task.id t1)) 43 | >>= fun () -> 44 | Scheduler.Task.stop t >>= fun () -> 45 | rcheck Alcotest.int "no more watches" 0 46 | (fun () -> Lwt.return @@ Store.nb_watches s) 47 | in 48 | run test 49 | 50 | let basic_jobs () = 51 | let test () = 52 | let check_roots t = 53 | List.iter (fun h -> 54 | let root = job_root h in 55 | Alcotest.(check @@ option job_t) "root" 56 | (Some root) (Scheduler.Job.peek t h) 57 | ) hosts 58 | in 59 | store () >>= fun s -> 60 | Scheduler.Job.start s >>= fun t -> 61 | rcheck Alcotest.(list job_t) "0 jobs" [] (mk Scheduler.Job.list t) 62 | >>= fun () -> 63 | Lwt_list.iter_p (Store.Job.add s) jobs >>= fun () -> 64 | rcheck jobs_t "jobs" jobs (mk Scheduler.Job.list t) 65 | >>= fun () -> 66 | check_roots t; 67 | Scheduler.Job.stop t >>= fun () -> 68 | rcheck Alcotest.int "no more watches" 0 (mk Store.nb_watches s) 69 | >>= fun () -> 70 | Scheduler.Job.start s >>= fun t -> 71 | rcheck jobs_t "jobs" jobs (mk Scheduler.Job.list t) 72 | >>= fun () -> 73 | check_roots t; 74 | Scheduler.Job.stop t >>= fun () -> 75 | rcheck Alcotest.int "no more watches" 0 (mk Store.nb_watches s) 76 | in 77 | run test 78 | 79 | let basic_workers () = 80 | let test () = 81 | store () >>= fun s -> 82 | Scheduler.Worker.start s >>= fun t -> 83 | Alcotest.(rcheck @@ list worker_t) "0 workers" [] (mk Scheduler.Worker.list t) 84 | >>= fun () -> 85 | Lwt_list.iter_p (Store.Worker.add s) workers >>= fun () -> 86 | rcheck workers_t "workers" workers (mk Scheduler.Worker.list t) 87 | >>= fun () -> 88 | rcheck bool_t "worker" true (fun () -> 89 | let w = match Scheduler.Worker.peek t `Job with 90 | | None -> Alcotest.fail "worker peek" 91 | | Some w -> w 92 | in 93 | Lwt.return (List.mem w job_workers)) 94 | >>= fun () -> 95 | Scheduler.Worker.stop t >>= fun () -> 96 | rcheck Alcotest.int "no more watches" 0 (mk Store.nb_watches s) 97 | >>= fun () -> 98 | Scheduler.Worker.start s >>= fun t -> 99 | rcheck workers_t "workers" workers (mk Scheduler.Worker.list t) 100 | >>= fun () -> 101 | Lwt_list.iter_s (fun w -> Store.Worker.forget s (Worker.id w)) workers 102 | >>= fun () -> 103 | rcheck Alcotest.(list worker_t) "0 workers again" 104 | [] (mk Scheduler.Worker.list t) 105 | >>= fun () -> 106 | Scheduler.Worker.stop t >>= fun () -> 107 | rcheck Alcotest.int "no more watches" 0 (mk Store.nb_watches s) 108 | in 109 | run test 110 | 111 | let task_check s ~section sched msg expected = 112 | let msg = Printf.sprintf "[%s] %s" section msg in 113 | let tasks = Scheduler.Task.list (Scheduler.task sched) in 114 | Alcotest.(check @@ tasks_t) "t1 is monitored" [t1] tasks; 115 | Store.Task.status s (Task.id t1) >>= fun status -> 116 | Alcotest.(check @@ option task_status_t) msg (Some expected) status; 117 | Lwt.return_unit 118 | 119 | let task_check s ~section sched msg expected = 120 | retry (fun () -> task_check s ~section sched msg expected) 121 | 122 | (* - add a task 123 | - start the scheduler 124 | - add a worker: the task is picked-up 125 | - kill the worker: the task is new again *) 126 | let task_scheduler_1 () = 127 | let test () = 128 | store () >>= fun s -> 129 | Store.Task.add s t1 >>= fun () -> 130 | Scheduler.start s >>= fun scheduler -> 131 | let check = task_check s ~section:"task -> scheduler -> worker" scheduler in 132 | check "init" `New >>= fun () -> 133 | Store.Worker.add s wj1 >>= fun () -> 134 | check "init" `New >>= fun () -> 135 | Store.Worker.add s wt1 >>= fun () -> 136 | check "start" (`Dispatched (Worker.id wt1, `Pending)) >>= fun () -> 137 | Store.Worker.forget s (Worker.id wt1) >>= fun () -> 138 | check "forget" `New >>= fun () -> 139 | Scheduler.stop scheduler >>= fun () -> 140 | rcheck Alcotest.int "no more watches" 0 (mk Store.nb_watches s) 141 | in 142 | run test 143 | 144 | (* - add a worker 145 | - start the scheduler 146 | - add a task: the task is picked-up 147 | - kill the worker: the task is new again *) 148 | let task_scheduler_2 () = 149 | let test () = 150 | store () >>= fun s -> 151 | Store.Worker.add s wt1 >>= fun () -> 152 | Scheduler.start s >>= fun scheduler -> 153 | let check = task_check s ~section:"worker -> scheduler -> task" scheduler in 154 | rcheck tasks_t "t1 is not monitored" [] 155 | (mk Scheduler.Task.list (Scheduler.task scheduler)) 156 | >>= fun () -> 157 | Store.Task.add s t1 >>= fun () -> 158 | check "start" (`Dispatched (Worker.id wt1, `Pending)) >>= fun () -> 159 | Store.Worker.forget s (Worker.id wt1) >>= fun () -> 160 | check "forget" `New >>= fun () -> 161 | Scheduler.stop scheduler >>= fun () -> 162 | rcheck Alcotest.int "no more watches" 0 (mk Store.nb_watches s) 163 | in 164 | run test 165 | 166 | (* - add a worker 167 | - add a task 168 | - start the scheduler 169 | - the task is picked-up 170 | - kill the worker: the task is new again *) 171 | let task_scheduler_3 () = 172 | let test () = 173 | store () >>= fun s -> 174 | Store.Worker.add s wt1 >>= fun () -> 175 | Store.Task.add s t1 >>= fun () -> 176 | Scheduler.start s >>= fun scheduler -> 177 | let check = task_check s ~section:"worker -> task -> scheduler" scheduler in 178 | check "start" (`Dispatched (Worker.id wt1, `Pending)) >>= fun () -> 179 | Store.Worker.forget s (Worker.id wt1) >>= fun () -> 180 | check "forget" `New >>= fun () -> 181 | Scheduler.stop scheduler >>= fun () -> 182 | rcheck Alcotest.int "no more watches" 0 (mk Store.nb_watches s) 183 | in 184 | run test 185 | 186 | let job_check s ~section sched msg expected = 187 | let msg = Printf.sprintf "[%s] %s" section msg in 188 | let jobs = Scheduler.Job.list (Scheduler.job sched) in 189 | Alcotest.(check @@ jobs_t) "jr1 is monitored" [jr1] jobs; 190 | Store.Job.status s (Job.id jr1) >>= fun status -> 191 | Alcotest.(check @@ option job_status_t) msg (Some expected) status; 192 | Lwt.return_unit 193 | 194 | let job_check s ~section sched msg expected = 195 | retry (fun () -> job_check s ~section sched msg expected) 196 | 197 | (* - add a job 198 | - start the scheduler 199 | - add a worker: the job is picked-up 200 | - kill the worker: the job is pending again *) 201 | let job_scheduler_1 () = 202 | let test () = 203 | store () >>= fun s -> 204 | Store.Job.add s jr1 >>= fun () -> 205 | Scheduler.start s >>= fun scheduler -> 206 | let check = job_check s ~section:"job -> scheduler -> worker" scheduler in 207 | check "init" `Runnable >>= fun () -> 208 | Store.Worker.add s wt1 >>= fun () -> 209 | check "init" `Runnable >>= fun () -> 210 | Store.Worker.add s wj1 >>= fun () -> 211 | check "start" (`Dispatched (Worker.id wj1, `Pending)) >>= fun () -> 212 | Store.Worker.forget s (Worker.id wj1) >>= fun () -> 213 | check "forget" `Runnable >>= fun () -> 214 | Scheduler.stop scheduler >>= fun () -> 215 | rcheck Alcotest.int "no more watches" 0 (mk Store.nb_watches s) 216 | in 217 | run test 218 | 219 | (* - add a worker 220 | - start the scheduler 221 | - add a job: the job is picked-up 222 | - kill the worker: the job is new again *) 223 | let job_scheduler_2 () = 224 | let test () = 225 | store () >>= fun s -> 226 | Store.Worker.add s wj1 >>= fun () -> 227 | Scheduler.start s >>= fun scheduler -> 228 | let check = job_check s ~section:"worker -> scheduler -> job" scheduler in 229 | rcheck jobs_t "jr1 is not monitored" [] 230 | (mk Scheduler.Job.list (Scheduler.job scheduler)) >>= fun () -> 231 | Store.Job.add s jr1 >>= fun () -> 232 | check "start" (`Dispatched (Worker.id wj1, `Pending)) >>= fun () -> 233 | Store.Worker.forget s (Worker.id wj1) >>= fun () -> 234 | check "forget" `Runnable >>= fun () -> 235 | Scheduler.stop scheduler >>= fun () -> 236 | rcheck Alcotest.int "no more watches" 0 (mk Store.nb_watches s) 237 | in 238 | run test 239 | 240 | (* - add a worker 241 | - add a job 242 | - start the scheduler 243 | - the job is picked-up 244 | - kill the worker: the job is new again *) 245 | let job_scheduler_3 () = 246 | let test () = 247 | store () >>= fun s -> 248 | Store.Worker.add s wj1 >>= fun () -> 249 | Store.Job.add s jr1 >>= fun () -> 250 | Scheduler.start s >>= fun scheduler -> 251 | let check = job_check s ~section:"worker -> job -> scheduler" scheduler in 252 | check "start" (`Dispatched (Worker.id wj1, `Pending)) >>= fun () -> 253 | Store.Worker.forget s (Worker.id wj1) >>= fun () -> 254 | check "forget" `Runnable >>= fun () -> 255 | Scheduler.stop scheduler >>= fun () -> 256 | rcheck Alcotest.int "no more watches" 0 (mk Store.nb_watches s) 257 | in 258 | run test 259 | 260 | (* - add a task 261 | - assign it to a dead worker 262 | - start the scheduler 263 | - the task should be new *) 264 | let task_and_dead_worker () = 265 | let test () = 266 | store () >>= fun s -> 267 | Store.Task.add s t1 >>= fun () -> 268 | Store.Task.ack s (Task.id t1) (Worker.id wt1) >>= fun () -> 269 | Scheduler.start s >>= fun scheduler -> 270 | let check = task_check s ~section:"task to dead worker" scheduler in 271 | check "start" `New >>= fun () -> 272 | Scheduler.stop scheduler >>= fun () -> 273 | rcheck Alcotest.int "no more watches" 0 (mk Store.nb_watches s) 274 | in 275 | run test 276 | 277 | (* - add a job 278 | - assign it to a dead worker 279 | - start the scheduler 280 | - the job should be runnable *) 281 | let job_and_dead_worker () = 282 | let test () = 283 | store () >>= fun s -> 284 | Store.Job.add s jr1 >>= fun () -> 285 | Store.Job.ack s (Job.id jr1) (Worker.id wt1) >>= fun () -> 286 | Scheduler.start s >>= fun scheduler -> 287 | let check = job_check s ~section:"task to dead worker" scheduler in 288 | check "start" `Runnable >>= fun () -> 289 | Scheduler.stop scheduler >>= fun () -> 290 | rcheck Alcotest.int "no more watches" 0 (mk Store.nb_watches s) 291 | in 292 | run test 293 | 294 | let suite = [ 295 | "basic tasks" , `Quick, basic_tasks; 296 | "basic jobs" , `Quick, basic_jobs; 297 | "basic workers" , `Quick, basic_workers; 298 | "task schduler 1", `Quick, task_scheduler_1; 299 | "task schduler 2", `Quick, task_scheduler_2; 300 | "task schduler 3", `Quick, task_scheduler_3; 301 | "job schduler 1" , `Quick, job_scheduler_1; 302 | "job schduler 2" , `Quick, job_scheduler_2; 303 | "job schduler 3" , `Quick, job_scheduler_3; 304 | "task & dead worker", `Quick, task_and_dead_worker; 305 | "job & dead worker" , `Quick, job_and_dead_worker; 306 | ] 307 | -------------------------------------------------------------------------------- /lib_test/test_scheduler.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | val suite: Alcotest.test_case list 18 | -------------------------------------------------------------------------------- /lib_test/test_simple.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | include Test_common 18 | 19 | let simple_package () = 20 | List.iter (fun p -> 21 | let name = Package.to_string p in 22 | Alcotest.(check package_t) name p1 (json Package.json p1) 23 | ) [p1; p2] 24 | 25 | let simple_task () = 26 | List.iter (fun t -> 27 | let id = Id.to_string (Task.id t) in 28 | Alcotest.(check task_t) id t1 (json Task.json t1) 29 | ) [t1; t2] 30 | 31 | let simple_host () = 32 | List.iter (fun h -> 33 | let name = Fmt.to_to_string Host.pp h in 34 | Alcotest.(check host_t) name h (json Host.json h) 35 | ) hosts 36 | 37 | let simple_switch () = 38 | List.iter (fun c -> 39 | let name = Fmt.to_to_string Switch.pp c in 40 | Alcotest.(check switch_t) name c (json Switch.json c) 41 | ) Switch.defaults 42 | 43 | let simple_worker () = 44 | List.iter (fun w -> 45 | let name = Id.to_string (Worker.id w) in 46 | Fmt.pf Fmt.stdout "%a\n%!" Worker.pp w; 47 | Alcotest.(check worker_t) name w (json Worker.json w) 48 | ) workers 49 | 50 | 51 | let simple_job () = 52 | List.iter (fun j -> 53 | let name = Id.to_string (Job.id j) in 54 | Alcotest.(check job_t) name j (json Job.json j) 55 | ) jobs 56 | 57 | let obj () = 58 | let file name contents = name, Digest.string contents in 59 | let files = [ 60 | file "foo.ml" "let x = 3"; 61 | file "foo.cmo" (random_ascii_string 1024) 62 | ] in 63 | Object.(archive files (random_cstruct 2049)) 64 | 65 | let lines n = 66 | let rec aux acc = function 67 | | 0 -> acc 68 | | n -> aux (random_ascii_string 80 :: acc) (n-1) 69 | in 70 | let str = String.concat "\n" (aux [] n) in 71 | Cstruct.of_string str 72 | 73 | let objects = [ 74 | obj (); 75 | obj (); 76 | obj (); 77 | Object.file "foo" (lines 10); 78 | Object.file "bar" (lines 100); 79 | ] 80 | 81 | let simple_object () = 82 | List.iter (fun o -> 83 | let id = Id.to_string (Object.id o) in 84 | Alcotest.(check object_t) id o (json Object.json o) 85 | ) objects 86 | 87 | let simple_status pp js l () = 88 | List.iter (fun x -> 89 | let str = Fmt.to_to_string pp x in 90 | let y = json js x in 91 | Alcotest.(check @@ of_pp pp) str x y 92 | ) l 93 | 94 | let simple_task_status = 95 | simple_status Task.pp_status Task.json_status [ 96 | `New; 97 | `Dispatched (Worker.id wt1, `Pending); 98 | `Dispatched (Worker.id wj1, `Started); 99 | `Pending; 100 | `Complete `Success; 101 | `Complete `Failure; 102 | `Cancelled 103 | ] 104 | 105 | let simple_job_status = 106 | simple_status Job.pp_status Job.json_status [ 107 | `Pending; 108 | `Runnable; 109 | `Dispatched (Worker.id wt1, `Pending); 110 | `Dispatched (Worker.id wj1, `Started); 111 | `Complete `Success; 112 | `Complete `Failure; 113 | `Cancelled; 114 | ] 115 | 116 | let simple_work_status = 117 | simple_status Worker.pp_status Worker.json_status [ 118 | `Idle; 119 | `Job (Job.id j1); 120 | `Job (Job.id j2); 121 | `Task (Task.id t1); 122 | ] 123 | 124 | let suite = [ 125 | "package" , `Quick, simple_package; 126 | "task" , `Quick, simple_task; 127 | "host" , `Quick, simple_host; 128 | "switch" , `Quick, simple_switch; 129 | "worker" , `Quick, simple_worker; 130 | "job" , `Quick, simple_job; 131 | "object" , `Quick, simple_object; 132 | "task status", `Quick, simple_task_status; 133 | "job status" , `Quick, simple_job_status; 134 | "work status", `Quick, simple_work_status; 135 | ] 136 | -------------------------------------------------------------------------------- /lib_test/test_simple.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | val suite: Alcotest.test_case list 18 | -------------------------------------------------------------------------------- /lib_test/test_worker.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Lwt.Infix 18 | include Test_common 19 | 20 | let opam_root = "/tmp/ciso-tests-opam" 21 | let host = Job.host jr1 22 | 23 | let check_task s sched msg expected = 24 | let testable = 25 | let compare (x, _) (y, _) = Task.compare x y in 26 | let pp ppf (x, y) = 27 | Fmt.(pf ppf "%a:%a" Id.pp (Task.id x) (option Task.pp_status) y) 28 | in 29 | set (of_pp pp) compare 30 | in 31 | let tasks = Scheduler.Task.list (Scheduler.task sched) in 32 | Lwt_list.map_p (fun t -> 33 | Store.Task.status s (Task.id t) >|= fun status -> 34 | t, status 35 | ) tasks 36 | >|= fun tasks -> 37 | let expected = List.map (fun (t, s) -> t, Some s) expected in 38 | Alcotest.(check testable) msg expected tasks 39 | 40 | let check_task s sched msg expected = 41 | retry (fun () -> check_task s sched msg expected) 42 | 43 | let check_job s sched msg expected = 44 | let testable = 45 | let compare (x, _) (y, _) = Job.compare x y in 46 | let pp ppf (x, y) = 47 | Fmt.(pf ppf "%a:%a" Id.pp (Job.id x) (option Job.pp_status) y) 48 | in 49 | set (of_pp pp) compare 50 | in 51 | let jobs = Scheduler.Job.list (Scheduler.job sched) in 52 | Lwt_list.map_p (fun t -> 53 | Store.Job.status s (Job.id t) >|= fun status -> 54 | t, status 55 | ) jobs 56 | >|= fun jobs -> 57 | let expected = List.map (fun (t, s) -> t, Some s) expected in 58 | Alcotest.(check testable) msg expected jobs 59 | 60 | let check_job s sched msg expected = 61 | retry (fun () -> check_job s sched msg expected) 62 | 63 | let check_worker s sched msg expected = 64 | let testable = 65 | let compare (x, _) (y, _) = Worker.compare x y in 66 | let pp ppf (x, y) = 67 | Fmt.(pf ppf "%a:%a" Id.pp (Worker.id x) (option Worker.pp_status) y) 68 | in 69 | set (of_pp pp) compare 70 | in 71 | let workers = Scheduler.Worker.list (Scheduler.worker sched) in 72 | Lwt_list.map_p (fun t -> 73 | Store.Worker.status s (Worker.id t) >|= fun status -> 74 | t, status 75 | ) workers 76 | >|= fun workers -> 77 | let expected = List.map (fun (t, s) -> t, Some s) expected in 78 | Alcotest.(check testable) msg expected workers 79 | 80 | let check_worker s sched msg expected = 81 | retry (fun () -> check_worker s sched msg expected) 82 | 83 | let task_worker () = 84 | let t, w = Lwt.task () in 85 | let callback _t _task f = Lwt.join [t; f jr1; f jnr1] in 86 | callback, Lwt.wakeup w 87 | 88 | let job_worker () = 89 | let t1, w1 = Lwt.task () in 90 | let t2, w2 = Lwt.task () in 91 | let callback _t job = 92 | if Job.equal job jr1 then t1 93 | else if Job.equal job jnr1 then t2 94 | else failwith "job_worker" 95 | in 96 | callback, Lwt.wakeup w1, Lwt.wakeup w2 97 | 98 | (* - starts the scheduler 99 | - add a task 100 | - add a task worker 101 | - check that the task is dispatched 102 | - add job workers 103 | - check that the jobs are complete 104 | - check that the task is complete 105 | *) 106 | let test_task_worker () = 107 | let test () = 108 | store () >>= fun s -> 109 | Scheduler.start s >>= fun scheduler -> 110 | let check_t = check_task s scheduler in 111 | let check_j = check_job s scheduler in 112 | let check_w = check_worker s scheduler in 113 | Store.Task.add s t1 >>= fun () -> 114 | check_t "init task" [t1, `New] >>= fun () -> 115 | check_j "init job" [] >>= fun () -> 116 | check_w "init worker" [] >>= fun () -> 117 | 118 | let callback, stop = task_worker () in 119 | Task_worker.start ~callback ~host ~opam_root s >>= fun tw1 -> 120 | let w1 = Task_worker.worker tw1 in 121 | let wid1 = Worker.id w1 in 122 | (* need to wait two ticks here, as this involved 2 transitions in 123 | the state machine. *) 124 | check_t "start task" [t1, `Dispatched (wid1, `Started)] >>= fun () -> 125 | check_j "start job" [] >>= fun () -> 126 | check_w "start worker" [w1, `Task (Task.id t1)] >>= fun () -> 127 | 128 | stop (); 129 | check_t "ready task" [t1, `Pending] >>= fun () -> 130 | check_j "ready job" [jr1, `Runnable; jnr1, `Pending] >>= fun () -> 131 | check_w "ready worker" [w1, `Idle] >>= fun () -> 132 | 133 | let callback, stop1, stop2 = job_worker () in 134 | Job_worker.start ~callback ~host ~opam_root s >>= fun tw2 -> 135 | let w2 = Job_worker.worker tw2 in 136 | let wid2 = Worker.id w2 in 137 | check_t "start2 task" [t1, `Pending] >>= fun () -> 138 | check_w "start2 worker" [w1, `Idle; w2, `Job (Job.id jr1)] >>= fun () -> 139 | check_j "start2 job" [ 140 | jr1 , `Dispatched (wid2, `Started); 141 | jnr1, `Pending 142 | ] >>= fun () -> 143 | 144 | stop1 `Success; 145 | check_t "next task" [t1, `Pending] >>= fun () -> 146 | check_j "next job" [ 147 | jr1 , `Complete `Success; 148 | jnr1, `Dispatched (wid2, `Started) 149 | ] >>= fun () -> 150 | check_w "next worker" [w1, `Idle; w2, `Job (Job.id jnr1)] >>= fun () -> 151 | 152 | stop2 `Success; 153 | check_j "end job" [ 154 | jr1 , `Complete `Success; 155 | jnr1, `Complete `Success; 156 | ] >>= fun () -> 157 | check_t "end task" [] >>= fun () -> 158 | check_w "end worker" [w1, `Idle; w2, `Idle] >>= fun () -> 159 | 160 | Task_worker.stop tw1 >>= fun () -> 161 | Job_worker.stop tw2 >>= fun () -> 162 | check_w "grand final" [] >>= fun () -> 163 | Scheduler.stop scheduler 164 | in 165 | run test 166 | 167 | (* - starts the scheduler 168 | - add a task 169 | - add a task worker 170 | - check that the task is dispatched *) 171 | 172 | (* - starts the scheduler 173 | - add a task 174 | - add a task worker 175 | - check that the task is dispatched *) 176 | 177 | let suite = [ 178 | "task", `Quick, test_task_worker; 179 | ] 180 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | maintainer: "thomas@gazagnaire.org" 3 | authors: [ "David Sheets" "Qi Li" "Thomas Gazagnaire"] 4 | license: "ISC" 5 | homepage: "https://github.com/samoht/ciso-git" 6 | bug-reports: "https://github.com/samoht/ciso/issues" 7 | dev-repo: "https://github.com/samoht/ciso.git" 8 | 9 | build: [ 10 | ["./configure" "--prefix" prefix] 11 | [make] 12 | ] 13 | build-test: [ 14 | ["./configure" "--enable-tests"] 15 | [make "test"] 16 | ] 17 | depends: [ 18 | "ocamlfind" {build} 19 | "alcotest" {test} 20 | "uuidm" 21 | "lwt" 22 | "uri" 23 | "nocrypto" 24 | "irmin-unix" {>= "0.9.9"} 25 | "hex" 26 | "fmt" 27 | "jsont" 28 | "opam-lib" 29 | "ocamlgraph" 30 | "rresult" 31 | "js_of_ocaml" # needed because of https://github.com/dbuenzli/jsont/issues/3 32 | # "cmdliner" 33 | ] 34 | -------------------------------------------------------------------------------- /setup.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samoht/ciso/cd64117e0a97df7461b1311d107fe80e5a71dd49/setup.ml -------------------------------------------------------------------------------- /version: -------------------------------------------------------------------------------- 1 | 0.1.0 --------------------------------------------------------------------------------