;; Script to browse locally-hosted URLs ;; ;; To use, replace the strings git-base-url and git-base-dir ;; with the values appropriate to your system. Your git ;; repository REPO should then be reachable at the selector ;; browse-git.scm|REPO. ;; ;; You may optionally include a file named project-description ;; in each repository, which will be displayed at the top ;; of the page when the repository tree is served. (lambda (repo . args) (let ((branch (if (< (length args) 1) "master" (list-ref args 0))) (path (if (< (length args) 2) "." (list-ref args 1))) (type-str (if (< (length args) 3) "tree" (list-ref args 2)))) (import (chicken string) (chicken process) (chicken io) (chicken pathname) (chicken file) srfi-13) (define git-base-url "git://MY.GIT.SERVER/") (define git-base-dir "/path/to/git/repositories/") (define (git . args) (let ((repo-pathname (make-pathname git-base-dir repo))) (if (not (string-prefix? git-base-dir (normalize-pathname repo-pathname))) (error "Invalid git repository.")) (with-current-working-directory repo-pathname (lambda () (let-values (((in-port out-port id) (process "git" args))) (let ((result (read-lines in-port))) (close-input-port in-port) (close-output-port out-port) result)))))) (define (serve-tree) (let ((entries (git "ls-tree" branch path)) (references (git "show-ref" "--heads")) (commits (git "rev-list" "--abbrev-commit" "-n5" branch))) (append (list (conc "Git repository " git-base-url repo) "") (let ((descr-file (make-pathname git-base-dir (make-pathname repo "project-description")))) (if (file-exists? descr-file) (list "----= Description =----" (with-input-from-file descr-file read-string) "") '())) (list "-----= Branches =-----") (map (lambda (ref) (let ((refname (caddr (string-split ref "/")))) (list 1 (conc (if (equal? branch refname) "*" "") refname) (conc "browse-git.scm|" repo "|" refname "|" path "|tree")))) references) (list "" (conc "-----= Recent Commits [" branch "] =-----")) (map (lambda (commit) (list 1 (conc (if (equal? branch commit) "*" "") (car (git "show" "-s" "--format=%s (%ar)" commit))) (conc "browse-git.scm|" repo "|" commit "|" path "|tree"))) commits) (list "" (conc "-----= Files [" path "] =-----")) (map (lambda (entry) (let* ((l (string-split entry "\t")) (type (string->symbol (cadr (string-split (car l) " ")))) (file-path (cadr l)) (file (conc (pathname-file file-path) (if (pathname-extension file-path) (conc "." (pathname-extension file-path)) "")))) (list (if (eq? type 'tree) 1 0) file (conc "browse-git.scm|" repo "|" branch "|" file-path (if (eq? type 'tree) "/" "") "|" type)))) entries)))) (define (serve-blob) (for-each (lambda (line) (print line "\r")) (git "cat-file" "blob" (conc branch ":" path))) (print ".\r")) (let ((type (string->symbol type-str))) (case type ((tree) (serve-tree)) ((blob) (serve-blob)) (else (error "Unsupported git object."))))))