#lang scheme/base
(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)))
(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))
(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?)))
)