(define-module (ruther build environment)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 format)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (ice-9 textual-ports)
  #:use-module (guix build utils)
  #:use-module (guix build union)
  #:use-module (ruther build utils)

  #:export (make-profile-wrapper-script
            unsymlink
            ensure-file-writable
            file-has-binary-path?
            file-replace-binary-paths
            file-replace-binary-paths-maybe
            patch-extra-files
            copy-extra-files
            copy-binary-files))

(define (make-profile-wrapper-script source-file input-file output-file)
  "Make a wrapper script at output-file that will source the source-file
and exec input-file"
  (call-with-output-file output-file
    (lambda (port)
      (format port "!#~a~%"
              (search-path (search-path-as-string->list (getenv "TARGET"))
                           "bash"))
      (format port "source ~a~%" source-file)
      (format port "exec ~a \"$@\"~%" input-file)))
  (chmod output-file #o555))

(define (unsymlink link)
  "Make sure the file is writable by "

  (define (absolute? file)
    (string-prefix? "/" file))

  (let ((target (match (readlink link)
                  ((? absolute? target)
                   target)
                  ((? string? relative)
                   (string-append (dirname link) "/" relative)))))
    (delete-file link)
    (copy-file target link)))

(define (ensure-file-writable file)
  ;; TODO: add writable permission
  (when (symbolic-link? file)
      (unsymlink file)))

;; Iterate all files in extra-paths... check if the file contains any of 'profile-binaries'
;; if yes, ensure file writable and substitute it
(define (file-has-binary-path? file binaries)
  (call-with-input-file file
    (lambda (port)
      (let loop ((line (get-line port)))
        ;; if there is a /gnu/store, then look if the binary paths are present
        (if (eof-object? line)
            #f
            (if (string-contains line (%store-directory))
                (if (any (lambda (binary-path)
                       (string-contains line binary-path))
                         (map car binaries))
                    #t
                    (loop (get-line port)))
                (loop (get-line port))))))))

(define (file-replace-binary-paths file binaries)
  (format (current-output-port) "Replacing binary paths in ~a~%" file)
  (ensure-file-writable file)
  (for-each (lambda (binary)
              (substitute*
                  file
                (((car binary)) (car (cdr binary)))))
            binaries))

(define (file-replace-binary-paths-maybe file binaries)
  (when (file-has-binary-path? file binaries)
    (file-replace-binary-paths file binaries)))

(define (patch-extra-files output binaries)
  (format (current-output-port) "Going to patch files in ~a~%" output)
  (ftw
   output
   (lambda (file stat flag)
     (match flag
       ('regular
        (when (file-is-text-file? file)
          (file-replace-binary-paths-maybe file binaries)))
       (_ #f))
     #t)))

(define (copy-extra-files output profile-path extra-folders)
  (for-each
   (lambda (extra-path)
     (when (file-exists? (string-append profile-path "/" extra-path))
       (when (string-contains extra-path "/")
         (mkdir-p (string-append output "/" (dirname extra-path))))
       (union-build (string-append output "/" extra-path)
                    (list (string-append profile-path "/" extra-path))
                    #:create-all-directories? #t)))
   extra-folders))

(define* (copy-binary-files output
                            output-binary-folders
                            profile-path
                            binaries
                            #:key
                            (filter-function (const #t))
                            (rename-function identity))
  (for-each mkdir-p output-binary-folders)
  (for-each
   (lambda (binary)
     (make-profile-wrapper-script
      (string-append profile-path "/etc/profile")
      (string-append profile-path "/" binary)
      (string-append output "/" (dirname binary) "/" (rename-function (basename binary)))))
   (filter filter-function binaries)))