initial import from racket-sound -> racket-audio
This commit is contained in:
@@ -0,0 +1,170 @@
|
||||
#lang racket/base
|
||||
|
||||
(require setup/dirs
|
||||
net/sendurl
|
||||
net/url
|
||||
net/url-connect
|
||||
net/dns
|
||||
racket/file
|
||||
racket/system
|
||||
racket/string
|
||||
file/unzip
|
||||
)
|
||||
|
||||
(provide download-soundlibs
|
||||
soundlibs-clear-download!
|
||||
soundlibs-version
|
||||
soundlibs-directory
|
||||
soundlibs-available?
|
||||
soundlibs-downloadable?
|
||||
soundlibs-resolves?
|
||||
)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Version info of the version to download
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define version-major 1)
|
||||
(define version-minor 0)
|
||||
(define version-patch 0)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Internal functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
(define download-version (format "~a-~a-~a"
|
||||
version-major
|
||||
version-minor
|
||||
version-patch
|
||||
))
|
||||
|
||||
(define download-site "git.dijkewijk.nl")
|
||||
(define base-path "hans/racket-sound-lib/releases/download")
|
||||
(define os (system-type 'os*))
|
||||
(define arch (system-type 'arch))
|
||||
|
||||
(define download-url (format "https://~a/~a/~a/~a-~a.zip"
|
||||
download-site
|
||||
base-path
|
||||
download-version
|
||||
os
|
||||
arch))
|
||||
|
||||
(define install-path (build-path (find-system-path 'addon-dir) "racket-sound-lib"))
|
||||
(define version-file (build-path install-path "version.txt"))
|
||||
(define ffi-path (build-path install-path (format "~a-~a" os arch)))
|
||||
|
||||
(define (download-port link)
|
||||
(let ((current-https-prot (current-https-protocol)))
|
||||
(current-https-protocol 'secure)
|
||||
(let* ((url (string->url link))
|
||||
(port-in (get-pure-port url #:redirections 10)))
|
||||
(current-https-protocol current-https-prot)
|
||||
port-in)))
|
||||
|
||||
|
||||
(define (do-download port-in port-out)
|
||||
(letrec ((downloader-func (λ (count next-c len)
|
||||
(let ((bytes (read-bytes 16384 port-in)))
|
||||
(if (eof-object? bytes)
|
||||
count
|
||||
(let ((read-len (bytes-length bytes)))
|
||||
(when (> read-len 0)
|
||||
(set! count (+ count read-len))
|
||||
(when (> count next-c)
|
||||
(display (format "~a..." count))
|
||||
(set! next-c (+ count len)))
|
||||
(write-bytes bytes port-out)
|
||||
)
|
||||
(downloader-func count next-c len)))))
|
||||
))
|
||||
(let ((count (downloader-func 0 100000 100000)))
|
||||
(displayln (format "~a downloaded" count))
|
||||
(close-input-port port-in)
|
||||
(close-output-port port-out)
|
||||
count)
|
||||
)
|
||||
)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Provided functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (soundlibs-available?)
|
||||
(if (file-exists? version-file)
|
||||
(with-handlers ([exn:fail? (λ (e) #f)])
|
||||
(let ((v (file->value version-file)))
|
||||
(and
|
||||
(= (car v) version-major)
|
||||
(= (cadr v) version-minor)
|
||||
(= (caddr v) version-patch)))
|
||||
)
|
||||
#f))
|
||||
|
||||
(define (soundlibs-directory)
|
||||
(if (soundlibs-available?)
|
||||
(build-path install-path (format "~a-~a" os arch))
|
||||
#f))
|
||||
|
||||
(define (soundlibs-resolves?)
|
||||
(if (eq? (dns-find-nameserver) #f)
|
||||
#f
|
||||
(with-handlers ([exn:fail? (λ (e) #f)])
|
||||
(dns-get-address (dns-find-nameserver) download-site)
|
||||
#t)
|
||||
)
|
||||
)
|
||||
|
||||
(define (soundlibs-version)
|
||||
(if (soundlibs-available?)
|
||||
(file->value version-file)
|
||||
#f))
|
||||
|
||||
(define (soundlibs-downloadable?)
|
||||
(with-handlers ([exn:fail? (λ (e) #f)])
|
||||
(let ((in (download-port download-url)))
|
||||
(let ((d (input-port? in)))
|
||||
(when d
|
||||
(close-input-port in))
|
||||
d))))
|
||||
|
||||
(define (soundlibs-clear-download!)
|
||||
(when (file-exists? version-file)
|
||||
(delete-file version-file)))
|
||||
|
||||
(define (download-soundlibs)
|
||||
(let ((in (download-port download-url)))
|
||||
(unless (input-port? in)
|
||||
(error (format "Cannot get a download port for '~a'" download-url)))
|
||||
(unless (directory-exists? install-path)
|
||||
(make-directory* install-path))
|
||||
(let* ((file (build-path install-path "archive.zip"))
|
||||
(out (open-output-file file #:exists 'replace))
|
||||
)
|
||||
(displayln (format "Downloading racket-webview-qt (~a)..." download-url))
|
||||
(do-download in out)
|
||||
(displayln (format "downloaded '~a'" file))
|
||||
(when (directory-exists? ffi-path)
|
||||
(displayln (format "Removing existing directory '~a'" ffi-path))
|
||||
(delete-directory/files ffi-path))
|
||||
(displayln "Unzipping...")
|
||||
(let ((cd (current-directory)))
|
||||
(current-directory install-path)
|
||||
(unzip file #:preserve-attributes? #t #:preserve-timestamps? #t)
|
||||
(current-directory cd))
|
||||
(displayln "Removing zip archive")
|
||||
(delete-file file)
|
||||
(displayln "Writing version")
|
||||
(let ((version (list version-major
|
||||
version-minor
|
||||
version-patch
|
||||
)))
|
||||
(let ((out (open-output-file version-file #:exists 'replace)))
|
||||
(write version out)
|
||||
(close-output-port out)))
|
||||
(displayln "Version file written; ready for FFI integration")
|
||||
#t
|
||||
)
|
||||
)
|
||||
)
|
||||
@@ -0,0 +1,126 @@
|
||||
(module utils racket/base
|
||||
|
||||
(require racket/path
|
||||
racket/runtime-path
|
||||
ffi/unsafe
|
||||
setup/dirs
|
||||
"downloader.rkt"
|
||||
simple-log
|
||||
)
|
||||
|
||||
(provide while
|
||||
until
|
||||
build-lib-path
|
||||
get-lib
|
||||
do-for
|
||||
dbg-sound
|
||||
info-sound
|
||||
err-sound
|
||||
warn-sound
|
||||
fatal-sound
|
||||
sync-log-sound
|
||||
integer->int-bytes
|
||||
int-bytes->integer
|
||||
)
|
||||
|
||||
(sl-def-log racket-sound sound)
|
||||
|
||||
(define-syntax while
|
||||
(syntax-rules ()
|
||||
((_ cond body ...)
|
||||
(letrec ((while-f (lambda (last-result)
|
||||
(if cond
|
||||
(let ((last-result (begin
|
||||
body
|
||||
...)))
|
||||
(while-f last-result))
|
||||
last-result))))
|
||||
(while-f #f))
|
||||
)
|
||||
))
|
||||
|
||||
(define-syntax until
|
||||
(syntax-rules ()
|
||||
((_ cond body ...)
|
||||
(letrec ((until-f (lambda (last-result)
|
||||
(if cond
|
||||
last-result
|
||||
(let ((last-reult (begin
|
||||
body
|
||||
...)))
|
||||
(until-f last-result))))))
|
||||
(until-f #f)))))
|
||||
|
||||
(define-syntax do-for
|
||||
(syntax-rules ()
|
||||
((_ (init cond next) body ...)
|
||||
(begin
|
||||
init
|
||||
(letrec ((do-for-f (lamba ()
|
||||
(if cond
|
||||
(begin
|
||||
(begin
|
||||
body
|
||||
...)
|
||||
next
|
||||
(do-for-f))))))
|
||||
(do-for-f))))))
|
||||
|
||||
|
||||
(define (build-lib-path)
|
||||
(soundlibs-directory))
|
||||
|
||||
(define (get-lib* libs-to-try orig-libs versions)
|
||||
(let ((libs-path (cons (build-lib-path) (get-lib-search-dirs))))
|
||||
(unless (soundlibs-available?)
|
||||
(download-soundlibs))
|
||||
(if (null? libs-to-try)
|
||||
(begin
|
||||
(displayln (format "Warning: Cannot find library, tried ~a in ~a" orig-libs libs-path))
|
||||
#f)
|
||||
(ffi-lib (car libs-to-try) versions
|
||||
#:get-lib-dirs (λ () libs-path)
|
||||
#:fail (λ ()
|
||||
(ffi-lib (car libs-to-try) versions
|
||||
#:fail (λ ()
|
||||
(get-lib* (cdr libs-to-try) orig-libs versions))))
|
||||
)
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
(define (get-lib libs-to-try versions)
|
||||
(get-lib* libs-to-try libs-to-try versions))
|
||||
|
||||
(define-syntax-rule (integer->int-bytes v size signed? big? bs pos)
|
||||
(if (= size 3)
|
||||
(if big?
|
||||
(begin
|
||||
(bytes-set! bs pos (bitwise-and (arithmetic-shift v -16) #xff))
|
||||
(bytes-set! bs (+ pos 1) (bitwise-and (arithmetic-shift v -8) #xff))
|
||||
(bytes-set! bs (+ pos 2) (bitwise-and v #xff)))
|
||||
(begin
|
||||
(bytes-set! bs pos (bitwise-and v #xff))
|
||||
(bytes-set! bs (+ pos 1) (bitwise-and (arithmetic-shift v -8) #xff))
|
||||
(bytes-set! bs (+ pos 2) (bitwise-and (arithmetic-shift v -16) #xff))))
|
||||
(integer->integer-bytes v size signed? big? bs pos)))
|
||||
|
||||
(define-syntax-rule (int-bytes->integer bs signed? big? start end)
|
||||
(let ([size (- end start)])
|
||||
(if (= size 3)
|
||||
(let* ([b0 (bytes-ref bs start)]
|
||||
[b1 (bytes-ref bs (+ start 1))]
|
||||
[b2 (bytes-ref bs (+ start 2))]
|
||||
[u (if big?
|
||||
(bitwise-ior (arithmetic-shift b0 16)
|
||||
(arithmetic-shift b1 8)
|
||||
b2)
|
||||
(bitwise-ior b0
|
||||
(arithmetic-shift b1 8)
|
||||
(arithmetic-shift b2 16)))])
|
||||
(if (and signed? (not (zero? (bitwise-and u #x800000))))
|
||||
(- u #x1000000)
|
||||
u))
|
||||
(integer-bytes->integer bs signed? big? start end))))
|
||||
|
||||
) ; end of module
|
||||
Reference in New Issue
Block a user