dustycloud/convert-content.scm

(use-modules (srfi srfi-1)
             (ice-9 ftw)
             (ice-9 match)
             (ice-9 popen)
             (ice-9 rdelim)
             (ice-9 textual-ports)
             (htmlprag))


;;; general stuff
;;; =============

(define (get-filenames)
  (map car (cddr (file-system-tree "content"))))

(define (filename-extension fname)
  (last (string-split fname #\.)))

(define (write-metadata metadata op)
  (for-each (match-lambda
              ;; fix up my name where need be
              (('author . val)
               (display "author: Christine Lemmer-Webber\n" op))
              ((key . val)
               (format op "~a: ~a\n" key val)))
            metadata)
  (display "---\n" op))


(define (maybe-append-slug metadata default-slug)
  (if (assoc 'slug metadata)
      metadata
      (append metadata `((slug . ,default-slug)))))

(define (get-stripped-line ip)
  (string-trim-both (get-line ip) char-set:whitespace))

;;; rst stuff
;;; =========

(define (make-convert-rst output-format)
  (define (convert-rst default-slug ip op)
    (define metadata
      (maybe-append-slug (read-rst-metadata ip)
                         default-slug))
    (write-metadata metadata op)
    (pandocify-rst ip op output-format))
  convert-rst)

(define convert-rst->md
  (make-convert-rst "markdown-smart"))

(define convert-rst->html
  (make-convert-rst "html"))

(define (read-rst-metadata ip)
  (define title #f)
  (define rest-metadata #f)
  (set! title (get-stripped-line ip))
  (when (string-match "^[=-~]+$" title)
    (set! title (get-stripped-line ip)))
  (get-line ip)
  (get-line ip)
  (set! rest-metadata
        (let lp ()
          (let ((line (get-stripped-line ip)))
            (if (equal? line "")
                '()
                (let ((colon-pos (string-index line #\: 1)))
                  (if colon-pos
                      (let* ((key-str (substring line 1 colon-pos))
                             (key (string->symbol (string-downcase key-str)))
                             (val (substring line (+ colon-pos 2))))
                        (cons (cons key val)
                              (lp)))
                      '()))))))
  (cons (cons 'title title)
        rest-metadata))

(define (pandocify-rst ip op out-format)
  (define tmpfile (tmpnam))
  (define pipe
    (open-pipe (format #f "pandoc -f rst -t ~a -o ~a"
                       out-format tmpfile)
               OPEN_WRITE))
  (display (get-string-all ip) pipe)
  (close-pipe pipe)
  (let ((converted (call-with-input-file tmpfile get-string-all)))
    (display converted op)
    (delete-file tmpfile)))



;;; html stuff
;;; ==========

(define (html-head->metadata head)
  (let lp ((head head))
    (match head
      ('() '())
      ((('title title) rest ...)
       (cons (cons 'title title)
             (lp rest)))
      ((('meta ('@ tags ...)) rest ...)
       (let* ((key (string->symbol (string-downcase (cadr (assoc 'name tags)))))
              (val (cadr (assoc 'contents tags))))
         (cons (cons key val)
               (lp rest))))
      ((_ rest ...)
       (lp rest)))))

(define (convert-html default-slug ip op)
  (define-values (head body)
    (get-html-head-body (html->sxml ip)))
  (define new-metadata
    (maybe-append-slug (html-head->metadata head)
                       default-slug))
  (write-metadata new-metadata op)
  (display (sxml->html body) op))

(define (get-html-head-body post-html)
  (let* ((html-data
          (match post-html
            (('*TOP* (html html-data ...) _ ...)
             html-data)))
         (head 
          (find (match-lambda 
                  (('head _ ...) #t)
                  (_ #f))
                html-data))
         (body
          (find (match-lambda 
                  (('body _ ...) #t)
                  (_ #f))
                html-data)))
    (values head body)))


;;; markdown stuff
;;; ==============

(define (convert-md default-slug ip op)
  (define new-metadata
    (maybe-append-slug (read-md-metadata ip)
                       default-slug))
  (write-metadata new-metadata op)
  (newline op)
  (display (get-string-all ip) op))

(define (read-md-metadata ip)
  (let lp ()
    (define line
      (get-stripped-line ip))
    (define colon-pos
      (string-index line #\:))
    (if colon-pos
        (let* ((key-str (substring line 0 colon-pos))
               (key (string->symbol (string-downcase key-str)))
               (val (string-trim-both (substring line (+ colon-pos 1)) char-set:whitespace)))
          (cons (cons key val)
                (lp)))
        '())))


;;; conversion stuff
;;; ================

;; Returns two values to its continuation: build-output and new-filename
(define* (decide-file-conversion fname #:key rst->md?)
  (match (filename-extension fname)
    ("rst"
     (values (if rst->md?
                 convert-rst->md
                 convert-rst->html)
             (string-append (car (string-split fname #\.))
                            (if rst->md? ".md" ".html"))))
    ("html"
     (values convert-html fname))
    ("md"
     (values convert-md fname))))

(define* (convert-one fname #:key rst->md?)
  (define-values (converter new-fname)
    (decide-file-conversion fname #:rst->md? rst->md?))
  (define default-slug (car (string-split fname #\.)))
  (call-with-input-file (string-append "content/" fname)
    (lambda (ip)
      (call-with-output-file (string-append "posts/" new-fname)
        (lambda (op)
          (converter default-slug ip op))))))