repo2html/main.scm
pho4cexa 66f1105deb don't call (main) twice when running uncompiled
this set of patches gets repo2html working for me running as cli, both compiled
and not, for fa! there was one markdown file in fa that lowdown throws an error
about, i haven't investigated further. but i catch the error and render as
plaintext instead.

i haven't re-tested running as githook for pushing to fa and other repos yet.
2022-12-07 21:10:07 -05:00

173 lines
5.2 KiB
Scheme
Executable file

#!/usr/bin/csi -s
(import utf8
lowdown
(chicken string)
(chicken port)
(chicken io)
(chicken process)
(chicken process-context)
(chicken format)
(chicken pathname)
(chicken file)
sxml-transforms
(clojurian syntax)
)
(define CLONE-URL (or (get-environment-variable "REPO2HTML_CLONE_URL") "git://git.example.com"))
(define TITLE (or (get-environment-variable "REPO2HTML_TITLE") "my git repositories"))
(define DESCRIPTION (or (get-environment-variable "REPO2HTML_DESCRIPTION") "my git repositories"))
(define H1 (or (get-environment-variable "REPO2HTML_H1") "git.example.com"))
(define (populate-html-template repo-name display-body-thunk)
(display #<#string-block
<!DOCTYPE html>
<html lang="en">
<head>
<title>#{TITLE}</title>
<meta charset="utf-8" />
<meta name="viewport" content="width=device-width, initial-scale=1.0, user-scalable=yes" />
<link rel="icon" href="data:,">
<meta name="description" content="#{DESCRIPTION}"/>
<style>
body {
margin: 0 auto;
max-width: 700px;
}
pre, code {
background-color: ##ffd9df;
}
pre {
padding: 15px 20px;
white-space: pre;
overflow: scroll;
}
a { color: blue; }
nav a { margin-right: 10px; }
hr {
border:0;
border-bottom: 1px solid black;
margin-top: 16px;
}
##file-path {
/* change this to your liking */
}
</style>
</head>
<body>
<h1>#{H1}</h1>
<h2>#{repo-name}</h2>
<p>clone url: #{CLONE-URL}/#{repo-name}</p>
<nav>
<a href="/#{repo-name}/index.html">about</a>
<a href="/#{repo-name}/files.html">files</a>
<a href="/#{repo-name}/contributors.html">contributors</a>
</nav>
<hr>
string-block
)
(display-body-thunk)
(display #<#string-block
</body>
</html>
string-block
))
(define (display-escaped-html str)
(SRV:send-reply (string->goodHTML str)))
(define (in-git-directory?)
(not (eof-object? (call-with-input-pipe "git rev-parse --git-dir" read-line))))
(define (git-repository->paths-list)
(call-with-input-pipe "git ls-tree -r --name-only HEAD" read-lines))
(define (git-file->string path)
(->
(format "git show HEAD:~a" path)
(call-with-input-pipe read-lines)
(string-intersperse "\n")))
(define (display-source-html source-file) ;; src/main.scm
(format #t "<p id=\"file-path\">~a</p>" source-file)
(case (string->symbol (or (pathname-extension source-file) ""))
((md markdown)
(markdown->html (git-file->string source-file)))
((jpg jpeg png gif webp webm apng avif svgz ico)
(format #t "<p><img src=\"~a\" /></p>" source-file)
)
((svg)
(format #t "<p><img src=\"~a\" /></p>" source-file)
(display "<pre>")
(display-escaped-html (git-file->string source-file))
(display "</pre>"))
(else
(display "<pre>")
(display-escaped-html (git-file->string source-file))
(display "</pre>"))))
(define (display-files-html source-files-list)
(display "<ul>\n")
(for-each
(lambda (source-file)
(format #t "<li><a href=\"~a.html\">~a</a></li>\n" source-file source-file))
source-files-list)
(display "</ul>\n"))
(define (display-readme-html)
(markdown->html (git-file->string "README.md")))
(define (display-contributors-html)
(SXML->HTML
`((h1 "Contributors")
(ul ,(map
(lambda (line)
(let-values (((commits . author) (apply values (string-split line "\t"))))
`(li ,author)))
(call-with-input-pipe "git shortlog -ns HEAD" read-lines))))))
(define (generate-html-files html-repo-path)
(let ((source-files-list (git-repository->paths-list))
(repository-name (pathname-strip-directory html-repo-path)))
(define (write-with-template filename display-body-thunk)
(let ((destination-directory (pathname-directory filename)))
(when destination-directory (create-directory pathname-directory #t)))
(with-output-to-file (make-pathname html-repo-path filename)
(lambda () (populate-html-template repository-name display-body-thunk))))
(create-directory html-repo-path #t)
(write-with-template "index.html" (lambda () (display-readme-html)))
(write-with-template "files.html" (lambda () (display-files-html source-files-list)))
(write-with-template "contributors.html" (lambda () (display-contributors-html)))
(for-each
(lambda (source-file)
(write-with-template
(string-append source-file ".html")
(lambda () (display-source-html source-file)))
(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)))
(define (bail . args)
(let-optionals args ((status 1) (msg ""))
(unless (equal? "" msg) (print msg))
(exit status)))
(define (main args)
(let-optionals args ((html-repo-path '()))
(when (null? html-repo-path)
(bail 1 "please specify a destination directory for html files"))
(unless (in-git-directory?)
(bail 1 "woops this isn't a git directory"))
(generate-html-files html-repo-path)))
(main (command-line-arguments))