clone url: git://git.m455.casa/m455.casa
src/generate.scm
| 1 | (module generate () |
| 2 | |
| 3 | (import scheme |
| 4 | utf8 |
| 5 | srfi-1 |
| 6 | (chicken base) |
| 7 | (chicken format) |
| 8 | (chicken time posix) |
| 9 | (chicken irregex) |
| 10 | (chicken pathname) |
| 11 | (chicken string) |
| 12 | (chicken file) |
| 13 | (chicken io) |
| 14 | (chicken port) |
| 15 | static |
| 16 | utils |
| 17 | parser) |
| 18 | |
| 19 | ;; generate posts page ====================================================== |
| 20 | (define (path-data->html-link path-data) |
| 21 | ;; remove "markup/" from links for a nicer URL |
| 22 | (let ((path (strip-markup-directory-from-start-of-path (alist-ref 'path path-data)))) |
| 23 | (format " <li><a href=\"/~a\">~a</a></li>" |
| 24 | (pathname-replace-extension path "html") |
| 25 | (clean (alist-ref 'title path-data))))) |
| 26 | |
| 27 | (define (create-posts-page paths-data) |
| 28 | (let* ((posts-list (map path-data->html-link paths-data)) |
| 29 | ;; TODO: probably turn this into a template eventually |
| 30 | (html-contents (string-append |
| 31 | "<h1>posts</h1>\n" |
| 32 | "<p>here's a list of my blog posts. if you're looking for my older posts, then you\n" |
| 33 | "can find them in my <a href=\"/archive\">archive</a>.</p>\n" |
| 34 | "<ul>\n" |
| 35 | (string-intersperse posts-list "\n") |
| 36 | "\n</ul>"))) |
| 37 | (string-populate |
| 38 | HTML-TEMPLATE |
| 39 | `((title . "m455's posts") |
| 40 | (contents . ,html-contents))))) |
| 41 | |
| 42 | (define (generate-posts-page) |
| 43 | (let ((paths-data (paths->sorted-alists |
| 44 | (find-files |
| 45 | (make-pathname MARKUP-DIRECTORY |
| 46 | POSTS-DIRECTORY)))) |
| 47 | (posts-build-path (make-pathname BUILD-DIRECTORY POSTS-DIRECTORY))) |
| 48 | (create-directory posts-build-path #t) |
| 49 | (file-write (make-pathname posts-build-path "index.html") |
| 50 | (create-posts-page paths-data)))) |
| 51 | |
| 52 | ;; generate html ============================================================ |
| 53 | (define (markup-file->html file) |
| 54 | (let ((lines (file->lines file))) |
| 55 | (string-populate |
| 56 | HTML-TEMPLATE |
| 57 | `((title . ,(substring (car lines) (string-length TITLE-PREFIX))) |
| 58 | (contents . ,(parse-lines lines 'normal)))))) |
| 59 | |
| 60 | (define (generate-html) |
| 61 | (let* ((markup-files-and-directories (find-files MARKUP-DIRECTORY)) |
| 62 | (markup-files (filter (lambda (path) |
| 63 | (not (directory-exists? path))) |
| 64 | markup-files-and-directories)) |
| 65 | (markup-directories (filter (lambda (path) |
| 66 | (directory-exists? path)) |
| 67 | markup-files-and-directories))) |
| 68 | (for-each |
| 69 | (lambda (path) |
| 70 | (create-directory |
| 71 | (make-pathname BUILD-DIRECTORY |
| 72 | (strip-markup-directory-from-start-of-path path)) |
| 73 | #t)) |
| 74 | markup-directories) |
| 75 | |
| 76 | (for-each |
| 77 | (lambda (path) |
| 78 | (let ((stripped-path (strip-markup-directory-from-start-of-path path))) |
| 79 | (file-write (pathname-replace-extension |
| 80 | (make-pathname BUILD-DIRECTORY stripped-path) |
| 81 | "html") |
| 82 | (markup-file->html path)))) |
| 83 | markup-files))) |
| 84 | |
| 85 | ;; generate rss ============================================================= |
| 86 | |
| 87 | ;; this is mostly to fix the issue of rss readers opening relative links. |
| 88 | ;; this just takes links like "/path/to/thing.html" and changes them |
| 89 | ;; to "https://example.com/path/to/thing.html" |
| 90 | (define (relative-links->urls str) |
| 91 | (irregex-replace/all |
| 92 | (irregex "\\[(/[^\\[]*)\\|([^\\[]*)\\]" 's) |
| 93 | str |
| 94 | (lambda (m) |
| 95 | (format "[https://m455.casa~a|~a]" |
| 96 | (irregex-match-substring m 1) ;; link |
| 97 | (irregex-match-substring m 2))))) ;; title |
| 98 | |
| 99 | (define (date->rss-date str) |
| 100 | (time->string |
| 101 | (string->time str "%Y-%m-%d %H:%M") |
| 102 | "%a, %d %b %Y %H:%M:%S %z")) |
| 103 | |
| 104 | (define (post->rss-item path-data) |
| 105 | (let* ((content (with-input-from-file (alist-ref 'path path-data) read-string)) |
| 106 | (content-links-fixed (relative-links->urls content)) |
| 107 | (path (pathname-replace-extension (alist-ref 'path path-data) "html")) |
| 108 | (path-stripped (strip-markup-directory-from-start-of-path path))) |
| 109 | (string-populate |
| 110 | RSS-ITEM-TEMPLATE |
| 111 | `((post-title . ,(alist-ref 'title path-data)) |
| 112 | (post-url . ,(string-append "https://m455.casa/" path-stripped)) |
| 113 | (post-date . ,(date->rss-date (alist-ref 'date path-data))) |
| 114 | (post-contents . ,(parse-lines |
| 115 | (with-input-from-string content-links-fixed read-lines) |
| 116 | 'normal)))))) |
| 117 | |
| 118 | (define (generate-rss) |
| 119 | (let* ((paths-data (paths->sorted-alists |
| 120 | (filter (lambda (path) |
| 121 | (not (directory-exists? path))) |
| 122 | (find-files (make-pathname MARKUP-DIRECTORY |
| 123 | POSTS-DIRECTORY))))) |
| 124 | (posts-as-rss-items (string-intersperse (map post->rss-item paths-data) "\n"))) |
| 125 | (file-write |
| 126 | (make-pathname BUILD-DIRECTORY "feed.rss") |
| 127 | (string-populate RSS-CHANNEL-TEMPLATE `((items . ,posts-as-rss-items)))))) |
| 128 | |
| 129 | ;; do the stuff |
| 130 | (generate-posts-page) |
| 131 | (generate-html) |
| 132 | (generate-rss)) |