;; 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")))
- (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 "-----= 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))))
- 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."))))))
The Lambda Lab / projects / scratchy.git / blobdiff