#!/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
#{TITLE}
#{H1}
#{repo-name}
clone url: #{CLONE-URL}/#{repo-name}
string-block
)
(display-body-thunk)
(display #<#string-block
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 "~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 "![](\"~a\")
" 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 (display-files-html source-files-list)
(display "\n")
(for-each
(lambda (source-file)
(format #t "- ~a
\n" source-file source-file))
source-files-list)
(display "
\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))