From 4ea51c0ed54049b9f944a9b169f79c0e7771980e Mon Sep 17 00:00:00 2001 From: w6vvn Date: Sun, 7 Sep 2025 18:48:54 -0700 Subject: [PATCH] total overhaul of client implementation --- client.rkt | 287 ++++++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 239 insertions(+), 48 deletions(-) diff --git a/client.rkt b/client.rkt index b78bf00..8b680b1 100644 --- a/client.rkt +++ b/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,65 +22,255 @@ (53 . "proxy request refused") (59 . "bad request"))) -(struct exn:status:input-required exn () - #:extra-constructor-name make-exn:status:input-required - #:transparent) - -(struct exn:status:redirect exn () - #:extra-constructor-name make-exn:status:redirect - #:transparent) - -(struct exn:status:temporary-failure exn (errno) - #:extra-constructor-name make-exn:status:temporary-failure - #:transparent) - -(struct exn:status:permanent-failure exn (errno) - #:extra-constructor-name make-exn:status:permanent-failure - #:transparent) - -(struct exn:status:certificate-required exn () - #:extra-constructor-name make-exn:status:certificate-required - #:transparent) +;;; CLIENT (define client% (class object% (define document-object '()) (define document-buffer '()) - (define current-url '()) + (define history '()) (super-new) - (define/private (get-document url) - (with-handlers - ;; exceptions which may be raised by net:request - ([exn:fail:network? (λ (exn) (displayln (exn-message exn)))] - [net:exn:fail:response? (λ (exn) (displayln (exn-message exn)))]) + ;;; + ;;; client commands + ;;; - (let-values ([(status meta body-port) (net:request url)]) - (cond - ;; clients MUST reject status codes outside of the 10-69 range - [(or (< status 10) (> status 69)) - (void)] + ;; 'go ' 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))) - ;; 10-19 INPUT REQUIRED - [(and (>= status 10) (<= status 19)) - (void)] + (get-document (string->url destination-string))) - ;; 20-29 SUCCESS - [(and (>= status 20) (<= status 29)) - (void)] + ;; '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")) - ;; 30-39 REDIRECT - [(and (>= status 30) (<= status 39)) - (void)] + ;; 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))))) - ;; 40-49 TEMPORARY FAILURE - [(and (>= status 40) (<= status 49)) - (void)] + (let () + (iter 10) + (newline) + (let ([remaining (pipe-content-length document-buffer)]) + (printf "~a bytes remaining\n" remaining)))) - ;; 50-59 PERMANENT FAILURE - [(and (>= status 50) (<= status 59)) - (void)] + ;; '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")) - ;; 60-69 CERTIFICATE REQUIRED - [(and (>= status 60) (<= status 69))])))) + (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) 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)))