◊(Local Yarn Code "dust.rkt at [ac35ba69]")

File dust.rkt artifact aa082dfb part of check-in ac35ba69


#lang racket/base

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

(require pollen/core
         "series-list.rkt"
         pollen/pagetree
         pollen/setup
         pollen/file
         net/uri-codec
         threading
         file/sha1
         gregor
         txexpr
         racket/list
         racket/match
         racket/port
         racket/system
         racket/string)

;; Provides common helper functions used throughout the project

(provide maybe-meta     ; Select from (current-metas) or default value ("") if not available
         maybe-attr     ; Return an attribute’s value or a default ("") if not available
         here-output-path
         here-source-path
         here-id
         listing-context
         current-series-noun    ; Retrieve noun-singular from current 'series meta, or #f
         current-series-title   ; Retrieve title of series in current 'series meta, or #f
         current-series-pagenode
         invalidate-series
         checked-in?
         make-tag-predicate
         tx-strs
         ymd->english
         ymd->dateformat
         default-authorname
         default-title
         web-root
         articles-folder
         series-folder
         images-folder
         articles-pagetree
         series-pagetree
         first-words
         build-note-id
         notes->last-disposition-values
         disposition-values
         )

(define default-authorname "Joel Dueck")
(define series-folder "series")
(define articles-folder "articles")
(define images-folder "images")
(define web-root "/")

(define (default-title body-txprs)
  (format "“~a…”" (first-words body-txprs 5)))

(define (maybe-meta m [missing ""])
  (cond [(current-metas) (or (select-from-metas m (current-metas)) missing)]
        [else missing]))

