Commits

Anonymous committed 20bb887

Initial commit.

Comments (0)

Files changed (5)

+#lang racket
+
+(require racket/serialize)
+
+(require bert)
+
+(require "errors.ss")
+
+(provide encode-scheme-request
+         decode-bert-response)
+
+(define (error-rpc err)
+  (let ((level (vector-ref err 0))
+        (code (vector-ref err 1))
+        (klass (vector-ref err 2))
+        (message (vector-ref err 3))
+        (backtrace (vector-ref err 4)))
+    (bertrpc-raise-exn level (cons code message) klass backtrace)))
+
+(define (encode-scheme-request scheme-request)
+  (bert-encode scheme-request))
+
+(define (decode-bert-response bert-response)
+  (let* ((scheme-response (bert-decode bert-response))
+         (vect-get-elem (lambda (n) (vector-ref scheme-response n)))
+         (resp-kind (vect-get-elem 0)))
+    (cond 
+      ((equal? resp-kind 'reply)
+       (vect-get-elem 1))
+      ((equal? resp-kind 'noreply)
+       'nil)
+      ((equal? resp-kind 'error)
+       (error-rpc (vect-get-elem 1)))
+      (else
+       (bertrpc-error "Invalid response received from server.")))))
+#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)))
+#lang setup/infotab
+
+(define name "racket-bertrpc")
+(define blurb
+  '("Implements BERT-RPC client. "
+    "BERT-RPC protocol is described at http://bert-rpc.org"))
+(define primary-file "racket-bertrpc.rkt")
+(define categories '(net))

racket-bertrpc.rkt

+#lang racket
+
+(require bert)
+
+(require "encodes.rkt")
+(require "errors.rkt")
+(require "transport.rkt")
+
+(require racket/mpair)
+
+(provide call cast from-uri)
+  
+(define (action kind transport m f a)
+  (let* ((bert-request (encode-scheme-request (vector kind m f a)))
+         (bert-response (recvt (sendt transport bert-request))))
+    (decode-bert-response bert-response)))
+
+(define call
+  ((curry action) 'call))
+
+(define cast
+  ((curry action) 'cast))
+
+; Sample call
+; (call (from-uri "bert://192.168.32.40:9999") 'nat 'add (list 5 9))
+#lang racket
+
+(require "errors.ss")
+
+(require racket/tcp)
+(require racket/serialize)
+(require net/url)
+(require rnrs/bytevectors-6)
+(require rnrs/io/ports-6)
+
+; Create a (TCP) transport from the given host and port.
+(define (from-host-port host port)
+    (cons 'tcp (hash 
+                'host host
+                'port port)))
+
+; Create a transport from the given URI.
+(define (from-uri s)
+  (let* ((uri (string->url s))
+         (scheme (url-scheme uri))
+         (host (url-host uri))
+         (port (url-port uri)))    
+    (cond
+      ((equal? scheme "bert")
+       (from-host-port host port))
+      (else 
+       (error "from-uri" "URI schemes other than 'bert' not implemented.")))))
+
+; Send a term via a TCP socket.
+(define (sendt-tcp transport berp-header bert-request)
+  (let ((host (hash-ref (cdr transport) 'host))
+        (port (hash-ref (cdr transport) 'port)))
+    (with-handlers ([exn:fail:network? (lambda(_) 
+                                         (connection-error host port))])
+                   (let-values (((in-port out-port) (tcp-connect host port)))
+                               ;; perform write to the socket
+                               (put-bytevector out-port berp-header)  ;header
+                               (put-bytevector out-port bert-request) ;payload
+                               (flush-output-port out-port)
+                               (cons (car transport)  ;; 'tcp
+                                     (hash 'host        host
+                                           'port        port
+                                           'in-port     in-port
+                                           'out-port    out-port))))))
+
+(define (recvt-tcp transport)
+  (let* ((read-n (lambda (n)
+                   (get-bytevector-n 
+                    (hash-ref (cdr transport) 'in-port) n)))
+         (len-raw (read-n 4))
+         (bert-response-len (bytevector-u32-ref len-raw 0 (endianness big)))
+         (bert-response (read-n bert-response-len)))
+    ; DEBUG
+    ; (display bert-response-len) (display " many bytes read from port") (newline)
+    
+    ; according to spec we should close an output port 
+    ; after reading a reply back
+    (close-output-port (hash-ref (cdr transport) 'out-port))
+    bert-response))
+
+; Send a term using specified transport.
+(define (sendt transport bert-request)
+  (let* ((berp-header (make-bytevector 4))
+         (bert-req-len (bytevector-length bert-request)))
+    (bytevector-u32-set! berp-header 0 bert-req-len (endianness big))
+    (cond
+      ((equal? (car transport) 'tcp)
+       (sendt-tcp transport berp-header bert-request))
+      (else (error "sendt" "Other transports not implemented.")))))
+
+; Receive a term using transport returned by sendt.
+(define (recvt transport)
+  (cond
+    ((equal? (car transport) 'tcp)
+     (recvt-tcp transport))
+    (else (error "recvt" "Other transports not implemented."))))
+
+(provide from-uri sendt recvt)