#lang racket/base ;; Copyright (c) 2018 Joel Dueck. ;; ;; Licensed under the Apache License, Version 2.0 (the "License"); ;; you may not use this file except in compliance with the License. ;; A copy of the License is included with this source code, in the ;; file "LICENSE.txt". ;; You may also obtain a copy of the License at ;; ;; http://www.apache.org/licenses/LICENSE-2.0 ;; ;; Unless required by applicable law or agreed to in writing, software ;; distributed under the License is distributed on an "AS IS" BASIS, ;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;; See the License for the specific language governing permissions and ;; limitations under the License. ;; ;; Author contact information: ;; joel@jdueck.net ;; https://joeldueck.com ;; ------------------------------------------------------------------------- (require pollen/core pollen/pagetree pollen/setup net/uri-codec gregor txexpr racket/list 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 series-noun ; Retrieve noun-singular from current 'series meta, or "" series-title ; Retrieve title of series in current 'series meta, or "" attr-present? ; Test if an attribute is present tx-strs ymd->english ymd->dateformat default-authorname default-title articles-path series-path articles-pagetree series-pagetree first-words build-note-id notes->last-disposition-values disposition-values ) (define default-authorname "Joel Dueck") (define series-path "series") (define articles-path "articles") (define (default-title date) (format "Entry of ~a" (ymd->dateformat date "d MMM YYYY"))) (define (maybe-meta m [missing ""]) (or (select-from-metas m (current-metas)) missing)) ;; Checks current-metas for a 'series meta and returns the pagenode of that series, ;; or '|| if no series is specified. (define (series-pagenode) (define maybe-series (or (select-from-metas 'series (current-metas)) "")) (cond [(non-empty-string? maybe-series) (->pagenode (format "~a/~a.html" series-path maybe-series))] [else '||])) (define (series-noun) (define series-pnode (series-pagenode)) (case series-pnode ['|| ""] ; no series specified [else (or (select-from-metas 'noun-singular series-pnode) "")])) (define (series-title) (define series-pnode (series-pagenode)) (case series-pnode ['|| ""] ; no series specified [else (or (select-from-metas 'title series-pnode) "")])) ;; ~~~ 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-path ".poly.pm"))) (define (series-pagetree) `(root ,@(include-in-pagetree series-path ".poly.pm"))) ;; ~~~ Convenience functions for tagged x-expressions ~~~ (define (attr-present? name attrs) (for/or ([attr-pair (in-list attrs)]) (equal? name (car attr-pair)))) (define (maybe-attr name attrs [missing ""]) (define result (assoc name attrs)) (cond [(pair? result) (cadr result)] [else missing])) (define (tx-strs xpr) (cond [(txexpr? xpr) (apply string-append (map tx-strs (get-elements xpr)))] [(string? xpr) xpr] [else ""])) (define (first-words str n) (define trunc (apply string-append (add-between (take (string-split str) n) " "))) ;; Remove trailing punctuation (commas, etc.) (regexp-replace #px"\\W+$" trunc "")) (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? (attr-present? 'name test-attrs) #t) (check-equal? (attr-present? 'dingus test-attrs) #f) (check-equal? (maybe-attr 'rank test-attrs) "Chief") (check-equal? (maybe-attr 'dingus test-attrs) "") (check-equal? (maybe-attr 'dingus test-attrs "zippy") "zippy")) ;; 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) but is included ;; here since it also serves as a primary key in the DB. (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) (attr-present? 'disposition (get-attrs tx))) (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"))))