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
|
(*
* 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 CalendarLib
module J = Json_encoding
let memoize f =
let hashtbl = Hashtbl.create ~random:true 100 in
fun v ->
match Hashtbl.find_opt hashtbl v with
| Some r -> r
| None ->
let r = f v in
Hashtbl.add hashtbl v r;
r
let get_unicode v =
let b = Buffer.create 1 in
Buffer.add_utf_8_uchar b (Uchar.of_int v);
Buffer.contents b
let memoized_get_unicode = memoize get_unicode
let html_entities_regex = Re.Perl.compile_pat "&#(\\d+);"
let replace_entities str =
Re.Pcre.full_split ~rex:html_entities_regex str
|> List.filter_map (function
| Re.Pcre.Group (_, v) ->
Some ("&#" ^ v ^ ";", memoized_get_unicode @@ int_of_string v)
| _ -> None)
|> Stringext.replace_all_assoc str
type loc_and_sum =
| Nothing
| Groups
| Location of string
| Summary of string * string
let loc_and_sum_to_str category = function
| Nothing | Groups -> "", category
| Location location -> location, category
| Summary (location, summary) ->
let summary = match Astring.String.cut ~sep:" - " summary with
| None -> summary
| Some (_, str) -> str in
location, summary ^ " (" ^ category ^ ")"
let check_groups str =
let group_affixes = ["L1 "; "L2 "; "L3 "; "L3P "; "M1 "; "M2 "; "DEUST ";
"MAG1 "; "1ERE ANNEE "; "2EME ANNEE "; "3EME ANNEE ";
"MAT-Agreg Interne "] in
if List.fold_left
(fun res affix ->
res || Astring.String.is_prefix ~affix str) false group_affixes then
Groups
else
Nothing
let location_and_summary str category =
let sep = "\r\n\r\n<br />\r\n\r\n" in
let parts = Astring.String.cuts ~empty:false ~sep str in
List.fold_right (fun str -> function
| Nothing -> check_groups str
| Groups -> Location (replace_entities str)
| Location summary -> Summary (replace_entities str, summary)
| Summary _ as res -> res)
parts Nothing
|> loc_and_sum_to_str category
let date =
let date_format = "%FT%T" in
Printer.Calendar.(
J.(conv (sprint date_format) (from_fstring date_format) string))
let encoding =
J.(conv
(fun _ -> (None, None, "", "", (), (), ()),
((), (), (), (), (), (), (), (), (), ()))
(fun ((start, stop, description, category, (), (), ()),
((), (), (), (), (), (), (), (), (), ())) ->
let location, summary = location_and_summary description category in
match start, stop with
| Some start, Some stop ->
Some (Ics.Event.make start stop summary location)
| _, _ -> None)
(merge_objs
(obj7
(req "start" @@ option date)
(req "end" @@ option date)
(req "description" string)
(req "eventCategory" string)
(req "id" unit)
(req "allDay" unit)
(req "backgroundColor" unit))
(obj10
(req "textColor" unit)
(req "department" unit)
(req "faculty" unit)
(req "sites" unit)
(req "modules" unit)
(req "registerStatus" unit)
(req "studentMark" unit)
(req "custom1" unit)
(req "custom2" unit)
(req "custom3" unit))))
let decode s =
let toks =
match s with
| "" -> `O []
| s -> Ezjsonm.from_string s in
J.(destruct (list encoding) toks)
|> List.filter_map (fun event -> event)
|> Ics.make
|
