From fb75dcd38d6bf19a3534997df4e88c17c77f4c51 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 23 Oct 2014 07:57:30 -0600
Subject: [PATCH] unix-installer test: check "natipkg"

---
 .../meta/tests/unix-installer.rkt             | 372 +++++++++++-------
 1 file changed, 236 insertions(+), 136 deletions(-)

diff --git a/pkgs/plt-services/meta/tests/unix-installer.rkt b/pkgs/plt-services/meta/tests/unix-installer.rkt
index 1b926fa1fe..39bf9e3cab 100644
--- a/pkgs/plt-services/meta/tests/unix-installer.rkt
+++ b/pkgs/plt-services/meta/tests/unix-installer.rkt
@@ -3,7 +3,9 @@
          remote-shell/vbox
          net/url
          racket/date
-         file/zip)
+         file/zip
+         pkg/lib
+         web-server/servlet-env)
 
 (module test racket/base)
 
@@ -15,23 +17,35 @@
 (define vbox-user "racket")
 (define vbox-snapshot "init")
 
-(define snapshot-site "http://pre-release.racket-lang.org/installers/")
+(define snapshot-site "http://pre-release.racket-lang.org/")
+(define installers-site (~a snapshot-site "installers/"))
+(define catalog (~a snapshot-site "catalog/"))
 
 (define min-racket-installers
-  (list "racket-minimal-6.0.900.900-x86_64-linux-ubuntu-precise.sh"))
+  (list "racket-minimal-6.1.0.900-x86_64-linux-ubuntu-precise.sh"))
 
 (define racket-installers
-  (list "racket-6.0.900.900-x86_64-linux-ubuntu-precise.sh"))
+  (list "racket-6.1.0.900-x86_64-linux-ubuntu-precise.sh"))
+
+(define min-racket-natipkg-installers
+  (list "racket-minimal-6.1.0.900-x86_64-linux-natipkg-debian-squeeze.sh"))
+
+;; For serving packages to VM:
+(define server-port 50001)
 
 (define work-dir (find-system-path 'temp-dir))
 
+;; For disabling some tests:
+(define basic? #t)
+(define natipkg? #t)
+
 ;; ----------------------------------------
 ;; Get installers and "base.zip" from snapshot
 
 (define (get f #:sub [sub ""])
   (unless (file-exists? (build-path work-dir f))
     (printf "Getting ~a\n" f)
-    (call/input-url (string->url (string-append snapshot-site sub f))
+    (call/input-url (string->url (string-append installers-site sub f))
                     get-pure-port
                     (lambda (i)
                       (call-with-output-file*
@@ -42,6 +56,7 @@
 
 (for-each get min-racket-installers)
 (for-each get racket-installers)
+(for-each get min-racket-natipkg-installers)
 (get #:sub "base/" "base.zip")
 
 ;; ----------------------------------------
@@ -78,143 +93,228 @@
    (displayln "#lang racket/base" o)
    (write '(require sample) o)))
 
+
+;; ----------------------------------------
+;; Packages to local
+
+(define pkg-archive-dir (build-path work-dir "archive"))
+
+(when natipkg?
+  (pkg-catalog-archive pkg-archive-dir
+                       (list catalog)
+                       #:state-catalog (build-path work-dir "archive" "state.sqlite")
+                       #:relative-sources? #t))
+
 ;; ----------------------------------------
 
-(for* ([min? '(#t #f)]
-       [f (in-list (if min?
-                       min-racket-installers
-                       racket-installers))]
-       ;; Unix-style install?
-       [unix-style? '(#f #t)]
-       ;; Change path of "shared" to "mine-all-mine"?
-       [mv-shared? (if unix-style? '(#t #f) '(#f))]
-       ;; Install into "/usr/local"?
-       [usr-local? '(#t #f)]
-       ;; Link in-place install executables in "/usr/local/bin"?
-       [links? (if unix-style? '(#f) '(#t #f))])
-  (printf (~a "=================================================================\n"
-              "CONFIGURATION: "
-              (if min? "minimal" "full") " "
-              (if unix-style? "unix-style" "in-place") " "
-              (if mv-shared? "mine-all-mine " "")
-              (if usr-local? "/usr/local " "")
-              (if links? "linked" "")
-              "\n"))
+(define (set-date rt)
+  (ssh rt "sudo date --set=\""
+       (parameterize ([date-display-format 'rfc2822])
+         (date->string (seconds->date (current-seconds)) #t))
+       "\""))
 
-  (restore-vbox-snapshot vbox-name vbox-snapshot)
+;; ----------------------------------------
 
-  (#%app
-   dynamic-wind
-   
-   (lambda ()
-     (start-vbox-vm vbox-name #:pause-seconds 0))
-   
-   (lambda ()
-     (define rt (remote #:host vbox-host
-                        #:user vbox-user))
+(when basic?
+  (for* ([min? '(#t #f)]
+         [f (in-list (if min?
+                         min-racket-installers
+                         racket-installers))]
+         ;; Unix-style install?
+         [unix-style? '(#f #t)]
+         ;; Change path of "shared" to "mine-all-mine"?
+         [mv-shared? (if unix-style? '(#t #f) '(#f))]
+         ;; Install into "/usr/local"?
+         [usr-local? '(#t #f)]
+         ;; Link in-place install executables in "/usr/local/bin"?
+         [links? (if unix-style? '(#f) '(#t #f))])
+    (printf (~a "=================================================================\n"
+                "CONFIGURATION: "
+                (if min? "minimal" "full") " "
+                (if unix-style? "unix-style" "in-place") " "
+                (if mv-shared? "mine-all-mine " "")
+                (if usr-local? "/usr/local " "")
+                (if links? "linked" "")
+                "\n"))
+
+    (restore-vbox-snapshot vbox-name vbox-snapshot)
+
+    (#%app
+     dynamic-wind
      
-     (make-sure-remote-is-ready rt)
+     (lambda ()
+       (start-vbox-vm vbox-name #:pause-seconds 0))
      
-     (ssh rt "sudo date --set=\""
-          (parameterize ([date-display-format 'rfc2822])
-            (date->string (seconds->date (current-seconds)) #t))
-          "\"")
+     (lambda ()
+       (define rt (remote #:host vbox-host
+                          #:user vbox-user))
+       
+       (make-sure-remote-is-ready rt)
+       
+       (set-date rt)
+       
+       (scp rt (build-path work-dir f) (at-remote rt f))
+
+       (define script (build-path work-dir "script"))
+       (call-with-output-file*
+        script
+        #:exists 'truncate
+        (lambda (o)
+          ;; Installer interactions:
+          ;; 
+          ;; Unix-style distribution?
+          ;;  * yes -> 
+          ;;     Where to install?
+          ;;       [like below]
+          ;; 
+          ;;     Target directories
+          ;;       [e]
+          ;;       ...
+          ;; 
+          ;;  * no ->  
+          ;;     Where to install?
+          ;;       * 1 /usr/racket
+          ;;       * 2 /usr/local/racket
+          ;;       * 3 ~/racket
+          ;;       * 4 ./racket
+          ;;       * <anything else>
+          ;; 
+          ;;     Prefix for link?
+          (fprintf o "~a\n" (if unix-style? "yes" "no"))
+          (fprintf o (if usr-local?
+                         "2\n"
+                         "4\n"))
+          (when mv-shared?
+            (fprintf o "s\n") ; "shared" path
+            (fprintf o "~a\n" (if usr-local?
+                                  "/usr/local/mine-all-mine"
+                                  "mine-all-mine")))
+          (when links?
+            (fprintf o "/usr/local\n"))
+          (fprintf o "\n")))
+       (scp rt script (at-remote rt "script"))
+
+       (when min?
+         (scp rt (build-path work-dir "base.zip") (at-remote rt "base.zip")))
+       (scp rt sample-zip-path (at-remote rt "sample.zip"))
+       (unless min?
+         (scp rt progy-path (at-remote rt "progy.rkt")))
+
+       (define sudo? (or usr-local? links?))
+       (define sudo (if sudo? "sudo " ""))
+
+       ;; install --------------------
+       (ssh rt sudo "sh " f " < script")
+
+       (define bin-dir
+         (cond
+          [(or links? (and usr-local? unix-style?)) ""]
+          [else
+           (~a (if usr-local?
+                   "/usr/local/"
+                   "")
+               (if unix-style?
+                   "bin/"
+                   "racket/bin/"))]))
+
+       ;; check that Racket runs --------------------
+       (ssh rt (~a bin-dir "racket") " -e '(displayln \"hello\")'")
+
+       ;; check that `raco setup` is ok --------------------
+       ;;  For example, there are no file-permission problems.
+       (ssh rt (~a bin-dir "raco") " setup" (if sudo?
+                                                " --avoid-main"
+                                                ""))
+
+       ;; install and use a package --------------------
+       (ssh rt (~a bin-dir "raco") " pkg install sample.zip" (if min? " base.zip" ""))
+       (ssh rt (~a bin-dir "racket") " -l sample")
+
+       ;; create a stand-alone executable ----------------------------------------
+       (unless min?
+         (ssh rt (~a bin-dir "raco") " exe progy.rkt")
+         (ssh rt "./progy")
+         (ssh rt (~a bin-dir "raco") " distribute d progy")
+         (ssh rt "d/bin/progy"))
+
+       ;; uninstall ----------------------------------------
+       (when unix-style?
+         (ssh rt sudo (~a bin-dir "racket-uninstall"))
+         (when (ssh rt (~a bin-dir "racket") #:mode 'result)
+           (error "not uninstalled")))
+
+       ;; check stand-alone executable ----------------------------------------
+       (unless min?
+         (ssh rt "d/bin/progy"))
+       
+       (void))
+
+     (lambda ()
+       (stop-vbox-vm vbox-name)))))
+
+
+;; ----------------------------------------
+
+(when natipkg?
+  (printf "Starting web server\n")
+  (define server
+    (thread
+     (lambda ()
+       (serve/servlet
+        (lambda args #f)
+        #:command-line? #t
+        #:listen-ip "localhost"
+        #:extra-files-paths (list pkg-archive-dir)
+        #:servlet-regexp #rx"$." ; never match
+        #:port server-port))))
+  (sync (system-idle-evt))
+  
+  (for* ([f (in-list min-racket-natipkg-installers)])
+    (printf (~a "=================================================================\n"
+                "NATIPKG: "
+                f
+                "\n"))
+
+    (restore-vbox-snapshot vbox-name vbox-snapshot)
+
+    (#%app
+     dynamic-wind
      
-     (scp rt (build-path work-dir f) (at-remote rt f))
-
-     (define script (build-path work-dir "script"))
-     (call-with-output-file*
-      script
-      #:exists 'truncate
-      (lambda (o)
-        ;; Installer interactions:
-        ;; 
-        ;; Unix-style distribution?
-        ;;  * yes -> 
-        ;;     Where to install?
-        ;;       [like below]
-        ;; 
-        ;;     Target directories
-        ;;       [e]
-        ;;       ...
-        ;; 
-        ;;  * no ->  
-        ;;     Where to install?
-        ;;       * 1 /usr/racket
-        ;;       * 2 /usr/local/racket
-        ;;       * 3 ~/racket
-        ;;       * 4 ./racket
-        ;;       * <anything else>
-        ;; 
-        ;;     Prefix for link?
-        (fprintf o "~a\n" (if unix-style? "yes" "no"))
-        (fprintf o (if usr-local?
-                       "2\n"
-                       "4\n"))
-        (when mv-shared?
-          (fprintf o "s\n") ; "shared" path
-          (fprintf o "~a\n" (if usr-local?
-                                "/usr/local/mine-all-mine"
-                                "mine-all-mine")))
-        (when links?
-          (fprintf o "/usr/local\n"))
-        (fprintf o "\n")))
-     (scp rt script (at-remote rt "script"))
-
-     (when min?
-       (scp rt (build-path work-dir "base.zip") (at-remote rt "base.zip")))
-     (scp rt sample-zip-path (at-remote rt "sample.zip"))
-     (unless min?
-       (scp rt progy-path (at-remote rt "progy.rkt")))
-
-     (define sudo? (or usr-local? links?))
-     (define sudo (if sudo? "sudo " ""))
-
-     ;; install --------------------
-     (ssh rt sudo "sh " f " < script")
-
-     (define bin-dir
-       (cond
-        [(or links? (and usr-local? unix-style?)) ""]
-        [else
-         (~a (if usr-local?
-                 "/usr/local/"
-                 "")
-             (if unix-style?
-                 "bin/"
-                 "racket/bin/"))]))
-
-     ;; check that Racket runs --------------------
-     (ssh rt (~a bin-dir "racket") " -e '(displayln \"hello\")'")
-
-     ;; check that `raco setup` is ok --------------------
-     ;;  For example, there are no file-permission problems.
-     (ssh rt (~a bin-dir "raco") " setup" (if sudo?
-                                              " --avoid-main"
-                                              ""))
-
-     ;; install and use a package --------------------
-     (ssh rt (~a bin-dir "raco") " pkg install sample.zip" (if min? " base.zip" ""))
-     (ssh rt (~a bin-dir "racket") " -l sample")
-
-     ;; create a stand-alone executable ----------------------------------------
-     (unless min?
-       (ssh rt (~a bin-dir "raco") " exe progy.rkt")
-       (ssh rt "./progy")
-       (ssh rt (~a bin-dir "raco") " distribute d progy")
-       (ssh rt "d/bin/progy"))
-
-     ;; uninstall ----------------------------------------
-     (when unix-style?
-       (ssh rt sudo (~a bin-dir "racket-uninstall"))
-       (when (ssh rt (~a bin-dir "racket") #:mode 'result)
-         (error "not uninstalled")))
-
-     ;; check stand-alone executable ----------------------------------------
-     (unless min?
-       (ssh rt "d/bin/progy"))
+     (lambda ()
+       (start-vbox-vm vbox-name #:pause-seconds 0))
      
-     (void))
+     (lambda ()
+       (define rt (remote #:host vbox-host
+                          #:user vbox-user
+                          #:remote-tunnels (list (cons server-port server-port))))
+       
+       (make-sure-remote-is-ready rt)
 
-   (lambda ()
-     (stop-vbox-vm vbox-name))))
+       (set-date rt)
+       
+       (scp rt (build-path work-dir f) (at-remote rt f))
+
+       ;; install --------------------
+       (ssh rt "sh " f " --in-place --dest racket")
+
+       (define bin-dir "racket/bin/")
+
+       ;; check that Racket runs --------------------
+       (ssh rt (~a bin-dir "racket") " -e '(displayln \"hello\")'")
+
+       ;; check that `raco setup` is ok --------------------
+       (ssh rt (~a bin-dir "raco") " setup")
+
+       ;; install packages  --------------------
+       (ssh rt (~a bin-dir "raco") " pkg install"
+            " --catalog http://localhost:" (~a server-port) "/catalog/"
+            " --auto"
+            " drracket")
+       
+       ;; check that the drawing library works:
+       (ssh rt (~a bin-dir "racket") " -l racket/draw")
+       
+       (void))
+
+     (lambda ()
+       (stop-vbox-vm vbox-name)))))