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/demo-repository/server_config.json b/demo-repository/server_config.json new file mode 100644 index 000000000..dc8e798d1 --- /dev/null +++ b/demo-repository/server_config.json @@ -0,0 +1,3 @@ +{ + "use_lti": true +} 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/dune b/src/app/dune index addb087bb..fb65b7fe3 100644 --- a/src/app/dune +++ b/src/app/dune @@ -132,6 +132,28 @@ (preprocessor_deps (sandbox none)) ) +(executable + (name learnocaml_lti_main) + (modes byte js) + (flags :standard -warn-error -6-9-27-33-39) + (libraries ezjsonm + ace + sha + learnocaml_repository + learnocaml_app_common + learnocaml_toplevel + js_of_ocaml-ppx + ocplib_i18n + js_of_ocaml-tyxml + str) + (modules Learnocaml_lti_main) + (preprocess (pps ppx_ocplib_i18n js_of_ocaml-ppx)) + (preprocessor_deps (sandbox none)) + (js_of_ocaml + (flags :standard +cstruct/cstruct.js) + (javascript_files ../ace-lib/ace_bindings.js)) +) + (install (package learn-ocaml) (section share) @@ -140,6 +162,7 @@ (learnocaml_student_view.bc.js as www/js/learnocaml-student-view.js) (learnocaml_description_main.bc.js as www/js/learnocaml-description.js) (learnocaml_partition_view.bc.js as www/js/learnocaml-partition-view.js) - (learnocaml_playground_main.bc.js as www/js/learnocaml-playground.js)) + (learnocaml_playground_main.bc.js as www/js/learnocaml-playground.js) + (learnocaml_lti_main.bc.js as www/js/learnocaml-lti.js)) ) diff --git a/src/app/learnocaml_common.ml b/src/app/learnocaml_common.ml index a5a12d2d6..43f2d920a 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,28 +1159,38 @@ let setup_prelude_pane ace prelude = Manip.appendChildren prelude_pane [ prelude_title ; prelude_container ] -let get_token ?(has_server = true) () = +let encode_form_body body = + body |> List.map (fun (k,v) -> (k, [v])) |> Uri.encoded_of_query + +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 -> ask_string ~title:"Token" ~may_cancel:false [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 + let body = [ ("method", "token"); ("token", input_tok) ] in + let encoded_body = encode_form_body body in + Server_caller.request (Learnocaml_api.Login encoded_body) >>= 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 +1265,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 +1377,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 +1385,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..ceb3ce5b8 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,9 @@ 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 encode_form_body : (string * string) list -> string + +val get_session : ?has_server:bool -> unit -> Learnocaml_data.Session.t option Lwt.t module Display_exercise :functor (_ : sig @@ -269,7 +271,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 +296,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..ea904b8e9 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,36 @@ 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"]]; + let body = [ ("method", "token"); ("token", Token.to_string token) ] in + let encoded_body = Learnocaml_common.encode_form_body body in + Server_caller.request (Learnocaml_api.Login encoded_body) >>= 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 +784,88 @@ 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 get_cookie name = + Js.(to_array (str_array (Dom_html.document##.cookie##split (string ";")))) + |> Array.fold_left + (fun res v -> + match res with + | Some _ -> res + | None -> let cookie = Js.to_string v + |> String.trim + |> String.split_on_char '=' in + match cookie with + | n :: v when n = name -> Some (String.concat "=" v) + | _ -> None) + None + +let delete_cookie name = + Dom_html.document##.cookie := Js.string (Printf.sprintf "%s=; Max-age=-1;" name) -let init_sync_token button_group = +let init_sync_session button_group = catch (fun () -> - begin try - Lwt.return Learnocaml_local_storage.(retrieve sync_token) - with Not_found -> init_token_dialog () - end >>= fun token -> + begin + match get_cookie "session" with + | None -> + begin + try Lwt.return Learnocaml_local_storage.(retrieve sync_session) + with Not_found -> init_token_dialog () + end + | Some session -> + let session = Learnocaml_data.Session.parse session in + Server_caller.request (Learnocaml_api.Fetch_save_s session) >>= function + | Ok save -> + set_state_from_save_file ~session:session save; + Lwt.return session + | Error _ -> init_token_dialog () + 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 -> + let body = [ ("method", "token"); ("token", Token.to_string token) ] in + let encoded_body = Learnocaml_common.encode_form_body body in + Server_caller.request (Learnocaml_api.Login encoded_body) >>= 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 +922,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 +935,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 +943,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 +1032,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,10 +1062,11 @@ 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 (); + delete_cookie "session"; reload (); Lwt.return_unit) in @@ -975,7 +1074,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 +1125,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_lti_main.ml b/src/app/learnocaml_lti_main.ml new file mode 100644 index 000000000..bc652d35a --- /dev/null +++ b/src/app/learnocaml_lti_main.ml @@ -0,0 +1,45 @@ +(* This file is part of Learn-OCaml. + * + * Copyright (C) 2020 Alban Gruin + * + * Learn-OCaml is distributed under the terms of the MIT license. See the + * included LICENSE file for details. *) + +open Js_utils +open Js_of_ocaml +open Lwt +open Learnocaml_common + +module H = Js_of_ocaml_tyxml.Tyxml_js.Html5 + +let id s = s, find_component s + +(* XXX there is dead code among these variables *) +let login_overlay_id, login_overlay = id "login-overlay" + +let login_direct_button_id, login_direct_button = id "login-direct-login" + +let login_token_button_id, login_token_button = id "login-token-button" + +let set_string_translations = + List.iter + (fun (id, text) -> + Manip.setInnerHtml (find_component id) text) + +let init_dialogs () = + Manip.SetCss.display login_overlay "block" + +let () = + (match Js_utils.get_lang () with Some l -> Ocplib_i18n.set_lang l | None -> ()); + init_dialogs (); + set_string_translations [ + "txt_direct_login_nickname", [%i"Choose a nickname"]; + "txt_direct_login", [%i"Direct login"]; + "txt_indirect_label", [%i"Or to be able to login independently of Moodle, \ + you might want to setup a password below \ + (or upgrade your account later)"]; + "txt_button_direct_login", [%i"Direct login"]; + "txt_token_returning", [%i"Connect"]; + "txt_returning_with_token", [%i"Reuse an account with a legacy token"]; + "txt_returning_token", [%i"Token"]; + ] 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..940662e79 100644 --- a/src/server/dune +++ b/src/server/dune @@ -11,10 +11,37 @@ magic-mime sha checkseum.c - decompress + decompress.de + decompress.zl learnocaml_report learnocaml_data learnocaml_api + learnocaml_auth learnocaml_store - learnocaml_partition_create) + learnocaml_partition_create + markup) ) +(library + (name learnocaml_auth) + (modules learnocaml_auth) + (libraries lwt.unix + lwt_utils + cryptokit + learnocaml_store + learnocaml_data) +) + +(library + (name learnocaml_auth_test) + (wrapped false) + (modules Learnocaml_auth_test) + (libraries learnocaml_auth + learnocaml_store + learnocaml_data + lwt.unix + lwt_utils + cryptokit) + (inline_tests) + (preprocess (pps ppx_expect ppx_inline_test)) +) + diff --git a/src/server/learnocaml_auth.ml b/src/server/learnocaml_auth.ml new file mode 100644 index 000000000..de7abc162 --- /dev/null +++ b/src/server/learnocaml_auth.ml @@ -0,0 +1,158 @@ +(* This file is part of Learn-OCaml. + * + * Copyright (C) 2019-2023 OCaml Software Foundation. + * Copyright (C) 2015-2018 OCamlPro. + * + * Learn-OCaml is distributed under the terms of the MIT license. See the + * included LICENSE file for details. *) + +open Learnocaml_data +open Learnocaml_store +open Lwt.Infix + + +let generate_random_hex len = + Cryptokit.Random.string Cryptokit.Random.secure_rng len + |> Cryptokit.transform_string @@ Cryptokit.Hexa.encode () + +let safe_encode s = + Uri.pct_encode ~component:`Userinfo s + + +let generate_hmac secret csrf user_id = + let hmac = Cryptokit.MAC.hmac_sha256 secret and + encoder = Cryptokit.Hexa.encode () in + Cryptokit.hash_string hmac (csrf ^ user_id) + |> Cryptokit.transform_string encoder + +module type AUTH_METHOD = sig + type login_credentials + type register_credentials + type associate_credentials + + val login : login_credentials -> (Token.t, string) result Lwt.t + val register : register_credentials -> (Token.t, string) result Lwt.t + val associate : associate_credentials -> (Token.t, string) result Lwt.t + val get_token : params:(string * string) list -> (Token.t, string) result Lwt.t +end + +type oauth_args = { + signature: string; + timestamp: string; + nonce: string; + version: string; + consumer_key: string; + signature_method: string; + } + +let get_oauth_args args = + (* POST request handling *) + List.( + let signature = assoc "oauth_signature" args and + timestamp = assoc "oauth_timestamp" args and + nonce = assoc "oauth_nonce" args and + version = assoc "oauth_version" args and + consumer_key = assoc "oauth_consumer_key" args and + signature_method = assoc "oauth_signature_method" args in + {signature; timestamp; nonce; version; consumer_key; signature_method} + ) + +(* Based on gapi-ocaml + This function will build a signature by using hmac_sha1 algorithm.*) +let signature_oauth list_args http_method basic_uri secret = + let pair_encode = (* 1 : encode keys/values *) + List.filter (fun (k, _) -> k <> "oauth_signature") list_args + |> List.map (fun (k, v) -> + (safe_encode k,safe_encode v)) in + let pair_sorted = List.sort compare pair_encode in + let list_concat = (* 3 : Form key=value&key2=value2*) + List.map (fun (k, v) -> k ^ "=" ^ v) pair_sorted + |> String.concat "&" in + let signature_base_string = (* 4 : Add HTTP method and URI *) + Printf.sprintf "%s&%s&%s" (String.uppercase_ascii http_method) + (safe_encode basic_uri) + (safe_encode list_concat) in + let signing_key = (safe_encode secret) ^ "&" in (* 5 : Build signing_key *) + let encoding = + let hash = Cryptokit.MAC.hmac_sha1 signing_key in + let result = Cryptokit.hash_string hash signature_base_string in + Base64.encode result + in match encoding with + | Ok string -> string + | Error (`Msg msg) -> failwith msg + +let oauth_signature_method = "HMAC-SHA1" + + +(** LTI (Moodle) authentication implementation *) +module LtiAuth = struct + type login_credentials = { user_id : string } + type register_credentials = { user_id : string; nickname : string; csrf : string; hmac : string } + type associate_credentials = { user_id : string; token : Token.t; csrf : string; hmac : string } + + let user_exists _ = Lwt.return true + + let get_token id = + LtiIndex.get_user_token id >>= function + | Some token -> Lwt.return (Ok token) + | None -> Lwt.return (Error "Token not found") + + let can_login id token = + LtiIndex.exists id >>= fun already_linked -> + if already_linked then + Lwt.return false + else + TokenIndex.has token "lti" >|= not + + + let login (_:login_credentials) = Lwt.return (Error "TODO: implement LtiAuth.login") + + let register (params:register_credentials) = + NonceIndex.get_current_secret () >>= fun secret -> + let new_hmac = generate_hmac secret params.csrf params.user_id in + if not (Eqaf.equal params.hmac new_hmac) then + Lwt.return (Error "bad hmac") + else + let nickname = params.nickname in + Token.create_student () >>= fun token -> + (if nickname = "" then Lwt.return_unit + else Save.set token Save.{empty with nickname}) + >>= fun () -> + LtiIndex.add params.user_id token >>= fun () -> + Lwt.return (Ok token) + + let associate (params:associate_credentials) = + NonceIndex.get_current_secret () >>= fun secret -> + let new_hmac = generate_hmac secret params.csrf params.user_id in + if not (Eqaf.equal params.hmac new_hmac) then + Lwt.return (Error "bad hmac") + else + can_login params.user_id params.token >>= fun canlogin -> + if not canlogin then + Lwt.return (Error "Bad token (or token already used by an upgraded account") + else + LtiIndex.add params.user_id params.token >>= fun () -> + Lwt.return (Ok params.token) + + (** Don't give the same oauth_consumer_key to differents LTI consumer **) + (* Deal with the request to check OAuth autenticity and return Moodle user's token*) + let check_oauth url args secret = + try + let oauth_args = get_oauth_args args in + if oauth_args.signature_method <> oauth_signature_method then + Lwt.return (Error "Not implemented") + else + NonceIndex.check_nonce oauth_args.nonce >>= fun exists -> + if exists then + Lwt.return (Error "Nonce already used") + else + NonceIndex.add_nonce oauth_args.nonce >>= fun () -> + let s = signature_oauth args "post" url secret in + if Eqaf.equal s oauth_args.signature then + Lwt.return (Ok ((safe_encode oauth_args.consumer_key) ^ "/" ^ (List.assoc "user_id" args))) + else + Lwt.return (Error "Wrong signature") + with Not_found -> + Lwt.return (Error "Missing args") + +end diff --git a/src/server/learnocaml_auth.mli b/src/server/learnocaml_auth.mli new file mode 100644 index 000000000..06261d51b --- /dev/null +++ b/src/server/learnocaml_auth.mli @@ -0,0 +1,29 @@ +(* This file is part of Learn-OCaml. + * + * Copyright (C) 2019-2023 OCaml Software Foundation. + * Copyright (C) 2015-2018 OCamlPro. + * + * Learn-OCaml is distributed under the terms of the MIT license. See the + * included LICENSE file for details. *) + +(** Modular authentication framework for Learn-OCaml. *) + +open Learnocaml_data + +val generate_hmac : string -> string -> string -> string + +(** Authentication using LTI (Moodle) *) +module LtiAuth : sig + type login_credentials = { user_id : string } + type register_credentials = { user_id : string; nickname : string; csrf : string; hmac : string } + type associate_credentials = { user_id : string; token : Token.t; csrf : string; hmac : string } + + val login : login_credentials -> (Token.t, string) result Lwt.t + val register : register_credentials -> (Token.t, string) result Lwt.t + val associate : associate_credentials -> (Token.t, string) result Lwt.t + + val user_exists : string -> bool Lwt.t + val get_token : string -> (Token.t, string) result Lwt.t + + val check_oauth : string -> (string * string) list -> string -> (string, string) result Lwt.t +end diff --git a/src/server/learnocaml_auth_test.ml b/src/server/learnocaml_auth_test.ml new file mode 100644 index 000000000..9f8063fc6 --- /dev/null +++ b/src/server/learnocaml_auth_test.ml @@ -0,0 +1,75 @@ +(* This file is part of Learn-OCaml. + * + * Copyright (C) 2024 OCaml Software Foundation. + * + * Learn-OCaml is distributed under the terms of the MIT license. See the + * included LICENSE file for details. *) + +(* LTI OAuth signature verification: expect-style tests *) + +open Learnocaml_auth.LtiAuth +open Learnocaml_store +open Lwt.Infix + +let () = + sync_dir := Filename.get_temp_dir_name (); + LtiIndex.repo_path := "mem://" + +let parse_body (body : string) : (string * string) list = + Uri.query_of_encoded body + |> List.map (fun (k, vs) -> k, String.concat "," vs) + +let learner_payload = + "oauth_version=1.0&oauth_nonce=435e97b4b067d2c6b629d8300a2400a2&oauth_timestamp=1753433334&oauth_consumer_key=moodle.univ-tlse3.fr&user_id=2&lis_person_sourcedid=&roles=Learner&context_id=2&context_label=Pfi&context_title=Pfitaxel&resource_link_title=Pfi&resource_link_description=&resource_link_id=1&context_type=CourseSection&lis_course_section_sourcedid=&lis_result_sourcedid=%7B%22data%22%3A%7B%22instanceid%22%3A%221%22%2C%22userid%22%3A%222%22%2C%22typeid%22%3Anull%2C%22launchid%22%3A1397134956%7D%2C%22hash%22%3A%2213aeb6940f7f79b55c9ff49c1690352ea478abd188cd1a44ec51a1e916034dd4%22%7D&lis_outcome_service_url=http%3A%2F%2Flocalhost%3A9090%2Fmod%2Flti%2Fservice.php&lis_person_name_given=Admin&lis_person_name_family=User&lis_person_name_full=Admin+User&ext_user_username=user&lis_person_contact_email_primary=user%40example.com&launch_presentation_locale=en&ext_lms=moodle-2&tool_consumer_info_product_family_code=moodle&tool_consumer_info_version=2021051707&oauth_callback=about%3Ablank<i_version=LTI-1p0<i_message_type=basic-lti-launch-request&tool_consumer_instance_guid=localhost&tool_consumer_instance_name=New+Site&tool_consumer_instance_description=New+Site&launch_presentation_document_target=iframe&launch_presentation_return_url=http%3A%2F%2Flocalhost%3A9090%2Fmod%2Flti%2Freturn.php%3Fcourse%3D2%26launch_container%3D2%26instanceid%3D1%26sesskey%3DzWWyXZqOnc&oauth_signature_method=HMAC-SHA1&oauth_signature=vtyWSL1j2qBCGdzti7AP%2BaqH2WU%3D" +let instructor_payload = + "oauth_version=1.0&oauth_nonce=8f0c975b428f3a6683947a5348aaabad&oauth_timestamp=1753432816&oauth_consumer_key=moodle.univ-tlse3.fr&user_id=2&lis_person_sourcedid=&roles=Instructor%2Curn%3Alti%3Asysrole%3Aims%2Flis%2FAdministrator%2Curn%3Alti%3Ainstrole%3Aims%2Flis%2FAdministrator&context_id=2&context_label=Pfi&context_title=Pfitaxel&resource_link_title=Pfi&resource_link_description=&resource_link_id=1&context_type=CourseSection&lis_course_section_sourcedid=&lis_result_sourcedid=%7B%22data%22%3A%7B%22instanceid%22%3A%221%22%2C%22userid%22%3A%222%22%2C%22typeid%22%3Anull%2C%22launchid%22%3A739795865%7D%2C%22hash%22%3A%226917e44d8a3e77beec8cd7f1e3df1e0c174cdb1a7b61af2728a309f7cf5b661c%22%7D&lis_outcome_service_url=http%3A%2F%2Flocalhost%3A9090%2Fmod%2Flti%2Fservice.php&lis_person_name_given=Admin&lis_person_name_family=User&lis_person_name_full=Admin+User&ext_user_username=user&lis_person_contact_email_primary=user%40example.com&launch_presentation_locale=en&ext_lms=moodle-2&tool_consumer_info_product_family_code=moodle&tool_consumer_info_version=2021051707&oauth_callback=about%3Ablank<i_version=LTI-1p0<i_message_type=basic-lti-launch-request&tool_consumer_instance_guid=localhost&tool_consumer_instance_name=New+Site&tool_consumer_instance_description=New+Site&launch_presentation_document_target=iframe&launch_presentation_return_url=http%3A%2F%2Flocalhost%3A9090%2Fmod%2Flti%2Freturn.php%3Fcourse%3D2%26launch_container%3D2%26instanceid%3D1%26sesskey%3DzWWyXZqOnc&oauth_signature_method=HMAC-SHA1&oauth_signature=ZXYi%2BJOi4CgdkJoao7gdjzP%2FpZE%3D" +let false_payload = + "oauth_version=1.0&oauth_nonce=8f0c975b428f3a7683947a5348aaabad&oauth_timestamp=1&oauth_consumer_key=moodle.univ-tlse3.fr&user_id=2&lis_person_sourcedid=&roles=Instructor%2Curn%3Alti%3Asysrole%3Aims%2Flis%2FAdministrator%2Curn%3Alti%3Ainstrole%3Aims%2Flis%2FAdministrator&context_id=2&context_label=Pfi&context_title=Pfitaxel&resource_link_title=Pfi&resource_link_description=&resource_link_id=1&context_type=CourseSection&lis_course_section_sourcedid=&lis_result_sourcedid=%7B%22data%22%3A%7B%22instanceid%22%3A%221%22%2C%22userid%22%3A%222%22%2C%22typeid%22%3Anull%2C%22launchid%22%3A739795865%7D%2C%22hash%22%3A%226917e44d8a3e77beec8cd7f1e3df1e0c174cdb1a7b61af2728a309f7cf5b661c%22%7D&lis_outcome_service_url=http%3A%2F%2Flocalhost%3A9090%2Fmod%2Flti%2Fservice.php&lis_person_name_given=Admin&lis_person_name_family=User&lis_person_name_full=Admin+User&ext_user_username=user&lis_person_contact_email_primary=user%40example.com&launch_presentation_locale=en&ext_lms=moodle-2&tool_consumer_info_product_family_code=moodle&tool_consumer_info_version=2021051707&oauth_callback=about%3Ablank<i_version=LTI-1p0<i_message_type=basic-lti-launch-request&tool_consumer_instance_guid=localhost&tool_consumer_instance_name=New+Site&tool_consumer_instance_description=New+Site&launch_presentation_document_target=iframe&launch_presentation_return_url=http%3A%2F%2Flocalhost%3A9090%2Fmod%2Flti%2Freturn.php%3Fcourse%3D2%26launch_container%3D2%26instanceid%3D1%26sesskey%3DzWWyXZqOnc&oauth_signature_method=HMAC-SHA1&oauth_signature=ZXYi%2BJOi4CgdkJoao7gdjzP%2FpZE%3D" + +let launch_url = "http://localhost:8080/launch" +let consumer_key = "moodle.univ-tlse3.fr" +let shared_secret = "5e06d2c671b7aaf26678bb52dd085f128cda772357ab11c5f5f12b87b0ef6f0b" + +(* Unit test: verifies that the OAuth signature is valid for an Instructor *) +let%expect_test "LTI: instructor signature is valid" = + let params = parse_body instructor_payload in + Lwt_main.run ( + check_oauth launch_url params shared_secret >>= function + | Ok id -> + Printf.printf "LTI accepted: %s\n" id; + Lwt.return_unit + | Error msg -> + Printf.printf "LTI rejected: %s\n" msg; + Lwt.return_unit + ); + [%expect {| LTI accepted: moodle.univ-tlse3.fr/2 |}] + +(* Unit test: verifies that the OAuth signature is valid for a Learner *) +let%expect_test "LTI: learner signature is valid" = + let params = parse_body learner_payload in + Lwt_main.run ( + check_oauth launch_url params shared_secret >>= function + | Ok id -> + Printf.printf "LTI accepted: %s\n" id; + Lwt.return_unit + | Error msg -> + Printf.printf "LTI rejected: %s\n" msg; + Lwt.return_unit + ); + [%expect {| LTI accepted: moodle.univ-tlse3.fr/2 |}] + +(* Unit test: verifies that an invalid OAuth signature is correctly rejected *) +let%expect_test "LTI: invalid signature is rejected" = + let params = parse_body false_payload in + Lwt_main.run ( + check_oauth launch_url params shared_secret >>= function + | Ok id -> + Printf.printf "LTI accepted (should have failed!): %s\n" id; + Lwt.return_unit + | Error msg -> + Printf.printf "LTI rejected: %s\n" msg; + Lwt.return_unit + ); + [%expect {| + LTI rejected: Wrong signature + |}] diff --git a/src/server/learnocaml_server.ml b/src/server/learnocaml_server.ml index 364b5088a..5bad171f2 100644 --- a/src/server/learnocaml_server.ml +++ b/src/server/learnocaml_server.ml @@ -8,6 +8,7 @@ open Learnocaml_data open Learnocaml_store +open Learnocaml_auth let port = ref 8080 @@ -22,8 +23,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 '/', \ @@ -33,6 +33,8 @@ let args = Arg.align @@ open Lwt.Infix +type kind = Exercise of string*bool | Lesson of string*bool | Playground of string*bool | Toplevel + let read_static_file path = Lwt_io.(with_file ~mode: Input (sanitise_path !static_dir path) read) @@ -76,12 +78,17 @@ type cached_response = { deflated_body: string option; content_type: string; caching: caching; + cookies: Cohttp.Cookie.Set_cookie_hdr.t list } type 'a response = | Response of { contents: 'a; content_type: string; - caching: caching } + caching: caching; + cookies: Cohttp.Cookie.Set_cookie_hdr.t list } + | Redirect of { code: Cohttp.Code.status_code; + url: string; + cookies: Cohttp.Cookie.Set_cookie_hdr.t list } | Cached of cached_response type error = (Cohttp.Code.status_code * string) @@ -123,21 +130,22 @@ let lwt_option_fail x e f = | Some x -> f x | None -> lwt_fail e -let respond_static caching path = +let respond_static ?(cookies=[]) caching path = lwt_catch_fail (fun () -> read_static_file path >>= fun contents -> let content_type = Magic_mime.lookup (List.fold_left (fun _ r -> r) "" path) in - lwt_ok @@ Response { contents; content_type; caching }) + lwt_ok @@ Response { contents; content_type; caching; cookies }) (fun e -> (`Not_found, Printexc.to_string e)) -let respond_json caching contents = +let respond_json ?(cookies=[]) caching contents = lwt_ok @@ Response { contents; content_type = "application/json"; - caching } + caching; + cookies} let verify_teacher_token token = Token.check_teacher token >>= function @@ -183,6 +191,12 @@ let check_report exo report grade = let score, _ = Learnocaml_report.result report in score * 100 / max_grade = grade +let generate_csrf_token length = + let random_bytes = Bytes.make length '\000' in + Cryptokit.Random.secure_rng#random_bytes random_bytes 0 length; + Base64.encode (Bytes.to_string random_bytes) + + module Memory_cache = struct let (tbl: (cache_request_hash, cached_response) Hashtbl.t) = @@ -203,6 +217,7 @@ module Request_handler = struct let map_ret f r = r >?= function | Response ({contents; _} as r) -> lwt_ok @@ Response {r with contents = f contents} + | (Redirect _) as r -> lwt_ok r | (Cached _) as r -> lwt_ok r let alphanum = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" @@ -232,11 +247,16 @@ 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 -> + caching -> Api.http_request -> resp Api.request -> (resp response, error) result Lwt.t = let module ServerData = Learnocaml_data.Server in - fun conn config cache -> function + fun conn config cache req -> function | Api.Version () -> respond_json cache (Api.version, config.ServerData.server_id) | Api.Static path -> @@ -288,6 +308,243 @@ 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.Launch body when config.ServerData.use_lti -> + (* 32 bytes of entropy, same as RoR as of 2020. *) + let csrf_token = match generate_csrf_token 32 with + | Ok tok -> tok + | Error (`Msg msg) -> failwith msg in + let cookies = [Cohttp.Cookie.Set_cookie_hdr.make + ~expiration:(`Max_age (Int64.of_int 3600)) + ~path:"/" ~http_only:true + ("csrf", csrf_token)] in + let params = Uri.query_of_encoded body + |> List.map (fun (a, b) -> a, String.concat "," b) in + let launch_url = + if req.Api.host = "" then + "http://localhost:8080/launch" + else + req.Api.host ^ "/launch" + in + NonceIndex.get_current_secret () >>= fun secret -> + LtiAuth.check_oauth launch_url params secret >>= + (function + | Ok id -> + LtiAuth.get_token id >>= (function + |Ok token -> + let session = Session.gen_session () in + Session.set_session session token >>= fun () -> + let cookies = [Cohttp.Cookie.Set_cookie_hdr.make + ~expiration:(`Max_age (Int64.of_int 60)) + ~path:"/" + ("session", Session.to_string session)] in + let rank = function Exercise (_,_) -> 0 | Lesson (_,_) -> 1 | Playground (_,_) -> 2 | Toplevel -> 3 in + let sort_from_rank l = List.sort (fun (k1) (k2) -> rank k1 - rank k2) l in + (*sort_from_rank [(Lesson, "first"); (Exercise, "demo"); (Playground, "editor")]*) + let ex_exist exo = Exercise.Index.get () >>= fun exercises -> + let find_exercises_names contents = match contents with + | Learnocaml_data.Exercise.Index.Groups _ -> failwith "erreur find_exercises_names" + | Learnocaml_data.Exercise.Index.Exercises exos -> List.map fst exos in + let find_names exs = List.map + (fun group -> find_exercises_names (snd group).Learnocaml_data.Exercise.Index.contents) + exs in + let names = match exercises with + | Learnocaml_data.Exercise.Index.Groups exs -> List.concat (find_names exs) + | Learnocaml_data.Exercise.Index.Exercises _ -> [] in + Lwt.return (List.exists (fun name -> name = exo) names) in + let play_exist play = Playground.Index.get () >>= fun playgrounds -> + let find_names exs = List.map + (fun group -> (fst group)) + exs in + let names = find_names playgrounds in + Lwt.return (List.exists (fun name -> name = play) names) in + let less_exist less = Lesson.Index.get () >>= fun lessons -> + let find_names exs = List.map + (fun group -> (fst group)) + exs in + let names = find_names lessons in + Lwt.return (List.exists (fun name -> name = less) names) in + let list_redirections l = + Lwt_list.fold_left_s (fun r (kind, id) -> + match kind with + | "custom_exercise" -> ex_exist id >|= fun ok -> + Exercise (id,ok) :: r + | "custom_playground" -> play_exist id >|= fun ok -> + Playground (id, ok) :: r + | "custom_lesson" -> less_exist id >|= fun ok -> + Lesson (id, ok) :: r + | "custom_toplevel" -> Lwt.return (Toplevel :: r) + | _ -> Lwt.return r + ) [] l + in + let return_url kind_url = match kind_url with + | Exercise (id,ok) -> if ok + then "/exercises/"^id^"/#tab%3Dtext" + else "/redirection?kind=exercise&id="^id + | Playground (id,ok) -> if ok + then "/playground/"^id^"/#tab%3Dtoplevel" + else "/redirection?kind=playground&id="^id + | Lesson (id,ok) -> if ok + then "/#activity%3Dlessons%26lesson%3D"^id + else "/redirection?kind=lesson&id="^id + | Toplevel -> "/#activity%3Dtoplevel" + in + let return_url_many kind_url = match kind_url with + | Exercise (id,ok) -> if ok + then "/redirection?kind=exercise&id="^id^"&many=true" + else "/redirection?kind=exercise&id="^id + | Playground (id,ok) -> if ok + then "/redirection?kind=playground&id="^id^"&many=true" + else "/redirection?kind=playground&id="^id + | Lesson (id,ok) -> if ok + then "/redirection?kind=lesson&id="^id^"&many=true" + else "/redirection?kind=lesson&id="^id + | _ -> "/" in + let redirection l = match sort_from_rank l with + [] -> "/" + | [url] -> return_url url + | url :: _ -> return_url_many url in + list_redirections params >>= fun list -> + lwt_ok @@ Redirect { code=`See_other; url= !base_url^(redirection list); cookies } + |Error _ -> + NonceIndex.get_current_secret () >>= fun secret -> + let hmac = generate_hmac secret csrf_token id in + read_static_file ["lti.html"] >>= fun s -> + let contents = + Markup.string s + |> Markup.parse_html + |> Markup.signals + |> Markup.map (function + | `Start_element ((e, "input"), attrs) as elt -> + (match List.assoc_opt ("", "type") attrs, + List.assoc_opt ("", "name") attrs with + | Some "hidden", Some "csrf" -> + `Start_element ((e, "input"), (("", "value"), csrf_token) :: attrs) + | Some "hidden", Some "user-id" -> + `Start_element ((e, "input"), (("", "value"), id) :: attrs) + | Some "hidden", Some "hmac" -> + `Start_element ((e, "input"), (("", "value"), hmac) :: attrs) + | _ -> elt) + | t -> t) + |> Markup.pretty_print + |> Markup.write_html + |> Markup.to_string in + lwt_ok @@ Response { contents; content_type="text/html"; caching=Nocache; cookies }) + | Error e -> lwt_fail (`Forbidden, e)) + | Api.Launch _ -> + lwt_fail (`Forbidden, "LTI is disabled on this instance.") + | Api.Associate body -> + let params = Uri.query_of_encoded body + |> List.map (fun (k, vs) -> (k, String.concat "," vs)) in + let target_method = List.assoc "target_method" params in + let source_method = List.assoc "source_method" params in + + if target_method = source_method then + lwt_fail (`Bad_request, "Cannot associate a method to itself") + else (match source_method with + |"token"-> + let token = List.assoc "token" params in + Lwt.return (Ok (Token.parse token)) + |"email" -> + Lwt.return (Error "Not implemented yet") + | _ -> Lwt.return (Error "Unknow method")) + >>= (function + | Error msg -> lwt_fail (`Forbidden, msg) + | Ok token -> + let lwt_result = + (match target_method with + | "lti" when config.ServerData.use_lti -> + let csrf = List.assoc "csrf" params and + hmac = List.assoc "hmac" params and + user_id = List.assoc "user-id" params in + let creds = { LtiAuth.user_id; LtiAuth.token; LtiAuth.csrf; LtiAuth.hmac } in + LtiAuth.associate creds >>= (function + | Ok t -> Lwt.return (Ok (t, "lti", user_id)) + | Error e -> Lwt.return (Error e)) + | "lti" -> + Lwt.return (Error "LTI is disabled on this instance") + |"email" -> + Lwt.return (Error "Not implemented yet") + | _ -> + Lwt.return (Error "Unknown target_method")) + in + lwt_result >>= (function + | Error msg -> + lwt_fail (`Forbidden, msg) + | Ok (token, method_, value) -> + TokenIndex.add_association ~token ~method_ ~value >>= fun () -> + let session = Session.gen_session () in + Session.set_session session token >>= fun () -> + let make_cookie = Cohttp.Cookie.Set_cookie_hdr.make + ~expiration:(`Max_age (Int64.of_int 60)) ~path:"/" in + let cookies = [make_cookie ("session", Session.to_string session); + make_cookie ~http_only:true ("csrf", "expired")] in + lwt_ok @@ Redirect { code=`See_other; url="/"; cookies })) + | Api.Login body -> + let params = Uri.query_of_encoded body + |> List.map (fun (k, vs) -> (k, String.concat "," vs)) in + begin match List.assoc_opt "method" params with + | Some "token" -> + begin match List.assoc_opt "token" params with + | Some t -> + let token = Token.parse t in + Token.exists token >>= fun exists -> + if exists then ( + let session = Session.gen_session () in + Session.set_session session token >>= fun () -> + respond_json cache session + ) else + lwt_fail (`Forbidden, "Invalid token") + | None -> + lwt_fail (`Bad_request, "Missing 'token' parameter") + end + | Some "email" -> + lwt_fail (`Forbidden, "Not implemented yet") + | Some m -> lwt_fail (`Bad_request, "Unknown login method: " ^ m) + | None -> lwt_fail (`Bad_request, "Missing 'method' parameter") + end + | Api.Register body -> + let params = Uri.query_of_encoded body + |> List.map (fun (k, vs) -> (k, String.concat "," vs)) in + let token = + (match List.assoc_opt "method" params with + | Some "lti" -> + let user_id = List.assoc "user-id" params and + csrf = List.assoc "csrf" params and + hmac = List.assoc "hmac" params and + nickname = List.assoc "nick" params in + let creds = { LtiAuth.user_id; LtiAuth.nickname; LtiAuth.csrf; LtiAuth.hmac } in + LtiAuth.register creds >>= + (function + | Ok t -> Lwt.return (Ok (t,"lti",user_id)) + | Error e -> Lwt.return (Error e)) + | Some "email" -> + Lwt.return (Error "Not implemented yet") + | Some m -> + Lwt.return (Error ("Unknown login method: " ^ m)) + |None -> Lwt.return (Error "Missing 'method' parameter")) + in + token >>= (function + | Ok (token, method_, value) -> + TokenIndex.add_association ~token ~method_ ~value >>= fun () -> + let session = Session.gen_session () in + Session.set_session session token >>= fun () -> + let make_cookie = Cohttp.Cookie.Set_cookie_hdr.make + ~expiration:(`Max_age (Int64.of_int 60)) ~path:"/" in + let cookies = [make_cookie ("session", Session.to_string session); + make_cookie ~http_only:true ("csrf", "expired")] in + lwt_ok @@ Redirect { code=`See_other; url="/"; cookies } + | Error msg -> + lwt_fail (`Forbidden, msg)) | Api.Fetch_save token -> lwt_catch_fail (fun () -> @@ -297,6 +554,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 @@ -305,7 +575,19 @@ module Request_handler = struct Lwt_process.pread ~stdin:stdout cmd >>= fun contents -> lwt_ok @@ Response { contents = contents; content_type = "application/zip"; - caching = Nocache } + caching = Nocache; + cookies = [] } + | 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; + cookies = [] } | 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 +614,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 @@ -344,13 +653,19 @@ module Request_handler = struct lwt_ok @@ Response { contents; content_type = "application/octet-stream"; - caching = Nocache }) + caching = Nocache; + cookies = [] }) (fun e -> (`Not_found, Printexc.to_string e)) | Api.Students_list token -> 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 +680,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 @@ -431,7 +761,77 @@ module Request_handler = struct lwt_ok @@ Response {contents = Buffer.contents buf; content_type = "text/csv"; - caching = Nocache} + caching = Nocache; + cookies = [] } + | 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; + cookies = [] } | Api.Exercise_index (Some token) -> Exercise.Index.get () >>= fun index -> @@ -449,8 +849,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 +882,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 +917,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 +936,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,18 +954,28 @@ 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) let callback: type resp. Conduit.endp -> Learnocaml_data.Server.config -> + Api.http_request -> resp Api.request -> resp ret - = fun conn config req -> + = fun conn config http_req req -> let cache = caching req in let respond () = Lwt.catch - (fun () -> callback_raw conn config cache req) + (fun () -> callback_raw conn config cache http_req req) (function | Not_found -> lwt_fail (`Not_found, "Component not found") @@ -530,7 +990,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,39 +1020,50 @@ 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 () ; + NonceIndex.get_first_oauth () >>= fun (secret, _) -> + Lwt_io.printf "LTI shared secret: %s\n" secret + >>= fun () -> Learnocaml_store.Server.get () >>= fun config -> let callback conn req body = let uri = Request.uri req in @@ -616,8 +1087,8 @@ let launch () = (Cohttp.Header.get_acceptable_encodings req.Request.headers) in let respond = function - | Response {contents=body; content_type; caching; _} - | Cached {body; content_type; caching; _} as resp -> + | Response {contents=body; content_type; caching; cookies; _} + | Cached {body; content_type; caching; cookies; _} as resp -> let headers = Cohttp.Header.init_with "Content-Type" content_type in let headers = match caching with | Longcache _ -> @@ -632,10 +1103,12 @@ let launch () = | Nocache -> Cohttp.Header.add headers "Cache-Control" "no-cache" in + let cookies_hdr = List.rev_map Cohttp.Cookie.Set_cookie_hdr.serialize cookies in + let headers = Cohttp.Header.add_list headers cookies_hdr in let resp = match resp, caching with | Response _, (Longcache key | Shortcache (Some key)) -> let cached = - {body; deflated_body = None; content_type; caching} + {body; deflated_body = None; content_type; caching; cookies = []} in Memory_cache.add key cached; Cached cached @@ -667,19 +1140,38 @@ let launch () = (fun e -> Server.respond_error ~status:`Internal_server_error ~body:(Printexc.to_string e) ()) + | Redirect { code; url; cookies } -> + let headers = Cohttp.Header.init_with "Location" url in + let cookies_hdr = List.rev_map Cohttp.Cookie.Set_cookie_hdr.serialize cookies in + let headers = Cohttp.Header.add_list headers cookies_hdr in + Server.respond_string ~headers ~status:code ~body:"" () in if Cohttp.Header.get req.Request.headers "If-Modified-Since" = Some last_modified then Server.respond ~status:`Not_modified ~body:Cohttp_lwt.Body.empty () else (match req.Request.meth with - | `GET -> lwt_ok {Api.meth = `GET; path; args} + | `GET -> lwt_ok {Api.meth = `GET; host = !base_url; path; args} | `POST -> begin - string_of_stream (Cohttp_lwt.Body.to_stream body) - >>= function - | Some s -> lwt_ok {Api.meth = `POST s; path; args} - | None -> lwt_fail (`Bad_request, "Missing POST body") + Cohttp_lwt.Body.to_string body + >>= fun params -> + let param_list = Uri.query_of_encoded params in + if param_list = [] then + lwt_fail (`Bad_request, "Missing POST body") + else + let cookies = Cohttp.Cookie.Cookie_hdr.extract req.Request.headers in + match List.assoc_opt "csrf" param_list, + List.assoc_opt "csrf" cookies with + | Some (param_csrf :: _), Some cookie_csrf -> + if Eqaf.equal param_csrf cookie_csrf then + lwt_ok {Api.meth = `POST params; host = !base_url; path; args} + else + lwt_fail (`Forbidden, "CSRF token mismatch") + | None, None | None, Some _ -> + lwt_ok {Api.meth = `POST params; host = !base_url; path; args} + | _, _ -> + lwt_fail (`Forbidden, "Bad CSRF token") end | _ -> lwt_fail (`Bad_request, "Unsupported method")) >?= (fun req -> 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..a3892f659 100644 --- a/src/state/learnocaml_api.ml +++ b/src/state/learnocaml_api.ml @@ -102,26 +102,55 @@ 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 + | Launch : + string -> string request + | Associate : + string -> string request + | Login: + string -> string request + | Register : + string -> string 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 +169,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 +195,44 @@ 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")) + | Launch _ -> Compat.(Since (v "2.0")) + | Associate _ -> Compat.(Since (v "2.0")) + | Login _ -> Compat.(Since (v "2.0")) + | Register _ -> 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 @@ -196,6 +251,7 @@ let is_supported type http_request = { meth: [ `GET | `POST of string]; + host: string; path: string list; args: (string * string) list; } @@ -207,6 +263,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 +301,50 @@ 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) + | Launch _ -> str + | Associate _ -> str + | Login _ -> str + | Register _ -> str + | 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 +360,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 +386,19 @@ 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; + host = ""; 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; + host = ""; 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 +415,48 @@ 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])) + | Launch body -> + post ["lauch"] body + | Associate body -> + post ["associate"] body + | Login body -> + post ["login"] body + | Register body -> + post ["register"] body | 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 +465,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 +515,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) @@ -386,7 +553,7 @@ module type REQUEST_HANDLER = sig val map_ret: ('a -> 'b) -> 'a ret -> 'b ret val callback: Conduit.endp -> - Learnocaml_data.Server.config -> 'resp request -> 'resp ret + Learnocaml_data.Server.config -> http_request -> 'resp request -> 'resp ret end module Server (Json: JSON_CODEC) (Rh: REQUEST_HANDLER) = struct @@ -398,7 +565,7 @@ module Server (Json: JSON_CODEC) (Rh: REQUEST_HANDLER) = struct let handler conn config request = let k req = - Rh.callback conn config req |> Rh.map_ret (C.response_encode req) + Rh.callback conn config request req |> Rh.map_ret (C.response_encode req) in let token = match List.assoc_opt "token" request.args with @@ -407,47 +574,82 @@ 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 + | `POST body, ["launch"], _token, _ -> + Launch body |> k + | `POST body, ["associate"], _, _ -> + Associate body |> k + | `POST body, ["login"], _, _ -> + Login body |> k + | `POST body, ["register"], _, _ -> + Register body |> 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 +660,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 +688,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 +716,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 +756,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 +773,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..025eec180 100644 --- a/src/state/learnocaml_api.mli +++ b/src/state/learnocaml_api.mli @@ -88,29 +88,58 @@ 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 + | Launch : + string -> string request + | Associate : + string -> string request + | Login: + string -> string request + | Register : + string -> string 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 +158,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 @@ -155,6 +193,7 @@ val is_supported: type http_request = { meth: [ `GET | `POST of string]; + host: string; path: string list; args: (string * string) list; } @@ -164,13 +203,15 @@ 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 val map_ret: ('a -> 'b) -> 'a ret -> 'b ret - val callback: Conduit.endp -> - Learnocaml_data.Server.config -> 'resp request -> 'resp ret + val callback: Conduit.endp -> Learnocaml_data.Server.config -> http_request -> 'resp request -> 'resp ret end module Server: functor (_: JSON_CODEC) (Rh: REQUEST_HANDLER) -> sig diff --git a/src/state/learnocaml_data.ml b/src/state/learnocaml_data.ml index 211ee9928..8c8100150 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 @@ -376,18 +399,29 @@ let enc_check_version_2 enc = module Server = struct type preconfig = { secret : string option; + use_lti : bool; } let empty_preconfig = { secret = None; + use_lti = false; } + let bool_of_option = function + | Some b -> b + | None -> false + let preconfig_enc = - J.conv (fun (c : preconfig) -> c.secret) - (fun secret : preconfig -> {secret}) @@ - J.obj1 (J.opt "secret" J.string) + J.conv (fun (c : preconfig) -> + (c.secret, Some(c.use_lti))) + (fun (secret, use_lti) -> + {secret; + use_lti = bool_of_option use_lti}) @@ + J.obj2 (J.opt "secret" J.string) + (J.opt "use_lti" J.bool) type config = { secret : string option; + use_lti : bool; server_id : int; } @@ -398,13 +432,20 @@ module Server = struct let server_id = Random.bits () in { secret; + use_lti = preconf.use_lti; server_id; } let config_enc = - J.conv (fun (c : config) -> (c.secret,c.server_id)) - (fun (secret,server_id) : config -> {secret; server_id}) @@ - J.obj2 (J.opt "secret" J.string) (J.req "server_id" J.int) + J.conv (fun (c : config) -> + (c.secret, Some(c.use_lti), c.server_id)) + (fun (secret, use_lti, server_id) -> + {secret; + use_lti = bool_of_option use_lti; + server_id}) @@ + J.obj3 (J.opt "secret" J.string) + (J.opt "use_lti" J.bool) + (J.req "server_id" J.int) end module Exercise = struct diff --git a/src/state/learnocaml_data.mli b/src/state/learnocaml_data.mli index 2af6ed0a3..d575fe18f 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 @@ -128,6 +140,7 @@ module Server : sig where users can pre-set some of the server settings. *) type preconfig = { secret : string option; + use_lti : bool; } val empty_preconfig : preconfig @@ -135,6 +148,7 @@ module Server : sig from the preconfig during the 'build' stage. *) type config = { secret : string option; (* maybe a secret *) + use_lti : bool; server_id : int; (* random integer generated each building time *) } diff --git a/src/state/learnocaml_store.ml b/src/state/learnocaml_store.ml index 04bd5d51e..df17b021e 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 = @@ -558,3 +596,162 @@ module Student = struct with module Index := Student.Index) end + +module LtiIndex = struct + 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 "./.secret/lti.git" + let config () = Irmin_git.config ~bare:true !repo_path + + let enc = + let open Json_encoding in + conv + (fun token -> token) + (fun token -> token) + Token.enc + + let add id token = + let* repo = Store.Repo.v (config ()) in + let* t = Store.main repo in + Store.set_exn t ~info:(Info.v "Add LTI ID → Token") [id] + (Json_encoding.construct enc token) + + let get_user_token id = + let* repo = Store.Repo.v (config ()) in + let* t = Store.main repo in + let+ res = Store.find t [id] in + Option.map (Json_encoding.destruct enc) res + + let exists id = + let* repo = Store.Repo.v (config ()) in + let* t = Store.main repo in + Store.mem t [id] + +end + +module TokenIndex = struct + 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 "./.secret/token.git" + let config () = Irmin_git.config ~bare:true !repo_path + + type methods = { + idmoodle : string option; + email : string option; + } + + let enc_methods = + let open Json_encoding in + conv + (fun { idmoodle; email } -> (idmoodle, email)) + (fun (idmoodle, email) -> { idmoodle; email }) + (tup2 (option string) (option string)) + + let add_association ~token ~method_ ~value = + let* repo = Store.Repo.v (config ()) in + let* t = Store.main repo in + let key = [Token.to_string token] in + let* existing = Store.find t key in + let methods = + match existing with + | Some json -> + let current = Json_encoding.destruct enc_methods json in + begin match method_ with + | "idmoodle" -> { current with idmoodle = Some value } + | "email" -> { current with email = Some value } + | _ -> current + end + | None -> + match method_ with + | "idmoodle" -> { idmoodle = Some value; email = None} + | "email" -> { idmoodle = None; email = Some value} + | _ -> { idmoodle = None; email = None } + in + Store.set_exn t ~info:(Info.v "Add Token → Methods") key + (Json_encoding.construct enc_methods methods) + + let get_methods token = + let* repo = Store.Repo.v (config ()) in + let* t = Store.main repo in + let+ res = Store.find t [Token.to_string token] in + Option.map (Json_encoding.destruct enc_methods) res + + let has token method_ = + let* res = get_methods token in + match res with + | None -> Lwt.return false + | Some m -> + let b = match method_ with + | "lti" -> Option.is_some m.idmoodle + | "email" -> Option.is_some m.email + | _ -> false + in + Lwt.return b + + let exists token = + let* repo = Store.Repo.v (config ()) in + let* t = Store.main repo in + Store.mem t [Token.to_string token] +end + +module BaseNonceIndex = struct + let file = "oauth.json" + + let generate_random_hex len = + Cryptokit.Random.string Cryptokit.Random.secure_rng len + |> Cryptokit.transform_string @@ Cryptokit.Hexa.encode () + + let enc = Json_encoding.(list (tup2 string (list string))) + + let file_path () = + Filename.concat !sync_dir file + + let parse = Learnocaml_api.Json_codec.decode enc + let serialise = Learnocaml_api.Json_codec.encode ~minify:false enc + + let create_index () = + let secret = generate_random_hex 32 in + let value = [(secret, [])] in + write_to_file enc value (file_path ()) >|= fun () -> + secret + + let get_first_oauth () = + let create () = + create_index () >|= fun secret -> (secret, []) + in + Lwt.catch + (fun () -> + get_from_file enc (file_path ()) >>= function + | (secret, nonces) :: _ -> Lwt.return (secret, nonces) + | [] -> create () + ) + (fun _exn -> create ()) + + let get_current_secret () = + get_first_oauth () >|= fun (secret, _nonces) -> secret + + let purge () = + get_first_oauth () >>= fun oauth -> + write_to_file enc [oauth] (file_path ()) + + let add_nonce nonce = + get_from_file enc (file_path ()) >>= fun oauth -> + let oauth = + match oauth with + | (secret, nonces) :: r -> (secret, nonce :: nonces) :: r + | [] -> [(generate_random_hex 32, [nonce])] + in + write_to_file enc oauth (file_path ()) + + let check_nonce nonce = + get_first_oauth () >|= fun (_secret, nonces) -> + List.exists ((=) nonce) nonces +end + +module NonceIndex = BaseNonceIndex \ No newline at end of file diff --git a/src/state/learnocaml_store.mli b/src/state/learnocaml_store.mli index e0d1356e5..462bf918a 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 @@ -180,3 +202,53 @@ module Student: sig val set: t -> unit Lwt.t end + +module LtiIndex: sig + + val repo_path: string ref + + (** Adds a new LTI entry to the store. *) + val add : string -> Token.t -> unit Lwt.t + + (** Retrieves the token associated with the given user ID. *) + val get_user_token : string -> Token.t option Lwt.t + + (** Checks if the user ID exists in the LTI index. *) + val exists : string -> bool Lwt.t + +end + +module TokenIndex : sig + + type methods = { + idmoodle : string option; + email : string option; + } + + (** Associate a token with an external authentication method and value (e.g. "idmoodle", "email"). *) + val add_association : token:Token.t -> method_:string -> value:string -> unit Lwt.t + + (** Retrieve all associated external methods for a given token. *) + val get_methods : Token.t -> methods option Lwt.t + + (** Check if a token is associated with a specific method (e.g. "idmoodle", "email"). *) + val has : Token.t -> string -> bool Lwt.t + + (** Check if a token exists in the TokenIndex (i.e. has any association). *) + val exists : Token.t -> bool Lwt.t + +end + +module NonceIndex: sig + val create_index : unit -> string Lwt.t + + val get_first_oauth : unit -> (string * string list) Lwt.t + val get_current_secret : unit -> string Lwt.t + + (** Delete all secrets + nonce associated excepted the current secret with its nonces *) + val purge : unit -> unit Lwt.t + + val add_nonce : string -> unit Lwt.t + val check_nonce : string -> bool Lwt.t + +end \ No newline at end of file diff --git a/static/lti.html b/static/lti.html new file mode 100644 index 000000000..1e55a83a5 --- /dev/null +++ b/static/lti.html @@ -0,0 +1,61 @@ + + + + + + + Learn OCaml + + + + + + + + + +
+
+
+

+
+
+
+ +
+ + + + + +
+
+
+
+

+
+
+
+ +
+ + + + + + +
+ +
+
+
+ + + \ No newline at end of file