Fix description metadata for post pages.

2 files changed, 25 insertions, 2 deletions

diff --git a/haunt/jakob/builder/blog.scm b/haunt/jakob/builder/blog.scm
index 84a687e..d286f13 100644
--- a/haunt/jakob/builder/blog.scm
+++ b/haunt/jakob/builder/blog.scm
@@ -117,7 +117,7 @@
   "Return a Haunt page for POST."
   (make-page (post-uri post)
              (theme #:title (post-ref post 'title)
-                    #:description (first-paragraph post)
+                    #:description (description-from-post post)
                     #:keywords (post-ref post 'tags)
                     #:content (render-article post))
              sxml->html))
diff --git a/haunt/jakob/utils.scm b/haunt/jakob/utils.scm
index 2036503..3f51d60 100644
--- a/haunt/jakob/utils.scm
+++ b/haunt/jakob/utils.scm
@@ -22,7 +22,8 @@
             maybe-list
             date->string*
             intersperse
-            first-paragraph))
+            first-paragraph
+            description-from-post))
 
 (define (maybe-list . args)
   "Create a list of all ARGS that are neither #f nor unspecified."
@@ -67,3 +68,25 @@ is of an odd length and every second element is DELIM."
       ((head . tail)
        (loop tail (cons head result))))))
 
+(define (description-from-post post)
+  (define (first-elem sxml)
+    (if (and (list? sxml) (positive? (length sxml)))
+        (if (symbol? (first sxml))
+            sxml
+            (let ((reduced (remove null? (map first-elem sxml))))
+              (if (positive? (length reduced))
+                  (first reduced)
+                  '())))
+        '()))
+  (define (collect-strings elt res)
+    (cond ((null? elt) res)
+          ((string? (car elt)) (collect-strings (cdr elt) (cons (car elt) res)))
+          ((list? (car elt)) (if (and (positive? (length (car elt)))
+                                      (not (eq? '@ (caar elt))))
+                                 (let ((nested (collect-strings (car elt) (list))))
+                                   (collect-strings (cdr elt) (append nested res)))
+                                 (collect-strings (cdr elt) res)))
+          (else (collect-strings (cdr elt) res))))
+  (let* ((sxml (first-paragraph post))
+         (extracted (collect-strings (first-elem sxml) (list))))
+    (string-join (map string-trim-both (reverse extracted)) " ")))