mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 13:49:17 +02:00
b52b2024f8
Currently a package's cond-expand contains the symbol of the target implementation and optionally more from config file. Execute a command (once) on target implementation to add their full feature list, making it available for each package to use. All of these Schemes are tested. Larceny is just too annoying to get the feature list (no one-liner, and it could take a while) so Larceny stays the current behavior. There is a small unrelated change here: the gosh command to get version. We don't need to call (exit), if stdin is closed properly (it should) then gosh should exit regardless.
570 lines
19 KiB
Scheme
570 lines
19 KiB
Scheme
|
|
;; (chibi io) utils
|
|
|
|
(define (port-fold kons knil . o)
|
|
(let ((read (if (pair? o) (car o) read))
|
|
(in (if (and (pair? o) (pair? (cdr o)))
|
|
(car (cdr o))
|
|
(current-input-port))))
|
|
(let lp ((acc knil))
|
|
(let ((x (read in)))
|
|
(if (eof-object? x) acc (lp (kons x acc)))))))
|
|
|
|
(define (port-map fn . o)
|
|
(reverse (apply port-fold (lambda (x ls) (cons (fn x) ls)) '() o)))
|
|
|
|
(define (port->list read in)
|
|
(port-map (lambda (x) x) read in))
|
|
|
|
(define (port->sexp-list in)
|
|
(port->list read in))
|
|
|
|
(define (port->bytevector in)
|
|
(let ((out (open-output-bytevector)))
|
|
(do ((c (read-u8 in) (read-u8 in)))
|
|
((eof-object? c) (get-output-bytevector out))
|
|
(write-u8 c out))))
|
|
|
|
;; general utils
|
|
|
|
(define (read-from-string str)
|
|
(call-with-input-string str read))
|
|
|
|
(define (display-to-string x)
|
|
(cond ((string? x) x)
|
|
((symbol? x) (symbol->string x))
|
|
((number? x) (number->string x))
|
|
(else (call-with-output-string (lambda (out) (display x out))))))
|
|
|
|
(define (maybe-parse-hex x)
|
|
(if (string? x) (hex-string->bytevector x) x))
|
|
|
|
;; rsa key utils
|
|
|
|
(define (lookup-digest name)
|
|
(case name
|
|
((md5) md5)
|
|
((sha-224) sha-224)
|
|
((sha-256) sha-256)
|
|
(else (error "unknown digest: " name))))
|
|
|
|
(define (rsa-identity=? email)
|
|
(lambda (x)
|
|
(cond ((not email) #f)
|
|
((assoc-get x 'email eq?)
|
|
=> (lambda (e) (string-ci=? email e)))
|
|
(else #f))))
|
|
|
|
(define (extract-rsa-key ls name)
|
|
(define (hex x)
|
|
(if (integer? x) x (string->number x 16)))
|
|
(cond
|
|
((assq name ls)
|
|
=> (lambda (x)
|
|
(let ((bits (assoc-get ls 'bits))
|
|
(modulus (assoc-get (cdr x) 'modulus))
|
|
(exponent (assoc-get (cdr x) 'exponent)))
|
|
(and bits modulus exponent
|
|
(if (eq? name 'private-key)
|
|
(make-rsa-key (hex bits) (hex modulus) #f (hex exponent))
|
|
(make-rsa-key (hex bits) (hex modulus)
|
|
(hex exponent) #f))))))
|
|
(else #f)))
|
|
|
|
(define (extract-rsa-private-key ls)
|
|
(extract-rsa-key ls 'private-key))
|
|
|
|
(define (extract-rsa-public-key ls)
|
|
(extract-rsa-key ls 'public-key))
|
|
|
|
;; repositories
|
|
|
|
(define (repo-url repo)
|
|
(and (pair? repo) (assoc-get (cdr repo) 'url eq?)))
|
|
|
|
(define (repo-find-publisher repo email)
|
|
(find (rsa-identity=? email)
|
|
(filter (lambda (x) (and (pair? x) (eq? 'publisher (car x))))
|
|
(cdr repo))))
|
|
|
|
;; packages
|
|
|
|
(define (package? x)
|
|
(and (pair? x) (eq? 'package (car x)) (every pair? (cdr x))))
|
|
|
|
(define (package-name package)
|
|
(and (pair? package)
|
|
(eq? 'package (car package))
|
|
(or (cond ((assoc-get (cdr package) 'name)
|
|
=> (lambda (x) (and (pair? x) x)))
|
|
(else #f))
|
|
(any library-name (package-libraries package))
|
|
(any program-name (package-programs package)))))
|
|
|
|
(define (package-email pkg)
|
|
(and (package? pkg)
|
|
(let ((sig (assq 'signature (cdr pkg))))
|
|
(and (pair? sig)
|
|
(assoc-get (cdr sig) 'email eq?)))))
|
|
|
|
(define (strip-email str)
|
|
(string-trim (regexp-replace '(: "<" (* (~ (">"))) ">") str "")))
|
|
|
|
(define (package-author repo pkg . o)
|
|
(let ((show-email? (and (pair? o) (car o))))
|
|
(cond
|
|
((not (package? pkg))
|
|
#f)
|
|
((assoc-get (cdr pkg) 'authors)
|
|
=> (lambda (authors)
|
|
(cond (show-email? authors)
|
|
((pair? authors) (map strip-email authors))
|
|
(else (strip-email authors)))))
|
|
(else
|
|
(let ((email (package-email pkg)))
|
|
(or (cond
|
|
((repo-find-publisher repo email)
|
|
=> (lambda (pub)
|
|
(let ((name (assoc-get pub 'name)))
|
|
(if (and name show-email?)
|
|
(string-append name " <" (or email "") ">")
|
|
(or name email "")))))
|
|
(else #f))
|
|
email))))))
|
|
|
|
(define (package-maintainer repo pkg . o)
|
|
(let ((show-email? (and (pair? o) (car o))))
|
|
(cond
|
|
((not (package? pkg))
|
|
#f)
|
|
((assoc-get (cdr pkg) 'maintainers)
|
|
=> (lambda (maint) (if show-email? maint (strip-email maint))))
|
|
(else
|
|
#f))))
|
|
|
|
(define (package-url repo pkg)
|
|
(let ((url (and (pair? pkg) (assoc-get (cdr pkg) 'url eq?))))
|
|
(and url
|
|
(uri-resolve url (string->path-uri 'http (or (repo-url repo) ""))))))
|
|
|
|
(define (package-version pkg)
|
|
(and (pair? pkg) (assoc-get (cdr pkg) 'version eq?)))
|
|
|
|
(define (package-digest-mismatches cfg pkg raw)
|
|
(let ((size (assoc-get (cdr pkg) 'size))
|
|
(actual-size (bytevector-length raw)))
|
|
(if (and (integer? size) (not (= size actual-size)))
|
|
`(size: expected: ,size actual: ,actual-size)
|
|
(let* ((digest-name (assoc-get (cdr pkg) 'digest #f 'sha-256))
|
|
(digest (assoc-get (cdr pkg) digest-name))
|
|
(actual-digest ((lookup-digest digest-name) raw)))
|
|
(and digest
|
|
(not (equal? digest actual-digest))
|
|
`(digest: ,digest-name expected: ,digest
|
|
actual: ,actual-digest))))))
|
|
|
|
(define (package-digest-ok? cfg pkg raw)
|
|
(not (package-digest-mismatches cfg pkg raw)))
|
|
|
|
(define (package-signature-mismatches repo cfg pkg raw)
|
|
(let* ((sig-spec (assoc-get-list (cdr pkg) 'signature))
|
|
(digest-name (assoc-get sig-spec 'digest #f 'sha-256))
|
|
(digest (assoc-get sig-spec digest-name))
|
|
(sig (assoc-get sig-spec 'rsa))
|
|
(email (assoc-get sig-spec 'email))
|
|
(rsa-key-sexp (repo-find-publisher repo email))
|
|
(rsa-key (and (pair? rsa-key-sexp)
|
|
(extract-rsa-public-key (cdr rsa-key-sexp)))))
|
|
(cond
|
|
((not email)
|
|
`(sign: missing-email ,sig-spec))
|
|
((not rsa-key)
|
|
`(sign: unknown-publisher: ,email))
|
|
((not (rsa-verify? rsa-key
|
|
(maybe-parse-hex digest)
|
|
(maybe-parse-hex sig)))
|
|
`(sign: rsa-signature-invalid: digest: ,digest sig: ,sig
|
|
actual: ,(rsa-verify rsa-key (maybe-parse-hex digest))))
|
|
(else #f))))
|
|
|
|
(define (package-signature-ok? cfg pkg raw)
|
|
(not (package-signature-mismatches cfg pkg raw)))
|
|
|
|
(define (failure str . args)
|
|
(let ((out (open-output-string)))
|
|
(display str out)
|
|
(cond
|
|
((pair? args)
|
|
(display ":" out)
|
|
(for-each (lambda (x) (display " " out) (write x out)) args)))
|
|
(get-output-string out)))
|
|
|
|
(define (invalid-library-reason lib)
|
|
(cond
|
|
((not (list? lib)) "library must be a list")
|
|
((not (list? (library-name lib)))
|
|
(failure "library name must be a list" (library-name lib)))
|
|
((not (every (lambda (x) (or (symbol? x) (integer? x))) (library-name lib)))
|
|
(failure "library name must contain only symbols or integers"
|
|
(library-name lib)))
|
|
(else #f)))
|
|
|
|
(define (valid-library? lib)
|
|
(not (invalid-library-reason lib)))
|
|
|
|
(define (invalid-program-reason prog)
|
|
(cond
|
|
((not (list? prog)) "program must be a list")
|
|
((not (or (assoc-get prog 'path) (assoc-get prog 'name)))
|
|
"program must have a path")
|
|
(else #f)))
|
|
|
|
(define (valid-program? prog)
|
|
(not (invalid-program-reason prog)))
|
|
|
|
(define (invalid-package-reason pkg)
|
|
(cond
|
|
((not (list? pkg))
|
|
"package must be a list")
|
|
((not (string? (package-version pkg)))
|
|
(failure "package-version is not a string" (package-version pkg)))
|
|
(else
|
|
(let ((libs (package-libraries pkg))
|
|
(progs (package-programs pkg)))
|
|
(cond
|
|
((and (not (pair? libs)) (not (pair? progs)))
|
|
"package must contain at least one library or program")
|
|
((any invalid-library-reason libs))
|
|
((any invalid-program-reason progs))
|
|
(else #f))))))
|
|
|
|
(define (valid-package? pkg)
|
|
(not (invalid-package-reason pkg)))
|
|
|
|
(define (package-for-impl impl cfg pkg)
|
|
(append
|
|
pkg
|
|
(append-map
|
|
(lambda (x)
|
|
(or (and (pair? x) (eq? 'cond-expand (car x))
|
|
(cond
|
|
((find
|
|
(lambda (clause) (check-cond-expand impl cfg (car clause)))
|
|
(cdr x))
|
|
=> cdr)
|
|
(else #f)))
|
|
'()))
|
|
(cdr pkg))))
|
|
|
|
(define (package-libraries package)
|
|
(and (package? package) (filter library? (cdr package))))
|
|
|
|
(define (package-programs package)
|
|
(and (package? package) (filter program? (cdr package))))
|
|
|
|
(define (package-data-files package)
|
|
(and (package? package)
|
|
(append-map cdr (filter data-files? (cdr package)))))
|
|
|
|
(define (package-provides? package name)
|
|
(and (pair? package)
|
|
(eq? 'package (car package))
|
|
(or (equal? name (assoc-get (cdr package) 'name))
|
|
(find (lambda (x) (equal? name (library-name x)))
|
|
(package-libraries package)))))
|
|
|
|
(define (package-dependencies impl cfg package)
|
|
(append-map (lambda (lib) (library-dependencies impl cfg lib))
|
|
(append (package-libraries package)
|
|
(package-programs package))))
|
|
|
|
(define (package-test-dependencies impl cfg package)
|
|
(let ((pkg (package-for-impl impl cfg package)))
|
|
(if (or (conf-get cfg '(command install skip-tests?))
|
|
(conf-get cfg '(command upgrade skip-tests?)))
|
|
'()
|
|
(or (assoc-get (cdr pkg) 'test-depends)
|
|
'()))))
|
|
|
|
(define (package-installed-files pkg)
|
|
(or (and (pair? pkg) (assoc-get-list (cdr pkg) 'installed-files)) '()))
|
|
|
|
(define (library-separator cfg)
|
|
(conf-get cfg 'library-separator "/"))
|
|
|
|
(define (library-name->path cfg name)
|
|
(if (null? name)
|
|
""
|
|
(call-with-output-string
|
|
(lambda (out)
|
|
(let lp ((name name))
|
|
(display (car name) out)
|
|
(cond ((pair? (cdr name))
|
|
(display (library-separator cfg) out)
|
|
(lp (cdr name)))))))))
|
|
|
|
;; map a library to the path name it would be found in (sans extension)
|
|
(define (library->path cfg library)
|
|
(library-name->path cfg (library-name library)))
|
|
|
|
;; find the library declaration file for the given library
|
|
(define (get-library-file cfg library)
|
|
(or (assoc-get library 'path)
|
|
(string-append (library->path cfg library) "."
|
|
(conf-get cfg 'library-extension "sld"))))
|
|
|
|
(define (package->path cfg pkg)
|
|
(library-name->path cfg (package-name pkg)))
|
|
|
|
(define (package-name->meta-file cfg name)
|
|
(let ((path (library-name->path cfg name)))
|
|
(string-append (path-directory path) "/."
|
|
(path-strip-directory path) ".meta")))
|
|
|
|
(define (get-package-meta-file cfg pkg)
|
|
(package-name->meta-file cfg (package-name pkg)))
|
|
|
|
(define (get-library-meta-file cfg lib)
|
|
(package-name->meta-file cfg (library-name lib)))
|
|
|
|
(define (library-file-name file)
|
|
(guard (exn (else #f))
|
|
(let ((x (call-with-input-file file read)))
|
|
(and (pair? x)
|
|
(memq (car x) '(define-library library))
|
|
(list? (cadr x))
|
|
(cadr x)))))
|
|
|
|
(define (find-library-file cfg lib-name . o)
|
|
(let ((base (string-append (library-name->path cfg lib-name)
|
|
"."
|
|
(conf-get cfg 'library-extension "sld"))))
|
|
(let lp ((dirs (append (or (and (pair? o) (car o)) '())
|
|
(cons "." (conf-get-list cfg 'library-path )))))
|
|
(and (pair? dirs)
|
|
(let ((path (make-path (car dirs) base)))
|
|
(or (and (file-exists? path)
|
|
(equal? lib-name (library-file-name path))
|
|
path)
|
|
(lp (cdr dirs))))))))
|
|
|
|
(define (tar-file? file)
|
|
(or (equal? (path-extension file) "tgz")
|
|
(and (member (path-extension file) '("gz" "bz2"))
|
|
(equal? (path-extension (path-strip-extension file)) "tar"))))
|
|
|
|
(define (package-file-unzipped file)
|
|
(and (tar-file? file)
|
|
(if (member (path-extension file) '("tgz" "gz"))
|
|
(gunzip (let* ((in (open-binary-input-file file))
|
|
(res (port->bytevector in)))
|
|
(close-input-port in)
|
|
res))
|
|
file)))
|
|
|
|
(define (package-file-meta file)
|
|
(let* ((unzipped-file (package-file-unzipped file))
|
|
(package-file
|
|
(and unzipped-file
|
|
(find
|
|
(lambda (x)
|
|
(and (equal? "package.scm" (path-strip-directory x))
|
|
(equal? "." (path-directory (path-directory x)))))
|
|
(tar-files unzipped-file)))))
|
|
(and package-file
|
|
(guard (exn (else #f))
|
|
(let* ((str (utf8->string
|
|
(tar-extract-file unzipped-file package-file)))
|
|
(package (read (open-input-string str))))
|
|
(and (pair? package)
|
|
(eq? 'package (car package))
|
|
package))))))
|
|
|
|
(define (package-file? file)
|
|
(and (package-file-meta file) #t))
|
|
|
|
(define (package-file-top-directory file)
|
|
(let ((unzipped-file (package-file-unzipped file)))
|
|
(and unzipped-file
|
|
(let lp ((file (car (tar-files unzipped-file))))
|
|
(let ((dir (path-directory file)))
|
|
(if (member dir '("" "." "/"))
|
|
file
|
|
(lp dir)))))))
|
|
|
|
;; libraries
|
|
|
|
(define (library? x)
|
|
(and (pair? x) (eq? 'library (car x)) (every pair? (cdr x))))
|
|
|
|
(define (library-name lib)
|
|
(and (pair? lib) (assoc-get (cdr lib) 'name eq?)))
|
|
|
|
(define (library-url lib)
|
|
(and (pair? lib) (assoc-get (cdr lib) 'url eq?)))
|
|
|
|
(define (library-for-impl impl cfg lib)
|
|
(append
|
|
lib
|
|
(append-map
|
|
(lambda (x)
|
|
(or (and (pair? x) (eq? 'cond-expand (car x))
|
|
(cond
|
|
((find
|
|
(lambda (clause) (check-cond-expand impl cfg (car clause)))
|
|
(cdr x))
|
|
=> cdr)
|
|
(else #f)))
|
|
'()))
|
|
(cdr lib))))
|
|
|
|
(define (library-dependencies impl cfg lib)
|
|
(append-map
|
|
(lambda (x) (or (and (pair? x) (eq? 'depends (car x)) (cdr x)) '()))
|
|
(cdr (library-for-impl impl cfg lib))))
|
|
|
|
(define (library-foreign-dependencies impl cfg lib)
|
|
(append-map
|
|
(lambda (x) (or (and (pair? x) (eq? 'foreign-depends (car x)) (cdr x)) '()))
|
|
(cdr (library-for-impl impl cfg lib))))
|
|
|
|
(define (parse-library-name str)
|
|
(cond
|
|
((pair? str) str)
|
|
((equal? "" str) (error "empty library name"))
|
|
((eqv? #\( (string-ref str 0)) (read-from-string str))
|
|
(else (map (lambda (x) (or (string->number x) (string->symbol x)))
|
|
(string-split str #\.)))))
|
|
|
|
(define (check-cond-expand impl config test)
|
|
(define (library-installed? config name)
|
|
;; assume it could be installed for now... this is effectively a
|
|
;; "suggested" package rather than a required one
|
|
#t)
|
|
(cond
|
|
((symbol? test)
|
|
(or (eq? test 'else)
|
|
(eq? test impl)
|
|
(memq test (conf-get-list config 'features))
|
|
(memq test (impl->features impl))))
|
|
((pair? test)
|
|
(case (car test)
|
|
((not) (not (check-cond-expand impl config (cadr test))))
|
|
((and) (every (lambda (x) (check-cond-expand impl config x)) (cdr test)))
|
|
((or) (any (lambda (x) (check-cond-expand impl config x)) (cdr test)))
|
|
((library) (every (lambda (x) (library-installed? config x)) (cdr test)))
|
|
(else
|
|
(warn "unknown cond-expand form" test)
|
|
#f)))
|
|
(else #f)))
|
|
|
|
(define (library-analyze-body impl config body dir)
|
|
(let lp ((ls body) (include-decls '()) (res '()))
|
|
(cond
|
|
((null? ls) (values (reverse res) (reverse include-decls)))
|
|
(else
|
|
(let ((decl (car ls)))
|
|
(case (and (pair? decl) (car decl))
|
|
((cond-expand)
|
|
(cond
|
|
((find (lambda (x) (check-cond-expand impl config (car x)))
|
|
(cdar ls))
|
|
=> (lambda (x) (lp (append (cdr x) (cdr ls)) include-decls res)))
|
|
(else (lp (cdr ls) include-decls res))))
|
|
((include-library-declarations)
|
|
(let* ((ls (if (pair? (cddr decl))
|
|
`((include-library-declarations ,@(cddr decl))
|
|
,@(cdr ls))
|
|
(cdr ls)))
|
|
(file (make-path dir (cadr decl)))
|
|
(dir (path-directory file))
|
|
(include-decls (cons file include-decls))
|
|
(sexp (call-with-input-file file port->sexp-list)))
|
|
(if (and (pair? sexp) (list? sexp))
|
|
(let-values (((lib sub-include-decls)
|
|
(library-analyze-body impl config sexp dir)))
|
|
(lp ls
|
|
(append (reverse sub-include-decls) include-decls)
|
|
(append (reverse lib) res)))
|
|
(lp ls include-decls res))))
|
|
(else
|
|
(lp (cdr ls)
|
|
include-decls
|
|
(if (pair? decl) (cons decl res) res)))))))))
|
|
|
|
;; We can't use the native library system introspection since we may
|
|
;; be analyzing a library which can't be loaded in the native system.
|
|
(define (library-analyze impl config file)
|
|
(let ((sexp (call-with-input-file file read)))
|
|
(and (list? sexp)
|
|
(memq (car sexp) '(define-library library define-module module))
|
|
(pair? sexp)
|
|
(pair? (cdr sexp))
|
|
(library-analyze-body impl config (cddr sexp) (path-directory file)))))
|
|
|
|
(define (library-include-files impl config file)
|
|
(let-values (((lib include-decls) (library-analyze impl config file))
|
|
((dir) (path-directory file)))
|
|
(append
|
|
(append-map
|
|
(lambda (x) (map (lambda (y) (make-path dir y)) (cdr x)))
|
|
(filter (lambda (x) (and (pair? x) (memq (car x) '(include include-ci))))
|
|
lib))
|
|
include-decls)))
|
|
|
|
(define (library-shared-include-files impl config file)
|
|
(let-values (((lib include-decls) (library-analyze impl config file))
|
|
((dir) (path-directory file)))
|
|
(append-map
|
|
(lambda (x) (map (lambda (y) (make-path dir y)) (cdr x)))
|
|
(filter (lambda (x) (and (pair? x) (eq? (car x) 'include-shared)))
|
|
lib))))
|
|
|
|
(define (library-rewrite-includes x rules)
|
|
(define (recurse x) (library-rewrite-includes x rules))
|
|
(define (rewrite x)
|
|
(cond ((find (lambda (r) (and (pair? r) (equal? x (car r)))) rules) => cadr)
|
|
(else x)))
|
|
(cond
|
|
((pair? x)
|
|
(case (car x)
|
|
((include include-ci)
|
|
(cons (car x) (map rewrite (cdr x))))
|
|
((cond-expand)
|
|
(cons (car x)
|
|
(map (lambda (y) (cons (car y) (map recurse (cdr y)))) (cdr x))))
|
|
((define-library library)
|
|
(cons (car x) (map recurse (cdr x))))
|
|
;; support define-library as well as the package format
|
|
((path) (cons (car x) (map rewrite (cdr x))))
|
|
(else x)))
|
|
(else x)))
|
|
|
|
;; programs
|
|
|
|
(define (program? x)
|
|
(and (pair? x) (eq? 'program (car x)) (every pair? (cdr x))))
|
|
|
|
(define (program-name prog)
|
|
(and (pair? prog)
|
|
(cond ((assoc-get (cdr prog) 'name eq?))
|
|
((assoc-get (cdr prog) 'path eq?)
|
|
=> (lambda (p) (list (string->symbol (path-strip-directory p)))))
|
|
(else #f))))
|
|
|
|
(define (get-program-file cfg prog)
|
|
(cond ((assoc-get prog 'path))
|
|
((assoc-get prog 'name)
|
|
=> (lambda (name) (library-name->path cfg (list (last name)))))
|
|
(else (error "program missing path: " prog))))
|
|
|
|
(define (program-install-name prog)
|
|
(or (assoc-get (cdr prog) 'install-name eq?)
|
|
(path-strip-extension
|
|
(path-strip-directory
|
|
(assoc-get (cdr prog) 'path eq?)))))
|
|
|
|
;; data files
|
|
|
|
(define (data-files? x)
|
|
(and (pair? x) (eq? 'data-files (car x))))
|