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 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 (take-last l n)
33 (define git-base-url "git://MY.GIT.SERVER/")
34 (define git-base-dir "/path/to/git/repositories/")
36 (define (with-input-from-git args thunk)
37 (let ((repo-pathname (make-pathname git-base-dir repo)))
38 (if (not (string-prefix? git-base-dir (normalize-pathname repo-pathname)))
39 (error "Invalid git repository."))
40 (with-current-working-directory
43 (let-values (((in-port out-port id) (process "git" args)))
44 (let ((result (with-input-from-port in-port thunk)))
45 (close-input-port in-port)
46 (close-output-port out-port)
50 (with-input-from-git args read-lines))
52 (define (git-dump . args)
56 (let loop ((b (read-byte)))
61 (loop (read-byte))))))))
64 (let ((entries (git "ls-tree" branch path))
65 (references (git "show-ref" "--heads"))
66 (tags (reverse (take-last (git "show-ref" "--tags") 5)))
67 (commits (git "rev-list" "--abbrev-commit" "-n5" branch)))
69 (list (conc "Git repository " git-base-url repo)
71 (let ((descr-file (make-pathname git-base-dir
72 (make-pathname repo "description"))))
73 (if (file-exists? descr-file)
74 (list "----= Description =----"
75 (with-input-from-file descr-file read-string)
78 (list "----= Branches and Recent Tags=----")
80 (let ((refname (caddr (string-split ref "/"))))
83 (conc (if (equal? branch refname) "*" "")
85 (conc "browse-git.scm|" repo "|" refname "|" path "|tree"))))
86 (append references tags))
89 (conc "----= Recent Commits [" branch "] =----"))
93 (conc (if (equal? branch commit) "*" "")
94 (car (git "show" "-s" "--format=%s (%ar)" commit)))
95 (conc "browse-git.scm|" repo "|" commit "|" path "|tree")))
98 (conc "----= Files [" path "] =----"))
100 (let* ((l (string-split entry "\t"))
101 (type (string->symbol (cadr (string-split (car l) " "))))
103 (file (conc (pathname-file file-path)
104 (if (pathname-extension file-path)
105 (conc "." (pathname-extension file-path))
107 (list (if (eq? type 'tree) 1 0)
109 (conc "browse-git.scm|" repo "|" branch "|"
111 (if (eq? type 'tree) "/" "")
119 (git "cat-file" "blob" (conc branch ":" path)))
123 (git-dump "archive" "--format=zip" branch))
125 (let ((type (string->symbol type-str)))
127 ((tree) (serve-tree))
128 ((blob) (serve-blob))
131 (error "Unsupported git object."))))))