9edd5855254336810b844496c18f17872198decb
[scratchy.git] / examples / browse-git.scm
1 ;; Script to browse locally-hosted URLs
2 ;;
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.
7 ;;
8 ;; A zip archive of the repository can be retrieved using
9 ;; the selector browse-git.scm|REPO||zip.
10 ;;
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.
14
15 (lambda (repo . args)
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))))
19
20     (import (chicken string)
21             (chicken process)
22             (chicken io)
23             (chicken pathname)
24             (chicken file)
25             (chicken port)
26             srfi-13)
27
28     (define git-base-url "git://MY.GIT.SERVER/")
29     (define git-base-dir "/path/to/git/repositories/")
30
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
36          repo-pathname
37          (lambda ()
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)
42                result))))))
43
44     (define (git . args)
45       (with-input-from-git args read-lines))
46
47     (define (git-dump . args)
48       (with-input-from-git
49        args
50        (lambda ()
51          (let loop ((b (read-byte)))
52            (if (eof-object? b)
53                'done
54                (begin
55                  (write-byte b)
56                  (loop (read-byte))))))))
57
58     (define (serve-tree)
59       (let ((entries (git "ls-tree" branch path))
60             (references (git "show-ref" "--heads"))
61             (commits (git "rev-list" "--abbrev-commit" "-n5" branch)))
62         (append
63          (list (conc "Git repository " git-base-url repo)
64                "")
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)
70                      "")
71                '()))
72          (list "-----= Branches =-----")
73          (map (lambda (ref)
74                 (let ((refname (caddr (string-split ref "/"))))
75                   (list
76                    1
77                    (conc (if (equal? branch refname) "*" "")
78                          refname)
79                    (conc "browse-git.scm|" repo "|" refname "|" path "|tree"))))
80               references)
81          (list
82           ""
83           (conc "-----= Recent Commits [" branch "] =-----"))
84          (map (lambda (commit)
85                 (list
86                  1
87                  (conc (if (equal? branch commit) "*" "")
88                        (car (git "show" "-s" "--format=%s (%ar)" commit)))
89                  (conc "browse-git.scm|" repo "|" commit "|" path "|tree")))
90               commits)
91          (list ""
92                (conc "-----= Files [" path "] =-----"))
93          (map (lambda (entry)
94                 (let* ((l (string-split entry "\t"))
95                        (type (string->symbol (cadr (string-split (car l) " "))))
96                        (file-path (cadr l))
97                        (file (conc (pathname-file file-path)
98                                    (if (pathname-extension file-path)
99                                        (conc "." (pathname-extension file-path))
100                                        ""))))
101                   (list (if (eq? type 'tree) 1 0)
102                         file
103                         (conc "browse-git.scm|" repo "|" branch "|"
104                               file-path
105                               (if (eq? type 'tree) "/" "")
106                               "|" type))))
107               entries))))
108
109     (define (serve-blob)
110       (for-each
111        (lambda (line)
112          (print line "\r"))
113        (git "cat-file" "blob" (conc branch ":" path)))
114       (print ".\r"))
115
116     (define (serve-zip)
117       (git-dump "archive" "--format=zip" branch))
118
119     (let ((type (string->symbol type-str)))
120       (case type
121         ((tree) (serve-tree))
122         ((blob) (serve-blob))
123         ((zip) (serve-zip))
124         (else
125          (error "Unsupported git object."))))))