move unix-installer test to "distro-build-test"
This commit is contained in:
Matthew Flatt
parent
39a9526f35
commit
d400a7fcb1
|
|
@ -1,320 +0,0 @@
|
||||||
#lang racket
|
|
||||||
(require remote-shell/ssh
|
|
||||||
remote-shell/vbox
|
|
||||||
net/url
|
|
||||||
racket/date
|
|
||||||
file/zip
|
|
||||||
pkg/lib
|
|
||||||
web-server/servlet-env)
|
|
||||||
|
|
||||||
(module test racket/base)
|
|
||||||
|
|
||||||
;; ----------------------------------------
|
|
||||||
;; Configuration (adjust as needed)
|
|
||||||
|
|
||||||
(define vbox-name "Ubuntu Server 14.04")
|
|
||||||
(define vbox-host "192.168.56.107")
|
|
||||||
(define vbox-user "racket")
|
|
||||||
(define vbox-snapshot "init")
|
|
||||||
|
|
||||||
(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.1.0.900-x86_64-linux-ubuntu-precise.sh"))
|
|
||||||
|
|
||||||
(define racket-installers
|
|
||||||
(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 installers-site sub f))
|
|
||||||
get-pure-port
|
|
||||||
(lambda (i)
|
|
||||||
(call-with-output-file*
|
|
||||||
(build-path work-dir f)
|
|
||||||
#:exists 'truncate
|
|
||||||
(lambda (o)
|
|
||||||
(copy-port i o)))))))
|
|
||||||
|
|
||||||
(for-each get min-racket-installers)
|
|
||||||
(for-each get racket-installers)
|
|
||||||
(for-each get min-racket-natipkg-installers)
|
|
||||||
(get #:sub "base/" "base.zip")
|
|
||||||
|
|
||||||
;; ----------------------------------------
|
|
||||||
;; Construct a simple package
|
|
||||||
|
|
||||||
(define sample-pkg-dir (build-path work-dir "sample"))
|
|
||||||
(delete-directory/files sample-pkg-dir #:must-exist? #f)
|
|
||||||
(make-directory* sample-pkg-dir)
|
|
||||||
(call-with-output-file*
|
|
||||||
(build-path sample-pkg-dir "info.rkt")
|
|
||||||
(lambda (o)
|
|
||||||
(displayln "#lang info" o)
|
|
||||||
(write '(define collection "sample") o)
|
|
||||||
(write '(define deps '("base")) o)))
|
|
||||||
(call-with-output-file*
|
|
||||||
(build-path sample-pkg-dir "main.rkt")
|
|
||||||
(lambda (o)
|
|
||||||
(displayln "#lang racket/base" o)
|
|
||||||
(write "sample" o)))
|
|
||||||
|
|
||||||
(define sample-zip-path (build-path work-dir "sample.zip"))
|
|
||||||
(parameterize ([current-directory work-dir])
|
|
||||||
(when (file-exists? "sample.zip") (delete-file "sample.zip"))
|
|
||||||
(zip "sample.zip" "sample" #:utc-timestamps? #t))
|
|
||||||
|
|
||||||
;; ----------------------------------------
|
|
||||||
;; Construct a simple program
|
|
||||||
|
|
||||||
(define progy-path (build-path work-dir "progy.rkt"))
|
|
||||||
(call-with-output-file*
|
|
||||||
progy-path
|
|
||||||
#:exists 'truncate
|
|
||||||
(lambda (o)
|
|
||||||
(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))
|
|
||||||
|
|
||||||
;; ----------------------------------------
|
|
||||||
|
|
||||||
(define (set-date rt)
|
|
||||||
(ssh rt "sudo date --set=\""
|
|
||||||
(parameterize ([date-display-format 'rfc2822])
|
|
||||||
(date->string (seconds->date (current-seconds)) #t))
|
|
||||||
"\""))
|
|
||||||
|
|
||||||
;; ----------------------------------------
|
|
||||||
|
|
||||||
(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
|
|
||||||
|
|
||||||
(lambda ()
|
|
||||||
(start-vbox-vm vbox-name #:pause-seconds 0))
|
|
||||||
|
|
||||||
(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
|
|
||||||
|
|
||||||
(lambda ()
|
|
||||||
(start-vbox-vm vbox-name #:pause-seconds 0))
|
|
||||||
|
|
||||||
(lambda ()
|
|
||||||
(define rt (remote #:host vbox-host
|
|
||||||
#:user vbox-user
|
|
||||||
#:remote-tunnels (list (cons server-port server-port))))
|
|
||||||
|
|
||||||
(make-sure-remote-is-ready rt)
|
|
||||||
|
|
||||||
(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)))))
|
|
||||||
Loading…
Reference in New Issue
Block a user