;; repository REPO should then be reachable at the selector
;; browse-git.scm|REPO.
;;
-;; You may optionally include a file named project-description
+;; A zip archive of the repository can be retrieved using
+;; the selector browse-git.scm|REPO||zip.
+;;
+;; You may optionally include a file named description
;; in each repository, which will be displayed at the top
;; of the page when the repository tree is served.
(chicken io)
(chicken pathname)
(chicken file)
- srfi-13)
+ (chicken port)
+ srfi-1 srfi-13)
+
+ (define (take-last l n)
+ (if (< (length l) n)
+ l
+ (take-right l n)))
(define git-base-url "git://MY.GIT.SERVER/")
(define git-base-dir "/path/to/git/repositories/")
-
- (define (git . args)
+ (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."))
repo-pathname
(lambda ()
(let-values (((in-port out-port id) (process "git" args)))
- (let ((result (read-lines in-port)))
+ (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"))
+ (tags (reverse (take-last (git "show-ref" "--tags") 5)))
(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"))))
+ (make-pathname repo "description"))))
(if (file-exists? descr-file)
(list "----= Description =----"
(with-input-from-file descr-file read-string)
"")
'()))
- (list "-----= Branches =-----")
+ (list "----= Branches and Recent Tags=----")
(map (lambda (ref)
(let ((refname (caddr (string-split ref "/"))))
(list
(conc (if (equal? branch refname) "*" "")
refname)
(conc "browse-git.scm|" repo "|" refname "|" path "|tree"))))
- references)
+ (append references tags))
(list
""
- (conc "-----= Recent Commits [" branch "] =-----"))
+ (conc "----= Recent Commits [" branch "] =----"))
(map (lambda (commit)
(list
1
(conc "browse-git.scm|" repo "|" commit "|" path "|tree")))
commits)
(list ""
- (conc "-----= Files [" path "] =-----"))
+ (conc "----= Files [" path "] =----"))
(map (lambda (entry)
(let* ((l (string-split entry "\t"))
(type (string->symbol (cadr (string-split (car l) " "))))
(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))
+ ((zip) (serve-zip))
(else
(error "Unsupported git object."))))))