#lang scheme
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PLANET.plt - local planet proxy server
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; Licensed under LGPL.
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; getinfo.ss - functions for retrieving info from plt packages
;; yc 1/18/2010 - first version

(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)))))

;; let's read from the info file that we have created...
;; 1 - get the path based on the info.ss...
(define (archive-path->info path)
  (parent-path path ".info"))

;; we need to know whether
(define (info-satisfied? info arg) 
  (define (repo-helper repo ver) ;; repositories does not exist prior to 4.0
    (if (version<? ver "4.0") 
        (not repo) 
        (pair? repo)))
  (define (version-helper core ver) 
    (if (not core) 
        #t ;; we are good for the current version... hmm...
        ;; otherwise core must be less than the language version for it to work...
        (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) 
  ;; let's ensure that the file exists...
  (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))
 )