suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

raco pkg: normalize error reporting

Browse Source 
Use `raise-user-error' for `raco pkg ...' errors, so that stack
traces don't print out for external errors. Reformat error messages
generally to match current conventions. Use logging for debugging
output.
This commit is contained in:
Matthew Flatt 2012-11-30 16:52:39 -07:00
parent 59f289249f
commit b83804c153
3 changed files with 113 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

152
collects/planet2/lib.rkt
View File

@ -15,7 +15,6 @@
racket/function racket/function
racket/dict racket/dict
racket/set racket/set
unstable/debug
racket/string racket/string
file/untgz file/untgz
file/tar file/tar
@ -23,6 +22,7 @@
file/unzip file/unzip
setup/getinfo setup/getinfo
setup/dirs setup/dirs
racket/format
"name.rkt" "name.rkt"
"util.rkt") "util.rkt")
@ -30,6 +30,20 @@
(make-parameter #f)) (make-parameter #f))
(define current-install-version-specific? (define current-install-version-specific?
(make-parameter #t)) (make-parameter #t))
(define current-pkg-error
(make-parameter (lambda args (apply error 'pkg args))))
(define (pkg-error . rest)
(apply (current-pkg-error) rest))
(define (format-list l)
(if (null? l)
" [none]"
(apply string-append
(for/list ([v (in-list l)])
(format "\n ~a" v)))))
(define-logger planet2)
(struct pkg-desc (source type name auto?)) (struct pkg-desc (source type name auto?))
@ -73,7 +87,7 @@
(unless fail-okay? (unless fail-okay?
(raise x)))]) (raise x)))])
(make-parent-directory* file) (make-parent-directory* file)
(dprintf "\t\tDownloading ~a to ~a\n" (url->string url) file) (log-planet2-debug "\t\tDownloading ~a to ~a" (url->string url) file)
(call-with-output-file file (call-with-output-file file
(λ (op) (λ (op)
(call/input-url+200 (call/input-url+200
@ -139,17 +153,18 @@
(for/and ([dep (in-list deps)]) (for/and ([dep (in-list deps)])
(and (string? dep) (and (string? dep)
(package-source->name dep)))) (package-source->name dep))))
(error 'pkg (pkg-error (~a "invalid `deps' specification\n"
"invalid `dependencies' specification\n specification: ~e" " specification: ~e")
deps))) deps)))
(define (with-package-lock* t) (define (with-package-lock* t)
(make-directory* (pkg-dir)) (make-directory* (pkg-dir))
(call-with-file-lock/timeout (call-with-file-lock/timeout
#f 'exclusive #f 'exclusive
t t
(λ () (error 'planet2 "Could not acquire package lock: ~e" (λ () (pkg-error (~a "could not acquire package lock\n"
(pkg-lock-file))) " lock file: ~a")
(pkg-lock-file)))
#:lock-file (pkg-lock-file))) #:lock-file (pkg-lock-file)))
(define-syntax-rule (with-package-lock e ...) (define-syntax-rule (with-package-lock e ...)
(with-package-lock* (λ () e ...))) (with-package-lock* (λ () e ...)))
@ -175,7 +190,9 @@
(string->url i) (string->url i)
(format "/pkg/~a" pkg)) (format "/pkg/~a" pkg))
read)) read))
(error 'planet2 "Cannot find package ~a on indexes" pkg))) (pkg-error (~a "cannot find package on indexes\n"
" package: ~a")
pkg)))
(define (remote-package-checksum pkg) (define (remote-package-checksum pkg)
(match pkg (match pkg
@ -207,9 +224,11 @@
[(not fail?) [(not fail?)
#f] #f]
[else [else
(error 'planet2 "Package ~e not currently installed; ~e are installed" (pkg-error (~a "package not currently installed\n"
pkg-name " package: ~a\n"
(hash-keys db))])) " currently installed:~a")
pkg-name
(format-list (hash-keys db)))]))
(define (update-pkg-db! pkg-name info) (define (update-pkg-db! pkg-name info)
(write-file-hash! (write-file-hash!
@ -301,8 +320,9 @@
(set->list (set->list
remaining-pkg-db-set))))) remaining-pkg-db-set)))))
(unless (set-empty? deps-to-be-removed) (unless (set-empty? deps-to-be-removed)
(error 'planet2 "Cannot remove packages that are dependencies of other packages: ~e" (pkg-error (~a "cannot remove packages that are dependencies of other packages\n"
(set->list deps-to-be-removed)))) " dependencies:~a")
(format-list (set->list deps-to-be-removed)))))
(for-each remove-package pkgs)) (for-each remove-package pkgs))
(define (install-packages (define (install-packages
@ -326,7 +346,9 @@
(package-source->name+type pkg given-type))) (package-source->name+type pkg given-type)))
(define pkg-name (or given-pkg-name inferred-pkg-name)) (define pkg-name (or given-pkg-name inferred-pkg-name))
(when (and type (not pkg-name)) (when (and type (not pkg-name))
(error 'pkg "count not infer package name from source\n source: ~e" pkg)) (pkg-error (~a "could not infer package name from source\n"
" source: ~a")
pkg))
(cond (cond
[(and (eq? type 'github) [(and (eq? type 'github)
(not (regexp-match? #rx"^github://" pkg))) (not (regexp-match? #rx"^github://" pkg)))
@ -419,8 +441,9 @@
(url-like "MANIFEST") (url-like "MANIFEST")
port->lines)) port->lines))
(unless manifest (unless manifest
(error 'pkg "could not find MANIFEST for package source\n source: ~e" (pkg-error (~a "could not find MANIFEST for package source\n"
pkg)) " source: ~a")
pkg))
(for ([f (in-list manifest)]) (for ([f (in-list manifest)])
(download-file! (url-like f) (download-file! (url-like f)
(path-like f)))))] (path-like f)))))]
@ -435,13 +458,13 @@
(values package-path (values package-path
'file 'file
(λ () (λ ()
(dprintf "\tAssuming URL names a file\n") (log-planet2-debug "\tAssuming URL names a file")
(download-file! pkg-url package-path)))])) (download-file! pkg-url package-path)))]))
(dynamic-wind (dynamic-wind
void void
(λ () (λ ()
(download-package!) (download-package!)
(dprintf "\tDownloading done, installing ~a as ~a\n" (log-planet2-debug "\tDownloading done, installing ~a as ~a"
package-path pkg-name) package-path pkg-name)
(install-package package-path (install-package package-path
download-type download-type
@ -454,21 +477,25 @@
(when (and check-sums? (when (and check-sums?
(install-info-checksum info) (install-info-checksum info)
(not checksum)) (not checksum))
(error 'planet2 "Remote package ~a had no checksum" (pkg-error (~a "remote package had no checksum\n"
pkg)) " package: ~a")
pkg))
(when (and checksum (when (and checksum
(install-info-checksum info) (install-info-checksum info)
check-sums? check-sums?
(not (equal? (install-info-checksum info) checksum))) (not (equal? (install-info-checksum info) checksum)))
(error 'planet2 "Incorrect checksum on package ~e: expected ~e, got ~e" (pkg-error (~a "incorrect checksum on package\n"
pkg " package: ~a\n"
(install-info-checksum info) checksum)) " expected ~e\n"
" got ~e")
pkg
(install-info-checksum info) checksum))
(update-install-info-checksum (update-install-info-checksum
info info
checksum)] checksum)]
[(eq? type 'file) [(eq? type 'file)
(unless (file-exists? pkg) (unless (file-exists? pkg)
(error 'pkg "no such file\n path: ~e" pkg)) (pkg-error "no such file\n path: ~a" pkg))
(define checksum-pth (format "~a.CHECKSUM" pkg)) (define checksum-pth (format "~a.CHECKSUM" pkg))
(define expected-checksum (define expected-checksum
(and (file-exists? checksum-pth) (and (file-exists? checksum-pth)
@ -480,8 +507,10 @@
(sha1 (current-input-port))))) (sha1 (current-input-port)))))
(unless (or (not expected-checksum) (unless (or (not expected-checksum)
(string=? expected-checksum actual-checksum)) (string=? expected-checksum actual-checksum))
(error 'pkg "Incorrect checksum on package: expected ~e, got ~e" (pkg-error (~a "incorrect checksum on package\n"
expected-checksum actual-checksum)) " expected: ~e\n"
" got: ~e")
expected-checksum actual-checksum))
(define checksum (define checksum
actual-checksum) actual-checksum)
(define pkg-format (filename-extension pkg)) (define pkg-format (filename-extension pkg))
@ -505,12 +534,12 @@
[#"plt" [#"plt"
(make-directory* pkg-dir) (make-directory* pkg-dir)
(unpack pkg pkg-dir (unpack pkg pkg-dir
(lambda (x) (printf "~a\n" x)) (lambda (x) (log-planet2-debug "~a" x))
(lambda () pkg-dir) (lambda () pkg-dir)
#f #f
(lambda (auto-dir main-dir file) pkg-dir))] (lambda (auto-dir main-dir file) pkg-dir))]
[x [x
(error 'pkg "Invalid package format: ~e" x)]) (pkg-error "invalid package format\n given: ~a" x)])
(update-install-info-checksum (update-install-info-checksum
(update-install-info-orig-pkg (update-install-info-orig-pkg
@ -524,7 +553,7 @@
[(or (eq? type 'dir) [(or (eq? type 'dir)
(eq? type 'link)) (eq? type 'link))
(unless (directory-exists? pkg) (unless (directory-exists? pkg)
(error 'pkg "no such directory\n path: ~e" pkg)) (pkg-error "no such directory\n path: ~a" pkg))
(let ([pkg (directory-path-no-slash pkg)]) (let ([pkg (directory-path-no-slash pkg)])
(cond (cond
[(eq? type 'link) [(eq? type 'link)
@ -552,14 +581,14 @@
(when (and (install-info-checksum info) (when (and (install-info-checksum info)
check-sums? check-sums?
(not (equal? (install-info-checksum info) checksum))) (not (equal? (install-info-checksum info) checksum)))
(error 'planet2 "Incorrect checksum on package: ~e" pkg)) (pkg-error "incorrect checksum on package\n package: ~a" pkg))
(update-install-info-orig-pkg (update-install-info-orig-pkg
(update-install-info-checksum (update-install-info-checksum
info info
checksum) checksum)
`(pns ,pkg))] `(pns ,pkg))]
[else [else
(error 'pkg "cannot infer package source type\n given: ~e" pkg)])) (pkg-error "cannot infer package source type\n source: ~a" pkg)]))
(define db (read-pkg-db)) (define db (read-pkg-db))
(define db+with-dbs (define db+with-dbs
(let ([with-sys-wide (lambda (t) (let ([with-sys-wide (lambda (t)
@ -596,7 +625,7 @@
(cond (cond
[(and (not updating?) (package-info pkg-name #f)) [(and (not updating?) (package-info pkg-name #f))
(clean!) (clean!)
(error 'planet2 "~e is already installed" pkg-name)] (pkg-error "package is already installed\n package: ~a" pkg-name)]
[(and [(and
(not force?) (not force?)
(for/or ([c (in-list (package-collections pkg-dir metadata-ns))] (for/or ([c (in-list (package-collections pkg-dir metadata-ns))]
@ -632,12 +661,11 @@
(λ (conflicting-pkg*file) (λ (conflicting-pkg*file)
(clean!) (clean!)
(match-define (cons conflicting-pkg file) conflicting-pkg*file) (match-define (cons conflicting-pkg file) conflicting-pkg*file)
(error 'planet2 (string-append (pkg-error (~a "packages conflict\n"
"packages conflict\n" " package: ~a\n"
" package: ~a\n" " package: ~a\n"
" package: ~a\n" " file: ~a")
" file: ~a") pkg conflicting-pkg file))]
pkg conflicting-pkg file))]
[(and [(and
(not (eq? dep-behavior 'force)) (not (eq? dep-behavior 'force))
(let () (let ()
@ -661,7 +689,7 @@
'fail)) 'fail))
['fail ['fail
(clean!) (clean!)
(error 'planet2 "missing dependencies: ~e" unsatisfied-deps)] (pkg-error "missing dependencies\n missing packages:~a" (format-list unsatisfied-deps))]
['search-auto ['search-auto
(printf (string-append (printf (string-append
"The following packages are listed as dependencies, but are not currently installed,\n" "The following packages are listed as dependencies, but are not currently installed,\n"
@ -685,7 +713,7 @@
(raise (vector infos unsatisfied-deps))] (raise (vector infos unsatisfied-deps))]
[(or "n" "N") [(or "n" "N")
(clean!) (clean!)
(error 'planet2 "missing dependencies: ~e" unsatisfied-deps)] (pkg-error "missing dependencies\n missing packages:~a" (format-list unsatisfied-deps))]
[x [x
(eprintf "Invalid input: ~e\n" x) (eprintf "Invalid input: ~e\n" x)
(loop)]))]))] (loop)]))]))]
@ -701,14 +729,14 @@
final-pkg-dir] final-pkg-dir]
[else [else
pkg-dir])) pkg-dir]))
(dprintf "creating link to ~e" final-pkg-dir) (log-planet2-debug "creating link to ~e" final-pkg-dir)
(links final-pkg-dir (links final-pkg-dir
#:user? (not (current-install-system-wide?)) #:user? (not (current-install-system-wide?))
#:version-regexp (link-version-regexp) #:version-regexp (link-version-regexp)
#:root? #t) #:root? #t)
(define this-pkg-info (define this-pkg-info
(pkg-info orig-pkg checksum auto?)) (pkg-info orig-pkg checksum auto?))
(dprintf "updating db with ~e to ~e" pkg-name this-pkg-info) (log-planet2-debug "updating db with ~e to ~e" pkg-name this-pkg-info)
(update-pkg-db! pkg-name this-pkg-info))])) (update-pkg-db! pkg-name this-pkg-info))]))
(define metadata-ns (make-metadata-namespace)) (define metadata-ns (make-metadata-namespace))
(define infos (define infos
@ -730,8 +758,8 @@
(and (list? c) (and (list? c)
(pair? c) (pair? c)
(andmap path-string? c)))))) (andmap path-string? c))))))
(error 'pkg "bad 'setup-collects value\n value: ~e" (pkg-error "bad 'setup-collects value\n value: ~e"
v))))))) v)))))))
(define do-its (define do-its
(map (curry install-package/outer (append old-infos infos)) (map (curry install-package/outer (append old-infos infos))
(append old-descs descs) (append old-descs descs)
@ -782,15 +810,21 @@
(package-info pkg-name)) (package-info pkg-name))
(match orig-pkg (match orig-pkg
[`(link ,_) [`(link ,_)
(error 'planet2 "Cannot update linked packages (~e is linked to ~e)" (pkg-error (~a "cannot update linked packages\n"
pkg-name " package name: ~a\n"
orig-pkg)] " package source: ~a")
pkg-name
orig-pkg)]
[`(dir ,_) [`(dir ,_)
(error 'planet2 "Cannot update packages installed locally. (~e was installed via a local directory.)" (pkg-error (~a "cannot update packages installed locally;\n"
pkg-name)] " package was installed via a local directory\n"
" package name: ~a")
pkg-name)]
[`(file ,_) [`(file ,_)
(error 'planet2 "Cannot update packages installed locally. (~e was installed via a local file.)" (pkg-error (~a "cannot update packages installed locally;\n"
pkg-name)] " package was installed via a local file\n"
" package name: ~a")
pkg-name)]
[`(,_ ,orig-pkg-source) [`(,_ ,orig-pkg-source)
(define new-checksum (define new-checksum
(remote-package-checksum orig-pkg)) (remote-package-checksum orig-pkg))
@ -857,9 +891,9 @@
[(list* (and key "indexes") val) [(list* (and key "indexes") val)
(update-pkg-cfg! "indexes" val)] (update-pkg-cfg! "indexes" val)]
[(list key) [(list key)
(error 'planet2 "unsupported config key: ~e" key)] (pkg-error "unsupported config key\n key: ~e" key)]
[(list) [(list)
(error 'planet2 "must provide config key")])] (pkg-error "config key not provided")])]
[else [else
(match key+vals (match key+vals
[(list key) [(list key)
@ -868,17 +902,17 @@
(for ([s (in-list (read-pkg-cfg/def "indexes"))]) (for ([s (in-list (read-pkg-cfg/def "indexes"))])
(printf "~a\n" s))] (printf "~a\n" s))]
[_ [_
(error 'planet2 "unsupported config key: ~e" key)])] (pkg-error "unsupported config key\n key: ~e" key)])]
[(list) [(list)
(error 'planet2 "must provide config key")] (pkg-error "config key not provided")]
[_ [_
(error 'planet2 "must provide only config key")])])) (pkg-error "multiple config keys provided")])]))
(define (create-cmd create:format maybe-dir) (define (create-cmd create:format maybe-dir)
(begin (begin
(define dir (regexp-replace* #rx"/$" maybe-dir "")) (define dir (regexp-replace* #rx"/$" maybe-dir ""))
(unless (directory-exists? dir) (unless (directory-exists? dir)
(error 'planet2 "directory does not exist: ~e" dir)) (pkg-error "directory does not exist\n path: ~a" dir))
(match create:format (match create:format
["MANIFEST" ["MANIFEST"
(with-output-to-file (with-output-to-file
@ -928,7 +962,7 @@
#:as-paths (map (lambda (v) (build-path "collects" v)) names) #:as-paths (map (lambda (v) (build-path "collects" v)) names)
#:collections (map list (map path->string dirs))))] #:collections (map list (map path->string dirs))))]
[x [x
(error 'pkg "Invalid package format: ~e" x)]) (pkg-error "invalid package format\n format: ~a" x)])
(define chk (format "~a.CHECKSUM" pkg)) (define chk (format "~a.CHECKSUM" pkg))
(with-output-to-file chk #:exists 'replace (with-output-to-file chk #:exists 'replace
(λ () (display (call-with-input-file pkg sha1))))]))) (λ () (display (call-with-input-file pkg sha1))))])))
@ -944,6 +978,8 @@
(parameter/c boolean?)] (parameter/c boolean?)]
[current-install-version-specific? [current-install-version-specific?
(parameter/c boolean?)] (parameter/c boolean?)]
[current-pkg-error
(parameter/c procedure?)]
[pkg-desc [pkg-desc
(-> string? (-> string?
(or/c #f 'file 'dir 'link 'file-url 'dir-url 'github 'name) (or/c #f 'file 'dir 'link 'file-url 'dir-url 'github 'name)

24
collects/planet2/main.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base #lang racket/base
(require racket/function (require racket/function
raco/command-name
"lib.rkt" "lib.rkt"
"commands.rkt" "commands.rkt"
(prefix-in setup: setup/setup)) (prefix-in setup: setup/setup))
@ -16,6 +17,11 @@
(if installation? '("scribblings/main") null) (if installation? '("scribblings/main") null)
'("scribblings/main/user"))))))) '("scribblings/main/user")))))))
(define ((pkg-error cmd) . args)
(apply raise-user-error
(string->symbol (format "~a ~a" (short-program+command-name) cmd))
args))
(commands (commands
"This tool is used for managing installed packages." "This tool is used for managing installed packages."
[install [install
@ -46,7 +52,8 @@
"that it affects dependencies... so make sure the dependencies exist first")] "that it affects dependencies... so make sure the dependencies exist first")]
#:args pkg-source #:args pkg-source
(parameterize ([current-install-system-wide? installation] (parameterize ([current-install-system-wide? installation]
[current-install-version-specific? (not shared)]) [current-install-version-specific? (not shared)]
[current-pkg-error (pkg-error 'install)])
(with-package-lock (with-package-lock
(define setup-collects (define setup-collects
(install-cmd #:dep-behavior deps (install-cmd #:dep-behavior deps
@ -76,7 +83,8 @@
[#:bool update-deps () "Check named packages' dependencies for updates"] [#:bool update-deps () "Check named packages' dependencies for updates"]
#:args pkgs #:args pkgs
(parameterize ([current-install-system-wide? installation] (parameterize ([current-install-system-wide? installation]
[current-install-version-specific? (not shared)]) [current-install-version-specific? (not shared)]
[current-pkg-error (pkg-error 'update)])
(with-package-lock (with-package-lock
(define setup-collects (define setup-collects
(update-packages pkgs (update-packages pkgs
@ -95,7 +103,8 @@
[#:bool auto () "Remove automatically installed packages with no dependencies"] [#:bool auto () "Remove automatically installed packages with no dependencies"]
#:args pkgs #:args pkgs
(parameterize ([current-install-system-wide? installation] (parameterize ([current-install-system-wide? installation]
[current-install-version-specific? (not shared)]) [current-install-version-specific? (not shared)]
[current-pkg-error (pkg-error 'remove)])
(with-package-lock (with-package-lock
(remove-packages pkgs (remove-packages pkgs
#:auto? auto #:auto? auto
@ -120,7 +129,8 @@
[(s) "User-specific, all-version:"] [(s) "User-specific, all-version:"]
[(u) "User-spcific, version-specific:"]))) [(u) "User-spcific, version-specific:"])))
(parameterize ([current-install-system-wide? (eq? mode 'i)] (parameterize ([current-install-system-wide? (eq? mode 'i)]
[current-install-version-specific? (eq? mode 'u)]) [current-install-version-specific? (eq? mode 'u)]
[current-pkg-error (pkg-error 'show)])
(with-package-lock (with-package-lock
(show-cmd (if only-mode "" " "))))))] (show-cmd (if only-mode "" " "))))))]
[config [config
@ -130,7 +140,8 @@
[#:bool set () "Completely replace the value"] [#:bool set () "Completely replace the value"]
#:args key+vals #:args key+vals
(parameterize ([current-install-system-wide? installation] (parameterize ([current-install-system-wide? installation]
[current-install-version-specific? (not shared)]) [current-install-version-specific? (not shared)]
[current-pkg-error (pkg-error 'config)])
(with-package-lock (with-package-lock
(config-cmd set key+vals)))] (config-cmd set key+vals)))]
[create [create
@ -140,4 +151,5 @@
"options are: zip (the default), tgz, plt")] "options are: zip (the default), tgz, plt")]
[#:bool manifest () "Creates a manifest file for a directory, rather than an archive"] [#:bool manifest () "Creates a manifest file for a directory, rather than an archive"]
#:args (maybe-dir) #:args (maybe-dir)
(create-cmd (if manifest "MANIFEST" (or format "zip")) maybe-dir)]) (parameterize ([current-pkg-error (pkg-error 'create)])
(create-cmd (if manifest "MANIFEST" (or format "zip")) maybe-dir))])

2
collects/tests/planet2/tests-install.rkt
View File

@ -53,7 +53,7 @@
$ "raco pkg install --type file test-pkgs/pkg-a-first/" =exit> 1) $ "raco pkg install --type file test-pkgs/pkg-a-first/" =exit> 1)
(shelly-case (shelly-case
"local directory name fails because called a URL" "local directory name fails because called a URL"
$ "raco pkg install --type url test-pkgs/pkg-a-first/" =exit> 1) $ "raco pkg install --type file-url test-pkgs/pkg-a-first/" =exit> 1)
(shelly-case (shelly-case
"remote/URL/http directory, non-existant file" "remote/URL/http directory, non-existant file"