@@ -22,57 +22,74 @@ ;; ------------------------------------------------------------------------- (require pollen/core pollen/pagetree pollen/setup + pollen/file net/uri-codec + file/sha1 gregor txexpr racket/list + 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-id series-noun ; Retrieve noun-singular from current 'series meta, or "" series-title ; Retrieve title of series in current 'series meta, or "" series-pagenode - attr-present? ; Test if an attribute is present + invalidate-series make-tag-predicate tx-strs ymd->english ymd->dateformat default-authorname default-title - articles-path - series-path + articles-folder + series-folder 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 series-folder "series") +(define articles-folder "articles") (define (default-title body-txprs) (format "“~a…”" (first-words body-txprs 5))) (define (maybe-meta m [missing ""]) - (or (select-from-metas m (current-metas)) missing)) + (cond [(current-metas) (or (select-from-metas m (current-metas)) missing)] + [else missing])) + +;; 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) + (cond [(current-metas) + (define-values (_ rel-path-parts) + (drop-common-prefix (explode-path (current-project-root)) + (explode-path (string->path (select-from-metas 'here-path (current-metas)))))) + (->output-path (apply build-path rel-path-parts))] + [else (error "No metas are available")])) ;; 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))] + (->pagenode (format "~a/~a.html" series-folder maybe-series))] [else '||])) (define (series-noun) (define series-pnode (series-pagenode)) (case series-pnode @@ -83,10 +100,31 @@ (define series-pnode (series-pagenode)) (case series-pnode ['|| ""] ; no series specified [else (or (select-from-metas 'title series-pnode) "")])) +;; Generates a short ID for the current article +(define (here-id [suffix #f]) + (define here-hash + (substring (bytes->hex-string (sha1-bytes (path->bytes (here-output-path)))) 0 8)) + (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))])))) + ;; ~~~ Project-wide Pagetrees ~~~ (define (include-in-pagetree folder extension) (define (matching-file? f) (string-suffix? f extension)) @@ -95,21 +133,17 @@ (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"))) + `(root ,@(include-in-pagetree articles-folder ".poly.pm"))) (define (series-pagetree) - `(root ,@(include-in-pagetree series-path ".poly.pm"))) + `(root ,@(include-in-pagetree series-folder ".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])) @@ -132,12 +166,10 @@ (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")) ;; Return the first N words out of a list of txexprs. This function will unpack the strings out of @@ -223,11 +255,11 @@ "_" (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 (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))]