src/data-viewers/post.lisp

   1 (uiop:define-package #:lw2.data-viewers.post
   2   (:use #:cl #:lw2.utils #:lw2.sites #:lw2.backend #:lw2.context #:lw2.clean-html #:lw2.schema-type #:lw2.html-reader #:lw2.interface-utils #:lw2.user-context #:lw2.links #:lw2.backlinks)
   3   (:import-from #:alexandria #:when-let)
   4   (:export #:post-headline-to-html #:post-body-to-html))
   5
   6 (in-package #:lw2.data-viewers.post)
   7
   8 (named-readtables:in-readtable html-reader)
   9
  10 (define-schema-type :post ()
  11   ((post-id string :alias :--id)
  12    (slug string)
  13    (title string)
  14    (user-id string)
  15    (coauthors (or null list) :backend-type backend-lw2 :subfields (:--id))
  16    (url (or null string))
  17    (feed-link (or null string) :backend-type backend-feed-crossposts)
  18    (canonical-source (or null string) :backend-type backend-feed-crossposts)
  19    (posted-at string)
  20    (base-score (or null fixnum))
  21    (af-base-score (or null fixnum))
  22    (comment-count (or null fixnum))
  23    (page-url (or null string))
  24    (word-count (or null fixnum))
  25    (frontpage-date (or null string))
  26    (curated-date (or null string))
  27    (legacy-id t :backend-type backend-lw2)
  28    (meta boolean)
  29    (af boolean :backend-type backend-alignment-forum)
  30    (draft boolean)
  31    (question boolean :backend-type backend-q-and-a)
  32    ;; todo: allow recursive schema types and clean this up
  33    (target-post-relations list
  34                           :context :body
  35                           :backend-type backend-related-questions
  36                           :subfields ((:target-post :--id :slug :title :user-id :url :feed-link
  37                                                     :posted-at :base-score :comment-count :page-url
  38                                                     :word-count :frontpage-date :curated-date :meta
  39                                                     :af :question :vote-count)))
  40    (source-post-relations list
  41                           :context :body
  42                           :backend-type backend-related-questions
  43                           :subfields ((:source-post :--id :slug :title :user-id :url :feed-link
  44                                                     :posted-at :base-score :comment-count :page-url
  45                                                     :word-count :frontpage-date :curated-date :meta
  46                                                     :af :question :vote-count)))
  47    (vote-count (or null fixnum))
  48    (nomination-count-2019 (or null fixnum) :backend-type backend-lw2)
  49    (review-count-2019 (or null fixnum) :backend-type backend-lw2)
  50    (is-event boolean :backend-type backend-events)
  51    (local-start-time (or null string) :backend-type backend-events)
  52    (local-end-time (or null string) :backend-type backend-events)
  53    (location (or null string) :backend-type backend-events)
  54    (google-location (or null list) :backend-type backend-events)
  55    (contact-info (or null string) :backend-type backend-events)
  56    (comment-sort-order (or null string) :backend-type backend-lw2)
  57    (tags list :graphql-ignore t)
  58    (submit-to-frontpage boolean :backend-type backend-lw2-misc-features)
  59    (html-body (or null string) :context :body)))
  60
  61 (defgeneric rectify-post* (backend post) ; TODO this should go in a more generic postprocessing method
  62   (:method ((backend t) post) post)
  63   (:method ((backend backend-lw2-misc-workarounds) post)
  64     (let* ((post (if (next-method-p) (call-next-method) post))
  65            (url (cdr (assoc :url post)))
  66            (url (and url (string-trim " " url))))
  67       (cond ((null url) post)
  68             ((or (uiop:string-prefix-p "http" url) (uiop:string-prefix-p "/" url)) post)
  69             (t (acons :url (concatenate 'string "http://" url) post)))))
  70   (:method ((backend backend-feed-crossposts) post)
  71     (if (cdr (assoc :url post))
  72         post
  73         (acons :url (cdr (assoc :feed-link post)) post))))
  74
  75 (defun rectify-post (post) (rectify-post* *current-backend* post))
  76
  77 (defgeneric tag-list-to-html (backend tags)
  78   (:method ((backend backend-accordius) tags)
  79     (dolist (tag tags) (alist-bind ((text string)) tag <a href=("/tags/~A" text)>(progn text)</a>)))
  80   (:method ((backend backend-lw2-tags) tags)
  81     (dolist (tag tags) (alist-bind ((name string) (slug string)) (cdr (assoc :tag tag)) <a href=("/tag/~A" slug)>(progn name)</a>))))
  82
  83 (defun qualified-linking (url meta-location)
  84   <nav class="qualified-linking">
  85     <input type="checkbox" tabindex="-1" id=("qualified-linking-toolbar-toggle-checkbox-~(~A~)" meta-location)>
  86     <label for=("qualified-linking-toolbar-toggle-checkbox-~(~A~)" meta-location)><span>&#xf141\;</span></label>
  87     <div class="qualified-linking-toolbar">
  88       <a href=url>Post permalink</a>
  89       <a href=("~A?comments=false" url)>Link without comments</a>
  90       <a href=("~A?hide-nav-bars=true" url)>Link without top nav bars</a>
  91       <a href=("~A?comments=false&hide-nav-bars=true" url)>Link without comments or top nav bars</a>
  92     </div>
  93   </nav>)
  94
  95 (defun post-section-to-html (post &key skip-section)
  96   (schema-bind (:post (rectify-post post) (user-id frontpage-date curated-date meta is-event af draft))
  97     (multiple-value-bind (class title href)
  98         (cond (af (if (eq skip-section :alignment-forum) nil (values "alignment-forum" "View Alignment Forum posts" "/index?view=alignment-forum")))
  99               ; show alignment forum even if skip-section is t
 100               ((eq skip-section t) nil)
 101               (draft nil)
 102               (curated-date (if (eq skip-section :featured) nil (values "featured" "View Featured posts" "/index?view=featured")))
 103               (frontpage-date (if (eq skip-section :frontpage) nil (values "frontpage" "View Frontpage posts" "/")))
 104               (meta (if (eq skip-section :meta) nil (values "meta" "View Meta posts" "/index?view=meta")))
 105               (is-event (values "events" "View Events" "/index?view=events"))
 106               (t (if (eq skip-section :personal) nil (values "personal" (format nil "View posts by ~A" (get-username user-id)) (format nil "/users/~A?show=posts" (get-user-slug user-id))))))
 107       <a class=("post-section ~A" class) title=title href=href></a>)))
 108
 109 (defun post-meta-to-html (post context skip-section meta-location)
 110   (schema-bind (:post (rectify-post post) :auto)
 111     <div class=("post-meta~@[ ~(~A~)-post-meta~]" meta-location)>
 112       (labels ((emit-author (user-id)
 113                  (if (user-deleted user-id)
 114                      <span class="author">[deleted]</span>
 115                      <a class=("author~{ ~A~}" (list-cond
 116                                                 ((logged-in-userid user-id) "own-user-author")))
 117                         href=("/users/~A" (get-user-slug user-id))
 118                         data-userid=user-id
 119                         data-full-name=(get-user-full-name user-id)>
 120                        (get-username user-id)
 121                      </a>)))
 122         (if coauthors
 123             <div class="coauthors">
 124               (emit-author user-id)
 125               (do ((remaining-coauthors coauthors (rest remaining-coauthors))) ((not remaining-coauthors))
 126                 (with-html-stream-output (:stream stream)
 127                   (write-string
 128                    (cond ((second remaining-coauthors) ", ")
 129                          (t " and "))
 130                    stream))
 131                 (emit-author (cdr (assoc :--id (first remaining-coauthors)))))
 132             </div>
 133             (emit-author user-id)))
 134       (pretty-time-html posted-at)
 135       (vote-buttons base-score :with-buttons (eq context :body) :vote-count vote-count :post-id post-id :af-score (and (eq context :body) af af-base-score))
 136       <a class="comment-count" href=("~A#comments" (if (eq context :body) "" (generate-item-link :post post)))>
 137         (safe (pretty-number (or comment-count 0) "comment"))
 138       </a>
 139       (when (and (eq context :listing) word-count)
 140         <span class="read-time" title=(safe (pretty-number word-count "word" :text))>(max 1 (round word-count 300))<span> min read</span></span>)
 141       (if page-url <a class="lw2-link" href=(clean-lw-link page-url)>(main-site-abbreviation *current-site*)<span> link</span></a>)
 142       (when (and legacy-id (eq context :body))
 143         <a class="archive-link" href=("https://web.archive.org/web/*/~A" (lw2.legacy-archive:lw-legacy-url legacy-id title))>Archive</a>)
 144       (when (nonzero-number-p nomination-count-2019)
 145         <a href=("~A#nominations" (if (eq context :body) "" (generate-item-link :post post))) class="nomination-count">(safe (pretty-number nomination-count-2019 "nomination"))</a>)
 146       (when (nonzero-number-p review-count-2019)
 147         <a href=("~A#reviews" (if (eq context :body) "" (generate-item-link :post post))) class="review-count">(safe (pretty-number review-count-2019 "review"))</a>)
 148       (with-html-stream-output (post-section-to-html post :skip-section skip-section))
 149       (when (and (eq context :body) tags)
 150         <div id="tags">
 151           (tag-list-to-html *current-backend* tags)
 152         </div>)
 153       (when-let ((url-host (and (eq context :listing) url (ignore-errors (quri:uri-host (quri:uri (string-trim " " url)))))))
 154         <div class="link-post-domain">("(~A)" url-host)</div>)
 155       (when (eq context :body)
 156         (qualified-linking (generate-item-link :post post) meta-location))
 157     </div>))
 158
 159 (defun post-headline-to-html (post &key skip-section need-auth)
 160   (schema-bind (:post (rectify-post post) (post-id user-id url question title))
 161     <h1 class=("listing~{ ~A~}" (list-cond
 162                                  (url "link-post-listing")
 163                                  (question "question-post-listing")
 164                                  ((logged-in-userid user-id) "own-post-listing")))>
 165       (if url <a class="link-post-link" href=(presentable-link url)>&#xf0c1;</a>)
 166       <a class="post-title-link" href=(generate-post-auth-link post nil nil need-auth)>
 167         (if question <span class="post-type-prefix">[Question] </span>)
 168         (safe (clean-text-to-html title))
 169       </a>
 170       (if (logged-in-userid user-id) <a class="edit-post-link button" href=("/edit-post?post-id=~A" post-id)></a>)
 171     </h1>
 172     (post-meta-to-html post :listing skip-section nil)))
 173
 174 (defun post-body-to-html (post)
 175   (schema-bind (:post (rectify-post post) (post-id url question title html-body is-event local-start-time local-end-time location google-location contact-info) :context :body)
 176     <main class=("post~{ ~A~}" (list-cond
 177                                 (url "link-post")
 178                                 (question "question-post")))>
 179       <h1 class="post-title">
 180         (if question <span class="post-type-prefix">[Question] </span>)
 181         (safe (clean-text-to-html title :hyphenation nil))
 182       </h1>
 183       (with-html-stream-output (post-meta-to-html post :body nil :top))
 184       (when is-event
 185         (labels ((brief-date (timestamp)
 186                    (local-time:format-timestring nil timestamp :timezone local-time:+utc-zone+ :format '(:day #\Space :long-month #\Space :year)))
 187                  (brief-time (timestamp)
 188                    (local-time:format-timestring nil timestamp :timezone local-time:+utc-zone+ :format '(:hour12 #\: (:min 2) #\Space :ampm))))
 189           <div class="event-info">
 190             (alist-bind ((geometry list)
 191                          (google-maps-url (or null string) :url))
 192                         google-location
 193               (alist-bind ((lat (or null real)) (lng (or null real))) (cdr (assoc :location geometry))
 194                 (when (and lat lng)
 195                   (let* ((north (+ lat 0.125)) (south (- lat 0.125)) (east (+ lng 0.25)) (west (- lng 0.25)))
 196                     <div class="map">
 197                       <iframe src=("https://www.openstreetmap.org/export/embed.html?bbox=~F,~F,~F,~F&layer=mapnik&marker=~F,~F" west south east north lat lng)></iframe>
 198                     </div>))
 199                 (let* ((start-timestamp (and local-start-time (local-time:parse-timestring local-start-time)))
 200                        (end-timestamp (and local-end-time (local-time:parse-timestring local-end-time)))
 201                        (same-day (and start-timestamp end-timestamp (= (local-time:day-of start-timestamp) (local-time:day-of end-timestamp)))))
 202                   <ul>
 203                     (when (and lat lng)
 204                       <li><a href=("https://www.google.com/maps/place/~F,~F" lat lng)>[Open in Google Maps]</a> <a href=("geo:~F,~F" lat lng)>[Open in local app]</a></li>)
 205                     (when start-timestamp
 206                       <li>(brief-date start-timestamp), (brief-time start-timestamp)
 207                         (when end-timestamp
 208                           <span>—(unless same-day (format nil "~A, " (brief-date end-timestamp)))(brief-time end-timestamp)</span>)
 209                       </li>)
 210                     (when location
 211                       <li>(safe (clean-text-to-html location))</li>)
 212                     (when contact-info
 213                       <li>Contact: (safe (clean-text-to-html contact-info))</li>)
 214                     </ul>)))
 215         </div>))
 216       (when (or url (nonempty-string html-body))
 217         <div class="body-text post-body">
 218           (if url <p><a class="link-post-link" href=(presentable-link url)>Link post</a></p>)
 219           (with-html-stream-output (:stream stream)
 220             (let ((*before-clean-hook* (lambda () (clear-backlinks post-id)))
 221                   (*link-hook* (lambda (link) (add-backlink link post-id)))
 222                   (lw2.lmdb:*memoized-output-stream* stream))
 223               (clean-html* (or html-body "") :with-toc t :post-id post-id)))
 224         </div>)
 225       (backlinks-to-html (get-backlinks post-id) post-id)
 226       (when (nonempty-string html-body)
 227         (with-html-stream-output (post-meta-to-html post :body nil :bottom)))
 228     </main>))