clone url: git://git.m455.casa/lol
src/main.scm
| 1 | (import utf8 |
| 2 | spiffy |
| 3 | lowdown |
| 4 | (chicken sort) |
| 5 | (chicken string) |
| 6 | (chicken irregex) |
| 7 | (chicken io) |
| 8 | (chicken format) |
| 9 | (chicken file) |
| 10 | (chicken port) |
| 11 | (chicken pathname) |
| 12 | (chicken time posix) |
| 13 | (chicken process) |
| 14 | (chicken process-context)) |
| 15 | |
| 16 | (include "src/static.scm") |
| 17 | (include "src/utils.scm") |
| 18 | |
| 19 | (define (markup->html source-file-contents) |
| 20 | (with-output-to-string ;; left off here |
| 21 | (lambda () (markdown->html source-file-contents)))) |
| 22 | |
| 23 | (define (markup->rss-item source-pathname) |
| 24 | (let ((markup-body (string-populate (file->string source-pathname) *config-data*))) |
| 25 | (string-populate |
| 26 | (file->string (get *config-data* 'rss-item-template)) |
| 27 | `((page-title ,(string->title markup-body)) |
| 28 | (page-url ,(pathname->url source-pathname 'with-https-prefix)) |
| 29 | (page-date ,(date->rss-date (string->date markup-body))))))) |
| 30 | |
| 31 | ;; this populates variables in the html template file, and the populates the |
| 32 | ;; variables in the body contents, which are created by people in their source |
| 33 | ;; files |
| 34 | ;; |
| 35 | ;; note: the title of the source page should exist on the first line in the |
| 36 | ;; file, because the source page is checked by string->title to |
| 37 | ;; extract the title of the post |
| 38 | (define (populate-html-page source-file-contents) |
| 39 | (string-populate |
| 40 | (file->string (get *config-data* 'html-page-template)) |
| 41 | (append `((page-contents ,(markup->html source-file-contents)) |
| 42 | (rss-file ,(get *config-data* 'rss-file)) |
| 43 | (css ,(file->string (get *config-data* 'css-file))) |
| 44 | (page-title ,(string->title source-file-contents))) |
| 45 | *config-data*))) |
| 46 | |
| 47 | ;; source-pathname = source/posts/2021/somefile.txt |
| 48 | (define (create-html-file source-pathname) |
| 49 | (let* ((source-file-contents (file->string source-pathname)) |
| 50 | (destination-pathname-markup (pathname->destination-pathname source-pathname)) ;; => build/posts/2021/somefile.txt |
| 51 | (destination-pathname (pathname-replace-extension destination-pathname-markup "html")) ;; => build/posts/2021/somefile.html |
| 52 | (html-content (populate-html-page source-file-contents))) |
| 53 | (file-write destination-pathname html-content))) |
| 54 | |
| 55 | (define (generate-rss-feed source-posts) |
| 56 | (let* ((rss-feed-without-items (string-populate |
| 57 | (file->string (get *config-data* 'rss-channel-template)) |
| 58 | `((domain ,(get *config-data* 'domain)) |
| 59 | (rss-file ,(get *config-data* 'rss-file))))) |
| 60 | (rss-items-list (map markup->rss-item source-posts)) |
| 61 | (rss-feed (string-populate |
| 62 | rss-feed-without-items |
| 63 | `((rss-items ,(string-intersperse rss-items-list "\n"))))) |
| 64 | (rss-pathname (make-pathname (get *config-data* 'build-directory) (get *config-data* 'rss-file)))) |
| 65 | (file-write rss-pathname rss-feed))) |
| 66 | |
| 67 | ;; takes a list like this: |
| 68 | ;; '("/posts/2022/hey.txt" |
| 69 | ;; "/posts/2021/yep.txt" |
| 70 | ;; "/posts/2020/fuck.txt") |
| 71 | (define (generate-posts-page source-posts) |
| 72 | (let* ((links-list (map (lambda (post-pathname) |
| 73 | (let ((title (string->title (file->string post-pathname))) |
| 74 | (url (pathname->url post-pathname 'no-prefix))) |
| 75 | (format "- [~a](~a)" title url))) |
| 76 | source-posts)) |
| 77 | (links-str (string-intersperse links-list "\n")) |
| 78 | (markup (string-populate |
| 79 | (file->string (get *config-data* 'posts-page-template)) |
| 80 | `((links ,links-str))))) |
| 81 | (file-write (make-pathname |
| 82 | (pathname->destination-pathname (get *config-data* 'posts-directory)) |
| 83 | "index" |
| 84 | "html") |
| 85 | (populate-html-page markup)))) |
| 86 | |
| 87 | ;; first, create a list like this: |
| 88 | ;; '((20210122 "/posts/2021/yep.txt") |
| 89 | ;; (20220122 "/posts/2022/hey.txt") |
| 90 | ;; (20200122 "/posts/2020/fuck.txt")) |
| 91 | ;; , then reverse sort it by the dates (the car of the list) |
| 92 | ;; , and then remove the dates, so you get a list like this: |
| 93 | ;; '("/posts/2022/hey.txt" |
| 94 | ;; "/posts/2021/yep.txt" |
| 95 | ;; "/posts/2020/fuck.txt") |
| 96 | (define (reverse-sort-posts source-posts) |
| 97 | (let ((dates-and-pathnames (map (lambda (pathname) |
| 98 | (list (string->date (file->string pathname)) |
| 99 | pathname)) |
| 100 | source-posts))) |
| 101 | (map cadr (sort dates-and-pathnames |
| 102 | (lambda (date-path-pair-x date-path-pair-y) |
| 103 | (string>? (car date-path-pair-x) (car date-path-pair-y))))))) |
| 104 | |
| 105 | ;; commands ==================================================================== |
| 106 | ;; preview ------------------------------------------------- |
| 107 | (define (preview) |
| 108 | (set! *config-data* (load-config-file)) |
| 109 | (server-port 8000) |
| 110 | (root-path (get *config-data* 'build-directory)) |
| 111 | (displayln "you can preview your website at http://127.0.0.1:8000") |
| 112 | (displayln "press ctrl-c to stop the server") |
| 113 | (start-server)) |
| 114 | |
| 115 | ;; build --------------------------------------------------- |
| 116 | (define (build) |
| 117 | (set! *config-data* (load-config-file)) |
| 118 | (let* ((source-pathnames (find-files (get *config-data* 'source-directory))) |
| 119 | (assets-pathnames (find-files (get *config-data* 'assets-directory))) |
| 120 | (source-files (filter (lambda (path) |
| 121 | (and (file-exists? path) |
| 122 | (not (directory-exists? path)))) |
| 123 | source-pathnames)) |
| 124 | (assets-files (filter (lambda (pathname) |
| 125 | (and (file-exists? pathname) |
| 126 | (not (directory-exists? pathname)))) |
| 127 | assets-pathnames)) |
| 128 | (directories (append (filter directory-exists? source-pathnames) |
| 129 | (filter directory-exists? assets-pathnames)))) |
| 130 | |
| 131 | ;; clean build directory |
| 132 | (when (equal? (get *config-data* 'clean-build-directory?) "yes") |
| 133 | (let ((build-dir (get *config-data* 'build-directory))) |
| 134 | (displayln-format "clearing your ~a directory..." build-dir) |
| 135 | (delete-directory build-dir #t) |
| 136 | (create-directory build-dir #t))) |
| 137 | |
| 138 | ;; copy directory structure of source and asset directories |
| 139 | (when (not (null? directories)) |
| 140 | (displayln-format "copying the directory structure of your ~a and ~a directories..." |
| 141 | (get *config-data* 'source-directory) |
| 142 | (get *config-data* 'assets-directory)) |
| 143 | (for-each (lambda (dir) (create-directory dir #t)) |
| 144 | (map pathname->destination-pathname directories))) |
| 145 | |
| 146 | ;; copy assets over |
| 147 | (when (not (null? assets-files)) |
| 148 | (displayln "copying assets...") |
| 149 | (for-each (lambda (file) (copy-file file (pathname->destination-pathname file) #t)) |
| 150 | assets-files)) |
| 151 | |
| 152 | ;; process source files |
| 153 | (when (not (null? source-files)) |
| 154 | ;; generate html files |
| 155 | (displayln "generating html files...") |
| 156 | (for-each create-html-file source-files) |
| 157 | |
| 158 | (let ((source-posts (reverse-sort-posts |
| 159 | (filter (lambda (path) |
| 160 | (and (file-exists? path) |
| 161 | (not (directory-exists? path)))) |
| 162 | (find-files (get *config-data* 'posts-directory)))))) |
| 163 | ;; generate list of posts at build/posts/index.html |
| 164 | (when (equal? (get *config-data* 'generate-posts-page?) "yes") |
| 165 | (displayln "building a list of posts...") |
| 166 | (generate-posts-page source-posts) |
| 167 | |
| 168 | ;; generate rss feed |
| 169 | (when (equal? (get *config-data* 'generate-rss-feed?) "yes") |
| 170 | (displayln "building an rss feed...") |
| 171 | (generate-rss-feed source-posts))))) |
| 172 | (displayln "done building your website!"))) |
| 173 | |
| 174 | ;; init ---------------------------------------------------- |
| 175 | (define (init) |
| 176 | (if (file-exists? CONFIG-FILE) |
| 177 | (set! *config-data* (load-config-file)) |
| 178 | (begin (file-write CONFIG-FILE *config-data*) |
| 179 | (set! *config-data* (load-config-file)))) |
| 180 | |
| 181 | (for-each (lambda (directory) (create-directory directory #t)) |
| 182 | (list (get *config-data* 'build-directory) |
| 183 | (get *config-data* 'source-directory) |
| 184 | (get *config-data* 'posts-directory) |
| 185 | (get *config-data* 'assets-directory) |
| 186 | (get *config-data* 'templates-directory))) |
| 187 | |
| 188 | (for-each (lambda (pair) |
| 189 | (let* ((file (car pair)) |
| 190 | (contents (cadr pair)) |
| 191 | (directory (pathname-directory file))) |
| 192 | (when directory (create-directory directory #t)) |
| 193 | (when (not (file-exists? file)) |
| 194 | (file-write file contents)))) |
| 195 | (list (list (get *config-data* 'css-file) DEFAULT-CONTENTS-CSS) |
| 196 | (list (get *config-data* 'html-page-template) DEFAULT-CONTENTS-HTML-PAGE) |
| 197 | (list (get *config-data* 'posts-page-template) DEFAULT-CONTENTS-POSTS-PAGE) |
| 198 | (list (get *config-data* 'rss-channel-template) DEFAULT-CONTENTS-RSS-CHANNEL) |
| 199 | (list (get *config-data* 'rss-item-template) DEFAULT-CONTENTS-RSS-ITEM))) |
| 200 | |
| 201 | (displayln "initialized default files and directory for your website!")) |
| 202 | |
| 203 | ;; help --------------------------------------------------- |
| 204 | (define help-message |
| 205 | #<<string-block |
| 206 | help - display this help message. |
| 207 | init - create the files and directories that are required for generating a website. |
| 208 | build - generate a website |
| 209 | preview - preview your website on a local http server |
| 210 | string-block |
| 211 | ) |
| 212 | |
| 213 | (define (main args) |
| 214 | (if (null? args) |
| 215 | (displayln help-message) |
| 216 | (case (string->symbol (car args)) |
| 217 | ((--help -help help -h) |
| 218 | (displayln help-message)) |
| 219 | ('init (init)) |
| 220 | ('build (build)) |
| 221 | ('preview (preview)) |
| 222 | (else (displayln help-message))))) |
| 223 | |
| 224 | (main (command-line-arguments)) |