From cbad40db59bfb75547b7a0250602d7fbae141c42 Mon Sep 17 00:00:00 2001 From: Nassim Mourabit Date: Mon, 31 Mar 2025 10:31:13 +0200 Subject: [PATCH 01/18] 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/18] 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/18] 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/18] 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/18] 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/18] =?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/18] 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/18] 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/18] 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/18] =?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/18] 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/18] 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/18] 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/18] 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/18] 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/18] 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/18] 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/18] 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