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

;;; Installation library for scsh modules.
;;; $Id: install-lib.scm,v 1.3 2003/12/14 14:45:20 michel-schinz 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)))))))