The Lambda Lab
/
projects
/
scratchy.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (from parent 1:
ddf946e
)
Added archive generation to git browser example.
author
Tim Vaughan
<tgvaughan@gmail.com>
Sat, 3 Aug 2019 10:21:20 +0000
(12:21 +0200)
committer
Tim Vaughan
<tgvaughan@gmail.com>
Sat, 3 Aug 2019 10:21:20 +0000
(12:21 +0200)
examples/browse-git.scm
patch
|
blob
|
history
diff --git
a/examples/browse-git.scm
b/examples/browse-git.scm
index
ec7ea42
..
9edd585
100644
(file)
--- a/
examples/browse-git.scm
+++ b/
examples/browse-git.scm
@@
-5,6
+5,9
@@
;; repository REPO should then be reachable at the selector
;; browse-git.scm|REPO.
;;
;; 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.
;; 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.
@@
-19,13
+22,13
@@
(chicken io)
(chicken pathname)
(chicken file)
(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/")
srfi-13)
(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."))
(let ((repo-pathname (make-pathname git-base-dir repo)))
(if (not (string-prefix? git-base-dir (normalize-pathname repo-pathname)))
(error "Invalid git repository."))
@@
-33,11
+36,25
@@
repo-pathname
(lambda ()
(let-values (((in-port out-port id) (process "git" args)))
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))))))
(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"))
(define (serve-tree)
(let ((entries (git "ls-tree" branch path))
(references (git "show-ref" "--heads"))
@@
-96,9
+113,13
@@
(git "cat-file" "blob" (conc branch ":" path)))
(print ".\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))
(let ((type (string->symbol type-str)))
(case type
((tree) (serve-tree))
((blob) (serve-blob))
+ ((zip) (serve-zip))
(else
(error "Unsupported git object."))))))
(else
(error "Unsupported git object."))))))