examples/browse-git.scm

   1 ;; Script to browse locally-hosted URLs
   2
   3 (lambda (type-str repo branch path)
   4   (import (chicken string)
   5           (chicken process)
   6           (chicken io)
   7           (chicken pathname)
   8           srfi-13)
   9
  10   (define git-base-url "git://MY.GIT.SERVER/")
  11   (define git-base-dir "/PATH/TO/GIT/REPOS/")
  12
  13
  14   (define (git . args)
  15     (let ((repo-pathname (make-pathname git-base-dir repo)))
  16       (if (not (string-prefix? git-base-dir (normalize-pathname repo-pathname)))
  17           (error "Invalid git repository."))
  18       (with-current-working-directory
  19        repo-pathname
  20        (lambda ()
  21          (let-values (((in-port out-port id) (process "git" args)))
  22            (let ((result (read-lines in-port)))
  23              (close-input-port in-port)
  24              (close-output-port out-port)
  25              result))))))
  26
  27   (define (serve-tree)
  28     (let ((entries (git "ls-tree" branch path))
  29           (references (git "show-ref" "--heads"))
  30           (commits (git "rev-list" "--abbrev-commit" "-n5" branch)))
  31       (append
  32        (list
  33         (conc "Git repository " repo)
  34         ""
  35         (conc "(Clone from " git-base-url repo ".)")
  36         ""
  37         "-----= Branches =-----")
  38        (map (lambda (ref)
  39               (let ((refname (caddr (string-split ref "/"))))
  40                 (list
  41                  1
  42                  (conc (if (equal? branch refname) "*" "")
  43                        refname)
  44                  (conc "browse-git.scm|tree|" repo "|" refname "|" path))))
  45             references)
  46        (list
  47         ""
  48         (conc "-----= Recent Commits [" branch "] =-----"))
  49        (map (lambda (commit)
  50               (list
  51                1
  52                (conc (if (equal? branch commit) "*" "")
  53                      (car (git "show" "-s" "--format=%s (%ar)" commit)))
  54                (conc "browse-git.scm|tree|" repo "|" commit "|" path)))
  55             commits)
  56        (list
  57         ""
  58         (conc "-----= Files [" path "] =-----"))
  59        (map (lambda (entry)
  60               (let* ((l (string-split entry "\t"))
  61                      (type (string->symbol (cadr (string-split (car l) " "))))
  62                      (file-path (cadr l))
  63                      (file (conc (pathname-file file-path)
  64                                  (if (pathname-extension file-path)
  65                                      (conc "." (pathname-extension file-path))
  66                                      ""))))
  67                 (list (if (eq? type 'tree) 1 0)
  68                       file
  69                       (conc "browse-git.scm|" type "|" repo "|" branch "|"
  70                             file-path
  71                             (if (eq? type 'tree) "/" "")))))
  72             entries))))
  73
  74   (define (serve-blob)
  75     (for-each
  76      (lambda (line)
  77        (print line "\r"))
  78      (git "cat-file" "blob" (conc branch ":" path)))
  79     (print ".\r"))
  80
  81   (let ((type (string->symbol type-str)))
  82     (case type
  83       ((tree) (serve-tree))
  84       ((blob) (serve-blob))
  85       (else
  86        (error "Unsupported git object.")))))
  87