;; Script to browse locally-hosted URLs

(lambda (type-str repo branch path)
  (import (chicken string)
          (chicken process)
          (chicken io)
          (chicken pathname)
          srfi-13)

  (define git-base-url "git://MY.GIT.SERVER/")
  (define git-base-dir "/PATH/TO/GIT/REPOS/")


  (define (git . args)
    (let ((repo-pathname (make-pathname git-base-dir repo)))
      (if (not (string-prefix? git-base-dir (normalize-pathname repo-pathname)))
          (error "Invalid git repository."))
      (with-current-working-directory
       repo-pathname
       (lambda ()
         (let-values (((in-port out-port id) (process "git" args)))
           (let ((result (read-lines in-port)))
             (close-input-port in-port)
             (close-output-port out-port)
             result))))))

  (define (serve-tree)
    (let ((entries (git "ls-tree" branch path))
          (references (git "show-ref" "--heads"))
          (commits (git "rev-list" "--abbrev-commit" "-n5" branch)))
      (append
       (list
        (conc "Git repository " repo)
        ""
        (conc "(Clone from " git-base-url repo ".)")
        ""
        "-----= Branches =-----")
       (map (lambda (ref)
              (let ((refname (caddr (string-split ref "/"))))
                (list
                 1
                 (conc (if (equal? branch refname) "*" "")
                       refname)
                 (conc "browse-git.scm|tree|" repo "|" refname "|" path))))
            references)
       (list
        ""
        (conc "-----= Recent Commits [" branch "] =-----"))
       (map (lambda (commit)
              (list
               1
               (conc (if (equal? branch commit) "*" "")
                     (car (git "show" "-s" "--format=%s (%ar)" commit)))
               (conc "browse-git.scm|tree|" repo "|" commit "|" path)))
            commits)
       (list
        ""
        (conc "-----= Files [" path "] =-----"))
       (map (lambda (entry)
              (let* ((l (string-split entry "\t"))
                     (type (string->symbol (cadr (string-split (car l) " "))))
                     (file-path (cadr l))
                     (file (conc (pathname-file file-path)
                                 (if (pathname-extension file-path)
                                     (conc "." (pathname-extension file-path))
                                     ""))))
                (list (if (eq? type 'tree) 1 0)
                      file
                      (conc "browse-git.scm|" type "|" repo "|" branch "|"
                            file-path
                            (if (eq? type 'tree) "/" "")))))
            entries))))

  (define (serve-blob)
    (for-each
     (lambda (line)
       (print line "\r"))
     (git "cat-file" "blob" (conc branch ":" path)))
    (print ".\r"))

  (let ((type (string->symbol type-str)))
    (case type
      ((tree) (serve-tree))
      ((blob) (serve-blob))
      (else
       (error "Unsupported git object.")))))