574 lines
20 KiB
Scheme
574 lines
20 KiB
Scheme
;;; Installation library for scsh modules.
|
|
;;; $Id: install-lib.scm,v 1.2 2003/12/16 16:44:40 frese Exp $
|
|
|
|
;; TODO
|
|
;; - add support for image creation,
|
|
;; - add support to maintain a documentation index,
|
|
;; - add "--mode" option to specify permissions for files/directories.
|
|
;; - add "--verbose" to show whats being done.
|
|
;; - add "--log" option to specify a log file.
|
|
;; - decide what to do when target files already exist
|
|
;; - allow installation of platform-specific files only
|
|
|
|
;;
|
|
;; Utilities
|
|
;;
|
|
|
|
(define default-perms #o755)
|
|
|
|
(define (parent-directory fname)
|
|
(file-name-directory (directory-as-file-name fname)))
|
|
|
|
(define (create-directory&parents fname . rest)
|
|
(let-optionals rest ((perms default-perms))
|
|
(let ((parent (parent-directory fname)))
|
|
(if (not (file-exists? parent))
|
|
(apply create-directory&parents parent rest))
|
|
(if (not (file-exists? fname))
|
|
(-create-directory fname perms)))))
|
|
|
|
(define (common-prefix-length l1 l2 . rest)
|
|
(let-optionals rest ((pred equal?))
|
|
(if (or (null? l1) (null? l2) (not (pred (first l1) (first l2))))
|
|
0
|
|
(+ 1 (apply common-prefix-length (cdr l1) (cdr l2) rest)))))
|
|
|
|
(define (relative-file-name name . rest)
|
|
(let-optionals rest ((dir (cwd)))
|
|
(let* ((abs-pl (split-file-name (absolute-file-name name)))
|
|
(dir-pl (split-file-name (directory-as-file-name dir)))
|
|
(cp-len (common-prefix-length abs-pl dir-pl)))
|
|
(path-list->file-name (append (make-list (- (length dir-pl) cp-len) "..")
|
|
(drop abs-pl cp-len))))))
|
|
|
|
;; Copy file/symlink SOURCE to TARGET and set the permisions of TARGET
|
|
;; to PERMS. TARGET must be the name of a non-existing file (i.e. it
|
|
;; cannot be the name of a directory).
|
|
(define (copy-file source target perms)
|
|
(if (file-exists? target)
|
|
(error "copy-file: target file exists" target))
|
|
(if (file-symlink? source)
|
|
(create-symlink (read-symlink source) target)
|
|
(begin
|
|
(run (cp ,source ,target))
|
|
(set-file-mode target perms))))
|
|
|
|
;; Like "load" but without printing anything.
|
|
(define load-quietly
|
|
(let ((eval (lambda (expr t) (eval expr (interaction-environment)))))
|
|
(lambda (file-name)
|
|
(call-with-input-file file-name
|
|
(lambda (port) (port-fold port read eval #f))))))
|
|
|
|
(define (permissions->string perms)
|
|
(let ((decode (lambda (mask str)
|
|
(if (zero? (bitwise-and perms mask)) "-" str))))
|
|
(string-append (decode #o400 "r") (decode #o200 "w") (decode #o100 "x")
|
|
(decode #o040 "r") (decode #o020 "w") (decode #o010 "x")
|
|
(decode #o004 "r") (decode #o002 "w") (decode #o001 "x"))))
|
|
|
|
;;
|
|
;; Support for dry runs.
|
|
;;
|
|
|
|
(define *dry-run* (make-fluid #f))
|
|
|
|
(define (wrap-for-dry-run real-fn dry-fn)
|
|
(lambda args
|
|
(apply (if (fluid *dry-run*) dry-fn real-fn) args)))
|
|
|
|
(define (dry-run-print msg . args)
|
|
(apply format #t msg args) (newline))
|
|
|
|
(define -create-directory
|
|
(wrap-for-dry-run
|
|
create-directory
|
|
(lambda (fname . rest)
|
|
(let-optionals rest ((perms default-perms))
|
|
(dry-run-print "creating directory ~a with permissions ~a"
|
|
fname
|
|
(permissions->string perms))))))
|
|
|
|
(define -create-symlink
|
|
(wrap-for-dry-run
|
|
create-symlink
|
|
(lambda (old-name new-name)
|
|
(dry-run-print "creating symbolic link ~a pointing to ~a"
|
|
new-name
|
|
old-name))))
|
|
|
|
(define -copy-file
|
|
(wrap-for-dry-run
|
|
copy-file
|
|
(lambda (source target perms)
|
|
(dry-run-print "copying file ~a to ~a with permissions ~a"
|
|
source
|
|
target
|
|
(permissions->string perms)))))
|
|
|
|
(define -delete-file
|
|
(wrap-for-dry-run delete-file
|
|
(lambda (fname) (dry-run-print "deleting file ~a" fname))))
|
|
|
|
;;
|
|
;; Versions
|
|
;;
|
|
;; Versions are represented as lists of integers, the most significant
|
|
;; being at the head.
|
|
|
|
(define (version->string version)
|
|
(string-join (map number->string version) "."))
|
|
|
|
(define string->version
|
|
(let ((split-version (infix-splitter ".")))
|
|
(lambda (version-string)
|
|
(map string->number (split-version version-string)))))
|
|
|
|
(define (version-compare v1 v2)
|
|
(cond ((and (null? v1) (null? v2)) 'equal)
|
|
((null? v1) 'smaller)
|
|
((null? v2) 'greater)
|
|
(else (let ((v1h (car v1)) (v2h (car v2)))
|
|
(cond ((< v1h v2h) 'smaller)
|
|
((> v1h v2h) 'greater)
|
|
(else (version-compare (cdr v1) (cdr v2))))))))
|
|
|
|
(define (version<? v1 v2) (eq? (version-compare v1 v2) 'smaller))
|
|
(define (version>? v1 v2) (eq? (version-compare v1 v2) 'greater))
|
|
(define (version=? v1 v2) (eq? (version-compare v1 v2) 'equal))
|
|
|
|
;;
|
|
;; Layouts
|
|
;;
|
|
|
|
(define parse-layout
|
|
(let ((split-defs (infix-splitter ","))
|
|
(split-sides (infix-splitter "=")))
|
|
(lambda (str)
|
|
(map (lambda (name&value)
|
|
(let ((name/value (split-sides name&value)))
|
|
(cons (string->symbol (first name/value)) (second name/value))))
|
|
(split-defs str)))))
|
|
|
|
;; Combine layouts L1 and L2 by adding to L1 all the additional
|
|
;; mappings found in L2.
|
|
(define (combine-layouts l1 l2)
|
|
(fold (lambda (key/value layout)
|
|
(if (assoc (car key/value) layout) layout (cons key/value layout)))
|
|
l1
|
|
l2))
|
|
|
|
;; Return an absolute version of LAYOUT by prepending PREFIX to all
|
|
;; its components (which must be relative).
|
|
(define (absolute-layout layout prefix)
|
|
(map (lambda (key/value)
|
|
(cons (car key/value) (absolute-file-name (cdr key/value) prefix)))
|
|
layout))
|
|
|
|
(define (layout-dir layout dir)
|
|
(cond ((assoc dir layout) => cdr)
|
|
(else #f)))
|
|
|
|
;; Predefined layouts
|
|
|
|
(define (scsh-layout platform base)
|
|
`((base . ,base)
|
|
(misc-shared . ,base)
|
|
(scheme . ,(absolute-file-name "scheme" base))
|
|
(lib . ,(absolute-file-name
|
|
(path-list->file-name (list "lib" platform))
|
|
base))
|
|
(doc . ,(absolute-file-name "doc" base))))
|
|
|
|
(define (scsh-layout-1 platform pkg)
|
|
(combine-layouts '((active . "."))
|
|
(scsh-layout platform (package-full-name pkg))))
|
|
|
|
(define (scsh-layout-2 platform pkg)
|
|
(combine-layouts
|
|
'((active . "active"))
|
|
(scsh-layout platform
|
|
(path-list->file-name
|
|
(list "installed"
|
|
(package-name pkg)
|
|
(version->string (package-version pkg)))))))
|
|
|
|
(define (fhs-layout platform pkg)
|
|
(let ((base (absolute-file-name (package-full-name pkg)
|
|
"share/scsh/modules")))
|
|
`((base . ,base)
|
|
(misc-shared . ,base)
|
|
(scheme . ,(absolute-file-name "scheme" base))
|
|
(lib . ,(absolute-file-name (package-full-name pkg)
|
|
"lib/scsh/modules"))
|
|
(doc . ,(absolute-file-name (package-full-name pkg) "share/doc"))
|
|
(active . "share/scsh/modules"))))
|
|
|
|
(define predefined-layouts
|
|
`(("scsh" . ,scsh-layout-1)
|
|
("scsh-alt" . ,scsh-layout-2)
|
|
("fhs" . ,fhs-layout)))
|
|
|
|
;;
|
|
;; Packages
|
|
;;
|
|
|
|
(define-record-type package
|
|
(make-package name version extensions install-thunk)
|
|
package?
|
|
(name package-name)
|
|
(version package-version)
|
|
(extensions package-extensions)
|
|
(install-thunk package-install-thunk))
|
|
|
|
(define (package-full-name pkg)
|
|
(string-append
|
|
(package-name pkg) "-" (version->string (package-version pkg))))
|
|
|
|
;; List of all defined packages
|
|
(define packages '())
|
|
|
|
;; Add a package to the above list
|
|
(define (add-package pkg)
|
|
(set! packages (cons pkg packages)))
|
|
|
|
(define-syntax define-package
|
|
(syntax-rules ()
|
|
((define-package name version extensions body ...)
|
|
(add-package (make-package name
|
|
(quote version)
|
|
(quote extensions)
|
|
(lambda () body ...))))))
|
|
|
|
;;
|
|
;; Actions
|
|
;;
|
|
|
|
;; Perform all actions required to make the given version of the
|
|
;; package active (i.e. the default version for that package).
|
|
(define (activate-package layout pkg)
|
|
(let ((lnk-name (absolute-file-name (package-name pkg)
|
|
(layout-dir layout 'active))))
|
|
(if (and (file-exists? lnk-name) (file-symlink? lnk-name))
|
|
(-delete-file lnk-name))
|
|
(-create-symlink (relative-file-name (layout-dir layout 'base)
|
|
(file-name-directory lnk-name))
|
|
lnk-name)))
|
|
|
|
(define (install-thing% layout name-or-pair location target-rel-dir perms)
|
|
(let* ((target-dir (absolute-file-name target-rel-dir
|
|
(layout-dir layout location)))
|
|
(source (if (pair? name-or-pair) (car name-or-pair) name-or-pair))
|
|
(target-name (file-name-nondirectory (if (pair? name-or-pair)
|
|
(cdr name-or-pair)
|
|
name-or-pair)))
|
|
(target (absolute-file-name target-name target-dir)))
|
|
(create-directory&parents target-dir perms)
|
|
(cond ((or (file-regular? source) (file-symlink? source))
|
|
(-copy-file source target perms))
|
|
((file-directory? source)
|
|
(create-directory target perms)
|
|
(install-directory-contents% layout
|
|
source
|
|
location
|
|
(absolute-file-name target-name
|
|
target-rel-dir)
|
|
perms))
|
|
(else (error "cannot install file-system object" source)))))
|
|
|
|
(define (install-directory-contents% layout name location target-rel-dir perms)
|
|
(for-each (lambda (thing)
|
|
(install-thing% layout thing location target-rel-dir perms))
|
|
(map (lambda (f) (absolute-file-name f name))
|
|
(directory-files name #t))))
|
|
|
|
(define (install-thing name-or-pair location . rest)
|
|
(let-optionals rest ((target-rel-dir ".") (perms default-perms))
|
|
(install-thing% (fluid *install-layout*)
|
|
name-or-pair
|
|
location
|
|
target-rel-dir
|
|
perms)))
|
|
|
|
(define (install-things names-or-pairs . rest)
|
|
(for-each (lambda (name-or-pair)
|
|
(apply install-thing name-or-pair rest))
|
|
names-or-pairs))
|
|
|
|
(define install-file install-thing)
|
|
(define install-files install-things)
|
|
(define install-directory install-thing)
|
|
(define install-directories install-things)
|
|
|
|
(define (install-directory-contents name location . rest)
|
|
(let-optionals rest ((target-rel-dir ".") (perms default-perms))
|
|
(install-directory-contents% (fluid *install-layout*)
|
|
name
|
|
location
|
|
target-rel-dir
|
|
perms)))
|
|
|
|
(define (install-empty-directory% layout name location dir . rest)
|
|
(let-optionals rest ((perms default-perms))
|
|
(-create-directory (absolute-file-name dir (layout-dir layout location))
|
|
perms)))
|
|
|
|
(define (install-empty-directory&parents% layout name location dir . rest)
|
|
(let-optionals rest ((perms default-perms))
|
|
(create-directory&parents
|
|
(absolute-file-name dir (layout-dir layout location))
|
|
perms)))
|
|
|
|
(define *layout* (make-fluid #f))
|
|
(define *install-layout* (make-fluid #f))
|
|
|
|
(define (get-directory location install?)
|
|
(layout-dir (fluid (if install? *install-layout* *layout*)) location))
|
|
|
|
(define (install-package layout install-layout pkg)
|
|
(let-fluids *layout* layout
|
|
*install-layout* install-layout
|
|
(package-install-thunk pkg)))
|
|
|
|
;;
|
|
;; Error handling
|
|
;;
|
|
|
|
(define (display-error-and-exit msg . args)
|
|
(apply format (current-error-port) (string-append "Error: " msg) args)
|
|
(newline)
|
|
(exit 1))
|
|
|
|
(define usage #<<END
|
|
Usage: ~a [options]
|
|
|
|
options:
|
|
-h, --help display this help message, then exit
|
|
--prefix <dir> specify directory where files are installed
|
|
--layout <layout> specify layout of installation directory
|
|
(predefined: ~a)
|
|
--dry-run don't do anything, print what would have been done
|
|
--inactive don't activate package after installing it
|
|
|
|
advanced options:
|
|
--build <name> name of platform for which to build
|
|
--layout-from <file> load layout of installation directory from file
|
|
--layout-to <file> output layout to given file
|
|
--install-prefix <dir> specify prefix to used during installation
|
|
(to be used only during staged installations)
|
|
|
|
END
|
|
)
|
|
|
|
(define usage-description-column 26)
|
|
|
|
(define (complete-usage! optional-parts)
|
|
(let ((usage-port (make-string-output-port)))
|
|
(write-string usage usage-port)
|
|
(write-string "\noptional parts:\n" usage-port)
|
|
(for-each
|
|
(lambda (part)
|
|
(let* ((sname (symbol->string (optional-part:name part)))
|
|
(pf (string-append " --with-" sname "=[yes|no]")))
|
|
(format usage-port
|
|
"~a~a~a [~a]\n"
|
|
pf
|
|
(spaces 2 (- usage-description-column
|
|
(string-length pf)))
|
|
(optional-part:description part)
|
|
(unbooleanize (optional-part:default part)))))
|
|
optional-parts)
|
|
(set! usage (string-output-port-output usage-port))))
|
|
|
|
(define (display-usage-and-exit msg . args)
|
|
(if msg (begin (apply format #t msg args) (newline)))
|
|
(format #t
|
|
usage
|
|
(car (command-line))
|
|
(string-join (map car predefined-layouts) ", "))
|
|
(exit 1))
|
|
|
|
;;
|
|
;; Command line parsing
|
|
;;
|
|
|
|
(define (booleanize s)
|
|
(cond ((string=? s "yes") #t)
|
|
((string=? s "no") #f)
|
|
(else (display-error-and-exit
|
|
"unknown boolean value '~a'. Use 'yes' or 'no'." s))))
|
|
|
|
(define (unbooleanize b)
|
|
(if b "yes" "no"))
|
|
|
|
(define (spaces min n)
|
|
(make-string (if (< n min) min n) #\space))
|
|
|
|
(define (get-all-optional-parts packages)
|
|
(if (null? packages)
|
|
'()
|
|
(let* ((p (car packages))
|
|
(ext (package-extensions p))
|
|
(op (assq 'optional-parts ext)))
|
|
(append (if op (cdr op) '())
|
|
(get-all-optional-parts (cdr packages))))))
|
|
|
|
(define optional-part:name car)
|
|
(define optional-part:description cadr)
|
|
(define (optional-part:default part)
|
|
(if (null? (cddr part)) #f (caddr part)))
|
|
|
|
(define (optional-parts->options parts)
|
|
(map (lambda (part)
|
|
(let ((part-name (optional-part:name part)))
|
|
(option (list (string-append "with-" (symbol->string part-name)))
|
|
#t #f
|
|
(optional-part-processor part-name))))
|
|
parts))
|
|
|
|
(define (optional-parts-defaults parts)
|
|
(map (lambda (part)
|
|
(cons (optional-part:name part) (optional-part:default part)))
|
|
parts))
|
|
|
|
(define *optional-parts-alist* (make-fluid '()))
|
|
|
|
(define (with-optional-part? name)
|
|
(cdr (assq name (fluid *optional-parts-alist*))))
|
|
|
|
(define (process-option opt
|
|
name
|
|
arg
|
|
prefix
|
|
i-prefix
|
|
layout
|
|
layout-file
|
|
build
|
|
activate?
|
|
dry-run?
|
|
opt-parts)
|
|
(case (cdr (assoc opt options/keys))
|
|
((prefix)
|
|
(values arg i-prefix layout layout-file build activate? dry-run? opt-parts))
|
|
((i-prefix)
|
|
(values prefix arg layout layout-file build activate? dry-run? opt-parts))
|
|
((layout)
|
|
(values prefix
|
|
i-prefix
|
|
(cond ((assoc arg predefined-layouts) => cdr)
|
|
(else (parse-layout arg)))
|
|
layout-file
|
|
build
|
|
activate?
|
|
dry-run?
|
|
opt-parts))
|
|
((layout-from)
|
|
(values prefix
|
|
i-prefix
|
|
(let ((layout (call-with-input-file arg read)))
|
|
(lambda args layout))
|
|
layout-file
|
|
build
|
|
activate?
|
|
dry-run?
|
|
opt-parts))
|
|
((layout-to)
|
|
(values prefix i-prefix layout arg build activate? dry-run? opt-parts))
|
|
((build)
|
|
(values prefix i-prefix layout layout-file arg activate? dry-run? opt-parts))
|
|
((inactive)
|
|
(values prefix i-prefix layout layout-file build #f dry-run? opt-parts))
|
|
((dry-run)
|
|
(values prefix i-prefix layout layout-file build activate? #t opt-parts))
|
|
((help)
|
|
(display-usage-and-exit #f))))
|
|
|
|
(define (optional-part-processor part-name)
|
|
(lambda (opt
|
|
name
|
|
arg
|
|
prefix
|
|
i-prefix
|
|
layout
|
|
layout-file
|
|
build
|
|
activate?
|
|
dry-run?
|
|
opt-parts)
|
|
(values prefix
|
|
i-prefix
|
|
layout
|
|
layout-file
|
|
build
|
|
activate?
|
|
dry-run?
|
|
(alist-cons part-name (booleanize arg) opt-parts))))
|
|
|
|
(define options/keys
|
|
(list
|
|
(cons (option '(#\h "help") #f #f process-option) 'help)
|
|
(cons (option '("prefix") #t #f process-option) 'prefix)
|
|
(cons (option '("install-prefix") #t #f process-option) 'i-prefix)
|
|
(cons (option '("layout") #t #f process-option) 'layout)
|
|
(cons (option '("layout-from") #t #f process-option) 'layout-from)
|
|
(cons (option '("layout-to") #t #f process-option) 'layout-to)
|
|
(cons (option '("build") #t #f process-option) 'build)
|
|
(cons (option '("inactive") #f #f process-option) 'inactive)
|
|
(cons (option '("dry-run") #f #f process-option) 'dry-run)))
|
|
|
|
(define package-definition-file "pkg-def.scm")
|
|
|
|
(define (is-running-dry?)
|
|
(fluid *dry-run*))
|
|
|
|
(define (install-main cmd-line)
|
|
(if (not (file-exists? package-definition-file))
|
|
(display-error-and-exit "cannot find package definition file (~a)"
|
|
package-definition-file))
|
|
(load-quietly package-definition-file)
|
|
(let ((all-optional-parts (get-all-optional-parts packages)))
|
|
(if (not (null? all-optional-parts))
|
|
(complete-usage! all-optional-parts))
|
|
(receive (prefix maybe-i-prefix layout-fn layout-to build activate? dry-run? opt-parts)
|
|
(args-fold (cdr cmd-line)
|
|
(append (map car options/keys)
|
|
(optional-parts->options all-optional-parts))
|
|
(lambda (option name . rest)
|
|
(display-usage-and-exit "Unknown option ~a" name))
|
|
(lambda (operand . rest)
|
|
(display-usage-and-exit
|
|
"Don't know what to do with ~a"
|
|
operand))
|
|
#f ; default prefix
|
|
#f ; default install-prefix
|
|
scsh-layout-1 ; default layout-fn
|
|
#f ; default layout-to
|
|
(host) ; default build platform
|
|
#t ; default activation
|
|
#f ; default dry run
|
|
(optional-parts-defaults all-optional-parts))
|
|
|
|
(if (not prefix)
|
|
(display-error-and-exit "no prefix specified (use --prefix option)"))
|
|
(let ((i-prefix (or maybe-i-prefix prefix)))
|
|
(if (not (and (file-exists? i-prefix) (file-directory? i-prefix)))
|
|
(display-error-and-exit "install prefix directory ~a doesn't exist"
|
|
i-prefix))
|
|
(let-fluids *dry-run* dry-run?
|
|
*optional-parts-alist* opt-parts
|
|
(lambda ()
|
|
(for-each
|
|
(lambda (pkg)
|
|
(let* ((rel-layout (layout-fn build pkg))
|
|
(layout (absolute-layout rel-layout prefix))
|
|
(i-layout (absolute-layout rel-layout i-prefix)))
|
|
(if layout-to
|
|
(call-with-output-file
|
|
(string-append layout-to "_"
|
|
(package-full-name pkg))
|
|
(lambda (port)
|
|
(write rel-layout port) (newline port))))
|
|
(install-package layout i-layout pkg)
|
|
(if activate? (activate-package i-layout pkg))))
|
|
packages)))))))
|