···
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+
(** 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