racket-bertrpc / errors.rkt

; Author: Yasir M. Arsanukaev <yarsanukaev AT gmail DOT com>
; License: The 2-clause BSD license. See LICENSE for details.

#lang racket

(require racket/mpair)

(provide connection-error
         bertrpc-error
         bertrpc-raise-exn
         (struct-out connection-exception)
         (struct-out protocol-exception)
         (struct-out proxy-exception)
         (struct-out server-exception)
         (struct-out user-exception))

(struct connection-exception exn:fail:user ())
(struct invalid-option-exception exn:fail:user ())
(struct protocol-exception exn:fail:user ())
(struct proxy-exception exn:fail:user ())
(struct read-exception exn:fail:user ())
(struct read-timeout-exception exn:fail:user ())
(struct remote-exception exn:fail:user ())
(struct server-exception exn:fail:user ())
(struct user-exception exn:fail:user ())

(define (bertrpc-error exn-struct msg klass bt)
  (let* ((ismsgpair (pair? msg))
         (code (if ismsgpair
                   (car msg)
                   0))
         (message (if ismsgpair
                      (cdr msg)
                      msg))
         (details (string-append
                    (if (or (eq? 'nil bt) (zero? (length (mlist->list bt)))) ""
                               (format "Traceback:~n~a~n"
                                       (string-join (mlist->list bt) "\n")))
                    (if (eq? 'nil klass) ""
                        (format "Class: ~a~n" klass))
                    (format "Code: ~a~n" code)
                    (format "Detail: ~a" message))))
    (raise (exn-struct details (current-continuation-marks)))))

(define (bertrpc-raise-exn level msg klass bt)
  (let ((exn-struct (cond
                     ((eq? level 'protocol)
                       protocol-exception)
                     ((eq? level 'server)
                       server-exception)
                     ((eq? level 'user)
                       user-exception)
                     ((eq? level 'proxy)
                       proxy-exception)
                     (else
                       (bertrpc-error 
                         "Invalid error code received from server.")))))
    (bertrpc-error exn-struct msg klass bt)))

(define (connection-error host port)
  (let ((msg (format "Unable to connect to ~a:~a.~n" host port)))
    (bertrpc-error connection-exception msg 'nil 'nil)))
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.