;; Return the current source path, relative to (current-project-root)
(define (here-source-path)
  (match (current-metas)
    [(? hash? m)
     (define-values (_ rel-path-parts)
       (drop-common-prefix (explode-path (current-project-root))
                           (explode-path (string->path (hash-ref m 'here-path)))))
     (apply build-path rel-path-parts)]
    [_ (string->path ".")]))
         
;; Return the current output path, relative to (current-project-root)
;; Similar to the variable 'here' which is only accessible in Pollen templates,
;; except this is an actual path, not a string.
(define (here-output-path)
  (->output-path (here-source-path)))

(define listing-context (make-parameter ""))

;; Checks current-metas for a 'series meta and returns the pagenode of that series,
;; or '|| if no series is specified.
(define (current-series-pagenode)
  (or (and~> (current-metas)
             (hash-ref 'series #f)
             (format "~a/~a.html" series-folder _)
             ->pagenode)
      '||))

(define (current-series-noun)
  (or (and~> (current-metas)
             (hash-ref 'series #f)
             (hash-ref series-list _ #f)
             series-noun-singular)
      ""))

(define (current-series-title)
  (or (and~> (current-metas)
             (hash-ref 'series #f)
             (hash-ref series-list _ #f)
             series-title)
      ""))

(define article-ids (make-hash))

;; Generates a short ID for the current article
(define (here-id [suffix #f])
  (define maybe-hash (hash-ref article-ids (here-output-path) #f))
  (define here-hash
    (cond
      [(not maybe-hash)
       (let ([h (substring (bytes->hex-string (sha1-bytes (path->bytes (here-output-path)))) 0 8)])
         (hash-set! article-ids (here-output-path) h)
         h)]
      [else maybe-hash]))
  (cond [(list? suffix) (apply string-append here-hash suffix)]
        [(string? suffix) (string-append here-hash suffix)]
        [else here-hash]))

;; “Touches” the last-modified date on the current article’s series, if there is one

(define (invalidate-series)
  (define series-name (maybe-meta 'series #f))
  (when series-name
    (define series-file (build-path (current-project-root)
                                    series-folder
                                    (format "~a.poly.pm" series-name)))
    (when (file-exists? series-file)
      (case (system-type 'os)
        [(windows) (system (format "type nul >> ~a" series-file))]
        [else (system (format "touch ~a" series-file))]))))

;; Determine if the current article has been checked into Fossil repo
(define (checked-in?)
  (cond [(current-metas)
         (define articles-path (build-path (current-project-root) articles-folder))
         (define checked-in
           (with-output-to-string
             (lambda () (system (format "/usr/local/bin/fossil ls ~a" articles-path)))))
         (string-contains? checked-in (path->string (here-source-path)))]
        [else #f]))

;; ~~~ Project-wide Pagetrees ~~~

(define (include-in-pagetree folder extension)
  (define (matching-file? f)
    (string-suffix? f extension))
  (define (file->output-pagenode f)
    (string->symbol (format "~a/~a" folder (string-replace f extension ".html"))))
  (define folder-path (build-path (current-project-root) folder))
  (define file-strs (map path->string (directory-list folder-path)))
  (map file->output-pagenode (filter matching-file? file-strs)))

(define (articles-pagetree)
  `(root ,@(include-in-pagetree articles-folder ".poly.pm")))

(define (series-pagetree)
  `(root ,@(include-in-pagetree series-folder ".poly.pm")))

;; ~~~ Convenience functions for tagged x-expressions ~~~

(define (maybe-attr name attrs [missing ""])
  (define result (assoc name attrs))
  (cond
    [(pair? result) (cadr result)]
    [else missing]))

;; Returns a function will test if a txexpr's tag matches the given symbol.
(define (make-tag-predicate . tagsyms)
  (lambda (tx) (if (and (txexpr? tx) (member (get-tag tx) tagsyms)) #t #f)))

(define (tx-strs xpr)
  (cond
    [(txexpr? xpr) (apply string-append (map tx-strs (get-elements xpr)))]
    [(string? xpr) xpr]
    [else ""]))

(module+ test
  (require rackunit)
  (define test-metas (hash 'name "Fiver" 'size "Small"))
  (define test-attrs '([name "Hazel"] [rank "Chief"]))

  (parameterize ([current-metas test-metas])
    (check-equal? (maybe-meta 'name) "Fiver") ; present meta
    (check-equal? (maybe-meta 'age) "")       ; missing meta
    (check-equal? (maybe-meta 'age 2) 2))      ; alternate default value
  
  (check-equal? (maybe-attr 'rank test-attrs) "Chief")
  (check-equal? (maybe-attr 'dingus test-attrs) "")
  (check-equal? (maybe-attr 'dingus test-attrs "zippy") "zippy"))

;; Return the first N words out of a list of txexprs. This function will unpack the strings out of
;; the elements of one txexpr at a time until it finds the requested number of words. It aims to be
;; both reliable and fast for any size of list you pass it, and smart about the punctuation it
;; allows through.
(define (first-words txprs words-needed)
  (define punc-allowed-in-word '(#\- #\' #\% #\$ #\‘ #\’ #\# #\& #\/ #\. #\!))
  
  (define (word-boundary? c) (or (char-whitespace? c) (equal? c #\null) (eof-object? c)))
  (define (word-char? c) (or (char-alphabetic? c) (char-numeric? c)))
  
  (define in (open-input-string (tx-strs (first txprs))))
  (define out (open-output-string))
  
  (define words-found
    (let loop ([words-found 0] [last-c #\null] [last-c-in-word? #f])
      (define c (read-char in))

      (cond [(equal? words-found words-needed) words-found]
            [(eof-object? c)
             (cond [(positive? words-found) (if last-c-in-word? (+ 1 words-found) words-found)]
                   [else 0])]
            [else
             (define-values (write-this-char? new-word-count c-in-word?)
               (cond
                 ;; Spaces increment the word count if the previous character was part of,
                 ;; or adjacent to, a word
                 [(and (char-whitespace? c) last-c-in-word?)
                  (values (if (equal? words-needed (+ 1 words-found)) #f #t) (+ 1 words-found) #f)]
                 ;; Some punctuation survives if the previous or next char is part of a word
                 [(member c punc-allowed-in-word)
                  (cond [(or (word-char? last-c) (word-char? (peek-char in)))
                         (values #t words-found #t)]
                        [else (values #f words-found #f)])]
                 [(word-char? c)
                  (values #t words-found #t)]
                 ;; If c is a non-whitespace non-allowed character that immediately follows a word,
                 ;; do not write it out but count it as being part of the word.   
                 [(and (not (word-char? c)) (not (char-whitespace? c)) last-c-in-word?)
                  (values #f words-found #t)]
                 [else (values #f words-found #f)]))

             (cond [write-this-char? (write-char c out)])
             (loop new-word-count c c-in-word?)])))
  
  (define words (get-output-string out))
  (cond [(equal? words-found words-needed) words]
        [(equal? '() (rest txprs)) words]
        [else (string-append words " " (first-words (rest txprs) (- words-needed words-found)))]))

(module+ test
  (require rackunit)
  (define txs-decimals
    '((p "Four score and 7.8 years ago — our fathers brought forth on this continent etc etc")))
  (define txs-punc+split-elems
    '((p "“Stop!” she called.") (p "(She was never one to be silent.)")))
  (define txs-dashes
    '((p [[class "newthought"]] (span [[class "smallcaps"]] "One - and") " only one.")
      (p "That was all she would allow.")))
  (define txs-parens-commas
    '((p "She counted (" (em "one, two") "— silently, eyes unblinking")))
  (define txs-short
    '((span "Not much here!")))

  (check-equal? (first-words txs-decimals 5) "Four score and 7.8 years")
  (check-equal? (first-words txs-punc+split-elems 5) "Stop! she called. She was")
  (check-equal? (first-words txs-dashes 5) "One and only one. That")
  (check-equal? (first-words txs-dashes 4) "One and only one.")
  (check-equal? (first-words txs-parens-commas 5) "She counted one two silently")
  (check-equal? (first-words txs-short 5) "Not much here!"))
                
;; Convert, e.g., "* thoroughly recanted" into (values "*" "thoroughly recanted")
(define (disposition-values str)
  (cond [(string=? "" str) (values "" "")]
        [else (let ([splut (string-split str)])
                (values (car splut) (string-join (cdr splut))))]))

;; The format of a note’s ID is “HTML-driven” (used as an anchor link)
(define (build-note-id txpr)
  (string-append (maybe-attr 'date (get-attrs txpr))
                 "_"
                 (uri-encode (maybe-attr 'author (get-attrs txpr) default-authorname))))

;; Extract the last disposition (if any), and the ID of the disposing note, out of a list of notes
(define (notes->last-disposition-values txprs)
  (define (contains-disposition? tx) (attrs-have-key? tx 'disposition))
  (define disp-notes (filter contains-disposition? txprs))
  (cond [(not (empty? disp-notes))
         (define latest-disposition-note (last disp-notes))
         (values (attr-ref latest-disposition-note 'disposition)
                 (build-note-id latest-disposition-note))]
        [else (values "" "")]))
        
;; ~~~ Convenience functions for YYYY-MM-DD date strings ~~~

;; These functions ignore everything after the first space in the input!
(define (ymd->dateformat ymd-string dateformat)
  (~t (iso8601->date (car (string-split ymd-string))) dateformat))

(define (ymd->english ymd-string)
  (ymd->dateformat ymd-string "MMMM d, yyyy"))

(module+ test
  (check-equal? (ymd->english "2018-08-12") "August 12, 2018")
  (check-equal? (ymd->dateformat "2018-08-12" "d MMM YYYY") "12 Aug 2018")

  ;; How we handle weird input
  (check-equal? (ymd->english "2018-08-12 everything after 1st space ignored") "August 12, 2018")
  (check-equal? (ymd->english "2018-08 omitting the day") "August 1, 2018")
  (check-equal? (ymd->english "2018 omitting month and day") "January 1, 2018")
  (check-equal? (ymd->dateformat "2018-08-12" "123") "123")

  ;; Stuff we just don't handle
  (check-exn exn:gregor:parse? (lambda () (ymd->english "2018-xyz"))))