213 lines
7.9 KiB
Racket
213 lines
7.9 KiB
Racket
#lang scheme/base
|
|
(require racket/file
|
|
racket/path
|
|
setup/dirs)
|
|
|
|
(provide links)
|
|
|
|
(define (links #:error [error error]
|
|
#:user? [user? #t]
|
|
#:file [in-file #f]
|
|
#:name [name #f]
|
|
#:version-regexp [version-regexp #f]
|
|
#:root? [root? #f]
|
|
#:remove? [remove? #f]
|
|
#:show? [show? #f]
|
|
#:repair? [repair? #f]
|
|
#:with-path? [with-path? #f]
|
|
. dirs)
|
|
(define (check-name name)
|
|
(unless (and (regexp-match #rx"^[a-zA-z0-9+_%-]+$" name)
|
|
(module-path? name))
|
|
(error 'links "name is not valid as a top-level collection name: ~e"
|
|
name)))
|
|
|
|
(when name
|
|
(check-name name))
|
|
|
|
(define file (or in-file
|
|
(if user?
|
|
(find-system-path 'links-file)
|
|
(let ([d (find-collects-dir)])
|
|
(if d
|
|
(build-path d "config" "links.rktd")
|
|
(error 'links
|
|
"cannot find installation collections path"))))))
|
|
|
|
(define need-repair? #f)
|
|
|
|
(define (content-error str v)
|
|
(if repair?
|
|
(begin
|
|
(log-warning (format "~a~e" str v))
|
|
(set! need-repair? #t)
|
|
#f)
|
|
(error 'links "~a~e" str v)))
|
|
|
|
(define table
|
|
(with-handlers ([exn:fail?
|
|
(lambda (exn)
|
|
(let ([msg (format
|
|
"error reading from link file: ~s: ~a"
|
|
file
|
|
(exn-message exn))])
|
|
(if repair?
|
|
(begin
|
|
(log-warning msg)
|
|
(set! need-repair? #t)
|
|
null)
|
|
(error 'links "~a" msg))))])
|
|
(if (file-exists? file)
|
|
(let ([l (with-input-from-file file read)])
|
|
(if (list? l)
|
|
(for/list ([e (in-list l)]
|
|
#:when
|
|
(or (and (list? e)
|
|
(or (= 2 (length e))
|
|
(= 3 (length e))))
|
|
(content-error "entry is a not a 2- or 3-element list: " e))
|
|
#:when
|
|
(or (or (string? (car e))
|
|
(eq? 'root (car e)))
|
|
(content-error "entry's first element is not a string or 'root: " e))
|
|
#:when
|
|
(or (path-string? (cadr e))
|
|
(content-error "entry's second element is not a path string: " e))
|
|
#:when
|
|
(or (null? (cddr e))
|
|
(regexp? (caddr e))
|
|
(content-error "entry's third element is not a version regexp: " e)))
|
|
e)
|
|
(begin
|
|
(content-error "content is not a list: " l)
|
|
null)))
|
|
null)))
|
|
|
|
(define mapped (make-hash))
|
|
|
|
(define (add-entry! e)
|
|
(hash-set! mapped
|
|
(car e)
|
|
(cons (cdr e) (hash-ref mapped (car e) null))))
|
|
|
|
|
|
(for ([e (in-list table)]) (add-entry! e))
|
|
|
|
(define file-dir (let-values ([(base name dir?)
|
|
(split-path (simplify-path
|
|
(path->complete-path file)))])
|
|
base))
|
|
|
|
(define (simplify p)
|
|
(simplify-path (path->complete-path p file-dir)))
|
|
|
|
(define new-table
|
|
(reverse
|
|
(for/fold ([table (reverse table)]) ([d (in-list
|
|
(if (and (null? dirs)
|
|
name)
|
|
'(#f)
|
|
dirs))])
|
|
(let* ([dp (and d
|
|
(find-relative-path file-dir
|
|
(simplify-path
|
|
(path->complete-path d))
|
|
#:more-than-root? #t))]
|
|
[a-name (if root?
|
|
'root
|
|
(and d
|
|
(or name
|
|
(let-values ([(base name dir?) (split-path dp)])
|
|
(path-element->string name)))))]
|
|
[rx version-regexp]
|
|
[d (and dp (path->string dp))]
|
|
[sd (and d (simplify d))])
|
|
(unless remove?
|
|
(unless (directory-exists? sd)
|
|
(error 'links
|
|
"no such directory for link: ~a"
|
|
sd)))
|
|
(if remove?
|
|
(filter (lambda (e)
|
|
(or (and d
|
|
(not (equal? (simplify (cadr e))
|
|
sd)))
|
|
(and name
|
|
(not (equal? (car e) name)))
|
|
(and root?
|
|
(not (eq? (car e) 'root)))
|
|
(and version-regexp
|
|
(pair? (cddr e))
|
|
(not (equal? (caddr e) version-regexp)))))
|
|
table)
|
|
(let ([l (hash-ref mapped a-name null)]
|
|
[e (list* a-name
|
|
d
|
|
(if rx (list rx) null))])
|
|
(if (member (cdr e) l)
|
|
table
|
|
(let ()
|
|
(when (string? a-name)
|
|
(check-name a-name))
|
|
(add-entry! e)
|
|
(cons e table)))))))))
|
|
|
|
(unless (and (not need-repair?)
|
|
(equal? new-table table))
|
|
(let ([dir (let-values ([(base name dir?) (split-path file)])
|
|
base)])
|
|
(make-directory* dir)
|
|
(let ([tmp (make-temporary-file "links~a.rktd"
|
|
#f
|
|
dir)])
|
|
(with-output-to-file tmp
|
|
#:exists 'truncate
|
|
(lambda ()
|
|
(printf "(")
|
|
(let loop ([l new-table] [prefix ""])
|
|
(cond
|
|
[(null? l) (printf ")\n")]
|
|
[else
|
|
(printf "~a~s" prefix (car l))
|
|
(unless (null? (cdr l)) (newline))
|
|
(loop (cdr l) " ")]))))
|
|
(with-handlers ([exn:fail? (lambda (exn)
|
|
(with-handlers ([exn:fail? void])
|
|
(delete-file tmp))
|
|
(raise exn))])
|
|
(rename-file-or-directory tmp file #t)))))
|
|
|
|
(when show?
|
|
(for ([e (in-list new-table)])
|
|
(printf " ~a~s path: ~s~a\n"
|
|
(if (eq? (car e) 'root)
|
|
""
|
|
"collection: ")
|
|
(car e)
|
|
(path->string (simplify (cadr e)))
|
|
(if (null? (cddr e))
|
|
""
|
|
(format " version: ~s"
|
|
(caddr e))))))
|
|
|
|
(if remove?
|
|
;; return list of removed entries:
|
|
(filter (lambda (e) (not (member e new-table))) table)
|
|
(if root?
|
|
;; Return root paths:
|
|
(for/list ([e (in-list new-table)]
|
|
#:when (eq? 'root (car e)))
|
|
(simplify (cadr e)))
|
|
;; Return list of collections mapped for this version:
|
|
(let ([ht (make-hash)])
|
|
(for ([e (in-list new-table)])
|
|
(when (and (string? (car e))
|
|
(or (null? (cddr e))
|
|
(regexp-match? (caddr e) (version))))
|
|
(hash-set! ht (car e) (cadr e))))
|
|
(hash-map ht (lambda (k p)
|
|
(if with-path?
|
|
(cons k (simplify p))
|
|
k)))))))
|
|
|