X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=scratchy.git;a=blobdiff_plain;f=examples%2Fbrowse-git.scm;h=9edd5855254336810b844496c18f17872198decb;hp=75b940c15ba58166190a572f3f498d88c30703bb;hb=3ae59eae730bb15ef86c1f64824a5f62ca1ee4a1;hpb=b415f682a8bbb14d01e8cd132ab16afbdd13d4c8 diff --git a/examples/browse-git.scm b/examples/browse-git.scm old mode 100755 new mode 100644 index 75b940c..9edd585 --- a/examples/browse-git.scm +++ b/examples/browse-git.scm @@ -1,87 +1,125 @@ ;; 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. +;; +;; A zip archive of the repository can be retrieved using +;; the selector browse-git.scm|REPO||zip. +;; +;; 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) + (chicken port) + 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 + (define (with-input-from-git args thunk) + (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 (with-input-from-port in-port thunk))) + (close-input-port in-port) + (close-output-port out-port) + result)))))) + + (define (git . args) + (with-input-from-git args read-lines)) + + (define (git-dump . args) + (with-input-from-git + args (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)))))) + (let loop ((b (read-byte))) + (if (eof-object? b) + 'done + (begin + (write-byte b) + (loop (read-byte)))))))) - (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 "/")))) + (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 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)))) + (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")) - (define (serve-blob) - (for-each - (lambda (line) - (print line "\r")) - (git "cat-file" "blob" (conc branch ":" path))) - (print ".\r")) + (define (serve-zip) + (git-dump "archive" "--format=zip" branch)) - (let ((type (string->symbol type-str))) - (case type - ((tree) (serve-tree)) - ((blob) (serve-blob)) - (else - (error "Unsupported git object."))))) - + (let ((type (string->symbol type-str))) + (case type + ((tree) (serve-tree)) + ((blob) (serve-blob)) + ((zip) (serve-zip)) + (else + (error "Unsupported git object."))))))