src/backlinks.lisp

   1 (uiop:define-package #:lw2.backlinks
   2   (:use #:cl #:alexandria #:split-sequence
   3         #:lw2.html-reader #:lw2.lmdb #:lw2.backend-modules #:lw2.backend #:lw2.sites #:lw2.links #:lw2.context #:lw2.clean-html #:lw2.conditions #:lw2.utils #:lw2.interface-utils)
   4   (:import-from #:collectors #:with-collector)
   5   (:export #:clear-backlinks #:add-backlink #:get-backlinks #:backlinks-to-html))
   6
   7 (in-package #:lw2.backlinks)
   8
   9 (named-readtables:in-readtable html-reader)
  10
  11 (define-cache-database 'backend-backlinks
  12   (list "backlinks" :flags liblmdb:+dupsort+)
  13   (list "frontlinks" :flags liblmdb:+dupsort+)
  14   "backlinks-cache")
  15
  16 (declaim (ftype (function (string (or null string) &optional string) string) item-reference-string))
  17
  18 (defun item-reference-string (post-id comment-id &optional host)
  19   (format nil "~@[~A ~]~A~@[ ~A~]" host post-id comment-id))
  20
  21 (define-backend-function clear-backlinks (post-id &optional comment-id)
  22   (backend-backlinks
  23    (cache-del "frontlinks" (item-reference-string post-id comment-id))))
  24
  25 (define-backend-function add-backlink (link post-id &optional comment-id)
  26   (backend-backlinks
  27    (let* ((link-host (or (quri:uri-host (quri:uri link)) (site-host *current-site*)))
  28           (link-site (and link-host (find-site link-host)))
  29           (current-host (site-host *current-site*)))
  30      (when link-site
  31        (multiple-value-bind (link-post-id link-comment-id) (match-lw2-link link)
  32          (when link-post-id
  33            (ignore-errors
  34              (cache-put "frontlinks"
  35                         (item-reference-string post-id comment-id)
  36                         (item-reference-string link-post-id link-comment-id link-host))
  37              (with-site-context (link-site)
  38                (cache-put "backlinks"
  39                           (item-reference-string link-post-id link-comment-id)
  40                           (item-reference-string post-id comment-id current-host)))))))))
  41   (backend-base
  42    (declare (ignore link post-id comment-id))
  43    nil))
  44
  45 (define-backend-function link-exists-p (source-post-id source-comment-id target-host target-post-id target-comment-id)
  46   (backend-backlinks
  47    (call-with-cursor "frontlinks"
  48                      (lambda (db cursor)
  49                        (declare (ignore db))
  50                        (cursor-get cursor :get-both
  51                                    :key (item-reference-string source-post-id source-comment-id)
  52                                    :value (item-reference-string target-post-id target-comment-id target-host)
  53                                    :return-type 'existence)))))
  54
  55 (define-backend-function get-backlink-pointers (post-id &optional comment-id)
  56   (backend-backlinks
  57    (call-with-cursor "backlinks"
  58                      (lambda (db cursor)
  59                        (declare (ignore db))
  60                        (loop for backlink-data = (cursor-get cursor :set :key (item-reference-string post-id comment-id))
  61                           then (cursor-get cursor :next-dup)
  62                           while backlink-data
  63                           collect (split-sequence #\Space backlink-data)))
  64                      :read-only t))
  65   (backend-base
  66    (declare (ignore post-id comment-id))
  67    nil))
  68
  69 (define-backend-function process-backlink (current-post-id current-comment-id source-site-host source-post-id &optional source-comment-id)
  70   (backend-backlinks
  71    (let* ((source-db (if source-comment-id "post-comments-json-meta" "post-body-json-meta"))
  72           (metadata (cache-get source-db source-post-id :value-type :lisp))
  73           (cache-key (format nil "~@{~S~^ ~}" current-post-id current-comment-id source-site-host source-post-id source-comment-id))
  74           (cached-data (cache-get "backlinks-cache" cache-key :value-type :lisp))
  75           (last-modified (cdr (assoc :last-modified metadata)))
  76           (if-modified-since (cdr (assoc :if-modified-since cached-data))))
  77      (if (and last-modified if-modified-since (= last-modified if-modified-since))
  78          cached-data
  79          (log-and-ignore-errors
  80           (let ((current-site-host (site-host *current-site*)))
  81             (labels ((cleanup-stale-backlink ()
  82                        (with-cache-transaction
  83                            (cache-del "backlinks-cache" cache-key)
  84                          (cache-del "backlinks"
  85                                     (item-reference-string current-post-id current-comment-id)
  86                                     :value (item-reference-string source-post-id source-comment-id source-site-host)))
  87                        nil))
  88               (handler-case
  89                   (with-site-context ((find-site source-site-host))
  90                     (if (not (link-exists-p source-post-id source-comment-id current-site-host current-post-id current-comment-id))
  91                         (cleanup-stale-backlink)
  92                         (let* ((source-post (get-post-body source-post-id :revalidate nil))
  93                                (source-comment (when source-comment-id
  94                                                  (find-if (lambda (c) (string= source-comment-id (cdr (assoc :--id c))))
  95                                                           (get-post-comments source-post-id :revalidate nil))))
  96                                (result
  97                                 (alist :if-modified-since last-modified
  98                                        :site-host source-site-host
  99                                        :link (generate-item-link :post source-post :comment-id source-comment-id :absolute t)
 100                                        :post-title (cdr (assoc :title source-post))
 101                                        :post-user-id (cdr (assoc :user-id source-post))
 102                                        :comment-user-id (cdr (assoc :user-id source-comment))
 103                                        :posted-at (cdr (assoc :posted-at (or source-comment source-post)))
 104                                        :score (cdr (assoc :base-score (or source-comment source-post))))))
 105                           (cache-put "backlinks-cache" cache-key (prin1-to-string result))
 106                           result)))
 107                 (lw2-client-error ()
 108                   (cleanup-stale-backlink))))))))))
 109
 110 (define-backend-function get-backlinks (post-id &optional comment-id)
 111   (backend-backlinks
 112    (loop
 113       for bp in (get-backlink-pointers post-id comment-id)
 114       for backlink-data = (apply 'process-backlink post-id comment-id bp)
 115       when backlink-data collect backlink-data))
 116   (backend-base
 117    (declare (ignore post-id comment-id))
 118    nil))
 119
 120 (defun backlinks-to-html (backlinks id)
 121   (when backlinks
 122     <div class="backlinks">
 123       <input type="checkbox" id=("expand-~A" id)>
 124       <label for=("expand-~A" id)>What links here?</label>
 125       <ul>
 126       (let ((original-site *current-site*))
 127         (loop for backlink-alist in (sort backlinks
 128                                           (lambda (x y) (> (or x 0) (or y 0)))
 129                                           :key (lambda (bl) (cdr (assoc :score bl))))
 130            do
 131              (log-and-ignore-errors
 132               (alist-bind (site-host link post-title post-user-id comment-user-id posted-at score) backlink-alist
 133                 (with-site-context ((find-site site-host))
 134                   <li>
 135                     <a href=link>
 136                       (with-html-stream-output
 137                           (when comment-user-id
 138                             <span class="inline-author" data-userid=comment-user-id>(get-username comment-user-id)</span>
 139                             (format *html-output* "'s comment on ")))
 140                       (safe (clean-text-to-html post-title))
 141                       (" by ")
 142                       <span class="inline-author" data-userid=post-user-id>(get-username post-user-id)</span>
 143                       (" (")
 144                       (when (not (eq *current-site* original-site))
 145                         (format *html-output* "~A; " (main-site-title *current-site*)))
 146                       (multiple-value-bind (pretty-time js-time) (pretty-time posted-at)
 147                         <span class="date" data-js-date=js-time>
 148                           (safe pretty-time)
 149                           (safe (pretty-time-js))
 150                         </span>)
 151                       ("; ~A point~:*~P)" score)
 152                     </a>
 153                   </li>)))))
 154       </ul>
 155     </div>))