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
|
(*
* 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
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 of string list
| Summary of string list * string
| Location of string list * string * string
let loc_and_sum_to_groups = function
| Nothing -> []
| Groups groups | Summary (groups, _) | Location (groups, _, _) -> groups
let loc_and_sum_to_location = function
| Nothing | Groups _ | Summary _ -> None
| Location (_, _, location) -> Some location
let loc_and_sum_to_summary category = function
| Nothing | Groups _ -> category
| Summary (_, summary) | Location (_, summary, _) ->
let summary = match Astring.String.cut ~sep:" - " summary with
| None -> summary
| Some (_, str) -> str in
summary ^ " (" ^ category ^ ")"
let loc_and_sum_to_event start stop category loc_and_sum =
let groups = loc_and_sum_to_groups loc_and_sum and
location = loc_and_sum_to_location loc_and_sum and
summary = loc_and_sum_to_summary category loc_and_sum in
Some (Ics.Event.make start stop summary location groups)
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 (Astring.String.cuts ~empty:false ~sep:"<br />" @@ replace_entities str)
else
Nothing
let location_and_summary str =
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 groups -> Summary (groups, replace_entities str)
| Summary (groups, summary) -> Location (groups, summary, replace_entities str)
| Location _ as res -> res)
parts Nothing
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), ()) ->
match start, stop with
| Some start, Some stop ->
let loc_and_sum = location_and_summary description in
loc_and_sum_to_event start stop category loc_and_sum
| _, _ -> None)
(merge_objs
(obj4
(req "start" @@ option date)
(req "end" @@ option date)
(req "description" string)
(req "eventCategory" string))
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
|
