~evhan/beaker

ref: ab7ad7060a35979dc5334c5d5a7c9fcbf8c07edc beaker/lib/beaker/repository.scm -rw-r--r-- 5.7 KiB
ab7ad706Evan Hanson Add `repair-repository` helper 3 years ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Procedures to help manage egg repositories.
;;;
;;; Copyright (c) 2018-2019, 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 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))

;;
;; 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)))

;;
;; 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*))))
    (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")))))))