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