From dbe6bbf43b3603fe0c664b15a840f284df29e940 Mon Sep 17 00:00:00 2001 From: w6vvn Date: Sat, 6 Sep 2025 16:41:42 -0700 Subject: [PATCH] add proper handling of exceptions raised by network procedures --- client.rkt | 102 +++++++++++++++++++++++++++++------------------------ net.rkt | 33 ++++++++++++++--- 2 files changed, 84 insertions(+), 51 deletions(-) diff --git a/client.rkt b/client.rkt index 2283500..1ec14be 100644 --- a/client.rkt +++ b/client.rkt @@ -82,64 +82,72 @@ (define/private (get url) (define (iter url depth) - (let-values ([(status header 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")] + (with-handlers + ([exn:fail:network? + (λ (exn) + (displayln (exn-message exn)))] + [net:exn:fail:response? + (λ (exn) + (displayln (exn-message exn)))]) - ;; 10-19 INPUT REQUIRED - [(and (>= status 10) - (<= status 19)) - (display "input requested > ") - (get (string-append url "?" (read-line)))] + (let-values ([(status header 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")] - ;; 20-29 SUCCESS - [(and (>= status 20) - (<= status 29)) + ;; 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-values ([(doc) (gmi:parse (port->lines c-in))] - [(db-in db-out) (make-pipe #f)]) + (let-values ([(doc) (gmi:parse (port->lines c-in))] + [(db-in db-out) (make-pipe #f)]) - (set! document-object doc) + (set! document-object doc) - (set! document-buffer db-in) - (parameterize ([current-output-port db-out]) - (gmi:render doc)) + (set! document-buffer db-in) + (parameterize ([current-output-port db-out]) + (gmi:render doc)) - (set! current-url url) + (set! current-url url) - (let ([remaining (pipe-content-length db-in)]) - (printf "document retrieved. ~a bytes\n" remaining)) + (let ([remaining (pipe-content-length db-in)]) + (printf "document retrieved. ~a bytes\n" remaining)) - (next-cmd))] + (next-cmd))] - ;; 30-39 REDIRECT - [(and (>= status 30) - (<= status 39)) - (if (> depth 5) - (displayln "WARNING: maximum redirection depth exceeded") - (iter (string->url header) (sub1 depth)))] + ;; 30-39 REDIRECT + [(and (>= status 30) + (<= status 39)) + (if (> depth 5) + (displayln "WARNING: maximum redirection depth exceeded") + (iter (string->url header) (sub1 depth)))] - ;; 40-49 TEMPORARY FAILURE - [(and (>= status 40) - (<= status 49)) - (printf "status ~a: ~a\n" status - (dict-ref temporary-failures status "temporary failure"))] + ;; 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"))] + ;; 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")]))) + ;; 60-69 CERTIFICATE REQUIRED + [(and (>= status 60) + (<= status 69)) + (displayln "certificate handling not yet implemented")])))) - (iter url 5)))) + (iter url 5)))) diff --git a/net.rkt b/net.rkt index a04e724..6d224be 100644 --- a/net.rkt +++ b/net.rkt @@ -1,11 +1,14 @@ #lang racket (provide (contract-out - [request (-> url? (values integer? string? input-port?))])) + [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) @@ -19,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) @@ -35,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)])))))