From 2ee1c7c6da9e093c1722a0009c82dba5c14a0db0 Mon Sep 17 00:00:00 2001 From: Tim Vaughan Date: Sat, 15 Jun 2019 12:22:52 +0200 Subject: [PATCH] Added optional description file to git browser. --- examples/browse-git.scm | 164 +++++++++++++++++++++------------------- 1 file changed, 85 insertions(+), 79 deletions(-) diff --git a/examples/browse-git.scm b/examples/browse-git.scm index 75b940c..dbf0b17 100755 --- a/examples/browse-git.scm +++ b/examples/browse-git.scm @@ -1,87 +1,93 @@ ;; 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 (type-str repo branch path) - (import (chicken string) - (chicken process) - (chicken io) - (chicken pathname) - srfi-13) +(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)))) - (define git-base-url "git://MY.GIT.SERVER/") - (define git-base-dir "/PATH/TO/GIT/REPOS/") + (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 " repo) - "" - (conc "(Clone from " git-base-url repo ".)") - "" - "-----= Branches =-----") - (map (lambda (ref) - (let ((refname (caddr (string-split ref "/")))) - (list - 1 - (conc (if (equal? branch refname) "*" "") - refname) - (conc "browse-git.scm|tree|" repo "|" refname "|" path)))) - 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|tree|" repo "|" commit "|" path))) - 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|" type "|" repo "|" branch "|" - file-path - (if (eq? type 'tree) "/" ""))))) - entries)))) + (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-blob) - (for-each - (lambda (line) - (print line "\r")) - (git "cat-file" "blob" (conc branch ":" path))) - (print ".\r")) + (define (serve-tree) + (let ((entries (git "ls-tree" branch path)) + (references (git "show-ref" "--heads"))) + (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 "-----= 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)))) - (let ((type (string->symbol type-str))) - (case type - ((tree) (serve-tree)) - ((blob) (serve-blob)) - (else - (error "Unsupported git object."))))) - + (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.")))))) -- 2.20.1