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

File crystalize.rkt artifact 7c40c653 part of check-in aaa8d600


#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
         threading
         racket/match
         racket/string
         txexpr
         pollen/template
         pollen/decode
         (except-in pollen/core select) ; avoid conflict with deta
         )

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

(provide main
         cache-index-entries-only!)

(define current-title       (make-parameter #f))
(define current-excerpt     (make-parameter #f))
(define current-notes       (make-parameter '()))
(define current-disposition (make-parameter ""))
(define current-disp-id     (make-parameter ""))

;; Rebuild the SQLite cache with all article entities
(define (main)
  (define pages (cdr (articles-pagetree)))
  (define (getter-thunk)
    (define parent (thread-receive))
    (define article (thread-receive))
    (thread-send parent (all-entities article (get-doc article))))
  
  (for ([p (in-list pages)])
    (let ([t (thread getter-thunk)])
      (thread-send t (current-thread))
      (thread-send t p)))

  (define entities
    (time
      (for/vector ([i (in-range (length pages))])
                  (thread-receive))))

   (time (call-with-transaction
    (cache-conn)
    (lambda ()
      (init-cache-db! #:reset? #t)
      (for ([x (in-vector entities)])
        (for ([e (in-list x)])
          (insert-one! (cache-conn) e)))))))

(define (filter-special-tags tx)
  (match (get-tag tx)
    ['title (current-title tx) ""]
    ['excerpt (current-excerpt tx) ""]
    ['excerpt* (current-excerpt tx) `(@ ,@(get-elements tx))] ; splice contents back in
    ['note
     (define note-id (build-note-id tx))
     (cond [(attrs-have-key? tx 'disposition)
            (current-disp-id note-id)
            (current-disposition (attr-ref tx 'disposition))])
     (current-notes (cons (attr-set tx 'note-id note-id) (current-notes))) ""]
    [_ tx]))

;; From an article, return a list of cache:article, cache:note and cache:index-entry entities
(define (all-entities pagenode doc)
  ;; Reset parameters in case we’re doing multiple articles
  (current-title #f)
  (current-excerpt #f)
  (current-notes '())
  (current-disposition "")
  (current-disp-id "")
  (current-metas (get-metas pagenode))
  
  (define body-txpr (decode doc #:txexpr-proc filter-special-tags))
  (current-notes (reverse (current-notes)))
  (let* ([pubdate (select-from-metas 'published (current-metas))]
         [doc-html    (->html body-txpr #:splice? #t)]
         [title-specified? (if (current-title) #t #f)]
         [title-val   (or (current-title) (check-for-poem-title doc))]
         [title-tx    (make-article-title pagenode
                                          title-val
                                          body-txpr
                                          (current-disposition)
                                          (current-disp-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 (current-series-pagenode)]
         [footertext  (make-article-footertext pagenode
                                               series-node
                                               (current-disposition)
                                               (current-disp-id)
                                               (length (current-notes)))]
         [footer (html$-article-close footertext)]
         [listing-short (html$-article-listing-short pagenode pubdate title-html)]
         [listing-full (string-append header doc-html footer)]
         [listing-excerpt (match (current-excerpt)
                            [#f listing-full]
                            [(var e) (string-append header (html$-article-excerpt pagenode e) footer)])]
         [notes (extract-notes pagenode title-plain (current-notes))]
         [index-entries (extract-index-entries pagenode doc)])
    (append
     (cons (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 (current-series-noun))
            #:note-count (length (current-notes))
            #:content-html doc-html
            #:disposition (current-disposition)
            #:disp-html-anchor (current-disp-id)
            #:listing-full-html listing-full
            #:listing-excerpt-html listing-excerpt
            #:listing-short-html listing-short)
           notes)
     index-entries)))

(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 (current-series-title)
      [(? non-empty-string? s-title)
       (format "<span class=\"series-part\">This is ~a, part of <a href=\"/~a\">‘~a’</a>.</span>"
               (current-series-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 (extract-notes pagenode parent-title note-txprs)
  (for/list ([n (in-list note-txprs)])
    (make-note n pagenode parent-title)))

;; Create cache:note entity
(define (make-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)]
         [note-srcline (maybe-attr 'srcline attrs)]
         [content-html (html$-note-contents disp-mark disp-verb elems)]
         [listing-full (html$-note-listing-full pagenode
                                                note-id
                                                title-html
                                                note-date
                                                note-srcline
                                                content-html
                                                author
                                                author-url)])
    (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 (current-series-pagenode)
     #:conceal (or (maybe-attr 'conceal attrs #f) (maybe-meta 'conceal))
     #:content-html content-html
     #:listing-full-html listing-full
     #:listing-excerpt-html listing-full
     #:listing-short-html "")))

(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))]))

;; Get index entries out of metas
(define (current-metas-keyword-entries pagenode)
  (for/list ([kw (in-list (string-split (maybe-meta 'keywords "") #px";\\s*"))])
    (match (split-entry kw)
      [(list main sub)
       (make-cache:index-entry
        #:entry main
        #:subentry sub
        #:page pagenode
        #:html-anchor "")])))

;; Build a list of cache:index-entry entities for all entries in the docs or current metas
;; Sub-entries are specified by "!" in the index key
(define (extract-index-entries pagenode doc)
  (define-values (_ entry-txs) (splitf-txexpr doc index-entry-txpr?))
  (append (for/list ([etx (in-list entry-txs)]) (txexpr->index-entry etx pagenode))
          (current-metas-keyword-entries pagenode)))

(define (cache-index-entries-only! title pagenode doc)
  (void
   (thread
    (lambda ()
      (call-with-transaction
       (cache-conn)
       (lambda ()
         (delete-index-entries! pagenode)
         (delete-article! pagenode)
         (apply insert! (cache-conn)
                (make-cache:article
                 #:title-plain title
                 #:conceal "blog,feed"
                 #:page pagenode)
                (extract-index-entries pagenode doc))))))))