diff --git a/.ci-macosx.sh b/.ci-macosx.sh index 1c2ff39ef..6e66f61a6 100644 --- a/.ci-macosx.sh +++ b/.ci-macosx.sh @@ -40,6 +40,9 @@ brew install pkg-config brew install opam brew install libev brew install openssl +brew install libffi +brew install zlib + opam init -y -a --bare opam switch create . ocaml-base-compiler --deps-only --locked -y -j 2 # -v diff --git a/.github/workflows/static-builds.yml b/.github/workflows/static-builds.yml index 882d332cc..e8807068c 100644 --- a/.github/workflows/static-builds.yml +++ b/.github/workflows/static-builds.yml @@ -100,6 +100,7 @@ jobs: brew install openssl@3 # Workaround https://github.com/ocaml/opam-repository/issues/19676 brew install zstd # Install zstd to avoid "ld: Undefined symbols: _ZSTD_*" at linking time # ^-> see also https://github.com/ocaml/ocaml/issues/12562 + brew install libffi zlib # needed since https://github.com/ocaml-sf/learn-ocaml/pull/610 opam switch create . ocaml-base-compiler --deps-only - name: Build the binaries run: | diff --git a/Dockerfile b/Dockerfile index fb44dd51a..6740b96db 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,10 +1,11 @@ -FROM ocaml/opam:alpine-3.20-ocaml-5.1 as compilation +FROM ocaml/opam:alpine-3.21-ocaml-5.1 as compilation LABEL Description="learn-ocaml building" Vendor="OCamlPro" WORKDIR /home/opam/learn-ocaml COPY learn-ocaml.opam learn-ocaml.opam.locked learn-ocaml-client.opam learn-ocaml-client.opam.locked ./ RUN sudo chown -R opam:nogroup . +RUN sudo ln -sf /usr/bin/opam-2.3 /usr/bin/opam && opam init --reinit -ni ENV OPAMYES true RUN echo 'archive-mirrors: [ "https://opam.ocaml.org/cache" ]' >> ~/.opam/config \ @@ -28,7 +29,7 @@ RUN cat /proc/cpuinfo /proc/meminfo RUN opam install . --destdir /home/opam/install-prefix --locked -FROM alpine:3.20 as client +FROM alpine:3.21 as client RUN apk update \ && apk add ncurses-libs libev dumb-init libssl3 libcrypto3 \ @@ -45,10 +46,10 @@ COPY --from=compilation /home/opam/install-prefix/bin/learn-ocaml-client /usr/bi ENTRYPOINT ["dumb-init","/usr/bin/learn-ocaml-client"] -FROM alpine:3.20 as program +FROM alpine:3.21 as program RUN apk update \ - && apk add ncurses-libs libev dumb-init git openssl lsof \ + && apk add ncurses-libs libev dumb-init git gmp openssl lsof \ && addgroup learn-ocaml \ && adduser learn-ocaml -DG learn-ocaml diff --git a/Dockerfile.test-client b/Dockerfile.test-client index 82da27115..2c60a2ed5 100644 --- a/Dockerfile.test-client +++ b/Dockerfile.test-client @@ -1,7 +1,7 @@ # This Dockerfile is useful for testing purposes # to ensure learn-ocaml-client can be built alone from learn-ocaml-client.opam -FROM ocaml/opam:alpine-3.20-ocaml-5.1 as compilation +FROM ocaml/opam:alpine-3.21-ocaml-5.1 as compilation LABEL Description="learn-ocaml building" Vendor="OCamlPro" WORKDIR /home/opam/learn-ocaml @@ -9,6 +9,7 @@ WORKDIR /home/opam/learn-ocaml # Note: don't copy learn-ocaml.opam.locked COPY learn-ocaml-client.opam learn-ocaml.opam ./ RUN sudo chown -R opam:nogroup . +RUN sudo ln -sf /usr/bin/opam-2.3 /usr/bin/opam && opam init --reinit -ni ENV OPAMYES true RUN echo 'archive-mirrors: [ "https://opam.ocaml.org/cache" ]' >> ~/.opam/config \ @@ -34,7 +35,7 @@ RUN opam install learn-ocaml-client --destdir /home/opam/install-prefix \ && ls -l /home/opam/install-prefix/bin/learn-ocaml-client -FROM alpine:3.20 as client +FROM alpine:3.21 as client ARG BUILD_DATE ARG VCS_BRANCH diff --git a/Dockerfile.test-server b/Dockerfile.test-server index 759c3224c..9525d4a33 100644 --- a/Dockerfile.test-server +++ b/Dockerfile.test-server @@ -1,7 +1,7 @@ # This Dockerfile is useful for testing purposes # to ensure learn-ocaml can be built alone from learn-ocaml.opam -FROM ocaml/opam:alpine-3.20-ocaml-5.1 as compilation +FROM ocaml/opam:alpine-3.21-ocaml-5.1 as compilation LABEL Description="learn-ocaml building" Vendor="OCamlPro" WORKDIR /home/opam/learn-ocaml @@ -9,6 +9,7 @@ WORKDIR /home/opam/learn-ocaml # Note: don't copy learn-ocaml.locked COPY learn-ocaml.opam learn-ocaml-client.opam ./ RUN sudo chown -R opam:nogroup . +RUN sudo ln -sf /usr/bin/opam-2.3 /usr/bin/opam && opam init --reinit -ni ENV OPAMYES true RUN echo 'archive-mirrors: [ "https://opam.ocaml.org/cache" ]' >> ~/.opam/config \ @@ -37,7 +38,7 @@ RUN opam install learn-ocaml --destdir /home/opam/install-prefix \ && ls -l /home/opam/install-prefix/bin/learn-ocaml -FROM alpine:3.20 as program +FROM alpine:3.21 as program ARG BUILD_DATE ARG VCS_BRANCH @@ -54,7 +55,7 @@ LABEL org.label-schema.build-date="${BUILD_DATE}" \ org.label-schema.schema-version="1.0" RUN apk update \ - && apk add ncurses-libs libev dumb-init git openssl lsof \ + && apk add ncurses-libs libev dumb-init git gmp openssl lsof \ && addgroup learn-ocaml \ && adduser learn-ocaml -DG learn-ocaml diff --git a/learn-ocaml-client.opam.locked b/learn-ocaml-client.opam.locked index fb3bad529..bbf5efaf3 100644 --- a/learn-ocaml-client.opam.locked +++ b/learn-ocaml-client.opam.locked @@ -23,7 +23,7 @@ bug-reports: "https://github.com/ocaml-sf/learn-ocaml/issues" depends: [ "angstrom" {= "0.15.0"} "asak" {= "0.5"} - "asn1-combinators" {= "0.2.6"} + "asn1-combinators" {= "0.3.2"} "astring" {= "0.8.5"} "base" {= "v0.16.3"} "base-bigarray" {= "base"} @@ -34,16 +34,16 @@ depends: [ "base-unix" {= "base"} "base64" {= "3.5.0"} "bigarray-compat" {= "1.1.0"} - "bigstringaf" {= "0.8.0"} + "bigstringaf" {= "0.10.0"} "bos" {= "0.2.1"} - "ca-certs" {= "0.2.3"} - "cmdliner" {= "1.1.0"} - "cohttp" {= "4.0.0"} - "cohttp-lwt" {= "4.0.0"} - "cohttp-lwt-unix" {= "4.0.0"} - "conduit" {= "4.0.2"} - "conduit-lwt" {= "4.0.2"} - "conduit-lwt-unix" {= "4.0.2"} + "ca-certs" {= "1.0.0"} + "cmdliner" {= "1.3.0"} + "cohttp" {= "5.3.1"} + "cohttp-lwt" {= "5.3.0"} + "cohttp-lwt-unix" {= "5.3.0"} + "conduit" {= "7.0.0"} + "conduit-lwt" {= "7.0.0"} + "conduit-lwt-unix" {= "7.0.0"} "conf-bash" {= "1"} "conf-gmp" {= "4"} "conf-gmp-powm-sec" {= "3"} @@ -55,7 +55,7 @@ depends: [ "digestif" {= "1.2.0"} "domain-name" {= "0.4.0"} "dune" {= "3.16.0"} - "dune-configurator" {= "2.9.3"} + "dune-configurator" {= "3.17.2"} "duration" {= "0.2.1"} "eqaf" {= "0.9"} "ezjsonm" {= "1.3.0"} @@ -75,6 +75,7 @@ depends: [ "json-data-encoding" {= "1.0.1"} "jsonm" {= "1.0.1"} "jst-config" {= "v0.16.0"} + "kdf" {= "1.0.0"} "logs" {= "0.7.0"} "lwt" {= "5.7.0"} "lwt_ssl" {= "1.1.3"} @@ -84,11 +85,10 @@ depends: [ "menhirCST" {= "20231231"} "menhirLib" {= "20231231"} "menhirSdk" {= "20231231"} - "mirage-crypto" {= "0.11.3"} - "mirage-crypto-ec" {= "0.11.3"} - "mirage-crypto-pk" {= "0.11.3"} - "mirage-crypto-rng" {= "0.11.3"} - "num" {= "1.4"} + "mirage-crypto" {= "1.1.0"} + "mirage-crypto-ec" {= "1.1.0"} + "mirage-crypto-pk" {= "1.1.0"} + "mirage-crypto-rng" {= "1.1.0"} "ocaml" {= "5.1.1"} "ocaml-compiler-libs" {= "v0.12.4"} "ocaml-config" {= "3"} @@ -99,9 +99,8 @@ depends: [ "ocp-indent-nlfork" {= "1.5.5"} "ocp-ocamlres" {= "0.4"} "ocplib-endian" {= "1.2"} + "ohex" {= "0.2.0"} "omd" {= "1.3.2"} - "parsexp" {= "v0.16.0"} - "pbkdf" {= "1.2.0"} "pprint" {= "20220103"} "ppx_assert" {= "v0.16.0"} "ppx_base" {= "v0.16.0"} @@ -124,7 +123,6 @@ depends: [ "rresult" {= "0.7.0"} "sedlex" {= "3.2"} "seq" {= "base"} - "sexplib" {= "v0.16.0"} "sexplib0" {= "v0.16.0"} "ssl" {= "0.7.0"} "stdio" {= "v0.16.0"} @@ -137,7 +135,7 @@ depends: [ "uri-sexp" {= "4.2.0"} "uutf" {= "1.0.3"} "vg" {= "0.9.4"} - "x509" {= "0.16.5"} + "x509" {= "1.0.5"} "yojson" {= "2.2.2"} "zarith" {= "1.13"} ] diff --git a/learn-ocaml.opam b/learn-ocaml.opam index 8cd728d0f..d44b311a4 100644 --- a/learn-ocaml.opam +++ b/learn-ocaml.opam @@ -29,12 +29,14 @@ depends: [ "cohttp-lwt-unix" {>= "2.0.0"} "conduit-lwt-unix" {< "7.1.0"} "conf-git" - "decompress" {= "0.8.1"} + "cryptokit" + "decompress" {>= "1.5.3"} "digestif" {>= "1.2.0"} "dune" {>= "2.3.0"} "easy-format" {>= "1.3.0" } "ezjsonm" "ipaddr" {>= "2.9.0" } + "irmin-git" {= "3.10.0"} "js_of_ocaml" {>= "5.0.0" & < "6.0.0"} "js_of_ocaml-compiler" {>= "5.0.0" & < "6.0.0"} "js_of_ocaml-lwt" diff --git a/learn-ocaml.opam.locked b/learn-ocaml.opam.locked index 84023a11e..ec411bfd8 100644 --- a/learn-ocaml.opam.locked +++ b/learn-ocaml.opam.locked @@ -1,6 +1,15 @@ opam-version: "2.0" name: "learn-ocaml" version: "1.1.0" +synopsis: "The learn-ocaml online platform (engine)" +description: """\ +This contains the binaries forming the engine for the learn-ocaml platform, and +the common files. A demo exercise repository is also provided as example.""" +maintainer: [ + "Érik Martin-Dorel " + "Yann Régis-Gianas " + "Louis Gesbert " +] authors: [ "Benjamin Canou (OCamlPro)" "Çağdaş Bozman (OCamlPro)" @@ -8,20 +17,17 @@ authors: [ "Louis Gesbert (OCamlPro)" "Pierrick Couderc (OCamlPro)" ] -maintainer: [ - "Érik Martin-Dorel " - "Yann Régis-Gianas " - "Louis Gesbert " -] license: "MIT" homepage: "https://github.com/ocaml-sf/learn-ocaml" bug-reports: "https://github.com/ocaml-sf/learn-ocaml/issues" -dev-repo: "git+https://github.com/ocaml-sf/learn-ocaml" depends: [ "angstrom" {= "0.15.0"} + "arp" {= "3.1.1"} "asak" {= "0.5"} - "asn1-combinators" {= "0.2.6"} + "asn1-combinators" {= "0.3.2"} "astring" {= "0.8.5"} + "awa" {= "0.4.0"} + "awa-mirage" {= "0.4.0"} "base" {= "v0.16.3"} "base-bigarray" {= "base"} "base-bytes" {= "base"} @@ -30,46 +36,88 @@ depends: [ "base-threads" {= "base"} "base-unix" {= "base"} "base64" {= "3.5.0"} + "bheap" {= "2.0.0"} "bigarray-compat" {= "1.1.0"} - "bigstringaf" {= "0.8.0"} + "bigstringaf" {= "0.10.0"} "bos" {= "0.2.1"} - "ca-certs" {= "0.2.3"} + "ca-certs" {= "1.0.0"} + "ca-certs-nss" {= "3.107"} "camlp-streams" {= "5.0.1"} - "checkseum" {= "0.3.2"} - "cmdliner" {= "1.1.0"} - "cohttp" {= "4.0.0"} - "cohttp-lwt" {= "4.0.0"} - "cohttp-lwt-unix" {= "4.0.0"} - "conduit" {= "4.0.2"} - "conduit-lwt" {= "4.0.2"} - "conduit-lwt-unix" {= "4.0.2"} + "carton" {= "0.7.2"} + "carton-git" {= "0.7.2"} + "carton-lwt" {= "0.7.2"} + "cf" {= "0.5.0"} + "cf-lwt" {= "0.5.0"} + "checkseum" {= "0.5.2"} + "cmdliner" {= "1.3.0"} + "cohttp" {= "5.3.1"} + "cohttp-lwt" {= "5.3.0"} + "cohttp-lwt-unix" {= "5.3.0"} + "conduit" {= "7.0.0"} + "conduit-lwt" {= "7.0.0"} + "conduit-lwt-unix" {= "7.0.0"} "conf-bash" {= "1"} "conf-git" {= "1.1"} "conf-gmp" {= "4"} "conf-gmp-powm-sec" {= "3"} + "conf-libffi" {= "2.0.0"} "conf-libssl" {= "4"} "conf-pkg-config" {= "3"} + "conf-zlib" {= "1"} "cppo" {= "1.6.8"} "crunch" {= "3.3.1"} + "cryptokit" {= "1.20"} "csexp" {= "1.5.1"} "cstruct" {= "6.2.0"} - "decompress" {= "0.8.1"} + "cstruct-lwt" {= "6.2.0"} + "cstruct-unix" {= "6.2.0"} + "ctypes" {= "0.23.0"} + "ctypes-foreign" {= "0.23.0"} + "decompress" {= "1.5.3"} "digestif" {= "1.2.0"} + "dns" {= "9.1.0"} + "dns-client" {= "9.1.0"} + "dns-client-mirage" {= "9.1.0"} "domain-name" {= "0.4.0"} + "duff" {= "0.5"} "dune" {= "3.16.0"} - "dune-configurator" {= "2.9.3"} + "dune-configurator" {= "3.17.2"} "duration" {= "0.2.1"} "easy-format" {= "1.3.4"} + "either" {= "1.0.0"} + "emile" {= "1.1"} + "encore" {= "0.8"} "eqaf" {= "0.9"} + "ethernet" {= "3.2.0"} "ezjsonm" {= "1.3.0"} + "faraday" {= "0.8.2"} "fmt" {= "0.9.0"} "fpath" {= "0.7.3"} + "fsevents" {= "0.3.0"} + "fsevents-lwt" {= "0.3.0"} "gen" {= "1.1"} "gg" {= "1.0.0"} + "git" {= "3.17.0"} + "git-mirage" {= "3.17.0"} + "git-paf" {= "3.17.0"} + "git-unix" {= "3.17.0"} "gmap" {= "0.3.0"} + "h2" {= "0.13.0"} + "happy-eyeballs" {= "1.2.2"} + "happy-eyeballs-lwt" {= "1.2.2"} + "happy-eyeballs-mirage" {= "1.2.2"} "hex" {= "1.4.0"} + "hpack" {= "0.13.0"} + "httpaf" {= "0.7.1"} + "httpun-types" {= "0.2.0"} + "hxd" {= "0.3.3"} + "integers" {= "0.7.0"} "ipaddr" {= "5.6.0"} + "ipaddr-cstruct" {= "5.6.0"} "ipaddr-sexp" {= "5.6.0"} + "irmin" {= "3.10.0"} + "irmin-git" {= "3.10.0"} + "irmin-watcher" {= "0.5.0"} "jane-street-headers" {= "v0.16.0"} "js_of_ocaml" {= "5.8.2"} "js_of_ocaml-compiler" {= "5.8.2"} @@ -81,12 +129,17 @@ depends: [ "json-data-encoding-browser" {= "1.0.1"} "jsonm" {= "1.0.1"} "jst-config" {= "v0.16.0"} + "kdf" {= "1.0.0"} + "ke" {= "0.6"} "logs" {= "0.7.0"} + "lru" {= "0.3.1"} "lwt" {= "5.7.0"} + "lwt-dllist" {= "1.0.1"} "lwt_log" {= "1.1.2"} "lwt_react" {= "1.1.5"} "lwt_ssl" {= "1.1.3"} "macaddr" {= "5.6.0"} + "macaddr-cstruct" {= "5.6.0"} "magic-mime" {= "1.2.0"} "markup" {= "1.0.3"} "markup-lwt" {= "0.5.0"} @@ -94,10 +147,23 @@ depends: [ "menhirCST" {= "20231231"} "menhirLib" {= "20231231"} "menhirSdk" {= "20231231"} - "mirage-crypto" {= "0.11.3"} - "mirage-crypto-ec" {= "0.11.3"} - "mirage-crypto-pk" {= "0.11.3"} - "mirage-crypto-rng" {= "0.11.3"} + "metrics" {= "0.4.1"} + "mimic" {= "0.0.9"} + "mimic-happy-eyeballs" {= "0.0.9"} + "mirage-clock" {= "4.2.0"} + "mirage-clock-unix" {= "4.2.0"} + "mirage-crypto" {= "1.1.0"} + "mirage-crypto-ec" {= "1.1.0"} + "mirage-crypto-pk" {= "1.1.0"} + "mirage-crypto-rng" {= "1.1.0"} + "mirage-crypto-rng-mirage" {= "1.1.0"} + "mirage-flow" {= "4.0.2"} + "mirage-kv" {= "6.1.1"} + "mirage-net" {= "4.0.0"} + "mirage-runtime" {= "4.8.2"} + "mirage-time" {= "3.0.0"} + "mirage-unix" {= "5.0.1"} + "mtime" {= "2.1.0"} "num" {= "1.4"} "ocaml" {= "5.1.1"} "ocaml-compiler-libs" {= "v0.12.4"} @@ -106,15 +172,18 @@ depends: [ "ocaml-syntax-shims" {= "1.0.0"} "ocamlbuild" {= "0.14.3"} "ocamlfind" {= "1.9.6"} + "ocamlgraph" {= "2.1.0"} "ocp-indent-nlfork" {= "1.5.5"} "ocp-ocamlres" {= "0.4"} "ocplib-endian" {= "1.2"} "odoc" {= "2.4.2"} "odoc-parser" {= "2.4.2"} + "ohex" {= "0.2.0"} "omd" {= "1.3.2"} - "optint" {= "0.1.0"} + "optint" {= "0.3.0"} + "paf" {= "0.7.0"} "parsexp" {= "v0.16.0"} - "pbkdf" {= "1.2.0"} + "pecu" {= "0.7"} "pprint" {= "20220103"} "ppx_assert" {= "v0.16.0"} "ppx_base" {= "v0.16.0"} @@ -122,19 +191,25 @@ depends: [ "ppx_compare" {= "v0.16.0"} "ppx_cstruct" {= "6.2.0"} "ppx_derivers" {= "1.2.1"} + "ppx_deriving" {= "6.0.3"} "ppx_enumerate" {= "v0.16.0"} "ppx_expect" {= "v0.16.0"} "ppx_globalize" {= "v0.16.0"} "ppx_hash" {= "v0.16.0"} "ppx_here" {= "v0.16.0"} "ppx_inline_test" {= "v0.16.1"} + "ppx_irmin" {= "3.10.0"} "ppx_optcomp" {= "v0.16.0"} + "ppx_repr" {= "0.7.0"} "ppx_sexp_conv" {= "v0.16.0"} "ppxlib" {= "0.32.1"} + "psq" {= "0.2.1"} "ptime" {= "1.1.0"} + "randomconv" {= "0.2.0"} "re" {= "1.10.3"} "react" {= "1.2.2"} "reactiveData" {= "0.3.0"} + "repr" {= "0.7.0"} "result" {= "1.5"} "rresult" {= "0.7.0"} "sedlex" {= "3.2"} @@ -145,7 +220,10 @@ depends: [ "stdio" {= "v0.16.0"} "stdlib-shims" {= "0.3.0"} "stringext" {= "1.6.0"} + "tcpip" {= "8.2.0"} "time_now" {= "v0.16.0"} + "tls" {= "1.0.4"} + "tls-mirage" {= "1.0.4"} "topkg" {= "1.0.7"} "tyxml" {= "4.6.0"} "uchar" {= "0.0.2"} @@ -153,7 +231,7 @@ depends: [ "uri-sexp" {= "4.2.0"} "uutf" {= "1.0.3"} "vg" {= "0.9.4"} - "x509" {= "0.16.5"} + "x509" {= "1.0.5"} "yojson" {= "2.2.2"} "zarith" {= "1.13"} ] @@ -162,14 +240,10 @@ build: [ ["dune" "build" "-p" name "-j" jobs] [make "detect-libs"] {with-test} ] +run-test: [make "test"] install: [ ["mkdir" "-p" "%{_:share}%"] ["cp" "-r" "demo-repository" "%{_:share}%/repository"] ] -synopsis: "The learn-ocaml online platform (engine)" -description: """ -This contains the binaries forming the engine for the learn-ocaml platform, and -the common files. A demo exercise repository is also provided as example. -""" -run-test: [make "test"] depexts: ["lsof"] {os-distribution = "alpine"} +dev-repo: "git+https://github.com/ocaml-sf/learn-ocaml" diff --git a/src/app/learnocaml_common.ml b/src/app/learnocaml_common.ml index a5a12d2d6..e70c3aedf 100644 --- a/src/app/learnocaml_common.ml +++ b/src/app/learnocaml_common.ml @@ -421,10 +421,10 @@ let extract_text_from_rich_text text = render (("$" ^ code ^ "$") :: acc) rest in render [] text -let set_state_from_save_file ?token save = +let set_state_from_save_file ?session save = let open Learnocaml_data.Save in let open Learnocaml_local_storage in - (match token with None -> () | Some t -> store sync_token t); + (match session with None -> () | Some s -> store sync_session s); store nickname save.nickname; store all_graded_solutions (SMap.map (fun ans -> ans.Answer.solution) save.all_exercise_states); @@ -471,34 +471,35 @@ let get_state_as_save_file ?(include_reports = false) () = all_exercise_toplevel_histories = retrieve all_exercise_toplevel_histories; } -let rec sync_save token save_file on_sync = - Server_caller.request (Learnocaml_api.Update_save (token, save_file)) +let rec sync_save session save_file on_sync = + Server_caller.request (Learnocaml_api.Update_save_s (session, save_file)) >>= function | Ok save -> - set_state_from_save_file ~token save; + set_state_from_save_file ~session save; on_sync (); Lwt.return save + (* Removed auto-create fallback; token must already exist | Error (`Not_found _) -> Server_caller.request_exn (Learnocaml_api.Create_token ("", Some token, None)) >>= fun _token -> assert (_token = token); Server_caller.request_exn - (Learnocaml_api.Update_save (token, save_file)) >>= fun save -> - set_state_from_save_file ~token save; + (Learnocaml_api.Update_save (session, save_file)) >>= fun save -> + set_state_from_save_file ~session save; on_sync (); - Lwt.return save + Lwt.return save*) | Error e -> lwt_alert ~title:[%i"SYNC FAILED"] [ H.p [H.txt [%i"Could not synchronise save with the server"]]; H.code [H.txt (Server_caller.string_of_error e)]; ] ~buttons:[ - [%i"Retry"], (fun () -> sync_save token save_file on_sync); + [%i"Retry"], (fun () -> sync_save session save_file on_sync); [%i"Ignore"], (fun () -> Lwt.return save_file); ] -let sync token on_sync = sync_save token (get_state_as_save_file ()) on_sync +let sync session on_sync = sync_save session (get_state_as_save_file ()) on_sync -let sync_exercise token ?answer ?editor id on_sync = +let sync_exercise session ?answer ?editor id on_sync = let handle_serverless () = (* save the text at least locally (but not the report & grade, that could be misleading) *) @@ -533,13 +534,13 @@ let sync_exercise token ?answer ?editor id on_sync = all_toplevel_histories = SMap.empty; all_exercise_toplevel_histories = opt_to_map toplevel_history; } in - match token with - | Some token -> - Lwt.catch (fun () -> sync_save token save_file on_sync) + match session with + | Some session -> + Lwt.catch (fun () -> sync_save session save_file on_sync) (fun e -> handle_serverless (); raise e) - | None -> set_state_from_save_file save_file; + | _ -> set_state_from_save_file save_file; handle_serverless (); on_sync (); Lwt.return save_file @@ -884,7 +885,7 @@ let mk_tab_handlers default_tab other_tabs = Manip.addClass (find_component ("learnocaml-exo-tab-" ^ name)) "front-tab" ; - Manip.disable + Manip.disable (find_component ("learnocaml-exo-button-" ^ name)) ; current := name in let init_tabs () = @@ -932,13 +933,13 @@ module Editor_button (E : Editor_info) = struct Ace.set_contents E.ace template); Lwt.return () - let reload token id template = - let rec fetch_draft_solution tok () = - match tok with - | token -> - Server_caller.request (Learnocaml_api.Fetch_save token) >>= function + let reload session id template = + let rec fetch_draft_solution sess () = + match sess with + | session -> + Server_caller.request (Learnocaml_api.Fetch_save_s session) >>= function | Ok save -> - set_state_from_save_file ~token save; + set_state_from_save_file ~session save; Lwt.return_some (save.Save.nickname) | Error (`Not_found _) -> alert ~title:[%i"TOKEN NOT FOUND"] @@ -949,7 +950,7 @@ module Editor_button (E : Editor_info) = struct H.p [H.txt [%i"Could not retrieve data from server"]]; H.code [H.txt (Server_caller.string_of_error e)]; ] ~buttons:[ - [%i"Retry"], (fun () -> fetch_draft_solution tok ()); + [%i"Retry"], (fun () -> fetch_draft_solution sess ()); [%i"Cancel"], (fun () -> Lwt.return_none); ] in @@ -984,19 +985,19 @@ module Editor_button (E : Editor_info) = struct ] ] [%i"Reload"] @@ fun () -> - token >>= function + session >>= function None -> (* We may want to only show "Reset to initial template" in this case, though there is already this code in learnocaml_exercise_main.ml: {| if has_server then EB.reload ... else EB.cleanup ... |}. *) Lwt.return_unit - | Some tok -> + | Some sess -> let found f = match f () with | _val -> true | exception Not_found -> false in - fetch_draft_solution tok () >|= fun _save -> + fetch_draft_solution sess () >|= fun _save -> let menu_draft = find_component (id_menu ^ "-draft") in Manip.SetCss.display menu_draft (if found (fun () -> @@ -1023,13 +1024,13 @@ module Editor_button (E : Editor_info) = struct select_tab "toplevel"; Lwt.return_unit - let sync token id on_sync = + let sync session id on_sync = let state = button_state () in (editor_button ~state ~icon: "sync" [%i"Sync"] @@ fun () -> - token >>= fun token -> - sync_exercise token id ~editor:(Ace.get_contents E.ace) on_sync + session >>= fun session -> + sync_exercise session id ~editor:(Ace.get_contents E.ace) on_sync >|= fun _save -> ()); Ace.register_sync_observer E.ace (fun sync -> (* this is run twice when clicking on Reset, because of Ace's implem *) @@ -1158,12 +1159,12 @@ let setup_prelude_pane ace prelude = Manip.appendChildren prelude_pane [ prelude_title ; prelude_container ] -let get_token ?(has_server = true) () = +let get_session ?(has_server = true) () = if not has_server then Lwt.return None else try - Some Learnocaml_local_storage.(retrieve sync_token) |> + Some Learnocaml_local_storage.(retrieve sync_session) |> Lwt.return with Not_found -> @@ -1171,15 +1172,21 @@ let get_token ?(has_server = true) () = [H.txt [%i"Enter your token"]] >>= fun input_tok -> let token = Token.parse (input_tok) in - Server_caller.request (Learnocaml_api.Fetch_save token) - >>= function - | Ok save -> - set_state_from_save_file ~token save; - Lwt.return_some token - | _ -> - alert ~title:[%i"TOKEN NOT FOUND"] - [%i"The entered token couldn't be recognised."]; - Lwt.return_none + Server_caller.request (Learnocaml_api.Login token) >>= function + | Ok session -> + (Server_caller.request (Learnocaml_api.Fetch_save_s session) + >>= function + | Ok save -> + set_state_from_save_file ~session save; + Lwt.return_some session + | _ -> + alert ~title:[%i"TOKEN NOT FOUND"] + [%i"The entered token couldn't be recognised."]; + Lwt.return_none) + | _ -> + alert ~title:[%i"TOKEN NOT FOUND"] + [%i"The entered token couldn't be recognised."]; + Lwt.return_none module Display_exercise = functor ( @@ -1254,9 +1261,9 @@ module Display_exercise = in gen [] l |> List.rev - let get_skill_index token = + let get_skill_index session = let index = lazy ( - retrieve (Learnocaml_api.Exercise_index (Some token)) + retrieve (Learnocaml_api.Exercise_index_s (Some session)) >|= fun (index, _) -> Exercise.Index.fold_exercises (fun (req, focus) id meta -> let add sk id map = @@ -1366,7 +1373,7 @@ module Display_exercise = | [] -> None | l -> Some (caption, display_list ~sep:(H.txt "") l) - let display_meta token ex_meta id = + let display_meta session ex_meta id = let open Learnocaml_data.Exercise in let ident = Format.asprintf "%s %s" [%i "Identifier:" ] id in let authors = @@ -1374,7 +1381,7 @@ module Display_exercise = | [] -> None | [author] -> Some (display_authors [%i "Author:"] [author]) | authors -> Some (display_authors [%i "Authors:"] authors) in - retrieve (Learnocaml_api.Exercise_index token) + retrieve (Learnocaml_api.Exercise_index_s session) >|= fun (index, _) -> let req_map, focus_map = extract_maps_exo_index index in let focus = diff --git a/src/app/learnocaml_common.mli b/src/app/learnocaml_common.mli index eff755d06..76cb8c597 100644 --- a/src/app/learnocaml_common.mli +++ b/src/app/learnocaml_common.mli @@ -126,7 +126,7 @@ val extract_text_from_rich_text : Learnocaml_data.Tutorial.text -> string (** Sets the local storage from the data in a save file *) val set_state_from_save_file : - ?token:Token.t -> Save.t -> unit + ?session:Session.t -> Save.t -> unit (** Gets a save file containing the locally stored data *) val get_state_as_save_file : ?include_reports:bool -> unit -> Save.t @@ -139,12 +139,12 @@ val get_state_as_save_file : ?include_reports:bool -> unit -> Save.t Notice that this function synchronizes student {b,content} but not the reports which are only synchronized when an actual "grading" is done. *) -val sync: Token.t -> (unit -> unit) -> Save.t Lwt.t +val sync: Session.t -> (unit -> unit) -> Save.t Lwt.t (** The same, but limiting the submission to the given exercise, using the given answer if any, and the given editor text, if any. *) val sync_exercise: - Token.t option -> ?answer:Learnocaml_data.Answer.t -> ?editor:string -> + Session.t option -> ?answer:Learnocaml_data.Answer.t -> ?editor:string -> Learnocaml_data.Exercise.id -> (unit -> unit) -> Save.t Lwt.t @@ -225,10 +225,10 @@ end module Editor_button (_ : Editor_info) : sig val cleanup : string -> unit - val reload : Learnocaml_data.Token.t option Lwt.t -> string -> string -> unit + val reload : Learnocaml_data.Session.t option Lwt.t -> string -> string -> unit val download : string -> unit val eval : Learnocaml_toplevel.t -> (string -> unit) -> unit - val sync : Token.t option Lwt.t -> Learnocaml_data.SMap.key -> (unit -> unit) -> unit + val sync : Session.t option Lwt.t -> Learnocaml_data.SMap.key -> (unit -> unit) -> unit end val setup_editor : string -> Ocaml_mode.editor * Ocaml_mode.editor Ace.editor @@ -243,7 +243,7 @@ val setup_tab_text_prelude_pane : string -> unit val setup_prelude_pane : 'a Ace.editor -> string -> unit -val get_token : ?has_server:bool -> unit -> Learnocaml_data.Token.t option Lwt.t +val get_session : ?has_server:bool -> unit -> Learnocaml_data.Session.t option Lwt.t module Display_exercise :functor (_ : sig @@ -269,7 +269,7 @@ module Display_exercise :functor ?sep:([> Html_types.pcdata ] as 'a) Tyxml_js.Html5.elt -> 'a Tyxml_js.Html5.elt list -> 'a Tyxml_js.Html5.elt list val get_skill_index : - 'a Learnocaml_data.token -> + 'a Learnocaml_data.session -> [< `Focus of Learnocaml_data.SMap.key | `Requirements of Learnocaml_data.SMap.key ] -> Learnocaml_data.SSet.elt list Lwt.t @@ -294,6 +294,6 @@ module Display_exercise :functor (string Tyxml_js.Html5.wrap * string Tyxml_js.Html5.wrap) list -> [> `PCDATA | `Span ] Tyxml_js.Html5.elt list val display_meta : - 'a Learnocaml_data.token option -> + 'a Learnocaml_data.session option -> Learnocaml_data.Exercise.Meta.t -> string -> unit Lwt.t end diff --git a/src/app/learnocaml_description_main.ml b/src/app/learnocaml_description_main.ml index e215555be..d9a0de51c 100644 --- a/src/app/learnocaml_description_main.ml +++ b/src/app/learnocaml_description_main.ml @@ -15,39 +15,29 @@ open Learnocaml_data.Exercise.Meta let init_tabs, select_tab = mk_tab_handlers "text" ["text"; "meta"] -type encoded_token = +type encoded_session = { arg_name: string; raw_arg: string; - token: Learnocaml_data.Token.t + session: Learnocaml_data.Session.t } -(** [get_arg_token ()] read (and decode if need be) the user token. +(** [get_arg_session ()] read (and decode if need be) the user session. - @return [Some encoded_token] if a token was successfully read. - It returns [None] if no token was specified in the URL. - An exception is raised if an incorrect token was specified. *) -let get_encoded_token () = - match arg "token" with (* arg in plain text, deprecated in learn-ocaml 0.13 *) + @return [Some encoded_session] if a session was successfully read. + It returns [None] if no session was specified in the URL. + An exception is raised if an incorrect session was specified. *) +let get_encoded_session () = + match arg "session" with (* arg in plain text, deprecated in learn-ocaml 0.13 *) | raw_arg -> - let token = Learnocaml_data.Token.parse raw_arg in - Some { arg_name = "token"; raw_arg; token } - | exception Not_found -> - match arg "token1" with (* encoding algo 1: space-padded token |> base64 *) - | raw_arg -> - begin match Base64.decode ~pad:true raw_arg with - (* ~pad:false would work also, but ~pad:true is stricter *) - | Ok pad_token -> - Some { arg_name = "token1"; raw_arg; - token = Learnocaml_data.Token.parse (String.trim pad_token) } - | Error (`Msg msg) -> failwith msg - end - | exception Not_found -> None + let session = raw_arg in + Some { arg_name = "session"; raw_arg; session } + | exception Not_found -> None module Exercise_link = struct let exercise_link ?(cl = []) id content = - match get_encoded_token () with + match get_encoded_session () with | Some { arg_name; raw_arg; _ } -> Tyxml_js.Html5.(a ~a:[ a_href (Printf.sprintf "/description/%s#%s=%s" @@ -70,10 +60,10 @@ let () = Learnocaml_local_storage.init () ; let title_container = find_component "learnocaml-exo-tab-text-title" in let text_container = find_component "learnocaml-exo-tab-text-descr" in - match get_encoded_token () with - | Some { arg_name = _; raw_arg = _; token } -> begin + match get_encoded_session () with + | Some { arg_name = _; raw_arg = _; session } -> begin let exercise_fetch = - retrieve (Learnocaml_api.Exercise (Some token, id, true)) + retrieve (Learnocaml_api.Exercise_s (Some session, id, true)) in init_tabs (); exercise_fetch >>= fun (ex_meta, exo, _deadline) -> @@ -92,9 +82,12 @@ let () = d##write (Js.string (exercise_text ex_meta exo)); d##close) ; (* display meta *) - display_meta (Some token) ex_meta id >>= fun () -> - (* hide the initial/loading phase curtain *) - Lwt.return @@ hide_loading ~id:"learnocaml-exo-loading" () + match get_encoded_session () with + | Some { arg_name = _; raw_arg = _; session } -> + display_meta (Some session) ex_meta id >>= fun () -> + (* hide the initial/loading phase curtain *) + Lwt.return @@ hide_loading ~id:"learnocaml-exo-loading" () + | None ->Lwt.return_unit end | None -> let elt = find_div_or_append_to_body "learnocaml-exo-loading" in diff --git a/src/app/learnocaml_exercise_main.ml b/src/app/learnocaml_exercise_main.ml index 0ac7d113d..22cc95973 100644 --- a/src/app/learnocaml_exercise_main.ml +++ b/src/app/learnocaml_exercise_main.ml @@ -101,7 +101,7 @@ let () = (function | Ok (_, server_id) -> Learnocaml_local_storage.(store server_id) server_id; Lwt.return_true | Error _ -> Lwt.return_false) >>= fun has_server -> - let token = get_token ~has_server () + let session = get_session ~has_server () in (* ---- launch everything --------------------------------------------- *) let toplevel_buttons_group = button_group () in @@ -118,8 +118,8 @@ let () = Dom_html.document##.title := Js.string (id ^ " - " ^ "Learn OCaml" ^" v."^ Learnocaml_api.version); let exercise_fetch = - token >>= fun token -> - retrieve (Learnocaml_api.Exercise (token, id, true)) + session >>= fun session -> + retrieve (Learnocaml_api.Exercise_s (session, id, true)) in let after_init top = exercise_fetch >>= fun (_meta, exo, _deadline) -> @@ -171,8 +171,8 @@ let () = (* ---- details pane -------------------------------------------------- *) let load_meta () = Lwt.async (fun () -> - token >>= fun token -> - display_meta token ex_meta id) + session >>= fun session -> + display_meta session ex_meta id) in if arg "tab" = "meta" then load_meta () else Manip.Ev.onclick (find_component "learnocaml-exo-button-meta") (fun _ -> @@ -191,9 +191,9 @@ let () = let editor, ace = setup_editor solution in let module EB = Editor_button (struct let ace = ace let buttons_container = editor_toolbar end) in if has_server then - EB.reload token id (Learnocaml_exercise.(access File.template exo)) + EB.reload session id (Learnocaml_exercise.(access File.template exo)) else EB.cleanup (Learnocaml_exercise.(access File.template exo)); - EB.sync token id (fun () -> Ace.focus ace; Ace.set_synchronized ace) ; + EB.sync session id (fun () -> Ace.focus ace; Ace.set_synchronized ace) ; EB.download id; EB.eval top select_tab; let typecheck = typecheck top ace editor in @@ -277,8 +277,8 @@ let () = else Some solution, None in - token >>= fun token -> - sync_exercise token id ?answer ?editor (fun () -> Ace.set_synchronized ace) + session >>= fun session -> + sync_exercise session id ?answer ?editor (fun () -> Ace.set_synchronized ace) >>= fun _save -> select_tab "report" ; Lwt_js.yield () >>= fun () -> diff --git a/src/app/learnocaml_index_main.ml b/src/app/learnocaml_index_main.ml index 29a3d9dc6..7a8a3eaed 100644 --- a/src/app/learnocaml_index_main.ml +++ b/src/app/learnocaml_index_main.ml @@ -72,8 +72,8 @@ type tab_handler = let show_loading msg = show_loading ~id:El.loading_id H.[ul [li [txt msg]]] -let get_url token dynamic_url static_url id = - match token with +let get_url session dynamic_url static_url id = + match session with | Some _ -> dynamic_url ^ Url.urlencode id ^ "/" | None -> api_server ^ "/" ^ static_url ^ Url.urlencode id @@ -170,12 +170,12 @@ let make_exercises_to_display_signal index = let retain_signals = ref (React.S.const ()) (* Used to register signals as GC roots *) -let exercises_tab token : tab_handler = +let exercises_tab session: tab_handler = fun _ _ () -> let open Tyxml_js.Html5 in show_loading [%i"Loading exercises"] @@ fun () -> Lwt_js.sleep 0.5 >>= fun () -> - retrieve (Learnocaml_api.Exercise_index token) + retrieve (Learnocaml_api.Exercise_index_s session) >>= fun (index, deadlines) -> let exercises_to_display_signal = make_exercises_to_display_signal index @@ -214,7 +214,7 @@ let exercises_tab token : tab_handler = | Some pct when pct >= 100 -> [ "stats" ; "success" ] | Some _ -> [ "stats" ; "partial" ]) pct_signal in - a ~a:[ a_href (get_url token "/exercises/" "exercise.html#id=" exercise_id) ; + a ~a:[ a_href (get_url session "/exercises/" "exercise.html#id=" exercise_id) ; a_class [ "exercise" ] ] [ div ~a:[ a_class [ "descr" ] ] ( h1 [ txt title ] :: @@ -313,7 +313,7 @@ let exercises_tab token : tab_handler = React.S.merge (fun () () -> ()) () (list_update_signal :: btns_sigs); Lwt.return pane_div -let playground_tab token : tab_handler = +let playground_tab session : tab_handler = fun _ _ () -> show_loading [%i"Loading playground"] @@ fun () -> Lwt_js.sleep 0.5 >>= fun () -> @@ -324,7 +324,7 @@ let playground_tab token : tab_handler = let open Tyxml_js.Html5 in let title = pmeta.Playground.Meta.title in let short_description = pmeta.Playground.Meta.short_description in - a ~a:[ a_href (get_url token "/playground/" "playground.html#id=" id) ; + a ~a:[ a_href (get_url session "/playground/" "playground.html#id=" id) ; a_class [ "exercise" ] ] [ div ~a:[ a_class [ "descr" ] ] ( h1 [ txt title ] :: @@ -669,16 +669,27 @@ let toplevel_tab : tab_handler = init_toplevel_pane (Lwt.return top) top toplevel_buttons_group button ; Lwt.return div -let teacher_tab token : tab_handler = +let teacher_tab session: tab_handler = fun a b () -> show_loading [%i"Loading student info"] @@ fun () -> - Learnocaml_teacher_tab.teacher_tab token a b () >>= fun div -> + Learnocaml_teacher_tab.teacher_tab session a b () >>= fun div -> Lwt.return div -let get_stored_token () = - Learnocaml_local_storage.(retrieve sync_token) +let get_stored_session () = + Learnocaml_local_storage.(retrieve sync_session) -let sync () = sync (get_stored_token ()) +let fetch_token () = + let session = + try get_stored_session () + with Not_found -> failwith "No session stored" + in + Server_caller.request (Learnocaml_api.Get_token session) >>= function + | Ok token -> + Lwt.return token + | Error e -> + failwith ("Could not fetch token: " ^ Server_caller.string_of_error e) + +let sync () = sync (get_stored_session ()) let token_disp_div token = H.input ~a: [ @@ -716,9 +727,8 @@ let init_token_dialog () = retrieve (Learnocaml_api.Create_token (secret, None, Some nickname)) >>= fun token -> - Learnocaml_local_storage.(store sync_token) token; show_token_dialog token; - Lwt.return_some (token, nickname)) + Lwt.return_some nickname) in let rec login_token () = let input = input_tok in @@ -727,17 +737,34 @@ let init_token_dialog () = Manip.SetCss.borderColor input "#f44"; Lwt.return_none | token -> - Server_caller.request (Learnocaml_api.Fetch_save token) >>= function - | Ok save -> - set_state_from_save_file ~token save; - Lwt.return_some (token, save.Save.nickname) - | Error (`Not_found _) -> - alert ~title:[%i"TOKEN NOT FOUND"] - [%i"The entered token couldn't be recognised."]; - Lwt.return_none - | Error e -> - lwt_alert ~title:[%i"REQUEST ERROR"] [ - H.p [H.txt [%i"Could not retrieve data from server"]]; + Server_caller.request (Learnocaml_api.Login token) >>= function + | Ok session -> + Learnocaml_local_storage.(store sync_session) session; + Learnocaml_local_storage.(store is_teacher) (Token.is_teacher token); + Server_caller.request (Learnocaml_api.Fetch_save_s session) + >>= (function + | Ok save -> + set_state_from_save_file ~session:session save; + Lwt.return_some save.Save.nickname + | Error (`Not_found _) -> + alert ~title:[%i"TOKEN NOT FOUND"] + [%i"Token was accepted but no save found"]; + Lwt.return_none + | Error e -> + lwt_alert ~title:[%i"REQUEST ERROR"] [ + H.p [H.txt [%i"Could not retrieve save from server"]]; + H.code [H.txt (Server_caller.string_of_error e)]; + ] ~buttons:[ + [%i"Retry"], (fun () -> login_token ()); + [%i"Cancel"], (fun () -> Lwt.return_none); + ]) + | Error (`Not_found _) -> + alert ~title:[%i"TOKEN NOT FOUND"] + [%i"Invalid token"]; + Lwt.return_none + | Error e -> + lwt_alert ~title:[%i"REQUEST ERROR"] [ + H.p [H.txt [%i"Could not login to server"]]; H.code [H.txt (Server_caller.string_of_error e)]; ] ~buttons:[ [%i"Retry"], (fun () -> login_token ()); @@ -755,22 +782,58 @@ let init_token_dialog () = Manip.Ev.onreturn input_nick (handler create_token ()); Manip.Ev.onclick button_connect (handler login_token false); Manip.Ev.onreturn input_tok (handler login_token ()); - get_token >|= fun (token, nickname) -> + get_token >|= fun ( nickname) -> (Tyxml_js.To_dom.of_input nickname_field)##.value := Js.string nickname; Manip.SetCss.display login_overlay "none"; - token + let session = Learnocaml_local_storage.(retrieve sync_session) in + session -let init_sync_token button_group = +let init_sync_session button_group = catch (fun () -> begin try - Lwt.return Learnocaml_local_storage.(retrieve sync_token) + Lwt.return (Learnocaml_local_storage.(retrieve sync_session)) with Not_found -> init_token_dialog () - end >>= fun token -> + end >>= fun session -> enable_button_group button_group ; - Lwt.return (Some token)) + Lwt.return (Some session)) (fun _ -> Lwt.return None) +(** [migrate_from_legacy_token] runs once to move old browsers + that still keep the old [sync-token] (v 1.x and earlier) + over to the new session-based login used since Learn-OCaml 2.0. *) +let migrate_from_legacy_token () = + let token = + try + Some (Learnocaml_local_storage.(retrieve sync_token)) + with Not_found -> None + in + match token with + | None -> Lwt.return () + | Some token -> + Server_caller.request (Learnocaml_api.Login token) >>= function + | Error e -> + Learnocaml_common.alert + ~title:[%i"Migration error"] + (Server_caller.string_of_error e); + Lwt.return_unit + + | Ok session -> + Learnocaml_local_storage.(delete sync_token); + Learnocaml_local_storage.(store sync_session session); + Learnocaml_local_storage.(store is_teacher (Learnocaml_data.Token.is_teacher token)); + + Server_caller.request (Learnocaml_api.Fetch_save_s session) >>= (function + | Ok save -> + set_state_from_save_file ~session save; + Learnocaml_common.alert + ~title:[%i"Connection preserved"] + [%i"The application has been upgraded to a session-based \ + authentication. Your previous connection was restored"]; + Lwt.return_unit + | Error _ -> + Lwt.return_unit) + let set_string_translations () = let configured v s = Js.Optdef.case v (fun () -> s) Js.to_string in let translations = [ @@ -827,6 +890,7 @@ let () = Js.string ("Learn OCaml" ^ " v"^Learnocaml_api.version); Manip.setInnerText El.version ("v"^Learnocaml_api.version); Learnocaml_local_storage.init () ; + migrate_from_legacy_token () >>= fun () -> let sync_button_group = button_group () in disable_button_group sync_button_group; let menu_hidden = ref true in @@ -839,7 +903,7 @@ let () = Manip.appendChild El.content div ; delete_arg "activity" in - let init_tabs token = + let init_tabs session = let get_opt o = Js.Optdef.get o (fun () -> false) in let tabs : (string * (string * tab_handler)) list = (if get_opt config##.enableTutorials @@ -847,15 +911,16 @@ let () = (if get_opt config##.enableLessons then [ "lessons", ([%i"Lessons"], lessons_tab) ] else []) @ (if get_opt config##.enableExercises then - ["exercises", ([%i"Exercises"], exercises_tab token)] + ["exercises", ([%i"Exercises"], exercises_tab session)] else []) @ (if get_opt config##.enableToplevel then [ "toplevel", ([%i"Toplevel"], toplevel_tab) ] else []) @ (if get_opt config##.enablePlayground - then [ "playground", ([%i"Playground"], playground_tab token) ] else []) @ - (match token with - | Some t when Token.is_teacher t -> - [ "teacher", ([%i"Teach"], teacher_tab t) ] + then [ "playground", ([%i"Playground"], playground_tab session) ] else []) @ + let is_teacher = Learnocaml_local_storage.(retrieve is_teacher) in + (match session with + | Some s when is_teacher -> + [ "teacher", ([%i"Teach"], teacher_tab s) ] | _ -> []) in let container = El.tab_buttons_container in @@ -935,24 +1000,25 @@ let () = Json_repr_browser.Json_encoding.destruct Save.enc (Js._JSON##(parse contents)) in - let token = try Some (get_stored_token ()) with Not_found -> None in - set_state_from_save_file ?token save_file ; + let session = try Some (get_stored_session ()) with Not_found -> None in + set_state_from_save_file save_file ; (Tyxml_js.To_dom.of_input El.nickname_field)##.value := Js.string save_file.Save.nickname; - let _tabs = init_tabs token in + let _tabs = init_tabs session in no_tab_selected (); Lwt.return () in let download_all () = - let token = get_stored_token () |> Token.to_string in + let session = get_stored_session () |> Session.to_string in Dom_html.window##.location##assign - (Js.string @@ "/archive.zip?token=" ^ token); + (Js.string @@ "/archive.zip?session=" ^ session); Lwt.return_unit in let logout_dialog () = + fetch_token () >>= fun token -> Server_caller.request - (Learnocaml_api.Update_save - (get_stored_token (), get_state_as_save_file ())) + (Learnocaml_api.Update_save_s + (get_stored_session (), get_state_as_save_file ())) >|= (function | Ok _ -> [%i"Be sure to write down your token before logging out:"] @@ -964,7 +1030,7 @@ let () = confirm ~title:[%i"Logout"] ~ok_label:[%i"Logout"] [H.p [H.txt s]; H.div ~a:[H.a_style "text-align: center;"] - [token_disp_div (get_stored_token ())]] + [token_disp_div (token)]] (fun () -> Lwt.async @@ fun () -> Learnocaml_local_storage.clear (); @@ -975,7 +1041,8 @@ let () = button ~container:El.sync_buttons ~theme:"white" ~group:sync_button_group ~icon text f) [ [%i"Show token"], "token", (fun () -> - show_token_dialog (get_stored_token ()); + fetch_token () >>= fun token -> + show_token_dialog (token); Lwt.return_unit); [%i"Sync workspace"], "sync", (fun () -> catch_with_alert @@ fun () -> @@ -1025,7 +1092,7 @@ let () = true); Server_caller.request (Learnocaml_api.Version ()) >>= (function - | Ok _ -> init_sync_token sync_button_group >|= init_tabs + | Ok _ -> init_sync_session sync_button_group >|= fun session -> init_tabs session | Error _ -> Lwt.return (init_tabs None)) >>= fun tabs -> try let activity = arg "activity" in diff --git a/src/app/learnocaml_local_storage.ml b/src/app/learnocaml_local_storage.ml index c77aa6db7..4e28350fc 100644 --- a/src/app/learnocaml_local_storage.ml +++ b/src/app/learnocaml_local_storage.ml @@ -142,6 +142,7 @@ let server_id = { key = Some key ; dependent_keys = (=) key ; store ; retrieve ; delete ; listeners = [] } + let sync_token = let key = mangle [ "sync-token" ] in let enc = Json_encoding.(obj1 (req "token" string)) in @@ -151,6 +152,15 @@ let sync_token = { key = Some key ; dependent_keys = (=) key ; store ; retrieve ; delete ; listeners = [] } +let sync_session = + let key = mangle [ "sync-session" ] in + let enc = Json_encoding.(obj1 (req "session" string)) in + let store value = store_single key enc value + and retrieve () = retrieve_single key enc () + and delete () = delete_single key enc () in + { key = Some key ; dependent_keys = (=) key ; + store ; retrieve ; delete ; listeners = [] } + let nickname = let key = mangle [ "nickname" ] in let enc = Json_encoding.(obj1 (req "nickname" string)) in @@ -161,6 +171,16 @@ let nickname = { key = Some key ; dependent_keys = (=) key ; store ; retrieve ; delete ; listeners = [] } +let is_teacher = + let key = mangle [ "is_teacher" ] in + let enc = Json_encoding.(obj1 (req "is_teacher" bool)) in + let store value = store_single key enc value + and retrieve () = + try retrieve_single key enc () with Not_found -> false + and delete () = delete_single key enc () in + { key = Some key ; dependent_keys = (=) key ; + store ; retrieve ; delete ; listeners = [] } + let cached_exercise name = let key = mangle [ "cached-exercise" ; name ] in let enc = Learnocaml_exercise.enc in diff --git a/src/app/learnocaml_local_storage.mli b/src/app/learnocaml_local_storage.mli index 5dc4a3270..986475c45 100644 --- a/src/app/learnocaml_local_storage.mli +++ b/src/app/learnocaml_local_storage.mli @@ -57,4 +57,8 @@ val server_id : int storage_key val sync_token : Token.t storage_key +val sync_session : Session.t storage_key + +val is_teacher : bool storage_key + val nickname : string storage_key diff --git a/src/app/learnocaml_partition_view.ml b/src/app/learnocaml_partition_view.ml index a3e77ce99..1fe8b237b 100644 --- a/src/app/learnocaml_partition_view.ml +++ b/src/app/learnocaml_partition_view.ml @@ -215,8 +215,9 @@ let main () = Learnocaml_local_storage.init (); (match Js_utils.get_lang() with Some l -> Ocplib_i18n.set_lang l | None -> ()); set_string_translations_view (); - let teacher_token = Learnocaml_local_storage.(retrieve sync_token) in - if not (Token.is_teacher teacher_token) then + let session = Learnocaml_local_storage.(retrieve sync_session) in + let is_teacher = Learnocaml_local_storage.(retrieve is_teacher) in + if not (is_teacher) then (* No security here: it's client-side, and we don't check that the token is registered server-side *) failwith "The page you are trying to access is for teachers only"; @@ -234,7 +235,7 @@ let main () = | None -> true | Some (tok,_) -> Lwt.async (fun () -> - retrieve (Learnocaml_api.Fetch_save tok) + retrieve (Learnocaml_api.Fetch_save_s session) >|= fun save -> match SMap.find_opt exercise_id save.Save.all_exercise_states with | None -> () @@ -250,7 +251,7 @@ let main () = else true in let fetch_students = - retrieve (Learnocaml_api.Students_list teacher_token) + retrieve (Learnocaml_api.Students_list_s session) >|= fun students -> let map = List.fold_left (fun res st -> Token.Map.add st.Student.token st res) @@ -258,7 +259,7 @@ let main () = students_map := map in let fetch_part = - retrieve (Learnocaml_api.Partition (teacher_token, exercise_id, fun_id, prof)) + retrieve (Learnocaml_api.Partition_s (session, exercise_id, fun_id, prof)) >|= fun part -> partition := Some part in diff --git a/src/app/learnocaml_student_view.ml b/src/app/learnocaml_student_view.ml index c7c41e361..4b7260534 100644 --- a/src/app/learnocaml_student_view.ml +++ b/src/app/learnocaml_student_view.ml @@ -348,10 +348,10 @@ let stats_tab assignments answers = end ] -let init_exercises_and_stats_tabs teacher_token student_token answers = - retrieve (Learnocaml_api.Exercise_index (Some teacher_token)) +let init_exercises_and_stats_tabs student_token session answers = + retrieve (Learnocaml_api.Exercise_index_s (Some session)) >>= fun (index, _) -> - retrieve (Learnocaml_api.Exercise_status_index teacher_token) + retrieve (Learnocaml_api.Exercise_status_index_s session) >>= fun status -> let assignments = gather_assignments student_token index status in Manip.replaceChildren El.Tabs.(stats.tab) (stats_tab assignments answers); @@ -491,8 +491,9 @@ let () = Learnocaml_local_storage.init (); Option.iter Ocplib_i18n.set_lang (Js_utils.get_lang ()); set_string_translations_view (); - let teacher_token = Learnocaml_local_storage.(retrieve sync_token) in - if not (Token.is_teacher teacher_token) then + let is_teacher = Learnocaml_local_storage.(retrieve is_teacher) in + let session = Learnocaml_local_storage.(retrieve sync_session) in + if not (is_teacher) then (* No security here: it's client-side, and we don't check that the token is registered server-side *) failwith "The page you are trying to access is for teachers only"; @@ -503,11 +504,11 @@ let () = init_draft_tab (); Manip.setInnerText El.token ([%i"Status of student: "] ^ Token.to_string student_token); - retrieve (Learnocaml_api.Fetch_save student_token) + retrieve (Learnocaml_api.Fetch_save_s session) >>= fun save -> Manip.setInnerText El.nickname save.Save.nickname; init_exercises_and_stats_tabs - teacher_token student_token save.Save.all_exercise_states + student_token session save.Save.all_exercise_states >>= fun _sighandlers -> hide_loading ~id:El.loading_id (); let _sig = @@ -515,7 +516,7 @@ let () = | None -> () | Some ex_id -> Lwt.async @@ fun () -> - retrieve (Learnocaml_api.Exercise (Some teacher_token, ex_id, true)) + retrieve (Learnocaml_api.Exercise_s (Some session, ex_id, true)) >>= fun (meta, exo, _) -> clear_tabs (); let ans = SMap.find_opt ex_id save.Save.all_exercise_states in diff --git a/src/app/learnocaml_teacher_tab.ml b/src/app/learnocaml_teacher_tab.ml index c615e0b10..cee74a623 100644 --- a/src/app/learnocaml_teacher_tab.ml +++ b/src/app/learnocaml_teacher_tab.ml @@ -91,7 +91,7 @@ let help_button name (title,md_text) = H.a_style "margin-left: 1em;"; ] [H.txt "?"] -let rec teacher_tab token _select _params () = +let rec teacher_tab session _select _params () = let action_new_token () = Learnocaml_common.ask_string ~title:"NEW TEACHER TOKEN" @@ -101,7 +101,7 @@ let rec teacher_tab token _select _params () = | "" -> None | s -> Some s in - retrieve (Learnocaml_api.Create_teacher_token (token, nick)) + retrieve (Learnocaml_api.Create_teacher_token_s (session, nick)) >|= fun new_token -> alert ~title:[%i"TEACHER TOKEN"] (Printf.sprintf [%if"New teacher token created:\n%s\n\n\ @@ -217,7 +217,7 @@ let rec teacher_tab token _select _params () = Seq.filter_map (function `Token tk -> Some tk | `Any -> None) |> List.of_seq in - retrieve (Learnocaml_api.Students_csv (token, exercises, students)) + retrieve (Learnocaml_api.Students_csv_s (session, exercises, students)) >|= fun csv -> Learnocaml_common.fake_download ~name:"learnocaml.csv" @@ -946,14 +946,14 @@ let rec teacher_tab token _select _params () = in (if changes = [] then Lwt.return () else retrieve - (Learnocaml_api.Set_exercise_status (token, changes))) + (Learnocaml_api.Set_exercise_status_s (session, changes))) >>= fun () -> (if students_changes = [] then Lwt.return () else retrieve - (Learnocaml_api.Set_students_list (token, students_changes))) + (Learnocaml_api.Set_students_list_s (session, students_changes))) >>= fun () -> (* Reload the full tab: a bit more costly, but safer & simpler *) - teacher_tab token _select _params () >|= + teacher_tab session _select _params () >|= Manip.replaceSelf (find_component "learnocaml-main-teacher") (* status_map := status_current (); * status_changes := SMap.empty; @@ -1333,12 +1333,12 @@ let rec teacher_tab token _select _params () = ] in let fetch_exercises = - retrieve (Learnocaml_api.Exercise_index (Some token)) + retrieve (Learnocaml_api.Exercise_index_s (Some session)) >|= fun (index, _) -> exercises_index := index in let fetch_stats = - retrieve (Learnocaml_api.Exercise_status_index token) + retrieve (Learnocaml_api.Exercise_status_index_s session) >|= fun statuses -> let map = List.fold_left (fun m ex -> SMap.add ex.ES.id ex m) @@ -1347,7 +1347,7 @@ let rec teacher_tab token _select _params () = status_map := map in let fetch_students = - retrieve (Learnocaml_api.Students_list token) + retrieve (Learnocaml_api.Students_list_s session) >|= fun students -> students_map := List.fold_left (fun m st -> Token.Map.add st.Student.token st m) diff --git a/src/app/learnocaml_teacher_tab.mli b/src/app/learnocaml_teacher_tab.mli index 5ac39bcd6..3fc99e7e7 100644 --- a/src/app/learnocaml_teacher_tab.mli +++ b/src/app/learnocaml_teacher_tab.mli @@ -9,5 +9,5 @@ open Js_of_ocaml_tyxml val teacher_tab: - Learnocaml_data.Token.t -> (unit -> 'a Lwt.t) -> 'b -> unit -> + Learnocaml_data.Session.t -> (unit -> 'a Lwt.t) -> 'b -> unit -> [> Html_types.div ] Tyxml_js.Html5.elt Lwt.t diff --git a/src/app/server_caller.ml b/src/app/server_caller.ml index 9cb7a873a..a9d9c2f00 100644 --- a/src/app/server_caller.ml +++ b/src/app/server_caller.ml @@ -114,8 +114,8 @@ let fetch_lesson_index () = let fetch_lesson id = request_exn (Learnocaml_api.Lesson id) -let fetch_exercise token id js = - request_exn (Learnocaml_api.Exercise (token,id,js)) +let fetch_exercise session id js = + request_exn (Learnocaml_api.Exercise_s (session,id,js)) let fetch_tutorial_index () = request_exn (Learnocaml_api.Tutorial_index ()) diff --git a/src/app/server_caller.mli b/src/app/server_caller.mli index 932344be0..f01790dbb 100644 --- a/src/app/server_caller.mli +++ b/src/app/server_caller.mli @@ -24,7 +24,7 @@ exception Cannot_fetch of string val request_exn: 'a Learnocaml_api.request -> 'a Lwt.t val[@deprecated] fetch_exercise: - Token.t option -> Exercise.id -> bool -> (Exercise.Meta.t * Exercise.t * float option) Lwt.t + Session.t option -> Exercise.id -> bool -> (Exercise.Meta.t * Exercise.t * float option) Lwt.t val[@deprecated] fetch_lesson_index: unit -> Lesson.Index.t Lwt.t val[@deprecated] fetch_lesson : string -> Lesson.t Lwt.t diff --git a/src/main/dune b/src/main/dune index 5cfc7fff9..734a90cc7 100644 --- a/src/main/dune +++ b/src/main/dune @@ -43,7 +43,6 @@ cohttp-lwt-unix grading_cli learnocaml_data - learnocaml_store learnocaml_api) ) (install diff --git a/src/main/learnocaml_client.ml b/src/main/learnocaml_client.ml index 25121374e..eabbb58aa 100644 --- a/src/main/learnocaml_client.ml +++ b/src/main/learnocaml_client.ml @@ -452,7 +452,7 @@ let console_report ?(verbose=false) ex report = List.iter (fun i -> print_endline (format_item i)) report; print_newline () -module Api_client = Learnocaml_api.Client (Learnocaml_store.Json_codec) +module Api_client = Learnocaml_api.Client (Learnocaml_api.Json_codec) let fetch server_url req = let url path args = diff --git a/src/server/dune b/src/server/dune index 2efd24516..5593095ae 100644 --- a/src/server/dune +++ b/src/server/dune @@ -11,7 +11,8 @@ magic-mime sha checkseum.c - decompress + decompress.de + decompress.zl learnocaml_report learnocaml_data learnocaml_api diff --git a/src/server/learnocaml_server.ml b/src/server/learnocaml_server.ml index 364b5088a..93c56101a 100644 --- a/src/server/learnocaml_server.ml +++ b/src/server/learnocaml_server.ml @@ -22,8 +22,7 @@ let args = Arg.align @@ "PATH where static files should be found (./www)" ; "-sync-dir", Arg.Set_string sync_dir, "PATH where sync tokens are stored (./sync)" ; - "-base-url", Arg.Set_string base_url, - "BASE_URL of the website. \ + "-base-url", Arg.Set_string base_url,"BASE_URL of the website. \ Should not end with a trailing slash. \ Currently, this has no effect on the native backend. \ Mandatory for 'learn-ocaml build' if the site is not hosted in path '/', \ @@ -232,6 +231,11 @@ module Request_handler = struct (`Forbidden, "No address information avaible") lwt_ok + let wrap_user_session session f = + Session.get_user_token session >>= function + | Some token -> f token + | None -> Lwt.fail_with "Invalid session" + let callback_raw: type resp. Conduit.endp -> Learnocaml_data.Server.config -> caching -> resp Api.request -> (resp response, error) result Lwt.t @@ -288,6 +292,29 @@ module Request_handler = struct | Some nickname -> Save.set tok Save.{empty with nickname}) >>= fun () -> respond_json cache tok + | Api.Create_teacher_token_s (session, nick) -> + wrap_user_session session @@ fun token -> + verify_teacher_token token + >?= fun () -> + Token.create_teacher () + >>= fun tok -> + (match nick with | None -> Lwt.return_unit + | Some nickname -> + Save.set tok Save.{empty with nickname}) + >>= fun () -> respond_json cache tok + | Api.Login token -> + lwt_catch_fail + (fun () -> + Token.exists token >>= fun exists -> + lwt_option_fail + (if exists then Some token else None) + (`Not_found, "Token does not exist") + @@ fun token -> + let session = Session.gen_session () in + Session.set_session session token >>= fun () -> + respond_json cache session + ) + (fun exn -> (`Internal_server_error, Printexc.to_string exn)) | Api.Fetch_save token -> lwt_catch_fail (fun () -> @@ -297,6 +324,19 @@ module Request_handler = struct (`Not_found, "token not found") (respond_json cache)) (fun exn -> (`Internal_server_error, Printexc.to_string exn)) + | Api.Fetch_save_s session -> + wrap_user_session session @@ fun token -> + lwt_catch_fail + (fun () -> + Save.get token >>= fun tokopt -> + lwt_option_fail + tokopt + (`Not_found, "token not found") + (respond_json cache)) + (fun exn -> (`Internal_server_error, Printexc.to_string exn)) + | Api.Get_token session -> + wrap_user_session session @@ fun token -> + respond_json cache token | Api.Archive_zip token -> let open Lwt_process in let path = Filename.concat !sync_dir (Token.to_path token) in @@ -306,6 +346,16 @@ module Request_handler = struct lwt_ok @@ Response { contents = contents; content_type = "application/zip"; caching = Nocache } + | Api.Archive_zip_s session -> + let open Lwt_process in + wrap_user_session session @@ fun token -> + let path = Filename.concat !sync_dir (Token.to_path token) in + let cmd = shell ("git archive master --format=zip -0 --remote="^path) + and stdout = `FD_copy Unix.stdout in + Lwt_process.pread ~stdin:stdout cmd >>= fun contents -> + lwt_ok @@ Response { contents = contents; + content_type = "application/zip"; + caching = Nocache } | Api.Update_save (token, save) -> let save = Save.fix_mtimes save in let exercise_states = SMap.bindings save.Save.all_exercise_states in @@ -332,6 +382,33 @@ module Request_handler = struct @@ fun prev_save -> let save = Save.sync prev_save save in Save.set token save >>= fun () -> respond_json cache save) + | Api.Update_save_s (session, save) -> + wrap_user_session session @@ fun token -> + let save = Save.fix_mtimes save in + let exercise_states = SMap.bindings save.Save.all_exercise_states in + (Token.check_teacher token >>= function + | true -> Lwt.return exercise_states + | false -> + Lwt_list.filter_s (fun (id, _) -> + Exercise.Status.is_open id token >|= function + | `Open -> true + | `Closed -> false + | `Deadline t -> t >= -300. (* Grace period! *)) + exercise_states) + >>= fun valid_exercise_states -> + let save = + { save with + Save.all_exercise_states = + List.fold_left (fun m (id,save) -> SMap.add id save m) + SMap.empty valid_exercise_states } + in + token_save_mutex.Lwt_utils.with_lock (token :> Token.t) (fun () -> + Save.get token >>= fun x -> + lwt_option_fail x + (`Not_found, Token.to_string token) + @@ fun prev_save -> + let save = Save.sync prev_save save in + Save.set token save >>= fun () -> respond_json cache save) | Api.Git (token, path) -> let prefix = let ( / ) = Filename.concat in @@ -351,6 +428,11 @@ module Request_handler = struct verify_teacher_token token >?= fun () -> Student.Index.get () >>= respond_json cache + | Api.Students_list_s session -> + wrap_user_session session @@ fun token -> + verify_teacher_token token >?= fun () -> + Student.Index.get () + >>= respond_json cache | Api.Set_students_list (token, students) -> verify_teacher_token token >?= fun () -> Lwt_list.map_s @@ -365,6 +447,21 @@ module Request_handler = struct students >>= Student.Index.set >>= respond_json cache + | Api.Set_students_list_s (session, students) -> + wrap_user_session session @@ fun token -> + verify_teacher_token token >?= fun () -> + Lwt_list.map_s + (fun (ancestor, ours) -> + let token = ancestor.Student.token in + Student.get token >|= fun theirs -> + let theirs = match theirs with + | None -> Student.default token + | Some std -> std + in + Student.three_way_merge ~ancestor ~theirs ~ours) + students >>= + Student.Index.set + >>= respond_json cache | Api.Students_csv (token, exercises, students) -> verify_teacher_token token >?= fun () -> (match students with @@ -432,6 +529,74 @@ module Request_handler = struct Response {contents = Buffer.contents buf; content_type = "text/csv"; caching = Nocache} + | Api.Students_csv_s (session, exercises, students) -> + wrap_user_session session @@ fun token -> + verify_teacher_token token >?= fun () -> + (match students with + | [] -> Token.Index.get () >|= List.filter Token.is_student + | l -> Lwt.return l) + >>= Lwt_list.map_p (fun token -> + Save.get token >|= fun save -> token, save) + >>= fun tok_saves -> + let all_exercises = + match exercises with + | [] -> + List.fold_left (fun acc (_tok, save) -> + match save with + | None -> acc + | Some save -> + SMap.fold (fun ex_id _ans acc -> SSet.add ex_id acc) + save.Save.all_exercise_states + acc) + SSet.empty tok_saves + |> SSet.elements + | exercises -> exercises + in + let columns = + "token" :: "nickname" :: + (List.fold_left (fun acc ex_id -> + (ex_id ^ " grade") :: + (ex_id ^ " date") :: + acc) + [] (List.rev all_exercises)) + in + let buf = Buffer.create 3497 in + let sep () = Buffer.add_char buf ',' in + let line () = Buffer.add_char buf '\n' in + Buffer.add_string buf (String.concat "," columns); + line (); + Lwt_list.iter_s (fun (tok, save) -> + match save with None -> Lwt.return_unit | Some save -> + Buffer.add_string buf (Token.to_string tok); + sep (); + Buffer.add_string buf save.Save.nickname; + Lwt_list.iter_s (fun ex_id -> + Lwt.catch (fun () -> + sep (); + Exercise.get ex_id >>= fun exo -> + Lwt.wrap2 SMap.find ex_id save.Save.all_exercise_states + >|= fun st -> + (match st.Answer.grade with + | None -> () + | Some grade -> + if match st.Answer.report with + | None -> false + | Some rep -> check_report exo rep grade + then Buffer.add_string buf (string_of_int grade) + else Printf.bprintf buf "CHEAT(%d)" grade); + sep (); + Buffer.add_string buf (string_of_date st.Answer.mtime)) + (function + | Not_found -> sep (); Lwt.return_unit + | e -> raise e)) + all_exercises + >|= line) + tok_saves + >>= fun () -> + lwt_ok @@ + Response {contents = Buffer.contents buf; + content_type = "text/csv"; + caching = Nocache} | Api.Exercise_index (Some token) -> Exercise.Index.get () >>= fun index -> @@ -449,8 +614,27 @@ module Request_handler = struct k true) index (fun index -> Lwt.return (index, !deadlines))) >>= respond_json cache + | Api.Exercise_index_s (Some session) -> + wrap_user_session session @@ fun token -> + Exercise.Index.get () >>= fun index -> + Token.check_teacher token >>= (function + | true -> Lwt.return (index, []) + | false -> + let deadlines = ref [] in + Exercise.Index.filterk + (fun id _ k -> + Exercise.Status.is_open id token >>= function + | `Open -> k true + | `Closed -> k false + | `Deadline t -> + deadlines := (id, max t 0.) :: !deadlines; + k true) + index (fun index -> Lwt.return (index, !deadlines))) + >>= respond_json cache | Api.Exercise_index None -> lwt_fail (`Forbidden, "Forbidden") + | Api.Exercise_index_s None -> + lwt_fail (`Forbidden, "Forbidden") | Api.Exercise (Some token, id, js) -> (Exercise.Status.is_open id token >>= function @@ -463,8 +647,22 @@ module Request_handler = struct match o with `Deadline t -> Some (max t 0.) | `Open -> None) | `Closed -> lwt_fail (`Forbidden, "Exercise closed")) + | Api.Exercise_s (Some session, id, js) -> + wrap_user_session session @@ fun token -> + (Exercise.Status.is_open id token >>= function + | `Open | `Deadline _ as o -> + Exercise.Meta.get id >>= fun meta -> + Exercise.get id >>= fun ex -> + let ex = Learnocaml_exercise.strip js ex in + respond_json cache + (meta, ex, + match o with `Deadline t -> Some (max t 0.) | `Open -> None) + | `Closed -> + lwt_fail (`Forbidden, "Exercise closed")) | Api.Exercise (None, _, _) -> lwt_fail (`Forbidden, "Forbidden") + | Api.Exercise_s (None, _, _) -> + lwt_fail (`Forbidden, "Forbidden") | Api.Lesson_index () -> Lesson.Index.get () >>= respond_json cache @@ -484,9 +682,17 @@ module Request_handler = struct | Api.Exercise_status_index token -> verify_teacher_token token >?= fun () -> Exercise.Status.all () >>= respond_json cache + | Api.Exercise_status_index_s session -> + wrap_user_session session @@ fun token -> + verify_teacher_token token >?= fun () -> + Exercise.Status.all () >>= respond_json cache | Api.Exercise_status (token, id) -> verify_teacher_token token >?= fun () -> Exercise.Status.get id >>= respond_json cache + | Api.Exercise_status_s (session, id) -> + wrap_user_session session @@ fun token -> + verify_teacher_token token >?= fun () -> + Exercise.Status.get id >>= respond_json cache | Api.Set_exercise_status (token, status) -> verify_teacher_token token >?= fun () -> Lwt_list.iter_s @@ -495,6 +701,15 @@ module Request_handler = struct set (three_way_merge ~ancestor ~theirs ~ours)) status >>= respond_json cache + | Api.Set_exercise_status_s (session, status) -> + wrap_user_session session @@ fun token -> + verify_teacher_token token >?= fun () -> + Lwt_list.iter_s + Exercise.Status.(fun (ancestor, ours) -> + get ancestor.id >>= fun theirs -> + set (three_way_merge ~ancestor ~theirs ~ours)) + status + >>= respond_json cache | Api.Partition (token, eid, fid, prof) -> lwt_catch_fail (fun () -> @@ -504,6 +719,15 @@ module Request_handler = struct >>= respond_json cache ) (fun exn -> (`Not_found, Printexc.to_string exn)) + | Api.Partition_s (session, eid, fid, prof) -> + wrap_user_session session @@ fun token -> + lwt_catch_fail (fun () -> + verify_teacher_token token + >?= fun () -> + Learnocaml_partition_create.partition eid fid prof + >>= respond_json cache + ) + (fun exn -> (`Not_found, Printexc.to_string exn)) | Api.Invalid_request body -> lwt_fail (`Bad_request, body) @@ -530,7 +754,7 @@ module Request_handler = struct end -module Api_server = Api.Server (Json_codec) (Request_handler) +module Api_server = Api.Server (Api.Json_codec) (Request_handler) let init_teacher_token () = Token.Index.get () >>= function tokens -> @@ -560,36 +784,44 @@ let last_modified = (* server startup time *) (tm.tm_year + 1900) tm.tm_hour tm.tm_min tm.tm_sec -(* Taken from the source of "decompress", from bin/easy.ml *) +(* Adapted from the source of "decompress.1.5.3", from bin/decompress.ml *) let compress ?(level = 4) data = - let input_buffer = Bytes.create 0xFFFF in - let output_buffer = Bytes.create 0xFFFF in - - let pos = ref 0 in - let res = Buffer.create (String.length data) in - + let bigstring_output o off len buf = + let res = Bytes.create len in + for i = 0 to len - 1 do + Bytes.set res i o.{off + i} + done + ; Buffer.add_bytes buf res in + let src_len = String.length data in + let dst_bound = max (De.Def.Ns.compress_bound src_len) De.io_buffer_size in + let o = De.bigstring_create dst_bound in + (* buffer.mli: nothing bad will happen if the buffer grows beyond that limit: *) + let buf = Buffer.create dst_bound in + (* de.mli: we recommend a queue as large as output buffer: *) + let q = De.Queue.create De.io_buffer_size in + (* LZ77 with a 32.kB sliding-window compression: *) + let w = De.Lz77.make_window ~bits:15 in + let open Zl in + let encoder = Def.encoder (`String data) `Manual ~q ~w ~level in + let rec go encoder = + match Def.encode encoder with + | `Await _encoder -> + Error "Zl.Def.encode: could not compress" + | `Flush encoder -> + let len = De.io_buffer_size - Def.dst_rem encoder in + bigstring_output o 0 len buf + ; Def.dst encoder o 0 De.io_buffer_size |> go + | `End encoder -> + let len = De.io_buffer_size - Def.dst_rem encoder in + if len > 0 then bigstring_output o 0 len buf + ; Ok (Buffer.contents buf) in Lwt_preemptive.detach - (Decompress.Zlib_deflate.bytes - input_buffer - output_buffer - (fun input_buffer -> function - | Some max -> - let n = min max (min 0xFFFF (String.length data - !pos)) in - Bytes.blit_string data !pos input_buffer 0 n; - pos := !pos + n; - n - | None -> - let n = min 0xFFFF (String.length data - !pos) in - Bytes.blit_string data !pos input_buffer 0 n; - pos := !pos + n; - n) - (fun output_buffer len -> - Buffer.add_subbytes res output_buffer 0 len; - 0xFFFF)) - (Decompress.Zlib_deflate.default ~witness:Decompress.B.bytes level) + (fun () -> + Def.dst encoder o 0 De.io_buffer_size |> go) + () >>= function - | Ok _ -> Lwt.return (Buffer.contents res) - | Error _ -> Lwt.fail_with "Could not compress" + | Ok str -> Lwt.return str + | Error e -> Lwt.fail_with e let launch () = Random.self_init () ; diff --git a/src/state/dune b/src/state/dune index 4f03db743..55e281e38 100644 --- a/src/state/dune +++ b/src/state/dune @@ -40,5 +40,5 @@ (name learnocaml_store) (wrapped false) (modules Learnocaml_store) - (libraries lwt_utils learnocaml_api) + (libraries cryptokit lwt_utils learnocaml_api irmin irmin-git irmin-git.unix) ) diff --git a/src/state/learnocaml_api.ml b/src/state/learnocaml_api.ml index 655b7f0f9..f97e87d4d 100644 --- a/src/state/learnocaml_api.ml +++ b/src/state/learnocaml_api.ml @@ -102,26 +102,49 @@ type _ request = string * student token option * string option -> student token request | Create_teacher_token: teacher token * string option -> teacher token request + | Create_teacher_token_s: + 'a session * string option -> teacher token request + | Login: + 'a token -> Session.t request | Fetch_save: 'a token -> Save.t request + | Fetch_save_s: + 'a session -> Save.t request + | Get_token: + 'a session -> Token.t request | Archive_zip: 'a token -> string request + | Archive_zip_s: + 'a session -> string request | Update_save: 'a token * Save.t -> Save.t request + | Update_save_s: + 'a session * Save.t -> Save.t request | Git: 'a token * string list -> string request | Students_list: teacher token -> Student.t list request + | Students_list_s: + 'a session -> Student.t list request | Set_students_list: teacher token * (Student.t * Student.t) list -> unit request + | Set_students_list_s: + 'a session * (Student.t * Student.t) list -> unit request | Students_csv: teacher token * Exercise.id list * Token.t list -> string request + | Students_csv_s: + 'a session * Exercise.id list * Token.t list -> string request | Exercise_index: 'a token option -> (Exercise.Index.t * (Exercise.id * float) list) request + | Exercise_index_s: + 'a session option -> (Exercise.Index.t * (Exercise.id * float) list) request | Exercise: 'a token option * string * bool -> (Exercise.Meta.t * Exercise.t * float option) request + | Exercise_s: + 'a session option * string * bool -> + (Exercise.Meta.t * Exercise.t * float option) request | Lesson_index: unit -> (string * string) list request @@ -140,13 +163,21 @@ type _ request = | Exercise_status_index: teacher token -> Exercise.Status.t list request + | Exercise_status_index_s: + 'a session -> Exercise.Status.t list request | Exercise_status: teacher token * Exercise.id -> Exercise.Status.t request + | Exercise_status_s: + 'a session * Exercise.id -> Exercise.Status.t request | Set_exercise_status: teacher token * (Exercise.Status.t * Exercise.Status.t) list -> unit request + | Set_exercise_status_s: + 'a session * (Exercise.Status.t * Exercise.Status.t) list -> unit request | Partition: teacher token * Exercise.id * string * int -> Partition.t request + | Partition_s: + 'a session * Exercise.id * string * int -> Partition.t request | Invalid_request: string -> string request @@ -158,26 +189,41 @@ let supported_versions | Version _ | Nonce _ | Create_token (_, _, _) - | Create_teacher_token _ - | Fetch_save _ - | Archive_zip _ - | Update_save (_, _) + | Create_teacher_token _ -> Compat.(Upto (v "2.0")) + | Fetch_save _ -> Compat.(Upto (v "2.0")) + | Archive_zip _ -> Compat.(Upto (v "2.0")) + | Update_save (_, _) -> Compat.(Upto (v "2.0")) | Git (_, _) - | Students_list _ - | Set_students_list (_, _) - | Students_csv (_, _, _) - | Exercise_index _ - | Exercise (_, _, _) + | Students_list _ -> Compat.(Upto (v "2.0")) + | Set_students_list (_, _) -> Compat.(Upto (v "2.0")) + | Students_csv (_, _, _) -> Compat.(Upto (v "2.0")) + | Exercise_index _ -> Compat.(Upto (v "2.0")) + | Exercise (_, _, _) -> Compat.(Upto (v "2.0")) | Lesson_index _ | Lesson _ | Tutorial_index _ | Tutorial _ | Playground_index _ | Playground _ - | Exercise_status_index _ - | Exercise_status (_, _) - | Set_exercise_status (_, _) - | Partition (_, _, _, _) + | Exercise_status_index _ -> Compat.(Upto (v "2.0")) + | Exercise_status (_, _) -> Compat.(Upto (v "2.0")) + | Set_exercise_status (_, _) -> Compat.(Upto (v "2.0")) + | Partition (_, _, _, _) -> Compat.(Upto (v "2.0")) + | Login _ -> Compat.(Since (v "2.0")) + | Get_token _ -> Compat.(Since (v "2.0")) + | Create_teacher_token_s _ -> Compat.(Since (v "2.0")) + | Fetch_save_s _ -> Compat.(Since (v "2.0")) + | Archive_zip_s _ -> Compat.(Since (v "2.0")) + | Update_save_s _ -> Compat.(Since (v "2.0")) + | Students_list_s _ -> Compat.(Since (v "2.0")) + | Set_students_list_s _ -> Compat.(Since (v "2.0")) + | Students_csv_s _ -> Compat.(Since (v "2.0")) + | Exercise_index_s _ -> Compat.(Since (v "2.0")) + | Exercise_s _ -> Compat.(Since (v "2.0")) + | Exercise_status_index_s _ -> Compat.(Since (v "2.0")) + | Exercise_status_s _ -> Compat.(Since (v "2.0")) + | Set_exercise_status_s _ -> Compat.(Since (v "2.0")) + | Partition_s (_, _, _, _) -> Compat.(Since (v "2.0")) | Invalid_request _ -> Compat.(Since (v "0.12")) let is_supported @@ -207,6 +253,23 @@ module type JSON_CODEC = sig val encode: ?minify:bool -> 'a J.encoding -> 'a -> string end +(* Erik: Json_codec was initially in learnocaml_store.ml, + which induced unneeded dependencies: + learn-ocaml-client -> irmin-git.unix, cryptokit *) +module Json_codec = struct + let decode enc s = + (match s with + | "" -> `O [] + | s -> Ezjsonm.from_string s) + |> J.destruct enc + + let encode ?minify enc x = + match J.construct enc x with + | `A _ | `O _ as json -> Ezjsonm.to_string ?minify json + | `Null -> "" + | _ -> assert false +end + module Conversions (Json: JSON_CODEC) = struct let response_codec @@ -228,24 +291,48 @@ module Conversions (Json: JSON_CODEC) = struct Token.(to_string, parse) | Create_teacher_token _ -> json J.(obj1 (req "token" string)) +> - Token.(to_string, parse) - | Fetch_save _ -> + Token.(to_string, parse) + | Create_teacher_token_s _ -> + json J.(obj1 (req "token" string)) +> + Token.(to_string, parse) + | Login _ -> + json J.(obj1 (req "session" string)) + | Fetch_save _ -> json Save.enc + |Fetch_save_s _ -> + json Save.enc + | Get_token _ -> + json J.(obj1 (req "token" string)) +> + Token.(to_string, parse) | Archive_zip _ -> str + | Archive_zip_s _ -> + str | Update_save _ -> json Save.enc + | Update_save_s _ -> + json Save.enc | Git _ -> str | Students_list _ -> json (J.list Student.enc) + | Students_list_s _ -> + json (J.list Student.enc) | Set_students_list _ -> json J.unit + | Set_students_list_s _ -> + json J.unit | Students_csv _ -> str + | Students_csv_s _ -> + str | Exercise_index _ -> json (J.tup2 Exercise.Index.enc (J.assoc J.float)) + | Exercise_index_s _ -> + json (J.tup2 Exercise.Index.enc (J.assoc J.float)) | Exercise _ -> json (J.tup3 Exercise.Meta.enc Exercise.enc (J.option J.float)) + | Exercise_s _ -> + json (J.tup3 Exercise.Meta.enc Exercise.enc (J.option J.float)) | Lesson_index _ -> json Lesson.Index.enc | Lesson _ -> @@ -261,13 +348,21 @@ module Conversions (Json: JSON_CODEC) = struct | Exercise_status_index _ -> json (J.list Exercise.Status.enc) + | Exercise_status_index_s _ -> + json (J.list Exercise.Status.enc) | Exercise_status _ -> json Exercise.Status.enc + | Exercise_status_s _ -> + json Exercise.Status.enc | Set_exercise_status _ -> json J.unit + | Set_exercise_status_s _ -> + json J.unit | Partition _ -> json Partition.enc + | Partition_s _ -> + json Partition.enc | Invalid_request _ -> str @@ -279,15 +374,17 @@ module Conversions (Json: JSON_CODEC) = struct let to_http_request : type resp. resp request -> http_request = - let get ?token ?(args=[]) path = { + let get ?token ?session ?(args=[]) path = { meth = `GET; path; - args = (match token with None -> [] | Some t -> ["token", Token.to_string t]) @ args; + args = (match token with None -> [] | Some t -> ["token", Token.to_string t]) @ + (match session with None -> [] | Some s -> ["session", s]) @ args; } in - let post ~token path body = { + let post ?token ?session path body = { meth = `POST body; path; - args = ["token", Token.to_string token]; + args = (match token with None -> [] | Some t -> ["token", Token.to_string t]) @ + (match session with None -> [] | Some s -> ["session", s]); } in function | Static path -> @@ -304,24 +401,42 @@ module Conversions (Json: JSON_CODEC) = struct assert (Token.is_teacher token); get ~token (["teacher"; "new"] @ (match nick with None -> [] | Some n -> [n])) - + | Create_teacher_token_s (session, nick) -> + get ~session (["session"; "teacher"; "new"] @ + (match nick with None -> [] | Some n -> [n])) + | Login token -> + get ~token ["login"] | Fetch_save token -> get ~token ["save.json"] + | Fetch_save_s session -> + get ~session ["session"; "save.json"] + | Get_token session -> + get ~session ["token"] | Archive_zip token -> get ~token ["archive.zip"] + | Archive_zip_s session -> + get ~session ["session"; "archive.zip"] | Update_save (token, save) -> post ~token ["sync"] (Json.encode Save.enc save) + | Update_save_s (session, save) -> + post ~session ["session"; "sync"] (Json.encode Save.enc save) | Git _ -> assert false (* Reserved for the [git] client *) | Students_list token -> assert (Token.is_teacher token); get ~token ["teacher"; "students.json"] + | Students_list_s session -> + get ~session ["session"; "teacher"; "students.json"] | Set_students_list (token, students) -> assert (Token.is_teacher token); post ~token ["teacher"; "students.json"] (Json.encode (J.list (J.tup2 Student.enc Student.enc)) students) + | Set_students_list_s (session, students) -> + post ~session + ["session"; "teacher"; "students.json"] + (Json.encode (J.list (J.tup2 Student.enc Student.enc)) students) | Students_csv (token, exercises, students) -> assert (Token.is_teacher token); post ~token ["teacher"; "students.csv"] @@ -330,19 +445,37 @@ module Conversions (Json: JSON_CODEC) = struct (J.dft "exercises" (J.list J.string) []) (J.dft "students" (J.list Token.enc) [])) (exercises, students)) + | Students_csv_s (session, exercises, students) -> + post ~session ["session"; "teacher"; "students.csv"] + (Json.encode + (J.obj2 + (J.dft "exercises" (J.list J.string) []) + (J.dft "students" (J.list Token.enc) [])) + (exercises, students)) | Exercise_index (Some token) -> get ~token ["exercise-index.json"] + | Exercise_index_s (Some session) -> + get ~session ["session"; "exercise-index.json"] | Exercise_index None -> get ["exercise-index.json"] + | Exercise_index_s None -> + get ["session"; "exercise-index.json"] | Exercise (Some token, id, js) -> get ~token ("exercises" :: String.split_on_char '/' (id^".json")) ~args:["mode", if js then "js" else "byte"] + | Exercise_s (Some session, id, js) -> + get ~session + ("session" :: "exercises" :: String.split_on_char '/' (id^".json")) + ~args:["mode", if js then "js" else "byte"] | Exercise (None, id, js) -> get ("exercises" :: String.split_on_char '/' (id^".json")) ~args:["mode", if js then "js" else "byte"] + | Exercise_s (None, id, js) -> + get ("exercises" :: String.split_on_char '/' (id^".json")) + ~args:["mode", if js then "js" else "byte"] | Lesson_index () -> get ["lessons.json"] @@ -362,19 +495,33 @@ module Conversions (Json: JSON_CODEC) = struct | Exercise_status_index token -> assert (Token.is_teacher token); get ~token ["teacher"; "exercise-status.json"] + | Exercise_status_index_s session -> + get ~session ["session"; "teacher"; "exercise-status.json"] | Exercise_status (token, id) -> get ~token ("teacher" :: "exercise-status" :: String.split_on_char '/' id) + | Exercise_status_s (session, id) -> + get ~session + ("session" :: "teacher" :: "exercise-status" :: String.split_on_char '/' id) | Set_exercise_status (token, status) -> post ~token ["teacher"; "exercise-status"] (Json.encode (J.list (J.tup2 Exercise.Status.enc Exercise.Status.enc)) status) + | Set_exercise_status_s (session, status) -> + post ~session + ["session"; "teacher"; "exercise-status"] + (Json.encode + (J.list (J.tup2 Exercise.Status.enc Exercise.Status.enc)) + status) | Partition (token, eid, fid, prof) -> get ~token ["partition"; eid; fid; string_of_int prof] + | Partition_s (session, eid, fid, prof) -> + get ~session + ["session"; "partition"; eid; fid; string_of_int prof] | Invalid_request s -> failwith ("Error request "^s) @@ -407,47 +554,76 @@ module Server (Json: JSON_CODEC) (Rh: REQUEST_HANDLER) = struct try Some (Token.parse stoken) with Failure _ -> None in - match request.meth, request.path, token with - | `GET, ([] | [""]), _ -> + let session = + match List.assoc_opt "session" request.args with + | None -> None + | Some session -> Some session + in + match request.meth, request.path, token, session with + | `GET, ([] | [""]), _, _ -> Static ["index.html"] |> k - | `GET, ["version"], _ -> + | `GET, ["version"], _ , _-> Version () |> k - | `GET, ["nonce"], _ -> + | `GET, ["nonce"], _, _ -> Nonce () |> k - | `GET, ["sync"; "new"; secret_candidate], token -> + | `GET, ["sync"; "new"; secret_candidate], token, _ -> Create_token (secret_candidate, token, None) |> k - | `GET, ["sync"; "new"; secret_candidate; nick], token -> + | `GET, ["sync"; "new"; secret_candidate; nick], token, _ -> Create_token (secret_candidate, token, Some nick) |> k - | `GET, ["teacher"; "new"], Some token when Token.is_teacher token -> + | `GET, ["teacher"; "new"], Some token, _ when Token.is_teacher token -> Create_teacher_token (token, None) |> k - | `GET, ["teacher"; "new"; nick], Some token when Token.is_teacher token -> + | `GET, ["session"; "teacher"; "new"], _, Some session -> + Create_teacher_token_s (session, None) |> k + | `GET, ["teacher"; "new"; nick], Some token, _ when Token.is_teacher token -> Create_teacher_token (token, Some nick) |> k - | `GET, ["save.json"], Some token -> + | `GET, ["session"; "teacher"; "new"; nick], _, Some session -> + Create_teacher_token_s (session, Some nick) |> k + | `GET, ["login"], Some token, _ -> + Login token |> k + | `GET, ["save.json"], Some token, _-> Fetch_save token |> k - | `GET, ["archive.zip"], Some token -> + | `GET, ["session"; "save.json"], _, Some session -> + Fetch_save_s session |> k + | `GET, ["token"], _, Some session -> + Get_token session |> k + | `GET, ["archive.zip"], Some token, _ -> Archive_zip token |> k - | `POST body, ["sync"], Some token -> + | `GET, ["session"; "archive.zip"], _, Some session -> + Archive_zip_s session |> k + | `POST body, ["sync"], Some token, _ -> (match Json.decode Save.enc body with | save -> Update_save (token, save) |> k | exception e -> Invalid_request (Printexc.to_string e) |> k) - | `GET, (stoken::"learnocaml-workspace.git"::p), None -> + | `POST body, ["session"; "sync"], _, Some session -> + (match Json.decode Save.enc body with + | save -> Update_save_s (session, save) |> k + | exception e -> Invalid_request (Printexc.to_string e) |> k) + | `GET, (stoken::"learnocaml-workspace.git"::p), None, _ -> (match Token.parse stoken with | token -> Git (token, p) |> k | exception Failure e -> Invalid_request e |> k) - | `GET, ["teacher"; "students.json"], Some token + | `GET, ["teacher"; "students.json"], Some token, _ when Token.is_teacher token -> Students_list token |> k - | `POST body, ["teacher"; "students.json"], Some token + | `GET, ["session"; "teacher"; "students.json"], _, Some session -> + Students_list_s session |> k + | `POST body, ["teacher"; "students.json"], Some token, _ when Token.is_teacher token -> (match Json.decode (J.list (J.tup2 Student.enc Student.enc)) body with | students -> Set_students_list (token, students) |> k | exception e -> Invalid_request (Printexc.to_string e) |> k) - | `GET, ["teacher"; "students.csv"], Some token + | `POST body, ["session"; "teacher"; "students.json"], _, Some session -> + (match Json.decode (J.list (J.tup2 Student.enc Student.enc)) body with + | students -> Set_students_list_s (session, students) |> k + | exception e -> Invalid_request (Printexc.to_string e) |> k) + | `GET, ["teacher"; "students.csv"], Some token, _ when Token.is_teacher token -> Students_csv (token, [], []) |> k - | `POST body, ["teacher"; "students.csv"], Some token + | `GET, ["session"; "teacher"; "students.csv"], _, Some session -> + Students_csv_s (session, [], []) |> k + | `POST body, ["teacher"; "students.csv"], Some token, _ when Token.is_teacher token -> (match Json.decode (J.obj2 @@ -458,10 +634,22 @@ module Server (Json: JSON_CODEC) (Rh: REQUEST_HANDLER) = struct | exercises, students -> Students_csv (token, exercises, students) |> k | exception e -> Invalid_request (Printexc.to_string e) |> k) + | `POST body, ["session"; "teacher"; "students.csv"], _, Some session -> + (match Json.decode + (J.obj2 + (J.dft "exercises" (J.list J.string) []) + (J.dft "students" (J.list Token.enc) [])) + body + with + | exercises, students -> + Students_csv_s (session, exercises, students) |> k + | exception e -> Invalid_request (Printexc.to_string e) |> k) - | `GET, ["exercise-index.json"], token -> + | `GET, ["exercise-index.json"], token, _ -> Exercise_index token |> k - | `GET, ("exercises"::path), token -> + | `GET, ["session"; "exercise-index.json"], _, session -> + Exercise_index_s session |> k + | `GET, ("exercises"::path), token, _ -> (match last path with | Some s when String.lowercase_ascii (Filename.extension s) = ".json" -> (match token with @@ -474,11 +662,24 @@ module Server (Json: JSON_CODEC) (Rh: REQUEST_HANDLER) = struct Static ["exercise.html"] |> k | _ -> Static ("static"::path) |> k) - | `GET, ("description"::_), _token -> + | `GET, ("session"::"exercises"::path), _, session -> + (match last path with + | Some s when String.lowercase_ascii (Filename.extension s) = ".json" -> + (match session with + | Some session -> + let id = Filename.chop_suffix (String.concat "/" path) ".json" in + let js = List.assoc_opt "mode" request.args = Some "js" in + Exercise_s (Some session, id, js) |> k + | None -> Invalid_request "Missing session" |> k) + | Some "" -> + Static ["exercise.html"] |> k + | _ -> + Static ("static"::path) |> k) + | `GET, ("description"::_), _token, _ -> (* match token with | None -> Invalid_request "Missing token" |> k *) Static ["description.html"] |> k - | `GET, ("playground"::path), _token -> + | `GET, ("playground"::path), _token, _ -> begin match last path with | Some s when String.lowercase_ascii (Filename.extension s) = ".json" -> @@ -489,32 +690,38 @@ module Server (Json: JSON_CODEC) (Rh: REQUEST_HANDLER) = struct | _ -> Static ("static"::path) |> k end - | `GET, ["lessons.json"], _ -> + | `GET, ["lessons.json"], _, _ -> Lesson_index () |> k - | `GET, ["lessons"; f], _ when Filename.check_suffix f ".json" -> + | `GET, ["lessons"; f], _, _ when Filename.check_suffix f ".json" -> Lesson (Filename.chop_suffix f ".json") |> k - | `GET, ["tutorials.json"], _ -> + | `GET, ["tutorials.json"], _, _ -> Tutorial_index () |> k - | `GET, ["tutorials"; f], _ when Filename.check_suffix f ".json" -> + | `GET, ["tutorials"; f], _, _ when Filename.check_suffix f ".json" -> Tutorial (Filename.chop_suffix f ".json") |> k - | `GET, ["playgrounds.json"], _ -> + | `GET, ["playgrounds.json"], _, _ -> Playground_index () |> k - | `GET, ["playgrounds"; f], _ when Filename.check_suffix f ".json" -> + | `GET, ["playgrounds"; f], _, _ when Filename.check_suffix f ".json" -> Playground (Filename.chop_suffix f ".json") |> k - | `GET, ["partition"; eid; fid; prof], Some token + | `GET, ["partition"; eid; fid; prof], Some token, _ when Token.is_teacher token -> Partition (token, eid, fid, int_of_string prof) |> k + | `GET, ["session"; "partition"; eid; fid; prof], _, Some session -> + Partition_s (session, eid, fid, int_of_string prof) |> k - | `GET, ["teacher"; "exercise-status.json"], Some token + | `GET, ["teacher"; "exercise-status.json"], Some token, _ when Token.is_teacher token -> Exercise_status_index token |> k - | `GET, ("teacher" :: "exercise-status" :: id), Some token + | `GET, ["session"; "teacher"; "exercise-status.json"], _, Some session -> + Exercise_status_index_s session |> k + | `GET, ("teacher" :: "exercise-status" :: id), Some token, _ when Token.is_teacher token -> Exercise_status (token, String.concat "/" id) |> k - | `POST body, ["teacher"; "exercise-status"], Some token + | `GET, ("session" :: "teacher" :: "exercise-status" :: id), _, Some session -> + Exercise_status_s (session, String.concat "/" id) |> k + | `POST body, ["teacher"; "exercise-status"], Some token, _ when Token.is_teacher token -> (match Json.decode (J.list (J.tup2 Exercise.Status.enc Exercise.Status.enc)) @@ -523,6 +730,14 @@ module Server (Json: JSON_CODEC) (Rh: REQUEST_HANDLER) = struct | status -> Set_exercise_status (token, status) |> k | exception e -> Invalid_request (Printexc.to_string e) |> k) + | `POST body, ["session"; "teacher"; "exercise-status"], _, Some session -> + (match Json.decode + (J.list (J.tup2 Exercise.Status.enc Exercise.Status.enc)) + body + with + | status -> + Set_exercise_status_s (session, status) |> k + | exception e -> Invalid_request (Printexc.to_string e) |> k) | `GET, ( ["index.html"] @@ -532,13 +747,13 @@ module Server (Json: JSON_CODEC) (Rh: REQUEST_HANDLER) = struct | ["description.html"] | ["partition-view.html"] | ("js"|"fonts"|"icons"|"css"|"static") :: _ as path), - _ -> + _, _ -> Static path |> k - | `GET, ["favicon.ico"], _ -> + | `GET, ["favicon.ico"], _, _ -> Static ["icons"; "favicon.ico"] |> k - | meth, path, _ -> + | meth, path, _, _ -> Invalid_request (Printf.sprintf "%s /%s%s" (match meth with `GET -> "GET" | `POST _ -> "POST") diff --git a/src/state/learnocaml_api.mli b/src/state/learnocaml_api.mli index 984a3277a..b22108c97 100644 --- a/src/state/learnocaml_api.mli +++ b/src/state/learnocaml_api.mli @@ -88,29 +88,52 @@ type _ request = string * student token option * string option -> student token request | Create_teacher_token: teacher token * string option -> teacher token request + | Create_teacher_token_s: + 'a session * string option -> teacher token request + | Login: + 'a token -> Session.t request | Fetch_save: 'a token -> Save.t request + | Fetch_save_s: + 'a session -> Save.t request + | Get_token: + 'a session -> Token.t request | Archive_zip: 'a token -> string request + | Archive_zip_s: + 'a session -> string request | Update_save: 'a token * Save.t -> Save.t request + | Update_save_s: + 'a session * Save.t -> Save.t request | Git: 'a token * string list -> string request | Students_list: teacher token -> Student.t list request + | Students_list_s: + 'a session -> Student.t list request | Set_students_list: teacher token * (Student.t * Student.t) list -> unit request + | Set_students_list_s: + 'a session * (Student.t * Student.t) list -> unit request (** Does not affect the students absent from the list. the pairs are the before/after states, used for merging *) | Students_csv: teacher token * Exercise.id list * Token.t list -> string request + | Students_csv_s: + 'a session * Exercise.id list * Token.t list -> string request | Exercise_index: 'a token option -> (Exercise.Index.t * (Exercise.id * float) list) request + | Exercise_index_s: + 'a session option -> (Exercise.Index.t * (Exercise.id * float) list) request | Exercise: 'a token option * string * bool -> (Exercise.Meta.t * Exercise.t * float option) request + | Exercise_s: + 'a session option * string * bool -> + (Exercise.Meta.t * Exercise.t * float option) request | Lesson_index: unit -> (string * string) list request @@ -129,16 +152,25 @@ type _ request = | Exercise_status_index: teacher token -> Exercise.Status.t list request + | Exercise_status_index_s: + 'a session -> Exercise.Status.t list request | Exercise_status: teacher token * Exercise.id -> Exercise.Status.t request + | Exercise_status_s: + 'a session * Exercise.id -> Exercise.Status.t request | Set_exercise_status: teacher token * (Exercise.Status.t * Exercise.Status.t) list -> unit request + | Set_exercise_status_s: + 'a session * (Exercise.Status.t * Exercise.Status.t) list -> + unit request (** The two Status.t correspond to the states before and after changes, used for three-way merge *) | Partition: teacher token * Exercise.id * string * int -> Partition.t request + | Partition_s: + 'a session * Exercise.id * string * int -> Partition.t request | Invalid_request: string -> string request @@ -164,6 +196,9 @@ module type JSON_CODEC = sig val encode: ?minify:bool -> 'a Json_encoding.encoding -> 'a -> string end +(** Used both for file i/o and request handling *) +module Json_codec: JSON_CODEC + module type REQUEST_HANDLER = sig type 'resp ret diff --git a/src/state/learnocaml_data.ml b/src/state/learnocaml_data.ml index 211ee9928..595a645e1 100644 --- a/src/state/learnocaml_data.ml +++ b/src/state/learnocaml_data.ml @@ -188,6 +188,29 @@ module Save = struct end +module Session = struct + type t = string + + let parse session = + let len = 32 in + if String.length session <> 2 * len then + failwith "Bad session length" + else if not (String.for_all + (fun c -> match c with + | '0'..'9' | 'a'..'z' -> true + | _ -> false) + session) + then + failwith "Invalid hex character" + else + session + + let to_string s = s + + let enc = J.conv (fun s -> s) parse J.string +end +type 'a session = Session.t + module Token = struct type t = string list diff --git a/src/state/learnocaml_data.mli b/src/state/learnocaml_data.mli index 2af6ed0a3..9fcd0bc8d 100644 --- a/src/state/learnocaml_data.mli +++ b/src/state/learnocaml_data.mli @@ -70,6 +70,18 @@ module Save: sig end +module Session : sig + type t = string + + val to_string: t -> string + + val parse: string -> t + + val enc : t Json_encoding.encoding +end + +type 'a session = Session.t + module Token: sig type t diff --git a/src/state/learnocaml_store.ml b/src/state/learnocaml_store.ml index 04bd5d51e..c4da13e09 100644 --- a/src/state/learnocaml_store.ml +++ b/src/state/learnocaml_store.ml @@ -15,26 +15,15 @@ let static_dir = ref (Filename.concat (Sys.getcwd ()) "www") let sync_dir = ref (Filename.concat (Sys.getcwd ()) "sync") -module Json_codec = struct - let decode enc s = - (match s with - | "" -> `O [] - | s -> Ezjsonm.from_string s) - |> J.destruct enc - - let encode ?minify enc x = - match J.construct enc x with - | `A _ | `O _ as json -> Ezjsonm.to_string ?minify json - | `Null -> "" - | _ -> assert false -end +let data_dir = ref (Filename.concat !sync_dir "data") + let get_from_file enc p = Lwt_io.(with_file ~mode: Input p read) >|= - Json_codec.decode enc + Learnocaml_api.Json_codec.decode enc let write_to_file enc s p = let open Lwt_io in - let s = Json_codec.encode enc s in + let s = Learnocaml_api.Json_codec.encode enc s in with_file ~mode:output p @@ fun oc -> write oc s let sanitise_path prefix subpath = @@ -215,7 +204,7 @@ module Exercise = struct let save () = Lazy.force tbl >>= fun tbl -> let l = Hashtbl.fold (fun _ s acc -> s::acc) tbl [] in - let s = Json_codec.encode (J.list enc) l in + let s = Learnocaml_api.Json_codec.encode (J.list enc) l in write (store_file ()) s let get id = @@ -297,6 +286,55 @@ module Exercise = struct end +module Session = struct + + include Session + open Lwt.Syntax + + module Store = Irmin_git_unix.FS.KV(Irmin.Contents.Json_value) + module Info = Irmin_git_unix.Info(Store.Info) + + let repo_path = ref "./session_store.git" + + let config () = Irmin_git.config ~bare:true !repo_path + + type entry = { + session : Session.t; + token : Token.t; + last_connection : float; + } + + let enc = + let open Json_encoding in + conv + (fun {session; token; last_connection} -> (session, token, last_connection)) + (fun (session, token, last_connection) -> {session; token; last_connection}) + (obj3 + (req "session" Session.enc) + (req "token" Token.enc) + (req "last_connection" float)) + + let set_session session token = + let now = Unix.gettimeofday () in + let* repo = Store.Repo.v (config ()) in + let* t = Store.main repo in + Store.set_exn t ~info:(Info.v "Set session/token") [Session.to_string session] (Json_encoding.construct enc {session; token; last_connection = now}) + + let get_user_token session = + let* repo = Store.Repo.v (config ()) in + let* t = Store.main repo in + Store.find t [Session.to_string session] >|= function + | Some value -> + let entry = Json_encoding.destruct enc value in + Some entry.token + | None -> None + + let gen_session () = + let len = 32 in + Cryptokit.Random.string Cryptokit.Random.secure_rng len + |> Cryptokit.transform_string @@ Cryptokit.Hexa.encode () +end + module Token = struct include Token @@ -452,7 +490,7 @@ module Save = struct in Lwt.catch (fun () -> write ~no_create:(Token.is_teacher token) ~extra file - (Json_codec.encode ~minify:false enc save)) + (Learnocaml_api.Json_codec.encode ~minify:false enc save)) (function | Not_found -> Lwt.fail_with "Unregistered teacher token" | e -> Lwt.fail e) @@ -515,7 +553,7 @@ module Student = struct let save () = Lazy.force map >>= fun map -> - let s = Json_codec.encode store_enc !map in + let s = Learnocaml_api.Json_codec.encode store_enc !map in write (store_file ()) s let get_student map token = diff --git a/src/state/learnocaml_store.mli b/src/state/learnocaml_store.mli index e0d1356e5..37ced23f0 100644 --- a/src/state/learnocaml_store.mli +++ b/src/state/learnocaml_store.mli @@ -15,11 +15,12 @@ val static_dir: string ref (** All mutable data access will be made relative to this directory *) val sync_dir: string ref +val data_dir: string ref (** {2 Utility server-side conversion functions} *) (** Used both for file i/o and request handling *) -module Json_codec: Learnocaml_api.JSON_CODEC + val get_from_file : 'a Json_encoding.encoding -> string -> 'a Lwt.t val write_to_file : 'a Json_encoding.encoding -> 'a -> string -> unit Lwt.t @@ -111,6 +112,27 @@ end (** {2 Dynamic data} *) +module Session: sig + + include module type of struct include Session end + + type entry = { + session : Session.t; + token : Token.t; + last_connection : float; + } + val enc : entry Json_encoding.encoding + + (** Retrieves the token associated with the given session. *) + val get_user_token : t -> Token.t option Lwt.t + + (** Associates a token to a session. *) + val set_session : t -> Token.t -> unit Lwt.t + + (** Generates a fresh session identifier *) + val gen_session : unit -> Session.t +end + module Token: sig