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
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
|
(*
* 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 <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 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 ())
|
