50bbb3686d
i started this off by trying to learn more about how scheme does file
i/o. it seems like many of its functions just expect you'll want them to
write to (current-output-port) instead of returning a string. so i
thought, i wonder what it would look like if i tweak these content
generator functions to just (display) their stuff, and
call (with-output-to-file) and apply the html template each time i call
them?
and whew it kindof got away from me
i totally understand if you feel like this is an unpleasant overhaul of
your whole project and don't want to merge this change!
anyway let's see if i can summarize the changes:
- image support!!
- svg image support!! it shows both the svg and its source code!
- markdown support; we now render all .md files instead of showing source
- using string->goodHTML instead of clean-html. turns out, it's a little
annoying, in that it only returns a string if it makes no changes, but
if it does, it returns a list of strings. it expects to be passed to
one of the other functions in the sxml library, so that's what i do.
- moved "wrap the template" outside of various "generate content"
functions
- simple command line use: from any git work-tree OR bare repo, run
repo2html /path/to/www/output/repo-foo-bar and it will create that
directory and use "repo-foo-bar" as the repo name.
- made our example post-receive a bit more robust
- changed env var names to have REPO2HTML_ prefix
- better repo name detection and automatic caching of it in git config
- moved the post-receive-specific logic to avoid generating if we're
not updating HEAD into the post-receive hook itself, along with some
status messages
- checked directory permissions in the hook so it doesn't even attempt
to run repo2html and avoids a crash
174 lines
5.2 KiB
Scheme
Executable file
174 lines
5.2 KiB
Scheme
Executable file
#!/usr/bin/csi -ss
|
|
|
|
(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 WEB-DIRECTORY (or (get-environment-variable "GIT_WWW") "/var/www/git"))
|
|
(define CLONE-URL (or (get-environment-variable "GIT_WWW_CLONE_URL") "git://git.example.com"))
|
|
(define TITLE (or (get-environment-variable "GIT_WWW_TITLE") "my git repositories"))
|
|
(define DESCRIPTION (or (get-environment-variable "GIT_WWW_DESCRIPTION") "my git repositories"))
|
|
(define H1 (or (get-environment-variable "GIT_WWW_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))
|