post: Add read-metadata-headers procedure.

* haunt/post.scm (read-metadata-headers): New procedure.
* haunt/reader.scm (read-html-post): Reimplement using
  'read-metadata-headers'.
* tests/post.scm (%tzoffset): New variable.
  ("read-metadata-headers"): New test.
This commit is contained in:
David Thompson 2015-10-15 22:46:30 -04:00
parent e505a66a1b
commit dfad89079b
3 changed files with 35 additions and 17 deletions

View File

@ -23,6 +23,8 @@
;;; Code: ;;; Code:
(define-module (haunt post) (define-module (haunt post)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-19) #:use-module (srfi srfi-19)
@ -40,7 +42,8 @@
posts/group-by-tag posts/group-by-tag
register-metdata-parser! register-metdata-parser!
parse-metadata)) parse-metadata
read-metadata-headers))
(define-record-type <post> (define-record-type <post>
(make-post file-name metadata sxml) (make-post file-name metadata sxml)
@ -107,6 +110,20 @@ specified."
(define (parse-metadata key value) (define (parse-metadata key value)
((metadata-parser key) value)) ((metadata-parser key) value))
(define (read-metadata-headers port)
(let loop ((metadata '()))
(let ((line (read-line port)))
(cond
((eof-object? line)
(error "end of file while reading metadata: " (port-filename port)))
((string=? line "---")
metadata)
(else
(match (map string-trim-both (string-split-at line #\:))
(((= string->symbol key) value)
(loop (alist-cons key (parse-metadata key value) metadata)))
(_ (error "invalid metadata format: " line))))))))
(register-metadata-parser! (register-metadata-parser!
'tags 'tags
(lambda (str) (lambda (str)

View File

@ -30,7 +30,6 @@
#:use-module (ice-9 ftw) #:use-module (ice-9 ftw)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 regex) #:use-module (ice-9 regex)
#:use-module (ice-9 rdelim)
#:use-module (sxml simple) #:use-module (sxml simple)
#:use-module (haunt post) #:use-module (haunt post)
#:use-module (haunt utils) #:use-module (haunt utils)
@ -105,20 +104,9 @@ post."
(assq-ref contents 'content)))))) (assq-ref contents 'content))))))
(define (read-html-post port) (define (read-html-post port)
(let loop ((metadata '())) (values (read-metadata-headers port)
(let ((line (read-line port))) (match (xml->sxml port)
(cond (('*TOP* sxml) sxml))))
((eof-object? line)
(error "end of file while reading metadata: " (port-filename port)))
((string=? line "---")
(values metadata
(match (xml->sxml port)
(('*TOP* sxml) sxml))))
(else
(match (map string-trim-both (string-split-at line #\:))
(((= string->symbol key) value)
(loop (alist-cons key (parse-metadata key value) metadata)))
(_ (error "invalid metadata format: " line))))))))
(define html-reader (define html-reader
(make-reader (make-file-extension-matcher "html") (make-reader (make-file-extension-matcher "html")

View File

@ -26,6 +26,8 @@
(define (make-date* year month day) (define (make-date* year month day)
(make-date 0 0 0 0 day month year 0)) (make-date 0 0 0 0 day month year 0))
(define %tzoffset (date-zone-offset (current-date)))
(test-equal "post-ref" (test-equal "post-ref"
'(hello test) '(hello test)
(post-ref (make-post "foo.skr" '((tags hello test)) '()) 'tags)) (post-ref (make-post "foo.skr" '((tags hello test)) '()) 'tags))
@ -62,9 +64,20 @@
(parse-metadata 'tags "foo, bar, baz")) (parse-metadata 'tags "foo, bar, baz"))
(test-equal "parse-metadata, date" (test-equal "parse-metadata, date"
(make-date 0 0 30 22 15 10 2015 (date-zone-offset (current-date))) (make-date 0 0 30 22 15 10 2015 %tzoffset)
(parse-metadata 'date "2015-10-15 22:30")) (parse-metadata 'date "2015-10-15 22:30"))
(test-equal "read-metadata-headers"
`((tags "foo" "bar" "baz")
(date . ,(make-date 0 0 30 22 15 10 2015 %tzoffset))
(title . "Hello, World!"))
(pk 'meta (call-with-input-string "title: Hello, World!
date: 2015-10-15 22:30
tags: foo, bar, baz
---
"
read-metadata-headers)))
(test-end) (test-end)