5 files changed, 240 insertions(+), 4 deletions(-)

M multi-transport.rkt
A protocols/mercury-protocol.rkt
M renderers/gemini-renderer.rkt
A transports/mercury-transport.rkt
M window.rkt

@@ 4,8 4,9 @@
   net/url
   "transports/gemini-transport.rkt"
   "transports/web-transport.rkt"
+  "transports/mercury-transport.rkt"
   "utils.rkt")
-
+ 
    
 (define multi-transport%
   (class object%


@@ 29,6 30,12 @@
        (new web-transport%
             [on-status-change on-status-change]
             [on-error on-error]
+            [on-request-complete on-request-complete])
+       ;; Mercury transport can handle mercury protocol
+       ;; Schemas: mercury://
+       (new mercury-transport%
+            [on-status-change on-status-change]
+            [on-error on-error]
             [on-request-complete on-request-complete])))
 
     (define/public (get-transport-for-url url)


@@ 40,7 47,10 @@
       (define transport (get-transport-for-url new-url))
       (if (false? transport)
           (on-error (format "no transport for: ~a" new-url))
-          (send transport fetch new-url current-url)))))
+          (with-handlers ([exn:fail? (lambda (v)
+                                             (print v)
+                                             (on-error (format "an error has happened: ~a" (exn-message v))))])
+            (send transport fetch new-url current-url))))))
 
   (provide multi-transport%)
   =
\ No newline at end of file

