From f175148ca3d26e97d4b68df9f73d693a0ae74243 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 19 May 2017 15:18:10 -0500
Subject: [PATCH] attempt to fix the "cannot visit documentation because the
 anchors are dropped in the urls" problem

inspired by Greg's approach, as discussed here:

  http://www.greghendershott.com/2017/03/please-scroll.html
---
 pkgs/net-doc/net/scribblings/sendurl.scrbl | 14 ++++-
 pkgs/net-lib/net/sendurl.rkt               | 63 ++++++++++++++++++++--
 2 files changed, 72 insertions(+), 5 deletions(-)

diff --git a/pkgs/net-doc/net/scribblings/sendurl.scrbl b/pkgs/net-doc/net/scribblings/sendurl.scrbl
index a965176ae1..8b29ca792d 100644
--- a/pkgs/net-doc/net/scribblings/sendurl.scrbl
+++ b/pkgs/net-doc/net/scribblings/sendurl.scrbl
@@ -24,8 +24,7 @@ On Windows, @racket[send-url] normally uses @racket[shell-execute]
 to launch a browser. (If the URL appears to contain a fragment, it may
 use an intermediate redirecting file due to a bug in IE7.)
 
-On Mac OS, @racket[send-url] runs @exec{osascript} to start the
-user's chosen browser.
+On Mac OS, @racket[send-url] calls @racket[send-url/mac].
 
 On Unix, @racket[send-url] uses a user-preference, or when none is
 set, it will look for a known browser.  See the description of
@@ -87,6 +86,17 @@ above.}
  @racketblock[(send-url/mac "http://www.google.com/" #:browser "Firefox")]
  would open the url in Firefox, even if that's not the default browser.
  Passing @racket[#f] means to use the default browser.
+
+ This function looks in
+ @filepath{com.apple.launchservices.secure.plist} in the
+ user's home directory for a @tt{LSHandlerURLScheme} key for
+ either @tt{http} or @tt{https} and then, looks for a
+ @tt{LSHandlerRoleAll} key that is one of a list of known
+ browsers. If it finds such a browser, it uses the
+ AppleScript command @tt{tell
+  application ... to open location} to send the url to the
+ browser. Otherwise, it uses just @tt{open location} to send
+ the url to the browser.
 }
 
 @defparam[external-browser cmd browser-preference?]{
diff --git a/pkgs/net-lib/net/sendurl.rkt b/pkgs/net-lib/net/sendurl.rkt
index 740a578c6a..7d70586fb1 100644
--- a/pkgs/net-lib/net/sendurl.rkt
+++ b/pkgs/net-lib/net/sendurl.rkt
@@ -4,7 +4,7 @@
 #lang racket/base
 
 (require racket/system racket/file racket/promise racket/port
-         racket/contract racket/promise)
+         racket/contract racket/promise json)
 
 (provide send-url send-url/file send-url/contents
          unix-browser-list browser-preference? external-browser
@@ -158,13 +158,70 @@
     (send-url/file temp)))
 
 (define osascript (delay/sync (find-executable-path "osascript" #f)))
-(define (send-url/mac url #:browser [browser #f])
+(define (send-url/mac url #:browser [_browser #f])
+  (define browser
+    (or _browser
+        (try-to-find-macosx-users-browser)))
   (browser-run (force osascript) "-e"
                (if browser
-                   (format "tell application \"~a\" to open location \"~a\""
+                   (format "tell application \"~a\" to open location \"~a\" activate"
                            browser url)
                    (format "open location \"~a\"" url))))
 
+(define (try-to-find-macosx-users-browser)
+  (define default-browser (hash-ref known-uri->macosx-browser-app "com.apple.safari"))
+  (let/ec k
+    (define (fail fmt . more)
+      (log-warning (string-append
+                    "tried to find user's browser choice, but: "
+                    (apply format fmt more)))
+      (k default-browser))
+    (define plist-file
+      (build-path (find-system-path 'home-dir)
+                  "Library" "Preferences"
+                  "com.apple.LaunchServices"
+                  "com.apple.launchservices.secure.plist"))
+    (unless (file-exists? plist-file) (fail "didn't find plist file"))
+    (define plutil (find-executable-path "plutil" #f))
+    (unless plutil (fail "didn't find plutil"))
+    (define-values (in out) (make-pipe))
+    (thread
+     (λ ()
+       (define-values (_1 _2 _3 _4 proc)
+         (apply
+          values
+          (process*/ports
+           out
+           (open-input-string "")
+           (current-error-port)
+           plutil
+           "-convert" "json"
+           "-o" "-"
+           plist-file)))
+       (proc 'wait)
+       (close-output-port out)))
+    (define json
+      (with-handlers ([exn:fail? (λ (exn) (fail (exn-message exn)))])
+        (read-json in)))
+    (define handlers (hash-ref json 'LSHandlers (λ () (fail "didn't find LSHandlers key in json"))))
+    (unless ((listof hash?) handlers) (fail "confusing LSHandlers ~s" handlers))
+    (define uri
+      (for/or ([table (in-list (hash-ref json 'LSHandlers))]
+               #:when
+               (member (hash-ref table 'LSHandlerURLScheme #f) '("http" "https")))
+        (hash-ref table 'LSHandlerRoleAll #f)))
+    (cond
+      [uri (hash-ref known-uri->macosx-browser-app uri #f)]
+      [else
+       ;; no preference set
+       default-browser])))
+
+(define known-uri->macosx-browser-app
+  (hash "com.google.chrome" "Google Chrome"
+        "com.apple.safari" "Safari"
+        "org.mozilla.firefox" "Firefox"
+        "com.operasoftware.opera" "Opera"))
+
 (define (send-url/unix url separate-window?)
   ;; in cases where a browser was uninstalled, we might get a preference that
   ;; is no longer valid, this will turn it back to #f