racket-webview/racket-webview-downloader.rkt

#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-racket-webview-qt
         racket-webview-qt-clear-download!
         racket-webview-qt-version
         racket-webview-qt-directory
         racket-webview-qt-is-available?
         racket-webview-qt-is-downloadable?
         racket-webview-qt-resolves?
         )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Version info of the version to download
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define rkt-qt-version-major 0)
(define rkt-qt-version-minor 1)
(define rkt-qt-version-patch 1)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Internal functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(define rkt-qt-download-version (format "~a-~a-~a"
                                        rkt-qt-version-major
                                        rkt-qt-version-minor
                                        rkt-qt-version-patch
                                        ))

(define rkt-qt-download-site "git.dijkewijk.nl")
(define rkt-qt-base-path "hans/racket-webview-qt/releases/download")
(define rkt-qt-os (system-type 'os*))
(define rkt-qt-arch (system-type 'arch))

(define rkt-download-url (format "https://~a/~a/~a/~a-~a.zip"
                                 rkt-qt-download-site
                                 rkt-qt-base-path
                                 rkt-qt-download-version
                                 rkt-qt-os
                                 rkt-qt-arch))

(define install-path (build-path (find-system-path 'addon-dir) "racket-webview-qt"))
(define version-file (build-path install-path "version.txt"))
(define ffi-path (build-path install-path (format "~a-~a" rkt-qt-os rkt-qt-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 1000000 1000000)))
      (displayln (format "~a downloaded" count))
      (close-input-port port-in)
      (close-output-port port-out)
      count)
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Provided functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (racket-webview-qt-is-available?)
  (if (file-exists? version-file)
      (with-handlers ([exn:fail? (λ (e) #f)])
        (let ((v (file->value version-file)))
          (and
           (= (car v) rkt-qt-version-major)
           (= (cadr v) rkt-qt-version-minor)
           (= (caddr v) rkt-qt-version-patch)))
        )
      #f))

(define (racket-webview-qt-directory)
  (if (racket-webview-qt-is-available?)
      (build-path install-path (format "~a-~a" rkt-qt-os rkt-qt-arch))
      #f))

(define (racket-webview-qt-resolves?)
  (if (eq? (dns-find-nameserver) #f)
    #f
    (with-handlers ([exn:fail? (λ (e) #f)])
      (dns-get-address (dns-find-nameserver) rkt-qt-download-site)
      #t)
    )
  )

(define (racket-webview-qt-version)
  (if (racket-webview-qt-is-available?)
      (file->value version-file)
      #f))


(define (racket-webview-qt-clear-download!)
  (when (file-exists? version-file)
    (delete-file version-file)))

(define (racket-webview-qt-is-downloadable?)
  (with-handlers ([exn:fail? (λ (e) #f)])
    (let ((in (download-port rkt-download-url)))
      (let ((d (input-port? in)))
        (when d
          (close-input-port in))
        d))))

(define (download-racket-webview-qt)
  (let ((in (download-port rkt-download-url)))
    (unless (input-port? in)
      (error (format "Cannot get a download port for '~a'" rkt-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)..." rkt-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 rkt-qt-version-major
                           rkt-qt-version-minor
                           rkt-qt-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
      )
    )
  )