next-cmd should only be called by get-document at the end of 20 status

client.rkt

@@ -0,0 +1,279 @@
+#lang racket
+
+(provide client%)
+
+(require (prefix-in net: "net.rkt")
+         (prefix-in gmi: "gmi.rkt")
+         (prefix-in txt: "txt.rkt"))
+
+(require net/url-string)
+
+(define temporary-failures
+  '((40 . "temporary failure")
+    (41 . "server unavailable")
+    (42 . "CGI error")
+    (43 . "proxy error")
+    (44 . "slow down")))
+
+(define permanent-failures
+  '((50 . "permanent failure")
+    (51 . "not found")
+    (52 . "gone")
+    (53 . "proxy request refused")
+    (59 . "bad request")))
+
+;;; CLIENT
+
+(define client%
+  (class object%
+    (define document-object '())
+    (define document-buffer '())
+    (define history '())
+
+    (super-new)
+
+    ;;;
+    ;;; client commands
+    ;;;
+
+    ;; 'go <url>' to go to a specific page
+    (define/public (go-cmd destination-string)
+      ;; the 'go' command is the only command with any sort of URL
+      ;; processing that isn't strictly RFC3986. Specifically, the
+      ;; user MAY omit the scheme. Rackets 'url' module will interpret
+      ;; the domain as part of the path in lieu of a scheme, and
+      ;; performing this operation on an existing url struct is
+      ;; non-trivial.
+      (when (not (string-contains? destination-string "://"))
+        (set! destination-string
+              (string-append "gemini://" destination-string)))
+
+      (get-document (string->url destination-string)))
+
+    ;; 'next' to display the next page
+    (define/public (next-cmd)
+      (when (null? document-buffer)
+        (raise-user-error
+         'next-cmd
+         "there is currently no visited document"))
+
+      ;; displays remaining buffer content, maximum of 10 lines.
+      (define (iter depth)
+        (when (and (> depth 0)
+                   (> (pipe-content-length document-buffer) 0))
+          (let ()
+            (displayln (read-line document-buffer))
+            (iter (sub1 depth)))))
+
+      (let ()
+        (iter 10)
+        (newline)
+        (let ([remaining (pipe-content-length document-buffer)])
+          (printf "~a bytes remaining\n" remaining))))
+
+    ;; 'visit {n}' to visit a link in the page
+    (define/public (visit-cmd id)
+      (when (not (gmi:document? document-object))
+        (raise-user-error
+         'visit-cmd
+         "currently visited document is not a gemini document"))
+
+      (get-document
+       (gmi:match-link document-object id)))
+
+    ;; 'url [n]' to get current url or links url
+    (define/public (url-cmd (id #f))
+      (if id
+          (if (gmi:document? document-object)
+              (displayln (url->string
+                          (absolutise-url
+                           (gmi:match-link document-object id))))
+              (raise-user-error
+               'url-cmd
+               "currently visited document is not a gemini document"))
+          (displayln (url->string (car history)))))
+
+    ;; 'back' to go back one in history
+    (define/public (back-cmd)
+      (when (< (length history) 2)
+        (raise-user-error
+         'back-cmd
+         "cannot go any further back in history!"))
+
+      ;; drop current page
+      (set! history (cdr history))
+      (let ([visiting (car history)])
+        ;; drop the page before that, too, since get-document will add
+        ;; it
+        (set! history (cdr history))
+
+        (get-document visiting)))
+
+    ;; 'up' to go up one directory
+    (define/public (up-cmd)
+      (when (null? history)
+        (error 'no-where))
+
+      (when (string=?  (path->string
+                        (simplify-path
+                         (url->path (car history))))
+                       "/")
+
+        (error 'at-root))
+
+      (let ([parent
+             (simplify-path
+              (build-path (url->path (car history)) 'up)
+              #f)])
+        (get-document
+         (struct-copy url (car history)
+                      [path (url-path (path->url parent))]))))
+
+    ;;;
+    ;;; MIME handling
+    ;;;
+
+    (define/private (mime/handle parse render body-port)
+      (set! document-object (parse body-port))
+
+      (let-values ([(input output) (make-pipe #f)])
+        (parameterize ([current-output-port output])
+          (gmi:render document-object))
+
+        (set! document-buffer input)))
+
+    (define/private (mime/handle-gmi body-port)
+      (mime/handle gmi:parse gmi:render body-port))
+
+    (define/private (mime/handle-txt body-port)
+      (mime/handle txt:parse txt:render body-port))
+
+    ;;;
+    ;;; document fetching
+    ;;;
+
+    (define/private (absolutise-url partial)
+      (combine-url/relative (car history)
+                            (url->string partial)))
+
+    (define/public (get-document destination (redirect-depth 0))
+      ;; handle urls which are relative to currently visited document
+      (when (not (null? history))
+        (set! destination (absolutise-url destination)))
+
+      (when (not (string=? (url-scheme destination) "gemini"))
+        (raise-user-error
+         'get-document
+         (string-append "unsupported scheme: ~a~n"
+                        "  url: ~a~n")
+         (url-scheme destination)
+         (url->string destination)))
+
+      (define-values (status meta body-port)
+        (net:request destination))
+
+      ;; if net:request does not raise an exception, then status
+      ;; meta and body-port are necessarily valid
+      (cond
+        ;; clients MUST reject status codes outside of the 10-69
+        ;; range
+        [(or (< status 10) (> status 69))
+         (raise-user-error
+          'get-document
+          (string-append "server returned out of range status: ~a~n"
+                         "  valid range: [10, 69]~a~n"
+                         "  url: ~a~n")
+          status (url->string destination))]
+
+        ;;
+        ;; 10-19 INPUT REQUIRED
+        ;;
+        [(and (>= status 10) (<= status 19))
+         (displayln "input requested")
+         (display "? ")
+         (flush-output)
+
+         (get-document
+          (struct-copy
+           url
+           destination
+           [query `((,(string->symbol
+                       (read-line (current-input-port)
+                                  'any)) . #f))]))]
+
+        ;;
+        ;; 20-29 SUCCESS
+        ;;
+        [(and (>= status 20) (<= status 29))
+         ;; SUCCESS only has a single defined status in this
+         ;; group. All actions are necessarily default
+
+         ;; This client does not use the lang MIME parameter for
+         ;; anything.
+         (match (car (string-split meta ";"))
+           ["text/gemini" (mime/handle-gmi body-port)]
+           ["text/plaintext" (mime/handle-txt body-port)]
+           [else
+            (raise-user-error
+             'get-document
+             (string-append "unsupported mime ~a~n"
+                            "  url: ~a~n")
+             meta (url->string destination))])
+
+         ;; If the document failed to be fetched (parser error,
+         ;; unsupported mime, so on and so forth) this would not
+         ;; ever be reached.
+         (set! history (cons destination history))
+         (next-cmd)]
+
+        ;;
+        ;; 30-39 REDIRECT
+        ;;
+        [(and (>= status 30) (<= status 39))
+         (if (> redirect-depth 5)
+             (raise-user-error
+              'get-document
+              (string-append "maximum redirect depth exceeded. "
+                             "bailing"))
+             (get-document (string->url meta)
+                           (add1 redirect-depth)))]
+
+        ;;
+        ;; 40-49 TEMPORARY FAILURE
+        ;;
+        [(and (>= status 40) (<= status 49))
+         (raise-user-error
+          'get-document
+          (string-append "server reports temporary failure: ~a~n"
+                         "  url: ~a~n"
+                         "  explanation: ~a~n")
+          status
+          (url->string destination)
+          (dict-ref temporary-failures
+                    status
+                    "temporary failure"))]
+
+        ;;
+        ;; 50-59 PERMANENT FAILURE
+        ;;
+        [(and (>= status 50) (<= status 59))
+         (raise-user-error
+          'get-document
+          (string-append "server reports permanent failure: ~a~n"
+                         "  url: ~a~n"
+                         "  explanation: ~a~n")
+          status
+          (url->string destination)
+          (dict-ref permanent-failures
+                    status
+                    "temporary failure"))]
+
+        ;;
+        ;; 60-69 CERTIFICATE REQUIRED
+        ;;
+        [(and (>= status 60) (<= status 69))
+         (raise-user-error
+          'get-document
+          (string-append "resource requires a client certificate, "
+                         "which this client does not yet support~a~n"
+                         "  url: ~a~n"))]))))

gem300.rkt

@@ -1,106 +1,68 @@
+#! /usr/bin/env /usr/local/bin/racket
 #lang racket
 
 (require (prefix-in net: "net.rkt")
-         (prefix-in gmi: "gmi.rkt"))
+         (prefix-in client: "client.rkt"))
 
-(require net/url-string)
-
-;; global state variable which will be an input port containing the
-;; rendered out gemtext document as it shall be shown to the user
-(define document-buffer null)
-
-;; global state which will be the document structure, before rendering
-(define document null)
-
-;; global state for the url of the currently visited document
-(define current-url null)
-
-(define (get url-str)
-  (define (iter url-str depth)
-    (let-values ([(status header c-in) (net:request url-str)])
-      ;; TODO there are bunch of other status codes to deal with for
-      ;; compliance
-      (cond
-        ;; clients MUST reject status codes outside of the 10-69 range
-        [(or (< status 10)
-             (> status 69))
-         (error "server returned invalid status code")]
-
-        ;; 30-39 redirection
-        [(and (>= status 30)
-              (<= status 39))
-         (if (> depth 5)
-             (error "maximum redirection depth exceeded")
-             (iter header (sub1 depth)))]
-
-        [else
-         (values status header c-in)])))
-
-     (iter url-str 5))
-
-(define (go-cmd url)
-  (if (non-empty-string? url)
-      (let ()
-        (when (not (string-contains? url "://"))
-          (set! url (string-append "gemini://" url)))
-
-        (let-values ([(status meta c-in) (get url)])
-          (let-values ([(doc) (gmi:parse (port->lines c-in))]
-                       [(db-in db-out) (make-pipe #f)])
-
-            (set! document doc)
-
-            (set! document-buffer db-in)
-            (parameterize ([current-output-port db-out])
-              (gmi:render doc))
-
-            (set! current-url url)
-
-            (let ([remaining (pipe-content-length db-in)])
-              (printf "document retrieved. ~a bytes\n" remaining))
-
-            (next-cmd))))
-
-      (displayln "go where?")))
-
-(define (next-cmd)
-  (define (iter depth)
-    (when (and (> depth 0)
-               (> (pipe-content-length document-buffer) 0))
-      (let ()
-        (displayln (read-line document-buffer))
-        (iter (sub1 depth)))))
-
-  (iter 10)
-  (newline)
-  (let ([remaining (pipe-content-length document-buffer)])
-    (printf "~a bytes remaining\n" remaining)))
-
-(define (visit-cmd line)
-  (define url (gmi:match-link document (string->number line)))
-  (set! url
-        (url->string (combine-url/relative (string->url current-url)
-                                           url)))
-  (go-cmd url))
+(define client (new client:client%))
 
 (define (repl)
   (display "G-300 > ")
 
-  (let ([matches (regexp-match #px"(\\w+)\\s*(.*)" (read-line))])
-    (cond
-      ;; next command. also default
-      [(or (not matches)
-           (string=? (cadr matches) "next")
-           (string=? (cadr matches) "n"))
-       (next-cmd)]
+  (flush-output)
 
-      ;; go command
-      [(or (string=? (cadr matches) "go")
-           (string=? (cadr matches) "g"))
-       (go-cmd (caddr matches))]
+  (with-handlers
+    ([(or/c exn:fail:user?
+            ;; todo: catch these errors separately and reformat them
+            ;; in a user-y way
+            exn:fail:network?
+            net:exn:fail:response?)
+      (λ (exn)
+        (displayln (exn-message exn)))])
 
-      ;; visit link command
-      [(andmap char-numeric? (string->list (cadr matches)))
-       (visit-cmd (cadr matches))]))
+    (match (regexp-match #px"(\\w+)\\s*(.*)"
+                         (read-line (current-input-port) 'any))
+      [(or (list _ "go" url)
+           (list _ "g" url))
+       (send client go-cmd url)]
+
+      [(or (list _ "visit" id)
+           (list _ "v" id))
+       (send client visit-cmd (string->number id))]
+
+      [(or (list _ "next" _)
+           (list _ "n" _))
+       (send client next-cmd)]
+
+      [(or (list _ "url" id)
+           (list _ "u" id))
+       (send client url-cmd (string->number id))]
+
+      [(or (list _ "url")
+           (list _ "u"))
+       (send client url-cmd)]
+
+      [(list _ "up" _)
+       (send client up-cmd)]
+
+      [(or (list _ "back" _)
+           (list _ "b" _))
+       (send client back-cmd)]
+
+      [(or (list _ "quit" _)
+           (list _ "q" _ ))
+       (exit)]
+
+      [else
+       (displayln "no such command")]))
 
   (repl))
+
+(displayln
+ (string-append "welcome to gem300, a gemini client.\n"
+                "to learn more, type:\n"
+                "'go w6vvn.flounder.online/gem300/tutorial.gmi'"))
+
+(flush-output)
+
+(repl)

gmi.rkt

@@ -2,10 +2,12 @@
 
 (provide (contract-out
           [render (-> document? void?)]
-          [parse (-> (listof string?) document?)]
-          [match-link (-> document? integer? (or/c string? #f))]
+          [parse (-> input-port? document?)]
+          [match-link (-> document? integer? (or/c url? #f))]
           [struct document ((items (listof (or/c text? link? pre?))))]))
 
+(require net/url-string)
+
 ;; a gemtext document is represented as a list of structs, a struct
 ;; for each type of item in a document.
 (struct document (items))
@@ -22,13 +24,13 @@
   (let ([split (string-split (substring line 2))])
     (if (empty? split)
         (text line)
-        (link (car split)
+        (link (string->url (car split))
               (if (>= (length split) 2)
                   (string-join (cdr split))
                   (car split))
               link-#))))
 
-(define (parse lines)
+(define (parse body-port)
   (define (iter document lines state link-id)
     ;; when there are no more lines, we have finished parsing.
     (if (empty? lines)
@@ -93,7 +95,7 @@
                  'normal
                  link-id)])))
 
-  (document (iter (list) lines 'normal 1)))
+  (document (iter (list) (port->lines body-port) 'normal 1)))
 
 ;;;
 ;;; RENDERING
@@ -108,7 +110,7 @@
   (define (inner-iter acc rst)
     (let ([line (string-join acc)])
       (if (or (empty? rst)
-              (> (string-length line) 80))
+              (> (string-length line) 40))
           (values acc rst)
           (inner-iter (append acc (list (car rst)))
                       (cdr rst)))))
@@ -144,21 +146,16 @@
         (for-each displayln (pre-lines item))]
 
        [(link? item)
-        (printf "[~a] ~a\n" (link-id item) (link-line item))]))
+        (render-paragraph
+         (let ([scheme (url-scheme (link-url item))])
+           (if (or (not scheme)
+                   (string=? scheme "gemini"))
+               (format "[~a] ~a\n" (link-id item) (link-line item))
+               (format "[~a ~a] ~a\n" (link-id item) scheme (link-line item)))))]))
 
    (document-items document)))
 
 (define (match-link document id)
-  (define (iter next-structure)
-    (cond
-      [(and (link? (car next-structure))
-            (= (link-id (car next-structure)) id))
-       (link-url (car next-structure))]
-
-      [(empty? (cdr next-structure))
-       #f]
-
-      [else
-       (iter (cdr next-structure))]))
-
-  (iter (document-items document)))
+  (let ([link (findf (λ (link) (= (link-id link) id))
+                     (filter link? (document-items document)))])
+    (if link (link-url link) #f)))

net.rkt

@@ -1,21 +1,20 @@
 #lang racket
 
-(provide request)
+(provide (contract-out
+          [request (-> url? (values integer? string? input-port?))])
+         (struct-out exn:fail:response))
 
 (require openssl)
 (require net/url-string)
 
-;; sends a request to a gemini server, and returns the status, header,
-;; and the input port for the rest of the body.
-;; this procedure will fail if the response is malformed, however, it
-;; is not up to it to validate the contents of the response.
-(define (request url-str)
-  (define url (string->url url-str))
+;; ssl-connect may raise (by way of tcp-connect) exn:fail:network
+;; read-response may raise exn:fail:network:gemini
+(define (request url)
   (define-values (c-in c-out)
     (ssl-connect (url-host url)
                  (or (url-port url) 1965)))
 
-  (write-string url-str c-out)
+  (write-string (url->string url) c-out)
   (write-string "\r\n" c-out)
 
   (define-values (status header)
@@ -23,13 +22,30 @@
 
   (values status header c-in))
 
+(struct exn:fail:response exn:fail ()
+  #:extra-constructor-name make-exn:fail:response
+  #:transparent)
+
+(define (raise-response-error name message response)
+  (raise (make-exn:fail:response
+          (format (string-append "~a: ~a~n"
+                                 "  response: ~a")
+                  (symbol->string name)
+                  message
+                  (if (> (string-length response) 20)
+                      (format "~a... (truncated)" (substring response 0 20))
+                      response))
+          (current-continuation-marks))))
+
 (define (read-response (c-in (current-input-port)))
   (define maxlen 1027)
 
   (let ([header (peek-string maxlen 0 c-in)])
 
     (if (not (string-contains? header "\r\n"))
-        (error "header exceeds maximum length")
+        (raise-response-error 'read-response
+                              "header exceeds maximum length"
+                              header)
 
         (let ([header (read-line c-in 'return-linefeed)])
           (define-values (status meta)
@@ -39,10 +55,15 @@
 
           (cond
             [(> (string-length status) 2)
-             (error "status code exceeds maximum length")]
+             (raise-response-error 'read-response
+                                   "status code exceeds maximum length"
+                                   header)]
+
 
             [(andmap (compose not char-numeric?) (string->list status))
-             (error "status code is not numeric")]
+             (raise-response-error 'read-response
+                                   "status code not numeric"
+                                   header)]
 
             [else
              (values (string->number status) meta)])))))