#!/usr/bin/env -S guile \\
-e build-image -s
!# ;; Guile uses a meta switch '\' which env requires escaping to passthru.
;; See: https://pingus.seul.org/~grumbel/tmp/guile-1.6.0/guile_10.html#SEC27

;;; Copyright © 2021 Kyle Cassidy <123_kbc@pm.me>
;;;
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU 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 General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;; Generate a bootable image with:
;; $ ./nongnu/system/build-image.scm

; Searches through Scheme file for 'define and 'define* expressions
; such as (define <name> ... ) or (define (<name> ...) ...)
(define (search-for-define scheme-file define-name)
  (call-with-input-file scheme-file
    (lambda (port)
      (let next ((exp (read port)))
        (cond ((eof-object? exp) #f)
              ((and (list? exp)
                 (or (equal? 'define (car exp))
                     (equal? 'define* (car exp)))
                 (if (list? (cadr exp))
                     (equal? define-name (caadr exp))
                   (equal? define-name (cadr exp))))
               exp)
              (#t (next (read port))))))))

; Writes channel-list to a tmpfile defined by (tmpnam)
(define (make-tmp-channel channel-list)
  (let ((tmpath (tmpnam)))
    (call-with-output-file tmpath
      (lambda (port)
        (write '(use-modules (guix ci)) port)
        (write channel-list port)))
    tmpath))

; Main function called when run at command line.
;   Parses "nongnu/system/install.scm" for channel definition
;   Creates tmpfile containing channel definition
;   Performs a guix pull using tmpfile as channel file
;   Deletes tmpfile file
;   Builds image (currently iso only)
;     supportes "--uncompress" command line argument 
;   If "--roll-back" is used as an argument, reverts guix pull
;   Returns #t if exit-code of build is 0, else returns #f
(define (build-image . args)
  (let* ((image-type 'iso) ; todo: parse args for supported image types
         (image-label "guix-nonfree-install")
         (channel-define-name '%channels)
         (config-dir (dirname (current-filename)))
         (config-file-name "install.scm")
         (install-config (string-append config-dir
                        file-name-separator-string
                        config-file-name))
         (channels (caddr (search-for-define
                            install-config
                            channel-define-name)))
         (tmp-channel-file-path (make-tmp-channel (cadr channels)))
         (exit-code #f))
    (system* "guix" "pull" (string-append "--channels=" tmp-channel-file-path))
    (delete-file tmp-channel-file-path)
    (cond ((equal? image-type 'iso)
           (let ((image-link (string-append config-dir
                               file-name-separator-string
                               image-label
                               ".iso")))
             (set! exit-code
               (system* "guix"
                        "system"
                        "image"
                        (if (member "--uncompress" args)
                            "--image-type=uncompressed-iso9660"
                          "--image-type=iso9660") ; remove once image types supported
                        (string-append "--label=" image-label)
                        (string-append "--root=" image-link)
                        install-config)))))
    (and (member "--roll-back" args)
      (system* "guix" "pull" "--roll-back"))
    (equal? exit-code 0)))