You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

902 lines
37 KiB
Scheme

9 years ago
(module news-db
(;; parameters
connection-spec
;; functions
with-db with-db/transaction
get-sources refresh-article-view! refresh-tags-and-sources-view!
add-user! get-user-id-by-email
get-password-and-salt get-viewed-articles get-upvoted-articles
article-upvoted? set-article-for-user-upvoted!
session-delete! session-exists?
upsert-article! get-article-cover-path get-all-images-path-and-id
article-exists? get-article-by-id get-articles-by-tags
get-articles-by-popularity
get-article-points mark-article-viewed! increment-article-viewed!
upvote-article! get-user-subscriptions
user-tag-subscribe! user-tag-unsubscribe!
user-author-subscribe! user-author-unsubscribe!
get-article-id-by-guid
get-article-author-by-source-id insert-new-author! insert-author!
get-author-name-by-author-id get-articles-by-authors
get-authors get-articles-by-subscriptions
set-rank-by-tag-association set-rank-by-title set-rank-by-partial-uri
set-rank-by-uri set-rank-by-date-difference
set-rank-by-rank db-connection get-sources get-user-sources
set-user-sources! add-source! get-user-settings set-user-setting!
get-articles-viewed-by-user set-session-user-id!
get-session-user-id user-signed-in? create-account! account-exists?
user-has-subscriptions user-tags
account-exists-condition account-exists-condition-predicate
get-users-articles get-user-headers get-possible-user-sources-for-tag
get-user-sources-for-tag set-rank-by-guids get-tags-by-rank
add-to-breaking-news-email add-to-get-invited get-tag-groups
set-tags-by-text set-user-default-interests!
add-all-sources-for-tag-for-user! remove-tag-from-user
get-tags-and-sources get-tags-by-tag-group
add-user-source! remove-user-source! get-possible-user-sources
set-new-user-default-interests!)
(import chicken scheme data-structures ports)
(use postgresql sql-null srfi-19 srfi-1 matchable srfi-13)
;; (define (debug a . r)
;; (log-to (debug-log) (with-output-to-string (lambda () (apply print a
;; r)))))
(define account-exists-condition (make-property-condition 'account-exists))
(define account-exists-condition-predicate (condition-predicate 'account-exists))
;; Update postgres parsers to handle dates.
(default-type-unparsers
(append (default-type-unparsers)
`((,date? . ,(lambda (conn d) (date->string d "~Y-~m-~d ~H:~M:~S"))))))
(default-type-parsers
(append (default-type-parsers)
`(("timestamptz" . ,(lambda (d) (string->date d "~Y-~m-~d ~H:~M:~S"))))))
(define connection-spec (make-parameter '((dbname . "news"))))
(define db-connection (make-parameter #f))
(define (with-db proc)
(if (db-connection)
(begin (db-connection)
(proc (db-connection)))
(let ((conn #f))
(dynamic-wind
(lambda ()
(set! conn (connect (connection-spec))))
(lambda () (proc conn))
(lambda ()
(when (and (connection? conn) (connected? conn))
(disconnect conn)))))))
(define (with-db/transaction proc)
(with-db
(lambda (conn)
(with-transaction conn
(lambda () (proc conn))))))
(define (get-sources conn)
(row-map* (lambda (id name icon-path)
`((source-id . ,id) (name . ,name) (icon-path . ,icon-path)))
(query conn "select source_id, name, icon_path from article_source;")))
(define (get-user-sources conn user-id)
(row-map* (lambda (id name icon-path)
`((source-id . ,id) (name . ,name) (icon-path . ,icon-path)))
(query conn "select user_sources.source_id, name, icon_path
from user_sources
join article_source on article_source.source_id =
user_sources.source_id
where user_id=$1;" user-id)))
(define (get-user-sources-for-tag conn user-id tag)
(row-map* (lambda (id name icon-path)
`((source-id . ,id) (name . ,name) (icon-path . ,icon-path)))
(query conn
"select article_source.source_id, article_source.name,
article_source.icon_path from tag_subscriptions
join tags on tags.tag_id = tag_subscriptions.tag_id
join article_source on
article_source.source_id = tag_subscriptions.source_id
where user_id=$1 and tags.name = $2;"
user-id tag)))
(define (get-possible-user-sources-for-tag conn user-id tag)
(row-map* (lambda (id name icon-path)
`((source-id . ,id) (name . ,name) (icon-path . ,icon-path)))
(query conn
"select t1.source_id, name, icon_path from
(select distinct user_sources.source_id from user_sources
join article_view
on article_view.source_id = user_sources.source_id
where user_id=$1 and $2 = any(tags)) as t1
join article_source on article_source.source_id = t1.source_id;"
user-id tag)))
(define (get-possible-user-sources conn user-id)
(row-map* (lambda (id name icon-path)
`((source-id . ,id) (name . ,name) (icon-path . ,icon-path)))
(query conn
"select distinct tags_and_sources.source_id,
source_name, source_icon_path from tag_subscriptions
join tags_and_sources
on tags_and_sources.tag_id = tag_subscriptions.tag_id
where user_id=$1;"
user-id)))
(define (get-tags-and-sources conn)
(row-map*
(lambda (source-id source-name source-icon-path tag-id tag-name tag-rank
groups-ids groups-names)
`((source-id . ,source-id) (source-name . ,source-name)
(source-icon-path . ,source-icon-path) (tag-id . ,tag-id)
(tag-name . ,tag-name) (tag-rank . ,tag-rank)
(groups-ids . ,(vector->list groups-ids))
(groups-names . ,(vector->list groups-names))))
(query
conn
"select source_id, source_name, source_icon_path, tag_id, tag_name, tag_rank,
tag_groups_id::int[], tag_groups_name::text[]
from tags_and_sources where tag_rank < 100;")))
(define (get-tags-by-tag-group conn tag-group #!key exclude-user-id)
(row-map*
(lambda (tag-id tag-name)
`((tag-id . ,tag-id) (tag-name . ,tag-name)))
(if exclude-user-id
(query
conn
"select tags.tag_id, tags.name from
(select tag_id from tags_groups
join tag_group_names on tag_group_names.group_id = tags_groups.group_id
where group_name=$1
except select tag_subscriptions.tag_id from tag_subscriptions
where user_id=$2) as t join tags on tags.tag_id = t.tag_id;"
tag-group exclude-user-id)
(query
conn
"select tags.tag_id, tags.name from
(select tag_id from tags_groups
join tag_group_names on tag_group_names.group_id = tags_groups.group_id
where group_name=$1) as t join tags on tags.tag_id = t.tag_id;"
tag-group))))
(define (set-user-sources! conn user-id sources)
;; TODO should do all in one query?
(with-transaction conn
(lambda ()
(query conn "delete from user_sources where user_id=$1;" user-id)
;; TODO should do all in one query
(for-each
(lambda (src)
(query conn "insert into user_sources(user_id, source_id) values ($1, $2);"
user-id (alist-ref 'source-id src)))
sources))))
(define (remove-tag-from-user conn user-id tag)
(query conn "delete from tag_subscriptions
where user_id=$1 and tag_id=(select tag_id from tags where name=$2);"
user-id tag))
(define (add-all-sources-for-tag-for-user! conn user-id tag)
(let ((sources
(column-values
(query
conn
"select distinct source_id from article_view where $1 = any(tags);" tag))))
(for-each
(lambda (src)
(query conn "insert into user_sources(user_id, source_id) values ($1, $2);"
user-id src))
sources)))
(define (add-source! conn name icon-path)
(query conn "insert into article_source(name, icon_path) values ($1, $2);"
name icon-path))
(define (add-user-source! conn source-id user-id)
(let ((tag-ids
(query
conn
"select tags_and_sources.tag_id from tags_and_sources
where tag_id = any((select distinct tag_id from tag_subscriptions
where user_id=$1)) and source_id=$2;"
user-id source-id)))
(row-for-each*
(lambda (tag-id)
(query conn
"insert into tag_subscriptions(source_id, user_id, tag_id)
values($1, $2, $3);"
source-id user-id tag-id))
tag-ids)
(query conn "insert into user_sources(user_id, source_id)
values ($1, $2);"
user-id source-id)))
(define (remove-user-source! conn source-id user-id)
(query conn "delete from tag_subscriptions where source_id=$1 and user_id=$2;"
source-id user-id)
(query conn "delete from user_sources where source_id=$1 and user_id=$2;;"
source-id user-id))
(define (set-new-user-default-interests! conn user-id default-user-id)
(row-for-each*
(lambda (tag-id source-id)
(query
conn
"insert into tag_subscriptions (user_id, tag_id, source_id) values ($1, $2, $3);"
user-id tag-id source-id))
(query conn "select tag_id, source_id from tag_subscriptions where user_id=$1"
default-user-id)))
(define (set-user-default-interests! conn user-id group-name)
(let ((tags (column-values
(query
conn
"select tags.name from tags_groups
join tag_group_names on tag_group_names.group_id = tags_groups.group_id
join tags on tags.tag_id = tags_groups.tag_id
where group_name=$1;" group-name))))
(for-each
(lambda (tag)
(let ((possible-sources (get-possible-user-sources-for-tag conn user-id tag)))
(for-each
(lambda (source-id)
(query
conn
"insert into tag_subscriptions (user_id, tag_id, source_id)
values ($1, (select tag_id from tags where name=$2), $3);"
user-id tag source-id))
(map (lambda (s) (alist-ref 'source-id s)) possible-sources))))
tags)))
(define (get-articles-by-subscriptions conn source-id/tag-lists
#!key (limit 20) rank
(excludes '()))
(query* conn (conc "select article_id, title, author, date, description,
rank, content, original_path, original_height, original_width,
tags::text[], points,
uri, source_name, source_icon_path, source_id, authors::text[],
author_ids::int[]
from article_view where article_id <> all($1::int[]) and "
(string-intersperse
(map-in-order
(lambda (i)
(conc " source_id = $" i " and $" (+ i 1)
"::varchar[] && tags "))
(iota (length source-id/tag-lists) 2 2))
" or ")
" order by " (if rank "rank, " "")
"date desc limit " limit ";")
(append
(list (list->vector (or excludes '())))
(flatten
(map-in-order
(lambda (source-id/tag-list)
`(,(car source-id/tag-list) ,(list->vector (cadr source-id/tag-list))))
source-id/tag-lists)))))
;; postgres result processing.
(define (single-value/default pg-result . default)
(if (and (> (row-count pg-result) 0) (> (column-count pg-result) 0))
(value-at pg-result 0 0)
(optional default (error "no result"))))
(define (refresh-article-view! conn)
(query conn "refresh materialized view concurrently article_view;"))
(define (refresh-tags-and-sources-view! conn)
(query conn "refresh materialized view concurrently tags_and_sources;"))
(define (add-user! conn email #!key hash salt)
(let ((user-id (query conn "insert into user_account(password, salt, email)
values($1, $2, $3) returning user_id;"
(or hash "")
(or salt "")
email)))
(query conn "insert into user_settings(user_id) values($1);"
(car (row-values user-id)))
user-id))
(define (get-user-id-by-email conn email)
(and-let* ((_user-id
(query conn "select user_id from user_account where email=$1;" email))
(user-id (and (> (row-count _user-id) 0) (value-at _user-id 0 0))))
user-id))
(define (get-password-and-salt conn email)
(query conn "select password, salt from user_account where email=$1;" email))
(define (get-viewed-articles conn user-id)
(column-values
(query conn "select article_id from article_viewed_by_user
where user_id=$1 and viewed=TRUE;"
user-id)))
(define (get-upvoted-articles conn user-id)
(column-values (query conn "select article_id from upvoted_by_user where user_id=$1;"
user-id)))
(define (article-upvoted? conn user-id article-id)
(query conn "select article_id from upvoted_by_user
where user_id=$1 and article_id=$2;"
user-id article-id))
(define (set-article-for-user-upvoted! conn user-id article-id)
(query conn "insert into upvoted_by_user (article_id, user_id) values ($1, $2);"
article-id user-id))
(define (session-delete! conn session-id)
(query conn "delete from session where session_id=$1;" session-id))
(define (insert-new-tag conn tag)
(value-at (query conn "insert into tags(name) values($1) returning tag_id;" tag) 0 0))
(define (get-article-id-by-guid conn guid-hash)
(query conn "select article_id from articles where guid=$1;" guid-hash))
(define (get-article-author-by-source-id conn source-id)
(query conn
"select article_id, author from articles where source_id=$1;" source-id))
(define (get-author-name-by-author-id conn author-id)
(query conn
"select name from authors where author_id=$1;" author-id))
(define (get-articles-by-authors conn authors #!key limit (exclude-ids '()))
(query conn
"select article_id, title, author, date, description,
rank, content, cover_image_path, cover_image_height,
cover_image_width, tags::text[], points,
uri, source_name, source_icon_path, source_id, authors::text[],
author_ids::int[]
from get_articles_by_authors($1::varchar[], $2, $3::int[]);"
(list->vector authors) (or limit (sql-null))
(or (and exclude-ids (list->vector exclude-ids)) #())))
(define (get-authors conn prefix)
(query conn
"select author_id, name from authors where name ilike $1;"
(conc prefix "%")))
(define (insert-new-author! conn name)
(query conn "insert into authors(name) values ($1);" name))
(define (insert-author! conn article-id author #!key (insert-if-not-exists #t))
(when insert-if-not-exists
(when (=
(row-count
(query conn
"select name from authors where name=$1;" author))
0)
(insert-new-author! conn author)))
(when (= (row-count
(query conn "select 1 from article_author
join authors on authors.author_id = article_author.author_id
where article_author.article_id=$1 and name=$2;"
article-id author))
0)
(query conn "insert into article_author(article_id, author_id)
values($1, (select author_id from authors where name=$2));"
article-id author)))
(define (upsert-article! conn #!key title author
date (tags '()) content (images '())
(viewed 0) (description "") (insert-tag-if-not-exists #f)
(insert-author-if-not-exists #t)
(rank 5) (article-id #f)
authors
source guid-hash uri)
(with-transaction conn
(lambda ()
(let* ((new-article (not article-id))
(article-id
(if article-id
(begin
(query conn "update articles set title=$1, author=$2, content=$3,
description=$4, rank=$5, uri=$6
where article_id=$7;"
title author content description rank
uri article-id)
article-id)
(car (row-values
(query conn "insert into articles (title, author, content,
date, description, rank, guid, uri,
source_id)
values($1, $2, $3, $4, $5, $6, $7, $8,
(select source_id from article_source where
name = $9))
returning article_id;"
;; don't set rank if rank is #f
title author content date description rank
guid-hash uri source))))))
(for-each (lambda (author)
(insert-author! conn article-id author
insert-if-not-exists: insert-author-if-not-exists))
authors)
(for-each (lambda (tag)
(when insert-tag-if-not-exists
(when (=
(row-count
(query conn
"select tag_id from tags where name=$1;" tag))
0)
(insert-new-tag conn tag)))
(when (=
(row-count
(query conn "select 1 from article_tags where
article_id=$1 and tag_id=
(select tag_id from tags where name=$2);"
article-id tag))
0)
(query conn
"insert into article_tags(article_id, tag_id) values($1,
(select tag_id from tags where name=$2));"
article-id tag)))
tags)
(for-each (lambda (img)
;; Make sure we don't end up with two cover images.
(when (and (not new-article) (alist-ref 'cover img))
(query conn "update article_images set cover=FALSE
where article_id=$1;" article-id))
(query conn
"insert into article_images(article_id,
original_path, original_width, original_height,
cover) values ($1, $2, $3, $4, $5);"
article-id
(alist-ref 'original-path img)
(alist-ref 'original-width img)
(alist-ref 'original-height img)
(alist-ref 'cover img)))
images)
(when new-article
(query conn "insert into article_stats (article_id) values ($1);"
article-id))
article-id))))
(define (get-article-cover-path conn article-id)
(let ((p (query conn "select original_path from article_images where article_id=$1
and cover=true;"
article-id)))
(if (and (> (row-count p) 0) (> (column-count p) 0))
(value-at p 0 0)
#f)))
(define (get-all-images-path-and-id conn)
(query conn "select original_path, image_id from article_images;"))
(define (article-exists? conn id)
(> (row-count (query conn "select 1 from articles where article_id=$1;" id)) 0))
(define (get-article-by-id conn article-id)
(row-values
(query conn
"select article_id, title, author, date, description,
rank, content, cover_image_path, cover_image_height,
cover_image_width, tags::text[], points,
uri, source_name, source_icon_path, source_id, authors::text[]
from get_article_by_id($1);"
article-id)))
(define (cursor-get-all conn pg-result)
(let* ((cur (value-at pg-result))
(r (query conn (string-append "fetch all in \"" cur "\";"))))
(query conn (string-append "close \"" cur "\";"))
r))
(define (get-articles-by-tags conn tags #!key limit exclude-ids sources sort)
(query conn
(string-append "select article_id, title, author, date, description,
rank, content, cover_image_path, cover_image_height,
cover_image_width, tags::text[], points,
uri, source_name, source_icon_path, source_id, authors::text[],
author_ids::int[]
from get_articles_by_tags" (if (eq? sort 'rank) "_and_rank" "")
"($1::varchar[], $2, $3::int[], $4::int[]);")
(list->vector tags) (or limit (sql-null))
(or (and exclude-ids (list->vector exclude-ids)) #())
(list->vector sources)))
;; TODO in news-init.sql, does the stored procedure need to order by
;; for the second query?
(define (get-articles-by-popularity conn #!key tags limit offset exclude-ids
sources)
(if (or (not tags) (null? tags))
(query conn
"select article_id, title, author, date, description,
rank, content, cover_image_path, cover_image_height,
cover_image_width, tags::text[], points, uri,
source_name, source_icon_path, source_id, authors::text[],
author_ids::int[]
from get_articles_by_popularity
($1::int, $2::int, $3::int[], $4::int[]);"
(or limit (sql-null)) (or offset 0)
(if exclude-ids (list->vector exclude-ids) #())
(list->vector sources))
(query conn
"select article_id, title, author, date, description,
rank, content, cover_image_path, cover_image_height,
cover_image_width, tags::text[], points, uri,
source_name, source_icon_path, source_id, authors::text[],
author_ids::int[]
from get_articles_by_popularity
($1, $2, $3::int[], $4::text[], $5::int[]);"
(or limit (sql-null)) (or offset 0)
(if exclude-ids (list->vector exclude-ids) #())
(if tags (list->vector tags) #())
(list->vector sources))))
(define (get-user-settings conn user-id)
(row-alist (query conn
"select unviewed_only as \"unviewed-only\", tracking
from user_settings where user_id=$1;"
user-id)))
(define (scheme-symbol->db-name symbol)
(string-intersperse (string-split (symbol->string symbol) "-") "_"))
(define (set-user-setting! conn user-id setting value)
(when (= (row-count
(query conn "select 1 from user_settings where user_id=$1;" user-id))
0)
(query conn (conc "insert into user_settings(user_id, "
(scheme-symbol->db-name setting)
") values ($1, $2);")
value user-id))
(query conn (conc "update user_settings set " (scheme-symbol->db-name setting)
"=$1 where user_id=$2;")
value user-id))
(define (get-articles-viewed-by-user conn user-id)
(column-values
(query conn
"select article_id from article_viewed_by_user
where user_id=$1 and viewed=TRUE;" user-id)))
(define (get-article-points conn article-id #!key (add-to-params #t))
(value-at
(query
conn "select points from article_stats where article_id=$1;" article-id)
0 0))
(define (mark-article-viewed! conn article-id user-id)
(handle-exceptions
exn
(if (string=?
((condition-property-accessor 'query 'error-code "nill") exn)
"23505") ; unique violation, we don't care
(void)
(abort exn))
(query conn
"insert into article_viewed_by_user(article_id, user_id, viewed)
values($1, $2, TRUE);"
article-id user-id)))
(define (increment-article-viewed! conn article-id)
(query conn
"update article_stats set view_count = view_count + 1
where article_id=$1;"
article-id))
(define (upvote-article! conn article-id)
(query conn
"update article_stats set points = points + 1 where article_id=$1;"
article-id))
(define (touch-session conn session-id expiration)
(query conn "update session set expiration=$1 where session_id=$2;"
expiration session-id))
(define (set-session-user-id! conn session-id user-id expiration
#!key (new-session #f))
(if new-session
(query conn
"insert into session(user_id, session_id, expiration)
values ($1, $2, $3);"
user-id session-id expiration)
(query conn
"update session set user_id=$1 where session_id=$2;"
user-id session-id))
(touch-session conn session-id expiration))
(define (get-session-user-id conn session-id)
(query conn "select expiration, user_id from session where session_id=$1;" session-id))
(define (session-exists? conn session-id)
(> (row-count
(query conn "select 1 from session where session_id=$1;" session-id))
0))
(define (user-signed-in? conn user-id session-id)
(> (row-count
(query conn "select 1 from user_account
join session on session.user_id = user_account.user_id
where user_account.user_id=$1 and password != ''
and session_id=$2;"
user-id session-id))
0))
(define (account-exists? conn email)
(> (row-count
(query conn "select 1 from user_account where email=$1 and password != '';"
email))
0))
(define (create-account! conn user-id email password-hash salt)
(if (not (account-exists? conn email))
(query conn
"update user_account set email=$1, password=$2, salt=$3 where user_id=$4;"
email password-hash salt user-id)
(signal account-exists-condition)))
(define (get-users-articles conn user-id limit #!key rank tag)
(query* conn
(string-append
"select article_id, title, author, date, description,
rank, content, cover_image_path, cover_image_height,
cover_image_width, tags::text[], points, uri,
source_name, source_icon_path, source_id, authors::text[],
author_ids::int[] from
get_tag_subscriptions_by_user"
(if rank "_by_rank" "")
"($1, $2"
(if tag ", $3::varchar" "")
");")
`(,user-id ,limit ,@(if tag `(,tag) '()))))
(define (get-user-subscriptions conn user-id)
(let ((tag-subscriptions
(query
conn
"select tags.name, tag_subscriptions.source_id,
tag_subscriptions.tag_id, article_source.name, article_source.icon_path
from tag_subscriptions
join tags on tags.tag_id=tag_subscriptions.tag_id
join article_source on article_source.source_id=tag_subscriptions.source_id
where tag_subscriptions.user_id=$1;"
user-id))
(author-subscriptions
(query
conn
"select authors.name, author_subscriptions.author_id
from author_subscriptions
join authors on authors.author_id=author_subscriptions.author_id
where author_subscriptions.user_id=$1;"
user-id)))
(append
(row-map* (lambda (name source-id tag-id source-name icon-path)
`((source-id . ,source-id) (source-name . ,source-name)
(type . tag) (value . ,name) (value-id . ,tag-id)
(source-icon-path . ,icon-path)))
tag-subscriptions)
(row-map* (lambda (name author-id)
`((type . author) (value . ,name) (value-id . ,author-id)))
author-subscriptions))))
(define (get-user-headers conn user-id)
(append
(row-map*
(lambda (name tag-id)
`((value . ,name) (id . ,tag-id) (type . tag)))
(query conn
"select name, tags.tag_id from tag_subscriptions
join tags on tags.tag_id = tag_subscriptions.tag_id
where user_id=$1 group by name, tags.tag_id;"
user-id))
(row-map*
(lambda (name author-id)
`((value . ,name) (id . ,author-id) (type . author)))
(query conn
"select name, authors.author_id from author_subscriptions
join authors on authors.author_id = author_subscriptions.author_id
where user_id=$1;"
user-id))))
(define (user-has-subscriptions conn user-id)
(or
(> (row-count
(query conn
"select 1 from tag_subscriptions
where tag_subscriptions.user_id=$1 limit 1" user-id))
0)
(> (row-count
(query conn
"select 1 from author_subscriptions
where author_subscriptions.user_id=$1 limit 1" user-id))
0)))
(define (user-tags conn user-id)
(query conn
"select tags.name from tag_subscriptions
join tags on tags.tag_id = tag_subscriptions.tag_id
where user_id=$1 group by tags.name;"
user-id))
(define (user-tag-subscribe! conn tag user-id source-id)
(when (> (row-count
(query conn
"select 1 from article_view where source_id=$1
and $2 = any(tags) limit 1;"
source-id tag))
0)
(query conn "insert into tag_subscriptions(user_id, tag_id, source_id)
values($1, (select tag_id from tags where name=$2), $3);"
user-id tag source-id)))
(define (user-tag-unsubscribe! conn tag user-id . source-id)
(if (optional source-id #f)
(query conn
"delete from tag_subscriptions where user_id=$1 and
tag_id=(select tag_id from tags where name=$2) and
source_id=$3;"
user-id tag (car source-id))
(query conn
"delete from tag_subscriptions where user_id=$1 and
tag_id=(select tag_id from tags where name=$2);"
user-id tag)))
(define (user-author-subscribe! conn author-id user-id)
(query conn "insert into author_subscriptions(user_id, author_id)
values($1, $2);"
user-id author-id))
(define (user-author-unsubscribe! conn author-id user-id)
(query conn
"delete from author_subscriptions where user_id=$1 and
author_id=$2;"
user-id author-id))
(define (set-rank-by-tag-association conn source tag rank limit #!key (offset 0))
(query conn
"update articles set rank=$1 from
(select articles.article_id from articles
join article_tags on article_tags.article_id = articles.article_id
join tags on tags.tag_id = article_tags.tag_id
join article_source on article_source.source_id = articles.source_id
where article_source.name = $2 and tags.name=$3
order by date desc limit $4 offset $5) as t
where articles.article_id=t.article_id;"
rank source tag limit offset))
(define (set-rank-by-title conn source-name titles rank)
(query conn
"update articles set rank=$1 from
(select articles.article_id from articles
join article_source on article_source.source_id = articles.source_id
where articles.title = any($2)
and article_source.name = $3) as t
where articles.article_id=t.article_id;"
rank (list->vector titles) source-name))
(define (set-rank-by-uri conn source-name uri rank)
(query conn
"update articles set rank=$1 from
(select articles.article_id from articles
join article_source on article_source.source_id = articles.source_id
where articles.uri=$2
and article_source.name = $3) as t
where articles.article_id=t.article_id;"
rank uri source-name))
(define (set-rank-by-partial-uri conn source-name uris rank)
(query conn
"update articles set rank=$1 from
(select articles.article_id from articles
join article_source on article_source.source_id = articles.source_id
where articles.uri like any($2)
and article_source.name = $3) as t
where articles.article_id=t.article_id;"
rank (list->vector
(map (lambda (u) (string-append "%" u "%")) uris)) source-name))
(define (set-rank-by-rank conn source-name by-rank to-rank limit)
(query conn
"update articles set rank=$1 from
(select articles.article_id from articles
join article_source on article_source.source_id = articles.source_id
where rank=$2 and article_source.name=$3 limit $4) as t
where articles.article_id=t.article_id;"
to-rank by-rank source-name limit))
(define (set-rank-by-guids conn rank guids)
(query conn
"update articles set rank=$1 where guid = any($2);"
rank (list->vector guids)))
(define (set-rank-by-date-difference conn rank duration source-name limit offset)
(query conn "update articles set rank=$1 from
(select article_id from articles
join article_source on article_source.source_id = articles.source_id
where date > $2 and article_source.name=$3 order by date desc limit $4
offset $5) as t
where articles.article_id=t.article_id;"
rank (date-subtract-duration (current-date) duration) source-name
limit offset))
(define (get-tags-by-rank conn)
(column-values
(query conn
"select name from tags where rank < 100 order by rank;")))
(define (get-tag-groups conn)
(row-map*
(lambda (tag-id group-name tag-name group-id)
`((tag-id . ,tag-id) (group-name . ,group-name) (tag-name . ,tag-name)
(group-id . ,group-id)))
(query
conn
"select tags_groups.tag_id, group_name, tags.name, tags_groups.group_id
from tags_groups
join tag_group_names on tag_group_names.group_id = tags_groups.group_id
join tags on tags.tag_id = tags_groups.tag_id order by rank;")))
(define (add-to-breaking-news-email conn user-id session-id email)
(when (not (user-signed-in? conn user-id session-id))
(query conn "update user_account set email=$1 where user_id=$2;"
email user-id))
(when (= (row-count
(query conn "select 1 from breaking_news_email where email=$1;"
email))
0)
(query conn "insert into breaking_news_email(email) values($1);"
email)))
(define (add-to-get-invited conn email)
(when (= (row-count
(query conn "select 1 from get_invited where email=$1;"
email))
0)
(query conn "insert into get_invited(email) values($1);"
email)))
(define (set-tags-by-text conn text-list tag)
(let* ((tag-id-result
(query conn
"select tag_id from tags where name=$1;" tag))
(tag-exists (> (row-count tag-id-result) 0))
(tag-id (if tag-exists
(value-at tag-id-result 0 0)
(insert-new-tag conn tag))))
(let ((ids
(column-values
(query*
conn
(conc
"select article_id from (select distinct t2.article_id from (select article_id from articles order by date desc limit 50000) as t2
join articles on articles.article_id = t2.article_id
where "
(string-intersperse
(map-in-order
(lambda (i)
(conc "description like $" i
" or description like $" (+ i 1)
" or title like $" (+ i 2)
" or title like $" (+ i 3)))
(iota (length text-list) 2 4))
" or ")
") as t
where article_id <> all
(select article_id from article_tags where tag_id=$1);")
(append
(list tag-id)
(flatten
(map-in-order
(lambda (text)
`(,(conc "%" text "%")
,(conc "%" (string-titlecase text) "%")
,(conc "%" text "%")
,(conc "%" (string-titlecase text) "%")))
text-list)))))))
(for-each (lambda (id)
(query conn
"insert into article_tags(tag_id, article_id) values($1, $2);"
tag-id id))
ids))))
)