add proper handling of exceptions raised by network procedures

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))))

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)])))))