diff --git a/main.scm b/main.scm index 08566af..7612927 100755 --- a/main.scm +++ b/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 @@ -59,127 +57,118 @@ hr {

#{H1}

-

#{REPOSITORY-NAME}

-

clone url: #{CLONE-URL}/#{REPOSITORY-NAME}

+

#{repo-name}

+

clone url: #{CLONE-URL}/#{repo-name}

-#{body} +string-block +) + (display-body-thunk) + (display #<#string-block 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 "

~a

" 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 "

" source-file) + ) + ((svg) + (format #t "

" source-file) + (display "
")
+     (display-escaped-html (git-file->string source-file))
+     (display "
")) + (else + (display "
")
+     (display-escaped-html (git-file->string source-file))
+     (display "
")))) -(define (clean-html str) - (string-translate* str '(("&" . "&") - ("<" . "<") - (">" . ">") - ("\"" . """) - ("'" . "'")))) +(define (display-files-html source-files-list) + (display "\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 "
  • ~a
    • \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) ;; //src - REPOSITORY-DIRECTORY))) ;; / - ;; 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 "

    " source-file "

    " - "
    \n"
-                                             (clean-html (git-file->string source-file))
-                                             "
    "))))) +(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 "
      \n" - (generate-list-of-files source-files-list) - "
    \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)) diff --git a/post-receive b/post-receive old mode 100644 new mode 100755 index f07d1b9..e400f5e --- a/post-receive +++ b/post-receive @@ -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"