package: make a package for each public git branch

1 files changed, 137 insertions, 69 deletions

diff --git a/update-channel.scm b/update-channel.scm
index 55eaa8a..26c0221 100644
--- a/update-channel.scm
+++ b/update-channel.scm
@@ -27,75 +27,143 @@
 (use-modules (guix store))
 (use-modules (ice-9 textual-ports))
 (use-modules (ice-9 rdelim))
+(use-modules (ice-9 optargs))
+(use-modules (ice-9 match))
+(use-modules (srfi srfi-26))
+(use-modules (oop goops))
+
+(define-class <branch-info> ()
+  (branch-name #:init-keyword #:branch-name #:getter branch-name)
+  (hash #:getter hash)
+  (version #:getter version)
+  (release-date #:getter release-date)
+  (commit-id #:getter commit-id)
+  (interned-modules #:getter interned-modules))
 
 (unsetenv "GIT_DIR")
 
-(let ((tmp-dirname (tmpnam))
-      (git
-       (run-with-store
-        (open-connection)
-        (package-file git "bin/git")))
-      (bash
-       (run-with-store
-        (open-connection)
-        (package-file bash "bin/bash")))
-      (tar
-       (run-with-store
-        (open-connection)
-        (package-file tar "bin/tar"))))
-  (format (current-error-port) "Found the required programs:
-- git:  ~a
-- bash: ~a
-- tar:  ~a
-"
-          git bash tar)
-  (format (current-error-port) "Using temporary directory ~a\n" tmp-dirname)
-  (mkdir tmp-dirname)
-  (mkdir (string-append tmp-dirname "/source"))
-  (invoke git "archive" "master" "-o" (string-append tmp-dirname "/source/source.tar.gz"))
-  (with-directory-excursion
-   (string-append tmp-dirname "/source")
-   (invoke tar "xf" (string-append tmp-dirname "/source/source.tar.gz"))
-   (delete-file (string-append tmp-dirname "/source/source.tar.gz")))
-  (with-directory-excursion
-   tmp-dirname
-   (invoke bash "-c" (format #f "guix hash -r source > hash")))
-  (invoke bash "-c" (format #f "~a describe --tags --always > ~a/version" git tmp-dirname))
-  (invoke bash "-c" (format #f "~a show -s --format=%cI > ~a/release-date" git tmp-dirname))
-  (invoke bash "-c" (format #f "~a rev-parse master > ~a/commit" git tmp-dirname))
-  (let ((hash (call-with-input-file (string-append tmp-dirname "/hash") read-line))
-        (version (call-with-input-file (string-append tmp-dirname "/version") read-line))
-        (release-date (call-with-input-file (string-append tmp-dirname "/release-date") read-line))
-        (commit (call-with-input-file (string-append tmp-dirname "/commit") read-line))
-        (interned-modules
-         (run-with-store
-          (open-connection)
-          (interned-file (string-append tmp-dirname "/source/guix") "ci-checkout" #:recursive? #t)))
-        (base-repository (getcwd)))
-    (delete-file-recursively tmp-dirname)
-    (invoke git "clone" (format #f "~a/../webid-oidc-channel" base-repository) tmp-dirname)
-    (with-directory-excursion
-     tmp-dirname
-     (invoke git "rm" "-f" "-r" "--ignore-unmatch" ".")
-     (copy-recursively interned-modules "." #:follow-symlinks? #t)
-     (chmod "vkraus/packages/disfluid.scm" #o644)
-     (let ((port (open-file "vkraus/packages/disfluid.scm" "a")))
-       (write `(define-public disfluid
-                 (disfluid-release ,version ,release-date ,commit ,hash))
-              port)
-       (display "\n" port)
-       (write `(define-public disfluid-html
-                 (disfluid-htmlize disfluid))
-              port)
-       (display "\n" port)
-       (write `(define-public disfluid:website
-                 (make-website disfluid))
-              port)
-       (display "\n" port)
-       (close-port port))
-     (invoke git "add" "-A")
-     (invoke bash "-c" (format #f "~a diff-index --quiet HEAD || ~a commit -m 'Update package'"
-                               git git))
-     (invoke git "push" "origin" "master"))))
-
-#~(system* #$(file-append hello "/bin/hello"))
+(define git
+  (run-with-store (open-connection) (package-file git "/bin/git")))
+
+(define bash
+  (run-with-store (open-connection) (package-file bash "/bin/bash")))
+
+(define tar
+  (run-with-store (open-connection) (package-file tar "/bin/tar")))
+
+(define-method (initialize (branch <branch-info>) initargs)
+  (let-keywords
+   initargs #t
+   ((branch-name "master"))
+   (let ((tmp-dirname (tmpnam)))
+     (mkdir tmp-dirname)
+     (mkdir (string-append tmp-dirname "/source"))
+     (invoke git "archive" branch-name "-o" (string-append tmp-dirname "/source/source.tar.gz"))
+     (with-directory-excursion
+         (string-append tmp-dirname "/source")
+       (invoke tar "xf" (string-append tmp-dirname "/source/source.tar.gz"))
+       (delete-file (string-append tmp-dirname "/source/source.tar.gz")))
+     (with-directory-excursion
+         tmp-dirname
+       (invoke bash "-c" (format #f "guix hash -r source > hash")))
+     (invoke bash "-c" (format #f "~a describe --tags --always ~a > ~a/version" git branch-name tmp-dirname))
+     (invoke bash "-c" (format #f "~a show -s --format=%cI ~a > ~a/release-date" git branch-name tmp-dirname))
+     (invoke bash "-c" (format #f "~a rev-parse ~a > ~a/commit-id" git branch-name tmp-dirname))
+     (slot-set! branch 'branch-name branch-name)
+     (slot-set! branch 'hash
+                (call-with-input-file (string-append tmp-dirname "/hash")
+                  read-line))
+     (slot-set! branch 'version
+                (call-with-input-file (string-append tmp-dirname "/version")
+                  read-line))
+     (slot-set! branch 'release-date
+                (call-with-input-file (string-append tmp-dirname "/release-date")
+                  read-line))
+     (slot-set! branch 'commit-id
+                (call-with-input-file (string-append tmp-dirname "/commit-id")
+                  read-line))
+     (slot-set! branch 'interned-modules
+                (run-with-store
+                    (open-connection)
+                  (interned-file (string-append tmp-dirname "/source/guix")
+                                 "ci-checkout"
+                                 #:recursive? #t)))
+     (delete-file-recursively tmp-dirname))))
+
+(define all-branches
+  (let ((tmp (tmpnam)))
+    (invoke bash "-c" (format #f "~a branch -l --format='%(refname:short)' > ~a" git tmp))
+    (map
+     (cute make <branch-info> #:branch-name <>)
+     (filter
+      (lambda (s) (not (equal? s "")))
+      (string-split (call-with-input-file tmp get-string-all) #\newline)))))
+
+(define master
+  (let find-master ((branches all-branches))
+    (match branches
+      (()
+       (error "No master branch in repo"))
+      (((and info
+             (= branch-name (? (cute equal? <> "master"))))
+        _ ...)
+       info)
+      ((_ branches ...)
+       (find-master branches)))))
+
+(define-method (package-variable-name (branch <branch-info>))
+  (string->symbol (string-append "disfluid-snapshot-" (branch-name branch))))
+
+(define-method (code (branch <branch-info>))
+  (let ((header
+         (if (equal? (branch-name branch) "master")
+             `((define-public disfluid
+                 (disfluid-release
+                  #:version ,(version branch)
+                  #:release-date ,(release-date branch)
+                  #:commit-id ,(commit-id branch)
+                  #:hash ,(hash branch))))
+             '())))
+    (append
+     header
+     `((define-public ,(package-variable-name branch)
+         (disfluid-branch-snapshot
+          #:branch-name ,(branch-name branch)
+          #:version ,(version branch)
+          #:release-date ,(release-date branch)
+          #:commit-id ,(commit-id branch)
+          #:hash ,(hash branch)))))))
+
+(define all-code
+  (append
+   (apply append (map code all-branches))
+   `((define-public disfluid:website
+       (make-website disfluid
+                     (list ,@(map
+                              (lambda (branch)
+                                `(cons ,(branch-name branch) ,(package-variable-name branch)))
+                              all-branches)))))))
+
+(define clone-dir (tmpnam))
+
+(invoke git "clone" "../webid-oidc-channel" clone-dir)
+
+(with-directory-excursion clone-dir
+  (invoke git "rm" "-f" "-r" "--ignore-unmatch" ".")
+  (copy-recursively (interned-modules master) "." #:follow-symlinks? #t)
+  (chmod "vkraus/packages/disfluid.scm" #o644)
+  (let ((port (open-file "vkraus/packages/disfluid.scm" "a")))
+    (for-each (lambda (code)
+                (write code port)
+                (display "\n" port))
+              all-code)
+    (close-port port))
+  (invoke git "add" "-A")
+  (invoke bash "-c" (format #f "~a diff-index --quiet HEAD || ~a commit -m 'Update package'"
+                            git git))
+  (invoke git "push" "origin" "master"))
+
+#~(plain-file
+   "done"
+   "Channel updated.
+")