examples/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://GIT-SERVER-URL/")
  11   (define git-base-dir "/PATH/TO/GIT/REPOS/")
  12
  13   (define (git . args)
  14     (with-current-working-directory
  15      (conc git-base-dir repo)
  16      (lambda ()
  17        (let-values (((in-port out-port id) (process "git" args)))
  18          (let ((result (read-lines in-port)))
  19            (close-input-port in-port)
  20            (close-output-port out-port)
  21            result)))))
  22
  23   (define (serve-tree)
  24     (let ((entries (git "ls-tree" branch path))
  25           (references (git "show-ref" "--heads")))
  26       (append
  27        (list
  28         (conc "Git repository for " repo)
  29         ""
  30         (conc "(Clone from " git-base-url repo ".)")
  31         ""
  32         "Branches:")
  33        (map (lambda (ref)
  34               (let ((refname (caddr (string-split ref "/"))))
  35                 (list
  36                  1
  37                  (conc (if (equal? branch refname) "*" "")
  38                        refname)
  39                  (conc "git.scm:tree:" repo ":" refname ":" path))))
  40             references)
  41        (list ""
  42              "Files:")
  43        (map (lambda (entry)
  44               (let* ((l (string-split entry "\t"))
  45                      (type (string->symbol (cadr (string-split (car l) " "))))
  46                      (file (cadr l)))
  47                 (list (if (eq? type 'tree) 1 0)
  48                       file
  49                       (conc "git.scm:" type ":" repo ":" branch ":"
  50                             file
  51                             (if (eq? type 'tree) "/" "")))))
  52             entries)
  53        (list
  54         "------"))))
  55
  56   (define (serve-blob)
  57     (for-each
  58      (lambda (line)
  59        (print line "\r"))
  60      (git "cat-file" "blob" (conc branch ":" path)))
  61     (print ".\r"))
  62
  63   (let ((type (string->symbol type-str)))
  64     (case type
  65       ((tree) (serve-tree))
  66       ((blob) (serve-blob))
  67       (else
  68        (error "Unsupported git object.")))))
  69