server: extract the function reading the module id and groups

A new function, listing events with no location, will also need to read
the module id and groups from request parameters.  Extract the function
taking care of that to avoid code duplication.

This also adds a button on the link page, to access to the page listing
events without location.  This feature is not yet implemented.

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

3 files changed, 35 insertions, 13 deletions

diff --git a/src/pages.ml b/src/pages.ml
index e9f255a..6fd7bef 100644
--- a/src/pages.ml
+++ b/src/pages.ml
@@ -99,14 +99,31 @@ d’Apple), et ainsi attirer plus d’utilisateurs ? -->
       </section>
 |}
 
-let link lnk =
+let link ?args lnk =
   let lnk = escape lnk in
+  let form = match args with
+    | Some (module_id, groups) ->
+      let group_fields =
+        List.map (fun group ->
+            Printf.sprintf "          <input type=\"hidden\" name=\"groups\" value=\"%s\" />" (escape group))
+          groups
+        |> String.concat "\n" in
+      {|      <section>
+        <h3>Trouver les cours sans salle</h3>
+        <form method="post" action="/empty">
+          <input type="hidden" name="module" value="|} ^ module_id ^ {|" />
+|} ^ group_fields ^ {|
+          <input type="submit" value="Trouver les cours sans salle" />
+        </form>
+      </section>
+|}
+    | _ -> "" in
   common @@ {|
       <section>
         <h3>Lien de l'emploi du temps</h3>
         <a href="|} ^ lnk ^ {|">|} ^ lnk ^ {|</a>
       </section>
-|}
+|} ^ form
 
 let select module_id groups =
   let options =
diff --git a/src/pages.mli b/src/pages.mli
index 0e2180e..4618faf 100644
--- a/src/pages.mli
+++ b/src/pages.mli
@@ -1,5 +1,5 @@
 (*
- *    Copyright (C) 2020, 2021  Alban Gruin
+ *    Copyright (C) 2020 -- 2022  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
@@ -16,5 +16,5 @@
  *)
 
 val main : string
-val link : string -> string
+val link : ?args:(string * string list) -> string -> string
 val select : string -> string Seq.t -> string
diff --git a/src/server.ml b/src/server.ml
index bedc9a0..287a416 100644
--- a/src/server.ml
+++ b/src/server.ml
@@ -96,12 +96,15 @@ let get_link ?(args=[]) base_url kind id =
     else "?" ^ Uri.encoded_of_query args in
   base_url ^ "/ics/" ^ kind_to_url kind ^ "/" ^ id ^ ".ics" ^ args
 
-let respond_link ?(args=[]) base_url kind id =
+let respond_link ?(groups=[]) base_url kind id =
+  let page_args, args = match groups with
+    | [] -> None, []
+    | groups -> Some (id, groups), ["groups", groups] in
   get_link ~args base_url kind id
-  |> Pages.link
+  |> Pages.link ?args:page_args
   |> respond
 
-let get_module_link base_url body =
+let get_module_and_groups_from_request body found not_found =
   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) ->
@@ -114,12 +117,14 @@ let get_module_link base_url body =
       | _, _, _, _ -> 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 ()
+    found module_id groups
+  | _, _ -> not_found ()
+
+let get_module_link base_url body =
+  get_module_and_groups_from_request body
+    (fun module_id groups ->
+       respond_link ~groups base_url Module module_id)
+    bad_request
 
 let check_ics = Astring.String.is_suffix ~affix:".ics"