server, ics, pages: allow to generate ICS from modules

This adds the ability to generate an ICS file from a module ID, and to
filter it based on its groups.

To do this, you can enter a module ID on the frontpage.  Then, µCS will
fetch the timetable, then return a page where one can select the
group(s) they want to filter (this is enabled by the new
Ics.get_all_groups function).  Then, µCS is able to generate a link to
that calendar, not unlike with a single group ID.

Signed-off-by: Alban Gruin <alban at pa1ch dot fr>

5 files changed, 66 insertions, 5 deletions

diff --git a/src/ics.ml b/src/ics.ml
index 888e9e8..d6d165a 100644
--- a/src/ics.ml
+++ b/src/ics.ml
@@ -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, _, _ ->