#!/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 #{TITLE}

#{H1}

#{REPOSITORY-NAME}

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

#{body} 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 "
  • ~a
    • \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) ;; //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-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 "
      \n" (generate-list-of-files source-files-list) "
    \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))