diff --git a/goblins/ocapn/netlayer/unix.rkt b/goblins/ocapn/netlayer/unix.rkt new file mode 100644 index 0000000..9196879 --- /dev/null +++ b/goblins/ocapn/netlayer/unix.rkt @@ -0,0 +1,179 @@ +#lang racket + +;;; Copyright 2021 Christine Lemmer-Webber +;;; Copyright 2022 Jonathan Frederickson +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +(require "../../core.rkt" + (submod "../../core.rkt" for-captp) + "../../vat.rkt" + "../../actor-lib/common.rkt" + "../../actor-lib/methods.rkt" + "../structs-urls.rkt" + "utils/read-write-procs.rkt" + racket/async-channel + racket/match + racket/unix-socket) + +(provide ^unix-netlayer) + +(define (^unix-netlayer _bcom our-name sock-dir) + (define address (build-path sock-dir "goblins.sock")) + (define our-location (ocapn-machine 'unix (path->string address) #f)) + (define listener (unix-socket-listen address)) + (define shutdown-time (make-semaphore)) + (define (do-cleanup) + (unix-socket-close-listener listener) + (delete-file address) + (delete-directory sock-dir)) + (define (start-listening conn-establisher) + (define (handle-ocapn-sock-listen) + (define-values (ip op) + (unix-socket-accept listener)) + (define-values (read-message write-message) + (read-write-procs ip op)) + (<-np-extern conn-establisher read-message write-message #t)) + (syscaller-free-thread + (lambda () + (dynamic-wind + void + (lambda () + (let lp () + (sync + shutdown-time + (handle-evt listener + (lambda _ + (handle-ocapn-sock-listen) + (lp)))))) + do-cleanup)))) + + (define (^netlayer bcom) + (define base-beh + (methods + [(netlayer-name) 'unix] + [(our-location) our-location])) + + ;; State of the netlayer before it gets called with 'setup + (define pre-setup-beh + (methods + #:extends base-beh + ;; The machine is now wiring us up with the appropriate behavior for + ;; when a new connection comes in + [(setup conn-establisher) + (start-listening conn-establisher) + ;; Now that we're set up, transition to the main behavior + (bcom (ready-beh conn-establisher))])) + + (define (ready-beh conn-establisher) + (methods + #:extends base-beh + [(self-location? loc) + (same-machine-location? our-location loc)] + [(connect-to remote-machine) + (match remote-machine + [(ocapn-machine 'unix address #f) + (define connect-vat (make-vat)) + (define (^start-conn _bcom) + (lambda () + (define-values (ip op) + (unix-socket-connect address)) + (define-values (read-message write-message) + (read-write-procs ip op)) + (<- conn-establisher read-message write-message #f))) + (define start-conn (connect-vat 'spawn ^start-conn)) + (<- start-conn)])])) + pre-setup-beh) + (spawn ^netlayer)) + +;; Unit tests + +(module+ test + (require rackunit + "../captp.rkt" + "../../actor-lib/bootstrap.rkt") + + + (define a-dir (make-temporary-directory)) + (define b-dir (make-temporary-directory)) + + (define-vat-run network-vat-run (make-vat)) + + (define-vat-run a-run (make-vat)) + (define-vat-run b-run (make-vat)) + + (define a-unix-netlayer + (a-run + (spawn ^unix-netlayer "a" a-dir))) + (define b-unix-netlayer + (b-run + (spawn ^unix-netlayer "b" b-dir))) + + (define a-mycapn + (a-run + (spawn-mycapn a-unix-netlayer))) + (define b-mycapn + (b-run + (spawn-mycapn b-unix-netlayer))) + + (define a-loc + (a-run + ($ a-unix-netlayer 'our-location))) + (define b-loc + (b-run + ($ b-unix-netlayer 'our-location))) + + (define a->b-vow + (a-run ($ a-mycapn 'connect-to-machine b-loc))) + + (define (^greeter _bcom my-name) + (lambda (your-name) + (format "Hello ~a, my name is ~a!" your-name my-name))) + + (define alice + (a-run (spawn ^greeter "Alice"))) + (define bob + (b-run (spawn ^greeter "Bob"))) + + (define alice-locator-sref + (a-run ($ a-mycapn 'register alice 'unix))) + (define bob-locator-sref + (b-run ($ b-mycapn 'register bob 'unix))) + + (let ([response-ch (make-async-channel)]) + (a-run + (define bob-vow (<- a-mycapn 'enliven bob-locator-sref)) + (on (<- bob-vow "Arthur") + (λ (val) + (async-channel-put response-ch `(fulfilled ,val))) + #:catch + (λ (err) + (async-channel-put response-ch `(broken ,err))))) + (test-equal? + "a->b communication works" + (sync/timeout 0.5 response-ch) + '(fulfilled "Hello Arthur, my name is Bob!"))) + + (let ([response-ch (make-async-channel)]) + (b-run + (define alice-vow (<- b-mycapn 'enliven alice-locator-sref)) + (on (<- alice-vow "Ben") + (λ (val) + (async-channel-put response-ch `(fulfilled ,val))) + #:catch + (λ (err) + (async-channel-put response-ch `(broken ,err))))) + (test-equal? + "b->a communication works" + (sync/timeout 0.5 response-ch) + '(fulfilled "Hello Ben, my name is Alice!"))))