#!/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:
;; $ chmod +x build-image.scm && ./build-image.scm

(use-modules (ice-9 pretty-print))

; 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 temp file
(define (make-temp-channel channel-list)
  (let ((port (mkstemp! (string-copy "/tmp/guix-channel-XXXXXX") "a")))
    (map (lambda (_) (pretty-print _ port))
      channel-list)
    (force-output port)
    (port-filename port)))

; Main function called when run at command line.
;   Parses "nongnu/system/install.scm" for channel definition
;     (current-filename) used to locate in same dir as this file
;   Creates a temp file containing channel definition
;   Performs a guix pull using temp file as channel file
;   Deletes temp file
;   Builds image (currently iso only)
;     supports "--uncompressed" command line argument
;   If "--roll-back" is used as an argument, reverts guix pull
;   Returns #t if exit-code is 0, else returns #f
(define (build-image args)
  (let* ((image-type 'iso) ; TODO: parse args for supported image types
         (image-label "nonguix-install")
         (config-dir (dirname (current-filename)))
         (config-file-name "install.scm")
         (install-config (string-append config-dir
                        file-name-separator-string
                        config-file-name))
         (name-to-search 'nonguix-channels) ; lookup in install-config
         (channels (caddr (search-for-define
                            install-config
                            name-to-search)))
         (temp-channel-file-path (make-temp-channel (cadr channels)))
         (exit-code #f))
    (system* "guix" "pull" (string-append "--channels=" temp-channel-file-path))
    (delete-file temp-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 "--uncompressed" 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)))