···
(** River RSS/Atom/JSONFeed aggregator library *)
-
let src = Logs.Src.create "river" ~doc:"River RSS/Atom aggregator"
-
module Log = (val Logs.src_log src : Logs.LOG)
-
(** {1 Internal Utilities} *)
-
module Text_extract = struct
-
let rec syndic_to_buffer b = function
-
| XML.Node (_, _, subs) -> List.iter (syndic_to_buffer b) subs
-
| XML.Data (_, d) -> Buffer.add_string b d
-
let syndic_to_string x =
-
let b = Buffer.create 1024 in
-
List.iter (syndic_to_buffer b) x;
-
let string_of_text_construct : Atom.text_construct -> string = function
-
| Atom.Text s | Atom.Html (_, s) -> s
-
| Atom.Xhtml (_, x) -> syndic_to_string x
-
module Html_meta = struct
-
[@@@warning "-32"] (* Suppress unused value warnings for internal utilities *)
-
(** This module determines an image to be used as preview of a website.
-
It does this by following the same logic Google+ and other websites use, and
-
described in this article:
-
https://www.raymondcamden.com/2011/07/26/How-are-Facebook-and-Google-creating-link-previews *)
-
let soup = parse html in
-
try soup $ "meta[property=og:image]" |> R.attribute "content" |> Option.some
-
let soup = parse html in
-
try soup $ "link[rel=\"image_src\"]" |> R.attribute "href" |> Option.some
-
let twitter_image html =
-
let soup = parse html in
-
soup $ "meta[name=\"twitter:image\"]" |> R.attribute "content"
-
let og_description html =
-
let soup = parse html in
-
soup $ "meta[property=og:description]" |> R.attribute "content"
-
let soup = parse html in
-
soup $ "meta[property=description]" |> R.attribute "content" |> Option.some
-
let preview_image html =
-
match og_image html with
-
match image_src html with
-
| None -> twitter_image html
-
match Option.map String.trim preview_image with
-
match og_description html with None -> description html | Some x -> Some x
-
match Option.map String.trim preview_image with
-
module Html_markdown = struct
-
[@@@warning "-32"] (* Suppress unused value warnings for internal utilities *)
-
(** HTML to Markdown converter using Lambda Soup *)
-
(** Extract all links from HTML content *)
-
let extract_links html_str =
-
let soup = Soup.parse html_str in
-
let links = Soup.select "a[href]" soup in
-
Soup.fold (fun acc link ->
-
match Soup.attribute "href" link with
-
let text = Soup.texts link |> String.concat "" |> String.trim in
-
(** Check if string contains any whitespace *)
-
let _ = Str.search_forward (Str.regexp "[ \t\n\r]") s 0 in
-
with Not_found -> false
-
(** Clean up excessive newlines and normalize spacing *)
-
let cleanup_markdown s =
-
(* Normalize line endings *)
-
let s = Str.global_replace (Str.regexp "\r\n") "\n" s in
-
(* Remove trailing whitespace from each line *)
-
let lines = String.split_on_char '\n' s in
-
let lines = List.map (fun line ->
-
(* Trim trailing spaces but preserve leading spaces for indentation *)
-
let len = String.length line in
-
let rec find_last_non_space i =
-
else if line.[i] = ' ' || line.[i] = '\t' then find_last_non_space (i - 1)
-
let last = find_last_non_space (len - 1) in
-
else String.sub line 0 (last + 1)
-
(* Join back and collapse excessive blank lines *)
-
let s = String.concat "\n" lines in
-
(* Replace 3+ consecutive newlines with just 2 *)
-
let s = Str.global_replace (Str.regexp "\n\n\n+") "\n\n" s in
-
(* Trim leading and trailing whitespace *)
-
(** Convert HTML to Markdown using state-based whitespace handling *)
-
let html_to_markdown html_str =
-
let soup = Soup.parse html_str in
-
let buffer = Buffer.create 256 in
-
(* State: track if we need to insert a space before next text *)
-
let need_space = ref false in
-
(* Get last character in buffer, if any *)
-
let len = Buffer.length buffer in
-
else Some (Buffer.nth buffer (len - 1))
-
(* Add text with proper spacing *)
-
let trimmed = String.trim text in
-
if trimmed <> "" then begin
-
(* Check if text starts with punctuation that shouldn't have space before it *)
-
let starts_with_punctuation =
-
String.length trimmed > 0 &&
-
(match trimmed.[0] with
-
| ',' | '.' | ';' | ':' | '!' | '?' | ')' | ']' | '}' -> true
-
(* Add space if needed, unless we're before punctuation *)
-
if !need_space && not starts_with_punctuation then begin
-
match last_char () with
-
| Some (' ' | '\n') -> ()
-
| _ -> Buffer.add_char buffer ' '
-
Buffer.add_string buffer trimmed;
-
(* Mark that we need space before next text (for inline elements) *)
-
let mark_space_needed () =
-
need_space := has_whitespace (Buffer.contents buffer) || Buffer.length buffer > 0
-
(* Process header with ID/anchor handling *)
-
let process_header level elem =
-
(* Check if header contains a link with an ID fragment *)
-
let link_opt = Soup.select_one "a[href]" elem in
-
let anchor_id = match link_opt with
-
(match Soup.attribute "href" link with
-
(* Extract fragment from URL *)
-
let uri = Uri.of_string href in
-
(* Add anchor if we found an ID *)
-
| Some id when id <> "" ->
-
Buffer.add_string buffer (Printf.sprintf "\n<a name=\"%s\"></a>\n" id)
-
(* Add the header marker *)
-
let marker = String.make level '#' in
-
Buffer.add_string buffer ("\n" ^ marker ^ " ");
-
(* Get text content, excluding link tags *)
-
let text = Soup.texts elem |> String.concat " " |> String.trim in
-
Buffer.add_string buffer text;
-
Buffer.add_string buffer "\n\n";
-
let rec process_node node =
-
match Soup.element node with
-
let tag = Soup.name elem in
-
(* Block elements - reset space tracking *)
-
| "h1" -> process_header 1 elem
-
| "h2" -> process_header 2 elem
-
| "h3" -> process_header 3 elem
-
| "h4" -> process_header 4 elem
-
| "h5" -> process_header 5 elem
-
| "h6" -> process_header 6 elem
-
Soup.children elem |> Soup.iter process_node;
-
Buffer.add_string buffer "\n\n";
-
Buffer.add_string buffer "\n";
-
(* Inline elements - preserve space tracking *)
-
(* Add space before if needed *)
-
if !need_space then begin
-
match last_char () with
-
| Some (' ' | '\n') -> ()
-
| _ -> Buffer.add_char buffer ' '
-
Buffer.add_string buffer "**";
-
Soup.children elem |> Soup.iter process_node;
-
Buffer.add_string buffer "**";
-
(* Add space before if needed *)
-
if !need_space then begin
-
match last_char () with
-
| Some (' ' | '\n') -> ()
-
| _ -> Buffer.add_char buffer ' '
-
Buffer.add_string buffer "*";
-
Soup.children elem |> Soup.iter process_node;
-
Buffer.add_string buffer "*";
-
(* Add space before if needed *)
-
if !need_space then begin
-
match last_char () with
-
| Some (' ' | '\n') -> ()
-
| _ -> Buffer.add_char buffer ' '
-
Buffer.add_string buffer "`";
-
Soup.children elem |> Soup.iter process_node;
-
Buffer.add_string buffer "`";
-
Buffer.add_string buffer "\n```\n";
-
Soup.children elem |> Soup.iter process_node;
-
Buffer.add_string buffer "\n```\n\n";
-
let text = Soup.texts elem |> String.concat " " |> String.trim in
-
let href = Soup.attribute "href" elem in
-
(* Add space before link if needed *)
-
if !need_space then begin
-
match last_char () with
-
| Some (' ' | '\n') -> ()
-
| _ -> Buffer.add_char buffer ' '
-
(* Add the link markdown *)
-
Buffer.add_string buffer (Printf.sprintf "<%s>" href)
-
Buffer.add_string buffer (Printf.sprintf "[%s](%s)" text href);
-
(* Mark that space may be needed after link *)
-
Buffer.add_string buffer "\n";
-
let is_ordered = tag = "ol" in
-
let items = Soup.children elem |> Soup.to_list in
-
List.iteri (fun i item ->
-
match Soup.element item with
-
| Some li when Soup.name li = "li" ->
-
Buffer.add_string buffer (Printf.sprintf "%d. " (i + 1))
-
Buffer.add_string buffer "- ";
-
Soup.children li |> Soup.iter process_node;
-
Buffer.add_string buffer "\n"
-
Buffer.add_string buffer "\n";
-
Buffer.add_string buffer "\n> ";
-
Soup.children elem |> Soup.iter process_node;
-
Buffer.add_string buffer "\n\n";
-
(* Add space before if needed *)
-
if !need_space then begin
-
match last_char () with
-
| Some (' ' | '\n') -> ()
-
| _ -> Buffer.add_char buffer ' '
-
let alt = Soup.attribute "alt" elem |> Option.value ~default:"" in
-
let src = Soup.attribute "src" elem |> Option.value ~default:"" in
-
Buffer.add_string buffer (Printf.sprintf "" alt src);
-
Buffer.add_string buffer "\n---\n\n";
-
(* Strip these tags but keep content *)
-
| "div" | "span" | "article" | "section" | "header" | "footer"
-
| "main" | "nav" | "aside" | "figure" | "figcaption" | "details" | "summary" ->
-
Soup.children elem |> Soup.iter process_node
-
(* Ignore script, style, etc *)
-
| "script" | "style" | "noscript" -> ()
-
(* Default: just process children *)
-
Soup.children elem |> Soup.iter process_node)
-
(* Text node - handle whitespace properly *)
-
match Soup.leaf_text node with
-
(* If text is only whitespace, mark that we need space *)
-
let trimmed = String.trim text in
-
if trimmed = "" then begin
-
if has_whitespace text then
-
(* Text has content - check if it had leading/trailing whitespace *)
-
let had_leading_ws = has_whitespace text &&
-
(String.length text > 0 &&
-
(text.[0] = ' ' || text.[0] = '\t' || text.[0] = '\n' || text.[0] = '\r')) in
-
(* If had leading whitespace, mark we need space *)
-
if had_leading_ws then need_space := true;
-
(* Add the text content *)
-
(* If had trailing whitespace, mark we need space for next *)
-
let had_trailing_ws = has_whitespace text &&
-
(String.length text > 0 &&
-
let last = text.[String.length text - 1] in
-
last = ' ' || last = '\t' || last = '\n' || last = '\r') in
-
if had_trailing_ws then need_space := true
-
Soup.children soup |> Soup.iter process_node;
-
(* Clean up the result *)
-
let result = Buffer.contents buffer in
-
cleanup_markdown result
-
(** Convert HTML content to clean Markdown *)
-
let to_markdown html_str =
-
html_to_markdown html_str
-
(** {1 Feed Sources} *)
-
let make ~name ~url = { name; url }
-
let make name url = { name; url } in
-
Jsont.Object.map ~kind:"Source" make
-
|> Jsont.Object.mem "name" Jsont.string ~enc:(fun s -> s.name)
-
|> Jsont.Object.mem "url" Jsont.string ~enc:(fun s -> s.url)
-
(** {1 HTTP Session Management} *)
-
module Session = struct
-
session : (float Eio.Time.clock_ty Eio.Resource.t,
-
[`Generic | `Unix] Eio.Net.ty Eio.Resource.t) Requests.t;
-
Log.info (fun m -> m "Initializing River session");
-
let session = Requests.create ~sw
-
~default_headers:(Requests.Headers.of_list [
-
("User-Agent", "OCaml-River/1.0");
-
let with_session env f =
-
Log.info (fun m -> m "Creating River session");
-
Eio.Switch.run @@ fun sw ->
-
let client = init ~sw env in
-
let get_requests_session t = t.session
-
(** {1 Feeds and Posts} *)
-
| Atom of Syndic.Atom.feed
-
| Rss2 of Syndic.Rss2.channel
-
content : feed_content;
-
let string_of_feed = function
-
let classify_feed ~xmlbase (body : string) =
-
Log.debug (fun m -> m "Attempting to parse feed (%d bytes)" (String.length body));
-
(* Quick check - does it look like JSON? *)
-
String.length body > 0 &&
-
let first_char = String.get body 0 in
-
first_char = '{' || first_char = '['
-
if looks_like_json then (
-
(* Try JSONFeed first *)
-
Log.debug (fun m -> m "Body looks like JSON, trying JSONFeed parser");
-
match Jsonfeed.of_string body with
-
Log.debug (fun m -> m "Successfully parsed as JSONFeed");
-
Log.debug (fun m -> m "Not a JSONFeed: %s" (Jsont.Error.to_string err));
-
(* Fall through to XML parsing *)
-
failwith "Not a valid JSONFeed"
-
let feed = Atom (Syndic.Atom.parse ~xmlbase (Xmlm.make_input (`String (0, body)))) in
-
Log.debug (fun m -> m "Successfully parsed as Atom feed");
-
| Syndic.Atom.Error.Error (pos, msg) -> (
-
Log.debug (fun m -> m "Not an Atom feed: %s at position (%d, %d)"
-
msg (fst pos) (snd pos));
-
let feed = Rss2 (Syndic.Rss2.parse ~xmlbase (Xmlm.make_input (`String (0, body)))) in
-
Log.debug (fun m -> m "Successfully parsed as RSS2 feed");
-
with Syndic.Rss2.Error.Error (pos, msg) ->
-
Log.err (fun m -> m "Failed to parse as RSS2: %s at position (%d, %d)"
-
msg (fst pos) (snd pos));
-
failwith "Neither Atom nor RSS2 feed")
-
Log.err (fun m -> m "Not_found exception during Atom feed parsing");
-
Log.err (fun m -> m "Backtrace:\n%s" (Printexc.get_backtrace ()));
-
Log.err (fun m -> m "Unexpected exception during feed parsing: %s"
-
(Printexc.to_string e));
-
Log.err (fun m -> m "Backtrace:\n%s" (Printexc.get_backtrace ()));
-
let fetch session source =
-
Log.info (fun m -> m "Fetching feed: %s" (Source.name source));
-
let xmlbase = Uri.of_string (Source.url source) in
-
(* Use Requests_json_api.get_result for clean Result-based error handling *)
-
let requests_session = Session.get_requests_session session in
-
match Requests_json_api.get_result requests_session (Source.url source) with
-
Log.info (fun m -> m "Successfully fetched %s (%d bytes)"
-
(Source.url source) (String.length body));
-
| Error (status, msg) ->
-
Log.err (fun m -> m "Failed to fetch feed '%s': HTTP %d - %s"
-
(Source.name source) status msg);
-
failwith (Printf.sprintf "HTTP %d: %s" status msg)
-
let content = classify_feed ~xmlbase response in
-
| Atom atom -> Text_extract.string_of_text_construct atom.Syndic.Atom.title
-
| Rss2 ch -> ch.Syndic.Rss2.title
-
| Json jsonfeed -> Jsonfeed.title jsonfeed
-
Log.info (fun m -> m "Successfully fetched %s feed '%s' (title: '%s')"
-
(string_of_feed content) (Source.name source) title);
-
{ source; title; content }
-
let source t = t.source
-
date : Syndic.Date.t option;
-
content : Soup.soup Soup.node;
-
mutable link_response : (string, string) result option;
-
summary : string option;
-
(** Generate a stable, unique ID from available data *)
-
let generate_id ?guid ?link ?title ?date ~feed_url () =
-
| Some id when id <> "" ->
-
(* Use explicit ID/GUID if available *)
-
| Some uri when Uri.to_string uri <> "" ->
-
(* Use permalink as ID (stable and unique) *)
-
(* Fallback: hash of feed_url + title + date *)
-
let title_str = Option.value title ~default:"" in
-
| Some d -> Ptime.to_rfc3339 d
-
let composite = Printf.sprintf "%s|%s|%s" feed_url title_str date_str in
-
(* Use SHA256 for stable hashing *)
-
Digest.string composite |> Digest.to_hex
-
let resolve_links_attr ~xmlbase attr el =
-
Soup.R.attribute attr el
-
|> Syndic.XML.resolve ~xmlbase
-
|> fun value -> Soup.set_attribute attr value el
-
(* Things that posts should not contain *)
-
let undesired_tags = [ "style"; "script" ]
-
let undesired_attr = [ "id" ]
-
let html_of_text ?xmlbase s =
-
let soup = Soup.parse s in
-
let ($$) = Soup.($$) in
-
soup $$ "a[href]" |> Soup.iter (resolve_links_attr ~xmlbase "href");
-
soup $$ "img[src]" |> Soup.iter (resolve_links_attr ~xmlbase "src");
-
undesired_tags |> List.iter (fun tag -> soup $$ tag |> Soup.iter Soup.delete);
-
soup $$ "*" |> Soup.iter (fun el ->
-
undesired_attr |> List.iter (fun attr -> Soup.delete_attribute attr el));
-
(* Do not trust sites using XML for HTML content. Convert to string and parse
-
back. (Does not always fix bad HTML unfortunately.) *)
-
let ns_prefix _ = Some "" in
-
(String.concat "" (List.map (Syndic.XML.to_string ~ns_prefix) h))
-
let string_of_option = function None -> "" | Some s -> s
-
let post_compare p1 p2 =
-
(* Most recent posts first. Posts with no date are always last *)
-
match (p1.date, p2.date) with
-
| Some d1, Some d2 -> Syndic.Date.compare d2 d1
-
if n <= 0 then l else match l with [] -> [] | _ :: tl -> remove (n - 1) tl
-
let rec take n = function
-
| e :: tl -> if n > 0 then e :: take (n - 1) tl else []
-
let post_of_atom ~(feed : Feed.t) (e : Syndic.Atom.entry) =
-
Log.debug (fun m -> m "Processing Atom entry: %s"
-
(Text_extract.string_of_text_construct e.title));
-
(List.find (fun l -> l.Syndic.Atom.rel = Syndic.Atom.Alternate) e.links)
-
Log.debug (fun m -> m "No alternate link found, trying fallback");
-
| l :: _ -> Some l.href
-
match Uri.scheme e.id with
-
| Some "http" -> Some e.id
-
| Some "https" -> Some e.id
-
match e.published with Some _ -> e.published | None -> Some e.updated
-
| Some (Text s) -> html_of_text s
-
| Some (Html (xmlbase, s)) -> html_of_text ?xmlbase s
-
| Some (Xhtml (xmlbase, h)) -> html_of_syndic ?xmlbase h
-
| Some (Mime _) | Some (Src _) | None -> (
-
| Some (Text s) -> html_of_text s
-
| Some (Html (xmlbase, s)) -> html_of_text ?xmlbase s
-
| Some (Xhtml (xmlbase, h)) -> html_of_syndic ?xmlbase h
-
| None -> Soup.parse "")
-
let is_valid_author_name name =
-
(* Filter out empty strings and placeholder values like "Unknown" *)
-
let trimmed = String.trim name in
-
trimmed <> "" && trimmed <> "Unknown"
-
(* Fallback chain for author:
-
1. Entry author (if present, not empty, and not "Unknown")
-
2. Feed-level author (from Atom feed metadata)
-
3. Feed title (from Atom feed metadata)
-
4. Source name (manually entered feed name) *)
-
let author, _ = e.authors in
-
let trimmed = String.trim author.name in
-
if is_valid_author_name author.name then trimmed
-
else raise Not_found (* Try feed-level author *)
-
match feed.content with
-
| Feed.Atom atom_feed -> (
-
(* Try feed-level authors *)
-
match atom_feed.Syndic.Atom.authors with
-
| author :: _ when is_valid_author_name author.name ->
-
String.trim author.name
-
Text_extract.string_of_text_construct atom_feed.Syndic.Atom.title)
-
| Feed.Rss2 _ | Feed.Json _ ->
-
(* For RSS2 and JSONFeed, use the source name *)
-
Source.name feed.source)
-
(* Extract tags from Atom categories *)
-
List.map (fun cat -> cat.Syndic.Atom.term) e.categories
-
(* Extract summary - convert from text_construct to string *)
-
| Some s -> Some (Text_extract.string_of_text_construct s)
-
(* Generate unique ID *)
-
let guid = Uri.to_string e.id in
-
let title_str = Text_extract.string_of_text_construct e.title in
-
generate_id ~guid ?link ~title:title_str ?date
-
~feed_url:(Source.url feed.source) ()
-
let post_of_rss2 ~(feed : Feed.t) it =
-
match it.Syndic.Rss2.story with
-
| All (t, xmlbase, d) -> (
-
| _, "" -> html_of_text ?xmlbase d
-
| xmlbase, c -> html_of_text ?xmlbase c ))
-
let xmlbase, c = it.content in
-
(t, html_of_text ?xmlbase c)
-
| Description (xmlbase, d) -> (
-
| _, "" -> html_of_text ?xmlbase d
-
| xmlbase, c -> html_of_text ?xmlbase c ))
-
(* Note: it.link is of type Uri.t option in Syndic *)
-
match (it.guid, it.link) with
-
| Some u, _ when u.permalink -> Some u.data
-
(* Sometimes the guid is indicated with isPermaLink="false" but is
-
nonetheless the only URL we get (e.g. ocamlpro). *)
-
(* Extract GUID string for ID generation *)
-
| Some u -> Some (Uri.to_string u.data)
-
(* RSS2 doesn't have a categories field exposed, use empty list *)
-
(* RSS2 doesn't have a separate summary field, so leave it empty *)
-
(* Generate unique ID *)
-
generate_id ?guid:guid_str ?link ~title ?date:it.pubDate
-
~feed_url:(Source.url feed.source) ()
-
author = Source.name feed.source;
-
email = string_of_option it.author;
-
let post_of_jsonfeed_item ~(feed : Feed.t) (item : Jsonfeed.Item.t) =
-
Log.debug (fun m -> m "Processing JSONFeed item: %s"
-
(Option.value (Jsonfeed.Item.title item) ~default:"Untitled"));
-
(* Extract content - prefer HTML, fall back to text *)
-
match Jsonfeed.Item.content item with
-
| `Html html -> html_of_text html
-
| `Text text -> html_of_text text
-
| `Both (html, _text) -> html_of_text html
-
(* Extract author - use first author if multiple *)
-
let author_name, author_email =
-
match Jsonfeed.Item.authors item with
-
let name = Jsonfeed.Author.name first |> Option.value ~default:"" in
-
(* JSONFeed authors don't typically have email *)
-
(* Fall back to feed-level authors or feed title *)
-
(match feed.content with
-
| Feed.Json jsonfeed ->
-
(match Jsonfeed.authors jsonfeed with
-
let name = Jsonfeed.Author.name first |> Option.value ~default:feed.title in
-
| _ -> (feed.title, ""))
-
| _ -> (feed.title, ""))
-
(* Link - use url field *)
-
|> Option.map Uri.of_string
-
let date = Jsonfeed.Item.date_published item in
-
let summary = Jsonfeed.Item.summary item in
-
Jsonfeed.Item.tags item
-
|> Option.value ~default:[]
-
(* Generate unique ID - JSONFeed items always have an id field (required) *)
-
let guid = Jsonfeed.Item.id item in
-
let title_str = Jsonfeed.Item.title item |> Option.value ~default:"Untitled" in
-
generate_id ~guid ?link ~title:title_str ?date
-
~feed_url:(Source.url feed.source) ()
-
match c.Feed.content with
-
let posts = List.map (post_of_atom ~feed:c) f.Syndic.Atom.entries in
-
Log.debug (fun m -> m "Extracted %d posts from Atom feed '%s'"
-
(List.length posts) (Source.name c.source));
-
let posts = List.map (post_of_rss2 ~feed:c) ch.Syndic.Rss2.items in
-
Log.debug (fun m -> m "Extracted %d posts from RSS2 feed '%s'"
-
(List.length posts) (Source.name c.source));
-
| Feed.Json jsonfeed ->
-
let items = Jsonfeed.items jsonfeed in
-
let posts = List.map (post_of_jsonfeed_item ~feed:c) items in
-
Log.debug (fun m -> m "Extracted %d posts from JSONFeed '%s'"
-
(List.length posts) (Source.name c.source));
-
let get_posts ?n ?(ofs = 0) planet_feeds =
-
Log.info (fun m -> m "Processing %d feeds for posts" (List.length planet_feeds));
-
let posts = List.concat @@ List.map posts_of_feed planet_feeds in
-
Log.debug (fun m -> m "Total posts collected: %d" (List.length posts));
-
let posts = List.sort post_compare posts in
-
Log.debug (fun m -> m "Posts sorted by date (most recent first)");
-
let posts = remove ofs posts in
-
Log.debug (fun m -> m "Returning all %d posts (offset=%d)"
-
(List.length posts) ofs);
-
let limited = take n posts in
-
Log.debug (fun m -> m "Returning %d posts (requested=%d, offset=%d)"
-
(List.length limited) n ofs);
-
let of_feeds feeds = get_posts feeds
-
let author t = t.author
-
let content t = Soup.to_string t.content
-
let summary t = t.summary
-
let meta_description _t =
-
(* TODO: This requires environment for HTTP access *)
-
Log.debug (fun m -> m "meta_description not implemented (requires environment)");
-
(* TODO: This requires environment for HTTP access *)
-
Log.debug (fun m -> m "seo_image not implemented (requires environment)");
-
(** {1 Format Conversion and Export} *)
-
let entry_of_post post =
-
let content = Syndic.Atom.Html (None, Post.content post) in
-
[ Syndic.Atom.author ~uri:(Uri.of_string (Source.url (Feed.source (Post.feed post))))
-
(Source.name (Feed.source (Post.feed post))) ]
-
match Post.link post with
-
| Some l -> [ Syndic.Atom.link ~rel:Syndic.Atom.Alternate l ]
-
match Post.link post with
-
| None -> Uri.of_string (Digest.to_hex (Digest.string (Post.title post)))
-
let authors = (Syndic.Atom.author ~email:(Post.email post) (Post.author post), []) in
-
let title : Syndic.Atom.text_construct = Syndic.Atom.Text (Post.title post) in
-
match Post.date post with
-
(* Atom entry requires a date but RSS2 does not. So if a date
-
* is not available, just capture the current date. *)
-
| None -> Ptime.of_float_s (Unix.gettimeofday ()) |> Option.get
-
Syndic.Atom.entry ~content ~contributors ~links ~id ~authors ~title ~updated
-
let entries_of_posts posts = List.map entry_of_post posts
-
let feed_of_entries ~title ?id ?(authors = []) entries =
-
let feed_id = match id with
-
| Some i -> Uri.of_string i
-
| None -> Uri.of_string "urn:river:merged"
-
let feed_authors = List.map (fun (name, email) ->
-
| Some e -> Syndic.Atom.author ~email:e name
-
| None -> Syndic.Atom.author name
-
Syndic.Atom.id = feed_id;
-
title = Syndic.Atom.Text title;
-
updated = Ptime.of_float_s (Unix.time ()) |> Option.get;
-
authors = feed_authors;
-
Syndic.Atom.version = Some "1.0";
-
content = "River Feed Aggregator";
-
let output = Buffer.create 4096 in
-
Syndic.Atom.output feed (`Buffer output);
-
match feed.Feed.content with
-
| Feed.Rss2 ch -> Some ch
-
module Jsonfeed = struct
-
let item_of_post post =
-
(* Convert HTML content back to string *)
-
let html = Post.content post in
-
let content = `Html html in
-
if Post.author post <> "" then
-
let author = Jsonfeed.Author.create ~name:(Post.author post) () in
-
?url:(Option.map Uri.to_string (Post.link post))
-
~title:(Post.title post)
-
?summary:(Post.summary post)
-
?date_published:(Post.date post)
-
let items_of_posts posts = List.map item_of_post posts
-
let feed_of_items ~title ?home_page_url ?feed_url ?description ?icon ?favicon items =
-
Jsonfeed.create ~title ?home_page_url ?feed_url ?description ?icon ?favicon ~items ()
-
let feed_of_posts ~title ?home_page_url ?feed_url ?description ?icon ?favicon posts =
-
let items = items_of_posts posts in
-
feed_of_items ~title ?home_page_url ?feed_url ?description ?icon ?favicon items
-
let to_string ?(minify = false) jsonfeed =
-
match Jsonfeed.to_string ~minify jsonfeed with
-
| Error err -> Error (Jsont.Error.to_string err)
-
match feed.Feed.content with
-
| Feed.Json jf -> Some jf
-
(** {1 User Management} *)
-
last_synced : string option;
-
let make ~username ~fullname ?email ?(feeds = []) ?last_synced () =
-
{ username; fullname; email; feeds; last_synced }
-
let username t = t.username
-
let fullname t = t.fullname
-
let last_synced t = t.last_synced
-
let add_feed t source =
-
{ t with feeds = source :: t.feeds }
-
let remove_feed t ~url =
-
let feeds = List.filter (fun s -> Source.url s <> url) t.feeds in
-
let set_last_synced t timestamp =
-
{ t with last_synced = Some timestamp }
-
let make username fullname email feeds last_synced =
-
{ username; fullname; email; feeds; last_synced }
-
Jsont.Object.map ~kind:"User" make
-
|> Jsont.Object.mem "username" Jsont.string ~enc:(fun u -> u.username)
-
|> Jsont.Object.mem "fullname" Jsont.string ~enc:(fun u -> u.fullname)
-
|> Jsont.Object.opt_mem "email" Jsont.string ~enc:(fun u -> u.email)
-
|> Jsont.Object.mem "feeds" (Jsont.list Source.jsont) ~enc:(fun u -> u.feeds)
-
|> Jsont.Object.opt_mem "last_synced" Jsont.string ~enc:(fun u -> u.last_synced)
-
(** {1 Feed Quality Analysis} *)
-
module Quality = struct
-
entries_with_summary : int;
-
entries_with_author : int;
-
entries_with_date : int;
-
entries_with_content : int;
-
entries_with_tags : int;
-
avg_content_length : float;
-
min_content_length : int;
-
max_content_length : int;
-
posting_frequency_days : float option;
-
let make ~total_entries ~entries_with_summary ~entries_with_author
-
~entries_with_date ~entries_with_content ~entries_with_tags
-
~avg_content_length ~min_content_length ~max_content_length
-
~posting_frequency_days ~quality_score =
-
posting_frequency_days;
-
let total_entries t = t.total_entries
-
let entries_with_summary t = t.entries_with_summary
-
let entries_with_author t = t.entries_with_author
-
let entries_with_date t = t.entries_with_date
-
let entries_with_content t = t.entries_with_content
-
let entries_with_tags t = t.entries_with_tags
-
let avg_content_length t = t.avg_content_length
-
let min_content_length t = t.min_content_length
-
let max_content_length t = t.max_content_length
-
let posting_frequency_days t = t.posting_frequency_days
-
let quality_score t = t.quality_score
-
(** Get content length from an Atom entry *)
-
let get_content_length (entry : Syndic.Atom.entry) =
-
match entry.content with
-
| Some (Syndic.Atom.Text s) -> String.length s
-
| Some (Syndic.Atom.Html (_, s)) -> String.length s
-
| Some (Syndic.Atom.Xhtml (_, _)) -> 0 (* Could calculate but complex *)
-
| Some (Syndic.Atom.Mime _) -> 0
-
| Some (Syndic.Atom.Src _) -> 0
-
match entry.summary with
-
| Some (Syndic.Atom.Text s) -> String.length s
-
| Some (Syndic.Atom.Html (_, s)) -> String.length s
-
| Some (Syndic.Atom.Xhtml (_, _)) -> 0
-
(** Check if entry has non-empty summary *)
-
let has_summary (entry : Syndic.Atom.entry) =
-
match entry.summary with
-
| Some (Syndic.Atom.Text s) when String.trim s <> "" -> true
-
| Some (Syndic.Atom.Html (_, s)) when String.trim s <> "" -> true
-
| Some (Syndic.Atom.Xhtml (_, _)) -> true
-
(** Check if entry has author *)
-
let has_author (entry : Syndic.Atom.entry) =
-
let (author, _) = entry.authors in
-
String.trim author.name <> ""
-
(** Check if entry has content *)
-
let has_content (entry : Syndic.Atom.entry) =
-
get_content_length entry > 0
-
(** Check if entry has tags/categories *)
-
let has_tags (entry : Syndic.Atom.entry) =
-
(** Calculate quality score from metrics *)
-
let calculate_quality_score t =
-
let total = float_of_int t.total_entries in
-
if total = 0.0 then 0.0
-
let summary_pct = float_of_int t.entries_with_summary /. total *. 100.0 in
-
let author_pct = float_of_int t.entries_with_author /. total *. 100.0 in
-
let date_pct = float_of_int t.entries_with_date /. total *. 100.0 in
-
let content_pct = float_of_int t.entries_with_content /. total *. 100.0 in
-
let tags_pct = float_of_int t.entries_with_tags /. total *. 100.0 in
-
(* Weighted average: content and dates are most important *)
-
(content_pct *. 0.30) +.
-
(author_pct *. 0.20) +.
-
(summary_pct *. 0.15) +.
-
failwith "No entries to analyze"
-
let total_entries = List.length entries in
-
let entries_with_summary = ref 0 in
-
let entries_with_author = ref 0 in
-
let entries_with_date = ref total_entries in (* All Atom entries have updated *)
-
let entries_with_content = ref 0 in
-
let entries_with_tags = ref 0 in
-
let content_lengths = ref [] in
-
List.iter (fun (entry : Syndic.Atom.entry) ->
-
if has_summary entry then incr entries_with_summary;
-
if has_author entry then incr entries_with_author;
-
if has_content entry then begin
-
incr entries_with_content;
-
content_lengths := get_content_length entry :: !content_lengths
-
if has_tags entry then incr entries_with_tags;
-
dates := entry.updated :: !dates
-
(* Calculate content statistics *)
-
let avg_content_length, min_content_length, max_content_length =
-
if !content_lengths = [] then
-
let sorted = List.sort compare !content_lengths in
-
let sum = List.fold_left (+) 0 sorted in
-
let avg = float_of_int sum /. float_of_int (List.length sorted) in
-
let min_len = List.hd sorted in
-
let max_len = List.hd (List.rev sorted) in
-
(avg, min_len, max_len)
-
(* Calculate posting frequency *)
-
let posting_frequency_days =
-
if List.length !dates < 2 then
-
let timestamps = List.map Ptime.to_float_s !dates in
-
let sorted_timestamps = List.sort compare timestamps in
-
let first = List.hd sorted_timestamps in
-
let last = List.hd (List.rev sorted_timestamps) in
-
let total_days = (last -. first) /. 86400.0 in
-
let num_intervals = float_of_int (List.length sorted_timestamps - 1) in
-
Some (total_days /. num_intervals)
-
(* Create metrics record (without quality_score first) *)
-
entries_with_summary = !entries_with_summary;
-
entries_with_author = !entries_with_author;
-
entries_with_date = !entries_with_date;
-
entries_with_content = !entries_with_content;
-
entries_with_tags = !entries_with_tags;
-
posting_frequency_days;
-
quality_score = 0.0; (* Placeholder *)
-
(* Calculate quality score *)
-
let quality_score = calculate_quality_score metrics in
-
{ metrics with quality_score }
-
(** {1 State Management} *)
-
(** Get the users directory path *)
-
let users_dir state = Eio.Path.(Xdge.state_dir state.xdg / "users")
-
(** Get the feeds directory path *)
-
let feeds_dir state = Eio.Path.(Xdge.state_dir state.xdg / "feeds")
-
(** Get the user feeds directory path *)
-
let user_feeds_dir state = Eio.Path.(feeds_dir state / "user")
-
(** Get the path to a user's JSON file *)
-
let user_file state username =
-
Eio.Path.(users_dir state / (username ^ ".json"))
-
(** Get the path to a user's Atom feed file *)
-
let user_feed_file state username =
-
Eio.Path.(user_feeds_dir state / (username ^ ".xml"))
-
(** Ensure all necessary directories exist *)
-
let ensure_directories state =
-
try Eio.Path.mkdir ~perm:0o755 dir
-
with Eio.Io (Eio.Fs.E (Already_exists _), _) -> ()
-
(** Decode a user from JSON string *)
-
match Jsont_bytesrw.decode_string' User.jsont s with
-
Log.err (fun m -> m "Failed to parse user JSON: %s" (Jsont.Error.to_string err));
-
(** Encode a user to JSON string *)
-
let user_to_string user =
-
match Jsont_bytesrw.encode_string' ~format:Jsont.Indent User.jsont user with
-
| Error err -> failwith ("Failed to encode user: " ^ Jsont.Error.to_string err)
-
module Storage = struct
-
(** Load a user from disk *)
-
let load_user state username =
-
let file = Paths.user_file state username in
-
let content = Eio.Path.load file in
-
Json.user_of_string content
-
| Eio.Io (Eio.Fs.E (Not_found _), _) -> None
-
Log.err (fun m -> m "Error loading user %s: %s" username (Printexc.to_string e));
-
(** Save a user to disk *)
-
let save_user state user =
-
let file = Paths.user_file state (User.username user) in
-
let json = Json.user_to_string user in
-
Eio.Path.save ~create:(`Or_truncate 0o644) file json
-
(** List all usernames *)
-
Eio.Path.read_dir (Paths.users_dir state)
-
|> List.filter_map (fun name ->
-
if Filename.check_suffix name ".json" then
-
Some (Filename.chop_suffix name ".json")
-
(** Load existing Atom entries for a user *)
-
let load_existing_posts state username =
-
let file = Paths.user_feed_file state username in
-
let content = Eio.Path.load file in
-
(* Parse existing Atom feed *)
-
let input = Xmlm.make_input (`String (0, content)) in
-
let feed = Syndic.Atom.parse input in
-
feed.Syndic.Atom.entries
-
| Eio.Io (Eio.Fs.E (Not_found _), _) -> []
-
Log.err (fun m -> m "Error loading existing posts for %s: %s"
-
username (Printexc.to_string e));
-
(** Save Atom entries for a user *)
-
let save_atom_feed state username entries =
-
let file = Paths.user_feed_file state username in
-
let feed = Format.Atom.feed_of_entries ~title:username entries in
-
let xml = Format.Atom.to_string feed in
-
Eio.Path.save ~create:(`Or_truncate 0o644) file xml
-
(** Delete a user and their feed file *)
-
let delete_user state username =
-
let user_file = Paths.user_file state username in
-
let feed_file = Paths.user_feed_file state username in
-
(try Eio.Path.unlink user_file with _ -> ());
-
(try Eio.Path.unlink feed_file with _ -> ())
-
(** Merge new entries with existing ones, updating matching IDs *)
-
let merge_entries ~existing ~new_entries =
-
(* Create a map of new entry IDs for efficient lookup and updates *)
-
let module UriMap = Map.Make(Uri) in
-
List.fold_left (fun acc (entry : Syndic.Atom.entry) ->
-
UriMap.add entry.id entry acc
-
) UriMap.empty new_entries
-
(* Update existing entries with new ones if IDs match, otherwise keep existing *)
-
List.filter_map (fun (entry : Syndic.Atom.entry) ->
-
if UriMap.mem entry.id new_entries_map then
-
None (* Will be replaced by new entry *)
-
Some entry (* Keep existing entry *)
-
(* Combine new entries with non-replaced existing entries *)
-
let combined = new_entries @ updated_existing in
-
List.sort (fun (a : Syndic.Atom.entry) (b : Syndic.Atom.entry) ->
-
Ptime.compare b.updated a.updated
-
(** Get current timestamp in ISO 8601 format *)
-
let current_timestamp () =
-
let tm = gmtime (time ()) in
-
Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ"
-
(tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday
-
tm.tm_hour tm.tm_min tm.tm_sec
-
(** Sync feeds for a single user *)
-
let sync_user session state ~username =
-
match Storage.load_user state username with
-
Error (Printf.sprintf "User %s not found" username)
-
| Some user when User.feeds user = [] ->
-
Log.info (fun m -> m "No feeds configured for user %s" username);
-
Log.info (fun m -> m "Syncing feeds for user %s..." username);
-
(* Fetch all feeds concurrently *)
-
Eio.Fiber.List.filter_map (fun source ->
-
Log.info (fun m -> m " Fetching %s (%s)..."
-
(Source.name source) (Source.url source));
-
Some (Feed.fetch session source)
-
Log.err (fun m -> m " Failed to fetch %s: %s"
-
(Source.name source) (Printexc.to_string e));
-
if fetched_feeds = [] then begin
-
Error "No feeds successfully fetched"
-
(* Get posts from fetched feeds *)
-
let posts = Post.of_feeds fetched_feeds in
-
Log.info (fun m -> m " Found %d new posts" (List.length posts));
-
(* Convert to Atom entries *)
-
let new_entries = Format.Atom.entries_of_posts posts in
-
(* Load existing entries *)
-
let existing = Storage.load_existing_posts state username in
-
Log.info (fun m -> m " Found %d existing posts" (List.length existing));
-
let merged = merge_entries ~existing ~new_entries in
-
Log.info (fun m -> m " Total posts after merge: %d" (List.length merged));
-
(* Save updated feed *)
-
Storage.save_atom_feed state username merged;
-
(* Update last_synced timestamp *)
-
let now = current_timestamp () in
-
let user = User.set_last_synced user now in
-
Storage.save_user state user;
-
Log.info (fun m -> m "Sync completed for user %s" username);
-
(** Convert Atom entry to JSONFeed item *)
-
let atom_entry_to_jsonfeed_item (entry : Syndic.Atom.entry) =
-
let id = Uri.to_string entry.id in
-
| Syndic.Atom.Text s -> Some s
-
| Syndic.Atom.Html (_, s) -> Some s
-
| Syndic.Atom.Xhtml (_, _) -> Some "Untitled"
-
| link :: _ -> Some (Uri.to_string link.href)
-
match entry.content with
-
| Some (Syndic.Atom.Text s) -> `Text s
-
| Some (Syndic.Atom.Html (_, s)) -> `Html s
-
| Some (Syndic.Atom.Xhtml (_, nodes)) ->
-
let html = String.concat "" (List.map Syndic.XML.to_string nodes) in
-
| Some (Syndic.Atom.Mime _) | Some (Syndic.Atom.Src _) | None ->
-
match entry.summary with
-
| Some (Syndic.Atom.Text s) when String.trim s <> "" -> Some s
-
| Some (Syndic.Atom.Html (_, s)) when String.trim s <> "" -> Some s
-
let (author, contributors) = entry.authors in
-
let author_list = author :: contributors in
-
let jsonfeed_authors = List.filter_map (fun (a : Syndic.Atom.author) ->
-
let name = String.trim a.name in
-
else Some (Jsonfeed.Author.create ~name ())
-
if jsonfeed_authors = [] then None else Some jsonfeed_authors
-
match entry.categories with
-
let tag_list = List.map (fun (c : Syndic.Atom.category) ->
-
if tag_list = [] then None else Some tag_list
-
(* Create JSONFeed item *)
-
~date_published:entry.updated
-
(** Export entries as JSONFeed *)
-
let export_jsonfeed ~title entries =
-
let items = List.map atom_entry_to_jsonfeed_item entries in
-
let feed = Jsonfeed.create ~title ~items () in
-
match Jsonfeed.to_string ~minify:false feed with
-
| Error err -> Error (Printf.sprintf "Failed to serialize JSON Feed: %s" (Jsont.Error.to_string err))
-
let create env ~app_name =
-
let xdg = Xdge.create env#fs app_name in
-
Paths.ensure_directories state;
-
let create_user state user =
-
match Storage.load_user state (User.username user) with
-
Error (Printf.sprintf "User %s already exists" (User.username user))
-
Storage.save_user state user;
-
Log.info (fun m -> m "User %s created" (User.username user));
-
let delete_user state ~username =
-
match Storage.load_user state username with
-
Error (Printf.sprintf "User %s not found" username)
-
Storage.delete_user state username;
-
Log.info (fun m -> m "User %s deleted" username);
-
let get_user state ~username =
-
Storage.load_user state username
-
let update_user state user =
-
match Storage.load_user state (User.username user) with
-
Error (Printf.sprintf "User %s not found" (User.username user))
-
Storage.save_user state user;
-
Log.info (fun m -> m "User %s updated" (User.username user));
-
Storage.list_users state
-
let sync_user env state ~username =
-
Session.with_session env @@ fun session ->
-
Sync.sync_user session state ~username
-
let sync_all env state =
-
let users = Storage.list_users state in
-
if users = [] then begin
-
Log.info (fun m -> m "No users to sync");
-
Log.info (fun m -> m "Syncing %d users concurrently..." (List.length users));
-
Session.with_session env @@ fun session ->
-
Eio.Fiber.List.map (fun username ->
-
match Sync.sync_user session state ~username with
-
Log.err (fun m -> m "Failed to sync user %s: %s" username err);
-
let success_count = List.length (List.filter (fun x -> x) results) in
-
let fail_count = List.length users - success_count in
-
Log.info (fun m -> m "All users synced successfully");
-
Ok (success_count, fail_count)
-
let get_user_posts state ~username ?limit () =
-
let entries = Storage.load_existing_posts state username in
-
| Some n -> List.filteri (fun i _ -> i < n) entries
-
let get_all_posts state ?limit () =
-
let users = Storage.list_users state in
-
(* Collect all entries from all users with username tag *)
-
List.concat_map (fun username ->
-
let entries = Storage.load_existing_posts state username in
-
List.map (fun entry -> (username, entry)) entries
-
(* Sort by date (newest first) *)
-
let sorted = List.sort (fun (_, a : string * Syndic.Atom.entry) (_, b) ->
-
Ptime.compare b.updated a.updated
-
| Some n -> List.filteri (fun i _ -> i < n) sorted
-
let export_merged_feed state ~title ~format ?limit () =
-
let all_posts = get_all_posts state ?limit () in
-
let entries = List.map snd all_posts in
-
let xml = Format.Atom.to_string (Format.Atom.feed_of_entries ~title entries) in
-
let feed = Jsonfeed.create ~title ~items:[] () in
-
match Jsonfeed.to_string ~minify:false feed with
-
| Error err -> Error (Printf.sprintf "Failed to serialize JSON Feed: %s" (Jsont.Error.to_string err))
-
Export.export_jsonfeed ~title entries
-
let analyze_user_quality state ~username =
-
match Storage.load_user state username with
-
Error (Printf.sprintf "User %s not found" username)
-
let entries = Storage.load_existing_posts state username in
-
Error "No entries to analyze"
-
Ok (Quality.analyze entries)
anil.recoil.org