9 files changed, 255 insertions(+), 17 deletions(-)

M multi-renderer.rkt
M multi-transport.rkt
A protocols/text-protocol.rkt
M renderers/feed-renderer.rkt
M renderers/gemini-renderer.rkt
M renderers/image-renderer.rkt
M renderers/markdown-renderer.rkt
A transports/text-transport.rkt
M window.rkt

@@ 6,6 6,7 @@
   "renderers/markdown-renderer.rkt"
   "renderers/image-renderer.rkt"
   "renderers/feed-renderer.rkt"
+  "config.rkt"
   "utils.rkt")
 
    


@@ 68,13 69,15 @@
       (for-each (lambda (r) (send r hide)) renderers)) ;; hide all children.
                                  
 
-    (define/public (get-renderer-for-mime mime [content #f])
+    (define/public (get-renderer-for-mime mime [content #f] [scheme "wrong"]) 
       (findf (lambda (r)
-               (send r can-handle-mime? mime content))
+               (when (debug-mode?)
+                  (printf "checking if ~a can handle schema '~a://' url with mime: '~a'~n" r scheme mime))
+               (send r can-handle-mime? mime content scheme))
              renderers))
 
-    (define/public (render mime content)
-      (define renderer (get-renderer-for-mime mime))
+    (define/public (render mime content scheme)
+      (define renderer (get-renderer-for-mime mime content scheme))
       (if (false? renderer)
           (on-error (format "Error: can't render mime: ~a" mime))
           (begin

@@ 5,6 5,7 @@
   "transports/gemini-transport.rkt"
   "transports/web-transport.rkt"
   "transports/mercury-transport.rkt"
+  "transports/text-transport.rkt"
   "utils.rkt")
  
    


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

@@ 0,0 1,173 @@
+#lang racket
+
+(require net/url
+         racket/tcp
+         racket/pretty
+         racket/struct)
+
+(define text-default-port 1961)
+
+(struct text-response (status meta body)
+  #:mutable 
+  #:methods gen:custom-write
+  [(define write-proc
+     (make-constructor-style-printer
+      (lambda (obj) 'text-response)
+      (lambda (obj) (list (text-response-status obj) (text-response-meta obj) (text-response-body obj)))))])
+
+(define (make-text-response status meta [body #f])
+  (text-response status meta body))
+
+(struct text-conn (host port in out) #:mutable)
+(define (make-text-conn) (text-conn #f #f #f #f))
+
+(define (text-conn-live? gc)
+  (define in (text-conn-in gc))
+  (define out (text-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 text-default-port)
+        url)
+      url))
+
+(define (ensure-text-protocol url)
+  (cond
+    ;; I don't think the case below can actually happen... 
+    [(false? (url-host url)) (error 'ensure-text-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-text-protocol (string->url url-as-string-with-protocol)))]
+    [(not (equal? (url-scheme url) "text")) (error 'ensure-text-protocol "can't request non-text protocol: ~a" (url-scheme url))]
+   
+    [else url]))
+
+(define (text-conn-open requested-url)
+  (define url ((compose1 ensure-default-port ensure-text-protocol string->url) requested-url))
+  (define-values (in out) (tcp-connect/enable-break (url-host url) (url-port url)))
+  (define gc (make-text-conn))
+  (set-text-conn-in! gc in)
+  (set-text-conn-out! gc out)
+  (set-text-conn-host! gc (url-host url))
+  (set-text-conn-port! gc (url-port url))
+  gc)
+
+(define (text-conn-close! gc)
+  (match-define (text-conn host port in out) gc)
+  (when out
+    (close-output-port out)
+    (set-text-conn-out! gc #f))
+  (when in
+    (close-input-port in)
+    (set-text-conn-in! gc #f)))
+
+(define (write-out out str)
+  (fprintf out "~a\r\n" str)
+  (flush-output out))
+
+(define (text-recv! gc)
+  (define-values (status meta) (text-conn-header! gc))
+  (text-response
+   status
+   meta
+   (text-conn-body! gc status meta)))
+
+(define (text-conn-header! gc)
+  (define header-line (read-line (text-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 (text-conn-body! gc status meta)
+  (cond
+    [(and (equal? status 20) (string-prefix? meta "text/plain")) (text-conn-body/parse-text! gc)]
+    [(and (equal? status 20) (string-prefix? meta "text/xml")) (text-conn-body/parse-binary! gc)]
+    [(and (equal? status 20) (string-prefix? meta "text/")) (text-conn-body/parse-generic! gc)]
+    [(and (equal? status 20) (string-prefix? meta "image/")) (text-conn-body/parse-binary! gc)]
+    [(equal? status 20) (text-conn-body/parse-binary! gc)] ;; Catch all for successful transfers. Just delegate to multi-renderer.
+    [else #f]))
+  
+
+(define (text-conn-body/parse-generic! gc)
+  (define (read-loop acc)
+    (define (read) (read-line (text-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 (text-conn-body/parse-binary! gc)
+  (port->bytes (text-conn-in gc)))
+
+(define (text-conn-body/parse-text! gc)
+  (define (read-loop acc)
+    (define (read) (read-line (text-conn-in gc) 'any))
+    (define line (read))
+    (if (not (eof-object? line))
+        (read-loop (cons (text-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 (text-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 (text-request url #:follow-redirects [fr #f] [how-many-redirects-so-far 0])
+  (when  (> how-many-redirects-so-far 4)
+    (error 'text-request "too many redirects"))
+  (define gc (text-conn-open url))
+  (write-out (text-conn-out gc) url)
+  (define response
+    (begin0
+      (text-recv! gc)
+      (text-conn-close! gc)))
+  (if (and (member (text-response-status response) (list 30)) fr)
+      (text-request (text-response-meta response) #:follow-redirects #t (add1 how-many-redirects-so-far))
+      response))
+
+(define (text-valid-status-code status)
+  (list? (member status '(20 30 40))))
+
+(define (gemtext->gemexpr str)
+  (map (lambda (l) (text-process-line l)) (string-split str "\n"))) 
+
+(provide
+ text-request
+ text-valid-status-code
+ ensure-text-protocol
+ gemtext->gemexpr)
+
+(provide (struct-out text-response))
+
+  

@@ 150,7 150,7 @@
       (render-html-to-text (feed->html content) text #t #f)
       (send pane show #t))
     
-    (define/public (can-handle-mime? mime content)
+    (define/public (can-handle-mime? mime content schema)
       (or
        (matches-mime "application/rss+xml" mime)
        (matches-mime "application/atom+xml" mime)

@@ 170,8 170,10 @@
       (display-gemtext content)
       (send pane show #t))
 
-    (define/public (can-handle-mime? mime content)
-      (matches-mime "text/gemini" mime))
+    (define/public (can-handle-mime? mime content schema)
+      (or 
+        (matches-mime "text/gemini" mime)
+        (and (equal? schema "text") (matches-mime "text/plain" mime))))
 
     ))
 

@@ 46,7 46,7 @@
       (send msg set-label img)
       (send pane show #t))
     
-    (define/public (can-handle-mime? mime content)
+    (define/public (can-handle-mime? mime content schema)
       (string-prefix? mime "image/"))
     
     ))

@@ 348,7 348,7 @@
       (send text hide-caret #t)
       (send pane show #t))
     
-    (define/public (can-handle-mime? mime content)
+    (define/public (can-handle-mime? mime content schema)
       (or (matches-mime "text/plain" mime) (matches-mime "text/markdown" mime)))))
 
 (provide markdown-renderer%)

@@ 0,0 1,48 @@
+#lang racket/gui
+
+(require
+  net/url
+  "../protocols/text-protocol.rkt"
+  "../utils.rkt")
+
+    
+   
+(define text-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) "text"))
+
+    (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 (text-request new-url #:follow-redirects #t))
+        (define status (text-response-status last-response))
+        (define meta (text-response-meta last-response))
+        (define body (text-response-body last-response))
+        (cond
+            [(equal? status 51) (on-error (format "Error: ~a not found" new-url))]
+            [(not (text-valid-status-code status)) (on-error (format "Error: invalid status code: ~a" status))]
+            [else (on-request-complete new-url
+                              meta
+                              body)])))))
+
+(provide text-transport%)

@@ 18,7 18,7 @@
 (define history-backward '())
 (define history-forward '())
 
-(struct tab (url mime content)
+(struct tab (url mime content scheme)
   #:methods gen:custom-write
   [(define write-proc
      (make-constructor-style-printer


@@ 80,7 80,7 @@
            (send this on-system-menu-char event)
            (send this on-traverse-char event))))
 
-   [label (format "Fafi (~a) is a Gemini Browser" program-version)]
+   [label (format "Fafi (~a) is a Smol Browser" program-version)]
    [width 900]
    [height 700]
    [x 100]


@@ 183,7 183,7 @@
   (send browser-tabs set-selection (sub1 (send browser-tabs get-number)))
   (when (not (false? url))
     (set! url (url->string (ensure-absolute-url url current-url (url-scheme (string->url current-url))))))
-  (set! tabs (append tabs (list (tab url #f #f))))
+  (set! tabs (append tabs (list (tab url #f #f (url-scheme (string->url current-url))))))
   (when (false? url)
     (send address-bar focus))
   (switch-tab (send browser-tabs get-selection)))


@@ 202,9 202,9 @@
       (send address-bar set-value (tab-url tab-n))
       (send address-bar set-value ""))
 
-  (cond [(not (false? (tab-content tab-n))) (send multi-renderer render (tab-mime tab-n) (tab-content tab-n))]
+  (cond [(not (false? (tab-content tab-n))) (send multi-renderer render (tab-mime tab-n) (tab-content tab-n) (tab-scheme tab-n))]
         [(not (false? (tab-url tab-n))) (send multi-transport fetch (tab-url tab-n))]
-        [else (send multi-renderer render "text/gemini" (new-tab-template))]))
+        [else (send multi-renderer render "text/gemini" (new-tab-template) "fafi")]))
 
 (define (close-tab n)
   (when (> (length tabs) 1)


@@ 228,10 228,11 @@
 (define (request-complete url mime content)
   (when (debug-mode?)
     (displayln (format "loaded ~a" url)))
+  (define scheme (url-scheme (string->url url)))
   (send address-bar set-value url)
   (send browser-tabs set-item-label (send browser-tabs get-selection) url)
 
-  (set! tabs (list-set tabs (send browser-tabs get-selection) (tab url mime content)))
+  (set! tabs (list-set tabs (send browser-tabs get-selection) (tab url mime content scheme)))
 
   (when (or (empty? history-backward) (not (equal? url (car history-backward))))
     (set! history-backward (cons url history-backward)))


@@ 239,7 240,11 @@
   (set! current-url url)
   (status-change (format "loaded: ~a mime: ~a" url mime))
 
-  (send multi-renderer render mime content))
+  (when (debug-mode?)
+    (printf "window looking for renderer for scheme: ~a~n" scheme))
+
+
+  (send multi-renderer render mime content scheme))
 
 (define (error-handler msg)
   (status-change "An error has happened.")


@@ 439,5 444,5 @@
     (send frame show #t)
     (send frame create-status-line)
     (send browser-tabs set-item-label 0 capsule)
-    (set! tabs (append tabs (list (tab capsule #f #f))))
+    (set! tabs (append tabs (list (tab capsule #f #f #f))))
     (send multi-transport fetch capsule)))