From 51f56a3cdcde7d29036971c67660ba91513747c5 Mon Sep 17 00:00:00 2001 From: Jacob Matthews Date: Thu, 11 Aug 2005 01:56:12 +0000 Subject: [PATCH] HTTP support for PLaneT svn: r579 --- collects/planet/config.ss | 23 ++++--- collects/planet/private/planet-shared.ss | 4 +- collects/planet/resolver.ss | 83 ++++++++++++++++++++++-- 3 files changed, 94 insertions(+), 16 deletions(-) diff --git a/collects/planet/config.ss b/collects/planet/config.ss index 40753704ad..f444677cd8 100644 --- a/collects/planet/config.ss +++ b/collects/planet/config.ss @@ -2,12 +2,17 @@ (require "private/planet-shared.ss") - (define-parameters (PLANET-SERVER-NAME "planet.plt-scheme.org") - (PLANET-SERVER-PORT 270) - (PLANET-CODE-VERSION "300") - (PLANET-DIR (build-path (find-system-path 'addon-dir) "planet" (PLANET-CODE-VERSION))) - (CACHE-DIR (build-path (PLANET-DIR) "cache")) - (LINKAGE-FILE (build-path (PLANET-DIR) "LINKAGE")) - (LOGGING-ENABLED? #t) - (LOG-FILE (build-path (PLANET-DIR) "INSTALL-LOG")) - (DEFAULT-PACKAGE-LANGUAGE (version)))) + (define-parameters + (PLANET-SERVER-NAME "planet.plt-scheme.org") + (PLANET-SERVER-PORT 270) + (PLANET-CODE-VERSION "300") + (PLANET-DIR (build-path (find-system-path 'addon-dir) "planet" (PLANET-CODE-VERSION))) + (CACHE-DIR (build-path (PLANET-DIR) "cache")) + (LINKAGE-FILE (build-path (PLANET-DIR) "LINKAGE")) + (LOGGING-ENABLED? #t) + (LOG-FILE (build-path (PLANET-DIR) "INSTALL-LOG")) + (DEFAULT-PACKAGE-LANGUAGE (version)) + + (USE-HTTP-DOWNLOADS? #t) + (HTTP-DOWNLOAD-SERVLET-URL "http://planet.plt-scheme.org/servlets/planet-servlet.ss"))) + diff --git a/collects/planet/private/planet-shared.ss b/collects/planet/private/planet-shared.ss index 3337daa47c..08d875a2aa 100644 --- a/collects/planet/private/planet-shared.ss +++ b/collects/planet/private/planet-shared.ss @@ -37,8 +37,8 @@ Various common pieces of code that both the client and server need to access ; finds the appropriate language version for the given repository (define (language-version->repository ver) (cond - [(regexp-match #rx"20.+" ver) "207.1"] - [(regexp-match #rx"3.+|29.|" ver) "300"] + [(regexp-match #rx"^20.+" ver) "207.1"] + [(regexp-match #rx"(^30.+)|(^29.+)" ver) "300"] [else #f])) (define (version->description ver) diff --git a/collects/planet/resolver.ss b/collects/planet/resolver.ss index 246b3ecc50..6d50cf7f09 100644 --- a/collects/planet/resolver.ss +++ b/collects/planet/resolver.ss @@ -148,6 +148,10 @@ an appropriate subdirectory. (lib "date.ss") + (lib "url.ss" "net") + (lib "head.ss" "net") + (lib "struct.ss") + "config.ss" "private/planet-shared.ss" "private/linkage.ss") @@ -229,7 +233,12 @@ attempted to load version ~a.~a while version ~a.~a was already loaded" (or (get-package-from-cache pspec) (get-package-from-server pspec) - (raise-syntax-error #f "Could not find matching package" stx))))]) + (raise-syntax-error #f (format "Could not find package matching ~s" (list (pkg-spec-name pspec) + (pkg-spec-maj pspec) + (list (pkg-spec-minor-lo pspec) + (pkg-spec-minor-hi pspec)) + (pkg-spec-path pspec))) + stx))))]) (values (apply build-path (pkg-path pkg) (append path (list file-name))) pkg))] [_ (raise-syntax-error 'require (format "Illegal PLaneT invocation: ~e" (cdr spec)) stx)])) @@ -278,9 +287,10 @@ attempted to load version ~a.~a while version ~a.~a was already loaded" "Error downloading module from PLaneT server: ~a" (exn-message e))) (exn-continuation-marks e))))]) - (match (download-package pkg) - [(#t path maj min) (install-pkg pkg path maj min)] - [(#f str) #f]))) + (let ((download (if (USE-HTTP-DOWNLOADS?) download-package/http download-package))) + (match (download pkg) + [(#t path maj min) (install-pkg pkg path maj min)] + [(#f str) #f])))) (define (current-time) @@ -383,6 +393,69 @@ attempted to load version ~a.~a while version ~a.~a was already loaded" (state:initialize) (close-ports)))) + ;; ------------------------------------------------------------ + ;; HTTP VERSION OF THE PROTOCOL + + ;; pkg->servlet-args : FULL-PKG-SPEC -> environment[from (lib "url.ss" "net")] + ;; gets the appropriate query arguments to request the given package from the + ;; PLaneT HTTP download servlet + (define (pkg->servlet-args pkg) + (let ((get (lambda (access) (format "~s" (access pkg))))) + `((lang . ,(format "~s" (DEFAULT-PACKAGE-LANGUAGE))) + (name . ,(get pkg-spec-name)) + (maj . ,(get pkg-spec-maj)) + (min-lo . ,(get pkg-spec-minor-lo)) + (min-hi . ,(get pkg-spec-minor-hi)) + (path . ,(get pkg-spec-path))))) + + ;; get-http-response-code : header[from (lib "head.ss" "net")] -> string + ;; gets the HTTP response code in the given header + (define (get-http-response-code header) + (let ((parsed (regexp-match #rx"^HTTP/[^ ]* ([^ ]*)" header))) + (and parsed (cadr parsed)))) + + ;; download-package/http : FULL-PKG-SPEC -> RESPONSE + ;; a drop-in replacement for download-package that uses HTTP rather than the planet protocol. + ;; The HTTP protocol does not allow any kind of complicated negotiation, but it appears that + ;; many more users can make HTTP requests than requests from nonstandard protocols. + (define (download-package/http pkg) + + (let* ((args (pkg->servlet-args pkg)) + (target (copy-struct url (string->url (HTTP-DOWNLOAD-SERVLET-URL)) (url-query args))) + (ip (get-impure-port target)) + (head (purify-port ip)) + (response-code/str (get-http-response-code head)) + (response-code (string->number response-code/str))) + + (define (abort msg) + (close-input-port ip) + (raise (make-exn:i/o:protocol msg (current-continuation-marks)))) + + (case response-code + [(#f) (abort (format "Server returned invalid HTTP response code ~s" response-code/str))] + [(200) + (let ((maj/str (extract-field "Package-Major-Version" head)) + (min/str (extract-field "Package-Minor-Version" head))) + (unless (and maj/str min/str + (nat? (string->number maj/str)) + (nat? (string->number min/str))) + (printf "~a" head) + (abort "Server did not include valid major and minor version information")) + (let* ((filename (make-temporary-file "planettmp~a.plt")) + (op (open-output-file filename 'truncate)) + (maj (string->number maj/str)) + (min (string->number min/str))) + (copy-port ip op) + (close-input-port ip) + (close-output-port op) + (list #t filename maj min)))] + [(404) + (list #f (format "Server had no matching package: ~a" (read-line ip)))] + [(400) + (abort (format "Internal error (malformed request): ~a" (read-line ip)))] + [else + (abort (format "Internal error (unknown HTTP response code ~a)" response-code))]))) + ; ========================================================================================== ; MODULE MANAGEMENT ; Handles interaction with the module system @@ -419,4 +492,4 @@ attempted to load version ~a.~a while version ~a.~a was already loaded" (make-directory dir) (cons dir dirs))])))) - ) \ No newline at end of file + )