#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PLANET.plt - local planet proxy server
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; Licensed under LGPL.
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; repository.ss - local repository and interfaces 
;; yc 1/18/2010 - first version
(require (planet bzlib/dbi)
         (planet bzlib/file)
         (planet bzlib/http)
         (planet bzlib/date/srfi)
         "base.ss"
         "getinfo.ss"
         "depend.ss"
         )

(define repository-path (make-parameter #f)) 

(define (make-repository (path (repository-path)))
  (connect 'file path))

(define (path-helper path) 
  (substring path 1 (string-length path)))

(define (numbered-path path) 
  (string->number (path-helper path))) 

;; use this similarly to argmax except to return #f when list is null...
(define (argmax/false proc lst) 
  (if (null? lst) 
      #f 
      (argmax proc lst))) 

(define (existence-helper repo path seg) 
  (query repo 'list `((path . ,(build-path* path seg)))))

(define (package-path arg) 
  (string-join (planet-arg-path arg) "/"))

(define (major-path-helper paths major) 
  (argmax/false numbered-path 
                (filter (lambda (p) 
                          (or (not major) 
                              (= major (numbered-path p)))) 
                        paths)))

(define (minor-path-helper paths low high) 
  (argmax/false numbered-path 
                (filter (lambda (p) 
                          (let ((np (numbered-path p))) 
                            (and (<= low np (if (not high) +inf.0 high)))))
                        paths)))

(define (planet-arg->repository-path repo arg) 
  (define (path-helper) 
    (let*/if ((name (planet-arg-name arg)) 
              (base (package-path arg))
              (majors (existence-helper repo base name))
              (major (major-path-helper majors (planet-arg-major arg)))
              (minors (existence-helper repo 
                                        (build-path* base name) major))
              (minor (minor-path-helper minors (planet-arg-minor-low arg)
                                        (planet-arg-minor-high arg))))
             (build-path* base name major minor name)))
  (let ((path (path-helper)))
    (values path 
            (if (not path)
                #f
                (plt-package-satisfies-planet-arg? 
                 (build-path (handle-conn repo) path) arg)))))

(define (repository-path->versions path) 
  (define (helper major minor) 
    (values major minor)) 
  (apply helper (filter (lambda (p) 
                          (string->number p))
                        (regexp-split #px"/" 
                                      ((if (path? path) path->string identity) path)))))

(define (repository-path->http-client-response repo path)
  (let-values (((major minor) 
                (repository-path->versions path)))
    (make-http-client-response "1.0" 
                               200 
                               "OK" 
                               `(("Package-Major-Version" . ,major) 
                                 ("Package-Minor-Version" . ,minor)
                                 ("Connection" . "Close")
                                 ("Content-Type" . "text/plain; charset=utf-8")
                                 ("Date" . ,(date->rfc822 (current-date)))
                                 ("Last-Modified" 
                                  . ,(date->rfc822 
                                      (seconds->date 
                                       (car (query repo 'mtime `((path . ,path)))))))
                                 ("Content-Length" 
                                  . ,(format "~a" (car (query repo 'size `((path . ,path))))))
                                 )
                               (car (query repo 'open-port `((path . ,path)))))))

(define (http-client-response->repository-path repo arg response) 
  (if (= (http-client-response-code response) 200) ;;
      (let*/if ((major (assoc/cdr "Package-Major-Version" 
                                  (http-client-response-headers response)))
                (minor (assoc/cdr "Package-Minor-Version" 
                                  (http-client-response-headers response)))) 
               (build-path* (handle-conn repo) 
                            (package-path arg)
                            (planet-arg-name arg)
                            major 
                            minor 
                            (planet-arg-name arg)))
      #f))
#|
(repository-path "/Users/yinso/planet")

(define r (make-repository))
(planet-arg->repository-path r (make-planet-arg '("bzlib") "base.plt" #f 0 #f (version)))
;;|#
(provide/contract 
 (repository-path (parameter/c (or/c false/c path-string?)))
 (make-repository (->* () 
                       (path-string?) 
                       handle?))
 (planet-arg->repository-path (-> handle? planet-arg? 
                                  (values (or/c false/c path-string?) 
                                          boolean?)))
 (repository-path->versions (-> path-string? (values exact-positive-integer?
                                                     exact-nonnegative-integer?)))
 (repository-path->http-client-response (-> handle? path-string? http-client-response?))
 (http-client-response->repository-path 
  (-> handle? planet-arg? http-client-response? (or/c false/c path-string?)))
 )