;; 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 <https://www.gnu.org/licenses/>.

(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-info> ()
  (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 <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 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-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)
                  #: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.
")