Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Supporting multiple repositories and siblings traversal.

Browse source 
Annotating (use-for test) for test libraries.
This commit is contained in:
Alex Shinn 2015-05-07 00:10:34 +09:00
parent d05b5c2d92
commit 9b5fe665cc
7 changed files with 164 additions and 33 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

141
lib/chibi/snow/commands.scm
View file

@ -482,7 +482,7 @@
(version (package-output-version cfg))
(maintainers (conf-get-list cfg '(command package maintainers)))
(license (package-license cfg)))
(let lp ((ls (map (lambda (x) (cons x #f)) libs))
(let lp ((ls (map (lambda (x) (list x #f)) libs))
(progs programs)
(res
`(,@(if license `((license ,license)) '())
@ -499,7 +499,9 @@
(let* ((lib+files (extract-library cfg (caar ls)))
(lib (car lib+files))
(name (library-name lib))
(base (or (cdar ls) name))
(base (or (second (car ls)) name))
(use-for-test? (and (pair? (cddr (car ls))) (third (car ls))))
(lib (if use-for-test? (append lib '((use-for test))) lib))
(subdeps (if recursive?
(filter-map
(lambda (x)
@ -507,7 +509,8 @@
(cond ((assq 'depends (cdr lib)) => cdr)
(else '())))
'())))
(lp (append (map (lambda (x) (cons x base)) subdeps) (cdr ls))
(lp (append (map (lambda (x) (list x base use-for-test?)) subdeps)
(cdr ls))
progs
(cons lib res)
(append (reverse (cdr lib+files)) files)
@ -537,8 +540,9 @@
lib-dirs))
=> (lambda (tests-from-libraries)
(if (pair? tests-from-libraries)
(lp (append (map (lambda (x) (cons x #f)) tests-from-libraries)
ls)
(lp (append ls
(map (lambda (x) (list x #f #t))
tests-from-libraries))
progs
res
files
@ -1004,11 +1008,16 @@
(map cdr (sort ls > car))))
(define (command/search cfg spec . keywords)
(let* ((repo (maybe-update-repository cfg))
(lib-names+pkgs (extract-sorted-packages cfg repo keywords)))
(if (pair? lib-names+pkgs)
(let* ((repo (current-repositories cfg))
(lib-names+pkgs (extract-sorted-packages cfg repo keywords))
(sexp? (conf-get cfg 'sexp?)))
(cond
((or (pair? lib-names+pkgs) sexp?)
(if sexp? (display "("))
(summarize-libraries cfg lib-names+pkgs)
(display "No libraries matched your query.\n"))))
(if sexp? (display ")\n")))
(else
(display "No libraries matched your query.\n")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Show - show detailed information for the given libraries
@ -1027,7 +1036,7 @@
(newline)))
(define (command/show cfg spec . args)
(maybe-update-repository cfg)
(current-repositories cfg)
(let* ((impls (conf-selected-implementations cfg))
(impl-cfgs (map (lambda (impl)
(conf-for-implementation cfg impl))
@ -1056,20 +1065,18 @@
(or (conf-get cfg 'local-user-repository)
(make-path (conf-get-snow-dir cfg) "repo")))))
(define (repository-local-path cfg)
(let* ((repo-uri (remote-uri cfg 'repository-uri "/s/repo.scm"))
(repo-id (substring (sha-224 (string->utf8 repo-uri)) 0 32))
(define (repository-local-path cfg repo-uri)
(let* ((repo-id (substring (sha-224 (string->utf8 repo-uri)) 0 32))
(local-dir (repository-dir cfg))
(local-base (string-append "repo-" repo-id ".scm")))
(make-path local-dir local-base)))
(define (update-repository cfg)
(let* ((local-path (repository-local-path cfg))
(define (update-repository cfg repo-uri)
(let* ((local-path (repository-local-path cfg repo-uri))
(local-dir (path-directory local-path))
(local-tmp (string-append local-path ".tmp."
(number->string (current-second)) "-"
(number->string (current-process-id))))
(repo-uri (remote-uri cfg 'repository-uri "/s/repo.scm"))
(repo-str (utf8->string (resource->bytevector repo-uri)))
(repo (guard (exn (else #f))
(let ((repo (read (open-input-string repo-str))))
@ -1088,38 +1095,114 @@
(rename-file local-tmp local-path)
repo)))))
(define (repository-stale? cfg)
(let ((local-path (repository-local-path cfg)))
(define (repository-stale? cfg repo-uri)
(let ((local-path (repository-local-path cfg repo-uri)))
(guard (exn (else #t))
(> (current-second)
(+ (file-modification-time local-path)
;; by default update once every 3 hours
(conf-get cfg 'update-refresh (* 3 60 60)))))))
(define (should-update-repository? cfg)
(define (should-update-repository? cfg repo-uri)
(case (conf-get cfg 'update-strategy 'cache)
((always) #t)
((never) #f)
((cache)
(repository-stale? cfg))
(repository-stale? cfg repo-uri))
((confirm)
(and (repository-stale? cfg)
(and (repository-stale? cfg repo-uri)
(yes-or-no? cfg "Update repository info?")))
(else
(warn "unknown update-stategy: " (conf-get cfg 'update-strategy))
#f)))
;; return the repo sexp
(define (maybe-update-repository cfg)
;; returns the single repo as a sexp, updated as needed
(define (maybe-update-repository cfg repo-uri)
(or (guard (exn (else #f))
(and (should-update-repository? cfg)
(update-repository cfg)))
(and (should-update-repository? cfg repo-uri)
(update-repository cfg repo-uri)))
(guard (exn (else '(repository)))
(call-with-input-file (repository-local-path cfg)
(call-with-input-file (repository-local-path cfg repo-uri)
read))))
;; returns all repos merged as a sexp, updated as needed
;; not to be confused with the current-repo util in (chibi snow fort)
;; which returns the single host
(define (current-repositories cfg)
(define (make-loc uri trust depth) (vector uri trust depth))
(define (loc-uri loc) (vector-ref loc 0))
(define (loc-trust loc) (vector-ref loc 1))
(define (loc-depth loc) (vector-ref loc 2))
(define (adjust-package-urls ls uri)
(map
(lambda (x)
(cond
((and (pair? x) (eq? 'package (car x)) (assq 'url (cdr x)))
=> (lambda (y)
(set-car! (cdr y)
(uri-resolve (cadr y) (string->path-uri 'http uri))))))
x)
(remove (lambda (x)
(and (pair? x)
(eq? 'url (car x))))
ls)))
(let lp ((ls (map (lambda (x) (make-loc x 1.0 0))
(conf-get-list cfg 'repository-uri)))
(seen '())
(res '()))
(cond
((null? ls)
(cons 'repository (reverse res)))
((> (loc-depth (car ls)) (conf-get cfg 'sibling-depth-limit 1000))
(warn "skipping sibling repo at max depth: "
(loc-uri (car ls)) (loc-depth (car ls)))
(lp (cdr ls)))
((< (loc-trust (car ls)) (conf-get cfg 'sibling-min-trust 0.0))
(warn "skipping sibling repo with low trust: "
(loc-uri (car ls)) (loc-trust (car ls)) )
(lp (cdr ls)))
(else
(let ((uri (uri-normalize (loc-uri (car ls)))))
(if (member uri seen)
(lp (cdr ls) seen res)
(let* ((repo (maybe-update-repository cfg uri))
(siblings
(if (and repo (conf-get cfg 'follow-siblings? #t))
(let ((uri-base
(if (string-suffix? "/" uri)
uri
(uri-directory uri))))
(filter-map
(lambda (x)
(and (pair? x)
(eq? 'sibling (car x))
(assoc-get (cdr x) 'url)
(make-loc
(uri-resolve (assoc-get (cdr x) 'url)
uri-base)
(* (loc-trust (car ls))
(or (assoc-get (cdr x) 'trust) 1.0))
(+ (loc-depth (car ls)) 1))))
(cdr repo)))
'()))
(res (if (valid-repository? repo)
(let ((multi? (or (pair? res)
(pair? siblings)
(pair? (cdr ls)))))
(append
(reverse
(if multi?
(adjust-package-urls (cdr repo) uri)
(cdr repo)))
res))
(begin
(if repo
(warn "invalid repository for uri: " uri))
res))))
(lp (append siblings (cdr ls)) (cons uri seen) res))))))))
(define (command/update cfg spec)
(update-repository cfg))
(current-repositories (conf-extend cfg '((update-strategy . always)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Install - install one or more libraries.
@ -1984,7 +2067,7 @@
;; single implementation at a time.
(define (command/install cfg spec . args)
(let*-values
(((repo) (maybe-update-repository cfg))
(((repo) (current-repositories cfg))
((impls) (conf-selected-implementations cfg))
((impl-cfgs) (map (lambda (impl)
(conf-for-implementation cfg impl))
@ -2017,7 +2100,7 @@
(define (command/upgrade cfg spec . args)
(if (pair? args)
(apply command/install cfg spec args)
(let* ((repo (maybe-update-repository cfg))
(let* ((repo (current-repositories cfg))
(impls (conf-selected-implementations cfg))
(impl-cfgs (map (lambda (impl)
(conf-for-implementation cfg impl))

2
lib/chibi/snow/package.scm
View file

@ -118,7 +118,7 @@
(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 (repo-url repo))))))
(uri-resolve url (string->path-uri 'http (or (repo-url repo) ""))))))
(define (package-version pkg)
(and (pair? pkg) (assoc-get (cdr pkg) 'version eq?)))

23
lib/chibi/snow/utils.scm
View file

@ -26,6 +26,29 @@
(call-with-input-url uri port->bytevector)
(file->bytevector (uri-path uri)))))
;; path-normalize either a uri or path, and return the result as a string
(define (uri-normalize x)
(cond
((uri? x)
(uri->string (uri-with-path x (path-normalize (uri-path x)))))
((not (string? x))
(error "not a uri" x))
((string->uri x)
=> uri-normalize)
(else
(path-normalize x))))
(define (uri-directory x)
(cond
((uri? x)
(uri->string (uri-with-path x (path-directory (uri-path x)))))
((not (string? x))
(error "not a uri" x))
((string->uri x)
=> uri-directory)
(else
(path-directory x))))
(define (version-split str)
(if str
(map (lambda (x) (or (string->number x) x))

2
lib/chibi/snow/utils.sld
View file

@ -1,7 +1,7 @@
(define-library (chibi snow utils)
(export find-in-path find-sexp-in-path
write-to-string resource->bytevector
write-to-string resource->bytevector uri-normalize uri-directory
version-split version-compare version>? version>=?)
(import (scheme base)
(scheme file)

6
tests/snow/repo5/repo.scm Normal file
View file

@ -0,0 +1,6 @@
;; forwarding repository with only siblings
(repository
(sibling
(url "../repo3/repo.scm"))
(sibling
(url "../repo4/repo.scm")))

17
tests/snow/snow-tests.scm
View file

@ -279,6 +279,7 @@
(snow ,@repo4 package --output-dir tests/snow/repo4/
tests/snow/repo4/euler/interest.sld)
(snow index ,(cadr repo4))
(let* ((pkg-file "tests/snow/repo4/euler-interest-2.3.tgz")
(pkg (package-file-meta pkg-file))
(libs (package-libraries pkg)))
@ -295,4 +296,20 @@
(run-euler-interest-test-tests))
(snowball-test->sexp-list pkg pkg-file)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; multiple repos
(define repo3+4
'(--repository-uri "tests/snow/repo3/repo.scm,tests/snow/repo4/repo.scm"))
(let ((ls (snow->sexp ,@repo3+4 search euler)))
(test-assert (assoc '(euler interest) ls))
(test-assert (assoc '(euler totient) ls)))
(define repo5 '(--repository-uri tests/snow/repo5/repo.scm))
(let ((ls (snow->sexp ,@repo5 search euler)))
(test-assert (assoc '(euler interest) ls))
(test-assert (assoc '(euler totient) ls)))
(test-end)

4
tools/snow-chibi
View file

@ -67,9 +67,11 @@
"don't verify implementation versions")
(sign-uploads? boolean ("sign-uploads") "sign with the rsa key if present")
(host string "base uri of snow repository")
(repository-uri string "uri of snow repository file")
(repository-uri (list string) "uris or paths of snow repositories")
(local-root-repository dirname "repository cache dir for root")
(local-user-repository dirname "repository cache dir for non-root users")
(update-strategy symbol
"when to refresh repo: always, never, cache or confirm")
(install-prefix string "prefix directory for installation")
(install-source-dir dirname "directory to install library source in")
(install-library-dir dirname "directory to install shared libraries in")