- (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 (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 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 " 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)