implement repl for new client structure

client.rkt

@@ -3,7 +3,8 @@
 (provide client%)
 
 (require (prefix-in net: "net.rkt")
-         (prefix-in gmi: "gmi.rkt"))
+         (prefix-in gmi: "gmi.rkt")
+         (prefix-in txt: "txt.rkt"))
 
 (require net/url-string)
 
@@ -21,44 +22,42 @@
     (53 . "proxy request refused")
     (59 . "bad request")))
 
+;;; CLIENT
+
 (define client%
   (class object%
     (define document-object '())
     (define document-buffer '())
-    (define current-url '())
+    (define history '())
 
     (super-new)
 
-    (define/public (up-cmd)
-      (if (null? current-url)
+    ;;;
+    ;;; client commands
+    ;;;
 
-          (displayln "you need to 'go' somewhere first!")
+    ;; '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)))
 
-          (if (string=?  (path->string
-                          (simplify-path
-                           (url->path current-url)))
-                         "/")
-
-              (displayln "already at root!")
-
-              (let ([parent
-                     (simplify-path
-                      (build-path (url->path current-url) 'up)
-                      #f)])
-                (get (struct-copy url current-url
-                                  [path (url-path (path->url parent))]))))))
-
-    (define/public (go-cmd url-string)
-      (if (non-empty-string? url-string)
-          (let ()
-            (when (not (string-contains? url-string "://"))
-              (set! url-string (string-append "gemini://" url-string)))
-
-            (get (string->url url-string)))
-
-          (displayln "go where?")))
+      (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))
@@ -66,107 +65,212 @@
             (displayln (read-line document-buffer))
             (iter (sub1 depth)))))
 
-      (if (null? document-buffer)
-          (displayln "you need to 'go' somewhere first!")
-          (let ()
-            (iter 10)
-            (newline)
-            (let ([remaining (pipe-content-length document-buffer)])
-              (printf "~a bytes remaining\n" remaining)))))
+      (let ()
+        (iter 10)
+        (newline)
+        (let ([remaining (pipe-content-length document-buffer)])
+          (printf "~a bytes remaining\n" remaining))))
 
-    (define/public (visit-cmd line)
-      (if (null? document-object)
-          (displayln "you need to 'go' somewhere first!")
-          (let ([url (gmi:match-link document-object line)])
-            (get (combine-url/relative current-url (url->string url))))))
+    ;; '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"))
 
-    (define/public (url-cmd (link-id #f))
-      (if (null? document-object)
-          (displayln "you need to 'go' somewhere first!")
-          (if link-id
-              (let ([link (gmi:match-link document-object link-id)])
-                (if link
-                    (displayln (url->string link))
-                    (displayln "no link with that id")))
-              (displayln (url->string current-url)))))
+      (get-document
+       (gmi:match-link document-object id)))
 
-    (define/private (handle-gmi url c-in)
-      (let-values ([(doc) (gmi:parse (port->lines c-in))]
-                   [(db-in db-out) (make-pipe #f)])
+    ;; '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)))))
 
-        (set! document-object doc)
+    ;; '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!"))
 
-        (set! document-buffer db-in)
-        (parameterize ([current-output-port db-out])
-          (gmi:render doc))
+      ;; 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))
 
-        (set! current-url url)
+        (get-document visiting)))
 
-        (let ([remaining (pipe-content-length db-in)])
-          (printf "document retrieved. ~a bytes\n" remaining))
+    ;; 'up' to go up one directory
+    (define/public (up-cmd)
+      (when (null? history)
+        (error 'no-where))
 
-        (next-cmd)))
+      (when (string=?  (path->string
+                        (simplify-path
+                         (url->path (car history))))
+                       "/")
 
-    (define/private (get url)
-      (define (iter url depth)
-        (with-handlers
-          ([exn:fail:network?
-            (λ (exn)
-              (displayln (exn-message exn)))]
-             [net:exn:fail:response?
-              (λ (exn)
-                (displayln (exn-message exn)))])
+        (error 'at-root))
 
-            (let-values ([(status meta c-in) (net:request url)])
-              ;; 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))
-                 (displayln "WARNING: server returned invalid status code")]
+      (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))]))))
 
-                ;; 10-19 INPUT REQUIRED
-                [(and (>= status 10)
-                      (<= status 19))
-                 (display "input requested > ")
-                 (get (string-append url "?" (read-line)))]
+    ;;;
+    ;;; MIME handling
+    ;;;
 
-                ;; 20-29 SUCCESS
-                [(and (>= status 20)
-                      (<= status 29))
+    (define/private (mime/handle parse render body-port)
+      (set! document-object (parse body-port))
 
-                 (let ([mime (car (string-split meta ";"))])
-                   (cond
-                     [(string=? mime "text/gemini")
-                      (handle-gmi url c-in)]
-                     [else
-                      (printf "unsupported mime type: ~a~n" mime)]))]
+      (let-values ([(input output) (make-pipe #f)])
+        (parameterize ([current-output-port output])
+          (gmi:render document-object))
 
-                ;; 30-39 REDIRECT
-                [(and (>= status 30)
-                      (<= status 39))
-                 (if (> depth 5)
-                     (displayln "WARNING: maximum redirection depth exceeded")
-                     (iter (string->url meta) (sub1 depth)))]
+        (set! document-buffer input)))
 
-                ;; 40-49 TEMPORARY FAILURE
-                [(and (>= status 40)
-                      (<= status 49))
-                 (printf "status ~a: ~a\n" status
-                         (dict-ref temporary-failures status "temporary failure"))]
+    (define/private (mime/handle-gmi body-port)
+      (mime/handle gmi:parse gmi:render body-port))
 
-                ;; 50-59 PERMANENT FAILURE
-                [(and (>= status 50)
-                      (<= status 59))
-                 (printf "status ~a: ~a\n" status
-                         (dict-ref permanent-failures status "permanent failure"))]
+    (define/private (mime/handle-txt body-port)
+      (mime/handle txt:parse txt:render body-port))
 
-                ;; 60-69 CERTIFICATE REQUIRED
-                [(and (>= status 60)
-                      (<= status 69))
-                 (displayln "certificate handling not yet implemented")]))))
+    ;;;
+    ;;; document fetching
+    ;;;
 
-        (if (not (string=? (url-scheme url) "gemini"))
-            (printf "unsupported url: ~a~n" (url->string url))
-            (iter url 5)))))
+    (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) 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 "? ")
+
+         (get-document
+          (struct-copy
+           url
+           destination
+           [query `((,(string->symbol (read-line)) . #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 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))]
+
+        ;;
+        ;; 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
+          (string->url 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
+          (string->url 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"))])
+
+      (next-cmd)))

gem300.rkt

@@ -1,27 +1,51 @@
 #lang racket
 
-(require (prefix-in client: "client.rkt"))
+(require (prefix-in net: "net.rkt")
+         (prefix-in client: "client.rkt"))
 
 (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"))
+  (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))
+      [(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)]
 
-      ;; go command
-      [(or (string=? (cadr matches) "go")
-           (string=? (cadr matches) "g"))
-       (send client go-cmd (caddr matches))]
+      [(or (list _ "url" id)
+           (list _ "u" id))
+       (send client url-cmd (string->number id))]
 
-      ;; visit link command
-      [(andmap char-numeric? (string->list (cadr matches)))
-       (send client visit-cmd (cadr matches))]))
+      [(or (list _ "url")
+           (list _ "u"))
+       (send client url-cmd)]
+
+      [(list _ "up" _)
+       (send client up-cmd)]
+
+      [(or (list _ "back" _)
+           (list _ "b" _))
+       (send client back-cmd)]
+
+      [else
+       (displayln "no such command")]))
 
   (repl))

gmi.rkt

@@ -2,7 +2,7 @@
 
 (provide (contract-out
           [render (-> document? void?)]
-          [parse (-> (listof string?) document?)]
+          [parse (-> input-port? document?)]
           [match-link (-> document? integer? (or/c url? #f))]
           [struct document ((items (listof (or/c text? link? pre?))))]))
 
@@ -30,7 +30,7 @@
                   (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)
@@ -95,7 +95,7 @@
                  'normal
                  link-id)])))
 
-  (document (iter (list) lines 'normal 1)))
+  (document (iter (list) (port->lines body-port) 'normal 1)))
 
 ;;;
 ;;; RENDERING
@@ -156,16 +156,6 @@
    (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)))