848 lines
34 KiB
Racket
848 lines
34 KiB
Racket
#lang racket/base
|
|
|
|
(require "config.rkt"
|
|
"planet-archives.rkt"
|
|
|
|
"private/planet-shared.rkt"
|
|
"private/linkage.rkt"
|
|
|
|
"resolver.rkt"
|
|
net/url
|
|
xml/xml
|
|
|
|
mzlib/file
|
|
mzlib/list
|
|
mzlib/etc
|
|
|
|
racket/contract
|
|
racket/port
|
|
racket/path
|
|
racket/class
|
|
racket/match
|
|
|
|
setup/pack
|
|
setup/plt-single-installer
|
|
setup/getinfo
|
|
setup/unpack
|
|
|
|
(for-syntax racket/base)
|
|
(prefix-in srfi1: srfi/1)
|
|
)
|
|
|
|
#| The util collection provides a number of useful functions for interacting with the PLaneT system. |#
|
|
|
|
(provide
|
|
|
|
current-cache-contents
|
|
current-linkage
|
|
make-planet-archive
|
|
unpack-planet-archive
|
|
force-package-building?
|
|
build-scribble-docs?
|
|
get-installed-planet-archives
|
|
get-hard-linked-packages
|
|
unlink-all
|
|
lookup-package-by-keys
|
|
resolve-planet-path
|
|
display-plt-file-structure
|
|
display-plt-archived-file
|
|
get-package-from-cache
|
|
pkg->download-url
|
|
exn:fail:planet?
|
|
make-exn:fail:planet
|
|
pkg-spec?)
|
|
|
|
(provide/contract
|
|
[get-package-spec
|
|
(->* (string? string?) (natural-number/c any/c) pkg-spec?)]
|
|
[download-package
|
|
(-> pkg-spec?
|
|
(or/c string?
|
|
(list/c #t path? natural-number/c natural-number/c)
|
|
(list/c #f string?)))]
|
|
[download/install-pkg
|
|
(-> string? string? natural-number/c any/c (or/c pkg? #f))]
|
|
[install-pkg
|
|
(-> pkg-spec? string? natural-number/c any/c (or/c pkg? #f))]
|
|
[add-hard-link
|
|
(-> string? string? natural-number/c natural-number/c path? void?)]
|
|
[remove-hard-link
|
|
(-> string? string? natural-number/c natural-number/c void?)]
|
|
[remove-pkg
|
|
(-> string? string? natural-number/c natural-number/c void?)]
|
|
[erase-pkg
|
|
(-> string? string? natural-number/c natural-number/c void?)])
|
|
|
|
|
|
;; get-package-spec : string string [nat | #f] [min-ver-spec | #f] -> pkg?
|
|
;; gets the package that corresponds to the given arguments, which are
|
|
;; values corresponding to the four parts of a package specifier in require syntax
|
|
(define (get-package-spec owner pkg [maj #f] [min #f])
|
|
(define arg
|
|
(cond
|
|
[(not maj) (list owner pkg)]
|
|
[(not min) (list owner pkg maj)]
|
|
[else (list owner pkg maj min)]))
|
|
(pkg-spec->full-pkg-spec arg #f))
|
|
|
|
;; download/install-pkg : string string nat nat -> pkg | #f
|
|
(define (download/install-pkg owner name maj min)
|
|
(let* ([pspec (pkg-spec->full-pkg-spec (list owner name maj min) #f)]
|
|
[upkg (get-package-from-server pspec)])
|
|
(cond
|
|
[(uninstalled-pkg? upkg)
|
|
(pkg-promise->pkg upkg)]
|
|
[else #f])))
|
|
|
|
;; current-cache-contents : -> ((string ((string ((nat (nat ...)) ...)) ...)) ...)
|
|
;; returns the packages installed in the local PLaneT cache
|
|
(define (current-cache-contents)
|
|
(cdr (tree->list (repository-tree))))
|
|
|
|
;; just so it will be provided
|
|
(define unlink-all remove-all-linkage!)
|
|
|
|
;; to remove:
|
|
;; -- setup-plt -c the package
|
|
;; -- remove relevant infodomain cache entries
|
|
;; -- delete files from cache directory
|
|
;; -- remove any existing linkage for package
|
|
;; returns void if the removal worked; raises an exception if no package existed.
|
|
|
|
(define (remove-pkg owner name maj min)
|
|
(let ((p (get-installed-package owner name maj min)))
|
|
(unless p
|
|
(raise (make-exn:fail:planet "Could not find package" (current-continuation-marks))))
|
|
(unless (normally-installed-pkg? p)
|
|
(raise (make-exn:fail:planet "Not a normally-installed package, can't remove" (current-continuation-marks))))
|
|
|
|
(let ((path (pkg-path p)))
|
|
(with-logging
|
|
(LOG-FILE)
|
|
(lambda ()
|
|
(printf "\n============= Removing ~a =============\n" (list owner name maj min))
|
|
(clean-planet-package path (list owner name '() maj min))))
|
|
(planet-log "Erasing metadata")
|
|
(erase-metadata p)
|
|
(planet-log "Deleting files in ~a" (path->string path))
|
|
(delete-directory/files path)
|
|
(planet-log "Trimming empty directories")
|
|
(trim-directory (CACHE-DIR) path)
|
|
(planet-log "Rebuilding documentation index")
|
|
(reindex-user-documentation)
|
|
(void))))
|
|
|
|
;; erase-metadata : pkg -> void
|
|
;; clears out any references to the given package in planet's metadata files
|
|
;; (i.e., linkage and info.rkt cache; not hard links which are not considered metadata)
|
|
(define (erase-metadata p)
|
|
(remove-infodomain-entries (pkg-path p))
|
|
(remove-linkage-to! p))
|
|
|
|
;; this really should go somewhere else. But what should setup's behavior be
|
|
;; when a package is cleaned? should it clear info-domain entries out? I think
|
|
;; no; an uncompiled package isn't necessarily not to be indexed and so on.
|
|
;; remove-infodomain-entries : path -> void
|
|
(define (remove-infodomain-entries path)
|
|
(let* ([pathbytes (path->bytes path)]
|
|
[cache-file (build-path (PLANET-DIR) "cache.rktd")])
|
|
(when (file-exists? cache-file)
|
|
(let ([cache-lines (with-input-from-file cache-file read)])
|
|
(call-with-output-file cache-file
|
|
(λ (op)
|
|
(if (pair? cache-lines)
|
|
(write (filter
|
|
(λ (line)
|
|
(not
|
|
(and
|
|
(pair? line)
|
|
(or (not (directory-exists? (bytes->path (car line))))
|
|
(subpath? path (bytes->path (car line)))))))
|
|
cache-lines)
|
|
op)
|
|
(fprintf op "\n")))
|
|
#:exists 'truncate/replace)))))
|
|
|
|
;; subpath? : path path -> boolean
|
|
;; determines if p1 is a subpath of p2.
|
|
(define (subpath? p1 p2)
|
|
(let ([full-p1 (explode-path (simple-form-path p1))]
|
|
[full-p2 (explode-path (simple-form-path p2))])
|
|
(sublist? full-p1 full-p2 (o2 bytes=? path->bytes))))
|
|
|
|
;; o2 : (X X -> Y) (Z -> X) -> (Z Z -> Y)
|
|
;; "compose-two"
|
|
(define (o2 a b) (λ (x y) (a (b x) (b y))))
|
|
|
|
;; sublist? : (listof X) (listof X) (X X -> boolean) -> boolean
|
|
;; determine if l1 is a sublist of l2, using = as the comparison operator for elements
|
|
(define (sublist? l1 l2 =)
|
|
(cond
|
|
[(null? l1) #t]
|
|
[(null? l2) #f]
|
|
[(= (car l1) (car l2)) (sublist? (cdr l1) (cdr l2) =)]
|
|
[else #f]))
|
|
|
|
(define (erase-pkg owner name maj min)
|
|
(let* ([uninstalled-pkg-dir
|
|
(build-path (UNINSTALLED-PACKAGE-CACHE) owner name (number->string maj) (number->string min))]
|
|
[uninstalled-pkg-file (build-path uninstalled-pkg-dir name)]
|
|
[uninstalled-file-exists? (file-exists? uninstalled-pkg-file)])
|
|
(when uninstalled-file-exists?
|
|
(delete-file uninstalled-pkg-file)
|
|
(trim-directory (UNINSTALLED-PACKAGE-CACHE) uninstalled-pkg-dir))
|
|
(with-handlers ([exn:fail:planet?
|
|
(λ (e) (if uninstalled-file-exists?
|
|
;; not really a failure, just return
|
|
(void)
|
|
(raise e)))])
|
|
(remove-pkg owner name maj min))))
|
|
|
|
;; listof X * listof X -> nonempty listof X
|
|
;; returns de-prefixed version of l2 if l1 is a proper prefix of l2;
|
|
;; signals an error otherwise.
|
|
(define (drop-common-base list1 list2)
|
|
(let loop ((l1 list1) (l2 list2))
|
|
(cond
|
|
[(null? l2)
|
|
(error 'drop-common-base "root ~s is not a prefix of stem ~s" list1 list2)]
|
|
[(null? l1) l2]
|
|
[(not (equal? (car l1) (car l2)))
|
|
(error 'drop-common-base "root ~s is not a prefix of stem ~s" list1 list2)]
|
|
[else (loop (cdr l1) (cdr l2))])))
|
|
|
|
;; pathify-list : path (listof path) -> listof path
|
|
;; given a base and a list of names, interprets each name as a subdirectory
|
|
;; of the previous, starting with base, and returns a list. (This list
|
|
;; is in reverse order, so the deepest subdirectory is returned first)
|
|
(define (pathify-list root dirs)
|
|
(let loop ((base root) (dirs dirs) (acc '()))
|
|
(cond
|
|
[(null? dirs) acc]
|
|
[else
|
|
(let ((new (build-path base (car dirs))))
|
|
(loop new (cdr dirs) (cons new acc)))])))
|
|
|
|
;; directory-empty? path -> bool
|
|
;; #t iff the given directory contains no subdirectories of files
|
|
(define (directory-empty? dir)
|
|
(null? (directory-list dir)))
|
|
|
|
;; trim-directory: path path -> void
|
|
;; deletes empty directories starting with stem and working down to root
|
|
(define (trim-directory root stem)
|
|
(let* ([rootl (explode-path root)]
|
|
[steml (explode-path stem)]
|
|
[extras (cdr (pathify-list root (drop-common-base rootl steml)))])
|
|
(let loop ((dirs extras))
|
|
(cond
|
|
[(null? dirs) (void)]
|
|
[(directory-empty? (car dirs))
|
|
(delete-directory (car dirs))
|
|
(loop (cdr dirs))]
|
|
[else (void)]))))
|
|
|
|
;; current-linkage : -> ((symbol (package-name nat nat) ...) ...)
|
|
;; gives the current "linkage table"; a table that links modules to particular versions
|
|
;; of planet requires that satisfy those linkages
|
|
(define (current-linkage)
|
|
(let* ((links
|
|
(if (file-exists? (LINKAGE-FILE))
|
|
(with-input-from-file (LINKAGE-FILE) read-all)
|
|
'()))
|
|
(buckets (categorize caar links)))
|
|
(map
|
|
(lambda (x) (cons (car x) (map (lambda (y) (drop-last (cadr y))) (cdr x))))
|
|
buckets)))
|
|
|
|
;; regexp->filter : (string | regexp) -> (path -> bool)
|
|
;; computes a filter that accepts paths that match the given regexps and rejects other paths
|
|
(define (regexp->filter re-s)
|
|
(let ([re (cond
|
|
[(string? re-s) (regexp re-s)]
|
|
[(regexp? re-s) re-s]
|
|
[else (error 'regexp->filter "not a regular expression")])])
|
|
(lambda (p) (regexp-match re (path->bytes p)))))
|
|
|
|
(define force-package-building? (make-parameter #f))
|
|
(define build-scribble-docs? (make-parameter #t))
|
|
|
|
;; ---
|
|
;; documentation stuff --- loaded on demand so that setup/scribble can be
|
|
;; omitted in the Racket distribution
|
|
(define-namespace-anchor anchor)
|
|
|
|
;; render : path[fully-expanded scribble file path] path[fully expanded directory] boolean? -> xref?
|
|
;; renders the given scribble doc file (in src dir) into the directory
|
|
;; dir as a real scribble document
|
|
(define (render src-file dest-dir multi-page?)
|
|
(parameterize ([current-namespace (namespace-anchor->empty-namespace anchor)])
|
|
(make-directory* dest-dir)
|
|
(let* ([index-dir (if multi-page?
|
|
(let-values ([(base name dir?) (split-path dest-dir)]) base)
|
|
dest-dir)]
|
|
[renderer (new ((if multi-page?
|
|
(dynamic-require 'scribble/html-render 'render-multi-mixin)
|
|
values)
|
|
((dynamic-require 'scribble/html-render 'render-mixin)
|
|
(dynamic-require 'scribble/base-render 'render%)))
|
|
[dest-dir index-dir]
|
|
[root-path dest-dir])]
|
|
[doc (dynamic-require `(file ,(path->string src-file)) 'doc)]
|
|
[fp (send renderer traverse (list doc) (list dest-dir))]
|
|
[ci (send renderer collect (list doc) (list dest-dir) fp)]
|
|
[xref ((dynamic-require 'setup/xref 'load-collections-xref))]
|
|
[_ ((dynamic-require 'scribble/xref 'xref-transfer-info) renderer ci xref)]
|
|
[ri (send renderer resolve (list doc) (list dest-dir) ci)])
|
|
(send renderer set-external-tag-path
|
|
"/servlets/doc-search.rkt")
|
|
(send renderer render
|
|
(list doc)
|
|
(list (if multi-page?
|
|
dest-dir
|
|
(build-path dest-dir "index.html")))
|
|
ri)
|
|
;; return cross-reference info:
|
|
(send renderer serialize-info ri))))
|
|
|
|
;; this MUST BE a syntactic directory (with the trailing slash)
|
|
;; or the scribble renderer gets very confused
|
|
(define SCRIBBLE-DOCUMENT-DIR "planet-docs/")
|
|
|
|
;; scribble-entry? : Any -> Boolean
|
|
;; Recognizes valid list entries in info.rkt's scribblings field.
|
|
(define scribble-entry?
|
|
(match-lambda
|
|
[(or (list (? string?))
|
|
(list (? string?) (? scribble-flags?))
|
|
(list (? string?) (? scribble-flags?) (? scribble-category?))
|
|
(list (? string?) (? scribble-flags?) (? scribble-category?) (? string?)))
|
|
#t]
|
|
[_ #f]))
|
|
|
|
;; scribble-flags? : Any -> Boolean
|
|
;; Recognizes a list of flags from an info.rkt scribblings entry.
|
|
(define scribble-flags?
|
|
(match-lambda
|
|
[(list (? symbol?) ...) #t]
|
|
[_ #f]))
|
|
|
|
;; scribble-category : Any -> Boolean
|
|
;; Recognizes a category descriptor from an info.rkt scribblings entry.
|
|
(define scribble-category?
|
|
(match-lambda
|
|
[(or (list (? symbol?))
|
|
(list (? symbol?) (? real?))) #t]
|
|
[_ #f]))
|
|
|
|
;; scribble-entry-file : ScribbleEntry -> String
|
|
;; Produces the filename of an info.rkt scribblings entry.
|
|
(define scribble-entry-file
|
|
(match-lambda [(list file _ ...) file]))
|
|
|
|
;; scribble-entry-flags : ScribbleEntry -> (Listof Symbol)
|
|
;; Produces the list of flags from an info.rkt scribblings entry.
|
|
(define scribble-entry-flags
|
|
(match-lambda
|
|
[(list _) null]
|
|
[(list _ flags _ ...) flags]))
|
|
|
|
;; make-planet-archive: path<directory> [path<file>] -> path<file>
|
|
;; Makes a .plt archive file suitable for PLaneT whose contents are
|
|
;; all files in the given directory and returns that file's name.
|
|
;; If the optional filename argument is provided, that filename will
|
|
;; be used as the output file's name.
|
|
(define make-planet-archive
|
|
(case-lambda
|
|
[(dir)
|
|
(let-values ([(path name must-be-dir?) (split-path dir)])
|
|
(make-planet-archive
|
|
dir
|
|
(build-path (current-directory)
|
|
(string-append (path->string name) ".plt"))))]
|
|
[(dir archive-name)
|
|
(let ([abs-dir (simple-form-path dir)])
|
|
(parameterize ((current-directory abs-dir))
|
|
(let ([announcements '()]
|
|
[warnings '()]
|
|
[critical-errors '()])
|
|
|
|
(define info.rkt
|
|
(let ([real-info
|
|
(check-info.rkt-sanity
|
|
dir
|
|
(λ (msg . args) (set! announcements (cons (apply format msg args) announcements)))
|
|
(λ (bad) (set! warnings (cons bad warnings)))
|
|
(λ (err) (set! critical-errors (cons err critical-errors))))])
|
|
(or real-info (λ (x [y (λ () (error 'info.rkt (format "undefined field: ~a" x)))]) (y)))))
|
|
|
|
(let ([scribble-files (info.rkt 'scribblings (λ () '()))])
|
|
|
|
(define (outdir file-str)
|
|
(let* ([filename (file-name-from-path file-str)]
|
|
[pathname (regexp-match #rx"(.*)\\.scrbl$" (path->bytes filename))])
|
|
(build-path SCRIBBLE-DOCUMENT-DIR (bytes->path (cadr pathname)))))
|
|
|
|
(when (and (build-scribble-docs?)
|
|
(file-exists? (build-path (collection-path "setup") "scribble.rkt")))
|
|
(with-handlers ([exn:fail?
|
|
(lambda (e)
|
|
(set! critical-errors
|
|
(cons (format "Error generating scribble documentation: ~a" (render-exn e))
|
|
critical-errors)))])
|
|
(unless (list? scribble-files)
|
|
(error (format "malformed scribblings field; expected (listof (list string (listof symbol))), received ~e"
|
|
scribble-files)))
|
|
(for ([entry scribble-files])
|
|
(unless (scribble-entry? entry)
|
|
(error "malformed scribblings entry"))
|
|
(let* ([filename (scribble-entry-file entry)]
|
|
[flags (scribble-entry-flags entry)])
|
|
(unless (and (relative-path? filename)
|
|
(subpath? abs-dir filename)
|
|
(bytes=? (filename-extension filename) #"scrbl"))
|
|
(error "illegal scribblings file ~a (must be a file with extension .scrbl in the package directory or a subdirectory"))
|
|
(unless (file-exists? (build-path abs-dir filename))
|
|
(error (format "scribblings file ~a not found" filename)))
|
|
(printf "Building: ~a\n" filename)
|
|
(let* ([name.scrbl (file-name-from-path filename)]
|
|
[name (path-replace-suffix name.scrbl #"")])
|
|
(render (build-path filename)
|
|
(build-path SCRIBBLE-DOCUMENT-DIR name)
|
|
(memq 'multi-page flags))))))))
|
|
|
|
(unless
|
|
(or (null? critical-errors)
|
|
(force-package-building?))
|
|
(error '|PLaneT packager| "~a\nRefusing to continue packaging." (car critical-errors)))
|
|
|
|
(pack archive-name
|
|
"archive"
|
|
(list ".")
|
|
null
|
|
(if (PLANET-ARCHIVE-FILTER)
|
|
(regexp->filter (PLANET-ARCHIVE-FILTER))
|
|
std-filter)
|
|
#t
|
|
'file
|
|
#f
|
|
#f)
|
|
|
|
(for-each display (reverse announcements))
|
|
(newline)
|
|
(for-each
|
|
(λ (s) (fprintf (current-error-port) "WARNING:\n\t~a\n" s))
|
|
(reverse warnings))))
|
|
|
|
(simple-form-path archive-name))]))
|
|
|
|
(define (unpack-planet-archive plt-file target)
|
|
(parameterize ([current-directory target])
|
|
(unpack plt-file)))
|
|
|
|
(define (location->path loc)
|
|
(match loc
|
|
['same (build-path 'same)]
|
|
[(list 'same path) path]
|
|
[(list other _) (error (format "bad location ~a (illegal in PLaneT packages)" other))]
|
|
[other (error (format "bad location ~a" other))]))
|
|
|
|
(define (foreach-planet-archive plt-file on-dir on-file)
|
|
(fold-plt-archive plt-file
|
|
void
|
|
void
|
|
(λ (l _) (on-dir (location->path l)))
|
|
(λ (l fip _) (on-file (location->path l) fip))
|
|
(void)))
|
|
|
|
;; hash-tree ::= (hash-table [string -o> (union string hash-tree)])
|
|
|
|
;; chop-path : path -> (listof (union path symbol))
|
|
;; fully chops up the given path into directory list, without
|
|
;; accessing the filesystem
|
|
(define (chop-path path)
|
|
(let loop ([p path] [acc '()])
|
|
(cond
|
|
[(not (path? p)) acc]
|
|
[else
|
|
(let-values ([(base name _) (split-path p)])
|
|
(loop base (cons name acc)))])))
|
|
|
|
;; ============================================================
|
|
;; hash trees
|
|
|
|
(define (new-hash-tree)
|
|
(make-hash))
|
|
|
|
(define (hash-tree-get htree pth)
|
|
(let loop ([pth pth]
|
|
[htree htree]
|
|
[route '()])
|
|
(cond
|
|
[(null? pth) htree]
|
|
[(not (hash? htree))
|
|
(error (format "subpath ~s maps to a value" (reverse route)))]
|
|
[else
|
|
(let* ([head (car pth)]
|
|
[next (hash-ref htree
|
|
head
|
|
(λ ()
|
|
(let ([extension (new-hash-tree)])
|
|
(hash-set! htree head extension)
|
|
extension)))])
|
|
(loop (cdr pth) next (cons (car pth) route)))])))
|
|
|
|
(define (hash-tree-put-value htree pth val)
|
|
(let-values ([(where key) (split-last pth)])
|
|
(let ([ht (hash-tree-get htree where)])
|
|
(unless (hash? ht)
|
|
(error "subpath ~s maps to a value" where))
|
|
(hash-set! ht key val))))
|
|
|
|
(define (split-last l)
|
|
(let loop ([l l]
|
|
[front '()])
|
|
(cond
|
|
[(null? (cdr l)) (values (reverse front) (car l))]
|
|
[else
|
|
(loop (cdr l)
|
|
(cons (car l) front))])))
|
|
|
|
(define (hash-tree->list ht)
|
|
(let ([lst (hash-map ht
|
|
(λ (k v)
|
|
(cons k
|
|
(if (hash? v)
|
|
(hash-tree->list v)
|
|
(list v)))))])
|
|
(sort lst (λ (a b) (string<? (car a) (car b))))))
|
|
|
|
;; a 'a treelist is ::= (list string 'a) | (list string ('a treelist) ...)
|
|
|
|
;; ============================================================
|
|
|
|
;; print out file treelists (treelists where 'file is the only non-structure
|
|
;; element)
|
|
(define (print-tree t depth)
|
|
(cond
|
|
[(and (not (null? (cdr t)))
|
|
(not (pair? (cadr t))))
|
|
(printf "~a~a\n" (padding depth) (car t))]
|
|
[else
|
|
(printf "~a~a:\n" (padding depth) (car t))
|
|
(print-tree-list (cdr t) (add1 depth))]))
|
|
|
|
(define (print-tree-list ts depth)
|
|
(for-each (λ (t) (print-tree t depth)) ts))
|
|
|
|
(define (padding n)
|
|
(apply string-append (build-list n (λ (_) " "))))
|
|
|
|
;; list-plt-file-contents : path-string[.plt-file] -> void
|
|
;; prints out a manifest of the given plt file
|
|
(define (display-plt-file-structure plt-file)
|
|
|
|
(define root (new-hash-tree))
|
|
|
|
(define (gen-put f)
|
|
(λ (path) (f (chop-path (simplify-path path #f)))))
|
|
|
|
(define put-directory
|
|
(gen-put
|
|
(λ (ps)
|
|
(cond
|
|
[(equal? ps '(same)) (void)]
|
|
[else (hash-tree-get root (map path->string ps))]))))
|
|
|
|
(define put-file
|
|
(gen-put
|
|
(λ (ps)
|
|
(hash-tree-put-value root (map path->string ps) 'file))))
|
|
|
|
(foreach-planet-archive
|
|
plt-file
|
|
put-directory
|
|
(λ (p _) (put-file p)))
|
|
|
|
(print-tree-list (hash-tree->list root) 0))
|
|
|
|
;; display-plt-archived-file : path-string[.plt-file] string -> void
|
|
(define (display-plt-archived-file plt-file file-to-print)
|
|
(let/ec finished
|
|
(let ([target (simplify-path file-to-print #f)])
|
|
(foreach-planet-archive
|
|
plt-file
|
|
void
|
|
(λ (path fip)
|
|
(when (equal? (simplify-path path #f) target)
|
|
(copy-port fip (current-output-port))
|
|
(finished (void))))))
|
|
(error 'display-archived-plt-file "The given file was not found in the given package")))
|
|
|
|
;; check-info.rkt-sanity : path (string -> void) (string -> void) (string -> void) -> info.rkt-fn | #f
|
|
;; gets all the info.rkt fields that planet will use (using the info.rkt file
|
|
;; from the current directory) and calls the announce, warn, and fail functions with strings
|
|
;; that describe how PLaneT sees the info.rkt file. NOTA BENE: if this function calls fail, it may
|
|
;; also warn on the same field, and the warning may not make sense. This is based on the
|
|
;; assumption that errors will be turned into some kind of critical failure that obliterates
|
|
;; all the other information produced.
|
|
(define (check-info.rkt-sanity dir announce warn fail)
|
|
(with-handlers ([exn:fail:read?
|
|
(λ (e)
|
|
(fail (format "Package has an unreadable info.rkt file. ~a" (render-exn e)))
|
|
#f)]
|
|
[exn:fail:syntax?
|
|
(λ (e)
|
|
(fail (format "Package's info.rkt has an syntactically ill-formed info.rkt file: ~a" (render-exn e)))
|
|
#f)])
|
|
(let ([i* (get-info/full dir)])
|
|
(cond
|
|
[(not i*)
|
|
(warn "Package has no info.rkt file. This means it will not have a description or documentation on the PLaneT web site.")]
|
|
[else
|
|
(let ([i (λ (field) (i* field (λ () #f)))])
|
|
(checkinfo i fail
|
|
[name ; field name
|
|
string? ; check
|
|
(announce "Name: ~a\n" name) ; success action
|
|
(warn "Package's info.rkt file has no name field.") ;failure action
|
|
]
|
|
[blurb
|
|
(λ (b) (and (list? b) (andmap xexpr? b)))
|
|
(announce "Package blurb: ~s\n" blurb)
|
|
(unless blurb
|
|
(warn "Package's info.rkt does not contain a blurb field. Without a blurb field, the package will have no description on planet.racket-lang.org."))]
|
|
[release-notes
|
|
(λ (b) (and (list? b) (andmap xexpr? b)))
|
|
(announce "Release notes: ~s\n" release-notes)
|
|
(unless release-notes
|
|
(warn "Package's info.rkt does not contain a release-notes field. Without a release-notes field, the package will not have any listed release information on planet.racket-lang.org beyond the contents of the blurb field."))]
|
|
[categories
|
|
(λ (s) (and (list? s) (andmap symbol? s)))
|
|
(cond
|
|
[(ormap illegal-category categories)
|
|
=>
|
|
(λ (bad-cat)
|
|
(fail (format "Package's info.rkt file contains illegal category \"~a\". The legal categories are: ~a\n"
|
|
bad-cat
|
|
legal-categories)))]
|
|
[else (announce "Categories: ~a\n" categories)])
|
|
(unless categories
|
|
(warn "Package's info.rkt file does not contain a category listing. It will be placed in the Miscellaneous category."))]
|
|
[doc.txt
|
|
string?
|
|
(announce "doc.txt file: ~a\n" doc.txt)
|
|
(when doc.txt
|
|
(warn "Package's info.rkt contains a doc.txt entry, which is now considered deprecated. The preferred method of documentation for PLaneT packages is now Scribble (see the Scribble documentation included in the Racket distribution for more information)."))]
|
|
[html-docs
|
|
(lambda (s) (and (list? s) (andmap string? s)))
|
|
(warn "Package specifies an html-docs entry. The preferred method of documentation for PLaneT packages is now Scribble (see the Scribble documentation included in the Racket distribution for more information).")]
|
|
[scribblings
|
|
(lambda (s)
|
|
(and (list? s)
|
|
(andmap scribble-entry? s)))
|
|
(void)
|
|
(unless scribblings
|
|
(warn "Package does not specify a scribblings field. Without a scribblings field, the package will not have browsable online documentation."))]
|
|
[homepage
|
|
string?
|
|
(cond
|
|
[(url-string? homepage)
|
|
(announce "Home page: ~a\n" homepage)]
|
|
[else
|
|
(fail (format "The value of the package's info.rkt homepage field, ~s, does not appear to be a legal URL." homepage))])]
|
|
[primary-file
|
|
(λ (x) (or (string? x) (and (list? x) (andmap string? x))))
|
|
(begin
|
|
(cond
|
|
[(string? primary-file)
|
|
(unless (file-in-current-directory? primary-file)
|
|
(warn (format "Package's info.rkt primary-file field is ~s, a file that does not exist in the package."
|
|
primary-file)))]
|
|
[(pair? primary-file)
|
|
(let ([bad-files (filter (λ (f) (not (file-in-current-directory? f))) primary-file)])
|
|
(unless (null? bad-files)
|
|
(warn (format "Package's info.rkt primary-file field is ~s, which contains non-existant files ~s."
|
|
primary-file bad-files))))])
|
|
(announce "Primary file: ~a\n" primary-file))
|
|
(unless primary-file
|
|
(warn "Package's info.rkt does not contain a primary-file field. The package's listing on planet.racket-lang.org will not have a valid require line for your package."))]
|
|
[required-core-version
|
|
core-version?
|
|
(announce "Required racket version: ~a\n" required-core-version)]
|
|
[repositories
|
|
(λ (x) (and (list? x)
|
|
(srfi1:lset<= equal? x '("3xx" "4.x"))))
|
|
(announce "Repositories: ~s\n" repositories)
|
|
(warn "Package's info.rkt does not contain a repositories field. The package will be listed in all repositories by default.")]
|
|
[version
|
|
string?
|
|
(announce "Version description: ~a\n" version)]))])
|
|
i*)))
|
|
|
|
|
|
(define (render-exn e)
|
|
(let ([sp (open-output-string)])
|
|
(parameterize ([current-output-port sp]
|
|
[current-error-port sp])
|
|
((error-display-handler) (exn-message e) e))
|
|
(get-output-string sp)))
|
|
|
|
;; legal-categories : (listof symbol)
|
|
(define legal-categories
|
|
'(devtools net media xml datastructures io scientific
|
|
system ui metaprogramming planet misc))
|
|
|
|
;; legal-category : symbol -> boolean
|
|
;; determine if the given symbol is a legal category
|
|
(define (legal-category? x) (memq x legal-categories))
|
|
|
|
;; illegal-category : symbol -> (union symbol false)
|
|
;; returns #f if the symbol is a legal category, or the symbol itself if it isn't
|
|
(define (illegal-category s) (if (legal-category? s) #f s))
|
|
|
|
;; url-string? : string -> boolean
|
|
;; determines if the given string is a reasonable homepage url
|
|
(define (url-string? s)
|
|
(and (string? s)
|
|
(let ([u (string->url s)])
|
|
(and (url-scheme u)
|
|
(url-host u)))))
|
|
|
|
;; file-in-current-directory? : string -> boolean
|
|
;; determines if the given string represents a file in the current directory
|
|
(define (file-in-current-directory? f)
|
|
(and (string? f) (file-exists? f)))
|
|
|
|
;; core-version : string -> boolean
|
|
;; determines if the given string is something that (version) could've produced
|
|
(define (core-version? s)
|
|
(and (string? s)
|
|
(string->mz-version s)))
|
|
|
|
;; checkinfo: syntax
|
|
;; given an info.rkt function, a failure function, and a bunch of fields to check,
|
|
;; goes through the checklist calling either the success or the failure branch
|
|
;; of each check as appropriate
|
|
(define-syntax checkinfo
|
|
(syntax-rules ()
|
|
[(checkinfo fn fail clauses ...)
|
|
(let ([fn* fn] [fail* fail])
|
|
(checkinfo* () fn* fail* clauses ...))]))
|
|
|
|
(define-syntax checkinfo*
|
|
(syntax-rules ()
|
|
[(checkinfo* () fn fail) (void)]
|
|
[(checkinfo* (handler1 handler ...) fn fail) (begin handler1 handler ...)]
|
|
[(checkinfo* (handler ...) fn fail [id check on-success] clauses ...)
|
|
(checkinfo* (handler ...) fn fail [id check on-success void] clauses ...)]
|
|
[(checkinfo* (handler ...) fn fail [id check on-success on-fail] clauses ...)
|
|
(checkinfo*
|
|
(handler ...
|
|
(let ([id (fn 'id)])
|
|
(cond
|
|
[id
|
|
(let ([checked (check id)])
|
|
(unless checked
|
|
on-fail
|
|
(fail (format "Package's info.rkt contained a malformed ~a field." 'id)))
|
|
on-success)]
|
|
[else on-fail])))
|
|
fn fail clauses ...)]))
|
|
|
|
;; ============================================================
|
|
;; HARD LINKS (aka development links)
|
|
|
|
;; add-hard-link : string string num num path -> void
|
|
;; adds an entry in the hard-links table associating the given
|
|
;; require spec to the given path
|
|
(define (add-hard-link owner pkg-name maj min path)
|
|
(unless (directory-exists? path)
|
|
(if (file-exists? path)
|
|
(error 'add-hard-link "Hard links must point to directories, not files")
|
|
(fprintf (current-error-port)
|
|
"Warning: directory ~a does not exist\n"
|
|
(path->string path))))
|
|
(add-hard-link! pkg-name (list owner) maj min path))
|
|
|
|
;; remove-hard-link : string string num num -> void
|
|
;; removes any development association from the given package spec
|
|
(define (remove-hard-link owner pkg-name maj min)
|
|
(filter-link-table!
|
|
(lambda (row)
|
|
(not (points-to? row pkg-name (list owner) maj min)))
|
|
(lambda (row)
|
|
(let ([p (row->package row)])
|
|
(when p
|
|
(erase-metadata p))))))
|
|
|
|
;; ============================================================
|
|
;; VERSION INFO
|
|
|
|
(provide this-package-version
|
|
this-package-version-name
|
|
this-package-version-owner
|
|
this-package-version-maj
|
|
this-package-version-min
|
|
(rename-out [this-package-version/proc path->package-version]))
|
|
|
|
(define-syntax (this-package-version stx)
|
|
(syntax-case stx ()
|
|
[(_)
|
|
#`(this-package-version/proc
|
|
#,(datum->syntax stx `(,#'this-expression-source-directory)))]))
|
|
|
|
(define-syntax define-getters
|
|
(syntax-rules ()
|
|
[(define-getters (name position) ...)
|
|
(begin
|
|
(define-syntax (name stx)
|
|
(syntax-case stx ()
|
|
[(name)
|
|
#`(let ([p #,(datum->syntax stx `(,#'this-package-version))])
|
|
(and p (position p)))]))
|
|
...)]))
|
|
|
|
(define-getters
|
|
(this-package-version-name pd->name)
|
|
(this-package-version-owner pd->owner)
|
|
(this-package-version-maj pd->maj)
|
|
(this-package-version-min pd->min))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (this-package-version/proc srcdir)
|
|
(let* ([package-roots (get-all-planet-packages)]
|
|
[thepkg (ormap (predicate->projection (contains-dir? srcdir))
|
|
package-roots)])
|
|
(and thepkg (archive-retval->simple-retval thepkg))))
|
|
|
|
;; predicate->projection : #f \not\in X ==> (X -> boolean) -> (X -> X)
|
|
(define (predicate->projection pred) (λ (x) (if (pred x) x #f)))
|
|
|
|
;; contains-dir? : path -> pkg -> boolean
|
|
(define ((contains-dir? srcdir) alleged-superdir-pkg)
|
|
(let* ([nsrcdir (simple-form-path srcdir)]
|
|
[nsuperdir (simple-form-path (car alleged-superdir-pkg))]
|
|
[nsrclist (explode-path nsrcdir)]
|
|
[nsuperlist (explode-path nsuperdir)])
|
|
(list-prefix? nsuperlist nsrclist)))
|
|
|
|
(define (list-prefix? sup sub)
|
|
(let loop ([sub sub]
|
|
[sup sup])
|
|
(cond
|
|
[(null? sup) #t]
|
|
[(equal? (car sup) (car sub))
|
|
(loop (cdr sub) (cdr sup))]
|
|
[else #f])))
|
|
|
|
(define (archive-retval->simple-retval p)
|
|
(list-refs p '(1 2 4 5)))
|
|
|
|
(define-values (pd->owner pd->name pd->maj pd->min)
|
|
(apply values (map (λ (n) (λ (l) (list-ref l n))) '(0 1 2 3))))
|
|
|
|
(define (list-refs p ns)
|
|
(map (λ (n) (list-ref p n)) ns))
|