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."))))))