;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Procedures to help manage egg repositories.
;;;
;;; Copyright (c) 2018, Evan Hanson
;;;
;;; See LICENSE for details.
;;;

;;
;; The `(beaker repository)` library provides a handful of procedures
;; to help manage egg repositories.
;;
(declare
  (module (beaker repository))
  (export chicken-install create-repository egg-files)
  (import (chicken condition)
          (chicken file)
          (chicken foreign)
          (except (chicken pathname) make-absolute-pathname)
          (chicken platform)
          (chicken process)
          (chicken process-context)
          (srfi 1)))

(define (install-egg-home)
  (foreign-value "C_INSTALL_EGG_HOME" c-string))

;;
;; Returns the full pathname of the `chicken-install` command.
;;
(define (chicken-install)
  (make-pathname
   (foreign-value "C_TARGET_BIN_HOME" c-string)
   (foreign-value "C_CHICKEN_INSTALL_PROGRAM" c-string)))

(define (install-egg-home-files)
  (append (glob (make-pathname (install-egg-home) "/chicken.*.import.so"))
          (glob (make-pathname (install-egg-home) "/srfi-4.import.so"))
          (glob (make-pathname (install-egg-home) "/types.db"))))

;;
;; Returns a list of all egg-info files in the repository path.
;;
;; The `path` argument can be used to specify an alternative repository
;; path, which should be a thunk returning a list of pathname strings.
;;
(define (egg-files #!optional (path repository-path))
  ((flip append-map)
   (path)
   (lambda (repo)
     (filter-map
      (lambda (f)
        (and (equal? (pathname-extension f) "egg-info")
             (make-pathname repo f)))
      (handle-exceptions _ '() (directory repo))))))

(define (make-absolute-pathname path)
  (if (absolute-pathname? path)
      path
      (make-pathname (current-directory) path)))

(define (copy-directory-tree source destination)
  (let* ((source* (make-absolute-pathname source))
         (source-prefix-length (add1 (string-length source*))))
    (find-files
     source*
     action: (lambda (s _)
               (unless (directory-exists? s)
                 (let ((d (make-pathname
                           destination
                           (substring s source-prefix-length))))
                   (create-directory (pathname-directory d) #t)
                   (copy-file s d)))))))

;;
;; Initialises a new egg repository at the pathname `destination`.
;;
;; If the directory `destination` doesn't exist, it is created. The core
;; CHICKEN libraries are then installed into the repository and a new
;; modules database is generated
;;
;; If a `source` repository is given, its contents are also copied into
;; the new repository. This can be used to copy an existing repository
;; to another location.
;;
(define (create-repository destination #!optional source)
  (let ((destination* (make-absolute-pathname destination)))
    (create-directory destination* #t)
    (for-each (lambda (file)
                (copy-file file (pathname-replace-directory file destination*) #t))
              (install-egg-home-files))
    (when (and (string? source) (directory-exists? source))
      (copy-directory-tree source destination*))
    (receive (_ _ status) (process-wait
                           (process-fork
                            (lambda ()
                              (process-execute
                               (chicken-install)
                               (list "-update-db")
                               (list (cons "CHICKEN_REPOSITORY_PATH" destination*)
                                     (cons "CHICKEN_INSTALL_REPOSITORY" destination*))))))
      (unless (zero? status)
        (signal (condition '(exn message "failed to create module database")))))))