Add Atom/RSS feed generation

lexi-lambda · lexi-lambda · commit 0aec8ae9058f · 2021-07-16T21:13:50.000-05:00
diff --git a/blog/build.rkt b/blog/build.rkt
@@ -20,6 +20,7 @@
          "paths.rkt"
          "build/metadata.rkt"
          "build/render/scribble.rkt"
+         "build/render/feed.rkt"
          "build/render/page.rkt")
 
 (define num-posts-per-page 10)
@@ -89,6 +90,10 @@
   (display "<!doctype html>" out)
   (write-xexpr xexpr out))
 
+(define (write-xml xexpr out)
+  (display "<?xml version=\"1.0\" encoding=\"utf-8\"?>" out)
+  (write-xexpr xexpr out))
+
 (define (build-post-body dep)
   (define src-mod-time (file-or-directory-modify-seconds (post-dep-src-path dep) #f (λ () #f)))
   (define info-mod-time (file-or-directory-modify-seconds (post-dep-info-path dep) #f (λ () #f)))
@@ -132,47 +137,55 @@
                           out-path
                           (λ~>> (write-html (post-page info)))))
 
-(define (build-post-index total-pages number posts)
-  (define site-path (index-path number #:file? #t))
+(define (build-index-page total-pages page-number posts #:tag [tag #f])
+  (define site-path (index-path page-number #:tag tag #:file? #t))
+  (define out-path (reroot-path site-path output-dir))
   (eprintf "~a rendering <output>~a\n" (timestamp-string) site-path)
+  (make-parent-directory* out-path)
   (call-with-output-file* #:exists 'truncate/replace
-                          (reroot-path site-path output-dir)
-                          (λ~>> (write-html (post-index-page total-pages number posts)))))
+                          out-path
+                          (λ~>> (write-html (index-page total-pages page-number posts #:tag tag)))))
+
+(define (build-feeds posts #:tag [tag #f])
+  (build-feed 'atom posts #:tag tag)
+  (build-feed 'rss posts #:tag tag))
 
-(define (build-tag-index total-pages page-number tag posts)
-  (define site-path (tag-index-path tag page-number))
+(define (build-feed type posts #:tag tag)
+  (define site-path (feed-path type #:tag tag))
   (define out-path (reroot-path site-path output-dir))
   (eprintf "~a rendering <output>~a\n" (timestamp-string) site-path)
   (make-parent-directory* out-path)
   (call-with-output-file* #:exists 'truncate/replace
                           out-path
-                          (λ~>> (write-html (tag-index-page total-pages page-number tag posts)))))
+                          (λ~>> (write-xml (feed type posts #:tag tag)))))
 
 (define (build-all)
   (make-directory* build-dir)
   (make-directory* output-dir)
-  (define post-infos
+  (define all-posts
     (for/list ([dep (in-list all-post-deps)])
       (define info (build-post-body dep))
       (build-post-page dep info)
       info))
 
   (define total-pages (ceiling (/ (length all-post-deps) num-posts-per-page)))
-  (for ([posts (in-slice num-posts-per-page (reverse post-infos))]
+  (for ([posts (in-slice num-posts-per-page (reverse all-posts))]
         [number (in-naturals 1)])
-    (build-post-index total-pages number posts))
+    (build-index-page total-pages number posts))
+  (build-feeds (reverse all-posts))
 
   (define tagged-posts
     (for*/fold ([tagged-deps+infos (hash)])
-               ([post (in-list post-infos)]
+               ([post (in-list all-posts)]
                 [tag (in-list (rendered-post-tags post))])
       (hash-update tagged-deps+infos tag (λ~>> (cons post)) '())))
 
   (for ([(tag posts) (in-immutable-hash tagged-posts)])
     (define total-pages (ceiling (/ (length posts) num-posts-per-page)))
     (for ([posts (in-slice num-posts-per-page posts)]
           [page-number (in-naturals 1)])
-      (build-tag-index total-pages page-number tag posts))))
+      (build-index-page total-pages page-number posts #:tag tag))
+    (build-feeds posts #:tag tag)))
 
 (module+ main
   (build-all))
diff --git a/blog/build/metadata.rkt b/blog/build/metadata.rkt
@@ -2,7 +2,7 @@
 
 (require racket/contract
          racket/serialize
-         (only-in xml xexpr?)
+         (only-in xml xexpr/c)
 
          "../paths.rkt"
          "../lang/metadata.rkt")
@@ -13,10 +13,10 @@
 
 (serializable-struct rendered-post (title-str title date tags body) #:transparent
   #:guard (struct-guard/c string?
-                          (listof xexpr?)
+                          (listof xexpr/c)
                           post-date?
                           (listof string?)
-                          (listof xexpr?)))
+                          (listof xexpr/c)))
 
 (define (rendered-post-path post #:file? [file? #f])
   (post-path (rendered-post-date post)
diff --git a/blog/build/render/feed.rkt b/blog/build/render/feed.rkt
@@ -0,0 +1,58 @@
+#lang racket/base
+
+(require racket/contract
+         racket/format
+         racket/list
+         racket/match
+         racket/string
+         (only-in xml xexpr/c xexpr->string)
+
+         "../../lang/metadata.rkt"
+         "../../paths.rkt"
+         "../metadata.rkt"
+         (only-in "page.rkt" index-page-title))
+
+(provide (contract-out
+          [feed (->* [(or/c 'atom 'rss) (listof rendered-post?)]
+                     [#:tag (or/c string? #f)]
+                     xexpr/c)]))
+
+(define (feed type posts #:tag [tag #f])
+  (match type
+    ['atom
+     `(feed ([xmlns "http://www.w3.org/2005/Atom"] [xml:lang "en"])
+        (title ,(index-page-title #:tag tag))
+        (link ([rel "self"] [href ,(full-url (feed-path 'atom #:tag tag))]))
+        (link ([rel "alternate"] [href ,(full-url (index-path #:tag tag))]))
+        (updated ,(post-date->rfc-3339-datetime (rendered-post-date (first posts))))
+        ,@(for/list ([post (in-list posts)])
+            (match-define (rendered-post title-str _ date tags body) post)
+            `(entry
+               (title ,title-str)
+               (link ([rel "alternate"]) ,(full-url (rendered-post-path post)))
+               (published ,(post-date->rfc-3339-datetime date))
+               (updated ,(post-date->rfc-3339-datetime date))
+               (author (name "Alexis King"))
+               (content ([type "html"]) ,(xexpr->string `(article ,@body))))))]
+
+    ['rss
+     (define updated (post-date->string (rendered-post-date (first posts))))
+     `(rss ([version "2.0"])
+        (channel
+         (title ,(index-page-title #:tag tag))
+         (description ,(index-page-title #:tag tag))
+         (link ,(full-url (index-path #:tag tag)))
+         (pubDate ,updated)
+         (lastBuildDate ,updated)
+         (ttl "60")
+         ,@(for/list ([post (in-list posts)])
+             (match-define (rendered-post title-str _ date tags body) post)
+             `(item
+                (title ,title-str)
+                (link ,(full-url (rendered-post-path post)))
+                (guid ([isPermaLink "true"]) ,(full-url (rendered-post-path post)))
+                (pubDate ,(post-date->string date))
+                (description ,(xexpr->string `(article ,@body)))))))]))
+
+(define (post-date->rfc-3339-datetime date)
+  (~a (post-date->string date) "T00:00:00Z"))
diff --git a/blog/build/render/highlight/pygments.rkt b/blog/build/render/highlight/pygments.rkt
@@ -17,7 +17,7 @@
                        [close-pygments-server (-> pygments-server? void?)]
                        [call-with-pygments-server (-> (-> pygments-server? any) any)]
                        [call-with-current-pygments-server (-> (-> any) any)]
-                       [pygmentize (->* [string? #:language string?] [#:server pygments-server?] xexpr?)]))
+                       [pygmentize (->* [string? #:language string?] [#:server pygments-server?] xexpr/c)]))
 
 (define-runtime-path pygments-server.py "pygments-server.py")
 
diff --git a/blog/build/render/page.rkt b/blog/build/render/page.rkt
@@ -6,24 +6,22 @@
          racket/list
          racket/match
          threading
-         (only-in xml xexpr?)
+         (only-in xml xexpr/c)
 
          "../../lang/metadata.rkt"
          "../../paths.rkt"
-         "../metadata.rkt")
+         "../metadata.rkt"
+         "util.rkt")
 
 (provide (contract-out
-          [page (-> #:title string? #:body xexpr? xexpr?)]
-          [post-page (-> rendered-post? xexpr?)]
-          [post-index-page (->i ([total-pages (and/c exact-integer? (>=/c 1))]
-                                 [page-number (total-pages) (and/c exact-integer? (>=/c 1) (<=/c total-pages))]
-                                 [posts (listof rendered-post?)])
-                                [result xexpr?])]
-          [tag-index-page (->i ([total-pages (and/c exact-integer? (>=/c 1))]
-                                [page-number (total-pages) (and/c exact-integer? (>=/c 1) (<=/c total-pages))]
-                                [tag string?]
-                                [posts (listof rendered-post?)])
-                               [result xexpr?])]))
+          [page (-> #:title string? #:body xexpr/c xexpr/c)]
+          [post-page (-> rendered-post? xexpr/c)]
+          [index-page-title (->* [] [#:tag (or/c string? #f)] string?)]
+          [index-page (->i ([total-pages (and/c exact-integer? (>=/c 1))]
+                            [page-number (total-pages) (and/c exact-integer? (>=/c 1) (<=/c total-pages))]
+                            [posts (listof rendered-post?)])
+                           (#:tag [tag (or/c string? #f)])
+                           [result xexpr/c])]))
 
 (define (page #:title title #:body body)
   `(html
@@ -53,8 +51,8 @@
            (div "Built with "
                 (a ([href "https://docs.racket-lang.org/scribble/index.html"]) (strong "Scribble"))
                 ", the Racket document preparation system.")
-           (div "Feeds are available via " (a ([href "/feeds/all.atom.xml"]) "Atom")
-                " or " (a ([href "/feeds/all.rss.xml"]) "RSS") "."))))))
+           (div "Feeds are available via " (a ([href ,(feed-path 'atom)]) "Atom")
+                " or " (a ([href ,(feed-path 'rss)]) "RSS") "."))))))
 
 (define (post-page info)
   (match-define (rendered-post title-str title date tags body) info)
@@ -64,18 +62,18 @@
                     ,(build-post-header title date tags)
                     ,@body))))
 
-(define (post-index-page total-pages page-number posts)
-  (page #:title "Alexis King’s Blog"
-        #:body `(div ([class "content"])
-                  ,@(build-post-index index-path total-pages page-number posts))))
+(define (index-page-title #:tag [tag #f])
+  (~a (if tag (~a "Posts tagged ‘" tag "’ | ") "")
+      "Alexis King’s Blog"))
 
-(define (tag-index-page total-pages page-number tag posts)
-  (page #:title (~a "Posts tagged ‘" tag "’")
+(define (index-page total-pages page-number posts #:tag [tag #f])
+  (page #:title (index-page-title #:tag tag)
         #:body `(div ([class "content"])
-                     (h1 ([class "tag-page-header"])
-                         "Posts tagged " (em ,tag))
-                     ,@(build-post-index (λ~>> (tag-index-path tag))
-                                         total-pages page-number posts))))
+                  ,@(when/list tag
+                      `(h1 ([class "tag-page-header"])
+                           "Posts tagged " (em ,tag)))
+                  ,@(build-post-index (λ~>> (index-path #:tag tag))
+                                      total-pages page-number posts))))
 
 (define (build-post-header title date tags)
   (define date-str (post-date->string date))
@@ -85,7 +83,7 @@
        (time ([datetime ,date-str]) ,date-str)
        " " (span ([style "margin: 0 5px"]) "⦿") " "
        ,@(~> (for/list ([tag (in-list tags)])
-               `(a ([href ,(tag-index-path tag)]) ,tag))
+               `(a ([href ,(index-path #:tag tag)]) ,tag))
              (add-between ", ")))))
 
 (define (build-post-index page-path total-pages page-number posts)
diff --git a/blog/lang/post-language.rkt b/blog/lang/post-language.rkt
@@ -64,7 +64,7 @@
 ;; -----------------------------------------------------------------------------
 
 (define (blog-tag tag-str)
-  (hyperlink (tag-index-path tag-str) tag-str))
+  (hyperlink (index-path #:tag tag-str) tag-str))
 
 (define-syntax-parser infer-date
   [(_) (match (path->string (syntax-source-file-name this-syntax))
diff --git a/blog/markdown/parse.rkt b/blog/markdown/parse.rkt
@@ -28,7 +28,7 @@
           (struct unordered-list ([blockss (listof (listof block?))]))
           (struct ordered-list ([blockss (listof (listof block?))]))
           (struct blockquote ([blocks (listof block?)]))
-          (struct html-block ([xexpr xexpr?]))
+          (struct html-block ([xexpr xexpr/c]))
 
           [document/p (parser/c char? document?)]))
 
diff --git a/blog/paths.rkt b/blog/paths.rkt
@@ -14,9 +14,13 @@
           [posts-dir path?]
 
           [site-path? predicate/c]
-          [index-path (->* [(and/c exact-integer? (>=/c 1))] [#:file? any/c] site-path?)]
+          [index-path (->* [] [(and/c exact-integer? (>=/c 1))
+                               #:tag (or/c string? #f)
+                               #:file? any/c]
+                           site-path?)]
           [post-path (->* [post-date? string?] [#:file? any/c] site-path?)]
-          [tag-index-path (->* [string?] [(and/c exact-integer? (>=/c 1))] site-path?)]))
+          [feed-path (->* [(or/c 'atom 'rss)] [#:tag (or/c string? #f)] site-path?)]
+          [full-url (-> site-path? string?)]))
 
 (define-runtime-path build-dir-base "../build")
 (define-runtime-path output-dir-base "../output")
@@ -29,17 +33,24 @@
   (and (string? v)
        (absolute-path? v)))
 
-(define (index-path page-number #:file? [file? #f])
-  (if (= page-number 1)
-      (if file? "/index.html" "/")
-      (~a "/index-" page-number ".html")))
+(define (index-path [page-number 1]
+                    #:tag [tag #f]
+                    #:file? [file? #f])
+  (if tag
+      (~a "/tags/"
+          (to-slug tag)
+          (if (= page-number 1) "" (~a "-" page-number))
+          ".html")
+      (if (= page-number 1)
+          (if file? "/index.html" "/")
+          (~a "/index-" page-number ".html"))))
 
 (define (post-path date title #:file? [file? #f])
   (~a "/blog/" (string-join (post-date->strings date) "/")
       "/" (to-slug title) "/" (if file? "index.html" "")))
 
-(define (tag-index-path tag-str [page-number 1])
-  (~a "/tags/"
-      (string-replace tag-str " " "-")
-      (if (= page-number 1) "" (~a "-" page-number))
-      ".html"))
+(define (feed-path format #:tag [tag #f])
+  (~a "/feeds/" (if tag (to-slug tag) "all") "." format ".xml"))
+
+(define (full-url path)
+  (~a "https://lexi-lambda.github.io" path))
