src/admin.lisp

   1 (uiop:define-package #:lw2.admin
   2   (:use #:cl #:alexandria #:lw2.lmdb #:lw2.clean-html #:lw2.backend #:lw2.backlinks)
   3   (:export #:reclean-html))
   4
   5 (in-package #:lw2.admin)
   6
   7 (defun map-posts-and-comments (fn &key skip-comments skip-posts)
   8   (let ((total-count (count-database-entries "post-body-json"))
   9         (done-count 0)
  10         (last-done nil))
  11     (format *error-output* "Press Enter to abort.~%")
  12     (labels ((report-progress ()
  13                (when (= 0 (mod done-count 1))
  14                  (format *error-output* "Finished ~A of ~A posts.~A" done-count total-count (string #\Return))
  15                  (force-output *error-output*))))
  16       (loop
  17          for (post post-id) = (with-cache-readonly-transaction
  18                                   (call-with-cursor "post-body-json"
  19                                                     (lambda (db cursor)
  20                                                       (declare (ignore db))
  21                                                       (multiple-value-bind (post post-id)
  22                                                           (if last-done
  23                                                               (progn
  24                                                                 (cursor-get cursor :set-range :key last-done :return-type 'existence)
  25                                                                 (cursor-get cursor :next :value-type :json))
  26                                                               (cursor-get cursor :first :value-type :json))
  27                                                         (list (ignore-errors (postprocess-query-result post)) post-id)))))
  28          while post-id
  29          do (when (read-char-no-hang)
  30               (format *error-output* "Aborted.~%")
  31               (return-from map-posts-and-comments (values)))
  32          do (report-progress)
  33          do (progn
  34               (unless skip-posts
  35                 (with-simple-restart (continue "Ignore this post and continue.")
  36                   (funcall fn post post-id)))
  37               (unless skip-comments
  38                 (ignore-errors
  39                   (let ((comments (if (cdr (assoc :question post))
  40                                       (append (get-post-comments post-id :revalidate nil)
  41                                               (get-post-answers post-id :revalidate nil))
  42                                       (get-post-comments post-id :revalidate nil))))
  43                     (loop for comment in comments
  44                        for comment-id = (cdr (assoc :--id comment))
  45                        do (with-simple-restart (continue "Ignore this comment and continue.")
  46                             (funcall fn comment post-id comment-id))))))
  47               (incf done-count)
  48               (setf last-done post-id)))
  49       (report-progress)
  50       (format *error-output* "~%Done.~%")
  51       (values))))
  52
  53 (defun reclean-html ()
  54   (map-posts-and-comments
  55    (lambda (item post-id &optional comment-id)
  56      (if (not comment-id)
  57          (ignore-errors
  58            (let ((*before-clean-hook* (lambda () (clear-backlinks post-id)))
  59                  (*link-hook* (lambda (link)
  60                                 (add-backlink link post-id))))
  61              (clean-html (or (cdr (assoc :html-body item)) "") :with-toc t :post-id post-id)))
  62          (ignore-errors
  63            (let ((*before-clean-hook* (lambda () (clear-backlinks post-id comment-id)))
  64                  (*link-hook* (lambda (link)
  65                                 (add-backlink link post-id comment-id))))
  66              (clean-html (or (cdr (assoc :html-body item)) ""))))))))
  67
  68 (defun grep-posts-and-comments (regex &key skip-comments print-ids)
  69   (let* ((scanner (ppcre:create-scanner regex))
  70          (printer (if print-ids
  71                       (lambda (item post-id &optional comment-id)
  72                         (when (ppcre:scan scanner (or (cdr (assoc :html-body item)) ""))
  73                           (format t "~A~@[/~A~]~%" post-id comment-id)))
  74                       (lambda (item post-id &optional comment-id)
  75                         (declare (ignore post-id comment-id))
  76                         (ppcre:do-matches-as-strings (match scanner (or (cdr (assoc :html-body item)) ""))
  77                           (write-line match))))))
  78     (map-posts-and-comments
  79      printer
  80      :skip-comments skip-comments)))