diff options
| -rw-r--r-- | src/server.ml | 70 | ||||
| -rw-r--r-- | src/server.mli | 18 | ||||
| -rw-r--r-- | src/ucs.ml | 55 |
3 files changed, 89 insertions, 54 deletions
diff --git a/src/server.ml b/src/server.ml new file mode 100644 index 0000000..a6f0617 --- /dev/null +++ b/src/server.ml @@ -0,0 +1,70 @@ +(* + * Copyright (C) 2020 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 <http://www.gnu.org/licenses/>. + *) + +open Lwt +open Cohttp +open Cohttp_lwt_unix + +let fetch celcat_url group = + let parameters = Uri.encoded_of_query + ["start", ["2020-09-01"]; "end", ["2020-10-01"]; + "resType", ["103"]; "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" in + Client.post ~body ~headers celcat_url + >>= fun (_resp, body) -> + Cohttp_lwt.Body.to_string body + +let log uri = + let datetime = CalendarLib.( + 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 serve base_url celcat_url mode = + let fetch = fetch celcat_url in + 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]] -> + let lnk = base_url ^ "/ics/" ^ group ^ ".ics" in + respond @@ Pages.link lnk + | `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 group >>= fun body -> + Course.decode body + |> Ics.to_string + |> respond ~mime:"text/calendar; charset=utf-8" + | `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 ~mode (Server.make ~callback ()) diff --git a/src/server.mli b/src/server.mli new file mode 100644 index 0000000..af3f0e8 --- /dev/null +++ b/src/server.mli @@ -0,0 +1,18 @@ +(* + * Copyright (C) 2020 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 <http://www.gnu.org/licenses/>. + *) + +val serve : string -> Uri.t -> Conduit_lwt_unix.server -> unit Lwt.t @@ -15,58 +15,5 @@ * along with ucs. If not, see <http://www.gnu.org/licenses/>. *) -open Lwt -open Cohttp -open Cohttp_lwt_unix - -let fetch group = - let parameters = Uri.encoded_of_query - ["start", ["2020-09-01"]; "end", ["2020-10-01"]; - "resType", ["103"]; "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" in - Client.post ~body ~headers (Uri.of_string "https://edt.univ-tlse3.fr/calendar2/Home/GetCalendarData") - >>= fun (_resp, body) -> - Cohttp_lwt.Body.to_string body - -let log uri = - let datetime = CalendarLib.( - 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 server = - 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]] -> - let lnk = "/ics/" ^ group ^ ".ics" in - respond @@ Pages.link lnk - | `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 group >>= fun body -> - Course.decode body - |> Ics.to_string - |> respond ~mime:"text/calendar; charset=utf-8" - | `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 ~mode:(`TCP (`Port 8080)) (Server.make ~callback ()) - let () = - Lwt_main.run server + Lwt_main.run (Server.serve "/" (Uri.of_string "/") (`TCP (`Port 8080))) |