diff options
| -rw-r--r-- | src/ics.ml | 7 | ||||
| -rw-r--r-- | src/ics.mli | 1 | ||||
| -rw-r--r-- | src/server.ml | 50 |
3 files changed, 48 insertions, 10 deletions
@@ -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" () | _ -> |