commit 594747381aff405b9db2c29dd24e36cf73f56c04
Author: Coder Agent <coder@agents.omni>
Date: Mon Feb 16 13:32:00 2026
Omni/Newsreader: web UI, JSON API, and topic clustering
Entry point with serve + ingest subcommands. Background feed
ingestion thread. River-of-news HTML UI with minimal text-focused
styling and dark mode. JSON API for programmatic access (Ava).
Simple keyword-based topic clustering for grouping related articles.
- Omni/Newsreader.hs: CLI entry point, warp server, background ingest
- Omni/Newsreader/Web.hs: WAI app with HTML views + JSON API
- Omni/Newsreader/Cluster.hs: keyword co-occurrence clustering
- Omni/Newsreader/Db.hs: embed schema SQL for nix closure compat
- Omni/Newsreader/Article.hs: add Ord to ArticleId
- Omni/Newsreader/Feed.hs: add Ord to FeedId
Task-Id: t-488
diff --git a/Omni/Newsreader.hs b/Omni/Newsreader.hs
new file mode 100755
index 00000000..dc94c3a1
--- /dev/null
+++ b/Omni/Newsreader.hs
@@ -0,0 +1,135 @@
+#!/usr/bin/env run.sh
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Newsreader: RSS/Atom reader with topic clustering.
+--
+-- Usage:
+-- newsreader serve # Start web server (port 8071)
+-- newsreader serve --port 9000 # Custom port
+-- newsreader ingest # Fetch all feeds once
+--
+-- : out newsreader
+-- : dep aeson
+-- : dep async
+-- : dep lucid
+-- : dep sqlite-simple
+-- : dep wai
+-- : dep warp
+-- : dep http-types
+-- : dep containers
+-- : dep time
+-- : dep directory
+-- : dep bytestring
+-- : dep req
+-- : dep feed
+-- : dep tagsoup
+-- : dep modern-uri
+-- : dep vector
+-- : dep cereal
+module Omni.Newsreader
+ ( main,
+ test,
+ )
+where
+
+import Alpha
+import qualified Control.Concurrent as Concurrent
+import qualified Control.Concurrent.Async as Async
+import qualified Data.Text as T
+import qualified Network.Wai.Handler.Warp as Warp
+import qualified Omni.Cli as Cli
+import qualified Omni.Newsreader.Db as Db
+import qualified Omni.Newsreader.Feed as Feed
+import qualified Omni.Newsreader.Ingest as Ingest
+import qualified Omni.Newsreader.Web as Web
+import qualified Omni.Test as Test
+
+main :: IO ()
+main = Cli.main plan
+
+plan :: Cli.Plan ()
+plan =
+ Cli.Plan
+ { Cli.move = parser,
+ Cli.test = test,
+ Cli.tidy = \_ -> pure ()
+ }
+
+parser :: Cli.Parser (IO ())
+parser =
+ Cli.subparser
+ ( Cli.command "serve" (Cli.info serveParser (Cli.progDesc "Start web server"))
+ <> Cli.command "ingest" (Cli.info ingestParser (Cli.progDesc "Fetch all feeds once"))
+ )
+
+serveParser :: Cli.Parser (IO ())
+serveParser =
+ doServe
+ </ Cli.option
+ Cli.auto
+ ( Cli.long "port"
+ <> Cli.value (8071 :: Int)
+ <> Cli.help "Port to listen on"
+ )
+ <*> Cli.option
+ Cli.auto
+ ( Cli.long "interval"
+ <> Cli.value (1800 :: Int)
+ <> Cli.help "Feed fetch interval in seconds (0 to disable)"
+ )
+
+ingestParser :: Cli.Parser (IO ())
+ingestParser = pure doIngest
+
+-- | Start the web server with optional background ingestion.
+doServe :: Int -> Int -> IO ()
+doServe port interval = do
+ Db.initDb
+ Db.withDb <| \conn -> do
+ putText <| "newsreader listening on port " <> T.pack (show port)
+
+ -- Start background ingestion thread if interval > 0
+ if interval > 0
+ then do
+ putText <| "background ingestion every " <> T.pack (show interval) <> "s"
+ Async.withAsync (backgroundIngest interval) <| \_ ->
+ Warp.run port (Web.app conn)
+ else Warp.run port (Web.app conn)
+
+-- | Background feed ingestion loop.
+backgroundIngest :: Int -> IO ()
+backgroundIngest interval =
+ forever <| do
+ Concurrent.threadDelay (interval * 1_000_000)
+ putText "background: fetching feeds..."
+ result <-
+ try <| Db.withDb <| \conn -> do
+ results <- Ingest.fetchAllFeeds conn
+ let totalNew = sum [Ingest.statsNewArticles s | (_, Ingest.IngestSuccess s) <- results]
+ putText <| "background: ingested " <> T.pack (show totalNew) <> " new articles from " <> T.pack (show (length results)) <> " feeds"
+ case result of
+ Left (e :: SomeException) ->
+ putText <| "background: ingestion error: " <> T.pack (show e)
+ Right () -> pure ()
+
+-- | One-shot feed ingestion.
+doIngest :: IO ()
+doIngest = do
+ Db.initDb
+ Db.withDb <| \conn -> do
+ results <- Ingest.fetchAllFeeds conn
+ forM_ results <| \(feed, result) -> do
+ let url = Feed.feedUrl feed
+ case result of
+ Ingest.IngestSuccess stats ->
+ putText <| url <> ": " <> T.pack (show (Ingest.statsNewArticles stats)) <> " new"
+ Ingest.IngestFailure err ->
+ putText <| url <> ": FAILED: " <> err
+
+test :: Test.Tree
+test =
+ Test.group
+ "Omni.Newsreader"
+ [ Test.unit "placeholder" <| pure ()
+ ]
diff --git a/Omni/Newsreader/Article.hs b/Omni/Newsreader/Article.hs
index 681e33d2..4b13cf2f 100644
--- a/Omni/Newsreader/Article.hs
+++ b/Omni/Newsreader/Article.hs
@@ -46,7 +46,7 @@ import qualified Omni.Newsreader.Feed as Feed
-- | Unique identifier for an article (database primary key).
newtype ArticleId = ArticleId {unArticleId :: Int}
- deriving (Eq, Show, Generic)
+ deriving (Eq, Ord, Show, Generic)
instance SQL.FromField ArticleId where
fromField f = ArticleId </ SQL.fromField f
@@ -77,7 +77,7 @@ instance ToJSON Article
instance SQL.FromRow Article where
fromRow = do
- artId <- Just <$> ArticleId <$> SQL.field
+ artId <- (Just <. ArticleId) </ SQL.field
feedId <- SQL.field
url <- SQL.field
title <- SQL.field
diff --git a/Omni/Newsreader/Cluster.hs b/Omni/Newsreader/Cluster.hs
new file mode 100644
index 00000000..6ecc721a
--- /dev/null
+++ b/Omni/Newsreader/Cluster.hs
@@ -0,0 +1,199 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Simple keyword-based topic clustering for news articles.
+--
+-- Groups articles that share significant words in their titles.
+-- No external dependencies (no embeddings/LLM needed).
+--
+-- : dep containers
+module Omni.Newsreader.Cluster
+ ( clusterArticles,
+ TopicCluster (..),
+ )
+where
+
+import Alpha
+import qualified Data.Char as Char
+import qualified Data.List as List
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import qualified Omni.Newsreader.Article as Article
+
+-- | A cluster of articles sharing a topic.
+data TopicCluster = TopicCluster
+ { clusterLabel :: Text,
+ clusterItems :: [Article.Article]
+ }
+ deriving (Show)
+
+-- | Cluster articles by shared significant title words.
+-- Returns clusters with 2+ articles, sorted by size (largest first).
+-- Articles can appear in multiple clusters.
+clusterArticles :: [Article.Article] -> [TopicCluster]
+clusterArticles articles =
+ let totalCount = length articles
+ -- Build word -> articles index
+ wordIndex = buildWordIndex articles
+ -- Filter to significant words (2+ articles, <40% of total)
+ maxFreq = max 2 (totalCount * 4 `div` 10)
+ significant =
+ Map.filter (\arts -> length arts >= 2 && length arts <= maxFreq) wordIndex
+ -- Merge clusters with high overlap
+ merged = mergeClusters (Map.toList significant)
+ -- Sort by cluster size
+ sorted = List.sortOn (negate <. length <. clusterItems) merged
+ in sorted
+
+-- | Build inverted index: significant word -> articles containing it.
+buildWordIndex :: [Article.Article] -> Map.Map Text [Article.Article]
+buildWordIndex articles =
+ let pairs =
+ [ (word, art)
+ | art <- articles,
+ word <- titleWords (Article.articleTitle art)
+ ]
+ in Map.fromListWith (++) [(w, [a]) | (w, a) <- pairs]
+
+-- | Extract significant words from a title.
+titleWords :: Text -> [Text]
+titleWords =
+ List.nub
+ <. filter (\w -> T.length w >= 3 && w `Set.notMember` stopWords)
+ <. map T.toLower
+ <. T.words
+ <. T.map (\c -> if Char.isAlphaNum c then c else ' ')
+
+-- | Merge clusters with >60% article overlap.
+mergeClusters :: [(Text, [Article.Article])] -> [TopicCluster]
+mergeClusters = go []
+ where
+ go acc [] = acc
+ go acc ((word, arts) : rest) =
+ let artIds = Set.fromList (mapMaybe Article.articleId arts)
+ -- Check if this overlaps significantly with an existing cluster
+ merged = tryMerge word arts artIds acc
+ in go merged rest
+
+ tryMerge word arts artIds existing =
+ case List.find (overlaps artIds) existing of
+ Nothing ->
+ -- New cluster
+ TopicCluster word arts : existing
+ Just cluster ->
+ -- Merge into existing cluster
+ let mergedArts = List.nubBy sameId (clusterItems cluster ++ arts)
+ mergedLabel = clusterLabel cluster
+ others = filter (/= cluster) existing
+ in TopicCluster mergedLabel mergedArts : others
+
+ overlaps ids1 cluster =
+ let ids2 = Set.fromList (mapMaybe Article.articleId (clusterItems cluster))
+ common = Set.size (Set.intersection ids1 ids2)
+ smaller = min (Set.size ids1) (Set.size ids2)
+ in smaller > 0 && common * 10 >= smaller * 6 -- 60% overlap
+ sameId a b = Article.articleId a == Article.articleId b
+
+instance Eq TopicCluster where
+ a == b = clusterLabel a == clusterLabel b
+
+-- | Common English stop words for filtering.
+stopWords :: Set.Set Text
+stopWords =
+ Set.fromList
+ [ "the",
+ "and",
+ "for",
+ "are",
+ "but",
+ "not",
+ "you",
+ "all",
+ "can",
+ "has",
+ "her",
+ "his",
+ "how",
+ "its",
+ "may",
+ "new",
+ "now",
+ "our",
+ "out",
+ "say",
+ "she",
+ "too",
+ "was",
+ "who",
+ "did",
+ "get",
+ "had",
+ "him",
+ "let",
+ "one",
+ "own",
+ "says",
+ "said",
+ "than",
+ "that",
+ "them",
+ "then",
+ "they",
+ "this",
+ "what",
+ "when",
+ "will",
+ "with",
+ "been",
+ "from",
+ "have",
+ "here",
+ "just",
+ "like",
+ "make",
+ "more",
+ "most",
+ "much",
+ "must",
+ "over",
+ "some",
+ "such",
+ "take",
+ "into",
+ "very",
+ "were",
+ "your",
+ "also",
+ "back",
+ "been",
+ "each",
+ "even",
+ "many",
+ "only",
+ "same",
+ "about",
+ "after",
+ "could",
+ "every",
+ "first",
+ "other",
+ "should",
+ "still",
+ "their",
+ "there",
+ "these",
+ "those",
+ "under",
+ "being",
+ "where",
+ "which",
+ "while",
+ "would",
+ "through",
+ "before",
+ "between",
+ "during",
+ "because",
+ "against"
+ ]
diff --git a/Omni/Newsreader/Db.hs b/Omni/Newsreader/Db.hs
index a4ca81b4..e1444d47 100644
--- a/Omni/Newsreader/Db.hs
+++ b/Omni/Newsreader/Db.hs
@@ -24,12 +24,10 @@ module Omni.Newsreader.Db
where
import Alpha
-import qualified Data.ByteString as BS
import Data.String (fromString)
import qualified Data.Text as T
-import qualified Data.Text.Encoding as TE
import qualified Database.SQLite.Simple as SQL
-import System.Directory (createDirectoryIfMissing, doesFileExist)
+import System.Directory (createDirectoryIfMissing)
import System.Environment (lookupEnv)
import System.FilePath (takeDirectory)
@@ -65,25 +63,14 @@ schemaVersion :: Int
schemaVersion = 1
-- | Execute schema initialization SQL.
--- Reads Schema.sql and executes it.
+-- Uses embedded schema so it works from nix closures.
initSchema :: SQL.Connection -> IO ()
initSchema conn = do
-- Enable foreign keys (disabled by default in SQLite)
SQL.execute_ conn "PRAGMA foreign_keys = ON"
- -- Read and execute schema file
- let schemaPath = "Omni/Newsreader/Schema.sql"
- schemaExists <- doesFileExist schemaPath
- unless schemaExists
- <| panic
- <| "Schema file not found: "
- <> T.pack schemaPath
-
- schemaSQL <- BS.readFile schemaPath
- let sqlText = TE.decodeUtf8 schemaSQL
-
- -- Parse SQL statements respecting BEGIN...END blocks
- let statements = parseSqlStatements sqlText
+ -- Parse embedded SQL statements respecting BEGIN...END blocks
+ let statements = parseSqlStatements embeddedSchema
forM_ statements <| \stmt ->
SQL.execute_ conn (fromString <| T.unpack stmt)
@@ -121,3 +108,68 @@ parseSqlStatements sqlText =
| otherwise ->
let (s, r) = extractStatement rest depth
in (T.cons c s, r)
+
+-- | Embedded database schema (mirrors Schema.sql).
+embeddedSchema :: Text
+embeddedSchema =
+ T.unlines
+ [ "CREATE TABLE IF NOT EXISTS feeds (",
+ " id INTEGER PRIMARY KEY AUTOINCREMENT,",
+ " url TEXT NOT NULL UNIQUE,",
+ " title TEXT,",
+ " description TEXT,",
+ " last_fetched TIMESTAMP,",
+ " created_at TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP",
+ ");",
+ "",
+ "CREATE TABLE IF NOT EXISTS articles (",
+ " id INTEGER PRIMARY KEY AUTOINCREMENT,",
+ " feed_id INTEGER NOT NULL,",
+ " url TEXT NOT NULL UNIQUE,",
+ " title TEXT NOT NULL,",
+ " content TEXT NOT NULL,",
+ " published_at TIMESTAMP,",
+ " fetched_at TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP,",
+ " embedding_vector BLOB,",
+ " FOREIGN KEY (feed_id) REFERENCES feeds(id) ON DELETE CASCADE",
+ ");",
+ "",
+ "CREATE VIRTUAL TABLE IF NOT EXISTS articles_fts USING fts5(",
+ " title, content, content='articles', content_rowid='id'",
+ ");",
+ "",
+ "CREATE TABLE IF NOT EXISTS topics (",
+ " id INTEGER PRIMARY KEY AUTOINCREMENT,",
+ " name TEXT NOT NULL,",
+ " representative_article_id INTEGER,",
+ " created_at TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP,",
+ " FOREIGN KEY (representative_article_id) REFERENCES articles(id) ON DELETE SET NULL",
+ ");",
+ "",
+ "CREATE TABLE IF NOT EXISTS article_topics (",
+ " article_id INTEGER NOT NULL,",
+ " topic_id INTEGER NOT NULL,",
+ " relevance_score REAL NOT NULL DEFAULT 1.0,",
+ " PRIMARY KEY (article_id, topic_id),",
+ " FOREIGN KEY (article_id) REFERENCES articles(id) ON DELETE CASCADE,",
+ " FOREIGN KEY (topic_id) REFERENCES topics(id) ON DELETE CASCADE",
+ ");",
+ "",
+ "CREATE INDEX IF NOT EXISTS idx_articles_feed_id ON articles(feed_id);",
+ "CREATE INDEX IF NOT EXISTS idx_articles_published_at ON articles(published_at DESC);",
+ "CREATE INDEX IF NOT EXISTS idx_articles_fetched_at ON articles(fetched_at DESC);",
+ "CREATE INDEX IF NOT EXISTS idx_article_topics_topic_id ON article_topics(topic_id);",
+ "",
+ "CREATE TRIGGER IF NOT EXISTS articles_fts_insert AFTER INSERT ON articles BEGIN",
+ " INSERT INTO articles_fts(rowid, title, content) VALUES (new.id, new.title, new.content);",
+ "END;",
+ "",
+ "CREATE TRIGGER IF NOT EXISTS articles_fts_delete AFTER DELETE ON articles BEGIN",
+ " DELETE FROM articles_fts WHERE rowid = old.id;",
+ "END;",
+ "",
+ "CREATE TRIGGER IF NOT EXISTS articles_fts_update AFTER UPDATE ON articles BEGIN",
+ " DELETE FROM articles_fts WHERE rowid = old.id;",
+ " INSERT INTO articles_fts(rowid, title, content) VALUES (new.id, new.title, new.content);",
+ "END;"
+ ]
diff --git a/Omni/Newsreader/Feed.hs b/Omni/Newsreader/Feed.hs
index ab5dadb1..d3f44d38 100644
--- a/Omni/Newsreader/Feed.hs
+++ b/Omni/Newsreader/Feed.hs
@@ -30,7 +30,7 @@ import qualified Database.SQLite.Simple.ToField as SQL
-- | Unique identifier for a feed (database primary key).
newtype FeedId = FeedId {unFeedId :: Int}
- deriving (Eq, Show, Generic)
+ deriving (Eq, Ord, Show, Generic)
instance SQL.FromField FeedId where
fromField f = FeedId </ SQL.fromField f
@@ -59,7 +59,7 @@ instance ToJSON Feed
instance SQL.FromRow Feed where
fromRow = do
- feedId' <- Just <$> FeedId <$> SQL.field
+ feedId' <- (Just <. FeedId) </ SQL.field
url <- SQL.field
title <- SQL.field
description <- SQL.field
diff --git a/Omni/Newsreader/Web.hs b/Omni/Newsreader/Web.hs
new file mode 100644
index 00000000..418fab0c
--- /dev/null
+++ b/Omni/Newsreader/Web.hs
@@ -0,0 +1,463 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Web server for the Newsreader: HTML views + JSON API.
+--
+-- HTML: minimal, text-focused, mobile-friendly river-of-news UI.
+-- API: JSON endpoints for programmatic access (e.g., by Ava agent).
+--
+-- : dep aeson
+-- : dep lucid
+-- : dep wai
+-- : dep http-types
+-- : dep sqlite-simple
+-- : dep bytestring
+-- : dep time
+-- : dep containers
+module Omni.Newsreader.Web
+ ( app,
+ )
+where
+
+import Alpha
+import qualified Data.Aeson as Aeson
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.List as List
+import qualified Data.Map.Strict as Map
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Data.Time as Time
+import qualified Data.Time.Format as TimeF
+import qualified Database.SQLite.Simple as SQL
+import qualified Lucid as L
+import qualified Network.HTTP.Types as HTTP
+import qualified Network.HTTP.Types.Header as Header
+import qualified Network.Wai as Wai
+import qualified Omni.Newsreader.Article as Article
+import qualified Omni.Newsreader.Cluster as Cluster
+import qualified Omni.Newsreader.Feed as Feed
+import qualified Omni.Newsreader.Ingest as Ingest
+import qualified Omni.Newsreader.Search as Search
+
+-- ============================================================================
+-- Application
+-- ============================================================================
+
+-- | Main WAI application.
+app :: SQL.Connection -> Wai.Application
+app conn req respond = do
+ let path = Wai.pathInfo req
+ method = Wai.requestMethod req
+ case (method, path) of
+ -- HTML
+ ("GET", []) -> riverPage conn req respond
+ ("GET", ["topics"]) -> topicsPage conn respond
+ ("GET", ["article", aid]) -> articlePage conn aid respond
+ ("GET", ["feeds"]) -> feedsPage conn respond
+ ("GET", ["search"]) -> searchPage conn req respond
+ -- API
+ ("GET", ["api", "articles"]) -> apiArticles conn req respond
+ ("GET", ["api", "article", aid]) -> apiArticle conn aid respond
+ ("GET", ["api", "topics"]) -> apiTopics conn respond
+ ("GET", ["api", "search"]) -> apiSearch conn req respond
+ ("GET", ["api", "feeds"]) -> apiFeeds conn respond
+ ("POST", ["api", "feeds"]) -> apiAddFeed conn req respond
+ ("POST", ["api", "ingest"]) -> apiIngest conn respond
+ _ -> respond (htmlResponse HTTP.status404 (errorPage "not found"))
+
+-- ============================================================================
+-- HTML Pages
+-- ============================================================================
+
+-- | River of news: recent articles in reverse chronological order.
+riverPage :: SQL.Connection -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived
+riverPage conn req respond = do
+ let limit = queryInt "limit" 50 req
+ articles <- Article.listRecentArticles conn limit
+ feeds <- Feed.listFeeds conn
+ let feedMap = Map.fromList [(fid, f) | f <- feeds, Just fid <- [Feed.feedId f]]
+ respond <| htmlResponse HTTP.status200 <| shell "newsreader" <| do
+ nav
+ L.div_ [L.class_ "articles"]
+ <| if null articles
+ then L.p_ [L.class_ "empty"] "No articles yet. Add some feeds to get started."
+ else forM_ articles <| \art -> articleCard feedMap art
+
+-- | Topics page: keyword-based clusters.
+topicsPage :: SQL.Connection -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived
+topicsPage conn respond = do
+ articles <- Article.listRecentArticles conn 200
+ let clusters = Cluster.clusterArticles articles
+ feeds <- Feed.listFeeds conn
+ let feedMap = Map.fromList [(fid, f) | f <- feeds, Just fid <- [Feed.feedId f]]
+ respond <| htmlResponse HTTP.status200 <| shell "topics" <| do
+ nav
+ L.h1_ "Topics"
+ if null clusters
+ then L.p_ [L.class_ "empty"] "Not enough articles to form topics yet."
+ else
+ forM_ clusters <| \cluster -> do
+ let arts = Cluster.clusterItems cluster
+ count = length arts
+ L.div_ [L.class_ "topic"] <| do
+ L.h2_ <| do
+ L.toHtml (Cluster.clusterLabel cluster)
+ L.span_ [L.class_ "count"] <| L.toHtml (" (" <> T.pack (show count) <> ")" :: Text)
+ forM_ (take 5 arts) <| \art -> articleCard feedMap art
+ when (count > 5)
+ <| L.p_ [L.class_ "muted"]
+ <| L.toHtml ("+ " <> T.pack (show (count - 5)) <> " more" :: Text)
+
+-- | Single article view.
+articlePage :: SQL.Connection -> Text -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived
+articlePage conn aidText respond = do
+ case readInt aidText of
+ Nothing -> respond (htmlResponse HTTP.status400 (errorPage "invalid article id"))
+ Just aid -> do
+ maybeArt <- Article.getArticle conn (Article.ArticleId aid)
+ case maybeArt of
+ Nothing -> respond (htmlResponse HTTP.status404 (errorPage "article not found"))
+ Just art -> do
+ feeds <- Feed.listFeeds conn
+ let feedMap = Map.fromList [(fid, f) | f <- feeds, Just fid <- [Feed.feedId f]]
+ feedName = maybe "unknown" (fromMaybe "untitled" <. Feed.feedTitle) (Map.lookup (Article.articleFeedId art) feedMap)
+ respond <| htmlResponse HTTP.status200 <| shell (Article.articleTitle art) <| do
+ nav
+ L.article_ [L.class_ "full-article"] <| do
+ L.h1_ (L.toHtml (Article.articleTitle art))
+ L.div_ [L.class_ "meta"] <| do
+ L.span_ [L.class_ "feed"] (L.toHtml feedName)
+ L.toHtml (" · " :: Text)
+ L.span_ [L.class_ "date"] (L.toHtml (fmtTime (Article.articlePublishedAt art)))
+ L.toHtml (" · " :: Text)
+ L.a_ [L.href_ (Article.articleUrl art), L.target_ "_blank"] "original ↗"
+ L.div_ [L.class_ "content"]
+ <| forM_ (T.splitOn "\n" (Article.articleContent art))
+ <| \para ->
+ unless (T.null (T.strip para))
+ <| L.p_ (L.toHtml para)
+
+-- | Feeds management page.
+feedsPage :: SQL.Connection -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived
+feedsPage conn respond = do
+ feeds <- Feed.listFeeds conn
+ respond <| htmlResponse HTTP.status200 <| shell "feeds" <| do
+ nav
+ L.h1_ "Feeds"
+ L.form_ [L.method_ "POST", L.action_ "/api/feeds", L.class_ "add-feed"] <| do
+ L.input_ [L.type_ "url", L.name_ "url", L.placeholder_ "https://example.com/feed.xml", L.required_ ""]
+ L.button_ [L.type_ "submit"] "add"
+ if null feeds
+ then L.p_ [L.class_ "empty"] "No feeds yet."
+ else
+ L.ul_ [L.class_ "feed-list"]
+ <| forM_ feeds
+ <| \feed -> do
+ let title = fromMaybe (Feed.feedUrl feed) (Feed.feedTitle feed)
+ fetched = maybe "never" (T.pack <. TimeF.formatTime TimeF.defaultTimeLocale "%Y-%m-%d %H:%M") (Feed.feedLastFetched feed)
+ L.li_ <| do
+ L.div_ (L.toHtml title)
+ L.div_ [L.class_ "muted small"] <| do
+ L.toHtml (Feed.feedUrl feed)
+ L.toHtml (" · last fetched: " :: Text)
+ L.toHtml fetched
+
+-- | Search page.
+searchPage :: SQL.Connection -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived
+searchPage conn req respond = do
+ let query = queryText "q" "" req
+ feeds <- Feed.listFeeds conn
+ let feedMap = Map.fromList [(fid, f) | f <- feeds, Just fid <- [Feed.feedId f]]
+ results <-
+ if T.null query
+ then pure []
+ else Search.searchArticles conn query 50
+ respond <| htmlResponse HTTP.status200 <| shell "search" <| do
+ nav
+ L.form_ [L.method_ "GET", L.action_ "/search", L.class_ "search-form"]
+ <| L.input_ [L.type_ "search", L.name_ "q", L.value_ query, L.placeholder_ "search articles...", L.autofocus_]
+ unless (T.null query)
+ <| if null results
+ then L.p_ [L.class_ "empty"] "No results."
+ else
+ forM_ results <| \sr ->
+ articleCard feedMap (Search.srArticle sr)
+
+-- ============================================================================
+-- JSON API
+-- ============================================================================
+
+-- | GET /api/articles — recent articles.
+apiArticles :: SQL.Connection -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived
+apiArticles conn req respond = do
+ let limit = queryInt "limit" 50 req
+ articles <- Article.listRecentArticles conn limit
+ feeds <- Feed.listFeeds conn
+ let feedMap = Map.fromList [(fid, f) | f <- feeds, Just fid <- [Feed.feedId f]]
+ respond <| jsonResponse (map (articleJson feedMap) articles)
+
+-- | GET /api/article/:id — single article.
+apiArticle :: SQL.Connection -> Text -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived
+apiArticle conn aidText respond =
+ case readInt aidText of
+ Nothing -> respond (jsonError 400 "invalid article id")
+ Just aid -> do
+ maybeArt <- Article.getArticle conn (Article.ArticleId aid)
+ case maybeArt of
+ Nothing -> respond (jsonError 404 "article not found")
+ Just art -> do
+ feeds <- Feed.listFeeds conn
+ let feedMap = Map.fromList [(fid, f) | f <- feeds, Just fid <- [Feed.feedId f]]
+ respond <| jsonResponse (articleJson feedMap art)
+
+-- | GET /api/topics — topic clusters.
+apiTopics :: SQL.Connection -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived
+apiTopics conn respond = do
+ articles <- Article.listRecentArticles conn 200
+ let clusters = Cluster.clusterArticles articles
+ feeds <- Feed.listFeeds conn
+ let feedMap = Map.fromList [(fid, f) | f <- feeds, Just fid <- [Feed.feedId f]]
+ respond <| jsonResponse <| map (clusterJson feedMap) clusters
+
+-- | GET /api/search?q= — search.
+apiSearch :: SQL.Connection -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived
+apiSearch conn req respond = do
+ let query = queryText "q" "" req
+ if T.null query
+ then respond (jsonError 400 "missing q parameter")
+ else do
+ results <- Search.searchArticles conn query 50
+ feeds <- Feed.listFeeds conn
+ let feedMap = Map.fromList [(fid, f) | f <- feeds, Just fid <- [Feed.feedId f]]
+ respond <| jsonResponse <| map (articleJson feedMap <. Search.srArticle) results
+
+-- | GET /api/feeds — list feeds.
+apiFeeds :: SQL.Connection -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived
+apiFeeds conn respond = do
+ feeds <- Feed.listFeeds conn
+ respond <| jsonResponse feeds
+
+-- | POST /api/feeds — add a feed. Accepts JSON body or form-encoded.
+apiAddFeed :: SQL.Connection -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived
+apiAddFeed conn req respond = do
+ body <- Wai.lazyRequestBody req
+ let contentType = fromMaybe "" (List.lookup Header.hContentType (Wai.requestHeaders req))
+ url <-
+ if "application/json" `BL.isPrefixOf` BL.fromStrict contentType
+ then case Aeson.decode body :: Maybe (Map.Map Text Text) of
+ Just m -> pure (Map.lookup "url" m)
+ Nothing -> pure Nothing
+ else do
+ -- Form-encoded
+ let params = HTTP.parseSimpleQuery (BL.toStrict body)
+ pure (TE.decodeUtf8 </ List.lookup "url" params)
+ case url of
+ Nothing -> respond (jsonError 400 "missing url")
+ Just feedUrl -> do
+ feed <- Feed.createFeed conn feedUrl Nothing Nothing
+ -- If it came from a form, redirect to /feeds
+ if "application/json" `BL.isPrefixOf` BL.fromStrict contentType
+ then respond <| jsonResponse feed
+ else respond <| Wai.responseLBS HTTP.status303 [(Header.hLocation, "/feeds")] ""
+
+-- | POST /api/ingest — trigger feed ingestion.
+apiIngest :: SQL.Connection -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived
+apiIngest conn respond = do
+ results <- Ingest.fetchAllFeeds conn
+ let summary =
+ [ Aeson.object
+ [ "feed" Aeson..= Feed.feedUrl f,
+ "result" Aeson..= case r of
+ Ingest.IngestSuccess stats ->
+ Aeson.object
+ [ "new" Aeson..= Ingest.statsNewArticles stats,
+ "skipped" Aeson..= Ingest.statsSkippedArticles stats,
+ "failed" Aeson..= Ingest.statsFailedArticles stats
+ ]
+ Ingest.IngestFailure err -> Aeson.String err
+ ]
+ | (f, r) <- results
+ ]
+ respond <| jsonResponse (Aeson.object ["results" Aeson..= summary])
+
+-- ============================================================================
+-- HTML Components
+-- ============================================================================
+
+-- | Article card for lists.
+articleCard :: Map.Map Feed.FeedId Feed.Feed -> Article.Article -> L.Html ()
+articleCard feedMap art = do
+ let feedName = maybe "unknown" (fromMaybe "untitled" <. Feed.feedTitle) (Map.lookup (Article.articleFeedId art) feedMap)
+ snippet = T.take 280 (Article.articleContent art)
+ artUrl = "/article/" <> maybe "" (T.pack <. show <. Article.unArticleId) (Article.articleId art)
+ L.div_ [L.class_ "article-card"] <| do
+ L.a_ [L.href_ artUrl, L.class_ "title"] (L.toHtml (Article.articleTitle art))
+ L.div_ [L.class_ "meta"] <| do
+ L.span_ [L.class_ "feed"] (L.toHtml feedName)
+ L.toHtml (" · " :: Text)
+ L.span_ [L.class_ "date"] (L.toHtml (fmtTime (Article.articlePublishedAt art)))
+ unless (T.null snippet)
+ <| L.p_ [L.class_ "snippet"] (L.toHtml snippet)
+
+-- | Navigation bar.
+nav :: L.Html ()
+nav =
+ L.nav_ <| do
+ L.a_ [L.href_ "/", L.class_ "brand"] "newsreader"
+ L.span_ [L.class_ "nav-links"] <| do
+ L.a_ [L.href_ "/topics"] "topics"
+ L.a_ [L.href_ "/feeds"] "feeds"
+ L.a_ [L.href_ "/search"] "search"
+
+-- | Error page.
+errorPage :: Text -> L.Html ()
+errorPage msg =
+ shell msg <| do
+ nav
+ L.p_ (L.toHtml msg)
+
+-- | Page shell with CSS.
+shell :: Text -> L.Html () -> L.Html ()
+shell title body =
+ L.doctypehtml_ <| do
+ L.head_ <| do
+ L.meta_ [L.charset_ "utf-8"]
+ L.meta_ [L.name_ "viewport", L.content_ "width=device-width, initial-scale=1"]
+ L.title_ (L.toHtml title)
+ L.style_ css
+ L.body_ body
+
+-- ============================================================================
+-- CSS
+-- ============================================================================
+
+css :: Text
+css =
+ T.unlines
+ [ ":root { --fg: #1a1a1a; --bg: #fafafa; --muted: #777; --link: #1a0dab;",
+ " --border: #eee; --hover: #f0f0f0; }",
+ "@media (prefers-color-scheme: dark) {",
+ " :root { --fg: #d4d4d4; --bg: #111; --muted: #888; --link: #8ab4f8;",
+ " --border: #222; --hover: #1a1a1a; }",
+ "}",
+ "* { box-sizing: border-box; margin: 0; padding: 0; }",
+ "body { font: 16px/1.6 -apple-system, system-ui, sans-serif;",
+ " max-width: 680px; margin: 0 auto; padding: 1rem;",
+ " background: var(--bg); color: var(--fg); }",
+ "a { color: var(--link); text-decoration: none; }",
+ "a:hover { text-decoration: underline; }",
+ "",
+ "nav { display: flex; align-items: baseline; gap: 1rem;",
+ " padding: 0.5rem 0; margin-bottom: 1.5rem; border-bottom: 1px solid var(--border); }",
+ ".brand { font-weight: 600; font-size: 1.1rem; color: var(--fg); }",
+ ".nav-links { display: flex; gap: 1rem; font-size: 0.9rem; }",
+ ".nav-links a { color: var(--muted); }",
+ "",
+ ".article-card { margin-bottom: 1.5rem; }",
+ ".article-card .title { font-size: 1.05rem; font-weight: 500; display: block; }",
+ ".article-card .meta { font-size: 0.8rem; color: var(--muted); margin: 0.15rem 0 0.3rem; }",
+ ".article-card .snippet { font-size: 0.9rem; color: var(--muted); line-height: 1.5; }",
+ "",
+ ".full-article h1 { font-size: 1.5rem; line-height: 1.3; margin-bottom: 0.3rem; }",
+ ".full-article .meta { font-size: 0.85rem; color: var(--muted); margin-bottom: 1.5rem; }",
+ ".full-article .content p { margin-bottom: 1rem; }",
+ "",
+ ".topic { margin-bottom: 2rem; }",
+ ".topic h2 { font-size: 1.1rem; margin-bottom: 0.5rem; }",
+ ".topic .count { font-weight: normal; color: var(--muted); }",
+ "",
+ ".feed-list { list-style: none; }",
+ ".feed-list li { padding: 0.5rem 0; border-bottom: 1px solid var(--border); }",
+ ".small { font-size: 0.8rem; }",
+ ".muted { color: var(--muted); }",
+ ".empty { color: var(--muted); font-style: italic; }",
+ "",
+ ".add-feed { display: flex; gap: 0.5rem; margin-bottom: 1.5rem; }",
+ ".add-feed input { flex: 1; padding: 0.4rem; font-size: 0.9rem;",
+ " border: 1px solid var(--border); background: var(--bg); color: var(--fg); border-radius: 3px; }",
+ ".add-feed button { padding: 0.4rem 0.8rem; font-size: 0.9rem;",
+ " border: 1px solid var(--border); background: var(--hover); color: var(--fg);",
+ " border-radius: 3px; cursor: pointer; }",
+ "",
+ ".search-form { margin-bottom: 1.5rem; }",
+ ".search-form input { width: 100%; padding: 0.5rem; font-size: 1rem;",
+ " border: 1px solid var(--border); background: var(--bg); color: var(--fg); border-radius: 3px; }",
+ "",
+ "h1 { font-size: 1.3rem; margin-bottom: 1rem; }"
+ ]
+
+-- ============================================================================
+-- JSON Helpers
+-- ============================================================================
+
+articleJson :: Map.Map Feed.FeedId Feed.Feed -> Article.Article -> Aeson.Value
+articleJson feedMap art =
+ let feedName = maybe "unknown" (fromMaybe "untitled" <. Feed.feedTitle) (Map.lookup (Article.articleFeedId art) feedMap)
+ in Aeson.object
+ [ "id" Aeson..= fmap Article.unArticleId (Article.articleId art),
+ "title" Aeson..= Article.articleTitle art,
+ "url" Aeson..= Article.articleUrl art,
+ "content" Aeson..= Article.articleContent art,
+ "feed" Aeson..= feedName,
+ "publishedAt" Aeson..= Article.articlePublishedAt art,
+ "fetchedAt" Aeson..= Article.articleFetchedAt art
+ ]
+
+clusterJson :: Map.Map Feed.FeedId Feed.Feed -> Cluster.TopicCluster -> Aeson.Value
+clusterJson feedMap cluster =
+ let arts = Cluster.clusterItems cluster
+ in Aeson.object
+ [ "label" Aeson..= Cluster.clusterLabel cluster,
+ "articleCount" Aeson..= length arts,
+ "articles" Aeson..= map (articleJson feedMap) (take 10 arts)
+ ]
+
+jsonResponse :: (Aeson.ToJSON a) => a -> Wai.Response
+jsonResponse val =
+ Wai.responseLBS
+ HTTP.status200
+ [(Header.hContentType, "application/json")]
+ (Aeson.encode val)
+
+jsonError :: Int -> Text -> Wai.Response
+jsonError code msg =
+ Wai.responseLBS
+ (HTTP.mkStatus code (TE.encodeUtf8 msg))
+ [(Header.hContentType, "application/json")]
+ (Aeson.encode (Aeson.object ["error" Aeson..= msg]))
+
+htmlResponse :: HTTP.Status -> L.Html () -> Wai.Response
+htmlResponse status html =
+ Wai.responseLBS
+ status
+ [(Header.hContentType, "text/html; charset=utf-8")]
+ (L.renderBS html)
+
+-- ============================================================================
+-- Utilities
+-- ============================================================================
+
+-- | Get a query parameter as Text.
+queryText :: ByteString -> Text -> Wai.Request -> Text
+queryText key def req =
+ case List.lookup key (Wai.queryString req) of
+ Just (Just val) -> TE.decodeUtf8 val
+ _ -> def
+
+-- | Get a query parameter as Int.
+queryInt :: ByteString -> Int -> Wai.Request -> Int
+queryInt key def req =
+ case List.lookup key (Wai.queryString req) of
+ Just (Just val) -> fromMaybe def (readInt (TE.decodeUtf8 val))
+ _ -> def
+
+-- | Read an Int from Text.
+readInt :: Text -> Maybe Int
+readInt t = case reads (T.unpack t) of
+ [(n, "")] -> Just n
+ _ -> Nothing
+
+-- | Format a Maybe UTCTime for display.
+fmtTime :: Maybe Time.UTCTime -> Text
+fmtTime Nothing = ""
+fmtTime (Just t) = T.pack (TimeF.formatTime TimeF.defaultTimeLocale "%b %d, %H:%M" t)