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