(* * 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 * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * ucs is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Affero General Public License for more details. * * You should have received a copy of the GNU Affero General Public License * along with ucs. If not, see . *) open CalendarLib open Lwt.Infix open Cohttp open Cohttp_lwt_unix 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 fetch_kind = | Group | Module let kind_to_res_type = function | Group -> "103" | Module -> "100" let kind_to_url = function | Group -> "g" | Module -> "m" let skip_if predicate fn value = if predicate then value else fn value let get_tz () = Lwt_unix.file_exists "/etc/timezone" >>= fun exists -> if exists then Lwt_io.(open_file ~mode:Input "/etc/timezone") >>= fun file -> Lwt.finalize (fun () -> Lwt_io.read file >|= String.trim) (fun () -> Lwt_io.close file) else Lwt.return "" let log uri = let datetime = Printer.Calendar.sprint "%Y-%m-%d %H:%M:%S" @@ Calendar.now () in Lwt_io.printlf "[%s] %s" datetime (Uri.path_and_query uri) 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 fetch celcat_url group kind = let current_date = Date.today () in let lower_date = format_date @@ Date.rem current_date a_month and upper_date = format_date @@ Date.add current_date a_year in let res_type = kind_to_res_type kind in let parameters = Uri.encoded_of_query ["start", [lower_date]; "end", [upper_date]; "resType", [res_type]; "calView", ["month"]; "federationIds[]", [group]; "colourScheme", ["3"]] in let body = Cohttp_lwt.Body.of_string parameters and headers = Header.init_with "Content-Type" "application/x-www-form-urlencoded; charset=UTF-8" in Client.post ~body ~headers celcat_url >>= fun (_resp, body) -> Cohttp_lwt.Body.to_string body let fetch_and_respond ?(groups=[]) tzname celcat_url file kind = 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 get_link ?(args=[]) base_url kind id = 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 ?(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 ?args:page_args |> respond 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) -> 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 -> 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 list_events_with_empty_location celcat_url body = get_module_and_groups_from_request body (fun module_id groups -> fetch celcat_url module_id Module >>= fun body -> Course.decode body |> skip_if (groups = []) (Ics.filter_groups groups) |> Ics.filter_empty_locations |> Pages.empty_events |> respond) bad_request let check_ics = Astring.String.is_suffix ~affix:".ics" let serve base_url celcat_url mode stop = get_tz () >>= fun tzname -> let callback _conn req body = let meth = Request.meth req and uri = Request.uri req in let path = Uri.path uri |> Astring.String.cuts ~empty:false ~sep:"/" |> List.map Uri.pct_decode and query = Uri.query uri in log uri >>= fun () -> match meth, path, query with | `GET, ([] | ["index.html"]), [] -> respond Pages.main | `GET, ["lnk"], ["group", [group]] -> respond_link base_url Group group | `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 | `POST, ["empty"], [] -> list_events_with_empty_location celcat_url body | (`GET | `POST), ["lnk"], _ | `GET, ["filter"], _ | `POST, ["empty"], _ -> bad_request () | `GET, ["ics"; "g" | "m"; file], _ when check_ics file -> bad_request () | `GET, _, _ -> Server.respond_string ~status:`Not_found ~body:"Not found\n" () | _ -> Server.respond_string ~status:`Method_not_allowed ~body:"Method not allowed\n" () in Server.create ~stop ~mode (Server.make ~callback ())