src/background-loader.lisp

   1 (in-package #:lw2.backend)
   2
   3 (defvar *background-loader-thread* nil)
   4 (defvar *background-loader-semaphore* (make-semaphore :count 1))
   5 (defvar *background-loader-ready* nil)
   6
   7 (defun background-loader-running-p ()
   8   (case (semaphore-count *background-loader-semaphore*)
   9     (0 t)
  10     (1 nil)))
  11
  12 (defun background-loader-ready-p ()
  13   (and (background-loader-running-p)
  14        (background-loader-enabled *current-site*)
  15        *background-loader-ready*))
  16
  17 (defun make-site-background-loader-fn (site)
  18   (let (last-post-processed last-comment-processed)
  19     (lambda ()
  20       (with-site-context (site :request nil)
  21         (log-and-ignore-errors
  22          (let* ((posts-json (sb-sys:with-deadline (:seconds 120) (get-posts-json)))
  23                 (posts-list (decode-query-result posts-json)))
  24            (when posts-list
  25              (with-cache-transaction
  26                (cache-put "index-json" "new-not-meta" posts-json)
  27                (dolist (post posts-list)
  28                  (cache-put "postid-to-title" (cdr (assoc :--id post)) (cdr (assoc :title post))))
  29                (dolist (post posts-list)
  30                  (cache-put "postid-to-slug" (cdr (assoc :--id post)) (cdr (assoc :slug post)))))
  31              (loop for post in posts-list
  32                 as post-id = (cdr (assoc :--id post))
  33                 if (string= post-id last-post-processed) return nil
  34                 do (log-and-ignore-errors
  35                     (lw2.clean-html:clean-html (cdr (assoc :html-body (get-post-body post-id :revalidate nil))) :with-toc t :post-id post-id)))
  36              (setf last-post-processed (cdr (assoc :--id (first posts-list)))))))
  37         (log-and-ignore-errors
  38          (let ((recent-comments-json (sb-sys:with-deadline (:seconds 120) (get-recent-comments-json))))
  39            (when-let ((recent-comments (ignore-errors (decode-query-result recent-comments-json))))
  40              (cache-put "index-json" "recent-comments" recent-comments-json)
  41              (loop for comment in recent-comments
  42                 as comment-id = (cdr (assoc :--id comment))
  43                 as cache-database = (if (or (cdr (assoc :answer comment)) (cdr (assoc :parent-answer-id comment)))
  44                                         "post-answers-json"
  45                                         "post-comments-json")
  46                 if (string= comment-id last-comment-processed) return nil
  47                 do (log-and-ignore-errors
  48                     (with-cache-transaction
  49                         (when-let ((post-id (cdr (assoc :post-id comment))))
  50                           (let* ((post-comments (when-let ((x (cache-get cache-database post-id :return-type 'binary-stream))) (decode-query-result x)))
  51                                  (new-post-comments (sort (cons comment (delete-if (lambda (c) (string= comment-id (cdr (assoc :--id c)))) post-comments))
  52                                                           #'> :key (lambda (c) (cdr (assoc :base-score c))))))
  53                             (cache-update cache-database post-id (comments-list-to-graphql-json new-post-comments))))
  54                       (when-let ((user-id (cdr (assoc :user-id comment))))
  55                         (cache-mark-stale "user-page-items" user-id))
  56                       (mark-comment-replied comment)))
  57                 do (log-and-ignore-errors
  58                     (lw2.clean-html:clean-html (cdr (assoc :html-body comment)))))
  59              (setf last-comment-processed (cdr (assoc :--id (first recent-comments)))))))
  60         (send-all-notifications)))))
  61
  62 (defun background-loader ()
  63   (let (sites loader-functions)
  64     (loop
  65        (unless (eq sites *sites*)
  66          (setf sites *sites*
  67                loader-functions (loop for site in sites
  68                                    when (background-loader-enabled site)
  69                                    collect (make-site-background-loader-fn site))))
  70        (dolist (loader-fn loader-functions)
  71          (funcall loader-fn))
  72        (setf *background-loader-ready* t)
  73        (if (wait-on-semaphore *background-loader-semaphore* :timeout 60)
  74            (return)))))
  75
  76 (defun start-background-loader ()
  77   (if (background-loader-running-p)
  78       (warn "Background loader already running.")
  79       (progn
  80         (wait-on-semaphore *background-loader-semaphore*)
  81         (setf *background-loader-thread* (sb-thread:make-thread #'background-loader :name "background loader")))))
  82
  83 (defun stop-background-loader ()
  84   (if (background-loader-running-p)
  85       (progn
  86         (signal-semaphore *background-loader-semaphore*)
  87         (join-thread *background-loader-thread*)
  88         (setf *background-loader-thread* nil
  89               *background-loader-ready* nil)
  90         (signal-semaphore *background-loader-semaphore*))
  91       (warn "Background loader not running.")))