~ chicken-core (chicken-5) c623cad942497e00b00a5ae9def4a5bef3d4ab61
commit c623cad942497e00b00a5ae9def4a5bef3d4ab61
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu May 19 15:47:54 2016 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sun Nov 13 11:32:19 2016 +0100
notes, cleanup in egg-compile, startup with chicken-install wrapper and download code.
diff --git a/egg-compile.scm b/egg-compile.scm
index e49b928e..419a2c4e 100644
--- a/egg-compile.scm
+++ b/egg-compile.scm
@@ -35,14 +35,14 @@
(for-each
(lambda (item)
(cond ((not (and (list? item) (pair? item) (symbol? (car item))))
- (error "egg-information item has invalid structure" item))
+ (error "egg-information item has invalid structure" item))
((not (memq (car item) valid-items))
- (error "invalid item" item))
+ (error "invalid item" item))
((and (memq (car item) named-items) (not (symbol? (cadr item))))
- (error "missing name for item" item))
+ (error "missing name for item" item))
((memq (car item) nested-items)
- (validate-egg-info
- (if (memq (car item) named-items) (cddr item) (cdr item))))))
+ (validate-egg-info
+ (if (memq (car item) named-items) (cddr item) (cdr item))))))
info))
@@ -61,7 +61,7 @@
(define (install-command platform)
(case platform
((unix) "cp")
- ((windows) "copy /y")))
+ ((windows) "xcopy /y")))
(define (destination-repository mode)
(case mode
@@ -313,7 +313,7 @@
" -D compiling-static-extension")))
(out (quotearg (target-file (conc name (object-extension platform)) mode)))
(src (quotearg (or source (conc name ".scm")))))
- (conc (slashify default-builder) " " out " " cmd (arglist options)
+ (conc (slashify default-builder platform) " " out " " cmd (arglist options)
" " src " -o " out " : "
src (arglist dependencies))))
@@ -323,16 +323,16 @@
(conc default-csc " -D compiling-extension -J -s")))
(out (quotearg (target-file (conc name ".so") mode)))
(src (quotearg (or source (conc name ".scm")))))
- (conc (slashify default-builder) " " out " " cmd (arglist options)
+ (conc (slashify default-builder platform) " " out " " cmd (arglist options)
(arglist link-options) " " src " -o " out " : "
src (arglist dependencies))))
-(define (gen-compile-import-library name #!key platform dependencies source kmode
+(define (gen-compile-import-library name #!key platform dependencies source mode
options link-options custom)
(let ((cmd (or custom (conc default-csc " -s")))
(out (quotearg (target-file (conc name ".import.so") mode)))
(src (quotearg (or source (conc name ".import.scm")))))
- (conc (slashify default-builder) " " out " " cmd (arglist options)
+ (conc (slashify default-builder platform) " " out " " cmd (arglist options)
(arglist link-options) " " src " -o " out " : "
src (arglist dependencies))))
@@ -342,7 +342,7 @@
(out (quotearg
(target-file (conc name (executable-extension platform)) mode)))
(src (quotearg (or source (conc name ".scm")))))
- (conc (slashify default-builder) " " out " " cmd (arglist options)
+ (conc (slashify default-builder platform) " " out " " cmd (arglist options)
(arglist link-options) " " src " -o " out " : "
src (arglist dependencies))))
@@ -352,7 +352,7 @@
(out (quotearg
(target-file (conc name (executable-extension platform)) mode)))
(src (quotearg (or source (conc name ".scm")))))
- (conc (slashify default-builder) " " out " " cmd (arglist options)
+ (conc (slashify default-builder platform) " " out " " cmd (arglist options)
(arglist link-options) " " src " -o " out " : "
src (arglist dependencies))))
@@ -364,42 +364,45 @@
(ext (object-extension platform))
(out (quotearg (target-file (conc name ext) mode)))
(dest (destination-repository mode)))
- (conc cmd " " out " " (quotearg (slashify (conc dest "/" name ext))))))
+ (conc cmd " " out " " (quotearg (slashify (conc dest "/" name ext) platform)))))
(define (gen-install-dynamic-extension name #!key platform mode)
(let ((cmd (install-command platform))
(out (quotearg (target-file (conc name ".so") mode)))
(dest (destination-repository mode)))
- (conc cmd " " out " " (quotearg (slashify (conc dest "/" name ".so"))))))
+ (conc cmd " " out " " (quotearg (slashify (conc dest "/" name ".so") platform)))))
(define (gen-install-import-library name #!key platform mode)
(let ((cmd (install-command platform))
(out (quotearg (target-file (conc name ".import.so") mode)))
(dest (destination-repository mode)))
- (conc cmd " " out " " (quotearg (slashify (conc dest "/" name ".import.so"))))))
+ (conc cmd " " out " "
+ (quotearg (slashify (conc dest "/" name ".import.so") platform)))))
(define (gen-install-import-library-source name #!key platform mode)
(let ((cmd (install-command platform))
(out (quotearg (target-file (conc name ".import.scm") mode)))
(dest (destination-repository mode)))
- (conc cmd " " out " " (quotearg (slashify (conc dest "/" name ".import.scm"))))))
+ (conc cmd " " out " "
+ (quotearg (slashify (conc dest "/" name ".import.scm") platform)))))
(define (gen-install-program name #!key platform mode)
(let* ((cmd (install-command platform))
(ext (executable-extension platform))
(out (quotearg (target-file (conc name ext) mode)))
- (dest (if (eq? mode 'target) target-bindir host-bindir9)))
- (conc cmd " " out " " (quotearg (slashify (conc dest "/" name ext))))))
+ (dest (if (eq? mode 'target) target-bindir host-bindir)))
+ (conc cmd " " out " "
+ (quotearg (slashify (conc dest "/" name ext) platform)))))
-(define (gen-install-data name #!key platform files destination)
+(define (gen-install-data name #!key platform files destination mode)
(let* ((cmd (install-command platform))
- (dest (or dest (if (eq? mode 'target) target-sharedir host-sharedir))))
- (conc cmd (arglist files) " " (quotearg (slashify dest)))))
+ (dest (or destination (if (eq? mode 'target) target-sharedir host-sharedir))))
+ (conc cmd (arglist files) " " (quotearg (slashify dest platform)))))
-(define (gen-install-c-include name #!key platform deps files dest)
+(define (gen-install-c-include name #!key platform deps files dest mode)
(let* ((cmd (install-command platform))
(dest (or dest (if (eq? mode 'target) target-incdir host-incdir))))
- (conc cmd " " (arglist files) " " (quotearg (slashify dest)))))
+ (conc cmd " " (arglist files) " " (quotearg (slashify dest platform)))))
(define command-table
`((compile-static-extension ,gen-compile-static-extension)
@@ -459,9 +462,3 @@
(define (arglist lst)
(apply conc (map (lambda (x) (conc " " (quotearg x))) lst)))
-
-
-;;
-
-(set! hyde (with-input-from-file "hyde.egg" read))
-(pp (receive (compile-egg-info hyde 'unix 'host)))
diff --git a/egg-download.scm b/egg-download.scm
index b61d20d9..2414d20b 100644
--- a/egg-download.scm
+++ b/egg-download.scm
@@ -10,23 +10,6 @@
(tcp-write-timeout +default-tcp-read/write-timeout+)
(define user-agent (conc "chicken-install " (chicken-version)))
-(define mode 'default)
-(define quiet #f)
-
-
-;; Simpler replacement for SRFI-13's string-suffix?
-(define (string-suffix? suffix s)
- (let ((len-s (string-length s))
- (len-suffix (string-length suffix)))
- (and (not (< len-s len-suffix))
- (string=? suffix
- (substring s (- len-s len-suffix))))))
-
-
-(define (d fstr . args)
- (let ((port (if quiet (current-error-port) (current-output-port))))
- (apply fprintf port fstr args)
- (flush-output port) ) )
(define (deconstruct-url url)
(let ((m (irregex-match +url-regex+ url)))
@@ -40,26 +23,6 @@
(or (and m (irregex-match-substring m 5))
"/"))))
-(define (download-egg egg url #!key version destination tests
- proxy-host proxy-port proxy-user-pass)
- (receive (host port locn) (deconstruct-url url)
- (let* ((locn (conc locn
- "?name=" egg
- "&release=" (##sys#fudge 41)
- (if version (string-append "&version=" version) "")
- "&mode=" mode
- (if tests "&tests=yes" "")))
- (eggdir (make-pathname destination egg))
- (pre-existing-dir? (file-exists? eggdir)) )
- (unless pre-existing-dir? (create-directory eggdir))
- (handle-exceptions exn
- (begin (unless pre-existing-dir? (remove-directory eggdir))
- (signal exn))
- (let ((fversion (http-fetch host port locn eggdir proxy-host
- proxy-port proxy-user-pass)))
- ;; If we get here then version of egg exists
- (values eggdir (or fversion version "")) )) ) ))
-
(define (http-fetch host port locn dest proxy-host proxy-port proxy-user-pass)
(let-values (((in out)
(http-connect host port locn proxy-host proxy-port
@@ -90,7 +53,7 @@
(set! in inpx) (set! out outpx)
(display
(make-HTTP-GET/1.1
- locn *chicken-install-user-agent* host port: port
+ locn user-agent host port: port
accept: "*/*"
proxy-host: proxy-host proxy-port: proxy-port
proxy-user-pass: proxy-user-pass)
@@ -140,7 +103,7 @@
(let* ((ins (skip))
(name (read ins)))
(cond ((and (pair? name) (eq? 'error (car name)))
- (throw-server-error (cadr name) (cddr name)))
+ (server-error (cadr name) (cddr name)))
((or (eof-object? name) (not name))
(close-input-port in)
(close-output-port out)
@@ -160,14 +123,14 @@
(cut display data) #:binary ) )
(get-files (cons name files)) ) ) ) ) ))
-(define (throw-server-error msg args)
+(define (server-error msg args)
(abort
- (make-composite-condition
- (make-property-condition
- 'exn
- 'message (string-append "[Server] " msg)
- 'arguments args)
- (make-property-condition 'setup-download-error))))
+ (make-composite-condition
+ (make-property-condition
+ 'exn
+ 'message (string-append "[Server] " msg)
+ 'arguments args)
+ (make-property-condition 'setup-download-error))))
(define (read-chunks in)
(let get-chunks ((data '()))
@@ -216,3 +179,55 @@
"")
"Content-length: " content-length "\r\n"
"\r\n") )
+
+(define (network-failure msg . args)
+ (signal
+ (make-composite-condition
+ (make-property-condition
+ 'exn
+ 'message "invalid response from server"
+ 'arguments args)
+ (make-property-condition 'http-fetch))) )
+
+
+;; entry point
+
+(define (download-egg egg url #!key version destination tests
+ proxy-host proxy-port proxy-user-pass)
+ (receive (host port locn) (deconstruct-url url)
+ (let* ((locn (conc locn
+ "?name=" egg
+ "&release=" (##sys#fudge 41)
+ (if version (string-append "&version=" version) "")
+ "&mode=default"
+ (if tests "&tests=yes" "")))
+ (eggdir (make-pathname destination egg)))
+ (let ((fversion (http-fetch host port locn eggdir proxy-host
+ proxy-port proxy-user-pass)))
+ ;; If we get here then version of egg exists
+ (values eggdir (or fversion version "")) )) ) )
+
+(define (try-download name url #!key version destination tests username
+ password proxy-host proxy-port proxy-user-pass)
+ (condition-case
+ (download-egg
+ name url
+ version: version
+ destination: destination
+ tests: tests
+ username: username
+ password: password
+ proxy-host: proxy-host
+ proxy-port: proxy-port
+ proxy-user-pass: proxy-user-pass)
+ ((exn net)
+ (print "TCP connect timeout")
+ (values #f "") )
+ ((exn http-fetch)
+ (print "HTTP protocol error")
+ (values #f "") )
+ (e (exn setup-download-error)
+ (print "Server error:")
+ (print-error-message e)
+ (values #f ""))
+ (e () (abort e) )))
diff --git a/egg-environment.scm b/egg-environment.scm
index f79eab61..da841b02 100644
--- a/egg-environment.scm
+++ b/egg-environment.scm
@@ -47,12 +47,14 @@ EOF
(string-append default-bindir "/chicken-do"))
(define host-repo (foreign-value "C_INSTALL_EGG_HOME" c-string))
+(define host-bindir (foreign-value "C_INSTALL_BIN_HOME" c-string))
(define host-incdir (foreign-value "C_INSTALL_INCLUDE_HOME" c-string))
(define host-sharedir (foreign-value "C_INSTALL_SHARE_HOME" c-string))
(define target-repo
(string-append default-libdir "/chicken/" (number->string binary-version)))
+(define target-bindir (foreign-value "C_TARGET_BIN_HOME" c-string))
(define target-incdir (foreign-value "C_TARGET_INCLUDE_HOME" c-string))
(define target-sharedir (foreign-value "C_TARGET_SHARE_HOME" c-string))
diff --git a/new-install.scm b/new-install.scm
new file mode 100644
index 00000000..1e5a3598
--- /dev/null
+++ b/new-install.scm
@@ -0,0 +1,193 @@
+;;;;
+
+(module main ()
+
+(import (scheme))
+(import (chicken))
+(import (chicken foreign))
+(import (chicken data-structures))
+(import (chicken keyword))
+(import (chicken files))
+(import (chicken format))
+(import (chicken irregex))
+(import (chicken tcp))
+(import (chicken posix))
+(import (chicken io))
+(import (chicken pretty-print))
+
+(define +defaults-version+ 1)
+(define +module-db+ "modules.db")
+(define +defaults-file+ "setup.defaults")
+(define +short-options+ '(#\h))
+
+(include "mini-srfi-1.scm")
+(include "egg-environment.scm")
+(include "egg-compile.scm")
+(include "egg-download.scm")
+
+(define quiet #f)
+(define default-sources '())
+(define mappings '())
+(define aliases '())
+(define override '())
+(define hacks '())
+(define proxy-host #f)
+(define proxy-port #f)
+(define proxy-user-pass #f)
+
+
+;; usage information
+
+(define (usage code)
+
+ ;;XXX
+
+ (exit code))
+
+
+;; utilities
+
+;; Simpler replacement for SRFI-13's string-suffix?
+(define (string-suffix? suffix s)
+ (let ((len-s (string-length s))
+ (len-suffix (string-length suffix)))
+ (and (not (< len-s len-suffix))
+ (string=? suffix
+ (substring s (- len-s len-suffix))))))
+
+(define (d fstr . args)
+ (let ((port (if quiet (current-error-port) (current-output-port))))
+ (apply fprintf port fstr args)
+ (flush-output port) ) )
+
+
+;; load defaults file ("setup.defaults")
+
+(define (load-defaults)
+ (let ((deff (make-pathname host-sharedir +defaults-file+)))
+ (define (broken x)
+ (error "invalid entry in defaults file" deff x))
+ (cond ((not (file-exists? deff)) '())
+ (else
+ (for-each
+ (lambda (x)
+ (unless (and (list? x) (positive? (length x)))
+ (broken x))
+ (case (car x)
+ ((version)
+ (cond ((not (pair? (cdr x))) (broken x))
+ ((not (= (cadr x) +defaults-version+))
+ (error
+ (sprintf
+ "version of installed `~a' does not match chicken-install version (~a)"
+ +defaults-file+
+ +defaults-version+)
+ (cadr x)))
+ ;; others are ignored
+ ))
+ ((server)
+ (set! default-sources
+ (append default-sources (list (cdr x)))))
+ ((map)
+ (set! mappings
+ (append
+ mappings
+ (map (lambda (m)
+ (let ((p (list-index (cut eq? '-> <>) m)))
+ (unless p (broken x))
+ (let-values (((from to) (split-at m p)))
+ (cons from (cdr to)))))
+ (cdr x)))))
+ ((alias)
+ (set! aliases
+ (append
+ aliases
+ (map (lambda (a)
+ (if (and (list? a) (= 2 (length a)) (every string? a))
+ (cons (car a) (cadr a))
+ (broken x)))
+ (cdr x)))))
+ ((override)
+ (set! override
+ (if (and (pair? (cdr x)) (string? (cadr x)))
+ (call-with-input-file (cadr x) read-all)
+ (cdr x))))
+ ((hack)
+ (set! hacks (append hacks (list (eval (cadr x))))))
+ (else (broken x))))
+ (call-with-input-file deff read-all))))
+ (pair? default-sources) ))
+
+(define (setup-proxy uri)
+ (and-let* (((string? uri))
+ (m (irregex-match "(http://)?([^:]+):?([0-9]*)" uri))
+ (port (irregex-match-substring m 3)))
+ (set! proxy-user-pass (get-environment-variable "proxy_auth"))
+ (set! proxy-host (irregex-match-substring m 2))
+ (set! proxy-port (or (string->number port) 80))))
+
+(define (apply-mappings eggs)
+ (define (canonical x)
+ (cond ((symbol? x) (cons (symbol->string x) #f))
+ ((string? x) (cons x #f))
+ ((pair? x) x)
+ (else (error "internal error - bad egg spec" x))))
+ (define (same? e1 e2)
+ (equal? (car (canonical e1)) (car (canonical e2))))
+ (let ((eggs2
+ (delete-duplicates
+ (append-map
+ (lambda (egg)
+ (cond ((find (lambda (m) (find (cut same? egg <>) (car m)))
+ *mappings*) =>
+ (lambda (m) (map ->string (cdr m))))
+ (else (list egg))))
+ eggs)
+ same?)))
+ (unless (and (= (length eggs) (length eggs2))
+ (every (lambda (egg) (find (cut same? <> egg) eggs2)) eggs))
+ (print "mapped " eggs " to " eggs2))
+ eggs2))
+
+(define (perform-actions eggs)
+ (let ((eggs (apply-mappings eggs)))
+
+
+(define (main args)
+ (setup-proxy (get-environment-variable "http_proxy"))
+ (let ((eggs '())
+ (rx (irregex "([^:]+):(.+)")))
+ (let loop ((args args))
+ (if (null? args)
+ (perform-actions (reverse eggs))
+ (let ((arg (car args)))
+ (cond ((member arg '("-h" "-help" "--help"))
+ (usage 0))
+
+ ;;XXX
+
+ ((and (positive? (string-length arg))
+ (char=? #\- (string-ref arg 0)))
+ (if (> (string-length arg) 2)
+ (let ((sos (string->list (substring arg 1))))
+ (if (every (cut memq <> +short-options+) sos)
+ (loop (append
+ (map (cut string #\- <>) sos)
+ (cdr args))
+ eggs)
+ (usage 1)))
+ (usage 1)))
+ ((irregex-match rx arg) =>
+ (lambda (m)
+ (set! eggs
+ (alist-cons
+ (irregex-match-substring m 1)
+ (irregex-match-substring m 2)
+ eggs))))
+ (else
+ (set! eggs (cons arg args))
+ (loop (cdr args)))))))))
+
+(main (command-line-arguments))
+
+)
diff --git a/rules.make b/rules.make
index 09fdd76f..3017cc7e 100644
--- a/rules.make
+++ b/rules.make
@@ -663,7 +663,8 @@ chicken-status.c: chicken-status.scm \
chicken.posix.import.scm \
chicken.pretty-print.import.scm \
setup-api.import.scm
-chicken-install.c: chicken-install.scm \
+#XXX new-install.scm -> chicken-install.scm
+chicken-install.c: new-install.scm \
chicken.data-structures.import.scm \
chicken.files.import.scm \
chicken.foreign.import.scm \
@@ -673,9 +674,7 @@ chicken-install.c: chicken-install.scm \
chicken.pathname.import.scm \
chicken.ports.import.scm \
chicken.posix.import.scm \
- chicken.pretty-print.import.scm \
- setup-api.import.scm \
- setup-download.import.scm
+ chicken.pretty-print.import.scm
chicken-uninstall.c: chicken-uninstall.scm \
chicken.data-structures.import.scm \
chicken.foreign.import.scm \
@@ -870,7 +869,8 @@ csi.c: $(SRCDIR)csi.scm $(SRCDIR)banner.scm
$(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
chicken-profile.c: $(SRCDIR)chicken-profile.scm $(SRCDIR)mini-srfi-1.scm
$(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
-chicken-install.c: $(SRCDIR)chicken-install.scm $(SRCDIR)mini-srfi-1.scm
+#XXX new-install -> chicken-install.scm
+chicken-install.c: $(SRCDIR)new-install.scm $(SRCDIR)mini-srfi-1.scm $(SRCDIR)egg-compile.scm $(SRCDIR)egg-download.scm $(SRCDIR)egg-environment.scm
$(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
chicken-uninstall.c: $(SRCDIR)chicken-uninstall.scm $(SRCDIR)mini-srfi-1.scm
$(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
diff --git a/setup.defaults b/setup.defaults
index c427f783..c25d546a 100644
--- a/setup.defaults
+++ b/setup.defaults
@@ -4,22 +4,20 @@
;; version-number of the defaults file - checked by "chicken-install"
; when defaults are loaded
-(version 1)
+(version 2)
;; list of servers in the order in which they will be processed
;
-; (server (location URL) (transport TRANSPORT))
+; (server (location URL))
;
; URL may be an alias (see below) or a real URL
(server
- (location "kitten-technologies")
- (transport http))
+ (location "kitten-technologies"))
(server
- (location "call-cc")
- (transport http))
+ (location "call-cc"))
;; extensions-mappings
Trap