Added optional description file to git browser.

diff --git a/examples/browse-git.scm b/examples/browse-git.scm
index 75b940c..dbf0b17 100755 (executable)
--- a/examples/browse-git.scm
+++ b/examples/browse-git.scm
@@ -1,87 +1,93 @@
 ;; Script to browse locally-hosted URLs
+;;
+;; To use, replace the strings git-base-url and git-base-dir
+;; with the values appropriate to your system.  Your git
+;; repository REPO should then be reachable at the selector
+;; browse-git.scm|REPO.
+;;
+;; 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.
 
-(lambda (type-str repo branch path)
-  (import (chicken string)
-          (chicken process)
-          (chicken io)
-          (chicken pathname)
-          srfi-13)
+(lambda (repo . args)
+  (let ((branch (if (< (length args) 1) "master" (list-ref args 0)))
+        (path (if (< (length args) 2) "." (list-ref args 1)))
+        (type-str (if (< (length args) 3) "tree" (list-ref args 2))))
 
-  (define git-base-url "git://MY.GIT.SERVER/")
-  (define git-base-dir "/PATH/TO/GIT/REPOS/")
+    (import (chicken string)
+            (chicken process)
+            (chicken io)
+            (chicken pathname)
+            (chicken file)
+            srfi-13)
 
+    (define git-base-url "git://MY.GIT.SERVER/")
+    (define git-base-dir "/path/to/git/repositories/")
 
-  (define (git . args)
-    (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 (read-lines in-port)))
-             (close-input-port in-port)
-             (close-output-port out-port)
-             result))))))
 
-  (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 " repo)
-        ""
-        (conc "(Clone from " git-base-url repo ".)")
-        ""
-        "-----= Branches =-----")
-       (map (lambda (ref)
-              (let ((refname (caddr (string-split ref "/"))))
-                (list
-                 1
-                 (conc (if (equal? branch refname) "*" "")
-                       refname)
-                 (conc "browse-git.scm|tree|" repo "|" refname "|" path))))
-            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|tree|" repo "|" commit "|" path)))
-            commits)
-       (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|" type "|" repo "|" branch "|"
-                            file-path
-                            (if (eq? type 'tree) "/" "")))))
-            entries))))
+    (define (git . args)
+      (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 (read-lines in-port)))
+               (close-input-port in-port)
+               (close-output-port out-port)
+               result))))))
 
-  (define (serve-blob)
-    (for-each
-     (lambda (line)
-       (print line "\r"))
-     (git "cat-file" "blob" (conc branch ":" path)))
-    (print ".\r"))
+    (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))))
 
-  (let ((type (string->symbol type-str)))
-    (case type
-      ((tree) (serve-tree))
-      ((blob) (serve-blob))
-      (else
-       (error "Unsupported git object.")))))
-                                    
+    (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."))))))