package: make a package for each public git branch

2 files changed, 191 insertions, 74 deletions

diff --git a/guix/vkraus/packages/disfluid.scm b/guix/vkraus/packages/disfluid.scm
index 38f24ed..d9558ac 100644
--- a/guix/vkraus/packages/disfluid.scm
+++ b/guix/vkraus/packages/disfluid.scm
@@ -35,7 +35,10 @@
   #:use-module (gnu packages man)
   #:use-module (gnu packages tls)
   #:use-module (gnu packages gtk)
-  #:use-module (gnu packages gnome))
+  #:use-module (gnu packages gnome)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 optargs)
+  #:use-module (sxml simple))
 
 (define-public disfluid-snapshot
   (package
@@ -142,7 +145,8 @@
            (variable "LTDL_LIBRARY_PATH")
            (files '("lib")))))))
 
-(define-public (disfluid-release version release-date commit hash)
+(define*-public (disfluid-release
+                 #:key version release-date commit-id hash)
   (package
    (inherit disfluid-snapshot)
    (name "disfluid")
@@ -152,7 +156,7 @@
      (method git-fetch)
      (uri (git-reference
            (url "https://labo.planete-kraus.eu/webid-oidc.git")
-           (commit commit)))
+           (commit commit-id)))
      (sha256 (base32 hash))
      (snippet
       `(begin
@@ -162,6 +166,16 @@
            (lambda _ (format #t "~a~%" ,release-date)))
          #t))))))
 
+(define*-public (disfluid-branch-snapshot
+                 #:key branch-name version release-date commit-id hash)
+  (package
+    (inherit (disfluid-release
+              #:version version
+              #:release-date release-date
+              #:commit-id commit-id
+              #:hash hash))
+    (name (string-append "disfluid-snapshot-" branch-name))))
+
 (define-public (disfluid-htmlize disfluid)
   (package
    (inherit disfluid)
@@ -230,5 +244,40 @@
 file, which is exported to HTML and PDF. Also include the complete
 corresponding source, as an AGPL requirement.")))
 
-(define-public (make-website disfluid)
-  (file-append (disfluid-htmlize disfluid) "/share/doc/disfluid/disfluid.html"))
+(define-public (make-website master-disfluid branch-disfluids)
+  (directory-union
+   "website"
+   `(,(file-append (disfluid-htmlize disfluid) "/share/doc/disfluid/disfluid.html")
+     ,(file-union
+       "branch-subdirectory"
+       `(("refs"
+          ,(file-union
+            "branch-websites"
+            `(("index.html"
+               ,(plain-file
+                 "branch-index"
+                 (call-with-output-string
+                   (lambda (port)
+                     (sxml->xml
+                      `(*TOP*
+                        (html (@ (href "http://www.w3.org/1999/xhtml")
+                                 (xml:lang "en"))
+                              (head (title "Other versions"))
+                              (body
+                               (h1 "Other versions of the manual")
+                               ,@(let ((lis
+                                        (map
+                                         (match-lambda
+                                           ((branch . _)
+                                            `(li (a (@ (href ,branch)) ,branch))))
+                                         branch-disfluids)))
+                                   (if (null? lis)
+                                       `((p "The manual is not available for any branch."))
+                                       `((p "The manual is available for these development branches:")
+                                         (ul ,@lis)))))))
+                      port)))))
+              ,@(map
+                 (match-lambda
+                   ((branch . package)
+                    `(,branch ,(file-append (disfluid-htmlize package) "/share/doc/disfluid/disfluid.html"))))
+                 branch-disfluids)))))))))
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.
+")