source: project/release/3/meta-setup/chicken-meta-setup.scm @ 11840

Last change on this file since 11840 was 11840, checked in by Kon Lovett, 13 years ago

Needs Unit files.

File size: 7.9 KB
Line 
1;;;; chicken-meta-setup.scm
2
3
4(use srfi-1)
5(use srfi-37 http-client tool files format-modular topological-sort)
6
7
8(define-constant +default-host+ "http://www.call-with-current-continuation.org")
9(define-constant +repository-file-name+ "repository")
10(define-constant +reinstall-progress-file+ "meta-setup-reinstall.status")
11(define-constant +upgrade-progress-file+ "meta-setup-upgrade.status")
12(define-constant +default-setup-program+ "chicken-setup")
13
14(define-constant +builtin-units+
15  '(posix srfi-1 srfi-4 srfi-18 srfi-13 srfi-14 extras match
16          utils regex tcp lolevel scheduler library eval posix))
17
18
19(define *repository-tree* #f)
20(define *dependency-tree* #f)
21
22(define *egg-directory*
23  (let ((m (##sys#fudge 41)))
24    (if (number? m)
25        (conc "eggs/" m)
26        "eggs" ) ) )
27
28
29(define-option "tree" "read repository tree from file" *tree-file*)
30(define-option "host" "specify alternative host for downloading" *host*)
31(define-option "setup-program" "specify alternative setup program (default: \"chicken-setup\")" 
32  *setup*)
33(define-option "setup-options" "give additional options for `chicken-setup' program"
34  *setup-options*)
35
36(define-option "repository" "specify local target repository" 
37  (lambda (o n x args)
38    (repository-path x)
39    args))
40
41(define-option '(#\x "exclude") "exclude list of extensions (space or comma separated)" *exclude*)
42
43(define-flag '(#\v "verbose") "show executed commands" *verbose*)
44(define-flag '(#\d "dry-run") "show, but do not execute commands" *dry-run*)
45(define-flag '(#\q "quiet") "do not show informational output" *quiet*)
46(define-flag '(#\y "dont-ask") "always continue, do not ask user" *dont-ask*)
47
48(define (bomb fstr . args)
49  (format (current-error-port) "Error: ~?~%" fstr args)
50  (exit 1) )
51
52(define (stop fstr . args)
53  (format (current-error-port) "~?~%" fstr args)
54  (exit 0) )
55
56(define (run fstr . args)
57  (let ((cmd (apply format #f fstr args)))
58    (when (or *verbose* *dry-run*) (print "  " cmd))
59    (unless *dry-run*
60      (let ((s (system cmd)))
61        (unless (zero? s)
62          (bomb "executing shell command failed: ~a" cmd))))))
63
64(define (yes-or-no? str . default)
65  (let ((def (:optional default #f)))
66    (if *dont-ask*
67        def
68        (let loop ()
69          (printf "~%~A (yes/no) " str)
70          (when def (printf "[~A] " def))
71          (flush-output)
72          (let ((ln (read-line)))
73            (cond ((eof-object? ln) (set! ln "no"))
74                  ((and def (string=? "" ln)) (set! ln def)) )
75            (cond ((string-ci=? "yes" ln) #t)
76                  ((string-ci=? "no" ln) #f)
77                  (else
78                   (printf "~%Please enter \"yes\" or \"no\".~%")
79                   (loop) ) ) ) ) ) ) )
80
81(define (symbol<? x y)
82  (string<? (symbol->string x) (symbol->string y)))
83
84(define (fetch-tree #!optional build-deps)
85  (unless *repository-tree*
86    (set! *repository-tree*
87      (sort
88       (let ((tree (cond (*tree-file* (with-input-from-file *tree-file* read))
89                         (else
90                          (with-input-from-string
91                              (http:GET (make-pathname 
92                                         (list (or *host* +default-host+) 
93                                               *egg-directory*)
94                                         +repository-file-name+
95                                         #f
96                                         "/"))
97                            read)))))
98         (unless (list? tree)
99           (bomb "repository tree corrupt or location invalid"))
100         tree)
101       (lambda (x y) (symbol<? (car x) (car y))))))
102  (when (and build-deps (not *dependency-tree*))
103    (set! *dependency-tree*
104      (map (lambda (info)
105             (cons (car info)
106                   (lset-difference
107                    eq?
108                    (cdddr info)
109                    +builtin-units+)))
110           *repository-tree*)))
111  *repository-tree*)
112
113(define (no-args args)
114  (unless (null? args)
115    (bomb "invalid argument~P: ~{~a ~}" (length args) args)))
116
117(define-command check "list extensions for which an upgrade is available"
118  (lambda (args)
119    (no-args args)
120    (fetch-tree)
121    (for-each
122     (lambda (info)
123       (match (upgrade-available? info)
124         ((rdate ldate)
125          (format #t "~32a available: ~a~@[ - installed: ~a~]~%" 
126                  (car info) rdate ldate))
127         (_ #f)))
128     *repository-tree*) ) )
129
130(define (upgrade-available? info)
131  (match info
132    ((name props . _)
133     (and-let* ((a (assq 'date props))
134                (info (extension-information name)) )
135       (let ((infoa (assq 'release info)))
136         (and (or (not infoa) (string>? (cadr a) (cadr infoa)))
137              (list (cadr a) (and infoa (cadr infoa)))))))))
138
139(define (install-list eggs pf)
140  (delete-file* pf)
141  (for-each
142   (lambda (egg)
143     (run "~a ~a -dont-ask ~@[~:*-host ~a ~]~a" 
144          (or *setup* +default-setup-program+) 
145          (or *setup-options* "")
146          *host* egg) 
147     (with-output-to-file pf (cut print egg) append:))
148   eggs)
149  (delete-file* pf))
150
151(define (installed-eggs)
152  (reverse
153   (topological-sort
154    (filter (lambda (a) (extension-information (car a))) *dependency-tree*)
155    eq?)))
156
157(define excluded 
158  (let ((excl #f))
159    (lambda (eggs)
160      (unless excl
161        (set! excl
162          (map string->symbol (string-split (or *exclude* "") " ,")) ) )
163      (lset-difference eq? eggs excl))))
164
165(define (check-meta eggs)
166  (cond ((memq 'meta-setup eggs)
167         (warning "meta-setup will not reinstall itself while running. Please enter `chicken-setup meta-setup' manually to upgrade.")
168         (delete 'meta-setup eggs eq?) )
169        (else eggs) ) )
170
171(define-command reinstall "re-install all eggs in the local extension repository"
172  (define-flag "resume" "resume previously aborted run" *resume*)
173  (lambda (args)
174    (no-args args)
175    (fetch-tree #t)
176    (let ((eggs (check-meta (installed-eggs))))
177      (when *resume*
178        (unless (file-exists? +reinstall-progress-file+)
179          (bomb "no previous reinstallation information available") )
180        (set! eggs
181              (excluded 
182               (lset-difference 
183                eq? eggs 
184                (map string->symbol (read-lines +reinstall-progress-file+)))) ) )
185      (when (null? eggs)
186        (stop "nothing to do"))
187      (unless *quiet*
188        (format #t "~%The following extensions will be re-installed:~2%~{\t~a~%~}" eggs))
189      (if (yes-or-no? "Do you want to continue?" "yes")
190          (install-list eggs +reinstall-progress-file+)
191          (print "Installation not started.")))))
192
193(define (egg-subset eggs args)
194  (excluded
195   (if (null? args)
196       eggs
197       (reverse
198        (topological-sort
199         (map (lambda (egg) (assq egg *dependency-tree*))
200              (delete-duplicates
201               (let collect ((args args))
202                 (if (null? args) 
203                     '()
204                     (let ((arg (car args)))
205                       (append (cons arg
206                                     (collect 
207                                      (cond ((assq arg *dependency-tree*) => cdr)
208                                            (else (bomb "unknown extension: ~a" arg)))))
209                               (collect (cdr args))))))
210               eq?))
211         eq?)))) )
212
213(define-command dependencies "show extension dependencies"
214  (define-flag "dump" "print dependency-tree as S-expression" *dump-deps*)
215  (lambda (args)
216    (fetch-tree #t)
217    (let ((eggs (egg-subset (installed-eggs) (map string->symbol args))))
218      (if *dump-deps*
219          (pp (filter (lambda (d) (memq (car d) eggs)) *dependency-tree*))
220          (for-each
221           (lambda (egg)
222             (let ((deps (and-let* ((a (assq egg *dependency-tree*))) (cdr a))))
223               (format #t "~32a~@[~* -> ~{~a~^, ~}~]~%" egg (pair? deps) deps)))
224           eggs)))))
225
226(define-command upgrade "upgrade extensions to newer version"
227  (define-flag "resume" "resume previously aborted run" *resume*)
228  (lambda (args)
229    (fetch-tree #t)
230    (let ((eggs (filter 
231                 (lambda (egg) (upgrade-available? (assq egg *repository-tree*)))
232                 (if (pair? args)
233                     (egg-subset (installed-eggs) (map string->symbol args))
234                     (installed-eggs)))) )
235      (set! eggs (check-meta eggs))
236      (when (null? eggs)
237        (stop "nothing to do"))
238      (when *resume*
239        (unless (file-exists? +upgrade-progress-file+)
240          (bomb "no previous upgrade information available") )
241        (set! eggs (lset-difference eq? eggs (map string->symbol (read-lines +upgrade-progress-file+)))))
242      (unless *quiet*
243        (format #t "~%The following extensions will be re-installed:~2%~{\t~a~%~}" eggs))
244      (if (yes-or-no? "Do you want to continue?" "yes")
245          (install-list eggs +upgrade-progress-file+)
246          (print "Installation not started.")))))
247
248(tool-name "chicken-meta-setup")
249(tool-help "Provides various operations on a local CHICKEN extension repository")
250(tool-main (command-line-arguments))
Note: See TracBrowser for help on using the repository browser.