Added archive generation to git browser example.

[scratchy.git] / examples / browse-git.scm

diff --git a/examples/browse-git.scm b/examples/browse-git.scm
old mode 100755 (executable)
new mode 100644 (file)
index dbf0b17..9edd585
--- 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.
 ;;
+;; 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.
@@ -19,13 +22,13 @@
             (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)
+    (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."))
@@ -33,14 +36,29 @@
          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")))
+            (references (git "show-ref" "--heads"))
+            (commits (git "rev-list" "--abbrev-commit" "-n5" branch)))
         (append
          (list (conc "Git repository " git-base-url repo)
                "")
@@ -60,6 +78,16 @@
                          refname)
                    (conc "browse-git.scm|" repo "|" refname "|" path "|tree"))))
               references)
+         (list
+          ""
+          (conc "-----= Recent Commits [" branch "] =-----"))
+         (map (lambda (commit)
+                (list
+                 1
+                 (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)
@@ -85,9 +113,13 @@
        (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."))))))