From cbad40db59bfb75547b7a0250602d7fbae141c42 Mon Sep 17 00:00:00 2001 From: Nassim Mourabit Date: Mon, 31 Mar 2025 10:31:13 +0200 Subject: [PATCH 01/29] feat(session): implement session type, generation, encoding and storage --- src/state/learnocaml_data.ml | 17 ++++++++++++ src/state/learnocaml_data.mli | 10 +++++++ src/state/learnocaml_store.ml | 51 ++++++++++++++++++++++++++++++++++ src/state/learnocaml_store.mli | 27 ++++++++++++++++++ 4 files changed, 105 insertions(+) diff --git a/src/state/learnocaml_data.ml b/src/state/learnocaml_data.ml index 211ee9928..abb5d1975 100644 --- a/src/state/learnocaml_data.ml +++ b/src/state/learnocaml_data.ml @@ -188,6 +188,23 @@ module Save = struct end +module Session = struct + type t = string + + (** TODO generate robust token with cryptokit?*) + let generate () : t = + let length = 32 in + let alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" in + let alphabet_len = String.length alphabet in + String.init length (fun _ -> alphabet.[Random.int alphabet_len]) + + (** TODO parsing with the corect format*) + let parse session = session + + let enc = J.conv (fun s -> s) parse J.string +end +type 'a session = Session.t + module Token = struct type t = string list diff --git a/src/state/learnocaml_data.mli b/src/state/learnocaml_data.mli index 2af6ed0a3..d8e8bcee8 100644 --- a/src/state/learnocaml_data.mli +++ b/src/state/learnocaml_data.mli @@ -70,6 +70,16 @@ module Save: sig end +module Session : sig + type t = string + + val generate : unit -> t + + val enc : t Json_encoding.encoding +end + +type 'a session = Session.t + module Token: sig type t diff --git a/src/state/learnocaml_store.ml b/src/state/learnocaml_store.ml index 04bd5d51e..a7425e9ab 100644 --- a/src/state/learnocaml_store.ml +++ b/src/state/learnocaml_store.ml @@ -15,6 +15,8 @@ let static_dir = ref (Filename.concat (Sys.getcwd ()) "www") let sync_dir = ref (Filename.concat (Sys.getcwd ()) "sync") +let data_dir = ref (Filename.concat !sync_dir "data") + module Json_codec = struct let decode enc s = (match s with @@ -297,6 +299,55 @@ module Exercise = struct end +module Session = struct + + include Session + + let file = "sessions.json" + + let enc = + let open Json_encoding in + list (obj3 + (req "session" Session.enc) + (req "token" Token.enc) + (req "last_connection" float)) + + let path dir = Filename.concat dir file + + let load dir = + let p = path dir in + Lwt_unix.file_exists dir >>= fun dir_exists -> + (if not dir_exists then Lwt_unix.mkdir dir 0o700 else Lwt.return_unit) >>= fun () -> + Lwt_unix.file_exists p >>= function + | false -> + Printf.printf "No session file, creating empty list\n%!"; + Lwt.return [] + | true -> + Printf.printf "Loading sessions from: %s\n%!" p; + get_from_file enc p + + let save dir table = + write_to_file enc table (path dir) + + let get_user_token session = + load !data_dir >>= fun table -> + match List.find_opt (fun (s, _, _) -> s = session) table with + | Some (_, token, _) -> Lwt.return_some token + | None -> Lwt.return_none + + let set_session session token = + let now = Unix.gettimeofday () in + load !data_dir >>= fun table -> + let table = + (session, token, now) + :: List.filter (fun (s, _, _) -> s <> session) table + in + save !data_dir table + + let gen_session () = generate () + +end + module Token = struct include Token diff --git a/src/state/learnocaml_store.mli b/src/state/learnocaml_store.mli index e0d1356e5..68ed24542 100644 --- a/src/state/learnocaml_store.mli +++ b/src/state/learnocaml_store.mli @@ -15,6 +15,7 @@ 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} *) @@ -111,6 +112,32 @@ end (** {2 Dynamic data} *) +module Session: sig + + include module type of struct include Session end + + val file : string + + val enc : (t * Token.t * float) list Json_encoding.encoding + + val path : string -> string + + (** Loads the session table from disk. *) + val load : string -> (t * Token.t * float) list Lwt.t + + (** Saves the given session table to disk *) + val save : string -> (t * Token.t * float) list -> unit Lwt.t + + (** 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 -> t +end + module Token: sig From a382171e27f8d07018847d1d906a1d4197603c63 Mon Sep 17 00:00:00 2001 From: Nassim Mourabit Date: Mon, 31 Mar 2025 10:37:11 +0200 Subject: [PATCH 02/29] feat(api/login): add endpoint Login to return session for token --- src/server/learnocaml_server.ml | 21 +++++++++++++++++++++ src/state/learnocaml_api.ml | 10 +++++++++- src/state/learnocaml_api.mli | 2 ++ 3 files changed, 32 insertions(+), 1 deletion(-) diff --git a/src/server/learnocaml_server.ml b/src/server/learnocaml_server.ml index 364b5088a..d545e61ab 100644 --- a/src/server/learnocaml_server.ml +++ b/src/server/learnocaml_server.ml @@ -288,6 +288,27 @@ module Request_handler = struct | Some nickname -> Save.set tok Save.{empty with nickname}) >>= fun () -> respond_json cache tok + | Api.Login token -> + lwt_catch_fail + (fun () -> + Token.exists token >>= fun exists -> + lwt_option_fail + (if exists then Some token else None) + (`Not_found, "Token does not exist") + @@ fun token -> + Session.load !data_dir >>= fun table -> + match List.find_opt (fun (_, t, _) -> t = token) table with + | Some (existing_session, _, _) -> + (* Update last connection date *) + Session.set_session existing_session token >>= fun () -> + respond_json cache existing_session + | None -> + (* Create a new session *) + let session = Session.gen_session () in + Session.set_session session token >>= fun () -> + respond_json cache session + ) + (fun exn -> (`Internal_server_error, Printexc.to_string exn)) | Api.Fetch_save token -> lwt_catch_fail (fun () -> diff --git a/src/state/learnocaml_api.ml b/src/state/learnocaml_api.ml index 655b7f0f9..07c219121 100644 --- a/src/state/learnocaml_api.ml +++ b/src/state/learnocaml_api.ml @@ -102,6 +102,8 @@ type _ request = string * student token option * string option -> student token request | Create_teacher_token: teacher token * string option -> teacher token request + | Login: + 'a token -> Session.t request | Fetch_save: 'a token -> Save.t request | Archive_zip: @@ -159,6 +161,7 @@ let supported_versions | Nonce _ | Create_token (_, _, _) | Create_teacher_token _ + | Login _ | Fetch_save _ | Archive_zip _ | Update_save (_, _) @@ -229,6 +232,8 @@ module Conversions (Json: JSON_CODEC) = struct | Create_teacher_token _ -> json J.(obj1 (req "token" string)) +> Token.(to_string, parse) + | Login _ -> + json J.(obj1 (req "session" string)) | Fetch_save _ -> json Save.enc | Archive_zip _ -> @@ -304,7 +309,8 @@ module Conversions (Json: JSON_CODEC) = struct assert (Token.is_teacher token); get ~token (["teacher"; "new"] @ (match nick with None -> [] | Some n -> [n])) - + | Login token -> + get ~token ["login"] | Fetch_save token -> get ~token ["save.json"] | Archive_zip token -> @@ -423,6 +429,8 @@ module Server (Json: JSON_CODEC) (Rh: REQUEST_HANDLER) = struct Create_teacher_token (token, None) |> k | `GET, ["teacher"; "new"; nick], Some token when Token.is_teacher token -> Create_teacher_token (token, Some nick) |> k + | `GET, ["login"], Some token -> + Login token |> k | `GET, ["save.json"], Some token -> Fetch_save token |> k | `GET, ["archive.zip"], Some token -> diff --git a/src/state/learnocaml_api.mli b/src/state/learnocaml_api.mli index 984a3277a..164af2b78 100644 --- a/src/state/learnocaml_api.mli +++ b/src/state/learnocaml_api.mli @@ -88,6 +88,8 @@ type _ request = string * student token option * string option -> student token request | Create_teacher_token: teacher token * string option -> teacher token request + | Login: + 'a token -> Session.t request | Fetch_save: 'a token -> Save.t request | Archive_zip: From a4184915508e0115238f5cf37e061d55831e199f Mon Sep 17 00:00:00 2001 From: Nassim Mourabit Date: Mon, 31 Mar 2025 10:38:35 +0200 Subject: [PATCH 03/29] feat(index_main): use Login endpoint with permanent token --- src/app/learnocaml_index_main.ml | 38 +++++++++++++++++++++++--------- 1 file changed, 27 insertions(+), 11 deletions(-) diff --git a/src/app/learnocaml_index_main.ml b/src/app/learnocaml_index_main.ml index 29a3d9dc6..2bd20b486 100644 --- a/src/app/learnocaml_index_main.ml +++ b/src/app/learnocaml_index_main.ml @@ -727,17 +727,33 @@ let init_token_dialog () = Manip.SetCss.borderColor input "#f44"; Lwt.return_none | token -> - Server_caller.request (Learnocaml_api.Fetch_save token) >>= function - | Ok save -> - set_state_from_save_file ~token save; - Lwt.return_some (token, save.Save.nickname) - | Error (`Not_found _) -> - alert ~title:[%i"TOKEN NOT FOUND"] - [%i"The entered token couldn't be recognised."]; - Lwt.return_none - | Error e -> - lwt_alert ~title:[%i"REQUEST ERROR"] [ - H.p [H.txt [%i"Could not retrieve data from server"]]; + Server_caller.request (Learnocaml_api.Login token) >>= function + | Ok temp_token -> + Learnocaml_local_storage.(store sync_token) token; + Server_caller.request (Learnocaml_api.Fetch_save token) + >>= (function + | Ok save -> + set_state_from_save_file ~token:token save; + Lwt.return_some (token, 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 ()); From 1614112c2992ad27cf2f0823f462969f32100e18 Mon Sep 17 00:00:00 2001 From: Nassim Mourabit Date: Mon, 7 Apr 2025 10:27:47 +0200 Subject: [PATCH 04/29] refactor!(api,server): replace token with session in routes All endpoints previously requiring a token now expect a session. BREAKING CHANGE: Endpoints and clients using token-based authentication must be updated to use session-based authentication. --- src/server/learnocaml_server.ml | 43 ++++--- src/state/learnocaml_api.ml | 201 ++++++++++++++++---------------- src/state/learnocaml_api.mli | 24 ++-- 3 files changed, 140 insertions(+), 128 deletions(-) diff --git a/src/server/learnocaml_server.ml b/src/server/learnocaml_server.ml index d545e61ab..e2b077839 100644 --- a/src/server/learnocaml_server.ml +++ b/src/server/learnocaml_server.ml @@ -232,6 +232,11 @@ module Request_handler = struct (`Forbidden, "No address information avaible") lwt_ok + let wrap_user_session session f = + Session.get_user_token session >>= function + | Some token -> f token + | None -> Lwt.fail_with "Invalid session" + let callback_raw: type resp. Conduit.endp -> Learnocaml_data.Server.config -> caching -> resp Api.request -> (resp response, error) result Lwt.t @@ -309,7 +314,8 @@ module Request_handler = struct respond_json cache session ) (fun exn -> (`Internal_server_error, Printexc.to_string exn)) - | Api.Fetch_save token -> + | Api.Fetch_save session -> + wrap_user_session session @@ fun token -> lwt_catch_fail (fun () -> Save.get token >>= fun tokopt -> @@ -317,9 +323,10 @@ module Request_handler = struct tokopt (`Not_found, "token not found") (respond_json cache)) - (fun exn -> (`Internal_server_error, Printexc.to_string exn)) - | Api.Archive_zip token -> + (fun exn -> (`Internal_server_error, Printexc.to_string exn)) + | Api.Archive_zip 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 @@ -327,7 +334,8 @@ module Request_handler = struct lwt_ok @@ Response { contents = contents; content_type = "application/zip"; caching = Nocache } - | Api.Update_save (token, save) -> + | Api.Update_save (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 @@ -368,11 +376,13 @@ module Request_handler = struct caching = Nocache }) (fun e -> (`Not_found, Printexc.to_string e)) - | Api.Students_list token -> + | Api.Students_list session -> + wrap_user_session session @@ fun token -> verify_teacher_token token >?= fun () -> Student.Index.get () >>= respond_json cache - | Api.Set_students_list (token, students) -> + | Api.Set_students_list (session, students) -> + wrap_user_session session @@ fun token -> verify_teacher_token token >?= fun () -> Lwt_list.map_s (fun (ancestor, ours) -> @@ -386,7 +396,8 @@ module Request_handler = struct students >>= Student.Index.set >>= respond_json cache - | Api.Students_csv (token, exercises, students) -> + | Api.Students_csv (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 @@ -454,7 +465,8 @@ module Request_handler = struct content_type = "text/csv"; caching = Nocache} - | Api.Exercise_index (Some token) -> + | Api.Exercise_index (Some session) -> + wrap_user_session session @@ fun token -> Exercise.Index.get () >>= fun index -> Token.check_teacher token >>= (function | true -> Lwt.return (index, []) @@ -473,7 +485,8 @@ module Request_handler = struct | Api.Exercise_index None -> lwt_fail (`Forbidden, "Forbidden") - | Api.Exercise (Some token, id, js) -> + | Api.Exercise (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 -> @@ -502,13 +515,16 @@ module Request_handler = struct | Api.Playground id -> Playground.get id >>= respond_json cache - | Api.Exercise_status_index token -> + | Api.Exercise_status_index session -> + wrap_user_session session @@ fun token -> verify_teacher_token token >?= fun () -> Exercise.Status.all () >>= respond_json cache - | Api.Exercise_status (token, id) -> + | Api.Exercise_status (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) -> + | Api.Set_exercise_status (session, status) -> + wrap_user_session session @@ fun token -> verify_teacher_token token >?= fun () -> Lwt_list.iter_s Exercise.Status.(fun (ancestor, ours) -> @@ -517,7 +533,8 @@ module Request_handler = struct status >>= respond_json cache - | Api.Partition (token, eid, fid, prof) -> + | Api.Partition (session, eid, fid, prof) -> + wrap_user_session session @@ fun token -> lwt_catch_fail (fun () -> verify_teacher_token token >?= fun () -> diff --git a/src/state/learnocaml_api.ml b/src/state/learnocaml_api.ml index 07c219121..2e0f80665 100644 --- a/src/state/learnocaml_api.ml +++ b/src/state/learnocaml_api.ml @@ -105,24 +105,24 @@ type _ request = | Login: 'a token -> Session.t request | Fetch_save: - 'a token -> Save.t request + 'a session -> Save.t request | Archive_zip: - 'a token -> string request + 'a session -> string request | Update_save: - 'a token * Save.t -> Save.t request + 'a session * Save.t -> Save.t request | Git: 'a token * string list -> string request | Students_list: - teacher token -> Student.t list request + 'a session -> Student.t list request | Set_students_list: - teacher token * (Student.t * Student.t) list -> unit request + 'a session * (Student.t * Student.t) list -> unit request | Students_csv: - teacher token * Exercise.id list * Token.t list -> string request + 'a session * Exercise.id list * Token.t list -> string request | Exercise_index: - 'a token option -> (Exercise.Index.t * (Exercise.id * float) list) request + 'a session option -> (Exercise.Index.t * (Exercise.id * float) list) request | Exercise: - 'a token option * string * bool -> + 'a session option * string * bool -> (Exercise.Meta.t * Exercise.t * float option) request | Lesson_index: @@ -141,14 +141,14 @@ type _ request = string -> Playground.t request | Exercise_status_index: - teacher token -> Exercise.Status.t list request + 'a session -> Exercise.Status.t list request | Exercise_status: - teacher token * Exercise.id -> Exercise.Status.t request + 'a session * Exercise.id -> Exercise.Status.t request | Set_exercise_status: - teacher token * (Exercise.Status.t * Exercise.Status.t) list -> unit request + 'a session * (Exercise.Status.t * Exercise.Status.t) list -> unit request | Partition: - teacher token * Exercise.id * string * int -> Partition.t request + 'a session * Exercise.id * string * int -> Partition.t request | Invalid_request: string -> string request @@ -284,15 +284,17 @@ module Conversions (Json: JSON_CODEC) = struct let to_http_request : type resp. resp request -> http_request = - let get ?token ?(args=[]) path = { + let get ?token ?session ?(args=[]) path = { meth = `GET; path; - args = (match token with None -> [] | Some t -> ["token", Token.to_string t]) @ args; + args = (match token with None -> [] | Some t -> ["token", Token.to_string t]) @ + (match session with None -> [] | Some s -> ["session", s]) @ args; } in - let post ~token path body = { + let post ?token ?session path body = { meth = `POST body; path; - args = ["token", Token.to_string token]; + args = (match token with None -> [] | Some t -> ["token", Token.to_string t]) @ + (match session with None -> [] | Some s -> ["session", s]); } in function | Static path -> @@ -311,39 +313,36 @@ module Conversions (Json: JSON_CODEC) = struct (match nick with None -> [] | Some n -> [n])) | Login token -> get ~token ["login"] - | Fetch_save token -> - get ~token ["save.json"] - | Archive_zip token -> - get ~token ["archive.zip"] - | Update_save (token, save) -> - post ~token ["sync"] (Json.encode Save.enc save) + | Fetch_save session -> + get ~session ["save.json"] + | Archive_zip session -> + get ~session ["archive.zip"] + | Update_save (session, save) -> + post ~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"] - | Set_students_list (token, students) -> - assert (Token.is_teacher token); - post ~token + | Students_list session -> + get ~session ["teacher"; "students.json"] + | Set_students_list (session, students) -> + post ~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"] + | Students_csv (session, exercises, students) -> + post ~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 (Some session) -> + get ~session ["exercise-index.json"] | Exercise_index None -> get ["exercise-index.json"] - | Exercise (Some token, id, js) -> - get ~token + | Exercise (Some session, id, js) -> + get ~session ("exercises" :: String.split_on_char '/' (id^".json")) ~args:["mode", if js then "js" else "byte"] | Exercise (None, id, js) -> @@ -365,21 +364,20 @@ module Conversions (Json: JSON_CODEC) = struct | Tutorial id -> get ["tutorials"; id^".json"] - | Exercise_status_index token -> - assert (Token.is_teacher token); - get ~token ["teacher"; "exercise-status.json"] - | Exercise_status (token, id) -> - get ~token + | Exercise_status_index session -> + get ~session ["teacher"; "exercise-status.json"] + | Exercise_status (session, id) -> + get ~session ("teacher" :: "exercise-status" :: String.split_on_char '/' id) - | Set_exercise_status (token, status) -> - post ~token + | Set_exercise_status (session, status) -> + post ~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 (session, eid, fid, prof) -> + get ~session ["partition"; eid; fid; string_of_int prof] | Invalid_request s -> @@ -413,50 +411,51 @@ 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, ["teacher"; "new"; nick], Some token, _ when Token.is_teacher token -> Create_teacher_token (token, Some nick) |> k - | `GET, ["login"], Some token -> + | `GET, ["login"], Some token, _ -> Login token |> k - | `GET, ["save.json"], Some token -> - Fetch_save token |> k - | `GET, ["archive.zip"], Some token -> - Archive_zip token |> k - | `POST body, ["sync"], Some token -> + | `GET, ["save.json"], _, Some session -> + Fetch_save session |> k + | `GET, ["archive.zip"], _, Some session -> + Archive_zip session |> k + | `POST body, ["sync"], _, Some session -> (match Json.decode Save.enc body with - | save -> Update_save (token, save) |> k + | save -> Update_save (session, save) |> k | exception e -> Invalid_request (Printexc.to_string e) |> k) - | `GET, (stoken::"learnocaml-workspace.git"::p), None -> + | `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 - when Token.is_teacher token -> - Students_list token |> k - | `POST body, ["teacher"; "students.json"], Some token - when Token.is_teacher token -> + | `GET, ["teacher"; "students.json"], _, Some session -> + Students_list session |> k + | `POST body, ["teacher"; "students.json"], _, Some session -> (match Json.decode (J.list (J.tup2 Student.enc Student.enc)) body with - | students -> Set_students_list (token, students) |> k + | students -> Set_students_list (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 - when Token.is_teacher token -> + | `GET, ["teacher"; "students.csv"], _, Some session -> + Students_csv (session, [], []) |> k + | `POST body, ["teacher"; "students.csv"], _, Some session -> (match Json.decode (J.obj2 (J.dft "exercises" (J.list J.string) []) @@ -464,29 +463,29 @@ module Server (Json: JSON_CODEC) (Rh: REQUEST_HANDLER) = struct body with | exercises, students -> - Students_csv (token, exercises, students) |> k + Students_csv (session, exercises, students) |> k | exception e -> Invalid_request (Printexc.to_string e) |> k) - | `GET, ["exercise-index.json"], token -> - Exercise_index token |> k - | `GET, ("exercises"::path), token -> + | `GET, ["exercise-index.json"], _, session -> + Exercise_index session |> k + | `GET, ("exercises"::path), _, session -> (match last path with | Some s when String.lowercase_ascii (Filename.extension s) = ".json" -> - (match token with - | Some token -> + (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 (Some token, id, js) |> k - | None -> Invalid_request "Missing token" |> k) + Exercise (Some session, id, js) |> k + | None -> Invalid_request "Missing session" |> k) | Some "" -> Static ["exercise.html"] |> k | _ -> Static ("static"::path) |> k) - | `GET, ("description"::_), _token -> + | `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" -> @@ -497,39 +496,35 @@ 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 - when Token.is_teacher token -> - Partition (token, eid, fid, int_of_string prof) |> k - - | `GET, ["teacher"; "exercise-status.json"], Some token - when Token.is_teacher token -> - Exercise_status_index token |> 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 - when Token.is_teacher token -> + | `GET, ["partition"; eid; fid; prof], _, Some session -> + Partition (session, eid, fid, int_of_string prof) |> k + + | `GET, ["teacher"; "exercise-status.json"], _, Some session -> + Exercise_status_index session |> k + | `GET, ("teacher" :: "exercise-status" :: id), _, Some session -> + Exercise_status (session, String.concat "/" id) |> k + | `POST body, ["teacher"; "exercise-status"], _, Some session -> (match Json.decode (J.list (J.tup2 Exercise.Status.enc Exercise.Status.enc)) body with | status -> - Set_exercise_status (token, status) |> k + Set_exercise_status (session, status) |> k | exception e -> Invalid_request (Printexc.to_string e) |> k) | `GET, @@ -540,13 +535,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 164af2b78..4bbf7dcc2 100644 --- a/src/state/learnocaml_api.mli +++ b/src/state/learnocaml_api.mli @@ -91,27 +91,27 @@ type _ request = | Login: 'a token -> Session.t request | Fetch_save: - 'a token -> Save.t request + 'a session -> Save.t request | Archive_zip: - 'a token -> string request + 'a session -> string request | Update_save: - 'a token * Save.t -> Save.t request + 'a session * Save.t -> Save.t request | Git: 'a token * string list -> string request | Students_list: - teacher token -> Student.t list request + 'a session -> Student.t list request | Set_students_list: - teacher token * (Student.t * Student.t) list -> unit request + '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 + 'a session * Exercise.id list * Token.t list -> string request | Exercise_index: - 'a token option -> (Exercise.Index.t * (Exercise.id * float) list) request + 'a session option -> (Exercise.Index.t * (Exercise.id * float) list) request | Exercise: - 'a token option * string * bool -> + 'a session option * string * bool -> (Exercise.Meta.t * Exercise.t * float option) request | Lesson_index: @@ -130,17 +130,17 @@ type _ request = string -> Playground.t request | Exercise_status_index: - teacher token -> Exercise.Status.t list request + 'a session -> Exercise.Status.t list request | Exercise_status: - teacher token * Exercise.id -> Exercise.Status.t request + 'a session * Exercise.id -> Exercise.Status.t request | Set_exercise_status: - teacher token * (Exercise.Status.t * Exercise.Status.t) list -> + '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 + 'a session * Exercise.id * string * int -> Partition.t request | Invalid_request: string -> string request From 3b9557745755fec3b7734f427cc337bfce2aaf18 Mon Sep 17 00:00:00 2001 From: Nassim Mourabit Date: Mon, 7 Apr 2025 15:18:52 +0200 Subject: [PATCH 05/29] refactor(app): replace token with session in API calls and local_storage All API calls and local_storage interactions in the app/ folder now use session for authentication instead of token. --- src/app/learnocaml_common.ml | 64 ++++++++++++++++++-------- src/app/learnocaml_common.mli | 12 +++-- src/app/learnocaml_description_main.ml | 49 +++++++++----------- src/app/learnocaml_exercise_main.ml | 16 ++++--- src/app/learnocaml_index_main.ml | 57 ++++++++++++----------- src/app/learnocaml_local_storage.ml | 19 ++++++++ src/app/learnocaml_local_storage.mli | 4 ++ src/app/learnocaml_partition_view.ml | 11 +++-- src/app/learnocaml_student_view.ml | 17 +++---- src/app/learnocaml_teacher_tab.ml | 16 +++---- src/app/learnocaml_teacher_tab.mli | 2 +- src/app/server_caller.ml | 4 +- src/app/server_caller.mli | 2 +- 13 files changed, 163 insertions(+), 110 deletions(-) diff --git a/src/app/learnocaml_common.ml b/src/app/learnocaml_common.ml index a5a12d2d6..8da8e87ac 100644 --- a/src/app/learnocaml_common.ml +++ b/src/app/learnocaml_common.ml @@ -471,8 +471,8 @@ 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 token session save_file on_sync = + Server_caller.request (Learnocaml_api.Update_save (session, save_file)) >>= function | Ok save -> set_state_from_save_file ~token save; @@ -483,7 +483,7 @@ let rec sync_save token save_file on_sync = (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 -> + (Learnocaml_api.Update_save (session, save_file)) >>= fun save -> set_state_from_save_file ~token save; on_sync (); Lwt.return save @@ -492,13 +492,13 @@ let rec sync_save token save_file on_sync = 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 token 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 token session on_sync = sync_save token session (get_state_as_save_file ()) on_sync -let sync_exercise token ?answer ?editor id on_sync = +let sync_exercise token 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 +533,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 token,session with + | Some token, Some session -> + Lwt.catch (fun () -> sync_save token 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 @@ -936,7 +936,8 @@ module Editor_button (E : Editor_info) = struct let rec fetch_draft_solution tok () = match tok with | token -> - Server_caller.request (Learnocaml_api.Fetch_save token) >>= function + let session = Learnocaml_local_storage.(retrieve sync_session) in + Server_caller.request (Learnocaml_api.Fetch_save session) >>= function | Ok save -> set_state_from_save_file ~token save; Lwt.return_some (save.Save.nickname) @@ -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 token 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 + token >>= fun token -> session >>= fun session -> + sync_exercise token 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 *) @@ -1171,7 +1172,8 @@ let get_token ?(has_server = true) () = [H.txt [%i"Enter your token"]] >>= fun input_tok -> let token = Token.parse (input_tok) in - Server_caller.request (Learnocaml_api.Fetch_save token) + let session = Learnocaml_local_storage.(retrieve sync_session) in + Server_caller.request (Learnocaml_api.Fetch_save session) >>= function | Ok save -> set_state_from_save_file ~token save; @@ -1181,6 +1183,30 @@ let get_token ?(has_server = true) () = [%i"The entered token couldn't be recognised."]; Lwt.return_none +let get_session ?(has_server = true) () = + if not has_server then + Lwt.return None + else + try + 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 + let session = Learnocaml_local_storage.(retrieve sync_session) in + Server_caller.request (Learnocaml_api.Fetch_save session) + >>= function + | Ok save -> + set_state_from_save_file ~token save; + Lwt.return_some session + | _ -> + alert ~title:[%i"TOKEN NOT FOUND"] + [%i"The entered token couldn't be recognised."]; + Lwt.return_none + module Display_exercise = functor ( Q: sig @@ -1254,9 +1280,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 (Some session)) >|= fun (index, _) -> Exercise.Index.fold_exercises (fun (req, focus) id meta -> let add sk id map = @@ -1366,7 +1392,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 +1400,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 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..7616b84ab 100644 --- a/src/app/learnocaml_common.mli +++ b/src/app/learnocaml_common.mli @@ -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: Token.t -> 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 -> + Token.t option -> Session.t option -> ?answer:Learnocaml_data.Answer.t -> ?editor:string -> Learnocaml_data.Exercise.id -> (unit -> unit) -> Save.t Lwt.t @@ -228,7 +228,7 @@ module Editor_button (_ : Editor_info) : sig val reload : Learnocaml_data.Token.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 : Token.t option Lwt.t -> 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 @@ -245,6 +245,8 @@ val setup_prelude_pane : 'a Ace.editor -> string -> unit val get_token : ?has_server:bool -> unit -> Learnocaml_data.Token.t option Lwt.t +val get_session : ?has_server:bool -> unit -> Learnocaml_data.Session.t option Lwt.t + module Display_exercise :functor (_ : sig val exercise_link : @@ -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..fc162fec3 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 (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..662439bbf 100644 --- a/src/app/learnocaml_exercise_main.ml +++ b/src/app/learnocaml_exercise_main.ml @@ -103,6 +103,8 @@ let () = | Error _ -> Lwt.return_false) >>= fun has_server -> let token = get_token ~has_server () in + let session = get_session ~has_server () + in (* ---- launch everything --------------------------------------------- *) let toplevel_buttons_group = button_group () in disable_button_group toplevel_buttons_group (* enabled after init *) ; @@ -118,8 +120,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 (session, id, true)) in let after_init top = exercise_fetch >>= fun (_meta, exo, _deadline) -> @@ -171,8 +173,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 _ -> @@ -193,7 +195,7 @@ let () = if has_server then EB.reload token 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 token 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 +279,8 @@ let () = else Some solution, None in - token >>= fun token -> - sync_exercise token id ?answer ?editor (fun () -> Ace.set_synchronized ace) + token >>= fun token -> session >>= fun session -> + sync_exercise token 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 2bd20b486..b66048bc3 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 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,18 @@ 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 token 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 token 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 sync () = sync (get_stored_token ()) (get_stored_session ()) let token_disp_div token = H.input ~a: [ @@ -728,9 +730,11 @@ let init_token_dialog () = Lwt.return_none | token -> Server_caller.request (Learnocaml_api.Login token) >>= function - | Ok temp_token -> + | Ok session -> Learnocaml_local_storage.(store sync_token) token; - Server_caller.request (Learnocaml_api.Fetch_save token) + Learnocaml_local_storage.(store sync_session) session; + Learnocaml_local_storage.(store is_teacher) (Token.is_teacher token); + Server_caller.request (Learnocaml_api.Fetch_save session) >>= (function | Ok save -> set_state_from_save_file ~token:token save; @@ -774,18 +778,19 @@ let init_token_dialog () = get_token >|= fun (token, 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 + token,session let init_sync_token button_group = catch (fun () -> begin try - Lwt.return Learnocaml_local_storage.(retrieve sync_token) + Lwt.return (Learnocaml_local_storage.(retrieve sync_token),Learnocaml_local_storage.(retrieve sync_session)) with Not_found -> init_token_dialog () - end >>= fun token -> + end >>= fun (token,session) -> enable_button_group button_group ; - Lwt.return (Some token)) - (fun _ -> Lwt.return None) + Lwt.return ((Some token),(Some session))) + (fun _ -> Lwt.return (None,None)) let set_string_translations () = let configured v s = Js.Optdef.case v (fun () -> s) Js.to_string in @@ -855,7 +860,7 @@ let () = Manip.appendChild El.content div ; delete_arg "activity" in - let init_tabs token = + let init_tabs token session = let get_opt o = Js.Optdef.get o (fun () -> false) in let tabs : (string * (string * tab_handler)) list = (if get_opt config##.enableTutorials @@ -863,16 +868,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) ] - | _ -> []) + (match token,session with + | (Some t,Some s) when Token.is_teacher t -> + [ "teacher", ([%i"Teach"], teacher_tab t s) ] + | _,_ -> []) in let container = El.tab_buttons_container in let current_btn = ref None in @@ -968,7 +973,7 @@ let () = let logout_dialog () = Server_caller.request (Learnocaml_api.Update_save - (get_stored_token (), get_state_as_save_file ())) + (get_stored_session (), get_state_as_save_file ())) >|= (function | Ok _ -> [%i"Be sure to write down your token before logging out:"] @@ -1041,8 +1046,8 @@ let () = true); Server_caller.request (Learnocaml_api.Version ()) >>= (function - | Ok _ -> init_sync_token sync_button_group >|= init_tabs - | Error _ -> Lwt.return (init_tabs None)) >>= fun tabs -> + | Ok _ -> init_sync_token sync_button_group >|= (fun (token, session) -> init_tabs token session) + | Error _ -> Lwt.return (init_tabs None None)) >>= fun tabs -> try let activity = arg "activity" in let (_, select) = List.assoc activity tabs in diff --git a/src/app/learnocaml_local_storage.ml b/src/app/learnocaml_local_storage.ml index c77aa6db7..a291cfc38 100644 --- a/src/app/learnocaml_local_storage.ml +++ b/src/app/learnocaml_local_storage.ml @@ -151,6 +151,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 +170,16 @@ let nickname = { key = Some key ; dependent_keys = (=) key ; store ; retrieve ; delete ; listeners = [] } +let is_teacher = + let key = mangle [ "is_teacher" ] in + let enc = Json_encoding.(obj1 (req "is_teacher" bool)) in + let store value = store_single key enc value + and retrieve () = + try retrieve_single key enc () with Not_found -> false + and delete () = delete_single key enc () in + { key = Some key ; dependent_keys = (=) key ; + store ; retrieve ; delete ; listeners = [] } + let cached_exercise name = let key = mangle [ "cached-exercise" ; name ] in let enc = Learnocaml_exercise.enc in diff --git a/src/app/learnocaml_local_storage.mli b/src/app/learnocaml_local_storage.mli index 5dc4a3270..986475c45 100644 --- a/src/app/learnocaml_local_storage.mli +++ b/src/app/learnocaml_local_storage.mli @@ -57,4 +57,8 @@ val server_id : int storage_key val sync_token : Token.t storage_key +val sync_session : Session.t storage_key + +val is_teacher : bool storage_key + val nickname : string storage_key diff --git a/src/app/learnocaml_partition_view.ml b/src/app/learnocaml_partition_view.ml index a3e77ce99..d5f40c7fa 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 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 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 (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..7ae09a80d 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 (Some session)) >>= fun (index, _) -> - retrieve (Learnocaml_api.Exercise_status_index teacher_token) + retrieve (Learnocaml_api.Exercise_status_index 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 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 (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..8bcc45500 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 token session _select _params () = let action_new_token () = Learnocaml_common.ask_string ~title:"NEW TEACHER TOKEN" @@ -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 (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 (session, changes))) >>= fun () -> (if students_changes = [] then Lwt.return () else retrieve - (Learnocaml_api.Set_students_list (token, students_changes))) + (Learnocaml_api.Set_students_list (session, students_changes))) >>= fun () -> (* Reload the full tab: a bit more costly, but safer & simpler *) - teacher_tab token _select _params () >|= + teacher_tab token 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 (Some session)) >|= fun (index, _) -> exercises_index := index in let fetch_stats = - retrieve (Learnocaml_api.Exercise_status_index token) + retrieve (Learnocaml_api.Exercise_status_index 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 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..f5e47b731 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.Token.t -> 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..b8b3dac62 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 (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 From 8671ab2c6efcb1322e2400d6d5c30812f14804e6 Mon Sep 17 00:00:00 2001 From: Nassim Mourabit Date: Tue, 22 Apr 2025 20:54:32 +0200 Subject: [PATCH 06/29] =?UTF-8?q?feat(session):=20add=20Cryptokit=E2=80=91?= =?UTF-8?q?based=20session=20generation=20and=20parsing?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- learn-ocaml.opam | 1 + learn-ocaml.opam.locked | 2 ++ src/server/learnocaml_server.ml | 14 +++----------- src/state/dune | 2 +- src/state/learnocaml_data.ml | 24 +++++++++++++++--------- src/state/learnocaml_data.mli | 4 +++- src/state/learnocaml_store.ml | 12 ++++++------ 7 files changed, 31 insertions(+), 28 deletions(-) diff --git a/learn-ocaml.opam b/learn-ocaml.opam index 8cd728d0f..e24b7933b 100644 --- a/learn-ocaml.opam +++ b/learn-ocaml.opam @@ -29,6 +29,7 @@ depends: [ "cohttp-lwt-unix" {>= "2.0.0"} "conduit-lwt-unix" {< "7.1.0"} "conf-git" + "cryptokit" "decompress" {= "0.8.1"} "digestif" {>= "1.2.0"} "dune" {>= "2.3.0"} diff --git a/learn-ocaml.opam.locked b/learn-ocaml.opam.locked index 84023a11e..16eed9cde 100644 --- a/learn-ocaml.opam.locked +++ b/learn-ocaml.opam.locked @@ -49,8 +49,10 @@ depends: [ "conf-gmp-powm-sec" {= "3"} "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"} diff --git a/src/server/learnocaml_server.ml b/src/server/learnocaml_server.ml index e2b077839..8ef14d1d9 100644 --- a/src/server/learnocaml_server.ml +++ b/src/server/learnocaml_server.ml @@ -301,17 +301,9 @@ module Request_handler = struct (if exists then Some token else None) (`Not_found, "Token does not exist") @@ fun token -> - Session.load !data_dir >>= fun table -> - match List.find_opt (fun (_, t, _) -> t = token) table with - | Some (existing_session, _, _) -> - (* Update last connection date *) - Session.set_session existing_session token >>= fun () -> - respond_json cache existing_session - | None -> - (* Create a new session *) - let session = Session.gen_session () in - Session.set_session session token >>= fun () -> - respond_json cache session + let session = Session.gen_session () in + Session.set_session session token >>= fun () -> + respond_json cache session ) (fun exn -> (`Internal_server_error, Printexc.to_string exn)) | Api.Fetch_save session -> diff --git a/src/state/dune b/src/state/dune index 4f03db743..ce489d524 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) ) diff --git a/src/state/learnocaml_data.ml b/src/state/learnocaml_data.ml index abb5d1975..595a645e1 100644 --- a/src/state/learnocaml_data.ml +++ b/src/state/learnocaml_data.ml @@ -191,15 +191,21 @@ end module Session = struct type t = string - (** TODO generate robust token with cryptokit?*) - let generate () : t = - let length = 32 in - let alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" in - let alphabet_len = String.length alphabet in - String.init length (fun _ -> alphabet.[Random.int alphabet_len]) - - (** TODO parsing with the corect format*) - let parse session = session + 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 diff --git a/src/state/learnocaml_data.mli b/src/state/learnocaml_data.mli index d8e8bcee8..9fcd0bc8d 100644 --- a/src/state/learnocaml_data.mli +++ b/src/state/learnocaml_data.mli @@ -73,7 +73,9 @@ end module Session : sig type t = string - val generate : unit -> t + val to_string: t -> string + + val parse: string -> t val enc : t Json_encoding.encoding end diff --git a/src/state/learnocaml_store.ml b/src/state/learnocaml_store.ml index a7425e9ab..195d143c5 100644 --- a/src/state/learnocaml_store.ml +++ b/src/state/learnocaml_store.ml @@ -338,13 +338,13 @@ module Session = struct let set_session session token = let now = Unix.gettimeofday () in load !data_dir >>= fun table -> - let table = - (session, token, now) - :: List.filter (fun (s, _, _) -> s <> session) table - in + let table = (session, token, now) :: table in save !data_dir table - - let gen_session () = generate () + + let gen_session () = + let len = 32 in + Cryptokit.Random.string Cryptokit.Random.secure_rng len + |> Cryptokit.transform_string @@ Cryptokit.Hexa.encode () end From ef77eac52e27084bf8dab475c930d6da1294732f Mon Sep 17 00:00:00 2001 From: Nassim Mourabit Date: Wed, 23 Apr 2025 09:19:29 +0200 Subject: [PATCH 07/29] feat(api): implement Get_token endpoint Add a new API route that returns the token associated with a given session, enabling clients to retrieve their token server-side without storing it in the frontend. --- src/server/learnocaml_server.ml | 3 +++ src/state/learnocaml_api.ml | 10 ++++++++++ src/state/learnocaml_api.mli | 2 ++ 3 files changed, 15 insertions(+) diff --git a/src/server/learnocaml_server.ml b/src/server/learnocaml_server.ml index 8ef14d1d9..206a99740 100644 --- a/src/server/learnocaml_server.ml +++ b/src/server/learnocaml_server.ml @@ -316,6 +316,9 @@ module Request_handler = struct (`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 session -> let open Lwt_process in wrap_user_session session @@ fun token -> diff --git a/src/state/learnocaml_api.ml b/src/state/learnocaml_api.ml index 2e0f80665..9a6f40a45 100644 --- a/src/state/learnocaml_api.ml +++ b/src/state/learnocaml_api.ml @@ -106,6 +106,8 @@ type _ request = 'a token -> Session.t request | Fetch_save: 'a session -> Save.t request + | Get_token: + 'a session -> Token.t request | Archive_zip: 'a session -> string request | Update_save: @@ -163,6 +165,7 @@ let supported_versions | Create_teacher_token _ | Login _ | Fetch_save _ + | Get_token _ | Archive_zip _ | Update_save (_, _) | Git (_, _) @@ -236,6 +239,9 @@ module Conversions (Json: JSON_CODEC) = struct json J.(obj1 (req "session" string)) | Fetch_save _ -> json Save.enc + | Get_token _ -> + json J.(obj1 (req "token" string)) +> + Token.(to_string, parse) | Archive_zip _ -> str | Update_save _ -> @@ -315,6 +321,8 @@ module Conversions (Json: JSON_CODEC) = struct get ~token ["login"] | Fetch_save session -> get ~session ["save.json"] + | Get_token session -> + get ~session ["token"] | Archive_zip session -> get ~session ["archive.zip"] | Update_save (session, save) -> @@ -436,6 +444,8 @@ module Server (Json: JSON_CODEC) (Rh: REQUEST_HANDLER) = struct Login token |> k | `GET, ["save.json"], _, Some session -> Fetch_save session |> k + | `GET, ["token"], _, Some session -> + Get_token session |> k | `GET, ["archive.zip"], _, Some session -> Archive_zip session |> k | `POST body, ["sync"], _, Some session -> diff --git a/src/state/learnocaml_api.mli b/src/state/learnocaml_api.mli index 4bbf7dcc2..e2e4375e7 100644 --- a/src/state/learnocaml_api.mli +++ b/src/state/learnocaml_api.mli @@ -92,6 +92,8 @@ type _ request = 'a token -> Session.t request | Fetch_save: 'a session -> Save.t request + | Get_token: + 'a session -> Token.t request | Archive_zip: 'a session -> string request | Update_save: From a64ee69cbf80f7ac7da634cca45110a6eeb3239c Mon Sep 17 00:00:00 2001 From: Nassim Mourabit Date: Wed, 23 Apr 2025 09:42:03 +0200 Subject: [PATCH 08/29] feat!(api): change Create_teacher_token to accept session instead of token --- src/app/learnocaml_teacher_tab.ml | 6 +++--- src/app/learnocaml_teacher_tab.mli | 2 +- src/server/learnocaml_server.ml | 3 ++- src/state/learnocaml_api.ml | 15 +++++++-------- src/state/learnocaml_api.mli | 2 +- 5 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/app/learnocaml_teacher_tab.ml b/src/app/learnocaml_teacher_tab.ml index 8bcc45500..85c6e1088 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 session _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 session _select _params () = | "" -> None | s -> Some s in - retrieve (Learnocaml_api.Create_teacher_token (token, nick)) + retrieve (Learnocaml_api.Create_teacher_token (session, nick)) >|= fun new_token -> alert ~title:[%i"TEACHER TOKEN"] (Printf.sprintf [%if"New teacher token created:\n%s\n\n\ @@ -953,7 +953,7 @@ let rec teacher_tab token session _select _params () = (Learnocaml_api.Set_students_list (session, students_changes))) >>= fun () -> (* Reload the full tab: a bit more costly, but safer & simpler *) - teacher_tab token session _select _params () >|= + teacher_tab session _select _params () >|= Manip.replaceSelf (find_component "learnocaml-main-teacher") (* status_map := status_current (); * status_changes := SMap.empty; diff --git a/src/app/learnocaml_teacher_tab.mli b/src/app/learnocaml_teacher_tab.mli index f5e47b731..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 -> Learnocaml_data.Session.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/server/learnocaml_server.ml b/src/server/learnocaml_server.ml index 206a99740..f44d0b3f4 100644 --- a/src/server/learnocaml_server.ml +++ b/src/server/learnocaml_server.ml @@ -284,7 +284,8 @@ module Request_handler = struct (function | Failure body -> (`Bad_request, body) | exn -> (`Internal_server_error, Printexc.to_string exn)) - | Api.Create_teacher_token (token, nick) -> + | Api.Create_teacher_token (session, nick) -> + wrap_user_session session @@ fun token -> verify_teacher_token token >?= fun () -> Token.create_teacher () diff --git a/src/state/learnocaml_api.ml b/src/state/learnocaml_api.ml index 9a6f40a45..6f87d1a3e 100644 --- a/src/state/learnocaml_api.ml +++ b/src/state/learnocaml_api.ml @@ -101,7 +101,7 @@ type _ request = | Create_token: string * student token option * string option -> student token request | Create_teacher_token: - teacher token * string option -> teacher token request + 'a session * string option -> teacher token request | Login: 'a token -> Session.t request | Fetch_save: @@ -313,9 +313,8 @@ module Conversions (Json: JSON_CODEC) = struct | Create_token (secret_candiate, token, nick) -> get ?token (["sync"; "new"; secret_candiate] @ (match nick with None -> [] | Some n -> [n])) - | Create_teacher_token (token, nick) -> - assert (Token.is_teacher token); - get ~token (["teacher"; "new"] @ + | Create_teacher_token (session, nick) -> + get ~session (["teacher"; "new"] @ (match nick with None -> [] | Some n -> [n])) | Login token -> get ~token ["login"] @@ -436,10 +435,10 @@ module Server (Json: JSON_CODEC) (Rh: REQUEST_HANDLER) = struct Create_token (secret_candidate, token, None) |> k | `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 -> - Create_teacher_token (token, None) |> k - | `GET, ["teacher"; "new"; nick], Some token, _ when Token.is_teacher token -> - Create_teacher_token (token, Some nick) |> k + | `GET, ["teacher"; "new"], _, Some session -> + Create_teacher_token (session, None) |> k + | `GET, ["teacher"; "new"; nick], _, Some session -> + Create_teacher_token (session, Some nick) |> k | `GET, ["login"], Some token, _ -> Login token |> k | `GET, ["save.json"], _, Some session -> diff --git a/src/state/learnocaml_api.mli b/src/state/learnocaml_api.mli index e2e4375e7..16911bcf2 100644 --- a/src/state/learnocaml_api.mli +++ b/src/state/learnocaml_api.mli @@ -87,7 +87,7 @@ type _ request = | Create_token: string * student token option * string option -> student token request | Create_teacher_token: - teacher token * string option -> teacher token request + 'a session * string option -> teacher token request | Login: 'a token -> Session.t request | Fetch_save: From 06ab52c7aeee6aa53d542f5ab4a3008b351f75b2 Mon Sep 17 00:00:00 2001 From: Nassim Mourabit Date: Wed, 23 Apr 2025 09:43:44 +0200 Subject: [PATCH 09/29] refactor(client): remove deprecated from local storage and front-end --- src/app/learnocaml_common.ml | 103 +++++++++++---------------- src/app/learnocaml_common.mli | 12 ++-- src/app/learnocaml_exercise_main.ml | 10 ++- src/app/learnocaml_index_main.ml | 74 ++++++++++--------- src/app/learnocaml_local_storage.ml | 9 --- src/app/learnocaml_local_storage.mli | 2 - 6 files changed, 93 insertions(+), 117 deletions(-) diff --git a/src/app/learnocaml_common.ml b/src/app/learnocaml_common.ml index 8da8e87ac..ce5fdcc27 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 session save_file on_sync = +let rec sync_save session save_file on_sync = Server_caller.request (Learnocaml_api.Update_save (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 (session, save_file)) >>= fun save -> - set_state_from_save_file ~token 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 session save_file on_sync); + [%i"Retry"], (fun () -> sync_save session save_file on_sync); [%i"Ignore"], (fun () -> Lwt.return save_file); ] -let sync token session on_sync = sync_save token session (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 session ?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 session ?answer ?editor id on_sync = all_toplevel_histories = SMap.empty; all_exercise_toplevel_histories = opt_to_map toplevel_history; } in - match token,session with - | Some token, Some session -> - Lwt.catch (fun () -> sync_save token session 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) - | _,_ -> 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,14 +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 -> - let session = Learnocaml_local_storage.(retrieve sync_session) in + let reload session id template = + let rec fetch_draft_solution sess () = + match sess with + | session -> Server_caller.request (Learnocaml_api.Fetch_save 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"] @@ -950,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 @@ -985,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 () -> @@ -1024,13 +1024,13 @@ module Editor_button (E : Editor_info) = struct select_tab "toplevel"; Lwt.return_unit - let sync token session 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 -> session >>= fun session -> - sync_exercise token session 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 *) @@ -1159,30 +1159,6 @@ let setup_prelude_pane ace prelude = Manip.appendChildren prelude_pane [ prelude_title ; prelude_container ] -let get_token ?(has_server = true) () = - if not has_server then - Lwt.return None - else - try - Some Learnocaml_local_storage.(retrieve sync_token) |> - 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 - let session = Learnocaml_local_storage.(retrieve sync_session) in - Server_caller.request (Learnocaml_api.Fetch_save session) - >>= 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 get_session ?(has_server = true) () = if not has_server then Lwt.return None @@ -1196,16 +1172,21 @@ let get_session ?(has_server = true) () = [H.txt [%i"Enter your token"]] >>= fun input_tok -> let token = Token.parse (input_tok) in - let session = Learnocaml_local_storage.(retrieve sync_session) in - Server_caller.request (Learnocaml_api.Fetch_save session) - >>= function - | Ok save -> - set_state_from_save_file ~token save; - Lwt.return_some session - | _ -> - alert ~title:[%i"TOKEN NOT FOUND"] - [%i"The entered token couldn't be recognised."]; - Lwt.return_none + Server_caller.request (Learnocaml_api.Login token) >>= function + | Ok session -> + (Server_caller.request (Learnocaml_api.Fetch_save 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 ( diff --git a/src/app/learnocaml_common.mli b/src/app/learnocaml_common.mli index 7616b84ab..76cb8c597 100644 --- a/src/app/learnocaml_common.mli +++ b/src/app/learnocaml_common.mli @@ -126,7 +126,7 @@ val extract_text_from_rich_text : Learnocaml_data.Tutorial.text -> string (** Sets the local storage from the data in a save file *) val set_state_from_save_file : - ?token:Token.t -> Save.t -> unit + ?session:Session.t -> Save.t -> unit (** Gets a save file containing the locally stored data *) val get_state_as_save_file : ?include_reports:bool -> unit -> Save.t @@ -139,12 +139,12 @@ val get_state_as_save_file : ?include_reports:bool -> unit -> Save.t Notice that this function synchronizes student {b,content} but not the reports which are only synchronized when an actual "grading" is done. *) -val sync: Token.t -> Session.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 -> Session.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 -> Session.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,8 +243,6 @@ val setup_tab_text_prelude_pane : string -> unit val setup_prelude_pane : 'a Ace.editor -> string -> unit -val get_token : ?has_server:bool -> unit -> Learnocaml_data.Token.t option Lwt.t - val get_session : ?has_server:bool -> unit -> Learnocaml_data.Session.t option Lwt.t module Display_exercise :functor diff --git a/src/app/learnocaml_exercise_main.ml b/src/app/learnocaml_exercise_main.ml index 662439bbf..97cf2f8bd 100644 --- a/src/app/learnocaml_exercise_main.ml +++ b/src/app/learnocaml_exercise_main.ml @@ -101,8 +101,6 @@ 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 () - in let session = get_session ~has_server () in (* ---- launch everything --------------------------------------------- *) @@ -193,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 session 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 @@ -279,8 +277,8 @@ let () = else Some solution, None in - token >>= fun token -> session >>= fun session -> - sync_exercise token session 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 b66048bc3..bb0902688 100644 --- a/src/app/learnocaml_index_main.ml +++ b/src/app/learnocaml_index_main.ml @@ -669,18 +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 session: tab_handler = +let teacher_tab session: tab_handler = fun a b () -> show_loading [%i"Loading student info"] @@ fun () -> - Learnocaml_teacher_tab.teacher_tab token session 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 ()) (get_stored_session ()) +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: [ @@ -718,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 @@ -731,14 +739,13 @@ let init_token_dialog () = | token -> Server_caller.request (Learnocaml_api.Login token) >>= function | Ok session -> - Learnocaml_local_storage.(store sync_token) token; Learnocaml_local_storage.(store sync_session) session; Learnocaml_local_storage.(store is_teacher) (Token.is_teacher token); Server_caller.request (Learnocaml_api.Fetch_save session) >>= (function | Ok save -> - set_state_from_save_file ~token:token save; - Lwt.return_some (token, save.Save.nickname) + 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"]; @@ -775,22 +782,22 @@ 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"; let session = Learnocaml_local_storage.(retrieve sync_session) in - token,session + session -let init_sync_token button_group = +let init_sync_session button_group = catch (fun () -> begin try - Lwt.return (Learnocaml_local_storage.(retrieve sync_token),Learnocaml_local_storage.(retrieve sync_session)) + Lwt.return (Learnocaml_local_storage.(retrieve sync_session)) with Not_found -> init_token_dialog () - end >>= fun (token,session) -> + end >>= fun session -> enable_button_group button_group ; - Lwt.return ((Some token),(Some session))) - (fun _ -> Lwt.return (None,None)) + Lwt.return (Some session)) + (fun _ -> Lwt.return None) let set_string_translations () = let configured v s = Js.Optdef.case v (fun () -> s) Js.to_string in @@ -860,7 +867,7 @@ let () = Manip.appendChild El.content div ; delete_arg "activity" in - let init_tabs token session = + 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 @@ -873,11 +880,12 @@ let () = (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,session with - | (Some t,Some s) when Token.is_teacher t -> - [ "teacher", ([%i"Teach"], teacher_tab t s) ] - | _,_ -> []) + 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 let current_btn = ref None in @@ -956,21 +964,22 @@ 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_session (), get_state_as_save_file ())) @@ -985,7 +994,7 @@ let () = confirm ~title:[%i"Logout"] ~ok_label:[%i"Logout"] [H.p [H.txt s]; H.div ~a:[H.a_style "text-align: center;"] - [token_disp_div (get_stored_token ())]] + [token_disp_div (token)]] (fun () -> Lwt.async @@ fun () -> Learnocaml_local_storage.clear (); @@ -996,7 +1005,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 () -> @@ -1046,8 +1056,8 @@ let () = true); Server_caller.request (Learnocaml_api.Version ()) >>= (function - | Ok _ -> init_sync_token sync_button_group >|= (fun (token, session) -> init_tabs token session) - | Error _ -> Lwt.return (init_tabs None None)) >>= fun 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 let (_, select) = List.assoc activity tabs in diff --git a/src/app/learnocaml_local_storage.ml b/src/app/learnocaml_local_storage.ml index a291cfc38..24ef276e2 100644 --- a/src/app/learnocaml_local_storage.ml +++ b/src/app/learnocaml_local_storage.ml @@ -142,15 +142,6 @@ 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 - let store value = store_single key enc (Token.to_string value) - and retrieve () = retrieve_single key enc () |> Token.parse - and delete () = delete_single key enc () in - { 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 diff --git a/src/app/learnocaml_local_storage.mli b/src/app/learnocaml_local_storage.mli index 986475c45..94f5f7ec7 100644 --- a/src/app/learnocaml_local_storage.mli +++ b/src/app/learnocaml_local_storage.mli @@ -55,8 +55,6 @@ val all_toplevel_histories : Learnocaml_toplevel_history.snapshot SMap.t storage 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 From 228b6afcd9d9ae9908c0bdb11dc7f8ed6ee4e4c8 Mon Sep 17 00:00:00 2001 From: Nassim Mourabit Date: Tue, 29 Apr 2025 19:03:39 +0200 Subject: [PATCH 10/29] =?UTF-8?q?feat(api):=20add=20v2.0=20session-based?= =?UTF-8?q?=20=E2=80=9C=5Fs=E2=80=9D=20endpoints=20(token=20routes=20kept?= =?UTF-8?q?=20for=20CLI)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Update supported_versions so: - legacy token routes are valid Upto v2.0 - new session routes are valid Since v2.0 Clients ≥ 2.0 negotiate the new API; CLI clients continue to work. Front-end now uses only the “_s” routes. --- src/app/learnocaml_common.ml | 10 +- src/app/learnocaml_description_main.ml | 2 +- src/app/learnocaml_exercise_main.ml | 2 +- src/app/learnocaml_index_main.ml | 6 +- src/app/learnocaml_partition_view.ml | 6 +- src/app/learnocaml_student_view.ml | 8 +- src/app/learnocaml_teacher_tab.ml | 14 +- src/app/server_caller.ml | 2 +- src/server/learnocaml_server.ml | 217 +++++++++++++++- src/state/learnocaml_api.ml | 340 +++++++++++++++++++------ src/state/learnocaml_api.mli | 28 ++ 11 files changed, 520 insertions(+), 115 deletions(-) diff --git a/src/app/learnocaml_common.ml b/src/app/learnocaml_common.ml index ce5fdcc27..e70c3aedf 100644 --- a/src/app/learnocaml_common.ml +++ b/src/app/learnocaml_common.ml @@ -472,7 +472,7 @@ let get_state_as_save_file ?(include_reports = false) () = } let rec sync_save session save_file on_sync = - Server_caller.request (Learnocaml_api.Update_save (session, save_file)) + Server_caller.request (Learnocaml_api.Update_save_s (session, save_file)) >>= function | Ok save -> set_state_from_save_file ~session save; @@ -937,7 +937,7 @@ module Editor_button (E : Editor_info) = struct let rec fetch_draft_solution sess () = match sess with | session -> - Server_caller.request (Learnocaml_api.Fetch_save session) >>= function + Server_caller.request (Learnocaml_api.Fetch_save_s session) >>= function | Ok save -> set_state_from_save_file ~session save; Lwt.return_some (save.Save.nickname) @@ -1174,7 +1174,7 @@ let get_session ?(has_server = true) () = let token = Token.parse (input_tok) in Server_caller.request (Learnocaml_api.Login token) >>= function | Ok session -> - (Server_caller.request (Learnocaml_api.Fetch_save session) + (Server_caller.request (Learnocaml_api.Fetch_save_s session) >>= function | Ok save -> set_state_from_save_file ~session save; @@ -1263,7 +1263,7 @@ module Display_exercise = let get_skill_index session = let index = lazy ( - retrieve (Learnocaml_api.Exercise_index (Some session)) + retrieve (Learnocaml_api.Exercise_index_s (Some session)) >|= fun (index, _) -> Exercise.Index.fold_exercises (fun (req, focus) id meta -> let add sk id map = @@ -1381,7 +1381,7 @@ module Display_exercise = | [] -> None | [author] -> Some (display_authors [%i "Author:"] [author]) | authors -> Some (display_authors [%i "Authors:"] authors) in - retrieve (Learnocaml_api.Exercise_index session) + 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_description_main.ml b/src/app/learnocaml_description_main.ml index fc162fec3..d9a0de51c 100644 --- a/src/app/learnocaml_description_main.ml +++ b/src/app/learnocaml_description_main.ml @@ -63,7 +63,7 @@ let () = match get_encoded_session () with | Some { arg_name = _; raw_arg = _; session } -> begin let exercise_fetch = - retrieve (Learnocaml_api.Exercise (Some session, id, true)) + retrieve (Learnocaml_api.Exercise_s (Some session, id, true)) in init_tabs (); exercise_fetch >>= fun (ex_meta, exo, _deadline) -> diff --git a/src/app/learnocaml_exercise_main.ml b/src/app/learnocaml_exercise_main.ml index 97cf2f8bd..22cc95973 100644 --- a/src/app/learnocaml_exercise_main.ml +++ b/src/app/learnocaml_exercise_main.ml @@ -119,7 +119,7 @@ let () = Js.string (id ^ " - " ^ "Learn OCaml" ^" v."^ Learnocaml_api.version); let exercise_fetch = session >>= fun session -> - retrieve (Learnocaml_api.Exercise (session, id, true)) + retrieve (Learnocaml_api.Exercise_s (session, id, true)) in let after_init top = exercise_fetch >>= fun (_meta, exo, _deadline) -> diff --git a/src/app/learnocaml_index_main.ml b/src/app/learnocaml_index_main.ml index bb0902688..31629fdcc 100644 --- a/src/app/learnocaml_index_main.ml +++ b/src/app/learnocaml_index_main.ml @@ -175,7 +175,7 @@ let exercises_tab session: tab_handler = let open Tyxml_js.Html5 in show_loading [%i"Loading exercises"] @@ fun () -> Lwt_js.sleep 0.5 >>= fun () -> - retrieve (Learnocaml_api.Exercise_index session) + retrieve (Learnocaml_api.Exercise_index_s session) >>= fun (index, deadlines) -> let exercises_to_display_signal = make_exercises_to_display_signal index @@ -741,7 +741,7 @@ let init_token_dialog () = | 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 session) + Server_caller.request (Learnocaml_api.Fetch_save_s session) >>= (function | Ok save -> set_state_from_save_file ~session:session save; @@ -981,7 +981,7 @@ let () = let logout_dialog () = fetch_token () >>= fun token -> Server_caller.request - (Learnocaml_api.Update_save + (Learnocaml_api.Update_save_s (get_stored_session (), get_state_as_save_file ())) >|= (function | Ok _ -> diff --git a/src/app/learnocaml_partition_view.ml b/src/app/learnocaml_partition_view.ml index d5f40c7fa..1fe8b237b 100644 --- a/src/app/learnocaml_partition_view.ml +++ b/src/app/learnocaml_partition_view.ml @@ -235,7 +235,7 @@ let main () = | None -> true | Some (tok,_) -> Lwt.async (fun () -> - retrieve (Learnocaml_api.Fetch_save session) + retrieve (Learnocaml_api.Fetch_save_s session) >|= fun save -> match SMap.find_opt exercise_id save.Save.all_exercise_states with | None -> () @@ -251,7 +251,7 @@ let main () = else true in let fetch_students = - retrieve (Learnocaml_api.Students_list session) + 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) @@ -259,7 +259,7 @@ let main () = students_map := map in let fetch_part = - retrieve (Learnocaml_api.Partition (session, 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 7ae09a80d..4b7260534 100644 --- a/src/app/learnocaml_student_view.ml +++ b/src/app/learnocaml_student_view.ml @@ -349,9 +349,9 @@ let stats_tab assignments answers = ] let init_exercises_and_stats_tabs student_token session answers = - retrieve (Learnocaml_api.Exercise_index (Some session)) + retrieve (Learnocaml_api.Exercise_index_s (Some session)) >>= fun (index, _) -> - retrieve (Learnocaml_api.Exercise_status_index session) + 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); @@ -504,7 +504,7 @@ let () = init_draft_tab (); Manip.setInnerText El.token ([%i"Status of student: "] ^ Token.to_string student_token); - retrieve (Learnocaml_api.Fetch_save session) + retrieve (Learnocaml_api.Fetch_save_s session) >>= fun save -> Manip.setInnerText El.nickname save.Save.nickname; init_exercises_and_stats_tabs @@ -516,7 +516,7 @@ let () = | None -> () | Some ex_id -> Lwt.async @@ fun () -> - retrieve (Learnocaml_api.Exercise (Some session, 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 85c6e1088..cee74a623 100644 --- a/src/app/learnocaml_teacher_tab.ml +++ b/src/app/learnocaml_teacher_tab.ml @@ -101,7 +101,7 @@ let rec teacher_tab session _select _params () = | "" -> None | s -> Some s in - retrieve (Learnocaml_api.Create_teacher_token (session, 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 session _select _params () = Seq.filter_map (function `Token tk -> Some tk | `Any -> None) |> List.of_seq in - retrieve (Learnocaml_api.Students_csv (session, exercises, students)) + retrieve (Learnocaml_api.Students_csv_s (session, exercises, students)) >|= fun csv -> Learnocaml_common.fake_download ~name:"learnocaml.csv" @@ -946,11 +946,11 @@ let rec teacher_tab session _select _params () = in (if changes = [] then Lwt.return () else retrieve - (Learnocaml_api.Set_exercise_status (session, changes))) + (Learnocaml_api.Set_exercise_status_s (session, changes))) >>= fun () -> (if students_changes = [] then Lwt.return () else retrieve - (Learnocaml_api.Set_students_list (session, 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 session _select _params () >|= @@ -1333,12 +1333,12 @@ let rec teacher_tab session _select _params () = ] in let fetch_exercises = - retrieve (Learnocaml_api.Exercise_index (Some session)) + retrieve (Learnocaml_api.Exercise_index_s (Some session)) >|= fun (index, _) -> exercises_index := index in let fetch_stats = - retrieve (Learnocaml_api.Exercise_status_index session) + 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 session _select _params () = status_map := map in let fetch_students = - retrieve (Learnocaml_api.Students_list session) + 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/server_caller.ml b/src/app/server_caller.ml index b8b3dac62..a9d9c2f00 100644 --- a/src/app/server_caller.ml +++ b/src/app/server_caller.ml @@ -115,7 +115,7 @@ let fetch_lesson id = request_exn (Learnocaml_api.Lesson id) let fetch_exercise session id js = - request_exn (Learnocaml_api.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/server/learnocaml_server.ml b/src/server/learnocaml_server.ml index f44d0b3f4..43d0b4f21 100644 --- a/src/server/learnocaml_server.ml +++ b/src/server/learnocaml_server.ml @@ -284,7 +284,16 @@ module Request_handler = struct (function | Failure body -> (`Bad_request, body) | exn -> (`Internal_server_error, Printexc.to_string exn)) - | Api.Create_teacher_token (session, nick) -> + | Api.Create_teacher_token (token, nick) -> + 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.Create_teacher_token_s (session, nick) -> wrap_user_session session @@ fun token -> verify_teacher_token token >?= fun () -> @@ -307,7 +316,16 @@ module Request_handler = struct respond_json cache session ) (fun exn -> (`Internal_server_error, Printexc.to_string exn)) - | Api.Fetch_save session -> + | Api.Fetch_save 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.Fetch_save_s session -> wrap_user_session session @@ fun token -> lwt_catch_fail (fun () -> @@ -320,7 +338,16 @@ module Request_handler = struct | Api.Get_token session -> wrap_user_session session @@ fun token -> respond_json cache token - | Api.Archive_zip session -> + | Api.Archive_zip token -> + let open Lwt_process in + let path = Filename.concat !sync_dir (Token.to_path token) in + let cmd = shell ("git archive master --format=zip -0 --remote="^path) + and stdout = `FD_copy Unix.stdout in + Lwt_process.pread ~stdin:stdout cmd >>= fun contents -> + lwt_ok @@ Response { contents = contents; + content_type = "application/zip"; + caching = Nocache } + | Api.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 @@ -330,7 +357,33 @@ module Request_handler = struct lwt_ok @@ Response { contents = contents; content_type = "application/zip"; caching = Nocache } - | Api.Update_save (session, save) -> + | Api.Update_save (token, save) -> + 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.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 @@ -372,12 +425,30 @@ module Request_handler = struct caching = Nocache }) (fun e -> (`Not_found, Printexc.to_string e)) - | Api.Students_list session -> + | 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 (session, students) -> + | Api.Set_students_list (token, students) -> + 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.Set_students_list_s (session, students) -> wrap_user_session session @@ fun token -> verify_teacher_token token >?= fun () -> Lwt_list.map_s @@ -392,7 +463,74 @@ module Request_handler = struct students >>= Student.Index.set >>= respond_json cache - | Api.Students_csv (session, exercises, students) -> + | Api.Students_csv (token, exercises, students) -> + verify_teacher_token token >?= fun () -> + (match students with + | [] -> Token.Index.get () >|= List.filter Token.is_student + | l -> Lwt.return l) + >>= Lwt_list.map_p (fun token -> + Save.get token >|= fun save -> token, save) + >>= fun tok_saves -> + let all_exercises = + match exercises with + | [] -> + List.fold_left (fun acc (_tok, save) -> + match save with + | None -> acc + | Some save -> + SMap.fold (fun ex_id _ans acc -> SSet.add ex_id acc) + save.Save.all_exercise_states + acc) + SSet.empty tok_saves + |> SSet.elements + | exercises -> exercises + in + let columns = + "token" :: "nickname" :: + (List.fold_left (fun acc ex_id -> + (ex_id ^ " grade") :: + (ex_id ^ " date") :: + acc) + [] (List.rev all_exercises)) + in + let buf = Buffer.create 3497 in + let sep () = Buffer.add_char buf ',' in + let line () = Buffer.add_char buf '\n' in + Buffer.add_string buf (String.concat "," columns); + line (); + Lwt_list.iter_s (fun (tok, save) -> + match save with None -> Lwt.return_unit | Some save -> + Buffer.add_string buf (Token.to_string tok); + sep (); + Buffer.add_string buf save.Save.nickname; + Lwt_list.iter_s (fun ex_id -> + Lwt.catch (fun () -> + sep (); + Exercise.get ex_id >>= fun exo -> + Lwt.wrap2 SMap.find ex_id save.Save.all_exercise_states + >|= fun st -> + (match st.Answer.grade with + | None -> () + | Some grade -> + if match st.Answer.report with + | None -> false + | Some rep -> check_report exo rep grade + then Buffer.add_string buf (string_of_int grade) + else Printf.bprintf buf "CHEAT(%d)" grade); + sep (); + Buffer.add_string buf (string_of_date st.Answer.mtime)) + (function + | Not_found -> sep (); Lwt.return_unit + | e -> raise e)) + all_exercises + >|= line) + tok_saves + >>= fun () -> + lwt_ok @@ + Response {contents = Buffer.contents buf; + content_type = "text/csv"; + caching = Nocache} + | Api.Students_csv_s (session, exercises, students) -> wrap_user_session session @@ fun token -> verify_teacher_token token >?= fun () -> (match students with @@ -461,7 +599,23 @@ module Request_handler = struct content_type = "text/csv"; caching = Nocache} - | Api.Exercise_index (Some session) -> + | Api.Exercise_index (Some 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_s (Some session) -> wrap_user_session session @@ fun token -> Exercise.Index.get () >>= fun index -> Token.check_teacher token >>= (function @@ -480,8 +634,21 @@ module Request_handler = struct >>= respond_json cache | Api.Exercise_index None -> lwt_fail (`Forbidden, "Forbidden") + | Api.Exercise_index_s None -> + lwt_fail (`Forbidden, "Forbidden") - | Api.Exercise (Some session, id, js) -> + | Api.Exercise (Some token, id, js) -> + (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_s (Some session, id, js) -> wrap_user_session session @@ fun token -> (Exercise.Status.is_open id token >>= function | `Open | `Deadline _ as o -> @@ -495,6 +662,8 @@ module Request_handler = struct 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 @@ -511,15 +680,29 @@ module Request_handler = struct | Api.Playground id -> Playground.get id >>= respond_json cache - | Api.Exercise_status_index session -> + | 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 (session, id) -> + | 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 (session, status) -> + | Api.Set_exercise_status (token, status) -> + 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.Set_exercise_status_s (session, status) -> wrap_user_session session @@ fun token -> verify_teacher_token token >?= fun () -> Lwt_list.iter_s @@ -529,7 +712,15 @@ module Request_handler = struct status >>= respond_json cache - | Api.Partition (session, eid, fid, prof) -> + | Api.Partition (token, eid, fid, prof) -> + 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.Partition_s (session, eid, fid, prof) -> wrap_user_session session @@ fun token -> lwt_catch_fail (fun () -> verify_teacher_token token diff --git a/src/state/learnocaml_api.ml b/src/state/learnocaml_api.ml index 6f87d1a3e..f549a21a8 100644 --- a/src/state/learnocaml_api.ml +++ b/src/state/learnocaml_api.ml @@ -101,29 +101,48 @@ type _ request = | Create_token: string * student token option * string option -> student token request | Create_teacher_token: + teacher token * string option -> teacher token request + | Create_teacher_token_s: 'a session * string option -> teacher token request | Login: 'a token -> Session.t request | Fetch_save: + 'a token -> Save.t request + | Fetch_save_s: 'a session -> Save.t request | Get_token: 'a session -> Token.t request | Archive_zip: + 'a token -> string request + | Archive_zip_s: 'a session -> string request | Update_save: + 'a token * Save.t -> Save.t request + | Update_save_s: 'a session * Save.t -> Save.t request | Git: 'a token * string list -> string request | Students_list: + teacher token -> Student.t list request + | Students_list_s: 'a session -> Student.t list request | Set_students_list: + teacher token * (Student.t * Student.t) list -> unit request + | Set_students_list_s: 'a session * (Student.t * Student.t) list -> unit request | Students_csv: + teacher token * Exercise.id list * Token.t list -> string request + | Students_csv_s: 'a session * Exercise.id list * Token.t list -> string request | Exercise_index: + 'a token option -> (Exercise.Index.t * (Exercise.id * float) list) request + | Exercise_index_s: 'a session option -> (Exercise.Index.t * (Exercise.id * float) list) request | Exercise: + 'a token option * string * bool -> + (Exercise.Meta.t * Exercise.t * float option) request + | Exercise_s: 'a session option * string * bool -> (Exercise.Meta.t * Exercise.t * float option) request @@ -143,13 +162,21 @@ type _ request = string -> Playground.t 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: @@ -162,28 +189,41 @@ let supported_versions | Version _ | Nonce _ | Create_token (_, _, _) - | Create_teacher_token _ - | Login _ - | Fetch_save _ - | Get_token _ - | Archive_zip _ - | Update_save (_, _) + | Create_teacher_token _ -> Compat.(Upto (v "2.0")) + | Fetch_save _ -> Compat.(Upto (v "2.0")) + | Archive_zip _ -> Compat.(Upto (v "2.0")) + | Update_save (_, _) -> Compat.(Upto (v "2.0")) | Git (_, _) - | Students_list _ - | Set_students_list (_, _) - | Students_csv (_, _, _) - | Exercise_index _ - | Exercise (_, _, _) + | Students_list _ -> Compat.(Upto (v "2.0")) + | Set_students_list (_, _) -> Compat.(Upto (v "2.0")) + | Students_csv (_, _, _) -> Compat.(Upto (v "2.0")) + | Exercise_index _ -> Compat.(Upto (v "2.0")) + | Exercise (_, _, _) -> Compat.(Upto (v "2.0")) | Lesson_index _ | Lesson _ | Tutorial_index _ | Tutorial _ | Playground_index _ | Playground _ - | Exercise_status_index _ - | Exercise_status (_, _) - | Set_exercise_status (_, _) - | Partition (_, _, _, _) + | Exercise_status_index _ -> Compat.(Upto (v "2.0")) + | Exercise_status (_, _) -> Compat.(Upto (v "2.0")) + | Set_exercise_status (_, _) -> Compat.(Upto (v "2.0")) + | Partition (_, _, _, _) -> Compat.(Upto (v "2.0")) + | Login _ -> Compat.(Since (v "2.0")) + | Get_token _ -> Compat.(Since (v "2.0")) + | Create_teacher_token_s _ -> Compat.(Since (v "2.0")) + | Fetch_save_s _ -> Compat.(Since (v "2.0")) + | Archive_zip_s _ -> Compat.(Since (v "2.0")) + | Update_save_s _ -> Compat.(Since (v "2.0")) + | Students_list_s _ -> Compat.(Since (v "2.0")) + | Set_students_list_s _ -> Compat.(Since (v "2.0")) + | Students_csv_s _ -> Compat.(Since (v "2.0")) + | Exercise_index_s _ -> Compat.(Since (v "2.0")) + | Exercise_s _ -> Compat.(Since (v "2.0")) + | Exercise_status_index_s _ -> Compat.(Since (v "2.0")) + | Exercise_status_s _ -> Compat.(Since (v "2.0")) + | Set_exercise_status_s _ -> Compat.(Since (v "2.0")) + | Partition_s (_, _, _, _) -> Compat.(Since (v "2.0")) | Invalid_request _ -> Compat.(Since (v "0.12")) let is_supported @@ -234,29 +274,48 @@ module Conversions (Json: JSON_CODEC) = struct Token.(to_string, parse) | Create_teacher_token _ -> json J.(obj1 (req "token" string)) +> - Token.(to_string, parse) + Token.(to_string, parse) + | Create_teacher_token_s _ -> + json J.(obj1 (req "token" string)) +> + Token.(to_string, parse) | Login _ -> - json J.(obj1 (req "session" string)) - | Fetch_save _ -> + json J.(obj1 (req "session" string)) + | Fetch_save _ -> + json Save.enc + |Fetch_save_s _ -> json Save.enc | Get_token _ -> json J.(obj1 (req "token" string)) +> Token.(to_string, parse) | Archive_zip _ -> str + | Archive_zip_s _ -> + str | Update_save _ -> json Save.enc + | Update_save_s _ -> + json Save.enc | Git _ -> str | Students_list _ -> json (J.list Student.enc) + | Students_list_s _ -> + json (J.list Student.enc) | Set_students_list _ -> json J.unit + | Set_students_list_s _ -> + json J.unit | Students_csv _ -> str + | Students_csv_s _ -> + str | Exercise_index _ -> json (J.tup2 Exercise.Index.enc (J.assoc J.float)) + | Exercise_index_s _ -> + json (J.tup2 Exercise.Index.enc (J.assoc J.float)) | Exercise _ -> json (J.tup3 Exercise.Meta.enc Exercise.enc (J.option J.float)) + | Exercise_s _ -> + json (J.tup3 Exercise.Meta.enc Exercise.enc (J.option J.float)) | Lesson_index _ -> json Lesson.Index.enc | Lesson _ -> @@ -272,13 +331,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 @@ -313,48 +380,85 @@ module Conversions (Json: JSON_CODEC) = struct | Create_token (secret_candiate, token, nick) -> get ?token (["sync"; "new"; secret_candiate] @ (match nick with None -> [] | Some n -> [n])) - | Create_teacher_token (session, nick) -> - get ~session (["teacher"; "new"] @ + | Create_teacher_token (token, nick) -> + assert (Token.is_teacher token); + get ~token (["teacher"; "new"] @ + (match nick with None -> [] | Some n -> [n])) + | Create_teacher_token_s (session, nick) -> + get ~session (["session"; "teacher"; "new"] @ (match nick with None -> [] | Some n -> [n])) | Login token -> get ~token ["login"] - | Fetch_save session -> - get ~session ["save.json"] + | Fetch_save token -> + get ~token ["save.json"] + | Fetch_save_s session -> + get ~session ["session"; "save.json"] | Get_token session -> get ~session ["token"] - | Archive_zip session -> - get ~session ["archive.zip"] - | Update_save (session, save) -> - post ~session ["sync"] (Json.encode Save.enc save) + | 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 session -> - get ~session ["teacher"; "students.json"] - | Set_students_list (session, students) -> - post ~session + | 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) - | Students_csv (session, exercises, students) -> - post ~session ["teacher"; "students.csv"] + | 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"] + (Json.encode + (J.obj2 + (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 session) -> - get ~session ["exercise-index.json"] + | 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 session, id, js) -> - get ~session + | 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"] @@ -371,21 +475,36 @@ module Conversions (Json: JSON_CODEC) = struct | Tutorial id -> get ["tutorials"; id^".json"] - | Exercise_status_index session -> - get ~session ["teacher"; "exercise-status.json"] - | Exercise_status (session, id) -> - get ~session + | 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) - | Set_exercise_status (session, status) -> - post ~session + | 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 (session, eid, fid, prof) -> - get ~session + | 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) @@ -424,9 +543,9 @@ module Server (Json: JSON_CODEC) (Rh: REQUEST_HANDLER) = struct | Some session -> Some session in match request.meth, request.path, token, session with - | `GET, ([] | [""]), _,_ -> + | `GET, ([] | [""]), _, _ -> Static ["index.html"] |> k - | `GET, ["version"], _, _ -> + | `GET, ["version"], _ , _-> Version () |> k | `GET, ["nonce"], _, _ -> @@ -435,36 +554,70 @@ module Server (Json: JSON_CODEC) (Rh: REQUEST_HANDLER) = struct Create_token (secret_candidate, token, None) |> k | `GET, ["sync"; "new"; secret_candidate; nick], token, _ -> Create_token (secret_candidate, token, Some nick) |> k - | `GET, ["teacher"; "new"], _, Some session -> - Create_teacher_token (session, None) |> k - | `GET, ["teacher"; "new"; nick], _, Some session -> - Create_teacher_token (session, Some nick) |> k + | `GET, ["teacher"; "new"], Some token, _ when Token.is_teacher token -> + Create_teacher_token (token, None) |> k + | `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, ["session"; "teacher"; "new"; nick], _, Some session -> + Create_teacher_token_s (session, Some nick) |> k | `GET, ["login"], Some token, _ -> Login token |> k - | `GET, ["save.json"], _, Some session -> - Fetch_save session |> k + | `GET, ["save.json"], Some token, _-> + Fetch_save token |> k + | `GET, ["session"; "save.json"], _, Some session -> + Fetch_save_s session |> k | `GET, ["token"], _, Some session -> Get_token session |> k - | `GET, ["archive.zip"], _, Some session -> - Archive_zip session |> k - | `POST body, ["sync"], _, Some session -> + | `GET, ["archive.zip"], Some token, _ -> + Archive_zip token |> k + | `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) + | `POST body, ["session"; "sync"], _, Some session -> (match Json.decode Save.enc body with - | save -> Update_save (session, save) |> k + | 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 session -> - Students_list session |> k - | `POST body, ["teacher"; "students.json"], _, Some session -> + | `GET, ["teacher"; "students.json"], Some token, _ + when Token.is_teacher token -> + Students_list token |> k + | `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) + | `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 (session, students) |> k + | 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 + | `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 + (J.dft "exercises" (J.list J.string) []) + (J.dft "students" (J.list Token.enc) [])) + body + with + | exercises, students -> + Students_csv (token, exercises, students) |> k | exception e -> Invalid_request (Printexc.to_string e) |> k) - | `GET, ["teacher"; "students.csv"], _, Some session -> - Students_csv (session, [], []) |> k - | `POST body, ["teacher"; "students.csv"], _, Some session -> + | `POST body, ["session"; "teacher"; "students.csv"], _, Some session -> (match Json.decode (J.obj2 (J.dft "exercises" (J.list J.string) []) @@ -472,19 +625,34 @@ module Server (Json: JSON_CODEC) (Rh: REQUEST_HANDLER) = struct body with | exercises, students -> - Students_csv (session, exercises, students) |> k + Students_csv_s (session, exercises, students) |> k | exception e -> Invalid_request (Printexc.to_string e) |> k) - | `GET, ["exercise-index.json"], _, session -> - Exercise_index session |> k - | `GET, ("exercises"::path), _, session -> + | `GET, ["exercise-index.json"], token, _ -> + Exercise_index token |> k + | `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 + | Some token -> + let id = Filename.chop_suffix (String.concat "/" path) ".json" in + let js = List.assoc_opt "mode" request.args = Some "js" in + Exercise (Some token, id, js) |> k + | None -> Invalid_request "Missing token" |> k) + | Some "" -> + Static ["exercise.html"] |> k + | _ -> + Static ("static"::path) |> k) + | `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 (Some session, id, js) |> k + Exercise_s (Some session, id, js) |> k | None -> Invalid_request "Missing session" |> k) | Some "" -> Static ["exercise.html"] |> k @@ -520,20 +688,38 @@ module Server (Json: JSON_CODEC) (Rh: REQUEST_HANDLER) = struct | `GET, ["playgrounds"; f], _, _ when Filename.check_suffix f ".json" -> Playground (Filename.chop_suffix f ".json") |> k - | `GET, ["partition"; eid; fid; prof], _, Some session -> - Partition (session, eid, fid, int_of_string prof) |> k - - | `GET, ["teacher"; "exercise-status.json"], _, Some session -> - Exercise_status_index session |> k - | `GET, ("teacher" :: "exercise-status" :: id), _, Some session -> - Exercise_status (session, String.concat "/" id) |> k - | `POST body, ["teacher"; "exercise-status"], _, Some session -> + | `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, _ + when Token.is_teacher token -> + Exercise_status_index token |> k + | `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 + | `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)) + body + with + | 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 (session, status) |> k + Set_exercise_status_s (session, status) |> k | exception e -> Invalid_request (Printexc.to_string e) |> k) | `GET, diff --git a/src/state/learnocaml_api.mli b/src/state/learnocaml_api.mli index 16911bcf2..31d14549f 100644 --- a/src/state/learnocaml_api.mli +++ b/src/state/learnocaml_api.mli @@ -87,32 +87,51 @@ type _ request = | Create_token: string * student token option * string option -> student token request | Create_teacher_token: + teacher token * string option -> teacher token request + | Create_teacher_token_s: 'a session * string option -> teacher token request | Login: 'a token -> Session.t request | Fetch_save: + 'a token -> Save.t request + | Fetch_save_s: 'a session -> Save.t request | Get_token: 'a session -> Token.t request | Archive_zip: + 'a token -> string request + | Archive_zip_s: 'a session -> string request | Update_save: + 'a token * Save.t -> Save.t request + | Update_save_s: 'a session * Save.t -> Save.t request | Git: 'a token * string list -> string request | Students_list: + teacher token -> Student.t list request + | Students_list_s: 'a session -> Student.t list request | Set_students_list: + teacher token * (Student.t * Student.t) list -> unit request + | Set_students_list_s: 'a session * (Student.t * Student.t) list -> unit request (** Does not affect the students absent from the list. the pairs are the before/after states, used for merging *) | Students_csv: + teacher token * Exercise.id list * Token.t list -> string request + | Students_csv_s: 'a session * Exercise.id list * Token.t list -> string request | Exercise_index: + 'a token option -> (Exercise.Index.t * (Exercise.id * float) list) request + | Exercise_index_s: 'a session option -> (Exercise.Index.t * (Exercise.id * float) list) request | Exercise: + 'a token option * string * bool -> + (Exercise.Meta.t * Exercise.t * float option) request + | Exercise_s: 'a session option * string * bool -> (Exercise.Meta.t * Exercise.t * float option) request @@ -132,16 +151,25 @@ type _ request = string -> Playground.t 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: From de81b65a1a4613330fc30c8b513fca6ab67abf6f Mon Sep 17 00:00:00 2001 From: Nassim Mourabit Date: Tue, 29 Apr 2025 22:54:37 +0200 Subject: [PATCH 11/29] feat(ui): auto-migrate legacy to v2 session auth --- src/app/learnocaml_index_main.ml | 36 ++++++++++++++++++++++++++++ src/app/learnocaml_local_storage.ml | 10 ++++++++ src/app/learnocaml_local_storage.mli | 2 ++ 3 files changed, 48 insertions(+) diff --git a/src/app/learnocaml_index_main.ml b/src/app/learnocaml_index_main.ml index 31629fdcc..7a8a3eaed 100644 --- a/src/app/learnocaml_index_main.ml +++ b/src/app/learnocaml_index_main.ml @@ -799,6 +799,41 @@ let init_sync_session button_group = Lwt.return (Some session)) (fun _ -> Lwt.return None) +(** [migrate_from_legacy_token] runs once to move old browsers + that still keep the old [sync-token] (v 1.x and earlier) + over to the new session-based login used since Learn-OCaml 2.0. *) +let migrate_from_legacy_token () = + let token = + try + Some (Learnocaml_local_storage.(retrieve sync_token)) + with Not_found -> None + in + match token with + | None -> Lwt.return () + | Some token -> + Server_caller.request (Learnocaml_api.Login token) >>= function + | Error e -> + Learnocaml_common.alert + ~title:[%i"Migration error"] + (Server_caller.string_of_error e); + Lwt.return_unit + + | Ok session -> + Learnocaml_local_storage.(delete sync_token); + Learnocaml_local_storage.(store sync_session session); + Learnocaml_local_storage.(store is_teacher (Learnocaml_data.Token.is_teacher token)); + + Server_caller.request (Learnocaml_api.Fetch_save_s session) >>= (function + | Ok save -> + set_state_from_save_file ~session save; + Learnocaml_common.alert + ~title:[%i"Connection preserved"] + [%i"The application has been upgraded to a session-based \ + authentication. Your previous connection was restored"]; + Lwt.return_unit + | Error _ -> + Lwt.return_unit) + let set_string_translations () = let configured v s = Js.Optdef.case v (fun () -> s) Js.to_string in let translations = [ @@ -855,6 +890,7 @@ let () = Js.string ("Learn OCaml" ^ " v"^Learnocaml_api.version); Manip.setInnerText El.version ("v"^Learnocaml_api.version); Learnocaml_local_storage.init () ; + migrate_from_legacy_token () >>= fun () -> let sync_button_group = button_group () in disable_button_group sync_button_group; let menu_hidden = ref true in diff --git a/src/app/learnocaml_local_storage.ml b/src/app/learnocaml_local_storage.ml index 24ef276e2..4e28350fc 100644 --- a/src/app/learnocaml_local_storage.ml +++ b/src/app/learnocaml_local_storage.ml @@ -142,6 +142,16 @@ 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 + let store value = store_single key enc (Token.to_string value) + and retrieve () = retrieve_single key enc () |> Token.parse + and delete () = delete_single key enc () in + { 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 diff --git a/src/app/learnocaml_local_storage.mli b/src/app/learnocaml_local_storage.mli index 94f5f7ec7..986475c45 100644 --- a/src/app/learnocaml_local_storage.mli +++ b/src/app/learnocaml_local_storage.mli @@ -55,6 +55,8 @@ val all_toplevel_histories : Learnocaml_toplevel_history.snapshot SMap.t storage 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 From e86c0d169b89cb8576600c7d4f65816d1fa0f049 Mon Sep 17 00:00:00 2001 From: Nassim Mourabit Date: Mon, 26 May 2025 10:47:01 +0200 Subject: [PATCH 12/29] deps(opam): Add Irmin-git 3.10.0 This change needed to refactor the decompress-based deflate encoding --- learn-ocaml-client.opam.locked | 38 +++++---- learn-ocaml.opam | 3 +- learn-ocaml.opam.locked | 136 ++++++++++++++++++++++++-------- src/server/dune | 3 +- src/server/learnocaml_server.ml | 65 ++++++++------- 5 files changed, 162 insertions(+), 83 deletions(-) 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 e24b7933b..d44b311a4 100644 --- a/learn-ocaml.opam +++ b/learn-ocaml.opam @@ -30,12 +30,13 @@ depends: [ "conduit-lwt-unix" {< "7.1.0"} "conf-git" "cryptokit" - "decompress" {= "0.8.1"} + "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 16eed9cde..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,23 +36,31 @@ 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"} @@ -55,23 +69,55 @@ depends: [ "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"} @@ -83,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"} @@ -96,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"} @@ -108,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"} @@ -124,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"} @@ -147,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"} @@ -155,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"} ] @@ -164,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/server/dune b/src/server/dune index 2efd24516..5593095ae 100644 --- a/src/server/dune +++ b/src/server/dune @@ -11,7 +11,8 @@ magic-mime sha checkseum.c - decompress + decompress.de + decompress.zl learnocaml_report learnocaml_data learnocaml_api diff --git a/src/server/learnocaml_server.ml b/src/server/learnocaml_server.ml index 43d0b4f21..87db973a2 100644 --- a/src/server/learnocaml_server.ml +++ b/src/server/learnocaml_server.ml @@ -22,8 +22,7 @@ let args = Arg.align @@ "PATH where static files should be found (./www)" ; "-sync-dir", Arg.Set_string sync_dir, "PATH where sync tokens are stored (./sync)" ; - "-base-url", Arg.Set_string base_url, - "BASE_URL of the website. \ + "-base-url", Arg.Set_string base_url,"BASE_URL of the website. \ Should not end with a trailing slash. \ Currently, this has no effect on the native backend. \ Mandatory for 'learn-ocaml build' if the site is not hosted in path '/', \ @@ -785,36 +784,44 @@ let last_modified = (* server startup time *) (tm.tm_year + 1900) tm.tm_hour tm.tm_min tm.tm_sec -(* Taken from the source of "decompress", from bin/easy.ml *) +(* Adapted from the source of "decompress.1.5.3", from bin/decompress.ml *) let compress ?(level = 4) data = - let input_buffer = Bytes.create 0xFFFF in - let output_buffer = Bytes.create 0xFFFF in - - let pos = ref 0 in - let res = Buffer.create (String.length data) in - + let bigstring_output o off len buf = + let res = Bytes.create len in + for i = 0 to len - 1 do + Bytes.set res i o.{off + i} + done + ; Buffer.add_bytes buf res in + let src_len = String.length data in + let dst_bound = max (De.Def.Ns.compress_bound src_len) De.io_buffer_size in + let o = De.bigstring_create dst_bound in + (* buffer.mli: nothing bad will happen if the buffer grows beyond that limit: *) + let buf = Buffer.create dst_bound in + (* de.mli: we recommend a queue as large as output buffer: *) + let q = De.Queue.create De.io_buffer_size in + (* LZ77 with a 32.kB sliding-window compression: *) + let w = De.Lz77.make_window ~bits:15 in + let open Zl in + let encoder = Def.encoder (`String data) `Manual ~q ~w ~level in + let rec go encoder = + match Def.encode encoder with + | `Await _encoder -> + Error "Zl.Def.encode: could not compress" + | `Flush encoder -> + let len = De.io_buffer_size - Def.dst_rem encoder in + bigstring_output o 0 len buf + ; Def.dst encoder o 0 De.io_buffer_size |> go + | `End encoder -> + let len = De.io_buffer_size - Def.dst_rem encoder in + if len > 0 then bigstring_output o 0 len buf + ; Ok (Buffer.contents buf) in Lwt_preemptive.detach - (Decompress.Zlib_deflate.bytes - input_buffer - output_buffer - (fun input_buffer -> function - | Some max -> - let n = min max (min 0xFFFF (String.length data - !pos)) in - Bytes.blit_string data !pos input_buffer 0 n; - pos := !pos + n; - n - | None -> - let n = min 0xFFFF (String.length data - !pos) in - Bytes.blit_string data !pos input_buffer 0 n; - pos := !pos + n; - n) - (fun output_buffer len -> - Buffer.add_subbytes res output_buffer 0 len; - 0xFFFF)) - (Decompress.Zlib_deflate.default ~witness:Decompress.B.bytes level) + (fun () -> + Def.dst encoder o 0 De.io_buffer_size |> go) + () >>= function - | Ok _ -> Lwt.return (Buffer.contents res) - | Error _ -> Lwt.fail_with "Could not compress" + | Ok str -> Lwt.return str + | Error e -> Lwt.fail_with e let launch () = Random.self_init () ; From c4839ff02c17246343a2e5c32846cd952a265750 Mon Sep 17 00:00:00 2001 From: Nassim Mourabit Date: Wed, 28 May 2025 10:04:24 +0200 Subject: [PATCH 13/29] feat(state): Store session-token links using Irmin instead of JSON file Replace the JSON-based storage of session-token-date entries with an Irmin Git-backed key-value store. Sessions are no longer stored in 'sessions.json' but in an Irmin Git repository ('session_store.git' by default). Credits: this patch reuses code from oauth-moodle-dev by the following authors. Co-authored-by: Louis Tariot <77079482+Plictox@users.noreply.github.com> --- src/state/dune | 2 +- src/state/learnocaml_store.ml | 66 +++++++++++++++++----------------- src/state/learnocaml_store.mli | 21 +++++------ 3 files changed, 42 insertions(+), 47 deletions(-) diff --git a/src/state/dune b/src/state/dune index ce489d524..55e281e38 100644 --- a/src/state/dune +++ b/src/state/dune @@ -40,5 +40,5 @@ (name learnocaml_store) (wrapped false) (modules Learnocaml_store) - (libraries cryptokit lwt_utils learnocaml_api) + (libraries cryptokit lwt_utils learnocaml_api irmin irmin-git irmin-git.unix) ) diff --git a/src/state/learnocaml_store.ml b/src/state/learnocaml_store.ml index 195d143c5..76e422657 100644 --- a/src/state/learnocaml_store.ml +++ b/src/state/learnocaml_store.ml @@ -302,50 +302,50 @@ end module Session = struct include Session + open Lwt.Syntax - let file = "sessions.json" + module Store = Irmin_git_unix.FS.KV(Irmin.Contents.Json_value) + module Info = Irmin_git_unix.Info(Store.Info) - let enc = - let open Json_encoding in - list (obj3 - (req "session" Session.enc) - (req "token" Token.enc) - (req "last_connection" float)) - - let path dir = Filename.concat dir file - - let load dir = - let p = path dir in - Lwt_unix.file_exists dir >>= fun dir_exists -> - (if not dir_exists then Lwt_unix.mkdir dir 0o700 else Lwt.return_unit) >>= fun () -> - Lwt_unix.file_exists p >>= function - | false -> - Printf.printf "No session file, creating empty list\n%!"; - Lwt.return [] - | true -> - Printf.printf "Loading sessions from: %s\n%!" p; - get_from_file enc p + let repo_path = ref "./session_store.git" - let save dir table = - write_to_file enc table (path dir) + let config () = Irmin_git.config ~bare:true !repo_path - let get_user_token session = - load !data_dir >>= fun table -> - match List.find_opt (fun (s, _, _) -> s = session) table with - | Some (_, token, _) -> Lwt.return_some token - | None -> Lwt.return_none + 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 - load !data_dir >>= fun table -> - let table = (session, token, now) :: table in - save !data_dir table + 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 () - + |> Cryptokit.transform_string @@ Cryptokit.Hexa.encode () end module Token = struct diff --git a/src/state/learnocaml_store.mli b/src/state/learnocaml_store.mli index 68ed24542..7cefa1918 100644 --- a/src/state/learnocaml_store.mli +++ b/src/state/learnocaml_store.mli @@ -116,17 +116,12 @@ module Session: sig include module type of struct include Session end - val file : string - - val enc : (t * Token.t * float) list Json_encoding.encoding - - val path : string -> string - - (** Loads the session table from disk. *) - val load : string -> (t * Token.t * float) list Lwt.t - - (** Saves the given session table to disk *) - val save : string -> (t * Token.t * float) list -> unit Lwt.t + 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 @@ -134,8 +129,8 @@ module Session: sig (** Associates a token to a session. *) val set_session : t -> Token.t -> unit Lwt.t - (** Generates a fresh session identifier *) - val gen_session : unit -> t + (** Generates a fresh session identifier *) + val gen_session : unit -> Session.t end From e3aa5326f979cbd91c522f4e84006aa82952d2b9 Mon Sep 17 00:00:00 2001 From: Erik Martin-Dorel Date: Tue, 3 Jun 2025 17:23:11 +0200 Subject: [PATCH 14/29] build(docker): Bump alpine-3.20 -> alpine-3.21 as `ocaml/opam:alpine-3.20-*` images are now 6-month old: cf. https://hub.docker.com/r/ocaml/opam/tags?name=alpine-3.20 which caused some CI build issue due to a too-old version of opam: cf. https://github.com/ocaml-sf/learn-ocaml/actions/runs/15413403948/job/43370458368#step:3:122 --- Dockerfile | 6 +++--- Dockerfile.test-client | 4 ++-- Dockerfile.test-server | 4 ++-- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/Dockerfile b/Dockerfile index fb44dd51a..03239da45 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,4 +1,4 @@ -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 @@ -28,7 +28,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,7 +45,7 @@ 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 \ diff --git a/Dockerfile.test-client b/Dockerfile.test-client index 82da27115..a5c42df90 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 @@ -34,7 +34,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..45cb76808 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 @@ -37,7 +37,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 From 0000ded4bf98f509f54ca235edb91c13ab2ba5d0 Mon Sep 17 00:00:00 2001 From: Erik Martin-Dorel Date: Tue, 3 Jun 2025 17:37:34 +0200 Subject: [PATCH 15/29] build(docker): Use opam-2.3 and run `opam init --reinit -ni` first Otherwise, we get: ``` The following dependencies couldn't be met: - learn-ocaml -> mirage-runtime = 4.8.2 unmet availability conditions: opam-version >= "2.1.0" ``` Related: https://github.com/ocaml-sf/learn-ocaml/actions/runs/15421443343/job/43397321956?pr=610#step:3:163 Related: https://github.com/ocurrent/docker-base-images/issues/132 Related: https://github.com/ocurrent/docker-base-images/blob/02a40d239bbb8dd2700d9bfaa7511926a84eca7b/Dockerfile#L3 --- Dockerfile | 1 + Dockerfile.test-client | 1 + Dockerfile.test-server | 1 + 3 files changed, 3 insertions(+) diff --git a/Dockerfile b/Dockerfile index 03239da45..fd51ff089 100644 --- a/Dockerfile +++ b/Dockerfile @@ -5,6 +5,7 @@ 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 \ diff --git a/Dockerfile.test-client b/Dockerfile.test-client index a5c42df90..2c60a2ed5 100644 --- a/Dockerfile.test-client +++ b/Dockerfile.test-client @@ -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 \ diff --git a/Dockerfile.test-server b/Dockerfile.test-server index 45cb76808..d92e2f776 100644 --- a/Dockerfile.test-server +++ b/Dockerfile.test-server @@ -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 \ From 57cb49ab612bce857b28d3c303c25d2ffd5799e1 Mon Sep 17 00:00:00 2001 From: Erik Martin-Dorel Date: Tue, 3 Jun 2025 17:51:16 +0200 Subject: [PATCH 16/29] build(macos): Add missing system packages for {conf-libffi,conf-zlib} --- .ci-macosx.sh | 3 +++ .github/workflows/static-builds.yml | 1 + 2 files changed, 4 insertions(+) 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: | From 7ce615a7a8a6c7322f1ed1015aa7bbd0a16ca539 Mon Sep 17 00:00:00 2001 From: Erik Martin-Dorel Date: Tue, 3 Jun 2025 18:20:02 +0200 Subject: [PATCH 17/29] refactor(Learnocaml_store): Move Json_codec to Learnocaml_api Motivation: - Learnocaml_store contained Json_codec - learnocaml_client.ml relies on Json_codec - Learnocaml_store depends on Learnocaml_api - Learnocaml_store pulls irmin-git.unix and cryptokit - unlike Learnocaml_api - and these two dependencies are unneeded for compiling learnocaml_client.ml --- src/main/dune | 1 - src/main/learnocaml_client.ml | 2 +- src/server/learnocaml_server.ml | 2 +- src/state/learnocaml_api.ml | 17 +++++++++++++++++ src/state/learnocaml_api.mli | 3 +++ src/state/learnocaml_store.ml | 23 +++++------------------ src/state/learnocaml_store.mli | 2 +- 7 files changed, 28 insertions(+), 22 deletions(-) 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/learnocaml_server.ml b/src/server/learnocaml_server.ml index 87db973a2..93c56101a 100644 --- a/src/server/learnocaml_server.ml +++ b/src/server/learnocaml_server.ml @@ -754,7 +754,7 @@ module Request_handler = struct end -module Api_server = Api.Server (Json_codec) (Request_handler) +module Api_server = Api.Server (Api.Json_codec) (Request_handler) let init_teacher_token () = Token.Index.get () >>= function tokens -> diff --git a/src/state/learnocaml_api.ml b/src/state/learnocaml_api.ml index f549a21a8..f97e87d4d 100644 --- a/src/state/learnocaml_api.ml +++ b/src/state/learnocaml_api.ml @@ -253,6 +253,23 @@ module type JSON_CODEC = sig val encode: ?minify:bool -> 'a J.encoding -> 'a -> string end +(* Erik: Json_codec was initially in learnocaml_store.ml, + which induced unneeded dependencies: + learn-ocaml-client -> irmin-git.unix, cryptokit *) +module Json_codec = struct + let decode enc s = + (match s with + | "" -> `O [] + | s -> Ezjsonm.from_string s) + |> J.destruct enc + + let encode ?minify enc x = + match J.construct enc x with + | `A _ | `O _ as json -> Ezjsonm.to_string ?minify json + | `Null -> "" + | _ -> assert false +end + module Conversions (Json: JSON_CODEC) = struct let response_codec diff --git a/src/state/learnocaml_api.mli b/src/state/learnocaml_api.mli index 31d14549f..b22108c97 100644 --- a/src/state/learnocaml_api.mli +++ b/src/state/learnocaml_api.mli @@ -196,6 +196,9 @@ module type JSON_CODEC = sig val encode: ?minify:bool -> 'a Json_encoding.encoding -> 'a -> string end +(** Used both for file i/o and request handling *) +module Json_codec: JSON_CODEC + module type REQUEST_HANDLER = sig type 'resp ret diff --git a/src/state/learnocaml_store.ml b/src/state/learnocaml_store.ml index 76e422657..c4da13e09 100644 --- a/src/state/learnocaml_store.ml +++ b/src/state/learnocaml_store.ml @@ -17,26 +17,13 @@ let sync_dir = ref (Filename.concat (Sys.getcwd ()) "sync") let data_dir = ref (Filename.concat !sync_dir "data") -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 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 = @@ -217,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 = @@ -503,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) @@ -566,7 +553,7 @@ module Student = struct let save () = Lazy.force map >>= fun map -> - let s = Json_codec.encode store_enc !map in + let s = Learnocaml_api.Json_codec.encode store_enc !map in write (store_file ()) s let get_student map token = diff --git a/src/state/learnocaml_store.mli b/src/state/learnocaml_store.mli index 7cefa1918..37ced23f0 100644 --- a/src/state/learnocaml_store.mli +++ b/src/state/learnocaml_store.mli @@ -20,7 +20,7 @@ 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 From d15c58832eb18d72fa4f4d75708d753bf4455772 Mon Sep 17 00:00:00 2001 From: Erik Martin-Dorel Date: Wed, 4 Jun 2025 00:15:07 +0200 Subject: [PATCH 18/29] deps(docker): Add gmp alpine package Otherwise we'd get: ``` Error loading shared library libgmp.so.10: No such file or directory (needed by /usr/bin/learn-ocaml) ``` cf. https://github.com/ocaml-sf/learn-ocaml/actions/runs/15428646832/job/43421680304?pr=610 --- Dockerfile | 2 +- Dockerfile.test-server | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Dockerfile b/Dockerfile index fd51ff089..6740b96db 100644 --- a/Dockerfile +++ b/Dockerfile @@ -49,7 +49,7 @@ ENTRYPOINT ["dumb-init","/usr/bin/learn-ocaml-client"] 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-server b/Dockerfile.test-server index d92e2f776..9525d4a33 100644 --- a/Dockerfile.test-server +++ b/Dockerfile.test-server @@ -55,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 From b3552ace721d2b72a7ed7e7dff7790e19957e754 Mon Sep 17 00:00:00 2001 From: Nassim Mourabit Date: Mon, 21 Jul 2025 09:33:45 +0200 Subject: [PATCH 19/29] feat(state): add LtiIndex and TokenIndex modules for external authentication support Introduce LtiIndex to map external LTI user IDs to tokens, and TokenIndex to manage token associations with multiple authentication methods (e.g. idmoodle, email). This enables future support for LTI and other authentication workflows. Credits: this patch reuses code from oauth-moodle-dev by the following authors. Co-authored-by: Alban Gruin <6310153+agrn@users.noreply.github.com> Co-authored-by: Erik Martin-Dorel --- src/state/learnocaml_store.ml | 159 +++++++++++++++++++++++++++++++++ src/state/learnocaml_store.mli | 48 ++++++++++ 2 files changed, 207 insertions(+) diff --git a/src/state/learnocaml_store.ml b/src/state/learnocaml_store.ml index c4da13e09..df17b021e 100644 --- a/src/state/learnocaml_store.ml +++ b/src/state/learnocaml_store.ml @@ -596,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 37ced23f0..8a18893cc 100644 --- a/src/state/learnocaml_store.mli +++ b/src/state/learnocaml_store.mli @@ -202,3 +202,51 @@ module Student: sig val set: t -> unit Lwt.t end + +module LtiIndex: sig + + (** 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 From 922f6de79ceaf56ea12410773a128762f7b24572 Mon Sep 17 00:00:00 2001 From: Nassim Mourabit Date: Mon, 21 Jul 2025 09:41:13 +0200 Subject: [PATCH 20/29] feat(api): add LTI authentication endpoints to request type and conversions Introduce endpoints for authentication workflows (launch, associate, login, register) in the API. --- src/state/learnocaml_api.ml | 39 ++++++++++++++++++++++++++++-------- src/state/learnocaml_api.mli | 10 +++++++-- 2 files changed, 39 insertions(+), 10 deletions(-) diff --git a/src/state/learnocaml_api.ml b/src/state/learnocaml_api.ml index f97e87d4d..78083817c 100644 --- a/src/state/learnocaml_api.ml +++ b/src/state/learnocaml_api.ml @@ -104,8 +104,14 @@ type _ request = teacher token * string option -> teacher token request | Create_teacher_token_s: 'a session * string option -> teacher token request - | Login: - 'a token -> Session.t 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: @@ -209,7 +215,10 @@ let supported_versions | 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")) @@ -295,8 +304,10 @@ module Conversions (Json: JSON_CODEC) = struct | Create_teacher_token_s _ -> json J.(obj1 (req "token" string)) +> Token.(to_string, parse) - | Login _ -> - json J.(obj1 (req "session" string)) + | Launch _ -> str + | Associate _ -> str + | Login _ -> str + | Register _ -> str | Fetch_save _ -> json Save.enc |Fetch_save_s _ -> @@ -404,8 +415,14 @@ module Conversions (Json: JSON_CODEC) = struct | Create_teacher_token_s (session, nick) -> get ~session (["session"; "teacher"; "new"] @ (match nick with None -> [] | Some n -> [n])) - | Login token -> - get ~token ["login"] + | 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 -> @@ -579,8 +596,14 @@ module Server (Json: JSON_CODEC) (Rh: REQUEST_HANDLER) = struct Create_teacher_token (token, Some nick) |> k | `GET, ["session"; "teacher"; "new"; nick], _, Some session -> Create_teacher_token_s (session, Some nick) |> k - | `GET, ["login"], Some token, _ -> - Login token |> 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, ["session"; "save.json"], _, Some session -> diff --git a/src/state/learnocaml_api.mli b/src/state/learnocaml_api.mli index b22108c97..f0ff6c1e5 100644 --- a/src/state/learnocaml_api.mli +++ b/src/state/learnocaml_api.mli @@ -90,8 +90,14 @@ type _ request = teacher token * string option -> teacher token request | Create_teacher_token_s: 'a session * string option -> teacher token request - | Login: - 'a token -> Session.t 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: From 6bd22c89b79df563342ade95187cfa1e2eacf57e Mon Sep 17 00:00:00 2001 From: Nassim Mourabit Date: Mon, 21 Jul 2025 09:49:24 +0200 Subject: [PATCH 21/29] feat(ui): add LTI login, registration (and association) forms in HTML template MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Add support for LTI user registration and token association in the login overlay, enabling direct and indirect LTI login workflows. Credits: this patch reuses code from oauth-moodle-dev by the following authors. Co-authored-by: Alban Gruin <6310153+agrn@users.noreply.github.com> Co-authored-by: Erik Martin-Dorel Co-authored-by: Léo Segond --- src/app/learnocaml_index_main.ml | 45 +++++++++++++++++++---- static/lti.html | 61 ++++++++++++++++++++++++++++++++ 2 files changed, 100 insertions(+), 6 deletions(-) create mode 100644 static/lti.html diff --git a/src/app/learnocaml_index_main.ml b/src/app/learnocaml_index_main.ml index 7a8a3eaed..ea904b8e9 100644 --- a/src/app/learnocaml_index_main.ml +++ b/src/app/learnocaml_index_main.ml @@ -737,7 +737,9 @@ let init_token_dialog () = Manip.SetCss.borderColor input "#f44"; Lwt.return_none | token -> - Server_caller.request (Learnocaml_api.Login token) >>= function + 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); @@ -788,13 +790,41 @@ let init_token_dialog () = 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_session button_group = catch (fun () -> - begin try - Lwt.return (Learnocaml_local_storage.(retrieve sync_session)) - with Not_found -> init_token_dialog () - end >>= fun session -> + 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 session)) (fun _ -> Lwt.return None) @@ -811,7 +841,9 @@ let migrate_from_legacy_token () = match token with | None -> Lwt.return () | Some token -> - Server_caller.request (Learnocaml_api.Login token) >>= function + 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"] @@ -1034,6 +1066,7 @@ let () = (fun () -> Lwt.async @@ fun () -> Learnocaml_local_storage.clear (); + delete_cookie "session"; reload (); Lwt.return_unit) in 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 From 6864ce6e39d95a08f0e828d2b0791a02ca3e362c Mon Sep 17 00:00:00 2001 From: Nassim Mourabit Date: Mon, 21 Jul 2025 10:06:54 +0200 Subject: [PATCH 22/29] feat(auth): modular authentication framework, LTI entrypoints, and API handler refactor MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Introduce a modular authentication layer (learnocaml_auth) with initial LTI (Moodle) support. Add Launch and Login endpoints to the server for new auth methods. Refactor API request handling to pass structured http_request and support future extensibility. Credits: this patch reuses code from oauth-moodle-dev by the following authors. Co-authored-by: Alban Gruin <6310153+agrn@users.noreply.github.com> Co-authored-by: Léo Segond --- src/server/learnocaml_auth.ml | 130 +++++++++++++++++ src/server/learnocaml_auth.mli | 29 ++++ src/server/learnocaml_server.ml | 245 +++++++++++++++++++++++++++----- src/state/learnocaml_api.ml | 7 +- src/state/learnocaml_api.mli | 4 +- 5 files changed, 376 insertions(+), 39 deletions(-) create mode 100644 src/server/learnocaml_auth.ml create mode 100644 src/server/learnocaml_auth.mli diff --git a/src/server/learnocaml_auth.ml b/src/server/learnocaml_auth.ml new file mode 100644 index 000000000..c9100fc74 --- /dev/null +++ b/src/server/learnocaml_auth.ml @@ -0,0 +1,130 @@ +(* 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 decoder = Cryptokit.Hexa.decode () in + let secret = Cryptokit.transform_string decoder secret in + 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 get_token id = + LtiIndex.get_user_token id >>= function + | Some token -> Lwt.return (Ok token) + | None -> Lwt.return (Error "Token not found") + + let login (_:login_credentials) = Lwt.return (Error "TODO: implement LtiAuth.login") + + let register (params:register_credentials) = + Lwt.return (Error "TODO: implement LtiAuth.register") + + let associate (params:associate_credentials) = + Lwt.return (Error "TODO: implement LtiAuth.associate") + + (** 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 = + 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 () -> + NonceIndex.get_current_secret () >|= + signature_oauth args "post" url >>= fun s -> + if Eqaf.equal s oauth_args.signature || true (* EMD: temporary fix; FIXME *) then + Lwt.return (Ok (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..33492c166 --- /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) result Lwt.t +end diff --git a/src/server/learnocaml_server.ml b/src/server/learnocaml_server.ml index 93c56101a..7adb7b2c1 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 @@ -32,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) @@ -75,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) @@ -122,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 @@ -182,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) = @@ -202,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" @@ -237,10 +253,10 @@ module Request_handler = struct | 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 -> @@ -302,19 +318,148 @@ module Request_handler = struct | Some nickname -> Save.set tok Save.{empty with nickname}) >>= fun () -> respond_json cache tok - | Api.Login token -> - lwt_catch_fail - (fun () -> - Token.exists token >>= fun exists -> - lwt_option_fail - (if exists then Some token else None) - (`Not_found, "Token does not exist") - @@ fun token -> - let session = Session.gen_session () in - Session.set_session session token >>= fun () -> - respond_json cache session - ) - (fun exn -> (`Internal_server_error, Printexc.to_string exn)) + | Api.Launch body -> + (* 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 + LtiAuth.check_oauth ("localhost:8080" ^ "/launch") params >>= + (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.Associate body -> + lwt_fail (`Forbidden, "Not implemented yet") + | 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 -> + lwt_fail (`Forbidden, "Not implemented yet") | Api.Fetch_save token -> lwt_catch_fail (fun () -> @@ -345,7 +490,8 @@ 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 -> @@ -355,7 +501,8 @@ 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.Update_save (token, save) -> let save = Save.fix_mtimes save in let exercise_states = SMap.bindings save.Save.all_exercise_states in @@ -421,7 +568,8 @@ 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 -> @@ -528,7 +676,8 @@ 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 () -> @@ -596,7 +745,8 @@ module Request_handler = struct lwt_ok @@ Response {contents = Buffer.contents buf; content_type = "text/csv"; - caching = Nocache} + caching = Nocache; + cookies = [] } | Api.Exercise_index (Some token) -> Exercise.Index.get () >>= fun index -> @@ -734,12 +884,13 @@ module Request_handler = struct 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") @@ -825,6 +976,9 @@ let compress ?(level = 4) data = 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 @@ -848,8 +1002,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 _ -> @@ -864,10 +1018,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 @@ -899,19 +1055,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/learnocaml_api.ml b/src/state/learnocaml_api.ml index 78083817c..a3892f659 100644 --- a/src/state/learnocaml_api.ml +++ b/src/state/learnocaml_api.ml @@ -251,6 +251,7 @@ let is_supported type http_request = { meth: [ `GET | `POST of string]; + host: string; path: string list; args: (string * string) list; } @@ -387,12 +388,14 @@ module Conversions (Json: JSON_CODEC) = struct = let get ?token ?session ?(args=[]) path = { meth = `GET; + host = ""; path; 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 ?session path body = { meth = `POST body; + host = ""; path; args = (match token with None -> [] | Some t -> ["token", Token.to_string t]) @ (match session with None -> [] | Some s -> ["session", s]); @@ -550,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 @@ -562,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 diff --git a/src/state/learnocaml_api.mli b/src/state/learnocaml_api.mli index f0ff6c1e5..025eec180 100644 --- a/src/state/learnocaml_api.mli +++ b/src/state/learnocaml_api.mli @@ -193,6 +193,7 @@ val is_supported: type http_request = { meth: [ `GET | `POST of string]; + host: string; path: string list; args: (string * string) list; } @@ -210,8 +211,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 + val callback: Conduit.endp -> Learnocaml_data.Server.config -> http_request -> 'resp request -> 'resp ret end module Server: functor (_: JSON_CODEC) (Rh: REQUEST_HANDLER) -> sig From bae56c63599943ec853700d447d4e3e3d81957a9 Mon Sep 17 00:00:00 2001 From: Nassim Mourabit Date: Mon, 21 Jul 2025 10:12:02 +0200 Subject: [PATCH 23/29] feat(auth,lti): implement LTI-token association and modularize authentication linking - Add learnocaml_auth as a separate library with its dependencies in dune. - Implement secure association between legacy tokens and LTI accounts (Moodle) in the backend. - Improve logic and handle POST /associate route with checks and session management. - Prepare future extensibility for additional authentication methods (email, etc). Credits: this patch reuses code from oauth-moodle-dev by the following authors. Co-authored-by: Alban Gruin <6310153+agrn@users.noreply.github.com> Co-authored-by: Erik Martin-Dorel --- src/server/dune | 14 +++++++++- src/server/learnocaml_auth.ml | 20 ++++++++++++++- src/server/learnocaml_server.ml | 45 ++++++++++++++++++++++++++++++++- 3 files changed, 76 insertions(+), 3 deletions(-) diff --git a/src/server/dune b/src/server/dune index 5593095ae..ac31ff3b1 100644 --- a/src/server/dune +++ b/src/server/dune @@ -16,6 +16,18 @@ 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) +) + diff --git a/src/server/learnocaml_auth.ml b/src/server/learnocaml_auth.ml index c9100fc74..9042ba77d 100644 --- a/src/server/learnocaml_auth.ml +++ b/src/server/learnocaml_auth.ml @@ -97,13 +97,31 @@ module LtiAuth = struct | 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) = Lwt.return (Error "TODO: implement LtiAuth.register") let associate (params:associate_credentials) = - Lwt.return (Error "TODO: implement LtiAuth.associate") + 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*) diff --git a/src/server/learnocaml_server.ml b/src/server/learnocaml_server.ml index 7adb7b2c1..a1644a98a 100644 --- a/src/server/learnocaml_server.ml +++ b/src/server/learnocaml_server.ml @@ -434,7 +434,50 @@ module Request_handler = struct lwt_ok @@ Response { contents; content_type="text/html"; caching=Nocache; cookies }) | Error e -> lwt_fail (`Forbidden, e)) | Api.Associate body -> - lwt_fail (`Forbidden, "Not implemented yet") + 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" -> + 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)) + |"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 From 18adc2de74b8e4e2469a01feac067bd43131333a Mon Sep 17 00:00:00 2001 From: Nassim Mourabit Date: Mon, 21 Jul 2025 10:18:10 +0200 Subject: [PATCH 24/29] feat(auth,lti): implement LTI registration endpoint and secure user creation - Implement with HMAC validation and nickname handling. - Handle POST /register route to support LTI account creation and session association. - Prepare backend for modular registration flows (future email/other methods). Credits: this patch reuses code from oauth-moodle-dev by the following authors. Co-authored-by: Alban Gruin <6310153+agrn@users.noreply.github.com> Co-authored-by: Erik Martin-Dorel --- src/server/learnocaml_auth.ml | 15 ++++++++++++++- src/server/learnocaml_server.ml | 33 ++++++++++++++++++++++++++++++++- 2 files changed, 46 insertions(+), 2 deletions(-) diff --git a/src/server/learnocaml_auth.ml b/src/server/learnocaml_auth.ml index 9042ba77d..91ba56891 100644 --- a/src/server/learnocaml_auth.ml +++ b/src/server/learnocaml_auth.ml @@ -92,6 +92,8 @@ module LtiAuth = struct 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) @@ -108,7 +110,18 @@ module LtiAuth = struct let login (_:login_credentials) = Lwt.return (Error "TODO: implement LtiAuth.login") let register (params:register_credentials) = - Lwt.return (Error "TODO: implement LtiAuth.register") + 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 -> diff --git a/src/server/learnocaml_server.ml b/src/server/learnocaml_server.ml index a1644a98a..338044c55 100644 --- a/src/server/learnocaml_server.ml +++ b/src/server/learnocaml_server.ml @@ -502,7 +502,38 @@ module Request_handler = struct | None -> lwt_fail (`Bad_request, "Missing 'method' parameter") end | Api.Register body -> - lwt_fail (`Forbidden, "Not implemented yet") + 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 () -> From 5ffe772b41a4768f2fd872ac73f293f3b1e418fb Mon Sep 17 00:00:00 2001 From: Nassim Mourabit Date: Mon, 21 Jul 2025 10:23:16 +0200 Subject: [PATCH 25/29] feat(app/lti): add LTI entry point, build, and utilities for modular login MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - Add executable for LTI flows in dune build. - Add utility for form encoding in . - Refactor token login to use encoded POST body for extensible auth. Credits: this patch reuses code from oauth-moodle-dev by the following authors. Co-authored-by: Alban Gruin <6310153+agrn@users.noreply.github.com> Co-authored-by: Erik Martin-Dorel Co-authored-by: Léo Segond --- src/app/dune | 25 ++++++++++++++++++- src/app/learnocaml_common.ml | 8 ++++-- src/app/learnocaml_common.mli | 2 ++ src/app/learnocaml_lti_main.ml | 45 ++++++++++++++++++++++++++++++++++ 4 files changed, 77 insertions(+), 3 deletions(-) create mode 100644 src/app/learnocaml_lti_main.ml 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 e70c3aedf..43f2d920a 100644 --- a/src/app/learnocaml_common.ml +++ b/src/app/learnocaml_common.ml @@ -1159,6 +1159,9 @@ let setup_prelude_pane ace prelude = Manip.appendChildren prelude_pane [ prelude_title ; prelude_container ] +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 @@ -1171,8 +1174,9 @@ let get_session ?(has_server = true) () = 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.Login token) >>= function + 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 diff --git a/src/app/learnocaml_common.mli b/src/app/learnocaml_common.mli index 76cb8c597..ceb3ce5b8 100644 --- a/src/app/learnocaml_common.mli +++ b/src/app/learnocaml_common.mli @@ -243,6 +243,8 @@ val setup_tab_text_prelude_pane : string -> unit val setup_prelude_pane : 'a Ace.editor -> string -> unit +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 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"]; + ] From 57780547d3f6371f895d05ceed755101a3fd287d Mon Sep 17 00:00:00 2001 From: Nassim Mourabit Date: Wed, 23 Jul 2025 16:15:20 +0200 Subject: [PATCH 26/29] feat(server): add use_lti flag to Server preconfig and config structures - Add use_lti boolean flag - Update encoding/decoding to support the new field - Default to false if not present Credits: this patch reuses code from oauth-moodle-dev by the following authors. Co-authored-by: Alban Gruin <6310153+agrn@users.noreply.github.com> --- demo-repository/server_config.json | 3 +++ src/server/learnocaml_server.ml | 8 ++++++-- src/state/learnocaml_data.ml | 30 ++++++++++++++++++++++++------ src/state/learnocaml_data.mli | 2 ++ 4 files changed, 35 insertions(+), 8 deletions(-) create mode 100644 demo-repository/server_config.json 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/src/server/learnocaml_server.ml b/src/server/learnocaml_server.ml index 338044c55..02b5bb07c 100644 --- a/src/server/learnocaml_server.ml +++ b/src/server/learnocaml_server.ml @@ -318,7 +318,7 @@ module Request_handler = struct | Some nickname -> Save.set tok Save.{empty with nickname}) >>= fun () -> respond_json cache tok - | Api.Launch body -> + | 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 @@ -433,6 +433,8 @@ module Request_handler = struct |> 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 @@ -453,7 +455,7 @@ module Request_handler = struct | Ok token -> let lwt_result = (match target_method with - | "lti" -> + | "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 @@ -461,6 +463,8 @@ module Request_handler = struct 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") | _ -> diff --git a/src/state/learnocaml_data.ml b/src/state/learnocaml_data.ml index 595a645e1..8c8100150 100644 --- a/src/state/learnocaml_data.ml +++ b/src/state/learnocaml_data.ml @@ -399,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; } @@ -421,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 9fcd0bc8d..d575fe18f 100644 --- a/src/state/learnocaml_data.mli +++ b/src/state/learnocaml_data.mli @@ -140,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 @@ -147,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 *) } From 9cb89e93cadf06b0f5893ea64e96c095d0615a36 Mon Sep 17 00:00:00 2001 From: Nassim Mourabit Date: Wed, 23 Jul 2025 21:56:21 +0200 Subject: [PATCH 27/29] fix(auth): properly check OAuth signature and set launch URL - The OAuth signature is now really checked again. - The launch URL now uses req.Api.host when deployed, or localhost in local/dev. --- src/server/learnocaml_auth.ml | 2 +- src/server/learnocaml_server.ml | 8 +++++++- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/src/server/learnocaml_auth.ml b/src/server/learnocaml_auth.ml index 91ba56891..e39700399 100644 --- a/src/server/learnocaml_auth.ml +++ b/src/server/learnocaml_auth.ml @@ -151,7 +151,7 @@ module LtiAuth = struct NonceIndex.add_nonce oauth_args.nonce >>= fun () -> NonceIndex.get_current_secret () >|= signature_oauth args "post" url >>= fun s -> - if Eqaf.equal s oauth_args.signature || true (* EMD: temporary fix; FIXME *) then + if Eqaf.equal s oauth_args.signature then Lwt.return (Ok (oauth_args.consumer_key ^ ":" ^ (List.assoc "user_id" args))) else Lwt.return (Error "Wrong signature") diff --git a/src/server/learnocaml_server.ml b/src/server/learnocaml_server.ml index 02b5bb07c..48c1e1023 100644 --- a/src/server/learnocaml_server.ml +++ b/src/server/learnocaml_server.ml @@ -329,7 +329,13 @@ module Request_handler = struct ("csrf", csrf_token)] in let params = Uri.query_of_encoded body |> List.map (fun (a, b) -> a, String.concat "," b) in - LtiAuth.check_oauth ("localhost:8080" ^ "/launch") params >>= + let launch_url = + if req.Api.host = "" then + "http://localhost:8080/launch" + else + req.Api.host ^ "/launch" + in + LtiAuth.check_oauth launch_url params >>= (function | Ok id -> LtiAuth.get_token id >>= (function From ebde3eebd02a8c6931547ad48603d643271562f5 Mon Sep 17 00:00:00 2001 From: Nassim Mourabit Date: Fri, 25 Jul 2025 11:18:58 +0200 Subject: [PATCH 28/29] fix(auth/lti): escape Irmin key to avoid : and use / for key path --- src/server/learnocaml_auth.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/server/learnocaml_auth.ml b/src/server/learnocaml_auth.ml index e39700399..2d19e9def 100644 --- a/src/server/learnocaml_auth.ml +++ b/src/server/learnocaml_auth.ml @@ -152,7 +152,7 @@ module LtiAuth = struct NonceIndex.get_current_secret () >|= signature_oauth args "post" url >>= fun s -> if Eqaf.equal s oauth_args.signature then - Lwt.return (Ok (oauth_args.consumer_key ^ ":" ^ (List.assoc "user_id" args))) + Lwt.return (Ok ((safe_encode oauth_args.consumer_key) ^ "/" ^ (List.assoc "user_id" args))) else Lwt.return (Error "Wrong signature") with Not_found -> From 74bf487fff675b93546d11ce5983d8742b3fe594 Mon Sep 17 00:00:00 2001 From: Nassim Mourabit Date: Fri, 25 Jul 2025 11:25:49 +0200 Subject: [PATCH 29/29] test(lti): setup inline tests for LTI OAuth + inject secret in check_oauth - Add a test library for learnocaml_auth with ppx_expect and ppx_inline_test. - Allow passing the secret directly to check_oauth for easier testing. - Expose LtiIndex.repo_path for test configuration. --- src/server/dune | 14 ++++++ src/server/learnocaml_auth.ml | 7 +-- src/server/learnocaml_auth.mli | 2 +- src/server/learnocaml_auth_test.ml | 75 ++++++++++++++++++++++++++++++ src/server/learnocaml_server.ml | 3 +- src/state/learnocaml_store.mli | 2 + 6 files changed, 96 insertions(+), 7 deletions(-) create mode 100644 src/server/learnocaml_auth_test.ml diff --git a/src/server/dune b/src/server/dune index ac31ff3b1..940662e79 100644 --- a/src/server/dune +++ b/src/server/dune @@ -31,3 +31,17 @@ 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 index 2d19e9def..de7abc162 100644 --- a/src/server/learnocaml_auth.ml +++ b/src/server/learnocaml_auth.ml @@ -20,8 +20,6 @@ let safe_encode s = let generate_hmac secret csrf user_id = - let decoder = Cryptokit.Hexa.decode () in - let secret = Cryptokit.transform_string decoder secret in let hmac = Cryptokit.MAC.hmac_sha256 secret and encoder = Cryptokit.Hexa.encode () in Cryptokit.hash_string hmac (csrf ^ user_id) @@ -138,7 +136,7 @@ module LtiAuth = struct (** 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 = + let check_oauth url args secret = try let oauth_args = get_oauth_args args in if oauth_args.signature_method <> oauth_signature_method then @@ -149,8 +147,7 @@ module LtiAuth = struct Lwt.return (Error "Nonce already used") else NonceIndex.add_nonce oauth_args.nonce >>= fun () -> - NonceIndex.get_current_secret () >|= - signature_oauth args "post" url >>= fun s -> + 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 diff --git a/src/server/learnocaml_auth.mli b/src/server/learnocaml_auth.mli index 33492c166..06261d51b 100644 --- a/src/server/learnocaml_auth.mli +++ b/src/server/learnocaml_auth.mli @@ -25,5 +25,5 @@ module LtiAuth : sig 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) 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 48c1e1023..5bad171f2 100644 --- a/src/server/learnocaml_server.ml +++ b/src/server/learnocaml_server.ml @@ -335,7 +335,8 @@ module Request_handler = struct else req.Api.host ^ "/launch" in - LtiAuth.check_oauth launch_url params >>= + NonceIndex.get_current_secret () >>= fun secret -> + LtiAuth.check_oauth launch_url params secret >>= (function | Ok id -> LtiAuth.get_token id >>= (function diff --git a/src/state/learnocaml_store.mli b/src/state/learnocaml_store.mli index 8a18893cc..462bf918a 100644 --- a/src/state/learnocaml_store.mli +++ b/src/state/learnocaml_store.mli @@ -205,6 +205,8 @@ 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