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