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

Added support for a hard-link file that will hopefully ease development burdens

Browse Source 
svn: r1876
This commit is contained in:
Jacob Matthews 2006-01-20 00:40:38 +00:00
parent 66074b867f
commit 19435656d0
4 changed files with 131 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/planet/config.ss
View File

@ -1,7 +1,5 @@
(module config mzscheme
(require "private/planet-shared.ss")
(require "private/define-config.ss")
(define-parameters
(PLANET-SERVER-NAME "planet.plt-scheme.org")
(PLANET-SERVER-PORT 270)
@ -11,6 +9,7 @@
(build-path (find-system-path 'addon-dir) "planet" (PLANET-CODE-VERSION) (version))))
(CACHE-DIR (build-path (PLANET-DIR) "cache"))
(LINKAGE-FILE (build-path (PLANET-DIR) "LINKAGE"))
(HARD-LINK-FILE (build-path (PLANET-DIR) "HARD-LINKS"))
(LOGGING-ENABLED? #t)
(LOG-FILE (build-path (PLANET-DIR) "INSTALL-LOG"))
(DEFAULT-PACKAGE-LANGUAGE (version))

13
collects/planet/private/define-config.ss Normal file
View File

@ -0,0 +1,13 @@
(module define-config mzscheme
(provide define-parameters)
(define-syntax (define-parameters stx)
(syntax-case stx ()
[(_ (name val) ...)
(andmap identifier? (syntax-e #'(name ...)))
#'(begin
(provide name ...)
(define name (make-parameter val)) ...)])))

136
collects/planet/private/planet-shared.ss
View File

@ -1,32 +1,23 @@
#| planet-shared.ss -- shared client/server utility functions
Various common pieces of code that both the client and server need to access
==========================================================================================
|#
(module planet-shared mzscheme
(require (lib "list.ss")
(lib "etc.ss")
(lib "port.ss"))
(lib "port.ss")
(prefix srfi1: (lib "1.ss" "srfi"))
(lib "match.ss")
(lib "file.ss")
"../config.ss")
(provide (all-defined))
(define-syntax (define-parameters stx)
(syntax-case stx ()
[(_ (name val) ...)
(andmap identifier? (syntax-e #'(name ...)))
#'(begin
(provide name ...)
(define name (make-parameter val)) ...)]))
; exn:i/o:protocol: exception indicating that a protocol error occured
(define-struct (exn:i/o:protocol exn:fail:network) ())
(define BUILD "build")
; ==========================================================================================
; CACHE LOGIC
@ -50,16 +41,111 @@ Various common pieces of code that both the client and server need to access
(define (legal-language? l)
(and (language-version->repository l) #t))
; lookup-package : FULL-PKG-SPEC string[dirname] -> PKG | #f
; returns the directory pointing to the appropriate package in the cache, or #f if the given package
; isn't in the cache
(define (lookup-package pkg cache-dir)
(let ((pkg-dir (build-path (apply build-path cache-dir (pkg-spec-path pkg)) (pkg-spec-name pkg))))
(if (directory-exists? pkg-dir)
(get-best-match pkg pkg-dir)
#f)))
; lookup-package : FULL-PKG-SPEC -> PKG | #f
; returns the directory pointing to the appropriate package in the cache, the user's hardlink table,
; or #f if the given package isn't in the cache or the hardlink table
(define (lookup-package pkg)
(let* ((at (build-assoc-table pkg)))
(get-best-match/t at pkg)))
; get-best-match :FULL-PKG-SPEC (listof string[directory-name]) -> PKG | #f
; build-assoc-table : FULL-PKG-SPEC -> assoc-table
; returns a version-number -> directory association table for the given package
(define (build-assoc-table pkg)
(let ((path (build-path (apply build-path (CACHE-DIR) (pkg-spec-path pkg)) (pkg-spec-name pkg))))
(add-to-table
(dir->assoc-table path)
(hard-links pkg))))
;; assoc-table ::= (listof (list n n path))
(define empty-table '())
; dir->assoc-table : path -> assoc-table
; returns the association table for the given planet dir
(define (dir->assoc-table path)
(define (tree-stuff->row-or-false p majs mins)
(let ((maj (string->number majs))
(min (string->number mins)))
(if (and (path? p) maj min)
(list maj min (build-path path majs mins))
#f)))
(if (directory-exists? path)
(filter
(λ (x) x)
(tree-apply
tree-stuff->row-or-false
(directory->tree path (λ (x) #t) 2 (λ (x) x))))
empty-table))
; the link table format:
; (listof (list string[name] (listof string[path]) num num bytes[directory])
; hard-links : FULL-PKG-SPEC -> (listof assoc-table-row)
(define (hard-links pkg)
(unless (and (absolute-path? (HARD-LINK-FILE)) (path-only (HARD-LINK-FILE)))
(raise (make-exn:fail:contract
(string->immutable-string
(format
"The HARD-LINK-FILE setting must be an absolute path name specifying a file; given ~s"
(HARD-LINK-FILE)))
(current-continuation-marks))))
(let ((link-table
(if (file-exists? (HARD-LINK-FILE))
(with-input-from-file (HARD-LINK-FILE) read)
'())))
(srfi1:filter-map
(λ (row)
(match row
[`(,(? (λ (name) (equal? name (pkg-spec-name pkg))))
,(? (λ (path) (equal? path (pkg-spec-path pkg))))
,maj ,min ,(? bytes? dir))
(list maj min (bytes->path dir))]
[_ #f]))
link-table)))
; add-to-table assoc-table (listof assoc-table-row) -> assoc-table
(define add-to-table append)
; assoc-table-row->{maj,min,dir} : assoc-table-row -> {num,num,path}
; retrieve the {major version, minor version, directory} of the given row
(define assoc-table-row->maj car)
(define assoc-table-row->min cadr)
(define assoc-table-row->dir caddr)
; get-best-match/t : assoc-table FULL-PKG-SPEC -> PKG | #f
(define (get-best-match/t table spec)
(let* ((target-maj
(or (pkg-spec-maj spec)
(apply max (map assoc-table-row->maj table))))
(maj-matches (filter (λ (x) (equal? target-maj (assoc-table-row->maj x))) table))
(in-min-range
(let ((lo (pkg-spec-minor-lo spec))
(hi (pkg-spec-minor-hi spec)))
(filter
(λ (x)
(let ((n (assoc-table-row->min x)))
(or (not lo) (>= n lo))
(or (not hi) (<= n hi))))
maj-matches))))
(if (null? in-min-range)
#f
(let ((best-row
(car
(quicksort
in-min-range
(λ (a b) (> (assoc-table-row->min a) (assoc-table-row->min b)))))))
(make-pkg
(pkg-spec-name spec)
(pkg-spec-path spec)
(assoc-table-row->maj best-row)
(assoc-table-row->min best-row)
(assoc-table-row->dir best-row))))))
; get-best-match : FULL-PKG-SPEC (listof string[directory-name]) -> PKG | #f
; gets the best version in the given subdirectory in the specified low and high version range
; or #f if there is no appropriate version
(define (get-best-match pkg-spec path)
@ -222,9 +308,7 @@ Various common pieces of code that both the client and server need to access
(hash-table-put! ht key (cons i (hash-table-get ht key (lambda () '()))))))
l)
(hash-table-map ht cons)))
(define (drop-last l) (reverse (cdr (reverse l))))
;; note: this can be done faster by reading a copy-port'ed port with

9
collects/planet/resolver.ss
View File

@ -38,8 +38,11 @@ provided, the default package is assumed.
2. PLaneT protocol
PLaneT clients communicate request PLaneT servers over a TCP connection using a specialized
protocol. The protocol is described below.
PLaneT clients support two protocols for communicating with the PLaneT server: the standard HTTP
GET/response system (currently the default) and a specialized TCP-based protocol that may become
more important if PLaneT becomes smarter about downloading packages behind the scenes.
In the following sections we describe the specialized protocol only.
2.1 Overview
@ -269,7 +272,7 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
; get-package-from-cache : FULL-PKG-SPEC -> PKG | #f
(define (get-package-from-cache pkg-spec)
(lookup-package pkg-spec (CACHE-DIR)))
(lookup-package pkg-spec))
; ==========================================================================================
; PHASE 3: SERVER RETRIEVAL