Improvements to git repo browser.

[scratchy.git] / examples / browse-git.scm

diff --git a/examples/browse-git.scm b/examples/browse-git.scm
new file mode 100755 (executable)
index 0000000..02e7554
--- /dev/null
+++ b/examples/browse-git.scm
@@ -0,0 +1,71 @@
+;; 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/REPOS/")
+
+  (define (git . args)
+    (with-current-working-directory
+     (list git-base-dir repo)
+     (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")))
+      (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 "-----= 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.")))))
+