@@ 0,0 1,173 @@
+#lang racket
+
+(require net/url
+         racket/tcp
+         racket/pretty
+         racket/struct)
+
+(define mercury-default-port 1965)
+
+(struct mercury-response (status meta body)
+  #:mutable 
+  #:methods gen:custom-write
+  [(define write-proc
+     (make-constructor-style-printer
+      (lambda (obj) 'mercury-response)
+      (lambda (obj) (list (mercury-response-status obj) (mercury-response-meta obj) (mercury-response-body obj)))))])
+
+(define (make-mercury-response status meta [body #f])
+  (mercury-response status meta body))
+
+(struct mercury-conn (host port in out) #:mutable)
+(define (make-mercury-conn) (mercury-conn #f #f #f #f))
+
+(define (mercury-conn-live? gc)
+  (define in (mercury-conn-in gc))
+  (define out (mercury-conn-out gc))
+  (and in (port-closed? in)
+       out (port-closed? out)
+       #t))
+ 
+(define (ensure-default-port url)
+  (if (not (url-port url))
+      (begin
+        (set-url-port! url mercury-default-port)
+        url)
+      url))
+
+(define (ensure-mercury-protocol url)
+  (cond
+    ;; I don't think the case below can actually happen... 
+    [(false? (url-host url)) (error 'ensure-mercury-protocol "No host in url: ~a" (url->string url))]
+    ;; Below is a very complicated dance to prepend mercury:// if the URL contains no protocol.
+    [(false? (url-scheme url)) (let*
+                                   ([url-as-string (url->string url)]
+                                    [url-as-string-with-protocol (string-append "mercury://" url-as-string)])
+                                 (ensure-mercury-protocol (string->url url-as-string-with-protocol)))]
+    [(not (equal? (url-scheme url) "mercury")) (error 'ensure-mercury-protocol "can't request non-mercury protocol: ~a" (url-scheme url))]
+   
+    [else url]))
+
+(define (mercury-conn-open requested-url)
+  (define url ((compose1 ensure-default-port ensure-mercury-protocol string->url) requested-url))
+  (define-values (in out) (tcp-connect/enable-break (url-host url) (url-port url)))
+  (define gc (make-mercury-conn))
+  (set-mercury-conn-in! gc in)
+  (set-mercury-conn-out! gc out)
+  (set-mercury-conn-host! gc (url-host url))
+  (set-mercury-conn-port! gc (url-port url))
+  gc)
+
+(define (mercury-conn-close! gc)
+  (match-define (mercury-conn host port in out) gc)
+  (when out
+    (close-output-port out)
+    (set-mercury-conn-out! gc #f))
+  (when in
+    (close-input-port in)
+    (set-mercury-conn-in! gc #f)))
+
+(define (write-out out str)
+  (fprintf out "~a\r\n" str)
+  (flush-output out))
+
+(define (mercury-recv! gc)
+  (define-values (status meta) (mercury-conn-header! gc))
+  (mercury-response
+   status
+   meta
+   (mercury-conn-body! gc status meta)))
+
+(define (mercury-conn-header! gc)
+  (define header-line (read-line (mercury-conn-in gc) 'return-linefeed))
+  (define header-list (regexp-split #rx" +" header-line))
+  (values (string->number (car header-list)) (string-join (cdr header-list))))
+
+
+(define (mercury-conn-body! gc status meta)
+  (cond
+    [(and (equal? status 20) (string-prefix? meta "text/gemini")) (mercury-conn-body/parse-mercury! gc)]
+    [(and (equal? status 20) (string-prefix? meta "text/xml")) (mercury-conn-body/parse-binary! gc)]
+    [(and (equal? status 20) (string-prefix? meta "text/")) (mercury-conn-body/parse-generic! gc)]
+    [(and (equal? status 20) (string-prefix? meta "image/")) (mercury-conn-body/parse-binary! gc)]
+    [(equal? status 20) (mercury-conn-body/parse-binary! gc)] ;; Catch all for successful transfers. Just delegate to multi-renderer.
+    [else #f]))
+  
+
+(define (mercury-conn-body/parse-generic! gc)
+  (define (read-loop acc)
+    (define (read) (read-line (mercury-conn-in gc) 'any))
+    (define line (read))
+    (if (not (eof-object? line))
+        (read-loop (cons line acc))
+        (string-join (reverse acc) "\n")))
+  (read-loop '()))
+
+(define (mercury-conn-body/parse-binary! gc)
+  (port->bytes (mercury-conn-in gc)))
+
+(define (mercury-conn-body/parse-mercury! gc)
+  (define (read-loop acc)
+    (define (read) (read-line (mercury-conn-in gc) 'any))
+    (define line (read))
+    (if (not (eof-object? line))
+        (read-loop (cons (mercury-process-line line) acc))
+        (reverse acc)))
+  (read-loop '()))
+
+(define line-toggled #f) ;; I don't think this is thread-safe. Ideally, this can be a part of conn.
+
+(define (mercury-process-line line)
+  (define first-word (car (regexp-split #rx" " line)))
+  (define (link? w) (equal? w "=>"))
+  (define (heading? w) (and (> (string-length w) 0) (equal? (substring w 0 1) "#")))
+  (define (list? w) (equal? w "*"))
+  (define (toggle? w) (equal? w "```"))
+  (define (make-link line)
+    (define lst (string-split line))
+    `(link ,(cadr lst) ,(string-join (cddr lst))))
+  (define (make-heading line)
+    (define lst (string-split line))
+    `(heading ,(string-length (car lst)) ,(string-join (cdr lst))))
+  (define (make-list line)
+    (define lst (string-split line))
+    `(list ,(string-join (cdr lst))))
+  (cond
+    [(link? first-word) (make-link line)]
+    [(heading? first-word) (make-heading line)]
+    [(list? first-word) (make-list line)]
+    [(equal? line "") `(break)]
+    [(toggle? first-word) 
+     (begin
+       (set! line-toggled (not line-toggled))
+       `(preformatted ,line-toggled))]
+    [else `(text ,line)]))
+
+(define (mercury-request url #:follow-redirects [fr #f] [how-many-redirects-so-far 0])
+  (when  (> how-many-redirects-so-far 4)
+    (error 'mercury-request "too many redirects"))
+  (define gc (mercury-conn-open url))
+  (write-out (mercury-conn-out gc) url)
+  (define response
+    (begin0
+      (mercury-recv! gc)
+      (mercury-conn-close! gc)))
+  (if (and (member (mercury-response-status response) (list 30 31)) fr)
+      (mercury-request (mercury-response-meta response) #:follow-redirects #t (add1 how-many-redirects-so-far))
+      response))
+
+(define (mercury-valid-status-code status)
+  (list? (member status '(10 11 20 30 31 40 41 42 43 44 50 51 52 53 59 60 61 62))))
+
+(define (gemtext->gemexpr str)
+  (map (lambda (l) (mercury-process-line l)) (string-split str "\n"))) 
+
+(provide
+ mercury-request
+ mercury-valid-status-code
+ ensure-mercury-protocol
+ gemtext->gemexpr)
+
+(provide (struct-out mercury-response))
+
+  

@@ 3,6 3,7 @@
 (require
   "../styles.rkt"
   "../config.rkt"
+  "../persist.rkt"
   "../utils.rkt")
 
 


@@ 136,7 137,9 @@
 
                 (if (middle-clicked)
                     (on-request-new-tab link)
-                    (on-request-navigation link))
+                    (if (side-load? link)
+                        (on-request-new-tab link)
+                        (on-request-navigation link)))
                 hyperlink-clicked-style)
               )))
 

@@ 0,0 1,48 @@
+#lang racket/gui
+
+(require
+  net/url
+  "../protocols/mercury-protocol.rkt"
+  "../utils.rkt")
+
+    
+   
+(define mercury-transport%
+  (class object%
+    (super-new)
+        
+    (init-field
+     [on-status-change (void)]
+     [on-request-complete (void)]
+     [on-error (void)])
+
+    (define/public (can-handle-url? url)
+      (define u (string->url url))
+      (equal? (url-scheme u) "mercury"))
+
+    (define/public (fetch new-url [current-url #f])
+      (begin
+        (when (not (non-empty-string? new-url))
+          (error 'set-url "Can't load empty URL"))
+        (when (not (false? current-url))
+          (define new-url-url (string->url new-url))
+          (set! new-url (url->string
+                         (ensure-absolute-url
+                          new-url
+                          current-url
+                          (url-scheme new-url-url)))))
+          
+        (on-status-change (format "Requesting ~a" new-url))
+        
+        (define last-response (mercury-request new-url #:follow-redirects #t))
+        (define status (mercury-response-status last-response))
+        (define meta (mercury-response-meta last-response))
+        (define body (mercury-response-body last-response))
+        (cond
+            [(equal? status 51) (on-error (format "Error: ~a not found" new-url))]
+            [(not (mercury-valid-status-code status)) (on-error (format "Error: invalid status code: ~a" status))]
+            [else (on-request-complete new-url
+                              (mercury-response-meta last-response)
+                              (mercury-response-body last-response))])))))
+
+(provide mercury-transport%)

@@ 242,7 242,9 @@
   (send multi-renderer render mime content))
 
 (define (error-handler msg)
-  (message-box "Error" msg #f '(caution ok)))
+  (status-change "An error has happened.")
+  (message-box "Error" msg #f '(caution ok))
+  (status-change ""))
 
 (define (render-complete)
   (void))