1 ;; Script to browse locally-hosted URLs
3 ;; To use, replace the strings git-base-url and git-base-dir
4 ;; with the values appropriate to your system. Your git
5 ;; repository REPO should then be reachable at the selector
6 ;; browse-git.scm|REPO.
8 ;; A zip archive of the repository can be retrieved using
9 ;; the selector browse-git.scm|REPO||zip.
11 ;; You may optionally include a file named project-description
12 ;; in each repository, which will be displayed at the top
13 ;; of the page when the repository tree is served.
16 (let ((branch (if (< (length args) 1) "master" (list-ref args 0)))
17 (path (if (< (length args) 2) "." (list-ref args 1)))
18 (type-str (if (< (length args) 3) "tree" (list-ref args 2))))
20 (import (chicken string)
28 (define git-base-url "git://MY.GIT.SERVER/")
29 (define git-base-dir "/path/to/git/repositories/")
31 (define (with-input-from-git args thunk)
32 (let ((repo-pathname (make-pathname git-base-dir repo)))
33 (if (not (string-prefix? git-base-dir (normalize-pathname repo-pathname)))
34 (error "Invalid git repository."))
35 (with-current-working-directory
38 (let-values (((in-port out-port id) (process "git" args)))
39 (let ((result (with-input-from-port in-port thunk)))
40 (close-input-port in-port)
41 (close-output-port out-port)
45 (with-input-from-git args read-lines))
47 (define (git-dump . args)
51 (let loop ((b (read-byte)))
56 (loop (read-byte))))))))
59 (let ((entries (git "ls-tree" branch path))
60 (references (git "show-ref" "--heads"))
61 (commits (git "rev-list" "--abbrev-commit" "-n5" branch)))
63 (list (conc "Git repository " git-base-url repo)
65 (let ((descr-file (make-pathname git-base-dir
66 (make-pathname repo "project-description"))))
67 (if (file-exists? descr-file)
68 (list "----= Description =----"
69 (with-input-from-file descr-file read-string)
72 (list "-----= Branches =-----")
74 (let ((refname (caddr (string-split ref "/"))))
77 (conc (if (equal? branch refname) "*" "")
79 (conc "browse-git.scm|" repo "|" refname "|" path "|tree"))))
83 (conc "-----= Recent Commits [" branch "] =-----"))
87 (conc (if (equal? branch commit) "*" "")
88 (car (git "show" "-s" "--format=%s (%ar)" commit)))
89 (conc "browse-git.scm|" repo "|" commit "|" path "|tree")))
92 (conc "-----= Files [" path "] =-----"))
94 (let* ((l (string-split entry "\t"))
95 (type (string->symbol (cadr (string-split (car l) " "))))
97 (file (conc (pathname-file file-path)
98 (if (pathname-extension file-path)
99 (conc "." (pathname-extension file-path))
101 (list (if (eq? type 'tree) 1 0)
103 (conc "browse-git.scm|" repo "|" branch "|"
105 (if (eq? type 'tree) "/" "")
113 (git "cat-file" "blob" (conc branch ":" path)))
117 (git-dump "archive" "--format=zip" branch))
119 (let ((type (string->symbol type-str)))
121 ((tree) (serve-tree))
122 ((blob) (serve-blob))
125 (error "Unsupported git object."))))))