From 37aa091e1ca23c332cee63f852d79546c05c03d5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 12 Apr 2013 21:04:47 -0600 Subject: [PATCH] raco pkg: add support for local package-index databases Adds `pkg/pnr-db', `raco pkg index-copy', and `raco pkg index-show'. Includes tools to build a database of modules that are supplied by packages, which will be useful for a tool to recommend package installs when a module is not found. Also, document `pkg/lib' and add extra helper functions for getting package information from a package name resolver. --- collects/pkg/db.rkt | 301 ++++++ collects/pkg/lib.rkt | 980 ++++++++++++++------ collects/pkg/main.rkt | 45 +- collects/pkg/pnr-db.rkt | 454 +++++++++ collects/pkg/scribblings/apis.scrbl | 17 + collects/pkg/scribblings/common.rkt | 15 + collects/pkg/scribblings/lib.scrbl | 266 ++++++ collects/pkg/scribblings/pkg.scrbl | 140 ++- collects/pkg/scribblings/pnr-db.scrbl | 120 +++ collects/pkg/scribblings/pnr-protocol.scrbl | 168 ++++ collects/pkg/scribblings/pnr.scrbl | 44 + collects/pkg/util.rkt | 37 + collects/tests/pkg/basic-index.rkt | 7 +- collects/tests/pkg/test-indexes-api.rkt | 43 + collects/tests/pkg/test.rkt | 3 +- collects/tests/pkg/tests-indexes.rkt | 86 ++ collects/tests/pkg/tests-locking.rkt | 3 +- collects/tests/pkg/util.rkt | 3 +- 18 files changed, 2395 insertions(+), 337 deletions(-) create mode 100644 collects/pkg/db.rkt create mode 100644 collects/pkg/pnr-db.rkt create mode 100644 collects/pkg/scribblings/apis.scrbl create mode 100644 collects/pkg/scribblings/common.rkt create mode 100644 collects/pkg/scribblings/lib.scrbl create mode 100644 collects/pkg/scribblings/pnr-db.scrbl create mode 100644 collects/pkg/scribblings/pnr-protocol.scrbl create mode 100644 collects/pkg/scribblings/pnr.scrbl create mode 100644 collects/tests/pkg/test-indexes-api.rkt create mode 100644 collects/tests/pkg/tests-indexes.rkt diff --git a/collects/pkg/db.rkt b/collects/pkg/db.rkt new file mode 100644 index 0000000000..a511d555b0 --- /dev/null +++ b/collects/pkg/db.rkt @@ -0,0 +1,301 @@ +#lang racket/base +(require racket/contract/base + racket/format + racket/set + db) + +(provide + (struct-out pkg) + (contract-out + [current-pkg-index-file + (parameter/c path-string?)] + + [get-pnr-urls (-> (listof string?))] + [set-pnr-urls! ((listof string?) . -> . void?)] + + [set-pnr-pkgs! (string? (listof string?) . -> . void?)] + + [get-pkgs (() + (#:pnr-url (or/c #f string?) + #:name (or/c #f string?)) + . ->* . + (listof pkg?))] + [set-pkg! (string? string? string? string? string? string? + . -> . + void?)] + + [get-pkg-modules (string? string? string? + . -> . (listof module-path?))] + [set-pkg-modules! (string? string? string? + (listof module-path?) + . -> . void?)])) + +(struct pkg (name pnr-url author checksum desc tags) + #:transparent) + +(define current-pkg-index-file + (make-parameter (build-path + (find-system-path 'addon-dir) + "pnr.sqlite"))) + +(define (call-with-pnr-db proc) + (define db #f) + (dynamic-wind + (lambda () + (set! db (sqlite3-connect #:database (current-pkg-index-file) + #:mode 'create + #:busy-retry-limit +inf.0))) + (lambda () (proc db)) + (lambda () + (disconnect db)))) + +(define (get-pkgs #:pnr-url [pnr-url #f]) + (call-with-pnr-db + (lambda (db) + (prepare-pnr-table db) + (prepare-pkg-table db) + (for/list ([row (in-list + (apply + query-rows + db + (~a "SELECT K.name, N.url, K.author, K.checksum, K.desc, k.tags" + " FROM pkg K, pnr N" + " WHERE N.id = K.pnr" + (if pnr-url + " AND N.url = $1" + "")) + (if pnr-url + (list pnr-url) + null)))]) + (pkg (vector-ref row 0) + (vector-ref row 1) + (vector-ref row 2) + (vector-ref row 3) + (vector-ref row 4) + (vector-ref row 5)))))) + +(define (set-pkg! name pnr-url author checksum desc tags) + (call-with-pnr-db + (lambda (db) + (prepare-pnr-table db) + (prepare-pkg-table db) + (call-with-transaction + db + (lambda () + (define pnr (url->pnr db pnr-url)) + (query db + (~a "UPDATE pkg" + " SET author=$1, checksum=$2, desc=$3, tags=$4" + " WHERE name=$5" + " AND pnr=$6") + author checksum desc tags + name pnr) + (void)))))) + +(define (get-pkg-modules name pnr-url checksum) + (call-with-pnr-db + (lambda (db) + (prepare-pnr-table db) + (prepare-pkg-table db) + (prepare-modules-table db) + (define pnr (url->pnr db pnr-url)) + (map + string->mod + (query-list db + "SELECT name FROM modules WHERE pnr=$1, pkg=$2, checksum=$3" + pnr + name + checksum))))) + +(define (set-pkg-modules! name pnr-url checksum modules) + (call-with-pnr-db + (lambda (db) + (prepare-pnr-table db) + (prepare-pkg-table db) + (prepare-modules-table db) + (call-with-transaction + db + (lambda () + (define pnr (url->pnr db pnr-url)) + (query-exec db + "DELETE FROM modules WHERE pnr=$1, pkg=$2, checksum=$3" + pnr + name + checksum) + (for ([mod (in-list modules)]) + (query db + (~a "INSERT INTO modules" + " VALUES ($1, $2, $3, $4)") + (mod->string mod) name pnr checksum))))))) + +(define (string->mod mp) (~s mp)) +(define (mod->string str) (read (open-input-string str))) + +(define (get-pnr-urls) + (call-with-pnr-db + (lambda (db) + (prepare-pnr-table db) + (query-list db (~a "SELECT url FROM pnr"))))) + +(define (set-pnr-urls! urls) + (call-with-pnr-db + (lambda (db) + (prepare-pnr-table db) + (prepare-pkg-table db) + (prepare-modules-table db) + (call-with-transaction + db + (lambda () + (define current-url+ids + (query-rows db "SELECT url, id FROM pnr")) + (define old-urls (for/list ([old (in-list current-url+ids)]) + (vector-ref old 0))) + (for ([old (in-list current-url+ids)]) + (define old-url (vector-ref old 0)) + (define old-id (vector-ref old 1)) + (unless (member old-url urls) + (query-exec db + "DELETE FROM pnr WHERE id=$1" + old-id) + (query-exec db + "DELETE FROM pkg WHERE pnr=$1" + old-id) + (query-exec db + "DELETE FROM modules WHERE pnr=$1" + old-id))) + (for ([new-url (in-list urls)]) + (unless (member new-url old-urls) + (let loop ([id 0]) + (if (query-maybe-row db + "SELECT url FROM pnr WHERE id=$1" + id) + (loop (add1 id)) + (query-exec db "INSERT INTO pnr VALUES ($1, $2)" + id + new-url)))))))))) + +(define (url->pnr db url) + (query-value db + "SELECT id FROM pnr WHERE url=$1" + url)) + +(define (set-pnr-pkgs! url pkgs) + (call-with-pnr-db + (lambda (db) + (prepare-pnr-table db) + (prepare-pkg-table db) + (prepare-modules-table db) + (call-with-transaction + db + (lambda () + (define pnr (url->pnr db url)) + (define current-pkgs + (query-list db "SELECT name FROM pkg WHERE pnr=$1" + pnr)) + (define new-pkgs (list->set pkgs)) + (define old-pkgs (list->set current-pkgs)) + (for ([old (in-list current-pkgs)]) + (unless (set-member? new-pkgs old) + (query-exec db + "DELETE FROM pkg WHERE pnr=$1, name=$2" + pnr + old) + (query-exec db + "DELETE FROM modules WHERE pnr=$1, pkg=$2" + pnr + old))) + (for ([new (in-list pkgs)]) + (unless (set-member? old-pkgs new) + (query-exec db + "INSERT INTO pkg VALUES ($1, $2, $3, $4, $5, $6)" + new + pnr + "" + "" + "" + "")))))))) + +(define (prepare-pnr-table db) + (prepare-table db + "pnr" + (~a "(id SMALLINT," + " url VARCHAR(1024))"))) + +(define (prepare-pkg-table db) + (prepare-table db + "pkg" + (~a "(name VARCHAR(1024)," + " pnr SMALLINT," + " author VARCHAR(256)," + " checksum VARCHAR(256)," + " desc VARCHAR(4096)," + " tags VARCHAR(1024))"))) + +(define (prepare-modules-table db) + (prepare-table db + "modules" + (~a "(name VARCHAR(1024)," + " pkg VARCHAR(1024)," + " pnr SMALLINT," + " checksum VARCHAR(256))"))) + +(define (prepare-table db which desc) + (when (null? + (query-rows db (~a "SELECT name FROM sqlite_master" + " WHERE type='table' AND name='" which "'"))) + (query-exec db (~a "CREATE TABLE " which " " + desc)))) + +;; ---------------------------------------- + +(module+ main + (require rackunit + racket/file) + + (define (pkgurl (read-pkg-cfg/def "indexes")))) + +(define (db-path? p) + (regexp-match? #rx"[.]sqlite$" (path->bytes p))) + +(define (pnr-dispatch i server db dir) + (cond + [(equal? "file" (url-scheme i)) + (define path (url->path i)) + (cond + [(db-path? path) + (parameterize ([db:current-pkg-index-file path]) + (db))] + [(directory-exists? path) (dir path)])] + [else (server i)])) + +(define (add-version-query addr/no-query) + (struct-copy url addr/no-query + [query (append + (url-query addr/no-query) + (list + (cons 'version (version))))])) + +(define (package-index-lookup pkg details?) (or - (for/or ([i (in-list (read-pkg-cfg/def "indexes"))]) - (define addr/no-query (combine-url/relative (string->url i) - (format "pkg/~a" pkg))) - (define addr (struct-copy url addr/no-query - [query (append - (url-query addr/no-query) - (list - (cons 'version (version))))])) - (log-pkg-debug "resolving via ~a" (url->string addr)) - (call/input-url+200 - addr - read)) + (for/or ([i (in-list (pkg-indexes))]) + (pnr-dispatch + i + ;; Server: + (lambda (i) + (define addr (add-version-query + (combine-url/relative i (format "pkg/~a" pkg)))) + (log-pkg-debug "resolving via ~a" (url->string addr)) + (read-from-server + 'package-index-lookup + addr + (lambda (v) (and (hash? v) + (for/and ([k (in-hash-keys v)]) + (symbol? k)))) + (lambda (s) #f))) + ;; Local database: + (lambda () + (define pkgs (db:get-pkgs #:name pkg)) + (and (pair? pkgs) + (db-pkg-info (car pkgs) details?))) + ;; Local directory: + (lambda (path) + (define pkg-path (build-path path "pkg" pkg)) + (and (file-exists? pkg-path) + (call-with-input-file* pkg-path read))))) (pkg-error (~a "cannot find package on indexes\n" " package: ~a") pkg))) +(define (db-pkg-info pkg details?) + (if details? + (let ([tags (db:get-pkg-tags (db:pkg-name pkg) + (db:pkg-index pkg))]) + (hash 'name (db:pkg-name pkg) + 'author (db:pkg-author pkg) + 'source (db:pkg-source pkg) + 'checksum (db:pkg-checksum pkg) + 'description (db:pkg-desc pkg) + 'tags tags)) + (hash 'source (db:pkg-source pkg) + 'checksum (db:pkg-source pkg)))) + (define (remote-package-checksum pkg) (match pkg [`(pns ,pkg-name) ; compatibility, for now - (hash-ref (package-index-lookup pkg-name) 'checksum)] + (hash-ref (package-index-lookup pkg-name #f) 'checksum)] [`(pnr ,pkg-name) - (hash-ref (package-index-lookup pkg-name) 'checksum)] + (hash-ref (package-index-lookup pkg-name #f) 'checksum)] [`(url ,pkg-url-str) (package-url->checksum pkg-url-str)])) @@ -448,6 +506,291 @@ (set->list deps-to-be-removed)))))) (for-each remove-package pkgs)) +;; Downloads a package (if needed) and unpacks it (if needed) into a +;; temporary directory. +(define (stage-package/info pkg + given-type + given-pkg-name + #:given-checksum [given-checksum #f] + check-sums?) + (define-values (inferred-pkg-name type) + (if (path? pkg) + (package-source->name+type (path->string pkg) + (or given-type + (if (directory-exists? pkg) + 'dir + 'file))) + (package-source->name+type pkg given-type))) + (define pkg-name (or given-pkg-name inferred-pkg-name)) + (when (and type (not pkg-name)) + (pkg-error (~a "could not infer package name from source\n" + " source: ~a") + pkg)) + (cond + [(and (eq? type 'github) + (not (regexp-match? #rx"^github://" pkg))) + ;; Add "github://github.com/" + (stage-package/info (string-append "github://github.com/" pkg) type + pkg-name #:given-checksum given-checksum + check-sums?)] + [(or (eq? type 'file-url) (eq? type 'dir-url) (eq? type 'github)) + (define pkg-url (string->url pkg)) + (define scheme (url-scheme pkg-url)) + + (define orig-pkg `(url ,pkg)) + (define checksum (remote-package-checksum orig-pkg)) + (define info + (update-install-info-orig-pkg + (match type + ['github + (when given-checksum + (set! checksum given-checksum)) + (unless checksum + (pkg-error + (~a "could not find checksum for github package source, which implies it doesn't exist\n" + " source: ~a") + pkg)) + (match-define (list* user repo branch path) + (map path/param-path (url-path/no-slash pkg-url))) + (define new-url + (url "https" #f "github.com" #f #t + (map (λ (x) (path/param x empty)) + (list user repo "tarball" checksum)) + empty + #f)) + (define tmp.tgz + (make-temporary-file + (string-append + "~a-" + (format "~a.~a.tgz" repo branch)) + #f)) + (delete-file tmp.tgz) + (define tmp-dir + (make-temporary-file + (string-append + "~a-" + (format "~a.~a" repo branch)) + 'directory)) + (define package-path + (apply build-path tmp-dir path)) + + (dynamic-wind + void + (λ () + (download-file! new-url tmp.tgz) + (dynamic-wind + void + (λ () + (untar tmp.tgz tmp-dir #:strip-components 1) + (stage-package/info (path->string package-path) + 'dir + pkg-name + check-sums?)) + (λ () + (delete-directory/files tmp-dir)))) + (λ () + (delete-directory/files tmp.tgz)))] + [_ + (define url-last-component + (path/param-path (last (url-path pkg-url)))) + (define url-looks-like-directory? (eq? type 'dir-url)) + (define-values + (package-path download-type download-package!) + (cond + [url-looks-like-directory? + (define package-path + (make-temporary-file + (string-append + "~a-" + pkg-name) + 'directory)) + (define (path-like f) + (build-path package-path f)) + (define (url-like f) + (if (and (pair? (url-path pkg-url)) + (equal? "" (path/param-path (last (url-path pkg-url))))) + ;; normal relative path: + (combine-url/relative pkg-url f) + ;; we're assuming that the last path element is + ;; a directory, so just add f: + (struct-copy url pkg-url [path + (append + (url-path pkg-url) + (list (path/param f null)))]))) + (values package-path + 'dir + (λ () + (printf "\tCloning remote directory\n") + (make-directory* package-path) + (define manifest + (call/input-url+200 + (url-like "MANIFEST") + port->lines)) + (unless manifest + (pkg-error (~a "could not find MANIFEST for package source\n" + " source: ~a") + pkg)) + (for ([f (in-list manifest)]) + (download-file! (url-like f) + (path-like f)))))] + [else + (define package-path + (make-temporary-file + (string-append + "~a-" + url-last-component) + #f)) + (delete-file package-path) + (values package-path + 'file + (λ () + (log-pkg-debug "\tAssuming URL names a file") + (download-file! pkg-url package-path)))])) + (dynamic-wind + void + (λ () + (download-package!) + (log-pkg-debug "\tDownloading done, installing ~a as ~a" + package-path pkg-name) + (stage-package/info package-path + download-type + pkg-name + check-sums?)) + (λ () + (when (or (file-exists? package-path) + (directory-exists? package-path)) + (delete-directory/files package-path))))]) + orig-pkg)) + (when (and check-sums? + (install-info-checksum info) + (not checksum)) + (pkg-error (~a "remote package had no checksum\n" + " package: ~a") + pkg)) + (when (and checksum + (install-info-checksum info) + check-sums? + (not (equal? (install-info-checksum info) checksum))) + (pkg-error (~a "incorrect checksum on package\n" + " package: ~a\n" + " expected ~e\n" + " got ~e") + pkg + (install-info-checksum info) checksum)) + (update-install-info-checksum + info + checksum)] + [(eq? type 'file) + (unless (file-exists? pkg) + (pkg-error "no such file\n path: ~a" pkg)) + (define checksum-pth (format "~a.CHECKSUM" pkg)) + (define expected-checksum + (and (file-exists? checksum-pth) + check-sums? + (file->string checksum-pth))) + (define actual-checksum + (with-input-from-file pkg + (λ () + (sha1 (current-input-port))))) + (unless (or (not expected-checksum) + (string=? expected-checksum actual-checksum)) + (pkg-error (~a "incorrect checksum on package\n" + " expected: ~e\n" + " got: ~e") + expected-checksum actual-checksum)) + (define checksum + actual-checksum) + (define pkg-format (filename-extension pkg)) + (define pkg-dir + (make-temporary-file (string-append "~a-" pkg-name) + 'directory)) + (dynamic-wind + void + (λ () + (make-directory* pkg-dir) + + (match pkg-format + [#"tgz" + (untar pkg pkg-dir)] + [#"tar" + (untar pkg pkg-dir)] + [#"gz" ; assuming .tar.gz + (untar pkg pkg-dir)] + [#"zip" + (unzip pkg (make-filesystem-entry-reader #:dest pkg-dir))] + [#"plt" + (make-directory* pkg-dir) + (unpack pkg pkg-dir + (lambda (x) (log-pkg-debug "~a" x)) + (lambda () pkg-dir) + #f + (lambda (auto-dir main-dir file) pkg-dir))] + [x + (pkg-error "invalid package format\n given: ~a" x)]) + + (update-install-info-checksum + (update-install-info-orig-pkg + (stage-package/info pkg-dir + 'dir + pkg-name + check-sums?) + `(file ,(simple-form-path* pkg))) + checksum)) + (λ () + (delete-directory/files pkg-dir)))] + [(or (eq? type 'dir) + (eq? type 'link)) + (unless (directory-exists? pkg) + (pkg-error "no such directory\n path: ~a" pkg)) + (let ([pkg (directory-path-no-slash pkg)]) + (cond + [(eq? type 'link) + (install-info pkg-name + `(link ,(simple-form-path* pkg)) + pkg + #f #f)] + [else + (define pkg-dir + (make-temporary-file "pkg~a" 'directory)) + (delete-directory pkg-dir) + (make-parent-directory* pkg-dir) + (copy-directory/files pkg pkg-dir) + (install-info pkg-name + `(dir ,(simple-form-path* pkg)) + pkg-dir + #t #f)]))] + [(eq? type 'name) + (define index-info (package-index-lookup pkg #f)) + (define source (hash-ref index-info 'source)) + (define checksum (hash-ref index-info 'checksum)) + (define info (stage-package/info source + #f + pkg-name + #:given-checksum checksum + check-sums?)) + (when (and (install-info-checksum info) + check-sums? + (not (equal? (install-info-checksum info) checksum))) + (pkg-error "incorrect checksum on package\n package: ~a" pkg)) + (update-install-info-orig-pkg + (update-install-info-checksum + info + checksum) + `(pnr ,pkg))] + [else + (pkg-error "cannot infer package source type\n source: ~a" pkg)])) + +(define (stage-package desc + #:checksum [checksum #f]) + (define i (stage-package/info (pkg-desc-source desc) + (pkg-desc-type desc) + (pkg-desc-name desc) + #:given-checksum checksum + #t)) + (values (install-info-directory i) + (install-info-checksum i) + (install-info-clean? i))) + (define (install-packages #:old-infos [old-infos empty] #:old-descs [old-descs empty] @@ -458,271 +801,6 @@ #:force? [force? #f] descs) (define check-sums? (not ignore-checksums?)) - (define (install-package pkg - given-type - given-pkg-name - #:given-checksum [given-checksum #f]) - (define-values (inferred-pkg-name type) - (if (path? pkg) - (package-source->name+type (path->string pkg) - (or given-type - (if (directory-exists? pkg) - 'dir - 'file))) - (package-source->name+type pkg given-type))) - (define pkg-name (or given-pkg-name inferred-pkg-name)) - (when (and type (not pkg-name)) - (pkg-error (~a "could not infer package name from source\n" - " source: ~a") - pkg)) - (cond - [(and (eq? type 'github) - (not (regexp-match? #rx"^github://" pkg))) - ;; Add "github://github.com/" - (install-package (string-append "github://github.com/" pkg) type - pkg-name #:given-checksum given-checksum)] - [(or (eq? type 'file-url) (eq? type 'dir-url) (eq? type 'github)) - (define pkg-url (string->url pkg)) - (define scheme (url-scheme pkg-url)) - - (define orig-pkg `(url ,pkg)) - (define checksum (remote-package-checksum orig-pkg)) - (define info - (update-install-info-orig-pkg - (match type - ['github - (when given-checksum - (set! checksum given-checksum)) - (unless checksum - (pkg-error - (~a "could not find checksum for github package source, which implies it doesn't exist\n" - " source: ~a") - pkg)) - (match-define (list* user repo branch path) - (map path/param-path (url-path/no-slash pkg-url))) - (define new-url - (url "https" #f "github.com" #f #t - (map (λ (x) (path/param x empty)) - (list user repo "tarball" checksum)) - empty - #f)) - (define tmp.tgz - (make-temporary-file - (string-append - "~a-" - (format "~a.~a.tgz" repo branch)) - #f)) - (delete-file tmp.tgz) - (define tmp-dir - (make-temporary-file - (string-append - "~a-" - (format "~a.~a" repo branch)) - 'directory)) - (define package-path - (apply build-path tmp-dir path)) - - (dynamic-wind - void - (λ () - (download-file! new-url tmp.tgz) - (dynamic-wind - void - (λ () - (untar tmp.tgz tmp-dir #:strip-components 1) - (install-package (path->string package-path) - 'dir - pkg-name)) - (λ () - (delete-directory/files tmp-dir)))) - (λ () - (delete-directory/files tmp.tgz)))] - [_ - (define url-last-component - (path/param-path (last (url-path pkg-url)))) - (define url-looks-like-directory? (eq? type 'dir-url)) - (define-values - (package-path download-type download-package!) - (cond - [url-looks-like-directory? - (define package-path - (make-temporary-file - (string-append - "~a-" - pkg-name) - 'directory)) - (define (path-like f) - (build-path package-path f)) - (define (url-like f) - (if (and (pair? (url-path pkg-url)) - (equal? "" (path/param-path (last (url-path pkg-url))))) - ;; normal relative path: - (combine-url/relative pkg-url f) - ;; we're assuming that the last path element is - ;; a directory, so just add f: - (struct-copy url pkg-url [path - (append - (url-path pkg-url) - (list (path/param f null)))]))) - (values package-path - 'dir - (λ () - (printf "\tCloning remote directory\n") - (make-directory* package-path) - (define manifest - (call/input-url+200 - (url-like "MANIFEST") - port->lines)) - (unless manifest - (pkg-error (~a "could not find MANIFEST for package source\n" - " source: ~a") - pkg)) - (for ([f (in-list manifest)]) - (download-file! (url-like f) - (path-like f)))))] - [else - (define package-path - (make-temporary-file - (string-append - "~a-" - url-last-component) - #f)) - (delete-file package-path) - (values package-path - 'file - (λ () - (log-pkg-debug "\tAssuming URL names a file") - (download-file! pkg-url package-path)))])) - (dynamic-wind - void - (λ () - (download-package!) - (log-pkg-debug "\tDownloading done, installing ~a as ~a" - package-path pkg-name) - (install-package package-path - download-type - pkg-name)) - (λ () - (when (or (file-exists? package-path) - (directory-exists? package-path)) - (delete-directory/files package-path))))]) - orig-pkg)) - (when (and check-sums? - (install-info-checksum info) - (not checksum)) - (pkg-error (~a "remote package had no checksum\n" - " package: ~a") - pkg)) - (when (and checksum - (install-info-checksum info) - check-sums? - (not (equal? (install-info-checksum info) checksum))) - (pkg-error (~a "incorrect checksum on package\n" - " package: ~a\n" - " expected ~e\n" - " got ~e") - pkg - (install-info-checksum info) checksum)) - (update-install-info-checksum - info - checksum)] - [(eq? type 'file) - (unless (file-exists? pkg) - (pkg-error "no such file\n path: ~a" pkg)) - (define checksum-pth (format "~a.CHECKSUM" pkg)) - (define expected-checksum - (and (file-exists? checksum-pth) - check-sums? - (file->string checksum-pth))) - (define actual-checksum - (with-input-from-file pkg - (λ () - (sha1 (current-input-port))))) - (unless (or (not expected-checksum) - (string=? expected-checksum actual-checksum)) - (pkg-error (~a "incorrect checksum on package\n" - " expected: ~e\n" - " got: ~e") - expected-checksum actual-checksum)) - (define checksum - actual-checksum) - (define pkg-format (filename-extension pkg)) - (define pkg-dir - (make-temporary-file (string-append "~a-" pkg-name) - 'directory)) - (dynamic-wind - void - (λ () - (make-directory* pkg-dir) - - (match pkg-format - [#"tgz" - (untar pkg pkg-dir)] - [#"tar" - (untar pkg pkg-dir)] - [#"gz" ; assuming .tar.gz - (untar pkg pkg-dir)] - [#"zip" - (unzip pkg (make-filesystem-entry-reader #:dest pkg-dir))] - [#"plt" - (make-directory* pkg-dir) - (unpack pkg pkg-dir - (lambda (x) (log-pkg-debug "~a" x)) - (lambda () pkg-dir) - #f - (lambda (auto-dir main-dir file) pkg-dir))] - [x - (pkg-error "invalid package format\n given: ~a" x)]) - - (update-install-info-checksum - (update-install-info-orig-pkg - (install-package pkg-dir - 'dir - pkg-name) - `(file ,(simple-form-path* pkg))) - checksum)) - (λ () - (delete-directory/files pkg-dir)))] - [(or (eq? type 'dir) - (eq? type 'link)) - (unless (directory-exists? pkg) - (pkg-error "no such directory\n path: ~a" pkg)) - (let ([pkg (directory-path-no-slash pkg)]) - (cond - [(eq? type 'link) - (install-info pkg-name - `(link ,(simple-form-path* pkg)) - pkg - #f #f)] - [else - (define pkg-dir - (make-temporary-file "pkg~a" 'directory)) - (delete-directory pkg-dir) - (make-parent-directory* pkg-dir) - (copy-directory/files pkg pkg-dir) - (install-info pkg-name - `(dir ,(simple-form-path* pkg)) - pkg-dir - #t #f)]))] - [(eq? type 'name) - (define index-info (package-index-lookup pkg)) - (define source (hash-ref index-info 'source)) - (define checksum (hash-ref index-info 'checksum)) - (define info (install-package source - #f - pkg-name - #:given-checksum checksum)) - (when (and (install-info-checksum info) - check-sums? - (not (equal? (install-info-checksum info) checksum))) - (pkg-error "incorrect checksum on package\n package: ~a" pkg)) - (update-install-info-orig-pkg - (update-install-info-checksum - info - checksum) - `(pnr ,pkg))] - [else - (pkg-error "cannot infer package source type\n source: ~a" pkg)])) (define db (read-pkg-db)) (define db+with-dbs (let ([with-sys-wide (lambda (t) @@ -981,7 +1059,7 @@ (define metadata-ns (make-metadata-namespace)) (define infos (for/list ([v (in-list descs)]) - (install-package (pkg-desc-source v) (pkg-desc-type v) (pkg-desc-name v)))) + (stage-package/info (pkg-desc-source v) (pkg-desc-type v) (pkg-desc-name v) check-sums?))) (define setup-collects (maybe-append (for/list ([info (in-list (append old-infos infos))]) @@ -1133,10 +1211,16 @@ (list (~a (package-directory pkg))) empty)))))))) -(define (installed-pkg-names) - (with-package-lock/read-only - (define db (read-pkg-db)) - (sort (hash-keys db) string-ci<=?))) +(define (installed-pkg-table #:scope [given-scope #f]) + (define scope (or given-scope (get-default-package-scope))) + (parameterize ([current-install-system-wide? (eq? scope 'i)] + [current-install-version-specific? (not (eq? scope 's))]) + (with-package-lock/read-only + (read-pkg-db)))) + +(define (installed-pkg-names #:scope [given-scope #f]) + (sort (installed-pkg-table #:scope given-scope) + string-ci<=?)) (define (config-cmd config:set key+vals) (cond @@ -1249,13 +1333,285 @@ #:exists 'replace (λ () (display (call-with-input-file pkg sha1))))]))) +(define (index-copy-cmd srcs dest + #:from-config? [from-config? #f] + #:merge? [merge? #f] + #:force? [force? #f] + #:override? [override? #f]) + (define src-paths + (for/list ([src (in-list (append srcs + (if from-config? + (pkg-config-indexes) + null)))]) + (define src-path + (cond + [(path? src) (path->complete-path src)] + [(regexp-match? #rx"^https?://" src) + (string->url src)] + [(regexp-match? #rx"^file://" src) + (url->path (string->url src))] + [(regexp-match? #rx"^[a-zA-Z]*://" src) + (pkg-error (~a "unrecognized URL scheme for an index\n" + " URL: ~a") + src)] + [else (path->complete-path src)])) + (when (path? src-path) + (cond + [(db-path? src-path) + (void)] + [(directory-exists? src-path) + (void)] + [(let-values ([(base name dir?) (split-path src-path)]) dir?) + (void)] + [else + (pkg-error (~a "bad source index path\n" + " path: ~a\n" + " expected: directory or path with \".sqlite\" extension") + src)])) + src-path)) + (define dest-path + (cond + [(path? dest) (path->complete-path dest)] + [(regexp-match? #rx"^file://" dest) + (url->path (string->url dest))] + [(regexp-match? #rx"^[a-zA-Z]*://" dest) + (pkg-error (~a "cannot copy to a non-file destination index\n" + " given URL: ~a") + dest)] + [else (path->complete-path dest)])) + + (unless (or force? merge?) + (when (or (file-exists? dest-path) + (directory-exists? dest-path) + (link-exists? dest-path)) + (pkg-error (~a "destination exists\n" + " path: ~a") + dest-path))) + + (define details + (let ([src-paths (if (and merge? + (or (file-exists? dest-path) + (directory-exists? dest-path))) + (if override? + (append src-paths + (list dest-path)) + (cons dest-path + src-paths)) + src-paths)]) + (parameterize ([current-pkg-indexes (for/list ([src-path src-paths]) + (if (path? src-path) + (path->url src-path) + src-path))]) + (get-all-pkg-details-from-indexes)))) + + (when (and force? (not merge?)) + (cond + [(file-exists? dest-path) + (delete-file dest-path)] + [(directory-exists? dest-path) + (if (db-path? dest-path) + (delete-directory/files dest-path) + (for ([i (directory-list dest-path)]) + (delete-directory/files (build-path dest-path i))))] + [(link-exists? dest-path) + (delete-file dest-path)])) + + (cond + [(db-path? dest-path) + (parameterize ([db:current-pkg-index-file dest-path]) + (db:set-indexes! '("local")) + (db:set-pkgs! "local" + (for/list ([(k v) (in-hash details)]) + (db:pkg k "local" + (hash-ref v 'author "") + (hash-ref v 'source "") + (hash-ref v 'checksum "") + (hash-ref v 'description "")))) + (for ([(k v) (in-hash details)]) + (define t (hash-ref v 'tags '())) + (unless (null? t) + (db:set-pkg-tags! k "local" t))))] + [else + (define pkg-path (build-path dest-path "pkg")) + (make-directory* pkg-path) + (for ([(k v) (in-hash details)]) + (call-with-output-file* + #:exists 'truncate/replace + (build-path pkg-path k) + (lambda (o) (write v o)))) + (call-with-output-file* + #:exists 'truncate/replace + (build-path dest-path "pkgs") + (lambda (o) (write (hash-keys details) o))) + (call-with-output-file* + #:exists 'truncate/replace + (build-path dest-path "pkgs-all") + (lambda (o) (write details o)))])) + +(define (index-show-cmd names + #:all? [all? #f] + #:only-names? [only-names? #f]) + (for ([name (in-list names)]) + (define-values (parsed-name type) + (package-source->name+type name #f)) + (unless (eq? type 'name) + (pkg-error (~a "incorrect syntax for a package name\n" + " given: ~a") + name))) + + (cond + [only-names? + (define all-names (if all? + (get-all-pkg-names-from-indexes) + names)) + (for ([name (in-list all-names)]) + (unless all? + ;; Make sure it's available: + (get-pkg-details-from-indexes name)) + (printf "~a\n" name))] + [else + (define all-details (and all? + (get-all-pkg-details-from-indexes))) + (for ([name (in-list (if all? + (hash-keys all-details) + names))]) + (define details (if all? + (hash-ref all-details name) + (get-pkg-details-from-indexes name))) + (printf "Package name: ~a\n" name) + (for ([key '(author source checksum tags description)]) + (define v (hash-ref details key #f)) + (when v + (printf " ~a: ~a\n" + (string-titlecase (symbol->string key)) + (if (list? v) + (apply ~a #:separator ", " v) + v)))))])) + +(define (get-all-pkg-names-from-indexes) + (define ht + (for*/hash ([i (in-list (pkg-indexes))] + [name + (pnr-dispatch + i + ;; Server: + (lambda (i) + (read-from-server + 'get-all-pkg-names-from-indexes + (add-version-query + (combine-url/relative i "pkgs")) + (lambda (l) (and (list? l) + (andmap string? l))))) + ;; Local database: + (lambda () + (map db:pkg-name (db:get-pkgs))) + ;; Local directory: + (lambda (path) + (define pkgs-path (build-path path "pkgs")) + (cond + [(file-exists? pkgs-path) + (call-with-input-file* pkgs-path read)] + [else + (define pkg-path (build-path path "pkg")) + (for/list ([i (directory-list pkg-path)] + #:when (file-exists? (build-path pkg-path i))) + (path-element->string i))])))]) + (values name #t))) + (sort (hash-keys ht) stringstring i) + (call-with-input-file* (build-path pkg-path i) + read)))])))) + (for/fold ([ht ht]) ([(k v) (in-hash one-ht)]) + (if (hash-ref ht k #f) + ht + (hash-set ht k v))))) + +(define (extract-dependencies get-info) + (define v (if get-info + (get-info 'deps (lambda () empty)) + empty)) + (check-dependencies v) + v) + +(define (get-pkg-content desc + #:extract-info [extract-info extract-dependencies]) + (define-values (dir cksum clean?) (stage-package desc)) + (define get-info (with-handlers ([exn:fail? (λ (x) + (log-exn x "getting info") + #f)]) + (get-info/full dir #:namespace (make-base-namespace)))) + (define module-paths + (let ([dummy (build-path (current-directory) "dummy.rkt")]) + (parameterize ([current-directory dir]) + (for/list ([f (in-directory)] + #:when (file-exists? f) + #:when (regexp-match? #rx#"[.](rkt|ss)$" (path->bytes f)) + #:when (let-values ([(base name dir?) (split-path f)]) + (not (eq? 'relative base)))) + (define m (apply ~a + #:separator "/" + (map path-element->string + (explode-path f)))) + ;; normalize the path: + (collapse-module-path `(lib ,m) dummy))))) + + (begin0 + (values cksum + module-paths + (extract-info get-info)) + (when clean? + (delete-directory/files dir)))) + (define dep-behavior/c - (or/c false/c - (symbols 'fail 'force 'search-ask 'search-auto))) + (or/c #f 'fail 'force 'search-ask 'search-auto)) (provide with-package-lock with-package-lock/read-only + (struct-out pkg-info) + pkg-desc? (contract-out [current-install-system-wide? (parameter/c boolean?)] @@ -1265,6 +1621,8 @@ (parameter/c string?)] [current-pkg-error (parameter/c procedure?)] + [current-pkg-indexes + (parameter/c (or/c #f (listof url?)))] [package-directory (-> string? path-string?)] [pkg-desc @@ -1289,18 +1647,58 @@ (->* ((listof string?)) (#:auto? boolean? #:force? boolean?) - void)] + void?)] [show-cmd (->* (string?) (#:directory? boolean?) - void)] + void?)] [install-cmd (->* ((listof pkg-desc?)) (#:dep-behavior dep-behavior/c #:force? boolean? #:ignore-checksums? boolean?) (or/c #f (listof (or/c path-string? (non-empty-listof path-string?)))))] + [index-show-cmd + (->* ((listof string?)) + (#:all? boolean? + #:only-names? boolean?) + void?)] + [index-copy-cmd + (->* ((listof path-string?) path-string?) + (#:from-config? any/c + #:merge? boolean? + #:force? boolean? + #:override? boolean?) + void?)] [get-default-package-scope (-> (or/c 'i 'u 's))] [installed-pkg-names - (-> (listof string?))])) + (->* () + (#:scope (or/c #f 'i 'u 's)) + (listof string?))] + [installed-pkg-table + (->* () + (#:scope (or/c #f 'i 'u 's)) + (hash/c string? pkg-info?))] + [stage-package (->* (pkg-desc?) + (#:checksum (or/c #f string?)) + (values path? + (or/c #f string?) + boolean?))] + [pkg-config-indexes + (-> (listof string?))] + [get-all-pkg-names-from-indexes + (-> (listof string?))] + [get-all-pkg-details-from-indexes + (-> (hash/c string? (hash/c symbol? any/c)))] + [get-pkg-details-from-indexes + (-> string? + (or/c #f (hash/c symbol? any/c)))] + [get-pkg-content + (->* (pkg-desc?) + (#:extract-info (-> (or/c #f + ((symbol?) ((-> any)) . ->* . any)) + any/c)) + (values (or/c #f string?) + (listof module-path?) + any/c))])) diff --git a/collects/pkg/main.rkt b/collects/pkg/main.rkt index 7b651b69a1..0ecb858805 100644 --- a/collects/pkg/main.rkt +++ b/collects/pkg/main.rkt @@ -1,7 +1,9 @@ #lang racket/base (require (only-in racket/base [version r:version]) racket/function + racket/list raco/command-name + net/url "lib.rkt" "commands.rkt" (prefix-in setup: setup/setup)) @@ -115,14 +117,14 @@ [#:bool installation ("-i") "shorthand for `--scope installation'"] [#:bool user ("-u") "shorthand for `--scope user'"] [#:bool shared ("-s") "shorthand for `--scope shared'"] - #:args pkgs + #:args pkg (call-with-package-scope 'update scope installation shared user (lambda () (with-package-lock (define setup-collects - (update-packages pkgs + (update-packages pkg #:all? all #:dep-behavior deps #:deps? update-deps)) @@ -144,13 +146,13 @@ [#:bool installation ("-i") "shorthand for `--scope installation'"] [#:bool user ("-u") "shorthand for `--scope user'"] [#:bool shared ("-s") "shorthand for `--scope shared'"] - #:args pkgs + #:args pkg (call-with-package-scope 'remove scope installation shared user (lambda () (with-package-lock - (remove-packages pkgs + (remove-packages pkg #:auto? auto #:force? force) (setup no-setup #f))))] @@ -225,4 +227,37 @@ [#:bool manifest () "Creates a manifest file for a directory, rather than an archive"] #:args (package-directory) (parameterize ([current-pkg-error (pkg-error 'create)]) - (create-cmd (if manifest 'MANIFEST (or format 'zip)) package-directory))]) + (create-cmd (if manifest 'MANIFEST (or format 'zip)) package-directory))] + [index-show + "Show information about packages as reported by index" + #:once-any + [(#:str index #f) index () "Use instead of configured indexes"] + #:once-each + [#:bool all () "Show all packages"] + [#:bool only-names () "Show only package names"] + #:args pkg-name + (when (and all (pair? pkg-name)) + ((pkg-error 'index-show) "both `--all' and package names provided")) + (parameterize ([current-pkg-indexes (and index + (list (string->url index)))] + [current-pkg-error (pkg-error 'index-show)]) + (index-show-cmd pkg-name + #:all? all + #:only-names? only-names))] + [index-copy + "Copy/merge package name resolver information" + #:once-each + [#:bool from-config () "Include currently configured packages last"] + #:once-any + [#:bool force () "Force replacement fo existing file/directory"] + [#:bool merge () "Merge to existing database"] + #:once-each + [#:bool override () "While merging, override existing with new"] + #:args index + (parameterize ([current-pkg-error (pkg-error 'index-copy)]) + (index-copy-cmd (drop-right index 1) + (last index) + #:from-config? from-config + #:force? force + #:merge? merge + #:override? override))]) diff --git a/collects/pkg/pnr-db.rkt b/collects/pkg/pnr-db.rkt new file mode 100644 index 0000000000..16466b54dd --- /dev/null +++ b/collects/pkg/pnr-db.rkt @@ -0,0 +1,454 @@ +#lang racket/base +(require racket/contract/base + racket/format + racket/set + db) + +(provide + (struct-out pkg) + (contract-out + [current-pkg-index-file + (parameter/c path-string?)] + + [get-indexes (-> (listof string?))] + [set-indexes! ((listof string?) . -> . void?)] + + [set-pkgs! (string? (listof (or/c pkg? string?)) . -> . void?)] + + [get-pkgs (() + (#:name (or/c #f string?) + #:index (or/c #f string?)) + . ->* . + (listof pkg?))] + [set-pkg! (string? string? string? string? string? string? + . -> . + void?)] + + [get-pkg-modules (string? string? string? + . -> . (listof module-path?))] + [set-pkg-modules! (string? string? string? + (listof module-path?) + . -> . void?)] + + [get-pkg-tags (string? string? + . -> . (listof string?))] + [set-pkg-tags! (string? string? (listof string?) + . -> . void?)] + + [get-module-pkgs (module-path? . -> . pkg?)])) + +(struct pkg (name index author source checksum desc) + #:transparent) + +(define (prepare-pnr-table db) + (prepare-table db + "pnr" + (~a "(id SMALLINT," + " url TEXT," + " pos SMALLINT)"))) + +(define (prepare-pkg-table db) + (prepare-table db + "pkg" + (~a "(name TEXT," + " pnr SMALLINT," + " author TEXT," + " source TEXT," + " checksum TEXT," + " desc TEXT)"))) + +(define (prepare-tags-table db) + (prepare-table db + "tags" + (~a "(pkg TEXT," + " pnr TEXT," + " tag TEXT)"))) + +(define (prepare-modules-table db) + (prepare-table db + "modules" + (~a "(name TEXT," + " pkg TEXT," + " pnr SMALLINT," + " checksum TEXT)"))) + +(define current-pkg-index-file + (make-parameter (build-path + (find-system-path 'addon-dir) + (version) + "pnr.sqlite"))) + +(define (call-with-pnr-db proc) + (define db #f) + (dynamic-wind + (lambda () + (set! db (sqlite3-connect #:database (current-pkg-index-file) + #:mode 'create + #:busy-retry-limit +inf.0))) + (lambda () (proc db)) + (lambda () + (disconnect db)))) + +(define (get-pkgs #:name [name #f] + #:index [index #f]) + (call-with-pnr-db + (lambda (db) + (prepare-pnr-table db) + (prepare-pkg-table db) + (for/list ([row (in-list + (apply + query-rows + db + (~a "SELECT K.name, N.url, K.author, K.source, K.checksum, K.desc" + " FROM pkg K, pnr N" + " WHERE N.id = K.pnr" + (if index + " AND N.url = $1" + "") + (if name + (~a " AND K.name = " + (if index "$2" "$1")) + "") + " ORDER BY N.pos") + (append + (if index + (list index) + null) + (if name + (list name) + null))))]) + (pkg (vector-ref row 0) + (vector-ref row 1) + (vector-ref row 2) + (vector-ref row 3) + (vector-ref row 4) + (vector-ref row 5)))))) + +(define (set-pkg! name index author source checksum desc) + (call-with-pnr-db + (lambda (db) + (prepare-pnr-table db) + (prepare-pkg-table db) + (call-with-transaction + db + (lambda () + (define pnr (url->pnr db index)) + (query db + (~a "UPDATE pkg" + " SET author=$1, source=$2, checksum=$3, desc=$4" + " WHERE name=$5" + " AND pnr=$6") + author source checksum desc + name pnr) + (void)))))) + +(define (get-pkg-tags name index) + (call-with-pnr-db + (lambda (db) + (prepare-pnr-table db) + (prepare-pkg-table db) + (prepare-tags-table db) + (define pnr (url->pnr db index)) + (query-list db + (~a "SELECT tag FROM tags" + " WHERE pnr=$1" + " AND pkg=$2") + pnr + name)))) + +(define (set-pkg-tags! name index tags) + (call-with-pnr-db + (lambda (db) + (prepare-pnr-table db) + (prepare-pkg-table db) + (prepare-tags-table db) + (call-with-transaction + db + (lambda () + (define pnr (url->pnr db index)) + (query-exec db + (~a "DELETE FROM tags" + " WHERE pnr=$1" + " AND pkg=$2") + pnr + name) + (for ([tag (in-list tags)]) + (query db + (~a "INSERT INTO tags" + " VALUES ($1, $2, $3)") + name pnr tag))))))) + +(define (get-pkg-modules name index checksum) + (call-with-pnr-db + (lambda (db) + (prepare-pnr-table db) + (prepare-pkg-table db) + (prepare-modules-table db) + (define pnr (url->pnr db index)) + (map + string->mod + (query-list db + (~a "SELECT name FROM modules" + " WHERE pnr=$1" + " AND pkg=$2" + " AND checksum=$3") + pnr + name + checksum))))) + +(define (set-pkg-modules! name index checksum modules) + (call-with-pnr-db + (lambda (db) + (prepare-pnr-table db) + (prepare-pkg-table db) + (prepare-modules-table db) + (call-with-transaction + db + (lambda () + (define pnr (url->pnr db index)) + (query-exec db + (~a "DELETE FROM modules" + " WHERE pnr=$1" + " AND pkg=$2" + " AND checksum=$3") + pnr + name + checksum) + (for ([mod (in-list modules)]) + (query db + (~a "INSERT INTO modules" + " VALUES ($1, $2, $3, $4)") + (mod->string mod) name pnr checksum))))))) + +(define (get-module-pkgs mod) + (call-with-pnr-db + (lambda (db) + (define rows + (query-rows db + (~a "SELECT M.pkg, P.url, M.checksum" + " FROM modules M, pnr P" + " WHERE M.name = $1" + " AND M.pnr = P.id") + (mod->string mod))) + (for/list ([row (in-list rows)]) + (pkg (vector-ref row 0) + (vector-ref row 1) + "" + "" + (vector-ref row 2) + ""))))) + +(define (mod->string mp) (~s mp)) +(define (string->mod str) (read (open-input-string str))) + +(define (get-indexes) + (call-with-pnr-db + (lambda (db) + (prepare-pnr-table db) + (query-list db (~a "SELECT url FROM pnr" + " ORDER BY pos"))))) + +(define (set-indexes! urls) + (call-with-pnr-db + (lambda (db) + (prepare-pnr-table db) + (prepare-pkg-table db) + (prepare-tags-table db) + (prepare-modules-table db) + (call-with-transaction + db + (lambda () + (define current-url+ids + (query-rows db "SELECT url, id FROM pnr")) + (define old-urls (for/list ([old (in-list current-url+ids)]) + (vector-ref old 0))) + (for ([old (in-list current-url+ids)]) + (define old-url (vector-ref old 0)) + (define old-id (vector-ref old 1)) + (unless (member old-url urls) + (query-exec db + "DELETE FROM pnr WHERE id=$1" + old-id) + (query-exec db + "DELETE FROM pkg WHERE pnr=$1" + old-id) + (query-exec db + "DELETE FROM tags WHERE pnr=$1" + old-id) + (query-exec db + "DELETE FROM modules WHERE pnr=$1" + old-id))) + (for ([new-url (in-list urls)]) + (unless (member new-url old-urls) + (let loop ([id 0]) + (if (query-maybe-row db + "SELECT url FROM pnr WHERE id=$1" + id) + (loop (add1 id)) + (query-exec db "INSERT INTO pnr VALUES ($1, $2, 0)" + id + new-url))))) + (for ([new-url (in-list urls)] + [pos (in-naturals)]) + (query-exec db (~a "UPDATE pnr" + " SET pos = $1" + " WHERE url = $2") + pos + new-url))))))) + +(define (url->pnr db url) + (query-value db + "SELECT id FROM pnr WHERE url=$1" + url)) + +(define (set-pkgs! url pkgs) + (call-with-pnr-db + (lambda (db) + (prepare-pnr-table db) + (prepare-pkg-table db) + (prepare-modules-table db) + (call-with-transaction + db + (lambda () + (define pnr (url->pnr db url)) + (define pkg-names (for/list ([p (in-list pkgs)]) + (if (pkg? p) + (pkg-name p) + p))) + (define current-pkgs + (query-list db "SELECT name FROM pkg WHERE pnr=$1" + pnr)) + (define new-pkgs (list->set pkg-names)) + (define old-pkgs (list->set current-pkgs)) + (for ([old (in-list current-pkgs)]) + (unless (set-member? new-pkgs old) + (query-exec db + "DELETE FROM pkg WHERE pnr=$1, name=$2" + pnr + old) + (query-exec db + "DELETE FROM tags WHERE pnr=$1, pkg=$2" + pnr + old) + (query-exec db + "DELETE FROM modules WHERE pnr=$1, pkg=$2" + pnr + old))) + (for ([new0 (in-list pkgs)]) + (define new (if (pkg? new0) + new0 + (pkg new0 "" "" "" "" ""))) + (unless (and (string? new0) + (set-member? old-pkgs new0)) + (if (set-member? old-pkgs (pkg-name new)) + (query-exec db + (~a "UPDATE pkg" + " SET author=$1, source=$2, checksum=$3, desc=$4" + " WHERE name=$5" + " AND pnr=$6") + (pkg-author new) + (pkg-source new) + (pkg-checksum new) + (pkg-desc new) + (pkg-name new) + pnr) + (query-exec db + "INSERT INTO pkg VALUES ($1, $2, $3, $4, $5, $6)" + (pkg-name new) + pnr + (pkg-author new) + (pkg-source new) + (pkg-checksum new) + (pkg-desc new)))))))))) + +(define (prepare-table db which desc) + (when (null? + (query-rows db (~a "SELECT name FROM sqlite_master" + " WHERE type='table' AND name='" which "'"))) + (query-exec db (~a "CREATE TABLE " which " " + desc)))) + +;; ---------------------------------------- + +(module+ main + (require rackunit + racket/file) + + (define (pkg any)) . ->* . any)) + . -> . any) + (lambda (get-pkg-info) ...)]) + (values (or/c #f string?) + (listof module-path?) + any/c)]{ + +Gets information about the content of the package specified by +@racket[desc]. The information is determined inspecting the +package---resolving a @tech{package name}, downloading, and unpacking +into a temporary directory as necessary. + +The results are as follows: + +@itemize[ + + @item{The checksum, if any, for the downloaded package.} + + @item{A list of module paths that are provided by the package. + Each module path is normalized in the sense of + @racket[collapse-module-path].} + + @item{Information extracted from the package's metadata. By default, + this information is the package's dependencies, but in general + it is the result of @racket[extract-proc], which receives an + information-getting function (or @racket[#f]) as returned by + @racket[get-info].} + +]} diff --git a/collects/pkg/scribblings/pkg.scrbl b/collects/pkg/scribblings/pkg.scrbl index 31ab09ddf6..291a0874cb 100644 --- a/collects/pkg/scribblings/pkg.scrbl +++ b/collects/pkg/scribblings/pkg.scrbl @@ -1,6 +1,7 @@ #lang scribble/manual @(require scribble/bnf scribble/core + "common.rkt" (for-label pkg (except-in racket/base remove) setup/dirs)) @@ -22,15 +23,6 @@ @(define (gtech s) @tech[#:doc '(lib "scribblings/guide/guide.scrbl") s]) -@(define (command s) - @exec{raco pkg @|s|}) - -@(define (command-ref s) - @(link-element "plainlink" @command[s] `(raco-pkg-cmd ,s))) - -@(define (command/toc s) - @(toc-target-element #f @command[s] `(raco-pkg-cmd ,s))) - @; ---------------------------------------- @@ -183,28 +175,23 @@ means that it has only the characters @|package-name-chars|.} ] -A @deftech{package name resolver} (@deftech{PNR}) is a server that -converts package names to other package sources. A PNR is identified -by a string representing a URL. This URL is combined with -@exec{pkg/}@nonterm{package} path segments (where @nonterm{package} is a package name) plus a -@exec{version=}@nonterm{version} query (where @nonterm{version} is the -Racket version number) to form a URL that should refer to a -@racket[read]-able hash table with the keys: @racket['source] mapped to -the @tech{package source} string and @racket['checksum] mapped to the -@tech{checksum} value. Typically, the @tech{package source} value for -@racket['source] will be a remote URL. +A @deftech{package name resolver} (@deftech{PNR}, +a.k.a. @deftech{index}) is a server or database that converts package +names to other package sources. A PNR is identified by a string +representing a URL, where a @litchar{http://} or @litchar{https://} +URL indicates a remote server, and a @litchar{file://} URL indicates a +local database in the form of an SQLite database or a directory tree. PLT supports two @tech{package name resolvers} that are enabled by -default: @url{https://pkg.racket-lang.org} for new -packages and @url{https://planet-compat.racket-lang.org} for -automatically generated packages for old @|PLaneT| -packages. Anyone may host their own @tech{package name resolver}. The -source for the PLT-hosted resolvers is in the -@racket[(collection-file-path "pkg-index" "meta")] -directory. +default: @url{https://pkg.racket-lang.org} for new packages and +@url{https://planet-compat.racket-lang.org} for automatically +generated packages for old @|PLaneT| packages. Anyone may host a +@tech{package name resolver}, and any file-serving HTTP host can act +as a basic @tech{package name resolver}. See @secref["pnr-protocol"] +for information on how package information is extracted from a PNR. After a package is installed, the original source of its installation -is recorded, as well as if it was an @tech{automatic installation}. An +is recorded, as well as whether the instalation was an @tech{automatic installation}. An @deftech{automatic installation} is one that was installed because it was a dependency of a non-@tech{automatic installation} package. @@ -244,9 +231,9 @@ user-specific, but for all versions and installations of Racket. @section{Managing Packages} - -The Racket package manager has two user interfaces: a command line @exec{raco} -sub-command and a library. They have the exact same capabilities, as +The Racket package manager has two main user interfaces: a command line @exec{raco} +sub-command and a @racketmodname[pkg] library to run the same commands. +They have the exact same capabilities, as the command line interface invokes the library functions and reprovides all their options. @@ -329,7 +316,7 @@ the following @nonterm{option}s: @item{@command/toc{remove} @nonterm{option} ... @nonterm{pkg} ... --- Attempts to remove the given packages. If a package is the dependency of another package that is not listed, this command fails without -removing any of the @nonterm{pkg}s. It accepts the following @nonterm{option}s: +removing any of the @nonterm{pkg}s. This command accepts the following @nonterm{option}s: @itemlist[ @item{@DFlag{force} --- Ignore dependencies when removing packages.} @@ -367,7 +354,7 @@ removing any of the @nonterm{pkg}s. It accepts the following @nonterm{option}s: } @item{@command/toc{config} @nonterm{option} ... @nonterm{key} @nonterm{val} ... --- -View and modify package configuration options. It accepts the following @nonterm{option}s: +View and modify package configuration options. This command accepts the following @nonterm{option}s: @itemlist[ @item{@DFlag{set} --- Sets an option, rather than printing it.} @@ -387,7 +374,7 @@ View and modify package configuration options. It accepts the following @nonterm } @item{@command/toc{create} @nonterm{option} ... @nonterm{package-directory} ---- Bundles a package directory into a package archive. It accepts the following @nonterm{option}s: +--- Bundles a package directory into a package archive. This command accepts the following @nonterm{option}s: @itemlist[ @item{@DFlag{format} @nonterm{format} --- Specifies the archive format. @@ -396,9 +383,52 @@ View and modify package configuration options. It accepts the following @nonterm @item{@DFlag{manifest} --- Creates a manifest file for a directory, rather than an archive.} ] } + +@item{@command/toc{index-show} @nonterm{option} ... @nonterm{package-name} ... +--- Consults @tech{package name resolvers} for a package (that is not necessarily installed) + and displays the resolver's information for the package, such as its source URL and + a checksum. This command accepts the following @nonterm{option}s: + + @itemlist[ + @item{@DFlag{all} --- Show information for all available packages. When using this flag, + supply no @nonterm{packaee-name}s.} + @item{@DFlag{only-names} --- Show only package names. This option is mainly useful with + @DFlag{all}, but when a @nonterm{packaee-name} is provided, + indexes are consulted to ensure that he package is available.} + @item{@DFlag{index} @nonterm{index} --- Query @nonterm{index} instead of the currently configured + @tech{package name resolvers}.} + ] +} + +@item{@command/toc{index-copy} @nonterm{option} ... @nonterm{src-index} ... @nonterm{dest-index} +--- Copies information from @tech{package name resolvers} names by @nonterm{src-index}es + to a local database or directory @nonterm{dest-index}, + which can be used as a new @tech{package name resolver}. + + The @nonterm{src-index}es can be remote or local, while @nonterm{dest-index} must be local + (i.e., a directory path or a SQLite database path, as inferred from the path). + If a @nonterm{src-index} or @nonterm{dest-index} does not start with a URL scheme, it is + treated as a filesystem path. Information from multiple @nonterm{src-index}es is merged, + with information from earlier @nonterm{src-index}es taking precedence over later + @nonterm{src-index}es. + + This command accepts the following @nonterm{option}s: + + @itemlist[ + @item{@DFlag{from-config} --- Adds the currently configured + @tech{package name resolvers} to the end of the @nonterm{src-index}es list.} + @item{@DFlag{force} --- Replaces @nonterm{dest-index} if it exists already.} + @item{@DFlag{merge} --- Adds to @nonterm{dest-index} if it exists already. By default, + information already in @nonterm{dest-index} takes precedence + over new information.} + @item{@DFlag{override} --- Changes merging so that new information takes precedence + over information already in @nonterm{dest-index}.} + ] +} + ] -@subsection{Programmatic} +@subsection{Programmatic Commands} @defmodule[pkg] @@ -410,8 +440,10 @@ to the command sub-sub-commands. @defthing[update procedure?] @defthing[remove procedure?] @defthing[show procedure?] - @defthing[config procedure?] - @defthing[create procedure?]) + @defthing[config procedure?] + @defthing[create procedure?] + @defthing[index-show procedure?] + @defthing[index-copy procedure?]) ]{ Duplicates the @seclink["cmdline"]{command line interface}. @@ -419,7 +451,9 @@ to the command sub-sub-commands. argument. An argument corresponding to @DFlag{type}, @DFlag{deps}, @DFlag{format}, or @DFlag{scope} accepts its argument as a symbol. All other options accept booleans, where @racket[#t] is equivalent to the presence of - the option.} + the option. + + See also @racketmodname[pkg/lib].} @; ---------------------------------------- @@ -681,6 +715,12 @@ future. @; ---------------------------------------- +@include-section["apis.scrbl"] + +@include-section["pnr-protocol.scrbl"] + +@; ---------------------------------------- + @section[#:style 'quiet]{FAQ} This section answers anticipated frequently asked questions about @@ -759,6 +799,32 @@ release a new package with a new name. For example, package @pkgname{libgtk} might become @pkgname{libgtk2}. These packages should be designed to not conflict with each other, as well. +@subsection{How can I fix my installation to a specific set of package +implementations or @tech{checksums}?} + +Packages are updated only when you run a tool such as +@command-ref{update}, so packages are never updated +implicitly. Furthermore, you can snapshot a set of package archives +and install from those archives, instead of relying on package name +resolution through a @tech{package name resolver}. + +If you want to control the resolution of package names (including +specific @tech{checksum}s) but not necessary keep a copy of all package +code (assuming that old @tech{checksum}s remain available, such as +through Github), you can create a snapshot of the @tech{package name} +to @tech{package source} mapping by using @command-ref{index-copy}. +For example, + +@commandline{raco pkg index-copy --from-config /home/joe/snapshot.sqlite} + +creates a snapshot @filepath{/home/joe/snapshot.sqlite} of the current +package name resolution, and then + +@commandline{raco pkg config --set indexes file:///home/joe/snapshot.sqlite} + +directs all package-name resolution to the snapshot. You can configure +resolution for specific package names by editing the snapshot. + @subsection{Why is the package manager so different than @|Planet1|?} There are two fundamental differences between @|Planet1| and this package manager. diff --git a/collects/pkg/scribblings/pnr-db.scrbl b/collects/pkg/scribblings/pnr-db.scrbl new file mode 100644 index 0000000000..ccb26691bf --- /dev/null +++ b/collects/pkg/scribblings/pnr-db.scrbl @@ -0,0 +1,120 @@ +#lang scribble/manual +@(require (for-label racket/base + racket/contract/base + pkg/pnr-db)) + +@title[#:tag "pnr-db"]{Package Name Database} + +@defmodule[pkg/pnr-db]{The @racketmodname[pkg/pnr-db] library provides +tools for storing and retrieving @tech{package name resolver} +information in a local database.} + +The functions provided by @racketmodname[pkg/pnr-db] do not actually +manage packages; they do not change or consult the local database of +installed modules in any @tech{package scope}. The functions provided +by @racketmodname[pkg/pnr-db] simply reflect a local copy of the +information that a @tech{package name resolver} and individual package +might provide (but with no guarantee of being in sync with an actual +@tech{package name resolver} or package). + +The database is implemented as an SQLite database with its own +locking, so no additional locks are needed for database access, but +beware of concurrent database changes that could break your program +logic. + +@defstruct[pkg ([name string?] + [index string?] + [author string?] + [source string?] + [checksum string?] + [desc string?]) + #:transparent]{ + +Represents a package implementation in the database. The @racket[name] +(@tech{package name}) and @racket[index] (@tech{package name +resolver}, normally a URL) fields are always nonempty +strings. Otherwise, unknown fields are represented by empty strings.} + + +@defparam[current-pkg-index-file file path-string?]{ + +A parameter that determines the file path used to hold the SQLite +database. The default value is in the user's add-on directory and in +a version-specific subdirectory.} + + +@deftogether[( +@defproc[(get-indexes) (listof string?)] +@defproc[(set-indexes! [indexes (listof string?)]) void?] +)]{ + +Returns or sets the list of strings for all @tech{package name +resolvers} represented in the database. (Within the database, each +@tech{package name resolver} gets its own identifying number.) +The order of indices in the list represents a search order. + +The @racket[set-indexes!] function removes information for any other +@tech{package name resolvers} from the database.} + + +@defproc[(get-pkgs [#:name name (or/c #f string?) #f] + [#:index index (or/c #f string?) #f]) + (listof pkg?)]{ + +Gets a list of package descriptions. If @racket[name] or +@racket[index] is not @racket[#f] (or if both are not @racket[#f]), +then the result includes only matching packages. + +The result list is ordered by precedence of the @tech{package name +resolver}.} + + +@defproc[(set-pkgs! [index string?] [pkgs (listof (or/c string? pkg?))]) + void?]{ + +Sets the list of all packages that are recognized by the +@tech{package name resolver} @racket[index]. + +Information about any other package for @racket[index] is removed from +the database. If a string is provided for @racket[pkgs], it is +treated as a package name; if additional information is already +recorded in the database for the package name, then the additional +information is preserved.} + + +@defproc[(set-pkg! [name string?] + [index string?] + [author string?] + [source string?] + [checksum string?] + [desc string?]) + void?]{ + +Sets the information for a specific package @racket[name] as +recognized by the @tech{package name resolver} @racket[index].} + + +@deftogether[( +@defproc[(get-pkg-tags [name string?] [index string?]) + (listof string?)] +@defproc[(set-pkg-tags! [name string?] [index string?] + [module-paths (listof string?)]) + void?] +)]{ + +Gets or sets a list of tags for the package +@racket[name] as recognized by the @tech{package name resolver} +@racket[index].} + + +@deftogether[( +@defproc[(get-pkg-modules [name string?] [index string?] [checksum string?]) + (listof module-path?)] +@defproc[(set-pkg-modules! [name string?] [index string?] [checksum string?] + [module-paths (listof module-path?)]) + void?] +)]{ + +Gets or sets a list of module paths that are provided for the package +@racket[name] as recognized by the @tech{package name resolver} +@racket[index] and for a specific @tech{checksum}.} diff --git a/collects/pkg/scribblings/pnr-protocol.scrbl b/collects/pkg/scribblings/pnr-protocol.scrbl new file mode 100644 index 0000000000..f3f300bc4a --- /dev/null +++ b/collects/pkg/scribblings/pnr-protocol.scrbl @@ -0,0 +1,168 @@ +#lang scribble/manual +@(require scribble/bnf + "common.rkt") + +@title[#:tag "pnr-protocol"]{Package Name Resolver Protocol} + +A @tech{package name resolver} is specified by a URL in one of three +forms: + +@itemlist[ + + @item{@litchar{http://} or @litchar{https://} --- a remote URL} + + @item{@litchar{file://} ending with @litchar{.sqlite} --- a local + SQLite database} + + @item{@litchar{file://} without @litchar{.sqlite} --- a local + directory} + +] + +@section{Remote and Directory Indexes} + +In the case of a remote URL or a local directory naming an +@tech{index}, the URL/path is extended as follows to obtain +information about packages: + +@itemlist[ + + @item{@litchar{pkg} and @nonterm{package} path elements, where + @nonterm{package} is a @tech{package name}, plus a + @exec{version=}@nonterm{version} query (where @nonterm{version} + is the Racket version number) in the case of a remote URL: + + This URL/path form is use to obtain information about + @nonterm{package}. An HTTP request for a remote URL should + respond with a @racket[read]-able hash table, as described + below. A path in a local directory formed by adding + @filepath{pkg} and @nonterm{package} should refer to a file + that similarly contains a @racket[read]-able hash table. + + The hash table should supply the following keys: + + @itemlist[ + + @item{@racket['source] (required) --- a @tech{package source} + string, typically a remote URL.} + + @item{@racket['checksum] (requires) --- a string for a + @tech{checksum}.} + + @item{@racket['name] --- a string that is the same as + @nonterm{package}.} + + @item{@racket['author] --- a string for the author of the + package, normally an e-mail address.} + + @item{@racket['description] --- a string describing the + package.} + + @item{@racket['tags] --- a list of strings that describe the + package's categorization.} + + ]} + + @item{@litchar{pkgs} path element: Obtains a list of package names + that are mapped by the @tech{index}. An HTTP request for a remote URL + should respond with a @racket[read]-able list of strings. A + path in a local directory formed by adding @filepath{pkg} and + @nonterm{package} should refer to a file that similarly + contains a @racket[read]-able list of strings. + + This URL/path form is used by @command-ref{index-copy} and + tools that allow a user to browse an index. + + In the case of a local directory, if no @filepath{pkgs} file is + available, a list is created by listing all files in the + @filepath{pkg} directory.} + + @item{@litchar{pkgs-all} path element: Obtains a hash table mapping + package names to package details. An HTTP request for a remote + URL should respond with a @racket[read]-able hash table mapping + strings to hash tables. A path in a local directory formed by + adding @filepath{pkg} and @nonterm{package} should refer to a + file that similarly contains a @racket[read]-able hash table. + + This URL/path form is a shortcut for a @litchar{pkgs} URL/path + form combined with a @litchar{pkgs/}@nonterm{package} query for + each package. + + In the case of a local directory, if no @filepath{pkgs-all} + file is available, a list is created from files in the + @filepath{pkg} directory.} + +] + +Note that a local directory served as files through an HTTP server +works as a remote URL, as long as the @filepath{pkgs} and +@filepath{pkgs-all} files are present. + +The source for the PLT-hosted @tech{package name resolvers} is in the +@racket[(collection-file-path "pkg-index" "meta")] +directory of the full Racket distribution. + +@; ---------------------------------------- + +@section{SQLite Indexes} + +A SQLite database @tech{index} is meant to be constructed and queries +using the @racketmodname[pkg/pnr-db] library, but the database can be +constructed in any way as long as it contains the following tables: + +@itemlist[ + + @item{A @tt{pnr} table with the format + + @verbatim[#:indent 2]{(id SMALLINT, + url TEXT, + pos SMALLINT)}. + + Normally, the only row in this table is @tt{(0, "local", 0)}, + but a database that records the content of a set of other + indexes can also be used as an index, in which case each row + represents an index; the @tt{id} field is a unique identifier + for each index, the @tt{url} field is the index's URL, and the + @tt{pos} column orders the index relative to others (where a + lower @tt{pos} takes precedence).} + + @item{A @tt{pkg} table with the format + + @verbatim[#:indent 2]{(name TEXT, + pnr SMALLINT, + author TEXT, + source TEXT, + checksum TEXT, + desc TEXT)} + + The @tt{pnr} field is normally @tt{0}; in the case that the + database reflects multiple other indexes, the @tt{pnr} field + indicates the package entry's source index. + + The @tt{pkg} and @tt{pnr} fields together determine a unique + row in the table.} + + @item{A @tt{tags} table with the form + + @verbatim[#:indent 2]{(pkg TEXT, + pnr TEXT, + tag TEXT)} + + where the @tt{pkg} and @tt{pnr} combination identifies a unique + row in @tt{pkg}.} + + @item{A @tt{modules} table with the form + + @verbatim[#:indent 2]{(name TEXT, + pkg TEXT, + pnr SMALLINT, + checksum TEXT)} + + where the @tt{pkg} and @tt{pnr} combination identifies a unique + row in @tt{pkg}, and @racket[name] is a printed module path. + + This table is not currently used by any @exec{raco pkg} + command, but it can be used to suggest package installations to + provide a particular library.} + +] diff --git a/collects/pkg/scribblings/pnr.scrbl b/collects/pkg/scribblings/pnr.scrbl new file mode 100644 index 0000000000..87606cdb2d --- /dev/null +++ b/collects/pkg/scribblings/pnr.scrbl @@ -0,0 +1,44 @@ +#lang scribble/manual +@(require (for-label racket/base + pkg/pnr + pkg/lib + net/url + syntax/modcollapse)) + +@title[#:tag "pnr"]{Package Information Download} + +@defmodule[pkg/pnr]{The @racketmodname[pkg/pnr] +library provides tools for consulting a @tech{package name resolver} +and package servers to obtain information about a package.} + +In particular, @racketmodname[pkg/pnr] uses some of the functions from +@racketmodname[pkg/lib] to obtain information is that useful to +populate a database that is managed by @racketmodname[pkg/db]. + +See also @racket[pkg-indexes] from @racketmodname[pkg/lib]. + + +@defproc[(get-pkg-names-from-pnr [pnr url?]) (listof string?)]{ + +Obtains a list of unique package names from the specified +@tech{package name resolver}.} + +@defproc[(get-pkg-details-from-pnr [pnr url?] + [name string?]) + hash?]{ + +Returns a hash table representing information about @racket[name] as +reported by @racket[pnr].} + + +@defproc[(get-pkg-modules [pnr url?] + [name string?]) + (values (or/c #f string?) (listof module-path?))]{ + +Gets a list of module paths that are provided by @racket[name] as +resolved by @racket[pnr] and as provided by the package's server. The +result reports both the checksum of the package (as reported by +@racket[pnr]) and list of module paths. + +The module paths are normalized in the sense of +@racket[collapse-module-path].} diff --git a/collects/pkg/util.rkt b/collects/pkg/util.rkt index a0f2cc23d4..c2ecc14c9b 100644 --- a/collects/pkg/util.rkt +++ b/collects/pkg/util.rkt @@ -5,6 +5,7 @@ racket/file racket/port racket/match + racket/format net/url json) @@ -77,4 +78,40 @@ (call/input-url+200 (string->url (string-append pkg-url-str ".CHECKSUM")) port->string)])) +;; uses a custodian to avoid leaks: +(define (call-with-url url handler) + (define c (make-custodian)) + (dynamic-wind + void + (lambda () + (define-values (p hs) + (parameterize ([current-custodian c]) + (get-pure-port/headers url #:redirections 25 #:status? #t))) + (begin0 + (and (string=? "200" (substring hs 9 12)) + (handler p)) + (close-input-port p))) + (lambda () + (custodian-shutdown-all c)))) + +(define (read-from-server who url pred + [failure + (lambda (s) + (error who + (~a "bad response from server\n" + " url: ~a\n" + " response: ~v") + (url->string url) + s))]) + (define bytes (call-with-url url port->bytes)) + ((if bytes + (with-handlers ([exn:fail:read? (lambda (exn) + (lambda () (failure bytes)))]) + (define v (read (open-input-bytes bytes))) + (lambda () + (if (pred v) + v + (failure bytes)))) + (lambda () (failure #f))))) + (provide (all-defined-out)) diff --git a/collects/tests/pkg/basic-index.rkt b/collects/tests/pkg/basic-index.rkt index b5dab89a8b..57bd17e7c3 100644 --- a/collects/tests/pkg/basic-index.rkt +++ b/collects/tests/pkg/basic-index.rkt @@ -9,15 +9,20 @@ #"text/s-expr" empty (λ (op) (write v op)))) -(define (pkg-index/basic pkg-name->info) +(define (pkg-index/basic pkg-name->info all-pkgs) (define (write-info req pkg-name) (response/sexpr (pkg-name->info pkg-name))) (define-values (dispatch get-url) (dispatch-rules + [("pkgs-all") (lambda (req) + (response/sexpr (all-pkgs)))] + [("pkgs") (lambda (req) + (response/sexpr (hash-keys (all-pkgs))))] [("pkg" (string-arg)) write-info])) dispatch) (provide/contract [pkg-index/basic (-> (-> string? (hash/c symbol? any/c)) + (-> hash?) (-> request? response?))]) diff --git a/collects/tests/pkg/test-indexes-api.rkt b/collects/tests/pkg/test-indexes-api.rkt new file mode 100644 index 0000000000..47b73c1dd6 --- /dev/null +++ b/collects/tests/pkg/test-indexes-api.rkt @@ -0,0 +1,43 @@ +#lang racket/base +(require pkg/lib + rackunit) + +;; The `test-api' function is meant to be called via "test-indexes.rkt" +(provide test-api) + +(define (test-api) + (check-true (andmap string? (pkg-config-indexes))) + + (define pkg-names (get-all-pkg-names-from-indexes)) + (check-not-false (member "pkg-test1" pkg-names)) + (check-not-false (member "pkg-test2" pkg-names)) + + (define details (get-all-pkg-details-from-indexes)) + (check-not-false (hash-ref details "pkg-test1" #f)) + (check-not-false (hash-ref details "pkg-test2" #f)) + + (check-equal? (hash-ref (hash-ref details "pkg-test1") + 'source) + "http://localhost:9999/pkg-test1.zip") + (check-equal? (hash-ref (hash-ref details "pkg-test2") + 'source) + "http://localhost:9999/pkg-test2.zip") + + (define test1-details (get-pkg-details-from-indexes "pkg-test1")) + (check-equal? test1-details + (hash-ref details "pkg-test1")) + + (define-values (cksum mods deps) + (get-pkg-content (pkg-desc "pkg-test1" #f #f #f))) + (define-values (cksum1 mods1 deps1) + (get-pkg-content (pkg-desc "http://localhost:9999/pkg-test1.zip" #f #f #f))) + + (check-equal? cksum cksum1) + (check-equal? mods '((lib "pkg-test1/conflict.rkt") + (lib "pkg-test1/main.rkt") + (lib "pkg-test1/update.rkt"))) + (check-equal? deps '()) + + (define-values (cksum2 mods2 deps2) + (get-pkg-content (pkg-desc "pkg-test2" 'name #f #f))) + (check-equal? deps2 '("pkg-test1"))) \ No newline at end of file diff --git a/collects/tests/pkg/test.rkt b/collects/tests/pkg/test.rkt index 745ec34572..0022064cb8 100644 --- a/collects/tests/pkg/test.rkt +++ b/collects/tests/pkg/test.rkt @@ -52,4 +52,5 @@ "update-deps" "update-auto" "versions" - "raco") + "raco" + "indexes") diff --git a/collects/tests/pkg/tests-indexes.rkt b/collects/tests/pkg/tests-indexes.rkt new file mode 100644 index 0000000000..d01ee1b2b5 --- /dev/null +++ b/collects/tests/pkg/tests-indexes.rkt @@ -0,0 +1,86 @@ +#lang racket/base +(require pkg/lib + (prefix-in db: pkg/pnr-db) + racket/file + racket/format + "shelly.rkt" + "util.rkt") + +(pkg-tests + (shelly-begin + (initialize-indexes) + + $ "raco pkg config --set indexes http://localhost:9990" + + $ "racket -l racket/base -l pkg/lib -e '(pkg-config-indexes)'" + =stdout> "'(\"http://localhost:9990\")\n" + + $ "racket -l racket/base -l tests/pkg/test-indexes-api -e '(test-api)'" + =stderr> "" + + (define d (make-temporary-file "pkg-~a" 'directory)) + (define db (build-path d "pnr.sqlite")) + (define dir (build-path d "pnr")) + (define dir2 (build-path d "pnr2")) + $ (~a "raco pkg index-copy --from-config " (path->string db)) + $ (~a "raco pkg config --set indexes file://" (path->string db)) + + $ "raco pkg index-show pkg-test1" + =stdout> #rx"Source: http://localhost:9999/pkg-test1.zip" + + (parameterize ([db:current-pkg-index-file db]) + (db:set-pkgs! "local" + (append (db:get-pkgs) + (list + (db:pkg "fish" "local" "nemo@sub" "http://localhost:9999/fish.zip" "123" + "Not a whale"))))) + $ "raco pkg index-show fish" =stdout> #rx"Checksum: 123" + + $ (~a "raco pkg index-copy " (path->string db) " " (path->string dir)) + $ (~a "raco pkg config --set indexes file://" (path->string dir)) + $ "raco pkg index-show fish" =stdout> #rx"Checksum: 123" + $ "raco pkg index-show --only-names fish" =stdout> #rx"fish" + $ "raco pkg index-show --only-names --all" =stdout> #rx"fish" + + (delete-file (build-path dir "pkgs")) + (delete-file (build-path dir "pkgs-all")) + $ "raco pkg index-show fish" =stdout> #rx"Checksum: 123" + $ "raco pkg index-show --only-names fish" =stdout> #rx"^fish" + $ "raco pkg index-show --only-names --all" =stdout> #rx"^fish" + + (delete-file (build-path dir "pkg/fish")) + $ "raco pkg index-show fish" =exit> 1 + + (define (try-merge dest) + (shelly-begin + $ (~a "raco pkg config --set indexes file://" (path->string dest)) + + (make-directory* (build-path dir2 "pkg")) + (define (add-whale! cksum) + (call-with-output-file* + (build-path dir2 "pkg" "whale") + #:exists 'truncate + (lambda (o) + (write (hash 'name "whale" + 'checksum cksum + 'source "http://localhost:9999/whale.plt") + o)))) + (add-whale! "345") + $ (~a "raco pkg index-show --index file://" (path->string dir2) " whale") =stdout> #rx"Checksum: 345" + $ "raco pkg index-show whale" =exit> 1 + + $ (~a "raco pkg index-copy --merge " (path->string dir2) " " (path->string dest)) + $ "raco pkg index-show whale" =stdout> #rx"Checksum: 345" + + (add-whale! "567") + $ (~a "raco pkg index-copy --merge " (path->string dir2) " " (path->string dest)) + $ "raco pkg index-show whale" =stdout> #rx"Checksum: 345" + $ (~a "raco pkg index-copy --merge --override " (path->string dir2) " " (path->string dest)) + $ "raco pkg index-show whale" =stdout> #rx"Checksum: 567")) + + (try-merge dir) + (try-merge db) + + $ "raco pkg config --set indexes http://localhost:9990" + + (delete-directory/files d))) diff --git a/collects/tests/pkg/tests-locking.rkt b/collects/tests/pkg/tests-locking.rkt index 52aa30b9f0..c537c15dea 100644 --- a/collects/tests/pkg/tests-locking.rkt +++ b/collects/tests/pkg/tests-locking.rkt @@ -19,7 +19,8 @@ (λ (pkg-name) (semaphore-wait okay-to-respond?-sema) (define r (hash-ref *index-ht-1* pkg-name #f)) - r)) + r) + (λ () *index-ht-1*)) #:command-line? #t #:servlet-regexp #rx"" #:port 9967) diff --git a/collects/tests/pkg/util.rkt b/collects/tests/pkg/util.rkt index dc9af9903f..ee00470185 100644 --- a/collects/tests/pkg/util.rkt +++ b/collects/tests/pkg/util.rkt @@ -66,7 +66,8 @@ (λ (pkg-name) (define r (hash-ref index-ht pkg-name #f)) (printf "[>server ~a] ~a = ~a\n" port pkg-name r) - r)) + r) + (λ () index-ht)) #:command-line? #t #:servlet-regexp #rx"" #:port port))