#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"))))
