post.ml 8.8 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273
  1. (*
  2. * Copyright (c) 2014, OCaml.org project
  3. * Copyright (c) 2015 KC Sivaramakrishnan <sk826@cl.cam.ac.uk>
  4. *
  5. * Permission to use, copy, modify, and distribute this software for any
  6. * purpose with or without fee is hereby granted, provided that the above
  7. * copyright notice and this permission notice appear in all copies.
  8. *
  9. * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
  10. * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
  11. * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
  12. * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
  13. * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
  14. * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  15. * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  16. *)
  17. type t = {
  18. title : string;
  19. link : Uri.t option;
  20. date : Syndic.Date.t option;
  21. feed : Feed.t;
  22. author : string;
  23. email : string;
  24. description : Nethtml.document list;
  25. }
  26. let rec len_prefix_of_html html len =
  27. if len <= 0 then (0, [])
  28. else
  29. match html with
  30. | [] -> (len, [])
  31. | el :: tl ->
  32. let len, prefix_el = len_prefix_of_el el len in
  33. let len, prefix_tl = len_prefix_of_html tl len in
  34. (len, prefix_el :: prefix_tl)
  35. and len_prefix_of_el el len =
  36. match el with
  37. | Nethtml.Data d ->
  38. let len' = len - String.length d in
  39. (len', if len' >= 0 then el else Data (String.sub d 0 len ^ "…"))
  40. | Nethtml.Element (tag, args, content) ->
  41. (* Remove "id" and "name" to avoid duplicate anchors with the whole
  42. post. *)
  43. let args = List.filter (fun (n, _) -> n <> "id" && n <> "name") args in
  44. let len, prefix_content = len_prefix_of_html content len in
  45. (len, Element (tag, args, prefix_content))
  46. let prefix_of_html html len = snd (len_prefix_of_html html len)
  47. let rec filter_map l f =
  48. match l with
  49. | [] -> []
  50. | a :: tl -> (
  51. match f a with None -> filter_map tl f | Some a -> a :: filter_map tl f)
  52. let encode_html =
  53. Netencoding.Html.encode ~prefer_name:false ~in_enc:`Enc_utf8 ()
  54. let decode_document html = Nethtml.decode ~enc:`Enc_utf8 html
  55. let encode_document html = Nethtml.encode ~enc:`Enc_utf8 html
  56. let rec resolve ?xmlbase html = List.map (resolve_links_el ~xmlbase) html
  57. and resolve_links_el ~xmlbase = function
  58. | Nethtml.Element ("a", attrs, sub) ->
  59. let attrs =
  60. match List.partition (fun (t, _) -> t = "href") attrs with
  61. | [], _ -> attrs
  62. | (_, h) :: _, attrs ->
  63. let src =
  64. Uri.to_string (Syndic.XML.resolve ~xmlbase (Uri.of_string h))
  65. in
  66. ("href", src) :: attrs
  67. in
  68. Nethtml.Element ("a", attrs, resolve ?xmlbase sub)
  69. | Nethtml.Element ("img", attrs, sub) ->
  70. let attrs =
  71. match List.partition (fun (t, _) -> t = "src") attrs with
  72. | [], _ -> attrs
  73. | (_, src) :: _, attrs ->
  74. let src =
  75. Uri.to_string (Syndic.XML.resolve ~xmlbase (Uri.of_string src))
  76. in
  77. ("src", src) :: attrs
  78. in
  79. Nethtml.Element ("img", attrs, sub)
  80. | Nethtml.Element (e, attrs, sub) ->
  81. Nethtml.Element (e, attrs, resolve ?xmlbase sub)
  82. | Data _ as d -> d
  83. (* Things that posts should not contain *)
  84. let undesired_tags = [ "style"; "script" ]
  85. let undesired_attr = [ "id" ]
  86. let remove_undesired_attr =
  87. List.filter (fun (a, _) -> not (List.mem a undesired_attr))
  88. let rec remove_undesired_tags html = filter_map html remove_undesired_tags_el
  89. and remove_undesired_tags_el = function
  90. | Nethtml.Element (t, a, sub) ->
  91. if List.mem t undesired_tags then None
  92. else
  93. Some
  94. (Nethtml.Element
  95. (t, remove_undesired_attr a, remove_undesired_tags sub))
  96. | Data _ as d -> Some d
  97. let relaxed_html40_dtd =
  98. (* Allow <font> inside <pre> because blogspot uses it! :-( *)
  99. let constr =
  100. `Sub_exclusions
  101. ( [ "img"; "object"; "applet"; "big"; "small"; "sub"; "sup"; "basefont" ],
  102. `Inline )
  103. in
  104. let dtd = Nethtml.relaxed_html40_dtd in
  105. ("pre", (`Block, constr)) :: List.remove_assoc "pre" dtd
  106. let html_of_text ?xmlbase s =
  107. try
  108. Nethtml.parse (new Netchannels.input_string s) ~dtd:relaxed_html40_dtd
  109. |> decode_document |> resolve ?xmlbase |> remove_undesired_tags
  110. with _ -> [ Nethtml.Data (encode_html s) ]
  111. (* Do not trust sites using XML for HTML content. Convert to string and parse
  112. back. (Does not always fix bad HTML unfortunately.) *)
  113. let html_of_syndic =
  114. let ns_prefix _ = Some "" in
  115. fun ?xmlbase h ->
  116. html_of_text ?xmlbase
  117. (String.concat "" (List.map (Syndic.XML.to_string ~ns_prefix) h))
  118. let string_of_option = function None -> "" | Some s -> s
  119. (* Email on the forge contain the name in parenthesis *)
  120. let forge_name_re = Str.regexp ".*(\\([^()]*\\))"
  121. let post_compare p1 p2 =
  122. (* Most recent posts first. Posts with no date are always last *)
  123. match (p1.date, p2.date) with
  124. | Some d1, Some d2 -> Syndic.Date.compare d2 d1
  125. | None, Some _ -> 1
  126. | Some _, None -> -1
  127. | None, None -> 1
  128. let rec remove n l =
  129. if n <= 0 then l else match l with [] -> [] | _ :: tl -> remove (n - 1) tl
  130. let rec take n = function
  131. | [] -> []
  132. | e :: tl -> if n > 0 then e :: take (n - 1) tl else []
  133. (* Blog feed
  134. ***********************************************************************)
  135. let post_of_atom ~(feed : Feed.t) (e : Syndic.Atom.entry) =
  136. let link =
  137. try
  138. Some
  139. (List.find (fun l -> l.Syndic.Atom.rel = Syndic.Atom.Alternate) e.links)
  140. .href
  141. with Not_found -> (
  142. match e.links with l :: _ -> Some l.href | [] -> None)
  143. in
  144. let date =
  145. match e.published with Some _ -> e.published | None -> Some e.updated
  146. in
  147. let description =
  148. match e.content with
  149. | Some (Text s) -> html_of_text s
  150. | Some (Html (xmlbase, s)) -> html_of_text ?xmlbase s
  151. | Some (Xhtml (xmlbase, h)) -> html_of_syndic ?xmlbase h
  152. | Some (Mime _) | Some (Src _) | None -> (
  153. match e.summary with
  154. | Some (Text s) -> html_of_text s
  155. | Some (Html (xmlbase, s)) -> html_of_text ?xmlbase s
  156. | Some (Xhtml (xmlbase, h)) -> html_of_syndic ?xmlbase h
  157. | None -> [])
  158. in
  159. let author, _ = e.authors in
  160. {
  161. title = Util.string_of_text_construct e.title;
  162. link;
  163. date;
  164. feed;
  165. author = author.name;
  166. email = "";
  167. description;
  168. }
  169. let post_of_rss2 ~(feed : Feed.t) it =
  170. let title, description =
  171. match it.Syndic.Rss2.story with
  172. | All (t, xmlbase, d) -> (
  173. ( t,
  174. match it.content with
  175. | _, "" -> html_of_text ?xmlbase d
  176. | xmlbase, c -> html_of_text ?xmlbase c ))
  177. | Title t -> (t, [])
  178. | Description (xmlbase, d) -> (
  179. ( "",
  180. match it.content with
  181. | _, "" -> html_of_text ?xmlbase d
  182. | xmlbase, c -> html_of_text ?xmlbase c ))
  183. in
  184. let link =
  185. match (it.guid, it.link) with
  186. | Some u, _ when u.permalink -> Some u.data
  187. | _, Some _ -> it.link
  188. | Some u, _ ->
  189. (* Sometimes the guid is indicated with isPermaLink="false" but is
  190. nonetheless the only URL we get (e.g. ocamlpro). *)
  191. Some u.data
  192. | None, None -> None
  193. in
  194. {
  195. title;
  196. link;
  197. feed;
  198. author = feed.name;
  199. email = string_of_option it.author;
  200. description;
  201. date = it.pubDate;
  202. }
  203. let posts_of_feed c =
  204. match c.Feed.content with
  205. | Feed.Atom f -> List.map (post_of_atom ~feed:c) f.Syndic.Atom.entries
  206. | Feed.Rss2 ch -> List.map (post_of_rss2 ~feed:c) ch.Syndic.Rss2.items
  207. let string_of_html html =
  208. let buffer = Buffer.create 1024 in
  209. let channel = new Netchannels.output_buffer buffer in
  210. let () = Nethtml.write channel @@ encode_document html in
  211. Buffer.contents buffer
  212. let mk_entry post =
  213. let content = Syndic.Atom.Html (None, string_of_html post.description) in
  214. let contributors =
  215. [ Syndic.Atom.author ~uri:(Uri.of_string post.feed.url) post.feed.name ]
  216. in
  217. let links =
  218. match post.link with
  219. | Some l -> [ Syndic.Atom.link ~rel:Syndic.Atom.Alternate l ]
  220. | None -> []
  221. in
  222. (* TODO: include source *)
  223. let id =
  224. match post.link with
  225. | Some l -> l
  226. | None -> Uri.of_string (Digest.to_hex (Digest.string post.title))
  227. in
  228. let authors = (Syndic.Atom.author ~email:post.email post.author, []) in
  229. let title : Syndic.Atom.text_construct = Syndic.Atom.Text post.title in
  230. let updated =
  231. match post.date with
  232. (* Atom entry requires a date but RSS2 does not. So if a date
  233. * is not available, just capture the current date. *)
  234. | None -> Ptime.of_float_s (Unix.gettimeofday ()) |> Option.get
  235. | Some d -> d
  236. in
  237. Syndic.Atom.entry ~content ~contributors ~links ~id ~authors ~title ~updated
  238. ()
  239. let mk_entries posts = List.map mk_entry posts
  240. let get_posts ?n ?(ofs = 0) planet_feeds =
  241. let posts = List.concat @@ List.map posts_of_feed planet_feeds in
  242. let posts = List.sort post_compare posts in
  243. let posts = remove ofs posts in
  244. match n with None -> posts | Some n -> take n posts