b3719a005d
post-receive commit hooks receive on standard input lines of the form: old-commit new-commit ref old-commit new-commit ref old-commit new-commit ref so we can inspect those lines to determine whether or not the current branch (aka HEAD) has been changed. because there's no reason to rebuild the html representation of other branches. in future we might even use the git tree-diff between old-commit and new-commit to determine the set of files that have been added, removed, or changed, and regenerate the html representation for only those files, instead of deleting and rebuilding all files every time.
184 lines
6.2 KiB
Scheme
184 lines
6.2 KiB
Scheme
#!/usr/bin/csi -ss
|
|
|
|
(import utf8
|
|
lowdown
|
|
(chicken string)
|
|
(chicken port)
|
|
(chicken io)
|
|
(chicken process)
|
|
(chicken process-context)
|
|
(chicken format)
|
|
(chicken pathname)
|
|
(chicken file))
|
|
|
|
(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 REPOSITORY-NAME (pathname-strip-directory (current-directory)))
|
|
(define REPOSITORY-DIRECTORY (make-pathname WEB-DIRECTORY REPOSITORY-NAME))
|
|
|
|
(define (populate-html-template body)
|
|
#<#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>#{REPOSITORY-NAME}</h2>
|
|
<p>clone url: #{CLONE-URL}/#{REPOSITORY-NAME}</p>
|
|
<nav>
|
|
<a href="/#{REPOSITORY-NAME}/index.html">about</a>
|
|
<a href="/#{REPOSITORY-NAME}/files.html">files</a>
|
|
</nav>
|
|
<hr>
|
|
#{body}
|
|
</body>
|
|
</html>
|
|
string-block
|
|
)
|
|
|
|
(define (write-file file contents)
|
|
(with-output-to-file file (lambda () (display contents))))
|
|
|
|
(define (in-git-directory?)
|
|
(equal? (call-with-input-pipe "git rev-parse --is-bare-repository 2> /dev/null" read-line) "true"))
|
|
|
|
(define (git-repository->paths-list)
|
|
(call-with-input-pipe "git ls-tree -r --name-only HEAD" read-lines))
|
|
|
|
(define (git-file->string path)
|
|
(string-intersperse
|
|
(call-with-input-pipe (format "git show HEAD:~a" path) read-lines)
|
|
"\n"))
|
|
|
|
|
|
(define (clean-html str)
|
|
(string-translate* str '(("&" . "&")
|
|
("<" . "<")
|
|
(">" . ">")
|
|
("\"" . """)
|
|
("'" . "'"))))
|
|
|
|
(define (md->html markdown-string)
|
|
(with-output-to-string
|
|
(lambda ()
|
|
(markdown->html markdown-string))))
|
|
|
|
(define (generate-list-of-files source-files-list)
|
|
(if (null? source-files-list)
|
|
""
|
|
(let* ((source-file (car source-files-list))
|
|
(link-url (string-append source-file ".html"))) ;; src/main.scm.html
|
|
(string-append (format "<li><a href=\"~a\">~a</a></li>\n" link-url source-file)
|
|
(generate-list-of-files (cdr source-files-list))))))
|
|
|
|
(define (generate-source-file source-file) ;; src/main.scm
|
|
(let* ((source-file-directory (pathname-directory source-file)) ;; src or #f
|
|
(output-directory (if source-file-directory
|
|
(make-pathname REPOSITORY-DIRECTORY source-file-directory) ;; <WEB-DIRECTORY>/<repository-name>/src
|
|
REPOSITORY-DIRECTORY))) ;; <WEB-DIRECTORY>/<repository-name>
|
|
;; create directories that mimic the path of the source file, so when
|
|
;; someone clicks a link to view the contents of a source file, the URL
|
|
;; matches up with the path of the source file.
|
|
;; i guess another reason to do this is to avoid conflicts with files that
|
|
;; have the same name, but exist in different directories.
|
|
(create-directory output-directory #t)
|
|
(write-file
|
|
(make-pathname output-directory (pathname-strip-directory source-file) "html")
|
|
(populate-html-template (string-append "<p id=\"file-path\">" source-file "</p>"
|
|
"<pre>\n"
|
|
(clean-html (git-file->string source-file))
|
|
"</pre>")))))
|
|
|
|
(define (generate-source-files source-files-list)
|
|
(for-each (lambda (source-file) (generate-source-file source-file))
|
|
source-files-list))
|
|
|
|
(define (generate-files-page files-list-page-path source-files-list)
|
|
(write-file
|
|
files-list-page-path
|
|
(populate-html-template (string-append "<ul>\n"
|
|
(generate-list-of-files source-files-list)
|
|
"</ul>\n"))))
|
|
|
|
(define (generate-readme-page index-page-path)
|
|
(write-file
|
|
index-page-path
|
|
(populate-html-template (md->html (git-file->string "README.md")))))
|
|
|
|
(define (generate-repository-directory)
|
|
(if (directory-exists? REPOSITORY-DIRECTORY)
|
|
(begin (delete-directory REPOSITORY-DIRECTORY #t)
|
|
(create-directory REPOSITORY-DIRECTORY #t))
|
|
(create-directory REPOSITORY-DIRECTORY #t)))
|
|
|
|
(define (generate-html-files)
|
|
(let ((source-files-list (git-repository->paths-list)))
|
|
(generate-repository-directory)
|
|
(generate-readme-page (make-pathname REPOSITORY-DIRECTORY "index.html"))
|
|
(generate-files-page (make-pathname REPOSITORY-DIRECTORY "files.html") source-files-list)
|
|
(generate-source-files source-files-list)))
|
|
|
|
(define (bail . args)
|
|
(let-optionals args ((status 1) (msg ""))
|
|
(unless (equal? "" msg) (print msg))
|
|
(exit status)))
|
|
|
|
(define (main args)
|
|
|
|
(unless (null? args)
|
|
(bail 1 "woops, i dont take args"))
|
|
|
|
(unless (in-git-directory?)
|
|
(bail 1 "woops that's not a bare git directory"))
|
|
|
|
(let ((head-ref (call-with-input-pipe "git symbolic-ref -q HEAD" read-line)))
|
|
|
|
(when (null? head-ref)
|
|
(bail 1 "no HEAD reference is set"))
|
|
|
|
;; loop over the changed refs
|
|
;; if the HEAD ref is changed, generate html for it
|
|
((flip for-each)
|
|
(read-lines)
|
|
(lambda (line)
|
|
;; isn't there a better way to destructure a list?
|
|
;; egg 'matchable' has match-let
|
|
(let-values (((before after ref) (apply values (string-split line))))
|
|
(when (equal? ref head-ref)
|
|
(generate-html-files)))))))
|
|
|
|
(main (command-line-arguments))
|