#!/bin/sh
exec scsh -e main -o srfi-26 -o sort -s "$0" "$@"
!#

;; Regression testing for the installation library. Works by
;; installing a set of packages with two different versions of the
;; library and checking that both install the same files, with the
;; same attributes. Every package is installed successively with a
;; different set of options, specified below.

;; $Id: test-install-lib.scm,v 1.1 2004/09/20 17:42:31 michel-schinz Exp $

(define options-set
  '(()
    ("--layout" "fhs")))

;; Utilities
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax unless
  (syntax-rules ()
    ((unless cond body1 ...)
     (if (not cond) (begin body1 ...)))))

;; Temporary directories management

(define (delete-directory-and-contents dir)
  (run (rm -rf ,(directory-as-file-name dir))))

(define (create-temp-directory)
  (temp-file-iterate (lambda (dir) (create-directory dir) dir)
                     "/var/tmp/tmp.~a"))

(define (call-with-temporary-directory proc)
  (let ((temp-dir (create-temp-directory)))
    (proc temp-dir)
    (delete-directory-and-contents temp-dir)))

(define (with-temporary-directory* thunk)
  (call-with-temporary-directory (lambda (dir) (with-cwd dir (thunk)))))

(define-syntax with-temporary-directory
  (syntax-rules ()
    ((with-temporary-directory body ...)
     (with-temporary-directory* (lambda () body ...)))))

(define-syntax let-temporary-directories
  (syntax-rules ()
    ((let-temporary-directories () body ...)
     (begin body ...))
    ((let-temporary-directories (i1 i2 ...) body ...)
     (call-with-temporary-directory
      (lambda (i1) (let-temporary-directories (i2 ...) body ...))))))

(define (create-temp-symlink old-name)
  (temp-file-iterate (lambda (l) (create-symlink old-name l) l)))

;; Logging

(define (log msg . args)
  (apply format #t msg args))

(define error-count 0)

(define (log-error msg . args)
  (set! error-count (+ 1 error-count))
  (apply log msg args))

(define (log-notice msg . args)
  (apply log msg args))


;; Main program
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (single-subdirectory)
  (let ((all-files (directory-files)))
    (if (and (= (length all-files) 1) (file-directory? (first all-files)))
        (first all-files)
        (begin
          (log-error "more than one file in directory ~a: ~a\n"
                     (cwd)
                     all-files)
          #f))))

(define (install-install-lib archive bin-dir prefix)
  (with-temporary-directory
   (run (tar --extract --gzip --file ,archive))
   (with-cwd (single-subdirectory)
             (run (./install.scm --bindir ,bin-dir --prefix ,prefix)))))

(define (install-package archive bin-dir prefix options)
  (with-temporary-directory
   (run (tar --extract --gzip --file ,archive))
   (with-cwd (single-subdirectory)
             (run (,(absolute-file-name "scsh-install-pkg" bin-dir)
                   --no-user-defaults
                   --prefix ,prefix
                   ,@options)
                  (> /dev/null)))))

(define (sorted-directory-files dir)
  (sort-list (map (cut absolute-file-name <> dir) (directory-files dir))
             string<?))

(define (compare-file-kind f1 i1 f2 i2 mismatch-handler)
  (unless (eq? (file-info:type i1) (file-info:type i2))
          (mismatch-handler f1 f2 'type)))

(define (compare-file-mode f1 i1 f2 i2 mismatch-handler)
  (unless (= (file-info:mode i1) (file-info:mode i2))
          (mismatch-handler f1 f2 'mode)))

(define (compare-file-contents f1 i1 f2 i2 mismatch-handler)
  (unless (and (= (file-info:size i1) (file-info:size i2))
               (zero? (run (diff -q ,f1 ,f2) (> /dev/null))))
          (mismatch-handler f1 f2 'contents)))

(define (compare-directories dir1 dir2 mismatch-handler)
  (for-each (lambda (f1 f2)
              (unless (string=? (file-name-nondirectory f1)
                                (file-name-nondirectory f2))
                      (mismatch-handler f1 f2 'name))
              (let ((i1 (file-info f1 #f)) (i2 (file-info f2 #f)))
                (compare-file-kind f1 i1 f2 i2 mismatch-handler)
                (cond ((file-info-regular? i1)
                       (compare-file-mode f1 i1 f2 i2 mismatch-handler)
                       (compare-file-contents f1 i1 f2 i2 mismatch-handler))
                      ((file-info-directory? i1)
                       (compare-file-mode f1 i1 f2 i2 mismatch-handler)
                       (compare-directories f1 f2 mismatch-handler))
                      ((file-info-symlink? i1)
                       )
                      (else
                       (mismatch-handler f1 f2 'unknown)))))
            (sorted-directory-files dir1)
            (sorted-directory-files dir2)))

(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"))))

(define (get-characteristic file characteristic)
  (case characteristic
    ((name)
     (string-append "name = " file))
    ((mode)
     (string-append "mode = " (permissions->string (file-mode file))))
    ((type)
     (string-append "type = " (file-type file)))
    ((contents)
     "contents")
    (else
     "unknown characteristic")))

(define (log-mismatch ref-file tst-file reason)
  (log-error "difference found for file ~a:\n  reference: ~a\n    to-test: ~a\n"
             (string-take-right ref-file
                                (string-suffix-length ref-file tst-file))
             (get-characteristic ref-file reason)
             (get-characteristic tst-file reason)))

(define (test-install-lib ref-archive tst-archive . pkg-archives)
  (let-temporary-directories (ref-bin-dir
                              ref-iprefix-dir
                              tst-bin-dir
                              tst-iprefix-dir)
    (log-notice "Installing reference library...\n")
    (install-install-lib ref-archive ref-bin-dir ref-iprefix-dir)
    (log-notice "Installing test library...\n")
    (install-install-lib tst-archive tst-bin-dir tst-iprefix-dir)
    (for-each
     (lambda (options)
       (log-notice "\nTesting with options: ~a\n" options)
       (for-each
        (lambda (pkg-archive)
          (log-notice "  ~a: " (file-name-nondirectory pkg-archive))
          (let-temporary-directories (ref-prefix-dir tst-prefix-dir)
            (let ((link (create-temp-symlink ref-prefix-dir)))
              (log-notice "[ref]")
              (install-package pkg-archive ref-bin-dir link options)
              (create-symlink tst-prefix-dir link #t)
              (log-notice "[test]")
              (install-package pkg-archive tst-bin-dir link options)
              (delete-file link))
            (log-notice "[compare]\n")
            (compare-directories ref-prefix-dir tst-prefix-dir log-mismatch)))
          pkg-archives))
     options-set)))

(define (main cmd-line)
  (let ((prog (car cmd-line))
        (args (cdr cmd-line)))
    (if (>= (length args) 3)
        (begin
          (apply test-install-lib (map absolute-file-name args))
          (if (zero? error-count)
              (begin
                (log-notice "\nTest succeeded.\n")
                (exit 0))
              (begin
                (log-notice "\nTest failed with ~a error~a.\n"
                            error-count
                            (if (> error-count 1) "s" ""))
                (exit 1))))
        (begin
          (format #t "Usage: ~a <reference> <to-test> <pkg_1> ...\n" prog)
          (exit 1)))))