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

this stumped me for quite a minute. this procedure sometimes needs to
halt execution to get input, like a server requesting input, or the
client asking for permission to follow cross site redirects. the
problem is if the get procedure is thought of as being part of the net
interface, and compartmentalized from the program loop, actually doing
that would require heavy use of continuations to go back and forth
across the boundary

i -do- think that the way i ultimately want to go in the end is using
continuations to halt execution, catch it in the user interface to get
input, and then continue. however, its a lot simpler and more
immediate to change where i'm drawing the line in the separation of
concerns. the continuations-based approach is enough of a diversion
that i haven't managed to get anything done for the last couple of hours.

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,95 +1,68 @@
+#! /usr/bin/env /usr/local/bin/racket
 #lang racket
 
-(require openssl)
-(require net/url)
-
-(define (request url-str)
-  (define url (string->url url-str))
-  (define-values (c-in c-out)
-    (ssl-connect (url-host url)
-                 (or (url-port url) 1965)))
-
-  (write-string url-str c-out)
-  (write-string "\r\n" c-out)
-
-  (define-values (status header)
-    (read-response c-in))
-
-  (println status)
-  (println header))
-
-(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")
-
-        (let ([header (read-line c-in 'return-linefeed)])
-          (define-values (status meta)
-            (let ([status-meta (string-split header " ")])
-              (values (car status-meta)
-                      (string-join (cdr status-meta)))))
-
-          (cond
-            [(> (string-length status) 2)
-             (error "status code exceeds maximum length")]
-
-            [(andmap (compose not char-numeric?) (string->list status))
-             (error "status code is not numeric")]
-
-            [else
-             (values (string->number status) meta)])))))
-
-;; takes one long string and reflows it within an 80 character wide
-;; column
-(define (render-paragraph paragraph)
-  ;; collects from one list of words into another such that the new
-  ;; list does not exceed 80 characters when joined, and returns the
-  ;; new list and remainder of the first list
-  (define (inner-iter acc rst)
-    (let ([line (string-join acc)])
-      (if (or (empty? rst)
-              (> (string-length line) 80))
-          (values acc rst)
-          (inner-iter (append acc (list (car rst)))
-                      (cdr rst)))))
-
-  ;; collects from a list of words into sublists of words such that
-  ;; each sublist is no greater than 80 characters when joined
-  (define (outer-iter acc rst)
-    (if (empty? rst)
-        acc
-        (let-values ([(inner-acc inner-rst)
-                      (inner-iter (list) rst)])
-          (outer-iter (append acc (list inner-acc)) inner-rst))))
-
-  ;; join each sublist into one string, and display one string per
-  ;; line
-  (for-each displayln
-   (map string-join (outer-iter (list) (string-split paragraph)))))
-
-(define commands
-  (list
-   (cons "default" (lambda (line) (void)))
-   (cons "go" (lambda (line)
-                (request line)))))
-
-(define (dispatch-command line)
-  (let ([split (string-split line " ")])
-
-    (let ([cmd (assoc (cond [(null? split) "default"]
-                            [else (first split)])
-                      commands)])
-      (if cmd
-          ((cdr cmd) (string-join (cdr split)))
-          (displayln "no such command")))))
+(require (prefix-in net: "net.rkt")
+         (prefix-in client: "client.rkt"))
 
+(define client (new client:client%))
 
 (define (repl)
-  (display "G300> ")
-  (dispatch-command (read-line))
+  (display "G-300 > ")
+
+  (flush-output)
+
+  (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)))])
+
+    (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

@@ -0,0 +1,161 @@
+#lang racket
+
+(provide (contract-out
+          [render (-> document? void?)]
+          [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))
+
+(struct text (line))
+(struct link (url line id))
+(struct pre (lines))
+
+;;;
+;;; PARSING
+;;;
+
+(define (parse-url line link-#)
+  (let ([split (string-split (substring line 2))])
+    (if (empty? split)
+        (text line)
+        (link (string->url (car split))
+              (if (>= (length split) 2)
+                  (string-join (cdr split))
+                  (car split))
+              link-#))))
+
+(define (parse body-port)
+  (define (iter document lines state link-id)
+    ;; when there are no more lines, we have finished parsing.
+    (if (empty? lines)
+        ;; consing inherently makes everything backwards
+        (reverse document)
+
+        ;; otherwise, we have a state machine to traverse.
+        (cond
+          ;; turn off preformatted mode
+          [(and (symbol=? 'preformatted state)
+                (or (empty? (cdr lines))
+                    (string-prefix? (car lines) "```")))
+
+           ;; also hard to follow. at this point:
+           ;; 1. the car of the document is necessarily a preformatted block
+           ;;    and the contents of that block are backwards
+           ;; 2. take those contents, reverse them, append them to the
+           ;; cdr of the document
+           (iter (cons (pre (reverse (pre-lines (car document))))
+                       (cdr document))
+                 (cdr lines)
+                 'normal
+                 link-id)]
+
+          ;; add line to most recent preformat block
+          [(symbol=? 'preformatted state)
+           ;; little bit hard to follow: take the existing
+           ;; preformatted blocks content, cons the new line;
+           ;; then, cons the new preformatted block to the cdr of
+           ;; the document
+           (iter (cons (pre (cons (car lines)
+                                  (pre-lines (car document))))
+                       (cdr document))
+                 (cdr lines)
+                 'preformatted
+                 link-id)]
+
+          ;; rest of this is normal mode
+
+          ;; link lines
+          [(string-prefix? (car lines) "=>")
+           (let ([parsed (parse-url (car lines) link-id)])
+                 (iter (cons parsed document)
+                       (cdr lines)
+                       'normal
+                       (if (link? parsed)
+                           (add1 link-id)
+                           link-id)))]
+
+          ;; preformatting toggle lines
+          [(string-prefix? (car lines) "```")
+           ;; add preformatted block to document and toggle mode
+           (iter (cons (pre (list)) document)
+                 (cdr lines)
+                 'preformatted
+                 link-id)]
+
+          [else
+           (iter (cons (text (car lines))
+                       document)
+                 (cdr lines)
+                 'normal
+                 link-id)])))
+
+  (document (iter (list) (port->lines body-port) 'normal 1)))
+
+;;;
+;;; RENDERING
+;;;
+
+;; takes one long string and reflows it within an 80 character wide
+;; column
+(define (render-paragraph paragraph)
+  ;; collects from one list of words into another such that the new
+  ;; list does not exceed 80 characters when joined, and returns the
+  ;; new list and remainder of the first list
+  (define (inner-iter acc rst)
+    (let ([line (string-join acc)])
+      (if (or (empty? rst)
+              (> (string-length line) 40))
+          (values acc rst)
+          (inner-iter (append acc (list (car rst)))
+                      (cdr rst)))))
+
+  ;; collects from a list of words into sublists of words such that
+  ;; each sublist is no greater than 80 characters when joined
+  (define (outer-iter acc rst)
+    (if (empty? rst)
+        acc
+        (let-values ([(inner-acc inner-rst)
+                      (inner-iter (list) rst)])
+          (outer-iter (append acc (list inner-acc)) inner-rst))))
+
+  ;; the algorithm implemented here does not work for empty
+  ;; paragraphs. thus, they are handled as a special case here.
+  (if (non-empty-string? paragraph)
+      ;; join each sublist into one string, and display one string per
+      ;; line
+      (for-each displayln
+                (map string-join (outer-iter (list) (string-split paragraph))))
+      (newline)))
+
+;; given a document, which is a list of structs, render it out into
+;; the current output port exactly as it will be shown to the user
+(define (render document)
+  (for-each
+   (λ (item)
+     (cond
+       [(text? item)
+        (render-paragraph (text-line item))]
+
+       [(pre? item)
+        (for-each displayln (pre-lines item))]
+
+       [(link? 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)
+  (let ([link (findf (λ (link) (= (link-id link) id))
+                     (filter link? (document-items document)))])
+    (if link (link-url link) #f)))

net.rkt

@@ -0,0 +1,69 @@
+#lang racket
+
+(provide (contract-out
+          [request (-> url? (values integer? string? input-port?))])
+         (struct-out exn:fail:response))
+
+(require openssl)
+(require net/url-string)
+
+;; 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->string url) c-out)
+  (write-string "\r\n" c-out)
+
+  (define-values (status header)
+    (read-response c-in))
+
+  (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"))
+        (raise-response-error 'read-response
+                              "header exceeds maximum length"
+                              header)
+
+        (let ([header (read-line c-in 'return-linefeed)])
+          (define-values (status meta)
+            (let ([status-meta (string-split header " ")])
+              (values (car status-meta)
+                      (string-join (cdr status-meta)))))
+
+          (cond
+            [(> (string-length status) 2)
+             (raise-response-error 'read-response
+                                   "status code exceeds maximum length"
+                                   header)]
+
+
+            [(andmap (compose not char-numeric?) (string->list status))
+             (raise-response-error 'read-response
+                                   "status code not numeric"
+                                   header)]
+
+            [else
+             (values (string->number status) meta)])))))