kabonky/db.scm

(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))))

)