massive changes incl. support for images, markdown
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
This commit is contained in:
pho4cexa
m455
parent
1a3b8b1aa1
commit
50bbb3686d
2 changed files with 136 additions and 103 deletions
183
main.scm
183
main.scm
|
|
@ -11,6 +11,7 @@
|
|||
(chicken pathname)
|
||||
(chicken file)
|
||||
sxml-transforms
|
||||
(clojurian syntax)
|
||||
)
|
||||
|
||||
(define WEB-DIRECTORY (or (get-environment-variable "GIT_WWW") "/var/www/git"))
|
||||
|
|
@ -19,11 +20,8 @@
|
|||
(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
|
||||
(define (populate-html-template repo-name display-body-thunk)
|
||||
(display #<#string-block
|
||||
<!DOCTYPE html>
|
||||
<html lang="en">
|
||||
<head>
|
||||
|
|
@ -59,127 +57,118 @@ hr {
|
|||
</head>
|
||||
<body>
|
||||
<h1>#{H1}</h1>
|
||||
<h2>#{REPOSITORY-NAME}</h2>
|
||||
<p>clone url: #{CLONE-URL}/#{REPOSITORY-NAME}</p>
|
||||
<h2>#{repo-name}</h2>
|
||||
<p>clone url: #{CLONE-URL}/#{repo-name}</p>
|
||||
<nav>
|
||||
<a href="/#{REPOSITORY-NAME}/index.html">about</a>
|
||||
<a href="/#{REPOSITORY-NAME}/files.html">files</a>
|
||||
<a href="/#{REPOSITORY-NAME}/contributors.html">contributors</a>
|
||||
<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>
|
||||
#{body}
|
||||
string-block
|
||||
)
|
||||
(display-body-thunk)
|
||||
(display #<#string-block
|
||||
</body>
|
||||
</html>
|
||||
string-block
|
||||
)
|
||||
))
|
||||
|
||||
(define (write-file file contents)
|
||||
(call-with-output-file file (lambda (port) (write-line contents port))))
|
||||
(define (display-escaped-html str)
|
||||
(SRV:send-reply (string->goodHTML str)))
|
||||
|
||||
(define (in-git-directory?)
|
||||
(equal? (call-with-input-pipe "git rev-parse --is-bare-repository 2> /dev/null" read-line) "true"))
|
||||
(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)
|
||||
(string-intersperse
|
||||
(call-with-input-pipe (format "git show HEAD:~a" path) read-lines)
|
||||
"\n"))
|
||||
(->
|
||||
(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 (clean-html str)
|
||||
(string-translate* str '(("&" . "&")
|
||||
("<" . "<")
|
||||
(">" . ">")
|
||||
("\"" . """)
|
||||
("'" . "'"))))
|
||||
(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 (md->html markdown-string)
|
||||
(with-output-to-string
|
||||
(lambda ()
|
||||
(markdown->html markdown-string))))
|
||||
(define (display-readme-html)
|
||||
(markdown->html (git-file->string "README.md")))
|
||||
|
||||
(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 (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-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-html-files html-repo-path)
|
||||
(let ((source-files-list (git-repository->paths-list))
|
||||
(repository-name (pathname-strip-directory html-repo-path)))
|
||||
|
||||
(define (generate-source-files source-files-list)
|
||||
(for-each (lambda (source-file) (generate-source-file source-file))
|
||||
source-files-list))
|
||||
(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))))
|
||||
|
||||
(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"))))
|
||||
(create-directory html-repo-path #t)
|
||||
|
||||
(define (generate-readme-page index-page-path)
|
||||
(write-file
|
||||
index-page-path
|
||||
(populate-html-template (md->html (git-file->string "README.md")))))
|
||||
|
||||
(define (generate-contributors-html)
|
||||
(populate-html-template
|
||||
(with-output-to-string
|
||||
(lambda ()
|
||||
(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-repository-directory)
|
||||
(when (directory-exists? REPOSITORY-DIRECTORY)
|
||||
(delete-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)
|
||||
(write-file (make-pathname REPOSITORY-DIRECTORY "contributors.html") (generate-contributors-html))
|
||||
(generate-source-files source-files-list)))
|
||||
(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)))
|
||||
(unless (equal? "" msg) (print msg))
|
||||
(exit status)))
|
||||
|
||||
(define (main args)
|
||||
(let-optionals args ((html-repo-path '()))
|
||||
|
||||
(unless (null? args)
|
||||
(bail 1 "woops, i dont take args"))
|
||||
(when (null? html-repo-path)
|
||||
(bail 1 "please specify a destination directory for html files"))
|
||||
|
||||
(unless (in-git-directory?)
|
||||
(bail 1 "woops that's not a bare git directory"))
|
||||
(unless (in-git-directory?)
|
||||
(bail 1 "woops this isn't a git directory"))
|
||||
|
||||
(generate-html-files))
|
||||
(generate-html-files html-repo-path)))
|
||||
|
||||
(main (command-line-arguments))
|
||||
|
|
|
|||
56
post-receive
Normal file → Executable file
56
post-receive
Normal file → Executable file
|
|
@ -3,9 +3,53 @@
|
|||
# - place this file in the 'hooks' directory of a bare git repository
|
||||
# - this assumes that repo2html is in your path
|
||||
|
||||
export GIT_WWW=/var/www/git/
|
||||
export GIT_WWW_CLONE_URL=git://git.example.com
|
||||
export GIT_WWW_TITLE=git.example.com
|
||||
export GIT_WWW_DESCRIPTION="sherry's git repositories"
|
||||
export GIT_WWW_H1=git.example.com
|
||||
repo2html
|
||||
# The toplevel path containing directories of static pages
|
||||
[ "$REPO2HTML_PREFIX" ] || export REPO2HTML_PREFIX=/var/www/git
|
||||
# The toplevel clone url for repos.
|
||||
export REPO2HTML_CLONE_URL=git://git.example.com
|
||||
export REPO2HTML_TITLE=git.example.com
|
||||
export REPO2HTML_DESCRIPTION="sherry's git repositories"
|
||||
export REPO2HTML_H1=git.example.com
|
||||
|
||||
# hueristic attempt to detect a reasonable default for the name of this repo
|
||||
# you may want to adjust this if you have e.g. sub-directories containing repos
|
||||
# whose structure you want to preserve on the webserver.
|
||||
if repo_name="$(git config repo2html.dirname)"; then
|
||||
: # repo name from git config; do nothing else
|
||||
elif [ "$(git rev-parse --is-bare-repository)" = "true" ]; then
|
||||
# bare /foo/bar/baz/myrepo.git -> myrepo
|
||||
repo_name="$(basename "$(pwd)" .git)"
|
||||
git config repo2html.dirname "$repo_name"
|
||||
else
|
||||
# /foo/bar/baz/myrepo/.git -> myrepo
|
||||
repo_name="$(basename "$(dirname "$(pwd)")")"
|
||||
git config repo2html.dirname "$repo_name"
|
||||
fi
|
||||
|
||||
# only generate if default branch is modified
|
||||
headref="$(git symbolic-ref -q HEAD)"
|
||||
while read -r _ _ ref
|
||||
do [ "$ref" = "$headref" ] && go=1
|
||||
done
|
||||
if [ "$go" ]; then
|
||||
echo "$headref was updated; regenerating HTML at: $REPO2HTML_PREFIX/$repo_name"
|
||||
else
|
||||
echo "($headref was not updated so HTML will not be regenerated.)"
|
||||
exit 0
|
||||
fi
|
||||
|
||||
# check to see if we can even write to the specified directory
|
||||
if mkdir -p "$REPO2HTML_PREFIX/$repo_name" && \
|
||||
[ -x "$REPO2HTML_PREFIX/$repo_name" ] && \
|
||||
[ -w "$REPO2HTML_PREFIX/$repo_name" ]
|
||||
then
|
||||
: # we can write to the directory; seems good
|
||||
else
|
||||
echo "Error: can't generate HTML due to insufficient permissions on path:"
|
||||
echo " $REPO2HTML_PREFIX/$repo_name"
|
||||
echo "Set REPO2HTML_PREFIX in the environment or this script:"
|
||||
echo " $0"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
repo2html "$REPO2HTML_PREFIX/$repo_name"
|
||||
|
|
|
|||
Loading…
Reference in a new issue