Merge branch 'feat/unix-netlayer' into 'master'

Draft: feat: Add raw UNIX socket netlayer

See merge request spritely/goblins!25

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