suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

meta/pkg-build: use Etag header to avoid installer download

Browse Source
This commit is contained in:
Matthew Flatt 2014-07-08 17:20:59 +01:00
parent aff4391d92
commit e0ec228fd2
2 changed files with 75 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
pkgs/plt-services/meta/pkg-build/download.rkt Normal file
View File

@ -0,0 +1,51 @@
#lang racket/base
(require net/url
net/head
racket/format
racket/file
racket/port)
(provide download-installer)
(define (download-installer snapshot-url installer-dir installer-name substatus)
(define status-file (build-path installer-dir "status.rktd"))
(define name+etag (and (file-exists? status-file)
(call-with-input-file*
status-file
read)))
(define installer-url (combine-url/relative (string->url snapshot-url)
(~a "installers/" installer-name)))
(define etag
(cond
[(equal? (url-scheme installer-url) "file")
#f]
[else
(define p (head-impure-port installer-url))
(define h (purify-port p))
(close-input-port p)
(extract-field "ETag" h)]))
(cond
[(and (file-exists? (build-path installer-dir installer-name))
name+etag
(equal? (car name+etag) installer-name)
(cadr name+etag)
(equal? (cadr name+etag) etag))
(substatus "Using cached installer, Etag ~a\n" etag)]
[else
(delete-directory/files installer-dir #:must-exist? #f)
(make-directory* installer-dir)
(call/input-url
installer-url
get-pure-port
(lambda (i)
(call-with-output-file*
(build-path installer-dir installer-name)
#:exists 'replace
(lambda (o)
(copy-port i o)))))
(when etag
(call-with-output-file*
status-file
(lambda (o)
(write (list installer-name etag) o)
(newline o))))]))

33
pkgs/plt-services/meta/pkg-build/main.rkt
View File

@ -16,6 +16,7 @@
distro-build/vbox
web-server/servlet-env
(only-in scribble/html a td tr #%top)
"download.rkt"
"union-find.rkt"
"thread.rkt"
"ssh.rkt"
@ -265,30 +266,30 @@
(define (cd-racket vm) (~a "cd " (q (remote-dir vm)) "/racket"))
;; ----------------------------------------
(define installer-table-path (build-path work-dir "table.rktd"))
(unless skip-download?
(status "Getting installer table\n")
(define table (call/input-url
(combine-url/relative (string->url snapshot-url)
"installers/table.rktd")
get-pure-port
(lambda (i) (read i))))
(call-with-output-file*
installer-table-path
#:exists 'truncate/replace
(lambda (o) (write table o) (newline o))))
(define installer-name (hash-ref table installer-platform-name))
(define installer-name (hash-ref
(call-with-input-file*
installer-table-path
read)
installer-platform-name))
(substatus "Installer is ~a\n" installer-name)
;; ----------------------------------------
(unless skip-download?
(status "Downloading installer ~a\n" installer-name)
(delete-directory/files installer-dir #:must-exist? #f)
(make-directory* installer-dir)
(call/input-url
(combine-url/relative (string->url snapshot-url)
(~a "installers/" installer-name))
get-pure-port
(lambda (i)
(call-with-output-file*
(build-path installer-dir installer-name)
#:exists 'replace
(lambda (o)
(copy-port i o))))))
(download-installer snapshot-url installer-dir installer-name substatus))
;; ----------------------------------------
(unless skip-archive?
@ -855,7 +856,8 @@
(with-handlers ([exn:break? (lambda (exn)
(log-error "breaking...")
(for-each break-running runnings)
(wait-chunk-output))])
(wait-chunk-output)
(raise exn))])
(parameterize-break
#t
(apply sync runnings))))
@ -950,7 +952,7 @@
(cons k v)))
(cond
[(null? conflicts)
available-pkgs]
(values (set) available-pkgs)]
[else
(define (show-conflicts)
(substatus "Install conflicts:\n")
@ -1130,6 +1132,7 @@
(wpath "server" "built" "pkgs")
(wpath "server" "built" "adds")
(wpath "dumpster")
(wpath "table.rktd")
(wpath "state.sqlite")
(wpath "all-doc.tgz")
(wpath "install-doc.tgz")