242 lines
8.5 KiB
Racket
242 lines
8.5 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/cmdline racket/tcp)
|
|
|
|
;; This program avoids racket/port and net/url, because it is loaded
|
|
;; without using bytecode.
|
|
|
|
(define url-host "download.racket-lang.org")
|
|
(define url-path "/libs/3/")
|
|
(define url-base (string-append "http://" url-host url-path))
|
|
|
|
(provide all-files+sizes)
|
|
(define all-files+sizes
|
|
;; alist mapping package to
|
|
;; alist mapping architecture to
|
|
;; a list of entries, each has filename and size
|
|
;; and optionally a path that it would install to and the installed size
|
|
`(;; Core Libraries
|
|
[core
|
|
[win32/i386
|
|
["iconv.dll" 892928]
|
|
["libeay32.dll" 1089536]
|
|
["ssleay32.dll" 237568]]
|
|
[win32/x86_64
|
|
["libiconv-2.dll" 1378028]
|
|
["libeay32.dll" 1293824]
|
|
["ssleay32.dll" 260608]]]
|
|
;; GUI Libraries
|
|
[gui
|
|
[i386-macosx
|
|
["libcairo.2.dylib" 803196]
|
|
["libintl.8.dylib" 57604]
|
|
["libgio-2.0.0.dylib" 736720]
|
|
["libjpeg.62.dylib" 412024]
|
|
["libglib-2.0.0.dylib" 1009572]
|
|
["libpango-1.0.0.dylib" 345476]
|
|
["libgmodule-2.0.0.dylib" 18836]
|
|
["libpangocairo-1.0.0.dylib" 83612]
|
|
["libgobject-2.0.0.dylib" 284384]
|
|
["libpixman-1.0.dylib" 526564]
|
|
["libgthread-2.0.0.dylib" 24368]
|
|
["libpng14.14.dylib" 182732]
|
|
["PSMTabBarControl.tgz" 94103 "PSMTabBarControl.framework" 251764]]
|
|
[x86_64-macosx
|
|
["libcairo.2.dylib" 919840]
|
|
["libintl.8.dylib" 61016]
|
|
["libgio-2.0.0.dylib" 897624]
|
|
["libjpeg.62.dylib" 153360]
|
|
["libglib-2.0.0.dylib" 1162256]
|
|
["libpango-1.0.0.dylib" 394768]
|
|
["libgmodule-2.0.0.dylib" 19832]
|
|
["libpangocairo-1.0.0.dylib" 94952]
|
|
["libgobject-2.0.0.dylib" 344024]
|
|
["libpixman-1.0.dylib" 577128]
|
|
["libgthread-2.0.0.dylib" 21728]
|
|
["libpng14.14.dylib" 192224]
|
|
["PSMTabBarControl.tgz" 107267 "PSMTabBarControl.framework" 316528]]
|
|
[ppc-macosx
|
|
["libcairo.2.dylib" 2716096]
|
|
["libintl.8.dylib" 133156]
|
|
["libgio-2.0.0.dylib" 936176]
|
|
["libjpeg.62.dylib" 209688]
|
|
["libglib-2.0.0.dylib" 1242368]
|
|
["libpango-1.0.0.dylib" 761292]
|
|
["libgmodule-2.0.0.dylib" 19872]
|
|
["libpangocairo-1.0.0.dylib" 199440]
|
|
["libgobject-2.0.0.dylib" 352728]
|
|
["libpixman-1.0.dylib" 1366816]
|
|
["libgthread-2.0.0.dylib" 25416]
|
|
["libpng14.14.dylib" 505920]
|
|
["PSMTabBarControl.tgz" 96039 "PSMTabBarControl.framework" 229501]]
|
|
[win32/i386
|
|
["libjpeg-7.dll" 233192]
|
|
["libcairo-2.dll" 921369]
|
|
["libpango-1.0-0.dll" 336626]
|
|
["libexpat-1.dll" 143096]
|
|
["libpng14-14.dll" 219305]
|
|
["zlib1.dll" 55808]
|
|
["freetype6.dll" 535264]
|
|
["libfontconfig-1.dll" 279059]
|
|
["libglib-2.0-0.dll" 1110713]
|
|
["libgobject-2.0-0.dll" 316586]
|
|
["libgmodule-2.0-0.dll" 31692]
|
|
["libpangocairo-1.0-0.dll" 94625]
|
|
["libpangowin32-1.0-0.dll" 102210]
|
|
["libpangoft2-1.0-0.dll" 679322]
|
|
["libplplot.dll" 245760]
|
|
["libfit.dll" 73728]
|
|
,@(if (getenv "PLT_WIN_GTK")
|
|
'(["libatk-1.0-0.dll" 153763]
|
|
["libgtk-win32-2.0-0.dll" 4740156]
|
|
["libgdk-win32-2.0-0.dll" 827670]
|
|
["libgdk_pixbuf-2.0-0.dll" 252150]
|
|
["libgio-2.0-0.dll" 669318]
|
|
["libwimp.dll" 69632]
|
|
["gtkrc" 1181])
|
|
'())]
|
|
[win32/x86_64
|
|
["libjpeg-7.dll" 224768]
|
|
["libcairo-2.dll" 1266147]
|
|
["libpango-1.0-0.dll" 423199]
|
|
["libexpat-1.dll" 263006]
|
|
["libpng14-14.dll" 272473]
|
|
["zlib1.dll" 191825]
|
|
["libfreetype-6.dll" 633649]
|
|
["libintl-8.dll" 240862]
|
|
["libfontconfig-1.dll" 339943]
|
|
["libglib-2.0-0.dll" 1267577]
|
|
["libgobject-2.0-0.dll" 425888]
|
|
["libgmodule-2.0-0.dll" 119538]
|
|
["libgthread-2.0-0.dll" 126615]
|
|
["libpangocairo-1.0-0.dll" 185168]
|
|
["libpangowin32-1.0-0.dll" 192656]
|
|
["libpangoft2-1.0-0.dll" 1188615]
|
|
["libplplot.dll" 248832]
|
|
["libfit.dll" 69120]]]))
|
|
|
|
(define-values [package dest-dir]
|
|
(command-line #:args [package [dest-dir (current-directory)]]
|
|
(values (string->symbol package) dest-dir)))
|
|
|
|
(define (unixize p)
|
|
(let-values ([(base name dir?) (split-path p)])
|
|
(if (path? base)
|
|
(string-append (unixize base) "/" (path->string name))
|
|
(path->string name))))
|
|
|
|
(define architecture (string->symbol (unixize (system-library-subpath #f))))
|
|
|
|
(define (needed-files+sizes)
|
|
(let ([files+sizes
|
|
(cdr (or (assq package all-files+sizes)
|
|
(error 'get-libs "bad package: ~s, expecting one of ~s"
|
|
package (map car all-files+sizes))))])
|
|
(cond [(assq architecture files+sizes) => cdr]
|
|
[else '()])))
|
|
|
|
(define (purify-port port)
|
|
(let ([m (regexp-match-peek-positions #rx#"^HTTP/.*?(?:\r\n\r\n|\n\n|\r\r)"
|
|
port)])
|
|
(if m (read-bytes (cdar m) port) "")))
|
|
|
|
(define (copy-port src dest)
|
|
(let ([s (make-bytes 4096)])
|
|
(let loop ()
|
|
(let ([c (read-bytes-avail! s src)])
|
|
(cond [(number? c)
|
|
(let loop ([start 0])
|
|
(unless (= start c)
|
|
(let ([c2 (write-bytes-avail s dest start c)])
|
|
(loop (+ start c2)))))
|
|
(loop)]
|
|
;; Must be EOF
|
|
[else (void)])))))
|
|
|
|
(define (download file size)
|
|
(define src (format "~a~a/~a" url-path architecture file))
|
|
(define-values [i o] (tcp-connect url-host 80))
|
|
(fprintf o "GET ~a HTTP/1.0\r\nHost: ~a\r\n\r\n" src url-host)
|
|
(flush-output o) (tcp-abandon-port o)
|
|
(purify-port i)
|
|
(define tmp (format "~a.download" file))
|
|
(call-with-output-file tmp #:exists 'truncate/replace
|
|
(lambda (out) (copy-port i out)))
|
|
(rename-file-or-directory tmp file #t)
|
|
(let ([sz (file-size file)])
|
|
(unless (= size sz)
|
|
(eprintf "\n")
|
|
(raise-user-error 'get-libs
|
|
"size of ~a is ~a; doesn't match expected size ~a"
|
|
file sz size))))
|
|
|
|
(define (unpack-tgz tgz)
|
|
(printf " unpacking...") (flush-output)
|
|
(define-values [p pout pin perr]
|
|
(subprocess
|
|
(current-output-port) (current-input-port) (current-error-port)
|
|
(find-executable-path "tar") "zxf" tgz))
|
|
(subprocess-wait p)
|
|
(delete-file tgz))
|
|
|
|
(define (install file)
|
|
(cond [(regexp-match? #rx"[.]tgz" file) (unpack-tgz file)]
|
|
[else (eprintf "\n")
|
|
(raise-user-error 'get-libs "don't know how to install file: ~a"
|
|
file)]))
|
|
|
|
(define (delete-path path)
|
|
(cond [(directory-exists? path)
|
|
(parameterize ([current-directory path])
|
|
(for-each delete-path (directory-list)))
|
|
(delete-directory path)]
|
|
[(or (file-exists? path) (link-exists? path)) (delete-file path)]))
|
|
|
|
(define (directory-size dir)
|
|
(parameterize ([current-directory dir])
|
|
(for/fold ([sum 0]) ([path (in-list (directory-list))])
|
|
(+ sum (path-size path)))))
|
|
|
|
(define (path-size path)
|
|
(cond [(file-exists? path) (file-size path)]
|
|
[(directory-exists? path) (directory-size path)]
|
|
[else 0]))
|
|
|
|
(define got-path? ; approximate, using size
|
|
(case-lambda [(path size unpacked-path unpacked-size)
|
|
(got-path? unpacked-path unpacked-size)]
|
|
[(path size)
|
|
(equal? size (path-size path))]))
|
|
|
|
(unless (eq? package 'nothing)
|
|
(unless (directory-exists? dest-dir) (make-directory dest-dir))
|
|
(parameterize ([current-directory dest-dir])
|
|
(define needed (needed-files+sizes))
|
|
(define really-needed
|
|
(filter (lambda (n) (not (apply got-path? n))) needed))
|
|
(printf (if (null? needed)
|
|
">> No ~a libraries to download for ~a\n"
|
|
">> Getting ~a libraries for ~a\n")
|
|
package architecture)
|
|
(cond
|
|
[(null? needed) (void)]
|
|
[(null? really-needed)
|
|
(printf ">> All files present, no downloads needed.\n")]
|
|
[else
|
|
(printf ">> Downloading files from\n>> ~a~a\n" url-base architecture)
|
|
(printf ">> If you don't want automatic download, download each file\n")
|
|
(printf ">> yourself from there to\n")
|
|
(printf ">> ~a\n" (path->complete-path (current-directory)))
|
|
(for ([file+size (in-list needed)])
|
|
(define file (car file+size))
|
|
(define size (cadr file+size))
|
|
(printf " ~a" file)
|
|
(if (member file+size really-needed)
|
|
(begin (printf " downloading...") (flush-output)
|
|
(download file size)
|
|
(when (pair? (cddr file+size))
|
|
(delete-path (caddr file+size))
|
|
(install file))
|
|
(printf " done.\n"))
|
|
(printf " already exists.\n")))])))
|