◊(Local Yarn Code "tools.rkt at [cf83a366]")

File yarn-lib/tools.rkt artifact b56e0b6a part of check-in cf83a366


#lang racket/base

(require file/sha1
         pollen/core
         racket/file
         racket/list
         racket/string
         threading
         txexpr)

(provide (all-defined-out))

;; Convert a string into all lowercase, delete all non-alphanum chars, replace spaces with ‘-’
(define (normalize-key str)
  (~> (string-downcase str)
      (regexp-replace #rx"ies$" _ "y")
      (string-trim "s" #:left? #f)
      (regexp-replace* #rx"[^A-Za-z0-9 ]" _ "")
      (string-normalize-spaces #px"\\s+" "-")))

;; ~~ Metas reference and updating ~~~~~~~~~~~~~~~

;; Computes a unique string key for the current Pollen source and stashes it in the metas
(define (here-key [suffix ""])
  (define metas (current-metas))
  (define (set-here-key!)
    (set-meta 'here-key
              (~> (hash-ref metas 'here-path)
                  string->bytes/utf-8
                  sha1-bytes
                  bytes->hex-string
                  (substring 0 8))))
  (string-append (hash-ref metas 'here-key set-here-key!) suffix))

;;
;; Meta tools ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

(define (meta-set? key)
  (and (hash-ref (current-metas) key #f) #t))

(define (set-meta key val)
  (current-metas (hash-set (current-metas) key val))
  val)

(define (update-meta key proc default)
  (let ([updated (proc (hash-ref (current-metas) key default))])
    (set-meta key updated)))

(define (cons-to-metas-list key val)
  (define consed (cons val (hash-ref (current-metas) key '())))
  (current-metas (hash-set (current-metas) key consed))
  consed)

(define (update-metas-subhash key subkey val [proc (λ (v) v)])
  (define metas (current-metas))
  (define subhash (hash-ref metas key hasheq))
  (set-meta key (hash-set subhash subkey (proc val))))

(define (get-metas-subhash key subkey)
  (hash-ref (hash-ref (current-metas) key #hasheq()) subkey #f))

;; Returns a function will test if a txexpr's tag matches the given symbol and
;; (optionally) contains all given attributes.
(define (tx-is? t #:has-attrs [a '()])
  (define tags (if (list? t) t (list t)))
  (define attrs (if (list? a) a (list a)))
  (lambda (v)
    (and (txexpr? v)
         (member (get-tag v) tags)
         (andmap (λ (attr) (attrs-have-key? a attr)) attrs)
         #t)))

;; “Notes”, in addition to being attached to/contained in articles, are also
;; shown alongside articles in the chronological feed. To make building this
;; mixed chronological feed faster, articles and notes create files in a
;; “serialize” subfolder at compile time:
;;   * The filenames are prefixed with the thing’s YMD date.
;;   * Note-files contain a datum of the entire note.
;;   * Article-files contain only the path to the article’s source.
;; 
;; This way building the chrono feed is simple and doesn’t require loading
;; and sorting the docs/metas of the entire article set.

(define serialize-folder "compiled/.serialized")

(define (current-serialize-folder-path)
  (and~> (hash-ref (current-metas) 'here-path #f)
         explode-path
         (drop-right 1)
         (append (list serialize-folder))
         (apply build-path _)))

;; 
;; TODO: Possible speed gains by spawning a thread to do this
(define (serialize-article-placeholder)
  (let* ([ser-folder (current-serialize-folder-path)]
         [filename (format "~a.article" (hash-ref (current-metas) 'published))]
         [placeholder (build-path ser-folder filename)])
    (unless (directory-exists? ser-folder) (make-directory ser-folder))
    (unless (file-exists? placeholder)
      (write-to-file (hash-ref (current-metas) 'here-path)
                     (build-path ser-folder filename)
                     #:exists 'truncate))))

(define (serialize-note note num)
  (let ([ser-folder (current-serialize-folder-path)]
        [filename (format "~a_~a.note" (attr-ref note 'date) num)])
    (unless (directory-exists? ser-folder) (make-directory ser-folder))
    (write-to-file note (build-path ser-folder filename) #:exists 'truncate)))