1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
(*
* Copyright (C) 2020, 2021 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 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 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" in
Client.post ~body ~headers celcat_url
>>= fun (_resp, body) ->
Cohttp_lwt.Body.to_string body
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 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 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 =
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
| `GET, ["lnk"], _ ->
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" ()
| _ ->
Server.respond_string
~status:`Method_not_allowed ~body:"Method not allowed\n" () in
Server.create ~stop ~mode (Server.make ~callback ())
|
