w6vvn/gem300
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add proper handling of exceptions raised by network procedures

Browse Source
This commit is contained in:
w6vvn
2025-09-06 16:41:42 -07:00
parent dbaa44190f
commit dbe6bbf43b
2 changed files with 84 additions and 51 deletions
Download Patch File Download Diff File Expand all files Collapse all files

102
client.rkt
View File

@@ -82,64 +82,72 @@
(define/private (get url) (define/private (get url)
(define (iter url depth) (define (iter url depth)
(let-values ([(status header c-in) (net:request url)]) (with-handlers
;; TODO there are bunch of other status codes to deal with for ([exn:fail:network?
;; compliance (λ (exn)
(cond (displayln (exn-message exn)))]
;; clients MUST reject status codes outside of the 10-69 range [net:exn:fail:response?
[(or (< status 10) (λ (exn)
(> status 69)) (displayln (exn-message exn)))])
(displayln "WARNING: server returned invalid status code")]
;; 10-19 INPUT REQUIRED (let-values ([(status header c-in) (net:request url)])
[(and (>= status 10) ;; TODO there are bunch of other status codes to deal with for
(<= status 19)) ;; compliance
(display "input requested > ") (cond
(get (string-append url "?" (read-line)))] ;; 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 ;; 10-19 INPUT REQUIRED
[(and (>= status 20) [(and (>= status 10)
(<= status 29)) (<= 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))] (let-values ([(doc) (gmi:parse (port->lines c-in))]
[(db-in db-out) (make-pipe #f)]) [(db-in db-out) (make-pipe #f)])
(set! document-object doc) (set! document-object doc)
(set! document-buffer db-in) (set! document-buffer db-in)
(parameterize ([current-output-port db-out]) (parameterize ([current-output-port db-out])
(gmi:render doc)) (gmi:render doc))
(set! current-url url) (set! current-url url)
(let ([remaining (pipe-content-length db-in)]) (let ([remaining (pipe-content-length db-in)])
(printf "document retrieved. ~a bytes\n" remaining)) (printf "document retrieved. ~a bytes\n" remaining))
(next-cmd))] (next-cmd))]
;; 30-39 REDIRECT ;; 30-39 REDIRECT
[(and (>= status 30) [(and (>= status 30)
(<= status 39)) (<= status 39))
(if (> depth 5) (if (> depth 5)
(displayln "WARNING: maximum redirection depth exceeded") (displayln "WARNING: maximum redirection depth exceeded")
(iter (string->url header) (sub1 depth)))] (iter (string->url header) (sub1 depth)))]
;; 40-49 TEMPORARY FAILURE ;; 40-49 TEMPORARY FAILURE
[(and (>= status 40) [(and (>= status 40)
(<= status 49)) (<= status 49))
(printf "status ~a: ~a\n" status (printf "status ~a: ~a\n" status
(dict-ref temporary-failures status "temporary failure"))] (dict-ref temporary-failures status "temporary failure"))]
;; 50-59 PERMANENT FAILURE ;; 50-59 PERMANENT FAILURE
[(and (>= status 50) [(and (>= status 50)
(<= status 59)) (<= status 59))
(printf "status ~a: ~a\n" status (printf "status ~a: ~a\n" status
(dict-ref permanent-failures status "permanent failure"))] (dict-ref permanent-failures status "permanent failure"))]
;; 60-69 CERTIFICATE REQUIRED ;; 60-69 CERTIFICATE REQUIRED
[(and (>= status 60) [(and (>= status 60)
(<= status 69)) (<= status 69))
(displayln "certificate handling not yet implemented")]))) (displayln "certificate handling not yet implemented")]))))
(iter url 5)))) (iter url 5))))

33
net.rkt
View File

@@ -1,11 +1,14 @@
#lang racket #lang racket
(provide (contract-out (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 openssl)
(require net/url-string) (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 (request url)
(define-values (c-in c-out) (define-values (c-in c-out)
(ssl-connect (url-host url) (ssl-connect (url-host url)
@@ -19,13 +22,30 @@
(values status header 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 (read-response (c-in (current-input-port)))
(define maxlen 1027) (define maxlen 1027)
(let ([header (peek-string maxlen 0 c-in)]) (let ([header (peek-string maxlen 0 c-in)])
(if (not (string-contains? header "\r\n")) (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)]) (let ([header (read-line c-in 'return-linefeed)])
(define-values (status meta) (define-values (status meta)
@@ -35,10 +55,15 @@
(cond (cond
[(> (string-length status) 2) [(> (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)) [(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 [else
(values (string->number status) meta)]))))) (values (string->number status) meta)])))))