#lang scheme
(require setup/getinfo
setup/unpack
"base.ss"
"depend.ss"
(planet bzlib/file)
)
(define (unpack-plt-archive! archive path)
(unpack archive
path
void
(lambda () path)))
(define (call-with-temporary-directory proc)
(let ((dir (temp-path (uuid->string (make-uuid)))))
(dynamic-wind (lambda ()
(mkdir* dir))
(lambda ()
(proc dir))
(lambda ()
(rm-rf dir)))))
(define (with-temporary-directory proc)
(call-with-temporary-directory
(lambda (dir)
(parameterize ((current-directory dir))
(proc)))))
(define (get-info-from-plt! archive)
(define (helper info)
(define (get-info key (default #f))
(with-handlers ((exn? (lambda (e) default)))
(info key)))
(list (cons 'required-core-version (get-info 'required-core-version))
(cons 'repositories (get-info 'repositories))))
(call-with-temporary-directory
(lambda (dir)
(unpack-plt-archive! archive dir)
(helper (get-info/full dir)))))
(define (save-info-from-plt! archive)
(let ((path (archive-path->info archive)))
(mkdir* (parent-path path))
(call-with-output-atomic-file
path
(lambda (out)
(write (get-info-from-plt! archive) out)))))
(define (archive-path->info path)
(parent-path path ".info"))
(define (info-satisfied? info arg)
(define (repo-helper repo ver) (if (version<? ver "4.0")
(not repo)
(pair? repo)))
(define (version-helper core ver)
(if (not core)
#t (version<=? core ver)))
(and (repo-helper (assoc/cdr 'repositories info) (planet-arg-lang arg))
(version-helper (assoc/cdr 'required-core-version info) (planet-arg-lang arg))))
(define (plt-package-satisfies-planet-arg? path arg)
(unless (file-exists? (archive-path->info path))
(save-info-from-plt! path))
(call-with-input-file (archive-path->info path)
(lambda (in)
(info-satisfied? (read in) arg))))
(provide/contract
(save-info-from-plt! (-> path-string? any))
(plt-package-satisfies-planet-arg? (-> path-string? planet-arg? any))
)