319 lines
12 KiB
Scheme
Executable file
319 lines
12 KiB
Scheme
Executable file
#!/usr/bin/csi -s
|
|
|
|
(import
|
|
(chicken file)
|
|
(chicken format)
|
|
(chicken io)
|
|
(chicken pathname)
|
|
(chicken port)
|
|
(chicken process)
|
|
(chicken process-context)
|
|
(chicken string)
|
|
(clojurian syntax)
|
|
ersatz
|
|
lowdown
|
|
scss
|
|
srfi-1 ;; list utils
|
|
srfi-13 ;; string utils
|
|
srfi-14 ;; charsets
|
|
sxml-transforms
|
|
symbol-utils ;; (unspecified-value)
|
|
utf8
|
|
)
|
|
|
|
(define CLONE-URL (or (get-environment-variable "REPO2HTML_CLONE_URL") "git://git.example.com"))
|
|
(define TITLE (or (get-environment-variable "REPO2HTML_TITLE") "git.example.com"))
|
|
(define DESCRIPTION (or (get-environment-variable "REPO2HTML_DESCRIPTION") "my git repositories"))
|
|
(define H1 (or (get-environment-variable "REPO2HTML_H1") "git.example.com"))
|
|
|
|
;; small utilities ---------------------------------
|
|
|
|
;; (bail [message [exit-status]])
|
|
;; end the program immediately.
|
|
;; if a message is provided, print it to the screen.
|
|
;; exit-status defaults to 1.
|
|
(define (bail #!optional msg (status 1))
|
|
(when msg (print msg))
|
|
(exit status))
|
|
|
|
;; decompose a path s into its constituent parts. returns values:
|
|
;;
|
|
;; root: "/" if it's an absolute path, "" if relative directory-elements: a list
|
|
;; of each directory from root, () if none basename: the filename with extension
|
|
;; removed like "readme" or ".bashrc" extension: the file extension with the
|
|
;; dot, like ".txt" or "" if none relative-root: the relative path from the
|
|
;; given path to the root
|
|
;; e.g foo/bar/baz.html -> ../../
|
|
;;
|
|
;; this is intended to provide default values that make for easier reassembly
|
|
;; into filenames.
|
|
;;
|
|
;; typical use:
|
|
;; (->> source-file
|
|
;; (pathparts)
|
|
;; (define-values (root elements basename extension relative-root)))
|
|
;;
|
|
(define (pathparts s)
|
|
(define-values (dirname basename extension)
|
|
(decompose-pathname s))
|
|
(define-values (origin root directory-elements)
|
|
(decompose-directory (or dirname "")))
|
|
;; discarding origin because idgaf about windows
|
|
(values (or root "")
|
|
(or directory-elements '())
|
|
basename
|
|
(if extension (string-append "." extension) "")
|
|
(->>
|
|
(or directory-elements '())
|
|
(map (constantly "../"))
|
|
(apply string-append))))
|
|
|
|
;; like (substring) but doesn't break if start and end are too big/small
|
|
(define (substring* s start end)
|
|
(substring s (max start 0) (min end (string-length s))))
|
|
|
|
;; merge alists a and b. values in b "win"
|
|
(define (alist-merge a b)
|
|
(lset-union (lambda (x y) (eq? (car x) (car y))) a b))
|
|
|
|
;; auto-apply ids to headings ---------------------------------
|
|
|
|
(define (slugify _ inner)
|
|
(->
|
|
inner
|
|
(pre-post-order*
|
|
`((*text* .
|
|
,(lambda (_ str)
|
|
(if (string? str)
|
|
(->
|
|
str
|
|
(string-downcase)
|
|
(string-translate "/,:;\"[]{}()=+")
|
|
(string-translate " _." "---"))
|
|
str)))
|
|
,@alist-conv-rules*))
|
|
(flatten)
|
|
((flip map) ->string)
|
|
(string-intersperse "")
|
|
(substring* 0 40)))
|
|
|
|
(define (enumerate-tag tag inner)
|
|
`(,tag (@ (id ,tag "-" ,(slugify tag inner))) ,inner))
|
|
|
|
(define sxml-html-rules
|
|
`(;; assign all headings an id so you can link to them
|
|
(h1 . ,enumerate-tag)
|
|
(h2 . ,enumerate-tag)
|
|
(h3 . ,enumerate-tag)
|
|
(h4 . ,enumerate-tag)
|
|
(h5 . ,enumerate-tag)
|
|
;; this copied from lowdown html-serialization-rules* because it
|
|
;; is for some reason not exported??
|
|
(*COMMENT* . ,(lambda (_ str) (list #\< "!--" str "--" #\>)))
|
|
;; ignore #<unspecified> in tree
|
|
(*text* . ,(lambda (_ str) (if (unspecified? str) "" str)))
|
|
,@alist-conv-rules*))
|
|
|
|
;; reading in data from git commands
|
|
|
|
(define (in-git-directory?)
|
|
(not (eof-object? (call-with-input-pipe "git rev-parse --git-dir" read-line))))
|
|
|
|
(define (git-file-is-text? source-file)
|
|
(not (equal?
|
|
"-\t-\t"
|
|
(call-with-input-pipe
|
|
(string-append "git diff 4b825dc642cb6eb9a060e54bf8d69288fbee4904 --numstat HEAD -- " source-file)
|
|
(lambda (port) (read-line port 4))))))
|
|
|
|
(define (git-repository->paths-list)
|
|
(call-with-input-pipe "git ls-tree -r --name-only HEAD" read-lines))
|
|
|
|
(define (git-file->string source-file)
|
|
(->
|
|
(format "git show HEAD:~a" source-file)
|
|
(call-with-input-pipe read-lines)
|
|
(string-intersperse "\n")))
|
|
|
|
;; sxml generators for constructed pages
|
|
|
|
(define (source->sxml source-file) ;; src/main.scm
|
|
(define-values (_ _ basename extension _)
|
|
(pathparts source-file))
|
|
(define (image-link)
|
|
`(p (img (@ src ,basename ,extension))))
|
|
(define (plaintext)
|
|
`(pre ,(git-file->string source-file)))
|
|
(define (binary)
|
|
'(p "(Binary file)"))
|
|
`((p (@ id "file-path") ,source-file)
|
|
,(case (string->symbol extension)
|
|
((.md .markdown)
|
|
(handle-exceptions exn
|
|
(begin
|
|
(format (current-error-port) "Error parsing ~a\n" source-file)
|
|
`((p (b "There was an error parsing this file as Markdown."))
|
|
,(plaintext)))
|
|
(markdown->sxml (git-file->string source-file))))
|
|
((.jpg .jpeg .png .gif .webp .webm .apng .avif .svgz .ico)
|
|
(image-link))
|
|
((.svg)
|
|
(list (image-link) (plaintext)))
|
|
((.gz .pack .idx)
|
|
(binary))
|
|
(else
|
|
(if (git-file-is-text? source-file)
|
|
(plaintext)
|
|
(binary))))))
|
|
|
|
(define (filelist->sxml source-files-list)
|
|
`((h1 "Files")
|
|
((ul
|
|
,(map
|
|
(lambda (source-file)
|
|
`(li (a (@ href ,source-file ".html") ,source-file)))
|
|
source-files-list)))))
|
|
|
|
(define (commits->sxml)
|
|
`((h1 "Commits")
|
|
(table
|
|
(tr (th "Date") (th "Ref") (th "Log") (th "Author"))
|
|
,(map
|
|
(lambda (line)
|
|
(let-values (((date ref title author) (apply values (string-split line "\t"))))
|
|
`(tr (td ,date) (td ,ref) (td ,title) (td ,author))))
|
|
(call-with-input-pipe "git log --format=format:%as%x09%h%x09%s%x09%aN HEAD" read-lines)))))
|
|
|
|
(define (contributors->sxml)
|
|
`((h1 "Contributors")
|
|
(table
|
|
(tr (th "Author") (th "Commits"))
|
|
,(map
|
|
(lambda (line)
|
|
(let-values (((commits author) (apply values (string-split line "\t"))))
|
|
`(tr (td ,author) (td ,commits))))
|
|
(call-with-input-pipe "git shortlog -ns HEAD" read-lines)))))
|
|
|
|
(define (issueslist->sxml source-files-list)
|
|
`((h1 "Issues")
|
|
((ul
|
|
,(filter-map
|
|
(lambda (source-file)
|
|
(and
|
|
(string-prefix? "ISSUES/" source-file)
|
|
`(li (a (@ href ,source-file ".html")
|
|
,(->
|
|
source-file
|
|
((flip format) "git show HEAD:~a")
|
|
(call-with-input-pipe read-line)
|
|
(string-trim (string->char-set "# ")))))))
|
|
source-files-list)))))
|
|
|
|
;; used by ersatz writer
|
|
(define (alist->tvals vars)
|
|
(map (lambda (pair)
|
|
`(,(car pair) . ,(sexpr->tvalue (cdr pair)))) vars))
|
|
|
|
;; this version uses a jinja-style template via ersatz
|
|
(define (make-template-writer-ersatz templates-directory #!optional vars)
|
|
(define template (statements-from-file (template-std-env search-path: (list templates-directory)) "default.html"))
|
|
(lambda (output-filename body-sxml #!optional newvars)
|
|
;; create destination directory if needed
|
|
(if-let (destination-directory (pathname-directory output-filename))
|
|
(create-directory destination-directory #t)
|
|
'())
|
|
|
|
(let* (;; render the sxml to a html string that we can hand to the template
|
|
(body-html
|
|
(with-output-to-string
|
|
(lambda ()
|
|
(SXML->HTML (pre-post-order* body-sxml sxml-html-rules)))))
|
|
;; vars = global vars + file-specific vars + body k/v pair
|
|
(vars
|
|
(alist-cons
|
|
'content body-html
|
|
(alist-merge vars (or newvars '())))))
|
|
|
|
(with-output-to-file output-filename
|
|
(lambda ()
|
|
(display (eval-statements template models: (alist->tvals vars))))))))
|
|
|
|
;; main program ------------------------------------------------------------------------------
|
|
|
|
(define (generate-html-files html-repo-path templates-directory)
|
|
(let* ((source-files-list (git-repository->paths-list))
|
|
(repository-name (pathname-strip-directory (string-chomp html-repo-path "/")))
|
|
(template-alist `(;; variables provided to template at all times
|
|
(source_files_list . ,source-files-list)
|
|
(clone_url_prefix . ,CLONE-URL)
|
|
(forge_title . ,TITLE)
|
|
(h1 . ,H1)
|
|
(repository_description . ,DESCRIPTION)
|
|
(repository_name . ,repository-name)
|
|
(readme_file
|
|
. ,(find (lambda (x) (member x source-files-list))
|
|
'("README" "README.md" "README.txt")))
|
|
(license_file
|
|
. ,(find (lambda (x) (member x source-files-list))
|
|
'("LICENSE" "LICENSE.md" "LICENSE.txt")))
|
|
(issues_file
|
|
. ,(and (find (lambda (x) (string-prefix? "ISSUES/" x)) source-files-list) "ISSUES"))
|
|
))
|
|
(write-with-template
|
|
(make-template-writer-ersatz templates-directory template-alist)))
|
|
|
|
(create-directory html-repo-path #t)
|
|
;; special files
|
|
(write-with-template (make-pathname html-repo-path "files" "html") (filelist->sxml source-files-list))
|
|
(write-with-template (make-pathname html-repo-path "contributors" "html") (contributors->sxml))
|
|
(write-with-template (make-pathname html-repo-path "commits" "html") (commits->sxml))
|
|
;; htmlified repo contents
|
|
(for-each
|
|
(lambda (source-file)
|
|
(->> source-file
|
|
(pathparts)
|
|
(define-values (root elements basename extension relative-root)))
|
|
(write-with-template
|
|
(make-pathname html-repo-path source-file "html")
|
|
(source->sxml source-file)
|
|
`(;; additional per-page variables provided to template
|
|
(source_file . ,source-file)
|
|
(root . ,root)
|
|
(elements . ,elements)
|
|
(basename . ,basename)
|
|
(extension . ,extension)
|
|
(relative_root . ,relative-root)
|
|
))
|
|
;; if it's an image also copy it verbatim to output directory
|
|
(case (string->symbol (or (pathname-extension source-file) ""))
|
|
((jpg jpeg png gif webp webm svg apng avif svgz ico)
|
|
(system (format "git show HEAD:~a > ~a"
|
|
source-file
|
|
(make-pathname html-repo-path source-file))))))
|
|
source-files-list)
|
|
;; if (the output version of) README.md, README, or README.txt exists, copy
|
|
;; that to index.html. otherwise copy files.html to index.html.
|
|
(->>
|
|
'("README.md" "README" "README.txt" "files")
|
|
(map (lambda (x) (make-pathname html-repo-path x "html")))
|
|
(find file-exists?)
|
|
((lambda (x) (copy-file x (make-pathname html-repo-path "index" "html") #t))))
|
|
;; if the ISSUES directory got created, write out an index file for the
|
|
;; stuff in there.
|
|
(when (file-exists? (make-pathname html-repo-path "ISSUES"))
|
|
(write-with-template (make-pathname html-repo-path "ISSUES" "html") (issueslist->sxml source-files-list)))))
|
|
|
|
(define (main #!optional html-repo-path templates-directory)
|
|
|
|
(unless html-repo-path
|
|
(bail "please specify a destination directory for html files"))
|
|
|
|
(unless (in-git-directory?)
|
|
(bail "woops this isn't a git directory"))
|
|
|
|
(unless templates-directory
|
|
(bail "please specify the directory containing the templates.\nnote: built-in sxml templates have been removed."))
|
|
|
|
(generate-html-files html-repo-path templates-directory))
|
|
|
|
(apply main (command-line-arguments))
|