├── .circleci └── config.yml ├── .dockerignore ├── .gitattributes ├── .gitignore ├── .ocamlformat ├── 9p.md ├── CHANGES.md ├── CONTRIBUTING.md ├── Dockerfile ├── Dockerfile.bridge-local-git ├── Dockerfile.ci ├── Dockerfile.client ├── Dockerfile.github ├── LICENSE.md ├── MAINTAINERS ├── Makefile ├── README.md ├── api ├── go-datakit │ ├── README │ ├── client.go │ ├── client_test.go │ ├── config.go │ ├── config_test.go │ ├── dial_test.go │ ├── dial_windows_test.go │ ├── doc.go │ ├── snapshot.go │ ├── snapshot_test.go │ ├── transaction.go │ ├── transaction_test.go │ └── watch.go └── ocaml │ ├── 9p │ ├── datakit_client_9p.ml │ ├── datakit_client_9p.mli │ ├── dune │ └── mount │ │ ├── dune │ │ └── mount.ml │ ├── datakit_client.ml │ ├── datakit_client.mli │ ├── dune │ └── git │ ├── datakit_client_git.ml │ ├── datakit_client_git.mli │ └── dune ├── appveyor.yml ├── bridge ├── github │ ├── README.md │ ├── datakit_github_api.ml │ ├── datakit_github_api.mli │ ├── datakit_github_state.ml │ ├── datakit_github_state.mli │ ├── datakit_github_sync.ml │ ├── datakit_github_sync.mli │ ├── dune │ ├── main.ml │ └── main.mli └── local │ ├── Makefile │ ├── README.md │ ├── dune │ ├── main.ml │ ├── main.mli │ ├── sync.ml │ └── sync.mli ├── check-libev.ml ├── ci ├── Makefile ├── README.md ├── self-ci │ ├── .dockerignore │ ├── .gitignore │ ├── Dockerfile │ ├── Makefile │ ├── README.md │ ├── _tags │ ├── datakit-ci.yml │ ├── docker-compose.yml │ ├── selfCI.ml │ └── selfCI.mli ├── skeleton │ ├── .dockerignore │ ├── .gitignore │ ├── Dockerfile │ ├── Makefile │ ├── _tags │ └── exampleCI.ml ├── src │ ├── cI_ACL.ml │ ├── cI_ACL.mli │ ├── cI_cache.ml │ ├── cI_cache.mli │ ├── cI_char_stream.ml │ ├── cI_char_stream.mli │ ├── cI_config.ml │ ├── cI_config.mli │ ├── cI_docker.ml │ ├── cI_docker.mli │ ├── cI_engine.ml │ ├── cI_engine.mli │ ├── cI_escape_parser.ml │ ├── cI_escape_parser.mli │ ├── cI_eval.ml │ ├── cI_eval.mli │ ├── cI_form.ml │ ├── cI_form.mli │ ├── cI_git.ml │ ├── cI_git.mli │ ├── cI_history.ml │ ├── cI_history.mli │ ├── cI_live_log.ml │ ├── cI_live_log.mli │ ├── cI_log_reporter.ml │ ├── cI_log_reporter.mli │ ├── cI_main.ml │ ├── cI_main.mli │ ├── cI_monitored_pool.ml │ ├── cI_monitored_pool.mli │ ├── cI_output.ml │ ├── cI_output.mli │ ├── cI_process.ml │ ├── cI_process.mli │ ├── cI_result.ml │ ├── cI_result.mli │ ├── cI_s.ml │ ├── cI_secrets.ml │ ├── cI_secrets.mli │ ├── cI_static.mli │ ├── cI_target.ml │ ├── cI_target.mli │ ├── cI_term.ml │ ├── cI_term.mli │ ├── cI_utils.ml │ ├── cI_utils.mli │ ├── cI_web.ml │ ├── cI_web.mli │ ├── cI_web_templates.ml │ ├── cI_web_templates.mli │ ├── cI_web_utils.ml │ ├── cI_web_utils.mli │ ├── datakit_ci.ml │ ├── datakit_ci.mli │ └── dune ├── static │ ├── css │ │ ├── bootstrap.min.css │ │ └── style.css │ ├── fonts │ │ ├── glyphicons-halflings-regular.eot │ │ ├── glyphicons-halflings-regular.svg │ │ ├── glyphicons-halflings-regular.ttf │ │ ├── glyphicons-halflings-regular.woff │ │ └── glyphicons-halflings-regular.woff2 │ ├── images │ │ └── favicon.png │ └── js │ │ ├── bootstrap.min.js │ │ └── ci.js └── tests │ ├── _tags │ ├── dune │ ├── exampleCI.ml │ ├── test_ci.ml │ ├── test_ci.mli │ └── test_utils.ml ├── datakit-bridge-github.opam ├── datakit-bridge-local-git.opam ├── datakit-ci.descr ├── datakit-ci.opam ├── datakit-client-9p.opam ├── datakit-client-git.opam ├── datakit-client.opam ├── datakit-github.opam ├── datakit-server-9p.opam ├── datakit-server.opam ├── datakit.opam ├── dune-project ├── examples └── ocaml-client │ ├── Makefile │ ├── _tags │ └── example.ml ├── reports ├── 2017-04-23.md ├── 2017-04-30.md ├── 2017-05-07.md ├── 2017-05-14.md ├── 2017-05-28.md └── 2017-06-04.md ├── scripts ├── check-dylib.sh ├── git-dumb-server ├── start-client.sh ├── start-datakit-gh-bridge.sh ├── start-datakit.sh ├── test-pr.sh └── watermark.sh ├── src ├── datakit-conduit │ ├── datakit_conduit.ml │ ├── datakit_conduit.mli │ └── dune ├── datakit-github │ ├── datakit_github.ml │ ├── datakit_github.mli │ ├── datakit_github_conv.ml │ ├── datakit_github_conv.mli │ └── dune ├── datakit-io │ ├── datakit_io.ml │ ├── datakit_io.mli │ └── dune ├── datakit-log │ ├── datakit_log.ml │ ├── datakit_log.mli │ └── dune ├── datakit-server-9p │ ├── dune │ ├── fs9p.ml │ ├── fs9p.mli │ ├── fs9p_error.ml │ └── fs9p_error.mli ├── datakit-server │ ├── dune │ ├── vfs.ml │ └── vfs.mli ├── datakit │ ├── bin │ │ ├── autopush.ml │ │ ├── dune │ │ └── main.ml │ ├── blob.ml │ ├── blob.mli │ ├── branch.ml │ ├── branch.mli │ ├── datakit.ml │ ├── datakit.mli │ ├── dir.ml │ ├── dir.mli │ ├── dune │ ├── merge.ml │ ├── merge.mli │ ├── metadata.ml │ ├── metadata.mli │ ├── path.ml │ ├── path.mli │ ├── remote.ml │ ├── remote.mli │ ├── store.ml │ └── store.mli └── version.ml └── tests ├── common ├── dune ├── test_client.ml ├── test_client.mli └── test_utils.ml ├── datakit-9p ├── dune ├── test.ml └── test.mli ├── datakit-bridge-github ├── dune ├── test.ml └── test.mli ├── datakit-git ├── dune ├── test.ml └── test.mli └── datakit ├── dune ├── test.ml └── test.mli /.circleci/config.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | jobs: 3 | build: 4 | macos: 5 | xcode: "9.0" 6 | environment: 7 | OPAMYES: "1" 8 | OPAMJOBS: "2" 9 | MACOSX_DEPLOYMENT_TARGET: "10.10" 10 | TERM: vt100 11 | steps: 12 | - checkout 13 | - run: brew uninstall python # remove files in /usr/local/bin 14 | - run: brew install gmp wget ocaml opam pkg-config dylibbundler 15 | - run: opam init -n https://github.com/ocaml/opam-repository.git 16 | - run: opam pin add -n . 17 | - run: opam update && opam upgrade --fixup && opam upgrade 18 | - run: opam install depext && opam config exec -- opam depext osx-fsevents datakit 19 | - run: opam list 20 | - run: opam install . 21 | - run: mkdir -p _build/src/datakit 22 | - run: opam exec -- make bundle COMMIT 23 | - store_artifacts: 24 | path: com.docker.db 25 | - store_artifacts: 26 | path: COMMIT 27 | workflows: 28 | version: 2 29 | build-test-datakit: 30 | jobs: 31 | - build 32 | -------------------------------------------------------------------------------- /.dockerignore: -------------------------------------------------------------------------------- 1 | **/*.native 2 | **/*.byte 3 | **/_build 4 | ci/self-ci/data 5 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | www/* linguist-documentation 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | _tests/ 3 | _build/ 4 | Datakit.app/ 5 | *~ 6 | \.\#* 7 | \#*# 8 | *.install 9 | *.native 10 | *.byte 11 | bridge/github/webhook/webhook 12 | COMMIT 13 | .merlin 14 | .*.swp 15 | _opam 16 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=conventional 2 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to Docker open source projects 2 | 3 | Want to hack on this project? Awesome! Here are instructions to get you started. 4 | 5 | This project is a part of the [Docker](https://www.docker.com) project, and follows 6 | the same rules and principles. If you're already familiar with the way 7 | Docker does things, you'll feel right at home. 8 | 9 | Otherwise, go read Docker's 10 | [contributions guidelines](https://github.com/docker/docker/blob/master/CONTRIBUTING.md), 11 | [issue triaging](https://github.com/docker/docker/blob/master/project/ISSUE-TRIAGE.md), 12 | [review process](https://github.com/docker/docker/blob/master/project/REVIEWING.md) and 13 | [branches and tags](https://github.com/docker/docker/blob/master/project/BRANCHES-AND-TAGS.md). 14 | 15 | For an in-depth description of our contribution process, visit the 16 | contributors guide: [Understand how to contribute](https://docs.docker.com/opensource/workflow/make-a-contribution/) 17 | 18 | ### Sign your work 19 | 20 | The sign-off is a simple line at the end of the explanation for the patch. Your 21 | signature certifies that you wrote the patch or otherwise have the right to pass 22 | it on as an open-source patch. The rules are pretty simple: if you can certify 23 | the below (from [developercertificate.org](http://developercertificate.org/)): 24 | 25 | ``` 26 | Developer Certificate of Origin 27 | Version 1.1 28 | 29 | Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 30 | 660 York Street, Suite 102, 31 | San Francisco, CA 94110 USA 32 | 33 | Everyone is permitted to copy and distribute verbatim copies of this 34 | license document, but changing it is not allowed. 35 | 36 | Developer's Certificate of Origin 1.1 37 | 38 | By making a contribution to this project, I certify that: 39 | 40 | (a) The contribution was created in whole or in part by me and I 41 | have the right to submit it under the open source license 42 | indicated in the file; or 43 | 44 | (b) The contribution is based upon previous work that, to the best 45 | of my knowledge, is covered under an appropriate open source 46 | license and I have the right under that license to submit that 47 | work with modifications, whether created in whole or in part 48 | by me, under the same open source license (unless I am 49 | permitted to submit under a different license), as indicated 50 | in the file; or 51 | 52 | (c) The contribution was provided directly to me by some other 53 | person who certified (a), (b) or (c) and I have not modified 54 | it. 55 | 56 | (d) I understand and agree that this project and the contribution 57 | are public and that a record of the contribution (including all 58 | personal information I submit with it, including my sign-off) is 59 | maintained indefinitely and may be redistributed consistent with 60 | this project or the open source license(s) involved. 61 | ``` 62 | 63 | Then you just add a line to every git commit message: 64 | 65 | Signed-off-by: Joe Smith 66 | 67 | Use your real name (sorry, no pseudonyms or anonymous contributions.) 68 | 69 | If you set your `user.name` and `user.email` git configs, you can sign your 70 | commit automatically with `git commit -s`. 71 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam2:alpine 2 | RUN sudo apk add --no-cache tzdata aspcud gmp-dev perl libev-dev m4 3 | 4 | RUN opam switch 4.07 5 | 6 | ENV OPAMERRLOGLEN=0 OPAMYES=1 7 | 8 | RUN git -C /home/opam/opam-repository fetch origin && \ 9 | git -C /home/opam/opam-repository reset 340acb7d88264bf29485b1d292388e1d91dc2214 --hard && \ 10 | opam update -u 11 | 12 | RUN opam install alcotest lwt conf-libev inotify 13 | 14 | COPY check-libev.ml /tmp/check-libev.ml 15 | RUN opam exec -- ocaml /tmp/check-libev.ml 16 | 17 | # cache opam install of dependencies 18 | 19 | COPY *.opam /home/opam/src/datakit/ 20 | RUN opam pin add /home/opam/src/datakit/ -n 21 | 22 | # install dependencies 23 | 24 | RUN opam install datakit --deps -t 25 | 26 | # copy local sources 27 | 28 | COPY . /home/opam/src/datakit 29 | RUN sudo chown opam.nogroup -R /home/opam/src/datakit 30 | 31 | RUN opam update --dev && opam upgrade 32 | 33 | RUN opam install datakit -ytv 34 | 35 | RUN sudo cp $(opam config exec -- which datakit) /usr/bin/datakit && \ 36 | sudo cp $(opam config exec -- which datakit-mount) /usr/bin/datakit-mount 37 | 38 | FROM alpine:3.9 39 | RUN apk add --no-cache libev gmp tzdata ca-certificates git openssh-client bash 40 | EXPOSE 5640 41 | ENTRYPOINT ["/usr/bin/datakit"] 42 | CMD ["--url=tcp://0.0.0.0:5640", "--git=/data", "-v"] 43 | COPY --from=0 /usr/bin/datakit /usr/bin/datakit 44 | COPY --from=0 /usr/bin/datakit-mount /usr/bin/datakit-mount 45 | -------------------------------------------------------------------------------- /Dockerfile.bridge-local-git: -------------------------------------------------------------------------------- 1 | FROM datakit/client 2 | 3 | COPY . /home/opam/src/datakit 4 | RUN sudo chown opam.nogroup -R /home/opam/src/datakit 5 | 6 | RUN opam update --dev && opam upgrade 7 | 8 | RUN opam install datakit-bridge-local-git -tyv 9 | RUN sudo cp $(opam config exec -- which datakit-bridge-local-git) /usr/bin/ 10 | 11 | FROM alpine:3.9 12 | RUN apk add --no-cache libev gmp tzdata ca-certificates 13 | ENTRYPOINT ["/usr/bin/datakit-bridge-local-git"] 14 | COPY --from=0 /usr/bin/datakit-bridge-local-git /usr/bin/datakit-bridge-local-git 15 | -------------------------------------------------------------------------------- /Dockerfile.ci: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam2:alpine 2 | RUN sudo apk add --no-cache tzdata aspcud gmp-dev perl libev-dev m4 3 | 4 | RUN opam switch 4.07 5 | 6 | ENV OPAMERRLOGLEN=0 OPAMYES=1 7 | 8 | RUN git -C /home/opam/opam-repository fetch origin && \ 9 | git -C /home/opam/opam-repository reset 340acb7d88264bf29485b1d292388e1d91dc2214 --hard && \ 10 | opam update -u 11 | 12 | RUN opam install alcotest lwt conf-libev inotify 13 | 14 | COPY check-libev.ml /tmp/check-libev.ml 15 | RUN opam exec -- ocaml /tmp/check-libev.ml 16 | 17 | # cache opam install of dependencies 18 | 19 | COPY *.opam /home/opam/src/datakit/ 20 | RUN opam pin add /home/opam/src/datakit/ -n 21 | 22 | # install dependencies 23 | 24 | RUN sudo apk add --no-cache libressl-dev linux-headers pcre-dev 25 | RUN opam install datakit-ci --deps -t 26 | 27 | # copy local sources 28 | 29 | COPY . /home/opam/src/datakit 30 | RUN sudo chown opam.nogroup -R /home/opam/src/datakit 31 | 32 | RUN opam update --dev && opam upgrade 33 | 34 | RUN opam install datakit-ci -ytv 35 | 36 | VOLUME /secrets 37 | -------------------------------------------------------------------------------- /Dockerfile.client: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam2:alpine 2 | RUN sudo apk add --no-cache tzdata aspcud gmp-dev perl libev-dev m4 3 | 4 | RUN opam switch 4.07 5 | 6 | ENV OPAMERRLOGLEN=0 OPAMYES=1 7 | 8 | RUN git -C /home/opam/opam-repository fetch origin && \ 9 | git -C /home/opam/opam-repository reset 340acb7d88264bf29485b1d292388e1d91dc2214 --hard && \ 10 | opam update -u 11 | 12 | RUN opam install alcotest lwt conf-libev inotify 13 | 14 | COPY check-libev.ml /tmp/check-libev.ml 15 | RUN opam config exec -- ocaml /tmp/check-libev.ml 16 | 17 | # cache opam install of dependencies 18 | 19 | COPY *.opam /home/opam/src/datakit/ 20 | RUN opam pin add /home/opam/src/datakit/ -n 21 | 22 | # install dependencies 23 | 24 | RUN OPAMSOLVERTIMEOUT=120 opam install datakit-client-git datakit-client-9p --deps -t 25 | 26 | COPY . /home/opam/src/datakit 27 | RUN sudo chown opam.nogroup -R /home/opam/src/datakit 28 | 29 | RUN opam update --dev && opam upgrade 30 | RUN opam install datakit-client-9p datakit-client-git -tyv 31 | 32 | RUN sudo mkdir /data && sudo chown opam.nogroup /data && chmod 700 /data && \ 33 | sudo cp $(opam config exec -- which datakit-mount) /usr/bin/datakit-mount 34 | 35 | CMD bash -c "/usr/bin/datakit-mount -h $(getent hosts datakit | awk '{print $1}')"; \ 36 | bash 37 | -------------------------------------------------------------------------------- /Dockerfile.github: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam2:alpine 2 | RUN sudo apk add --no-cache tzdata aspcud gmp-dev perl libev-dev m4 3 | 4 | RUN opam switch 4.07 5 | 6 | ENV OPAMERRLOGLEN=0 OPAMYES=1 7 | 8 | RUN git -C /home/opam/opam-repository fetch origin && \ 9 | git -C /home/opam/opam-repository reset 340acb7d88264bf29485b1d292388e1d91dc2214 --hard && \ 10 | opam update -u 11 | 12 | RUN opam install alcotest lwt conf-libev inotify tls 13 | 14 | COPY check-libev.ml /tmp/check-libev.ml 15 | RUN opam exec -- ocaml /tmp/check-libev.ml 16 | 17 | # cache opam install of dependencies 18 | 19 | COPY *.opam /home/opam/src/datakit/ 20 | RUN opam pin add /home/opam/src/datakit/ -n 21 | 22 | # install dependencies 23 | 24 | RUN opam install datakit-bridge-github --deps -t 25 | 26 | # copy local sources 27 | 28 | COPY . /home/opam/src/datakit 29 | RUN sudo chown opam.nogroup -R /home/opam/src/datakit 30 | 31 | RUN opam update --dev && opam upgrade 32 | 33 | RUN opam install datakit-bridge-github -ytv 34 | 35 | RUN sudo cp $(opam config exec -- which datakit-bridge-github) /usr/bin/ 36 | 37 | FROM alpine:3.9 38 | RUN apk add --no-cache libev gmp tzdata ca-certificates 39 | EXPOSE 5640 40 | EXPOSE 5641 41 | ENTRYPOINT ["/usr/bin/datakit-bridge-github"] 42 | CMD ["--listen=tcp://0.0.0.0:5641", "-v", "--datakit=tcp:127.0.0.1:5640"] 43 | COPY --from=0 /usr/bin/datakit-bridge-github /usr/bin/datakit-bridge-github 44 | -------------------------------------------------------------------------------- /MAINTAINERS: -------------------------------------------------------------------------------- 1 | # DataKit maintainers file 2 | # 3 | # This file describes who runs the moby/datakit project and how. 4 | # This is a living document - if you see something out of date or missing, speak up! 5 | # 6 | # It is structured to be consumable by both humans and programs. 7 | # To extract its contents programmatically, use any TOML-compliant 8 | # parser. 9 | # 10 | # This file is compiled into the MAINTAINERS file in docker/opensource. 11 | # 12 | [Org] 13 | [Org."Core maintainers"] 14 | people = [ 15 | "samoht", 16 | "talex5", 17 | "avsm" 18 | ] 19 | 20 | [people] 21 | 22 | # A reference list of all people associated with the project. 23 | # All other sections should refer to people by their canonical key 24 | # in the people section. 25 | 26 | # ADD YOURSELF HERE IN ALPHABETICAL ORDER 27 | 28 | [people.samoht] 29 | Name = "Thomas Gazagnaire" 30 | Email = "thomas@gazagnaire.org" 31 | GitHub = "samoht" 32 | 33 | [people.talex5] 34 | Name = "Thomas Leonard" 35 | Email = "thomas.leonard@docker.com" 36 | GitHub = "talex5" 37 | 38 | [people.avsm] 39 | Name = "Anil Madhavapeddy" 40 | Email = "anil@recoil.org" 41 | GitHub = "avsm" 42 | 43 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | PINOPTS=-yn -k git 2 | 3 | BUILD=dune build --profile=release 4 | RUNTEST=dune runtest 5 | 6 | .PHONY: all clean test bundle COMMIT exe ci 7 | 8 | all: 9 | $(BUILD) 10 | 11 | depends: 12 | opam pin add ${PINOPTS} datakit-client.dev . 13 | opam pin add ${PINOPTS} datakit-server.dev . 14 | opam pin add ${PINOPTS} datakit-client-9p.dev . 15 | opam pin add ${PINOPTS} datakit-server-9p.dev . 16 | opam pin add ${PINOPTS} datakit.dev . 17 | opam pin add ${PINOPTS} datakit-github.dev . 18 | opam pin add ${PINOPTS} datakit-bridge-github.dev . 19 | opam pin add ${PINOPTS} datakit-bridge-local-git.dev . 20 | opam pin add ${PINOPTS} datakit-ci.dev . 21 | opam install -y --deps-only datakit-ci datakit datakit-bridge-github datakit-bridge-local-git 22 | opam update -u datakit datakit-client datakit-server datakit-github \ 23 | datakit-ci datakit-bridge-github datakit-bridge-local-git -y 24 | 25 | datakit: 26 | $(BUILD) -p datakit 27 | 28 | client: 29 | $(BUILD) -p datakit-client 30 | 31 | client-9p: 32 | $(BUILD) -p datakit-client-9p 33 | 34 | server: 35 | $(BUILD) -p datakit-server 36 | 37 | github: 38 | $(BUILD) -p datakit-github 39 | 40 | bridge-local-git: 41 | $(BUILD) -p datakit-bridge-local-git 42 | 43 | bridge-github: 44 | $(BUILD) -p datakit-bridge-github 45 | $(RUNTEST) test/datakit-github-bridge 46 | 47 | ci: 48 | $(BUILD) -p datakit-ci 49 | $(RUNTEST) ci/tests 50 | 51 | clean: 52 | dune clean 53 | rm -rf com.docker.db com.docker.db.exe COMMIT _tests 54 | rm -f examples/ocaml-client/*.native 55 | rm -f ci/skeleton/exampleCI.native 56 | rm -f com.docker.db 57 | 58 | test: 59 | dune runtest 60 | 61 | bundle: 62 | opam remove tls ssl -y 63 | $(MAKE) clean 64 | $(BUILD) src/datakit/bin/main.exe 65 | cp _build/default/src/datakit/bin/main.exe com.docker.db 66 | ./scripts/check-dylib.sh 67 | 68 | COMMIT: 69 | @git rev-parse HEAD > COMMIT 70 | 71 | exe: 72 | opam remove tls ssl -y 73 | rm -rf _build/ 74 | $(BUILD) src/datakit/bin/main.exe 75 | cp _build/default/src/datakit/bin/main.exe com.docker.db.exe 76 | -------------------------------------------------------------------------------- /api/go-datakit/README: -------------------------------------------------------------------------------- 1 | To run test on windows, launch the a datakit server with --url \\.\pipe\datakit-test -------------------------------------------------------------------------------- /api/go-datakit/client_test.go: -------------------------------------------------------------------------------- 1 | package datakit 2 | 3 | import ( 4 | "bytes" 5 | "io" 6 | "log" 7 | "testing" 8 | 9 | p9p "github.com/docker/go-p9p" 10 | 11 | "context" 12 | ) 13 | 14 | func TestInit(t *testing.T) { 15 | ctx := context.Background() 16 | log.Println("Testing the client interface") 17 | 18 | client, err := dial(ctx) 19 | if err != nil { 20 | t.Fatalf("Dial failed: %v", err) 21 | } 22 | err = client.Remove(ctx, "branch", "master", "rm", "does-not-exist") 23 | if err != nil { 24 | t.Fatalf("Remove failed: %v", err) 25 | } 26 | err = client.Remove(ctx, "branch", "master", "rm", "foo") 27 | if err != nil { 28 | t.Fatalf("Remove failed: %v", err) 29 | } 30 | path := []string{"branch", "master", "transactions", "foo"} 31 | err = client.Mkdir(ctx, path...) 32 | if err != nil { 33 | t.Fatalf("Mkdir failed: %v", err) 34 | } 35 | path = []string{"branch", "master", "transactions", "foo", "rw", "a", "b", "c"} 36 | err = client.Mkdir(ctx, path...) 37 | if err != nil { 38 | t.Fatalf("Mkdir failed: %v", err) 39 | } 40 | current := make([]string, len(path)) 41 | copy(current, path) 42 | log.Println("Remove", current) 43 | for len(current) > 5 { 44 | err = client.Remove(ctx, current...) 45 | if err != nil { 46 | t.Fatalf("Remove %v failed: %v", current, err) 47 | } 48 | current = current[0 : len(current)-1] 49 | } 50 | err = client.Mkdir(ctx, path...) 51 | if err != nil { 52 | t.Fatalf("Mkdir failed: %v", err) 53 | } 54 | filePath := append(path, "filename") 55 | 56 | err = client.Remove(ctx, filePath...) 57 | if err != nil { 58 | t.Fatalf("Remove failed: %v", err) 59 | } 60 | file, err := client.Create(ctx, filePath...) 61 | if err != nil { 62 | t.Fatalf("Create %v failed: %v", filePath, err) 63 | } 64 | message := []byte("Hello world") 65 | n, err := file.Write(ctx, message, 0) 66 | if err != nil { 67 | t.Fatalf("Write failed: %v", err) 68 | } 69 | sector := make([]byte, 512) 70 | m, err := file.Read(ctx, sector, 0) 71 | if err != nil { 72 | t.Fatalf("Read failed: %v", err) 73 | } 74 | if n != m { 75 | t.Fatalf("Failed to read back the number of bytes we wrote") 76 | } 77 | if string(message) != string(sector[0:m]) { 78 | t.Fatalf("The message we read back was different to the message we wrote") 79 | } 80 | file.Close(ctx) 81 | file.Close(ctx) // should be idempotent 82 | 83 | largeFilePath := append(path, "largefile") 84 | var largeDataInput []byte 85 | 86 | for ix := 0; ix < p9p.DefaultMSize*2+150; ix++ { 87 | largeDataInput = append(largeDataInput, byte(ix)) 88 | } 89 | file, err = client.Create(ctx, largeFilePath...) 90 | if err != nil { 91 | t.Fatalf("Create %v failed: %v", filePath, err) 92 | } 93 | defer file.Close(ctx) 94 | n, err = file.NewIOWriter(ctx, 0).Write(largeDataInput) 95 | if err != nil { 96 | t.Fatalf("Write failed: %v", err) 97 | } 98 | if n != len(largeDataInput) { 99 | t.Fatalf("Write was only partial: %v", err) 100 | } 101 | t.Logf("Written %v bytes successfully", n) 102 | readBackData := make([]byte, len(largeDataInput)+2) // make sure reported length when ReadAll is called has the right value 103 | n, err = io.ReadFull(file.NewIOReader(ctx, 0), readBackData) 104 | if err != nil && err != io.EOF && err != io.ErrUnexpectedEOF { 105 | t.Fatalf("Read failed: %v", err) 106 | } 107 | if n != len(largeDataInput) { 108 | t.Fatalf("Failed to read back the number of bytes we wrote") 109 | } 110 | if bytes.Compare(largeDataInput, readBackData[:n]) != 0 { 111 | t.Fatalf("The message we read back was different to the message we wrote") 112 | } 113 | t.Logf("Read %v bytes successfully", n) 114 | } 115 | -------------------------------------------------------------------------------- /api/go-datakit/dial_test.go: -------------------------------------------------------------------------------- 1 | // +build linux darwin 2 | 3 | package datakit 4 | 5 | import "context" 6 | 7 | func dial(ctx context.Context) (*Client, error) { 8 | return Dial(ctx, "unix", "/var/tmp/foo") 9 | } 10 | -------------------------------------------------------------------------------- /api/go-datakit/dial_windows_test.go: -------------------------------------------------------------------------------- 1 | package datakit 2 | 3 | import ( 4 | "context" 5 | 6 | "github.com/Microsoft/go-winio" 7 | ) 8 | 9 | func dial(ctx context.Context) (*Client, error) { 10 | conn, err := winio.DialPipe(`\\.\pipe\datakit-test`, nil) 11 | if err != nil { 12 | return nil, err 13 | } 14 | return NewClient(ctx, conn) 15 | } 16 | -------------------------------------------------------------------------------- /api/go-datakit/doc.go: -------------------------------------------------------------------------------- 1 | /* 2 | The datakit package contains common patterns over 9P, which avoids the need 3 | for applications to use 9P directly. 4 | */ 5 | package datakit 6 | -------------------------------------------------------------------------------- /api/go-datakit/snapshot.go: -------------------------------------------------------------------------------- 1 | package datakit 2 | 3 | import ( 4 | "bytes" 5 | "io" 6 | "log" 7 | "strings" 8 | 9 | p9p "github.com/docker/go-p9p" 10 | "context" 11 | ) 12 | 13 | type SnapshotKind uint8 14 | 15 | const ( 16 | COMMIT SnapshotKind = 0x01 // from a commit hash 17 | OBJECT SnapshotKind = 0x02 // from an object hash 18 | ) 19 | 20 | type snapshot struct { 21 | client *Client 22 | kind SnapshotKind 23 | thing string 24 | } 25 | 26 | type Snapshot struct { 27 | snapshot 28 | } 29 | 30 | // NewSnapshot opens a new snapshot referencing the given object. 31 | func NewSnapshot(ctx context.Context, client *Client, kind SnapshotKind, thing string) *Snapshot { 32 | return &Snapshot{snapshot{client: client, kind: kind, thing: thing}} 33 | } 34 | 35 | // Head retrieves the commit sha of the given branch 36 | func Head(ctx context.Context, client *Client, fromBranch string) (string, error) { 37 | // SHA=$(cat branch//head) 38 | file, err := client.Open(ctx, p9p.ORDWR, "branch", fromBranch, "head") 39 | if err != nil { 40 | log.Println("Failed to open branch/", fromBranch, "/head") 41 | return "", err 42 | } 43 | defer file.Close(ctx) 44 | buf := make([]byte, 512) 45 | n, err := file.Read(ctx, buf, 0) 46 | if err != nil { 47 | log.Println("Failed to Read branch", fromBranch, "head", err) 48 | return "", err 49 | } 50 | return strings.TrimSpace(string(buf[0:n])), nil 51 | } 52 | 53 | func (s *Snapshot) getFullPath(path []string) []string { 54 | var p []string 55 | 56 | switch s.kind { 57 | case COMMIT: 58 | p = []string{"snapshots", s.thing, "ro"} 59 | case OBJECT: 60 | p = []string{"trees", s.thing} 61 | } 62 | 63 | for _, element := range path { 64 | p = append(p, element) 65 | } 66 | return p 67 | } 68 | 69 | // Read reads a value from the snapshot 70 | func (s *Snapshot) Read(ctx context.Context, path []string) (string, error) { 71 | p := s.getFullPath(path) 72 | file, err := s.client.Open(ctx, p9p.OREAD, p...) 73 | if err != nil { 74 | return "", err 75 | } 76 | defer file.Close(ctx) 77 | reader := file.NewIOReader(ctx, 0) 78 | buf := bytes.NewBuffer(nil) 79 | io.Copy(buf, reader) 80 | return string(buf.Bytes()), nil 81 | } 82 | 83 | // List returns filenames list in directory 84 | func (s *Snapshot) List(ctx context.Context, path []string) ([]string, error) { 85 | p := s.getFullPath(path) 86 | return s.client.List(ctx, p) 87 | } 88 | -------------------------------------------------------------------------------- /api/go-datakit/snapshot_test.go: -------------------------------------------------------------------------------- 1 | package datakit 2 | 3 | import ( 4 | "log" 5 | "testing" 6 | 7 | "context" 8 | ) 9 | 10 | func TestSnapshot(t *testing.T) { 11 | ctx := context.Background() 12 | log.Println("Testing the snapshot interface") 13 | 14 | client, err := dial(ctx) 15 | if err != nil { 16 | t.Fatalf("Failed to connect to db: %v", err) 17 | } 18 | 19 | trans, err := NewTransaction(ctx, client, "master") 20 | 21 | if err != nil { 22 | t.Fatalf("NewTransaction failed: %v", err) 23 | } 24 | path := []string{"snapshot", "test", "time"} 25 | expected := "hello!" 26 | err = trans.Write(ctx, path, expected) 27 | if err != nil { 28 | t.Fatalf("Transaction.Write failed: %v", err) 29 | } 30 | err = trans.Commit(ctx, "Snapshot test") 31 | if err != nil { 32 | t.Fatalf("Transaction.Commit failed: %v", err) 33 | } 34 | sha, err := Head(ctx, client, "master") 35 | if err != nil { 36 | t.Fatalf("Failed to discover the HEAD of master: %v", err) 37 | } 38 | snap := NewSnapshot(ctx, client, COMMIT, sha) 39 | actual, err := snap.Read(ctx, path) 40 | if err != nil { 41 | t.Fatalf("Failed to read path %v from snapshot %v: %v", path, sha, err) 42 | } 43 | if expected != actual { 44 | t.Fatalf("Value in snapshot (%v) doesn't match the value we wrote (%v)", actual, expected) 45 | } 46 | testpath := []string{"snapshot", "test"} 47 | list, err := snap.List(ctx, testpath) 48 | if err != nil { 49 | t.Fatalf("Failed to list path %v from snapshot %v: %v", testpath, sha, err) 50 | } 51 | if len(list) != 1 && list[0] != "time" { 52 | t.Fatalf("Value in snapshot (%v) doesn't match the value we wrote (%v)", actual, expected) 53 | } 54 | } 55 | -------------------------------------------------------------------------------- /api/go-datakit/transaction.go: -------------------------------------------------------------------------------- 1 | package datakit 2 | 3 | import ( 4 | "bytes" 5 | "io" 6 | "log" 7 | "strconv" 8 | "sync/atomic" 9 | 10 | p9p "github.com/docker/go-p9p" 11 | "context" 12 | ) 13 | 14 | type transaction struct { 15 | client *Client 16 | fromBranch string 17 | newBranch string 18 | } 19 | 20 | var nextTransaction = int64(0) 21 | 22 | // NewTransaction opens a new transaction originating from fromBranch, named 23 | // newBranch. 24 | func NewTransaction(ctx context.Context, client *Client, fromBranch string) (*transaction, error) { 25 | 26 | id := atomic.AddInt64(&nextTransaction, 1) 27 | newBranch := strconv.FormatInt(id, 10) 28 | err := client.Mkdir(ctx, "branch", fromBranch) 29 | if err != nil { 30 | log.Println("Failed to Create branch/", fromBranch, err) 31 | return nil, err 32 | } 33 | err = client.Mkdir(ctx, "branch", fromBranch, "transactions", newBranch) 34 | if err != nil { 35 | log.Println("Failed to Create branch/", fromBranch, "/transactions/", newBranch, err) 36 | return nil, err 37 | } 38 | 39 | return &transaction{client: client, fromBranch: fromBranch, newBranch: newBranch}, nil 40 | } 41 | 42 | func (t *transaction) close(ctx context.Context) { 43 | // TODO: do we need to clear up unmerged branches? 44 | } 45 | 46 | // Abort ensures the update will not be committed. 47 | func (t *transaction) Abort(ctx context.Context) { 48 | t.close(ctx) 49 | } 50 | 51 | // Commit merges the newBranch back into the fromBranch, or fails 52 | func (t *transaction) Commit(ctx context.Context, msg string) error { 53 | // msg 54 | msgPath := []string{"branch", t.fromBranch, "transactions", t.newBranch, "msg"} 55 | msgFile, err := t.client.Open(ctx, p9p.ORDWR, msgPath...) 56 | if err != nil { 57 | log.Println("Failed to Open msg", err) 58 | return err 59 | } 60 | defer msgFile.Close(ctx) 61 | _, err = msgFile.Write(ctx, []byte(msg), 0) 62 | if err != nil { 63 | log.Println("Failed to Write msg", err) 64 | } 65 | 66 | // ctl 67 | ctlPath := []string{"branch", t.fromBranch, "transactions", t.newBranch, "ctl"} 68 | ctlFile, err := t.client.Open(ctx, p9p.ORDWR, ctlPath...) 69 | if err != nil { 70 | log.Println("Failed to Open ctl", err) 71 | return err 72 | } 73 | defer ctlFile.Close(ctx) 74 | _, err = ctlFile.Write(ctx, []byte("commit"), 0) 75 | if err != nil { 76 | log.Println("Failed to Write ctl", err) 77 | return err 78 | } 79 | return nil 80 | } 81 | 82 | // Write updates a key=value pair within the transaction. 83 | func (t *transaction) Write(ctx context.Context, path []string, value string) error { 84 | p := []string{"branch", t.fromBranch, "transactions", t.newBranch, "rw"} 85 | for _, dir := range path[0 : len(path)-1] { 86 | p = append(p, dir) 87 | } 88 | err := t.client.Mkdir(ctx, p...) 89 | if err != nil { 90 | log.Println("Failed to Mkdir", p) 91 | } 92 | p = append(p, path[len(path)-1]) 93 | file, err := t.client.Create(ctx, p...) 94 | if err != nil { 95 | log.Println("Failed to Create", p) 96 | return err 97 | } 98 | defer file.Close(ctx) 99 | writer := file.NewIOWriter(ctx, 0) 100 | _, err = writer.Write([]byte(value)) 101 | if err != nil { 102 | log.Println("Failed to Write", path, "=", value, ":", err) 103 | return err 104 | } 105 | return nil 106 | } 107 | 108 | // Read reads a key within the transaction. 109 | func (t *transaction) Read(ctx context.Context, path []string) (string, error) { 110 | p := []string{"branch", t.fromBranch, "transactions", t.newBranch, "rw"} 111 | for _, dir := range path[0 : len(path)-1] { 112 | p = append(p, dir) 113 | } 114 | file, err := t.client.Open(ctx, p9p.OREAD, p...) 115 | if err != nil { 116 | return "", err 117 | } 118 | defer file.Close(ctx) 119 | reader := file.NewIOReader(ctx, 0) 120 | buf := bytes.NewBuffer(nil) 121 | io.Copy(buf, reader) 122 | return string(buf.Bytes()), nil 123 | } 124 | 125 | // Remove deletes a key within the transaction. 126 | func (t *transaction) Remove(ctx context.Context, path []string) error { 127 | p := []string{"branch", t.fromBranch, "transactions", t.newBranch, "rw"} 128 | for _, dir := range path { 129 | p = append(p, dir) 130 | } 131 | err := t.client.Remove(ctx, p...) 132 | if err != nil { 133 | log.Println("Failed to Remove ", p) 134 | } 135 | return nil 136 | } 137 | -------------------------------------------------------------------------------- /api/go-datakit/transaction_test.go: -------------------------------------------------------------------------------- 1 | package datakit 2 | 3 | import ( 4 | "log" 5 | "testing" 6 | 7 | "context" 8 | ) 9 | 10 | func TestTransaction(t *testing.T) { 11 | ctx := context.Background() 12 | log.Println("Testing the transaction interface") 13 | 14 | client, err := dial(ctx) 15 | if err != nil { 16 | t.Fatalf("Failed to connect to db: %v", err) 17 | } 18 | trans, err := NewTransaction(ctx, client, "master") 19 | 20 | if err != nil { 21 | t.Fatalf("NewTransaction failed: %v", err) 22 | } 23 | err = trans.Write(ctx, []string{"a", "b", "c"}, "hello!") 24 | if err != nil { 25 | t.Fatalf("Transaction.Write failed: %v", err) 26 | } 27 | err = trans.Commit(ctx, "Test transaction") 28 | if err != nil { 29 | t.Fatalf("Transaction.Commit failed: %v", err) 30 | } 31 | } 32 | -------------------------------------------------------------------------------- /api/go-datakit/watch.go: -------------------------------------------------------------------------------- 1 | package datakit 2 | 3 | import ( 4 | "io" 5 | "log" 6 | "strings" 7 | 8 | p9p "github.com/docker/go-p9p" 9 | "context" 10 | ) 11 | 12 | type watch struct { 13 | client *Client 14 | file *File 15 | offset int64 // current offset within head.live file 16 | } 17 | 18 | type Watch struct { 19 | watch 20 | } 21 | 22 | // NewWatch starts watching a path within a branch 23 | func NewWatch(ctx context.Context, client *Client, fromBranch string, path []string) (*Watch, error) { 24 | // SHA=$(cat branch//watch//tree.live) 25 | p := []string{"branch", fromBranch, "watch"} 26 | for _, dir := range path { 27 | p = append(p, dir+".node") 28 | } 29 | p = append(p, "tree.live") 30 | file, err := client.Open(ctx, p9p.OREAD, p...) 31 | if err != nil { 32 | log.Println("Failed to open", p, err) 33 | return nil, err 34 | } 35 | offset := int64(0) 36 | return &Watch{watch{client: client, file: file, offset: offset}}, nil 37 | } 38 | 39 | func (w *Watch) Next(ctx context.Context) (*Snapshot, error) { 40 | buf := make([]byte, 512) 41 | sawFlush := false 42 | for { 43 | // NOTE: irmin9p-direct will never return a fragment; 44 | // we can rely on the buffer containing a whold number 45 | // of lines. 46 | n, err := w.file.Read(ctx, buf, w.offset) 47 | if n == 0 { 48 | // Two reads of "" in a row means end-of-file 49 | if sawFlush { 50 | return nil, io.EOF 51 | } else { 52 | sawFlush = true 53 | continue 54 | } 55 | } else { 56 | sawFlush = false 57 | } 58 | w.offset = w.offset + int64(n) 59 | if err != nil { 60 | log.Println("Failed to Read head.live", err) 61 | return nil, io.EOF 62 | } 63 | lines := strings.Split(string(buf[0:n]), "\n") 64 | // Use the last non-empty line 65 | thing := "" 66 | for _, line := range lines { 67 | if line != "" { 68 | thing = line 69 | } 70 | } 71 | return NewSnapshot(ctx, w.client, OBJECT, thing), nil 72 | } 73 | } 74 | 75 | func (w *Watch) Close(ctx context.Context) { 76 | w.file.Close(ctx) 77 | } 78 | -------------------------------------------------------------------------------- /api/ocaml/9p/datakit_client_9p.mli: -------------------------------------------------------------------------------- 1 | (** A DataKit client that connects to the server over a 9p connection. *) 2 | 3 | module Make (P9p : Protocol_9p.Client.S) : sig 4 | include Datakit_client.S 5 | 6 | val connect : P9p.t -> t 7 | (** [connect c] is a Datakit connection using the 9p connection [c]. *) 8 | end 9 | -------------------------------------------------------------------------------- /api/ocaml/9p/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name datakit_client_9p) 3 | (public_name datakit-client-9p) 4 | (wrapped false) 5 | (libraries datakit-client protocol-9p-unix)) 6 | -------------------------------------------------------------------------------- /api/ocaml/9p/mount/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name mount) 3 | (public_name datakit-mount) 4 | (package datakit-client-9p) 5 | (libraries cmdliner unix)) 6 | 7 | (rule 8 | (targets version.ml) 9 | (action 10 | (with-stdout-to 11 | %{targets} 12 | (echo "let v = \"%{version:datakit-client-9p}\"")))) 13 | -------------------------------------------------------------------------------- /api/ocaml/9p/mount/mount.ml: -------------------------------------------------------------------------------- 1 | open Cmdliner 2 | 3 | let mopts = "MOUNT OPTIONS" 4 | 5 | let host = 6 | let doc = 7 | Arg.info ~doc:"The 9p server hostname (or ip)" ~docv:"HOST" ~docs:mopts 8 | [ "h"; "host" ] 9 | in 10 | Arg.(value & opt string "172.17.0.2" doc) 11 | 12 | let port = 13 | let doc = 14 | Arg.info ~doc:"The 9p server port" ~docv:"PORT" ~docs:mopts [ "p"; "port" ] 15 | in 16 | Arg.(value & opt int 5640 doc) 17 | 18 | let mnt = 19 | let doc = 20 | Arg.info ~doc:"The destination mount point." ~docv:"DIR" ~docs:mopts [] 21 | in 22 | Arg.(value & pos 0 string "/db" doc) 23 | 24 | let mount ip port mnt = 25 | let uid = Unix.getuid () in 26 | let gid = Unix.getgid () in 27 | let user = try Unix.((getpwuid uid).pw_name) with Not_found -> "user" in 28 | ( if not (Sys.file_exists mnt) then 29 | let i = Sys.command (Printf.sprintf "sudo mkdir -p %s" mnt) in 30 | if i <> 0 then exit i ); 31 | let cmd = 32 | Printf.sprintf 33 | "sudo mount -t 9p -o \ 34 | trans=tcp,port=%d,name=%s,uname=%s,noextend,nodev,uid=%d,gid=%d,dfltuid=%d,dfltgid=%d \ 35 | %s %s" 36 | port user user uid gid uid gid ip mnt 37 | in 38 | exit (Sys.command cmd) 39 | 40 | let term = 41 | let doc = "Mount a Datakit volume on the filesystem over 9p." in 42 | let man = 43 | [ `S "DESCRIPTION"; 44 | `P "$(i, datakit-mount) mounts datakit volumes on the local filesystem." 45 | ] 46 | in 47 | ( Term.(pure mount $ host $ port $ mnt), 48 | Term.info "datakit-mount" ~version:Version.v ~doc ~man ) 49 | 50 | let () = match Term.eval term with `Error _ -> exit 1 | _ -> () 51 | -------------------------------------------------------------------------------- /api/ocaml/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name datakit_client) 3 | (public_name datakit-client) 4 | (wrapped false) 5 | (libraries fmt lwt cstruct astring)) 6 | -------------------------------------------------------------------------------- /api/ocaml/git/datakit_client_git.mli: -------------------------------------------------------------------------------- 1 | (** A DataKit client that use a Git directory directly. *) 2 | 3 | include Datakit_client.S 4 | 5 | val connect : 6 | ?head:string -> 7 | ?bare:bool -> 8 | ?level:int -> 9 | ?dot_git:string -> 10 | ?author:string -> 11 | string -> 12 | t Lwt.t 13 | -------------------------------------------------------------------------------- /api/ocaml/git/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name datakit_client_git) 3 | (public_name datakit-client-git) 4 | (wrapped false) 5 | (libraries datakit-client irmin-git git-unix irmin-watcher)) 6 | -------------------------------------------------------------------------------- /appveyor.yml: -------------------------------------------------------------------------------- 1 | platform: 2 | - x86 3 | 4 | environment: 5 | FORK_USER: ocaml 6 | FORK_BRANCH: master 7 | CYG_ROOT: C:\cygwin64 8 | PACKAGE: datakit 9 | OPAM_SWITCH: "4.05.0+mingw64c" 10 | PINS: "datakit-server.dev:. datakit-server-9p.dev:. datakit-github.dev:. datakit-client.dev:. datakit-client-9p.dev:." 11 | 12 | install: 13 | - ps: iex ((new-object net.webclient).DownloadString("https://raw.githubusercontent.com/$env:FORK_USER/ocaml-ci-scripts/$env:FORK_BRANCH/appveyor-install.ps1")) 14 | 15 | build_script: 16 | - call %CYG_ROOT%\bin\bash.exe -l %APPVEYOR_BUILD_FOLDER%\appveyor-opam.sh 17 | - call %CYG_ROOT%\bin\bash.exe -lc 'cd ${APPVEYOR_BUILD_FOLDER}; make exe COMMIT' 18 | 19 | artifacts: 20 | - path: "com.docker.db.exe" 21 | - path: "COMMIT" 22 | 23 | #cache: 24 | # - '%CYG_ROOT%\home\appveyor\.opam' 25 | -------------------------------------------------------------------------------- /bridge/github/README.md: -------------------------------------------------------------------------------- 1 | ## DataKit-GitHub bridge 2 | 3 | The bridge monitors the state of one or more GitHub projects, writing the status (open PRs, branches and tags) to a DataKit branch. 4 | It also monitors the branch and writes back any changes to GitHub. 5 | 6 | 7 | ### Build 8 | 9 | Build using the `Dockerfile.github` file at the root of this repository: 10 | 11 | docker build -t datakit-github -f Dockerfile.github . 12 | 13 | ### Run 14 | 15 | To see the help text: 16 | 17 | docker run -it --rm datakit-github --help 18 | 19 | Create a GitHub API token: 20 | 21 | docker run -it --rm \ 22 | -v /path/to/jar:/home/opam/.github/jar \ 23 | --entrypoint opam \ 24 | -u opam \ 25 | datakit-github \ 26 | config exec \ 27 | git jar make my-user datakit 28 | 29 | Replace `/path/to/jar` with the path of your new directory. 30 | Replace `my-user` with your GitHub user name. 31 | 32 | Using the GitHub web interface, edit the token to give it the `repo`, permission. 33 | Also, ensure the user is an `admin` in the `Collaborators` settings. 34 | 35 | Start a DataKit server running somewhere: 36 | 37 | mkdir test-store 38 | git init test-store/.git --bare 39 | datakit --git test-store --url tcp://127.0.0.1:6640 -v 40 | 41 | 42 | To run it: 43 | 44 | docker run -it --rm \ 45 | -v /path/to/jar/datakit:/run/secrets/datakit-github-cookie \ 46 | datakit-github \ 47 | --datakit=tcp:x.x.x.x:6640 \ 48 | --verbose \ 49 | --webhook=http://my-ip 50 | 51 | Note: `/path/to/jar/datakit` MUST NOT have any "other" permissions set in its Unix permissions. 52 | Otherwise, the bridge will refuse to start, saying that the file doesn't exist. 53 | 54 | Replace: 55 | - `/path/to/jar` with the path of your jar directory. 56 | - `tcp:x.x.x.x:6640` with the path to your DataKit server. 57 | - `http://my-ip` with a URL which GitHub can use to send events to the bridge. 58 | 59 | ### Start monitoring a repository 60 | 61 | Connect to DataKit and create an empty file `repo/project/.monitor` on the `github-metadata` branch. 62 | The bridge will immediately start querying GitHub and will populate the directory with information about the project. 63 | -------------------------------------------------------------------------------- /bridge/github/datakit_github_api.mli: -------------------------------------------------------------------------------- 1 | (** {!API} implementation using [ocaml-github] bindings. *) 2 | 3 | type token 4 | 5 | val token : user_agent:string -> token:Github.Token.t -> token 6 | 7 | include Datakit_github.API with type token := token 8 | -------------------------------------------------------------------------------- /bridge/github/datakit_github_state.mli: -------------------------------------------------------------------------------- 1 | open Datakit_github 2 | 3 | (** API State: TODO find a better name? *) 4 | module Make (API : API) : sig 5 | (** {1 Token} *) 6 | 7 | type token 8 | (** The type for state token. *) 9 | 10 | val token : API.token -> Capabilities.t -> token 11 | (** [token t c] is the token using the GitHub API token [t] limited 12 | by the capabilities [c]. *) 13 | 14 | val capabilities : token -> Capabilities.t 15 | (** [capabilities t] is the token [t]'s capabilities. *) 16 | 17 | val with_capabilities : Capabilities.t -> token -> token 18 | (** [with_capabilities c t] is [t] with the capabilities [c]. *) 19 | 20 | (** {1 Synchronisation} *) 21 | 22 | val import : token -> Snapshot.t -> Elt.IdSet.t -> Snapshot.t Lwt.t 23 | (** [import token t r] imports the state of GitHub for the elements 24 | in [r] into [t]. API calls use the token [token]. *) 25 | 26 | val apply : token -> Diff.t -> unit Lwt.t 27 | (** [apply token d] applies the snapshot diff [d] as a series of 28 | GitHub API calls, using the token [token]. *) 29 | 30 | (** {1 Webhooks} *) 31 | 32 | val add_webhooks : 33 | token -> watch:(Repo.t -> unit Lwt.t) -> Repo.Set.t -> unit Lwt.t 34 | (** [add_webhooks t rs] adds webhooks for the repositories [rs]. *) 35 | 36 | val import_webhook_events : 37 | token -> 38 | events:(unit -> Event.t list Lwt.t) -> 39 | Snapshot.t -> 40 | Snapshot.t Lwt.t 41 | (** [import_webhook_events t ~events s] applies [events ()] on top 42 | of [s]. Note: it ensure that all the metadata are correctly 43 | updated by inserting (possibly) missing events in the mix. For 44 | instance, GitHub never sends {{!Event.Status}status} events, so 45 | [import_events] has to reconstruct them. *) 46 | end 47 | -------------------------------------------------------------------------------- /bridge/github/datakit_github_sync.mli: -------------------------------------------------------------------------------- 1 | open Datakit_github 2 | 3 | module Make (API : API) (DK : Datakit_client.S) : sig 4 | type t 5 | (** The type for synchronizer state. *) 6 | 7 | val empty : t 8 | (** Create an empty sync state. *) 9 | 10 | val sync : 11 | token:API.token -> 12 | ?webhook:API.Webhook.t -> 13 | ?resync_interval:float -> 14 | ?switch:Lwt_switch.t -> 15 | ?policy:[ `Once | `Repeat ] -> 16 | ?cap:Capabilities.t -> 17 | DK.Branch.t -> 18 | t -> 19 | t Lwt.t 20 | (** [sync ~token b t] mirror GitHub changes in the DataKit branch 21 | [b]. The GitHub API calls use the token [token]. The default 22 | [policy] is [`Repeat] and [cap] is [Cap.all]. *) 23 | end 24 | -------------------------------------------------------------------------------- /bridge/github/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name datakit_bridge_github) 3 | (wrapped false) 4 | (modules 5 | (:standard \ main) 6 | \ 7 | version) 8 | (libraries rresult github-hooks-unix github-unix datakit-github 9 | datakit-client)) 10 | 11 | (executable 12 | (name main) 13 | (modules main version) 14 | (package datakit-bridge-github) 15 | (public_name datakit-bridge-github) 16 | (libraries datakit_bridge_github datakit-client-9p protocol-9p-unix 17 | datakit-client-git prometheus-app.unix datakit_log fmt.cli fmt.tty 18 | github-unix)) 19 | 20 | (rule 21 | (targets version.ml) 22 | (action 23 | (with-stdout-to 24 | %{targets} 25 | (echo "let v = \"%{version:datakit-bridge-github}\"")))) 26 | -------------------------------------------------------------------------------- /bridge/github/main.mli: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /bridge/local/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | make -w -C ../.. bridge-local-git 3 | 4 | clean: 5 | make -C ../.. clean 6 | -------------------------------------------------------------------------------- /bridge/local/README.md: -------------------------------------------------------------------------------- 1 | ## DataKit Local-Git bridge 2 | 3 | This service is a drop-in replacement for the DataKit-GitHub bridge that instead just monitors a local Git repository. 4 | It is useful for testing a new DataKitCI configuration without having to configure GitHub integration first. 5 | 6 | The local bridge monitors the state of one or more local Git repositories, writing the current head of each branch to DataKit. 7 | DataKitCI can be configured to run the CI tests against the project each time a commit is made. 8 | 9 | Once you are happy with the way the CI is working, you can replace this service with the GitHub bridge service to have the CI test a project hosted on GitHub instead. 10 | 11 | Unlike the GitHub bridge, this service: 12 | 13 | - only reports on branches, not tags or pull requests; 14 | - does not report build statuses from other CI systems; and 15 | - does not push the statuses set by the CI anywhere. 16 | 17 | For an example test configuration using this bridge, see `ci/self-ci/docker-compose.yml`. 18 | 19 | 20 | ### Build 21 | 22 | Build using the `Dockerfile.bridge-local-git` file at the root of this repository: 23 | 24 | docker build -t datakit/local-bridge -f Dockerfile.bridge-local-git . 25 | 26 | ### Run 27 | 28 | To see the help text: 29 | 30 | docker run -it --rm datakit/local-bridge --help 31 | 32 | To run it (after starting a DataKit container called "datakit"): 33 | 34 | docker run -it --rm \ 35 | --link datakit:datakit \ 36 | -v /path/to/repos:/repos \ 37 | datakit/local-bridge -v \ 38 | me/my-project:/repos/my-project \ 39 | --verbose \ 40 | --webhook=http://my-ip 41 | 42 | Replace: 43 | - `/path/to/repos` with the path to your local repository or repositories. 44 | - `me/my-project` (simulating the GitHub `http://github.com/my/my-project` repository) with the ID of your project. 45 | -------------------------------------------------------------------------------- /bridge/local/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (package datakit-bridge-local-git) 4 | (public_name datakit-bridge-local-git) 5 | (libraries irmin datakit-client-9p datakit-github irmin-unix cmdliner 6 | protocol-9p-unix fmt.cli logs.cli fmt.tty)) 7 | -------------------------------------------------------------------------------- /bridge/local/main.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | let src = 4 | Logs.Src.create "bridge-local-git" ~doc:"Local Git bridge for Datakit" 5 | 6 | module Log = (val Logs.src_log src : Logs.LOG) 7 | 8 | let src9p = 9 | Logs.Src.create "bridge-local-git.9p" 10 | ~doc:"Local Git bridge for Datakit (9p)" 11 | 12 | module Log9p = (val Logs.src_log src9p : Logs.LOG) 13 | 14 | module Client9p = Protocol_9p_unix.Client9p_unix.Make (Log9p) 15 | module Store = Irmin_unix.Git.FS.KV (Irmin.Contents.String) 16 | module DK = Datakit_client_9p.Make (Client9p) 17 | module Sync = Sync.Make (Store) (DK) 18 | 19 | let failf fmt = Fmt.kstrf failwith fmt 20 | 21 | let start () (protocol, address) repos = 22 | Log.info (fun f -> 23 | f "Connecting to DataKit server on %s:%s" protocol address); 24 | Irmin.Private.Watch.set_listen_dir_hook Irmin_watcher.hook; 25 | Lwt_main.run 26 | ( Lwt.catch 27 | (fun () -> 28 | Client9p.connect ~send_pings:true protocol address () >|= function 29 | | Ok c -> c 30 | | Error (`Msg m) -> failwith m) 31 | (fun ex -> 32 | failf "Failed to connect to DataKit server at proto=%S addr=%S: %s" 33 | protocol address (Printexc.to_string ex)) 34 | >|= DK.connect 35 | >>= fun dk -> 36 | repos 37 | |> Lwt_list.map_p (fun (name, root) -> 38 | Log.info (fun f -> f "Monitoring local repository %S" root); 39 | let config = Irmin_git.config root ~bare:true in 40 | Store.Repo.v config >|= fun store -> 41 | (name, store)) 42 | >>= Sync.run dk ) 43 | 44 | (* Command-line parsing *) 45 | 46 | open Cmdliner 47 | 48 | let datakit_endpoint = 49 | let doc = 50 | Arg.info ~doc:"DataKit store for metadata." ~docv:"ADDR" 51 | [ "metadata-store" ] 52 | in 53 | Arg.(value (opt (pair ~sep:':' string string) ("tcp", "localhost:5640") doc)) 54 | 55 | let pp_level f lvl = 56 | let style, msg = 57 | match lvl with 58 | | Logs.App -> (`Black, "APP") 59 | | Logs.Error -> (`Red, "ERR") 60 | | Logs.Warning -> (`Red, "WRN") 61 | | Logs.Info -> (`None, "INF") 62 | | Logs.Debug -> (`Cyan, "DBG") 63 | in 64 | Fmt.pf f "%a" Fmt.(styled style string) msg 65 | 66 | let pp_timestamp f x = 67 | let open Unix in 68 | let tm = localtime x in 69 | Fmt.pf f "%04d-%02d-%02d %02d:%02d.%02d" (tm.tm_year + 1900) (tm.tm_mon + 1) 70 | tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec 71 | 72 | let report src level ~over k msgf = 73 | let k _ = 74 | over (); 75 | k () 76 | in 77 | msgf @@ fun ?header:_ ?tags:_ fmt -> 78 | let src = Logs.Src.name src in 79 | Format.kfprintf k Format.err_formatter 80 | ("%a %a [%s] @[" ^^ fmt ^^ "@]@.") 81 | pp_timestamp (Unix.gettimeofday ()) pp_level level src 82 | 83 | let init style_renderer level = 84 | Fmt_tty.setup_std_outputs ?style_renderer (); 85 | Logs.set_level level; 86 | Logs.Src.set_level src9p (Some Logs.Info); 87 | Logs.set_reporter { Logs.report } 88 | 89 | let setup_log = 90 | Term.(const init $ Fmt_cli.style_renderer () $ Logs_cli.level ()) 91 | 92 | let repo_id = 93 | let parse s = 94 | match Datakit_github.Repo.of_string s with 95 | | None -> 96 | `Error 97 | (Fmt.strf "Bad repository name %S (format should be user/project)" s) 98 | | Some x -> `Ok x 99 | in 100 | (parse, Datakit_github.Repo.pp) 101 | 102 | let git_dir = 103 | let parse, pp = Arg.dir in 104 | let parse s = 105 | match parse (Filename.concat s ".git") with 106 | | `Ok _ -> `Ok s 107 | | `Error _ as e -> e 108 | in 109 | (parse, pp) 110 | 111 | let repo = Arg.(pair ~sep:':' repo_id git_dir) 112 | 113 | let repos = 114 | let doc = 115 | Arg.info [] 116 | ~doc: 117 | "A Git repository to monitor and the name to use for it. e.g. \ 118 | 'my/my-project:/tmp/my-project'" 119 | ~docv:"NAME:PATH" 120 | in 121 | Arg.(non_empty @@ pos_all repo [] doc) 122 | 123 | let main = 124 | let doc = "Bridge between a local Git repository and Datakit." in 125 | let man = 126 | [ `S "DESCRIPTION"; 127 | `P 128 | "$(tname) is a local replacement for datakit-github. It allows you to \ 129 | test DataKitCI against a local Git repository without having to \ 130 | configure GitHub integration first." 131 | ] 132 | in 133 | ( Term.(pure start $ setup_log $ datakit_endpoint $ repos), 134 | Term.info (Filename.basename Sys.argv.(0)) ~doc ~man ) 135 | 136 | let () = 137 | match Term.eval main with 138 | | `Error _ -> exit 1 139 | | `Help | `Version | `Ok () -> () 140 | -------------------------------------------------------------------------------- /bridge/local/main.mli: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /bridge/local/sync.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Datakit_github 3 | 4 | let src = 5 | Logs.Src.create "bridge-local-git.sync" 6 | ~doc:"Local Git bridge sync for Datakit" 7 | 8 | module Log = (val Logs.src_log src : Logs.LOG) 9 | 10 | module Make (S : Irmin.S with type branch = string) (DK : Datakit_client.S) = 11 | struct 12 | module Conv = Datakit_github_conv.Make (DK) 13 | 14 | let ( >>*= ) x f = 15 | x >>= function 16 | | Ok x -> f x 17 | | Error e -> Lwt.fail (Failure (Fmt.to_to_string DK.pp_error e)) 18 | 19 | type t = { 20 | repos : Repo.Set.t; 21 | metadata_branch : DK.Branch.t; 22 | mutable known : Commit.t Ref.Index.t; 23 | cond : unit Lwt_condition.t; (* Fires when [known] changes. *) 24 | } 25 | 26 | let on_change t repo_id irmin_repo branch = 27 | Log.debug (fun f -> f "Notification for %S" branch); 28 | S.Branch.find irmin_repo branch >|= fun head -> 29 | let old = t.known in 30 | let id = (repo_id, [ "heads"; branch ]) in 31 | let next = 32 | match head with 33 | | None -> Ref.Index.remove id old 34 | | Some head -> 35 | Ref.Index.add id 36 | (Commit.v repo_id (Fmt.to_to_string S.Commit.pp head)) 37 | old 38 | in 39 | if t.known != next then ( 40 | Log.debug (fun f -> f "Update for %S" branch); 41 | t.known <- next; 42 | Lwt_condition.broadcast t.cond () ) 43 | 44 | let watch t (name, repo) = 45 | let callback branch _diff = on_change t name repo branch in 46 | S.Branch.watch_all ~init:[] repo callback >>= fun (_w : S.watch) -> 47 | (* XXX: In theory, we should be able to pass [~init:[]] and have Irmin notify us 48 | of the initial state. However, Irmin's [watch_branches] is buggy. *) 49 | S.Repo.branches repo >>= Lwt_list.iter_s (fun b -> on_change t name repo b) 50 | 51 | let read_refs t tr = 52 | DK.Transaction.parents tr >>*= function 53 | | [] -> Lwt.return Ref.Set.empty 54 | | [ p ] -> DK.Commit.tree p >>*= Conv.refs ~repos:t.repos 55 | | _ -> assert false 56 | 57 | (* We never make merge transactions. *) 58 | 59 | let update_ref tr ~changelog ~new_state existing_ref = 60 | Log.debug (fun f -> f "Updating ref %a" Ref.pp existing_ref); 61 | let id = Ref.id existing_ref in 62 | match Ref.Index.find id !new_state with 63 | | None -> 64 | Log.info (fun f -> f "Branch %a no longer exists" Ref.pp existing_ref); 65 | Buffer.add_string changelog 66 | (Fmt.strf "Removing deleted branch %a@." Ref.pp existing_ref); 67 | Conv.remove_elt tr (`Ref (Ref.id existing_ref)) 68 | | Some new_head -> 69 | new_state := Ref.Index.remove id !new_state; 70 | if Commit.equal new_head (Ref.commit existing_ref) then Lwt.return () 71 | else 72 | let r = Ref.v new_head (Ref.name existing_ref) in 73 | Log.debug (fun f -> f "Updating ref to %a" Ref.pp r); 74 | Buffer.add_string changelog 75 | (Fmt.strf "Updating existing branch to %a@." Ref.pp r); 76 | Conv.update_elt tr (`Ref r) 77 | 78 | let add_ref tr ~changelog (id, commit) = 79 | Log.info (fun f -> f "Tracking new branch %a" Ref.pp_id id); 80 | let r = Ref.v commit (snd id) in 81 | Buffer.add_string changelog (Fmt.strf "Tracking new branch %a@." Ref.pp r); 82 | Conv.update_elt tr (`Ref r) 83 | 84 | let sync t new_state = 85 | Log.info (fun f -> f "Copy state to DataKit"); 86 | DK.Branch.with_transaction t.metadata_branch (fun tr -> 87 | let changelog = Buffer.create 128 in 88 | read_refs t tr >>= fun old_refs -> 89 | let new_state = ref new_state in 90 | Lwt_list.iter_s 91 | (update_ref tr ~changelog ~new_state) 92 | (Ref.Set.elements old_refs) 93 | >>= fun () -> 94 | let new_state = !new_state in 95 | Lwt_list.iter_s (add_ref tr ~changelog) (Ref.Index.bindings new_state) 96 | >>= fun () -> 97 | match Buffer.contents changelog with 98 | | "" -> 99 | Log.info (fun f -> f "No updates needed"); 100 | DK.Transaction.abort tr 101 | | message -> DK.Transaction.commit tr ~message) 102 | >>*= Lwt.return 103 | 104 | let run dk repos = 105 | DK.branch dk "github-metadata" >>*= fun metadata_branch -> 106 | let cond = Lwt_condition.create () in 107 | let monitored = List.map fst repos |> Repo.Set.of_list in 108 | let t = 109 | { repos = monitored; metadata_branch; known = Ref.Index.empty; cond } 110 | in 111 | Lwt_list.iter_p (watch t) repos >>= fun () -> 112 | let rec aux () = 113 | let next = Lwt_condition.wait t.cond in 114 | sync t t.known >>= fun () -> 115 | next >>= aux 116 | in 117 | aux () 118 | end 119 | -------------------------------------------------------------------------------- /bridge/local/sync.mli: -------------------------------------------------------------------------------- 1 | module Make (S : Irmin.S with type branch = string) (DK : Datakit_client.S) : sig 2 | val run : DK.t -> (Datakit_github.Repo.t * S.Repo.t) list -> 'a Lwt.t 3 | end 4 | -------------------------------------------------------------------------------- /check-libev.ml: -------------------------------------------------------------------------------- 1 | (* Make sure we have libev, or we'll crash from time-to-time with EINVAL in select *) 2 | #use "topfind";; 3 | #thread;; 4 | #require "lwt.unix";; 5 | Lwt_engine.set (new Lwt_engine.libev () :> Lwt_engine.t);; 6 | -------------------------------------------------------------------------------- /ci/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | make -C .. ci 3 | 4 | clean: 5 | make -C .. clean 6 | -------------------------------------------------------------------------------- /ci/self-ci/.dockerignore: -------------------------------------------------------------------------------- 1 | _build 2 | data 3 | *.native 4 | -------------------------------------------------------------------------------- /ci/self-ci/.gitignore: -------------------------------------------------------------------------------- 1 | data 2 | docker-self-ci 3 | -------------------------------------------------------------------------------- /ci/self-ci/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM datakit/ci AS build-env 2 | RUN sudo apk add --no-cache libev docker gmp 3 | ADD . /home/opam/build 4 | WORKDIR /home/opam/build 5 | RUN sudo chown opam . 6 | RUN opam config exec make selfCI 7 | RUN sudo cp selfCI.native /usr/local/bin/ci 8 | 9 | FROM alpine:3.5 10 | RUN apk add --no-cache libev docker gmp tzdata ca-certificates 11 | 12 | USER root 13 | ENTRYPOINT ["/usr/local/bin/ci"] 14 | COPY --from=build-env /usr/local/bin/ci /usr/local/bin/ci 15 | -------------------------------------------------------------------------------- /ci/self-ci/Makefile: -------------------------------------------------------------------------------- 1 | OCAMLBUILD_FLAGS=-use-ocamlfind 2 | 3 | all: selfCI 4 | 5 | %CI: 6 | ocamlbuild ${OCAMLBUILD_FLAGS} $@.native 7 | 8 | docker: 9 | docker build -t editions/datakit-self-ci . 10 | 11 | clean: 12 | ocamlbuild -clean 13 | -------------------------------------------------------------------------------- /ci/self-ci/README.md: -------------------------------------------------------------------------------- 1 | The CI configuration for testing DataKit itself, using DataKitCI. 2 | The `docker-compose.yml` file describes a configuration for testing the CI locally with `docker-compose`. 3 | The `datakit-ci.yml` file describes the configuration we use to run , managed by `docker stack`. 4 | 5 | # Local testing 6 | 7 | To test it locally, use: 8 | 9 | ``` 10 | $ docker-compose up 11 | ci_1 | 2017-01-23 14:15.55 APP [datakit-ci] >>> Configure the CI by visiting 12 | ci_1 | http://localhost:8080/auth/intro/... 13 | ``` 14 | 15 | Visit the URL shown to configure an admin user. 16 | 17 | In this configuration: 18 | 19 | - The bridge that normally syncs the CI state with GitHub is replaced by `datakit/local-bridge`, which tracks the local DataKit Git repository (`../../.git`). 20 | - Only the master branch is tested (`--canary=moby/datakit/heads/master`). 21 | - Plain HTTP connections are used, to avoid browser warnings about self-signed certificates when testing. 22 | - The main executable is called with `--profile=localhost`, which affects some settings in `selfCI.ml` (search for `Localhost` to find the changes). 23 | 24 | This mode is useful for testing changes to the CI itself, or for testing your changes before making a public PR. 25 | 26 | 27 | # Docker Cloud / Swarm Mode configuration 28 | 29 | To use this as a template for your own projects: 30 | 31 | 1. Edit `datakit-ci.yml`. 32 | - For the `ci` service: 33 | - Change `--web-ui=https://datakit.datakit.ci/` to the URL users should use to see the web user interface of your service. 34 | - For the `datakit` service: 35 | - Edit (or remove) the `--auto-push git@github.com:moby/datakit.logs` option to point at a new, empty, GitHub repository 36 | which will mirror the results. 37 | - For the bridge, change `--webhook http://HOST:PORT` to a public endpoint that GitHub can use to send web events. 38 | If you change the port, change *both* ports in the `ports` configuration below. 39 | 40 | 2. Edit `selfCI.ml` to specify the tests you require. See the [DataKitCI][] README for details. 41 | 42 | 3. Add the token that the bridge will use to access GitHub. 43 | Get a token with `git jar` and add it as a Docker secret with: 44 | `docker secret create datakit-github-cookie - < ~/.github/jar/datakit-github-cookie` 45 | See [ocaml-github][]'s README for details. 46 | 47 | 4. Use `docker stack deploy self-ci -c datakit-ci.yml` to deploy the stack. 48 | 49 | 5. Check the logs for the `ci` service. You should see a configuration URL displayed near the start. 50 | Open this in a browser (you'll probably have to click through a security warning, as the server 51 | generates itself a self-signed X.509 certificate by default). 52 | 53 | 5. Configure an admin password when prompted, then log in as the new "admin" user. 54 | 55 | You will need to add some SSH keys and (optionally) X.509 certificates: 56 | 57 | 1. Populate the `datakit-ssh` volume with a fresh ssh key (run `ssh-keygen`). 58 | DataKit can use this to `git push` if you configured `--auto-push` above. 59 | You'll also need a `known_hosts` file so it can recognise GitHub. 60 | The easiest way to set this up is to run `git push` manually once. 61 | 62 | 2. Restore the `datakit-public-data` volume (optional). 63 | If you are restoring the database from a backup, use `git clone --bare --mirror backup`. 64 | 65 | 3. Replace the X.509 certificates in the `ci-secrets` volume (optional). 66 | `server.crt` and `server.key` will be generated on first run if missing. 67 | They are used for the web UI. You can replace these with a proper certificate and key when you get one (e.g. using [certbot][]). 68 | 69 | On startup, the CI should commit to the `datakit-public-data` repository's `github-metadata` branch a request to monitor the projects it is testing. 70 | The `bridge` service should then start populating the branch with information about the branches, tags and open PRs in the repository, and the CI will start testing them. 71 | 72 | ## Prometheus metrics 73 | 74 | All the DataKit services are run with `--listen-prometheus=9090`, which means that they will provide Prometheus metrics on port 9090 at `/metrics`. You can configure a Prometheus server to monitor these ports. 75 | 76 | [DataKitCI]: https://github.com/moby/datakit/tree/master/ci/self-ci 77 | [ocaml-github]: https://github.com/mirage/ocaml-github 78 | [certbot]: https://certbot.eff.org/ 79 | -------------------------------------------------------------------------------- /ci/self-ci/_tags: -------------------------------------------------------------------------------- 1 | true: warn(A-4), strict_sequence, safe_string, annot, bin_annot 2 | true: package(datakit-ci) 3 | : -traverse 4 | -------------------------------------------------------------------------------- /ci/self-ci/datakit-ci.yml: -------------------------------------------------------------------------------- 1 | version: '3.1' 2 | 3 | services: 4 | bridge: 5 | command: '--listen-prometheus=9090 --datakit tcp://datakit:5640 -v -c "*:r,status[ci/datakit]:x,webhook:rw" --webhook http://hooks.datakit.ci:81 --log-destination timestamp' 6 | image: 'datakit/github-bridge' 7 | ports: 8 | - '81:81' 9 | secrets: 10 | - source: 'datakit-github-cookie' 11 | mode: 0600 12 | ci: 13 | command: '--listen-prometheus=9090 --metadata-store tcp:datakit:5640 --web-ui=https://datakit.datakit.ci/ --sessions-backend=redis://redis' 14 | image: 'editions/datakit-self-ci:latest' 15 | environment: 16 | - DOCKER_HOST=unix:///var/run/builder/docker.sock 17 | volumes: 18 | - 'ci-cache:/data/repos' 19 | - 'ci-secrets:/secrets' 20 | - '/var/run/datakit:/var/run/builder' 21 | datakit: 22 | user: 'root' 23 | command: '--git /data --listen-prometheus=9090 --listen-9p tcp://0.0.0.0:5640 --auto-push git@github.com:moby/datakit.logs' 24 | image: 'datakit/db' 25 | volumes: 26 | - datakit-public-data:/data 27 | - datakit-ssh:/root/.ssh 28 | redis: 29 | command: redis-server --save 60 1 30 | image: 'redis:latest' 31 | 32 | volumes: 33 | ci-secrets: 34 | ci-cache: 35 | datakit-public-data: 36 | datakit-ssh: 37 | 38 | secrets: 39 | datakit-github-cookie: 40 | external: true 41 | -------------------------------------------------------------------------------- /ci/self-ci/docker-compose.yml: -------------------------------------------------------------------------------- 1 | version: '3' 2 | services: 3 | # This Docker Compose file is for testing locally against a local Git repository. 4 | # Also, we use --canary to test only the master branch. 5 | # For production use datakit-ci.yml, which tests against GitHub. 6 | bridge: 7 | command: '--metadata-store tcp:datakit:5640 -v moby/datakit:/data/repos/datakit' 8 | image: 'datakit/local-bridge' 9 | links: 10 | - datakit 11 | volumes: 12 | - '../../.git:/data/repos/datakit/.git' # XXX: should really be :ro (see #622) 13 | ci: 14 | command: '--profile=localhost --metadata-store tcp:datakit:5640 --web-ui=http://localhost:8080/ --canary=moby/datakit/heads/master' 15 | build: . 16 | links: 17 | - datakit 18 | ports: 19 | - '8080:8080' 20 | volumes: 21 | - '../../.git:/mnt/datakit/.git:ro' 22 | - '/secrets' 23 | - '/var/run/docker.sock:/var/run/docker.sock' 24 | datakit: 25 | user: 'root' 26 | command: '--git /data --listen-9p tcp://0.0.0.0:5640' 27 | image: 'datakit/db' 28 | volumes: 29 | - /data 30 | -------------------------------------------------------------------------------- /ci/self-ci/selfCI.ml: -------------------------------------------------------------------------------- 1 | open! Astring 2 | open Datakit_ci 3 | 4 | let minute = 60. 5 | 6 | let pool = Monitored_pool.create "Docker" 10 7 | 8 | module Dockerfile = struct 9 | (* [v ~timeout file] is a caching builder for [file]. *) 10 | let v ?label ~timeout file = 11 | let label = label |> Utils.default file in 12 | Docker.create ~logs ~pool ~timeout ~label file 13 | 14 | let client = v ~timeout:(30. *. minute) "Dockerfile.client" 15 | 16 | let ci = v ~timeout:(30. *. minute) "Dockerfile.ci" 17 | 18 | let self_ci = 19 | v ~timeout:(30. *. minute) "ci/self-ci/Dockerfile" 20 | ~label:"Dockerfile.self-ci" 21 | 22 | let github = v ~timeout:(30. *. minute) "Dockerfile.github" 23 | 24 | let local_git = v ~timeout:(30. *. minute) "Dockerfile.bridge-local-git" 25 | 26 | let datakit = v ~timeout:(30. *. minute) "Dockerfile" 27 | end 28 | 29 | module Tests = struct 30 | open Term.Infix 31 | 32 | (* Rules to create the images from the Dockerfiles. 33 | Note that we may build multiple images from the same Dockerfile (to test different bases). 34 | We also define the dependencies between the builds here. *) 35 | let images src = 36 | let build ?from dockerfile = 37 | match from with 38 | | None -> src >>= Docker.build dockerfile ?from:None 39 | | Some from -> 40 | Term.without_logs (Term.pair src from) >>= fun (src, from) -> 41 | Docker.build dockerfile ~from src 42 | in 43 | object (self) 44 | method client = build Dockerfile.client 45 | 46 | method local_git = build Dockerfile.local_git ~from:self#client 47 | 48 | method ci = build Dockerfile.ci 49 | 50 | method self_ci = build Dockerfile.self_ci ~from:self#ci 51 | 52 | method github = build Dockerfile.github 53 | 54 | method datakit = build Dockerfile.datakit 55 | end 56 | 57 | let check_builds term = 58 | term >|= fun (_ : Docker.Image.t) -> 59 | "Build succeeded" 60 | 61 | (* [datakit repo target] is the set of tests to run on [target]. *) 62 | let datakit repo = function 63 | | `Ref (_, [ "heads"; "gh-pages" ]) -> 64 | [] (* Don't try to build the gh-pages branch *) 65 | | target -> 66 | let src = Git.fetch_head repo target in 67 | let images = images src in 68 | [ ("ci", check_builds images#ci); 69 | ("self-ci", check_builds images#self_ci); 70 | ("github", check_builds images#github); 71 | ("datakit", check_builds images#datakit); 72 | ("local-git", check_builds images#local_git); 73 | ( "libraries", 74 | Term.wait_for_all [ ("client", check_builds images#client) ] 75 | >|= fun () -> 76 | "Library tests succeeded" ) 77 | ] 78 | end 79 | 80 | let projects repo = [ Config.project ~id:"moby/datakit" (Tests.datakit repo) ] 81 | 82 | let can_build = 83 | let open ACL in 84 | any [ username "admin"; github_org "moby" ] 85 | 86 | let make_config ?state_repo ~listen_addr ~remote () = 87 | let repo = Git.v ~logs ~remote "/data/repos/datakit" in 88 | let web_config = 89 | Web.config ~name:"datakit-ci" ?state_repo 90 | ~github_scopes_needed:[ `Read_org ] ~can_read:ACL.everyone ~can_build 91 | ~listen_addr () 92 | in 93 | Config.v ~web_config ~projects:(projects repo) 94 | 95 | let config_for = function 96 | | `Production -> 97 | make_config ~remote:"https://github.com/moby/datakit.git" 98 | ~state_repo:(Uri.of_string "https://github.com/moby/datakit.logs") 99 | ~listen_addr:(`HTTP 8080) (* We live behind an nginx proxy. *) () 100 | | `Localhost -> 101 | (* We pull from a shared volume, not from GitHub, and we don't push the results. *) 102 | make_config ~remote:"/mnt/datakit" ~listen_addr:(`HTTP 8080) 103 | (* Don't bother with TLS when testing locally. *) () 104 | 105 | (* Command-line parsing *) 106 | 107 | open Cmdliner 108 | 109 | let profiles = 110 | [ ("production", `Production); 111 | (* Running on Docker Cloud *) 112 | ("localhost", `Localhost) 113 | (* Running locally with docker-compose *) 114 | ] 115 | 116 | (* The "--profile=PROFILE" option *) 117 | let profile = 118 | let doc = 119 | Arg.info [ "profile" ] ~docv:"PROFILE" 120 | ~doc:"Which configuration profile to use." 121 | in 122 | Arg.(value @@ opt (enum profiles) `Production doc) 123 | 124 | let () = Datakit_ci.run Cmdliner.Term.(pure config_for $ profile) 125 | -------------------------------------------------------------------------------- /ci/self-ci/selfCI.mli: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /ci/skeleton/.dockerignore: -------------------------------------------------------------------------------- 1 | *.native 2 | _build 3 | -------------------------------------------------------------------------------- /ci/skeleton/.gitignore: -------------------------------------------------------------------------------- 1 | secrets 2 | -------------------------------------------------------------------------------- /ci/skeleton/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM datakit/ci 2 | 3 | ARG CONFIG=exampleCI 4 | ADD . /datakit-ci 5 | WORKDIR /datakit-ci 6 | RUN sudo chown opam . 7 | RUN opam config exec make $CONFIG && ln _build/$CONFIG.native /datakit-ci/datakit-ci && rm -rf _build 8 | USER root 9 | ENTRYPOINT ["/datakit-ci/datakit-ci"] 10 | CMD [] 11 | -------------------------------------------------------------------------------- /ci/skeleton/Makefile: -------------------------------------------------------------------------------- 1 | OCAMLBUILD_FLAGS=-use-ocamlfind 2 | 3 | all: exampleCI 4 | 5 | %CI: 6 | ocamlbuild ${OCAMLBUILD_FLAGS} $@.native 7 | 8 | clean: 9 | ocamlbuild -clean 10 | -------------------------------------------------------------------------------- /ci/skeleton/_tags: -------------------------------------------------------------------------------- 1 | true: warn(A-4), strict_sequence, safe_string, annot, bin_annot 2 | true: package(datakit-ci) 3 | -------------------------------------------------------------------------------- /ci/skeleton/exampleCI.ml: -------------------------------------------------------------------------------- 1 | open Datakit_ci 2 | 3 | (* An example test that just always returns success. *) 4 | let my_test = Term.return "Success!" 5 | 6 | let tests _target = [ ("my-test", my_test) ] 7 | 8 | (* A list of GitHub projects to monitor. *) 9 | let projects = 10 | [ Config.project 11 | ~id: 12 | "me/my-project" 13 | (* The project is at https://github.com/me/my-project *) 14 | ~dashboards: 15 | [ "master" ] (* Key branches to display in the dashboard overview *) 16 | tests 17 | (* The tests to apply to the open PRs in this project. *) 18 | ] 19 | 20 | (* The URL of a mirror on GitHub of DataKit's state repository (optional). *) 21 | let state_repo = None 22 | 23 | (* Some (Uri.of_string "https://github.com/my-org/my-project.logs") *) 24 | 25 | let web_config = 26 | Web.config ~name:"example-ci" 27 | ~can_read:ACL.(everyone) 28 | ~can_build:ACL.(username "admin") 29 | ?state_repo ~listen_addr:(`HTTPS 8443) () 30 | 31 | (* The main entry-point *) 32 | let () = run (Cmdliner.Term.pure (Config.v ~web_config ~projects)) 33 | -------------------------------------------------------------------------------- /ci/src/cI_ACL.ml: -------------------------------------------------------------------------------- 1 | open Datakit_github 2 | 3 | type t = 4 | [ `Everyone 5 | | `Username of string 6 | | `Github_org of string 7 | | `Can_read of Repo.t 8 | | `Any of t list ] 9 | 10 | let everyone = `Everyone 11 | 12 | let username x = `Username x 13 | 14 | let github_org x = `Github_org x 15 | 16 | let any ts = `Any ts 17 | 18 | let can_read_github repo = 19 | match Repo.of_string repo with 20 | | Some r -> `Can_read r 21 | | _ -> invalid_arg ("can_read_github: " ^ repo) 22 | -------------------------------------------------------------------------------- /ci/src/cI_ACL.mli: -------------------------------------------------------------------------------- 1 | open Datakit_github 2 | 3 | (** Access control lists. *) 4 | 5 | type t = 6 | [ `Everyone 7 | | `Username of string 8 | | `Github_org of string 9 | | `Can_read of Repo.t 10 | | `Any of t list ] 11 | 12 | val everyone : t 13 | 14 | val username : string -> t 15 | 16 | val github_org : string -> t 17 | 18 | val can_read_github : string -> t 19 | 20 | val any : t list -> t 21 | -------------------------------------------------------------------------------- /ci/src/cI_cache.mli: -------------------------------------------------------------------------------- 1 | (** A cache for values computed (slowly) by terms. *) 2 | 3 | open CI_utils 4 | 5 | module Path : sig 6 | val log : Datakit_client.Path.t 7 | 8 | (* The job's log output *) 9 | 10 | val value : Datakit_client.Path.t (* Store build results in this directory *) 11 | end 12 | 13 | module Make (B : CI_s.BUILDER) : sig 14 | type t 15 | 16 | val create : logs:CI_live_log.manager -> B.t -> t 17 | 18 | val lookup : 19 | t -> 20 | (unit -> DK.t Lwt.t) -> 21 | B.context -> 22 | B.Key.t -> 23 | B.value CI_s.status Lwt.t 24 | 25 | val find : t -> B.context -> B.Key.t -> B.value CI_term.t 26 | end 27 | 28 | val read_log : DK.t -> CI_output.saved -> string DK.result 29 | (** [read_log dk log] is the contents of the saved log [log]. *) 30 | -------------------------------------------------------------------------------- /ci/src/cI_char_stream.ml: -------------------------------------------------------------------------------- 1 | type t = string * int 2 | 3 | type span = string * int * int 4 | 5 | let of_string s = (s, 0) 6 | 7 | let to_string (s, i) = String.sub s i (String.length s - i) 8 | 9 | let skip (s, a) = (s, a + 1) 10 | 11 | let skip_all (s, _) = (s, String.length s) 12 | 13 | let string_of_span (s, a, b) = String.sub s a (b - a) 14 | 15 | let ( -- ) (s, a) (_, b) = 16 | assert (b >= a); 17 | (s, a, b) 18 | 19 | let find (base, off) c = 20 | try Some (base, String.index_from base off c) with Not_found -> None 21 | 22 | let avail (base, off) = String.length base - off 23 | 24 | let is_empty (base, off) = String.length base = off 25 | 26 | let next (base, off) = 27 | if String.length base = off then None else Some (base.[off], (base, off + 1)) 28 | 29 | let equal (a : t) (b : t) = a = b 30 | -------------------------------------------------------------------------------- /ci/src/cI_char_stream.mli: -------------------------------------------------------------------------------- 1 | type t 2 | (** A base string with an index into it, representing the rest of the string from that point. *) 3 | 4 | val of_string : string -> t 5 | (** [of_string s] is a cursor at the start of [s]. *) 6 | 7 | val to_string : t -> string 8 | (** [to_string t] is the substring from [t] to the end of the input. *) 9 | 10 | val skip : t -> t 11 | (** [skip t] is the stream without its first character. [t] must be non-empty. *) 12 | 13 | val skip_all : t -> t 14 | (** [skip_all t] is the empty stream at the end of [t]. *) 15 | 16 | val find : t -> char -> t option 17 | (** [find t c] is a stream from the first occurance of [c] in [t], if any. *) 18 | 19 | val avail : t -> int 20 | (** [avail t] is the number of remaining characters in the stream. *) 21 | 22 | val is_empty : t -> bool 23 | (** [is_empty t] is [avail t = 0]. *) 24 | 25 | val next : t -> (char * t) option 26 | (** [next t] is [Some (c, t2)], where [c] is the next character in the stream and [t2] is [skip t], 27 | or [None] if [is_empty t]. *) 28 | 29 | val equal : t -> t -> bool 30 | (** [equal a b] is [true] iff the streams [a] and [b] are at the same offset in the same base string. *) 31 | 32 | type span = string * int * int 33 | (** [(s, a, b)] represents the span of [s] from index [a] up to but excluding [b]. *) 34 | 35 | val ( -- ) : t -> t -> span 36 | (** [a -- b] is the span from [a] (inclusive) to [b] (exclusive). 37 | [a] must not have a higher offset than [b]. *) 38 | 39 | val string_of_span : span -> string 40 | (** [string_of_span (s, a, b)] is the sub-string of [s] from [a] to [b]. *) 41 | -------------------------------------------------------------------------------- /ci/src/cI_config.ml: -------------------------------------------------------------------------------- 1 | open Datakit_github 2 | open! Astring 3 | 4 | type test = string CI_term.t 5 | 6 | type project = { 7 | dashboards : CI_target.Set.t; 8 | tests : CI_target.t -> test String.Map.t; 9 | } 10 | 11 | type t = { web_config : CI_web_templates.t; projects : project Repo.Map.t } 12 | 13 | let id_of_branch repo name = `Ref (repo, "heads" :: String.cuts ~sep:"/" name) 14 | 15 | let project ~id ?(dashboards = [ "master" ]) tests = 16 | let id = 17 | match Repo.of_string id with 18 | | None -> CI_utils.failf "Invalid repo ID %S" id 19 | | Some r -> r 20 | in 21 | let tests x = String.Map.of_list (tests x) in 22 | let dashboards = 23 | CI_target.Set.of_list (List.map (id_of_branch id) dashboards) 24 | in 25 | (id, { tests; dashboards }) 26 | 27 | let v ~web_config ~projects = 28 | let projects = Repo.Map.of_list projects in 29 | { web_config; projects } 30 | -------------------------------------------------------------------------------- /ci/src/cI_config.mli: -------------------------------------------------------------------------------- 1 | open Datakit_github 2 | open Astring 3 | 4 | type test = string CI_term.t 5 | 6 | type project = { 7 | dashboards : CI_target.Set.t; 8 | tests : CI_target.t -> test String.Map.t; 9 | } 10 | 11 | type t = private { 12 | web_config : CI_web_templates.t; 13 | projects : project Repo.Map.t; 14 | } 15 | 16 | val project : 17 | id:string -> 18 | ?dashboards:string list -> 19 | (CI_target.t -> (string * test) list) -> 20 | Repo.t * project 21 | 22 | val v : web_config:CI_web_templates.t -> projects:(Repo.t * project) list -> t 23 | -------------------------------------------------------------------------------- /ci/src/cI_docker.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val create : 4 | logs:CI_live_log.manager -> 5 | pool:CI_monitored_pool.t -> 6 | timeout:float -> 7 | label:string -> 8 | string -> 9 | t 10 | 11 | module Image : sig 12 | type t 13 | 14 | val of_published : string -> t 15 | 16 | val id : t -> string 17 | 18 | val pp : t Fmt.t 19 | end 20 | 21 | val build : t -> ?from:Image.t -> CI_git.commit -> Image.t CI_term.t 22 | 23 | type command 24 | 25 | val command : 26 | logs:CI_live_log.manager -> 27 | pool:CI_monitored_pool.t -> 28 | timeout:float -> 29 | label:string -> 30 | ?entrypoint:string -> 31 | ?user:string -> 32 | ?network:string -> 33 | string list -> 34 | command 35 | 36 | val run : command -> Image.t -> unit CI_term.t 37 | -------------------------------------------------------------------------------- /ci/src/cI_engine.mli: -------------------------------------------------------------------------------- 1 | open Datakit_github 2 | open Astring 3 | open CI_utils 4 | 5 | type t 6 | (** A DataKit CI instance. *) 7 | 8 | type target 9 | (** The state of an open PR or branch. *) 10 | 11 | type job 12 | (** A job keeps up-to-date one state within an open PR. *) 13 | 14 | val create : 15 | web_ui:Uri.t -> 16 | ?canaries:CI_target.Set.t Repo.Map.t -> 17 | (unit -> DK.t Lwt.t) -> 18 | (CI_target.t -> string CI_term.t String.Map.t) Repo.Map.t -> 19 | t 20 | (** [create ~web_ui connect projects] is a new DataKit CI that calls [connect] to connect to the database. 21 | Once [listen] has been called, it will handle CI for [projects]. 22 | [projects] maps projects to the status reports to produce. 23 | [web_ui] is the URL of the main web-page (used when adding links to PRs on GitHub). 24 | If [canaries] is given, only those targets will be considered. *) 25 | 26 | val listen : ?switch:Lwt_switch.t -> t -> [ `Abort ] Lwt.t 27 | (** [listen t] runs a loop that watches for PRs and branches that need building. 28 | Returns [`Abort] if the switch is turned off. *) 29 | 30 | val dk : t -> DK.t Lwt.t 31 | (** [dk t] is the connection to DataKit. If not currently connected, this will be a sleeping 32 | thread that will resolve to the next successful connection. *) 33 | 34 | val prs : t -> target PR.Index.t Repo.Map.t 35 | (** [prs t] is a snapshot of the current state of all known PRs. *) 36 | 37 | val refs : t -> target Ref.Index.t Repo.Map.t 38 | (** [targets t] is a snapshot of the current state of all branches. *) 39 | 40 | val latest_state : t -> CI_target.t -> CI_history.State.t option Lwt.t 41 | (** [latest_state t target] is the current state of [target]. *) 42 | 43 | val jobs : target -> job list 44 | (** [jobs t] is the list of jobs for a target. *) 45 | 46 | val job_name : job -> string 47 | (** [job_name j] is the name of the GitHub status that this job computes. *) 48 | 49 | val state : job -> string CI_output.t option 50 | (** [state job] is the current state of [job]. *) 51 | 52 | val target : target -> CI_target.v 53 | (** [target target] is the GitHub metadata about this target. *) 54 | 55 | val targets_of_commit : t -> Repo.t -> string -> CI_target.t list 56 | (** [targets_of_commit t repo c] is the list of targets in [repo] with head commit [c]. *) 57 | 58 | val repo : target -> Repo.t 59 | (** [repo t] is the GitHub repository that contains [target]. *) 60 | 61 | val title : target -> string 62 | (** [title t] is the title of PR [t]. *) 63 | 64 | val rebuild : t -> branch_name:string -> unit Lwt.t 65 | (** [rebuild t ~branch_name] triggers a rebuild for results branch [branch_name] and recalculates any terms that depend on it. 66 | An error is reported if no term currently depends on [branch_name]. *) 67 | -------------------------------------------------------------------------------- /ci/src/cI_escape_parser.ml: -------------------------------------------------------------------------------- 1 | module Stream = CI_char_stream 2 | 3 | type colour = 4 | [ `Black | `Blue | `Cyan | `Green | `Magenta | `Red | `White | `Yellow ] 5 | 6 | type sgr = 7 | [ `BgCol of [ `Default | colour ] 8 | | `Bold 9 | | `FgCol of [ `Default | colour ] 10 | | `Italic 11 | | `NoBold 12 | | `NoItalic 13 | | `NoReverse 14 | | `NoUnderline 15 | | `Reset 16 | | `Reverse 17 | | `Underline ] 18 | 19 | type escape = [ `Reset | `Ctrl of [ `SelectGraphicRendition of sgr list ] ] 20 | 21 | let is_param_byte c = 22 | let c = Char.code c in 23 | c land 0xf0 = 0x30 24 | 25 | let is_im_byte c = 26 | let c = Char.code c in 27 | c land 0xf0 = 0x40 28 | 29 | let is_final_byte c = 30 | let c = Char.code c in 31 | c >= 0x40 && c <= 0x7e 32 | 33 | exception Unknown_escape 34 | 35 | let colour = function 36 | | 0 -> `Black 37 | | 1 -> `Red 38 | | 2 -> `Green 39 | | 3 -> `Yellow 40 | | 4 -> `Blue 41 | | 5 -> `Magenta 42 | | 6 -> `Cyan 43 | | 7 -> `White 44 | | _ -> raise Unknown_escape 45 | 46 | let sgr = function 47 | | "" -> `Reset 48 | | x -> ( 49 | match int_of_string x with 50 | | exception _ -> raise Unknown_escape 51 | | 0 -> `Reset 52 | | 1 -> `Bold 53 | | 3 -> `Italic 54 | | 4 -> `Underline 55 | | 7 -> `Reverse 56 | | 22 -> `NoBold 57 | | 23 -> `NoItalic 58 | | 24 -> `NoUnderline 59 | | 27 -> `NoReverse 60 | | x when x >= 30 && x <= 37 -> `FgCol (colour (x - 30)) 61 | | 39 -> `FgCol `Default 62 | | x when x >= 40 && x <= 47 -> `BgCol (colour (x - 40)) 63 | | 49 -> `BgCol `Default 64 | | _ -> raise Unknown_escape ) 65 | 66 | let parse_ctrl ~params = function 67 | | "m" -> `SelectGraphicRendition (List.map sgr params) 68 | | _ -> raise Unknown_escape 69 | 70 | let read_intermediates ~params start = 71 | let rec aux s = 72 | match Stream.next s with 73 | | None -> `Incomplete (* No final byte *) 74 | | Some (x, s) when is_im_byte x -> aux s 75 | | Some (x, s2) when is_final_byte x -> ( 76 | let func = Stream.(start -- s2 |> string_of_span) in 77 | let params = Astring.String.cuts ~sep:";" params in 78 | try `Escape (`Ctrl (parse_ctrl ~params func), s2) 79 | with Unknown_escape -> `Invalid s2 ) 80 | | Some _ -> `Invalid s 81 | in 82 | aux start 83 | 84 | let read_params start = 85 | let rec aux s = 86 | match Stream.next s with 87 | | None -> `Incomplete (* No final byte *) 88 | | Some (x, s) when is_param_byte x -> aux s 89 | | Some _ -> 90 | let params = Stream.(start -- s |> string_of_span) in 91 | read_intermediates ~params s 92 | in 93 | aux start 94 | 95 | (* Parse [esc], an escape sequence. *) 96 | let parse_escape esc = 97 | match Stream.(next (Stream.skip esc)) with 98 | | Some ('[', s) -> read_params s (* [esc] is a control sequence *) 99 | | Some (']', s) -> 100 | `Invalid s (* [esc] is a operating system command sequence (todo) *) 101 | | Some ('c', s) -> `Escape (`Reset, s) 102 | | Some (_, s) -> `Invalid s (* TODO: other types of escape *) 103 | | None -> `Incomplete 104 | 105 | let parse input = 106 | (* In theory, we could also get the 8-bit escape character encoded as two 107 | UTF-8 bytes, but for now we just process the "[" sequence, which 108 | seems to be what everyone is using. *) 109 | match Stream.find input '\x1b' with 110 | | None -> `Literal (Stream.skip_all input) 111 | | Some i when Stream.equal input i -> parse_escape input 112 | | Some i -> `Literal i 113 | -------------------------------------------------------------------------------- /ci/src/cI_escape_parser.mli: -------------------------------------------------------------------------------- 1 | type colour = 2 | [ `Black | `Blue | `Cyan | `Green | `Magenta | `Red | `White | `Yellow ] 3 | 4 | type sgr = 5 | [ `BgCol of [ `Default | colour ] 6 | | `Bold 7 | | `FgCol of [ `Default | colour ] 8 | | `Italic 9 | | `NoBold 10 | | `NoItalic 11 | | `NoReverse 12 | | `NoUnderline 13 | | `Reset 14 | | `Reverse 15 | | `Underline ] 16 | 17 | type escape = [ `Reset | `Ctrl of [ `SelectGraphicRendition of sgr list ] ] 18 | 19 | val parse : 20 | CI_char_stream.t -> 21 | [ `Literal of CI_char_stream.t 22 | | `Escape of escape * CI_char_stream.t 23 | | `Invalid of CI_char_stream.t 24 | | `Incomplete ] 25 | (** [parse stream] returns the first token in [stream] and the stream directly after it, 26 | or [`Incomplete] if more data is required to parse the first token. 27 | [`Literal s2] indicates that everything between [stream] and [s2] should be output as literal text. 28 | [`Escape (e, s2)] indicates that the first token was escape sequence [e]. 29 | [`Invalid s2] indicates that the first token was malformed or not understood and processing should continue 30 | from [s2]. 31 | *) 32 | -------------------------------------------------------------------------------- /ci/src/cI_eval.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | type 'a or_error = 'a CI_result.t 4 | 5 | module L = CI_output 6 | 7 | module Make (C : CI_s.CONTEXT) = struct 8 | type context = C.t 9 | 10 | type 'a key = C.t -> 'a 11 | 12 | type 'a t = C.t -> ('a or_error * L.logs) Lwt.t 13 | 14 | let return x _ = Lwt.return (Ok x, L.Empty) 15 | 16 | let fail fmt = 17 | fmt 18 | |> Fmt.kstrf @@ fun x _ -> 19 | Lwt.return (Error (`Failure x), L.Empty) 20 | 21 | let pending fmt = 22 | fmt 23 | |> Fmt.kstrf @@ fun x _ -> 24 | Lwt.return (Error (`Pending x), L.Empty) 25 | 26 | let state x ctx = 27 | x ctx >|= fun (x, x_logs) -> 28 | (Ok x, x_logs) 29 | 30 | let of_state x _ = Lwt.return ((x :> 'a or_error), L.Empty) 31 | 32 | let catch x ctx = 33 | x ctx >>= fun (x, x_logs) -> 34 | match x with 35 | | Error (`Pending _) as x -> Lwt.return (x, x_logs) 36 | | (Ok _ | Error (`Failure _)) as x -> Lwt.return (Ok x, x_logs) 37 | 38 | let run ctx t = t ctx 39 | 40 | let value key ctx = Lwt.return (Ok (key ctx), L.Empty) 41 | 42 | let of_lwt_quick x _ctx = 43 | x >>= fun x -> 44 | Lwt.return (Ok x, L.Empty) 45 | 46 | let of_lwt_slow check ctx = 47 | check () >|= fun { CI_s.result; output } -> 48 | match result with 49 | | (Ok _ | Error (`Failure _)) as x -> (x, output) 50 | | Error (`Pending (message, ready)) -> 51 | C.watch ctx ready; 52 | (Error (`Pending message), output) 53 | 54 | let pair a b ctx = 55 | a ctx >>= fun (a, a_logs) -> 56 | b ctx >>= fun (b, b_logs) -> 57 | let logs = L.Pair (a_logs, b_logs) in 58 | match (a, b) with 59 | | Ok a, Ok b -> Lwt.return (Ok (a, b), logs) 60 | | (Error _ as problem), _ -> Lwt.return (problem, logs) 61 | | Ok _, (Error _ as problem) -> Lwt.return (problem, logs) 62 | 63 | let without_logs x ctx = 64 | x ctx >|= fun (x, _) -> 65 | (x, L.Empty) 66 | 67 | let wait_for (x : 'a t) ~while_pending ~on_failure ctx = 68 | x ctx >|= fun (x, x_logs) -> 69 | match x with 70 | | Ok _ -> (Ok (), x_logs) 71 | | Error (`Pending _) -> (Error (`Pending while_pending), x_logs) 72 | | Error (`Failure _) -> (Error (`Failure on_failure), x_logs) 73 | 74 | module Infix = struct 75 | let ( >>= ) x f ctx = 76 | x ctx >>= fun (x, x_logs) -> 77 | match x with 78 | | Error _ as problem -> Lwt.return (problem, x_logs) 79 | | Ok x -> 80 | f x ctx >|= fun (f_result, f_logs) -> 81 | (f_result, L.Pair (x_logs, f_logs)) 82 | 83 | let ( >|= ) x f = 84 | x >>= fun x -> 85 | return (f x) 86 | 87 | let ( $ ) f x = 88 | pair f x >|= fun (f, x) -> 89 | f x 90 | end 91 | 92 | open! Infix 93 | 94 | let join t = 95 | t >>= fun x -> 96 | x 97 | 98 | let list_map_p f l = 99 | List.fold_left 100 | (fun acc x -> 101 | pair acc (f x) >|= fun (acc, x) -> 102 | x :: acc) 103 | (return []) l 104 | 105 | let pp_names ppf names = 106 | if List.length names > 10 then Fmt.pf ppf "%d tasks" (List.length names) 107 | else Fmt.(list ~sep:(const string ", ") string) ppf names 108 | 109 | let wait_for_all l = 110 | let partition (ps, fs) (name, state) = 111 | match state with 112 | | Ok _ -> (ps, fs) 113 | | Error (`Pending _) -> (name :: ps, fs) 114 | | Error (`Failure _) -> (ps, name :: fs) 115 | in 116 | let get_state (name, x) = 117 | state x >|= fun s -> 118 | (name, s) 119 | in 120 | list_map_p get_state l >>= fun states -> 121 | match List.fold_left partition ([], []) states with 122 | | [], [] -> return () 123 | | [], fs -> fail "%a failed" pp_names fs 124 | | ps, [] -> pending "Waiting for %a" pp_names ps 125 | | ps, fs -> 126 | pending "%a failed (still waiting for %a)" pp_names fs pp_names ps 127 | end 128 | -------------------------------------------------------------------------------- /ci/src/cI_eval.mli: -------------------------------------------------------------------------------- 1 | module Make (C : CI_s.CONTEXT) : sig 2 | include CI_s.TERM with type context = C.t and type 'a key = C.t -> 'a 3 | 4 | val run : context -> 'a t -> ('a CI_result.t * CI_output.logs) Lwt.t 5 | (** [run context term] is the result of evaluating [term] in [context]. *) 6 | end 7 | -------------------------------------------------------------------------------- /ci/src/cI_form.mli: -------------------------------------------------------------------------------- 1 | type 'a or_error = ('a, string) result 2 | 3 | module State : sig 4 | type t 5 | (** The state of a form upload from the user. *) 6 | 7 | type field = { data : string option; error : string option } 8 | 9 | val empty : t 10 | (** A state with no fields. *) 11 | 12 | val pop : string -> t -> field 13 | (** [pop field_name t] returns the current value of the field and removes [field_name] from [t]. 14 | Returns an empty field record if the field isn't known. *) 15 | 16 | val bindings : t -> (string * field) list 17 | (** [bindings t] is the list of [(name, field)] pairs that haven't been popped. *) 18 | 19 | val of_values : (string * string) list -> t 20 | (** [of_values vs] is a state initialised with [(field_name, value)] pairs in [vs]. *) 21 | end 22 | 23 | module Html : sig 24 | type field_type = 25 | [ `Url 26 | | `Tel 27 | | `Text 28 | | `Time 29 | | `Search 30 | | `Password 31 | | `Checkbox 32 | | `Range 33 | | `Radio 34 | | `Submit 35 | | `Reset 36 | | `Number 37 | | `Hidden 38 | | `Month 39 | | `Week 40 | | `File 41 | | `Email 42 | | `Image 43 | | `Datetime_local 44 | | `Datetime 45 | | `Date 46 | | `Color 47 | | `Button ] 48 | 49 | val form : 50 | State.t -> 51 | csrf_token:string -> 52 | form_class:string list -> 53 | action:string -> 54 | [< Html_types.form_content_fun > `Div ] Tyxml.Html.elt list -> 55 | [> Html_types.form ] Tyxml.Html.elt 56 | (** [form state ~csrf_token ~form_class ~action controls] is an HTML form 57 | which posts the values to [action]. 58 | If [state] still contains any fields, they are reported as unknown-field 59 | errors. *) 60 | 61 | val field : 62 | State.t -> 63 | string -> 64 | field_type -> 65 | string -> 66 | [> Html_types.div ] Tyxml.Html.elt 67 | (** [field state label type name] is an HTML form control for entering a value of type [type]. 68 | If [state] contains a value for this field, that will be the initial value. 69 | If [state] contains an error for this field, it will be displayed (and removed from [state]). *) 70 | end 71 | 72 | module Validator : sig 73 | type 'a t 74 | (** An ['a t] is a validator that parses a form and, on success, returns an ['a]. *) 75 | 76 | type 'a reader = string -> 'a or_error 77 | 78 | val maybe : 'a -> 'a t 79 | (** [maybe x] is a validator that successfully returns [x] if there were no other validation errors. *) 80 | 81 | val fail : string -> msg:string -> 'a t 82 | (** [fail field ~msg] is a validation that fails, reporting [msg] against [field]. *) 83 | 84 | val get : string -> (string -> ('a, string) result) -> 'a t 85 | (** [get field conv] gets the uploaded field named [field] and processes it with [conv]. 86 | If [conv] fails, an error is reported against [field]. *) 87 | 88 | val string : string reader 89 | (** [string s] always accepts [s]. *) 90 | 91 | val uri : Uri.t reader 92 | (** [uri s] tries to parse [s] as a Uri. *) 93 | 94 | val non_empty : string reader 95 | (** [non_empty s] accepts [s] if it is not the empty string. *) 96 | 97 | val confirm : string -> unit reader 98 | (** [confirm x y] accepts [y] if it is the same as [x] (useful for enter-this-twice confirmation fields). *) 99 | 100 | val optional : 'a reader -> 'a option reader 101 | (** [optional x] is a reader that returns [None] for the empty string, 102 | while using [x] to read non-empty strings. *) 103 | 104 | val ( >>!= ) : 'a t -> ('a -> 'b t) -> 'b t 105 | (** [x >>!= f] is [f y] if the validator [x] successfully produces [y]. *) 106 | 107 | val ( <*> ) : 'a t -> 'b t -> ('a * 'b) t 108 | (** [x <*> y] validates [x] and [y] and, if both are successful, returns the pair of values. 109 | If either fails, all errors are reported. *) 110 | 111 | val run : 112 | 'a t -> 113 | [ `String of string | `File of Multipart.file ] Multipart.StringMap.t -> 114 | ('a, State.t) result 115 | (** [run v form_data] runs validator [v] on form data uploaded by the user. 116 | It returns ['a] on success, or a [State.t] if there were any validation errors. *) 117 | end 118 | -------------------------------------------------------------------------------- /ci/src/cI_git.mli: -------------------------------------------------------------------------------- 1 | open CI_s 2 | 3 | type t 4 | 5 | val v : ?remote:string -> logs:CI_live_log.manager -> string -> t 6 | 7 | module Commit : sig 8 | type t 9 | 10 | val pp : t Fmt.t 11 | 12 | val pp_short : t Fmt.t 13 | end 14 | 15 | type commit = Commit.t 16 | 17 | val hash : commit -> string 18 | 19 | val is_after : old:string -> commit -> bool Lwt.t 20 | 21 | val fetch_head : t -> CI_target.t -> commit CI_term.t 22 | 23 | val with_checkout : 24 | log:CI_live_log.t -> 25 | job_id:job_id -> 26 | commit -> 27 | (string -> 'a Lwt.t) -> 28 | 'a Lwt.t 29 | 30 | val with_clone : 31 | log:CI_live_log.t -> 32 | job_id:job_id -> 33 | commit -> 34 | (string -> 'a Lwt.t) -> 35 | 'a Lwt.t 36 | 37 | type command 38 | 39 | val command : 40 | logs:CI_live_log.manager -> 41 | timeout:float -> 42 | label:string -> 43 | clone:bool -> 44 | string array list -> 45 | command 46 | 47 | val run : command -> commit -> unit CI_term.t 48 | -------------------------------------------------------------------------------- /ci/src/cI_history.mli: -------------------------------------------------------------------------------- 1 | open Astring 2 | open CI_utils 3 | 4 | type t 5 | (** A cache of states. *) 6 | 7 | type target 8 | (** A mutable holder for the current state of a target. *) 9 | 10 | module State : sig 11 | type t 12 | (** An immutable snapshot of a target's state. *) 13 | 14 | val parents : t -> string list 15 | (** [parents t] is the list of hashes of [t]'s parent commits. *) 16 | 17 | val jobs : t -> string CI_output.t String.Map.t 18 | (** [jobs t] returns the list of jobs and their outputs at [t]. *) 19 | 20 | val metadata_commit : t -> string option 21 | (** [metadata_commit t] is the hash of the Git commit in github-metadata that was the build context. *) 22 | 23 | val source_commit : t -> string option 24 | (** [source_commit t] is the hash of the Git commit that triggered the build. *) 25 | 26 | val empty : t 27 | (** [empty] is a state with no jobs and no parents. *) 28 | 29 | val equal : t -> t -> bool 30 | 31 | val pp : t Fmt.t 32 | end 33 | 34 | val create : unit -> t 35 | 36 | val lookup : t -> DK.t -> CI_target.t -> target Lwt.t 37 | 38 | val record : 39 | target -> 40 | DK.t -> 41 | source_commit:string -> 42 | DK.Commit.t -> 43 | string CI_output.t String.Map.t -> 44 | unit Lwt.t 45 | (** [record target dk ~source_commit input jobs] records the new output of each job in [jobs] 46 | as a new commit of [target], and records that it was calculated using metadata snapshot [input]. 47 | The commit index of [source_commit] is updated to include the new result (for [builds_of_commit]). *) 48 | 49 | val load : DK.Commit.t -> State.t Lwt.t 50 | (** [load commit] loads a saved state from the database. *) 51 | 52 | val head : target -> State.t option 53 | (** [head t] is the current state of [t]. *) 54 | 55 | val builds_of_commit : 56 | DK.t -> Datakit_github.Commit.t -> DK.Commit.t CI_target.Map.t Lwt.t 57 | (** [builds_of_commit dk c] finds the latest build results for source commit [c]. *) 58 | -------------------------------------------------------------------------------- /ci/src/cI_live_log.mli: -------------------------------------------------------------------------------- 1 | (** An in-memory buffer where log messages are written during a build. *) 2 | 3 | type manager 4 | 5 | val create_manager : unit -> manager 6 | 7 | type t 8 | 9 | type stream = { data : string; next : stream option Lwt.t Lazy.t } 10 | 11 | val create : 12 | ?switch:Lwt_switch.t -> 13 | pending:string -> 14 | branch:string -> 15 | title:string -> 16 | manager -> 17 | t 18 | (** [create ~pending ~branch ~title manager] is a fresh, empty log with pending reason [pending]. 19 | It is an error to have two live logs on the same branch at the same time (finish the other one first). *) 20 | 21 | val title : t -> string 22 | (** [title t] is the title, as passed to [create]. *) 23 | 24 | val lookup : branch:string -> manager -> t option 25 | (** [lookup ~branch manager] is the currently-active log for [branch]. *) 26 | 27 | val branch : t -> string 28 | (** [branch t] is the branch to which this log will be written when finished. *) 29 | 30 | val stream : t -> stream option Lwt.t 31 | (** [stream t] reads the contents of the log as a stream. *) 32 | 33 | val write : t -> string -> unit 34 | (** [write t msg] appends [msg] to the log. *) 35 | 36 | val printf : t -> ('a, Format.formatter, unit, unit) format4 -> 'a 37 | (** [printf t fmt] appends a formatted message to the log. *) 38 | 39 | val log : t -> ('a, Format.formatter, unit, unit) format4 -> 'a 40 | (** [log t fmt] appends a formatted message to the log, with a newline added at the end. *) 41 | 42 | val heading : t -> ('a, Format.formatter, unit, unit) format4 -> 'a 43 | (** [heading t fmt] appends a formatted message to the log as a heading. *) 44 | 45 | val contents : t -> string 46 | (** [contents t] is the current contents of the buffer. *) 47 | 48 | val pending : t -> string * [ `Continue of unit Lwt.t | `Stop ] 49 | (** [pending t] is the current pending reason of the buffer and a thread that will 50 | resolve next time it changes. If it returns [`Stop] then there will be no further changes. *) 51 | 52 | val with_pending_reason : t -> string -> (unit -> 'a Lwt.t) -> 'a Lwt.t 53 | (** [with_pending_reason t msg fn] calls [fn ()]. If it gets a sleeping thread, then it 54 | pushes [msg] onto the pending-reason stack, waits for the thread to finish, and then 55 | removes the pending message. *) 56 | 57 | val enter_with_pending_reason : 58 | t -> string -> (('a -> 'b Lwt.t) -> 'b Lwt.t) -> ('a -> 'b Lwt.t) -> 'b Lwt.t 59 | (** [enter_with_pending_reason t msg use fn] is like [use fn], but posts [msg] as the pending reason until [fn] is called 60 | (or [use] fails). 61 | This is useful to give a pending reason while getting a mutex or pool resource. *) 62 | 63 | val finish : t -> unit 64 | (** [finish t] prevents any further changes and notifies anyone waiting on [pending]. *) 65 | 66 | val can_cancel : t -> bool 67 | (** [can_cancel t] indicates whether [cancel t] will succeed. *) 68 | 69 | val cancel : t -> (unit, string) result Lwt.t 70 | (** [cancel t] turns off [t]'s switch, or returns an error if [t] cannot be cancelled. *) 71 | -------------------------------------------------------------------------------- /ci/src/cI_log_reporter.ml: -------------------------------------------------------------------------------- 1 | let pp_level f lvl = 2 | let style, msg = 3 | match lvl with 4 | | Logs.App -> (`Black, "APP") 5 | | Logs.Error -> (`Red, "ERR") 6 | | Logs.Warning -> (`Red, "WRN") 7 | | Logs.Info -> (`None, "INF") 8 | | Logs.Debug -> (`Cyan, "DBG") 9 | in 10 | Fmt.pf f "%a" Fmt.(styled style string) msg 11 | 12 | let pp_timestamp f x = 13 | let open Unix in 14 | let tm = localtime x in 15 | Fmt.pf f "%04d-%02d-%02d %02d:%02d.%02d" (tm.tm_year + 1900) (tm.tm_mon + 1) 16 | tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec 17 | 18 | module Metrics = struct 19 | open Prometheus 20 | 21 | let namespace = "DataKitCI" 22 | 23 | let subsystem = "logs" 24 | 25 | let inc_messages = 26 | let help = "Total number of messages logged" in 27 | let c = 28 | Counter.v_labels ~label_names:[ "level"; "src" ] ~help ~namespace 29 | ~subsystem "messages_total" 30 | in 31 | fun lvl src -> 32 | let lvl = Logs.level_to_string (Some lvl) in 33 | Counter.inc_one @@ Counter.labels c [ lvl; src ] 34 | end 35 | 36 | let report src level ~over k msgf = 37 | let k _ = 38 | over (); 39 | k () 40 | in 41 | msgf @@ fun ?header:_ ?tags:_ fmt -> 42 | let src = Logs.Src.name src in 43 | Metrics.inc_messages level src; 44 | Format.kfprintf k Format.err_formatter 45 | ("%a %a [%s] @[" ^^ fmt ^^ "@]@.") 46 | pp_timestamp (Unix.gettimeofday ()) pp_level level src 47 | 48 | let init style_renderer level = 49 | Fmt_tty.setup_std_outputs ?style_renderer (); 50 | Logs.set_level level; 51 | Logs.set_reporter { Logs.report } 52 | 53 | let setup_log = 54 | let open Cmdliner in 55 | Term.(const init $ Fmt_cli.style_renderer () $ Logs_cli.level ()) 56 | -------------------------------------------------------------------------------- /ci/src/cI_log_reporter.mli: -------------------------------------------------------------------------------- 1 | val init : Fmt.style_renderer option -> Logs.level option -> unit 2 | 3 | val setup_log : unit Cmdliner.Term.t 4 | -------------------------------------------------------------------------------- /ci/src/cI_main.mli: -------------------------------------------------------------------------------- 1 | val run : ?info:Cmdliner.Term.info -> CI_config.t Cmdliner.Term.t -> 'a 2 | 3 | val logs : CI_live_log.manager 4 | -------------------------------------------------------------------------------- /ci/src/cI_monitored_pool.ml: -------------------------------------------------------------------------------- 1 | open Astring 2 | 3 | module Metrics = struct 4 | open Prometheus 5 | 6 | let namespace = "DataKitCI" 7 | 8 | let subsystem = "pool" 9 | 10 | let qlen = 11 | let help = "Number of users waiting for a resource" in 12 | Gauge.v_label ~help ~label_name:"name" ~namespace ~subsystem "qlen" 13 | 14 | let wait_time = 15 | let help = "Time spent waiting for a resource" in 16 | Summary.v_label ~help ~label_name:"name" ~namespace ~subsystem 17 | "wait_time_seconds" 18 | 19 | let use_time = 20 | let help = "Time spent using a resource" in 21 | Summary.v_label ~help ~label_name:"name" ~namespace ~subsystem 22 | "use_time_seconds" 23 | 24 | let resources_in_use = 25 | let help = "Number of resources currently being used" in 26 | Gauge.v_label ~help ~label_name:"name" ~namespace ~subsystem 27 | "resources_in_use" 28 | 29 | let capacity = 30 | let help = "Total pool capacity" in 31 | Gauge.v_label ~help ~label_name:"name" ~namespace ~subsystem "capacity" 32 | end 33 | 34 | type t = { 35 | label : string; 36 | capacity : int; 37 | mutable qlen : int; 38 | mutable active : int; 39 | pool : unit Lwt_pool.t; 40 | mutable users : ((CI_s.job_id * string option) * CI_live_log.t option) list; 41 | } 42 | 43 | let registered_pools = ref String.Map.empty 44 | 45 | let create label capacity = 46 | let pool = Lwt_pool.create capacity Lwt.return in 47 | let t = { label; capacity; qlen = 0; active = 0; pool; users = [] } in 48 | assert (not (String.Map.mem label !registered_pools)); 49 | registered_pools := String.Map.add label t !registered_pools; 50 | Prometheus.Gauge.set (Metrics.capacity label) (float_of_int capacity); 51 | t 52 | 53 | let rec remove_first msg = function 54 | | [] -> assert false 55 | | (m, _) :: xs when m = msg -> xs 56 | | x :: xs -> x :: remove_first msg xs 57 | 58 | let use ?log t ~reason fn = 59 | let qlen = Metrics.qlen t.label in 60 | Prometheus.Gauge.inc_one qlen; 61 | t.qlen <- t.qlen + 1; 62 | let dec = 63 | lazy 64 | ( Prometheus.Gauge.dec_one qlen; 65 | t.qlen <- t.qlen - 1 ) 66 | in 67 | let start_wait = Unix.gettimeofday () in 68 | Lwt.finalize 69 | (fun () -> 70 | Lwt_pool.use t.pool (fun v -> 71 | Lazy.force dec; 72 | let stop_wait = Unix.gettimeofday () in 73 | Prometheus.Summary.observe 74 | (Metrics.wait_time t.label) 75 | (stop_wait -. start_wait); 76 | t.active <- t.active + 1; 77 | t.users <- (reason, log) :: t.users; 78 | Prometheus.Gauge.track_inprogress (Metrics.resources_in_use t.label) 79 | @@ fun () -> 80 | Lwt.finalize 81 | (fun () -> fn v) 82 | (fun () -> 83 | let stop_use = Unix.gettimeofday () in 84 | Prometheus.Summary.observe (Metrics.use_time t.label) 85 | (stop_use -. stop_wait); 86 | t.active <- t.active - 1; 87 | t.users <- remove_first reason t.users; 88 | Lwt.return_unit))) 89 | (fun () -> 90 | Lazy.force dec; 91 | Lwt.return ()) 92 | 93 | let use t ?log ?label job_id fn = 94 | let reason = (job_id, label) in 95 | match log with 96 | | None -> use ?log t ~reason fn 97 | | Some log -> 98 | let msg = Fmt.strf "Waiting for resource in %S" t.label in 99 | CI_live_log.enter_with_pending_reason log msg (use ~log t ~reason) fn 100 | 101 | let active t = t.active 102 | 103 | let capacity t = t.capacity 104 | 105 | let qlen t = t.qlen 106 | 107 | let pools () = !registered_pools 108 | 109 | let users t = t.users 110 | -------------------------------------------------------------------------------- /ci/src/cI_monitored_pool.mli: -------------------------------------------------------------------------------- 1 | open Astring 2 | 3 | type t 4 | 5 | val pools : unit -> t String.Map.t 6 | 7 | val create : string -> int -> t 8 | 9 | val use : 10 | t -> 11 | ?log:CI_live_log.t -> 12 | ?label:string -> 13 | CI_s.job_id -> 14 | (unit -> 'a Lwt.t) -> 15 | 'a Lwt.t 16 | (** [use t job fn] evaluates [fn ()] with one pool resource held. 17 | [job] (and [label]) will be displayed as the reason why the resource is in use. 18 | If [log] is provided then a message will be logged if we have to wait, and 19 | if the log is cancellable then the user will be able to cancel the operation. *) 20 | 21 | val active : t -> int 22 | 23 | val capacity : t -> int 24 | 25 | val qlen : t -> int 26 | 27 | val users : t -> ((CI_s.job_id * string option) * CI_live_log.t option) list 28 | (** [users t] is the list of reasons why resources are being used, one per resource, and (optionally) its 29 | log (through which it may be possible to cancel the job). *) 30 | -------------------------------------------------------------------------------- /ci/src/cI_output.ml: -------------------------------------------------------------------------------- 1 | type saved = { 2 | title : string; 3 | commit : string; 4 | branch : string; 5 | failed : bool; 6 | mutable rebuild : 7 | [ `Rebuildable of unit Lwt.t Lazy.t | `Rebuilding | `Archived ]; 8 | } 9 | 10 | type logs = 11 | | Empty 12 | | Live of CI_live_log.t 13 | | Saved of saved 14 | | Pair of logs * logs 15 | 16 | type 'a t = 'a CI_result.t * logs 17 | 18 | let result = fst 19 | 20 | let logs = snd 21 | 22 | let status t = CI_result.status (result t) 23 | 24 | let descr t = CI_result.descr (result t) 25 | 26 | let rec json_of_logs : logs -> Yojson.Basic.t = function 27 | | Empty -> `Null 28 | | Live x -> `Assoc [ ("branch", `String (CI_live_log.branch x)) ] 29 | | Saved x -> 30 | `Assoc 31 | [ ("title", `String x.title); 32 | ("branch", `String x.branch); 33 | ("commit", `String x.commit); 34 | ("failed", `Bool x.failed) 35 | ] 36 | | Pair (a, b) -> ( 37 | match (json_of_logs a, json_of_logs b) with 38 | | `Null, x -> x 39 | | x, `Null -> x 40 | | x, y -> `List [ x; y ] ) 41 | 42 | let rec logs_of_json = function 43 | | `Null -> Empty 44 | | `Assoc [ ("branch", `String _x) ] -> 45 | Empty (* Can't restore live logs currently *) 46 | | `Assoc 47 | [ ("title", `String title); 48 | ("branch", `String branch); 49 | ("commit", `String commit); 50 | ("failed", `Bool failed) 51 | ] -> 52 | Saved { title; commit; branch; failed; rebuild = `Archived } 53 | | `List [ a; b ] -> Pair (logs_of_json a, logs_of_json b) 54 | | json -> 55 | CI_utils.failf "Invalid logs JSON: %a" 56 | (Yojson.Basic.pretty_print ?std:None) 57 | json 58 | 59 | let json_of (result, logs) = 60 | `Assoc [ ("result", CI_result.json_of result); ("logs", json_of_logs logs) ] 61 | 62 | let of_json = function 63 | | `Assoc [ ("result", result); ("logs", logs) ] -> 64 | (CI_result.of_json result, logs_of_json logs) 65 | | json -> 66 | CI_utils.failf "Invalid output JSON: %a" 67 | (Yojson.Basic.pretty_print ?std:None) 68 | json 69 | 70 | let pp_logs f logs = Yojson.Basic.pretty_print f (json_of_logs logs) 71 | 72 | let equal a b = json_of a = json_of b 73 | 74 | let pp fv f (result, logs) = 75 | Fmt.pf f "%a:@[%a@]" (CI_result.pp fv) result pp_logs logs 76 | -------------------------------------------------------------------------------- /ci/src/cI_output.mli: -------------------------------------------------------------------------------- 1 | type saved = { 2 | title : string; 3 | commit : string; 4 | branch : string; 5 | failed : bool; 6 | mutable rebuild : 7 | [ `Rebuildable of unit Lwt.t Lazy.t | `Rebuilding | `Archived ]; 8 | } 9 | 10 | type logs = 11 | | Empty 12 | | Live of CI_live_log.t 13 | | Saved of saved 14 | | Pair of logs * logs 15 | 16 | type 'a t = 'a CI_result.t * logs 17 | 18 | val result : 'a t -> 'a CI_result.t 19 | 20 | val logs : 'a t -> logs 21 | 22 | val status : _ t -> [ `Success | `Pending | `Failure ] 23 | 24 | val descr : string t -> string 25 | 26 | val equal : string t -> string t -> bool 27 | (** [equal a b] is [true] iff [a] and [b] are equal for the purposes of saving the output metadata to disk. 28 | i.e. they have the same JSON representation. *) 29 | 30 | val json_of : string t -> Yojson.Basic.t 31 | 32 | val of_json : Yojson.Basic.t -> string t 33 | 34 | val pp : 'a Fmt.t -> 'a t Fmt.t 35 | -------------------------------------------------------------------------------- /ci/src/cI_process.mli: -------------------------------------------------------------------------------- 1 | (** Convenience wrappers around [Lwt_process]. *) 2 | 3 | val run_with_exit_status : 4 | ?switch:Lwt_switch.t -> 5 | ?log:CI_live_log.t -> 6 | ?cwd:string -> 7 | ?env:string array -> 8 | ?stdin:Lwt_process.redirection -> 9 | output:(string -> unit) -> 10 | ?stderr:(string -> unit) -> 11 | ?log_cmd:Lwt_process.command -> 12 | Lwt_process.command -> 13 | Unix.process_status Lwt.t 14 | (** Run [cmd], passing each chunk of output it produces on stdout to [output] and each chunk on stderr to [stderr]. 15 | If [stderr] is not given, [output] is used for both. 16 | Returns the exit status of the process when completed. 17 | If [log_cmd] is given, it is displayed in all log messages instead of [cmd]. 18 | This is useful to hide secret tokens, etc. *) 19 | 20 | val run : 21 | ?switch:Lwt_switch.t -> 22 | ?log:CI_live_log.t -> 23 | ?cwd:string -> 24 | ?env:string array -> 25 | ?stdin:Lwt_process.redirection -> 26 | output:(string -> unit) -> 27 | ?stderr:(string -> unit) -> 28 | ?log_cmd:Lwt_process.command -> 29 | Lwt_process.command -> 30 | unit Lwt.t 31 | (** Run [cmd], passing each chunk of output it produces on stdout to [output] and each chunk on stderr to [stderr]. 32 | If [stderr] is not given, [output] is used for both. 33 | Raises an exception if the process doesn't return an exit status of zero. *) 34 | 35 | val check_status : Lwt_process.command -> Unix.process_status -> unit 36 | (** [check_status cmd status] checks that [status] is a successful exit status. 37 | If not, it raises an exception giving [cmd] as the cause. *) 38 | -------------------------------------------------------------------------------- /ci/src/cI_result.ml: -------------------------------------------------------------------------------- 1 | type error = 2 | [ `Failure of string (* A permanent error (unless an input changes) *) 3 | | `Pending of string ] 4 | 5 | (* A problem that is expected to resolve itself with time *) 6 | 7 | type 'a t = ('a, error) result 8 | 9 | let pp_error f = function 10 | | `Failure x -> Fmt.pf f "Failure: %s" x 11 | | `Pending x -> Fmt.pf f "Pending: %s" x 12 | 13 | let pp ok f = function Ok x -> ok f x | Error e -> pp_error f e 14 | 15 | let descr = function Ok x -> x | Error (`Failure x | `Pending x) -> x 16 | 17 | let v status descr = 18 | match status with 19 | | `Success -> Ok descr 20 | | `Pending -> Error (`Pending descr) 21 | | `Failure -> Error (`Failure descr) 22 | 23 | let status = function 24 | | Ok _ -> `Success 25 | | Error (`Pending _) -> `Pending 26 | | Error (`Failure _) -> `Failure 27 | 28 | let string_of_status = function 29 | | `Pending -> "pending" 30 | | `Success -> "success" 31 | | `Failure -> "failure" 32 | 33 | let json_of t = 34 | `Assoc 35 | [ ("status", `String (status t |> string_of_status)); 36 | ("descr", `String (descr t)) 37 | ] 38 | 39 | let of_json = function 40 | | `Assoc [ ("status", `String "success"); ("descr", `String d) ] -> Ok d 41 | | `Assoc [ ("status", `String "pending"); ("descr", `String d) ] -> 42 | Error (`Pending d) 43 | | `Assoc [ ("status", `String "failure"); ("descr", `String d) ] -> 44 | Error (`Failure d) 45 | | json -> 46 | CI_utils.failf "Invalid results JSON: %a" 47 | (Yojson.Basic.pretty_print ?std:None) 48 | json 49 | -------------------------------------------------------------------------------- /ci/src/cI_result.mli: -------------------------------------------------------------------------------- 1 | type error = 2 | [ `Failure of string (* A permanent error (unless an input changes) *) 3 | | `Pending of string ] 4 | 5 | (* A problem that is expected to resolve itself with time *) 6 | 7 | type 'a t = ('a, error) result 8 | 9 | val pp_error : error Fmt.t 10 | 11 | val pp : 'a Fmt.t -> 'a t Fmt.t 12 | 13 | val v : [< `Success | `Pending | `Failure ] -> string -> string t 14 | 15 | val status : _ t -> [> `Success | `Pending | `Failure ] 16 | 17 | val descr : string t -> string 18 | 19 | val json_of : string t -> Yojson.Basic.t 20 | 21 | val of_json : Yojson.Basic.t -> string t 22 | -------------------------------------------------------------------------------- /ci/src/cI_s.ml: -------------------------------------------------------------------------------- 1 | open CI_utils 2 | 3 | type 'a status = { 4 | result : 5 | ('a, [ `Pending of string * unit Lwt.t | `Failure of string ]) result; 6 | output : CI_output.logs; 7 | } 8 | 9 | type job_id = CI_target.t * string 10 | (** Used in logging and monitoring to identify the owning job. *) 11 | 12 | module type CONTEXT = sig 13 | type t 14 | (** A [ctx] is a context in which a term is evaluated. *) 15 | 16 | val watch : t -> unit Lwt.t -> unit 17 | (** [watch t thread] is called to indicate that the term will need 18 | to be recalculated when [thread] finishes. *) 19 | end 20 | 21 | module type TERM = sig 22 | type context 23 | 24 | type 'a key 25 | 26 | type 'a t 27 | 28 | val return : 'a -> 'a t 29 | 30 | val fail : ('a, Format.formatter, unit, 'b t) format4 -> 'a 31 | 32 | val pending : ('a, Format.formatter, unit, 'b t) format4 -> 'a 33 | 34 | val state : 35 | 'a t -> ('a, [ `Pending of string | `Failure of string ]) result t 36 | 37 | val of_state : 38 | ('a, [< `Pending of string | `Failure of string ]) result -> 'a t 39 | 40 | val catch : 'a t -> ('a, [ `Failure of string ]) result t 41 | 42 | val value : 'a key -> 'a t 43 | 44 | val of_lwt_quick : 'a Lwt.t -> 'a t 45 | 46 | val of_lwt_slow : (unit -> 'a status Lwt.t) -> 'a t 47 | 48 | val join : 'a t t -> 'a t 49 | 50 | val pair : 'a t -> 'b t -> ('a * 'b) t 51 | 52 | val without_logs : 'a t -> 'a t 53 | 54 | module Infix : sig 55 | val ( $ ) : ('a -> 'b) t -> 'a t -> 'b t 56 | 57 | val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t 58 | 59 | val ( >|= ) : 'a t -> ('a -> 'b) -> 'b t 60 | end 61 | 62 | val list_map_p : ('a -> 'b t) -> 'a list -> 'b list t 63 | 64 | val wait_for : 'a t -> while_pending:string -> on_failure:string -> unit t 65 | 66 | val wait_for_all : (string * 'a t) list -> unit t 67 | end 68 | 69 | module type BUILDER = sig 70 | type t 71 | 72 | module Key : sig 73 | type t 74 | end 75 | 76 | type context 77 | 78 | type value 79 | 80 | val name : t -> string 81 | 82 | val title : t -> Key.t -> string 83 | 84 | val generate : 85 | t -> 86 | switch:Lwt_switch.t -> 87 | log:CI_live_log.t -> 88 | DK.Transaction.t -> 89 | context -> 90 | Key.t -> 91 | (value, [ `Failure of string ]) result Lwt.t 92 | 93 | val load : t -> DK.Tree.t -> Key.t -> value Lwt.t 94 | 95 | val branch : t -> Key.t -> string 96 | end 97 | -------------------------------------------------------------------------------- /ci/src/cI_secrets.ml: -------------------------------------------------------------------------------- 1 | open Sexplib.Std 2 | open CI_utils 3 | open Lwt.Infix 4 | 5 | let ( / ) = Filename.concat 6 | 7 | type t = { secrets_dir : string } 8 | 9 | type github_auth = { 10 | client_id : string; 11 | client_secret : string; 12 | callback : Uri_sexp.t option; 13 | } 14 | [@@deriving sexp] 15 | 16 | class type ['a] disk_secret = 17 | object 18 | method read : 'a option Lwt.t 19 | 20 | method write : 'a option -> unit Lwt.t 21 | end 22 | 23 | type 'a secret = { 24 | mutable value : 'a option; 25 | conv : 'a disk_secret; 26 | lock : Lwt_mutex.t; 27 | } 28 | 29 | let private_key_path t = t.secrets_dir / "server.key" 30 | 31 | let certificate_path t = t.secrets_dir / "server.crt" 32 | 33 | let passwords_path t = t.secrets_dir / "passwords.sexp" 34 | 35 | let github_auth_path t = t.secrets_dir / "github.sexp" 36 | 37 | let get_private_key ~key_bits path = 38 | if Sys.file_exists path then 39 | Lwt_io.with_file ~mode:Lwt_io.input path (fun ch -> Lwt_io.read ch) 40 | >|= fun data -> 41 | X509.Encoding.Pem.Private_key.of_pem_cstruct1 (Cstruct.of_string data) 42 | else ( 43 | Log.info (fun f -> f "Generating new private key..."); 44 | let priv = `RSA (Nocrypto.Rsa.generate key_bits) in 45 | let data = 46 | X509.Encoding.Pem.Private_key.to_pem_cstruct1 priv |> Cstruct.to_string 47 | in 48 | Lwt_io.with_file ~mode:Lwt_io.output path (fun ch -> Lwt_io.write ch data) 49 | >|= fun () -> 50 | priv ) 51 | 52 | let ensure_crt ~private_key path = 53 | if Sys.file_exists path then Lwt.return () 54 | else 55 | let dn = [ `CN "DataKitCI" ] in 56 | let csr = X509.CA.request dn private_key in 57 | let valid_from = Ptime.of_date_time ((2016, 07, 25), ((12, 0, 0), 0)) in 58 | let valid_from = opt_get (fun () -> assert false) valid_from in 59 | let valid_until = Ptime.of_date_time ((3000, 01, 01), ((15, 0, 0), 0)) in 60 | let valid_until = opt_get (fun () -> assert false) valid_until in 61 | let crt = X509.CA.sign csr ~valid_from ~valid_until private_key dn in 62 | let data = 63 | X509.Encoding.Pem.Certificate.to_pem_cstruct1 crt |> Cstruct.to_string 64 | in 65 | Lwt_io.with_file ~mode:Lwt_io.output path (fun ch -> Lwt_io.write ch data) 66 | 67 | let secret conv = 68 | conv#read >|= fun value -> 69 | let lock = Lwt_mutex.create () in 70 | { value; conv; lock } 71 | 72 | let const value = 73 | let conv = 74 | object 75 | method read = assert false 76 | 77 | method write = failwith "const" 78 | end 79 | in 80 | let lock = Lwt_mutex.create () in 81 | { value; conv; lock } 82 | 83 | let github_auth t = 84 | let path = github_auth_path t in 85 | secret 86 | @@ object 87 | method read = 88 | match Sys.file_exists path with 89 | | false -> Lwt.return None 90 | | true -> 91 | Lwt_io.with_file ~mode:Lwt_io.input path (fun ch -> 92 | Lwt_io.read ch) 93 | >|= fun data -> 94 | Some (github_auth_of_sexp (Sexplib.Sexp.of_string data)) 95 | 96 | method write = 97 | function 98 | | None -> 99 | if Sys.file_exists path then Unix.unlink path; 100 | Lwt.return_unit 101 | | Some settings -> 102 | let data = 103 | Sexplib.Sexp.to_string (sexp_of_github_auth settings) 104 | in 105 | Lwt_io.with_file ~mode:Lwt_io.output path (fun ch -> 106 | Lwt_io.write ch data) 107 | end 108 | 109 | let get secret = secret.value 110 | 111 | let set secret value = 112 | Lwt_mutex.with_lock secret.lock @@ fun () -> 113 | (secret.conv)#write value >|= fun () -> 114 | secret.value <- value 115 | 116 | let create ~key_bits secrets_dir = 117 | let t = { secrets_dir } in 118 | get_private_key ~key_bits (private_key_path t) >>= fun private_key -> 119 | ensure_crt ~private_key (certificate_path t) >|= fun () -> 120 | t 121 | -------------------------------------------------------------------------------- /ci/src/cI_secrets.mli: -------------------------------------------------------------------------------- 1 | type t 2 | (** A collection of secrets. *) 3 | 4 | type github_auth = { 5 | client_id : string; 6 | client_secret : string; 7 | callback : Uri.t option; 8 | } 9 | 10 | type 'a secret 11 | 12 | (* A secret that can be read or written. *) 13 | 14 | val get : 'a secret -> 'a option 15 | 16 | (* Read the current value of the secret. This operation is quick (does not access the disk). *) 17 | 18 | val set : 'a secret -> 'a option -> unit Lwt.t 19 | 20 | val private_key_path : t -> string 21 | (** [private_key_path t] is the path of the PEM-encoded private key. *) 22 | 23 | val certificate_path : t -> string 24 | (** [certificate_path t] is the path of the PEM-encoded X.509 certificate for the key. *) 25 | 26 | val passwords_path : t -> string 27 | (** [passwords_path t] is the path of the file in which passwords, roles, etc should be saved. *) 28 | 29 | val github_auth : t -> github_auth secret Lwt.t 30 | 31 | val create : key_bits:int -> string -> t Lwt.t 32 | (** [create ~key_bits secrets_dir] connects to [secrets_dir], creating a new [key_bits] long RSA pair-key and 33 | self-signed certificate if there isn't one there already. *) 34 | 35 | val const : 'a option -> 'a secret 36 | (** [const v] is a secret whose value is always [v] and which cannot be set. Mainly useful for unit-tests. *) 37 | -------------------------------------------------------------------------------- /ci/src/cI_static.mli: -------------------------------------------------------------------------------- 1 | val read : string -> string option 2 | 3 | (* to avoid warning 32 *) 4 | val file_list : string list 5 | -------------------------------------------------------------------------------- /ci/src/cI_target.mli: -------------------------------------------------------------------------------- 1 | open Datakit_github 2 | open! Asetmap 3 | 4 | type t = [ `PR of PR.id | `Ref of Ref.id ] 5 | 6 | val pp : t Fmt.t 7 | 8 | val compare : t -> t -> int 9 | 10 | val equal : t -> t -> bool 11 | 12 | val arg : t Cmdliner.Arg.converter 13 | 14 | val repo : t -> Repo.t 15 | 16 | val id : t -> [ `PR of int | `Ref of string list ] 17 | 18 | val path : ?test:string -> t -> Uri.t 19 | 20 | module Map : Map.S with type key = t 21 | 22 | module Set : Set.S with type elt = t 23 | 24 | val map_of_list : t list -> Set.t Repo.Map.t 25 | 26 | type v = [ `PR of PR.t | `Ref of Ref.t ] 27 | 28 | val head : v -> Commit.t 29 | 30 | val compare_v : v -> v -> int 31 | 32 | val path_v : v -> Uri.t 33 | 34 | val repo_v : v -> Repo.t 35 | 36 | val unescape_ref : string -> Ref.name 37 | 38 | val pp_v : v Fmt.t 39 | 40 | val of_v : v -> t 41 | 42 | module Branch_escape : sig 43 | val pp_sub : t Fmt.t 44 | (** [pp_sub t] formats the PR or ref part as a branch name, without the repository information. *) 45 | 46 | val parse_sub : repo:Repo.t -> string -> t option 47 | (** [parse_sub ~repo s] is the reverse of [pp_sub]. *) 48 | end 49 | 50 | val status_branch : t -> string 51 | (** [status_branch target] is the DataKit branch in which to store the status of [target]'s jobs. *) 52 | 53 | val of_status_branch : string -> t 54 | (** [of_status_branch branch_name] reverses [status_branch_v]. *) 55 | -------------------------------------------------------------------------------- /ci/src/cI_term.ml: -------------------------------------------------------------------------------- 1 | open Datakit_github 2 | module Conv = Datakit_github_conv.Make (CI_utils.DK) 3 | 4 | module Metrics = struct 5 | let namespace = "DataKitCI" 6 | 7 | let subsystem = "term" 8 | 9 | let evals = 10 | let help = "Number of term evaluations" in 11 | Prometheus.Counter.v ~help ~namespace ~subsystem "evals_total" 12 | end 13 | 14 | module Context = struct 15 | (* The context in which a term is evaluated. We create a fresh context each time 16 | the term is evaluated. *) 17 | type t = { 18 | github : CI_utils.DK.Tree.t; 19 | job_id : CI_s.job_id; 20 | mutable recalc : unit -> unit; 21 | (* Call this to schedule a recalculation. *) 22 | dk : unit -> CI_utils.DK.t Lwt.t; 23 | } 24 | 25 | let dk t = t.dk 26 | 27 | let github t = t.github 28 | 29 | let job_id t = t.job_id 30 | 31 | let disable t = 32 | t.recalc <- 33 | (fun () -> 34 | CI_utils.Log.debug (fun f -> 35 | f "recalculate called, but term is finished")) 36 | 37 | let watch t ready = 38 | (* When [ready] is done, call the then-current [recalc] function. *) 39 | Lwt.on_termination ready (fun () -> t.recalc ()) 40 | end 41 | 42 | include CI_eval.Make (Context) 43 | open Infix 44 | 45 | let dk = value Context.dk 46 | 47 | let github = value Context.github 48 | 49 | let job_id = value Context.job_id 50 | 51 | let pp_target f = function `PR pr -> PR.pp f pr | `Ref r -> Ref.pp f r 52 | 53 | let ( >?= ) x f = Lwt.map (function None -> None | Some x -> Some (f x)) x 54 | 55 | let target t = function 56 | | `PR x -> 57 | Conv.pr t x >?= fun x -> 58 | `PR x 59 | | `Ref x -> 60 | Conv.ref t x >?= fun x -> 61 | `Ref x 62 | 63 | let target id = 64 | github >>= fun gh -> 65 | of_lwt_quick (target gh id) >>= function 66 | | None -> fail "Target %a does not exist" CI_target.pp id 67 | | Some x -> return x 68 | 69 | let head id = target id >|= CI_target.head 70 | 71 | let ref_head repo ref_name = 72 | match Datakit_client.Path.of_string ref_name with 73 | | Error msg -> fail "Invalid ref name %S: %s" ref_name msg 74 | | Ok ref_path -> head @@ `Ref (repo, Datakit_client.Path.unwrap ref_path) 75 | 76 | let branch_head repo branch = ref_head repo ("heads/" ^ branch) 77 | 78 | let tag repo tag = ref_head repo ("tags/" ^ tag) 79 | 80 | let ci_state fn ci t = 81 | head t >>= fun c -> 82 | github >>= fun s -> 83 | of_lwt_quick (Conv.status s (c, ci)) >|= function 84 | | Some s -> fn s 85 | | None -> None 86 | 87 | let ci_status = ci_state (fun s -> Some (Status.state s)) 88 | 89 | let ci_descr = ci_state Status.description 90 | 91 | let ci_target_url = ci_state Status.url 92 | 93 | let pp_opt_descr f = function 94 | | None -> () 95 | | Some descr -> Fmt.pf f " (%s)" descr 96 | 97 | let ci_success_target_url ci target = 98 | ci_status ci target >>= function 99 | | None -> pending "Waiting for %a status to appear" Ref.pp_name ci 100 | | Some `Pending -> 101 | ci_descr ci target 102 | >>= pending "Waiting for %a to complete%a" Ref.pp_name ci pp_opt_descr 103 | | Some `Failure -> 104 | ci_descr ci target >>= fail "%a failed%a" Ref.pp_name ci pp_opt_descr 105 | | Some `Error -> 106 | ci_descr ci target >>= fail "%a errored%a" Ref.pp_name ci pp_opt_descr 107 | | Some `Success -> ( 108 | ci_state Status.url ci target >>= function 109 | | None -> fail "%a succeeded, but has no URL!" Ref.pp_name ci 110 | | Some url -> return url ) 111 | 112 | let run ~snapshot ~job_id ~recalc ~dk term = 113 | Prometheus.Counter.inc_one Metrics.evals; 114 | let ctx = { Context.recalc; job_id; dk; github = snapshot } in 115 | (run ctx term, fun () -> Context.disable ctx) 116 | -------------------------------------------------------------------------------- /ci/src/cI_term.mli: -------------------------------------------------------------------------------- 1 | open Datakit_github 2 | 3 | include CI_s.TERM 4 | 5 | val pp_target : [ `PR of PR.t | `Ref of Ref.t ] Fmt.t 6 | 7 | val github : CI_utils.DK.Tree.t t 8 | 9 | val target : CI_target.t -> CI_target.v t 10 | 11 | val job_id : CI_s.job_id t 12 | 13 | val head : CI_target.t -> Commit.t t 14 | 15 | val branch_head : Repo.t -> string -> Commit.t t 16 | 17 | val tag : Repo.t -> string -> Commit.t t 18 | 19 | val dk : (unit -> CI_utils.DK.t Lwt.t) t 20 | 21 | val ci_status : string list -> CI_target.t -> Status_state.t option t 22 | 23 | val ci_target_url : string list -> CI_target.t -> Uri.t option t 24 | 25 | val ci_success_target_url : string list -> CI_target.t -> Uri.t t 26 | 27 | val run : 28 | snapshot:CI_utils.DK.Tree.t -> 29 | job_id:CI_s.job_id -> 30 | recalc:(unit -> unit) -> 31 | dk:(unit -> CI_utils.DK.t Lwt.t) -> 32 | 'a t -> 33 | ('a CI_result.t * CI_output.logs) Lwt.t * (unit -> unit) 34 | -------------------------------------------------------------------------------- /ci/src/cI_utils.ml: -------------------------------------------------------------------------------- 1 | open Result 2 | open Lwt.Infix 3 | 4 | let src9p = Logs.Src.create "Client9p" ~doc:"9p client" 5 | 6 | module Log9p = (val Logs.src_log src9p : Logs.LOG) 7 | 8 | module Client9p = Protocol_9p_unix.Client9p_unix.Make (Log9p) 9 | module DK = Datakit_client_9p.Make (Client9p) 10 | 11 | let src = Logs.Src.create "datakit-ci" ~doc:"DataKit-based CI system" 12 | 13 | module Log = (val Logs.src_log src : Logs.LOG) 14 | 15 | (* Hold this to prevent other threads changing the current directory. *) 16 | let chdir_lock = Lwt_mutex.create () 17 | 18 | let ok x = Lwt.return (Ok x) 19 | 20 | module Infix = struct 21 | (* Chain operations together, returning early if we get an error *) 22 | let ( >>*= ) x f = 23 | x >>= function 24 | | Ok x -> f x 25 | | Error e -> Lwt.fail (Failure (Fmt.to_to_string DK.pp_error e)) 26 | 27 | let ( >|*= ) x f = 28 | x >>*= fun x -> 29 | Lwt.return (f x) 30 | end 31 | 32 | let return_error fmt = 33 | fmt 34 | |> Fmt.kstrf @@ fun msg -> 35 | Lwt.return (Error msg) 36 | 37 | let failf fmt = Fmt.kstrf failwith fmt 38 | 39 | let pp_exn f = function 40 | | Failure msg -> Fmt.string f msg 41 | | ex -> Fmt.string f (Printexc.to_string ex) 42 | 43 | let pp_duration f d = 44 | if d < 120. then Fmt.pf f "%.2f seconds" d 45 | else Fmt.pf f "%.2f minutes" (d /. 60.) 46 | 47 | let with_switch fn = 48 | let switch = Lwt_switch.create () in 49 | Lwt.finalize (fun () -> fn switch) (fun () -> Lwt_switch.turn_off switch) 50 | 51 | let with_child_switch ?switch fn = 52 | match switch with 53 | | None -> with_switch fn 54 | | Some parent -> 55 | with_switch (fun child -> 56 | Lwt_switch.add_hook_or_exec (Some parent) (fun () -> 57 | Lwt_switch.turn_off child) 58 | >>= fun () -> 59 | fn child) 60 | 61 | let with_timeout ?switch duration fn = 62 | with_child_switch ?switch @@ fun switch -> 63 | let timeout = Lwt_unix.sleep duration in 64 | Lwt_switch.add_hook (Some switch) (fun () -> 65 | Lwt.cancel timeout; 66 | Lwt.return ()); 67 | Lwt.on_success timeout (fun () -> 68 | Log.info (fun f -> f "Timeout (of %a) expired" pp_duration duration); 69 | Lwt.async (fun () -> Lwt_switch.turn_off switch)); 70 | Lwt.catch 71 | (fun () -> fn switch) 72 | (fun ex -> 73 | match Lwt.state timeout with 74 | | Lwt.Return () -> failf "Exceeded timeout of %a" pp_duration duration 75 | | _ -> Lwt.fail ex) 76 | 77 | let default d = function None -> d | Some x -> x 78 | 79 | let abs_path x = 80 | if Filename.is_relative x then Filename.concat (Sys.getcwd ()) x else x 81 | 82 | let ensure_dir ~mode path = 83 | let rec loop path = 84 | match Unix.stat path with 85 | | info -> 86 | if info.Unix.st_kind = Unix.S_DIR then () 87 | else failf "Not a directory: %s" path 88 | | exception _ -> 89 | let parent = Filename.dirname path in 90 | assert (path <> parent); 91 | loop parent; 92 | Unix.mkdir path mode 93 | in 94 | loop path 95 | 96 | let make_tmp_dir ?(prefix = "tmp-") ?(mode = 0o700) parent = 97 | let rec mktmp = function 98 | | 0 -> failf "Failed to generate temporary directroy name!" 99 | | n -> ( 100 | try 101 | let tmppath = 102 | Printf.sprintf "%s/%s%x" parent prefix (Random.int 0x3fffffff) 103 | in 104 | Unix.mkdir tmppath mode; 105 | tmppath 106 | with Unix.Unix_error (Unix.EEXIST, _, _) -> mktmp (n - 1) ) 107 | in 108 | mktmp 10 109 | 110 | let rm_f_tree root = 111 | Log.debug (fun f -> f "rm -rf %S" root); 112 | let rec rmtree path = 113 | let info = Unix.lstat path in 114 | match info.Unix.st_kind with 115 | | Unix.S_REG | Unix.S_LNK | Unix.S_BLK | Unix.S_CHR | Unix.S_SOCK 116 | | Unix.S_FIFO -> 117 | Unix.unlink path 118 | | Unix.S_DIR -> 119 | Unix.chmod path 0o700; 120 | Sys.readdir path 121 | |> Array.iter (fun leaf -> rmtree (Filename.concat path leaf)); 122 | Unix.rmdir path 123 | in 124 | rmtree root 125 | 126 | let with_tmpdir ?prefix ?mode fn = 127 | let tmpdir = make_tmp_dir ?prefix ?mode (Filename.get_temp_dir_name ()) in 128 | Lwt.finalize 129 | (fun () -> fn tmpdir) 130 | (fun () -> 131 | rm_f_tree tmpdir; 132 | Lwt.return ()) 133 | 134 | let ls path = 135 | let rec read_files acc fd = 136 | Lwt.try_bind 137 | (fun () -> Lwt_unix.readdir fd) 138 | (fun leaf -> read_files (leaf :: acc) fd) 139 | (function End_of_file -> Lwt.return acc | ex -> Lwt.fail ex) 140 | in 141 | Lwt_unix.opendir path >>= fun fd -> 142 | Lwt.finalize (fun () -> read_files [] fd) (fun () -> Lwt_unix.closedir fd) 143 | 144 | let cancel_when_off switch fn = 145 | let th = fn () in 146 | Lwt_switch.add_hook_or_exec (Some switch) (fun () -> 147 | Lwt.cancel th; 148 | Lwt.return ()) 149 | >>= fun () -> 150 | th 151 | 152 | let opt_get f = function None -> f () | Some x -> x 153 | -------------------------------------------------------------------------------- /ci/src/cI_utils.mli: -------------------------------------------------------------------------------- 1 | open! Result 2 | 3 | module Log : Logs.LOG 4 | 5 | val src : Logs.src 6 | 7 | module Client9p : sig 8 | include Protocol_9p.Client.S 9 | 10 | val connect : 11 | string -> 12 | string -> 13 | ?msize:int32 -> 14 | ?username:string -> 15 | ?aname:string -> 16 | ?max_fids:int32 -> 17 | ?send_pings:bool -> 18 | unit -> 19 | t Protocol_9p.Error.t Lwt.t 20 | end 21 | 22 | module DK : sig 23 | include Datakit_client.S 24 | 25 | val connect : Client9p.t -> t 26 | end 27 | 28 | module Infix : sig 29 | val ( >>*= ) : ('a, DK.error) result Lwt.t -> ('a -> 'b Lwt.t) -> 'b Lwt.t 30 | 31 | val ( >|*= ) : ('a, DK.error) result Lwt.t -> ('a -> 'b) -> 'b Lwt.t 32 | end 33 | 34 | val chdir_lock : Lwt_mutex.t 35 | 36 | val ok : 'a -> ('a, 'b) result Lwt.t 37 | 38 | val return_error : 39 | ('a, Format.formatter, unit, ('b, string) result Lwt.t) format4 -> 'a 40 | 41 | val failf : ('a, Format.formatter, unit, 'b) format4 -> 'a 42 | 43 | val pp_exn : exn Fmt.t 44 | 45 | val with_timeout : 46 | ?switch:Lwt_switch.t -> float -> (Lwt_switch.t -> 'a Lwt.t) -> 'a Lwt.t 47 | 48 | val abs_path : string -> string 49 | 50 | val ensure_dir : mode:Unix.file_perm -> string -> unit 51 | 52 | val default : 'a -> 'a option -> 'a 53 | 54 | val with_tmpdir : 55 | ?prefix:string -> ?mode:Unix.file_perm -> (string -> 'a Lwt.t) -> 'a Lwt.t 56 | 57 | val ls : string -> string list Lwt.t 58 | 59 | val with_switch : (Lwt_switch.t -> 'a Lwt.t) -> 'a Lwt.t 60 | 61 | val cancel_when_off : Lwt_switch.t -> (unit -> 'a Lwt.t) -> 'a Lwt.t 62 | 63 | val opt_get : (unit -> 'a) -> 'a option -> 'a 64 | -------------------------------------------------------------------------------- /ci/src/cI_web.mli: -------------------------------------------------------------------------------- 1 | open Datakit_github 2 | 3 | val routes : 4 | logs:CI_live_log.manager -> 5 | ci:CI_engine.t -> 6 | server:CI_web_utils.server -> 7 | dashboards:CI_target.Set.t Repo.Map.t -> 8 | (string * (unit -> Cohttp_lwt.Body.t CI_web_utils.Wm.resource)) list 9 | (** [routes ~config ~logs ~ci ~auth ~dashboards] is the configuration for a web-server providing a UI to [ci]. *) 10 | -------------------------------------------------------------------------------- /ci/src/cI_web_templates.mli: -------------------------------------------------------------------------------- 1 | open Datakit_github 2 | 3 | (** Generate HTML for the various pages in the UI. *) 4 | 5 | type t = private { 6 | name : string; 7 | state_repo : Uri.t option; 8 | metrics_token : [ `SHA256 of Cstruct.t ] option; 9 | listen_addr : [ `HTTP of int | `HTTPS of int ]; 10 | github_scopes_needed : Github_t.scope list; 11 | can_read : CI_ACL.t; 12 | can_build : CI_ACL.t; 13 | } 14 | 15 | val config : 16 | ?name:string -> 17 | ?state_repo:Uri.t -> 18 | ?metrics_token:[ `SHA256 of string ] -> 19 | ?listen_addr:[ `HTTP of int | `HTTPS of int ] -> 20 | ?github_scopes_needed:Github_t.scope list -> 21 | can_read:CI_ACL.t -> 22 | can_build:CI_ACL.t -> 23 | unit -> 24 | t 25 | (** [config ~name ~state_repo ()] is a web configuration. 26 | If [name] is given, it is used as the main heading, and also as the name of the session cookie 27 | (useful if you run multiple CIs on the same host, on different ports). 28 | If [state_repo] is given, it is used to construct links to the state repository on GitHub. *) 29 | 30 | type page = user:string option -> [ `Html ] Tyxml.Html.elt 31 | 32 | module Error : sig 33 | type t 34 | 35 | val permission_denied : t 36 | 37 | val logout_needed : t 38 | 39 | val uri_path : t -> string 40 | (** Path to redirect users to to see this error. *) 41 | 42 | val uri : t -> Uri.t 43 | (** [uri t] is [Uri.of_string (uri_path t)] *) 44 | end 45 | 46 | val login_page : 47 | ?github:Uri.t -> 48 | csrf_token:string -> 49 | CI_form.State.t -> 50 | is_configured:bool -> 51 | t -> 52 | page 53 | 54 | val auth_setup : csrf_token:string -> CI_form.State.t -> t -> page 55 | 56 | val user_page : csrf_token:string -> t -> page 57 | 58 | val main_page : 59 | csrf_token:string -> 60 | ci:CI_engine.t -> 61 | dashboards:CI_target.Set.t Repo.Map.t -> 62 | t -> 63 | page 64 | 65 | val prs_page : ci:CI_engine.t -> t -> page 66 | 67 | val branches_page : ci:CI_engine.t -> t -> page 68 | 69 | val tags_page : ci:CI_engine.t -> t -> page 70 | 71 | val commit_page : 72 | ?test:string -> 73 | commit:string -> 74 | archived_targets:(CI_target.t * CI_utils.DK.Commit.t) list -> 75 | CI_target.t list -> 76 | t -> 77 | page 78 | 79 | val target_page : 80 | ?test:string -> 81 | csrf_token:string -> 82 | ?title:string -> 83 | target:CI_target.t -> 84 | CI_history.State.t -> 85 | t -> 86 | page 87 | 88 | val live_log_frame : branch:string -> have_history:bool -> t -> page 89 | 90 | val saved_log_frame : commit:string -> branch:string -> t -> page 91 | 92 | val plain_error : string -> t -> page 93 | (** A basic page just the error text and no header, footer, etc. *) 94 | 95 | val error_page : string -> t -> page 96 | 97 | module Settings : sig 98 | val index : t -> page 99 | 100 | val github_auth : csrf_token:string -> CI_form.State.t -> t -> page 101 | end 102 | 103 | val saved_log_frame_link : branch:string -> commit:string -> string 104 | (** [saved_log_frame_link ~branch ~commit] is the path component of the iframe link for the given saved log. *) 105 | -------------------------------------------------------------------------------- /ci/src/datakit_ci.ml: -------------------------------------------------------------------------------- 1 | open Datakit_github 2 | module Output = CI_output 3 | 4 | (* FIXME: we should probably make that type abstract *) 5 | type 'a status = 'a CI_s.status = { 6 | result : 7 | ('a, [ `Pending of string * unit Lwt.t | `Failure of string ]) result; 8 | output : Output.logs; 9 | } 10 | 11 | type job_id = CI_s.job_id 12 | 13 | module Term = CI_term 14 | include CI_main 15 | module Utils = CI_utils 16 | module Process = CI_process 17 | module Live_log = CI_live_log 18 | module Monitored_pool = CI_monitored_pool 19 | module Cache = CI_cache 20 | 21 | module type BUILDER = CI_s.BUILDER 22 | 23 | module DK = Utils.DK 24 | module ACL = CI_ACL 25 | module Target = CI_target 26 | module Git = CI_git 27 | module Docker = CI_docker 28 | 29 | module Web = struct 30 | type config = CI_web_templates.t 31 | 32 | let config = CI_web_templates.config 33 | end 34 | 35 | module Private = struct 36 | module Client9p = Utils.Client9p 37 | 38 | type engine = CI_engine.t 39 | 40 | let connect = DK.connect 41 | 42 | let test_engine ~web_ui conn = CI_engine.create ~web_ui conn 43 | 44 | let listen = CI_engine.listen 45 | 46 | let create_logs = CI_live_log.create_manager 47 | 48 | let lookup_log = CI_live_log.lookup 49 | 50 | let cancel = CI_live_log.cancel 51 | 52 | let read_log = CI_cache.read_log 53 | 54 | let rebuild saved = 55 | match saved.Output.rebuild with 56 | | `Rebuildable x -> Lazy.force x 57 | | _ -> assert false 58 | end 59 | 60 | module Config = struct 61 | type t = CI_config.t 62 | 63 | type project = Repo.t * CI_config.project 64 | 65 | type test = CI_config.test 66 | 67 | let project = CI_config.project 68 | 69 | let v = CI_config.v 70 | end 71 | -------------------------------------------------------------------------------- /ci/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name datakit_ci) 3 | (public_name datakit-ci) 4 | (wrapped false) 5 | (libraries datakit-github datakit-client datakit-client-9p yojson cmdliner 6 | tyxml multipart-form-data prometheus-app.unix webmachine redis-lwt session 7 | pbkdf github protocol-9p-unix logs.cli session-redis-lwt cstruct-sexp 8 | session-webmachine github-unix fmt.cli fmt.tty uri-sexp) 9 | (preprocess 10 | (per_module 11 | ((pps ppx_sexp_conv) 12 | cI_secrets 13 | cI_web_utils)))) 14 | 15 | (rule 16 | (targets cI_static.ml) 17 | (deps 18 | (source_tree ../static/)) 19 | (action 20 | (run ocaml-crunch --mode=plain -o %{targets} ../static))) 21 | -------------------------------------------------------------------------------- /ci/static/css/style.css: -------------------------------------------------------------------------------- 1 | body { 2 | padding-top: 50px; 3 | } 4 | .content { 5 | padding: 40px 15px; 6 | } 7 | 8 | button span { 9 | padding-right: 4px; 10 | } 11 | 12 | span.glyphicon { 13 | padding-right: 2px; 14 | } 15 | 16 | .log { 17 | background: #000; 18 | color: #fff; 19 | } 20 | 21 | .dashboard { 22 | margin-bottom: 20px; 23 | } 24 | 25 | .dashboard #title { 26 | margin-bottom: 40px; 27 | } 28 | 29 | .dashboard #status { 30 | margin-top: 0px; 31 | margin-bottom: 40px; 32 | } 33 | 34 | .dashboard #icon { 35 | margin-bottom: 0px; 36 | } 37 | 38 | .dashboard-pending { 39 | background: #f0ad4e 40 | } 41 | 42 | .dashboard-success { 43 | background: #5cb85c; 44 | color: #fff 45 | } 46 | 47 | .dashboard-error { 48 | background: #d9534f 49 | } 50 | 51 | .dashboard-failure { 52 | background: #d9534f; 53 | color: #fff 54 | } 55 | 56 | form.cancel { 57 | display: inline; 58 | padding-right: 1em; 59 | } 60 | 61 | iframe.log { 62 | width: 100%; 63 | flex-grow: 40; 64 | overflow: auto; 65 | border: 0; 66 | } 67 | 68 | body.split-page { 69 | padding: 0; 70 | overflow: hidden; 71 | display: flex; 72 | flex-direction: column; 73 | height: 100vh; 74 | } 75 | 76 | body.log { 77 | padding: 1em; 78 | color: black; 79 | background: white; 80 | } 81 | 82 | div.upper { 83 | flex-grow: 60; 84 | width: 100%; 85 | border-bottom: 1px solid #ccc; 86 | overflow: auto; 87 | height: 1em; 88 | } 89 | 90 | body.split-page nav.navbar-fixed-top { 91 | position: static; 92 | flex-grow: 0; 93 | margin-bottom: 0; 94 | } 95 | 96 | button.rebuild { 97 | margin-right: 0.5em; 98 | } 99 | 100 | button.failed { 101 | color: white; 102 | background: red; 103 | } 104 | 105 | table.results { 106 | margin-bottom: 0; 107 | } 108 | 109 | a.selected-log { 110 | background: yellow; 111 | } 112 | 113 | tr.selected-job { 114 | background: #ffffd0; 115 | } 116 | 117 | span.status { 118 | border: 1px solid black; 119 | padding: 1px; 120 | } 121 | 122 | table.results span.status { 123 | margin-right: 8px; 124 | } 125 | 126 | div.github-auth { 127 | max-width: 40em; 128 | } 129 | 130 | pre span.bold { 131 | font-weight: bold; 132 | } 133 | 134 | body.log pre { 135 | color: rgb(229, 229, 229); 136 | background: black; 137 | } 138 | 139 | pre span.fg-black { color: rgb(0, 0, 0) } 140 | pre span.fg-red { color: rgb(205, 0, 0) } 141 | pre span.fg-green { color: rgb(0, 205, 0) } 142 | pre span.fg-yellow { color: rgb(205, 205, 0) } 143 | pre span.fg-blue { color: rgb(0, 0, 238) } 144 | pre span.fg-magenta { color: rgb(205, 0, 205) } 145 | pre span.fg-cyan { color: rgb(0, 205, 205) } 146 | pre span.fg-white { color: rgb(229, 229, 229) } 147 | 148 | pre span.fg-bright-black { color: rgb(127, 127, 127) } 149 | pre span.fg-bright-red { color: rgb(255, 0, 0) } 150 | pre span.fg-bright-green { color: rgb(0, 255, 0) } 151 | pre span.fg-bright-yellow { color: rgb(255, 255, 0) } 152 | pre span.fg-bright-blue { color: rgb(92, 92, 255) } 153 | pre span.fg-bright-magenta { color: rgb(255, 0, 255) } 154 | pre span.fg-bright-cyan { color: rgb(0, 255, 255) } 155 | pre span.fg-bright-white { color: rgb(255, 255, 255) } 156 | 157 | pre span.bg-black { background: rgb(0, 0, 0) } 158 | pre span.bg-red { background: rgb(205, 0, 0) } 159 | pre span.bg-green { background: rgb(0, 205, 0) } 160 | pre span.bg-yellow { background: rgb(205, 205, 0) } 161 | pre span.bg-blue { background: rgb(0, 0, 238) } 162 | pre span.bg-magenta { background: rgb(205, 0, 205) } 163 | pre span.bg-cyan { background: rgb(0, 205, 205) } 164 | pre span.bg-white { background: rgb(229, 229, 229) } 165 | 166 | pre span.bg-bright-black { background: rgb(127, 127, 127) } 167 | pre span.bg-bright-red { background: rgb(255, 0, 0) } 168 | pre span.bg-bright-green { background: rgb(0, 255, 0) } 169 | pre span.bg-bright-yellow { background: rgb(255, 255, 0) } 170 | pre span.bg-bright-blue { background: rgb(92, 92, 255) } 171 | pre span.bg-bright-magenta { background: rgb(255, 0, 255) } 172 | pre span.bg-bright-cyan { background: rgb(0, 255, 255) } 173 | pre span.bg-bright-white { background: rgb(255, 255, 255) } 174 | -------------------------------------------------------------------------------- /ci/static/fonts/glyphicons-halflings-regular.eot: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/moby/datakit/e047e55a2dfa3aaec02398d7d7699f4f7afd2b47/ci/static/fonts/glyphicons-halflings-regular.eot -------------------------------------------------------------------------------- /ci/static/fonts/glyphicons-halflings-regular.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/moby/datakit/e047e55a2dfa3aaec02398d7d7699f4f7afd2b47/ci/static/fonts/glyphicons-halflings-regular.ttf -------------------------------------------------------------------------------- /ci/static/fonts/glyphicons-halflings-regular.woff: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/moby/datakit/e047e55a2dfa3aaec02398d7d7699f4f7afd2b47/ci/static/fonts/glyphicons-halflings-regular.woff -------------------------------------------------------------------------------- /ci/static/fonts/glyphicons-halflings-regular.woff2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/moby/datakit/e047e55a2dfa3aaec02398d7d7699f4f7afd2b47/ci/static/fonts/glyphicons-halflings-regular.woff2 -------------------------------------------------------------------------------- /ci/static/images/favicon.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/moby/datakit/e047e55a2dfa3aaec02398d7d7699f4f7afd2b47/ci/static/images/favicon.png -------------------------------------------------------------------------------- /ci/static/js/ci.js: -------------------------------------------------------------------------------- 1 | function highlight_log() { 2 | var current = document.getElementById('iframe_log').contentWindow.location.href; 3 | console.debug("current:" + current); 4 | var elements = document.getElementsByClassName('log-link'); 5 | for (x = 0; x < elements.length; x++) { 6 | if (elements[x].href == current) { 7 | console.debug("set:" + elements[x]); 8 | elements[x].className = "selected-log log-link" 9 | } else { 10 | console.debug("unset:" + elements[x]); 11 | elements[x].className = "log-link" 12 | } 13 | } 14 | } 15 | -------------------------------------------------------------------------------- /ci/tests/_tags: -------------------------------------------------------------------------------- 1 | true: package(irmin, git, datakit.ivfs, datakit-server.fs9p, irmin-git, irmin-unix, irmin, alcotest, str) 2 | true: thread 3 | -------------------------------------------------------------------------------- /ci/tests/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test_ci) 3 | (libraries datakit-github datakit-ci datakit-server-9p alcotest datakit_io 4 | datakit irmin-git)) 5 | 6 | (alias 7 | (name runtest) 8 | (deps test_ci.exe) 9 | (action 10 | (run %{exe:test_ci.exe} -q --color=always))) 11 | -------------------------------------------------------------------------------- /ci/tests/exampleCI.ml: -------------------------------------------------------------------------------- 1 | ../skeleton/exampleCI.ml -------------------------------------------------------------------------------- /ci/tests/test_ci.mli: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /datakit-bridge-github.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "thomas@gazagnaire.org" 3 | authors: [ 4 | "Thomas Leonard" "Magnus Skjegstad" "David Scott" "Thomas Gazagnaire" 5 | ] 6 | license: "Apache" 7 | homepage: "https://github.com/moby/datakit" 8 | doc: "https://docker.github.io/datakit/" 9 | bug-reports: "https://github.com/moby/datakit/issues" 10 | depends: [ 11 | "ocaml" 12 | "dune" {build} 13 | "cmdliner" 14 | "lwt" {>= "3.0.0"} 15 | "datakit-github" {>= "0.12.0"} 16 | "datakit-client" {>= "0.12.0"} 17 | "datakit-client-9p" {>= "0.12.0"} 18 | "datakit-client-git" {>= "0.12.0"} 19 | "logs" 20 | "fmt" 21 | "mtime" {>= "1.0.0"} 22 | "asl" 23 | "win-eventlog" 24 | "uri" {>= "2.0.0"} 25 | "hvsock" {>= "0.8.1"} 26 | "hex" 27 | "nocrypto" 28 | "prometheus-app" 29 | "protocol-9p-unix" {>= "0.11.0"} 30 | "github-hooks-unix" {>= "0.2.0"} 31 | "github" {>= "2.1.0"} 32 | "alcotest" {with-test} 33 | "datakit" {with-test & >= "0.12.0"} 34 | ] 35 | build: [ 36 | ["dune" "build" "-p" name "-j" jobs] 37 | ["dune" "runtest" "tests/%{name}%"] {with-test} 38 | ] 39 | dev-repo: "git+https://github.com/moby/datakit.git" 40 | synopsis: "A bidirectional bridge between the GitHub API and Datakit" 41 | description: """ 42 | The package provides a bi-directional bridge between the GitHub API 43 | and Datakit, so you can talk to the GitHub API using filesystem and 44 | Git-like commands only. The `datakit-github` programs can start a 45 | webhook server to listen for GitHub events in real time, and project 46 | it into a Git repository. It also monitors that Git repository for 47 | user-provided changes, and translate them into GitHub API calls. 48 | """ 49 | -------------------------------------------------------------------------------- /datakit-bridge-local-git.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "thomas.leonard@docker.com" 3 | authors: "Thomas Leonard" 4 | license: "Apache" 5 | homepage: "https://github.com/moby/datakit" 6 | doc: "https://docker.github.io/datakit/" 7 | bug-reports: "https://github.com/moby/datakit/issues" 8 | depends: [ 9 | "ocaml" 10 | "dune" {build} 11 | "cmdliner" 12 | "irmin-watcher" 13 | "irmin" {>= "1.2.0"} 14 | "irmin-unix" {>= "1.2.0"} 15 | "lwt" {>= "3.0.0"} 16 | "logs" 17 | "fmt" 18 | "protocol-9p-unix" {>= "0.11.0"} 19 | "datakit-client" {>= "0.12.0"} 20 | "datakit-client-9p" {>= "0.12.0"} 21 | "datakit-github" {>= "0.12.0"} 22 | ] 23 | build: ["dune" "build" "-p" name "-j" jobs] 24 | dev-repo: "git+https://github.com/moby/datakit.git" 25 | synopsis: "DataKit Local-Git bridge" 26 | description: """ 27 | This service is a drop-in replacement for the DataKit-GitHub bridge 28 | that instead just monitors a local Git repository. It is useful for 29 | testing a new DataKitCI configuration without having to configure 30 | GitHub integration first. 31 | 32 | The local bridge monitors the state of one or more local Git 33 | repositories, writing the current head of each branch to 34 | DataKit. DataKitCI can be configured to run the CI tests against the 35 | project each time a commit is made. 36 | 37 | Once you are happy with the way the CI is working, you can replace 38 | this service with the GitHub bridge service to have the CI test a 39 | project hosted on GitHub instead. 40 | 41 | Unlike the GitHub bridge, this service: 42 | 43 | - only reports on branches, not tags or pull requests; 44 | - does not report build statuses from other CI systems; and 45 | - does not push the statuses set by the CI anywhere. 46 | """ 47 | -------------------------------------------------------------------------------- /datakit-ci.descr: -------------------------------------------------------------------------------- 1 | Continuous Integration service using DataKit 2 | 3 | DataKitCI is a continuous integration service that monitors your 4 | GitHub project and tests each branch, tag and pull request. It 5 | displays the test results as status indicators in the GitHub UI. It 6 | keeps all of its state and logs in DataKit, rather than a traditional 7 | relational database, allowing review with the usual Git tools. 8 | -------------------------------------------------------------------------------- /datakit-ci.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "thomas@gazagnaire.org" 3 | authors: [ 4 | "Thomas© Leonard" "Anil Madhavapeddy" "Dave Tucker" "Thomas Gazagnaire" 5 | ] 6 | license: "Apache" 7 | homepage: "https://github.com/moby/datakit" 8 | doc: "https://docker.github.io/datakit/" 9 | bug-reports: "https://github.com/moby/datakit/issues" 10 | depends: [ 11 | "ocaml" {>= "4.03.0"} 12 | "dune" {build} 13 | "multipart-form-data" 14 | "datakit-client" {>= "0.12.0"} 15 | "datakit-client-9p" {>= "0.12.0"} 16 | "datakit-github" {>= "0.12.0"} 17 | "protocol-9p-unix" {>= "0.11.0"} 18 | "astring" 19 | "cmdliner" 20 | "fmt" 21 | "cstruct" {>="4.0.0"} 22 | "cstruct-sexp" 23 | "logs" 24 | "tyxml" {>= "4.0.0"} 25 | "tls" {>= "0.9.0"} 26 | "conduit-lwt-unix" {>= "1.0.0"} 27 | "io-page" 28 | "pbkdf" 29 | "webmachine" {>= "0.4.0"} 30 | "session-redis-lwt" {>= "0.4.0"} 31 | "session-webmachine" {>= "0.4.0"} 32 | "redis-lwt" 33 | "asetmap" 34 | "github-unix" {>= "3.0.0"} 35 | "prometheus-app" 36 | "lwt" {>= "3.0.0"} 37 | "ppx_sexp_conv" {build & >="v0.9.0"} 38 | "crunch" {build} 39 | "datakit" {with-test & >= "0.12.0"} 40 | "irmin-unix" {with-test & >= "1.2.0"} 41 | "alcotest" {with-test} 42 | "cohttp-lwt-unix" {>= "1.0.0"} 43 | "base64" {>="3.1.0"} 44 | "uri" {>="3.0.0"} 45 | "yojson" {>="1.7.0"} 46 | ] 47 | build: [ 48 | ["dune" "build" "-p" name "-j" jobs] 49 | ["dune" "runtest" "ci/tests"] {with-test} 50 | ] 51 | dev-repo: "git+https://github.com/moby/datakit.git" 52 | synopsis: "Continuous Integration service using DataKit" 53 | description: """ 54 | DataKitCI is a continuous integration service that monitors your 55 | GitHub project and tests each branch, tag and pull request. It 56 | displays the test results as status indicators in the GitHub UI. It 57 | keeps all of its state and logs in DataKit, rather than a traditional 58 | relational database, allowing review with the usual Git tools. 59 | """ 60 | -------------------------------------------------------------------------------- /datakit-client-9p.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "thomas@gazagnaire.org" 3 | authors: [ 4 | "Thomas Leonard" "Magnus Skjegstad" "David Scott" "Thomas Gazagnaire" 5 | ] 6 | license: "Apache" 7 | homepage: "https://github.com/moby/datakit" 8 | doc: "https://docker.github.io/datakit/" 9 | bug-reports: "https://github.com/moby/datakit/issues" 10 | depends: [ 11 | "ocaml" 12 | "dune" {build} 13 | "astring" 14 | "logs" 15 | "fmt" 16 | "cstruct" {> "2.2.0"} 17 | "datakit-client" {>= "0.12.0"} 18 | "protocol-9p-unix" {>= "0.11.0"} 19 | "cmdliner" 20 | ] 21 | build: ["dune" "build" "-p" name "-j" jobs] 22 | dev-repo: "git+https://github.com/moby/datakit.git" 23 | synopsis: "A library for Datakit clients over 9P" 24 | description: """ 25 | Connect to DataKit clients using the 9P filesystem protocol. 26 | """ 27 | -------------------------------------------------------------------------------- /datakit-client-git.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "thomas@gazagnaire.org" 3 | authors: [ 4 | "Thomas Leonard" "Magnus Skjegstad" "David Scott" "Thomas Gazagnaire" 5 | ] 6 | license: "Apache" 7 | homepage: "https://github.com/moby/datakit" 8 | doc: "https://docker.github.io/datakit/" 9 | bug-reports: "https://github.com/moby/datakit/issues" 10 | depends: [ 11 | "ocaml" 12 | "dune" {build} 13 | "datakit-client" {>= "0.12.0"} 14 | "irmin-git" {>= "1.2.0"} 15 | "irmin-watcher" 16 | "git-unix" 17 | "alcotest" {with-test} 18 | "irmin-mem" {with-test} 19 | "irmin-git" {with-test} 20 | ] 21 | build: [ 22 | ["dune" "build" "-p" name "-j" jobs] 23 | ["dune" "runtest" "tests/datakit-git"] {with-test} 24 | ] 25 | dev-repo: "git+https://github.com/moby/datakit.git" 26 | synopsis: "A library for connecting Datakit client using Git" 27 | description: """ 28 | This library allows for creating DataKit clients that 29 | use the Git protocol for communication. 30 | """ 31 | -------------------------------------------------------------------------------- /datakit-client.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "thomas@gazagnaire.org" 3 | authors: [ 4 | "Thomas Leonard" "Magnus Skjegstad" "David Scott" "Thomas Gazagnaire" 5 | ] 6 | license: "Apache" 7 | homepage: "https://github.com/moby/datakit" 8 | doc: "https://docker.github.io/datakit/" 9 | bug-reports: "https://github.com/moby/datakit/issues" 10 | depends: [ 11 | "ocaml" 12 | "dune" {build} 13 | "astring" 14 | "result" 15 | "fmt" 16 | "lwt" 17 | "cstruct" {> "2.2.0"} 18 | ] 19 | build: ["dune" "build" "-p" name "-j" jobs] 20 | dev-repo: "git+https://github.com/moby/datakit.git" 21 | synopsis: "A library to construct Datakit clients" 22 | description: """ 23 | The library currently only provides only a 9p client to talk to 24 | Datakit, but other filesystem protocols will be available in the 25 | future. 26 | """ 27 | -------------------------------------------------------------------------------- /datakit-github.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "thomas@gazagnaire.org" 3 | authors: [ 4 | "Thomas Leonard" "Magnus Skjegstad" "David Scott" "Thomas Gazagnaire" 5 | ] 6 | license: "Apache" 7 | homepage: "https://github.com/moby/datakit" 8 | doc: "https://docker.github.io/datakit/" 9 | bug-reports: "https://github.com/moby/datakit/issues" 10 | depends: [ 11 | "ocaml" 12 | "dune" {build} 13 | "cmdliner" 14 | "lwt" {>= "3.0.0"} 15 | "uri" {>= "1.8.0"} 16 | "asetmap" 17 | "logs" 18 | "fmt" 19 | "result" 20 | "datakit-client-9p" {>= "0.12.0"} 21 | "datakit-client-git" {>= "0.12.0"} 22 | ] 23 | build: ["dune" "build" "-p" name "-j" jobs] 24 | dev-repo: "git+https://github.com/moby/datakit.git" 25 | synopsis: "Abstraction of the GitHub API, suitable for DataKit clients" 26 | description: """ 27 | This library exposes the GitHub REST API over the 28 | DataKit filesystem layer. 29 | """ 30 | -------------------------------------------------------------------------------- /datakit-server-9p.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "thomas@gazagnaire.org" 3 | authors: [ 4 | "Thomas Leonard" "Magnus Skjegstad" "David Scott" "Thomas Gazagnaire" 5 | ] 6 | license: "Apache" 7 | homepage: "https://github.com/moby/datakit" 8 | doc: "https://docker.github.io/datakit/" 9 | bug-reports: "https://github.com/moby/datakit/issues" 10 | depends: [ 11 | "ocaml" 12 | "dune" {build} 13 | "datakit-server" {>= "0.12.0"} 14 | "mirage-flow-lwt" 15 | "protocol-9p" {>= "0.11.0"} 16 | "sexplib" 17 | ] 18 | build: ["dune" "build" "-p" name "-j" jobs] 19 | dev-repo: "git+https://github.com/moby/datakit.git" 20 | synopsis: "Build Datakit servers using the 9P filesystem protocol" 21 | description: """ 22 | This library allows for the construction of DataKit servers 23 | that can be accessed over the 9P filesystem protocol. 24 | """ 25 | -------------------------------------------------------------------------------- /datakit-server.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "thomas@gazagnaire.org" 3 | authors: [ 4 | "Thomas Leonard" "Magnus Skjegstad" "David Scott" "Thomas Gazagnaire" 5 | ] 6 | license: "Apache" 7 | homepage: "https://github.com/moby/datakit" 8 | doc: "https://docker.github.io/datakit/" 9 | bug-reports: "https://github.com/moby/datakit/issues" 10 | depends: [ 11 | "ocaml" 12 | "dune" {build} 13 | "astring" 14 | "logs" 15 | "rresult" 16 | "fmt" 17 | "lwt" {>= "3.0.0"} 18 | "cstruct" {>= "2.2.0"} 19 | ] 20 | build: ["dune" "build" "-p" name "-j" jobs] 21 | dev-repo: "git+https://github.com/moby/datakit.git" 22 | synopsis: "A library to write Datakit servers" 23 | description: """ 24 | The library exposes a VFS interface, that servers can use to write 25 | introspection libraries -- for instance to expose runtime parameters 26 | over 9p. The library does not depend on Irmin so is relatively 27 | lightweight to embed in any application. 28 | """ 29 | -------------------------------------------------------------------------------- /datakit.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "thomas@gazagnaire.org" 3 | authors: [ 4 | "Thomas Leonard" "Magnus Skjegstad" "David Scott" "Thomas Gazagnaire" 5 | ] 6 | license: "Apache" 7 | homepage: "https://github.com/moby/datakit" 8 | doc: "https://docker.github.io/datakit/" 9 | bug-reports: "https://github.com/moby/datakit/issues" 10 | depends: [ 11 | "ocaml" {>= "4.03.0"} 12 | "dune" {build} 13 | "cmdliner" 14 | "rresult" 15 | "astring" 16 | "fmt" 17 | "asetmap" 18 | "git" {>= "1.11.5"} 19 | "uri" {>="2.0.0"} 20 | "irmin" {>="1.4.0"} 21 | "irmin-mem" {>= "1.2.0"} 22 | "irmin-git" {>= "1.2.0"} 23 | "cstruct" {>= "2.2"} 24 | "result" 25 | "lwt" {>= "3.0.0"} 26 | "conduit-lwt-unix" {>= "1.0.0"} 27 | "mirage-flow" 28 | "named-pipe" {>= "0.4.0"} 29 | "hvsock" {>= "0.8.1"} 30 | "logs" {>= "0.5.0"} 31 | "win-eventlog" 32 | "asl" {>= "0.10"} 33 | "mtime" {>= "1.0.0"} 34 | "irmin-watcher" {>= "0.2.0"} 35 | "prometheus-app" 36 | "protocol-9p-unix" {>= "0.11.0"} 37 | "datakit-server-9p" {>= "0.12.0"} 38 | "datakit-client-9p" {with-test & >= "0.12.0"} 39 | "alcotest" {with-test & >= "0.8.0"} 40 | ] 41 | build: [ 42 | ["dune" "build" "-p" name "-j" jobs] 43 | ["dune" "runtest" "tests/datakit"] {with-test} 44 | ["dune" "runtest" "tests/datakit-9p"] {with-test} 45 | ] 46 | dev-repo: "git+https://github.com/moby/datakit.git" 47 | synopsis: "Orchestrate applications using a Git-like dataflow" 48 | description: """ 49 | DataKit is a tool to orchestrate applications using a Git-like dataflow. It 50 | revisits the UNIX pipeline concept, with a modern twist: streams of 51 | tree-structured data instead of raw text. DataKit allows you to define complex 52 | build pipelines over version-controlled data. 53 | 54 | DataKit is currently used as the coordination 55 | layer for [HyperKit](http://github.com/docker/hyperkit), the 56 | hypervisor component of 57 | [Docker for Mac and Windows](https://blog.docker.com/2016/03/docker-for-mac-windows-beta/), and 58 | for the DataKitCI continuous integration system. 59 | """ 60 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.0) 2 | (name datakit) 3 | (using fmt 1.1) 4 | -------------------------------------------------------------------------------- /examples/ocaml-client/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | ocamlbuild -use-ocamlfind example.native 3 | 4 | clean: 5 | ocamlbuild -clean 6 | -------------------------------------------------------------------------------- /examples/ocaml-client/_tags: -------------------------------------------------------------------------------- 1 | true: warn(A), strict_sequence, safe_string 2 | true: package(datakit-client protocol-9p.unix) 3 | -------------------------------------------------------------------------------- /examples/ocaml-client/example.ml: -------------------------------------------------------------------------------- 1 | (* Server configuration *) 2 | let server_protocol = "tcp" 3 | 4 | let server_address = "127.0.0.1:5640" 5 | 6 | open Result (* For [Ok] and [Error] on older versions of OCaml *) 7 | 8 | open Lwt.Infix (* For [>>=] *) 9 | 10 | let src = Logs.Src.create "Client9p" ~doc:"9p client" 11 | 12 | module Log9p = (val Logs.src_log src : Logs.LOG) 13 | 14 | module Client9p = Client9p_unix.Make (Log9p) 15 | module DK = Datakit_client_9p.Make (Client9p) 16 | 17 | (* Chain operations together, returning early if we get an error *) 18 | let ( >>*= ) x f = x >>= function Ok x -> f x | Error _ as e -> Lwt.return e 19 | 20 | let p = Datakit_path.of_string_exn 21 | 22 | let root = Datakit_path.empty 23 | 24 | let main () = 25 | (* Connect to 9p server *) 26 | Client9p.connect server_protocol server_address () >>= function 27 | | Error (`Msg x) -> 28 | Fmt.epr "Failed to connect: %s" x; 29 | exit 1 30 | | Ok conn -> ( 31 | (* Wrap it with the DataKit client *) 32 | let dk = DK.connect conn in 33 | (* Make a test branch *) 34 | DK.branch dk "test" >>*= fun test_branch -> 35 | DK.Branch.with_transaction test_branch (fun t -> 36 | let contents = Cstruct.of_string "This is a test" in 37 | DK.Transaction.create_file t (p "README") contents >>*= fun () -> 38 | DK.Transaction.commit t ~message:"My first commit") 39 | >>*= fun () -> 40 | (* See what branches we've got *) 41 | DK.branches dk >>*= fun branches -> 42 | Fmt.pr "Branches: %a@." Fmt.(Dump.list string) branches; 43 | 44 | (* Look at the head commit *) 45 | DK.Branch.head test_branch >>*= function 46 | | None -> failwith "Branch no longer exists!" 47 | | Some head -> 48 | DK.Commit.message head >>*= fun msg -> 49 | Fmt.pr "Head (commit %s) has message: %S@." (DK.Commit.id head) msg; 50 | let tree = DK.Commit.tree head in 51 | DK.Tree.read_dir tree root >>*= fun items -> 52 | Fmt.pr "Items in the root directory: %a@." 53 | Fmt.(Dump.list string) 54 | items; 55 | DK.Tree.read_file tree (p "README") >>*= fun data -> 56 | Fmt.pr "Contents of README: %S@." (Cstruct.to_string data); 57 | Lwt.return (Ok ()) ) 58 | 59 | let () = 60 | match Lwt_main.run (main ()) with 61 | | Ok () -> () 62 | | Error e -> Fmt.epr "Test program failed: %a@." DK.pp_error e 63 | -------------------------------------------------------------------------------- /reports/2017-05-07.md: -------------------------------------------------------------------------------- 1 | 2 | # Weekly DataKit dev report for 2017-05-01 to 2017-05-07 (week 18) 3 | 4 | This report covers weekly developments in the [moby/datakit], [mirage/irmin], [mirage/ocaml-git] and [mirage/ocaml-9p] repositories. 5 | 6 | **TL;DR:** It's been a quiet week after the [previous week's](2017-04-24.md) slew of releases, with mainly packaging fixes and debugging deployments of DataKit CI in [LinuxKit](https://github.com/linuxkit/linuxkit). 7 | 8 | ## PRs merged 9 | 10 | **Build and Packaging:** 11 | - The automated release infrastructure was improved to support Jbuilder ([moby/datakit#543] [@samoht]). 12 | - The GitHub bridge version constraints were fixed to improve OPAM installation ([moby/datakit#544] [@samoht]). 13 | - The test harnesses were also extended to test on OCaml 4.03.0, which is the new minimum supported version of the compiler as of MirageOS 3.0 ([moby/datakit#546] [@samoht]). 14 | 15 | **Functionality improvements:** 16 | - The example 'self-ci' was updated to use the latest release of the GitHub bridge ([moby/datakit#545] [@samoht]). 17 | 18 | ### Ongoing activity 19 | 20 | - [@samoht] updated the development tree to support the latest versions of the 9P and Lwt libraries ([moby/datakit#547] [@samoht]). 21 | - [@djs55] has fixed the linking of the `protocol-9p-unix` subpackage to correctly link against `io-page.unix` ([mirage/ocaml-9p#121] [@djs55]). 22 | - [@talex5] has been debugging a possible regression in the latest releases by investigating why Irmin is reporting all remote branches as having invalid names ([mirage/irmin#440] [@talex5]). 23 | 24 | ## External Links or Blogs 25 | 26 | - Some of the code that powers DataKit is going to be [launched into space](https://twitter.com/avsm/status/860058980676141056)! 27 | - A Slack channel is now available to chat about DataKit over in [#datakit at Docker Community Slack](https://community.docker.com/registrations/groups/4316). 28 | 29 | Other reports in this series can be browsed directly in the repository at [moby/datakit:/reports](https://github.com/moby/datakit/tree/master/reports/). 30 | 31 | [@djs55]: https://github.com/djs55 32 | [@samoht]: https://github.com/samoht 33 | [@talex5]: https://github.com/talex5 34 | [mirage/irmin]: https://github.com/mirage/irmin 35 | [mirage/irmin#440]: https://github.com/mirage/irmin/issues/440 36 | [mirage/ocaml-9p]: https://github.com/mirage/ocaml-9p 37 | [mirage/ocaml-9p#121]: https://github.com/mirage/ocaml-9p/pull/121 38 | [mirage/ocaml-git]: https://github.com/mirage/ocaml-git 39 | [moby/datakit]: https://github.com/moby/datakit 40 | [moby/datakit#543]: https://github.com/moby/datakit/pull/543 41 | [moby/datakit#544]: https://github.com/moby/datakit/pull/544 42 | [moby/datakit#545]: https://github.com/moby/datakit/pull/545 43 | [moby/datakit#546]: https://github.com/moby/datakit/pull/546 44 | [moby/datakit#547]: https://github.com/moby/datakit/pull/547 45 | 46 | -------------------------------------------------------------------------------- /reports/2017-06-04.md: -------------------------------------------------------------------------------- 1 | # Weekly DataKit dev report for 2017-05-29 to 2017-06-04 (week 22) 2 | 3 | This report covers weekly developments in the [datakit] [irmin] [git] [9p] repositories. 4 | 5 | This week saw a significant simplication in how the GitHub bridge is deployed, as it can now run without a server and use a local Git repository directly ([datakit#577] [@talex5] [@samoht]). This in turn simplifies the deployment of DataKit as part of various CI services use it now, such as the [LinuxKit](https://github.com/linuxkit/linuxkit) Moby project. 6 | 7 | The GitHub bridge also adds an an `owner` file to identify the PR creator, which can be used by DataKitCI plugins ([datakit#587] [@samoht]). 8 | 9 | For those getting started with DataKit and Irmin, [@nickbetteridge] started an issue on how to get started ([irmin#450]). 10 | Our GSoC intern [@dudelson] is also active on [irmin#415] about the HTTP REST API ([@dbuenzli] [@dudelson] [@samoht]), and has started 11 | a tracking issue on contributing documentation improvements ([irmin#451]). This is massively appreciated! 12 | 13 | As part of the move to standardise interfaces across Moby components, there is working on adding building GRPC and CaPnP RPC libraries so that DataKit can make use of these. Check in with [@talex5] if you are interested in contributing. 14 | 15 | Releases are now being cut with this functionality, starting with [git:1.11.0]. 16 | 17 | ## PRs this week 18 | 19 | - Git client: fix the `exists*` functions ([datakit#576] [@samoht]) 20 | - Datakit: only the binary is using `datakit_io` ([datakit#582] [datakit#580] [@samoht]) 21 | - Refactor the library to wrap everything under the Datakit namespace ([datakit#583] [@samoht]) 22 | - Simplify the creation of DataKit stores using an Irmin backend ([datakit#584] [@nickbetteridge] [@samoht]) 23 | - Fix ocamldoc ([datakit#585] [@samoht]) 24 | - Various build fixes ([datakit#588] [@talex5]) and jbuilder improvements ([git#218] [@samoht]). 25 | 26 | ## External Links or Blogs 27 | 28 | - ["A quick tour of the Tezos code base, and the state of its development"](https://medium.com/tezos/a-quick-tour-of-the-tezos-code-base-and-the-state-of-its-development-c4e5fcb34b8a) 29 | 30 | Other reports in this series can be browsed directly in the repository at [datakit:/reports](https://github.com/moby/datakit/tree/master/reports/). There is also a [Docker Community Slack channel](https://docs.docker.com/opensource/get-help/) in `#datakit`. 31 | 32 | [@dbuenzli]: https://github.com/dbuenzli 33 | [@dudelson]: https://github.com/dudelson 34 | [@nickbetteridge]: https://github.com/nickbetteridge 35 | [@samoht]: https://github.com/samoht 36 | [@talex5]: https://github.com/talex5 37 | [irmin]: https://github.com/mirage/irmin 38 | [irmin#415]: https://github.com/mirage/irmin/issues/415 39 | [irmin#450]: https://github.com/mirage/irmin/issues/450 40 | [irmin#451]: https://github.com/mirage/irmin/issues/451 41 | [irmin#452]: https://github.com/mirage/irmin/pull/452 42 | [9p]: https://github.com/mirage/ocaml-9p 43 | [git]: https://github.com/mirage/ocaml-git 44 | [git#218]: https://github.com/mirage/ocaml-git/pull/218 45 | [git:1.11.0]: https://github.com/mirage/ocaml-git/releases/tag/1.11.0 46 | [datakit]: https://github.com/moby/datakit 47 | [datakit#576]: https://github.com/moby/datakit/pull/576 48 | [datakit#577]: https://github.com/moby/datakit/pull/577 49 | [datakit#580]: https://github.com/moby/datakit/issues/580 50 | [datakit#582]: https://github.com/moby/datakit/pull/582 51 | [datakit#583]: https://github.com/moby/datakit/pull/583 52 | [datakit#584]: https://github.com/moby/datakit/pull/584 53 | [datakit#585]: https://github.com/moby/datakit/pull/585 54 | [datakit#586]: https://github.com/moby/datakit/issues/586 55 | [datakit#587]: https://github.com/moby/datakit/pull/587 56 | [datakit#588]: https://github.com/moby/datakit/pull/588 57 | 58 | -------------------------------------------------------------------------------- /scripts/check-dylib.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | 3 | set -ue 4 | 5 | REPO_ROOT=$(git rev-parse --show-toplevel) 6 | OUTPUT=${REPO_ROOT}/com.docker.db 7 | 8 | # The output should have 2 lines, e.g.: 9 | # 10 | # Datakit.app/Contents/MacOS/com.docker.db: 11 | # /usr/lib/libSystem.B.dylib (compatibility version 1.0.0, current version 1213.0.0) 12 | 13 | if [ $(otool -L ${OUTPUT} | wc -l | xargs) != "2" ]; then 14 | otool -L ${OUTPUT} 15 | exit 1 16 | fi 17 | -------------------------------------------------------------------------------- /scripts/git-dumb-server: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | open Printf 3 | 4 | let run fmt = 5 | ksprintf (fun cmd -> 6 | printf "+ %s\n%!" cmd; 7 | let i = Sys.command cmd in 8 | if i <> 0 then ( 9 | Printf.eprintf "\027[31mERROR %d\027[0m\n" i; 10 | exit i 11 | ) 12 | ) fmt 13 | 14 | let git_daemon dir = 15 | Sys.chdir dir; 16 | run "git daemon --base-path=. --export-all \ 17 | --enable=receive-pack --reuseaddr \ 18 | --informative-errors --verbose" 19 | 20 | let git_add file = 21 | run "git add %s" file 22 | 23 | let git_commit msg = 24 | let date = "Thu Mar 10 19:25:07 2016 +0000" in 25 | let name = "John Doo" in 26 | let email = "" in 27 | run "export GIT_AUTHOR_DATE=%S; export GIT_COMMITTER_DATE=%S; \ 28 | \ git -c user.name=%S -c user.email=%S commit -a -m %S" 29 | date date name email msg 30 | 31 | let rmdir dir = 32 | run "rm -rf %s" dir 33 | 34 | let mkdir = function 35 | | "" 36 | | "." -> () 37 | | dir -> run "mkdir -p %s" dir 38 | 39 | let cat (file, contents) = 40 | mkdir (Filename.dirname file); 41 | run "echo %S > %s" contents file 42 | 43 | let git_init dir files = 44 | mkdir dir; 45 | let cwd = Sys.getcwd () in 46 | Sys.chdir dir; 47 | run "git init"; 48 | List.iter cat files; 49 | List.iter (fun (file, _) -> 50 | git_add file 51 | ) files; 52 | git_commit "Initial commit"; 53 | Sys.chdir cwd 54 | 55 | let files = 56 | [ "foo", "foo"; 57 | "x/y", "bar"; ] 58 | 59 | let (/) = Filename.concat 60 | let tmp = Filename.temp_dir_name 61 | 62 | let () = 63 | let repo = tmp / "ogit" / "xxx" in 64 | rmdir repo; 65 | git_init repo files; 66 | git_daemon repo 67 | -------------------------------------------------------------------------------- /scripts/start-client.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | 3 | CMD='datakit-mount -h 172.17.0.2 -p 5640 /db && \ 4 | datakit-mount -h 172.17.0.3 -p 5641 /gh && \ 5 | /bin/sh' 6 | 7 | docker run -it --privileged --rm \ 8 | --link datakit --link datakit-gh-bridge \ 9 | --entrypoint /bin/bash datakit -c "${CMD}" 10 | -------------------------------------------------------------------------------- /scripts/start-datakit-gh-bridge.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | 3 | set -exu 4 | 5 | REPO_ROOT=$(git rev-parse --show-toplevel) 6 | DOCKERFILE=Dockerfile.github 7 | NAME=datakit-gh-bridge 8 | ARGS="--listen=tcp://0.0.0.0:5641 -vv --datakit=tcp:192.168.65.1:5640" 9 | 10 | docker build -t ${NAME} -f ${DOCKERFILE} ${REPO_ROOT} 11 | 12 | docker rm -f ${NAME} || echo skip 13 | docker run --name=${NAME} --rm \ 14 | -p 8080:80 -p 5641:5641 \ 15 | -v ${HOME}/.github:/root/.github \ 16 | ${NAME} ${ARGS} 17 | -------------------------------------------------------------------------------- /scripts/start-datakit.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | 3 | set -exu 4 | 5 | REPO_ROOT=$(git rev-parse --show-toplevel) 6 | DOCKERFILE=Dockerfile 7 | NAME=datakit 8 | DATA=/tmp/datakit 9 | ARGS="--url=tcp://0.0.0.0:5640 --git=/data -vv" 10 | 11 | docker build -t ${NAME} -f ${DOCKERFILE} ${REPO_ROOT} 12 | 13 | docker rm -f ${NAME} || echo skip 14 | docker run --name=${NAME} -v ${DATA}:/data -p 5640:5640 --rm ${NAME} ${ARGS} 15 | -------------------------------------------------------------------------------- /scripts/test-pr.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -eux 4 | 5 | REPO=$1 6 | SCRIPT=$2 7 | 8 | while read N; do 9 | echo New PR: ${N}... 10 | PR=/db/github.com/${REPO}/pr/${N} 11 | mkdir -p ${PR}/status/test 12 | echo "My little test" > ${PR}/status/test/descr 13 | echo "http://docker.com" > ${PR}/status/test/url 14 | echo Doing some work... 15 | ${SCRIPT} 16 | echo success > ${PR}/status/test/state 17 | done < /db/github.com/${REPO}/pr/updates 18 | -------------------------------------------------------------------------------- /scripts/watermark.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -eu 4 | 5 | REPO_ROOT=$(git rev-parse --show-toplevel) 6 | 7 | watermark() { 8 | file=$1 9 | path="${REPO_ROOT}/${file}" 10 | tmp="${REPO_ROOT}/${file}.tmp" 11 | cp "$path" "$tmp" 12 | sed -e "s/%%VERSION%%/$(git describe --always --dirty)/g" "$tmp" > "$path" 13 | rm -f "$tmp" 14 | } 15 | 16 | watermark src/version.ml 17 | -------------------------------------------------------------------------------- /src/datakit-conduit/datakit_conduit.mli: -------------------------------------------------------------------------------- 1 | (** Conduit helpers. *) 2 | 3 | type t = 4 | [ `NamedPipe of string 5 | | `Fd of int 6 | | `File of string 7 | | `Tcp of string * int 8 | | `HyperV_connect of Uri.t 9 | | `HyperV_accept of Uri.t ] 10 | (** The type for supported conduit endpoints. *) 11 | 12 | val pp : t Fmt.t 13 | (** [pp] is the pretty-printer for conduit endpoits. *) 14 | 15 | val parse : default_tcp_port:int -> string -> [ `Ok of t | `Error of string ] 16 | (** [parse] parses conduit endpoint descriptions. *) 17 | 18 | val accept_forever : 19 | ?backlog:int -> 20 | serviceid:string -> 21 | make_root:(unit -> Vfs.Dir.t) -> 22 | t -> 23 | unit Lwt.t 24 | (** [accept_forever ~make_root url] starts a server which accepts Unix 25 | \ domain socket, TCP socket, HyperV socket and Named pipes 26 | connections and serves 9p filesystem described by [make_root 27 | ()]. *) 28 | -------------------------------------------------------------------------------- /src/datakit-conduit/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name datakit_conduit) 3 | (wrapped false) 4 | (libraries uri fmt lwt astring protocol-9p-unix hvsock.lwt-unix 5 | datakit-server-9p named-pipe.lwt)) 6 | -------------------------------------------------------------------------------- /src/datakit-github/datakit_github_conv.mli: -------------------------------------------------------------------------------- 1 | (** Efficient conversions between in-memory snapshots and persistent 2 | datakit state. *) 3 | 4 | open Datakit_github 5 | 6 | (** Conversion between GitHub and DataKit states. *) 7 | module Make (DK : Datakit_client.S) : sig 8 | type tree = DK.Tree.t 9 | (** The type for trees. *) 10 | 11 | (** {1 Repositories} *) 12 | 13 | val repos : tree -> Repo.Set.t Lwt.t 14 | (** [repos t] is the list of repositories stored in [t]. *) 15 | 16 | (** {1 Status} *) 17 | 18 | val statuses : ?commits:Commit.Set.t -> tree -> Status.Set.t Lwt.t 19 | (** [statuses t] is the list of status stored in [t]. *) 20 | 21 | (** {1 Pull requests} *) 22 | 23 | val prs : ?repos:Repo.Set.t -> tree -> PR.Set.t Lwt.t 24 | (** [prs t] is the list of pull requests stored in [t]. *) 25 | 26 | (** {1 Git References} *) 27 | 28 | val refs : ?repos:Repo.Set.t -> tree -> Ref.Set.t Lwt.t 29 | (** [refs t] is the list of Git references stored in [t].*) 30 | 31 | (** {1 Elements} *) 32 | 33 | val find : tree -> Elt.id -> Elt.t option Lwt.t 34 | (** [find t id] is the elements with ID [id] in [t]. *) 35 | 36 | val pr : tree -> PR.id -> PR.t option Lwt.t 37 | (** [pr t id] is the pull-request with ID [id]. *) 38 | 39 | val ref : tree -> Ref.id -> Ref.t option Lwt.t 40 | (** [ref t id] is the Git reference with ID [id]. *) 41 | 42 | val status : tree -> Status.id -> Status.t option Lwt.t 43 | (** [status t id] is the build status with ID [id]. *) 44 | 45 | (** {1 Updates} *) 46 | 47 | val update_elt : DK.Transaction.t -> Elt.t -> unit Lwt.t 48 | (** [update_elt t e] updates the element [e] in the transaction 49 | [t]. *) 50 | 51 | val remove_elt : DK.Transaction.t -> Elt.id -> unit Lwt.t 52 | (** [remove_elt t e] removes the element [e] in the transaction 53 | [t]. *) 54 | 55 | val update_event : DK.Transaction.t -> Event.t -> unit Lwt.t 56 | (** [update_event t e] applies the (webhook) event [e] to the 57 | transaction [t]. *) 58 | 59 | (** {1 Dirty} *) 60 | 61 | type dirty = Elt.IdSet.t 62 | (** The type for dirty elements. *) 63 | 64 | type t 65 | (** The type for filesystem snapshots. *) 66 | 67 | val stain : DK.Transaction.t -> dirty -> unit Lwt.t 68 | (** [stain tr d] makes all the elements in [d] dirty. *) 69 | 70 | val clean : DK.Transaction.t -> dirty -> unit Lwt.t 71 | (** [clean t d] removes [d] from the list of dirty elements in 72 | [t]. *) 73 | 74 | val dirty : t -> dirty 75 | (** [dirty t] is the collection of dirty elements in [t]. *) 76 | 77 | (** {1 Snapshots and diffs} *) 78 | 79 | val snapshot : t -> Snapshot.t 80 | (** [snapshot t] is [t]'s in-memory snapshot. *) 81 | 82 | val head : t -> DK.Commit.t 83 | (** [head t] is [t]'s head. *) 84 | 85 | val pp : t Fmt.t 86 | (** [pp] is the pretty-printer for {!snapshot} values. *) 87 | 88 | val diff : DK.Commit.t -> DK.Commit.t -> (Diff.t * dirty) Lwt.t 89 | (** [diff x y] computes the difference between the commits [x] and 90 | [y]. *) 91 | 92 | val of_branch : 93 | debug:string -> ?old:t -> DK.Branch.t -> (DK.Transaction.t * t) Lwt.t 94 | (** [snapshot dbg ?old b] is a pair [(t, s)] where [s] is a snapshot 95 | of the branch [b] and a [t] is a transaction started on [s]'s 96 | commit. Note: this is expensive, so try to provide a (recent) 97 | [old] snapshot if possible. In that case, the difference between 98 | the two snapshot's commits will be computed and only the minimal 99 | number of filesystem access will be performed to compute the new 100 | snapshot by updating the old one. *) 101 | 102 | val of_commit : debug:string -> ?old:t -> DK.Commit.t -> t Lwt.t 103 | (** Same as {!of_branch} but does not allow to update the underlying 104 | store. *) 105 | 106 | val apply : debug:string -> Diff.t -> DK.Transaction.t -> bool Lwt.t 107 | (** [apply d t] applies the snapshot diff [d] into the datakit 108 | transaction [t]. Returns [true] iff the undelying datakit state 109 | has changed. *) 110 | end 111 | -------------------------------------------------------------------------------- /src/datakit-github/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name datakit_github) 3 | (public_name datakit-github) 4 | (wrapped false) 5 | (libraries fmt asetmap uri lwt astring logs datakit-client)) 6 | -------------------------------------------------------------------------------- /src/datakit-io/datakit_io.mli: -------------------------------------------------------------------------------- 1 | module IO : Irmin_git.IO 2 | 3 | module FS : Git.FS.IO 4 | -------------------------------------------------------------------------------- /src/datakit-io/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name datakit_io) 3 | (wrapped false) 4 | (libraries irmin-git conduit-lwt-unix)) 5 | -------------------------------------------------------------------------------- /src/datakit-log/datakit_log.ml: -------------------------------------------------------------------------------- 1 | open Cmdliner 2 | 3 | module Metrics = struct 4 | open Prometheus 5 | 6 | let namespace = "ocaml" 7 | 8 | let subsystem = "logs" 9 | 10 | let inc_messages = 11 | let help = "Total number of messages logged" in 12 | let c = 13 | Counter.v_labels ~label_names:[ "level"; "src" ] ~help ~namespace 14 | ~subsystem "messages_total" 15 | in 16 | fun lvl src -> 17 | let lvl = Logs.level_to_string (Some lvl) in 18 | Counter.inc_one @@ Counter.labels c [ lvl; src ] 19 | end 20 | 21 | type t = Quiet | Timestamp | Eventlog | ASL 22 | 23 | let mk = 24 | Arg.enum 25 | [ ("quiet", Quiet); 26 | ("timestamp", Timestamp); 27 | ("eventlog", Eventlog); 28 | ("asl", ASL) 29 | ] 30 | 31 | let pp_ptime f () = 32 | let open Unix in 33 | let tm = Unix.localtime (Unix.time ()) in 34 | Fmt.pf f "%04d-%02d-%02d %02d:%02d" (tm.tm_year + 1900) (tm.tm_mon + 1) 35 | tm.tm_mday tm.tm_hour tm.tm_min 36 | 37 | let pp_mtime f () = 38 | let dt = Mtime.Span.to_us (Mtime_clock.elapsed ()) in 39 | Fmt.pf f "%+04.0fus" dt 40 | 41 | let reporter log_clock = 42 | let pp_time = 43 | match log_clock with `Posix -> pp_ptime | `Monotonic -> pp_mtime 44 | in 45 | let report src level ~over k msgf = 46 | let k _ = 47 | over (); 48 | k () 49 | in 50 | let ppf = match level with Logs.App -> Fmt.stdout | _ -> Fmt.stderr in 51 | let src = Logs.Src.name src in 52 | let with_stamp h _tags k fmt = 53 | Fmt.kpf k ppf 54 | ("\r%a %a %a @[" ^^ fmt ^^ "@]@.") 55 | pp_time () 56 | Fmt.(styled `Magenta string) 57 | (Printf.sprintf "%10s" src) 58 | Logs_fmt.pp_header (level, h) 59 | in 60 | msgf @@ fun ?header ?tags fmt -> 61 | Metrics.inc_messages level src; 62 | with_stamp header tags k fmt 63 | in 64 | { Logs.report } 65 | 66 | let setup style_renderer log_destination level log_clock = 67 | Logs.set_level level; 68 | match log_destination with 69 | | Quiet -> Logs.set_reporter (Logs_fmt.reporter ()) 70 | | Eventlog -> 71 | let eventlog = Eventlog.register "Docker.exe" in 72 | Logs.set_reporter (Log_eventlog.reporter ~eventlog ()) 73 | | Timestamp -> 74 | Fmt_tty.setup_std_outputs ?style_renderer (); 75 | Logs.set_reporter (reporter log_clock) 76 | | ASL -> 77 | let facility = Filename.basename Sys.executable_name in 78 | let client = Asl.Client.create ~ident:"Docker" ~facility () in 79 | Logs.set_reporter (Log_asl.reporter ~client ()) 80 | 81 | let docs = "LOG OPTIONS" 82 | 83 | let log_destination = 84 | let doc = 85 | Arg.info ~docs ~doc:"Destination for the logs" [ "log-destination" ] 86 | in 87 | Arg.(value & opt mk Quiet & doc) 88 | 89 | let log_clock = 90 | let doc = Arg.info ~docs ~doc:"Kind of clock" [ "log-clock" ] in 91 | Arg.( 92 | value 93 | & opt (enum [ ("monotonic", `Monotonic); ("posix", `Posix) ]) `Posix doc) 94 | -------------------------------------------------------------------------------- /src/datakit-log/datakit_log.mli: -------------------------------------------------------------------------------- 1 | (** Datakit loggers. *) 2 | 3 | (** Type for datakit log destination: quiet (simple outputs on 4 | stdout), timestamp (timestamped outputs on stdout), ASL, or Window 5 | event logs. *) 6 | type t = Quiet | Timestamp | Eventlog | ASL 7 | 8 | val log_destination : t Cmdliner.Term.t 9 | (** [log_destination] is [--log-destination] command-line argument, 10 | which sets-up a native log destination. *) 11 | 12 | val setup : 13 | Fmt.style_renderer option -> 14 | t -> 15 | Logs.level option -> 16 | [ `Posix | `Monotonic ] -> 17 | unit 18 | (** [setup s t l] setups the log rendering options. [s] specifies 19 | colors settings, [t] is the native log destination and [l] is the log 20 | level. *) 21 | 22 | val log_clock : [ `Posix | `Monotonic ] Cmdliner.Term.t 23 | -------------------------------------------------------------------------------- /src/datakit-log/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name datakit_log) 3 | (wrapped false) 4 | (libraries cmdliner fmt logs.cli prometheus-app.unix mtime mtime.clock.os 5 | win-eventlog asl logs.fmt fmt.tty)) 6 | -------------------------------------------------------------------------------- /src/datakit-server-9p/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name datakit_server_9p) 3 | (public_name datakit-server-9p) 4 | (wrapped false) 5 | (libraries datakit-server protocol-9p mirage-flow)) 6 | -------------------------------------------------------------------------------- /src/datakit-server-9p/fs9p.mli: -------------------------------------------------------------------------------- 1 | (** Expose a VFS directory over 9p. *) 2 | 3 | (** The server signature. *) 4 | module type S = sig 5 | type flow 6 | (** The type for communication "channels" between the clients and 7 | the server. *) 8 | 9 | val accept : 10 | root:Vfs.Dir.t -> msg:string -> flow -> unit Protocol_9p.Error.t Lwt.t 11 | (** [accept ~root f] accepts connection on [f], processs requests 12 | and returns when the connection has beenn closed. *) 13 | end 14 | 15 | module Make (Flow : Mirage_flow_lwt.S) : S with type flow = Flow.flow 16 | (** Server builder. *) 17 | -------------------------------------------------------------------------------- /src/datakit-server-9p/fs9p_error.ml: -------------------------------------------------------------------------------- 1 | (* Must match exactly what Linux is expecting *) 2 | 3 | open Rresult 4 | 5 | type t = Protocol_9p.Response.Err.t 6 | 7 | let error ?(errno = 0l) fmt = 8 | Printf.ksprintf 9 | (fun ename -> Error { Protocol_9p.Response.Err.ename; errno = Some errno }) 10 | fmt 11 | 12 | let enoent = error "No such file or directory" 13 | 14 | let eisdir = error "Is a directory" 15 | 16 | let enotdir = error "Is not a directory" 17 | 18 | let ero = error "Read-only file" 19 | 20 | let eperm = error "Operation not permitted" 21 | 22 | let of_error x = 23 | let open Vfs.Error in 24 | match x with 25 | | Noent -> enoent 26 | | Isdir -> eisdir 27 | | Notdir -> enotdir 28 | | Read_only_file -> ero 29 | | Perm -> eperm 30 | | Other err -> error ?errno:err.errno "%s" err.descr 31 | 32 | let map_error = function 33 | | Ok _ as x -> Lwt.return x 34 | | Error e -> Lwt.return (of_error e) 35 | 36 | module Infix = struct 37 | open Lwt.Infix 38 | 39 | let ( >>*= ) x f = 40 | x >>= function Ok x -> f x | Error _ as e -> Lwt.return e 41 | end 42 | -------------------------------------------------------------------------------- /src/datakit-server-9p/fs9p_error.mli: -------------------------------------------------------------------------------- 1 | open Result 2 | 3 | type t = Protocol_9p.Response.Err.t 4 | 5 | val map_error : ('a, Vfs.Error.t) Result.result -> ('a, t) Result.result Lwt.t 6 | 7 | val error : ?errno:int32 -> ('a, unit, string, ('b, t) result) format4 -> 'a 8 | 9 | module Infix : sig 10 | val ( >>*= ) : 11 | ('a, t) result Lwt.t -> 12 | ('a -> ('b, t) result Lwt.t) -> 13 | ('b, t) result Lwt.t 14 | end 15 | -------------------------------------------------------------------------------- /src/datakit-server/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name datakit_server) 3 | (public_name datakit-server) 4 | (wrapped false) 5 | (libraries astring rresult logs lwt fmt cstruct)) 6 | -------------------------------------------------------------------------------- /src/datakit/bin/autopush.ml: -------------------------------------------------------------------------------- 1 | open Astring 2 | open Lwt.Infix 3 | 4 | module Metrics = struct 5 | open Prometheus 6 | 7 | let namespace = "DataKit" 8 | 9 | let push_duration_seconds = 10 | let help = "Time spent auto-pushing branches to remote" in 11 | Summary.v ~help ~namespace ~subsystem:"git" "push_duration_seconds" 12 | end 13 | 14 | let src = Logs.Src.create "DataKit.autopush" ~doc:"DataKit auto-push" 15 | 16 | module Log = (val Logs.src_log src : Logs.LOG) 17 | 18 | type t = { 19 | local : string; 20 | (* Path to local repository *) 21 | remote : string; 22 | (* Remote repository *) 23 | mutable dirty : String.Set.t; 24 | (* Branches to be pushed *) 25 | cond : unit Lwt_condition.t; 26 | (* Fires whenever something is added to [dirty]. *) 27 | } 28 | 29 | let exec ~name cmd = 30 | Lwt_process.exec cmd >|= function 31 | | Unix.WEXITED 0 -> () 32 | | Unix.WEXITED i -> Log.err (fun l -> l "%s exited with code %d" name i) 33 | | Unix.WSIGNALED i -> Log.err (fun l -> l "%s killed by signal %d)" name i) 34 | | Unix.WSTOPPED i -> Log.err (fun l -> l "%s stopped by signal %d" name i) 35 | 36 | let daemon_thread t = 37 | let rec loop () = 38 | match String.Set.elements t.dirty with 39 | | [] -> 40 | Lwt_condition.wait t.cond >>= fun () -> 41 | (* Wait a bit in case some other branches need pushing immediately afterwards too *) 42 | Lwt_unix.sleep 2.0 >>= loop 43 | | dirty -> 44 | (* Note: must not block here, to ensure we don't erase new items. *) 45 | t.dirty <- String.Set.empty; 46 | Lwt.catch 47 | (fun () -> 48 | let cmd = 49 | [ "git"; "-C"; t.local; "push"; "--force"; "--"; t.remote ] 50 | @ dirty 51 | in 52 | let name = 53 | Fmt.strf "auto-push: %a" (Fmt.Dump.list String.dump) cmd 54 | in 55 | let t0 = Unix.gettimeofday () in 56 | exec ~name ("", Array.of_list cmd) >|= fun () -> 57 | let t1 = Unix.gettimeofday () in 58 | Prometheus.Summary.observe Metrics.push_duration_seconds (t1 -. t0)) 59 | (fun ex -> 60 | Log.err (fun l -> l "git push failed: %a" Fmt.exn ex); 61 | 62 | (* Should we re-queue [dirty] here? *) 63 | Lwt.return ()) 64 | >>= loop 65 | in 66 | loop () 67 | 68 | let create ~local ~remote = 69 | Log.info (fun l -> l "Auto-push to %s enabled" remote); 70 | let t = 71 | { local; remote; dirty = String.Set.empty; cond = Lwt_condition.create () } 72 | in 73 | Lwt.async (fun () -> daemon_thread t); 74 | t 75 | 76 | let push t ~branch = 77 | Log.info (fun l -> l "Marking %s/%s as dirty" t.local branch); 78 | t.dirty <- String.Set.add branch t.dirty; 79 | Lwt_condition.broadcast t.cond () 80 | -------------------------------------------------------------------------------- /src/datakit/bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (package datakit) 4 | (public_name datakit) 5 | (libraries datakit_io datakit datakit_conduit datakit_log cmdliner fmt.cli 6 | fmt.tty logs.fmt asetmap git irmin irmin-git irmin-watcher)) 7 | 8 | (rule 9 | (targets version.ml) 10 | (action 11 | (with-stdout-to 12 | %{targets} 13 | (echo "let v = \"%{version:datakit}\"")))) 14 | -------------------------------------------------------------------------------- /src/datakit/blob.ml: -------------------------------------------------------------------------------- 1 | open Result 2 | 3 | type t = Cstruct.t list ref (* (reversed) *) 4 | 5 | let pp_buf ppf buf = Fmt.string ppf (Cstruct.to_string buf) 6 | 7 | let pp ppf t = Fmt.pf ppf "%a" Fmt.(list ~sep:nop pp_buf) !t 8 | 9 | (* FIXME: very expensive! *) 10 | let compare x y = 11 | String.compare (Cstruct.copyv @@ List.rev !x) (Cstruct.copyv @@ List.rev !y) 12 | 13 | let ( >>!= ) x f = match x with Ok x -> f x | Error _ as e -> e 14 | 15 | let len t = Cstruct.lenv !t 16 | 17 | let empty_cs = Cstruct.create 0 18 | 19 | let empty = ref [] 20 | 21 | let string s = ref [ Cstruct.of_string s ] 22 | 23 | let ro_cstruct cs = ref [ cs ] 24 | 25 | let to_ro_cstruct t = 26 | let cs = Cstruct.concat (List.rev !t) in 27 | t := [ cs ]; 28 | cs 29 | 30 | let t = Irmin.Type.(like cstruct) ro_cstruct to_ro_cstruct 31 | 32 | let to_string t = Cstruct.to_string (to_ro_cstruct t) 33 | 34 | (* [overwrite orig (new, offset)] is a buffer [start; padding; new; 35 | end] where [new] is at position [offset], [start] and [end] are 36 | from [orig] and [padding] is zeroes inserted as needed. *) 37 | let overwrite orig (data, offset) = 38 | let orig_len = Cstruct.len orig in 39 | let data_len = Cstruct.len data in 40 | if offset = 0 && data_len >= orig_len then data (* Common, fast case *) 41 | else 42 | let padding = Cstruct.create (max 0 (offset - orig_len)) in 43 | let tail = 44 | let data_end = offset + data_len in 45 | if orig_len > data_end then 46 | Cstruct.sub orig data_end (orig_len - data_end) 47 | else empty_cs 48 | in 49 | Cstruct.concat 50 | [ Cstruct.sub orig 0 (min offset (Cstruct.len orig)); 51 | padding; 52 | data; 53 | tail 54 | ] 55 | 56 | let check_offset ~offset len = 57 | let len = Int64.of_int len in 58 | if offset < 0L then Vfs.Error.negative_offset offset 59 | else if offset > len then Vfs.Error.offset_too_large ~offset len 60 | else Ok () 61 | 62 | let read t ~offset ~count = 63 | let contents = to_ro_cstruct t in 64 | check_offset ~offset (Cstruct.len contents) >>!= fun () -> 65 | let avail = Cstruct.shift contents (Int64.to_int offset) in 66 | let count = min (max count 0) (Cstruct.len avail) in 67 | Ok (Cstruct.sub avail 0 count) 68 | 69 | let write old ~offset data = 70 | if offset < 0L then Vfs.Error.negative_offset offset 71 | else 72 | let offset = Int64.to_int offset in 73 | if offset = len old then Ok (ref (data :: !old)) 74 | else Ok (ro_cstruct (overwrite (to_ro_cstruct old) (data, offset))) 75 | 76 | let truncate old = function 77 | | n when n < 0L -> Vfs.Error.negative_offset n 78 | | 0L -> Ok empty 79 | | new_len -> 80 | let new_len = Int64.to_int new_len in 81 | let extra = new_len - len old in 82 | if extra = 0 then Ok old 83 | else if extra < 0 then 84 | Ok (ro_cstruct (Cstruct.sub (to_ro_cstruct old) 0 new_len)) 85 | else 86 | let padding = Cstruct.create extra in 87 | Ok (ref (padding :: !old)) 88 | 89 | let len t = Int64.of_int (len t) 90 | 91 | let merge = Irmin.Merge.(option @@ default t) 92 | 93 | let of_string x = Ok (string x) 94 | -------------------------------------------------------------------------------- /src/datakit/blob.mli: -------------------------------------------------------------------------------- 1 | (** An immutable Cstruct-like type that allows more efficient 2 | modification. *) 3 | 4 | open Result 5 | 6 | type t 7 | 8 | val empty : t 9 | 10 | val write : t -> offset:int64 -> Cstruct.t -> (t, Vfs.Error.t) result 11 | 12 | val len : t -> int64 13 | 14 | val truncate : t -> int64 -> (t, Vfs.Error.t) result 15 | 16 | val read : t -> offset:int64 -> count:int -> (Cstruct.t, Vfs.Error.t) result 17 | 18 | val ro_cstruct : Cstruct.t -> t 19 | 20 | val to_ro_cstruct : t -> Cstruct.t 21 | 22 | val string : string -> t 23 | 24 | val to_string : t -> string 25 | 26 | val compare : t -> t -> int 27 | 28 | include Irmin.Contents.S with type t := t 29 | -------------------------------------------------------------------------------- /src/datakit/branch.ml: -------------------------------------------------------------------------------- 1 | include Irmin.Branch.String 2 | 3 | let is_valid s = 4 | let ok = ref true in 5 | let n = String.length s in 6 | let i = ref 0 in 7 | while !i < n do 8 | ( match s.[!i] with 9 | | '/' | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '-' | '_' | '.' -> () 10 | | _ -> ok := false ); 11 | incr i 12 | done; 13 | !ok 14 | -------------------------------------------------------------------------------- /src/datakit/branch.mli: -------------------------------------------------------------------------------- 1 | include Irmin.Branch.S with type t = string 2 | -------------------------------------------------------------------------------- /src/datakit/dir.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Result 3 | 4 | type path = Path.t 5 | 6 | type perm = Metadata.t 7 | 8 | type blob = Blob.t 9 | 10 | let ( >>*= ) x f = x >>= function Ok y -> f y | Error _ as e -> Lwt.return e 11 | 12 | type impossible 13 | 14 | let doesnt_fail = function Ok x -> x | Error (_ : impossible) -> assert false 15 | 16 | module Make (Store : Store.S) = struct 17 | type t = { 18 | repo : Store.Repo.t; 19 | mutable root : Store.tree; 20 | mutex : Lwt_mutex.t; 21 | } 22 | 23 | let v repo root = { repo; root; mutex = Lwt_mutex.create () } 24 | 25 | let root t = t.root 26 | 27 | (* Walk to [t.root/path] and process the resulting directory with 28 | [fn dir], then update all the parents back to the root. *) 29 | let update_dir ~file_on_path t path fn = 30 | Lwt_mutex.with_lock t.mutex @@ fun () -> 31 | let empty = Store.Tree.empty in 32 | let rec aux base path = 33 | match Store.Key.decons path with 34 | | None -> fn base 35 | | Some (p, ps) -> 36 | let step = Store.Key.v [ p ] in 37 | (Store.Tree.find_tree base step >>= function 38 | | None -> aux empty ps 39 | | Some (`Node subdir) -> aux (Store.Tree.of_node subdir) ps 40 | | Some (`Contents f) -> 41 | file_on_path f >>*= fun () -> 42 | aux empty ps) 43 | >>*= fun new_subdir -> 44 | Store.Tree.add_tree base step new_subdir >|= fun x -> 45 | Ok x 46 | in 47 | aux t.root path >>*= fun new_root -> 48 | t.root <- new_root; 49 | Lwt.return (Ok ()) 50 | 51 | let err_not_a_directory (_ : Store.contents * _) = 52 | Lwt.return (Error `Not_a_directory) 53 | 54 | let replace_with_dir (_ : Store.contents * _) = Lwt.return (Ok ()) 55 | 56 | let update t path leaf (value, perm) = 57 | let step = Store.Key.v [ leaf ] in 58 | update_dir ~file_on_path:err_not_a_directory t path @@ fun dir -> 59 | let update ~old_perm = 60 | let perm = match perm with #Metadata.t as p -> p | `Keep -> old_perm in 61 | Store.Tree.add dir step ~metadata:perm value >|= fun new_dir -> 62 | Ok new_dir 63 | in 64 | Store.Tree.find_tree dir step >>= function 65 | | Some (`Node _) -> Lwt.return (Error `Is_a_directory) 66 | | Some (`Contents (_, old_perm)) -> update ~old_perm 67 | | None -> update ~old_perm:`Normal 68 | 69 | let chmod t path leaf perm = 70 | let step = Store.Key.v [ leaf ] in 71 | update_dir ~file_on_path:err_not_a_directory t path @@ fun dir -> 72 | Store.Tree.find_tree dir step >>= function 73 | | None -> Lwt.return (Error `No_such_item) 74 | | Some (`Node _) when perm = `Exec -> Lwt.return (Ok dir) 75 | | Some (`Node _) -> Lwt.return (Error `Is_a_directory) 76 | | Some (`Contents (f, _old_perm)) -> 77 | let file = 78 | match perm with 79 | | (`Normal | `Exec) as perm -> `Contents (f, perm) 80 | | `Link target -> `Contents (Blob.string target, `Link) 81 | in 82 | Store.Tree.add_tree dir step file >|= fun new_dir -> 83 | Ok new_dir 84 | 85 | let remove t path leaf = 86 | let step = Store.Key.v [ leaf ] in 87 | update_dir ~file_on_path:err_not_a_directory t path @@ fun dir -> 88 | Store.Tree.remove dir step >|= fun new_dir -> 89 | Ok new_dir 90 | 91 | let update_force t path leaf (value, perm) = 92 | let step = Store.Key.v [ leaf ] in 93 | update_dir ~file_on_path:replace_with_dir t path (fun dir -> 94 | Store.Tree.add dir step ~metadata:perm value >|= fun new_dir -> 95 | Ok new_dir) 96 | >|= doesnt_fail 97 | 98 | let remove_force t path leaf = 99 | let step = Store.Key.v [ leaf ] in 100 | update_dir ~file_on_path:replace_with_dir t path (fun dir -> 101 | Store.Tree.remove dir step >|= fun new_dir -> 102 | Ok new_dir) 103 | >|= doesnt_fail 104 | 105 | let rename t path ~old_name ~new_name = 106 | let old_step = Store.Key.v [ old_name ] in 107 | let new_step = Store.Key.v [ new_name ] in 108 | update_dir ~file_on_path:err_not_a_directory t path (fun dir -> 109 | Store.Tree.find_tree dir old_step >>= function 110 | | None -> Lwt.return (Error `No_such_item) 111 | | Some ((`Contents _ | `Node _) as value) -> ( 112 | Store.Tree.find_tree dir new_step >>= function 113 | | Some (`Node _) -> Lwt.return (Error `Is_a_directory) 114 | | None | Some (`Contents _) -> 115 | Store.Tree.remove dir old_step >>= fun dir' -> 116 | Store.Tree.add_tree dir' new_step value >|= fun new_dir -> 117 | Ok new_dir )) 118 | end 119 | -------------------------------------------------------------------------------- /src/datakit/dir.mli: -------------------------------------------------------------------------------- 1 | open Result 2 | 3 | type path = Path.t 4 | 5 | type perm = Metadata.t 6 | 7 | type blob = Blob.t 8 | 9 | module Make (Store : Store.S) : sig 10 | type t 11 | 12 | val v : Store.Repo.t -> Store.tree -> t 13 | 14 | val root : t -> Store.tree 15 | 16 | val update : 17 | t -> 18 | path -> 19 | string -> 20 | Blob.t * [ perm | `Keep ] -> 21 | (unit, [ `Is_a_directory | `Not_a_directory ]) result Lwt.t 22 | 23 | val remove : t -> path -> string -> (unit, [ `Not_a_directory ]) result Lwt.t 24 | 25 | val chmod : 26 | t -> 27 | path -> 28 | string -> 29 | Vfs.perm -> 30 | (unit, [ `Is_a_directory | `Not_a_directory | `No_such_item ]) result Lwt.t 31 | 32 | val update_force : t -> path -> string -> blob * perm -> unit Lwt.t 33 | 34 | val remove_force : t -> path -> string -> unit Lwt.t 35 | 36 | val rename : 37 | t -> 38 | path -> 39 | old_name:string -> 40 | new_name:string -> 41 | (unit, [ `Is_a_directory | `Not_a_directory | `No_such_item ]) result Lwt.t 42 | end 43 | -------------------------------------------------------------------------------- /src/datakit/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name datakit) 3 | (public_name datakit) 4 | (libraries lwt astring logs result cstruct fmt rresult irmin-mem 5 | datakit-server asetmap prometheus-app)) 6 | -------------------------------------------------------------------------------- /src/datakit/merge.ml: -------------------------------------------------------------------------------- 1 | open Astring 2 | open Lwt.Infix 3 | 4 | type path = Path.t 5 | 6 | type step = Path.step 7 | 8 | type blob = Blob.t 9 | 10 | type perm = Metadata.t 11 | 12 | module type RW = sig 13 | type t 14 | 15 | val update_force : t -> path -> string -> blob * perm -> unit Lwt.t 16 | 17 | val remove_force : t -> path -> string -> unit Lwt.t 18 | end 19 | 20 | module Make (Store : Store.S) (RW : RW) = struct 21 | module Metadata = Store.Metadata 22 | module Dir = Store.Tree 23 | 24 | let merge_file = 25 | let blob = Irmin.Merge.idempotent Irmin.Type.(pair Blob.t Metadata.t) in 26 | Irmin.Merge.(option blob) 27 | 28 | let map tree = Dir.list tree Store.Key.empty >|= String.Map.of_list 29 | 30 | let merge ~ours ~theirs ~base result = 31 | let conflicts = ref Path.Set.empty in 32 | let note_conflict path leaf msg = 33 | conflicts := !conflicts |> Path.Set.add (Store.Key.rcons path leaf); 34 | let f = Blob.string (Printf.sprintf "** Conflict **\n%s\n" msg) in 35 | RW.update_force result path leaf (f, `Normal) 36 | in 37 | let as_dir = function None -> Store.Tree.empty | Some v -> v in 38 | let rec merge_dir ~ours ~theirs ~base path = 39 | map ours >>= fun our_files -> 40 | map theirs >>= fun their_files -> 41 | (* Types tells us the type the result will have, if successful, 42 | or [`Conflict] if we know it won't work. *) 43 | let types = 44 | String.Map.merge 45 | (fun _leaf ours theirs -> 46 | match (ours, theirs) with 47 | | Some `Node, Some `Node -> Some `Node 48 | | Some `Contents, Some `Contents -> Some `Contents 49 | | Some _, Some _ -> Some `Conflict 50 | | Some `Contents, None | None, Some `Contents -> Some `Contents 51 | | Some `Node, None | None, Some `Node -> Some `Node 52 | | None, None -> assert false) 53 | our_files their_files 54 | in 55 | String.Map.bindings types 56 | |> Lwt_list.iter_s (fun (leaf, ty) -> 57 | let sub_path = Store.Key.rcons path leaf in 58 | let step = Path.v [ leaf ] in 59 | match ty with 60 | | `Conflict -> note_conflict path leaf "File vs dir" 61 | | `Node -> 62 | Dir.find_tree ours step >|= as_dir >>= fun ours -> 63 | Dir.find_tree theirs step >|= as_dir >>= fun theirs -> 64 | Dir.find_tree base step >|= as_dir >>= fun base -> 65 | merge_dir ~ours ~theirs ~base sub_path 66 | | `Contents -> ( 67 | Dir.find_all ours step >>= fun ours -> 68 | Dir.find_all theirs step >>= fun theirs -> 69 | let old () = 70 | Dir.find_all base step >|= fun f -> 71 | Ok (Some f) 72 | in 73 | Irmin.Merge.f merge_file ~old ours theirs >>= function 74 | | Ok (Some x) -> RW.update_force result path leaf x 75 | | Ok None -> RW.remove_force result path leaf 76 | | Error (`Conflict "default") -> 77 | note_conflict path leaf "Changed on both branches" 78 | | Error (`Conflict x) -> note_conflict path leaf x )) 79 | in 80 | Store.tree ours >>= fun ours -> 81 | Store.tree theirs >>= fun theirs -> 82 | ( match base with 83 | | None -> Lwt.return Store.Tree.empty 84 | | Some base -> Store.tree base ) 85 | >>= fun base -> 86 | merge_dir ~ours ~theirs ~base Store.Key.empty >>= fun () -> 87 | Lwt.return !conflicts 88 | end 89 | -------------------------------------------------------------------------------- /src/datakit/merge.mli: -------------------------------------------------------------------------------- 1 | type path = Path.t 2 | 3 | type step = Path.step 4 | 5 | type blob = Blob.t 6 | 7 | type perm = Metadata.t 8 | 9 | module type RW = sig 10 | type t 11 | 12 | val update_force : t -> path -> step -> blob * perm -> unit Lwt.t 13 | 14 | val remove_force : t -> path -> step -> unit Lwt.t 15 | end 16 | 17 | module Make (Store : Store.S) (RW : RW) : sig 18 | val merge : 19 | ours:Store.t -> 20 | theirs:Store.t -> 21 | base:Store.t option -> 22 | RW.t -> 23 | Path.Set.t Lwt.t 24 | (** [merge ~ours ~theirs ~base result] updates [result] (which 25 | initially is a copy of [ours]) to our best attempt at a merge. 26 | Returns the set of paths with conflicts. *) 27 | end 28 | -------------------------------------------------------------------------------- /src/datakit/metadata.ml: -------------------------------------------------------------------------------- 1 | module X = struct 2 | type t = [ `Normal | `Exec | `Link ] 3 | 4 | let t = 5 | Irmin.Type.enum "metadata" 6 | [ ("normal", `Normal); ("exec", `Exec); ("link", `Link) ] 7 | end 8 | 9 | include X 10 | 11 | let default = `Normal 12 | 13 | let merge = Irmin.Merge.default X.t 14 | -------------------------------------------------------------------------------- /src/datakit/metadata.mli: -------------------------------------------------------------------------------- 1 | (** Similar to Irmin.Branch.String but allow '/' in branch names. *) 2 | 3 | include Irmin.Metadata.S with type t = [ `Normal | `Exec | `Link ] 4 | -------------------------------------------------------------------------------- /src/datakit/path.ml: -------------------------------------------------------------------------------- 1 | open Astring 2 | 3 | type step = string 4 | 5 | let step_t = Irmin.Type.string 6 | 7 | let pp_step ppf x = Fmt.string ppf x 8 | 9 | let step_of_string = function "" -> Error (`Msg "Empty step!") | s -> Ok s 10 | 11 | type t = string list 12 | 13 | let t = Irmin.Type.(list string) 14 | 15 | let empty = [] 16 | 17 | let is_empty l = l = [] 18 | 19 | let cons s t = t @ [ s ] 20 | 21 | let rcons t s = s :: t 22 | 23 | let rdecons = function [] -> None | h :: t -> Some (t, h) 24 | 25 | let decons l = 26 | match List.rev l with [] -> None | h :: t -> Some (h, List.rev t) 27 | 28 | let map l f = List.map f l 29 | 30 | let v x = List.rev x 31 | 32 | let pp ppf t = Fmt.(list ~sep:(unit "/") string) ppf (List.rev t) 33 | 34 | (* XXX: slow *) 35 | let of_string s = 36 | List.filter (( <> ) "") (String.cuts s ~sep:"/") |> List.rev |> fun x -> 37 | Ok x 38 | 39 | module X = struct 40 | type nonrec t = t 41 | 42 | let compare = Irmin.Type.compare t 43 | end 44 | 45 | module Set = Set.Make (X) 46 | -------------------------------------------------------------------------------- /src/datakit/path.mli: -------------------------------------------------------------------------------- 1 | include Irmin.Path.S with type step = string 2 | 3 | module Set : Set.S with type elt = t 4 | -------------------------------------------------------------------------------- /src/datakit/remote.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | let src = Logs.Src.create "ivfs-remote" ~doc:"Irmin VFS: remote repositories" 4 | 5 | module Log = (val Logs.src_log src : Logs.LOG) 6 | 7 | let err_no_head = Vfs.error "error: no head to fetch" 8 | 9 | let err_fetch_error = Vfs.error "error: cannot fetch %s" 10 | 11 | let err_no_url = Vfs.error "error: remote url is not defined" 12 | 13 | module Make (Store : Store.S) = struct 14 | module Sync = Irmin.Sync (Store) 15 | 16 | type t = { 17 | remote_url : unit -> string option; 18 | update_head : Store.commit option -> unit; 19 | } 20 | 21 | let mk_head session = 22 | let pp_o ppf = function 23 | | None -> Fmt.string ppf "" 24 | | Some x -> Fmt.pf ppf "%a\n" Store.Commit.pp x 25 | in 26 | let stream () = Vfs.File.Stream.create pp_o session |> Lwt.return in 27 | let file = Vfs.File.of_stream stream in 28 | (file, fun x -> Vfs.File.Stream.publish session x) 29 | 30 | (* /remotes//url *) 31 | let mk_url default = 32 | let file, fn = Vfs.File.rw_of_string default in 33 | (file, function () -> ( match fn () with "" -> None | s -> Some s )) 34 | 35 | (* /remotes//fetch *) 36 | let mk_fetch t repo = 37 | let handler branch = 38 | match t.remote_url () with 39 | | None -> err_no_url 40 | | Some url -> ( 41 | let r = Irmin.remote_uri url in 42 | Store.of_branch repo branch >>= fun s -> 43 | Sync.fetch s r >>= function 44 | | Error `No_head -> err_no_head 45 | | Error _ -> err_fetch_error url 46 | | Ok h -> 47 | t.update_head (Some h); 48 | Vfs.ok "" ) 49 | in 50 | Vfs.File.command handler 51 | 52 | (* /remotes// *) 53 | let mk_remote ?(url = "") repo = 54 | let session = Vfs.File.Stream.session None in 55 | let url_file, remote_url = mk_url url in 56 | let head_file, update_head = mk_head session in 57 | let t = { remote_url; update_head } in 58 | let fetch_file = mk_fetch t repo in 59 | let files = 60 | Vfs.ok 61 | [ Vfs.Inode.file "url" url_file; 62 | Vfs.Inode.file "head" head_file; 63 | Vfs.Inode.file "fetch" fetch_file 64 | ] 65 | in 66 | Vfs.Dir.of_list (fun () -> files) 67 | 68 | let create ?(init = []) repo = 69 | Log.debug (fun l -> l "create"); 70 | let remote ?url name = Vfs.Inode.dir name (mk_remote ?url repo) in 71 | let init = List.map (fun (name, url) -> (name, remote ~url name)) init in 72 | let remotes = ref init in 73 | let ls () = Vfs.ok (List.map snd !remotes) in 74 | let lookup n = 75 | try Vfs.ok (List.assoc n !remotes) 76 | with Not_found -> Vfs.Dir.err_no_entry 77 | in 78 | let mkdir n = 79 | if List.mem_assoc n !remotes then Vfs.Dir.err_already_exists 80 | else 81 | let i = remote n in 82 | remotes := (n, i) :: !remotes; 83 | Vfs.ok i 84 | in 85 | let remove _ = Vfs.Dir.err_dir_only in 86 | let rename i new_name = 87 | let old_name = Vfs.Inode.basename i in 88 | Vfs.Inode.set_basename i new_name; 89 | let rs = List.filter (fun (n, _) -> n <> old_name) !remotes in 90 | remotes := (new_name, i) :: rs; 91 | Vfs.ok () 92 | in 93 | Vfs.Dir.dir_only ~ls ~mkdir ~remove ~rename ~lookup 94 | end 95 | -------------------------------------------------------------------------------- /src/datakit/remote.mli: -------------------------------------------------------------------------------- 1 | module Make (Store : Store.S) : sig 2 | val create : ?init:(string * string) list -> Store.Repo.t -> Vfs.Dir.t 3 | (** Create the /remotes/ virtual directory. [init] is a pair of 4 | remote names and urls. *) 5 | end 6 | -------------------------------------------------------------------------------- /src/datakit/store.ml: -------------------------------------------------------------------------------- 1 | module type S0 = 2 | Irmin.S 3 | with type metadata = Metadata.t 4 | and type Commit.Hash.t = Irmin.Hash.SHA1.t 5 | and type Tree.Hash.t = Irmin.Hash.SHA1.t 6 | and type Contents.Hash.t = Irmin.Hash.SHA1.t 7 | 8 | module type S = 9 | S0 10 | with type contents = Blob.t 11 | and type key = Path.t 12 | and type step = Path.step 13 | and type branch = Branch.t 14 | 15 | module type GIT_S_MAKER = functor 16 | (C : Irmin.Contents.S) 17 | (P : Irmin.Path.S) 18 | (B : Irmin.Branch.S) 19 | -> 20 | S0 21 | with type contents = C.t 22 | and type key = P.t 23 | and type step = P.step 24 | and module Key = P 25 | and type branch = B.t 26 | 27 | module Make_git (M : GIT_S_MAKER) = M (Blob) (Path) (Branch) 28 | -------------------------------------------------------------------------------- /src/datakit/store.mli: -------------------------------------------------------------------------------- 1 | module type S0 = 2 | Irmin.S 3 | with type metadata = Metadata.t 4 | and type Commit.Hash.t = Irmin.Hash.SHA1.t 5 | and type Tree.Hash.t = Irmin.Hash.SHA1.t 6 | and type Contents.Hash.t = Irmin.Hash.SHA1.t 7 | 8 | module type S = 9 | S0 10 | with type contents = Blob.t 11 | and type key = Path.t 12 | and type step = Path.step 13 | and type branch = Branch.t 14 | 15 | module type GIT_S_MAKER = functor 16 | (C : Irmin.Contents.S) 17 | (P : Irmin.Path.S) 18 | (B : Irmin.Branch.S) 19 | -> 20 | S0 21 | with type contents = C.t 22 | and type key = P.t 23 | and type step = P.step 24 | and module Key = P 25 | and type branch = B.t 26 | 27 | module Make_git (M : GIT_S_MAKER) : S 28 | -------------------------------------------------------------------------------- /src/version.ml: -------------------------------------------------------------------------------- 1 | let v = "%%VERSION%%" 2 | -------------------------------------------------------------------------------- /tests/common/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name test) 3 | (wrapped false) 4 | (libraries alcotest mtime mtime.clock.os logs.fmt io-page-unix mirage-flow 5 | datakit-client datakit_io irmin-mem irmin-git)) 6 | -------------------------------------------------------------------------------- /tests/common/test_client.mli: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | include Datakit_client.S 3 | 4 | val run : (t -> unit Lwt.t) -> unit 5 | end 6 | 7 | module Make (DK : S) : sig 8 | val test_set : unit Alcotest.test_case list 9 | end 10 | -------------------------------------------------------------------------------- /tests/common/test_utils.ml: -------------------------------------------------------------------------------- 1 | open Astring 2 | open Lwt.Infix 3 | open Result 4 | 5 | let () = Printexc.record_backtrace true 6 | 7 | let default d = function None -> d | Some x -> x 8 | 9 | let p = function 10 | | "" -> Datakit_client.Path.empty 11 | | path -> Datakit_client.Path.of_string_exn path 12 | 13 | let ( / ) = Datakit_client.Path.Infix.( / ) 14 | 15 | let v = Cstruct.of_string 16 | 17 | let ( ++ ) = Int64.add 18 | 19 | let ok x = Lwt.return (Ok x) 20 | 21 | let ( >>*= ) x f = 22 | x >>= function 23 | | Ok y -> f y 24 | | Error (`Msg msg) -> Alcotest.fail ("Msg: " ^ msg) 25 | 26 | let () = 27 | let fd_stderr = Unix.descr_of_out_channel stderr in 28 | let real_stderr = Unix.dup fd_stderr in 29 | let old_hook = !Lwt.async_exception_hook in 30 | Lwt.async_exception_hook := 31 | fun ex -> 32 | Unix.dup2 real_stderr fd_stderr; 33 | Printf.eprintf "\nasync_exception_hook:\n%!"; 34 | old_hook ex 35 | 36 | module Test_flow = struct 37 | type error = { zero : 'a. 'a } 38 | 39 | let pp_error ppf _ = Fmt.string ppf "<0>" 40 | 41 | type write_error = Mirage_flow.write_error 42 | 43 | let pp_write_error = Mirage_flow.pp_write_error 44 | 45 | type buffer = Cstruct.t 46 | 47 | type 'a io = 'a Lwt.t 48 | 49 | let error_message e = e.zero 50 | 51 | type flow = { 52 | from_remote : Cstruct.t Lwt_mvar.t; 53 | to_remote : Cstruct.t Lwt_mvar.t; 54 | } 55 | 56 | let create () = 57 | let a = Lwt_mvar.create_empty () in 58 | let b = Lwt_mvar.create_empty () in 59 | let flow1 = { from_remote = a; to_remote = b } in 60 | let flow2 = { from_remote = b; to_remote = a } in 61 | (flow1, flow2) 62 | 63 | let ok x = Ok x 64 | 65 | let close _t = Lwt.return_unit 66 | 67 | let write1 t buf = Lwt_mvar.put t.to_remote buf 68 | 69 | let write t buf = write1 t buf >|= ok 70 | 71 | let writev t bufv = Lwt_list.iter_s (write1 t) bufv >|= ok 72 | 73 | let read t = 74 | Lwt_mvar.take t.from_remote >|= fun x -> 75 | Ok (`Data x) 76 | end 77 | 78 | let reporter () = 79 | let pad n x = 80 | if String.length x > n then x 81 | else x ^ String.v ~len:(n - String.length x) (fun _ -> ' ') 82 | in 83 | let report src level ~over k msgf = 84 | let k _ = 85 | over (); 86 | k () 87 | in 88 | let ppf = match level with Logs.App -> Fmt.stdout | _ -> Fmt.stderr in 89 | let with_stamp h _tags k fmt = 90 | let dt = Mtime.Span.to_us (Mtime_clock.elapsed ()) in 91 | Fmt.kpf k ppf 92 | ("%+04.0fus %a %a @[" ^^ fmt ^^ "@]@.") 93 | dt 94 | Fmt.(styled `Magenta string) 95 | (pad 10 @@ Logs.Src.name src) 96 | Logs_fmt.pp_header (level, h) 97 | in 98 | msgf @@ fun ?header ?tags fmt -> 99 | with_stamp header tags k fmt 100 | in 101 | { Logs.report } 102 | 103 | let () = 104 | Fmt_tty.setup_std_outputs (); 105 | Logs.(set_level (Some Debug)); 106 | Logs.set_reporter (reporter ()); 107 | () 108 | 109 | module Maker = Irmin_git.Mem.Make (Datakit_io.IO) (Git.Inflate.M) 110 | 111 | type history_node = { id : string; msg : string; parents : history_node list } 112 | 113 | let compare_history_node a b = 114 | match compare a.msg b.msg with 0 -> compare a.id b.id | x -> x 115 | 116 | let quiet_9p src9p = 117 | Logs.Src.set_level src9p (Some Logs.Info); 118 | let srcs = Logs.Src.list () in 119 | List.iter 120 | (fun src -> 121 | if Logs.Src.name src = "fs9p" then 122 | Logs.Src.set_level src (Some Logs.Info)) 123 | srcs 124 | 125 | let quiet_git () = 126 | let srcs = Logs.Src.list () in 127 | List.iter 128 | (fun src -> 129 | if Logs.Src.name src = "git.value" || Logs.Src.name src = "git.memory" 130 | then Logs.Src.set_level src (Some Logs.Info)) 131 | srcs 132 | 133 | let quiet_irmin () = 134 | let srcs = Logs.Src.list () in 135 | List.iter 136 | (fun src -> 137 | if 138 | Logs.Src.name src = "irmin.bc" 139 | || Logs.Src.name src = "irmin.commit" 140 | || Logs.Src.name src = "irmin.node" 141 | then Logs.Src.set_level src (Some Logs.Info)) 142 | srcs 143 | 144 | let split path = 145 | match Irmin.Path.String_list.of_string path with 146 | | Error _ -> assert false 147 | | Ok path -> ( 148 | match Irmin.Path.String_list.rdecons path with 149 | | None -> assert false 150 | | Some (x, y) -> (x, y) ) 151 | 152 | let config = Irmin_mem.config () 153 | 154 | let rec pp_history fmt { id; msg; parents } = 155 | Format.fprintf fmt "@[%s (%s)@\n%a@]" id msg 156 | (Format.pp_print_list pp_history) 157 | parents 158 | 159 | let reject (type v) = 160 | let module T = struct 161 | type t = v 162 | 163 | let pp fmt _ = Fmt.string fmt "reject-all" 164 | 165 | let equal _ _ = false 166 | end in 167 | (module T : Alcotest.TESTABLE with type t = v) 168 | -------------------------------------------------------------------------------- /tests/datakit-9p/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries test str datakit-server-9p datakit-client-9p datakit 4 | protocol-9p-unix)) 5 | 6 | (alias 7 | (name runtest) 8 | (deps test.exe) 9 | (action 10 | (run %{exe:test.exe} -q --color=always))) 11 | -------------------------------------------------------------------------------- /tests/datakit-9p/test.mli: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /tests/datakit-bridge-github/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries test datakit-github datakit-client datakit_bridge_github 4 | datakit-client-9p datakit-server-9p datakit)) 5 | 6 | (alias 7 | (name runtest) 8 | (deps test.exe) 9 | (action 10 | (run %{exe:test.exe} -q --color=always))) 11 | -------------------------------------------------------------------------------- /tests/datakit-bridge-github/test.mli: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /tests/datakit-git/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries test str datakit-client-git)) 4 | 5 | (alias 6 | (name runtest) 7 | (deps test.exe) 8 | (action 9 | (run %{exe:test.exe} -q --color=always))) 10 | -------------------------------------------------------------------------------- /tests/datakit-git/test.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | module Client = Datakit_client_git 3 | 4 | let test_db = "_build/test-git" 5 | 6 | let run fn = 7 | Lwt_main.run 8 | ( Git_unix.FS.create ~root:test_db () >>= fun db -> 9 | Git_unix.FS.reset db >>= fun () -> 10 | Git_unix.FS.clear (); 11 | Client.connect ~author:"datakit" test_db >>= fn ) 12 | 13 | (* FIXME(samoht): re-add server-side tests *) 14 | 15 | module C = Test_client.Make (struct 16 | include Client 17 | 18 | let run = run 19 | end) 20 | 21 | let () = Alcotest.run "datakit-git" [ ("client", C.test_set) ] 22 | -------------------------------------------------------------------------------- /tests/datakit-git/test.mli: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /tests/datakit/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries test datakit_conduit datakit)) 4 | 5 | (alias 6 | (name runtest) 7 | (deps test.exe) 8 | (action 9 | (run %{exe:test.exe} -q --color=always))) 10 | -------------------------------------------------------------------------------- /tests/datakit/test.mli: -------------------------------------------------------------------------------- 1 | 2 | --------------------------------------------------------------------------------