diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/ics.ml | 10 | ||||
| -rw-r--r-- | src/ics.mli | 1 | ||||
| -rw-r--r-- | src/pages.ml | 20 | ||||
| -rw-r--r-- | src/pages.mli | 3 | ||||
| -rw-r--r-- | src/server.ml | 37 |
5 files changed, 66 insertions, 5 deletions
@@ -17,6 +17,8 @@ open CalendarLib +module StringSet = Set.Make (String) + let to_date = Printer.Calendar.sprint "%Y%m%dT%H%M%S" let current_date () = to_date @@ Calendar.now () @@ -61,6 +63,8 @@ module Event = struct let has_groups groups event = List.fold_left (fun found group -> found || List.exists ((=) group) groups) false event.groups + + let get_groups event = event.groups end type t = Event.t list @@ -80,6 +84,12 @@ let gen_vtimezone tz = else "" +let get_all_groups events = + let add_groups_to_set set event = + List.fold_left (fun set elt -> StringSet.add elt set) set @@ Event.get_groups event in + List.fold_left add_groups_to_set StringSet.empty events + |> StringSet.to_seq + let to_string tz events = let date = current_date () in let vtimezone = gen_vtimezone tz in diff --git a/src/ics.mli b/src/ics.mli index cdb00d8..f56a1a4 100644 --- a/src/ics.mli +++ b/src/ics.mli @@ -27,4 +27,5 @@ type t val make : Event.t list -> t val filter_groups : string list -> t -> t +val get_all_groups : t -> string Seq.t val to_string : string -> t -> string diff --git a/src/pages.ml b/src/pages.ml index 2cb0aa4..feb2769 100644 --- a/src/pages.ml +++ b/src/pages.ml @@ -48,6 +48,11 @@ let main = common {| <input type="text" name="group" id="id_group" required /> <input type="submit" value="Générer un ICS" /> </form> + <form action="/filter" method="get"> + <label for="id_module">ID du module</label> + <input type="text" name="module" id="id_module" required /> + <input type="submit" value="Générer un ICS" /> + </form> </section> <section> <p> @@ -99,3 +104,18 @@ let link lnk = <a href="|} ^ lnk ^ {|">|} ^ lnk ^ {|</a> </section> |} + +let select module_id groups = + let options = + Seq.map (fun group -> " <option>" ^ escape group ^ "</option>") groups + |> List.of_seq + |> String.concat "\n" in + common @@ {| + <form method="post" action="/lnk"> + <select name="groups" multiple> +|} ^ options ^ {| + </select> + <input type="hidden" name="module" value="|} ^ module_id ^ {|" /> + <input type="submit" text="Valider" /> + </form> +|} diff --git a/src/pages.mli b/src/pages.mli index aef68b4..0e2180e 100644 --- a/src/pages.mli +++ b/src/pages.mli @@ -1,5 +1,5 @@ (* - * Copyright (C) 2020 Alban Gruin + * Copyright (C) 2020, 2021 Alban Gruin * * ucs is free software: you can redistribute it and/or modify * it under the terms of the GNU Affero General Public License as published @@ -17,3 +17,4 @@ val main : string val link : string -> string +val select : string -> string Seq.t -> string diff --git a/src/server.ml b/src/server.ml index 389da95..371c402 100644 --- a/src/server.ml +++ b/src/server.ml @@ -101,9 +101,29 @@ let respond_link ?(args=[]) base_url kind id = |> Pages.link |> respond +let get_module_link base_url body = + Cohttp_lwt.Body.to_string body >>= fun body -> + let data = Uri.query_of_encoded body in + let groups, module_id, valid = List.fold_right (fun (k, v) (groups, module_id, valid) -> + match k, v, module_id, valid with + | _, _, _, false -> groups, module_id, false + | "groups", ([] | [""]), _, _ -> groups, module_id, true + | "groups", [group], _, _ -> group :: groups, module_id, true + | "groups", g, _, _ -> g @ groups, module_id, true + | "module", [module_id], None, _ -> groups, Some module_id, true + | _, _, _, _ -> groups, None, false) data ([], None, true) in + match module_id, valid with + | Some module_id, true -> + let args = + if groups = [] then [] + else ["groups", groups] in + respond_link ~args base_url Module module_id + | _, _ -> + bad_request () + let serve base_url celcat_url mode stop = get_tz () >>= fun tzname -> - let callback _conn req _body = + let callback _conn req body = let meth = Request.meth req and uri = Request.uri req in let path = Uri.path uri @@ -112,15 +132,24 @@ let serve base_url celcat_url mode stop = query = Uri.query uri in log uri >>= fun () -> match meth, path, query with - | `GET, ([] | ["index.html"]), [] -> respond Pages.main + | `GET, ([] | ["index.html"]), [] -> + respond Pages.main | `GET, ["lnk"], ["group", [group]] -> respond_link base_url Group group - | `GET, ["lnk"], _ -> - bad_request () + | `POST, ["lnk"], [] -> + get_module_link base_url body | `GET, ["ics"; "g"; file], [] when check_ics file -> fetch_and_respond tzname celcat_url file Group | `GET, ["ics"; "m"; file], ([] as groups | ["groups", groups]) when check_ics file -> fetch_and_respond ~groups tzname celcat_url file Module + | `GET, ["filter"], ["module", [module_id]] -> + fetch celcat_url module_id Module >>= fun body -> + Course.decode body + |> Ics.get_all_groups + |> Pages.select module_id + |> respond + | (`GET | `POST), ["lnk"], _ | `GET, ["filter"], _ -> + bad_request () | `GET, ["ics"; "g" | "m"; file], _ when check_ics file -> bad_request () | `GET, _, _ -> |