scsh-install-lib/scheme/install-lib/install-lib.scm

;;; Installation library for scsh modules.
;;; $Id: install-lib.scm,v 1.2 2003/12/14 12:33:59 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) 'smaller))
(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 extensions install-thunk)
  package?
  (name package:name)
  (version package:version)
  (extensions package:extensions)
  (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 extensions body ...)
     (add-package (make-package name
                                (quote version)
				(quote extensions)
                                (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 #<<END
Usage: ~a [options]
  -h, --help             display this help message, then exit
  -r, --root <dir>       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 <dir>  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)))
  (display-optional-parts-usage)
  (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? opt-parts)
                 (values arg dest-root activate? dry-run? opt-parts)))
       (option '(#\d "dest-root") #t #f
               (lambda (option name arg root dest-root activate? dry-run? opt-parts)
                 (values root arg activate? dry-run? opt-parts)))
       (option '(#\n "dry-run") #f #f
               (lambda (option name arg root dest-root activate? dry-run? opt-parts)
                 (values root dest-root activate? #t opt-parts)))
       (option '(#\i "inactive") #f #f
               (lambda (option name arg root dest-root activate? dry-run? opt-parts)
                 (values root dest-root #f dry-run? opt-parts)))))

;;
;; optional parts stuff
;;

(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
                   (lambda (option name arg root dest-root activate? dry-run? opt-parts)
                     (values root dest-root activate? dry-run?
                             (cons (cons part-name (booleanize arg))
                                   opt-parts))))))
       parts))

(define (optional-parts-defaults parts)
  (map (lambda (part)
         (cons (optional-part:name part) (optional-part:default part)))
       parts))

(define *all-optional-parts* (make-fluid '()))
(define *optional-parts-alist* (make-fluid '()))

(define *usage-description-column* 25)

(define (display-optional-parts-usage)
  (display "\noptionals parts:\n")
  (map (lambda (part)
         (let* ((sname (symbol->string (optional-part:name part)))
                (pf (string-append "  --with-" sname"=[yes|no]")))
         (display pf)
         (display (spaces 2 (- *usage-description-column* (string-length pf))))
         (display (optional-part:description part))
         (display (string-append " [" (unbooleanize (optional-part:default part)) "]"))
         (newline)))
       (fluid *all-optional-parts*)))

(define (with-optional-part? name)
  (cdr (assq name (fluid *optional-parts-alist*))))

;; main

(define package-definition-file "pkg-def.scm")

(define (is-running-dry?)
  (fluid *dry-run*))

(define (install-main cmd-line)
  (let ((prog (car cmd-line))
        (args (cdr 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)
    (set-fluid! *all-optional-parts* (get-all-optional-parts packages))
    (receive (root maybe-dest-root activate? dry-run? opt-parts)
             (args-fold args
                        (append options
                                (optional-parts->options (fluid *all-optional-parts*)))
                        (lambda (option name arg . seeds)
                          (display-usage-and-exit "Unknown option ~a" name))
                        (lambda (operand . seeds) ; 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
			(optional-parts-defaults (fluid *all-optional-parts*)))
             (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?
                           *optional-parts-alist* opt-parts
                           (lambda ()
                             (for-each
                              (lambda (pkg)
                                (install-package root dest-root pkg)
                                (if activate?
                                    (activate-package dest-root pkg)))
                              packages)))))))