server, ics: add a facility to filter courses by groups

When fetching courses based on their module ID, it is interesting to
exclude coruses that do not apply to some groups.  This adds the
functionnality to apply that filtering, with the Ics.filter_groups
function.

It also becomes possible to get ICS for modules.  URLs and generators
are changed accordingly.

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

3 files changed, 48 insertions, 10 deletions

diff --git a/src/ics.ml b/src/ics.ml
index f1b6cc5..888e9e8 100644
--- a/src/ics.ml
+++ b/src/ics.ml
@@ -57,12 +57,19 @@ module Event = struct
      "END:VEVENT\n"]
     |> List.map ics_split_line
     |> String.concat "\n"
+
+  let has_groups groups event =
+    List.fold_left (fun found group ->
+        found || List.exists ((=) group) groups) false event.groups
 end
 
 type t = Event.t list
 
 let make events = events
 
+let filter_groups groups =
+  List.filter (Event.has_groups groups)
+
 let gen_vtimezone tz =
   if tz <> "" then
   ["BEGIN:VTIMEZONE";
diff --git a/src/ics.mli b/src/ics.mli
index ca09406..cdb00d8 100644
--- a/src/ics.mli
+++ b/src/ics.mli
@@ -26,4 +26,5 @@ end
 type t
 
 val make : Event.t list -> t
+val filter_groups : string list -> t -> t
 val to_string : string -> t -> string
diff --git a/src/server.ml b/src/server.ml
index 7107fdf..389da95 100644
--- a/src/server.ml
+++ b/src/server.ml
@@ -26,7 +26,7 @@ let format_date = Printer.Date.sprint "%Y-%m-%d" and
     a_month = Date.Period.make 0 1 0 and
     a_year = Date.Period.make 1 0 0
 
-type [@warning "-37"] fetch_kind =
+type fetch_kind =
   | Group
   | Module
 
@@ -58,6 +58,8 @@ let respond ?(mime="text/html; charset=utf-8") ?(status=`OK) body =
   let headers = Header.init_with "Content-Type" mime in
   Server.respond_string ~status ~body ~headers ()
 
+let bad_request = Server.respond_string ~status:`Bad_request ~body:"Bad request\n"
+
 let get_tz () =
   Lwt_unix.file_exists "/etc/timezone" >>= fun exists ->
   if exists then
@@ -70,6 +72,35 @@ let get_tz () =
   else
     Lwt.return ""
 
+let fetch_and_respond ?(groups=[]) tzname celcat_url file kind =
+  let skip_if predicate fn value =
+    if predicate then
+      value
+    else
+      fn value in
+  let id = String.(sub file 0 (length file - 4)) in
+  fetch celcat_url id kind >>= fun body ->
+  Course.decode body
+  |> skip_if (kind = Group || groups = []) (Ics.filter_groups groups)
+  |> Ics.to_string tzname
+  |> respond ~mime:"text/calendar; charset=utf-8"
+
+let check_ics = Astring.String.is_suffix ~affix:".ics"
+
+let get_link ?(args=[]) base_url kind id =
+  let kind_to_url = function
+    | Group -> "g"
+    | Module -> "m" in
+  let args =
+    if args = [] then ""
+    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 =
+  get_link ~args base_url kind id
+  |> Pages.link
+  |> respond
+
 let serve base_url celcat_url mode stop =
   get_tz () >>= fun tzname ->
   let callback _conn req _body =
@@ -83,16 +114,15 @@ let serve base_url celcat_url mode stop =
     match meth, path, query with
     | `GET, ([] | ["index.html"]), [] -> respond Pages.main
     | `GET, ["lnk"], ["group", [group]] ->
-       let lnk = base_url ^ "/ics/" ^ group ^ ".ics" in
-       respond @@ Pages.link lnk
+       respond_link base_url Group group
     | `GET, ["lnk"], _ ->
-       Server.respond_string ~status:`Bad_request ~body:"Bad request\n" ()
-    | `GET, ["ics"; file], [] when Astring.String.is_suffix ~affix:".ics" file ->
-       let group = String.(sub file 0 (length file - 4)) in
-       fetch celcat_url group Group >>= fun body ->
-       Course.decode body
-       |> Ics.to_string tzname
-       |> respond ~mime:"text/calendar; charset=utf-8"
+       bad_request ()
+    | `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, ["ics"; "g" | "m"; file], _ when check_ics file ->
+       bad_request ()
     | `GET, _, _ ->
        Server.respond_string ~status:`Not_found ~body:"Not found\n" ()
     | _ ->