327 lines
13 KiB
Scheme
327 lines
13 KiB
Scheme
#| 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"))
|
|
|
|
(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
|
|
; Handles checking the cache for an appropriate module
|
|
; ==========================================================================================
|
|
|
|
; language-version->repository : string -> string | #f
|
|
; 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"]
|
|
[else #f]))
|
|
|
|
(define (version->description ver)
|
|
(cond
|
|
[(string=? ver "207.1") "20x"]
|
|
[(string=? ver "300") "299.x-30x"]
|
|
[else (error 'version->description "Expected one of 207.1 and 300, got ~a" ver)]))
|
|
|
|
(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)))
|
|
|
|
; 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)
|
|
(let ((major-version (if (pkg-spec-maj pkg-spec)
|
|
(let ((specified-number (number->string (pkg-spec-maj pkg-spec))))
|
|
(if (directory-exists? (build-path path specified-number))
|
|
specified-number
|
|
#f))
|
|
(get-highest-numbered-subdir path #f #f))))
|
|
(if major-version
|
|
(let ((minor-version (get-highest-numbered-subdir
|
|
(build-path path major-version)
|
|
(pkg-spec-minor-lo pkg-spec)
|
|
(pkg-spec-minor-hi pkg-spec))))
|
|
(if minor-version
|
|
(make-pkg
|
|
(pkg-spec-name pkg-spec)
|
|
(pkg-spec-path pkg-spec)
|
|
(string->number major-version)
|
|
(string->number minor-version)
|
|
(build-path path major-version minor-version))
|
|
#f))
|
|
#f)))
|
|
|
|
; get-highest-numbered-subdir : string (Nat | #f) (Nat | #f) -> string[subdir] | #f
|
|
; given a path, returns the subdirectory of that path with the highest numeric name or #f if
|
|
; none exists. Does not return the full path.
|
|
(define (get-highest-numbered-subdir path lo hi)
|
|
(define (valid-dir? d)
|
|
(and
|
|
(directory-exists? (build-path path d))
|
|
(let ((n (string->number (path->string d))))
|
|
(and n
|
|
(or (not lo) (>= n lo))
|
|
(or (not hi) (<= n hi))))))
|
|
|
|
(unless (directory-exists? path)
|
|
(raise (make-exn:fail:filesystem
|
|
"Internal PLaneT error: inconsistent cache, directory does not exist"
|
|
(current-continuation-marks))))
|
|
(max-string (map path->string (filter valid-dir? (directory-list path)))))
|
|
|
|
; FULL-PKG-SPEC : (make-pkg-spec string (Nat | #f) (Nat | #f) (Nat | #f) (listof string) (syntax | #f))
|
|
(define-struct pkg-spec (name maj minor-lo minor-hi path stx) (make-inspector))
|
|
; PKG : string Nat Nat path
|
|
(define-struct pkg (name route maj min path))
|
|
|
|
; ==========================================================================================
|
|
; UTILITY
|
|
; Miscellaneous utility functions
|
|
; ==========================================================================================
|
|
|
|
; make-cutoff-port : input-port nat [nat -> tst] -> input-port
|
|
; makes a new input port that reads the first n characters from the given port, then
|
|
; returns eof. If n characters are not available from the given input port, calls
|
|
; the given function and then returns eof
|
|
(define make-cutoff-port
|
|
(opt-lambda (ip n [underflow-fn void])
|
|
(let ((to-read n))
|
|
(make-input-port
|
|
'cutoff-port
|
|
|
|
(lambda (bytestr)
|
|
(cond
|
|
[(= to-read 0) eof]
|
|
[else
|
|
(let ((bytes-read (read-bytes-avail! bytestr ip 0 (min n (bytes-length bytestr)))))
|
|
(if (eof-object? bytes-read)
|
|
(begin
|
|
(underflow-fn (- to-read bytes-read))
|
|
(set! to-read 0)
|
|
eof)
|
|
(begin
|
|
(set! to-read (- to-read bytes-read))
|
|
bytes-read)))]))
|
|
#f
|
|
void))))
|
|
|
|
; max-string : listof string[digits] -> string | #f
|
|
; this odd little guy takes a list of strings that represent a number and returns the string
|
|
; that represents the maximum number among them, or #f if there were no numbers at all
|
|
(define (max-string strs)
|
|
(if (null? strs)
|
|
#f
|
|
(let loop ((biggest (car strs))
|
|
(big-n (string->number (car strs)))
|
|
(rest (cdr strs)))
|
|
(cond
|
|
[(null? rest) biggest]
|
|
[else
|
|
(let* ([candidate (car rest)]
|
|
[test-n (string->number candidate)])
|
|
(if (> test-n big-n)
|
|
(loop candidate test-n (cdr rest))
|
|
(loop biggest big-n (cdr rest))))]))))
|
|
|
|
; write-line : X output-port -> void
|
|
; writes the given value followed by a newline to the given port
|
|
(define (write-line obj p)
|
|
(write obj p)
|
|
(newline p))
|
|
|
|
; for-each/n (X Nat -> Y) (listof X) -> void
|
|
; calls the input function on each element of the input list in order,
|
|
; also providing the element's zero-based index in the list
|
|
(define (for-each/n f l)
|
|
(let loop ((l l) (n 0))
|
|
(cond
|
|
[(null? l) (void)]
|
|
[else
|
|
(f (car l) n)
|
|
(loop (cdr l) (add1 n))])))
|
|
|
|
; nat? : TST -> bool
|
|
; determines if the given scheme value is a natural number
|
|
(define (nat? obj) (and (integer? obj) (>= obj 0)))
|
|
|
|
; read-n-chars-to-file : Nat input-port string[filename] -> void
|
|
; copies exactly n chars to the given file from the given port. Raises an exception
|
|
; if the given number of characters are not available.
|
|
(define (read-n-chars-to-file n ip file)
|
|
(let ((op (open-output-file file 'truncate)))
|
|
(copy-n-chars n ip op)
|
|
(close-output-port op)))
|
|
|
|
; copy-n-chars : Nat input-port output-port -> void
|
|
; copies exactly n characters from the input to the output. Raises an exception
|
|
; if this is not possible.
|
|
(define (copy-n-chars n ip op)
|
|
(let ((cport (make-cutoff-port ip
|
|
n
|
|
(lambda ()
|
|
(raise
|
|
(make-exn:fail:read:eof
|
|
(format "Not enough chars on input (expected ~a, got ~a)"
|
|
n
|
|
(- n 0))
|
|
(current-continuation-marks)
|
|
ip))))))
|
|
(copy-port cport op)))
|
|
|
|
; repeat-forever : (-> void) -> [diverges]
|
|
; repeatedly invokes the given thunk forever
|
|
(define (repeat-forever thunk) (let loop () (thunk) (loop)))
|
|
|
|
; build-hash-table : listof (list X Y) -> equal-hash-table[X -> Y]
|
|
; builds a new hash-table mapping all given X's to their appropriate Y values
|
|
(define (build-hash-table asl)
|
|
(let ((ht (make-hash-table 'equal)))
|
|
(for-each (lambda (item) (hash-table-put! ht (car item) (cadr item))) asl)
|
|
ht))
|
|
|
|
; categorize : (X -> Y) (listof X) -> (listof (cons Y (listof X)))
|
|
; sorts the l into categories given by f
|
|
(define (categorize f l)
|
|
(let ((ht (make-hash-table 'equal)))
|
|
(for-each
|
|
(lambda (i)
|
|
(let ((key (f i)))
|
|
(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
|
|
;; ( and ) tacked around it
|
|
(define read-all
|
|
(case-lambda
|
|
[() (read-all (current-input-port))]
|
|
[(ip)
|
|
(let ((sexpr (read ip)))
|
|
(cond
|
|
[(eof-object? sexpr) '()]
|
|
[else (cons sexpr (read-all ip))]))]))
|
|
|
|
(define (wrap x) (begin (write x) (newline) x))
|
|
|
|
(define (with-logging logfile f)
|
|
(let* ((null-out (open-output-nowhere))
|
|
(outport
|
|
(if logfile
|
|
(with-handlers ((exn:fail:filesystem? (lambda (e) null-out)))
|
|
(open-output-file logfile 'append))
|
|
null-out)))
|
|
(parameterize ([current-output-port outport])
|
|
(f))))
|
|
|
|
;; ============================================================
|
|
;; TREE STUFF
|
|
;; ============================================================
|
|
|
|
;; tree[X] ::= (make-branch X (listof tree[X])
|
|
(define-struct branch (node children) (make-inspector))
|
|
|
|
(define-struct (exn:fail:filesystem:no-directory exn:fail:filesystem) (dir))
|
|
|
|
;; directory->tree : directory (string -> bool) [nat | bool] [path->X] -> tree[X] | #f
|
|
(define directory->tree
|
|
(opt-lambda (directory valid-dir? [max-depth #f] [path->x path->string])
|
|
(unless (directory-exists? directory)
|
|
(raise (make-exn:fail:filesystem:no-directory
|
|
"Directory ~s does not exist"
|
|
(current-continuation-marks)
|
|
directory)))
|
|
(let-values ([(path name _) (split-path directory)])
|
|
(let* ((files (directory-list directory))
|
|
(files (map (lambda (d) (build-path directory d)) files))
|
|
(files (filter (lambda (d) (and (directory-exists? d) (valid-dir? d))) files)))
|
|
(make-branch
|
|
(path->x name)
|
|
;; NOTE: the above line should not use path->string. I don't have time to track this down though
|
|
(if (equal? max-depth 0)
|
|
'()
|
|
(let ((next-depth (if max-depth (sub1 max-depth) #f)))
|
|
(map (lambda (d) (directory->tree d valid-dir? next-depth)) files))))))))
|
|
|
|
;; filter-pattern : (listof pattern-term)
|
|
;; pattern-term : (x -> y) | (make-star (tst -> bool) (x -> y))
|
|
(define-struct star (pred fun))
|
|
|
|
;; filter-tree-by-pattern : tree[x] filter-pattern -> tree[y]
|
|
;; constraint: depth of the tree <= length of the list
|
|
;; converts the tree by applying to each depth the function at that position in the list
|
|
(define (filter-tree-by-pattern tree pattern)
|
|
(cond
|
|
[(null? pattern) (error 'filter-tree-by-pattern "Tree too deep: ~e" tree)]
|
|
[(star? (car pattern))
|
|
(if (star-pred (car pattern))
|
|
(make-branch
|
|
(star-fun (branch-node tree))
|
|
(map (lambda (x) (filter-tree-by-pattern x pattern))
|
|
(branch-children tree)))
|
|
(filter-tree-by-pattern tree (cdr pattern)))]
|
|
[else
|
|
(make-branch ((car pattern) (branch-node tree))
|
|
(map
|
|
(lambda (x) (filter-tree-by-pattern x (cdr pattern)))
|
|
(branch-children tree)))]))
|
|
|
|
;; sexp-tree[x] ::= (cons x (listof sexp-tree[x]))
|
|
|
|
;; tree-apply : (... -> tst) tree -> listof tst
|
|
;; applies f to every path from root to leaf and
|
|
;; accumulates all results in a list
|
|
(define tree-apply
|
|
(opt-lambda (f t [depth 0])
|
|
(let loop ((t t)
|
|
(priors '())
|
|
(curr-depth 0))
|
|
(cond
|
|
[(null? (branch-children t))
|
|
(if (> curr-depth depth)
|
|
(list (apply f (reverse (cons (branch-node t) priors))))
|
|
'())]
|
|
[else
|
|
(let ((args (cons (branch-node t) priors)))
|
|
(apply append
|
|
(map (lambda (x) (loop x args (add1 curr-depth))) (branch-children t))))]))))
|
|
|
|
;; tree->list : tree[x] -> sexp-tree[x]
|
|
(define (tree->list tree)
|
|
(cons (branch-node tree) (map tree->list (branch-children tree))))) |