From b05dc90e70cbcd7d7bd23a1b63967622b10a5173 Mon Sep 17 00:00:00 2001 From: w6vvn Date: Sat, 6 Sep 2025 19:29:13 -0700 Subject: [PATCH] rip a ton of stuff out. clear my head a bit. --- client.rkt | 181 ++++++++++++++--------------------------------------- 1 file changed, 47 insertions(+), 134 deletions(-) diff --git a/client.rkt b/client.rkt index 7bf648c..b78bf00 100644 --- a/client.rkt +++ b/client.rkt @@ -21,6 +21,26 @@ (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) + (define client% (class object% (define document-object '()) @@ -29,144 +49,37 @@ (super-new) - (define/public (up-cmd) - (if (null? current-url) + (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)))]) - (displayln "you need to 'go' somewhere first!") + (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)] - (if (string=? (path->string - (simplify-path - (url->path current-url))) - "/") + ;; 10-19 INPUT REQUIRED + [(and (>= status 10) (<= status 19)) + (void)] - (displayln "already at root!") + ;; 20-29 SUCCESS + [(and (>= status 20) (<= status 29)) + (void)] - (let ([parent - (simplify-path - (build-path (url->path current-url) 'up) - #f)]) - (get (struct-copy url current-url - [path (url-path (path->url parent))])))))) + ;; 30-39 REDIRECT + [(and (>= status 30) (<= status 39)) + (void)] - (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))) + ;; 40-49 TEMPORARY FAILURE + [(and (>= status 40) (<= status 49)) + (void)] - (get (string->url url-string))) + ;; 50-59 PERMANENT FAILURE + [(and (>= status 50) (<= status 59)) + (void)] - (displayln "go where?"))) - - (define/public (next-cmd) - (define (iter depth) - (when (and (> depth 0) - (> (pipe-content-length document-buffer) 0)) - (let () - (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))))) - - (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)))))) - - (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))))) - - (define/private (handle-gmi url c-in) - (let-values ([(doc) (gmi:parse (port->lines c-in))] - [(db-in db-out) (make-pipe #f)]) - - (set! document-object 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))) - - (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)))]) - - (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")] - - ;; 10-19 INPUT REQUIRED - [(and (>= status 10) - (<= status 19)) - (display "input requested > ") - (get (string-append url "?" (read-line)))] - - ;; 20-29 SUCCESS - [(and (>= status 20) - (<= status 29)) - - (let ([mime (car (string-split meta ";"))]) - (cond - [(string=? mime "text/gemini") - (handle-gmi url c-in)] - [else - (printf "unsupported mime type: ~a~n" mime)]))] - - ;; 30-39 REDIRECT - [(and (>= status 30) - (<= status 39)) - (if (> depth 5) - (displayln "WARNING: maximum redirection depth exceeded") - (iter (string->url meta) (sub1 depth)))] - - ;; 40-49 TEMPORARY FAILURE - [(and (>= status 40) - (<= status 49)) - (printf "status ~a: ~a\n" status - (dict-ref temporary-failures status "temporary failure"))] - - ;; 50-59 PERMANENT FAILURE - [(and (>= status 50) - (<= status 59)) - (printf "status ~a: ~a\n" status - (dict-ref permanent-failures status "permanent failure"))] - - ;; 60-69 CERTIFICATE REQUIRED - [(and (>= status 60) - (<= status 69)) - (displayln "certificate handling not yet implemented")])))) - - (if (not (string=? (url-scheme url) "gemini")) - (printf "unsupported url: ~a~n" (url->string url)) - (iter url 5))))) + ;; 60-69 CERTIFICATE REQUIRED + [(and (>= status 60) (<= status 69))]))))