(module external mzscheme (require string-constants mred mzlib/class mzlib/file mzlib/list mzlib/match (prefix raw: net/sendurl) net/url (prefix fw: framework)) (provide send-url (rename raw:browser-preference? browser-preference?) update-browser-preference install-help-browser-preference-panel add-to-browser-prefs-panel) ; : -> bool (define (unix-browser?) (eq? (system-type) 'unix)) (fw:preferences:set-default 'external-browser (get-preference 'external-browser (lambda () #f)) raw:browser-preference?) (define http-proxy-preference 'plt:http-proxy) ;; proxy-pref? : any -> boolean ;; determines if the input is a valid setting for the ;; http-proxy-preference pref (define (proxy-pref? x) (match x [#f #t] [`("http" ,(? string?) ,(? integer?)) #t] [else #f])) ;; sync-current-proxy-servers : proxy-pref -> void ;; syncs current-proxy-servers parameter with the proxy-pref-val (define (sync-current-proxy-servers pref-val) (let* ([ops (current-proxy-servers)] [removed (remove-all-proxies "http" ops)]) (current-proxy-servers (if pref-val (cons pref-val removed) removed)))) (define (remove-all-proxies scheme proxies) (filter (lambda (x) (and (pair? x) (not (equal? (car x) scheme)))) proxies)) (fw:preferences:set-default http-proxy-preference #f proxy-pref?) (sync-current-proxy-servers (fw:preferences:get http-proxy-preference)) (fw:preferences:add-callback http-proxy-preference (lambda (p v) (sync-current-proxy-servers v))) (define send-url (if (unix-browser?) (lambda (url . args) (when (or (get-preference 'external-browser (lambda () #f)) ;; either the preference doesn't exist or is #f (update-browser-preference url)) (apply raw:send-url url args))) raw:send-url)) ; : str -> void ; to prompt the user for a browser preference and update the preference (define (update-browser-preference url) (or (not (unix-browser?)) (choose-browser url))) ; : (U symbol #f) -> void ; to set the default browser (define (set-browser! browser) (fw:preferences:set 'external-browser browser)) ;; Tries to put low-level prefs three times, sleeping a bit in ;; between, then gives up. (define (try-put-preferences names vals) (let loop ([tries 0]) (unless (= tries 3) (put-preferences names vals (lambda (lock-file) (sleep 0.2) (loop (add1 tries))))))) (define unix-browser-names (map (lambda (s) (string-titlecase (regexp-replace* #rx"-" (symbol->string s) " "))) raw:unix-browser-list)) ;; : (U str #f) -> (U symbol #f) ;; to prompt the user for a browser preference ;; #f for the URL indicates a pre-emptive request by Help Desk, ;; and in that case, the user can choose to use the internal ;; broswer. (define (choose-browser url) (let* ([title (string-constant choose-browser)] [d (make-object dialog% title)] [main-pane (make-object vertical-pane% d)] [internal-ok? (not url)] [ok? #f] [orig-external (fw:preferences:get 'external-browser)]) (make-object message% title main-pane) ;; No need to show the URL (it can be very long) ;; (when url ;; (make-object message% (format "URL: ~a" url) main-pane)) (let-values ([(panel callbacks) (make-help-browser-preference-panel internal-ok? #f (lambda (f) (f main-pane)))]) (let*-values ([(button-pane) (instantiate horizontal-panel% (main-pane) (alignment '(right center)))] [(ok-button cancel-button) (fw:gui-utils:ok/cancel-buttons button-pane (lambda (b e) (set! ok? #t) (send d show #f)) (lambda (b e) (fw:preferences:set 'external-browser orig-external) (send d show #f)))] [(enable-button) (lambda (_n _v) (queue-callback (lambda () (send ok-button enable (fw:preferences:get 'external-browser)))))]) (send ok-button enable #f) (set! callbacks (cons (fw:preferences:add-callback 'external-browser enable-button) callbacks))) (send d show #t) (map (lambda (f) (f)) callbacks) ok?))) (define panel-installed? #f) (define prefs-panel #f) (define synchronized? #f) (define additions null) (define (install-help-browser-preference-panel) (unless panel-installed? (set! panel-installed? #t) (make-help-browser-preference-panel #t #t (lambda (f) (fw:preferences:add-panel (string-constant browser) (lambda (parent) (let-values ([(panel cbs) (f parent)]) (set! prefs-panel panel) (map (lambda (f) (f panel)) additions) (set! additions null) panel))))))) (define (add-to-browser-prefs-panel proc) (if prefs-panel (proc prefs-panel) (set! additions (append additions (list proc))))) (define (make-help-browser-preference-panel set-help? ask-later? mk) (mk (lambda (parent) (define callbacks null) (let ([pref-panel (instantiate vertical-panel% () [parent parent] [alignment '(left center)])]) ;; -------------------- external browser for Unix -------------------- (when (unix-browser?) (unless synchronized? ;; Keep 'external-browser in sync (fw:preferences:add-callback 'external-browser (lambda (name browser) (try-put-preferences (list 'external-browser) (list browser))))) (letrec ([v-panel (instantiate group-box-panel% () (parent pref-panel) (alignment '(right center)) (stretchable-height #f) (label (string-constant external-browser-choice-title)))] [h-panel (instantiate horizontal-panel% () (parent v-panel) (alignment '(center bottom)))] [none-index (length raw:unix-browser-list)] [custom-index (add1 none-index)] [r (instantiate radio-box% () (label #f) (choices (append unix-browser-names (list (string-constant no-browser) (string-constant browser-command-line-label)))) (parent h-panel) (callback (lambda (radio event) (let ([n (send radio get-selection)]) (set-browser! (cond [(= n none-index) #f] [(= n custom-index) (get-custom)] [else (list-ref raw:unix-browser-list n)]))))))] [select-custom (lambda (_ __) (send r set-selection custom-index) (set-browser! (get-custom)))] [get-custom (lambda () (cons (send pre get-value) (send post get-value)))] [template-panel (instantiate horizontal-panel% (h-panel) (spacing 0) (stretchable-height #f))] [pre (instantiate text-field% () (label #f) (parent template-panel) (callback select-custom) (horiz-margin 0))] [mess (instantiate message% () (label "") (parent template-panel) (horiz-margin 0))] [post (instantiate text-field% () (label #f) (parent template-panel) (callback select-custom) (horiz-margin 0))] [note1 (instantiate message% ((string-constant browser-cmdline-expl-line-1) v-panel))] [note2 (instantiate message% ((string-constant browser-cmdline-expl-line-2) v-panel))] [refresh-controls (lambda (pref) (if (pair? pref) (begin (send r set-selection custom-index) (send pre set-value (car pref)) (send post set-value (cdr pref))) (let init ([x raw:unix-browser-list] [n 0]) (cond [(null? x) (send r set-selection n)] [else (if (eq? pref (car x)) (send r set-selection n) (init (cdr x) (add1 n)))]))))]) (unless ask-later? (send r enable none-index #f)) (refresh-controls (fw:preferences:get 'external-browser)) (set! callbacks (cons (fw:preferences:add-callback 'external-browser (lambda (name browser) (refresh-controls browser))) callbacks)))) ;; -------------------- proxy for doc downloads -------------------- (when set-help? (letrec ([p (instantiate group-box-panel% () [label (string-constant http-proxy)] [parent pref-panel] [stretchable-height #f] [alignment '(left top)])] [rb (make-object radio-box% #f (list (string-constant proxy-direct-connection) (string-constant proxy-use-proxy)) p (lambda (r e) (let ([proxy? (= 1 (send r get-selection))]) (send proxy-spec enable proxy?) (if proxy? (update-proxy) (fw:preferences:set http-proxy-preference #f)))))] [proxy-spec (instantiate horizontal-panel% (p) [stretchable-width #f] [stretchable-height #f] [alignment '(left center)])] [update-proxy (lambda () (let ([host (send host get-value)] [port (send port get-value)]) (let ([ok? (and (regexp-match? #rx"^[-0-9a-zA-Z.]+$" host) (regexp-match? #rx"^[0-9]+$" port) (string->number port) (<= 1 (string->number port) 65535))]) (when ok? (fw:preferences:set http-proxy-preference (list "http" host (string->number port)))) (send bad-host show (not ok?)))))] [host (make-object text-field% (string-constant proxy-host) proxy-spec (lambda (x y) (update-proxy)) "www.someplacethatisaproxy.domain.com")] [port (make-object text-field% (string-constant proxy-port) proxy-spec (lambda (x y) (update-proxy)) "65535")] [bad-host (make-object message% (string-constant proxy-bad-host) p)] [update-gui (lambda (proxy-val) (send bad-host show #f) (if proxy-val (begin (send rb set-selection 1) (send proxy-spec enable #t) (unless (string=? (cadr proxy-val) (send host get-value)) (send host set-value (cadr proxy-val))) (unless (equal? (caddr proxy-val) (string->number (send port get-value))) (send port set-value (number->string (caddr proxy-val))))) (begin (send rb set-selection 0) (send proxy-spec enable #f) (send host set-value "") (send port set-value ""))))]) (fw:preferences:add-callback http-proxy-preference (lambda (name val) (update-gui val))) (update-gui (fw:preferences:get http-proxy-preference)) (send bad-host show #f))) (set! synchronized? #t) (values pref-panel callbacks))))))