;; disfluid, implementation of the Solid specification
;; Copyright (C) 2020, 2021 Vivien Kraus
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU Affero General Public License for more details.
;; You should have received a copy of the GNU Affero General Public License
;; along with this program. If not, see .
(use-modules (gnu packages bash))
(use-modules (gnu packages base))
(use-modules (gnu packages tex))
(use-modules (gnu packages code))
(use-modules (gnu packages version-control))
(use-modules (guix build-system gnu))
(use-modules (guix packages))
(use-modules (guix gexp))
(use-modules (guix modules))
(use-modules (guix build utils))
(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-name #:init-keyword #:branch-name #:getter branch-name)
(hash #:getter hash)
(version #:getter version)
(release-date #:getter release-date)
(manual-mdate #:getter manual-mdate)
(commit-id #:getter commit-id)
(interned-modules #:getter interned-modules))
(unsetenv "GIT_DIR")
(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 ) 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 log -n 1 --format=%cI ~a -- doc/disfluid.texi > ~a/manual-mdate"
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 'manual-mdate
(call-with-input-file (string-append tmp-dirname "/manual-mdate")
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-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 ))
(string->symbol (string-append "disfluid-snapshot-" (branch-name branch))))
(define-method (code (branch ))
(let ((header
(if (equal? (branch-name branch) "master")
`((define-public disfluid
(disfluid-release
#:version ,(version branch)
#:manual-mdate ,(manual-mdate 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)
#:manual-mdate ,(manual-mdate 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.
")