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 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-1 srfi-13)
  27
  28     (define (take-last l n)
  29       (if (< (length l) n)
  30           l
  31           (take-right l n)))
  32
  33     (define git-base-url "git://MY.GIT.SERVER/")
  34     (define git-base-dir "/path/to/git/repositories/")
  35
  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
  41          repo-pathname
  42          (lambda ()
  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)
  47                result))))))
  48
  49     (define (git . args)
  50       (with-input-from-git args read-lines))
  51
  52     (define (git-dump . args)
  53       (with-input-from-git
  54        args
  55        (lambda ()
  56          (let loop ((b (read-byte)))
  57            (if (eof-object? b)
  58                'done
  59                (begin
  60                  (write-byte b)
  61                  (loop (read-byte))))))))
  62
  63     (define (serve-tree)
  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)))
  68         (append
  69          (list (conc "Git repository " git-base-url repo)
  70                "")
  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)
  76                      "")
  77                '()))
  78          (list "----= Branches and Recent Tags=----")
  79          (map (lambda (ref)
  80                 (let ((refname (caddr (string-split ref "/"))))
  81                   (list
  82                    1
  83                    (conc (if (equal? branch refname) "*" "")
  84                          refname)
  85                    (conc "browse-git.scm|" repo "|" refname "|" path "|tree"))))
  86               (append references tags))
  87          (list
  88           ""
  89           (conc "----= Recent Commits [" branch "] =----"))
  90          (map (lambda (commit)
  91                 (list
  92                  1
  93                  (conc (if (equal? branch commit) "*" "")
  94                        (car (git "show" "-s" "--format=%s (%ar)" commit)))
  95                  (conc "browse-git.scm|" repo "|" commit "|" path "|tree")))
  96               commits)
  97          (list ""
  98                (conc "----= Files [" path "] =----"))
  99          (map (lambda (entry)
 100                 (let* ((l (string-split entry "\t"))
 101                        (type (string->symbol (cadr (string-split (car l) " "))))
 102                        (file-path (cadr l))
 103                        (file (conc (pathname-file file-path)
 104                                    (if (pathname-extension file-path)
 105                                        (conc "." (pathname-extension file-path))
 106                                        ""))))
 107                   (list (if (eq? type 'tree) 1 0)
 108                         file
 109                         (conc "browse-git.scm|" repo "|" branch "|"
 110                               file-path
 111                               (if (eq? type 'tree) "/" "")
 112                               "|" type))))
 113               entries))))
 114
 115     (define (serve-blob)
 116       (for-each
 117        (lambda (line)
 118          (print line "\r"))
 119        (git "cat-file" "blob" (conc branch ":" path)))
 120       (print ".\r"))
 121
 122     (define (serve-zip)
 123       (git-dump "archive" "--format=zip" branch))
 124
 125     (let ((type (string->symbol type-str)))
 126       (case type
 127         ((tree) (serve-tree))
 128         ((blob) (serve-blob))
 129         ((zip) (serve-zip))
 130         (else
 131          (error "Unsupported git object."))))))