clone url: git://git.m455.casa/pancake
src/pancake.rkt
| 1 | #lang racket/base |
| 2 | |
| 3 | (require racket/file |
| 4 | racket/match |
| 5 | racket/string |
| 6 | racket/system |
| 7 | web-server/dispatchers/dispatch |
| 8 | web-server/servlet-env) |
| 9 | |
| 10 | ;; ----------------------------------------------------------- |
| 11 | ;; Path helpers |
| 12 | ;; ----------------------------------------------------------- |
| 13 | (define directories |
| 14 | (hash |
| 15 | 'pages (build-path "pages") |
| 16 | 'posts (build-path "posts") |
| 17 | 'output (build-path "output") |
| 18 | 'drafts (build-path "drafts") |
| 19 | 'layout (build-path "layout") |
| 20 | 'pdfs (build-path "pdfs") |
| 21 | 'css (build-path "css") |
| 22 | 'images (build-path "images") |
| 23 | 'misc (build-path "misc"))) |
| 24 | |
| 25 | (define (directories-ref a-key) |
| 26 | (hash-ref directories a-key)) |
| 27 | |
| 28 | (define (build-path-to-md-file-ref directories-key file-string) |
| 29 | (build-path (directories-ref directories-key) |
| 30 | (path-add-extension file-string #".md"))) |
| 31 | |
| 32 | (define files |
| 33 | (hash |
| 34 | 'head (build-path-to-md-file-ref 'layout "head") |
| 35 | 'nav (build-path-to-md-file-ref 'layout "nav") |
| 36 | 'index (build-path-to-md-file-ref 'pages "index") |
| 37 | 'footer (build-path-to-md-file-ref 'layout "footer"))) |
| 38 | |
| 39 | (define (files-ref a-key) |
| 40 | (hash-ref files a-key)) |
| 41 | |
| 42 | ;; ----------------------------------------------------------- |
| 43 | ;; File contents |
| 44 | ;; ----------------------------------------------------------- |
| 45 | (define head-contents |
| 46 | #<<string-block |
| 47 | --- |
| 48 | title: '[your blog title](/)' |
| 49 | lang: en |
| 50 | subtitle: 'your pronouns' |
| 51 | header-includes: |
| 52 | <meta name="author" content="Jesse Laprade" /> |
| 53 | <meta name="description" content="m455's blog" /> |
| 54 | <meta name="keywords" content="programming, documentation, personal homepages" /> |
| 55 | <meta name="0" content=" "/> |
| 56 | <meta name="0" content=" "/> |
| 57 | <meta name="0" content=" built with "/> |
| 58 | <meta name="0" content=" p a n c a k e "/> |
| 59 | <meta name="0" content=" "/> |
| 60 | <meta name="0" content=" "/> |
| 61 | <meta name="0" content=" __//\ "/> |
| 62 | <meta name="0" content=" ,,------/__\\ \-----,,,_ "/> |
| 63 | <meta name="0" content=" ,'` , -```|___|\\/`-, ,`, "/> |
| 64 | <meta name="0" content=" ; `, ____,-` '' ,; "/> |
| 65 | <meta name="0" content=" :; `` ; ;` , ' ;;;` "/> |
| 66 | <meta name="0" content=" ';,;,,,; ;,,,,,,,,,,,;;;;`` "/> |
| 67 | <meta name="0" content=" ```-; ;``````````` "/> |
| 68 | <meta name="0" content=" ,''`` `;______________ "/> |
| 69 | <meta name="0" content=" ; ------------ `, "/> |
| 70 | <meta name="0" content=" `'--------------------` "/> |
| 71 | <meta name="0" content=" "/> |
| 72 | <meta name="0" content=" "/> |
| 73 | --- |
| 74 | string-block |
| 75 | ) |
| 76 | |
| 77 | (define nav-contents |
| 78 | #<<string-block |
| 79 | ::: {#nav} |
| 80 | [Home](index.html) - [I also link to home](index.html) |
| 81 | ::: |
| 82 | <hr/> |
| 83 | ::: {#main} |
| 84 | string-block |
| 85 | ) |
| 86 | |
| 87 | (define index-contents |
| 88 | #<<string-block |
| 89 | # Welcome! |
| 90 | |
| 91 | I am default text! |
| 92 | string-block |
| 93 | ) |
| 94 | |
| 95 | ;; The ":::" below ends the "::: {#main}" id from head-contents |
| 96 | (define footer-contents |
| 97 | #<<string-block |
| 98 | ::: |
| 99 | <hr/> |
| 100 | ::: {#footer} |
| 101 | This website was built with [pancake](https://git.m455.casa/pancake.git) |
| 102 | ::: |
| 103 | string-block |
| 104 | ) |
| 105 | |
| 106 | ;; ----------------------------------------------------------- |
| 107 | ;; Display helpers |
| 108 | ;; ----------------------------------------------------------- |
| 109 | (define-syntax-rule (displayln-format a-string ...) |
| 110 | (displayln (format a-string ...))) |
| 111 | |
| 112 | (define (displayln-for . strings) |
| 113 | (for ([message strings]) |
| 114 | (displayln message))) |
| 115 | |
| 116 | (define (displayln-creating-file file-string) |
| 117 | (displayln-format "Creating file: ~a ..." file-string)) |
| 118 | |
| 119 | (define (displayln-creating-directory directory-string) |
| 120 | (displayln-format "Creating directory: ~a ..." directory-string)) |
| 121 | |
| 122 | (define (displayln-error error-type item-found) |
| 123 | (case error-type |
| 124 | ['arguments-invalid (displayln-format "Error: Found '~a', but expected 'help', 'initialize', 'preview', 'build', or 'clean'." item-found)] |
| 125 | ['arguments-length (displayln-format "Error: Found ~a arguments, but expected 1 argument." (number->string item-found))] |
| 126 | ['cannot-create-directory (begin (displayln-format "Error: Cannot create ~a." item-found) |
| 127 | (displayln-format "Reason: ~a is a file. Try moving this somewhere else and try again." item-found) |
| 128 | (exit))] |
| 129 | ['cannot-create-file (begin (displayln-format "Error: Cannot create ~a." item-found) |
| 130 | (displayln-format "Reason: ~a is a directory. Try moving this somewhere else and try again." item-found) |
| 131 | (exit))] |
| 132 | ['y-n (displayln-format "Error: Found '~a', but expected 'y' or 'n'." item-found)])) |
| 133 | |
| 134 | ;; ----------------------------------------------------------- |
| 135 | ;; Directory helpers |
| 136 | ;; ----------------------------------------------------------- |
| 137 | (define (directories-exist?) |
| 138 | (andmap directory-exists? (hash-values directories))) |
| 139 | |
| 140 | (define (path->directory-path-string directory-path) |
| 141 | (path->string (path->directory-path directory-path))) |
| 142 | |
| 143 | (define (directory-create directory-path) |
| 144 | (if (file-exists? directory-path) |
| 145 | (displayln-error 'cannot-create-directory (path->string directory-path)) |
| 146 | (begin |
| 147 | (let ([directory-string-with-slash (path->directory-path-string directory-path)]) |
| 148 | (when (not (directory-exists? directory-path)) |
| 149 | (displayln-creating-directory directory-string-with-slash) |
| 150 | (make-directory* directory-path)))))) |
| 151 | |
| 152 | ;; ----------------------------------------------------------- |
| 153 | ;; File helpers |
| 154 | ;; ----------------------------------------------------------- |
| 155 | (define (files-exist?) |
| 156 | (andmap file-exists? (hash-values files))) |
| 157 | |
| 158 | (define (filter-extensions extension-string listof-file-paths) |
| 159 | (let ([listof-file-strings (map path->string listof-file-paths)]) |
| 160 | (filter (lambda (file-string) (string-suffix? file-string extension-string)) |
| 161 | listof-file-strings))) |
| 162 | |
| 163 | ;; Lists all files inside of directories |
| 164 | (define (file-list) |
| 165 | (for/list ([file (in-directory)]) file)) |
| 166 | |
| 167 | (define (file-create file-path) |
| 168 | (if (directory-exists? file-path) |
| 169 | (displayln-error 'cannot-create-file) |
| 170 | (when (not (file-exists? file-path)) |
| 171 | (displayln-creating-file (path->string file-path)) |
| 172 | (close-output-port (open-output-file file-path #:exists 'truncate))))) |
| 173 | |
| 174 | (define (file-populate file-path contents) |
| 175 | (displayln-format "Populating file with default values: ~a ..." (path->string file-path)) |
| 176 | (display-to-file contents file-path #:exists 'truncate)) |
| 177 | |
| 178 | (define (file-populate-ref key contents) |
| 179 | (file-populate (files-ref key) contents)) |
| 180 | |
| 181 | (define (file-create-populate file-path contents) |
| 182 | (file-create file-path) |
| 183 | (file-populate file-path contents)) |
| 184 | |
| 185 | ;; ----------------------------------------------------------- |
| 186 | ;; Repair - Checks for and creates missing directories and files |
| 187 | ;; ----------------------------------------------------------- |
| 188 | (define (repair/cancel) |
| 189 | (displayln "Cancelled directory and file repairs.") |
| 190 | (exit)) |
| 191 | |
| 192 | (define (repair/elements-missing files-required files-to-check) |
| 193 | (if (null? files-required) |
| 194 | null |
| 195 | (if (member (car files-required) files-to-check) |
| 196 | (repair/elements-missing (cdr files-required) files-to-check) |
| 197 | (cons (car files-required) |
| 198 | (repair/elements-missing (cdr files-required) files-to-check))))) |
| 199 | |
| 200 | (define (repair/create-missing-directories missing-directory-paths) |
| 201 | (when (not (null? missing-directory-paths)) |
| 202 | (for ([directory missing-directory-paths]) |
| 203 | (directory-create directory)))) |
| 204 | |
| 205 | (define (repair/create-missing-files missing-file-paths) |
| 206 | (when (not (null? missing-file-paths)) |
| 207 | (for ([file missing-file-paths]) |
| 208 | (file-create file)))) |
| 209 | |
| 210 | (define (repair/populate-files missing-file-paths) |
| 211 | (when (not (null? missing-file-paths)) |
| 212 | (let ([head (files-ref 'head)] |
| 213 | [nav (files-ref 'nav)] |
| 214 | [index (files-ref 'index)] |
| 215 | [footer (files-ref 'footer)]) |
| 216 | (for ([file missing-file-paths]) |
| 217 | (match (path->string file) |
| 218 | [head (file-populate-ref 'head head-contents)] |
| 219 | [nav (file-populate-ref 'nav nav-contents)] |
| 220 | [index (file-populate-ref 'index index-contents)] |
| 221 | [footer (file-populate-ref 'footer footer-contents)] |
| 222 | [_ 'else]))))) |
| 223 | |
| 224 | (define (repair/start missing-directory-paths missing-file-paths) |
| 225 | (repair/create-missing-directories missing-directory-paths) |
| 226 | (repair/create-missing-files missing-file-paths) |
| 227 | (repair/populate-files missing-file-paths)) |
| 228 | |
| 229 | ;; missing-directory-paths and missing-file-paths will be null if |
| 230 | ;; all required directories and files exist |
| 231 | ;; |
| 232 | ;; the (filter directory-exists? ...) removes files from the list of paths |
| 233 | (define (repair/gather-missing-directory-paths) |
| 234 | (let* ([listof-required-paths (hash-values directories)] |
| 235 | [listof-current-paths (filter directory-exists? (directory-list))] |
| 236 | [listof-missing-paths (repair/elements-missing listof-required-paths listof-current-paths)]) |
| 237 | ;; return missing directories. |
| 238 | ;; path->directory-path appeneds a "/" at the end |
| 239 | listof-missing-paths)) |
| 240 | |
| 241 | ;; The (filter file-exists? ...) removes directories from the list of paths |
| 242 | (define (repair/gather-missing-file-paths) |
| 243 | (let* ([listof-required-paths (hash-values files)] |
| 244 | [listof-current-paths (filter file-exists? (file-list))]) |
| 245 | (repair/elements-missing listof-required-paths listof-current-paths))) |
| 246 | |
| 247 | (define (repair/display-missing-paths listof-paths) |
| 248 | (when (not (null? listof-paths)) |
| 249 | (let* ([listof-strings (map path->string listof-paths)] |
| 250 | [listas-string (string-join listof-strings "\n")]) |
| 251 | (displayln listas-string)))) |
| 252 | |
| 253 | ;; The (map path->directory-path ...) adds a "/" to each path in the list, which is |
| 254 | ;; only for displaying to the user |
| 255 | (define (repair/prompt) |
| 256 | (let ([missing-directory-paths (repair/gather-missing-directory-paths)] |
| 257 | [missing-file-paths (repair/gather-missing-file-paths)]) |
| 258 | (displayln "The following directories or files are missing:") |
| 259 | (repair/display-missing-paths (map path->directory-path missing-directory-paths)) |
| 260 | (repair/display-missing-paths missing-file-paths) |
| 261 | (displayln "Do you want to create them? [y/n]") |
| 262 | (display "> ") |
| 263 | (flush-output) |
| 264 | (let ([user-choice (read-line)]) |
| 265 | (case (string->symbol user-choice) |
| 266 | [(y Y yes Yes) (repair/start missing-directory-paths missing-file-paths)] |
| 267 | [(n N no No) (repair/cancel)] |
| 268 | [else (displayln-error 'y-n user-choice)])))) |
| 269 | |
| 270 | (define (repair) |
| 271 | (displayln "Checking for missing directories or files ...") |
| 272 | (if (not (and (directories-exist?) (files-exist?))) |
| 273 | (repair/prompt) |
| 274 | (displayln "No missing directories or files found!"))) |
| 275 | |
| 276 | ;; ----------------------------------------------------------- |
| 277 | ;; Help |
| 278 | ;; ----------------------------------------------------------- |
| 279 | (define (help) |
| 280 | (displayln-for |
| 281 | "pancake help - Displays this help message" |
| 282 | "pancake initialize - Generates the directories and files in your current directory, so pancake can operate" |
| 283 | "pancake build - Builds your website in the output/ directory" |
| 284 | "pancake clean - Deletes the contents of the output/ directory" |
| 285 | "pancake preview - Starts a local HTTP server in your output/ directory to view your website.")) |
| 286 | |
| 287 | ;; ----------------------------------------------------------- |
| 288 | ;; Clean - Deletes content in ./output/, except for ".git" |
| 289 | ;; ----------------------------------------------------------- |
| 290 | (define (clean/cancel) |
| 291 | (displayln "Cancelled cleaning of directories and files.") |
| 292 | (exit)) |
| 293 | |
| 294 | (define (clean/delete-files) |
| 295 | (let* ([output-directory (directories-ref 'output)] |
| 296 | [listof-paths (directory-list output-directory)]) |
| 297 | (for ([path listof-paths]) |
| 298 | (when (not (equal? path (string->path ".git"))) |
| 299 | (delete-directory/files (build-path output-directory path)))) |
| 300 | (displayln "Cleaning complete!"))) |
| 301 | |
| 302 | (define (clean) |
| 303 | (repair) |
| 304 | (displayln-for "Caution: The clean command will delete all contents of the output/ directory, except for any .git directories found." |
| 305 | "Do you want to continue? [y/n]") |
| 306 | (display "> ") |
| 307 | (flush-output) |
| 308 | (let ([user-choice (read-line)]) |
| 309 | (case (string->symbol user-choice) |
| 310 | [(y Y yes Yes) (clean/delete-files)] |
| 311 | [(n N no No) (clean/cancel)] |
| 312 | [else (displayln-error 'y-n user-choice)]))) |
| 313 | |
| 314 | ;; ----------------------------------------------------------- |
| 315 | ;; Build - Builds website in ./output/ |
| 316 | ;; ----------------------------------------------------------- |
| 317 | (define (build/copy directories-key) ;; directories-key is 'css, 'pdfs, or 'images |
| 318 | (let* ([css-directory (directories-ref directories-key)] |
| 319 | [output-directory (build-path (directories-ref 'output) |
| 320 | (directories-ref directories-key))] |
| 321 | [listof-file-paths (directory-list (directories-ref directories-key))]) |
| 322 | (directory-create output-directory) |
| 323 | (for ([file-path listof-file-paths]) |
| 324 | (copy-file (build-path css-directory file-path) |
| 325 | (build-path output-directory file-path) #t)))) |
| 326 | |
| 327 | (define (build/create-output-args directories-key file-string) |
| 328 | (let ([directory (case directories-key |
| 329 | ['posts (build-path (directories-ref 'output) |
| 330 | (directories-ref directories-key))] |
| 331 | ['pages (build-path (directories-ref 'output))])] |
| 332 | [file-name (path-replace-extension file-string ".html")]) |
| 333 | (path->string (build-path directory file-name)))) |
| 334 | |
| 335 | (define (build/create-input-args directories-key file-string) |
| 336 | (let* ([listof-input-paths (list (files-ref 'head) |
| 337 | (files-ref 'nav) |
| 338 | (build-path (directories-ref directories-key) file-string) |
| 339 | (files-ref 'footer))] |
| 340 | [listof-input-strings (map path->string listof-input-paths)]) |
| 341 | (string-join listof-input-strings))) |
| 342 | |
| 343 | (define (build/prepend-pandoc-prefix css-file) |
| 344 | (let* ([pandoc-flag "-c /"] |
| 345 | [css-directory (directories-ref 'css)] |
| 346 | [path-to-css-file (build-path css-directory css-file)] |
| 347 | [path-to-css-file-string (path->string path-to-css-file)]) |
| 348 | (string-append pandoc-flag path-to-css-file-string))) |
| 349 | |
| 350 | (define (build/create-css-args) |
| 351 | (let* ([css-directory (directories-ref 'css)] |
| 352 | [listof-css-file-strings (filter-extensions ".css" (directory-list css-directory))] |
| 353 | [listof-css-file-strings-prefixed (map build/prepend-pandoc-prefix listof-css-file-strings)]) |
| 354 | (string-join listof-css-file-strings-prefixed))) |
| 355 | |
| 356 | (define (build/markdown->html directories-key file-string) |
| 357 | (let ([css-args (build/create-css-args)] |
| 358 | [input-args (build/create-input-args directories-key file-string)] |
| 359 | [output-args (build/create-output-args directories-key file-string)]) |
| 360 | ;; In the future, I will need to change `--base-head-level=2` to `--shift-heading-level-by=NUMBER`, |
| 361 | ;; because Debian is using an older version of Pandoc. |
| 362 | (system (format "pandoc -s ~a ~a -o ~a --base-header-level=2" |
| 363 | css-args |
| 364 | input-args |
| 365 | output-args)))) |
| 366 | |
| 367 | (define (build/convert-files directories-key) |
| 368 | (let* ([listof-file-strings (directory-list (directories-ref directories-key))] |
| 369 | [listof-md-file-strings (filter-extensions ".md" listof-file-strings)]) |
| 370 | (for ([file-string listof-md-file-strings]) |
| 371 | (build/markdown->html directories-key file-string)))) |
| 372 | |
| 373 | (define (build/generate directories-key) |
| 374 | (case directories-key |
| 375 | ['posts (directory-create (build-path (directories-ref 'output) |
| 376 | (directories-ref directories-key)))] |
| 377 | ['pages (directory-create (build-path (directories-ref 'output)))]) |
| 378 | (build/convert-files directories-key)) |
| 379 | |
| 380 | (define (build) |
| 381 | (let ([output-directory (path->directory-path (build-path (directories-ref 'output)))]) |
| 382 | (repair) |
| 383 | (displayln "Building your website ...") |
| 384 | (for ([a '(posts pages)]) (build/generate a)) |
| 385 | (for ([b '(css pdfs images misc)]) (build/copy b)) |
| 386 | (displayln "Website build complete!") |
| 387 | (displayln-format "Your website was built in ~a" output-directory))) |
| 388 | |
| 389 | ;; ----------------------------------------------------------- |
| 390 | ;; Preview |
| 391 | ;; ----------------------------------------------------------- |
| 392 | ;; I referenced Greg Hendershott's servlet for this. |
| 393 | ;; Source: https://github.com/greghendershott/blog/blob/master/rkt/make-preview.rkt |
| 394 | (define (preview) |
| 395 | (repair) |
| 396 | ;; serve/servlet expects a procedure that expects a non-keyword argument |
| 397 | ;; as its first parameter. (next-dispatcher) makes a response, which the |
| 398 | ;; servlet expects. |
| 399 | (serve/servlet (lambda (x) (next-dispatcher)) |
| 400 | #:servlet-path "/index.html" |
| 401 | #:extra-files-paths (list "output/") |
| 402 | #:listen-ip "127.0.0.1" |
| 403 | #:port 8000 |
| 404 | #:launch-browser? #t)) |
| 405 | |
| 406 | ;; ----------------------------------------------------------- |
| 407 | ;; Initialize |
| 408 | ;; ----------------------------------------------------------- |
| 409 | (define (initialize/files-populate) |
| 410 | (file-populate-ref 'head head-contents) |
| 411 | (file-populate-ref 'nav nav-contents) |
| 412 | (file-populate-ref 'index index-contents) |
| 413 | (file-populate-ref 'footer footer-contents)) |
| 414 | |
| 415 | (define (initialize/files-create) |
| 416 | (for ([file (hash-values files)]) |
| 417 | (file-create file))) |
| 418 | |
| 419 | (define (initialize/directories-create) |
| 420 | (for ([directory (hash-values directories)]) |
| 421 | (directory-create directory))) |
| 422 | |
| 423 | (define (initialize/start) |
| 424 | (initialize/directories-create) |
| 425 | (initialize/files-create) |
| 426 | (initialize/files-populate) |
| 427 | (displayln "Initialization complete!")) |
| 428 | |
| 429 | (define (initialize/cancel) |
| 430 | (displayln "Cancelled directory creation.") |
| 431 | (exit)) |
| 432 | |
| 433 | ;; The path must be built here, instead of in the directory definitions |
| 434 | ;; themselves, because the directories do not have the path-building |
| 435 | ;; procedure built into them in order to avoid problems when joining with |
| 436 | ;; the file paths, such as: |
| 437 | ;; /home/username/directory/home/username/file.txt |
| 438 | (define (initialize/display-directories) |
| 439 | (for ([directory (hash-values directories)]) |
| 440 | (let* ([directory-path (path->directory-path-string directory)]) |
| 441 | (displayln directory-path)))) |
| 442 | |
| 443 | (define (initialize/display-files) |
| 444 | (for ([path (hash-values files)]) |
| 445 | (displayln path))) |
| 446 | |
| 447 | (define (initialize/prompt) |
| 448 | (displayln-for "Caution: If any of the files above exist, then they will be overwritten with default values." |
| 449 | "Note: If any of the directories above exist, then they will remain unmodified." |
| 450 | "Do you want to continue? [y/n]") |
| 451 | (display "> ") |
| 452 | (flush-output) |
| 453 | (let ([user-choice (read-line)]) |
| 454 | (case (string->symbol user-choice) |
| 455 | [(y Y yes Yes) (initialize/start)] |
| 456 | [(n N no No) (initialize/cancel)] |
| 457 | [else (displayln-error 'y-n user-choice)]))) |
| 458 | |
| 459 | (define (initialize) |
| 460 | (displayln "pancake will create the following directories and files in your current directory:") |
| 461 | (initialize/display-directories) |
| 462 | (initialize/display-files) |
| 463 | (initialize/prompt)) |
| 464 | |
| 465 | ;; ----------------------------------------------------------- |
| 466 | ;; Argument handling |
| 467 | ;; ----------------------------------------------------------- |
| 468 | (define (process-args vectorof-args) |
| 469 | (match vectorof-args |
| 470 | [(vector "initialize") (initialize)] |
| 471 | [(vector "preview") (preview)] |
| 472 | [(vector "build") (build)] |
| 473 | [(vector "clean") (clean)] |
| 474 | [(or '#("-h") |
| 475 | '#("--help") |
| 476 | '#("help")) (help)] |
| 477 | [(vector) (displayln-error 'arguments-length (vector-length vectorof-args))] |
| 478 | [(vector _ ...) (displayln-error 'arguments-invalid (vector-ref vectorof-args 0))])) |
| 479 | |
| 480 | (define (main vectorof-args) |
| 481 | (process-args vectorof-args)) |
| 482 | |
| 483 | (main (current-command-line-arguments)) |