◊(Local Yarn Code "crystalize.rkt at [23737623]")

File crystalize.rkt artifact 08bca5d2 part of check-in 23737623


#lang racket/base

; SPDX-License-Identifier: BlueOak-1.0.0
; This file is licensed under the Blue Oak Model License 1.0.0.

(require deta db/base db/sqlite3 threading txexpr gregor)

(require racket/match
         racket/string
         pollen/pagetree
         pollen/template
         (except-in pollen/core select) ; avoid conflict with deta
         pollen/setup)

(require "dust.rkt" "snippets-html.rkt")

(provide init-cache-db!
         cache-conn            ; The most eligible bachelor in Neo Yokyo
         parse-and-cache-article!
         cache-series!
         current-plain-title
         (schema-out cache:article)
         (schema-out cache:note)
         (schema-out cache:series)
         (schema-out cache:index-entry)
         articles
         articles+notes
         listing-htmls
         <listing-full>
         <listing-excerpt>
         <listing-short>
         unfence)

;; Cache DB and Schemas

(define DBFILE (build-path (current-project-root) "vitreous.sqlite"))
(define cache-conn (sqlite3-connect #:database DBFILE #:mode 'create))

(define current-plain-title (make-parameter "void"))

(define-schema cache:article #:table "articles"
  ([id                   id/f #:primary-key #:auto-increment]
   [page                 symbol/f]
   [title-plain          string/f]
   [title-html-flow      string/f]
   [title-specified?     boolean/f]
   [published            string/f]
   [updated              string/f]
   [author               string/f]
   [conceal              string/f]
   [series-page          symbol/f]
   [noun-singular        string/f]
   [note-count           integer/f]
   [doc-html             string/f]
   [disposition          string/f]
   [disp-html-anchor     string/f]
   [listing-full-html    string/f]   ; full content but without notes
   [listing-excerpt-html string/f]   ; Not used for now
   [listing-short-html   string/f])) ; Date and title only

(define-schema cache:note #:table "notes"
  ([id                   id/f #:primary-key #:auto-increment]
   [page                 symbol/f]
   [html-anchor          string/f]
   [title-html-flow      string/f] ; No block-level HTML elements
   [title-plain          string/f]
   [author               string/f]
   [author-url           string/f]
   [published            string/f]
   [disposition          string/f]
   [content-html         string/f]
   [series-page          symbol/f]
   [listing-full-html    string/f]
   [listing-excerpt-html string/f]   ; Not used for now
   [listing-short-html   string/f])) ; Date and title only

(define-schema cache:series #:table "series"
  ([id            id/f #:primary-key #:auto-increment]
   [page          symbol/f]
   [title         string/f]
   [published     string/f]
   [noun-plural   string/f]
   [noun-singular string/f]))

(define-schema cache:index-entry #:table "index_entries"
  ([id          id/f #:primary-key #:auto-increment]
   [entry       string/f]
   [subentry    string/f]
   [page        symbol/f]
   [html-anchor string/f]))

(define-schema listing
  #:virtual
  ([html        string/f]
   [published   date/f]
   [series-page symbol/f]))

(define (init-cache-db!)
  (create-table! cache-conn 'cache:article)
  (create-table! cache-conn 'cache:note)
  (create-table! cache-conn 'cache:series)
  (create-table! cache-conn 'cache:index-entry))

(define (delete-article! page)
  (query-exec cache-conn
              (~> (from cache:article #:as a)
                  (where (= a.page ,(format "~a" page)))
                  delete)))

(define (delete-notes! page)
  (query-exec cache-conn
              (~> (from cache:note #:as n)
                  (where (= n.page ,(format "~a" page)))
                  delete)))


;; Save an article and its notes (if any) to the database, and return the
;; rendered HTML of the complete article.
;;
(define (parse-and-cache-article! pagenode doc)
  (define-values (doc-no-title maybe-title)
    (splitf-txexpr doc (make-tag-predicate 'title)))
  (define-values (body-txpr note-txprs)
    (splitf-txexpr doc-no-title (make-tag-predicate 'note)))
  (define-values (disposition disp-note-id)
    (notes->last-disposition-values note-txprs))

  (let* ([pubdate (select-from-metas 'published (current-metas))]
         [doc-html    (->html body-txpr #:splice? #t)]
         [title-specified? (not (equal? '() maybe-title))]
         [title-val   (if (not (null? maybe-title)) (car maybe-title) (check-for-poem-title doc))]
         [title-tx    (make-article-title pagenode title-val body-txpr disposition disp-note-id)]
         [title-html  (->html title-tx #:splice? #t)]
         [title-plain (tx-strs title-tx)]
         [header      (html$-article-open pagenode title-specified? title-tx pubdate)]
         [series-node (metas-series-pagenode)]
         [footertext  (make-article-footertext pagenode
                                               series-node
                                               disposition
                                               disp-note-id
                                               (length note-txprs))]
         [footer (html$-article-close footertext)]
         [listing-short (html$-article-listing-short pagenode pubdate title-html)]
         [notes-section-html (cache-notes! pagenode title-plain note-txprs)])
    (cache-index-entries! pagenode doc) ; note original doc is used here
    (current-plain-title title-plain)
    (delete-article! pagenode)
    (insert-one! cache-conn
                 (make-cache:article
                  #:page pagenode
                  #:title-plain title-plain
                  #:title-html-flow title-html
                  #:title-specified? title-specified?
                  #:published pubdate
                  #:updated (maybe-meta 'updated)
                  #:author (maybe-meta 'author default-authorname)
                  #:conceal (maybe-meta 'conceal)
                  #:series-page series-node
                  #:noun-singular (maybe-meta 'noun (series-metas-noun))
                  #:note-count (length note-txprs)
                  #:doc-html doc-html
                  #:disposition disposition
                  #:disp-html-anchor disp-note-id
                  #:listing-full-html (string-append header doc-html footer)
                  #:listing-excerpt-html ""
                  #:listing-short-html listing-short))
    (string-append header doc-html notes-section-html footer)))

(define (check-for-poem-title doc-txpr)
  (match (car (get-elements doc-txpr))
    [(txexpr 'div
             (list (list 'class "poem"))
             (list* (txexpr 'p
                            (list (list 'class "verse-heading"))
                            heading-elems)
                    _))
     `(title (span [[class "smallcaps"]] "‘" ,@heading-elems "’"))]
    [_ '()]))

;; Return a title txexpr for the current article, constructing a default if no title text was specified.
(define (make-article-title pagenode supplied-title body-tx disposition disp-note-id)
  (define title-elems
    (cond [(null? supplied-title) (list (default-title (get-elements body-tx)))]
          [else (get-elements supplied-title)]))
  
  (define disposition-part
    (cond [(non-empty-string? disposition)
           (define-values (mark _) (disposition-values disposition))
           `(a [[class "disposition-mark"] 
                [href ,(format "~a~a#~a" web-root pagenode disp-note-id)]] 
               ,mark)]
          [else ""]))
  ;; Returns a txexpr, the tag will be discarded by the template/snippets
  `(title ,@title-elems ,disposition-part))

;; Convert a bunch of information about an article into some nice English and links.
(define (make-article-footertext pagenode series disposition disp-note-id note-count)
  (define series-part
    (match (series-metas-title)
      [(? non-empty-string? s-title)
       (format "<span class=\"series-part\">This is ~a, part of <a href=\"/~a\">‘~a’</a>.</span>"
               (series-metas-noun)
               series
               s-title)]
      [_ ""]))
  (define disp-part
    (cond [(non-empty-string? disposition)
           (define-values (mark verb) (disposition-values disposition))
           (format "Now considered <a href=\"/~a#~a\">~a</a>."
                   pagenode
                   disp-note-id
                   verb)]
          [else ""]))
  (define notes-part
    (cond [(note-count . > . 1)
           (format "There are <a href=\"/~a#furthernotes\">~a notes</a> appended."
                   pagenode
                   note-count)]
          [(and (note-count . > . 0) (string=? disposition ""))
           (format "There is <a href=\"/~a#furthernotes\">a note</a> appended."
                   pagenode)]
          [else ""]))
  
  (cond [(ormap non-empty-string? (list series-part disp-part notes-part))
         (string-join (list series-part disp-part notes-part))]
        [else ""]))

;; ~~~ Notes ~~~

(define (cache-notes! pagenode parent-title note-txprs)
  (query-exec cache-conn (delete (~> (from cache:note #:as n)
                                     (where (= n.page ,(symbol->string pagenode))))))
  (cond [(not (null? note-txprs))
         (define note-htmls
           (for/list ([n (in-list note-txprs)])
             (cache-note! n pagenode parent-title)))
         (html$-notes-section note-htmls)]
        [else ""]))

;; Save an individual note to the DB and return the HTML of the complete note as
;; it should appear on an individual article page
(define (cache-note! note-tx pagenode parent-title-plain)
  (define-values (_ attrs elems) (txexpr->values note-tx))
  (define disposition-attr (maybe-attr 'disposition attrs))
  (define note-date (maybe-attr 'date attrs))
  
  ;; Check required attributes
  (unless (non-empty-string? note-date)
    (raise-arguments-error 'note "required attr missing: date" "attrs" attrs))
  (unless (or (string=? "" disposition-attr)
              (>= (length (string-split disposition-attr)) 2))
    (raise-arguments-error 'note
                           "must be in format \"[symbol] [past-tense-verb]\""
                           "disposition attr"
                           disposition-attr))
  (define-values (disp-mark disp-verb) (disposition-values disposition-attr))
  (let* ([note-id (build-note-id note-tx)]
         [title-tx (make-note-title pagenode parent-title-plain)]
         [title-html (->html title-tx #:splice? #t)]
         [author (maybe-attr 'author attrs default-authorname)]
         [author-url (maybe-attr 'author-url attrs)]
         [content-html (html$-note-contents disp-mark disp-verb elems)])
    (insert-one! cache-conn
                 (make-cache:note
                  #:page pagenode
                  #:html-anchor note-id
                  #:title-html-flow title-html
                  #:title-plain (tx-strs title-tx)
                  #:published note-date
                  #:author author
                  #:author-url author-url
                  #:disposition disposition-attr
                  #:series-page (metas-series-pagenode)
                  #:content-html content-html
                  #:listing-full-html (html$-note-listing-full pagenode
                                                               note-id
                                                               title-html
                                                               note-date
                                                               content-html
                                                               author
                                                               author-url)
                  #:listing-excerpt-html ""
                  #:listing-short-html ""))
    (html$-note-in-article note-id note-date content-html author author-url)))

(define (make-note-title pagenode parent-title-plain)
  `(note-title "Re: " (a [[class "cross-reference"]
                          [href ,(format "~a~a" web-root pagenode)]]
                         ,parent-title-plain)))

;; ~~~ Keyword Index Entries ~~~

;; (private) Convert an entry key into a list of at most two elements,
;; a main entry and a sub-entry.
;;   "entry" → '("entry" "")
;;   "entry!sub" → '("entry" "sub")
;;   "entry!sub!why?!? '("entry" "sub")
(define (split-entry str)
  (define splits (string-split str "!"))
  (list (car splits)
        (cadr (append splits (list "")))))

(define (index-entry-txpr? tx)
  (and (txexpr? tx)
       (string=? "index-link" (attr-ref tx 'class "")) ; see definition of html-index
       (attr-ref tx 'data-index-entry #f)))

(define (txexpr->index-entry tx pagenode)
  (match (split-entry (attr-ref tx 'data-index-entry))
    [(list main sub)
     (make-cache:index-entry
      #:entry main
      #:subentry sub
      #:page pagenode
      #:html-anchor (attr-ref tx 'id))]))

;; Save any index entries in doc to the SQLite cache.
;; Sub-entries are specified by "!" in the index key
(define (cache-index-entries! pagenode doc)
  (define-values (_ entry-txs) (splitf-txexpr doc index-entry-txpr?))
  ; Naive idempotence: delete and re-insert all index entries every time doc is rendered.
  (query-exec cache-conn (delete (~> (from cache:index-entry #:as entry)
                                     (where (= entry.page ,(symbol->string pagenode))))))
  (unless (null? entry-txs)
    (void
     (apply insert! cache-conn
            (for/list ([etx (in-list entry-txs)])
              (txexpr->index-entry etx pagenode))))))

;;
;;  ~~~ Fetching articles and notes ~~~
;;

;; (Private use) Conveniece function for the WHERE `series-page` clause
(define (where-series q s)
  (define (s->p x) (format "~a/~a.html" series-folder x))
  (match s
    [(list series ...)
     (where q (in a.series-page ,(map s->p series)))] ; WHERE series-page IN (item1 ...)
    [(or (? string? series) (? symbol? series))
     (where q (= a.series-page ,(s->p series)))]      ; WHERE series-page = "item"
    [#t
     (where q (= a.series-page ,(path->string (here-output-path))))]
    [_ q]))

;; Needed to "parameterize" column names
;; see https://github.com/Bogdanp/deta/issues/14#issuecomment-573344928
(require (prefix-in ast: deta/private/ast))

;; Builds a query to fetch articles
(define (articles type #:series [s #t] #:limit [lim -1] #:order [ord 'desc])
  (define html-field (format "listing_~a_html" type))
  (~> (from cache:article #:as a)
      (select (fragment (ast:as (ast:qualified "a" html-field) "html"))
              a.published
              a.series-page)
      (where-series s)
      (limit ,lim)
      (order-by ([a.published ,ord]))
      (project-onto listing-schema)))

;; Builds a query that returns articles and notes intermingled chronologically
(define (articles+notes type #:series [s #t] #:limit [lim -1] #:order [ord 'desc])
  (define html-field (format "listing_~a_html" type))
  (~> (from (subquery
             (~> (from cache:article #:as A)
                 (select (fragment (ast:as (ast:qualified "A" html-field) "html"))
                         A.published
                         A.series-page)
                 (union
                  (~> (from cache:note #:as N)
                      (select (fragment (ast:as (ast:qualified "N" html-field) "html"))
                              N.published
                              N.series-page)))))
            #:as a)
      (where-series s)
      (limit ,lim)
      (order-by ([a.published ,ord]))
      (project-onto listing-schema)))

;; Get all the a list of the HTML all the results in a query
(define (listing-htmls list-query)
  (for/list ([l (in-entities cache-conn list-query)])
    (listing-html l)))

;; Return cached HTML of articles and/or notes, fenced within a style txexpr to prevent it being
;; escaped by ->html. See also: definition of `unfence`

;; E.g.: (<listing-full> articles+notes)
(define (<listing-full> query-func #:series [s #t] #:limit [lim -1] #:order [ord 'desc])
  `(style ,@(listing-htmls (query-func 'full #:series s #:limit lim #:order ord))))
;;                                     ^^^^^

(define (<listing-excerpt> query-func #:series [s #t] #:limit [lim -1] #:order [ord 'desc])
  `(style ,@(listing-htmls (query-func 'excerpt #:series s #:limit lim #:order ord))))
;;                                     ^^^^^^^^

(define (<listing-short> query-func #:series [s #t] #:limit [lim -1] #:order [ord 'desc])
  `(style "<ul class=\"article-list\">"
          ,@(listing-htmls (query-func 'short #:series s #:limit lim #:order ord))
          "</ul>")) ;;                 ^^^^^^

;; Remove "<style>" and "</style>" introduced by using ->html on docs containing output from
;; listing functions
(define (unfence html-str)
  (regexp-replace* #px"<[\\/]{0,1}style>" html-str ""))

;; Save the current article to the `series` table of the SQLite cache
;; Should be called from a template for series pages
(define (cache-series!)
  (define here-page (path->string (here-output-path)))
  (query-exec cache-conn
              (delete (~> (from cache:series #:as s)
                          (where (= s.page ,here-page)))))
  (void
   (insert-one! cache-conn
                (make-cache:series
                 #:page (string->symbol here-page)
                 #:title (hash-ref (current-metas) 'title)
                 #:published (hash-ref (current-metas) 'published "")
                 #:noun-plural (hash-ref (current-metas) 'noun-plural "")
                 #:noun-singular (hash-ref (current-metas) 'noun-singular "")))))