~ chicken-core (chicken-5) f3370bc522ff80ef435d8dc0afc65cec3222246c
commit f3370bc522ff80ef435d8dc0afc65cec3222246c
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Jun 15 14:39:15 2016 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sun Nov 13 11:32:19 2016 +0100
various changes to make a basic chicken-install compile
diff --git a/egg-compile.scm b/egg-compile.scm
index 419a2c4e..e7102ee1 100644
--- a/egg-compile.scm
+++ b/egg-compile.scm
@@ -46,6 +46,20 @@
info))
+;;; load egg-info from file and perform validation
+
+(define (load-egg-info fname)
+ (with-input-from-file fname
+ (lambda () (validate-egg-info (read)))))
+
+
+;;; lookup specific entries in egg-information
+
+(define (get-egg-property info prop #!optional default)
+ (let ((p (assq prop info)))
+ (or (and p (cadr p)) default)))
+
+
;;; some utilities
(define (object-extension platform)
@@ -58,11 +72,13 @@
((unix) unix-executable-extension)
((windows) windows-executable-extension)))
-(define (install-command platform)
+(define (copy-directory-command platform)
(case platform
((unix) "cp")
((windows) "xcopy /y")))
+(define install-command copy-directory-command)
+
(define (destination-repository mode)
(case mode
((target) target-repo)
diff --git a/egg-download.scm b/egg-download.scm
index 2414d20b..2a1f5bb3 100644
--- a/egg-download.scm
+++ b/egg-download.scm
@@ -24,11 +24,18 @@
"/"))))
(define (http-fetch host port locn dest proxy-host proxy-port proxy-user-pass)
- (let-values (((in out)
+ (let-values (((in out _)
(http-connect host port locn proxy-host proxy-port
proxy-user-pass)))
(http-retrieve-files in out dest)))
+(define (http-query host port locn proxy-host proxy-port proxy-user-pass)
+ (let-values (((in out len)
+ (http-connect host port locn proxy-host proxy-port
+ proxy-user-pass)))
+ (close-output-port out)
+ (http-retrieve-response in len)))
+
(define (http-connect host port locn proxy-host proxy-port proxy-user-pass)
(d "connecting to host ~s, port ~a ~a...~%" host port
(if proxy-host
@@ -44,6 +51,7 @@
(flush-output out)
(d "reading response ...~%")
(let* ((chunked #f)
+ (datalen #f)
(h1 (read-line in))
(response-match (match-http-response h1)))
(d "~a~%" h1)
@@ -63,15 +71,18 @@
(let loop ()
(let ((ln (read-line in)))
(unless (equal? ln "")
- (when (match-chunked-transfer-encoding ln) (set! chunked #t))
+ (cond ((match-chunked-transfer-encoding ln)
+ (set! chunked #t))
+ ((match-content-length ln) =>
+ (lambda (sz) (set! datalen sz))))
(d "~a~%" ln)
(loop) ) ) ) )
(when chunked
(d "reading chunks ")
(let ((data (read-chunks in)))
(close-input-port in)
- (set! in (open-input-string data))) ) )
- (values in out))))
+ (set! in (open-input-string data))) )
+ (values in out datalen)))))
(define (http-retrieve-files in out dest)
(d "reading files ...~%")
@@ -123,6 +134,12 @@
(cut display data) #:binary ) )
(get-files (cons name files)) ) ) ) ) ))
+(define (http-retrieve-response in len)
+ (d "reading response ...~%")
+ (let ((data (read-string len in)))
+ (close-input-port in)
+ data))
+
(define (server-error msg args)
(abort
(make-composite-condition
@@ -157,6 +174,10 @@
(define (match-chunked-transfer-encoding ln)
(irregex-match "[Tt]ransfer-[Ee]ncoding:\\s*chunked.*" ln) )
+(define (match-content-length ln)
+ (let ((m (irregex-match "[Cc]ontent-[Ll]ength:\\s*([0-9]+).*" ln)))
+ (and m (string->number (irregex-match-substring m 1)))))
+
(define (make-HTTP-GET/1.1 location user-agent host
#!key
(port 80)
@@ -190,34 +211,58 @@
(make-property-condition 'http-fetch))) )
-;; entry point
+;; entry points
+
+(define (list-versions egg url)
+ (receive (host port locn) (deconstruct-url url)
+ (let ((locn (conc locn
+ "?name=" egg
+ "&release=" (##sys#fudge 41)
+ "&mode=default"
+ "&listversions=1")))
+ (let ((data (http-query host port locn proxy-host
+ proxy-port proxy-user-pass)))
+ (string-split data)))))
+
+(define (try-list-versions name url #!key
+ proxy-host proxy-port proxy-user-pass)
+ (condition-case (list-versions name url)
+ ((exn net)
+ (print "TCP connect timeout")
+ #f)
+ ((exn http-fetch)
+ (print "HTTP protocol error")
+ #f)
+ (e (exn setup-download-error)
+ (print "Server error:")
+ (print-error-message e)
+ #f)
+ (e () (abort e) )))
(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" "")))
+ "?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)
+(define (try-download name url #!key version destination tests
+ 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-host: proxy-host
proxy-port: proxy-port
proxy-user-pass: proxy-user-pass)
((exn net)
diff --git a/new-install.scm b/new-install.scm
index 1e5a3598..094f2bd6 100644
--- a/new-install.scm
+++ b/new-install.scm
@@ -13,12 +13,17 @@
(import (chicken tcp))
(import (chicken posix))
(import (chicken io))
+(import (chicken time))
(import (chicken pretty-print))
(define +defaults-version+ 1)
(define +module-db+ "modules.db")
(define +defaults-file+ "setup.defaults")
-(define +short-options+ '(#\h))
+(define +short-options+ '(#\r #\h))
+(define +one-hour+ (* 60 60))
+(define +timestamp-file+ "TIMESTAMP")
+(define +status-file+ "STATUS")
+(define +egg-extension+ "egg")
(include "mini-srfi-1.scm")
(include "egg-environment.scm")
@@ -26,7 +31,8 @@
(include "egg-download.scm")
(define quiet #f)
-(define default-sources '())
+(define default-servers '())
+(define default-locations '())
(define mappings '())
(define aliases '())
(define override '())
@@ -34,14 +40,34 @@
(define proxy-host #f)
(define proxy-port #f)
(define proxy-user-pass #f)
+(define retrieve-only #f)
+(define canonical-eggs '())
+(define run-tests #f)
+(define platform
+ (if (eq? 'mingw (build-platform))
+ 'windows
+ 'unix))
+
+(define current-status
+ (list (get-environment-variable "CSC_OPTIONS"))) ;XXX more?
+
+(define (probe-dir dir)
+ (and dir (file-exists? dir) (directory? dir) dir))
-;; usage information
+(define cache-directory
+ (make-pathname (or (probe-dir (get-environment-variable "HOME"))
+ (probe-dir (get-environment-variable "USERPROFILE"))
+ (probe-dir "/tmp")
+ (probe-dir "/Temp")
+ ".")
+ ".chicken-install.cache"))
-(define (usage code)
- ;;XXX
+;; usage information
+(define (usage code)
+ ;;XXX
(exit code))
@@ -60,6 +86,25 @@
(apply fprintf port fstr args)
(flush-output port) ) )
+(define (version>=? v1 v2)
+ (define (version->list v)
+ (map (lambda (x) (or (string->number x) x))
+ (irregex-split "[-\\._]" (->string v))))
+ (let loop ((p1 (version->list v1))
+ (p2 (version->list v2)))
+ (cond ((null? p1) (null? p2))
+ ((null? p2))
+ ((number? (car p1))
+ (and (number? (car p2))
+ (or (> (car p1) (car p2))
+ (and (= (car p1) (car p2))
+ (loop (cdr p1) (cdr p2))))))
+ ((number? (car p2)))
+ ((string>? (car p1) (car p2)))
+ (else
+ (and (string=? (car p1) (car p2))
+ (loop (cdr p1) (cdr p2)))))))
+
;; load defaults file ("setup.defaults")
@@ -86,8 +131,8 @@
;; others are ignored
))
((server)
- (set! default-sources
- (append default-sources (list (cdr x)))))
+ (set! default-servers
+ (append default-servers (list (cdr x)))))
((map)
(set! mappings
(append
@@ -112,12 +157,17 @@
(if (and (pair? (cdr x)) (string? (cadr x)))
(call-with-input-file (cadr x) read-all)
(cdr x))))
+ ((location)
+ (set! default-locations
+ (append default-locations (list (cdr x)))))
((hack)
(set! hacks (append hacks (list (eval (cadr x))))))
(else (broken x))))
- (call-with-input-file deff read-all))))
- (pair? default-sources) ))
+ (call-with-input-file deff read-all))))))
+
+;; set variables with HTTP proxy information
+
(define (setup-proxy uri)
(and-let* (((string? uri))
(m (irregex-match "(http://)?([^:]+):?([0-9]*)" uri))
@@ -126,6 +176,9 @@
(set! proxy-host (irregex-match-substring m 2))
(set! proxy-port (or (string->number port) 80))))
+
+;; apply egg->egg mappings loaded from defaults
+
(define (apply-mappings eggs)
(define (canonical x)
(cond ((symbol? x) (cons (symbol->string x) #f))
@@ -139,19 +192,140 @@
(append-map
(lambda (egg)
(cond ((find (lambda (m) (find (cut same? egg <>) (car m)))
- *mappings*) =>
+ 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))
+ (d "mapped ~s to ~s~%" eggs eggs2))
eggs2))
+
+;; override versions, if specified in "overrides" file
+
+(define (override-version egg)
+ (let ((name (string->symbol (if (pair? egg) (car egg) egg))))
+ (cond ((assq name override) =>
+ (lambda (a)
+ (cond ((and (pair? egg) (not (equal? (cadr a) (cdr egg))))
+ (warning
+ (sprintf
+ "version `~a' of extension `~a' overrides explicitly given version `~a'"
+ (cadr a) name (cdr egg))))
+ (else (d "overriding: ~a~%" a)))
+ (cadr a)))
+ ((pair? egg) (cdr egg))
+ (else #f))))
+
+
+;; "locate" egg: either perform HTTP download or copy from a file-system
+;; location, also make sure it is up to date
+
+(define (locate-egg name version)
+ (let* ((cached (make-pathname cache-directory name))
+ (now (current-seconds))
+ (timestamp (make-pathname cached +timestamp-file+))
+ (status (make-pathname cached +status-file+))
+ (eggfile (make-pathname cached name +egg-extension+)))
+ (define (fetch)
+ (when (file-exists? cached)
+ (delete-directory cached #t))
+ (fetch-egg-sources name version cached)
+ (with-output-to-file status (cut write current-status)))
+ (cond ((not (probe-dir cached)) (fetch))
+ ((and (file-exists? status)
+ (not (equal? current-status
+ (with-input-from-file status read))))
+ (fetch)))
+ (let* ((info (load-egg-info eggfile))
+ (lversion (get-egg-property info 'version)))
+ (cond ((and (file-exists? timestamp)
+ (> (- now (with-input-from-file timestamp read)) +one-hour+)
+ (not (check-server-version name version lversion)))
+ (fetch)
+ (let ((info (load-egg-info eggfile)))
+ (values cached (get-egg-property info 'version))))
+ (else (values cached version))))))
+
+(define (fetch-egg-sources name version dest)
+ (let loop ((locs default-locations))
+ (cond ((null? locs)
+ (let loop ((srvs default-servers))
+ (receive (dir ver)
+ (try-download name (car srvs)
+ version: version
+ destination: dest
+ tests: run-tests
+ proxy-host: proxy-host
+ proxy-port: proxy-port
+ proxy-user-pass: proxy-user-pass)
+ (cond (dir
+ (with-output-to-file
+ (make-pathname dest +timestamp-file+)
+ (lambda () (write (current-seconds)))))
+ ((null? srvs) (error "extension or version not found"))
+ (else (loop (cdr srvs)))))))
+ ((probe-dir (make-pathname (car locs) name))
+ => (lambda (dir)
+ (let* ((eggfile (make-pathname dir name +egg-extension+))
+ (info (load-egg-info eggfile))
+ (rversion (get-egg-property info 'version)))
+ (if (or (not rversion)
+ (version>=? rversion version))
+ (copy-egg-sources dir dest)
+ (loop (cdr locs))))))
+ (else (loop (cdr locs))))))
+
+(define (copy-egg-sources from to)
+ ;;XXX should probably be done manually, instead of calling tool
+ (let ((cmd (quote-all
+ (string-append
+ (copy-directory-command platform)
+ " " (quotearg from) " " (quotearg to))
+ platform)))
+ (system cmd)))
+
+(define (check-server-version name version lversion)
+ (let loop ((srvs default-servers))
+ (and (pair? srvs)
+ (let ((versions (try-list-versions name (car srvs))))
+ (or (and versions
+ (any (cut version>=? <> version) versions))
+ (loop (cdr srvs)))))))
+
+
+;; retrieve eggs, recursively (if needed)
+
+(define (retrieve-eggs eggs)
+ (for-each
+ (lambda (egg)
+ (cond ((assoc egg canonical-eggs) =>
+ (lambda (a)
+ ;; push to front
+ (set! canonical-eggs (cons a (delete a canonical-eggs eq?)))))
+ (else
+ (let ((name (if (pair? egg) (car egg) egg))
+ (version (override-version egg)))
+ (let-values (((dir ver) (locate-egg name version)))
+ (when (or (not dir)
+ (null? (directory dir)))
+ (error "extension or version not found"))
+ (d " ~a located at ~a~%")
+ (set! canonical-eggs
+ (cons (list name dir ver) canonical-eggs)))))))
+ eggs)
+ (unless retrieve-only
+ (error "to be implemented"))) ; XXX
+
+
+;; command line parsing and selection of operations
+
(define (perform-actions eggs)
(let ((eggs (apply-mappings eggs)))
-
+ ;;XXX...
+ (retrieve-eggs eggs)))
(define (main args)
(setup-proxy (get-environment-variable "http_proxy"))
@@ -163,6 +337,8 @@
(let ((arg (car args)))
(cond ((member arg '("-h" "-help" "--help"))
(usage 0))
+ ((equal? arg "-test")
+ (set! run-tests #t))
;;XXX
@@ -173,8 +349,7 @@
(if (every (cut memq <> +short-options+) sos)
(loop (append
(map (cut string #\- <>) sos)
- (cdr args))
- eggs)
+ (cdr args)))
(usage 1)))
(usage 1)))
((irregex-match rx arg) =>
Trap