Added example scripts.

[scratchy.git] / examples / git.scm

diff --git a/examples/git.scm b/examples/git.scm
new file mode 100644 (file)
index 0000000..3b64ff9
--- /dev/null
+++ b/examples/git.scm
@@ -0,0 +1,69 @@
+;; 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://GIT-SERVER-URL/")
+  (define git-base-dir "/PATH/TO/GIT/REPOS/")
+
+  (define (git . args)
+    (with-current-working-directory
+     (conc 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 for " 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 "git.scm:tree:" repo ":" refname ":" path))))
+            references)
+       (list ""
+             "Files:")
+       (map (lambda (entry)
+              (let* ((l (string-split entry "\t"))
+                     (type (string->symbol (cadr (string-split (car l) " "))))
+                     (file (cadr l)))
+                (list (if (eq? type 'tree) 1 0)
+                      file
+                      (conc "git.scm:" type ":" repo ":" branch ":"
+                            file
+                            (if (eq? type 'tree) "/" "")))))
+            entries)
+       (list
+        "------"))))
+
+  (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.")))))
+