suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Finish move to v4

Browse Source 
svn: r10758
This commit is contained in:
Eli Barzilay 2008-07-14 09:01:44 +00:00
parent fd569e49c4
commit e4d9cfb557
8 changed files with 86 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/planet/cachepath.ss
View File

@ -1,4 +1,4 @@
(module cachepath mzscheme
#lang scheme/base
(require "config.ss")
(provide get-planet-cache-path)
@ -11,4 +11,4 @@
;; of directory, it doesn't do that anymore)
(define (get-planet-cache-path)
(let ((path (build-path (PLANET-DIR) "cache.ss")))
path)))
path))

6
collects/planet/config.ss
View File

@ -1,4 +1,5 @@
(module config mzscheme
#lang scheme/base
(require "private/define-config.ss")
(define-parameters
(PLANET-SERVER-NAME "planet.plt-scheme.org")
@ -20,5 +21,4 @@
(USE-HTTP-DOWNLOADS? #t)
(HTTP-DOWNLOAD-SERVLET-URL "http://planet.plt-scheme.org/servlets/planet-servlet.ss")
(PLANET-ARCHIVE-FILTER #f)))
(PLANET-ARCHIVE-FILTER #f))

6
collects/planet/planet-archives.ss
View File

@ -1,6 +1,6 @@
(module planet-archives mzscheme
#lang scheme/base
(require "private/planet-shared.ss"
mzlib/file
"config.ss"
"cachepath.ss")
@ -56,5 +56,3 @@
(define (get-all-planet-packages)
(append (get-installed-planet-archives)
(get-hard-linked-packages)))
)

27
collects/planet/planet.ss
View File

@ -1,4 +1,5 @@
(module planet mzscheme
#lang scheme/base
#|
This module contains code that implements the `planet' command-line tool.
@ -6,11 +7,11 @@ PLANNED FEATURES:
* Disable a package without removing it (disabling meaning
that if it's a tool it won't start w/ DrScheme, etc)
|#
(require mzlib/string
mzlib/file
(only mzlib/list sort)
net/url
mzlib/match
(require net/url
scheme/path
scheme/file
scheme/match
(only-in mzlib/string read-from-string)
"config.ss"
"private/planet-shared.ss"
@ -138,7 +139,7 @@ This command does not unpack or install the named .plt file."
(when (file-exists? pkg)
(fail "Cannot download, there is a file named ~a in the way" pkg))
(match (download-package full-pkg-spec)
[(#t path maj min)
[(list #t path maj min)
(copy-file path pkg)
(printf "Downloaded ~a package version ~a.~a\n" pkg maj min)]
[_
@ -192,7 +193,10 @@ This command does not unpack or install the named .plt file."
(for-each
(lambda (l) (apply printf " ~a\t~a\t~a ~a\n" l))
(sort-by-criteria
(map (lambda (x) (match x [(_ owner pkg _ maj min) (list owner pkg maj min)])) normal-packages)
(map (lambda (x)
(match x [(list _ owner pkg _ maj min)
(list owner pkg maj min)]))
normal-packages)
(list string<? string=?)
(list string<? string=?)
(list < =)
@ -204,7 +208,10 @@ This command does not unpack or install the named .plt file."
(lambda (l) (apply printf " ~a\t~a\t~a ~a\n --> ~a\n" l))
(sort-by-criteria
(map
(lambda (x) (match x [(dir owner pkg _ maj min) (list owner pkg maj min (path->string dir))]))
(lambda (x)
(match x
[(list dir owner pkg _ maj min)
(list owner pkg maj min (path->string dir))]))
devel-link-packages)
(list string<? string=?)
(list string<? string=?)
@ -287,4 +294,4 @@ This command does not unpack or install the named .plt file."
(lambda (e)
(fprintf (current-error-port) "~a\n" (exn-message e))
(exit 1))])
(start)))
(start))

5
collects/planet/private/define-config.ss
View File

@ -1,4 +1,5 @@
(module define-config scheme/base
#lang scheme/base
(require (for-syntax scheme/base))
(provide define-parameters)
@ -9,4 +10,4 @@
(andmap identifier? (syntax->list #'(name ...)))
#'(begin
(provide name ...)
(define name (make-parameter val)) ...)])))
(define name (make-parameter val)) ...)]))

37
collects/planet/private/linkage.ss
View File

@ -1,8 +1,8 @@
(module linkage mzscheme
#lang scheme/base
(require "planet-shared.ss"
"../config.ss"
mzlib/match)
scheme/match)
(provide get/linkage
get-linkage
@ -50,16 +50,15 @@
(define (add-linkage! rmp pkg-spec pkg)
(when rmp
(let ((key (get-key rmp pkg-spec)))
(hash-table-get
(hash-ref
(get-linkage-table)
key
(lambda ()
(let ((plist (pkg-as-list pkg)))
(begin
(hash-table-put! (get-linkage-table) key plist)
(with-output-to-file (LINKAGE-FILE)
(lambda () (write (list key plist)))
'append)))))))
(hash-set! (get-linkage-table) key plist)
(with-output-to-file (LINKAGE-FILE) #:exists 'append
(lambda () (write (list key plist))))))))))
pkg)
;; remove-linkage! pkg-spec -> void
@ -68,32 +67,29 @@
(let ((l (get-linkage-table)))
;; first remove bad entries from the in-memory hash table
(hash-table-for-each
(hash-for-each
l
(lambda (k v)
(match v
[(name route maj min _)
[(list name route maj min _)
(when (and (equal? name (pkg-name pkg))
(equal? route (pkg-route pkg))
(= maj (pkg-maj pkg))
(= min (pkg-min pkg)))
(hash-table-remove! l k))]
(hash-remove! l k))]
[_ (void)])))
;; now write the new table out to disk to keep it in sync
(with-output-to-file (LINKAGE-FILE)
(with-output-to-file (LINKAGE-FILE) #:exists 'truncate/replace
(lambda ()
(printf "\n")
(hash-table-for-each
(hash-for-each
l
(lambda (k v) (write (list k v)))))
'truncate/replace)))
(lambda (k v) (write (list k v))))))))
;; kill the whole linkage-table
(define (remove-all-linkage!)
(with-output-to-file (LINKAGE-FILE)
(lambda () (printf "\n"))
'truncate/replace)
(with-output-to-file (LINKAGE-FILE) #:exists 'truncate/replace newline)
(set! LT #f))
;; pkg-as-list : PKG -> (list string string nat nat bytes[path])
@ -111,13 +107,13 @@
(define (get-linkage rmp pkg-specifier)
(cond
[rmp
(let ((pkg-fields (hash-table-get
(let ((pkg-fields (hash-ref
(get-linkage-table)
(get-key rmp pkg-specifier)
(lambda () #f))))
(if pkg-fields
(with-handlers ([exn:fail? (lambda (e) #f)])
(match-let ([(name route maj min pathbytes) pkg-fields])
(match-let ([(list name route maj min pathbytes) pkg-fields])
(make-pkg name route maj min (bytes->path pathbytes))))
#f))]
[else #f]))
@ -136,6 +132,3 @@
; key suitable for marshalling that represents the given resolved-module-path
(define (get-module-id rmp)
(path->string (resolved-module-path-name rmp)))
)

71
collects/planet/resolver.ss
View File

@ -160,7 +160,7 @@ subdirectory.
||#
#lang mzscheme
#lang scheme/base
(define resolver
(case-lambda
@ -177,23 +177,23 @@ subdirectory.
stx
load?)]))
(require mzlib/match
mzlib/file
mzlib/port
mzlib/list
mzlib/date
(require scheme/match
scheme/path
scheme/file
scheme/port
scheme/date
scheme/tcp
mzlib/struct
net/url
net/head
mzlib/struct
"config.ss"
"private/planet-shared.ss"
"private/linkage.ss"
"parsereq.ss")
(provide (rename resolver planet-module-name-resolver)
(provide (rename-out [resolver planet-module-name-resolver])
resolve-planet-path
pkg-spec->full-pkg-spec
get-package-from-cache
@ -219,13 +219,13 @@ subdirectory.
(define (establish-diamond-property-monitor)
(unless VER-CACHE-NAME (set! VER-CACHE-NAME (gensym)))
(unless (namespace-variable-value VER-CACHE-NAME #t (lambda () #f))
(namespace-set-variable-value! VER-CACHE-NAME (make-hash-table 'equal))))
(namespace-set-variable-value! VER-CACHE-NAME (make-hash))))
(define (the-version-cache) (namespace-variable-value VER-CACHE-NAME))
(define (pkg->diamond-key pkg) (cons (pkg-name pkg) (pkg-route pkg)))
(define (pkg-matches-bounds? pkg bound-info)
(match-let ([(maj lo hi) bound-info])
(match-let ([(list maj lo hi) bound-info])
(and (= maj (pkg-maj pkg))
(or (not lo) (>= (pkg-min pkg) lo))
(or (not hi) (<= (pkg-min pkg) hi)))))
@ -235,18 +235,18 @@ subdirectory.
(define (build-compatibility-fn compat-data)
(define pre-fn
(match compat-data
[`none (lambda (_) #f)]
[`all (lambda (_) #t)]
[`(all-except ,vspec ...)
['none (lambda (_) #f)]
['all (lambda (_) #t)]
[(list 'all-except vspec ...)
(let ([bounders (map (λ (x) (version->bounds x (λ (_) #f))) vspec)])
(if (andmap (lambda (x) x) bounders)
(lambda (v)
(not (ormap (lambda (bounder) (pkg-matches-bounds? v bounder))
bounders)))
#f))]
[`(only ,vspec ...)
[(list 'only vspec ...)
(let ([bounders (map (λ (x) (version->bounds x (λ (_) #f))) vspec)])
(if (andmap (lambda (x) x) bounders)
(when (andmap (lambda (x) x) bounders)
(lambda (v)
(andmap (lambda (bounder) (pkg-matches-bounds? v bounder))
bounders)))
@ -274,7 +274,7 @@ subdirectory.
(define (add-pkg-to-diamond-registry! pkg stx)
(let ([loaded-packages
(hash-table-get (the-version-cache) (pkg->diamond-key pkg) '())])
(hash-ref (the-version-cache) (pkg->diamond-key pkg) '())])
(unless (list? loaded-packages)
(error 'PLaneT "Inconsistent state: expected loaded-packages to be a list, received: ~s" loaded-packages))
(let ([all-violations '()])
@ -306,9 +306,9 @@ subdirectory.
(unless (null? all-violations)
(let ([worst (or (assq values all-violations) (car all-violations))])
(raise (cadr worst)))))
(hash-table-put! (the-version-cache)
(pkg->diamond-key pkg)
(cons (list pkg stx) loaded-packages))))
(hash-set! (the-version-cache)
(pkg->diamond-key pkg)
(cons (list pkg stx) loaded-packages))))
;; =============================================================================
;; MAIN LOGIC
@ -477,7 +477,7 @@ subdirectory.
;; the uninstalled-packages cache, then returns a promise for it
(define (get-package-from-server pkg)
(match (download-package pkg)
[(#t tmpfile-path maj min)
[(list #t tmpfile-path maj min)
(let* ([upkg (make-uninstalled-pkg tmpfile-path pkg maj min)]
[cached-path (save-to-uninstalled-pkg-cache! upkg)]
[final (make-uninstalled-pkg cached-path pkg maj min)])
@ -485,7 +485,7 @@ subdirectory.
(normalize-path cached-path))
(delete-file tmpfile-path)) ;; remove the tmp file, we're done with it
final)]
[(#f str)
[(list #f str)
(string-append "PLaneT could not find the requested package: " str)]
[(? string? s)
(string-append "PLaneT could not download the requested package: " s)]))
@ -543,7 +543,7 @@ subdirectory.
(pkg-spec-name pkg)
(current-time))
;; oh man is this a bad hack!
(parameterize ([current-namespace (make-namespace)])
(parameterize ([current-namespace (make-base-namespace)])
(let ([ipp (dynamic-require 'setup/plt-single-installer
'install-planet-package)])
(ipp path the-dir (list owner (pkg-spec-name pkg)
@ -582,9 +582,12 @@ subdirectory.
(fprintf op "PLaneT/1.0\n")
(flush-output op)
(match (read ip)
['ok (state:send-pkg-request)]
[('invalid (? string? msg)) (state:abort (string-append "protocol version error: " msg))]
[bad-msg (state:abort (format "server protocol error (received invalid response): ~a" bad-msg))]))
['ok
(state:send-pkg-request)]
[(list 'invalid (? string? msg))
(state:abort (string-append "protocol version error: " msg))]
[bad-msg
(state:abort (format "server protocol error (received invalid response): ~a" bad-msg))]))
(define (state:send-pkg-request)
(request-pkg-list (list pkg))
@ -592,16 +595,16 @@ subdirectory.
(define (state:receive-package)
(match (read ip)
[(_ 'get 'ok (? nat? maj) (? nat? min) (? nat? bytes))
[(list _ 'get 'ok (? nat? maj) (? nat? min) (? nat? bytes))
(let ([filename (make-temporary-file "planettmp~a.plt")])
(read-char ip) ; throw away newline that must be present
(read-n-chars-to-file bytes ip filename)
(list #t filename maj min))]
[(_ 'error 'malformed-request (? string? msg))
[(list _ 'error 'malformed-request (? string? msg))
(state:abort (format "Internal error (malformed request): ~a" msg))]
[(_ 'get 'error 'not-found (? string? msg))
[(list _ 'get 'error 'not-found (? string? msg))
(state:failure (format "Server had no matching package: ~a" msg))]
[(_ 'get 'error (? symbol? code) (? string? msg))
[(list _ 'get 'error (? symbol? code) (? string? msg))
(state:abort (format "Unknown error ~a receiving package: ~a" code msg))]
[bad-response (state:abort (format "Server returned malformed message: ~e" bad-response))]))
@ -631,8 +634,8 @@ subdirectory.
;; get-http-response-code : header[from net/head] -> 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))))
(cond [(regexp-match #rx"^HTTP/[^ ]* ([^ ]*)" header) => cadr]
[else #f]))
;; pkg->download-url : FULL-PKG-SPEC -> url
;; gets the download url for the given package
@ -679,7 +682,7 @@ subdirectory.
[maj (string->number maj/str)]
[min (string->number min/str)]
[content-length (string->number content-length/str)]
[op (open-output-file filename 'truncate/replace)])
[op (open-output-file filename #:exists 'truncate/replace)])
(copy-port ip op)
(close-input-port ip)
(close-output-port op)
@ -728,8 +731,6 @@ subdirectory.
;; UTILITY
;; A few small utility functions
(define (last l) (car (last-pair l)))
;; make-directory*/paths : path -> (listof path)
;; like make-directory*, but returns what directories it actually created
(define (make-directory*/paths dir)

10
collects/planet/util.ss
View File

@ -1,4 +1,4 @@
#lang scheme
#lang scheme/base
(require "config.ss"
"planet-archives.ss"
@ -10,7 +10,12 @@
net/url
xml/xml
scheme/contract
scheme/path
scheme/file
scheme/port
scheme/match
scheme/class
setup/pack
setup/plt-single-installer
@ -18,7 +23,8 @@
setup/unpack
(prefix-in srfi1: srfi/1)
)
(for-syntax scheme/base))
#| The util collection provides a number of useful functions for interacting with the PLaneT system. |#