My agentic slop goes here. Not intended for anyone else!
anil.recoil.org
1open Syndic_common.XML
2open Syndic_common.Util
3module XML = Syndic_xml
4module Error = Syndic_error
5
6let namespaces =
7 ["http://purl.org/rss/1.0/"; "http://www.w3.org/1999/02/22-rdf-syntax-ns#"]
8
9type title = string
10
11let make_title ~pos (l : string list) =
12 let title =
13 match l with
14 | d :: _ -> d
15 | [] ->
16 raise
17 (Error.Error
18 (pos, "The content of <title> MUST be a non-empty string"))
19 in
20 `Title title
21
22let title_of_xml, title_of_xml' =
23 let leaf_producer ~xmlbase:_ _pos data = data in
24 ( generate_catcher ~namespaces ~leaf_producer make_title
25 , generate_catcher ~namespaces ~leaf_producer (fun ~pos:_ x -> `Title x) )
26
27type name = string
28
29let make_name ~pos (l : string list) =
30 let name =
31 match l with
32 | d :: _ -> d
33 | [] ->
34 raise
35 (Error.Error (pos, "The content of <name> MUST be a non-empty string"))
36 in
37 `Name name
38
39let name_of_xml, name_of_xml' =
40 let leaf_producer ~xmlbase:_ _pos data = data in
41 ( generate_catcher ~namespaces ~leaf_producer make_name
42 , generate_catcher ~namespaces ~leaf_producer (fun ~pos:_ x -> `Name x) )
43
44type description = string
45
46let make_description ~pos (l : string list) =
47 let description =
48 match l with
49 | s :: _ -> s
50 | [] ->
51 raise
52 (Error.Error
53 (pos, "The content of <description> MUST be a non-empty string"))
54 in
55 `Description description
56
57let description_of_xml, description_of_xml' =
58 let leaf_producer ~xmlbase:_ _pos data = data in
59 ( generate_catcher ~namespaces ~leaf_producer make_description
60 , generate_catcher ~namespaces ~leaf_producer (fun ~pos:_ x -> `Description x)
61 )
62
63type channel_image = Uri.t
64type channel_image' = [`URI of Uri.t option * string]
65
66let make_channel_image ~pos (l : [< channel_image'] list) =
67 let image =
68 match find (function `URI _ -> true) l with
69 | Some (`URI (xmlbase, u)) -> XML.resolve ~xmlbase (Uri.of_string u)
70 | _ ->
71 raise
72 (Error.Error
73 (pos, "The content of <image> MUST be a non-empty string"))
74 in
75 `Image image
76
77let channel_image_of_xml, channel_image_of_xml' =
78 let attr_producer = [("resource", fun ~xmlbase a -> `URI (xmlbase, a))] in
79 ( generate_catcher ~namespaces ~attr_producer make_channel_image
80 , generate_catcher ~namespaces ~attr_producer (fun ~pos:_ x -> `Image x) )
81
82type link = Uri.t
83type link' = [`URI of Uri.t option * string]
84
85let make_link ~pos (l : [< link'] list) =
86 let link =
87 match find (function `URI _ -> true) l with
88 | Some (`URI (xmlbase, u)) -> XML.resolve ~xmlbase (Uri.of_string u)
89 | _ ->
90 raise
91 (Error.Error (pos, "The content of <link> MUST be a non-empty string"))
92 in
93 `Link link
94
95let link_of_xml, link_of_xml' =
96 let leaf_producer ~xmlbase _pos data = `URI (xmlbase, data) in
97 ( generate_catcher ~namespaces ~leaf_producer make_link
98 , generate_catcher ~namespaces ~leaf_producer (fun ~pos:_ x -> `Link x) )
99
100type url = Uri.t
101type url' = [`URI of Uri.t option * string]
102
103let make_url ~pos (l : [< url'] list) =
104 let url =
105 match find (function `URI _ -> true) l with
106 | Some (`URI (xmlbase, u)) -> XML.resolve ~xmlbase (Uri.of_string u)
107 | _ ->
108 raise
109 (Error.Error (pos, "The content of <url> MUST be a non-empty string"))
110 in
111 `URL url
112
113let url_of_xml, url_of_xml' =
114 let leaf_producer ~xmlbase _pos data = `URI (xmlbase, data) in
115 ( generate_catcher ~namespaces ~leaf_producer make_url
116 , generate_catcher ~namespaces ~leaf_producer (fun ~pos:_ x -> `URL x) )
117
118type li = Uri.t
119type li' = [`URI of Uri.t option * string]
120
121let make_li ~pos (l : [< li'] list) =
122 let url =
123 match find (function `URI _ -> true) l with
124 | Some (`URI (xmlbase, u)) -> XML.resolve ~xmlbase (Uri.of_string u)
125 | _ ->
126 raise
127 (Error.Error (pos, "Li elements MUST have a 'resource' attribute"))
128 in
129 `Li url
130
131let li_of_xml, li_of_xml' =
132 let attr_producer = [("resource", fun ~xmlbase a -> `URI (xmlbase, a))] in
133 ( generate_catcher ~namespaces ~attr_producer make_li
134 , generate_catcher ~namespaces ~attr_producer (fun ~pos:_ x -> `Li x) )
135
136type seq = li list
137type seq' = [`Li of li]
138
139let make_seq ~pos:_ (l : [< seq'] list) =
140 let li = List.map (function `Li u -> u) l in
141 `Seq li
142
143let seq_of_xml =
144 let data_producer = [("li", li_of_xml)] in
145 generate_catcher ~namespaces ~data_producer make_seq
146
147let seq_of_xml' =
148 let data_producer = [("li", li_of_xml')] in
149 generate_catcher ~namespaces ~data_producer (fun ~pos:_ x -> `Seq x)
150
151type items = seq
152type items' = [`Seq of seq]
153
154let make_items ~pos (l : [< items'] list) =
155 let li =
156 match find (function `Seq _ -> true) l with
157 | Some (`Seq l) -> l
158 | _ ->
159 raise
160 (Error.Error
161 ( pos
162 , "<items> elements MUST contains exactly one <rdf:Seq> element"
163 ))
164 in
165 `Items li
166
167let items_of_xml =
168 let data_producer = [("Seq", seq_of_xml)] in
169 generate_catcher ~namespaces ~data_producer make_items
170
171let items_of_xml' =
172 let data_producer = [("Seq", seq_of_xml')] in
173 generate_catcher ~namespaces ~data_producer (fun ~pos:_ x -> `Items x)
174
175type channel_textinput = Uri.t
176type channel_textinput' = [`URI of Uri.t option * string]
177
178let make_textinput ~pos (l : [< channel_textinput'] list) =
179 let url =
180 match find (function `URI _ -> true) l with
181 | Some (`URI (xmlbase, u)) -> XML.resolve ~xmlbase (Uri.of_string u)
182 | _ ->
183 raise
184 (Error.Error
185 (pos, "Textinput elements MUST have a 'resource' attribute"))
186 in
187 `TextInput url
188
189let channel_textinput_of_xml, channel_textinput_of_xml' =
190 let attr_producer = [("resource", fun ~xmlbase a -> `URI (xmlbase, a))] in
191 ( generate_catcher ~namespaces ~attr_producer make_textinput
192 , generate_catcher ~namespaces ~attr_producer (fun ~pos:_ x -> `TextInput x)
193 )
194
195type channel =
196 { about: Uri.t
197 ; (* must be uniq *)
198 title: title
199 ; link: link
200 ; description: description
201 ; image: channel_image option
202 ; items: items
203 ; textinput: channel_textinput option }
204
205type channel' =
206 [ `Title of title
207 | `Link of link
208 | `Description of description
209 | `Image of channel_image
210 | `Items of items
211 | `TextInput of channel_textinput
212 | `About of Uri.t ]
213
214let make_channel ~pos (l : [< channel'] list) =
215 let about =
216 match find (function `About _ -> true | _ -> false) l with
217 | Some (`About u) -> u
218 | _ ->
219 raise
220 (Error.Error (pos, "Channel elements MUST have a 'about' attribute"))
221 in
222 let title =
223 match find (function `Title _ -> true | _ -> false) l with
224 | Some (`Title s) -> s
225 | _ ->
226 raise
227 (Error.Error
228 ( pos
229 , "<channel> elements MUST contains exactly one <title> element"
230 ))
231 in
232 let link =
233 match find (function `Link _ -> true | _ -> false) l with
234 | Some (`Link u) -> u
235 | _ ->
236 raise
237 (Error.Error
238 ( pos
239 , "<channel> elements MUST contains exactly one <link> element" ))
240 in
241 let description =
242 match find (function `Description _ -> true | _ -> false) l with
243 | Some (`Description s) -> s
244 | _ ->
245 raise
246 (Error.Error
247 ( pos
248 , "<channel> elements MUST contains exactly one <description> \
249 element" ))
250 in
251 let image =
252 match find (function `Image _ -> true | _ -> false) l with
253 | Some (`Image i) -> Some i
254 | _ -> None
255 in
256 let items =
257 match find (function `Items _ -> true | _ -> false) l with
258 | Some (`Items l) -> l
259 | _ ->
260 raise
261 (Error.Error
262 ( pos
263 , "<channel> elements MUST contains exactly one <items> element"
264 ))
265 in
266 let textinput =
267 match find (function `TextInput _ -> true | _ -> false) l with
268 | Some (`TextInput u) -> Some u
269 | _ -> None
270 in
271 `Channel
272 ({about; title; link; description; image; items; textinput} : channel)
273
274let about_of_xml ~xmlbase a = `About (XML.resolve ~xmlbase (Uri.of_string a))
275let about_of_xml' ~xmlbase a = `About (xmlbase, a)
276
277let channel_of_xml =
278 let data_producer =
279 [ ("title", title_of_xml); ("link", link_of_xml)
280 ; ("description", description_of_xml)
281 ; ("image", channel_image_of_xml)
282 ; ("items", items_of_xml)
283 ; ("textinput", channel_textinput_of_xml) ]
284 in
285 let attr_producer = [("about", about_of_xml)] in
286 generate_catcher ~namespaces ~attr_producer ~data_producer make_channel
287
288let channel_of_xml' =
289 let data_producer =
290 [ ("title", title_of_xml'); ("link", link_of_xml')
291 ; ("description", description_of_xml')
292 ; ("image", channel_image_of_xml')
293 ; ("items", items_of_xml')
294 ; ("textinput", channel_textinput_of_xml') ]
295 in
296 let attr_producer = [("about", about_of_xml')] in
297 generate_catcher ~namespaces ~attr_producer ~data_producer (fun ~pos:_ x ->
298 `Channel x )
299
300type image = {about: Uri.t; title: title; url: url; link: link}
301type image' = [`Title of title | `Link of link | `URL of url | `About of Uri.t]
302
303let make_image ~pos (l : [< image'] list) =
304 let title =
305 match find (function `Title _ -> true | _ -> false) l with
306 | Some (`Title t) -> t
307 | _ ->
308 raise
309 (Error.Error
310 (pos, "<image> elements MUST contains exactly one <title> element"))
311 in
312 let link =
313 match find (function `Link _ -> true | _ -> false) l with
314 | Some (`Link u) -> u
315 | _ ->
316 raise
317 (Error.Error
318 (pos, "<image> elements MUST contains exactly one <link> element"))
319 in
320 let url =
321 match find (function `URL _ -> true | _ -> false) l with
322 | Some (`URL u) -> u
323 | _ ->
324 raise
325 (Error.Error
326 (pos, "<image> elements MUST contains exactly one <url> element"))
327 in
328 let about =
329 match find (function `About _ -> true | _ -> false) l with
330 | Some (`About a) -> a
331 | _ ->
332 raise
333 (Error.Error (pos, "Image elements MUST have a 'about' attribute"))
334 in
335 `Image ({about; title; url; link} : image)
336
337let image_of_xml =
338 let data_producer =
339 [("title", title_of_xml); ("link", link_of_xml); ("url", url_of_xml)]
340 in
341 let attr_producer = [("about", about_of_xml)] in
342 generate_catcher ~namespaces ~attr_producer ~data_producer make_image
343
344let image_of_xml' =
345 let data_producer =
346 [("title", title_of_xml'); ("link", link_of_xml'); ("url", url_of_xml')]
347 in
348 let attr_producer = [("about", about_of_xml')] in
349 generate_catcher ~namespaces ~attr_producer ~data_producer (fun ~pos:_ x ->
350 `Image x )
351
352type item =
353 {about: Uri.t; title: title; link: link; description: description option}
354
355type item' =
356 [ `Title of title
357 | `Link of link
358 | `Description of description
359 | `About of Uri.t ]
360
361let make_item ~pos (l : [< item'] list) =
362 let title =
363 match find (function `Title _ -> true | _ -> false) l with
364 | Some (`Title t) -> t
365 | _ ->
366 raise
367 (Error.Error
368 (pos, "<item> elements MUST contains exactly one <title> element"))
369 in
370 let link =
371 match find (function `Link _ -> true | _ -> false) l with
372 | Some (`Link u) -> u
373 | _ ->
374 raise
375 (Error.Error
376 (pos, "<item> elements MUST contains exactly one <link> element"))
377 in
378 let description =
379 match find (function `Description _ -> true | _ -> false) l with
380 | Some (`Description d) -> Some d
381 | _ -> None
382 in
383 let about =
384 match find (function `About _ -> true | _ -> false) l with
385 | Some (`About u) -> u
386 | _ ->
387 raise
388 (Error.Error (pos, "Item elements MUST have a 'about' attribute"))
389 in
390 `Item ({about; title; link; description} : item)
391
392let item_of_xml =
393 let data_producer =
394 [ ("title", title_of_xml); ("link", link_of_xml)
395 ; ("description", description_of_xml) ]
396 in
397 let attr_producer = [("about", about_of_xml)] in
398 generate_catcher ~namespaces ~attr_producer ~data_producer make_item
399
400let item_of_xml' =
401 let data_producer =
402 [ ("title", title_of_xml'); ("link", link_of_xml')
403 ; ("description", description_of_xml') ]
404 in
405 let attr_producer = [("about", about_of_xml')] in
406 generate_catcher ~namespaces ~attr_producer ~data_producer (fun ~pos:_ x ->
407 `Item x )
408
409type textinput =
410 {about: Uri.t; title: title; description: description; name: name; link: link}
411
412type textinput' =
413 [ `About of Uri.t
414 | `Title of title
415 | `Description of description
416 | `Name of name
417 | `Link of link ]
418
419let make_textinput ~pos (l : [< textinput'] list) =
420 let title =
421 match find (function `Title _ -> true | _ -> false) l with
422 | Some (`Title s) -> s
423 | _ ->
424 raise
425 (Error.Error
426 ( pos
427 , "<textinput> elements MUST contains exactly one <title> element"
428 ))
429 in
430 let description =
431 match find (function `Description _ -> true | _ -> false) l with
432 | Some (`Description s) -> s
433 | _ ->
434 raise
435 (Error.Error
436 ( pos
437 , "<textinput> elements MUST contains exactly one <description> \
438 element" ))
439 in
440 let name =
441 match find (function `Name _ -> true | _ -> false) l with
442 | Some (`Name n) -> n
443 | _ ->
444 raise
445 (Error.Error
446 ( pos
447 , "<textinput> elements MUST contains exactly one <name> element"
448 ))
449 in
450 let link =
451 match find (function `Link _ -> true | _ -> false) l with
452 | Some (`Link u) -> u
453 | _ ->
454 raise
455 (Error.Error
456 ( pos
457 , "<textinput> elements MUST contains exactly one <link> element"
458 ))
459 in
460 let about =
461 match find (function `About _ -> true | _ -> false) l with
462 | Some (`About u) -> u
463 | _ ->
464 raise
465 (Error.Error (pos, "Textinput elements MUST have a 'about' attribute"))
466 in
467 `TextInput ({about; title; description; name; link} : textinput)
468
469let textinput_of_xml =
470 let data_producer =
471 [ ("title", title_of_xml)
472 ; ("description", description_of_xml)
473 ; ("name", name_of_xml); ("link", link_of_xml) ]
474 in
475 let attr_producer = [("about", about_of_xml)] in
476 generate_catcher ~namespaces ~attr_producer ~data_producer make_textinput
477
478let textinput_of_xml' =
479 let data_producer =
480 [ ("title", title_of_xml')
481 ; ("description", description_of_xml')
482 ; ("name", name_of_xml'); ("link", link_of_xml') ]
483 in
484 let attr_producer = [("about", about_of_xml')] in
485 generate_catcher ~namespaces ~attr_producer ~data_producer (fun ~pos:_ x ->
486 `TextInput x )
487
488type rdf =
489 { channel: channel
490 ; image: image option
491 ; item: item list
492 ; textinput: textinput option }
493
494type rdf' =
495 [ `Channel of channel
496 | `Image of image
497 | `Item of item
498 | `TextInput of textinput ]
499
500let make_rdf ~pos (l : [< rdf'] list) =
501 let channel =
502 match find (function `Channel _ -> true | _ -> false) l with
503 | Some (`Channel channel) -> channel
504 | _ ->
505 raise
506 (Error.Error
507 (pos, "<rdf> elements MUST contains exactly one <channel> element"))
508 in
509 let image =
510 match find (function `Image _ -> true | _ -> false) l with
511 | Some (`Image image) -> Some image
512 | _ -> None
513 in
514 let textinput =
515 match find (function `TextInput _ -> true | _ -> false) l with
516 | Some (`TextInput textinput) -> Some textinput
517 | _ -> None
518 in
519 let item =
520 List.fold_left (fun acc -> function `Item x -> x :: acc | _ -> acc) [] l
521 in
522 ({channel; image; item; textinput} : rdf)
523
524let rdf_of_xml =
525 let data_producer =
526 [ ("channel", channel_of_xml)
527 ; ("image", image_of_xml); ("item", item_of_xml)
528 ; ("textinput", textinput_of_xml) ]
529 in
530 generate_catcher ~namespaces ~data_producer make_rdf
531
532let rdf_of_xml' =
533 let data_producer =
534 [ ("channel", channel_of_xml')
535 ; ("image", image_of_xml'); ("item", item_of_xml')
536 ; ("textinput", textinput_of_xml') ]
537 in
538 generate_catcher ~namespaces ~data_producer (fun ~pos:_ x -> x)
539
540let parse ?xmlbase input =
541 match XML.of_xmlm input |> snd with
542 | XML.Node (pos, tag, datas) when tag_is tag "RDF" ->
543 rdf_of_xml ~xmlbase (pos, tag, datas)
544 | _ ->
545 raise
546 (Error.Error
547 ((0, 0), "document MUST contains exactly one <rdf> element"))
548
549let read ?xmlbase fname =
550 let fh = open_in fname in
551 try
552 let x = parse ?xmlbase (XML.input_of_channel fh) in
553 close_in fh ; x
554 with e -> close_in fh ; raise e
555
556type uri = Uri.t option * string
557
558let unsafe ?xmlbase input =
559 match XML.of_xmlm input |> snd with
560 | XML.Node (pos, tag, datas) when tag_is tag "RDF" ->
561 `RDF (rdf_of_xml' ~xmlbase (pos, tag, datas))
562 | _ -> `RDF []