~evhan/beaker unlisted

ab7ad7060a35979dc5334c5d5a7c9fcbf8c07edc — Evan Hanson 1 year, 4 months ago 260a296
Add `repair-repository` helper
1 files changed, 49 insertions(+), 2 deletions(-)

M lib/beaker/repository.scm
M lib/beaker/repository.scm => lib/beaker/repository.scm +49 -2
@@ 13,16 13,26 @@
;;
(declare
  (module (beaker repository))
  (export chicken-install create-repository egg-files)
  (import (chicken condition)
  (export chicken-install egg-files repair-repository create-repository)
  (import (beaker egg info)
          (chicken condition)
          (chicken file)
          (chicken foreign)
          (except (chicken pathname) make-absolute-pathname)
          (chicken platform)
          (chicken process)
          (chicken process-context)
          (chicken string)
          (srfi 1)))

(define (alist-merge x . ys)
  (foldl (lambda (x* y)
           (alist-update (car y) (cdr y) x*))
         x
         (if (null? ys)
             (list)
             (apply alist-merge ys))))

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



@@ 60,6 70,43 @@
      path
      (make-pathname (current-directory) path)))

;;
;; Installs any missing dependencies for the eggs 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.
;;
;; If there are any missing dependencies, they are installed into the
;; first repository in the path and a list of newly-installed eggs is
;; returned.
;;
;; If there are no missing dependencies, nothing is done and an empty
;; list is returned.
;;
(define (repair-repository #!optional (path repository-path))
  (let* ((repositories (path))
         (egg-files    (egg-files path))
         (path         (string-intersperse repositories ":"))
         (required     (append-map egg-dependencies egg-files))
         (installed    (map egg-name egg-files))
         (missing      (lset-difference eq? required installed)))
    (if (null? missing)
        (list)
        (receive (_ _ status) (let ((repository (make-absolute-pathname (car repositories))))
                                (process-wait
                                 (process-fork
                                  (lambda ()
                                    (process-execute
                                     (chicken-install)
                                     (map symbol->string missing)
                                     (alist-merge
                                      (list (cons "CHICKEN_INSTALL_REPOSITORY" repository)
                                            (cons "CHICKEN_REPOSITORY_PATH" path))
                                      (get-environment-variables)))))))
          (if (zero? status)
              (delete-duplicates! missing)
              (signal (condition '(exn message "failed to install missing eggs"))))))))

(define (copy-directory-tree source destination)
  (let* ((source* (make-absolute-pathname source))
         (source-prefix-length (add1 (string-length source*))))