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 ;; You may optionally include a file named project-description
   9 ;; in each repository, which will be displayed at the top
  10 ;; of the page when the repository tree is served.
  11
  12 (lambda (repo . args)
  13   (let ((branch (if (< (length args) 1) "master" (list-ref args 0)))
  14         (path (if (< (length args) 2) "." (list-ref args 1)))
  15         (type-str (if (< (length args) 3) "tree" (list-ref args 2))))
  16
  17     (import (chicken string)
  18             (chicken process)
  19             (chicken io)
  20             (chicken pathname)
  21             (chicken file)
  22             srfi-13)
  23
  24     (define git-base-url "git://MY.GIT.SERVER/")
  25     (define git-base-dir "/path/to/git/repositories/")
  26
  27
  28     (define (git . args)
  29       (let ((repo-pathname (make-pathname git-base-dir repo)))
  30         (if (not (string-prefix? git-base-dir (normalize-pathname repo-pathname)))
  31             (error "Invalid git repository."))
  32         (with-current-working-directory
  33          repo-pathname
  34          (lambda ()
  35            (let-values (((in-port out-port id) (process "git" args)))
  36              (let ((result (read-lines in-port)))
  37                (close-input-port in-port)
  38                (close-output-port out-port)
  39                result))))))
  40
  41     (define (serve-tree)
  42       (let ((entries (git "ls-tree" branch path))
  43             (references (git "show-ref" "--heads"))
  44             (commits (git "rev-list" "--abbrev-commit" "-n5" branch)))
  45         (append
  46          (list (conc "Git repository " git-base-url repo)
  47                "")
  48          (let ((descr-file (make-pathname git-base-dir
  49                                           (make-pathname repo "project-description"))))
  50            (if (file-exists? descr-file)
  51                (list "----= Description =----"
  52                      (with-input-from-file descr-file read-string)
  53                      "")
  54                '()))
  55          (list "-----= Branches =-----")
  56          (map (lambda (ref)
  57                 (let ((refname (caddr (string-split ref "/"))))
  58                   (list
  59                    1
  60                    (conc (if (equal? branch refname) "*" "")
  61                          refname)
  62                    (conc "browse-git.scm|" repo "|" refname "|" path "|tree"))))
  63               references)
  64          (list
  65           ""
  66           (conc "-----= Recent Commits [" branch "] =-----"))
  67          (map (lambda (commit)
  68                 (list
  69                  1
  70                  (conc (if (equal? branch commit) "*" "")
  71                        (car (git "show" "-s" "--format=%s (%ar)" commit)))
  72                  (conc "browse-git.scm|" repo "|" commit "|" path "|tree")))
  73               commits)
  74          (list ""
  75                (conc "-----= Files [" path "] =-----"))
  76          (map (lambda (entry)
  77                 (let* ((l (string-split entry "\t"))
  78                        (type (string->symbol (cadr (string-split (car l) " "))))
  79                        (file-path (cadr l))
  80                        (file (conc (pathname-file file-path)
  81                                    (if (pathname-extension file-path)
  82                                        (conc "." (pathname-extension file-path))
  83                                        ""))))
  84                   (list (if (eq? type 'tree) 1 0)
  85                         file
  86                         (conc "browse-git.scm|" repo "|" branch "|"
  87                               file-path
  88                               (if (eq? type 'tree) "/" "")
  89                               "|" type))))
  90               entries))))
  91
  92     (define (serve-blob)
  93       (for-each
  94        (lambda (line)
  95          (print line "\r"))
  96        (git "cat-file" "blob" (conc branch ":" path)))
  97       (print ".\r"))
  98
  99     (let ((type (string->symbol type-str)))
 100       (case type
 101         ((tree) (serve-tree))
 102         ((blob) (serve-blob))
 103         (else
 104          (error "Unsupported git object."))))))