clone url: git://git.m455.casa/repo2html
repo2html.scm
| 1 | #!/usr/bin/csi -s |
| 2 | |
| 3 | (import |
| 4 | (chicken file) |
| 5 | (chicken format) ;; format |
| 6 | (chicken io) ;; read-line |
| 7 | (chicken pathname) |
| 8 | (chicken port) |
| 9 | (chicken process) ;; call-with-input-pipe |
| 10 | (chicken process-context) |
| 11 | (chicken string) ;; string-intersperse |
| 12 | (clojurian syntax) |
| 13 | ersatz |
| 14 | lowdown |
| 15 | scss |
| 16 | srfi-1 ;; list utils |
| 17 | srfi-13 ;; string utils |
| 18 | srfi-14 ;; charsets |
| 19 | sxml-transforms |
| 20 | symbol-utils ;; (unspecified-value) |
| 21 | utf8 |
| 22 | utils |
| 23 | utils-git |
| 24 | ) |
| 25 | |
| 26 | ;; auto-apply ids to headings --------------------------------- |
| 27 | (define (slugify inner) |
| 28 | (-> |
| 29 | inner |
| 30 | (pre-post-order* |
| 31 | `((*text* . |
| 32 | ,(lambda (_ str) |
| 33 | (if (string? str) |
| 34 | (-> |
| 35 | str |
| 36 | (string-downcase) |
| 37 | (string-translate "/,:;\"[]{}()=+") |
| 38 | (string-translate " _." "---")) |
| 39 | str))) |
| 40 | ,@alist-conv-rules*)) |
| 41 | (flatten) |
| 42 | ((flip map) ->string) |
| 43 | (string-intersperse "") |
| 44 | (substring* 0 40))) |
| 45 | |
| 46 | (define (enumerate-tag inner) |
| 47 | (let ((slug (slugify inner))) |
| 48 | `((@ (id ,slug)) |
| 49 | ,inner |
| 50 | (a (@ ((title "Permalink to this section") |
| 51 | (href "#" ,slug))))))) |
| 52 | |
| 53 | ;; a relative link to a file within our own repo should get .html added to the |
| 54 | ;; target, since we make that filename change when rendering files for the web. |
| 55 | ;; |
| 56 | ;; thought it might also be good to apply that same treatment to any absolute |
| 57 | ;; links into our repo (or other repos on the same forge?) but that gets a bit |
| 58 | ;; messy, would need to drag variables holding current site, path, repo name all |
| 59 | ;; the way into here |
| 60 | ;; |
| 61 | ;; if adjust-relative is not false, it is a prefix to be added to relative |
| 62 | ;; links, to make the top-level readme link correctly into the site. |
| 63 | (define (adjust-relative-link adjust-relative inner) |
| 64 | (let* ((linkurl (alist-ref-in '(@ href) inner equal?)) |
| 65 | (linkurl-startswith (cute string-prefix? <> (car linkurl)))) |
| 66 | (if |
| 67 | (any linkurl-startswith '("#" "mailto:" "gemini:" "http://" "https://")) |
| 68 | inner |
| 69 | (alist-update-in '(@ href) (cons adjust-relative (append linkurl '(".html"))) inner equal?)))) |
| 70 | |
| 71 | ;; TODO FIXME for some reason, lowdown renders links differently than images: |
| 72 | ;; (markdown->sxml "[x](x)") => ((p (a (@ (href "x")) "x"))) |
| 73 | ;; (markdown->sxml "") => ((p (img (@ (src ("x")) (alt "x"))))) |
| 74 | |
| 75 | (define (adjust-relative-src adjust-relative inner) |
| 76 | (let* ((srcurl |
| 77 | (-> |
| 78 | ;; ugh why |
| 79 | (alist-ref-in '(@ src) inner equal?) |
| 80 | (car) |
| 81 | ((lambda (x) (if (list? x) (car x) x))))) |
| 82 | (srcurl-startswith (cute string-prefix? <> srcurl))) |
| 83 | (if |
| 84 | (or (not adjust-relative) |
| 85 | (not srcurl) |
| 86 | (any srcurl-startswith '("/" "http://" "https://"))) |
| 87 | inner |
| 88 | (alist-update-in '(@ src) `((,(string-append adjust-relative srcurl))) inner equal?)))) |
| 89 | |
| 90 | (define (sxml-html-rules adjust-relative) |
| 91 | `(;; assign all headings an id so you can link to them |
| 92 | (h1 . ,(lambda (t i) (cons t (enumerate-tag i)))) |
| 93 | (h2 . ,(lambda (t i) (cons t (enumerate-tag i)))) |
| 94 | (h3 . ,(lambda (t i) (cons t (enumerate-tag i)))) |
| 95 | (h4 . ,(lambda (t i) (cons t (enumerate-tag i)))) |
| 96 | (h5 . ,(lambda (t i) (cons t (enumerate-tag i)))) |
| 97 | ;; if adjust-relative is true, all relative links should get prefixed with |
| 98 | ;; the relative-root |
| 99 | (a . ,(lambda (t i) (cons t (adjust-relative-link adjust-relative i)))) |
| 100 | (img . ,(lambda (t i) (cons t (adjust-relative-src adjust-relative i)))) |
| 101 | ;; this copied from lowdown's html-serialization-rules* because it is for |
| 102 | ;; some reason not exported, so i can't just import it?? |
| 103 | (*COMMENT* . ,(lambda (_t i) (list #\< "!--" i "--" #\>))) |
| 104 | ;; ignore any #<unspecified> values in the tree |
| 105 | (*text* . ,(lambda (_t i) (if (unspecified? i) "" i))) |
| 106 | ,@alist-conv-rules*)) |
| 107 | |
| 108 | ;; environment always takes precedence over git-config |
| 109 | (define (config key) |
| 110 | (or |
| 111 | (get-environment-variable (string-append "REPO2HTML_" (string-upcase key))) |
| 112 | (git-config->string (string-append "repo2html." (string-downcase key))))) |
| 113 | |
| 114 | ;; sxml generators for constructed pages --------------------------------- |
| 115 | |
| 116 | (define (lines->string xs) (string-intersperse xs "\n")) |
| 117 | |
| 118 | (define (lines->numbered-sxml lines) |
| 119 | `(table |
| 120 | (@ (id "file-contents")) |
| 121 | ,@(map (lambda (number line) |
| 122 | `(tr (@ ((class "line") |
| 123 | (id ,number))) |
| 124 | (td (@ (class "line-number")) |
| 125 | (a (@ (href "#" ,number)) ,number)) |
| 126 | (td (@ (class "line-contents")) |
| 127 | (code ,line)))) |
| 128 | (map number->string (iota (length lines) 1)) |
| 129 | lines))) |
| 130 | |
| 131 | (define (source->sxml source-file) ;; src/main.scm |
| 132 | (define-values (_ _ basename extension _) |
| 133 | (pathparts source-file)) |
| 134 | (define (image-link) |
| 135 | `(p (img (@ (src (,(string-append basename extension))))))) |
| 136 | (define (plaintext) |
| 137 | `(pre ,(git-file->lines source-file))) |
| 138 | (define (numbered-sxml) |
| 139 | (-> source-file |
| 140 | git-file->lines |
| 141 | lines->numbered-sxml)) |
| 142 | (define (binary) |
| 143 | '(p "(Binary file)")) |
| 144 | (case (string->symbol extension) |
| 145 | ((.md .markdown) |
| 146 | (handle-exceptions exn |
| 147 | (begin |
| 148 | (format (current-error-port) "Error parsing ~a\n" source-file) |
| 149 | `((p (b "There was an error parsing this file as Markdown.")) |
| 150 | ,(plaintext))) |
| 151 | (-> source-file |
| 152 | git-file->lines |
| 153 | lines->string |
| 154 | markdown->sxml))) |
| 155 | ((.jpg .jpeg .png .gif .webp .webm .apng .avif .svgz .ico) |
| 156 | (image-link)) |
| 157 | ((.svg) |
| 158 | (list (image-link) (plaintext))) |
| 159 | ((.gz .pack .idx) |
| 160 | (binary)) |
| 161 | (else |
| 162 | (if (git-file-is-text? source-file) |
| 163 | (numbered-sxml) |
| 164 | (binary))))) |
| 165 | |
| 166 | (define (filelist->sxml source-files-list relative-root) |
| 167 | `((h1 "Files") |
| 168 | ((ul |
| 169 | ,(map |
| 170 | (lambda (source-file) |
| 171 | `(li (a (@ (href ,(make-pathname relative-root source-file))) ,source-file))) |
| 172 | source-files-list))))) |
| 173 | |
| 174 | (define (commits->sxml) |
| 175 | `((h1 "Commits") |
| 176 | (table |
| 177 | (tr ,@(map (lambda x `(th ,x)) '("Date" "Ref" "Log" "Author"))) |
| 178 | ,(map |
| 179 | (lambda (commit) `(tr ,@(map (lambda x `(td ,x)) commit))) |
| 180 | (git-commits))))) |
| 181 | |
| 182 | (define (contributors->sxml) |
| 183 | `((h1 "Contributors") |
| 184 | (table |
| 185 | (tr (th "Author") (th "Commits")) |
| 186 | ,(map |
| 187 | (lambda (line) |
| 188 | (let-values (((commits author) (apply values (string-split line "\t")))) |
| 189 | `(tr (td ,author) (td ,commits)))) |
| 190 | (git-contributors))))) |
| 191 | |
| 192 | |
| 193 | (define (issueslist->sxml source-files-list) |
| 194 | `((h1 "Issues") |
| 195 | ((ul |
| 196 | ,(filter-map |
| 197 | (lambda (source-file) |
| 198 | (and |
| 199 | (string-prefix? "ISSUES/" source-file) |
| 200 | `(li (a (@ (href ,source-file)) |
| 201 | ,(-> |
| 202 | source-file |
| 203 | git-file->lines |
| 204 | ((lambda (x) (if (or (eof-object? x) (null-list? x)) (list (pathname-strip-directory source-file)) x))) |
| 205 | car |
| 206 | (string-trim (string->char-set "# "))))))) |
| 207 | source-files-list))))) |
| 208 | |
| 209 | ;; used by ersatz writer |
| 210 | (define (alist->tvals vars) |
| 211 | (map (lambda (pair) |
| 212 | `(,(car pair) . ,(sexpr->tvalue (cdr pair)))) vars)) |
| 213 | |
| 214 | ;; this version uses a jinja-style template via ersatz |
| 215 | (define (make-template-writer-ersatz templates-directory #!optional vars) |
| 216 | (define template (statements-from-file (template-std-env search-path: (list templates-directory)) "default.html")) |
| 217 | (lambda (output-filename body-sxml #!optional newvars) |
| 218 | ;; create destination directory if needed |
| 219 | (if-let (destination-directory (pathname-directory output-filename)) |
| 220 | (create-directory destination-directory #t) |
| 221 | '()) |
| 222 | |
| 223 | (let* (;; vars = global vars + file-specific vars |
| 224 | (vars (alist-merge vars (or newvars '()))) |
| 225 | (adjust-relative (unless-equals (alist-ref 'relative_root vars) "html/")) |
| 226 | ;; render the sxml to a html string that we can hand to the template |
| 227 | (body-html |
| 228 | (with-output-to-string |
| 229 | (lambda () |
| 230 | (SXML->HTML (pre-post-order* body-sxml (sxml-html-rules adjust-relative)))))) |
| 231 | ;; vars = vars + body k/v pair |
| 232 | (vars (alist-cons 'content body-html vars))) |
| 233 | |
| 234 | (with-output-to-file output-filename |
| 235 | (lambda () |
| 236 | (display (eval-statements template models: (alist->tvals vars)))))))) |
| 237 | |
| 238 | ;; main program ------------------------------------------------------------------------------ |
| 239 | |
| 240 | (define (generate-html-files html-repo-path templates-directory) |
| 241 | ;; git automatically updates this hash when you checkout/pull/etc. |
| 242 | (let* ((version-ident "$Id$") |
| 243 | (source-files-list (git-repository->paths-list)) |
| 244 | (forge-root (string-append (string-chomp (or (config "forgeroot") "") "/") "/")) |
| 245 | (repository-path (or (config "path") |
| 246 | (and (not (equal? forge-root "/")) |
| 247 | (string-prefix? forge-root html-repo-path) |
| 248 | (string-drop html-repo-path (string-length forge-root))) |
| 249 | (pathname-strip-directory html-repo-path))) |
| 250 | (template-alist |
| 251 | `(;; variables provided to template at all times. beware: ersatz |
| 252 | ;; templates break if you attempt to use a variable with a hyphen. |
| 253 | |
| 254 | ;; the list of all files in the git repo |
| 255 | (source_files_list . ,source-files-list) |
| 256 | ;; the description of the repo, taken from: env, config, cgit-like |
| 257 | ;; description file |
| 258 | (repository_description . ,(or (config "description") |
| 259 | (if-let (f (file-exists? "description")) |
| 260 | (with-input-from-file f read-lines) #f) |
| 261 | "")) |
| 262 | ;; the name of the repo, which is usually but not necessarily the |
| 263 | ;; same as its directory name (and last path element of the url) |
| 264 | (repository_name . ,(or (config "name") |
| 265 | (-> html-repo-path |
| 266 | (string-chomp ".git") |
| 267 | (pathname-strip-directory)))) |
| 268 | ;; the path from the forge root to the repository |
| 269 | (repository_path . ,repository-path) |
| 270 | ;; the repository_path with the last path element removed |
| 271 | (repository_path_parent . ,(or (pathname-directory repository-path) "")) |
| 272 | ;; the repository_path_parent as a list of path components |
| 273 | (repository_ancestors . ,(or (string-split (or (pathname-directory repository-path) "") "/") '())) |
| 274 | ;; the first README file found among these, if any. |
| 275 | (readme_file . ,(find (cut member <> source-files-list) |
| 276 | '("README.md" "README" "README.txt"))) |
| 277 | ;; the first LICENSE file found among these, if any. |
| 278 | (license_file . ,(find (cut member <> source-files-list) |
| 279 | '("LICENSE.md" "LICENSE" "LICENSE.txt"))) |
| 280 | ;; the string "ISSUES" if any files exist in ISSUES/ |
| 281 | (issues_file . ,(and (find (cut string-prefix? "ISSUES/" <>) source-files-list) "ISSUES")) |
| 282 | (repo2html_version . ,(if (equal? version-ident (list->string '(#\$ #\I #\d #\$))) |
| 283 | "" |
| 284 | (substring* version-ident 5 12))) |
| 285 | )) |
| 286 | (write-with-template |
| 287 | (make-template-writer-ersatz templates-directory template-alist))) |
| 288 | (define html-path (make-pathname html-repo-path "html")) |
| 289 | |
| 290 | (create-directory html-repo-path #t) |
| 291 | ;; special files |
| 292 | (write-with-template (make-pathname html-path "files" "html") (filelist->sxml source-files-list "")) |
| 293 | (write-with-template (make-pathname html-path "contributors" "html") (contributors->sxml)) |
| 294 | (write-with-template (make-pathname html-path "commits" "html") (commits->sxml)) |
| 295 | ;; htmlified repo contents |
| 296 | (for-each |
| 297 | (lambda (source-file) |
| 298 | (->> source-file |
| 299 | (pathparts) |
| 300 | (define-values (root elements basename extension relative-root))) |
| 301 | (write-with-template |
| 302 | (make-pathname html-path source-file "html") |
| 303 | (source->sxml source-file) |
| 304 | `(;; additional per-page variables provided to template |
| 305 | (source_file . ,source-file) |
| 306 | (root . ,root) |
| 307 | (elements . ,elements) |
| 308 | (basename . ,basename) |
| 309 | (extension . ,extension) |
| 310 | (relative_root . ,relative-root) |
| 311 | )) |
| 312 | ;; if it's an image, also write it verbatim to output directory |
| 313 | (case (string->symbol (or (pathname-extension source-file) "")) |
| 314 | ((jpg jpeg png gif webp webm svg apng avif svgz ico) |
| 315 | (git-copy source-file (make-pathname html-path source-file))))) |
| 316 | source-files-list) |
| 317 | ;; if README.md, README, or README.txt exists, regenerate it as index.html. |
| 318 | ;; otherwise regenerate files.html as index.html. |
| 319 | (write-with-template |
| 320 | (make-pathname html-repo-path "index" "html") |
| 321 | (if-let (readme-file |
| 322 | (alist-ref 'readme_file template-alist)) |
| 323 | (source->sxml readme-file) |
| 324 | (filelist->sxml source-files-list "")) |
| 325 | ;; TODO: do we need the full set of template variables defined here? |
| 326 | ;; if so maybe this and the set above should be lifted out somewhere |
| 327 | `((relative_root . "html/"))) |
| 328 | |
| 329 | ;; if the ISSUES directory got created, write out an index file for the |
| 330 | ;; stuff in there. |
| 331 | (when (file-exists? (make-pathname html-path "ISSUES")) |
| 332 | (write-with-template (make-pathname html-path "ISSUES" "html") (issueslist->sxml source-files-list))))) |
| 333 | |
| 334 | (define (main #!optional html-repo-path templates-directory) |
| 335 | |
| 336 | (unless html-repo-path |
| 337 | (bail "please specify a destination directory for html files")) |
| 338 | |
| 339 | (unless (in-git-directory?) |
| 340 | (bail "woops this isn't a git directory")) |
| 341 | |
| 342 | (unless templates-directory |
| 343 | (bail "please specify the directory containing the templates.\nnote: built-in sxml templates have been removed.")) |
| 344 | |
| 345 | (generate-html-files (string-chomp html-repo-path "/") templates-directory)) |
| 346 | |
| 347 | (apply main (command-line-arguments)) |