diff --git a/.test-mirage.sh b/.test-mirage.sh new file mode 100755 index 000000000..57e8a367f --- /dev/null +++ b/.test-mirage.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +set -ex + +opam install -y mirage +(cd unikernel && mirage configure -t unix && make depends && mirage build && mirage clean && cd ..) || exit 1 diff --git a/.travis.yml b/.travis.yml index 0da4e2599..85ada7b09 100644 --- a/.travis.yml +++ b/.travis.yml @@ -3,7 +3,7 @@ install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.t script: bash -ex .travis-opam.sh env: global: - - PINS="carton.dev:. carton-lwt.dev:. carton-git.dev:. git-nss.dev:. git.dev:. git-unix.dev:. git-cohttp.dev:. git-cohttp-unix.dev:." + - PINS="mimic.dev:. carton.dev:. carton-lwt.dev:. carton-git.dev:. git-nss.dev:. git.dev:. git-unix.dev:. git-cohttp.dev:. git-cohttp-unix.dev:." matrix: - OCAML_VERSION=4.08 PACKAGE="git.dev" - OCAML_VERSION=4.09 PACKAGE="git.dev" diff --git a/appveyor.yml b/appveyor.yml index b3bdae93d..7bd61d793 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -7,7 +7,7 @@ environment: FORK_BRANCH: master CYG_ROOT: C:\cygwin64 OPAM_SWITCH: 4.08.1+mingw64c - PINS: "carton.dev:. carton-lwt.dev:. carton-git.dev:. git-nss.dev:. git.dev:. git-cohttp.dev:. git-cohttp-unix.dev:. git-unix.dev:." + PINS: "mimic.dev:. carton.dev:. carton-lwt.dev:. carton-git.dev:. git-nss.dev:. git.dev:. git-cohttp.dev:. git-cohttp-unix.dev:. git-unix.dev:." matrix: - PACKAGE: "git.dev" - PACKAGE: "git-unix.dev" diff --git a/carton-git.opam b/carton-git.opam index 2a7e1b697..bae757a8d 100644 --- a/carton-git.opam +++ b/carton-git.opam @@ -1,26 +1,19 @@ opam-version: "2.0" -name: "carton" -maintainer: "Romain Calascibetta " -authors: "Romain Calascibetta " -homepage: "https://github.com/dinosaure/carton" -bug-reports: "https://github.com/dinosaure/carton/issues" -dev-repo: "git+https://github.com/dinosaure/carton.git" -doc: "https://dinosaure.github.io/carton/" -license: "MIT" -synopsis: "Implementation of PACK file in OCaml" -description: """Carton is an implementation of the PACK file +name: "carton" +synopsis: "Implementation of PACK file in OCaml" +description: """\ +Carton is an implementation of the PACK file in OCaml. PACK file is used by Git to store Git objects. Carton is more -abstracted when it can store any objects. -""" - -build: [ - [ "dune" "build" "-p" name "-j" jobs ] - [ "dune" "runtest" "-p" name "-j" jobs ] {with-test} -] - +abstracted when it can store any objects.""" +maintainer: "Romain Calascibetta " +authors: "Romain Calascibetta " +license: "MIT" +homepage: "https://github.com/dinosaure/carton" +doc: "https://dinosaure.github.io/carton/" +bug-reports: "https://github.com/dinosaure/carton/issues" depends: [ - "ocaml" {>= "4.07.0"} - "dune" {>= "2.6.0"} + "ocaml" {>= "4.07.0"} + "dune" {>= "2.6.0"} "carton" "carton-lwt" "bigarray-compat" @@ -29,7 +22,19 @@ depends: [ "fpath" "result" "mmap" - "fmt" {>= "0.8.7"} + "fmt" {>= "0.8.7"} "base-unix" "decompress" {>= "1.2.0"} + "astring" {>= "0.8.5"} + "alcotest" {>= "1.2.3" & with-test} + "alcotest-lwt" {>= "1.2.3" & with-test} + "cstruct" {>= "6.0.0" & with-test} + "logs" {>= "0.7.0" & with-test} + "mirage-flow" {>= "2.0.1" & with-test} + "rresult" {>= "0.6.0" & with-test} +] +build: [ + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] +dev-repo: "git+https://github.com/dinosaure/carton.git" diff --git a/carton-lwt.opam b/carton-lwt.opam index cd1b0a3af..208efc69c 100644 --- a/carton-lwt.opam +++ b/carton-lwt.opam @@ -1,29 +1,35 @@ opam-version: "2.0" -name: "carton" -maintainer: "Romain Calascibetta " -authors: "Romain Calascibetta " -homepage: "https://github.com/dinosaure/carton" -bug-reports: "https://github.com/dinosaure/carton/issues" -dev-repo: "git+https://github.com/dinosaure/carton.git" -doc: "https://dinosaure.github.io/carton/" -license: "MIT" -synopsis: "Implementation of PACK file in OCaml" -description: """Carton is an implementation of the PACK file +name: "carton" +synopsis: "Implementation of PACK file in OCaml" +description: """\ +Carton is an implementation of the PACK file in OCaml. PACK file is used by Git to store Git objects. Carton is more -abstracted when it can store any objects. -""" - -build: [ - [ "dune" "build" "-p" name "-j" jobs ] - [ "dune" "runtest" "-p" name "-j" jobs ] {with-test} -] - +abstracted when it can store any objects.""" +maintainer: "Romain Calascibetta " +authors: "Romain Calascibetta " +license: "MIT" +homepage: "https://github.com/dinosaure/carton" +doc: "https://dinosaure.github.io/carton/" +bug-reports: "https://github.com/dinosaure/carton/issues" depends: [ - "ocaml" {>= "4.07.0"} - "dune" {>= "2.6.0"} + "ocaml" {>= "4.07.0"} + "dune" {>= "2.6.0"} "carton" "lwt" "decompress" {>= "1.2.0"} - "optint" {>= "0.0.4"} + "optint" {>= "0.0.4"} "bigstringaf" + "alcotest" {>= "1.2.3" & with-test} + "alcotest-lwt" {>= "1.2.3" & with-test} + "cstruct" {>= "6.0.0" & with-test} + "fmt" {>= "0.8.9" & with-test} + "logs" {>= "0.7.0" & with-test} + "mirage-flow" {>= "2.0.1" & with-test} + "result" {>= "1.5" & with-test} + "rresult" {>= "0.6.0" & with-test} +] +build: [ + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] +dev-repo: "git+https://github.com/dinosaure/carton.git" diff --git a/carton.opam b/carton.opam index d05377b4a..13c3850ed 100644 --- a/carton.opam +++ b/carton.opam @@ -1,48 +1,50 @@ opam-version: "2.0" -name: "carton" -maintainer: "Romain Calascibetta " -authors: "Romain Calascibetta " -homepage: "https://github.com/mirage/ocaml-git" -bug-reports: "https://github.com/mirage/ocaml-git/issues" -dev-repo: "git+https://github.com/mirage/ocaml-git.git" -doc: "https://mirage.github.io/ocaml-git/" -license: "MIT" -synopsis: "Implementation of PACKv2 file in OCaml" -description: """Carton is an implementation of the PACKv2 file +name: "carton" +synopsis: "Implementation of PACKv2 file in OCaml" +description: """\ +Carton is an implementation of the PACKv2 file in OCaml. PACKv2 file is used by Git to store Git objects. -Carton is more abstracted when it can store any objects. -""" - -build: [ - [ "dune" "build" "-p" name "-j" jobs ] - [ "dune" "runtest" "-p" name "-j" jobs ] {with-test} -] - +Carton is more abstracted when it can store any objects.""" +maintainer: "Romain Calascibetta " +authors: "Romain Calascibetta " +license: "MIT" +homepage: "https://github.com/mirage/ocaml-git" +doc: "https://mirage.github.io/ocaml-git/" +bug-reports: "https://github.com/mirage/ocaml-git/issues" depends: [ - "ocaml" {>= "4.07.0"} - "dune" {>= "2.6.0"} - "ke" {>= "0.4"} - "duff" {>= "0.3"} - "decompress" {>= "1.2.0"} - "cstruct" {>= "5.0.0"} - "optint" {>= "0.0.4"} + "ocaml" {>= "4.07.0"} + "dune" {>= "2.6.0"} + "ke" {>= "0.4"} + "duff" {>= "0.3"} + "decompress" {>= "1.2.0"} + "cstruct" {>= "5.0.0"} + "optint" {>= "0.0.4"} "bigstringaf" "stdlib-shims" "bigarray-compat" - "checkseum" {>= "0.2.1"} + "checkseum" {>= "0.2.1"} "logs" "bigstringaf" - "psq" {>= "0.2.0"} - "fmt" {>= "0.8.7"} - "result" {with-test} - "rresult" {with-test} - "fpath" {with-test} - "base64" {with-test & >= "3.0.0"} - "bos" {with-test} - "digestif" {with-test & >= "0.8.1"} - "mmap" {with-test} - "base-unix" {with-test} + "psq" {>= "0.2.0"} + "fmt" {>= "0.8.7"} + "result" {with-test} + "rresult" {with-test} + "fpath" {with-test} + "base64" {with-test & >= "3.0.0"} + "bos" {with-test} + "digestif" {with-test & >= "0.8.1"} + "mmap" {with-test} + "base-unix" {with-test} "base-threads" {with-test} - "alcotest" {with-test} - "crowbar" {with-test & >= "0.2"} + "alcotest" {with-test} + "crowbar" {with-test & >= "0.2"} + "alcotest-lwt" {>= "1.2.3" & with-test} + "lwt" {>= "5.3.0" & with-test} + "ocamlfind" {>= "1.8.1" & with-test} + "mirage-flow" {>= "2.0.1" & with-test} +] +build: [ + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] +dev-repo: "git+https://github.com/mirage/ocaml-git.git" diff --git a/git-cohttp-mirage.opam b/git-cohttp-mirage.opam index 9e5d233d4..1c98cf3f2 100644 --- a/git-cohttp-mirage.opam +++ b/git-cohttp-mirage.opam @@ -1,33 +1,34 @@ opam-version: "2.0" -maintainer: [ "thomas@gazagnaire.org" - "romain.calascibetta@gmail.com" ] -authors: "Thomas Gazagnaire" -license: "ISC" -homepage: "https://github.com/mirage/ocaml-git" -bug-reports: "https://github.com/mirage/ocaml-git/issues" -dev-repo: "git+https://github.com/mirage/ocaml-git.git" -doc: "https://mirage.github.io/ocaml-git/" -synopsis: "A package to use HTTP-based ocaml-git with MirageOS backend" - -build: [ - ["dune" "subst"] - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j1" "--no-buffer"] {with-test} -] - +synopsis: "A package to use HTTP-based ocaml-git with MirageOS backend" +maintainer: ["thomas@gazagnaire.org" "romain.calascibetta@gmail.com"] +authors: "Thomas Gazagnaire" +license: "ISC" +homepage: "https://github.com/mirage/ocaml-git" +doc: "https://mirage.github.io/ocaml-git/" +bug-reports: "https://github.com/mirage/ocaml-git/issues" depends: [ - "ocaml" {>= "4.07.0"} - "dune" {>= "2.6.0"} + "ocaml" {>= "4.07.0"} + "dune" {>= "2.6.0"} "git" - "git-cohttp" + "mimic" "cohttp-mirage" + "cohttp" {>= "2.5.4"} + "cohttp-lwt" {>= "2.5.4"} + "fmt" {>= "0.8.9"} + "lwt" {>= "5.3.0"} + "result" {>= "1.5"} + "rresult" {>= "0.6.0"} + "uri" {>= "4.0.0"} + "alcotest" {>= "1.2.3" & with-test} + "alcotest-lwt" {>= "1.2.3" & with-test} + "bigstringaf" {>= "0.7.0" & with-test} + "cstruct" {>= "6.0.0" & with-test} + "logs" {>= "0.7.0" & with-test} + "mirage-flow" {>= "2.0.1" & with-test} ] - -pin-depends: [ - [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] - [ "conduit-tls.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] - [ "conduit-mirage.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] - [ "cohttp.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#7f0efc6d7e0420e3abff99d29633519785c41f4b" ] - [ "cohttp-lwt.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#7f0efc6d7e0420e3abff99d29633519785c41f4b" ] - [ "cohttp-mirage.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#7f0efc6d7e0420e3abff99d29633519785c41f4b" ] +build: [ + ["dune" "subst"] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j1" "--no-buffer"] {with-test} ] +dev-repo: "git+https://github.com/mirage/ocaml-git.git" diff --git a/git-cohttp-unix.opam b/git-cohttp-unix.opam index ee52befeb..a32f38620 100644 --- a/git-cohttp-unix.opam +++ b/git-cohttp-unix.opam @@ -1,34 +1,34 @@ opam-version: "2.0" -maintainer: [ "thomas@gazagnaire.org" - "romain.calascibetta@gmail.com" ] -authors: "Thomas Gazagnaire" -license: "ISC" -homepage: "https://github.com/mirage/ocaml-git" -bug-reports: "https://github.com/mirage/ocaml-git/issues" -dev-repo: "git+https://github.com/mirage/ocaml-git.git" -doc: "https://mirage.github.io/ocaml-git/" -synopsis: "A package to use HTTP-based ocaml-git with Unix backend" - -build: [ - ["dune" "subst"] - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j1" "--no-buffer"] {with-test} -] - +synopsis: "A package to use HTTP-based ocaml-git with Unix backend" +maintainer: ["thomas@gazagnaire.org" "romain.calascibetta@gmail.com"] +authors: "Thomas Gazagnaire" +license: "ISC" +homepage: "https://github.com/mirage/ocaml-git" +doc: "https://mirage.github.io/ocaml-git/" +bug-reports: "https://github.com/mirage/ocaml-git/issues" depends: [ - "ocaml" {>= "4.07.0"} - "dune" {>= "2.6.0"} + "ocaml" {>= "4.07.0"} + "dune" {>= "2.6.0"} "git" "git-cohttp" "cohttp-lwt-unix" + "cohttp" {>= "2.5.4"} + "cohttp-lwt" {>= "2.5.4"} + "fmt" {>= "0.8.9"} + "lwt" {>= "5.3.0"} + "result" {>= "1.5"} + "rresult" {>= "0.6.0"} + "uri" {>= "4.0.0"} + "alcotest" {>= "1.2.3" & with-test} + "alcotest-lwt" {>= "1.2.3" & with-test} + "bigstringaf" {>= "0.7.0" & with-test} + "cstruct" {>= "6.0.0" & with-test} + "logs" {>= "0.7.0" & with-test} + "mirage-flow" {>= "2.0.1" & with-test} ] - -pin-depends: [ - [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] - [ "conduit-tls.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] - [ "conduit-lwt.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] - [ "conduit-lwt-tls.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] - [ "cohttp.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#7f0efc6d7e0420e3abff99d29633519785c41f4b" ] - [ "cohttp-lwt.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#7f0efc6d7e0420e3abff99d29633519785c41f4b" ] - [ "cohttp-lwt-unix.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#7f0efc6d7e0420e3abff99d29633519785c41f4b" ] +build: [ + ["dune" "subst"] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j1" "--no-buffer"] {with-test} ] +dev-repo: "git+https://github.com/mirage/ocaml-git.git" diff --git a/git-cohttp.opam b/git-cohttp.opam index a8dc8fac1..e1e83168a 100644 --- a/git-cohttp.opam +++ b/git-cohttp.opam @@ -1,29 +1,33 @@ opam-version: "2.0" -maintainer: [ "thomas@gazagnaire.org" - "romain.calascibetta@gmail.com" ] -authors: "Thomas Gazagnaire" -license: "ISC" -homepage: "https://github.com/mirage/ocaml-git" -bug-reports: "https://github.com/mirage/ocaml-git/issues" -dev-repo: "git+https://github.com/mirage/ocaml-git.git" -doc: "https://mirage.github.io/ocaml-git/" -synopsis: "A package to use HTTP-based ocaml-git with Unix backend" - -build: [ - ["dune" "subst"] - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j1" "--no-buffer"] {with-test} -] - +synopsis: "A package to use HTTP-based ocaml-git with Unix backend" +maintainer: ["thomas@gazagnaire.org" "romain.calascibetta@gmail.com"] +authors: "Thomas Gazagnaire" +license: "ISC" +homepage: "https://github.com/mirage/ocaml-git" +doc: "https://mirage.github.io/ocaml-git/" +bug-reports: "https://github.com/mirage/ocaml-git/issues" depends: [ - "ocaml" {>= "4.07.0"} - "dune" {>= "2.6.0"} + "ocaml" {>= "4.07.0"} + "dune" {>= "2.6.0"} "git" "cohttp" "cohttp-lwt" + "conduit" {>= "2.1.0"} + "fmt" {>= "0.8.9"} + "lwt" {>= "5.3.0"} + "result" {>= "1.5"} + "rresult" {>= "0.6.0"} + "uri" {>= "4.0.0"} + "alcotest" {>= "1.2.3" & with-test} + "alcotest-lwt" {>= "1.2.3" & with-test} + "bigstringaf" {>= "0.7.0" & with-test} + "cstruct" {>= "6.0.0" & with-test} + "logs" {>= "0.7.0" & with-test} + "mirage-flow" {>= "2.0.1" & with-test} ] - -pin-depends: [ - [ "cohttp.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#10ce452be074e91400c81271fd444af62c130019" ] - [ "cohttp-lwt.dev" "git+https://github.com/dinosaure/ocaml-cohttp.git#10ce452be074e91400c81271fd444af62c130019" ] +build: [ + ["dune" "subst"] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j1" "--no-buffer"] {with-test} ] +dev-repo: "git+https://github.com/mirage/ocaml-git.git" diff --git a/git-mirage.opam b/git-mirage.opam new file mode 100644 index 000000000..a50c9e671 --- /dev/null +++ b/git-mirage.opam @@ -0,0 +1,45 @@ +opam-version: "2.0" +synopsis: "A package to use ocaml-git with MirageOS backend" +maintainer: ["thomas@gazagnaire.org" "romain.calascibetta@gmail.com"] +authors: "Thomas Gazagnaire" +license: "ISC" +homepage: "https://github.com/mirage/ocaml-git" +doc: "https://mirage.github.io/ocaml-git/" +bug-reports: "https://github.com/mirage/ocaml-git/issues" +depends: [ + "ocaml" {>= "4.07.0"} + "dune" {>= "2.6.0"} + "mimic" + "mirage-stack" + "git-nss" + "awa" + "awa-mirage" + "dns-client" {>= "4.6.2"} + "domain-name" {>= "0.3.0"} + "fmt" {>= "0.8.9"} + "ipaddr" {>= "5.0.1"} + "lwt" {>= "5.3.0"} + "mirage-clock" {>= "3.1.0"} + "mirage-flow" {>= "2.0.1"} + "mirage-protocols" {>= "5.0.0"} + "mirage-random" {>= "2.0.0"} + "mirage-time" {>= "2.0.1"} + "result" {>= "1.5"} + "rresult" {>= "0.6.0"} + "alcotest" {>= "1.2.3" & with-test} + "alcotest-lwt" {>= "1.2.3" & with-test} + "bigstringaf" {>= "0.7.0" & with-test} + "cstruct" {>= "6.0.0" & with-test} + "logs" {>= "0.7.0" & with-test} +] +build: [ + ["dune" "subst"] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j1" "--no-buffer"] {with-test} +] +dev-repo: "git+https://github.com/mirage/ocaml-git.git" + +pin-depends: [ + [ "awa.dev" "git+https://github.com/mirage/awa-ssh.git#c337fbac71e3699ba4bcefe9382c9842354b3bee" ] + [ "awa-mirage.dev" "git+https://github.com/mirage/awa-ssh.git#c337fbac71e3699ba4bcefe9382c9842354b3bee" ] +] diff --git a/git-nss.opam b/git-nss.opam index c4e06cd0e..8508b27d6 100644 --- a/git-nss.opam +++ b/git-nss.opam @@ -1,51 +1,52 @@ opam-version: "2.0" -name: "git-nss" -maintainer: "Romain Calascibetta " -authors: "Romain Calascibetta " -homepage: "https://github.com/mirage/decompress" -bug-reports: "https://github.com/mirage/decompress/issues" -dev-repo: "git+https://github.com/mirage/decompress.git" -doc: "https://mirage.github.io/decompress/" -license: "MIT" -synopsis: "Not So Smart - Implementation of Smart protocol" - -build: [ - [ "dune" "build" "-p" name "-j" jobs ] - [ "dune" "runtest" "-p" name "-j" jobs ] {with-test} -] - +name: "git-nss" +synopsis: "Not So Smart - Implementation of Smart protocol" +maintainer: "Romain Calascibetta " +authors: "Romain Calascibetta " +license: "MIT" +homepage: "https://github.com/mirage/decompress" +doc: "https://mirage.github.io/decompress/" +bug-reports: "https://github.com/mirage/decompress/issues" depends: [ - "ocaml" {>= "4.07.0"} - "dune" {>= "2.6.0"} - "emile" {>= "0.9"} + "ocaml" {>= "4.07.0"} + "dune" {>= "2.6.0"} + "emile" {>= "0.9"} "stdlib-shims" "rresult" "result" - "fmt" {>= "0.8.7"} - "cstruct" {>= "5.0.0"} + "fmt" {>= "0.8.7"} + "cstruct" {>= "5.0.0"} "domain-name" "astring" "logs" - "psq" {>= "0.2.0"} + "psq" {>= "0.2.0"} "carton" "carton-lwt" - "conduit" "uri" - "digestif" {>= "0.8.1"} - "decompress" {>= "1.2.0"} + "mimic" + "digestif" {>= "0.8.1"} + "decompress" {>= "1.2.0"} "bigstringaf" - "ocurl" {with-test} + "ocurl" {with-test} "mirage-crypto-rng" {with-test & >= "0.8.0"} - "bos" {with-test} - "fpath" {with-test} - "conduit-lwt" {with-test} - "base-unix" {with-test} - "mmap" {with-test} - "alcotest-lwt" {with-test} - "crowbar" {with-test & >= "0.2"} + "bos" {with-test} + "fpath" {with-test} + "base-unix" {with-test} + "mmap" {with-test} + "alcotest-lwt" {with-test} + "crowbar" {with-test & >= "0.2"} + "bigarray-compat" {>= "1.0.0"} + "conduit" {>= "2.1.0"} + "ipaddr" {>= "5.0.1"} + "ke" {>= "0.4"} + "lwt" {>= "5.3.0"} + "mirage-flow" {>= "2.0.1"} + "alcotest" {>= "1.2.3" & with-test} + "cohttp-lwt-unix" {>= "2.5.4" & with-test} + "conduit-lwt" {>= "2.1.0" & with-test} ] - -pin-depends: [ - [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] - [ "conduit-lwt.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] +build: [ + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} ] +dev-repo: "git+https://github.com/mirage/decompress.git" diff --git a/git-unix.opam b/git-unix.opam index de8d048af..43ac3f2aa 100644 --- a/git-unix.opam +++ b/git-unix.opam @@ -1,53 +1,60 @@ opam-version: "2.0" -maintainer: [ "thomas@gazagnaire.org" - "romain.calascibetta@gmail.com" ] -authors: "Thomas Gazagnaire" -license: "ISC" -homepage: "https://github.com/mirage/ocaml-git" -bug-reports: "https://github.com/mirage/ocaml-git/issues" -dev-repo: "git+https://github.com/mirage/ocaml-git.git" -doc: "https://mirage.github.io/ocaml-git/" -synopsis: "Virtual package to install and configure ocaml-git's Unix backend" - -build: [ - ["dune" "subst"] - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name "-j1" "--no-buffer"] {with-test} -] - +synopsis: "Virtual package to install and configure ocaml-git's Unix backend" +maintainer: ["thomas@gazagnaire.org" "romain.calascibetta@gmail.com"] +authors: "Thomas Gazagnaire" +license: "ISC" +homepage: "https://github.com/mirage/ocaml-git" +doc: "https://mirage.github.io/ocaml-git/" +bug-reports: "https://github.com/mirage/ocaml-git/issues" depends: [ - "ocaml" {>= "4.07.0"} - "dune" {>= "2.6.0"} - "mmap" {>= "1.1.0"} + "ocaml" {>= "4.07.0"} + "dune" {>= "2.6.0"} + "mmap" {>= "1.1.0"} "stdlib-shims" "git" - "conduit" - "conduit-lwt" "rresult" "result" "bigarray-compat" "bigstringaf" - "fmt" {>= "0.8.7"} + "fmt" {>= "0.8.7"} "git-nss" "bos" "fpath" "uri" - "digestif" {>= "0.8.1"} + "digestif" {>= "0.8.1"} "logs" "lwt" "base-unix" - "alcotest" {with-test & >= "1.1.0"} - "alcotest-lwt" {with-test & >= "1.1.0"} - "base64" {with-test & >= "3.0.0"} + "alcotest" {with-test & >= "1.1.0"} + "alcotest-lwt" {with-test & >= "1.1.0"} + "base64" {with-test & >= "3.0.0"} "git-cohttp-unix" "mirage-clock" "mirage-clock-unix" - "awa-conduit" + "astring" {>= "0.8.5"} + "awa" + "cmdliner" {>= "1.0.4"} + "cohttp-lwt-unix" {>= "2.5.4"} + "conduit" {>= "2.1.0"} + "conduit-lwt" {>= "2.1.0"} + "decompress" {>= "1.2.0"} + "domain-name" {>= "0.3.0"} + "ipaddr" {>= "5.0.1"} + "mtime" {>= "1.2.0"} + "ocamlfind" {>= "1.8.1"} + "tcpip" {>= "6.0.0"} + "cstruct" {>= "6.0.0" & with-test} + "awa-mirage" + "mirage-flow" {>= "2.0.1"} +] +build: [ + ["dune" "subst"] + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j1" "--no-buffer"] {with-test} ] +dev-repo: "git+https://github.com/mirage/ocaml-git.git" pin-depends: [ - [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] - [ "conduit-lwt.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] - [ "awa.dev" "git+https://github.com/dinosaure/awa-ssh.git#e54302ecd5fe541c2fbecb277cb11bba40032b81"] - [ "awa-conduit.dev" "git+https://github.com/dinosaure/awa-ssh.git#e54302ecd5fe541c2fbecb277cb11bba40032b81"] + [ "awa.dev" "git+https://github.com/mirage/awa-ssh.git#c337fbac71e3699ba4bcefe9382c9842354b3bee" ] + [ "awa-mirage.dev" "git+https://github.com/mirage/awa-ssh.git#c337fbac71e3699ba4bcefe9382c9842354b3bee" ] ] diff --git a/git.opam b/git.opam index 633259b67..ce1c73dcc 100644 --- a/git.opam +++ b/git.opam @@ -1,14 +1,6 @@ opam-version: "2.0" -maintainer: [ "thomas@gazagnaire.org" - "romain.calascibetta@gmail.com" ] -authors: "Thomas Gazagnaire" -license: "ISC" -homepage: "https://github.com/mirage/ocaml-git" -bug-reports: "https://github.com/mirage/ocaml-git/issues" -dev-repo: "git+https://github.com/mirage/ocaml-git.git" -doc: "https://mirage.github.io/ocaml-git/" -synopsis: "Git format and protocol in pure OCaml" -description: """ +synopsis: "Git format and protocol in pure OCaml" +description: """\ Support for on-disk and in-memory Git stores. Can read and write all the Git objects: the usual blobs, trees, commits and tags but also the pack files, pack indexes and the index file (where the staging area @@ -16,16 +8,16 @@ lives). All the objects share a consistent API, and convenience functions are provided to manipulate the different objects.""" - -build: [ - ["dune" "build" "-p" name "-j" jobs] - ["dune" "runtest" "-p" name] {with-test} -] - +maintainer: ["thomas@gazagnaire.org" "romain.calascibetta@gmail.com"] +authors: "Thomas Gazagnaire" +license: "ISC" +homepage: "https://github.com/mirage/ocaml-git" +doc: "https://mirage.github.io/ocaml-git/" +bug-reports: "https://github.com/mirage/ocaml-git/issues" depends: [ - "ocaml" {>= "4.07.0"} - "dune" {>= "2.6.0"} - "digestif" {>= "0.8.1"} + "ocaml" {>= "4.07.0"} + "dune" {>= "2.6.0"} + "digestif" {>= "0.8.1"} "stdlib-shims" "rresult" "result" @@ -34,30 +26,32 @@ depends: [ "bigstringaf" "optint" "decompress" - "conduit" "logs" "lwt" - "cstruct" {>= "5.0.0"} - "angstrom" {>= "0.14.0"} + "cstruct" {>= "5.0.0"} + "angstrom" {>= "0.14.0"} "carton" "carton-lwt" "carton-git" - "ke" {>= "0.4"} - "fmt" {>= "0.8.7"} - "checkseum" {>= "0.2.1"} - "ocamlgraph" {>= "1.8.8"} + "ke" {>= "0.4"} + "fmt" {>= "0.8.7"} + "checkseum" {>= "0.2.1"} + "ocamlgraph" {>= "1.8.8"} "astring" "fpath" - "encore" {>= "0.7"} - "alcotest" {with-test & >= "1.1.0"} - "alcotest-lwt" {with-test & >= "1.1.0"} + "encore" {>= "0.7"} + "alcotest" {with-test & >= "1.1.0"} + "alcotest-lwt" {with-test & >= "1.1.0"} "mirage-crypto-rng" {with-test & >= "0.8.0"} - "cmdliner" {with-test} - "base-unix" {with-test} - "fpath" {with-test} - "base64" {with-test & >= "3.0.0"} + "cmdliner" {with-test} + "base-unix" {with-test} + "fpath" + "base64" {with-test & >= "3.0.0"} + "conduit" {>= "2.1.0"} + "mirage-flow" {>= "2.0.1" & with-test} ] - -pin-depends: [ - [ "conduit.dev" "git+https://github.com/mirage/ocaml-conduit.git#8912d458b2f3e43245e99cf3cb74e9c00712a8b0" ] +build: [ + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name] {with-test} ] +dev-repo: "git+https://github.com/mirage/ocaml-git.git" diff --git a/mimic.opam b/mimic.opam new file mode 100644 index 000000000..66c1b7afe --- /dev/null +++ b/mimic.opam @@ -0,0 +1,29 @@ +opam-version: "2.0" +synopsis: "A simple protocol dispatcher" +description: "A middleware to dispatch protocols used by Git" +maintainer: ["thomas@gazagnaire.org" "romain.calascibetta@gmail.com"] +authors: "Thomas Gazagnaire" +license: "ISC" +homepage: "https://github.com/mirage/ocaml-git" +doc: "https://mirage.github.io/ocaml-git/" +bug-reports: "https://github.com/mirage/ocaml-git/issues" +depends: [ + "ocaml" {>= "4.07.0"} + "dune" {>= "2.6.0"} + "hmap" + "fmt" {>= "0.8.9"} + "lwt" {>= "5.3.0"} + "mirage-flow" {>= "2.0.1"} + "result" {>= "1.5"} + "rresult" {>= "0.6.0"} + "alcotest" {>= "1.2.3" & with-test} + "alcotest-lwt" {>= "1.2.3" & with-test} + "bigstringaf" {>= "0.7.0" & with-test} + "cstruct" {>= "6.0.0" & with-test} + "logs" {>= "0.7.0"} +] +build: [ + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name] {with-test} +] +dev-repo: "git+https://github.com/mirage/ocaml-git.git" diff --git a/src/git-cohttp-mirage/dune b/src/git-cohttp-mirage/dune index 845cfc7fe..0e2f20db3 100644 --- a/src/git-cohttp-mirage/dune +++ b/src/git-cohttp-mirage/dune @@ -1,5 +1,5 @@ (library (name git_cohttp_mirage) (public_name git-cohttp-mirage) - (libraries git-cohttp lwt rresult result git-nss.git uri fmt cohttp - cohttp-lwt cohttp-mirage)) + (libraries mimic lwt rresult result git-nss.git uri fmt cohttp cohttp-lwt + cohttp-mirage)) diff --git a/src/git-cohttp-mirage/git_cohttp_mirage.ml b/src/git-cohttp-mirage/git_cohttp_mirage.ml index 3556b2339..29566f4b0 100644 --- a/src/git-cohttp-mirage/git_cohttp_mirage.ml +++ b/src/git-cohttp-mirage/git_cohttp_mirage.ml @@ -1 +1,49 @@ -include Git_cohttp.Make (Cohttp_mirage.Client) +open Lwt.Infix + +type error = | + +let pp_error : error Fmt.t = fun _ppf -> function _ -> . +let conduit = Mimic.make ~name:"conduit" +let with_conduit v ctx = Mimic.add conduit v ctx + +let with_redirects ?(max = 10) ~f uri = + if max < 10 then invalid_arg "with_redirects"; + let tbl = Hashtbl.create 0x10 in + let rec go max uri = + f uri >>= fun (resp, body) -> + let status_code = Cohttp.(Response.status resp |> Code.code_of_status) in + if Cohttp.Code.is_redirection status_code then + match Cohttp.(Response.headers resp |> Header.get_location) with + | Some uri' when Hashtbl.mem tbl uri' || max = 0 -> Lwt.return (resp, body) + | Some uri' -> + Hashtbl.add tbl uri' (); + Cohttp_lwt.Body.drain_body body >>= fun () -> go (pred max) uri' + | None -> Lwt.return (resp, body) + else Lwt.return (resp, body) + in + go max uri + +let get ~ctx ?(headers = []) uri = + let ctx = + match Mimic.get conduit ctx with + | Some ctx -> ctx + | None -> Cohttp_mirage.Client.default_ctx + in + let headers = Cohttp.Header.of_list headers in + let f uri = Cohttp_mirage.Client.get ~ctx ~headers uri in + with_redirects ~f uri >>= fun (_resp, body) -> + Cohttp_lwt.Body.to_string body >>= fun body -> Lwt.return_ok ((), body) + +let post ~ctx ?(headers = []) uri body = + let ctx = + match Mimic.get conduit ctx with + | Some ctx -> ctx + | None -> Cohttp_mirage.Client.default_ctx + in + let headers = Cohttp.Header.of_list headers in + let body = Cohttp_lwt.Body.of_string body in + let f uri = + Cohttp_mirage.Client.post ~ctx ~headers ~chunked:false ~body uri + in + with_redirects ~f uri >>= fun (_resp, body) -> + Cohttp_lwt.Body.to_string body >>= fun body -> Lwt.return_ok ((), body) diff --git a/src/git-cohttp-mirage/git_cohttp_mirage.mli b/src/git-cohttp-mirage/git_cohttp_mirage.mli index 7a50c8448..6ac57ee1d 100644 --- a/src/git-cohttp-mirage/git_cohttp_mirage.mli +++ b/src/git-cohttp-mirage/git_cohttp_mirage.mli @@ -1 +1,4 @@ include Smart_git.HTTP + +val conduit : Cohttp_mirage.Client.ctx Mimic.value +val with_conduit : Cohttp_mirage.Client.ctx -> Mimic.ctx -> Mimic.ctx diff --git a/src/git-cohttp/git_cohttp.ml b/src/git-cohttp/git_cohttp.ml index 02db21799..6972bc073 100644 --- a/src/git-cohttp/git_cohttp.ml +++ b/src/git-cohttp/git_cohttp.ml @@ -1,21 +1,38 @@ open Lwt.Infix -module Make - (Cohttp_client : Cohttp_lwt.S.Client with type ctx = Conduit.resolvers) = -struct +module Make (Cohttp_client : Cohttp_lwt.S.Client) = struct type error = | let pp_error : error Fmt.t = fun _ppf -> function _ -> . - let get ~resolvers ?(headers = []) uri = + let with_redirects ?(max = 10) ~f uri = + if max < 10 then invalid_arg "with_redirects"; + let tbl = Hashtbl.create 0x10 in + let rec go max uri = + f uri >>= fun (resp, body) -> + let status_code = Cohttp.(Response.status resp |> Code.code_of_status) in + if Cohttp.Code.is_redirection status_code then + match Cohttp.(Response.headers resp |> Header.get_location) with + | Some uri' when Hashtbl.mem tbl uri' || max = 0 -> + Lwt.return (resp, body) + | Some uri' -> + Hashtbl.add tbl uri' (); + Cohttp_lwt.Body.drain_body body >>= fun () -> go (pred max) uri' + | None -> Lwt.return (resp, body) + else Lwt.return (resp, body) + in + go max uri + + let get ~ctx:_ ?(headers = []) uri = let headers = Cohttp.Header.of_list headers in - Cohttp_client.get ~ctx:resolvers ~headers uri >>= fun (_response, body) -> + let f uri = Cohttp_client.get ~headers uri in + with_redirects ~f uri >>= fun (_resp, body) -> Cohttp_lwt.Body.to_string body >>= fun body -> Lwt.return_ok ((), body) - let post ~resolvers ?(headers = []) uri body = + let post ~ctx:_ ?(headers = []) uri body = let headers = Cohttp.Header.of_list headers in let body = Cohttp_lwt.Body.of_string body in - Cohttp_client.post ~ctx:resolvers ~headers ~chunked:false ~body uri - >>= fun (_response, body) -> + let f uri = Cohttp_client.post ~headers ~chunked:false ~body uri in + with_redirects ~f uri >>= fun (_resp, body) -> Cohttp_lwt.Body.to_string body >>= fun body -> Lwt.return_ok ((), body) end diff --git a/src/git-cohttp/git_cohttp.mli b/src/git-cohttp/git_cohttp.mli index e4f8f24eb..3d5f9a7b0 100644 --- a/src/git-cohttp/git_cohttp.mli +++ b/src/git-cohttp/git_cohttp.mli @@ -1,3 +1 @@ -module Make - (Cohttp_client : Cohttp_lwt.S.Client with type ctx = Conduit.resolvers) : - Smart_git.HTTP +module Make (Cohttp_client : Cohttp_lwt.S.Client) : Smart_git.HTTP diff --git a/src/git-mirage/dune b/src/git-mirage/dune new file mode 100644 index 000000000..7e37e5f4f --- /dev/null +++ b/src/git-mirage/dune @@ -0,0 +1,26 @@ +(library + (name git_mirage_tcp) + (modules git_mirage_tcp) + (public_name git-mirage.tcp) + (libraries mimic result fmt lwt mirage-flow ipaddr mirage-protocols + mirage-stack)) + +(library + (name git_mirage_ssh) + (modules git_mirage_ssh) + (public_name git-mirage.ssh) + (libraries git-nss.git mimic result rresult lwt fmt ipaddr mirage-protocols + mirage-stack mirage-flow mirage-clock awa awa-mirage)) + +(library + (name git_mirage_dns) + (modules git_mirage_dns) + (public_name git-mirage.dns) + (libraries mimic git-nss.git domain-name lwt ipaddr mirage-random + mirage-time mirage-clock mirage-protocols mirage-stack dns-client.mirage)) + +(library + (name git_mirage) + (modules git_mirage) + (public_name git-mirage) + (libraries mimic git-nss.git ipaddr mirage-stack mirage-protocols lwt)) diff --git a/src/git-mirage/git_mirage.ml b/src/git-mirage/git_mirage.ml new file mode 100644 index 000000000..766245d56 --- /dev/null +++ b/src/git-mirage/git_mirage.ml @@ -0,0 +1,34 @@ +module Make + (Stack : Mirage_stack.V4) (TCP : sig + val tcp_stack : Stack.t Mimic.value + val tcp_ipaddr : Ipaddr.V4.t Mimic.value + val tcp_port : int Mimic.value + val tcp_endpoint : (Stack.t * Ipaddr.V4.t * int) Mimic.value + end) = +struct + let git_path = Mimic.make ~name:"git-path" + let git_capabilities = Mimic.make ~name:"git-capabilities" + let with_git_path v ctx = Mimic.add git_path v ctx + let fetch ctx = Mimic.add git_capabilities `Rd ctx + let push ctx = Mimic.add git_capabilities `Wr ctx + + let with_resolv ctx = + let k stack ipaddr port _path _cap = + Lwt.return_some (stack, ipaddr, port) + in + Mimic.( + fold TCP.tcp_endpoint + Fun. + [ + req TCP.tcp_stack; req TCP.tcp_ipaddr; dft TCP.tcp_port 9418; + req git_path; dft git_capabilities `Rd; + ] + ~k ctx) + + let ctx = with_resolv Mimic.empty + + let with_smart_git_endpoint edn ctx = + match Smart_git.Endpoint.of_string edn with + | Ok { Smart_git.Endpoint.path; _ } -> with_git_path path ctx + | _ -> ctx +end diff --git a/src/git-mirage/git_mirage.mli b/src/git-mirage/git_mirage.mli new file mode 100644 index 000000000..4688f6d92 --- /dev/null +++ b/src/git-mirage/git_mirage.mli @@ -0,0 +1,16 @@ +module Make + (Stack : Mirage_stack.V4) (TCP : sig + val tcp_stack : Stack.t Mimic.value + val tcp_ipaddr : Ipaddr.V4.t Mimic.value + val tcp_port : int Mimic.value + val tcp_endpoint : (Stack.t * Ipaddr.V4.t * int) Mimic.value + end) : sig + val git_path : string Mimic.value + val git_capabilities : [ `Rd | `Wr ] Mimic.value + val with_git_path : string -> Mimic.ctx -> Mimic.ctx + val fetch : Mimic.ctx -> Mimic.ctx + val push : Mimic.ctx -> Mimic.ctx + val with_resolv : Mimic.ctx -> Mimic.ctx + val ctx : Mimic.ctx + val with_smart_git_endpoint : string -> Mimic.ctx -> Mimic.ctx +end diff --git a/src/git-mirage/git_mirage_dns.ml b/src/git-mirage/git_mirage_dns.ml new file mode 100644 index 000000000..54fde8ba4 --- /dev/null +++ b/src/git-mirage/git_mirage_dns.ml @@ -0,0 +1,32 @@ +module Make + (Random : Mirage_random.S) + (Mclock : Mirage_clock.MCLOCK) + (Time : Mirage_time.S) + (Stack : Mirage_stack.V4) (TCP : sig + val tcp_stack : Stack.t Mimic.value + val tcp_ipaddr : Ipaddr.V4.t Mimic.value + end) = +struct + include Dns_client_mirage.Make (Random) (Time) (Mclock) (Stack) + + let domain_name = Mimic.make ~name:"domain-name" + let with_domain_name v ctx = Mimic.add domain_name v ctx + + let with_resolv ctx = + let open Lwt.Infix in + let k stack domain_name = + let dns = create stack in + gethostbyname dns domain_name >>= function + | Ok ipv4 -> Lwt.return_some ipv4 + | _ -> Lwt.return_none + in + Mimic.( + fold TCP.tcp_ipaddr Fun.[ req TCP.tcp_stack; req domain_name ] ~k ctx) + + let ctx = with_resolv Mimic.empty + + let with_smart_git_endpoint edn ctx = + match Smart_git.Endpoint.of_string edn with + | Ok { Smart_git.Endpoint.host; _ } -> with_domain_name host ctx + | _ -> ctx +end diff --git a/src/git-mirage/git_mirage_dns.mli b/src/git-mirage/git_mirage_dns.mli new file mode 100644 index 000000000..61a39bd0a --- /dev/null +++ b/src/git-mirage/git_mirage_dns.mli @@ -0,0 +1,14 @@ +module Make + (Random : Mirage_random.S) + (Mclock : Mirage_clock.MCLOCK) + (Time : Mirage_time.S) + (Stack : Mirage_stack.V4) (TCP : sig + val tcp_stack : Stack.t Mimic.value + val tcp_ipaddr : Ipaddr.V4.t Mimic.value + end) : sig + val domain_name : [ `host ] Domain_name.t Mimic.value + val with_domain_name : [ `host ] Domain_name.t -> Mimic.ctx -> Mimic.ctx + val with_resolv : Mimic.ctx -> Mimic.ctx + val ctx : Mimic.ctx + val with_smart_git_endpoint : string -> Mimic.ctx -> Mimic.ctx +end diff --git a/src/git-mirage/git_mirage_ssh.ml b/src/git-mirage/git_mirage_ssh.ml new file mode 100644 index 000000000..dbcec0f15 --- /dev/null +++ b/src/git-mirage/git_mirage_ssh.ml @@ -0,0 +1,148 @@ +open Lwt.Infix + +type 'stack endpoint = { + stack : 'stack; + ipaddr : Ipaddr.V4.t; + port : int; + authenticator : Awa.Keys.authenticator option; + user : string; + key : Awa.Hostkey.priv; + path : string; + capabilities : [ `Rd | `Wr ]; +} + +module Make + (Stack : Mirage_stack.V4) (TCP : sig + val tcp_endpoint : (Stack.t * Ipaddr.V4.t * int) Mimic.value + val tcp_stack : Stack.t Mimic.value + val tcp_ipaddr : Ipaddr.V4.t Mimic.value + val tcp_port : int Mimic.value + end) (Git : sig + val git_path : string Mimic.value + val git_capabilities : [ `Rd | `Wr ] Mimic.value + end) + (Mclock : Mirage_clock.MCLOCK) = +struct + module SSH = struct + include Awa_mirage.Make (Stack.TCPV4) (Mclock) + + type nonrec endpoint = Stack.t endpoint + + type nonrec write_error = + [ `Write of write_error | `Connect of error | `Closed ] + + let pp_write_error ppf = function + | `Connect err -> pp_error ppf err + | `Write err -> pp_write_error ppf err + | `Closed as err -> pp_write_error ppf err + + let write flow cs = + write flow cs >>= function + | Ok _ as v -> Lwt.return v + | Error err -> Lwt.return_error (`Write err) + + let writev flow css = + writev flow css >>= function + | Ok _ as v -> Lwt.return v + | Error err -> Lwt.return_error (`Write err) + + let connect edn = + let open Lwt.Infix in + let stack = Stack.tcpv4 edn.stack in + let channel_request = + match edn.capabilities with + | `Rd -> Awa.Ssh.Exec (Fmt.str "git-upload-pack '%s'" edn.path) + | `Wr -> Awa.Ssh.Exec (Fmt.str "git-receive-pack '%s'" edn.path) + in + Stack.TCPV4.create_connection stack (edn.ipaddr, edn.port) >>= function + | Error err -> Lwt.return_error (`Connect (`Read err)) + | Ok flow -> ( + client_of_flow ?authenticator:edn.authenticator ~user:edn.user edn.key + channel_request flow + >>= function + | Error err -> Lwt.return_error (`Connect err) + | Ok _ as v -> Lwt.return v) + end + + type endpoint = SSH.endpoint + type flow = SSH.flow + + let ssh_endpoint, ssh_protocol = + Mimic.register ~name:"mirage-ssh" (module SSH) + + let ssh_authenticator = Mimic.make ~name:"ssh-authenticator" + let ssh_user = Mimic.make ~name:"ssh-user" + let ssh_key = Mimic.make ~name:"ssh-key" + let with_user v ctx = Mimic.add ssh_user v ctx + + let with_authenticator v ctx = + match Awa.Keys.authenticator_of_string v with + | Ok v -> Mimic.add ssh_authenticator v ctx + | Error msg -> failwith msg + + let with_rsa_key v ctx = + let v = Awa.Keys.of_seed `Rsa v in + Mimic.add ssh_key v ctx + + let with_ed25519_key v ctx = + let v = Awa.Keys.of_seed `Ed25519 v in + Mimic.add ssh_key v ctx + + let with_resolv ctx = + let k (stack, ipaddr, port) ssh_authenticator ssh_user ssh_key git_path + git_capabilities = + Lwt.return_some + { + stack; + ipaddr; + port; + authenticator = ssh_authenticator; + user = ssh_user; + key = ssh_key; + path = git_path; + capabilities = git_capabilities; + } + in + let ctx = + Mimic.( + fold ssh_endpoint + Fun. + [ + req TCP.tcp_endpoint; opt ssh_authenticator; req ssh_user; + req ssh_key; req Git.git_path; dft Git.git_capabilities `Rd; + ] + ~k ctx) + in + let k stack ipaddr port = k (stack, ipaddr, port) in + let ctx = + Mimic.( + fold ssh_endpoint + Fun. + [ + req TCP.tcp_stack; req TCP.tcp_ipaddr; dft TCP.tcp_port 22; + opt ssh_authenticator; req ssh_user; req ssh_key; + req Git.git_path; dft Git.git_capabilities `Rd; + ] + ~k ctx) + in + ctx + + let ctx = with_resolv Mimic.empty + + let with_smart_git_endpoint edn ctx = + match Smart_git.Endpoint.of_string edn with + | Ok { Smart_git.Endpoint.scheme = `SSH user; _ } -> with_user user ctx + | _ -> ctx +end + +module Destruct (SSH : sig + type endpoint + type flow + + val ssh_protocol : (endpoint, flow) Mimic.protocol +end) = +struct + include (val Mimic.repr SSH.ssh_protocol) + + let is = function T _ -> true | _ -> false +end diff --git a/src/git-mirage/git_mirage_ssh.mli b/src/git-mirage/git_mirage_ssh.mli new file mode 100644 index 000000000..24291de3f --- /dev/null +++ b/src/git-mirage/git_mirage_ssh.mli @@ -0,0 +1,47 @@ +type 'stack endpoint = { + stack : 'stack; + ipaddr : Ipaddr.V4.t; + port : int; + authenticator : Awa.Keys.authenticator option; + user : string; + key : Awa.Hostkey.priv; + path : string; + capabilities : [ `Rd | `Wr ]; +} + +module Make + (Stack : Mirage_stack.V4) (TCP : sig + val tcp_endpoint : (Stack.t * Ipaddr.V4.t * int) Mimic.value + val tcp_stack : Stack.t Mimic.value + val tcp_ipaddr : Ipaddr.V4.t Mimic.value + val tcp_port : int Mimic.value + end) (Git : sig + val git_path : string Mimic.value + val git_capabilities : [ `Rd | `Wr ] Mimic.value + end) + (Mclock : Mirage_clock.MCLOCK) : sig + type nonrec endpoint = Stack.t endpoint + type flow + + val ssh_endpoint : endpoint Mimic.value + val ssh_protocol : (endpoint, flow) Mimic.protocol + val ssh_authenticator : Awa.Keys.authenticator Mimic.value + val ssh_user : string Mimic.value + val ssh_key : Awa.Hostkey.priv Mimic.value + val with_user : string -> Mimic.ctx -> Mimic.ctx + val with_authenticator : string -> Mimic.ctx -> Mimic.ctx + val with_rsa_key : string -> Mimic.ctx -> Mimic.ctx + val with_ed25519_key : string -> Mimic.ctx -> Mimic.ctx + val with_resolv : Mimic.ctx -> Mimic.ctx + val ctx : Mimic.ctx + val with_smart_git_endpoint : string -> Mimic.ctx -> Mimic.ctx +end + +module Destruct (SSH : sig + type endpoint + type flow + + val ssh_protocol : (endpoint, flow) Mimic.protocol +end) : sig + val is : Mimic.flow -> bool +end diff --git a/src/git-mirage/git_mirage_tcp.ml b/src/git-mirage/git_mirage_tcp.ml new file mode 100644 index 000000000..e5ad3188e --- /dev/null +++ b/src/git-mirage/git_mirage_tcp.ml @@ -0,0 +1,53 @@ +open Lwt.Infix + +module Make (Stack : Mirage_stack.V4) = struct + module TCP = struct + include Stack.TCPV4 + + type endpoint = Stack.t * Ipaddr.V4.t * int + + type nonrec write_error = + [ `Write of write_error | `Connect of error | `Closed ] + + let pp_write_error ppf = function + | `Connect err -> pp_error ppf err + | `Write err -> pp_write_error ppf err + | `Closed as err -> pp_write_error ppf err + + let write flow cs = + write flow cs >>= function + | Ok _ as v -> Lwt.return v + | Error err -> Lwt.return_error (`Write err) + + let writev flow css = + writev flow css >>= function + | Ok _ as v -> Lwt.return v + | Error err -> Lwt.return_error (`Write err) + + let connect : endpoint -> _ = + fun (stack, ipaddr, port) -> + let stack = Stack.tcpv4 stack in + create_connection stack (ipaddr, port) >>= function + | Ok _ as v -> Lwt.return v + | Error err -> Lwt.return_error (`Connect err) + end + + let tcp_endpoint, tcp_protocol = + Mimic.register ~name:"mirage-tcpip" (module TCP) + + let tcp_ipaddr = Mimic.make ~name:"tcp-ipaddr" + let tcp_port = Mimic.make ~name:"tcp-port" + let tcp_stack = Mimic.make ~name:"tcp-stack" + let with_port v ctx = Mimic.add tcp_port v ctx + let with_ipaddr v ctx = Mimic.add tcp_ipaddr v ctx + let with_stack v ctx = Mimic.add tcp_stack v ctx + + let with_resolv ctx = + let k stack ipaddr port = Lwt.return_some (stack, ipaddr, port) in + Mimic.( + fold tcp_endpoint + Fun.[ req tcp_stack; req tcp_ipaddr; req tcp_port ] + ~k ctx) + + let ctx = with_resolv Mimic.empty +end diff --git a/src/git-mirage/git_mirage_tcp.mli b/src/git-mirage/git_mirage_tcp.mli new file mode 100644 index 000000000..224281e36 --- /dev/null +++ b/src/git-mirage/git_mirage_tcp.mli @@ -0,0 +1,15 @@ +module Make (Stack : Mirage_stack.V4) : sig + val tcp_endpoint : (Stack.t * Ipaddr.V4.t * int) Mimic.value + + val tcp_protocol : + (Stack.t * Ipaddr.V4.t * int, Stack.TCPV4.flow) Mimic.protocol + + val tcp_ipaddr : Ipaddr.V4.t Mimic.value + val tcp_port : int Mimic.value + val tcp_stack : Stack.t Mimic.value + val with_port : int -> Mimic.ctx -> Mimic.ctx + val with_ipaddr : Ipaddr.V4.t -> Mimic.ctx -> Mimic.ctx + val with_stack : Stack.t -> Mimic.ctx -> Mimic.ctx + val with_resolv : Mimic.ctx -> Mimic.ctx + val ctx : Mimic.ctx +end diff --git a/src/git-unix/git_unix.ml b/src/git-unix/git_unix.ml index 80978bbd4..f33951edd 100644 --- a/src/git-unix/git_unix.ml +++ b/src/git-unix/git_unix.ml @@ -656,9 +656,7 @@ module Sync (Git_store : Git.S) (HTTP : Smart_git.HTTP) = struct module Log = (val Logs.src_log src : Logs.LOG) include - Git.Sync.Make (Git_store.Hash) (Major_heap) (Major_heap) (Conduit_lwt) - (Git_store) - (HTTP) + Git.Sync.Make (Git_store.Hash) (Major_heap) (Major_heap) (Git_store) (HTTP) let random_gen = lazy (Random.State.make_self_init ()) @@ -719,8 +717,8 @@ module Sync (Git_store : Git.S) (HTTP : Smart_git.HTTP) = struct Lwt.async fill; fun () -> Lwt_stream.get stream - let fetch ?(push_stdout = ignore) ?(push_stderr = ignore) ~resolvers edn store - ?version ?capabilities ?deepen want = + let fetch ?(push_stdout = ignore) ?(push_stderr = ignore) ~ctx ?is_ssh edn + store ?version ?capabilities ?deepen want = let dotgit = Git_store.dotgit store in let temp = Fpath.(dotgit / "tmp") in tmp temp "pack-%s.pack" >>= fun src -> @@ -728,7 +726,7 @@ module Sync (Git_store : Git.S) (HTTP : Smart_git.HTTP) = struct tmp temp "pack-%s.idx" >>= fun idx -> let create_idx_stream () = stream_of_file idx in let create_pack_stream () = stream_of_file dst in - fetch ~push_stdout ~push_stderr ~resolvers edn store ?version ?capabilities - ?deepen want ~src ~dst ~idx ~create_idx_stream ~create_pack_stream temp - temp + fetch ~push_stdout ~push_stderr ~ctx ?is_ssh edn store ?version + ?capabilities ?deepen want ~src ~dst ~idx ~create_idx_stream + ~create_pack_stream temp temp end diff --git a/src/git-unix/ogit-fetch/dune b/src/git-unix/ogit-fetch/dune index 972193127..67b4b1281 100644 --- a/src/git-unix/ogit-fetch/dune +++ b/src/git-unix/ogit-fetch/dune @@ -2,7 +2,8 @@ (name main) (package git-unix) (public_name ogit-fetch) - (libraries git git-unix cohttp-lwt-unix conduit conduit-lwt mirage-clock - mirage-clock-unix awa awa-conduit git-nss.git fpath rresult result lwt + (libraries awa-mirage mirage-flow tcpip.stack-socket ipaddr ipaddr.unix + domain-name mimic git git-unix cohttp-lwt-unix conduit conduit-lwt + mirage-clock mirage-clock-unix awa git-nss.git fpath rresult result lwt lwt.unix git-cohttp-unix cmdliner mtime mtime.clock.os fmt.cli fmt.tty logs.cli logs.fmt)) diff --git a/src/git-unix/ogit-fetch/main.ml b/src/git-unix/ogit-fetch/main.ml index dc7c39422..cd5c2c82f 100644 --- a/src/git-unix/ogit-fetch/main.ml +++ b/src/git-unix/ogit-fetch/main.ml @@ -60,26 +60,123 @@ let pp_error ppf = function | `Store err -> Fmt.pf ppf "(`Store %a)" Store.pp_error err | `Sync err -> Fmt.pf ppf "(`Sync %a)" Sync.pp_error err -module SSH = Awa_conduit.Make (Lwt) (Conduit_lwt) (Mclock) +module TCP = struct + open Lwt.Infix + include Tcpip_stack_socket.V4V6.TCP -let ssh_protocol = SSH.protocol_with_ssh Conduit_lwt.TCP.protocol + type endpoint = Ipaddr.t * int -let ssh_cfg edn ssh_seed = - assert (String.length ssh_seed > 0); - let key = Awa.Keys.of_seed ssh_seed in + type nonrec write_error = + [ `Write of write_error | `Connect of error | `Closed ] + + let pp_write_error ppf = function + | `Write err -> pp_write_error ppf err + | `Connect err -> pp_error ppf err + | `Closed as err -> pp_write_error ppf err + + let write flow cs = + write flow cs >>= function + | Ok _ as v -> Lwt.return v + | Error err -> Lwt.return_error (`Write err) + + let writev flow css = + writev flow css >>= function + | Ok _ as v -> Lwt.return v + | Error err -> Lwt.return_error (`Write err) + + let connect (ipaddr, port) = + let open Lwt.Infix in + connect ~ipv4_only:false ~ipv6_only:false Ipaddr.V4.Prefix.global None + >>= fun t -> + create_connection t (ipaddr, port) >>= function + | Ok _ as v -> Lwt.return v + | Error err -> Lwt.return_error (`Connect err) +end + +module SSH = struct + open Lwt.Infix + include Awa_mirage.Make (Tcpip_stack_socket.V4V6.TCP) (Mclock) + + type nonrec write_error = + [ `Write of write_error | `Connect of error | `Closed ] + + let pp_write_error ppf = function + | `Connect err -> pp_error ppf err + | `Write err -> pp_write_error ppf err + | `Closed as err -> pp_write_error ppf err + + let write flow cs = + write flow cs >>= function + | Ok _ as v -> Lwt.return v + | Error err -> Lwt.return_error (`Write err) + + let writev flow css = + writev flow css >>= function + | Ok _ as v -> Lwt.return v + | Error err -> Lwt.return_error (`Write err) + + type endpoint = { + authenticator : Awa.Keys.authenticator option; + user : string; + path : string; + key : Awa.Hostkey.priv; + endpoint : TCP.endpoint; + } + + let ( >>? ) = Lwt_result.bind + + open Lwt.Infix + + let connect { authenticator; user; path; key; endpoint = ipaddr, port } = + let channel_request = Awa.Ssh.Exec (Fmt.str "git-upload-pack '%s'" path) in + Tcpip_stack_socket.V4V6.TCP.connect ~ipv4_only:false ~ipv6_only:false + Ipaddr.V4.Prefix.global None + >>= fun t -> + Tcpip_stack_socket.V4V6.TCP.create_connection t (ipaddr, port) + >|= Rresult.R.reword_error (fun err -> `Connect (`Read err)) + >>? fun flow -> + client_of_flow ?authenticator ~user key channel_request flow + >|= Rresult.R.reword_error (fun err -> `Connect err) +end + +let tcp_value, tcp_protocol = Mimic.register ~name:"tcp" (module TCP) +let domain_name = Mimic.make ~name:"domain-namme" +let port = Mimic.make ~name:"port" +let ssh_value, ssh_protocol = Mimic.register ~name:"ssh" (module SSH) +let path = Mimic.make ~name:"path" +let seed = Mimic.make ~name:"ssh-seed" +let user = Mimic.make ~name:"user" +let authenticator = Mimic.make ~name:"ssh-authenticator" + +let resolv ctx = + let k domain_name port = + match Unix.gethostbyname (Domain_name.to_string domain_name) with + | { Unix.h_addr_list; _ } when Array.length h_addr_list > 0 -> + Lwt.return_some (Ipaddr_unix.of_inet_addr h_addr_list.(0), port) + | _ | (exception _) -> Lwt.return_none + in + Mimic.fold tcp_value Mimic.Fun.[ req domain_name; dft port 9418 ] ~k ctx + +let resolv_ssh ctx = + let k authenticator sockaddr path user seed = + let key = Awa.Keys.of_seed `Rsa seed in + Lwt.return_some { SSH.authenticator; user; path; key; endpoint = sockaddr } + in + Mimic.fold ssh_value + Mimic.Fun.[ opt authenticator; req tcp_value; req path; req user; req seed ] + ~k ctx + +let of_smart_git_endpoint edn ctx = match edn with - | { Smart_git.Endpoint.scheme = `SSH user; path; _ } -> - let req = Awa.Ssh.Exec (Fmt.str "git-upload-pack '%s'" path) in - Some { Awa_conduit.user; key; req; authenticator = None } - | _ -> None - -let ssh_resolve (ssh_cfg : Awa_conduit.endpoint) domain_name = - let open Lwt.Infix in - Conduit_lwt.TCP.resolve ~port:22 domain_name >|= function - | Some edn -> Some (edn, ssh_cfg) - | None -> None - -let main (ssh_seed : string) + | { Smart_git.Endpoint.scheme = `SSH v_user; path = v_path; host } -> + ctx + |> Mimic.add domain_name host + |> Mimic.add path v_path + |> Mimic.add user v_user + | { Smart_git.Endpoint.path = v_path; host; _ } -> + ctx |> Mimic.add domain_name host |> Mimic.add path v_path + +let main (_ssh_seed : string) (references : (Git.Reference.t * Git.Reference.t) list) (directory : string) (repository : Smart_git.Endpoint.t) : (unit, 'error) Lwt_result.t = let repo_root = @@ -87,18 +184,13 @@ let main (ssh_seed : string) in let ( >>?= ) = Lwt_result.bind in let ( >>!= ) v f = Lwt_result.map_err f v in - let resolvers = - let git_scheme_resolver = Conduit_lwt.TCP.resolve ~port:9418 in - let ssh_cfg = ssh_cfg repository ssh_seed in - Conduit.empty - |> Conduit_lwt.add Conduit_lwt.TCP.protocol git_scheme_resolver - |> Conduit_lwt.add ssh_protocol (ssh_resolve @@ Option.get ssh_cfg) + let ctx = + Mimic.empty |> resolv |> resolv_ssh |> of_smart_git_endpoint repository in Store.v repo_root >>!= store_err >>?= fun store -> let push_stdout = print_endline in let push_stderr = prerr_endline in - Sync.fetch ~push_stdout ~push_stderr ~resolvers repository store - (`Some references) + Sync.fetch ~push_stdout ~push_stderr ~ctx repository store (`Some references) >>!= sync_err >>?= fun _ -> Lwt.return (Ok ()) diff --git a/src/git/dune b/src/git/dune index bd1b1f5d1..343d819e7 100644 --- a/src/git/dune +++ b/src/git/dune @@ -1,8 +1,8 @@ (library (name git) (public_name git) - (libraries stdlib-shims rresult git-nss.sigs git-nss.pck bigarray-compat - optint loose decompress.de decompress.zl result git-nss.smart conduit logs - lwt cstruct angstrom bigstringaf carton ke fmt checkseum git-nss.git - git-nss.hkt ocamlgraph astring fpath loose_git carton-lwt carton-git - digestif encore)) + (libraries mimic stdlib-shims rresult git-nss.sigs git-nss.pck + bigarray-compat optint loose decompress.de decompress.zl result + git-nss.smart conduit logs lwt cstruct angstrom bigstringaf carton ke fmt + checkseum git-nss.git git-nss.hkt ocamlgraph astring fpath loose_git + carton-lwt carton-git digestif encore)) diff --git a/src/git/mem.ml b/src/git/mem.ml index 71e983c02..d0e99cb80 100644 --- a/src/git/mem.ml +++ b/src/git/mem.ml @@ -422,14 +422,7 @@ end module Store = Make (Digestif.SHA1) -module Sync - (Conduit : Conduit.S - with type +'a io = 'a Lwt.t - and type input = Cstruct.t - and type output = Cstruct.t) - (Git_store : Minimal.S) - (HTTP : Smart_git.HTTP) = -struct +module Sync (Git_store : Minimal.S) (HTTP : Smart_git.HTTP) = struct let src = Logs.Src.create "git-mem.sync" ~doc:"logs git-mem's sync event" module Log = (val Logs.src_log src : Logs.LOG) @@ -459,9 +452,7 @@ struct let map _ _ ~pos:_ _ = assert false end - include - Sync.Make (Git_store.Hash) (Cstruct_append) (Index) (Conduit) (Git_store) - (HTTP) + include Sync.Make (Git_store.Hash) (Cstruct_append) (Index) (Git_store) (HTTP) let stream_of_cstruct ?(chunk = 0x1000) payload = let stream, emitter = Lwt_stream.create () in @@ -482,8 +473,8 @@ struct Lwt.async fill; fun () -> Lwt_stream.get stream - let fetch ?(push_stdout = ignore) ?(push_stderr = ignore) ~resolvers edn store - ?version ?capabilities ?deepen want = + let fetch ?(push_stdout = ignore) ?(push_stderr = ignore) ~ctx ?is_ssh edn + store ?version ?capabilities ?deepen want = let t_idx = Carton.Dec.Idx.Device.device () in let t_pck = Cstruct_append.device () in let index = Carton.Dec.Idx.Device.create t_idx in @@ -498,7 +489,7 @@ struct let pack = Cstruct_append.project t_pck dst in stream_of_cstruct pack in - fetch ~push_stdout ~push_stderr ~resolvers edn store ?version ?capabilities - ?deepen want ~src ~dst ~idx:index ~create_idx_stream ~create_pack_stream - t_pck t_idx + fetch ~push_stdout ~push_stderr ~ctx ?is_ssh edn store ?version + ?capabilities ?deepen want ~src ~dst ~idx:index ~create_idx_stream + ~create_pack_stream t_pck t_idx end diff --git a/src/git/mem.mli b/src/git/mem.mli index 0982386cc..05be23c71 100644 --- a/src/git/mem.mli +++ b/src/git/mem.mli @@ -53,11 +53,5 @@ module Store : sig val v : ?dotgit:Fpath.t -> Fpath.t -> (t, error) result Lwt.t end -module Sync - (Conduit : Conduit.S - with type +'a io = 'a Lwt.t - and type input = Cstruct.t - and type output = Cstruct.t) - (Store : Minimal.S) - (HTTP : Smart_git.HTTP) : +module Sync (Store : Minimal.S) (HTTP : Smart_git.HTTP) : Sync.S with type hash = Store.hash and type store = Store.t diff --git a/src/git/sync.ml b/src/git/sync.ml index a86cfd89d..d3de041b2 100644 --- a/src/git/sync.ml +++ b/src/git/sync.ml @@ -23,14 +23,15 @@ module Log = (val Logs.src_log src : Logs.LOG) module type S = sig type hash type store - type error = private [> `Msg of string | `Exn of exn | `Not_found ] + type error = private [> Mimic.error | `Invalid_flow | `Exn of exn ] val pp_error : error Fmt.t val fetch : ?push_stdout:(string -> unit) -> ?push_stderr:(string -> unit) -> - resolvers:Conduit.resolvers -> + ctx:Mimic.ctx -> + ?is_ssh:(Mimic.flow -> bool) -> Smart_git.Endpoint.t -> store -> ?version:[> `V1 ] -> @@ -40,7 +41,7 @@ module type S = sig ((hash * (Reference.t * hash) list) option, error) result Lwt.t val push : - resolvers:Conduit.resolvers -> + ctx:Mimic.ctx -> Smart_git.Endpoint.t -> store -> ?version:[> `V1 ] -> @@ -56,10 +57,6 @@ module Make (Digestif : Digestif.S) (Pack : Smart_git.APPEND with type +'a fiber = 'a Lwt.t) (Index : Smart_git.APPEND with type +'a fiber = 'a Lwt.t) - (Conduit : Conduit.S - with type +'a io = 'a Lwt.t - and type input = Cstruct.t - and type output = Cstruct.t) (Store : Minimal.S with type hash = Digestif.t) (HTTP : Smart_git.HTTP) = struct @@ -67,13 +64,13 @@ struct type store = Store.t type error = - [ `Msg of string | `Exn of exn | `Not_found | `Store of Store.error ] + [ `Exn of exn | `Store of Store.error | `Invalid_flow | Mimic.error ] let pp_error ppf = function - | `Msg err -> Fmt.string ppf err + | #Mimic.error as err -> Mimic.pp_error ppf err | `Exn exn -> Fmt.pf ppf "Exception: %s" (Printexc.to_string exn) - | `Not_found -> Fmt.string ppf "Not found" | `Store err -> Fmt.pf ppf "Store error: %a" Store.pp_error err + | `Invalid_flow -> Fmt.pf ppf "Invalid flow" module Hash = Hash.Make (Digestif) module Scheduler = Hkt.Make_sched (Lwt) @@ -187,16 +184,14 @@ struct Lwt.return (Carton.Dec.v ~kind raw) | None -> Lwt.fail Not_found - include - Smart_git.Make (Scheduler) (Pack) (Index) (Conduit) (HTTP) (Hash) - (Reference) + include Smart_git.Make (Scheduler) (Pack) (Index) (HTTP) (Hash) (Reference) let ( >>? ) x f = x >>= function Ok x -> f x | Error err -> Lwt.return_error err - let fetch ?(push_stdout = ignore) ?(push_stderr = ignore) ~resolvers endpoint - t ?version ?capabilities ?deepen want ~src ~dst ~idx ~create_idx_stream - ~create_pack_stream t_pck t_idx = + let fetch ?(push_stdout = ignore) ?(push_stderr = ignore) ~ctx ?is_ssh + endpoint t ?version ?capabilities ?deepen want ~src ~dst ~idx + ~create_idx_stream ~create_pack_stream t_pck t_idx = let want, src_dst_mapping = match want with | (`All | `None) as x -> x, fun src -> [ src ] @@ -222,7 +217,7 @@ struct `Some src_refs, src_dst_mapping in let ministore = Ministore.inj (t, Hashtbl.create 0x100) in - fetch ~push_stdout ~push_stderr ~resolvers + fetch ~push_stdout ~push_stderr ~ctx ?is_ssh (access, lightly_load t, heavily_load t) ministore endpoint ?version ?capabilities ?deepen want t_pck t_idx ~src ~dst ~idx @@ -295,9 +290,9 @@ struct unshallow = (fun _ -> assert false); } - let push ~resolvers endpoint t ?version ?capabilities cmds = + let push ~ctx endpoint t ?version ?capabilities cmds = let ministore = Ministore.inj (t, Hashtbl.create 0x100) in - push ~resolvers + push ~ctx (access, lightly_load t, heavily_load t) ministore endpoint ?version ?capabilities cmds end diff --git a/src/git/sync.mli b/src/git/sync.mli index ae8059b1f..dc802f427 100644 --- a/src/git/sync.mli +++ b/src/git/sync.mli @@ -22,14 +22,15 @@ module type S = sig type hash type store - type error = private [> `Msg of string | `Exn of exn | `Not_found ] + type error = private [> Mimic.error | `Invalid_flow | `Exn of exn ] val pp_error : error Fmt.t val fetch : ?push_stdout:(string -> unit) -> ?push_stderr:(string -> unit) -> - resolvers:Conduit.resolvers -> + ctx:Mimic.ctx -> + ?is_ssh:(Mimic.flow -> bool) -> Smart_git.Endpoint.t -> store -> ?version:[> `V1 ] -> @@ -39,7 +40,7 @@ module type S = sig ((hash * (Reference.t * hash) list) option, error) result Lwt.t val push : - resolvers:Conduit.resolvers -> + ctx:Mimic.ctx -> Smart_git.Endpoint.t -> store -> ?version:[> `V1 ] -> @@ -57,24 +58,21 @@ module Make (Digestif : Digestif.S) (Pack : Smart_git.APPEND with type +'a fiber = 'a Lwt.t) (Index : Smart_git.APPEND with type +'a fiber = 'a Lwt.t) - (Conduit : Conduit.S - with type +'a io = 'a Lwt.t - and type input = Cstruct.t - and type output = Cstruct.t) (Store : Minimal.S with type hash = Digestif.t) (HTTP : Smart_git.HTTP) : sig type hash = Digestif.t type store = Store.t type error = - [ `Msg of string | `Exn of exn | `Not_found | `Store of Store.error ] + [ `Exn of exn | `Store of Store.error | `Invalid_flow | Mimic.error ] val pp_error : error Fmt.t val fetch : ?push_stdout:(string -> unit) -> ?push_stderr:(string -> unit) -> - resolvers:Conduit.resolvers -> + ctx:Mimic.ctx -> + ?is_ssh:(Mimic.flow -> bool) -> Smart_git.Endpoint.t -> store -> ?version:[> `V1 ] -> @@ -100,7 +98,7 @@ module Make [`None] - doesn't save anything *) val push : - resolvers:Conduit.resolvers -> + ctx:Mimic.ctx -> Smart_git.Endpoint.t -> store -> ?version:[> `V1 ] -> diff --git a/src/mimic/dune b/src/mimic/dune new file mode 100644 index 000000000..d2bb0ae7d --- /dev/null +++ b/src/mimic/dune @@ -0,0 +1,5 @@ +(library + (name mimic) + (public_name mimic) + (modules hmap implicit mirage_protocol mimic) + (libraries logs result rresult fmt mirage-flow lwt)) diff --git a/src/mimic/hmap.ml b/src/mimic/hmap.ml new file mode 100644 index 000000000..f5b84d0ce --- /dev/null +++ b/src/mimic/hmap.ml @@ -0,0 +1,212 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ---------------------------------------------------------------------------*) + +(* Type identifiers. + See http://alan.petitepomme.net/cwn/2015.03.24.html#1 *) + +module Tid = struct type _ t = .. end + +module type Tid = sig + type t + type _ Tid.t += Tid : t Tid.t +end + +type 'a tid = (module Tid with type t = 'a) + +let tid () (type s) = + let module M = struct type t = s type _ Tid.t += Tid : t Tid.t end in + (module M : Tid with type t = s) + +type ('a, 'b) teq = Teq : ('a, 'a) teq + +let eq : type r s. r tid -> s tid -> (r, s) teq option = + fun r s -> + let module R = (val r : Tid with type t = r) in + let module S = (val s : Tid with type t = s) in + match R.Tid with S.Tid -> Some Teq | _ -> None + +(* Heterogeneous maps *) + +module type KEY_INFO = sig + type 'a t +end + +module type VALUE_INFO = sig + type 'a t +end + +module type S = sig + type 'a key + + module Key : sig + type 'a info + + val create : 'a info -> 'a key + val info : 'a key -> 'a info + + type t + + val hide_type : 'a key -> t + val equal : t -> t -> bool + val compare : t -> t -> int + val proof : 'a key -> 'b key -> ('a, 'b) teq option + end + + module Make (Value_info : VALUE_INFO) : sig + type 'a value = 'a Value_info.t + type t + + val empty : t + val is_empty : t -> bool + val mem : 'a key -> t -> bool + val add : 'a key -> 'a value -> t -> t + val singleton : 'a key -> 'a value -> t + val rem : 'a key -> t -> t + val find : 'a key -> t -> 'a value option + val get : 'a key -> t -> 'a value + + type binding = B : 'a key * 'a value -> binding + + val iter : (binding -> unit) -> t -> unit + val fold : (binding -> 'a -> 'a) -> t -> 'a -> 'a + val for_all : (binding -> bool) -> t -> bool + val exists : (binding -> bool) -> t -> bool + val filter : (binding -> bool) -> t -> t + val cardinal : t -> int + val any_binding : t -> binding option + val get_any_binding : t -> binding + val bindings : t -> binding list + + type merge = { + f : 'a. 'a key -> 'a value option -> 'a value option -> 'a value option; + } + + val merge : merge -> t -> t -> t + end +end + +module Make (Key_info : KEY_INFO) : S with type 'a Key.info = 'a Key_info.t = +struct + (* Keys *) + + module Key = struct + type 'a info = 'a Key_info.t + type 'a key = { uid : int; tid : 'a tid; info : 'a Key_info.t } + + let uid = + let id = ref (-1) in + fun () -> + incr id; + !id + + let create info = + let uid = uid () in + let tid = tid () in + { uid; tid; info } + + let info k = k.info + + type t = V : 'a key -> t + + let hide_type k = V k + let equal (V k0) (V k1) = (compare : int -> int -> int) k0.uid k1.uid = 0 + let compare (V k0) (V k1) = (compare : int -> int -> int) k0.uid k1.uid + let proof k0 k1 = eq k0.tid k1.tid + end + + type 'a key = 'a Key.key + + module Make (Value_info : VALUE_INFO) = struct + type 'a value = 'a Value_info.t + + (* Maps *) + + module M = Map.Make (Key) + + type binding = B : 'a key * 'a value -> binding + type t = binding M.t + + let empty = M.empty + let is_empty = M.is_empty + let mem k m = M.mem (Key.V k) m + let add k v m = M.add (Key.V k) (B (k, v)) m + let singleton k v = M.singleton (Key.V k) (B (k, v)) + let rem k m = M.remove (Key.V k) m + + let find : type a. a key -> t -> a value option = + fun k s -> + try + match M.find (Key.V k) s with + | B (k', v) -> ( + match eq k.Key.tid k'.Key.tid with + | None -> None + | Some Teq -> Some v) + with Not_found -> None + + let get k s = + match find k s with + | None -> invalid_arg "key not found in map" + | Some v -> v + + let iter f m = M.iter (fun _ b -> f b) m + let fold f m acc = M.fold (fun _ b acc -> f b acc) m acc + let for_all p m = M.for_all (fun _ b -> p b) m + let exists p m = M.exists (fun _ b -> p b) m + let filter p m = M.filter (fun _ b -> p b) m + let cardinal m = M.cardinal m + let any_binding m = try Some (snd (M.choose m)) with Not_found -> None + + type merge = { + f : 'a. 'a key -> 'a value option -> 'a value option -> 'a value option; + } + + let merge : merge -> t -> t -> t = + fun { f } t0 t1 -> + let f (Key.V k) a b = + match a, b with + | Some (B (k0, v)), None -> ( + match Key.proof k k0 with + | Some Teq -> Option.map (fun v -> B (k, v)) (f k (Some v) None) + | None -> Option.map (fun v -> B (k, v)) (f k None None)) + | None, Some (B (k0, v)) -> ( + match Key.proof k k0 with + | Some Teq -> Option.map (fun v -> B (k, v)) (f k None (Some v)) + | None -> Option.map (fun v -> B (k, v)) (f k None None)) + | Some (B (k0, v0)), Some (B (k1, v1)) -> ( + match Key.proof k k0, Key.proof k k1 with + | Some Teq, Some Teq -> + Option.map (fun v -> B (k, v)) (f k (Some v0) (Some v1)) + | Some Teq, None -> + Option.map (fun v -> B (k, v)) (f k (Some v0) None) + | None, Some Teq -> + Option.map (fun v -> B (k, v)) (f k None (Some v1)) + | None, None -> Option.map (fun v -> B (k, v)) (f k None None)) + | None, None -> Option.map (fun v -> B (k, v)) (f k None None) + in + M.merge f t0 t1 + + let get_any_binding m = + try snd (M.choose m) with Not_found -> invalid_arg "empty map" + + let bindings m = List.map snd (M.bindings m) + end +end + +(*--------------------------------------------------------------------------- + Copyright (c) 2016 Daniel C. Bünzli + + Permission to use, copy, modify, and/or distribute this software for any + purpose with or without fee is hereby granted, provided that the above + copyright notice and this permission notice appear in all copies. + + THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + ---------------------------------------------------------------------------*) diff --git a/src/mimic/hmap.mli b/src/mimic/hmap.mli new file mode 100644 index 000000000..37eae8351 --- /dev/null +++ b/src/mimic/hmap.mli @@ -0,0 +1,164 @@ +(*--------------------------------------------------------------------------- + Copyright (c) 2016 Daniel C. Bünzli. All rights reserved. + Distributed under the ISC license, see terms at the end of the file. + %%NAME%% %%VERSION%% + ---------------------------------------------------------------------------*) + +(** Heterogeneous value maps. + + {e %%VERSION%% - {{:%%PKG_HOMEPAGE%% }homepage}} *) + +(** {1:func Functorial interface} + + The functorial interface allows to associate more information to the + keys. For example a key name or a key value pretty-printer. *) + +(** The type for key information. *) +module type KEY_INFO = sig + type 'a t + (** The type for key information. *) +end + +module type VALUE_INFO = sig + type 'a t + (** The type for value information. *) +end + +type ('a, 'b) teq = Teq : ('a, 'a) teq + +(** Output signature of the functor {!Make} *) +module type S = sig + (** {1:keys Keys} *) + + type 'a key + (** The type for keys whose lookup value is of type ['a]. *) + + (** Keys. *) + module Key : sig + (** {1:keys Keys} *) + + type 'a info + (** The type for key information. *) + + val create : 'a info -> 'a key + (** [create i] is a new key with information [i]. *) + + val info : 'a key -> 'a info + (** [info k] is [k]'s information. *) + + (** {1:exists Existential keys} + + Exisential keys allow to compare keys. This can be useful for + functions like {!filter}. *) + + type t + (** The type for existential keys. *) + + val hide_type : 'a key -> t + (** [hide_type k] is an existential key for [k]. *) + + val equal : t -> t -> bool + (** [equal k k'] is [true] iff [k] and [k'] are the same key. *) + + val compare : t -> t -> int + (** [compare k k'] is a total order on keys compatible with {!equal}. *) + + val proof : 'a key -> 'b key -> ('a, 'b) teq option + end + + module Make (Value_info : VALUE_INFO) : sig + type 'a value = 'a Value_info.t + (** The type for values. *) + + (** {1:maps Maps} *) + + type t + (** The type for heterogeneous value maps. *) + + val empty : t + (** [empty] is the empty map. *) + + val is_empty : t -> bool + (** [is_empty m] is [true] iff [m] is empty. *) + + val mem : 'a key -> t -> bool + (** [mem k m] is [true] iff [k] is bound in [m]. *) + + val add : 'a key -> 'a value -> t -> t + (** [add k v m] is [m] with [k] bound to [v]. *) + + val singleton : 'a key -> 'a value -> t + (** [singleton k v] is [add k v empty]. *) + + val rem : 'a key -> t -> t + (** [rem k m] is [m] with [k] unbound. *) + + val find : 'a key -> t -> 'a value option + (** [find k m] is the value of [k]'s binding in [m], if any. *) + + val get : 'a key -> t -> 'a value + (** [get k m] is the value of [k]'s binding in [m]. + + @raise Invalid_argument if [k] is not bound in [m]. *) + + (** The type for bindings. *) + type binding = B : 'a key * 'a value -> binding + + val iter : (binding -> unit) -> t -> unit + (** [iter f m] applies [f] to all bindings of [m]. *) + + val fold : (binding -> 'a -> 'a) -> t -> 'a -> 'a + (** [fold f m acc] folds over the bindings of [m] with [f], starting with + [acc] *) + + val for_all : (binding -> bool) -> t -> bool + (** [for_all p m] is [true] iff all bindings of [m] satisfy [p]. *) + + val exists : (binding -> bool) -> t -> bool + (** [exists p m] is [true] iff there exists a bindings of [m] that + satisfies [p]. *) + + val filter : (binding -> bool) -> t -> t + (** [filter p m] are the bindings of [m] that satisfy [p]. *) + + val cardinal : t -> int + (** [cardinal m] is the number of bindings in [m]. *) + + val any_binding : t -> binding option + (** [any_binding m] is a binding of [m] (if not empty). *) + + val get_any_binding : t -> binding + (** [get_any_binding m] is a binding of [m]. + + @raise Invalid_argument if [m] is empty. *) + + val bindings : t -> binding list + + type merge = { + f : 'a. 'a key -> 'a value option -> 'a value option -> 'a value option; + } + + val merge : merge -> t -> t -> t + end +end + +(** Functor for heterogeneous maps whose keys hold information + of type [Key_info.t] *) +module Make : functor (Key_info : KEY_INFO) -> + S with type 'a Key.info = 'a Key_info.t + +(*--------------------------------------------------------------------------- + Copyright (c) 2016 Daniel C. Bünzli + + Permission to use, copy, modify, and/or distribute this software for any + purpose with or without fee is hereby granted, provided that the above + copyright notice and this permission notice appear in all copies. + + THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + ---------------------------------------------------------------------------*) diff --git a/src/mimic/implicit.ml b/src/mimic/implicit.ml new file mode 100644 index 000000000..9521dfa78 --- /dev/null +++ b/src/mimic/implicit.ml @@ -0,0 +1,60 @@ +module type KEY_INFO = sig + type 'a t +end + +module Make (Key_info : KEY_INFO) = struct + type t = .. + type 'a key = 'a Key_info.t + + module type WITNESS = sig + type a + type t += T of a + + val key : a key + end + + type 'a witness = (module WITNESS with type a = 'a) + type pack = Key : 'a key -> pack + type value = Value : 'a * 'a key -> value + + let handlers = Hashtbl.create 0x10 + let keys = Hashtbl.create 0x10 + + module Injection (M : sig + type t + + val key : t key + end) : WITNESS with type a = M.t = struct + type a = M.t + type t += T of a + + let key = M.key + let handler = function T a -> Value (a, key) | _ -> raise Not_found + + let () = + let[@warning "-3"] uid = + Stdlib.Obj.extension_id [%extension_constructor T] + in + Hashtbl.add handlers uid handler; + Hashtbl.add keys uid (Key key) + end + + let inj (type a) (key : a key) : a witness = + (module Injection (struct + type t = a + + let key = key + end)) + + let rec iter t = function + | [] -> assert false + | hd :: tl -> ( try hd t with Not_found -> iter t tl) + + let prj t = + let uid = + Stdlib.Obj.((extension_id (extension_constructor t) [@warning "-3"])) + in + iter t (Hashtbl.find_all handlers uid) + + let bindings () = Hashtbl.fold (fun _ v a -> v :: a) keys [] +end diff --git a/src/mimic/implicit.mli b/src/mimic/implicit.mli new file mode 100644 index 000000000..ad0f7459b --- /dev/null +++ b/src/mimic/implicit.mli @@ -0,0 +1,23 @@ +module type KEY_INFO = sig + type 'a t +end + +module Make (Key_info : KEY_INFO) : sig + type t = private .. + type 'a key = 'a Key_info.t + + module type WITNESS = sig + type a + type t += T of a + + val key : a key + end + + type 'a witness = (module WITNESS with type a = 'a) + type pack = Key : 'a key -> pack + type value = Value : 'a * 'a key -> value + + val inj : 'a key -> 'a witness + val prj : t -> value + val bindings : unit -> pack list +end diff --git a/src/mimic/mimic.ml b/src/mimic/mimic.ml new file mode 100644 index 000000000..81364d525 --- /dev/null +++ b/src/mimic/mimic.ml @@ -0,0 +1,401 @@ +type 'a info = { name : string; root : bool } + +let pp_info ppf { name; root } = + if root then Fmt.pf ppf "<%s>" name else Fmt.string ppf name + +open Rresult +module Mirage_protocol = Mirage_protocol +module Info = struct type 'a t = 'a info end +module Hmap0 = Hmap.Make (Info) + +let pp_value ppf value = Fmt.pf ppf "%a" pp_info (Hmap0.Key.info value) +let src = Logs.Src.create "mimic" ~doc:"logs mimic's event" + +module Log = (val Logs.src_log src : Logs.LOG) + +module rec Fun : sig + type ('k, 'res) args = + | [] : ('res, 'res) args + | ( :: ) : 'a arg * ('k, 'res) args -> ('a -> 'k, 'res) args + + and 'v arg = + | Map : ('f, 'a) args * 'f -> 'a arg + | Req : 'a Hmap0.key -> 'a arg + | Opt : 'a Hmap0.key -> 'a option arg + | Dft : 'a * 'a Hmap0.key -> 'a arg + + val req : 'a Hmap0.key -> 'a arg + val opt : 'a Hmap0.key -> 'a option arg + val dft : 'a Hmap0.key -> 'a -> 'a arg + val map : ('k, 'a) args -> 'k -> 'a arg +end = struct + type ('k, 'res) args = + | [] : ('res, 'res) args + | ( :: ) : 'a arg * ('k, 'res) args -> ('a -> 'k, 'res) args + + and 'v arg = + | Map : ('f, 'a) args * 'f -> 'a arg + | Req : 'a Hmap0.key -> 'a arg + | Opt : 'a Hmap0.key -> 'a option arg + | Dft : 'a * 'a Hmap0.key -> 'a arg + + let req value = Req value + let opt value = Opt value + let dft value v = Dft (v, value) + let map args k = Map (args, k) +end + +and Value : sig + type priority = int option + + type 'a elt = + | Val : priority * 'a -> 'a elt + | Fun : priority * ('k, 'a option Lwt.t) Fun.args * 'k -> 'a elt + + type 'a t = 'a elt list +end = struct + type priority = int option + + type 'a elt = + | Val : priority * 'a -> 'a elt + | Fun : priority * ('k, 'a option Lwt.t) Fun.args * 'k -> 'a elt + + type 'a t = 'a elt list +end + +module Hmap = Hmap0.Make (Value) + +type ctx = Hmap.t +type 'edn value = 'edn Hmap0.key + +let merge ctx0 ctx1 = + let f : + type a. + a value -> a Value.t option -> a Value.t option -> a Value.t option = + fun _k lst0 lst1 -> + match lst0, lst1 with + | Some lst0, Some lst1 -> Some (lst0 @ lst1) + | Some x, None | None, Some x -> Some x + | None, None -> None + in + Hmap.merge { f } ctx0 ctx1 + +module Merge (A : sig + val ctx : ctx +end) (B : sig + val ctx : ctx +end) = +struct + let ctx = merge A.ctx B.ctx +end + +let add ?priority value v ctx = + match Hmap.find value ctx with + | Some lst -> Hmap.add value (lst @ [ Val (priority, v) ]) ctx + | None -> Hmap.add value [ Val (priority, v) ] ctx + +let fold ?priority value args ~k ctx = + match Hmap.find value ctx with + | Some lst -> Hmap.add value (lst @ [ Fun (priority, args, k) ]) ctx + | None -> Hmap.add value [ Fun (priority, args, k) ] ctx + +(***** Mirage_flow.S part *****) + +module Implicit0 = Implicit.Make (struct + type 'flow t = (module Mirage_flow.S with type flow = 'flow) +end) + +type flow = Implicit0.t = private .. + +let ( <.> ) f g x = f (g x) + +type error = [ `Msg of string | `Not_found | `Cycle ] +type write_error = [ `Msg of string | `Closed ] + +let pp_error ppf = function + | `Msg err -> Fmt.string ppf err + | `Not_found -> Fmt.string ppf "No connection found" + | `Cycle -> Fmt.string ppf "Context contains a cycle" + +let pp_write_error ppf = function + | `Msg err -> Fmt.string ppf err + | `Closed -> Fmt.string ppf "Connection closed by peer" + +let read flow = + let (Implicit0.Value (flow, (module Flow))) = Implicit0.prj flow in + let open Lwt.Infix in + Flow.read flow >|= R.reword_error (R.msg <.> Fmt.to_to_string Flow.pp_error) + +let write flow cs = + let (Implicit0.Value (flow, (module Flow))) = Implicit0.prj flow in + let open Lwt.Infix in + Flow.write flow cs >|= function + | Error `Closed -> R.error `Closed + | Error _ as err -> + R.reword_error (R.msg <.> Fmt.to_to_string Flow.pp_write_error) err + | Ok _ as v -> v + +let writev flow css = + let (Implicit0.Value (flow, (module Flow))) = Implicit0.prj flow in + let open Lwt.Infix in + Flow.writev flow css + >|= R.reword_error (R.msg <.> Fmt.to_to_string Flow.pp_write_error) + +let close flow = + let (Implicit0.Value (flow, (module Flow))) = Implicit0.prj flow in + Flow.close flow + +(***** Protocol (Mirage_flow.S + connect) part *****) + +type ('edn, 'flow) snd = Snd : 'flow -> ('edn, 'flow) snd [@@warning "-37"] + +type _ pack = + | Protocol : + 'edn Hmap0.key + * 'flow Implicit0.witness + * (module Mirage_protocol.S + with type flow = 'flow + and type endpoint = 'edn) + -> ('edn, 'flow) snd pack + +module Implicit1 = Implicit.Make (struct type 'v t = 'v pack end) + +type ('edn, 'flow) protocol = { + flow : 'flow Implicit0.witness; + protocol : ('edn, 'flow) snd Implicit1.witness; +} + +let register : + type edn flow. + name:string -> + (module Mirage_protocol.S with type flow = flow and type endpoint = edn) -> + edn value * (edn, flow) protocol = + fun ~name (module Protocol) -> + let value = Hmap0.Key.create { name; root = true } in + let flow = Implicit0.inj (module Protocol) in + let protocol = Implicit1.inj (Protocol (value, flow, (module Protocol))) in + value, { flow; protocol } + +module type REPR = sig + type t + type flow += (* XXX(dinosaure): private? *) T of t +end + +let repr : + type edn flow. (edn, flow) protocol -> (module REPR with type t = flow) = + fun { flow; _ } -> + let (module Witness) = flow in + let module M = struct + include Witness + + type t = a + end in + (module M) + +let rec apply : + type k res. ctx -> (k, res option Lwt.t) Fun.args -> k -> res option Lwt.t = + fun ctx args f -> + let open Lwt.Infix in + let rec go : type k res. ctx -> (k, res) Fun.args -> k -> res Lwt.t = + fun ctx -> function + | [] -> fun x -> Lwt.return x + | Map (args', f') :: tl -> + fun f -> go ctx args' f' >>= fun v -> go ctx tl (f v) + | Opt value :: tl -> fun f -> find value ctx >>= fun v -> go ctx tl (f v) + | Dft (v, value) :: tl -> ( + fun f -> + find value ctx >>= function + | Some v' -> + Log.debug (fun m -> + m "Found a value for the default argument: %a." pp_value value); + go ctx tl (f v') + | None -> go ctx tl (f v)) + | Req value :: tl -> ( + fun f -> + find value ctx >>= function + | Some v -> go ctx tl (f v) + | None -> Lwt.fail Not_found) + in + Lwt.catch (fun () -> go ctx args f >>= fun fiber -> fiber) @@ function + | Not_found -> Lwt.return_none + | exn -> Lwt.fail exn + +and find : type a. a value -> ctx -> a option Lwt.t = + fun value ctx -> + match Hmap.find value ctx with + | None | Some [] -> Lwt.return_none + | Some lst -> + (* XXX(dinosaure): priority on values, then we apply the first [Fun] *) + let rec go fold lst = + match fold, lst with + | None, [] -> Lwt.return_none + | Some (Value.Fun (_p, args, f)), [] -> apply ctx args f + | Some (Value.Val _), [] -> assert false + | None, (Value.Fun _ as x) :: r -> go (Some x) r + | _, Val (_p, v) :: _ -> Lwt.return_some v + | Some _, Fun _ :: r -> go fold r + in + go None lst + +type edn = Edn : Value.priority * 'edn value * 'edn -> edn + +type fnu = + | Fun : + Value.priority * 'edn value * ('k, 'edn option Lwt.t) Fun.args * 'k + -> fnu + +type dep = Dep : 'edn value -> dep + +let pp_fnu ppf (Fun (_, dep, _, _)) = + Fmt.pf ppf "%a" pp_info (Hmap0.Key.info dep) + +module Sort = struct + type t = + | Val : Value.priority * 'edn value * 'edn -> t + | Fun : + Value.priority * 'edn value * ('k, 'edn option Lwt.t) Fun.args * 'k + -> t + + let pp ppf = function + | Val (_, k, _) -> pp_info ppf (Hmap0.Key.info k) + | Fun (_, k, _, _) -> pp_info ppf (Hmap0.Key.info k) +end + +let partition bindings = + let rec go leafs nodes = function + | [] -> List.rev leafs, List.rev nodes + | Hmap.B (_, []) :: r -> go leafs nodes r + | Hmap.B (k, Val (p, v) :: tl) :: r -> + go (Sort.Val (p, k, v) :: leafs) nodes (Hmap.B (k, tl) :: r) + | Hmap.B (k, Fun (p, args, f) :: tl) :: r -> + go leafs (Fun (p, k, args, f) :: nodes) (Hmap.B (k, tl) :: r) + in + go [] [] bindings + +let exists k bindings = + let rec go k = function + | [] -> false + | Hmap.B (k', _) :: r -> ( + match Hmap0.Key.proof k k' with Some _ -> true | None -> go k r) + in + go k bindings + +let dependencies (Fun (_, _, args, _)) bindings = + let rec go : type k r. _ -> (k, r) Fun.args -> _ = + fun acc -> function + | Fun.Req dep :: r -> go (Dep dep :: acc) r + | Fun.Opt dep :: r when exists dep bindings -> go (Dep dep :: acc) r + | Fun.Dft (_, dep) :: r when exists dep bindings -> go (Dep dep :: acc) r + | _ :: r -> go acc r + | [] -> List.rev acc + in + go [] args + +let exists leafs (Dep k) = + let rec go = function + | [] -> false + | Sort.Val (_, k', _) :: r -> ( + match Hmap0.Key.proof k k' with Some _ -> true | None -> go r) + | Sort.Fun (_, k', _, _) :: r -> ( + match Hmap0.Key.proof k k' with Some _ -> true | None -> go r) + in + go leafs + +let sort bindings = + let rec go acc later todo progress = + match todo, later with + | [], [] -> List.rev acc + | [], _ when progress -> go acc [] later false + | [], later -> + (* TODO(dinosaure): check, at least, one root in [acc]. *) + Log.warn (fun m -> + m "Found a solution only for: @[%a@]." + Fmt.(Dump.list Sort.pp) + acc); + Log.warn (fun m -> + m "Unsolvable values: @[%a@]." Fmt.(Dump.list pp_fnu) later); + List.rev acc + | (Fun (p, k, args, f) as x) :: xs, _ -> + let deps = dependencies x bindings in + let available = List.for_all (exists acc) deps in + if available then go (Sort.Fun (p, k, args, f) :: acc) later xs true + else go acc (x :: later) xs progress + in + let leafs, nodes = partition bindings in + Log.debug (fun m -> m "Partition done."); + Log.debug (fun m -> m "Nodes: @[%a@]." Fmt.(Dump.list pp_fnu) nodes); + go leafs [] nodes false + +let resolve : ctx -> (edn list, [> `Cycle ]) result Lwt.t = + fun ctx -> + let open Lwt.Infix in + let rec go ctx acc : Sort.t list -> _ = function + | [] -> Lwt.return_ok (List.rev acc) + | Sort.Val (p, k, v) :: r -> + Log.debug (fun m -> m "Return a value %a." pp_value k); + go ctx (Edn (p, k, v) :: acc) r + | Sort.Fun (p, k, args, f) :: r -> ( + Log.debug (fun m -> m "Apply a function %a." pp_value k); + apply ctx args f >>= function + | Some v -> go (add k v ctx) (Edn (p, k, v) :: acc) r + | None -> go ctx acc r) + in + let ordered_bindings = sort (Hmap.bindings ctx) in + go ctx [] ordered_bindings + +let flow_of_value : + type edn. edn value -> edn -> (flow, [> error ]) result Lwt.t = + fun k v -> + let open Lwt.Infix in + let rec go : Implicit1.pack list -> _ = function + | [] -> Lwt.return_error `Not_found + | Implicit1.Key (Protocol (k', (module Witness), (module Protocol))) :: r + -> ( + match Hmap0.Key.proof k k' with + | None -> go r + | Some Teq -> ( + Protocol.connect v >>= function + | Ok flow -> Lwt.return_ok (Witness.T flow) + | Error _err -> go r)) + in + go (Implicit1.bindings ()) + +let inf = -1 +and sup = 1 + +let priority_compare (Edn (p0, _, _)) (Edn (p1, _, _)) = + match p0, p1 with + | None, None -> 0 + | Some p0, Some p1 -> p0 - p1 + | None, Some _ -> inf + | Some _, None -> sup + +let resolve : ctx -> (flow, [> error ]) result Lwt.t = + fun ctx -> + let open Lwt.Infix in + let rec go : edn list -> _ = function + | [] -> Lwt.return_error `Not_found + | Edn (_, k, v) :: r -> ( + flow_of_value k v >>= function + | Ok _ as v -> Lwt.return v + | Error _err -> go r) + in + resolve ctx >>= function + | Ok lst -> + let lst = List.stable_sort priority_compare lst in + go lst + | Error _ as err -> Lwt.return err + +let make ~name = Hmap0.Key.create { name; root = false } +let empty = Hmap.empty + +let get value ctx = + match Hmap.find value ctx with + | Some lst -> + let rec first = function + | [] -> None + | Value.Val (_, v) :: _ -> Some v + | _ :: r -> first r + in + first lst + | None -> None diff --git a/src/mimic/mimic.mli b/src/mimic/mimic.mli new file mode 100644 index 000000000..1e49f29b7 --- /dev/null +++ b/src/mimic/mimic.mli @@ -0,0 +1,62 @@ +module Mirage_protocol = Mirage_protocol + +type flow = private .. + +include + Mirage_flow.S + with type flow := flow + and type error = [ `Msg of string | `Not_found | `Cycle ] + +type ctx +type 'edn value + +module Fun : sig + type ('k, 'res) args = + | [] : ('res, 'res) args + | ( :: ) : 'a arg * ('k, 'res) args -> ('a -> 'k, 'res) args + + and 'v arg + + val req : 'a value -> 'a arg + val opt : 'a value -> 'a option arg + val dft : 'a value -> 'a -> 'a arg + val map : ('k, 'a) args -> 'k -> 'a arg +end + +val make : name:string -> 'edn value +val add : ?priority:int -> 'edn value -> 'edn -> ctx -> ctx +val get : 'edn value -> ctx -> 'edn option + +val fold : + ?priority:int -> + 'edn value -> + ('k, 'edn option Lwt.t) Fun.args -> + k:'k -> + ctx -> + ctx + +val merge : ctx -> ctx -> ctx +val empty : ctx + +type ('edn, 'flow) protocol + +val register : + name:string -> + (module Mirage_protocol.S with type flow = 'flow and type endpoint = 'edn) -> + 'edn value * ('edn, 'flow) protocol + +module type REPR = sig + type t + type flow += (* XXX(dinosaure): private? *) T of t +end + +val repr : ('edn, 'flow) protocol -> (module REPR with type t = 'flow) +val resolve : ctx -> (flow, [> error ]) result Lwt.t + +module Merge (A : sig + val ctx : ctx +end) (B : sig + val ctx : ctx +end) : sig + val ctx : ctx +end diff --git a/src/mimic/mirage_protocol.ml b/src/mimic/mirage_protocol.ml new file mode 100644 index 000000000..e41a85d74 --- /dev/null +++ b/src/mimic/mirage_protocol.ml @@ -0,0 +1,7 @@ +module type S = sig + include Mirage_flow.S + + type endpoint + + val connect : endpoint -> (flow, write_error) result Lwt.t +end diff --git a/src/not-so-smart/dune b/src/not-so-smart/dune index ae4babde0..1e70f635c 100644 --- a/src/not-so-smart/dune +++ b/src/not-so-smart/dune @@ -41,10 +41,17 @@ (modules nss fetch push) (libraries conduit fmt result rresult logs domain-name smart sigs neg pck)) +(library + (name unixiz) + (public_name git-nss.unixiz) + (modules unixiz) + (libraries git-nss.sigs lwt result rresult fmt bigarray-compat mirage-flow + ke cstruct)) + (library (name smart_git) (public_name git-nss.git) (modules smart_git) - (libraries ipaddr decompress.de decompress.zl cstruct logs astring result - rresult bigstringaf fmt emile conduit lwt domain-name uri sigs smart pck - nss digestif carton carton-lwt)) + (libraries mimic mirage-flow unixiz ipaddr decompress.de decompress.zl + cstruct logs astring result rresult bigstringaf fmt emile conduit lwt + domain-name uri sigs smart pck nss digestif carton carton-lwt)) diff --git a/src/not-so-smart/fetch.mli b/src/not-so-smart/fetch.mli index 6a0e4ff14..183d6b5c0 100644 --- a/src/not-so-smart/fetch.mli +++ b/src/not-so-smart/fetch.mli @@ -17,7 +17,7 @@ module Make capabilities:Smart.Capability.t list -> ?deepen:[ `Depth of int | `Timestamp of int64 ] -> ?want:[ `All | `Some of Ref.t list | `None ] -> - host:Conduit.Endpoint.t -> + host:[ `host ] Domain_name.t -> string -> Flow.t -> (Uid.t, Uid.t * int ref * int64, 'g) store -> diff --git a/src/not-so-smart/protocol.ml b/src/not-so-smart/protocol.ml index 13c2c0d82..82f74e82e 100644 --- a/src/not-so-smart/protocol.ml +++ b/src/not-so-smart/protocol.ml @@ -99,7 +99,7 @@ end module Proto_request = struct type t = { path : string; - host : Conduit.Endpoint.t * int option; + host : [ `host ] Domain_name.t * int option; version : int; request_command : [ `Upload_pack | `Receive_pack | `Upload_archive ]; } @@ -119,8 +119,8 @@ module Proto_request = struct | `Upload_archive -> Fmt.pf ppf "git-upload-archive" in let pp_host ppf = function - | host, Some port -> Fmt.pf ppf "%a:%d" Conduit.Endpoint.pp host port - | host, None -> Fmt.pf ppf "%a" Conduit.Endpoint.pp host + | host, Some port -> Fmt.pf ppf "%a:%d" Domain_name.pp host port + | host, None -> Fmt.pf ppf "%a" Domain_name.pp host in Fmt.pf ppf "%a %s %a %a" pp_request_command request_command path Fmt.(prefix (const string " host=") pp_host) @@ -745,12 +745,10 @@ module Encoder = struct in let write_host encoder = function | host, Some port -> - let host = - Fmt.str "host=%s:%d" (Conduit.Endpoint.to_string host) port - in + let host = Fmt.str "host=%s:%d" (Domain_name.to_string host) port in write encoder host | host, None -> - let host = Fmt.str "host=%s" (Conduit.Endpoint.to_string host) in + let host = Fmt.str "host=%s" (Domain_name.to_string host) in write encoder host in let k encoder = diff --git a/src/not-so-smart/protocol.mli b/src/not-so-smart/protocol.mli index 6bd37f634..6fea9213c 100644 --- a/src/not-so-smart/protocol.mli +++ b/src/not-so-smart/protocol.mli @@ -48,10 +48,10 @@ module Proto_request : sig val pp : t Fmt.t val upload_pack : - host:Conduit.Endpoint.t -> ?port:int -> ?version:int -> string -> t + host:[ `host ] Domain_name.t -> ?port:int -> ?version:int -> string -> t val receive_pack : - host:Conduit.Endpoint.t -> ?port:int -> ?version:int -> string -> t + host:[ `host ] Domain_name.t -> ?port:int -> ?version:int -> string -> t end module Want : sig diff --git a/src/not-so-smart/push.mli b/src/not-so-smart/push.mli index 3d3c13bbb..1ed70fb08 100644 --- a/src/not-so-smart/push.mli +++ b/src/not-so-smart/push.mli @@ -14,7 +14,7 @@ module Make ?prelude:bool -> capabilities:Smart.Capability.t list -> [ `Create of Ref.t | `Delete of Ref.t | `Update of Ref.t * Ref.t ] list -> - host:Conduit.Endpoint.t -> + host:[ `host ] Domain_name.t -> string -> Flow.t -> (Uid.t, Uid.t Pck.t, 'git) store -> diff --git a/src/not-so-smart/smart.mli b/src/not-so-smart/smart.mli index 1245404f5..ab0dbacaa 100644 --- a/src/not-so-smart/smart.mli +++ b/src/not-so-smart/smart.mli @@ -56,10 +56,10 @@ module Proto_request : sig val pp : t Fmt.t val upload_pack : - host:Conduit.Endpoint.t -> ?port:int -> ?version:int -> string -> t + host:[ `host ] Domain_name.t -> ?port:int -> ?version:int -> string -> t val receive_pack : - host:Conduit.Endpoint.t -> ?port:int -> ?version:int -> string -> t + host:[ `host ] Domain_name.t -> ?port:int -> ?version:int -> string -> t end module Want : sig diff --git a/src/not-so-smart/smart_git.ml b/src/not-so-smart/smart_git.ml index 18950af3e..d0a38fb7e 100644 --- a/src/not-so-smart/smart_git.ml +++ b/src/not-so-smart/smart_git.ml @@ -41,13 +41,13 @@ module type HTTP = sig val pp_error : error Fmt.t val get : - resolvers:Conduit.resolvers -> + ctx:Mimic.ctx -> ?headers:(string * string) list -> Uri.t -> (unit * string, error) result Lwt.t val post : - resolvers:Conduit.resolvers -> + ctx:Mimic.ctx -> ?headers:(string * string) list -> Uri.t -> string -> @@ -64,19 +64,19 @@ module Endpoint = struct | `HTTP of (string * string) list | `HTTPS of (string * string) list ]; path : string; - endpoint : Conduit.Endpoint.t; + host : [ `host ] Domain_name.t; } let pp ppf edn = match edn with - | { scheme = `SSH user; path; endpoint } -> - Fmt.pf ppf "%s@%a:%s" user Conduit.Endpoint.pp endpoint path - | { scheme = `Git; path; endpoint } -> - Fmt.pf ppf "git://%a/%s" Conduit.Endpoint.pp endpoint path - | { scheme = `HTTP _; path; endpoint } -> - Fmt.pf ppf "http://%a/%s" Conduit.Endpoint.pp endpoint path - | { scheme = `HTTPS _; path; endpoint } -> - Fmt.pf ppf "https://%a/%s" Conduit.Endpoint.pp endpoint path + | { scheme = `SSH user; path; host } -> + Fmt.pf ppf "%s@%a:%s" user Domain_name.pp host path + | { scheme = `Git; path; host } -> + Fmt.pf ppf "git://%a/%s" Domain_name.pp host path + | { scheme = `HTTP _; path; host } -> + Fmt.pf ppf "http://%a/%s" Domain_name.pp host path + | { scheme = `HTTPS _; path; host } -> + Fmt.pf ppf "https://%a/%s" Domain_name.pp host path let of_string str = let open Rresult in @@ -96,35 +96,24 @@ module Endpoint = struct m.Emile.local) in (match fst m.Emile.domain with - | `Domain vs -> - Domain_name.of_strings vs - >>= Domain_name.host - >>| Conduit.Endpoint.domain - | `Literal v -> - Domain_name.of_string v - >>= Domain_name.host - >>| Conduit.Endpoint.domain - | `Addr (Emile.IPv4 ipv4) -> - R.ok (Conduit.Endpoint.ip (Ipaddr.V4 ipv4)) - | `Addr (Emile.IPv6 ipv6) -> - R.ok (Conduit.Endpoint.ip (Ipaddr.V6 ipv6)) - | `Addr (Emile.Ext (ext, _)) -> - R.error_msgf "Git does not handle domain extension %s." ext) - >>= fun endpoint -> R.ok { scheme = `SSH user; path; endpoint } + | `Domain vs -> Domain_name.of_strings vs >>= Domain_name.host + | `Literal v -> Domain_name.of_string v >>= Domain_name.host + | v -> R.error_msgf "Invalid hostname: %a" Emile.pp_domain v) + >>= fun host -> R.ok { scheme = `SSH user; path; host } | _ -> R.error_msg "invalid pattern" in let parse_uri x = let uri = Uri.of_string x in match Uri.scheme uri, Uri.host uri, Uri.path uri with | Some "git", Some host, path -> - Conduit.Endpoint.of_string host >>= fun endpoint -> - R.ok { scheme = `Git; path; endpoint } + Domain_name.of_string host >>= Domain_name.host >>= fun host -> + R.ok { scheme = `Git; path; host } | Some "http", Some host, path -> - Conduit.Endpoint.of_string host >>= fun endpoint -> - R.ok { scheme = `HTTP []; path; endpoint } + Domain_name.of_string host >>= Domain_name.host >>= fun host -> + R.ok { scheme = `HTTP []; path; host } | Some "https", Some host, path -> - Conduit.Endpoint.of_string host >>= fun endpoint -> - R.ok { scheme = `HTTPS []; path; endpoint } + Domain_name.of_string host >>= Domain_name.host >>= fun host -> + R.ok { scheme = `HTTPS []; path; host } | _ -> R.error_msgf "invalid uri: %a" Uri.pp uri in match parse_ssh str, parse_uri str with @@ -143,10 +132,6 @@ module Make (Scheduler : Sigs.SCHED with type +'a s = 'a Lwt.t) (Pack : APPEND with type +'a fiber = 'a Lwt.t) (Index : APPEND with type +'a fiber = 'a Lwt.t) - (Conduit : Conduit.S - with type +'a io = 'a Lwt.t - and type input = Cstruct.t - and type output = Cstruct.t) (HTTP : HTTP) (Uid : UID) (Ref : Sigs.REF) = @@ -323,38 +308,40 @@ struct >|= R.reword_error (R.msgf "%a" Index.pp_error) >>? fun () -> Lwt.return_ok pack - module Flow = struct - type +'a fiber = 'a Lwt.t - type t = Conduit.flow - - include Conduit - end - + module Flow = Unixiz.Make (Mimic) module Fetch = Nss.Fetch.Make (Scheduler) (Lwt) (Flow) (Uid) (Ref) module Push = Nss.Push.Make (Scheduler) (Lwt) (Flow) (Uid) (Ref) - let fetch_v1 ?uses_git_transport ~push_stdout ~push_stderr ~capabilities path - ~resolvers ?deepen ?want endpoint store access fetch_cfg pack = + let fetch_v1 ?(uses_git_transport = false) ?(is_ssh = fun _ -> false) + ~push_stdout ~push_stderr ~capabilities path ~ctx ?deepen ?want host store + access fetch_cfg pack = let open Lwt.Infix in - Log.debug (fun m -> m "Try to resolve %a." Conduit.Endpoint.pp endpoint); - Conduit.resolve resolvers endpoint >>= function + Log.debug (fun m -> m "Try to resolve %a." Domain_name.pp host); + Mimic.resolve ctx >>= function | Error _ as err -> pack None; Lwt.return err | Ok flow -> - Lwt.try_bind - (fun () -> - Fetch.fetch_v1 ?uses_git_transport ~push_stdout ~push_stderr - ~capabilities ?deepen ?want ~host:endpoint path flow store access - fetch_cfg (fun (payload, off, len) -> - let v = String.sub payload off len in - pack (Some (v, 0, len)))) - (fun refs -> - pack None; - Conduit.close flow >>? fun () -> Lwt.return_ok refs) - (fun exn -> - pack None; - Conduit.close flow >>= fun _ -> Lwt.fail exn) + Log.debug (fun m -> m "We use Git transport: %b." uses_git_transport); + Log.debug (fun m -> m "The flow is a SSH connection: %b." (is_ssh flow)); + if (not uses_git_transport) && not (is_ssh flow) then ( + Mimic.close flow >>= fun () -> + pack None; + Lwt.return_error `Invalid_flow) + else + Lwt.try_bind + (fun () -> + Fetch.fetch_v1 ~uses_git_transport ~push_stdout ~push_stderr + ~capabilities ?deepen ?want ~host path (Flow.make flow) store + access fetch_cfg (fun (payload, off, len) -> + let v = String.sub payload off len in + pack (Some (v, 0, len)))) + (fun refs -> + pack None; + Mimic.close flow >>= fun () -> Lwt.return_ok refs) + (fun exn -> + pack None; + Mimic.close flow >>= fun () -> Lwt.fail exn) module Flow_http = struct type +'a fiber = 'a Lwt.t @@ -363,9 +350,9 @@ struct mutable ic : string; mutable oc : string; mutable pos : int; - resolvers : Conduit.resolvers; uri : Uri.t; headers : (string * string) list; + ctx : Mimic.ctx; } type error = [ `Msg of string ] @@ -380,7 +367,7 @@ struct let rec recv t raw = if t.pos = String.length t.ic then ( let open Lwt.Infix in - (HTTP.post ~resolvers:t.resolvers ~headers:t.headers t.uri t.oc + (HTTP.post ~ctx:t.ctx ~headers:t.headers t.uri t.oc >|= Rresult.(R.reword_error (R.msgf "%a" HTTP.pp_error))) >>? fun (_resp, contents) -> t.ic <- t.ic ^ contents; @@ -394,26 +381,19 @@ struct module Fetch_http = Nss.Fetch.Make (Scheduler) (Lwt) (Flow_http) (Uid) (Ref) - let http_fetch_v1 ~push_stdout ~push_stderr ~capabilities uri ?(headers = []) - endpoint path ~resolvers ?deepen ?want store access fetch_cfg pack = + let http_fetch_v1 ~push_stdout ~push_stderr ~capabilities ~ctx uri + ?(headers = []) endpoint path ?deepen ?want store access fetch_cfg pack = let open Rresult in let open Lwt.Infix in let uri0 = Fmt.str "%a/info/refs?service=git-upload-pack" Uri.pp uri in let uri0 = Uri.of_string uri0 in - HTTP.get ~resolvers ~headers uri0 - >|= R.reword_error (R.msgf "%a" HTTP.pp_error) + Log.debug (fun m -> m "GET %a" Uri.pp uri0); + HTTP.get ~ctx ~headers uri0 >|= R.reword_error (R.msgf "%a" HTTP.pp_error) >>? fun (_resp, contents) -> let uri1 = Fmt.str "%a/git-upload-pack" Uri.pp uri in let uri1 = Uri.of_string uri1 in let flow = - { - Flow_http.ic = contents; - pos = 0; - oc = ""; - resolvers; - uri = uri1; - headers; - } + { Flow_http.ic = contents; pos = 0; oc = ""; uri = uri1; headers; ctx } in Fetch_http.fetch_v1 ~push_stdout ~push_stderr ~capabilities ?deepen ?want ~host:endpoint path flow store access fetch_cfg @@ -430,13 +410,13 @@ struct `Report_status; ] - let fetch ?(push_stdout = ignore) ?(push_stderr = ignore) ~resolvers + let fetch ?(push_stdout = ignore) ?(push_stderr = ignore) ~ctx ?is_ssh (access, light_load, heavy_load) store edn ?(version = `V1) ?(capabilities = default_capabilities) ?deepen want t_pck t_idx ~src ~dst ~idx = let open Rresult in let open Lwt.Infix in - let endpoint = edn.Endpoint.endpoint in + let host = edn.Endpoint.host in let path = edn.path in let stream, pusher = Lwt_stream.create () in let pusher = function @@ -457,9 +437,9 @@ struct in let run () = Lwt.both - (fetch_v1 ~push_stdout ~push_stderr ~uses_git_transport - ~capabilities path ~resolvers ?deepen ~want endpoint store - access fetch_cfg pusher) + (fetch_v1 ~push_stdout ~push_stderr ~uses_git_transport ?is_ssh + ~capabilities path ~ctx ?deepen ~want host store access + fetch_cfg pusher) (run ~light_load ~heavy_load stream t_pck t_idx ~src ~dst ~idx) >>= fun (refs, idx) -> match refs, idx with @@ -470,6 +450,7 @@ struct in run | `V1, ((`HTTP _ | `HTTPS _) as scheme) -> + Log.debug (fun m -> m "Start an HTTP transmission."); let fetch_cfg = Nss.Fetch.configuration ~stateless:true capabilities in @@ -477,19 +458,17 @@ struct match scheme with | `HTTP headers -> ( Uri.of_string - (Fmt.str "http://%a%s.git" Conduit.Endpoint.pp endpoint path), + (Fmt.str "http://%a%s.git" Domain_name.pp host path), headers ) | `HTTPS headers -> ( Uri.of_string - (Fmt.str "https://%a%s.git" Conduit.Endpoint.pp endpoint - path), + (Fmt.str "https://%a%s.git" Domain_name.pp host path), headers ) in let run () = Lwt.both - (http_fetch_v1 ~push_stdout ~push_stderr ~capabilities uri - ~headers endpoint path ~resolvers ?deepen ~want store access - fetch_cfg pusher) + (http_fetch_v1 ~push_stdout ~push_stderr ~capabilities ~ctx uri + ~headers host path ?deepen ~want store access fetch_cfg pusher) (run ~light_load ~heavy_load stream t_pck t_idx ~src ~dst ~idx) >>= fun (refs, idx) -> match refs, idx with @@ -596,26 +575,26 @@ struct Lwt.async fiber; stream - let push ?prelude ~resolvers ~capabilities path cmds endpoint store access - push_cfg pack = + let push ?prelude ~ctx ~capabilities path cmds endpoint store access push_cfg + pack = let open Lwt.Infix in - Conduit.resolve resolvers endpoint >>? fun flow -> - Push.push ?prelude ~capabilities cmds ~host:endpoint path flow store access - push_cfg pack - >>= fun () -> Conduit.close flow - - let push ~resolvers (access, light_load, heavy_load) store edn - ?(version = `V1) ?(capabilities = default_capabilities) cmds = + Mimic.resolve ctx >>? fun flow -> + Push.push ?prelude ~capabilities cmds ~host:endpoint path (Flow.make flow) + store access push_cfg pack + >>= fun () -> + Mimic.close flow >>= fun () -> Lwt.return_ok () + + let push ~ctx (access, light_load, heavy_load) store edn ?(version = `V1) + ?(capabilities = default_capabilities) cmds = let open Rresult in match version, edn.Endpoint.scheme with | `V1, ((`Git | `SSH _) as scheme) -> let prelude = match scheme with `Git -> true | `SSH _ -> false in - let endpoint = edn.endpoint in + let host = edn.host in let path = edn.path in let push_cfg = Nss.Push.configuration () in let run () = - push ~prelude ~resolvers ~capabilities path cmds endpoint store access - push_cfg + push ~prelude ~ctx ~capabilities path cmds host store access push_cfg (pack ~light_load ~heavy_load) in Lwt.catch run (function diff --git a/src/not-so-smart/smart_git.mli b/src/not-so-smart/smart_git.mli index d5351c26f..ee2274a35 100644 --- a/src/not-so-smart/smart_git.mli +++ b/src/not-so-smart/smart_git.mli @@ -34,13 +34,13 @@ module type HTTP = sig val pp_error : error Fmt.t val get : - resolvers:Conduit.resolvers -> + ctx:Mimic.ctx -> ?headers:(string * string) list -> Uri.t -> (unit * string, error) result Lwt.t val post : - resolvers:Conduit.resolvers -> + ctx:Mimic.ctx -> ?headers:(string * string) list -> Uri.t -> string -> @@ -55,7 +55,7 @@ module Endpoint : sig | `HTTP of (string * string) list | `HTTPS of (string * string) list ]; path : string; - endpoint : Conduit.Endpoint.t; + host : [ `host ] Domain_name.t; } val pp : t Fmt.t @@ -70,17 +70,14 @@ module Make (Scheduler : Sigs.SCHED with type +'a s = 'a Lwt.t) (Pack : APPEND with type +'a fiber = 'a Lwt.t) (Index : APPEND with type +'a fiber = 'a Lwt.t) - (Conduit : Conduit.S - with type +'a io = 'a Lwt.t - and type input = Cstruct.t - and type output = Cstruct.t) (HTTP : HTTP) (Uid : UID) (Ref : Sigs.REF) : sig val fetch : ?push_stdout:(string -> unit) -> ?push_stderr:(string -> unit) -> - resolvers:Conduit.resolvers -> + ctx:Mimic.ctx -> + ?is_ssh:(Mimic.flow -> bool) -> (Uid.t, _, Uid.t * int ref * int64, 'g, Scheduler.t) Sigs.access * Uid.t Carton_lwt.Thin.light_load * Uid.t Carton_lwt.Thin.heavy_load -> @@ -96,12 +93,12 @@ module Make dst:Pack.uid -> idx:Index.uid -> ( [ `Pack of Uid.t * (Ref.t * Uid.t) list | `Empty ], - [> `Msg of string | `Exn of exn | `Not_found ] ) + [> `Exn of exn | `Invalid_flow | Mimic.error ] ) result Lwt.t val push : - resolvers:Conduit.resolvers -> + ctx:Mimic.ctx -> (Uid.t, Ref.t, Uid.t Pck.t, 'g, Scheduler.t) Sigs.access * Uid.t Carton_lwt.Thin.light_load * Uid.t Carton_lwt.Thin.heavy_load -> @@ -110,5 +107,5 @@ module Make ?version:[> `V1 ] -> ?capabilities:Smart.Capability.t list -> [ `Create of Ref.t | `Delete of Ref.t | `Update of Ref.t * Ref.t ] list -> - (unit, [> `Msg of string | `Exn of exn | `Not_found ]) result Lwt.t + (unit, [> `Exn of exn | `Invalid_flow | Mimic.error ]) result Lwt.t end diff --git a/src/not-so-smart/unixiz.ml b/src/not-so-smart/unixiz.ml new file mode 100644 index 000000000..ed9b46176 --- /dev/null +++ b/src/not-so-smart/unixiz.ml @@ -0,0 +1,53 @@ +let blit0 src src_off dst dst_off len = + let dst = Cstruct.of_bigarray ~off:dst_off ~len dst in + Cstruct.blit src src_off dst 0 len + +let blit1 src src_off dst dst_off len = + let src = Cstruct.of_bigarray ~off:src_off ~len src in + Cstruct.blit src 0 dst dst_off len + +open Lwt.Infix +open Rresult + +let ( >>? ) = Lwt_result.bind + +module Make (Flow : Mirage_flow.S) = struct + type +'a fiber = 'a Lwt.t + + type t = { + queue : (char, Bigarray.int8_unsigned_elt) Ke.Rke.t; + flow : Flow.flow; + } + + type error = [ `Error of Flow.error | `Write_error of Flow.write_error ] + + let pp_error ppf = function + | `Error err -> Flow.pp_error ppf err + | `Write_error err -> Flow.pp_write_error ppf err + + let make flow = { flow; queue = Ke.Rke.create ~capacity:0x1000 Bigarray.char } + + let recv flow payload = + if Ke.Rke.is_empty flow.queue then ( + Flow.read flow.flow >|= R.reword_error (fun err -> `Error err) + >>? function + | `Eof -> Lwt.return_ok `End_of_flow + | `Data res -> + Ke.Rke.N.push flow.queue ~blit:blit0 ~length:Cstruct.len res; + let len = min (Cstruct.len payload) (Ke.Rke.length flow.queue) in + Ke.Rke.N.keep_exn flow.queue ~blit:blit1 ~length:Cstruct.len ~off:0 + ~len payload; + Ke.Rke.N.shift_exn flow.queue len; + Lwt.return_ok (`Input len)) + else + let len = min (Cstruct.len payload) (Ke.Rke.length flow.queue) in + Ke.Rke.N.keep_exn flow.queue ~blit:blit1 ~length:Cstruct.len payload; + Ke.Rke.N.shift_exn flow.queue len; + Lwt.return_ok (`Input len) + + let send flow payload = + Flow.write flow.flow payload >|= function + | Error `Closed -> R.error (`Write_error `Closed) + | Error err -> R.error (`Write_error err) + | Ok () -> R.ok (Cstruct.len payload) +end diff --git a/src/not-so-smart/unixiz.mli b/src/not-so-smart/unixiz.mli new file mode 100644 index 000000000..10fb0b463 --- /dev/null +++ b/src/not-so-smart/unixiz.mli @@ -0,0 +1,9 @@ +module Make (Flow : Mirage_flow.S) : sig + include + Sigs.FLOW + with type +'a fiber = 'a Lwt.t + and type error = + [ `Error of Flow.error | `Write_error of Flow.write_error ] + + val make : Flow.flow -> t +end diff --git a/test/mimic/dune b/test/mimic/dune new file mode 100644 index 000000000..c1ede4fbd --- /dev/null +++ b/test/mimic/dune @@ -0,0 +1,11 @@ +(executable + (name test) + (libraries mimic mirage-flow git-nss.unixiz result rresult lwt lwt.unix logs + logs.fmt fmt.tty cstruct fmt alcotest alcotest-lwt)) + +(rule + (alias runtest) + (deps + (:test test.exe)) + (action + (run %{test} --color=always))) diff --git a/test/mimic/test.ml b/test/mimic/test.ml new file mode 100644 index 000000000..cb27c6e0a --- /dev/null +++ b/test/mimic/test.ml @@ -0,0 +1,245 @@ +let () = Printexc.record_backtrace true +let () = Fmt_tty.setup_std_outputs ~style_renderer:`Ansi_tty ~utf_8:true () +let () = Logs.set_level ~all:true (Some Logs.Debug) +let () = Logs.set_reporter (Logs_fmt.reporter ~dst:Fmt.stderr ()) + +module Memory_flow0 : + Mimic.Mirage_protocol.S with type endpoint = string * bytes = struct + type flow = { + mutable i : string; + o : bytes; + mutable p : int; + mutable c : bool; + } + + type error = | + type write_error = [ `Closed ] + + let pp_error : error Fmt.t = fun _ppf -> function _ -> . + + let pp_write_error ppf = function + | `Closed -> Fmt.string ppf "!Connection closed by peer" + + let read ({ i; _ } as flow) = + let len = min 0x1000 (String.length i) in + if len = 0 then ( + flow.c <- true; + Lwt.return_ok `Eof) + else ( + flow.i <- String.sub i len (String.length i - len); + Lwt.return_ok (`Data (Cstruct.of_string ~off:0 ~len i))) + + let write ({ o; p = off; c; _ } as flow) cs = + if c then Lwt.return_error `Closed + else + let len = min (Cstruct.len cs) (Bytes.length o - off) in + Cstruct.blit_to_bytes cs 0 o off len; + if len = 0 then flow.c <- true; + flow.p <- flow.p + len; + Lwt.return_ok () + + let writev flow css = + let open Lwt.Infix in + let rec go = function + | [] -> Lwt.return_ok () + | x :: r -> ( + write flow x >>= function + | Ok () -> go r + | Error _ as err -> Lwt.return err) + in + go css + + let close flow = + flow.c <- true; + Lwt.return () + + type endpoint = string * bytes + + let connect (str, buf) = Lwt.return_ok { i = str; o = buf; p = 0; c = false } +end + +let edn0, memory0 = Mimic.register ~name:"memory0" (module Memory_flow0) + +module Flow = Unixiz.Make (Mimic) + +let error = Alcotest.testable Flow.pp_error ( = ) + +let recv = + let pp ppf = function + | `End_of_flow -> Fmt.string ppf "`End_of_flow" + | `Input len -> Fmt.pf ppf "(`Input %d)" len + in + Alcotest.testable pp ( = ) + +let send = Alcotest.int + +let test_input_string = + Alcotest_lwt.test_case "input string" `Quick @@ fun _sw () -> + let open Rresult in + let open Lwt.Infix in + let ctx = Mimic.add edn0 ("Hello World!", Bytes.empty) Mimic.empty in + Mimic.resolve ctx >>= fun flow -> + Alcotest.(check bool) "resolve" (R.is_ok flow) true; + let flow = Flow.make (R.get_ok flow) in + let buf0 = Cstruct.create 12 in + let buf1 = Cstruct.create 12 in + Flow.recv flow buf0 >>= fun res0 -> + Flow.recv flow buf1 >>= fun res1 -> + Flow.send flow (Cstruct.of_string "Hello World!") >>= fun res2 -> + Alcotest.(check (result recv error)) "res0" res0 (Ok (`Input 12)); + Alcotest.(check string) "buf0" (Cstruct.to_string buf0) "Hello World!"; + Alcotest.(check (result recv error)) "res1" res1 (Ok `End_of_flow); + Alcotest.(check (result send error)) + "res2" res2 + (Error (`Write_error `Closed)); + Lwt.return_unit + +let test_output_string = + Alcotest_lwt.test_case "output string" `Quick @@ fun _sw () -> + let open Rresult in + let open Lwt.Infix in + let buf = Bytes.create 12 in + let ctx = Mimic.add edn0 ("", buf) Mimic.empty in + Mimic.resolve ctx >>= fun flow -> + Alcotest.(check bool) "resolve" (R.is_ok flow) true; + let flow = Flow.make (R.get_ok flow) in + Flow.send flow (Cstruct.of_string "Hell") >>= fun res0 -> + Flow.send flow (Cstruct.of_string "o Wo") >>= fun res1 -> + Flow.send flow (Cstruct.of_string "rld!") >>= fun res2 -> + Flow.send flow (Cstruct.of_string "?!?!") >>= fun res3 -> + Flow.recv flow Cstruct.empty >>= fun res4 -> + Alcotest.(check (result send error)) "res0" (Ok 4) res0; + Alcotest.(check (result send error)) "res1" (Ok 4) res1; + Alcotest.(check (result send error)) "res2" (Ok 4) res2; + Alcotest.(check (result send error)) "res3" (Ok 4) res3; + (* FIXME(dinosaure) *) + Alcotest.(check (result recv error)) "res4" (Ok `End_of_flow) res4; + Alcotest.(check string) "buf" (Bytes.to_string buf) "Hello World!"; + Lwt.return_unit + +module Fake (Edn : sig + type t +end) = +struct + type error = | + type write_error = [ `Closed ] + + let pp_error : error Fmt.t = fun _ -> function _ -> . + + let pp_write_error : write_error Fmt.t = + fun ppf `Closed -> Fmt.string ppf "Connection closed by peer" + + type flow = Edn.t + + and endpoint = Edn.t + + let connect (edn : endpoint) = Lwt.return_ok edn + let read _ = Lwt.return_ok (`Data Cstruct.empty) + let write _ _ = Lwt.return_ok () + let close _ = Lwt.return_unit + let writev _ _ = Lwt.return_ok () +end + +let edn_int, protocol_int = + Mimic.register ~name:"int" (module Fake (struct type t = int end)) + +module Protocol_int = (val Mimic.repr protocol_int) + +let edn_string, protocol_string = + Mimic.register ~name:"string" (module Fake (struct type t = string end)) + +module Protocol_string = (val Mimic.repr protocol_string) + +let edn_float, protocol_float = + Mimic.register ~name:"float" (module Fake (struct type t = float end)) + +module Protocol_float = (val Mimic.repr protocol_float) + +let flow : + type edn flow. (edn, flow) Mimic.protocol -> Mimic.flow Alcotest.testable = + fun protocol -> + let module Repr = (val Mimic.repr protocol) in + let equal a b = match a, b with Repr.T a, Repr.T b -> a = b | _ -> false in + let pp ppf _ = Fmt.string ppf "flow" in + Alcotest.testable pp equal + +let mimic_error = Alcotest.testable Mimic.pp_error ( = ) + +let test_values = + Alcotest_lwt.test_case "values" `Quick @@ fun _sw () -> + let open Lwt.Infix in + let ctx0 = Mimic.empty |> Mimic.add edn_int 42 in + Mimic.resolve ctx0 >>= fun res0 -> + Alcotest.(check (result (flow protocol_int) mimic_error)) + "res0" res0 (Ok (Protocol_int.T 42)); + let ctx1 = ctx0 |> Mimic.add edn_string "Hello World!" in + Mimic.resolve ctx1 >>= fun res1 -> + Alcotest.(check (result (flow protocol_string) mimic_error)) + "res1" res1 (Ok (Protocol_string.T "Hello World!")); + let ctx2 = ctx1 |> Mimic.add edn_float 0.42 in + Mimic.resolve ctx2 >>= fun res2 -> + Alcotest.(check (result (flow protocol_float) mimic_error)) + "res2" res2 (Ok (Protocol_float.T 0.42)); + Lwt.return_unit + +let test_functions = + Alcotest_lwt.test_case "functions" `Quick @@ fun _sw () -> + let open Lwt.Infix in + let k a b = Lwt.return_some (a + b) in + let ka = Mimic.make ~name:"a" and kb = Mimic.make ~name:"b" in + let ctx = Mimic.(fold edn_int Fun.[ req ka; req kb ] ~k Mimic.empty) in + let ctx = Mimic.add ka 2 ctx in + let ctx = Mimic.add kb 3 ctx in + Mimic.resolve ctx >>= fun res0 -> + Alcotest.(check (result (flow protocol_int) mimic_error)) + "res0" res0 (Ok (Protocol_int.T 5)); + let kint = Mimic.make ~name:"int" in + let k v = Lwt.return_some (string_of_int v) in + let ctx0 = Mimic.(fold edn_string Fun.[ dft kint 42 ] ~k Mimic.empty) in + let ctx1 = Mimic.add kint 51 ctx0 in + Mimic.resolve ctx0 >>= fun res1 -> + Alcotest.(check (result (flow protocol_string) mimic_error)) + "res1" res1 (Ok (Protocol_string.T "42")); + Mimic.resolve ctx1 >>= fun res2 -> + Alcotest.(check (result (flow protocol_string) mimic_error)) + "res2" res2 (Ok (Protocol_string.T "51")); + Lwt.return_unit + +let test_topological_sort = + Alcotest_lwt.test_case "topologicial" `Quick @@ fun _sw () -> + let open Lwt.Infix in + let k v = Lwt.return_some (string_of_int v) in + let kint01 = Mimic.make ~name:"int01" in + let ctx = Mimic.empty in + let ctx = Mimic.(fold edn_string Fun.[ req kint01 ] ~k ctx) in + let kint02 = Mimic.make ~name:"int02" in + let k v = Lwt.return_some (succ v) in + let ctx = Mimic.(fold kint01 Fun.[ req kint02 ] ~k ctx) in + let ctx0 = Mimic.add kint01 5 ctx in + let ctx1 = Mimic.add kint02 4 ctx in + Mimic.resolve ctx0 >>= fun res0 -> + Alcotest.(check (result (flow protocol_string) mimic_error)) + "res0" res0 (Ok (Protocol_string.T "5")); + Mimic.resolve ctx1 >>= fun res1 -> + Alcotest.(check (result (flow protocol_string) mimic_error)) + "res1" res1 (Ok (Protocol_string.T "5")); + Mimic.resolve ctx >>= fun res2 -> + Alcotest.(check (result (flow protocol_string) mimic_error)) + "res2" res2 + (Error `Not_found); + Alcotest.(check (result (flow protocol_int) mimic_error)) + "res2" res2 + (Error `Not_found); + Lwt.return_unit + +let fiber = + Alcotest_lwt.run "mimic" + [ + ( "mimic", + [ + test_input_string; test_output_string; test_values; test_functions; + test_topological_sort; + ] ); + ] + +let () = Lwt_main.run fiber diff --git a/test/smart/dune b/test/smart/dune index fbe05d579..10cc87fc3 100644 --- a/test/smart/dune +++ b/test/smart/dune @@ -1,10 +1,11 @@ (executable (name test) - (libraries git git-unix result curl.lwt mirage-crypto-rng.unix digestif - digestif.c domain-name git-nss.git bos fpath bigarray-compat carton-lwt - bigstringaf git-nss.sigs git-nss.hkt fmt git-nss.pck carton rresult - conduit alcotest conduit-lwt git-nss.smart lwt.unix mmap astring lwt - cstruct uri fmt.tty logs.fmt alcotest-lwt cohttp-lwt-unix git-cohttp-unix)) + (libraries mirage-flow mimic git-nss.unixiz git git-unix result curl.lwt + mirage-crypto-rng.unix digestif digestif.c domain-name git-nss.git bos + fpath bigarray-compat carton-lwt bigstringaf git-nss.sigs git-nss.hkt fmt + git-nss.pck carton rresult conduit alcotest conduit-lwt git-nss.smart + lwt.unix mmap astring lwt cstruct uri fmt.tty logs.fmt alcotest-lwt + cohttp-lwt-unix git-cohttp-unix)) (rule (alias runtest) diff --git a/test/smart/fifo.ml b/test/smart/fifo.ml index 0d60994c0..8c9bbe0a1 100644 --- a/test/smart/fifo.ml +++ b/test/smart/fifo.ml @@ -1,11 +1,9 @@ +open Lwt.Infix + let src = Logs.Src.create "FIFO" ~doc:"logs FIFO event" module Log = (val Logs.src_log src : Logs.LOG) -type input = Cstruct.t -type output = Cstruct.t -type +'a io = 'a Lwt.t - type flow = { ic : Lwt_unix.file_descr; oc : Lwt_unix.file_descr; @@ -14,14 +12,12 @@ type flow = { } type endpoint = Fpath.t * Fpath.t -type error = [ `Closed | `Unix_error of Unix.error ] +type error = | +type write_error = [ `Closed ] +let pp_error : error Fmt.t = fun _ppf -> function _ -> . let closed_by_peer = "Closed by peer" - -let pp_error ppf = function - | `Closed -> Fmt.string ppf closed_by_peer - | `Unix_error err -> Fmt.pf ppf "fifo: %s" (Unix.error_message err) - +let pp_write_error ppf = function `Closed -> Fmt.string ppf closed_by_peer let io_buffer_size = 65536 let connect (ic, oc) = @@ -31,64 +27,32 @@ let connect (ic, oc) = Lwt_unix.openfile (Fpath.to_string oc) Unix.[ O_WRONLY ] 0o600 >>= fun oc -> Lwt.return_ok { ic; oc; linger = Bytes.create io_buffer_size; closed = false } -let recv { ic; linger; closed; _ } raw = - if closed then Lwt.return_ok `End_of_flow +let read { ic; linger; closed; _ } = + if closed then Lwt.return_ok `Eof else - let rec process filled raw = - let open Lwt.Infix in - let max = Cstruct.len raw in - Log.debug (fun m -> m "Start to recv over the input named pipe."); - Lwt_unix.read ic linger 0 (min max (Bytes.length linger)) >>= fun len -> - Log.debug (fun m -> m "Get %d byte(s)." len); - if len = 0 then - Lwt.return_ok (if filled = 0 then `End_of_flow else `Input filled) - else ( - Cstruct.blit_from_bytes linger 0 raw 0 len; - if len = Bytes.length linger && max > Bytes.length linger then - if Lwt_unix.readable ic then - process (filled + len) (Cstruct.shift raw len) - else - Lwt.return_ok - (if filled + len = 0 then `End_of_flow else `Input (filled + len)) - else - Lwt.return_ok - (if filled + len = 0 then `End_of_flow else `Input (filled + len))) - in - Lwt.catch (fun () -> process 0 raw) @@ function - | Unix.Unix_error (err, _, _) -> Lwt.return_error (`Unix_error err) - | exn -> Lwt.fail exn + Lwt_unix.read ic linger 0 (Bytes.length linger) >>= function + | 0 -> Lwt.return_ok `Eof + | len -> Lwt.return_ok (`Data (Cstruct.of_bytes linger ~off:0 ~len)) -let rec send ({ oc; closed; linger; _ } as t) raw = +let write { oc; closed; _ } cs = if closed then Lwt.return_error `Closed - else ( - Log.debug (fun m -> - m "Start to send over the output named pipe (%d byte(s))." - (Cstruct.len raw)); - let max = Cstruct.len raw in - let len0 = min (Bytes.length linger) max in - Cstruct.blit_to_bytes raw 0 linger 0 len0; - let process () = - let open Lwt.Infix in - Lwt_unix.write oc linger 0 len0 >>= fun len1 -> - if len1 = len0 then - if max > len0 then send t (Cstruct.shift raw len0) - else Lwt.return_ok max - else Lwt.return_ok len1 + else + let rec go ({ Cstruct.buffer; off; len } as cs) = + if len = 0 then Lwt.return_ok () + else + Lwt_bytes.write oc buffer off len >>= fun len -> + go (Cstruct.shift cs len) in - Lwt.catch process @@ function - | Unix.Unix_error (err, _, _) -> Lwt.return_error (`Unix_error err) - | exn -> Lwt.fail exn) - -let close t = - let process () = - let open Lwt.Infix in - if not t.closed then ( - Lwt_unix.close t.ic >>= fun () -> - Lwt_unix.close t.oc >>= fun () -> - t.closed <- true; - Lwt.return_ok ()) - else Lwt.return_ok () + go cs + +let writev t css = + let rec go = function + | [] -> Lwt.return_ok () + | hd :: tl -> ( + write t hd >>= function + | Ok () -> go tl + | Error _ as err -> Lwt.return err) in - Lwt.catch process @@ function - | Unix.Unix_error (err, _, _) -> Lwt.return_error (`Unix_error err) - | exn -> Lwt.fail exn + go css + +let close t = Lwt_unix.close t.ic >>= fun () -> Lwt_unix.close t.oc diff --git a/test/smart/hTTP.ml b/test/smart/hTTP.ml index fbe649ff6..451dda188 100644 --- a/test/smart/hTTP.ml +++ b/test/smart/hTTP.ml @@ -1,46 +1,20 @@ -module None = struct - type input = Cstruct.t +let payloads = ref None +let set_payloads (v : string Queue.t) = payloads := Some v - and output = Cstruct.t +type error = | - type +'a io = 'a Lwt.t - type endpoint = string Queue.t - type flow = string Queue.t - type error = | +let pp_error : error Fmt.t = fun _ppf -> function _ -> . - let pp_error : error Fmt.t = fun _ppf -> function _ -> . - let connect x = Lwt.return_ok x - let recv _ _ = assert false - let send _ _ = assert false - let close _ = assert false -end - -(* XXX(dinosaure): just pass the given value and - * inherits the totality axiom of [conduit]. *) - -let localhost = Conduit.Endpoint.v "localhost" -let protocol = Conduit_lwt.register ~protocol:(module None) - -module Protocol = struct include (val Conduit_lwt.repr protocol) end - -type error = Conduit_lwt.error - -let pp_error = Conduit_lwt.pp_error - -let ( >>? ) x f = - let open Lwt.Infix in - x >>= function Ok x -> f x | Error err -> Lwt.return_error err - -let get ~resolvers ?headers:_ _uri = - Conduit_lwt.resolve resolvers ~protocol localhost >>? function - | Protocol.T (Conduit.Value queue) -> +let get ~ctx:_ ?headers:_ _uri = + match !payloads with + | Some queue -> let v = Queue.pop queue in Lwt.return_ok ((), v) | _ -> assert false -let post ~resolvers ?headers:_ _uri _contents = - Conduit_lwt.resolve resolvers ~protocol localhost >>? function - | Protocol.T (Conduit.Value queue) -> +let post ~ctx:_ ?headers:_ _uri _contents = + match !payloads with + | Some queue -> let v = Queue.pop queue in Lwt.return_ok ((), v) | _ -> assert false diff --git a/test/smart/loopback.ml b/test/smart/loopback.ml index d3c87535a..1cc90a0c8 100644 --- a/test/smart/loopback.ml +++ b/test/smart/loopback.ml @@ -1,36 +1,48 @@ -type input = Cstruct.t -type output = Cstruct.t -type +'a io = 'a Lwt.t +open Lwt.Infix + type flow = { mutable i : Cstruct.t; mutable o : Cstruct.t; mutable c : bool } type endpoint = string list -type error = [ `Closed ] +type error = | +type write_error = [ `Closed ] +let pp_error : error Fmt.t = fun _ppf -> function _ -> . let closed_by_peer = "Closed by peer" -let pp_error ppf = function `Closed -> Fmt.string ppf closed_by_peer +let pp_write_error ppf = function `Closed -> Fmt.string ppf closed_by_peer let connect i = let i = String.concat "" i in let i = Cstruct.of_string i in Lwt.return_ok { i; o = Cstruct.create 0x1000; c = false } -let recv flow buf = +let read flow = if Cstruct.len flow.i = 0 then ( flow.c <- true; - Lwt.return_ok `End_of_flow) + Lwt.return_ok `Eof) else - let len = min (Cstruct.len buf) (Cstruct.len flow.i) in - Cstruct.blit flow.i 0 buf 0 len; + let res = Cstruct.create 0x1000 in + let len = min (Cstruct.len res) (Cstruct.len flow.i) in + Cstruct.blit flow.i 0 res 0 len; flow.i <- Cstruct.shift flow.i len; - Lwt.return_ok (`Input len) + Lwt.return_ok (`Data res) let ( <.> ) f g x = f (g x) -let send flow str = +let write flow str = if flow.c then Lwt.return_error `Closed else ( flow.o <- Cstruct.append flow.o str; - Lwt.return_ok (Cstruct.len str)) + Lwt.return_ok ()) + +let writev flow sstr = + let rec go = function + | [] -> Lwt.return_ok () + | hd :: tl -> ( + write flow hd >>= function + | Ok () -> go tl + | Error _ as err -> Lwt.return err) + in + go sstr let close flow = flow.c <- true; - Lwt.return_ok () + Lwt.return () diff --git a/test/smart/lwt_backend.ml b/test/smart/lwt_backend.ml index 3a323657d..549d62962 100644 --- a/test/smart/lwt_backend.ml +++ b/test/smart/lwt_backend.ml @@ -9,13 +9,15 @@ let lwt = return = (fun x -> inj (Lwt.return x)); } +module Flow = Unixiz.Make (Mimic) + let lwt_io = let open Scheduler in Sigs. { - recv = (fun flow raw -> inj (Conduit_lwt.recv flow raw)); - send = (fun flow raw -> inj (Conduit_lwt.send flow raw)); - pp_error = Conduit_lwt.pp_error; + recv = (fun flow raw -> inj (Flow.recv flow raw)); + send = (fun flow raw -> inj (Flow.send flow raw)); + pp_error = Flow.pp_error; } let lwt_fail exn = Scheduler.inj (Lwt.fail exn) diff --git a/test/smart/lwt_backend.mli b/test/smart/lwt_backend.mli index ecf7d2eab..5701ecc18 100644 --- a/test/smart/lwt_backend.mli +++ b/test/smart/lwt_backend.mli @@ -1,6 +1,7 @@ open Sigs module Scheduler : SCHED with type +'a s = 'a Lwt.t +module Flow : module type of Unixiz.Make (Mimic) val lwt : Scheduler.t scheduler -val lwt_io : (Conduit_lwt.flow, Conduit_lwt.error, Scheduler.t) flow +val lwt_io : (Flow.t, Flow.error, Scheduler.t) flow val lwt_fail : exn -> ('a, Scheduler.t) io diff --git a/test/smart/test.ml b/test/smart/test.ml index 768ed1632..4c7fff2e7 100644 --- a/test/smart/test.ml +++ b/test/smart/test.ml @@ -35,20 +35,10 @@ let ( >>? ) x f = (** conduit-related setup for tests: *) -let fifo = Conduit_lwt.register ~protocol:(module Fifo) - -let resolvers_with_fifo ic oc = - let resolve _domain_name = - Logs.debug (fun m -> m "Call to the local resolver to give named pipes."); - Lwt.return_some (ic, oc) - in - Conduit_lwt.add fifo resolve Conduit.empty - -let loopback = Conduit_lwt.register ~protocol:(module Loopback) - -let resolvers_with_payloads payloads = - let resolve _domain_name = Lwt.return_some payloads in - Conduit_lwt.add loopback resolve Conduit.empty +let fifo_value, fifo = Mimic.register ~name:"fifo" (module Fifo) +let ctx_with_fifo ic oc = Mimic.add fifo_value (ic, oc) Mimic.empty +let loopback_value, loopback = Mimic.register ~name:"loopback" (module Loopback) +let ctx_with_payloads payloads = Mimic.add loopback_value payloads Mimic.empty (** Alcotest setup for testing: *) let uid = Alcotest.testable Uid.pp Uid.equal @@ -245,14 +235,13 @@ let test_sync_fetch () = `Quick @@ fun _switch () -> let open Lwt.Infix in - let module Sync = Git.Mem.Sync (Conduit_lwt) (Git.Mem.Store) (Git_cohttp_unix) - in + let module Sync = Git.Mem.Sync (Git.Mem.Store) (Git_cohttp_unix) in let capabilities = [ `Side_band_64k ] in let head = Git.Reference.v "HEAD" in let empty_branch = Git.Reference.v "refs/heads/empty" in let master_branch = Git.Reference.v "refs/heads/master" in let payloads = empty_repository_fetch in - let resolvers = resolvers_with_payloads payloads in + let ctx = ctx_with_payloads payloads in Git.Mem.Store.v (Fpath.v "/") >|= store_err >>? (fun store -> @@ -265,7 +254,7 @@ let test_sync_fetch () = >|= bad_input_err >>? fun endpoint -> (* fetch HEAD and write it to refs/heads/master *) - Sync.fetch ~resolvers ~capabilities endpoint store + Sync.fetch ~ctx ~capabilities endpoint store (`Some [ head, empty_branch; head, master_branch ]) >|= sync_err >>? function @@ -298,8 +287,7 @@ let test_sync_fetch () = (* XXX(dinosaure): [tmp] without systemic deletion of directories. *) -module Git = - Smart_git.Make (Scheduler) (Append) (Append) (Conduit_lwt) (HTTP) (Uid) (Ref) +module Git = Smart_git.Make (Scheduler) (Append) (Append) (HTTP) (Uid) (Ref) (* TODO(dinosaure): we don't check what we sent, we should check that. *) @@ -315,13 +303,13 @@ let test_empty_clone () = ( Fpath.(path / ".git" / "objects" / "pack"), Fpath.(path / ".git" / "objects" / "pack") ) in - let resolvers = resolvers_with_payloads payloads in + let ctx = ctx_with_payloads payloads in Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> Smart_git.Endpoint.of_string "git://localhost/not-found.git" |> Lwt.return >>? fun endpoint -> - Git.fetch ~resolvers ~capabilities access store endpoint + Git.fetch ~ctx ~capabilities access store endpoint (`Some [ Ref.v "HEAD" ]) pack index ~src:tmp0 ~dst:tmp1 ~idx:tmp2 in @@ -329,8 +317,8 @@ let test_empty_clone () = | Ok `Empty -> Lwt.return_unit | Ok (`Pack _) -> Alcotest.failf "Unexpected PACK file" | Error (`Exn exn) -> Alcotest.failf "%s" (Printexc.to_string exn) - | Error (#Conduit_lwt.error as err) -> - Alcotest.failf "%a" Conduit_lwt.pp_error err + | Error (#Mimic.error as err) -> Alcotest.failf "%a" Mimic.pp_error err + | Error `Invalid_flow -> Alcotest.fail "Invalid flow" let test_simple_clone () = Alcotest_lwt.test_case "simple clone" `Quick @@ fun sw () -> @@ -344,21 +332,21 @@ let test_simple_clone () = ( Fpath.(path / ".git" / "objects" / "pack"), Fpath.(path / ".git" / "objects" / "pack") ) in - let resolvers = resolvers_with_payloads payloads in + let ctx = ctx_with_payloads payloads in Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> Smart_git.Endpoint.of_string "git://localhost/not-found.git" |> Lwt.return >>? fun endpoint -> - Git.fetch ~resolvers ~capabilities access store endpoint `All pack index - ~src:tmp0 ~dst:tmp1 ~idx:tmp2 + Git.fetch ~ctx ~capabilities access store endpoint `All pack index ~src:tmp0 + ~dst:tmp1 ~idx:tmp2 in run () >>= function | Ok (`Pack _) -> Lwt.return_unit | Ok `Empty -> Alcotest.failf "Unexpected empty fetch" | Error (`Exn exn) -> Alcotest.failf "%s" (Printexc.to_string exn) - | Error (#Conduit_lwt.error as err) -> - Alcotest.failf "%a" Conduit_lwt.pp_error err + | Error (#Mimic.error as err) -> Alcotest.failf "%a" Mimic.pp_error err + | Error `Invalid_flow -> Alcotest.fail "Invalid flow" let create_new_git_push_store _sw = let create () = @@ -446,17 +434,17 @@ let test_simple_push () = in create_new_git_push_store sw >>= fun (access, store) -> commit_foo store >>= fun _head -> - let resolvers = resolvers_with_payloads payloads in + let ctx = ctx_with_payloads payloads in Smart_git.Endpoint.of_string "git://localhost/not-found.git" |> Lwt.return >>? fun endpoint -> - Git.push ~resolvers ~capabilities access store endpoint + Git.push ~ctx ~capabilities access store endpoint [ `Update (Ref.v "refs/head/master", Ref.v "refs/head/master") ] in run () >>= function | Ok () -> Lwt.return_unit | Error (`Exn exn) -> Alcotest.failf "%s" (Printexc.to_string exn) - | Error (#Conduit_lwt.error as err) -> - Alcotest.failf "%a" Conduit_lwt.pp_error err + | Error (#Mimic.error as err) -> Alcotest.failf "%a" Mimic.pp_error err + | Error `Invalid_flow -> Alcotest.fail "Invalid flow" let test_push_error () = Alcotest_lwt.test_case "push error" `Quick @@ fun sw () -> @@ -482,10 +470,10 @@ let test_push_error () = ] in create_new_git_push_store sw >>= fun (access, store) -> - let resolvers = resolvers_with_payloads payloads in + let ctx = ctx_with_payloads payloads in Smart_git.Endpoint.of_string "git://localhost/not-found.git" |> Lwt.return >>? fun endpoint -> - Git.push ~resolvers ~capabilities access store endpoint + Git.push ~ctx ~capabilities access store endpoint [ `Update (Ref.v "refs/head/master", Ref.v "refs/head/master") ] in run () >>= function @@ -494,8 +482,8 @@ let test_push_error () = | Error (`Msg _) -> Alcotest.(check pass) "error" () (); Lwt.return_unit - | Error (#Conduit_lwt.error as err) -> - Alcotest.failf "%a" Conduit_lwt.pp_error err + | Error (#Mimic.error as err) -> Alcotest.failf "%a" Mimic.pp_error err + | Error `Invalid_flow -> Alcotest.fail "Invalid flow" let test_fetch_empty () = Alcotest_lwt.test_case "fetch empty" `Quick @@ fun sw () -> @@ -509,14 +497,14 @@ let test_fetch_empty () = ( Fpath.(path / ".git" / "objects" / "pack"), Fpath.(path / ".git" / "objects" / "pack") ) in - let resolvers = resolvers_with_payloads payloads in + let ctx = ctx_with_payloads payloads in Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> Smart_git.Endpoint.of_string "git://localhost/not-found.git" |> Lwt.return >>? fun endpoint -> - Git.fetch ~resolvers ~capabilities access store endpoint `All pack index - ~src:tmp0 ~dst:tmp1 ~idx:tmp2 + Git.fetch ~ctx ~capabilities access store endpoint `All pack index ~src:tmp0 + ~dst:tmp1 ~idx:tmp2 >>? function | `Empty -> Alcotest.fail "Unexpected empty fetch" | `Pack (uid, refs) -> @@ -602,22 +590,22 @@ let test_fetch_empty () = (* ds/master.0000 *); ] in - let resolvers = resolvers_with_payloads payloads in + let ctx = ctx_with_payloads payloads in Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> Smart_git.Endpoint.of_string "git://localhost/not-found.git" |> Lwt.return >>? fun endpoint -> - Git.fetch ~resolvers ~capabilities access store endpoint `All pack index + Git.fetch ~ctx ~capabilities access store endpoint `All pack index ~src:tmp0 ~dst:tmp1 ~idx:tmp2 in run () >>= function | Ok `Empty -> Lwt.return_unit | Ok (`Pack _) -> Alcotest.failf "Unexpected PACK file" | Error (`Exn exn) -> Alcotest.failf "%s" (Printexc.to_string exn) - | Error (#Conduit_lwt.error as err) -> - Alcotest.failf "%a" Conduit_lwt.pp_error err + | Error (#Mimic.error as err) -> Alcotest.failf "%a" Mimic.pp_error err + | Error `Invalid_flow -> Alcotest.fail "Invalid flow" let update_testzone_0 store = let { path; _ } = store_prj store in @@ -1045,21 +1033,21 @@ let test_negotiation () = |> Lwt.return >>? fun () -> update_testzone_0 store >>? fun () -> - let resolvers = resolvers_with_payloads payloads in + let ctx = ctx_with_payloads payloads in Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> Smart_git.Endpoint.of_string "git://localhost/not-found.git" |> Lwt.return >>? fun endpoint -> - Git.fetch ~resolvers ~capabilities access store endpoint `All pack index - ~src:tmp0 ~dst:tmp1 ~idx:tmp2 + Git.fetch ~ctx ~capabilities access store endpoint `All pack index ~src:tmp0 + ~dst:tmp1 ~idx:tmp2 in run () >>= function | Ok (`Pack _) -> Lwt.return_unit | Ok `Empty -> Alcotest.failf "Unexpected empty fetch" | Error (`Exn exn) -> Alcotest.failf "%s" (Printexc.to_string exn) - | Error (#Conduit_lwt.error as err) -> - Alcotest.failf "%a" Conduit_lwt.pp_error err + | Error (#Mimic.error as err) -> Alcotest.failf "%a" Mimic.pp_error err + | Error `Invalid_flow -> Alcotest.fail "Invalid flow" (* XXX(dinosaure): FIFO "à la BOS".*) @@ -1132,6 +1120,8 @@ let run_git_upload_pack ?(tmps_exit = true) store ic oc = in Rresult.R.failwith_error_msg <.> process +let always v _ = v + let test_ssh () = Alcotest_lwt.test_case "clone over ssh" `Quick @@ fun sw () -> let open Lwt.Infix in @@ -1169,7 +1159,7 @@ let test_ssh () = Fpath.(path / ".git" / "objects" / "pack") ) in let capabilities = [] in - let resolvers = resolvers_with_fifo ic_fifo oc_fifo in + let ctx = ctx_with_fifo ic_fifo oc_fifo in Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> @@ -1177,16 +1167,16 @@ let test_ssh () = >>? fun endpoint -> Logs.app (fun m -> m "Waiting git-upload-pack."); Logs.app (fun m -> m "Start to fetch repository with SSH."); - Git.fetch ~resolvers ~capabilities access store1 endpoint + Git.fetch ~ctx ~is_ssh:(always true) ~capabilities access store1 endpoint (`Some [ Ref.v "HEAD" ]) pack index ~src:tmp0 ~dst:tmp1 ~idx:tmp2 in run () >>= function | Ok `Empty -> Alcotest.failf "Unexpected empty fetch" | Ok (`Pack _) -> Lwt.return_unit - | Error (#Conduit_lwt.error as err) -> - Alcotest.failf "%a" Conduit_lwt.pp_error err + | Error (#Mimic.error as err) -> Alcotest.failf "%a" Mimic.pp_error err | Error (`Exn exn) -> Alcotest.failf "%s" (Printexc.to_string exn) + | Error `Invalid_flow -> Alcotest.fail "Invalid flow" let update_testzone_1 store = let { path; _ } = store_prj store in @@ -1253,7 +1243,7 @@ let test_negotiation_ssh () = let capabilities = [ `Side_band_64k; `Multi_ack_detailed; `Thin_pack; `Ofs_delta ] in - let resolvers = resolvers_with_fifo ic_fifo oc_fifo in + let ctx = ctx_with_fifo ic_fifo oc_fifo in Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> @@ -1261,16 +1251,16 @@ let test_negotiation_ssh () = >>? fun endpoint -> Logs.app (fun m -> m "Waiting git-upload-pack."); Logs.app (fun m -> m "Start to fetch repository with SSH."); - Git.fetch ~resolvers ~capabilities access store1 endpoint + Git.fetch ~ctx ~is_ssh:(always true) ~capabilities access store1 endpoint (`Some [ Ref.v "HEAD" ]) pack index ~src:tmp0 ~dst:tmp1 ~idx:tmp2 in run () >>= function | Ok `Empty -> Alcotest.failf "Unexpected empty fetch" | Ok (`Pack _) -> Lwt.return_unit - | Error (#Conduit_lwt.error as err) -> - Alcotest.failf "%a" Conduit_lwt.pp_error err + | Error (#Mimic.error as err) -> Alcotest.failf "%a" Mimic.pp_error err | Error (`Exn exn) -> Alcotest.failf "%s" (Printexc.to_string exn) + | Error `Invalid_flow -> Alcotest.fail "Invalid flow" let run_git_receive_pack store ic oc = let { path; _ } = store_prj store in @@ -1343,10 +1333,10 @@ let test_push_ssh () = >>? fun () -> update_testzone_1 store1 >>? fun () -> let capabilities = [ `Report_status; `Side_band_64k ] in - let resolvers = resolvers_with_fifo ic_fifo oc_fifo in + let ctx = ctx_with_fifo ic_fifo oc_fifo in Smart_git.Endpoint.of_string "git@localhost:not-found.git" |> Lwt.return >>? fun endpoint -> - Git.push ~resolvers ~capabilities access store1 endpoint + Git.push ~ctx ~capabilities access store1 endpoint [ `Update (Ref.v "refs/heads/master", Ref.v "refs/heads/master") ] >>? fun () -> let { path; _ } = store_prj store0 in @@ -1373,8 +1363,8 @@ let test_push_ssh () = hashes | Error (`Msg err) -> Alcotest.failf "git-show-ref: %s" err) | Error (`Exn exn) -> Alcotest.failf "%s" (Printexc.to_string exn) - | Error (#Conduit_lwt.error as err) -> - Alcotest.failf "%a" Conduit_lwt.pp_error err + | Error (#Mimic.error as err) -> Alcotest.failf "%a" Mimic.pp_error err + | Error `Invalid_flow -> Alcotest.fail "Invalid flow" let load_file filename = let ic = open_in_bin filename in @@ -1384,9 +1374,7 @@ let load_file filename = close_in ic; Bytes.unsafe_to_string rs -let http_resolver queue = - let resolver _domain_name = Lwt.return_some queue in - Conduit_lwt.add HTTP.protocol resolver Conduit.empty +let http_resolver queue = HTTP.set_payloads queue let test_negotiation_http () = Alcotest_lwt.test_case "fetch over http" `Quick @@ fun sw () -> @@ -1420,16 +1408,16 @@ let test_negotiation_http () = let queue = Queue.create () in Queue.push (load_file "GET") queue; Queue.push (load_file "POST") queue; - let resolvers = http_resolver queue in - Git.fetch ~resolvers ~capabilities access store endpoint `All pack index - ~src:tmp0 ~dst:tmp1 ~idx:tmp2 + let () = http_resolver queue in + Git.fetch ~ctx:Mimic.empty ~capabilities access store endpoint `All pack + index ~src:tmp0 ~dst:tmp1 ~idx:tmp2 in run () >>= function | Ok (`Pack _) -> Lwt.return_unit | Ok `Empty -> Alcotest.failf "Unexpected empty fetch" | Error (`Exn exn) -> Alcotest.failf "%s" (Printexc.to_string exn) - | Error (#Conduit_lwt.error as err) -> - Alcotest.failf "%a" Conduit_lwt.pp_error err + | Error (#Mimic.error as err) -> Alcotest.failf "%a" Mimic.pp_error err + | Error `Invalid_flow -> Alcotest.fail "Invalid flow" let test_partial_clone_ssh () = Alcotest_lwt.test_case "partial clone over ssh" `Quick @@ fun sw () -> @@ -1466,7 +1454,7 @@ let test_partial_clone_ssh () = Fpath.(path / ".git" / "objects" / "pack") ) in let capabilities = [] in - let resolvers = resolvers_with_fifo ic_fifo oc_fifo in + let ctx = ctx_with_fifo ic_fifo oc_fifo in Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> @@ -1474,7 +1462,8 @@ let test_partial_clone_ssh () = >>? fun endpoint -> Logs.app (fun m -> m "Waiting git-upload-pack."); Logs.app (fun m -> m "Start to fetch repository with SSH."); - Git.fetch ~resolvers ~capabilities access store1 endpoint ~deepen:(`Depth 1) + Git.fetch ~ctx ~is_ssh:(always true) ~capabilities access store1 endpoint + ~deepen:(`Depth 1) (`Some [ Ref.v "HEAD" ]) pack index ~src:tmp0 ~dst:tmp1 ~idx:tmp2 >>? function @@ -1488,9 +1477,9 @@ let test_partial_clone_ssh () = in run () >>= function | Ok () -> Lwt.return_unit - | Error (#Conduit_lwt.error as err) -> - Alcotest.failf "%a" Conduit_lwt.pp_error err + | Error (#Mimic.error as err) -> Alcotest.failf "%a" Mimic.pp_error err | Error (`Exn exn) -> Alcotest.failf "%s" (Printexc.to_string exn) + | Error `Invalid_flow -> Alcotest.fail "Invalid flow" let test_partial_fetch_ssh () = Alcotest_lwt.test_case "partial fetch" `Quick @@ fun sw () -> @@ -1537,7 +1526,7 @@ let test_partial_fetch_ssh () = let process = run_git_upload_pack ~tmps_exit:false store0 ic_fifo oc_fifo in process () >>= fun () -> create_new_git_store sw >>= fun (access, store1) -> - let resolvers = resolvers_with_fifo ic_fifo oc_fifo in + let ctx = ctx_with_fifo ic_fifo oc_fifo in Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> @@ -1548,7 +1537,8 @@ let test_partial_fetch_ssh () = in Logs.app (fun m -> m "Waiting git-upload-pack."); Logs.app (fun m -> m "Start to fetch repository with SSH."); - Git.fetch ~resolvers ~capabilities access store1 endpoint ~deepen:(`Depth 1) + Git.fetch ~ctx ~is_ssh:(always true) ~capabilities access store1 endpoint + ~deepen:(`Depth 1) (`Some [ Ref.v "HEAD" ]) pack index ~src:tmp0 ~dst:tmp1 ~idx:tmp2 >>? function @@ -1591,14 +1581,14 @@ let test_partial_fetch_ssh () = run_git_upload_pack ~tmps_exit:false store0 ic_fifo oc_fifo in process () >>= fun () -> - let resolvers = resolvers_with_fifo ic_fifo oc_fifo in + let ctx = ctx_with_fifo ic_fifo oc_fifo in Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> Logs.app (fun m -> m "Waiting git-upload-pack."); Logs.app (fun m -> m "Start to fetch repository with SSH."); - Git.fetch ~resolvers ~capabilities access store1 endpoint - ~deepen:(`Depth 1) + Git.fetch ~ctx ~is_ssh:(always true) ~capabilities access store1 + endpoint ~deepen:(`Depth 1) (`Some [ Ref.v "HEAD" ]) pack index ~src:tmp0 ~dst:tmp1 ~idx:tmp2 >>? function @@ -1612,8 +1602,8 @@ let test_partial_fetch_ssh () = run () >>= function | Ok v -> Lwt.return v | Error (`Exn exn) -> Alcotest.failf "%s" (Printexc.to_string exn) - | Error (#Conduit_lwt.error as err) -> - Alcotest.failf "%a" Conduit_lwt.pp_error err + | Error (#Mimic.error as err) -> Alcotest.failf "%a" Mimic.pp_error err + | Error `Invalid_flow -> Alcotest.fail "Invalid flow" let update_testzone_1 store = let { path; _ } = store_prj store in diff --git a/unikernel/.ocamlformat b/unikernel/.ocamlformat new file mode 100644 index 000000000..e3346c163 --- /dev/null +++ b/unikernel/.ocamlformat @@ -0,0 +1 @@ +disable=true diff --git a/unikernel/README.md b/unikernel/README.md new file mode 100644 index 000000000..243bd989e --- /dev/null +++ b/unikernel/README.md @@ -0,0 +1,18 @@ +## A simple MirageOS to fetch a Git repository + +```sh +$ mirage configure +$ mirage build +$ ./minigit -r git://github.com/dinosaure/art +$ ./minigit -r http://github.com/dinosaure/art +$ ./minigit -r https://github.com/dinosaure/art +$ ./minigit --ssh-seed seed -r git@github.com:dinosaure/art +``` + +An error occurs when the user wants to fetch a Git repository +over SSH without the SSH seed (to generate the private SSH key): + +```sh +$ ./minigit -r git@github.com:dinosaure/art +Fatal error: exception (Failure "Invalid flow") +``` diff --git a/unikernel/_tags b/unikernel/_tags new file mode 100644 index 000000000..f90bb5a9b --- /dev/null +++ b/unikernel/_tags @@ -0,0 +1 @@ +true: package(digestif.c), package(checkseum.c) diff --git a/unikernel/config.ml b/unikernel/config.ml new file mode 100644 index 000000000..ee6efc5ea --- /dev/null +++ b/unikernel/config.ml @@ -0,0 +1,235 @@ +open Mirage + +type mimic = Mimic + +let mimic = typ Mimic + +let mimic_conf () = + let packages = [ package "mimic" ] in + impl @@ object + inherit base_configurable + method ty = mimic @-> mimic @-> mimic + method module_name = "Mimic.Merge" + method! packages = Key.pure packages + method name = "ctx" + method! connect _ _modname = + function + | [ a; b ] -> Fmt.str "Lwt.return (Mimic.merge %s %s)" a b + | [ x ] -> Fmt.str "%s.ctx" x + | _ -> Fmt.str "Lwt.return Mimic.empty" + end + +let merge ctx0 ctx1 = mimic_conf () $ ctx0 $ ctx1 + +let mimic_tcp_conf () = + let packages = [ package "git-mirage" ~sublibs:[ "tcp" ] ] in + impl @@ object + inherit base_configurable + method ty = stackv4 @-> mimic + method module_name = "Git_mirage_tcp.Make" + method! packages = Key.pure packages + method name = "tcp_ctx" + method! connect _ modname = + function + | [ stack ] -> + Fmt.str "Lwt.return (%s.with_stack %s %s.ctx)" modname stack + modname + | _ -> Fmt.str "Lwt.return %s.ctx" modname + end + +let mimic_tcp_impl stackv4 = mimic_tcp_conf () $ stackv4 + +let mimic_git_conf ~edn () = + let packages = [ package "git-mirage" ] in + let edn = Key.abstract edn in + impl @@ object + inherit base_configurable + method ty = stackv4 @-> mimic @-> mimic + method! keys = [ edn ] + method module_name = "Git_mirage.Make" + method! packages = Key.pure packages + method name = "git_ctx" + method! connect _ modname _ = + Fmt.str + "Lwt.return (%s.with_resolv (%s.with_smart_git_endpoint (%a) \ + %s.ctx))" + modname modname Key.serialize_call edn modname + end + +let mimic_git_impl ~edn stackv4 mimic_tcp = + mimic_git_conf ~edn () $ stackv4 $ mimic_tcp + +let mimic_ssh_conf ~edn ~kind ~seed ~auth () = + let seed = Key.abstract seed in + let auth = Key.abstract auth in + let edn = Key.abstract edn in + let packages = [ package "git-mirage" ~sublibs:[ "ssh" ] ] in + impl @@ object + inherit base_configurable + method ty = stackv4 @-> mimic @-> mimic @-> mclock @-> mimic + method! keys = [ seed; auth; edn ] + method module_name = "Git_mirage_ssh.Make" + method! packages = Key.pure packages + method name = "ssh_ctx" + method! connect _ modname = + function + | [ _; tcp_ctx; git_ctx; _ ] -> + let with_key = + match kind with + | `Rsa -> "with_rsa_key" + | `Ed25519 -> "with_ed25519_key" + in + Fmt.str + {| let ctx00 = Mimic.merge %s %s in + let ctx01 = Option.fold ~none:ctx00 ~some:(fun v -> %s.%s v ctx00) %a in + let ctx02 = Option.fold ~none:ctx01 ~some:(fun v -> %s.with_authenticator v ctx01) %a in + let ctx03 = %s.with_resolv ctx02 in + Lwt.return (%s.with_resolv (%s.with_smart_git_endpoint (%a) ctx03)) |} + tcp_ctx git_ctx modname with_key Key.serialize_call seed modname + Key.serialize_call auth modname modname modname + Key.serialize_call edn + | _ -> Fmt.str "Lwt.return %s.ctx" modname + end + +let mimic_ssh_impl ~edn ~kind ~seed ~auth stackv4 mimic_tcp mimic_git mclock = + mimic_ssh_conf ~edn ~kind ~seed ~auth () + $ stackv4 + $ mimic_tcp + $ mimic_git + $ mclock + +let mimic_ssh_destruct = + impl @@ object + inherit base_configurable + method ty = mimic @-> mimic + method module_name = "Git_mirage_ssh.Destruct" + method! packages = Key.pure [ package "git-mirage" ~sublibs:[ "ssh" ] ] + method name = "is_ssh" + method! connect _ modname _ = Fmt.str "Lwt.return %s.is" modname + end + +(* TODO(dinosaure): user-defined nameserver and port. *) + +let mimic_dns_conf ~edn () = + let packages = [ package "git-mirage" ~sublibs:[ "dns" ] ] in + let edn = Key.abstract edn in + impl @@ object + inherit base_configurable + method ty = random @-> mclock @-> time @-> stackv4 @-> mimic @-> mimic + method! keys = [ edn ] + method module_name = "Git_mirage_dns.Make" + method! packages = Key.pure packages + method name = "dns_ctx" + method! connect _ modname = + function + | [ _; _; _; _; ctx ] -> + Fmt.str + "Lwt.return (%s.with_resolv (%s.with_smart_git_endpoint %a %s))" + modname modname Key.serialize_call edn ctx + | _ -> Fmt.str "Lwt.return %s.ctx" modname + end + +let mimic_dns_impl ~edn random mclock time stackv4 mimic_tcp = + mimic_dns_conf ~edn () $ random $ mclock $ time $ stackv4 $ mimic_tcp + +type hash = Hash + +let hash = typ Hash + +let sha1 = + impl @@ object + inherit base_configurable + method ty = hash + method module_name = "Digestif.SHA1" + method! packages = Key.pure [ package "digestif" ] + method name = "sha1" + end + +type git = Git + +let git = typ Git + +let git_conf ?path () = + let keys = + match path with Some path -> [ Key.abstract path ] | None -> [] + in + impl @@ object + inherit base_configurable + method ty = hash @-> git + method! keys = keys + method module_name = "Git.Mem.Make" + method! packages = Key.pure [ package "git"; package "digestif" ] + method name = "git" + method! connect _ modname _ = + match path with + | None -> + Fmt.str + {|%s.v (Fpath.v ".") >>= function + | Ok v -> Lwt.return v + | Error err -> Fmt.failwith "%%a" %s.pp_error err|} + modname modname + | Some key -> + Fmt.str + {|let res = match Option.map Fpath.of_string %a with + | Some (Ok path) -> %s.v path + | Some (Error (`Msg err)) -> failwith err + | None -> %s.v (Fpath.v ".") in + res >>= function + | Ok v -> Lwt.return v + | Error err -> Fmt.failwith "%%a" %s.pp_error err|} + Key.serialize_call (Key.abstract key) modname modname modname + end + +let git_impl ?path hash = git_conf ?path () $ hash + +(* User space *) + +let remote = + let doc = Key.Arg.info ~doc:"Remote Git repository." [ "r"; "remote" ] in + Key.(create "remote" Arg.(required string doc)) + +let ssh_seed = + let doc = Key.Arg.info ~doc:"Seed of the private SSH key." [ "ssh-seed" ] in + Key.(create "ssh_seed" Arg.(opt (some string) None doc)) + +let ssh_auth = + let doc = + Key.Arg.info ~doc:"SSH public key of the remote Git endpoint." + [ "ssh-auth" ] + in + Key.(create "ssh_auth" Arg.(opt (some string) None doc)) + +let minigit = + foreign "Unikernel.Make" + ~keys:[ Key.abstract remote; Key.abstract ssh_seed; Key.abstract ssh_auth ] + ~packages:[ package "cohttp-mirage"; package "git-cohttp-mirage" ] + (git + @-> time + @-> console + @-> resolver + @-> conduit + @-> mimic + @-> mimic + @-> job) + +let mimic ~edn ~kind ~seed ~auth stackv4 random mclock time = + let mtcp = mimic_tcp_impl stackv4 in + let mgit = mimic_git_impl ~edn stackv4 mtcp in + let mdns = mimic_dns_impl ~edn random mclock time stackv4 mtcp in + let mssh = mimic_ssh_impl ~edn ~kind ~seed ~auth stackv4 mtcp mgit mclock in + merge mssh mdns, mimic_ssh_destruct $ mssh + +let stackv4 = generic_stackv4 default_network +let mclock = default_monotonic_clock +let time = default_time +let random = default_random +let git = git_impl sha1 +let mimic = mimic stackv4 random mclock time +let console = default_console +let resolver = resolver_dns stackv4 +let conduit = conduit_direct ~tls:true stackv4 +let mimic, is_ssh = mimic ~edn:remote ~kind:`Rsa ~seed:ssh_seed ~auth:ssh_auth + +let () = + register "minigit" ~packages:[] + [ minigit $ git $ time $ console $ resolver $ conduit $ mimic $ is_ssh ] diff --git a/unikernel/unikernel.ml b/unikernel/unikernel.ml new file mode 100644 index 000000000..8243d702c --- /dev/null +++ b/unikernel/unikernel.ml @@ -0,0 +1,27 @@ +open Lwt.Infix + +module Make + (Store : Git.S) + (Time : Mirage_time.S) + (Console : Mirage_console.S) + (Resolver : Resolver_lwt.S) + (Conduit : Conduit_mirage.S) (_ : sig end) (_ : sig end) = +struct + module Sync = Git.Mem.Sync (Store) (Git_cohttp_mirage) + + let start git time console resolver conduit ctx is_ssh = + let ctx = + Git_cohttp_mirage.with_conduit + (Cohttp_mirage.Client.ctx resolver conduit) + ctx + in + let edn = + match Smart_git.Endpoint.of_string (Key_gen.remote ()) with + | Ok edn -> edn + | Error (`Msg err) -> failwith err + in + Sync.fetch ~ctx ~is_ssh edn git ~deepen:(`Depth 1) `All >>= function + | Ok (Some (hash, references)) -> Lwt.return_unit + | Ok None -> Lwt.return_unit + | Error err -> Fmt.failwith "%a" Sync.pp_error err +end