diff --git a/scheme/install-lib/install-lib-module.scm b/scheme/install-lib/install-lib-module.scm new file mode 100644 index 0000000..bdb21b6 --- /dev/null +++ b/scheme/install-lib/install-lib-module.scm @@ -0,0 +1,42 @@ +;;; Installation library for scsh modules. +;;; $Id: install-lib-module.scm,v 1.1 2003/12/14 12:23:36 michel-schinz Exp $ + +;;; Interfaces + +(define-interface install-interface + (export version->string + string->version + version-compare + version? + version=? + + installed-packages + active-packages + installed-packages&versions + active-packages&versions + active-version + + (define-package :syntax) + + install-file + install-files + install-directory + install-directories + + package-installation-dir + package-installation-staging-dir + + install-main)) + +;;; Structures + +(define-structure install install-interface + (open scheme-with-scsh + fluids + let-opt + srfi-1 + srfi-9 + srfi-13 + srfi-37) + (files install-lib)) diff --git a/scheme/install-lib/install-lib.scm b/scheme/install-lib/install-lib.scm new file mode 100755 index 0000000..c33a2a0 --- /dev/null +++ b/scheme/install-lib/install-lib.scm @@ -0,0 +1,432 @@ +;;; Installation library for scsh modules. +;;; $Id: install-lib.scm,v 1.1 2003/12/14 12:23:36 michel-schinz Exp $ + +;; TODO +;; - copy symbolic links as such, do not duplicate contents, +;; - add function to copy a directory contents, +;; - 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 +;; - find out how to perform installation for several architectures + +;; +;; 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)))))) + +(define (copy-file src target perms) + (run (cp ,src ,target)) + (set-file-mode target perms)) + +(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")))) + +;; 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)))))) + +;; +;; 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)))) + +;; +;; Regular expressions to match package names +;; + +(define number-rx (rx (+ digit))) +(define version-rx (rx ,number-rx (* "." ,number-rx))) +(define package-name-rx (rx (+ (| alphanum ("_"))))) +(define package-full-name-rx (rx (submatch ,package-name-rx) + "-" + (submatch ,version-rx))) + +;; +;; 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) 'greater)) +(define (version=? v1 v2) (eq? (version-compare v1 v2) 'equal)) + +;; +;; Packages +;; + +(define-record-type package + (make-package name version install-thunk) + package? + (name package:name) + (version package:version) + (install-thunk package:install-thunk)) + +;; 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 body ...) + (add-package (make-package name + (quote version) + (lambda () body ...)))))) + +;; +;; Names of various directories/links +;; + +;; Directory in which active versions of packages are "remembered". +(define (active-directory root) + (absolute-file-name "active" root)) + +;; Directory in which packages are installed. +(define (installed-directory root) + (absolute-file-name "installed" root)) + +(define (package-dir-name root pkg) + (absolute-file-name (package:name pkg) (installed-directory root))) + +(define (package-version-dir-name root pkg) + (absolute-file-name (version->string (package:version pkg)) + (package-dir-name root pkg))) + +(define (active-link-name root pkg) + (absolute-file-name (package:name pkg) (active-directory root))) + +;; +;; Queries +;; + +(define (packages-of dir) + (with-cwd dir (filter file-directory? (directory-files)))) + +;; Get the name of all installed packages (without versions) as a list +;; of strings. +(define (installed-packages root) + (packages-of (installed-directory root))) + +;; Get the name of all active packages (without versions) as a list of +;; strings. +(define (active-packages root) + (packages-of (active-directory root))) + +;; Return the list of all installed packages and their version(s), as +;; a list of pairs. The CAR of each pair contains the name of the +;; package, the CDR contains the list of all available versions. +(define (installed-packages&versions root) + (with-cwd (installed-directory root) + (map (lambda (pkg-dir) + (cons pkg-dir + (map string->version (directory-files pkg-dir)))) + (directory-files)))) + +(define (read-version pkg-link) + (string->version (file-name-nondirectory (read-symlink pkg-link)))) + +;; Return the list of all active packages and their version, as a list +;; of pairs. The CAR of each pair contains the name of the package, +;; and the CDR contains the active version. +(define (active-packages&versions root) + (with-cwd (active-directory root) + (map (lambda (pkg-dir) + (cons pkg-dir (read-version pkg-dir))) + (directory-files)))) + +;; Return the active version of package NAME. +(define (active-version root name) + (read-version (absolute-file-name name (active-directory root)))) + +;; +;; 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 root pkg) + (let ((lnk-name (active-link-name root pkg))) + (if (and (file-exists? lnk-name) (file-symlink? lnk-name)) + (-delete-file lnk-name)) + (-create-symlink (relative-file-name (package-version-dir-name root pkg) + (file-name-directory lnk-name)) + lnk-name))) + +(define (target-absolute-dir root pkg dir) + (absolute-file-name (directory-as-file-name dir) + (package-version-dir-name root pkg))) + +(define (re-root-file file dir) + (absolute-file-name (file-name-nondirectory (directory-as-file-name file)) + dir)) + +;; Copy the list of FILES to the TARGET-DIR and set their permission +;; to PERMS. The TARGET-DIR (default ".") is relative to the package +;; directory given by ROOT, NAME and VERSION. +(define (install-files% root pkg files . rest) + (let-optionals rest ((target-dir ".") (perms default-perms)) + (let* ((target-abs-dir (target-absolute-dir root pkg target-dir))) + (create-directory&parents target-abs-dir perms) + (for-each (lambda (file) + (-copy-file file (re-root-file file target-abs-dir) perms)) + files)))) + +;; Copy SRC-DIR and all its contents in TARGET-DIR, and set the +;; permission for everything to PERMS. The TARGET-DIR (default ".") is +;; relative to the package directory given by ROOT, NAME and VERSION. +(define (install-directory% root pkg src-dir . rest) + (let-optionals rest ((target-dir ".") (perms default-perms)) + (let* ((src-dir-name (file-name-nondirectory + (directory-as-file-name src-dir))) + (full-target-dir (absolute-file-name src-dir-name target-dir)) + (target-abs-dir (target-absolute-dir root pkg full-target-dir))) + (create-directory&parents target-abs-dir perms) + (for-each + (lambda (file) + (let ((abs-file (absolute-file-name file src-dir))) + (cond ((file-regular? abs-file) + (-copy-file abs-file + (absolute-file-name file target-abs-dir) + perms)) + ((file-directory? abs-file) + (install-directory% root pkg abs-file full-target-dir perms)) + (else + (display-error-and-exit "don't know what to do with file ~a" + abs-file))))) + (directory-files src-dir #t))))) + +(define (install-empty-directory% root pkg target-dir . rest) + (let-optionals rest ((perms default-perms)) + (-create-directory (target-absolute-dir root pkg target-dir) perms))) + +(define (install-empty-directory&parents% root pkg target-dir . rest) + (let-optionals rest ((perms default-perms)) + (create-directory&parents (target-absolute-dir root pkg target-dir) + perms))) + +(define *root* (make-fluid #f)) +(define *dest-root* (make-fluid #f)) +(define *package* (make-fluid #f)) + +(define (package-installation-dir) + (package-version-dir-name (fluid *root*) (fluid *package*))) +(define (package-installation-staging-dir) + (package-version-dir-name (fluid *dest-root*) (fluid *package*))) + +(define (forward-args-prepend-fluids target-fn args) + (apply target-fn (fluid *dest-root*) (fluid *package*) args)) + +(define (install-file file . rest) + (apply install-files (list file) rest)) + +(define (install-files . args) + (forward-args-prepend-fluids install-files% args)) + +(define (install-empty-directory . args) + (forward-args-prepend-fluids install-empty-directory% args)) + +(define (install-empty-directory&parents . args) + (forward-args-prepend-fluids install-empty-directory&parents% args)) + +(define (install-directory . args) + (forward-args-prepend-fluids install-directory% args)) + +(define (install-directories src-dirs . rest) + (for-each (lambda (src-dir) + (apply install-directory src-dir rest)) + src-dirs)) + +(define (install-package root dest-root pkg) + (let-fluids *root* root + *dest-root* dest-root + *package* pkg + (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 #< specify root directory + -n, --dry-run don't do anything, print what would have been done + -i, --inactive don't activate package after installing it + +advanced options: + -d, --dest-root specify staging root directory + +END +) + +(define (display-usage-and-exit msg . args) + (if msg (begin (apply format #t msg args) (newline))) + (format #t usage (car (command-line))) + (exit 1)) + +(define (check-root-directory root) + (for-each (lambda (dir) + (if (not (and (file-exists? dir) (file-directory? dir))) + (display-error-and-exit + (string-append + "directory ~a does not exist or is not a directory.\n" + "It should be created before installing packages.") + dir))) + (list root (active-directory root) (installed-directory root)))) + +;; +;; Command line parsing +;; + +(define options + (list (option '(#\h "help") #f #f + (lambda args + (display-usage-and-exit #f))) + (option '(#\r "root") #t #f + (lambda (option name arg root dest-root activate? dry-run?) + (values arg dest-root activate? dry-run?))) + (option '(#\d "dest-root") #t #f + (lambda (option name arg root dest-root activate? dry-run?) + (values root arg activate? dry-run?))) + (option '(#\n "dry-run") #f #f + (lambda (option name arg root dest-root activate? dry-run?) + (values root dest-root activate? #t))) + (option '(#\i "inactive") #f #f + (lambda (option name arg root dest-root activate? dry-run?) + (values root dest-root #f dry-run?))))) + +(define package-definition-file "pkg-def.scm") + +(define (install-main cmd-line) + (let ((prog (car cmd-line)) + (args (cdr cmd-line))) + (receive (root maybe-dest-root activate? dry-run?) + (args-fold args + options + (lambda (option name arg . seeds) + (display-usage-and-exit "Unknown option ~a" name)) + (lambda (operand root activate?) ; operand + (display-usage-and-exit + "Don't know what to do with ~a" + operand)) + #f ; default root + #f ; default dest-root + #t ; default activation + #f) ; default dry run + (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) + (if (not root) + (display-error-and-exit + "No package root specified (use --root option)")) + (let ((dest-root (or maybe-dest-root root))) + (check-root-directory dest-root) + (let-fluids *dry-run* dry-run? + (lambda () + (for-each + (lambda (pkg) + (install-package root dest-root pkg) + (if activate? + (activate-package dest-root pkg))) + packages)))))))