diff --git a/OLD-syndicate-examples/chat-client.rkt b/OLD-syndicate-examples/chat-client.rkt deleted file mode 100644 index 11ffcf3..0000000 --- a/OLD-syndicate-examples/chat-client.rkt +++ /dev/null @@ -1,37 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(require/activate syndicate/drivers/tcp) -(require/activate syndicate/drivers/external-event) -(require/activate syndicate/reassert) -(require (only-in racket/port read-bytes-line-evt)) - -(spawn (define id 'chat) - (define root-facet (current-facet)) - - (reassert-on (tcp-connection id (tcp-address "localhost" 5999)) - (retracted (tcp-accepted id)) - (asserted (tcp-rejected id _))) - - (on (asserted (tcp-rejected id $reason)) - (printf "*** ~a\n" (exn-message reason))) - - (during (tcp-accepted id) - (on-start (printf "*** Connected.\n") - (issue-credit! tcp-in id)) - (on (retracted (tcp-accepted id)) (printf "*** Remote EOF.\n")) - ;; ^ Not on-stop, because the facet is stopped by local EOF too! - - (on (message (tcp-in-line id $bs)) - (write-bytes bs) - (newline) - (flush-output) - (issue-credit! tcp-in id)) - - (define stdin-evt (read-bytes-line-evt (current-input-port) 'any)) - (on (message (inbound (external-event stdin-evt (list $line)))) - (if (eof-object? line) - (stop-facet root-facet (printf "*** Local EOF. Terminating.\n")) - (send! (tcp-out id (bytes-append line #"\n"))))))) diff --git a/OLD-syndicate-examples/chat-server-nested-dataspace.rkt b/OLD-syndicate-examples/chat-server-nested-dataspace.rkt deleted file mode 100644 index 0420ddf..0000000 --- a/OLD-syndicate-examples/chat-server-nested-dataspace.rkt +++ /dev/null @@ -1,32 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(require/activate syndicate/drivers/tcp) -(require racket/format) - -(message-struct speak (who what)) -(assertion-struct present (who)) - -(dataspace - (spawn #:name 'chat-server - (during/spawn (inbound (tcp-connection $id (tcp-listener 5999))) - #:name (list 'chat-connection id) - (assert (outbound (tcp-accepted id))) - (on-start (send! (outbound (credit (tcp-listener 5999) 1))) - (send! (outbound (credit tcp-in id 1)))) - (let ((me (gensym 'user))) - (assert (present me)) - (on (message (inbound (tcp-in-line id $bs))) - (match bs - [#"/quit" (stop-current-facet)] - [#"/stop-server" (quit-dataspace!)] - [_ (send! (speak me (bytes->string/utf-8 bs))) - (send! (outbound (credit tcp-in id 1)))]))) - (during (present $user) - (on-start (send! (outbound (tcp-out id (string->bytes/utf-8 (~a user " arrived\n")))))) - (on-stop (send! (outbound (tcp-out id (string->bytes/utf-8 (~a user " left\n")))))) - (on (message (speak user $text)) - (send! - (outbound (tcp-out id (string->bytes/utf-8 (~a user " says '" text "'\n")))))))))) diff --git a/OLD-syndicate-examples/chat-server.rkt b/OLD-syndicate-examples/chat-server.rkt deleted file mode 100644 index 9eef84c..0000000 --- a/OLD-syndicate-examples/chat-server.rkt +++ /dev/null @@ -1,33 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(require/activate syndicate/drivers/tcp) -(require racket/format) - -(message-struct speak (who what)) -(assertion-struct present (who)) - -(message-struct stop-server ()) - -(spawn #:name 'chat-server - (stop-when (message (stop-server))) - (during/spawn (tcp-connection $id (tcp-listener 5999)) - #:name (list 'chat-connection id) - (assert (tcp-accepted id)) - (on-start (issue-credit! (tcp-listener 5999)) - (issue-credit! tcp-in id)) - (let ((me (gensym 'user))) - (assert (present me)) - (on (message (tcp-in-line id $bs)) - (issue-credit! tcp-in id) - (match bs - [#"/quit" (stop-current-facet)] - [#"/stop-server" (send! (stop-server))] - [_ (send! (speak me (bytes->string/utf-8 bs)))]))) - (during (present $user) - (on-start (send! (tcp-out id (string->bytes/utf-8 (~a user " arrived\n"))))) - (on-stop (send! (tcp-out id (string->bytes/utf-8 (~a user " left\n"))))) - (on (message (speak user $text)) - (send! (tcp-out id (string->bytes/utf-8 (~a user " says '" text "'\n")))))))) diff --git a/OLD-syndicate-examples/echo.rkt b/OLD-syndicate-examples/echo.rkt deleted file mode 100644 index 49f3f05..0000000 --- a/OLD-syndicate-examples/echo.rkt +++ /dev/null @@ -1,16 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(require/activate syndicate/drivers/tcp) - -(spawn (during/spawn (tcp-connection $id (tcp-listener 5999)) - (on-start (printf "Accepted connection ~v\n" id)) - (on-stop (printf "Closed connection ~v\n" id)) - (assert (tcp-accepted id)) - (on-start (issue-credit! (tcp-listener 5999)) - (issue-credit! tcp-in id)) - (on (message (tcp-in-line id $bs)) - (issue-credit! tcp-in id) - (send! (tcp-out id (bytes-append bs (bytes 13 10))))))) diff --git a/OLD-syndicate-examples/filesystem.rkt b/OLD-syndicate-examples/filesystem.rkt deleted file mode 100644 index 62b8e16..0000000 --- a/OLD-syndicate-examples/filesystem.rkt +++ /dev/null @@ -1,34 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(require/activate syndicate/drivers/external-event) -(require/activate syndicate/drivers/filesystem) -(require racket/file) - -(require (only-in racket/port read-bytes-line-evt)) -(require (only-in racket/string string-trim string-split)) - -(spawn #:name 'monitor-shell - (define e (read-bytes-line-evt (current-input-port) 'any)) - (on (message (inbound (external-event e (list $line)))) - (match line - [(? eof-object?) - (stop-current-facet (send! (list "close" 'all)))] - [(? bytes? command-bytes) - (send! (string-split (string-trim (bytes->string/utf-8 command-bytes))))]))) - -(spawn #:name 'monitor-opener - - (define (monitor name reader-proc) - (spawn #:name (list 'monitor name) - (stop-when (message (list "close" 'all))) ;; old-syndicate version used wildcard - (stop-when (message (list "close" name))) - (on (asserted (file-content name reader-proc $data)) - (log-info "~a: ~v" name data)))) - - (on (message (list "open" $name)) (monitor name file->bytes)) - - ;; The driver can track directory "contents" just as well as files. - (on (message (list "opendir" $name)) (monitor name directory-list))) diff --git a/OLD-syndicate-examples/gl-2d-basic.rkt b/OLD-syndicate-examples/gl-2d-basic.rkt deleted file mode 100644 index 315c2c1..0000000 --- a/OLD-syndicate-examples/gl-2d-basic.rkt +++ /dev/null @@ -1,136 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(require racket/set) -(require 2htdp/image) -(require/activate syndicate/drivers/gl-2d) - -(define (spawn-background) - (spawn (during (window $width $height) - (assert-scene `((push-matrix (scale ,width ,(* height 2)) - (translate 0 -0.25) - (texture - ,(overlay/xy (rectangle 1 1 "solid" "white") - 0 0 - (rectangle 1 2 "solid" "black")))) - ;; (rotate -30) - ;; (scale 5 5) - ) - `())))) - -(define (draggable-mixin touching? x y) - (define (idle) - (react (stop-when #:when (touching?) - (message (mouse-event 'left-down (mouse-state $mx $my _ _ _))) - (log-info "idle -> dragging; in-script? ~v" (in-script?)) - (dragging (- mx (x)) (- my (y)))))) - - (define (dragging dx dy) - (react (on (message (mouse-event 'motion (mouse-state $mx $my _ _ _))) - (x (- mx dx)) - (y (- my dy))) - (stop-when (message (mouse-event 'left-up _)) (idle)) - (stop-when (message (mouse-event 'leave _)) (idle)))) - - (idle)) - -(define (draggable-shape name orig-x orig-y z plain-image hover-image - #:coordinate-map-id [coordinate-map-id #f] - #:parent [parent-id #f]) - (spawn (field [x orig-x] [y orig-y]) - (define/query-value touching? #f (touching name) #t) - (assert (simple-sprite #:parent parent-id - #:coordinate-map-id coordinate-map-id - #:touchable-id name - #:touchable-predicate in-unit-circle? - z (x) (y) 50 50 - (if (touching?) - hover-image - plain-image))) - (on-start (draggable-mixin touching? x y)))) - -(define (tooltip touching? x y w h label-string) - (define label-text (text label-string 22 "black")) - (define label (overlay label-text (empty-scene (+ (image-width label-text) 10) - (+ (image-height label-text) 10)))) - (define (pos) - (define v (- (x) (image-width label) 10)) - (if (negative? v) - (+ (x) w 10) - v)) - (react (assert #:when (touching?) - (simple-sprite -10 - (pos) - (+ (y) (* 1/2 h) (- (* 1/2 (image-height label)))) - (image-width label) - (image-height label) - label)))) - -(define (spawn-player-avatar) - (local-require 2htdp/planetcute) - (define CC character-cat-girl) - - (spawn (field [x 100] [y 100]) - (assert (simple-sprite #:touchable-id 'player - #:coordinate-map-id 'player - -0.5 (x) (y) (image-width CC) (image-height CC) CC)) - - (field [keys-down (set)]) - (on (asserted (key-pressed $k)) (keys-down (set-add (keys-down) k))) - (on (retracted (key-pressed $k)) (keys-down (set-remove (keys-down) k))) - (define (key->delta k distance) (if (set-member? (keys-down) k) distance 0)) - - (define/query-value touching? #f (touching 'player) #t) - (on-start (draggable-mixin touching? x y)) - - (on (asserted (coordinate-map 'player $xform)) - ;; TODO: figure out why this causes lag in frame updates - (log-info "Player coordinate map: ~v" xform)) - - (on-start (tooltip touching? x y (image-width CC) (image-height CC) "The Player")) - - (on (message (frame-event _ _ $elapsed-ms _)) - (define-values (old-x old-y) (values (x) (y))) - (define distance (* 0.360 elapsed-ms)) - (define nx (+ old-x (key->delta 'right distance) (key->delta 'left (- distance)))) - (define ny (+ old-y (key->delta 'down distance) (key->delta 'up (- distance)))) - (when (not (and (= nx old-x) (= ny old-y))) - (x nx) - (y ny))))) - -(define (spawn-frame-counter) - (spawn (field [i empty-image]) - (assert (simple-sprite -10 300 10 (image-width (i)) (image-height (i)) (i))) - (on (message (frame-event $counter $sim-time-ms _ _)) - (when (> sim-time-ms 0) - (define fps (/ counter (/ sim-time-ms 1000.0))) - (i (text (format "~a fps" fps) 22 "black")))))) - -(spawn-keyboard-integrator) -(spawn-mouse-integrator) -(spawn-background) -;; (spawn-frame-counter) -(spawn-player-avatar) - -(draggable-shape 'orange 50 50 0 - (circle 50 "solid" "orange") - (circle 50 "solid" "red")) - -(draggable-shape 'yellow 10 -10 0 #:parent 'orange - (circle 50 "solid" "yellow") - (circle 50 "solid" "purple")) - -(draggable-shape 'green 60 60 -1 - (circle 50 "solid" "green") - (circle 50 "solid" "cyan")) - -(spawn* (until (message (key-event #\q #t _))) - (assert! (gl-control 'stop))) - -(spawn (during (touching $id) - (on-start (log-info "Touching ~v" id)) - (on-stop (log-info "No longer touching ~v" id)))) - -(spawn-gl-2d-driver) diff --git a/OLD-syndicate-examples/gl-2d-clock-face.rkt b/OLD-syndicate-examples/gl-2d-clock-face.rkt deleted file mode 100644 index 9e6d189..0000000 --- a/OLD-syndicate-examples/gl-2d-clock-face.rkt +++ /dev/null @@ -1,90 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate -;; Compare to "ezd" clock-face example from: J. F. Bartlett, “Don’t -;; Fidget with Widgets, Draw!,” Palo Alto, California, DEC WRL -;; Research Report 91/6, May 1991. - -(require lang/posn) -(require 2htdp/image) -(require (only-in racket/math pi)) -(require racket/date) - -(require/activate syndicate/drivers/gl-2d) - -(define hand - (polygon (list (make-posn 0 0) - (make-posn 30 10) - (make-posn 100 0) - (make-posn 30 -10)) - "solid" - "black")) - -(define (fmod a b) - (- a (* b (truncate (/ a b))))) - -(define (hand-sprite id layer angle-field length) - (sprite #:id id layer `((translate 100 100) - (rotate ,(fmod (- 90 (angle-field)) 360)) - (scale ,length ,(/ length 5)) - (translate 0 -0.5) - (touchable ,id ,in-unit-square?) - (texture ,hand)))) - -(define (text-sprite layer x y content) - (define i (text content 24 "green")) - (simple-sprite layer x y (image-width i) (image-height i) i)) - -(spawn (field [minute-angle 0] - [hour-angle 0] - [start-time (current-inexact-milliseconds)] - [elapsed-seconds 0] - [displacement (let ((now (current-date))) - (* 6 (+ (* 60 (date-hour now)) - (date-minute now))))]) - - (assert (simple-sprite 10 0 0 200 200 (circle 100 "solid" "blue"))) - (assert (hand-sprite 'minute 9 minute-angle 95)) - (assert (text-sprite 8 40 40 "time")) - (assert (text-sprite 8 110 80 "drifts")) - (assert (text-sprite 8 40 120 "by")) - (assert (hand-sprite 'hour 7 hour-angle 65)) - (assert (simple-sprite 6 95 95 10 10 (circle 5 "solid" "black"))) - - (define (respond-to-drags id scale) - (define/query-value touching? #f (touching id) #t) - (on #:when (touching?) (message (mouse-event 'left-down (mouse-state $mx $my _ _ _))) - (start-time #f) - (elapsed-seconds 0) - (update-displacement! mx my scale) - (react (stop-when (message (mouse-event 'left-up _))) - (stop-when (message (mouse-event 'leave _))) - (on-stop (start-time (current-inexact-milliseconds))) - (on (message (mouse-event 'motion (mouse-state $mx $my _ _ _))) - (update-displacement! mx my scale))))) - - (define (update-displacement! mx my scale) - (define angle (- 90 (* (/ 180 pi) (atan (- 100 my) (- mx 100))))) - (define delta0 (fmod (- (* scale angle) (displacement)) 360)) - (define delta (if (<= delta0 -180) (+ delta0 360) delta0)) - (displacement (+ (displacement) delta))) - - (respond-to-drags 'minute 1) - (respond-to-drags 'hour 12) - - (begin/dataflow - (define angle (+ (/ (elapsed-seconds) 1000 10) (displacement))) - (minute-angle angle) - (hour-angle (/ angle 12))) - - (on (message (frame-event _ _ _ _)) - (when (start-time) - (elapsed-seconds (- (current-inexact-milliseconds) (start-time))))) - - (on (message (key-event #\q #t _)) - (send! (gl-control 'stop)))) - -(spawn-gl-2d-driver #:label "Syndicate Clock" - #:width 200 - #:height 200) diff --git a/OLD-syndicate-examples/gl-2d-many.rkt b/OLD-syndicate-examples/gl-2d-many.rkt deleted file mode 100644 index 660562d..0000000 --- a/OLD-syndicate-examples/gl-2d-many.rkt +++ /dev/null @@ -1,87 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate -;; Multiple animated sprites. -;; -;; 2018-05-01 With the new "imperative" implementation of Syndicate, -;; the same 2.6GHz laptop mentioned below can animate 135 logos in a -;; 640x480 window at 60 fps on a single core, with a bit of headroom -;; to spare. -;; -;; 2016-12-12 With the current implementations of (a) Syndicate's -;; dataspaces and (b) Syndicate's 2D sprite support, my reasonably new -;; 2.6GHz laptop can animate 20 logos at 256x256 pixels at about 20 -;; frames per second on a single core. -;; -;; For comparison, Kay recounts in "The Early History of Smalltalk" -;; (1993) that "by the Fall of '73 [Steve Purcell] could demo 80 -;; ping-pong balls and 10 flying horses running at 10 frames per -;; second in 2 1/2 D" in an early Smalltalk (?) on a NOVA. - -(require 2htdp/image) -(require images/logos) -(require/activate syndicate/drivers/gl-2d) - -(define speed-limit 40) -(define sprite-count 135) - -(define (spawn-background) - (spawn - (during (window $width $height) - (assert-scene `((push-matrix (scale ,width ,height) - (texture ,(rectangle 1 1 "solid" "white")))) - `())))) - -(define i:logo (plt-logo)) -(define i:logo-width (image-width i:logo)) -(define i:logo-height (image-height i:logo)) - -(define (spawn-logo) - (spawn (field [x 100] [y 100]) - (field [dx (* (- (random) 0.5) speed-limit)] - [dy (* (- (random) 0.5) speed-limit)]) - (define/query-value w #f ($ w (window _ _)) w) - (assert (simple-sprite 0 - (x) - (y) - i:logo-width - i:logo-height - i:logo)) - (define (bounce f df limit) - (define v (f)) - (define limit* (- limit i:logo-width)) - (cond [(< v 0) (f 0) (df (abs (df)))] - [(> v limit*) (f limit*) (df (- (abs (df))))] - [else (void)])) - (on (message (frame-event _ _ _ _)) - (when (w) ;; don't animate until we know the window bounds - (x (+ (x) (dx))) - (y (+ (y) (dy))) - (bounce x dx (window-width (w))) - (bounce y dy (window-height (w))))))) - -(spawn-background) -(for [(i sprite-count)] - (spawn-logo)) - -(spawn (define start-time #f) - (log-info "Sprite count: ~a" sprite-count) - (on (message (frame-event $counter $timestamp _ _)) - (if (eq? start-time #f) - (set! start-time (current-inexact-milliseconds)) - (let ((delta (- (current-inexact-milliseconds) start-time))) - (when (and (zero? (modulo counter 100)) (positive? delta)) - (log-info "~v frames, ~v ms ==> ~v Hz" - counter - delta - (/ counter (/ delta 1000.0)))))))) - -(spawn-gl-2d-driver) - -(spawn (field [fullscreen? #f]) - (on (message (key-event #\f #t _)) (fullscreen? (not (fullscreen?)))) - (assert #:when (fullscreen?) (gl-control 'fullscreen)) - - (on (message (key-event #\q #t _)) - (send! (gl-control 'stop)))) diff --git a/OLD-syndicate-examples/gl-2d-platformer.rkt b/OLD-syndicate-examples/gl-2d-platformer.rkt deleted file mode 100644 index bf8a998..0000000 --- a/OLD-syndicate-examples/gl-2d-platformer.rkt +++ /dev/null @@ -1,828 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(require 2htdp/image) -(require 2htdp/planetcute) - -(require racket/set) -(require plot/utils) ;; for vector utilities - -(require (only-in racket/string string-prefix?)) -(require (only-in racket/gui/base play-sound)) - -(require/activate syndicate/drivers/timer) -(require/activate syndicate/drivers/gl-2d) -(require syndicate/bag) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Layers: -;; -;; - External I/O -;; as arranged by syndicate-gl/2d -;; including keyboard events, interface to rendering, and frame timing -;; -;; - Ground -;; corresponds to computer itself -;; device drivers -;; applications (e.g. in this instance, the game) -;; -;; - Game -;; running application -;; per-game state, such as score and count-of-deaths -;; process which spawns levels -;; regular frame ticker -;; -;; - Level -;; model of the game world -;; actors represent entities in the world, mostly -;; misc actors do physicsish things -;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ## Common Data Definitions -;; -;; A Vec is a (vector Number Number) -;; A Point is a (vector Number Number) -;; (See vector functions in plot/utils) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ## Ground Layer Protocols - -;;------------------------------------------------------------------------- -;; ### Scene Management -;; - assertion: ScrollOffset -;; - assertion: OnScreenDisplay -;; - role: SceneManager -;; Displays the scene backdrop and adjusts display coordinates via ScrollOffset. -;; -;; A ScrollOffset is a (scroll-offset Vec), indicating the vector to *subtract* -;; from world coordinates to get device coordinates. -(struct scroll-offset (vec) #:transparent) -;; -;; An OnScreenDisplay is an (on-screen-display Number Number (Seal Image)), -;; representing an item to display in a fixed window-relative position -;; above the scrolled part of the scene. If the coordinates are -;; positive, they measure right/down from the left/top of the image; -;; if negative, they measure left/up from the right/bottom. -(struct on-screen-display (x y sealed-image) #:transparent) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ## Game Layer Protocols - -;;------------------------------------------------------------------------- -;; ### Scoring -;; - message: AddToScore -;; - assertion: CurrentScore -;; - role: ScoreKeeper -;; Maintains the score as private state. -;; Publishes the score using a CurrentScore. -;; Responds to AddToScore by updating the score. -;; -;; An AddToScore is an (add-to-score Number), a message -;; which signals a need to add the given number to the player's -;; current score. -(struct add-to-score (delta) #:transparent) -;; -;; A CurrentScore is a (current-score Number), an assertion -;; indicating the player's current score. -(struct current-score (value) #:transparent) - -;;------------------------------------------------------------------------- -;; ### Level Spawning -;; - assertion: LevelRunning -;; - message: LevelCompleted -;; - role: LevelSpawner -;; Maintains the current level number as private state. -;; Spawns a new Level when required. -;; Monitors LevelRunning - when it drops, the level is over. -;; Receives LevelCompleted messages. If LevelRunning drops without -;; a LevelCompleted having arrived, the level ended in failure and -;; should be restarted. If LevelComplete arrived before LevelRunning -;; dropped, the level was completed successfully, and the next level -;; should be presented. -;; - role: Level -;; Running level instance. Maintains LevelRunning while it's still -;; going. Sends LevelCompleted if the player successfully completed -;; the level. -;; -;; A LevelRunning is a (level-running), an assertion indicating that the -;; current level is still in progress. -(struct level-running () #:transparent) -;; -;; A LevelCompleted is a (level-completed), a message indicating that -;; the current level was *successfully* completed before it terminated. -(struct level-completed () #:transparent) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ## Level Layer Protocols - -;;------------------------------------------------------------------------- -;; ### Movement and Physics -;; - message: JumpRequest -;; - assertion: Impulse -;; - assertion: Position -;; - assertion: GamePieceConfiguration -;; - assertion: Touching -;; - role: PhysicsEngine -;; Maintains positions, velocities and accelerations of all GamePieces. -;; Uses GamePieceConfiguration for global properties of pieces. -;; Publishes Position to match. -;; Listens to FrameDescription, using it to advance the simulation. -;; Considers only mobile GamePieces for movement. -;; Takes Impulses as the baseline for moving GamePieces around. -;; For massive mobile GamePieces, applies gravitational acceleration. -;; Computes collisions between GamePieces. -;; Uses Attributes of GamePieces to decide what to do in response to collisions. -;; For 'touchable GamePieces, a Touching row is asserted. -;; Responds to JumpRequest by checking whether the named piece is in a -;; jumpable location, and sets its upward velocity negative if so. -;; - role: GamePiece -;; Maintains private state. Asserts Impulse to move around, -;; and GamePieceConfiguration to get things started. May issue -;; JumpRequests at any time. Represents both the player, -;; enemies, the goal(s), and platforms and blocks in the -;; environment. Asserts a Sprite two layers out to render -;; itself. -;; -;; An ID is a Symbol; the special symbol 'player indicates the player's avatar. -;; Gensyms from (gensym 'enemy) name enemies, etc. -;; -;; A JumpRequest is a (jump-request ID), a message indicating a *request* to jump, -;; not necessarily honoured by the physics engine. -(struct jump-request (id) #:transparent) -;; -;; An Impulse is an (impulse ID Vec), an assertion indicating a contribution to -;; the net *requested* velocity of the given gamepiece. -(struct impulse (id vec) #:transparent) -;; -;; A Position is a (position ID Point Vec), an assertion describing -;; the current actual top-left corner and (physics-related, not -;; necessarily graphics-related) size of the named gamepiece. -(struct position (id top-left size) #:transparent) -;; -;; An Attribute is either -;; - 'player - the named piece is a player avatar -;; - 'touchable - the named piece reacts to the player's touch -;; - 'solid - the named piece can be stood on / jumped from -;; - 'mobile - the named piece is not fixed in place -;; - 'massive - the named piece is subject to effects of gravity -;; (it is an error to be 'massive but not 'mobile) -;; -;; A GamePieceConfiguration is a -;; - (game-piece-configuration ID Point Vec (Set Attribute)) -;; an assertion specifying not only the *existence* of a named -;; gamepiece, but also its initial position and size and a collection -;; of its Attributes. -(struct game-piece-configuration (id initial-position size attributes) #:transparent) -;; -;; A Touching is a -;; - (touching ID ID Side) -;; an assertion indicating that the first ID is touching the second on -;; the named side of the second ID. -(struct touching (a b side) #:transparent) -;; -;; A Side is either 'top, 'left, 'right, 'bottom or the special value -;; 'mid, indicating an unknown or uncomputable side. - -(define (game-piece-has-attribute? g attr) - (set-member? (game-piece-configuration-attributes g) attr)) - -;;------------------------------------------------------------------------- -;; ### Player State -;; - message: Damage -;; - assertion: Health -;; - role: Player -;; Maintains hitpoints, which it reflects using Health. -;; Responds to Damage. -;; When hitpoints drop low enough, removes the player from the board. -;; -;; A Damage is a (damage ID Number), a message indicating an event that should -;; consume the given number of health points of the named gamepiece. -(struct damage (id hit-points) #:transparent) -;; -;; A Health is a (health ID Number), an assertion describing the current hitpoints -;; of the named gamepiece. -(struct health (id hit-points) #:transparent) - -;;------------------------------------------------------------------------- -;; ### World State -;; - assertion: LevelSize -;; - role: DisplayControl -;; Maintains a LevelSize assertion. -;; Observes the Position of the player, and computes and maintains a -;; ScrollOffset two layers out, to match. -;; Also kills the player if they wander below the bottom of the level. -;; -;; A LevelSize is a (level-size Vec), an assertion describing the right-hand and -;; bottom edges of the level canvas (in World coordinates). -(struct level-size (vec) #:transparent) - -;; ----------- -;; Interaction Diagrams (to be refactored into the description later) -;; -;; ================================================================================ -;; -;; title Jump Sequence -;; -;; Player -> Physics: (jump 'player) -;; note right of Physics: Considers the request. -;; note right of Physics: Denied -- Player is not on a surface. -;; -;; Player -> Physics: (jump 'player) -;; note right of Physics: Considers the request. -;; note right of Physics: Accepted. -;; note right of Physics: Updates velocity, position -;; Physics -> Subscribers: (vel 'player ...) -;; Physics -> Subscribers: (pos 'player ...) -;; -;; -;; ================================================================================ -;; -;; title Display Control Updates -;; -;; Physics -> DisplayCtl: (pos 'player ...) -;; note right of DisplayCtl: Compares player pos to level size -;; DisplayCtl -> Subscribers: (inbound (inbound (scroll-offset ...))) -;; -;; ================================================================================ -;; -;; title Movement Sequence -;; -;; Moveable -> Physics: (mobile ID Boolean) -;; Moveable -> Physics: (attr ID ...) -;; Moveable -> Physics: (impulse ID vec) -;; note right of Physics: Processes simulation normally -;; Physics -> Subscribers: (pos ID ...) -;; Physics -> Subscribers: (vel ID ...) -;; -;; ================================================================================ -;; -;; title Keyboard Interpretation -;; -;; Keyboard -> Player: (press right-arrow) -;; Player -->> Physics: assert (impulse ID (vec DX 0)) -;; -;; note right of Physics: Processes simulation normally -;; -;; Keyboard -> Player: (press left-arrow) -;; Player -->> Physics: assert (impulse ID (vec 0 0)) -;; -;; Keyboard -> Player: (release right-arrow) -;; Player -->> Physics: assert (impulse ID (vec -DX 0)) -;; -;; Keyboard -> Player: (press space) -;; Player -> Physics: (jump) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Icon - -(struct icon (pict scale hitbox-width-fraction hitbox-height-fraction baseline-fraction) - #:transparent) - -(define (icon-width i) (* (image-width (icon-pict i)) (icon-scale i))) -(define (icon-height i) (* (image-height (icon-pict i)) (icon-scale i))) -(define (icon-hitbox-width i) (* (icon-width i) (icon-hitbox-width-fraction i))) -(define (icon-hitbox-height i) (* (icon-height i) (icon-hitbox-height-fraction i))) -(define (icon-hitbox-size i) (vector (icon-hitbox-width i) (icon-hitbox-height i))) - -(define (focus->top-left i x y) - (vector (- x (/ (icon-hitbox-width i) 2)) - (- y (icon-hitbox-height i)))) - -(define (icon-sprite i layer pos) - (match-define (vector x y) pos) - (simple-sprite layer - (- x (/ (- (icon-width i) (icon-hitbox-width i)) 2)) - (- y (- (* (icon-baseline-fraction i) (icon-height i)) (icon-hitbox-height i))) - (icon-width i) - (icon-height i) - (icon-pict i))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; SceneManager - -(define (spawn-scene-manager) - (spawn #:name 'scene-manager - (define backdrop (rectangle 1 1 "solid" "white")) - - (define/query-value size (vector 0 0) (window $x $y) (vector x y)) - (define/query-set osds ($ o (on-screen-display _ _ _)) o) - (define/query-value offset (vector 0 0) (scroll-offset $v) v) - - (field [fullscreen? #f]) - (assert #:when (fullscreen?) (gl-control 'fullscreen)) - (on (message (key-event #\f #t _)) - (fullscreen? (not (fullscreen?)))) - - (define (compute-backdrop) - (match-define (vector width height) (size)) - (match-define (vector ofs-x ofs-y) (offset)) - (define osd-blocks - (for/list [(osd (in-set (osds)))] - (match-define (on-screen-display raw-x raw-y (seal i)) osd) - (define x (if (negative? raw-x) (+ width raw-x) raw-x)) - (define y (if (negative? raw-y) (+ height raw-y) raw-y)) - `(push-matrix (translate ,x ,y) - (scale ,(image-width i) ,(image-height i)) - (texture ,i)))) - (scene (seal `((push-matrix - (scale ,width ,height) - (texture ,backdrop)) - (translate ,(- ofs-x) ,(- ofs-y)))) - (seal `((translate ,ofs-x ,ofs-y) - ,@osd-blocks)))) - (assert (compute-backdrop)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; ScoreKeeper - -(define (spawn-score-keeper) - (spawn #:name 'score-keeper - (field [score 0]) - (assert (current-score (score))) - (assert (outbound - (on-screen-display -150 10 - (seal (text (format "Score: ~a" (score)) 24 "white"))))) - (on (message (add-to-score $delta)) - (score (+ (score) delta)) - (log-info "Score increased by ~a to ~a" delta (score)) - (play-sound-sequence 270304)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; PhysicsEngine - -(define impulse-multiplier 0.360) ;; 360 pixels per second -(define jump-vel (vector 0 -2)) -(define gravity 0.004) - -(define (spawn-physics-engine) - (spawn #:name 'physics-engine - (field [configs (hash)] - [previous-positions (hash)] - [previous-velocities (hash)] - [positions (hash)] - [velocities (hash)]) - - (during (game-piece-configuration $id $initial-position $size $attrs) - (on-start (configs - (hash-set (configs) id - (game-piece-configuration id initial-position size attrs)))) - (on-stop (configs (hash-remove (configs) id)) - (positions (hash-remove (positions) id)) - (velocities (hash-remove (velocities) id))) - (assert (position id (hash-ref (positions) id initial-position) size))) - - (define/query-hash impulses (impulse $id $vec) id vec) - - (define (piece-cfg id) (hash-ref (configs) id)) - (define (piece-pos which id) - (hash-ref (which) id (lambda () (game-piece-configuration-initial-position (piece-cfg id))))) - (define (piece-vel which id) (hash-ref (which) id (lambda () (vector 0 0)))) - (define (piece-imp id) (hash-ref (impulses) id (lambda () (vector 0 0)))) - - (define (update-piece! g new-pos new-vel) - (positions (hash-set (positions) (game-piece-configuration-id g) new-pos)) - (velocities (hash-set (velocities) (game-piece-configuration-id g) new-vel))) - - (define (find-support p size which-pos) - (match-define (vector p-left p-top) p) - (match-define (vector p-w p-h) size) - (define p-right (+ p-left p-w)) - (define p-bottom (+ p-top p-h)) - (for/or [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'solid)] - (match-define (vector left top) (piece-pos which-pos id)) - (and (< (abs (- top p-bottom)) 0.5) - (<= left p-right) - (match (game-piece-configuration-size g) - [(vector w h) - (<= p-left (+ left w))]) - g))) - - (define (segment-intersection-time p0 r q0 q1) - ;; See http://stackoverflow.com/a/565282/169231 - ;; Enhanced to consider the direction of impact with the segment, - ;; too: only returns an intersection when the vector of motion is - ;; at an obtuse angle to the normal of the segment. - (define s (v- q1 q0)) - (define rxs (vcross2 r s)) - (cond [(< (abs rxs) 0.005) #f] ;; zeroish; lines are parallel (and maybe collinear) - [else - (define q-p (v- q0 p0)) - (define q-pxs (vcross2 q-p s)) - (define t (/ q-pxs rxs)) - (and (<= 0 t 1) - (let* ((q-pxr (vcross2 q-p r)) - (u (/ q-pxr rxs))) - (and (< 0 u 1) - (let* ((q-norm - (vnormalize (vector (vector-ref s 1) (- (vector-ref s 0)))))) - (and (not (positive? (vdot r q-norm))) - (- t 0.001))))))])) - - (define (three-corners top-left size) - (match-define (vector w h) size) - (values (v+ top-left (vector w 0)) - (v+ top-left size) - (v+ top-left (vector 0 h)))) - - (define (clip-movement-by top-left moved-top-left size solid-top-left solid-size) - (define-values (solid-top-right solid-bottom-right solid-bottom-left) - (three-corners solid-top-left solid-size)) - (define-values (top-right bottom-right bottom-left) - (three-corners top-left size)) - (define r (v- moved-top-left top-left)) - (define t - (apply min - (for/list [(p (in-list (list #;top-left #;top-right bottom-right bottom-left)))] - (min (or (segment-intersection-time p r solid-top-left solid-top-right) 1) - ;; TODO: some means of specifying *which edges* should appear solid. - #;(or (segment-intersection-time p r solid-top-right solid-bottom-right) 1) - #;(or (segment-intersection-time p r solid-bottom-right solid-bottom-left) 1) - #;(or (segment-intersection-time p r solid-bottom-left solid-top-left) 1))))) - (v+ top-left (v* r t))) - - (define (clip-movement-by-solids p0 p1 size) - (for/fold [(p1 p1)] - [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'solid)] - (clip-movement-by p0 p1 size - (piece-pos previous-positions id) - (game-piece-configuration-size g)))) - - (define (touched-during-movement? TL moved-TL size touchable-TL touchable-size) - (define r (v- moved-TL TL)) - (if (positive? (vmag^2 r)) ;; r is nonzero, in other words - (let () - (define-values (touchable-TR touchable-BR touchable-BL) - (three-corners touchable-TL touchable-size)) - (define-values (TR BR BL) - (three-corners TL size)) - (for/or [(p (in-list (list TL TR BR BL)))] - (or - (and (segment-intersection-time p r touchable-TR touchable-BR) 'right) - (and (segment-intersection-time p r touchable-BR touchable-BL) 'bottom) - (and (segment-intersection-time p r touchable-BL touchable-TL) 'left) - (and (segment-intersection-time p r touchable-TL touchable-TR) 'top)))) - (let () - (match-define (vector left top) TL) - (match-define (vector touchable-left touchable-top) touchable-TL) - (match-define (vector width height) size) - (match-define (vector touchable-width touchable-height) touchable-size) - (and (<= left (+ touchable-left touchable-width)) - (<= top (+ touchable-top touchable-height)) - (<= touchable-left (+ left width)) - (<= touchable-top (+ top height)) - 'mid)))) - - (define (touchables-touched-during-movement p0 p1 size) - (for/fold [(ts '())] - [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'touchable)] - (define side (touched-during-movement? p0 p1 size - (piece-pos previous-positions id) - (game-piece-configuration-size g))) - (if side (cons (cons side g) ts) ts))) - - (define (update-game-piece! elapsed-ms id) - (define g (piece-cfg id)) - (define size (game-piece-configuration-size g)) - (define pos0 (piece-pos previous-positions id)) - (define support (find-support pos0 size previous-positions)) - - (define vel0 (piece-vel previous-velocities id)) - (define imp0 (piece-imp id)) - - (define vel1 (cond - [(and support (not (negative? (vector-ref vel0 1)))) - (piece-vel previous-velocities (game-piece-configuration-id support))] - [(game-piece-has-attribute? g 'massive) - (v+ vel0 (vector 0 (* gravity elapsed-ms)))] - [else - vel0])) - - (define pos1 (v+ pos0 (v* (v+ vel1 imp0) (* impulse-multiplier elapsed-ms)))) - (define final-pos (clip-movement-by-solids pos0 pos1 size)) - ;; TODO: figure out how to cancel just the component of velocity blocked by the obstacle(s) - ;; - which will avoid the "sticking to the wall" artifact - (define final-vel (if (v= pos1 final-pos) vel1 (vector 0 0))) ;; stop at collision - (define touchables (touchables-touched-during-movement pos0 final-pos size)) - - (for [(a (in-bag (current-adhoc-assertions)))] - (when (touching? a) - (retract! a +inf.0))) - (for [(t touchables)] - (match-define (cons side tg) t) - (assert! (touching id (game-piece-configuration-id tg) side))) - (update-piece! g final-pos final-vel)) - - (on (message (jump-request $id)) - (define g (piece-cfg id)) - (define pos (piece-pos positions id)) - (when (find-support pos (game-piece-configuration-size g) positions) - (play-sound-sequence 270318) - (update-piece! g pos jump-vel))) - - (define start-time #f) - (on (message (inbound (inbound (frame-event $counter _ _ _)))) - (let ((stop-time (current-inexact-milliseconds))) - (when (not (eq? start-time #f)) - (define elapsed-ms (- stop-time start-time)) - (when (zero? (modulo counter 10)) - (log-info "Instantaneous frame rate at frame ~a: ~a Hz" - counter - (/ 1000.0 elapsed-ms))) - (previous-positions (positions)) - (previous-velocities (velocities)) - (for [((id g) (in-hash (configs))) #:when (game-piece-has-attribute? g 'mobile)] - (update-game-piece! elapsed-ms id))) - (set! start-time stop-time))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Player - -(define player-id 'player) -(define planetcute-scale 1/2) - -(define (spawn-player-avatar initial-focus-x initial-focus-y) - (spawn #:name 'player-avatar - (define i (icon character-cat-girl planetcute-scale 2/6 3/10 13/16)) - (define initial-top-left (focus->top-left i initial-focus-x initial-focus-y)) - - (assert (game-piece-configuration player-id - initial-top-left - (icon-hitbox-size i) - (set 'player 'mobile 'massive))) - - (define/query-value pos initial-top-left (position player-id $hitbox-top-left _) - hitbox-top-left) - (assert (outbound (outbound (icon-sprite i 0 (pos))))) - - (field [hit-points 1]) - (assert (health player-id (hit-points))) - (stop-when-true (<= (hit-points) 0)) - (on (message (damage player-id $amount)) - (hit-points (- (hit-points) amount))) - - (on (asserted (inbound (inbound (key-pressed #\space)))) (send! (jump-request player-id))) - (on (asserted (inbound (inbound (key-pressed #\.)))) (send! (jump-request player-id))) - - (define/query-set keys-down (inbound (inbound (key-pressed $k))) k) - (define (any-key-down? . ks) (for/or [(k ks)] (set-member? (keys-down) k))) - (assert (impulse player-id (vector (+ (if (any-key-down? 'left 'prior) -1 0) - (if (any-key-down? 'right 'next) 1 0)) - 0))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Ground Block - -(define (spawn-ground-block top-left size #:color [color "purple"]) - (spawn #:name (list 'ground-block top-left size color) - (match-define (vector x y) top-left) - (match-define (vector w h) size) - (define block-id (gensym 'ground-block)) - (define block-pict (rectangle w h "solid" color)) - (assert (outbound (outbound (simple-sprite 0 x y w h block-pict)))) - (assert (game-piece-configuration block-id - top-left - size - (set 'solid))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Goal piece -;; -;; When the player touches a goal, sends LevelCompleted one layer out. - -(define (spawn-goal-piece initial-focus-x initial-focus-y) - (define goal-id (gensym 'goal)) - - (define i (icon key planetcute-scale 1/3 2/5 4/5)) - (define initial-top-left (focus->top-left i initial-focus-x initial-focus-y)) - - (spawn #:name (list 'goal-piece initial-focus-x initial-focus-y) - (on (asserted (touching player-id goal-id _)) - (send! (outbound (level-completed)))) - (assert (game-piece-configuration goal-id - initial-top-left - (icon-hitbox-size i) - (set 'touchable))) - (assert (outbound (outbound (icon-sprite i -1 initial-top-left)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Enemy - -(define (spawn-enemy initial-x initial-y range-lo range-hi - #:speed [speed 0.2] - #:facing [initial-facing 'right]) - (spawn #:name (list 'enemy initial-x initial-y initial-facing) - (define enemy-id (gensym 'enemy)) - (define i (icon enemy-bug planetcute-scale 9/10 1/3 5/6)) - (define i-flipped (struct-copy icon i [pict (flip-horizontal (icon-pict i))])) - (define initial-top-left (focus->top-left i initial-x initial-y)) - (match-define (vector width height) (icon-hitbox-size i)) - - (assert (game-piece-configuration enemy-id - initial-top-left - (icon-hitbox-size i) - (set 'mobile 'massive 'touchable))) - - (define/query-value current-level-size #f (level-size $v) v) - - (define/query-value pos initial-top-left (position enemy-id $top-left _) top-left - #:on-add (match-let (((vector left top) top-left)) - (facing (cond [(< left range-lo) 'right] - [(> (+ left width) range-hi) 'left] - [else (facing)])))) - - (stop-when-true (and (current-level-size) - (> (vector-ref (pos) 1) - (vector-ref (current-level-size) 1)))) - - (field [facing initial-facing]) - (assert (outbound (outbound - (icon-sprite (match (facing) ['right i] ['left i-flipped]) -1 (pos))))) - - (assert (impulse enemy-id (vector (* speed (match (facing) ['right 1] ['left -1])) 0))) - - (stop-when (asserted (touching player-id enemy-id 'top)) - (play-sound-sequence 270325) - (send! (outbound (add-to-score 1)))) - - (on (asserted (touching player-id enemy-id $side)) - (when (not (eq? side 'top)) (send! (damage player-id 1)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; DisplayControl - -(define (spawn-display-controller level-size-vec) - (match-define (vector level-width level-height) level-size-vec) - - (spawn #:name 'display-controller - (field [offset-pos (vector 0 0)]) - (assert (outbound (outbound (scroll-offset (offset-pos))))) - (assert (level-size level-size-vec)) - - (define/query-value window-size-vec #f (inbound (inbound (window $w $h))) (vector w h)) - - (define (compute-offset pos viewport limit) - (min (max 0 (- pos (/ viewport 2))) (- limit viewport))) - - (on (asserted (position player-id (vector $px $py) _)) - (when (window-size-vec) - (match-define (vector ww wh) (window-size-vec)) - (when (> py level-height) (send! (damage player-id +inf.0))) - (offset-pos (vector (compute-offset px ww level-width) - (compute-offset py wh level-height))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; LevelTerminationMonitor -;; -;; When the player vanishes from the board, or LevelCompleted is seen, -;; kills the dataspace. - -(define (wait-for-level-termination) - (spawn #:name 'wait-for-level-termination - (assert (outbound (level-running))) - (on (retracted (game-piece-configuration player-id _ _ _)) - (log-info "Player died! Terminating level.") - (play-sound-sequence 270328) - (quit-dataspace!)) - (on (message (inbound (level-completed))) - (log-info "Level completed! Terminating level.") - (play-sound-sequence 270330) - (send! (outbound (add-to-score 100))) - (quit-dataspace!)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; LevelSpawner - -(define (spawn-background-image level-size scene) - (match-define (vector level-width level-height) level-size) - (define scene-width (image-width scene)) - (define scene-height (image-height scene)) - (define level-aspect (/ level-width level-height)) - (define scene-aspect (/ scene-width scene-height)) - (define scale (if (> level-aspect scene-aspect) ;; level is wider, proportionally, than scene - (/ level-width scene-width) - (/ level-height scene-height))) - (spawn #:name 'background-image - (assert (outbound - (outbound - (sprite 10 - `((scale ,(* scene-width scale) - ,(* scene-height scale)) - (texture ,scene)))))))) - -;; http://www.travelization.net/wp-content/uploads/2012/07/beautiful-grassland-wallpapers-1920x1080.jpg -(define grassland-backdrop (bitmap "./private/beautiful-grassland-wallpapers-1920x1080.jpg")) - -(define (spawn-level #:initial-player-x [initial-player-x 50] - #:initial-player-y [initial-player-y 50] - #:level-size [level-size-vec (vector 4000 2000)] - #:scene [scene grassland-backdrop] - actions-thunk) - (lambda () - (dataspace #:name 'level-dataspace - (when scene (spawn-background-image level-size-vec scene)) - (spawn-display-controller level-size-vec) - (spawn-physics-engine) - (spawn-player-avatar initial-player-x initial-player-y) - (actions-thunk) - (wait-for-level-termination)))) - -(define standard-ground-height 50) - -(define (slab left top width #:color [color "purple"]) - (spawn-ground-block (vector left top) (vector width standard-ground-height) #:color color)) - -(define levels - (list - (spawn-level (lambda () - (slab 25 125 100) - (slab 50 300 500) - (spawn-enemy 100 300 50 550) - (spawn-enemy 300 300 50 550 #:facing 'left) - (spawn-goal-piece 570 150) - (slab 850 300 50) - (slab 925 400 50) - (slab 975 500 50) - (slab 975 600 50) - (slab 500 600 150 #:color "orange"))) - (spawn-level (lambda () - (slab 25 300 500) - (slab 500 400 500) - (slab 1000 500 400) - (spawn-goal-piece 1380 500))) - (spawn-level (lambda () - (slab 25 300 1000) - (spawn-enemy 600 300 25 1025 #:facing 'left) - (spawn-goal-piece 980 300))) - (spawn-level (lambda () - (spawn-goal-piece 250 280) - (spawn-enemy 530 200 400 600) - (spawn-enemy 500 200 -100 1000 #:facing 'left) - (slab 400 200 200) - (spawn-ground-block (vector 200 280) (vector 200 200) #:color "orange") - (slab 25 300 500) - (slab 600 1300 600) - (slab 1150 1200 25 #:color "red") - (for/list ((n 10)) - (slab 900 (+ 200 (* n 100)) 50))) - ) - )) - -(define (spawn-numbered-level level-number) - (if (< level-number (length levels)) - ((list-ref levels level-number)) - (spawn #:name 'victory-message - (assert (outbound - (let ((message (text "You won!" 72 "red"))) - (simple-sprite 0 - 10 - 100 - (image-width message) - (image-height message) - message))))))) - -(define (spawn-level-spawner starting-level) - (spawn #:name 'level-spawner - (field [current-level starting-level] - [level-complete? #f]) - - (on (message (level-completed)) (level-complete? #t)) - - (on (retracted (level-running)) - (current-level (if (level-complete?) (+ (current-level) 1) (current-level))) - (level-complete? #f) - (spawn-numbered-level (current-level))) - - (on-start (spawn-numbered-level starting-level)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Sounds - -(require racket/runtime-path) -(begin-for-declarations - (define-runtime-path sounds-path "./private/sounds")) -(define (lookup-sound-file sound-number) - (define sought-prefix (build-path sounds-path (format "~a__" sound-number))) - (for/or [(filename (in-directory sounds-path))] - (and (string-prefix? (path->string filename) (path->string sought-prefix)) - filename))) - -;; TODO: make this a sound driver... -;; TODO: ...and make sound triggering based on assertions of game -;; state, not hardcoding in game logic -(define (play-sound-sequence . sound-numbers) - (thread (lambda () - (for [(sound-number (in-list sound-numbers))] - (define sound-file (lookup-sound-file sound-number)) - (play-sound sound-file #f))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(spawn-keyboard-integrator) -(spawn-scene-manager) -(spawn-gl-2d-driver #:width 600 #:height 400) -(dataspace #:name 'game-dataspace - (spawn-score-keeper) - (spawn-level-spawner 0)) diff --git a/OLD-syndicate-examples/gui/README.md b/OLD-syndicate-examples/gui/README.md deleted file mode 100644 index f9f039b..0000000 --- a/OLD-syndicate-examples/gui/README.md +++ /dev/null @@ -1,22 +0,0 @@ -# Simple GUI experiments using Syndicate - -This directory contains UI experiments using -[Syndicate](http://syndicate-lang.org/) and its OpenGL 2D support. - -Files: - - - `gui.rkt`: Main entry point. Run `racket gui.rkt` to run the demo. - - - `layout/`: A simple widget layout engine, loosely inspired by TeX's boxes-and-glue model. - - - `sizing.rkt`: TeX-like "dimensions", including "fills" - - - `layout.rkt`: Uses "dimensions" to specify "table layouts", - which are then realized in terms of specified rectangle - coordinates - - - `hsv.rkt`: Utility for converting HSV colors to RGB. - -Screenshot: - -![Syndicate GUI screenshot](syndicate-gui-snapshot.png) diff --git a/OLD-syndicate-examples/gui/gui.rkt b/OLD-syndicate-examples/gui/gui.rkt deleted file mode 100644 index 952003a..0000000 --- a/OLD-syndicate-examples/gui/gui.rkt +++ /dev/null @@ -1,665 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(require racket/set) -(require data/order) -(require srfi/19) -(require (prefix-in i: 2htdp/image)) -(require (prefix-in p: pict)) -(require syndicate/drivers/gl-2d/affine) -(require "layout/main.rkt") -(require "hsv.rkt") -(require syndicate/bag) -(require syndicate/pattern) - -(require/activate syndicate/drivers/gl-2d) - -;;--------------------------------------------------------------------------- - -(define theme-font (make-parameter "Roboto")) -(define theme-font-size (make-parameter 16)) -(define theme-title-font (make-parameter "Roboto Condensed")) -(define theme-title-font-size (make-parameter 20)) -(define theme-title-font-color (make-parameter "white")) -(define theme-title-bar-color (make-parameter (hsv->color 260 1 0.6))) -(define theme-title-bar-selected-color (make-parameter (hsv->color 260 1 1))) -(define theme-title-bar-height (make-parameter 48)) -(define theme-button-background-color (make-parameter (hsv->color 30 0.9 1))) -(define theme-button-color (make-parameter "white")) -(define theme-button-x-padding (make-parameter 40)) -(define theme-button-y-padding (make-parameter 24)) -(define theme-button-min-height (make-parameter 48)) -(define theme-window-border-width (make-parameter 8)) -(define theme-window-resize-corner-size (make-parameter 16)) -(define theme-menu-item-color (make-parameter "white")) -(define theme-menu-item-background-color (make-parameter (hsv->color 240 1 0.8))) -(define theme-menu-item-selected-background-color (make-parameter (hsv->color 345 1 1))) -(define theme-menu-item-padding (make-parameter 16)) -(define theme-menu-separator-width (make-parameter 2)) -(define theme-menu-separator-color (make-parameter "white")) - -;;--------------------------------------------------------------------------- - -(define (*width x) - (cond [(i:image? x) (i:image-width x)] - [(p:pict? x) (p:pict-width x)] - [else (error '*width "Neither an image nor a pict: ~v" x)])) - -(define (*height x) - (cond [(i:image? x) (i:image-height x)] - [(p:pict? x) (p:pict-height x)] - [else (error '*height "Neither an image nor a pict: ~v" x)])) - -(define (costume #:id [id #f] #:parent [parent-id #f] #:coordinate-map-id [coordinate-map-id #f] i) - (define iw (*width i)) - (define ih (*height i)) - (define iaspect (/ iw ih)) - (lambda (z rect) - (match-define (rectangle left top sw sh) rect) - (define saspect (if (and (positive? sw) (positive? sh)) (/ sw sh) 1)) - (define-values (scale-w scale-h translate-x translate-y) - (if (> saspect iaspect) - (let ((scale-h (/ sw iaspect))) - (values sw scale-h 0 (/ (- sh scale-h) 2))) - (let ((scale-w (* sh iaspect))) - (values scale-w sh (/ (- sw scale-w) 2) 0)))) - (sprite #:id (or id (gensym 'costume)) - #:parent parent-id - z - `((translate ,left ,top) - (push-matrix (scale ,sw ,sh) - ,@(if id - `((touchable ,id ,in-unit-square?)) - `()) - ,@(if coordinate-map-id - `((coordinate-map ,coordinate-map-id)) - `()) - (texture ,i - ,(- (/ translate-x scale-w)) - ,(- (/ translate-y scale-h)) - ,(/ sw scale-w) - ,(/ sh scale-h) - )) - (render-children))))) - -(define (draggable-mixin touching? x y id-to-raise) - (define (idle) - (react (stop-when #:when (touching?) - (message (mouse-event 'left-down (mouse-state $mx $my _ _ _))) - (dragging (- mx (x)) (- my (y)))))) - - (define (dragging dx dy) - (when id-to-raise (send! (raise-widget id-to-raise))) - (react (on (message (mouse-event 'motion (mouse-state $mx $my _ _ _))) - (x (- mx dx)) - (y (- my dy))) - (stop-when (message (mouse-event 'left-up _)) (idle)) - (stop-when (message (mouse-event 'leave _)) (idle)))) - - (idle)) - -(spawn #:name 'root-window - (define c (costume #:id 'root (i:bitmap "oakura-beach-20081225.jpg"))) - (define/query-value touching? #f (touching 'root) #t) - (on #:when (touching?) (message (mouse-event 'right-down (mouse-state $x $y _ _ _))) - (send! (pop-up-menu-trigger 'system-menu x y 0 0.5 'right-up))) - ;; (during (window $width $height) - ;; (assert-scene `((translate ,width 0) (rotate -90)) `()) - ;; (assert (desktop height width)) - ;; (assert (c 0 (rectangle 0 0 height width)))) - (during (window $width $height) - (assert (desktop width height)) - (assert (c 0 (rectangle 0 0 width height)))) - ) - -(define (button-underlay i) - (define w (+ (*width i) (theme-button-x-padding))) - (define h (max (+ (*height i) (theme-button-y-padding)) (theme-button-min-height))) - (i:rectangle w h "solid" (theme-button-background-color))) - -;;--------------------------------------------------------------------------- -;; Protocol: Layout. -;;--------------------------------------------------------------------------- -;; Roles: -;; -;; Layout Solver -;; Responds to assertions of interest in layout solutions by -;; computing layouts and asserting the resulting positions. -;; -;; (Observe LayoutSolution)+ ==> -;; RequestedLayoutSize ==> -;; ComputedLayoutSize ∧ LayoutSolution+ -;; -;; Layout Observer -;; Supplies any initial constraints on the overall layout size, -;; and may observe the final overall computed layout size. -;; -;; RequestedLayoutSize ∧ (ComputedLayoutSize ==> 1)? -;; -;; Layout Participant -;; Supplies constraints on an individual item to be laid out -;; and monitors the resulting position decision for that item. -;; -;; LayoutSolution ==> 1 -;;--------------------------------------------------------------------------- - -;; A LayoutSpec is one of -;; - (horizontal-layout Any) -;; - (vertical-layout Any) -;; - (tabular-layout Nat Nat) -;; where the first two use their keys for *ordering* peers relative to -;; each other using datum-order, and the last uses the given row and -;; column to place the item within an implicitly-sized grid layout. -(struct horizontal-layout (key) #:transparent) -(struct vertical-layout (key) #:transparent) -(struct tabular-layout (row col) #:transparent) - -;; ASSERTION. A RequestedLayoutSize is a -;; (requested-layout-size Any (Option (box-size (Option Sizing) (Option Sizing)))) -;; and describes overall constraints on the total size of the layout to be -;; constructed. Supplying `size` as `#f` means that there is no constraint at all; -;; otherwise, the `box-size` given is used as the exact dimensions of -;; the layout, unless one or both of the dimensions of the `box-size` -;; are given as `#f`, in which case there is no constraint for that -;; dimension. -(struct requested-layout-size (container-id size) #:transparent) - -;; ASSERTION. A ComputedLayoutSize is a -;; (computed-layout-size Any BoxSize) -;; and gives the concrete dimensions of the layout after layout -;; computation has completed. -(struct computed-layout-size (container-id size) #:transparent) - -;; ASSERTION. A LayoutSolution is a -;; (layout-solution Any LayoutSpec BoxSize Rectangle) -;; and denotes the computed bounds of a given item within a layout. -;; TODO: introduce an item ID?? -(struct layout-solution (container-id - spec - size - rectangle) #:transparent) - -;; ASSERTION. Describes the size of the desktop area. -(struct desktop (width height) #:transparent) - -;;--------------------------------------------------------------------------- - -(struct layout-item (spec size) #:transparent) - -(define (layout-item-spec-key li) - (define v (layout-item-spec li)) - (if (number? v) (exact->inexact v) v)) - -(spawn #:name 'layout-driver - (during/spawn (observe (layout-solution $container-id _ _ _)) - #:name (list 'layout container-id) - (stop-when (asserted (observe (layout-solution container-id (horizontal-layout _) _ _))) - (react (solve-hv-layout #f container-id))) - (stop-when (asserted (observe (layout-solution container-id (vertical-layout _) _ _))) - (react (solve-hv-layout #t container-id))) - (stop-when (asserted (observe (layout-solution container-id (tabular-layout _ _) _ _))) - (react (solve-tabular-layout container-id))))) - -(define (solve-hv-layout vertical? container-id) - (field [items (set)]) - - (if vertical? - (query-set* items - (observe (layout-solution container-id (vertical-layout $key) $size _)) - (layout-item key size)) - (query-set* items - (observe (layout-solution container-id (horizontal-layout $key) $size _)) - (layout-item key size))) - - (define/dataflow ordered-items (sort (set->list (items)) - (order-list (items)))) - (row-count (+ 1 (apply max -1 (map car specs)))) - (col-count (+ 1 (apply max -1 (map cdr specs)))) - (mtx (for/vector [(r row-count)] (make-vector col-count #f)))) - (for [(item (items))] - (vector-set! (vector-ref mtx (car (layout-item-spec item))) - (cdr (layout-item-spec item)) - item)) - mtx)) - (define/dataflow table - (for/list [(row (items-table))] - (for/list [(item row)] - (if item (layout-item-size item) weak-fill-box-size)))) - - (solve-layout* container-id - table - (lambda (layout) - (define mtx (list->vector (map list->vector layout))) - (for [(item (items))] - (match-define (cons row col) (layout-item-spec item)) - (assert! (layout-solution container-id - (tabular-layout row col) - (layout-item-size item) - (vector-ref (vector-ref mtx row) col))))))) - -;;--------------------------------------------------------------------------- - -;; TODO: Having pop-up-menu-trigger be a message means that it's not -;; possible to cancel or move the menu once it has been triggered. -;; Consider using the "start" button in the corner to pop up a menu, -;; following which the screen is resized before the menu is dismissed. -;; Currently, the menu will continue to float in an incorrect location -;; rather than following the screen resize. If, however, the trigger -;; for a menu was an assertion, then the menu could track changes in -;; its triggering parameters and could be repositioned without fuss. - -(struct pop-up-menu-trigger (menu-id x y x-pin y-pin release-event) #:transparent) -(struct menu-separator (menu-id order) #:transparent) -(struct menu-item (menu-id order image message) #:transparent) - -(spawn #:name 'pop-up-menu-driver - (on (message (pop-up-menu-trigger $menu-id $x $y $x-pin $y-pin $release-event)) - (run-pop-up-menu menu-id x y x-pin y-pin release-event))) - -(define (run-pop-up-menu menu-id pop-up-cursor-x pop-up-cursor-y x-pin y-pin release-event) - (define instance-id (list menu-id (gensym 'instance))) - (define pad (theme-menu-item-padding)) - (define pad2 (* pad 2)) - (define normal (i:rectangle 1 1 "solid" (theme-menu-item-background-color))) - (define highlight (i:rectangle 1 1 "solid" (theme-menu-item-selected-background-color))) - (define separator (i:rectangle 1 1 "solid" (theme-menu-separator-color))) - (spawn #:name instance-id - (assert (requested-layout-size instance-id #f)) - (during (menu-item menu-id $order $sealed-image $msg) - (define item-id (gensym 'item)) - (define im (seal-contents sealed-image)) - (define imsize (box-size (sizing (+ pad2 (*width im)) 0 0) - (sizing (+ pad2 (*height im)) 0 0))) - (during (layout-solution instance-id (vertical-layout order) imsize $rect) - (match-define (rectangle left top width height) rect) - (assert (sprite #:id item-id #:parent instance-id - 0 - `((translate ,left ,top) - (push-matrix - (scale ,width ,height) - (touchable (,instance-id ,item-id ,msg) ,in-unit-square?) - (texture ,(if (eq? (selected-item) item-id) highlight normal))) - (push-matrix - (translate ,pad ,pad) - (scale ,(*width im) ,(*height im)) - (texture ,im))))))) - - (during (menu-separator menu-id $order) - (define sep-id (gensym 'sep)) - (during (layout-solution instance-id (vertical-layout order) - (box-size weak-fill-sizing - (sizing (theme-menu-separator-width) 0 0)) - $rect) - (match-define (rectangle left top width height) rect) - (assert (sprite #:id sep-id #:parent instance-id - 0 - `((translate ,left ,top) - (scale ,width ,height) - (texture ,separator)))))) - - (during (computed-layout-size instance-id $menu-size) - (match-define (box-size (sizing menu-width _ _) (sizing menu-height _ _)) menu-size) - (define offset-x (- pop-up-cursor-x (* x-pin (+ menu-width 2)) -1)) - (define offset-y (- pop-up-cursor-y (* y-pin (+ menu-height 2)) -1)) - (assert (sprite #:id instance-id - -1 - `((translate ,offset-x ,offset-y) - (render-children))))) - - (define/query-value selected-item #f (touching `(,instance-id ,$i ,_)) i) - (define/query-value selected-msg #f (touching `(,instance-id ,_ ,$msg)) msg) - (stop-when (message (mouse-event release-event _)) - (when (selected-item) (send! (selected-msg)))))) - -;;--------------------------------------------------------------------------- - -(define (system-text str [color #f]) - (i:text/font str (theme-font-size) (or color "white") - (theme-font) 'default 'normal 'normal #f)) - -(define (title-font-text str) - (i:text/font str (theme-title-font-size) (theme-title-font-color) - (theme-title-font) 'default 'normal 'normal #f)) - -(define (menu-item/text menu-id order str message) - (menu-item menu-id order (seal (system-text str (theme-menu-item-color))) message)) - -;;--------------------------------------------------------------------------- - -(struct window-state (window-id title state) #:transparent) -(struct raise-widget (id) #:transparent) -(struct top-widget (id) #:transparent) - -(define close-icon-i - (parameterize ((theme-font-size (round (* 4/3 (theme-title-font-size))))) - (system-text "×" (theme-title-font-color)))) - -(define (window-frame id title backdrop-color - #:close-icon? [close-icon? #t] - #:parent [parent-id 'root]) - (define title-text-i (title-font-text title)) - (define title-text-w (i:image-width title-text-i)) - (define title-text-h (i:image-height title-text-i)) - (define (title-bar-i focus?) (i:rectangle 1 1 "solid" - (if focus? - (theme-title-bar-selected-color) - (theme-title-bar-color)))) - (define close-icon-w (i:image-width close-icon-i)) - (define close-icon-h (i:image-height close-icon-i)) - (define gap (/ (- (theme-title-bar-height) close-icon-w) 2)) - (define backdrop (i:rectangle 1 1 "solid" backdrop-color)) - (lambda (z rect focus?) - (match-define (rectangle left top width height) rect) - (sprite #:id id - #:parent parent-id - z - `((translate ,left ,top) - (push-matrix (translate ,(- (theme-window-border-width)) - ,(- (theme-title-bar-height))) - (scale ,(+ width (* 2 (theme-window-border-width))) - ,(+ height (theme-title-bar-height) (theme-window-border-width))) - (touchable (,id window-backdrop) ,in-unit-square?) - (texture ,(title-bar-i focus?))) - (push-matrix (translate 0 ,(- (theme-title-bar-height))) - (scale ,width ,(theme-title-bar-height)) - (touchable (,id title-bar) ,in-unit-square?)) - (push-matrix (translate ,(- (+ width (theme-window-border-width)) - (theme-window-resize-corner-size)) - ,(- (+ height (theme-window-border-width)) - (theme-window-resize-corner-size))) - (scale ,(theme-window-resize-corner-size) - ,(theme-window-resize-corner-size)) - (touchable (,id resize-corner) ,in-unit-square?)) - ,@(if close-icon? - `((push-matrix - (translate ,gap ,(- (/ (+ (theme-title-bar-height) close-icon-h) 2))) - (scale ,close-icon-w ,close-icon-h) - (touchable (,id close-icon) ,in-unit-square?) - (texture ,close-icon-i))) - `()) - (push-matrix (translate ,(/ (- width title-text-w) 2) - ,(- (/ (+ (theme-title-bar-height) title-text-h) 2))) - (scale ,title-text-w ,title-text-h) - (texture ,title-text-i)) - (push-matrix (scale ,width ,height) - (texture ,backdrop)) - (render-children))))) - -(define (open-window window-id window-title x y width height [backdrop-color (hsv->color 200 1 1)] - #:resizable? [resizable? #t]) - (define c (window-frame window-id window-title backdrop-color)) - - (field [z (- (current-inexact-milliseconds))]) - (define/query-value touching-title-bar? - #f (touching `(,window-id title-bar)) #t) - (on-start (draggable-mixin touching-title-bar? x y window-id)) - - (when resizable? - (define/query-value touching-resize-corner? - #f (touching `(,window-id resize-corner)) #t) - (on-start (draggable-mixin touching-resize-corner? width height window-id))) - - (define/query-value touching-close-icon? - #f (touching `(,window-id close-icon)) #t) - (stop-when #:when (touching-close-icon?) (message (mouse-event 'left-up _))) - - (on (message (raise-widget window-id)) - (z (- (current-inexact-milliseconds)))) - - (define/query-value focus? #f (top-widget window-id) #t) - - (define/dataflow bounds (rectangle (x) (y) (width) (height)) #:default zero-rectangle) - (assert (window-state window-id window-title (bounds))) - (assert (c (z) (bounds) (focus?)))) - -(spawn #:name 'top-widget-monitor - (local-require data/heap) - - (define *widget-heap* (make-heap (lambda (a b) (<= (cdr a) (cdr b))))) - (field [widget-heap-version 0]) - (define (widget-heap) (begin (widget-heap-version) *widget-heap*)) ;; gross hack - ;; ^ this is to cope with the use of mutable data in a field. - ;; Field update only registers damage if the field *changes*, as detected by `equal?`. - (define (trigger-dependencies!) (widget-heap-version (+ (widget-heap-version) 1))) - - (on (asserted ( $id 'root $z _)) - (heap-add! (widget-heap) (cons id z)) - (trigger-dependencies!)) - (on (retracted ( $id 'root $z _)) - (heap-remove! (widget-heap) (cons id z)) - (trigger-dependencies!)) - - (assert #:when (positive? (heap-count (widget-heap))) - (top-widget (car (heap-min (widget-heap)))))) - -;;--------------------------------------------------------------------------- - -(struct button-click (id mouse-state) #:transparent) - -(begin-for-declarations - ;; TODO: figure out what it is about (define (f #:x x) x) that - ;; mandates begin-for-declarations to hide it from syndicate/lang's - ;; local-expansion here :-( - (define (pushbutton label-str x y [w #f] [h #f] - #:shrink-x [shrink-x 0] - #:id id - #:coordinate-map-id [coordinate-map-id #f] - #:parent parent-id - #:trigger-event [trigger-event 'left-up]) - (define label (system-text label-str (theme-button-color))) - (define i (i:overlay/align "middle" "middle" label (button-underlay label))) - (define c (costume #:id id #:parent parent-id #:coordinate-map-id coordinate-map-id i)) - - (define/query-value touching? #f (touching id) #t) - (on #:when (touching?) (message (mouse-event trigger-event $s)) - (send! (button-click id s))) - (assert (c 0 (rectangle (x) - (y) - (or (and w (w)) (*width i)) - (or (and h (h)) (*height i))))) - (box-size (sizing (*width i) 0 (* shrink-x (*width i))) (sizing (*height i) 0 0)))) - -;;--------------------------------------------------------------------------- - -(define (enforce-minimum f v) - (begin/dataflow (when (< (f) v) (f v)))) - -(begin-for-declarations - (define (message-box title init-x init-y body #:id id) - (define msg (system-text body)) - (spawn #:name (list 'message-box id) - (field [x init-x] - [y init-y] - [width (max 250 (*width msg))] - [height (max 100 (*height msg))]) - (open-window id title x y width height #:resizable? #f) - (assert ((costume #:parent id msg) - 0 - (rectangle (/ (- (width) (*width msg)) 2) - (/ (- (height) (*height msg)) 2) - (*width msg) - (*height msg))))))) - -(spawn #:name 'test-window - - (field [x 140] [y 140] [width 400] [height 300]) - (open-window 'w "Window Title" x y width height) - (enforce-minimum width 300) - (enforce-minimum height 300) - - (assert (menu-item/text 'testmenu 0 "First item" '(testmenu first))) - (assert (menu-item/text 'testmenu 1 "Second item" '(testmenu second))) - (assert (menu-item/text 'testmenu 2 "Third item" '(testmenu third))) - - (during (desktop $width $height) - (on (message `(testmenu ,$which)) - (define box-id (gensym 'box)) - (message-box #:id box-id - (date->string (seconds->date (current-seconds)) - "Selected at ~3") - (random width) (random height) - (format "~a" which)))) - - (pushbutton "Click me" - (lambda () 100) - (lambda () 100) - #:id 'click-me #:parent 'w #:trigger-event 'left-down) - (on (message (button-click 'click-me (mouse-state $x $y _ _ _))) - (send! (pop-up-menu-trigger 'testmenu x y 0 0.5 'left-up)))) - -;;--------------------------------------------------------------------------- - -(spawn #:name 'fullscreen-menu-item - (field [fullscreen? #f]) - (assert (menu-item/text 'system-menu -1 - (if (fullscreen?) - "Fullscreen ✓" - "Fullscreen") - '(system-menu toggle-fullscreen))) - (assert (menu-separator 'system-menu -0.9)) - (on (message '(system-menu toggle-fullscreen)) - (fullscreen? (not (fullscreen?)))) - (assert #:when (fullscreen?) (gl-control 'fullscreen))) - -(spawn #:name 'quit-menu-item - (assert (menu-item/text 'system-menu 0 "Quit" '(system-menu quit))) - (stop-when (message '(system-menu quit)) - (send! (gl-control 'stop))) - (stop-when (message (key-event #\q #t _)) - (send! (gl-control 'stop)))) - -(spawn #:name 'toolbar - - (field [window-width 0] [window-height 0]) - (on (asserted (desktop $w $h)) - (window-width w) - (window-height h)) - - (define pad 4) ;;(theme-menu-item-padding)) - (define pad2 (* pad 2)) - - (assert (requested-layout-size 'toolbar (box-size (sizing (- (window-width) pad2) 0 0) #f))) - (assert (observe (layout-solution 'toolbar - (horizontal-layout '(0.0 0.0)) - weak-fill-box-size - (discard)))) - - (during (computed-layout-size 'toolbar (box-size (sizing $w _ _) (sizing $h _ _))) - (assert (sprite #:id 'toolbar #:parent #f - -0.5 - `((translate 0 ,(- (window-height) h pad2)) - (push-matrix (scale ,(window-width) ,(+ h pad2)) - (touchable toolbar ,in-unit-square?) - (texture ,(i:rectangle 1 1 "solid" "black"))) - (translate ,pad ,pad) - (render-children)))))) - -(spawn #:name 'start-button - (field [x 0] [y 0]) - (define reqsize - (parameterize ((theme-button-y-padding 8) - (theme-button-min-height 0)) - (pushbutton "Start" x y #:id 'start-button #:parent 'toolbar - #:coordinate-map-id 'start-button - #:trigger-event 'left-down))) - (during (layout-solution 'toolbar (horizontal-layout '(-10.0 0.0)) reqsize - (rectangle $l $t $w $h)) - (x l) - (y t) - (during (coordinate-map 'start-button $xform) - (on (message (button-click 'start-button _)) - (define pt (- (transform-point xform 0+0i) 1+4i)) ;; padding + unoffset - (send! - (pop-up-menu-trigger 'system-menu (real-part pt) (imag-part pt) 0 1 'left-up)))))) - -(spawn #:name 'window-list-monitor - (during/spawn (window-state $id $title _) - #:name (list 'window-list id) - (field [x 0] [y 0] [width #f] [height #f]) - (define reqsize - (parameterize ((theme-button-y-padding 8) - (theme-button-min-height 0) - (theme-button-background-color (hsv->color 240 1 0.6))) - (pushbutton title x y width height #:id (list 'window-list id) #:parent 'toolbar - #:shrink-x 1 - #:trigger-event 'left-down))) - (during (layout-solution 'toolbar (horizontal-layout `(-5.0 ,id)) reqsize - (rectangle $l $t $w $h)) - (begin (x l) (y t) (width w) (height h)) - (during (top-widget id) - (assert (sprite #:id (list 'window-list id 'highlight) - #:parent (list 'window-list id) - 0 - `((translate 0 ,(- h 1)) - (scale ,w 1) - (texture ,(i:rectangle 1 1 "solid" "white")))))) - (on (message (button-click (list 'window-list id) _)) - (send! (raise-widget id)))))) - -(spawn #:name 'clock - (field [now (current-seconds)]) - (on (message (frame-event _ $timestamp _ _)) - (define new (current-seconds)) - (when (not (= new (now))) (now new))) - (define/dataflow now-im (system-text (date->string (seconds->date (now)) "~a ~b ~d, ~3")) - #:default i:empty-image) - (during (layout-solution 'toolbar (horizontal-layout '(10.0 0.0)) - (box-size (sizing (*width (now-im)) 0 0) - (sizing (*height (now-im)) 0 0)) - (rectangle $l $t $w $h)) - (assert (sprite #:id 'clock #:parent 'toolbar - 0 - `((translate ,l ,(+ t (/ (- h (*height (now-im))) 2))) - (scale ,(*width (now-im)) ,(*height (now-im))) - (texture ,(now-im))))))) - -(spawn-gl-2d-driver) diff --git a/OLD-syndicate-examples/gui/hsv.rkt b/OLD-syndicate-examples/gui/hsv.rkt deleted file mode 100644 index c5556a2..0000000 --- a/OLD-syndicate-examples/gui/hsv.rkt +++ /dev/null @@ -1,32 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang racket/base - -(provide fmod - hsv->color - color-by-hash) - -(require 2htdp/image) - -(define (fmod a b) - (- a (* b (truncate (/ a b))))) - -(define (hsv->color h s v) - (define h* (fmod (/ h 60.0) 6)) - (define chroma (* v s)) - (define x (* chroma (- 1 (abs (- (fmod h* 2) 1))))) - (define-values (r g b) - (cond - [(< h* 1) (values chroma x 0)] - [(< h* 2) (values x chroma 0)] - [(< h* 3) (values 0 chroma x)] - [(< h* 4) (values 0 x chroma)] - [(< h* 5) (values x 0 chroma)] - [else (values chroma 0 x)])) - (define m (- v chroma)) - (define (scale x) (inexact->exact (truncate (* 255 (+ x m))))) - (make-color (scale r) (scale g) (scale b))) - -(define (color-by-hash v) - (hsv->color (* 360.0 (/ (bitwise-and (equal-hash-code v) 16777215) 16777216.0)) 1 1)) diff --git a/OLD-syndicate-examples/gui/layout/layout.rkt b/OLD-syndicate-examples/gui/layout/layout.rkt deleted file mode 100644 index 7a4f4a8..0000000 --- a/OLD-syndicate-examples/gui/layout/layout.rkt +++ /dev/null @@ -1,194 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang racket/base -;; Tabular layout - -(provide table-sizing - table-layout) - -(require racket/match) -(require "sizing.rkt") - -(module+ test (require rackunit)) - -;;--------------------------------------------------------------------------- - -(define (transpose rows) - (if (null? rows) - '() - (apply map list rows))) - -(define (swedish-round x) - (floor (+ x 1/2))) - -;;--------------------------------------------------------------------------- - -(define (table-sizing box-sizes) - (box-size (sizing-sum (table-column-widths box-sizes)) - (sizing-sum (table-row-heights box-sizes)))) - -(define (table-row-heights box-sizes) - (map transverse-sizing (extract box-size-vertical box-sizes))) - -(define (table-column-widths box-sizes) - (map transverse-sizing (extract box-size-horizontal (transpose box-sizes)))) - -(define (extract acc mtx) - (map (lambda (r) (map acc r)) mtx)) - -(define (transverse-sizing sizings) - (define-values (lb-v lb-f) (transverse-bound sizings sizing-shrink - max)) - (define-values (ub-v ub-f) (transverse-bound sizings sizing-stretch + min)) - (let* ((ideal-v (foldl max 0 (map sizing-ideal sizings))) - (ideal-v (if ub-v (min ideal-v ub-v) ideal-v)) - (ideal-v (if lb-v (max ideal-v lb-v) ideal-v))) - (sizing ideal-v - (if ub-v (- ub-v ideal-v) ub-f) - (if lb-v (- ideal-v lb-v) lb-f)))) - -(define (transverse-bound sizings sizing-accessor minus-or-plus max-or-min) - (define vals (for/list [(s sizings) #:when (number? (sizing-accessor s))] - (minus-or-plus (sizing-ideal s) (sizing-accessor s)))) - (values (and (pair? vals) (apply max-or-min vals)) - (foldl fill-max 0 (filter fill? (map sizing-accessor sizings))))) - -;;--------------------------------------------------------------------------- - -(define (table-layout box-sizes top left width height #:round [round? #t]) - (define row-sizings (table-row-heights box-sizes)) - (define col-sizings (table-column-widths box-sizes)) - (define row-heights (compute-concrete-adjacent-sizes row-sizings height)) - (define col-widths (compute-concrete-adjacent-sizes col-sizings width)) - (define local-round (if round? swedish-round values)) - (define-values (_bot rows-rev) - (for/fold [(top top) (rows-rev '())] [(row-height row-heights)] - (define next-top (+ top row-height)) - (define rounded-top (local-round top)) - (define rounded-height (- (local-round next-top) rounded-top)) - (define-values (_right cells-rev) - (for/fold [(left left) (cells-rev '())] [(col-width col-widths)] - (define next-left (+ left col-width)) - (define rounded-left (local-round left)) - (define rounded-width (- (local-round next-left) rounded-left)) - (values next-left - (cons (rectangle rounded-left - rounded-top - rounded-width - rounded-height) - cells-rev)))) - (values next-top - (cons (reverse cells-rev) rows-rev)))) - (reverse rows-rev)) - -(define (compute-concrete-adjacent-sizes sizings actual-bound) - (define ideal-total (foldl + 0 (map sizing-ideal sizings))) - (define-values (available-slop sizing-give apply-give) - (if (<= ideal-total actual-bound) - (values (- actual-bound ideal-total) sizing-stretch +) - (values (- ideal-total actual-bound) sizing-shrink -))) - (define total-give (foldl fill+ 0 (map sizing-give sizings))) - (if (number? total-give) - (let ((scale (if (zero? total-give) 0 (/ available-slop total-give)))) - (map (lambda (s) - ;; numeric total-give ⇒ no fills for any give in the list - (apply-give (sizing-ideal s) (* (sizing-give s) scale))) - sizings)) - (let* ((weight (fill-weight total-give)) - (rank (fill-rank total-give)) - (scale (if (zero? weight) 0 (/ available-slop weight)))) - (map (lambda (s) - (match (sizing-give s) - [(fill w (== rank)) (apply-give (sizing-ideal s) (* w scale))] - [_ (sizing-ideal s)])) - sizings)))) - -;;--------------------------------------------------------------------------- - -(module+ test - (check-equal? (transpose '((1 2 3) (4 5 6) (7 8 9))) '((1 4 7) (2 5 8) (3 6 9))) - (check-equal? (swedish-round 0.1) 0.0) - (check-equal? (swedish-round 0.5) 1.0) - (check-equal? (swedish-round 0.9) 1.0) - (check-equal? (swedish-round 1.1) 1.0) - (check-equal? (swedish-round 1.5) 2.0) - (check-equal? (swedish-round 1.9) 2.0)) - -(module+ test - (define s211 (sizing 2 1 1)) - (define s0f0 (sizing 0 weak-fill 0)) - (define b22 (box-size s211 s211)) - (define b42 (box-size (sizing 4 1 1) s211)) - (define b62 (box-size (sizing 6 1 1) s211)) - (define b00 (box-size s0f0 s0f0)) - - (define t1 (list (list b22 b22 b00 b22) - (list b22 b22 b00 b22) - (list b22 b22 b00 b22))) - - (define t2 (list (list b22 b22 b22) - (list b22 b00 b22) - (list b22 b22 b22))) - - (define t3 (list (list b22 b42 b22) - (list b22 b00 b22) - (list b22 b22 b22))) - - (define t4 (list (list b22 b62 b22) - (list b22 b00 b22) - (list b22 b22 b22))) - - (check-equal? (table-sizing t1) - (box-size (sizing 6 weak-fill 3) - (sizing 6 3 3))) - - (check-equal? (table-sizing t2) - (box-size (sizing 6 3 3) - (sizing 6 3 3))) - - ;; Is this sane? - (check-equal? (table-sizing t3) - (box-size (sizing 7 2 2) - (sizing 6 3 3))) - - ;; Is this sane? - (check-equal? (table-sizing t4) - (box-size (sizing 9 0 2) - (sizing 6 3 3))) - - (check-equal? (table-layout t1 0 0 20 20) - (list (list (rectangle 0 0 2 7) - (rectangle 2 0 2 7) - (rectangle 4 0 14 7) - (rectangle 18 0 2 7)) - (list (rectangle 0 7 2 6) - (rectangle 2 7 2 6) - (rectangle 4 7 14 6) - (rectangle 18 7 2 6)) - (list (rectangle 0 13 2 7) - (rectangle 2 13 2 7) - (rectangle 4 13 14 7) - (rectangle 18 13 2 7)))) - - (check-equal? (table-layout t2 0 0 20 20) - (list (list (rectangle 0 0 7 7) - (rectangle 7 0 6 7) - (rectangle 13 0 7 7)) - (list (rectangle 0 7 7 6) - (rectangle 7 7 6 6) - (rectangle 13 7 7 6)) - (list (rectangle 0 13 7 7) - (rectangle 7 13 6 7) - (rectangle 13 13 7 7)))) - - ;; Is this sane? - (check-equal? (table-layout t3 0 0 20 20) - (list (list (rectangle 0 0 9 7) - (rectangle 9 0 3 7) - (rectangle 12 0 8 7)) - (list (rectangle 0 7 9 6) - (rectangle 9 7 3 6) - (rectangle 12 7 8 6)) - (list (rectangle 0 13 9 7) - (rectangle 9 13 3 7) - (rectangle 12 13 8 7))))) diff --git a/OLD-syndicate-examples/gui/layout/main.rkt b/OLD-syndicate-examples/gui/layout/main.rkt deleted file mode 100644 index c109228..0000000 --- a/OLD-syndicate-examples/gui/layout/main.rkt +++ /dev/null @@ -1,11 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang racket/base -;; Layout, based loosely on TeX's boxes-and-glue model. - -(require "sizing.rkt") -(require "layout.rkt") - -(provide (all-from-out "sizing.rkt") - (all-from-out "layout.rkt")) diff --git a/OLD-syndicate-examples/gui/layout/sizing.rkt b/OLD-syndicate-examples/gui/layout/sizing.rkt deleted file mode 100644 index b9b1f0b..0000000 --- a/OLD-syndicate-examples/gui/layout/sizing.rkt +++ /dev/null @@ -1,153 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang racket/base -;; Dimension sizing, based loosely on TeX's boxes-and-glue model. - -(provide (struct-out fill) - (struct-out sizing) - (struct-out box-size) - (struct-out rectangle) - - weak-fill - zero-sizing - weak-fill-sizing - zero-box-size - weak-fill-box-size - zero-rectangle - - fill+ - fill-max - fill-min - fill-scale - fill-weaken - - sizing-contains? - sizing-min - sizing-max - sizing-overlap? - sizing-scale - sizing-weaken - sizing-pad - sizing-adjust-ideal - sizing-sum - - box-size-weaken) - -(require racket/match) - -;;--------------------------------------------------------------------------- - -;; A Fill is one of -;; - a Nat, a fixed amount of space -;; - a (fill Nat Nat), a potentially infinite amount of space -(struct fill (weight rank) #:transparent) - -;; A Sizing is a (sizing Nat Fill Fill) -(struct sizing (ideal stretch shrink) #:transparent) - -;; A BoxSize is a (box-size Sizing Sizing) -(struct box-size (horizontal vertical) #:transparent) - -;; A Rectangle is a (rectangle Nat Nat BoxSize) -(struct rectangle (left top width height) #:transparent) - -;;--------------------------------------------------------------------------- - -;; A very weak fill. -(define weak-fill (fill 1 -1)) - -(define zero-sizing (sizing 0 0 0)) - -(define weak-fill-sizing (sizing 0 weak-fill 0)) - -(define zero-box-size (box-size zero-sizing zero-sizing)) - -(define weak-fill-box-size (box-size weak-fill-sizing weak-fill-sizing)) - -(define zero-rectangle (rectangle 0 0 0 0)) - -;;--------------------------------------------------------------------------- - -;; (Nat Nat -> Nat) -> (Fill Fill -> Fill) -(define ((fill-binop op) a b) - (match* (a b) - [((? number?) (? number?)) (op a b)] - [((? number?) (? fill?)) b] - [((? fill?) (? number?)) a] - [((fill w1 r1) (fill w2 r2)) - (cond [(= r1 r2) (fill (op w1 w2) r1)] - [(> r1 r2) (fill w1 r1)] - [(< r1 r2) (fill w2 r2)])])) - -;; Fill Fill -> Fill -(define fill+ (fill-binop +)) -(define fill-max (fill-binop max)) -(define (fill-min a b) - (if (and (number? a) (number? b)) - (min a b) - 0)) - -(define (fill-scale f scale) - (if (number? f) - (* f scale) - f)) - -(define (fill-weaken f w r) - (if (fill? f) - (fill w r) - f)) - -(define (sizing-contains? s v) - (match-define (sizing x x+ x-) s) - (cond [(>= v x) (if (number? x+) (<= v (+ x x+)) #t)] - [(<= v x) (if (number? x-) (>= v (- x x-)) #t)])) - -(define (sizing-min s) - (match (sizing-shrink s) - [(? number? n) (- (sizing-ideal s) n)] - [(? fill?) -inf.0])) - -(define (sizing-max s) - (match (sizing-stretch s) - [(? number? n) (+ (sizing-ideal s) n)] - [(? fill?) +inf.0])) - -(define (sizing-overlap? x y) - (define largest-min (max (sizing-min x) (sizing-min y))) - (define smallest-max (min (sizing-max x) (sizing-max y))) - (< largest-min smallest-max)) - -(define (sizing-scale s scale) - (match-define (sizing x x+ x-) s) - (sizing (* x scale) (fill-scale x+ scale) (fill-scale x- scale))) - -(define (sizing-weaken s - [stretch-weight 1] - [stretch-rank 0] - [shrink-weight stretch-weight] - [shrink-rank stretch-rank]) - (match-define (sizing x x+ x-) s) - (sizing x - (fill-weaken x+ stretch-weight stretch-rank) - (fill-weaken x- shrink-weight shrink-rank))) - -(define (sizing-pad s amount) - (match-define (sizing x x+ x-) s) - (sizing (+ x amount) x+ x-)) - -(define (sizing-adjust-ideal s i) - (match-define (sizing x x+ x-) s) - (sizing i - (if (fill? x+) x+ (+ x+ (- x i))) - (if (fill? x-) x- (- x- (- x i))))) - -(define (sizing-sum sizings) - (sizing (foldl + 0 (map sizing-ideal sizings)) - (foldl fill+ 0 (map sizing-stretch sizings)) - (foldl fill+ 0 (map sizing-shrink sizings)))) - -(define (box-size-weaken bs [weight 1] [rank 0]) - (match-define (box-size h v) bs) - (box-size (sizing-weaken h weight rank) - (sizing-weaken v weight rank))) diff --git a/OLD-syndicate-examples/gui/oakura-beach-20081225.jpg b/OLD-syndicate-examples/gui/oakura-beach-20081225.jpg deleted file mode 100644 index 2b134a7..0000000 Binary files a/OLD-syndicate-examples/gui/oakura-beach-20081225.jpg and /dev/null differ diff --git a/OLD-syndicate-examples/gui/syndicate-gui-snapshot.png b/OLD-syndicate-examples/gui/syndicate-gui-snapshot.png deleted file mode 100644 index 05bba99..0000000 Binary files a/OLD-syndicate-examples/gui/syndicate-gui-snapshot.png and /dev/null differ diff --git a/OLD-syndicate-examples/ircd/Makefile b/OLD-syndicate-examples/ircd/Makefile deleted file mode 100644 index 66d6663..0000000 --- a/OLD-syndicate-examples/ircd/Makefile +++ /dev/null @@ -1,10 +0,0 @@ -all: - -run: - raco make main.rkt && racket main.rkt - -clean: - rm -rf compiled - -client: - irssi --config=irssi-config -n client diff --git a/OLD-syndicate-examples/ircd/channel.rkt b/OLD-syndicate-examples/ircd/channel.rkt deleted file mode 100644 index 1954c53..0000000 --- a/OLD-syndicate-examples/ircd/channel.rkt +++ /dev/null @@ -1,34 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(require "protocol.rkt") -(require "message.rkt") - -(require/activate syndicate/reload) - -(spawn #:name 'channel-factory - (stop-when-reloaded) - - (during (ircd-channel-member $Ch _) - (assert (ircd-channel Ch))) - - (during/spawn (ircd-channel $Ch) - #:name (ircd-channel Ch) - (field [topic #f]) - (assert (ircd-channel-topic Ch (topic))) - - (define/query-count user-count (ircd-channel-member Ch $who) 'any) - (assert (ircd-channel-user-count Ch (hash-ref (user-count) 'any 0))) - - (on (message (ircd-action $who (irc-message _ "MODE" (list Ch "b") _))) - (send! (ircd-event who (irc-message server-prefix 368 (list (lookup-nick who) Ch) - "End of Channel Ban List")))) - - (on (message (ircd-action $who (irc-message _ "MODE" (list Ch) _))) - (send! (ircd-event who (irc-message server-prefix 324 - (list (lookup-nick who) Ch "+") #f)))) - - (on (message (ircd-action _ (irc-message _ "TOPIC" (list Ch) $new-topic))) - (topic new-topic)))) diff --git a/OLD-syndicate-examples/ircd/config.rkt b/OLD-syndicate-examples/ircd/config.rkt deleted file mode 100644 index 8b4c9ec..0000000 --- a/OLD-syndicate-examples/ircd/config.rkt +++ /dev/null @@ -1,30 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(require/activate syndicate/reload) -(require/activate syndicate/supervise) -(require/activate syndicate/drivers/config) - -(require "protocol.rkt") - -(require racket/set) -(require (only-in racket/list append* flatten)) -(require (only-in racket/string string-split)) - -(spawn-configuration 'ircd "ircd-config.rktd" #:hook (lambda () (stop-when-reloaded))) - -(spawn #:name 'config - (stop-when-reloaded) - - (during (config 'ircd `(port ,$port)) - (assert (ircd-listener port))) - - (during (config 'ircd `(channel ,$Ch)) - (assert (ircd-channel Ch))) - - (define/query-set motds (config 'ircd `(motd ,$text)) text) - (assert (ircd-motd (append* - (map (lambda (t) (string-split t "\n")) - (flatten (set->list (motds)))))))) diff --git a/OLD-syndicate-examples/ircd/dynamic-main.rkt b/OLD-syndicate-examples/ircd/dynamic-main.rkt deleted file mode 100644 index 28ac36c..0000000 --- a/OLD-syndicate-examples/ircd/dynamic-main.rkt +++ /dev/null @@ -1,9 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate -(require/activate syndicate/reload) -(spawn-reloader "config.rkt") -(spawn-reloader "session.rkt") -(spawn-reloader "channel.rkt") -(spawn-reloader "greeter.rkt") diff --git a/OLD-syndicate-examples/ircd/greeter.rkt b/OLD-syndicate-examples/ircd/greeter.rkt deleted file mode 100644 index 3492f64..0000000 --- a/OLD-syndicate-examples/ircd/greeter.rkt +++ /dev/null @@ -1,24 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(require "protocol.rkt") -(require "message.rkt") - -(require/activate syndicate/reload) - -(spawn #:name 'greeter - (stop-when-reloaded) - (on (asserted (ircd-channel-member $Ch $conn)) - (match-define (ircd-connection-info _ N U) - (immediate-query [query-value #f ($ I (ircd-connection-info conn _ _)) I])) - ;; TODO: history replay? As the following illustrates, we are able to forge messages - (send! (ircd-event conn (irc-message (irc-source-nick N U) "PRIVMSG" (list Ch) - (format "Welcome to ~a, ~a!" Ch N)))))) - -(spawn #:name 'authenticator - (stop-when-reloaded) - (during (observe (ircd-credentials $nick $user $password _)) - (log-info "Credentials: ~a ~a ~a" nick user password) - (assert (ircd-credentials nick user password (equal? password "foobar"))))) diff --git a/OLD-syndicate-examples/ircd/ircd-config.rktd b/OLD-syndicate-examples/ircd/ircd-config.rktd deleted file mode 100644 index 239a759..0000000 --- a/OLD-syndicate-examples/ircd/ircd-config.rktd +++ /dev/null @@ -1,3 +0,0 @@ -(port 6667) -(motd "Hello, world!") -(channel "#syndicate") diff --git a/OLD-syndicate-examples/ircd/irssi-config b/OLD-syndicate-examples/ircd/irssi-config deleted file mode 100644 index d69ba85..0000000 --- a/OLD-syndicate-examples/ircd/irssi-config +++ /dev/null @@ -1,24 +0,0 @@ -servers = ( - { - address = "localhost"; - chatnet = "Syndicate"; - port = "6667"; - autoconnect = "yes"; - password = "foobar"; - } -); - -chatnets = { Syndicate = { type = "IRC"; }; }; - -channels = ( - { name = "#test"; chatnet = "Syndicate"; autojoin = "yes"; }, - { name = "#test2"; chatnet = "Syndicate"; autojoin = "yes"; } -); -settings = { - core = { - real_name = "Alice Exampleuser"; - user_name = "alice"; - nick = "client"; - }; - "fe-text" = { actlist_sort = "refnum"; }; -}; diff --git a/OLD-syndicate-examples/ircd/main.rkt b/OLD-syndicate-examples/ircd/main.rkt deleted file mode 100644 index 17a7bf4..0000000 --- a/OLD-syndicate-examples/ircd/main.rkt +++ /dev/null @@ -1,6 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate -(require/activate syndicate/reload) -(spawn-reloader "dynamic-main.rkt") diff --git a/OLD-syndicate-examples/ircd/message.rkt b/OLD-syndicate-examples/ircd/message.rkt deleted file mode 100644 index 3a28d24..0000000 --- a/OLD-syndicate-examples/ircd/message.rkt +++ /dev/null @@ -1,96 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang racket/base - -(provide (struct-out irc-message) - (struct-out irc-user) - (struct-out irc-privmsg) - - (struct-out irc-source-servername) - (struct-out irc-source-nick) - - parse-irc-message - render-irc-message - - ;; TODO make these assertions in the dataspace: - server-name - server-prefix) - -(require racket/string) -(require racket/match) -(require racket/format) - -;; ::= [':' ] -;; ::= | [ '!' ] [ '@' ] -;; ::= { } | -;; ::= ' ' { ' ' } -;; ::= [ ':' | ] -;; -;; ::= -;; ::= -;; -;; ::= CR LF - -;; ::= [ "," ] -;; ::= | '@' | | -;; ::= ('#' | '&') -;; ::= -;; ::= see RFC 952 [DNS:4] for details on allowed hostnames -;; ::= { | | } -;; ::= ('#' | '$') -;; ::= - -;; ::= { } -;; ::= 'a' ... 'z' | 'A' ... 'Z' -;; ::= '0' ... '9' -;; ::= '-' | '[' | ']' | '\' | '`' | '^' | '{' | '}' - -;; ::= - -(struct irc-message (prefix command params trailing) #:prefab) -(struct irc-user (username hostname realname) #:prefab) -(struct irc-privmsg (source target text notice?) #:prefab) - -(struct irc-source-servername (servername) #:prefab) -(struct irc-source-nick (nick user) #:prefab) - -(define (parse-irc-message line0) - (match (string-trim #:left? #f line0 #px"[\r\n]") - [(pregexp #px"^:([^ ]+) +(.*)$" (list _ prefix rest)) (parse-command prefix rest)] - [line (parse-command #f line)])) - -(define (parse-command prefix line) - (match-define (pregexp #px"^([^ ]+)( +([^:]+)?(:(.*))?)?$" (list _ command _ params _ rest)) line) - (irc-message prefix - (string-upcase command) - (string-split (or params "")) - rest)) - -;; libpurple's irc protocol support crashes (!) (SIGSEGV) if you send -;; a prefix on a JOIN event from the server as just "nick" rather than -;; "nick!user@host" - specifically, it will crash if "!" doesn't -;; appear in the prefix. -;; -(define (render-irc-message m) - (match-define (irc-message prefix command params trailing) m) - (string-append (render-prefix prefix) - (~a command) - (if (pair? params) (string-append " " (string-join (map ~a params))) "") - (if trailing (string-append " :" trailing) ""))) - -(define (render-prefix p) - (match p - [#f - ""] - [(irc-source-servername servername) - (format ":~a " servername)] - [(irc-source-nick nick (irc-user username hostname _)) - (format ":~a!~a@~a " nick username hostname)])) - -(define server-name "syndicate-ircd") -(define server-prefix (irc-source-servername "syndicate-ircd.example")) diff --git a/OLD-syndicate-examples/ircd/protocol.rkt b/OLD-syndicate-examples/ircd/protocol.rkt deleted file mode 100644 index fc7add3..0000000 --- a/OLD-syndicate-examples/ircd/protocol.rkt +++ /dev/null @@ -1,71 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(provide (struct-out ircd-listener) - (struct-out ircd-motd) - - (struct-out claim) - (struct-out decision) - - (struct-out ircd-nick) - (struct-out ircd-connection-info) - (struct-out ircd-channel) - (struct-out ircd-channel-member) - (struct-out ircd-channel-topic) - (struct-out ircd-channel-user-count) - - (struct-out ircd-action) - (struct-out ircd-event) - - (struct-out ircd-credentials) - - lookup-nick) - -;; A Connection is a TcpAddress - -;;--------------------------------------------------------------------------- -;; Configuration - -;; (ircd-listener PortNumber) - causes TCP connections to be accepted on this port -(assertion-struct ircd-listener (port)) - -;; (ircd-motd (Listof String)) - Message Of The Day text -(assertion-struct ircd-motd (lines)) - -;;--------------------------------------------------------------------------- -;; Affine resources - -;; (claim Any NonFalse) -- any number of these. Decider picks a claimant -(assertion-struct claim (resource claimant)) - -;; (decision Any NonFalse) -- zero or one of these for a given resource. -(assertion-struct decision (resource resource-holder)) - -;;--------------------------------------------------------------------------- -;; IRC protocol - -;; (ircd-nick String) - a unique resource -(assertion-struct ircd-nick (name)) - -;; (ircd-connection-info Connection String IRCUser) -- mapping: nick <--> conn + userinfo -(assertion-struct ircd-connection-info (conn nick user)) - -(assertion-struct ircd-channel (channel)) -(assertion-struct ircd-channel-member (channel conn)) -(assertion-struct ircd-channel-topic (channel topic)) -(assertion-struct ircd-channel-user-count (channel count)) - -(message-struct ircd-action (conn message)) -(message-struct ircd-event (conn message)) - -(assertion-struct ircd-credentials (nick user password valid?)) - -;;--------------------------------------------------------------------------- -;; Application: chatroom model - -;;--------------------------------------------------------------------------- - -(define (lookup-nick conn) - (immediate-query [query-value #f (ircd-connection-info conn $N _) N])) diff --git a/OLD-syndicate-examples/ircd/session.rkt b/OLD-syndicate-examples/ircd/session.rkt deleted file mode 100644 index 999b388..0000000 --- a/OLD-syndicate-examples/ircd/session.rkt +++ /dev/null @@ -1,238 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(require racket/set) -(require racket/string) - -(require "protocol.rkt") -(require "message.rkt") - -(require/activate syndicate/reload) -(require/activate syndicate/drivers/tcp) -(require syndicate/support/hash) -(require (only-in racket/list append*)) - -(spawn #:name 'affine-resource-arbiter - (stop-when-reloaded) - (during (claim $resource _) - (define/query-set claimants (claim resource $claimant) claimant) - (field [holder #f]) - (begin/dataflow - (when (not (set-member? (claimants) (holder))) - (holder (and (not (set-empty? (claimants))) - (set-first (claimants)))))) - (assert #:when (holder) (decision resource (holder))))) - -(define (ircd-connection-facet connection-root-facet this-conn peer-host) - (define (send-to-remote #:newline [with-newline #t] fmt . vs) - (define bs (string->bytes/utf-8 (apply format fmt vs))) - (log-info "~a <- ~v" this-conn bs) - (send! (tcp-out this-conn (if with-newline (bytes-append bs #"\r\n") bs)))) - - (define (send-irc-message m) - (send-to-remote "~a" (render-irc-message m))) - - (define (send* #:source [prefix server-prefix] #:trailing [trailing #f] command . params) - (send-irc-message (irc-message prefix command params trailing))) - - (on-start (log-info "Connecting ~a" this-conn)) - (on-stop (log-info "Disconnecting ~a" this-conn)) - - (field [nick #f] - [user #f] - [password #f] - [registered? #f]) - (assert (ircd-connection-info this-conn (nick) (user))) - (assert #:when (nick) (claim (ircd-nick (nick)) this-conn)) - - (on-start - (react - (stop-when (asserted (ircd-motd $motd-lines)) - (react - (begin/dataflow - (when (and (nick) (user)) - (stop-current-facet - (react - (stop-when (asserted (ircd-credentials (nick) (user) (password) $valid?)) - (cond - [valid? - (registered? #t) - (send* 375 (nick) #:trailing (format "- ~a Message of the day - " server-name)) - (for [(line motd-lines)] (send* 372 (nick) #:trailing (format "- ~a" line))) - (send* 376 (nick) #:trailing (format "End of /MOTD command")) - (assert! (ircd-channel-member "#syndicate" this-conn)) ;; force membership! - ] - [else - (send* 464 (nick) #:trailing "Password incorrect") - (stop-facet connection-root-facet)])))))))))) - - (field [peer-common-channels (hash)] - [peer-names (hash)]) - - (during (ircd-channel-member $Ch this-conn) - (field [initial-names-sent? #f] - [initial-member-nicks (set)]) - - (on-start (send* #:source (irc-source-nick (nick) (user)) "JOIN" Ch) - (flush!) - (flush!) - (define nicks (initial-member-nicks)) - (initial-names-sent? #t) - (initial-member-nicks 'no-longer-valid) - (send* 353 (nick) "@" Ch #:trailing (string-join (set->list nicks))) - (send* 366 (nick) Ch #:trailing "End of /NAMES list")) - - (during (ircd-channel-member Ch $other-conn) - (on-start (peer-common-channels (hashset-add (peer-common-channels) other-conn Ch))) - (on-stop (peer-common-channels (hashset-remove (peer-common-channels) other-conn Ch))) - (field [current-other-source #f]) - (define/query-value next-other-source #f - (ircd-connection-info other-conn $N $U) - (irc-source-nick N U)) - (on (retracted (ircd-channel-member Ch other-conn)) - (when (current-other-source) (send* #:source (current-other-source) "PART" Ch))) - (on-stop (when (not (hash-has-key? (peer-common-channels) other-conn)) - (peer-names (hash-remove (peer-names) other-conn)))) - (begin/dataflow - (when (not (equal? (current-other-source) (next-other-source))) - (if (not (next-other-source)) ;; other-conn is disconnecting - (when (hash-ref (peer-names) other-conn #f) - (send* #:source (current-other-source) "QUIT") - (peer-names (hash-remove (peer-names) other-conn))) - (begin - (cond - [(not (initial-names-sent?)) ;; still gathering data for 353/366 below - (initial-member-nicks (set-add (initial-member-nicks) - (irc-source-nick-nick (next-other-source))))] - [(not (current-other-source)) ;; other-conn is joining - (send* #:source (next-other-source) "JOIN" Ch)] - [else ;; it's a nick change - (when (not (equal? this-conn other-conn)) ;; avoid dups for our own connection - (when (not (equal? (next-other-source) (hash-ref (peer-names) other-conn #f))) - (send* #:source (current-other-source) "NICK" - (irc-source-nick-nick (next-other-source)))))]) - (peer-names (hash-set (peer-names) other-conn (next-other-source))))) - (current-other-source (next-other-source))))) - - (on (asserted (ircd-channel-topic Ch $topic)) - (if topic - (send* 332 (nick) Ch #:trailing topic) - (send* 331 (nick) Ch #:trailing "No topic is set"))) - - (on (message (ircd-action this-conn (irc-message _ "WHO" (list Ch) _))) - (flush!) ;; Wait for responses to come in. GROSS and not in - ;; general correct (e.g. in the presence of - ;; pipelining) - (send! (ircd-event this-conn - (irc-message server-prefix 315 (list (nick) Ch) "End of WHO list.")))) - (on (message (ircd-action $who (irc-message _ "WHO" (list Ch) _))) - (match-define (irc-user U H R) (user)) - (send! (ircd-event who (irc-message server-prefix 352 - (list (nick) Ch U H server-name (nick) "H") - (format "0 ~a" R))))) - - (on (message (ircd-action $other-conn (irc-privmsg $source Ch $text $notice?))) - (when (not (equal? other-conn this-conn)) - (send* #:source source (if notice? "NOTICE" "PRIVMSG") Ch #:trailing text)))) - - (on (message (ircd-event this-conn $m)) - (send-irc-message m)) - - (on (message (ircd-action $other-conn (irc-privmsg $source (nick) $text $notice?))) - (when (not (equal? other-conn this-conn)) - (send* #:source source (if notice? "NOTICE" "PRIVMSG") (nick) #:trailing text))) - - (on (message (tcp-in-line this-conn $bs)) - (define m (parse-irc-message (bytes->string/utf-8 bs))) - (log-info "~a -> ~v" this-conn m) - (send! (ircd-action this-conn m)) - (issue-credit! tcp-in this-conn) - (match m - [(irc-message _ "PING" _ _) (void)] ;; RFC says servers don't reply to PINGs - [(or (irc-message _ "PASS" (list P) _) - (irc-message _ "PASS" '() P)) ;; libpurple does this (!) - (if (registered?) - (send* 462 (nick) #:trailing "You may not reregister") - (password P))] - [(or (irc-message _ "NICK" (list N) _) - (irc-message _ "NICK" '() N)) ;; libpurple does this (!) - ;; TODO: enforce syntactic restrictions on nick - (react (assert (claim (ircd-nick N) this-conn)) - (on (asserted (decision (ircd-nick N) $who)) - (if (equal? who this-conn) - (begin (when (nick) (send* #:source (irc-source-nick (nick) (user)) "NICK" N)) - (nick N)) - (send* 433 (or (nick) "*") N #:trailing "Nickname is already in use")) - (stop-current-facet)))] - [(irc-message _ "USER" (list U _Hostname _Servername) R) - ;; TODO: enforce syntactic restrictions on parameters to USER - (if (registered?) - (send* 462 (nick) #:trailing "You may not reregister") - (user (irc-user U peer-host R)))] - [(irc-message _ "QUIT" _ _) (stop-current-facet)] - [_ - (when (registered?) - (match m - [(irc-message _ "JOIN" (cons Channels _MaybeKeys) _) - (for [(Ch (string-split Channels #px",+"))] - (assert! (ircd-channel-member Ch this-conn)))] - [(irc-message _ "PART" (list Channels) _) - (for [(Ch (string-split Channels #px",+"))] - (retract! (ircd-channel-member Ch this-conn)))] - [(irc-message _ "WHOIS" _ _) - (send* 318 (nick) #:trailing "End of /WHOIS list")] ;; TODO - [(irc-message _ - (and cmd (or "PRIVMSG" "NOTICE")) - (list Targets) - Text) - (for [(T (string-split Targets #px",+"))] - (send! (ircd-action this-conn - (irc-privmsg (irc-source-nick (nick) (user)) - T - Text - (equal? cmd "NOTICE")))))] - [_ (void)]))]))) - -(spawn #:name 'ison-responder - (stop-when-reloaded) - (define/query-set nicks (ircd-connection-info _ $N _) N) - (on (message (ircd-action $conn (irc-message _ "ISON" $SomeNicks $MoreNicks))) - (define Nicks (append SomeNicks (string-split (or MoreNicks "")))) - (define (on? N) (set-member? (nicks) N)) - (define Present (string-join (filter on? Nicks) " ")) - (send! (ircd-event conn (irc-message server-prefix 303 '("*") Present))))) - -(spawn #:name 'list-responder - (stop-when-reloaded) - (define/query-hash topics (ircd-channel-topic $Ch $topic) Ch topic) - (define/query-hash counts (ircd-channel-user-count $Ch $count) Ch count) - (on (message (ircd-action $conn (irc-message _ "LIST" $requested-channel-names0 _))) - (define requested-channel-names - (append* (map (lambda (ns) (string-split ns #px",+")) requested-channel-names0))) - (send! (ircd-event conn (irc-message server-prefix 321 '("*" "Channel") "Users Name"))) - (for [(Ch (if (null? requested-channel-names) - (in-hash-keys (topics)) - (in-list requested-channel-names)))] - (when (hash-has-key? (topics) Ch) - (define topic (hash-ref (topics) Ch)) - (define count (hash-ref (counts) Ch 0)) - (send! (ircd-event conn (irc-message server-prefix 322 (list "*" Ch count) topic))))) - (send! (ircd-event conn (irc-message server-prefix 323 '("*") "End of /LIST"))))) - -(spawn #:name 'session-listener-factory - (stop-when-reloaded) - (during/spawn (ircd-listener $port) - #:name (ircd-listener port) - (on-start (log-info "Listening on port ~a." port)) - (on-stop (log-info "No longer listening on port ~a." port)) - (define server-handle (tcp-listener port)) - (during/spawn (tcp-connection $this-conn server-handle) - #:name `(ircd-connection ,this-conn) - (define connection-root-facet (current-facet)) - (on-start (issue-credit! server-handle) - (issue-credit! tcp-in this-conn)) - (during (tcp-connection-peer this-conn (tcp-address $peer-host _)) - (assert (tcp-accepted this-conn)) - (ircd-connection-facet connection-root-facet this-conn peer-host))))) diff --git a/OLD-syndicate-examples/netstack/Makefile b/OLD-syndicate-examples/netstack/Makefile deleted file mode 100644 index d7ba69b..0000000 --- a/OLD-syndicate-examples/netstack/Makefile +++ /dev/null @@ -1,7 +0,0 @@ -all: - -run: - raco make main.rkt && racket main.rkt - -clean: - find . -name compiled -type d | xargs rm -rf diff --git a/OLD-syndicate-examples/netstack/README.md b/OLD-syndicate-examples/netstack/README.md deleted file mode 100644 index 8229623..0000000 --- a/OLD-syndicate-examples/netstack/README.md +++ /dev/null @@ -1,19 +0,0 @@ -# TCP/IP Stack - -This implementation is largely the same as the old-Syndicate -"incremental highlevel" implementation, but using new-Syndicate. - -## Linux Firewall Configuration - -Imagine a setup where the machine you are running this code has IP -192.168.2.10. This code claims 192.168.2.222 for itself. Now, pinging -192.168.2.222 from some other machine, say 192.168.2.99, will cause -the local kernel to receive the pings and then *forward them on to -192.168.2.222*, which because of the gratuitous ARP announcement, it -knows to be on its own Ethernet MAC address. This causes the ping -requests to repeat endlessly, each time with one lower TTL. - -One approach to solving the problem is to prevent the kernel from -forwarding packets addressed to 192.168.2.222. To do this, - - sudo iptables -I FORWARD -d 192.168.2.222 -j DROP diff --git a/OLD-syndicate-examples/netstack/TODO.md b/OLD-syndicate-examples/netstack/TODO.md deleted file mode 100644 index e188d8c..0000000 --- a/OLD-syndicate-examples/netstack/TODO.md +++ /dev/null @@ -1,24 +0,0 @@ -Ideas on TCP unit testing: - - -Check behaviour around TCP zero-window probing. Is the correct -behaviour already a consequence of the way `send-outbound` works? - -Do something smarter with TCP timers and RTT estimation than the -nothing that's already being done. - -TCP options negotiation. - - SACK - - Window scaling - -Check that we handle the situations in figs. 9, 10, 11, pp.33- of RFC 793. - -Bugs: - - RST kills a connection even if its sequence number is bogus. Check - to make sure it's in the window. (See - http://static.googleusercontent.com/media/research.google.com/en//pubs/archive/41848.pdf - and RFC 5961) - - Conform better to the rules for reset generation and processing - from pp.36- of RFC 793. In particular, do not blindly accept RSTs - without checking sequence numbers against windows etc. diff --git a/OLD-syndicate-examples/netstack/arp.rkt b/OLD-syndicate-examples/netstack/arp.rkt deleted file mode 100644 index b5751e4..0000000 --- a/OLD-syndicate-examples/netstack/arp.rkt +++ /dev/null @@ -1,192 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate -;; ARP protocol, http://tools.ietf.org/html/rfc826 -;; Only does ARP-over-ethernet. - -(provide (struct-out arp-query) - (struct-out arp-assertion) - (struct-out arp-interface)) - -(require racket/set) -(require racket/match) -(require/activate syndicate/drivers/timer) -(require bitsyntax) - -(require "dump-bytes.rkt") -(require "configuration.rkt") -(require/activate "ethernet.rkt") - -(struct arp-query (protocol protocol-address interface-name link-address) #:prefab) -(struct arp-assertion (protocol protocol-address interface-name) #:prefab) -(struct arp-interface (interface-name) #:prefab) - -(struct arp-interface-up (interface-name) #:prefab) - -(define ARP-ethertype #x0806) -(define cache-entry-lifetime-msec (* 14400 1000)) -(define wakeup-interval 5000) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (spawn-arp-driver) - (spawn #:name 'arp-driver - (during/spawn (arp-interface $interface-name) - #:name (list 'arp-interface interface-name) - (assert (arp-interface-up interface-name)) - (during (ethernet-interface interface-name $hwaddr) - (run-arp-interface interface-name hwaddr))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(struct cache-key (protocol address) #:transparent) -(struct cache-value (expiry interface-name address) #:transparent) - -(define (expire-cache c) - (define now (current-inexact-milliseconds)) - (define (not-expired? v) (< now (cache-value-expiry v))) - (for/hash [((k v) (in-hash c)) #:when (not-expired? v)] - (values k v))) - -(define (run-arp-interface interface-name hwaddr) - (log-info "ARP interface ~v ~v" interface-name hwaddr) - - (define (build-packet dest-mac ptype oper sender-ha sender-pa target-ha target-pa) - (define hlen (bytes-length target-ha)) - (define plen (bytes-length target-pa)) - (define packet (bit-string->bytes - (bit-string (1 :: integer bytes 2) - (ptype :: integer bytes 2) - hlen - plen - (oper :: integer bytes 2) - (sender-ha :: binary bytes hlen) - (sender-pa :: binary bytes plen) - (target-ha :: binary bytes hlen) - (target-pa :: binary bytes plen)))) - (ethernet-packet interface-name - #f - hwaddr - dest-mac - ARP-ethertype - packet)) - - (define (some-asserted-pa ptype) - (match (filter (lambda (k) (equal? (cache-key-protocol k) ptype)) (set->list (assertions))) - ['() #f] - [(list* k _) (cache-key-address k)])) - - (define (send-questions!) - (for [(q (set-subtract (queries) (list->set (hash-keys (cache)))))] - (define pa (some-asserted-pa (cache-key-protocol q))) - (log-info "~a ARP Asking for ~a from ~a" - interface-name - (pretty-bytes (cache-key-address q)) - (and pa (pretty-bytes pa))) - (when pa - (send! (build-packet broadcast-ethernet-address - (cache-key-protocol q) - 1 ;; request - hwaddr - pa - zero-ethernet-address - (cache-key-address q)))))) - - (field [cache (hash)] - [queries (set)] - [assertions (set)]) - - (field [expiry-deadline (+ (current-inexact-milliseconds) wakeup-interval)]) - (on (asserted (later-than (expiry-deadline))) - (cache (expire-cache (cache))) - (send-questions!) - (expiry-deadline (+ (current-inexact-milliseconds) wakeup-interval))) - - (on (message ($ p (ethernet-packet-pattern interface-name #t ARP-ethertype))) - (match-define (ethernet-packet _ _ source destination _ body) p) - (bit-string-case body - ([ (= 1 :: integer bytes 2) - (ptype :: integer bytes 2) - hlen - plen - (oper :: integer bytes 2) - (sender-hardware-address0 :: binary bytes hlen) - (sender-protocol-address0 :: binary bytes plen) - (target-hardware-address0 :: binary bytes hlen) - (target-protocol-address0 :: binary bytes plen) - (:: binary) ;; The extra zeros exist because ethernet packets - ;; have a minimum size. This is, in part, why IPv4 - ;; headers have a total-length field, so that the - ;; zero padding can be removed. - ] - (let () - (define sender-protocol-address (bit-string->bytes sender-protocol-address0)) - (define sender-hardware-address (bit-string->bytes sender-hardware-address0)) - (define target-protocol-address (bit-string->bytes target-protocol-address0)) - (define learned-key (cache-key ptype sender-protocol-address)) - - (when (and (set-member? (queries) learned-key) ;; it is relevant to our interests - (not (equal? sender-hardware-address - (cache-value-address (hash-ref (cache) - learned-key - (lambda () - (cache-value #f #f #f))))))) - (log-info "~a ARP Adding ~a = ~a to cache" - interface-name - (pretty-bytes sender-protocol-address) - (pretty-bytes sender-hardware-address))) - - (cache (hash-set (expire-cache (cache)) - learned-key - (cache-value (+ (current-inexact-milliseconds) - cache-entry-lifetime-msec) - interface-name - sender-hardware-address))) - (case oper - [(1) ;; request - (when (set-member? (assertions) (cache-key ptype target-protocol-address)) - (log-info "~a ARP answering request for ~a/~a" - interface-name - ptype - (pretty-bytes target-protocol-address)) - (send! (build-packet sender-hardware-address - ptype - 2 ;; reply - hwaddr - target-protocol-address - sender-hardware-address - sender-protocol-address)))] - [(2) (void)] ;; reply - [else (void)]))) - (else #f))) - - (during (arp-assertion $protocol $protocol-address interface-name) - (define a (cache-key protocol protocol-address)) - (on-start (assertions (set-add (assertions) a)) - (log-info "~a ARP Announcing ~a as ~a" - interface-name - (pretty-bytes (cache-key-address a)) - (pretty-bytes hwaddr)) - (send! (build-packet broadcast-ethernet-address - (cache-key-protocol a) - 2 ;; reply -- gratuitous announcement - hwaddr - (cache-key-address a) - hwaddr - (cache-key-address a)))) - (on-stop (assertions (set-remove (assertions) a)))) - - (during (observe (arp-query $protocol $protocol-address interface-name _)) - (define key (cache-key protocol protocol-address)) - (on-start (queries (set-add (queries) key)) - (send-questions!)) - (on-stop (queries (set-remove (queries) key))) - (assert #:when (hash-has-key? (cache) key) - (match (hash-ref (cache) key) - [(cache-value _ ifname addr) - (arp-query protocol protocol-address ifname addr)])))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(spawn-arp-driver) diff --git a/OLD-syndicate-examples/netstack/checksum.rkt b/OLD-syndicate-examples/netstack/checksum.rkt deleted file mode 100644 index 711c892..0000000 --- a/OLD-syndicate-examples/netstack/checksum.rkt +++ /dev/null @@ -1,55 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang racket/base - -(provide ones-complement-sum16 ip-checksum) - -(require bitsyntax) -(require "dump-bytes.rkt") - -(define (ones-complement-+16 a b) - (define c (+ a b)) - (bitwise-and #xffff (+ (arithmetic-shift c -16) c))) - -(define (ones-complement-sum16 bs) - (bit-string-case bs - ([ (n :: integer bytes 2) (rest :: binary) ] - (ones-complement-+16 n (ones-complement-sum16 rest))) - ([ odd-byte ] - (arithmetic-shift odd-byte 8)) - ([ ] - 0))) - -(define (ones-complement-negate16-safely x) - (define r (bitwise-and #xffff (bitwise-not x))) - (if (= r 0) #xffff r)) - -(define (ip-checksum offset blob #:pseudo-header [pseudo-header #""]) - (bit-string-case blob - ([ (prefix :: binary bytes offset) - (:: binary bytes 2) - (suffix :: binary) ] - ;; (log-info "Packet pre checksum:\n~a" (dump-bytes->string blob)) - (define result (ones-complement-+16 - (ones-complement-sum16 pseudo-header) - (ones-complement-+16 (ones-complement-sum16 prefix) - (ones-complement-sum16 suffix)))) - ;; (log-info "result: ~a" (number->string result 16)) - (define checksum (ones-complement-negate16-safely result)) - ;; (log-info "Checksum ~a" (number->string checksum 16)) - (define final-packet (bit-string (prefix :: binary) - (checksum :: integer bytes 2) - (suffix :: binary))) - ;; (log-info "Packet with checksum:\n~a" (dump-bytes->string final-packet)) - final-packet))) - -(module+ test - (require rackunit) - (check-equal? (ones-complement-negate16-safely - (ones-complement-sum16 (bytes #x45 #x00 #x00 #x54 - #x00 #x00 #x00 #x00 - #x40 #x01 #x00 #x00 - #xc0 #xa8 #x01 #xde - #xc0 #xa8 #x01 #x8f))) - #xf5eb)) diff --git a/OLD-syndicate-examples/netstack/configuration.rkt b/OLD-syndicate-examples/netstack/configuration.rkt deleted file mode 100644 index 4ee7d86..0000000 --- a/OLD-syndicate-examples/netstack/configuration.rkt +++ /dev/null @@ -1,21 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang racket/base - -(provide (struct-out host-route) - (struct-out gateway-route) - (struct-out net-route) - - (struct-out route-up)) - -;; A Route is one of -;; - (host-route IpAddrBytes NetmaskNat InterfaceName), an own-IP route -;; - (gateway-route NetAddrBytes NetmaskNat IpAddrBytes InterfaceName), a gateway for a subnet -;; - (net-route NetAddrBytes NetmaskNat InterfaceName), an ethernet route for a subnet -;; NetmaskNat in a net-route is a default route. -(struct host-route (ip-addr netmask interface-name) #:prefab) -(struct gateway-route (network-addr netmask gateway-addr interface-name) #:prefab) -(struct net-route (network-addr netmask link) #:prefab) - -(struct route-up (route) #:prefab) ;; assertion: the given Route is running diff --git a/OLD-syndicate-examples/netstack/demo-config.rkt b/OLD-syndicate-examples/netstack/demo-config.rkt deleted file mode 100644 index 6d3a9c3..0000000 --- a/OLD-syndicate-examples/netstack/demo-config.rkt +++ /dev/null @@ -1,24 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate -;; Demonstration stack configuration for various hosts. - -(require racket/match) -(require (only-in mzlib/os gethostname)) -(require (only-in racket/string string-split)) -(require "configuration.rkt") - -(spawn - (match (gethostname) - [other ;; assume a private network - (define-values (interface mkaddr me gw) - (match (car (string-split other ".")) - ["skip" (values "en0" (lambda (v) (bytes 192 168 2 v)) 222 254)] - ["leap" (values "wlp4s0" ;; wtf - (lambda (v) (bytes 192 168 2 v)) - 222 - 254)] - [_ (values "wlan0" (lambda (v) (bytes 192 168 2 v)) 222 254)])) - (assert (gateway-route (bytes 0 0 0 0) 0 (mkaddr gw) interface)) - (assert (host-route (mkaddr me) 24 interface))])) diff --git a/OLD-syndicate-examples/netstack/dump-bytes.rkt b/OLD-syndicate-examples/netstack/dump-bytes.rkt deleted file mode 100644 index 5347de8..0000000 --- a/OLD-syndicate-examples/netstack/dump-bytes.rkt +++ /dev/null @@ -1,69 +0,0 @@ -;;; SPDX-License-Identifier: GPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2012-2021 Tony Garnock-Jones - -#lang racket/base - -;; Pretty hex dump output of a Bytes. - -(provide dump-bytes! - dump-bytes->string - pretty-bytes) - -(require (only-in bitsyntax bit-string->bytes)) -(require (only-in file/sha1 bytes->hex-string)) - -(define (pretty-bytes bs) - (bytes->hex-string (bit-string->bytes bs))) - -;; Exact Exact -> String -;; Returns the "0"-padded, width-digit hex representation of n -(define (hex width n) - (define s (number->string n 16)) - (define slen (string-length s)) - (cond - ((< slen width) (string-append (make-string (- width slen) #\0) s)) - ((= slen width) s) - ((> slen width) (substring s 0 width)))) - -;; Bytes Exact -> Void -;; Prints a pretty hex/ASCII dump of bs on (current-output-port). -(define (dump-bytes! bs0 [requested-count #f] #:base [baseaddr 0]) - (define bs (bit-string->bytes bs0)) - (define count (if requested-count (min requested-count (bytes-length bs)) (bytes-length bs))) - (define clipped (subbytes bs 0 count)) - (define (dump-hex i) - (if (< i count) - (display (hex 2 (bytes-ref clipped i))) - (display " ")) - (display #\space)) - (define (dump-char i) - (if (< i count) - (let ((ch (bytes-ref clipped i))) - (if (<= 32 ch 127) - (display (integer->char ch)) - (display #\.))) - (display #\space))) - (define (for-each-between f low high) - (do ((i low (+ i 1))) - ((= i high)) - (f i))) - (define (dump-line i) - (display (hex 8 (+ i baseaddr))) - (display #\space) - (for-each-between dump-hex i (+ i 8)) - (display ": ") - (for-each-between dump-hex (+ i 8) (+ i 16)) - (display #\space) - (for-each-between dump-char i (+ i 8)) - (display " : ") - (for-each-between dump-char (+ i 8) (+ i 16)) - (newline)) - (do ((i 0 (+ i 16))) - ((>= i count)) - (dump-line i))) - -(define (dump-bytes->string bs [requested-count #f] #:base [baseaddr 0]) - (define s (open-output-string)) - (parameterize ((current-output-port s)) - (dump-bytes! bs requested-count #:base baseaddr)) - (get-output-string s)) diff --git a/OLD-syndicate-examples/netstack/ethernet.rkt b/OLD-syndicate-examples/netstack/ethernet.rkt deleted file mode 100644 index 422f6c7..0000000 --- a/OLD-syndicate-examples/netstack/ethernet.rkt +++ /dev/null @@ -1,123 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate -;; Ethernet driver - -(provide (struct-out available-ethernet-interface) - (struct-out ethernet-interface) - (struct-out ethernet-packet) - zero-ethernet-address - broadcast-ethernet-address - ethernet-packet-pattern) - -(require/activate syndicate/drivers/timer) -(require racket/set) -(require racket/match) -(require racket/async-channel) - -(require packet-socket) -(require bitsyntax) - -(require "configuration.rkt") -(require "dump-bytes.rkt") -(require syndicate/pattern-expander) - -(assertion-struct available-ethernet-interface (name)) -(assertion-struct ethernet-interface (name hwaddr)) -(message-struct ethernet-packet (interface-name from-wire? source destination ethertype body)) - -(define zero-ethernet-address (bytes 0 0 0 0 0 0)) -(define broadcast-ethernet-address (bytes 255 255 255 255 255 255)) - -(define interface-names (raw-interface-names)) -(log-info "Device names: ~a" interface-names) - -(define (spawn-ethernet-driver) - (spawn #:name 'ethernet-driver - - (for [(n interface-names)] - (assert (available-ethernet-interface n))) - - (during/spawn - (observe (ethernet-packet $interface-name #t _ _ _ _)) - #:name (list 'ethernet-interface interface-name) - - (define h (raw-interface-open interface-name)) - (when (not h) (error 'ethernet "Couldn't open interface ~v" interface-name)) - (log-info "Opened interface ~a, yielding handle ~v" interface-name h) - - (assert (ethernet-interface interface-name (raw-interface-hwaddr h))) - - (define control-ch (make-async-channel)) - (thread (lambda () (interface-packet-read-loop interface-name h control-ch))) - (signal-background-activity! +1) - (on-start (async-channel-put control-ch 'unblock)) - (on-stop (async-channel-put control-ch 'quit)) - - ;; (on (message ($ p (ethernet-packet interface #t _ _ _ _))) - ;; (log-info "Interface ~a inbound packet ~a -> ~a (type 0x~a)" - ;; (ethernet-interface-name (ethernet-packet-interface p)) - ;; (pretty-bytes (ethernet-packet-source p)) - ;; (pretty-bytes (ethernet-packet-destination p)) - ;; (number->string (ethernet-packet-ethertype p) 16)) - ;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p)))) - - (on (message ($ p (ethernet-packet interface-name #f _ _ _ _))) - ;; (log-info "Interface ~a OUTBOUND packet ~a -> ~a (type 0x~a)" - ;; (ethernet-interface-name (ethernet-packet-interface p)) - ;; (pretty-bytes (ethernet-packet-source p)) - ;; (pretty-bytes (ethernet-packet-destination p)) - ;; (number->string (ethernet-packet-ethertype p) 16)) - ;; (log-info "~a" (dump-bytes->string (ethernet-packet-body p))) - (raw-interface-write h (encode-ethernet-packet p)))))) - -(define (interface-packet-read-loop interface-name h control-ch) - (define (blocked) - (match (async-channel-get control-ch) - ['unblock (unblocked)] - ['quit (void)])) - (define (unblocked) - (match (async-channel-try-get control-ch) - ['unblock (unblocked)] - ['quit (void)] - [#f - (define p (raw-interface-read h)) - (define decoded (decode-ethernet-packet interface-name p)) - (when decoded (ground-send! decoded)) - (unblocked)])) - (blocked) - (raw-interface-close h) - (signal-background-activity! -1)) - -(define (decode-ethernet-packet interface-name p) - (bit-string-case p - ([ (destination :: binary bytes 6) - (source :: binary bytes 6) - (ethertype :: integer bytes 2) - (body :: binary) ] - (ethernet-packet interface-name - #t - (bit-string->bytes source) - (bit-string->bytes destination) - ethertype - (bit-string->bytes body))) - (else #f))) - -(define (encode-ethernet-packet p) - (match-define (ethernet-packet _ _ source destination ethertype body) p) - (bit-string->bytes - (bit-string (destination :: binary bytes 6) - (source :: binary bytes 6) - (ethertype :: integer bytes 2) - (body :: binary)))) - -(begin-for-declarations - (define-pattern-expander ethernet-packet-pattern - (syntax-rules () - [(_ interface-name from-wire? ethertype) - (ethernet-packet interface-name from-wire? _ _ ethertype _)]))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(spawn-ethernet-driver) diff --git a/OLD-syndicate-examples/netstack/fetchurl.rkt b/OLD-syndicate-examples/netstack/fetchurl.rkt deleted file mode 100644 index 0f74c07..0000000 --- a/OLD-syndicate-examples/netstack/fetchurl.rkt +++ /dev/null @@ -1,35 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(require/activate "ethernet.rkt") -(require/activate "arp.rkt") -(require/activate "ip.rkt") -(require/activate "tcp.rkt") -(require/activate "udp.rkt") -(require/activate "demo-config.rkt") -(require net/dns) ;; not syndicateish yet - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(let () - (define host "www.w3.org") - (define port 80) - (define connection-id 'httpclient) - (define remote-handle (tcp-address (dns-get-address (dns-find-nameserver) host) port)) - - (spawn (assert (tcp-connection connection-id remote-handle)) - (stop-when (asserted (tcp-rejected connection-id $reason)) - (local-require racket/exn) - (printf "Connection failed:\n ~a" (exn->string reason))) - (on (asserted (tcp-accepted connection-id)) - (send! (tcp-out connection-id - (bytes-append #"GET / HTTP/1.0\r\nHost: " - (string->bytes/utf-8 host) - #"\r\n\r\n")))) - (stop-when (retracted (tcp-accepted connection-id)) - (printf "URL fetcher exiting.\n")) - (on (message (tcp-in connection-id $bs)) - (printf "----------------------------------------\n~a\n" bs) - (printf "----------------------------------------\n")))) diff --git a/OLD-syndicate-examples/netstack/ip.rkt b/OLD-syndicate-examples/netstack/ip.rkt deleted file mode 100644 index edc2921..0000000 --- a/OLD-syndicate-examples/netstack/ip.rkt +++ /dev/null @@ -1,262 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(provide (struct-out ip-packet) - ip-address->hostname - ip-string->ip-address - apply-netmask - ip-address-in-subnet? - query-local-ip-addresses - broadcast-ip-address - spawn-ip-driver) - -(require racket/set) -(require (only-in racket/string string-split)) -(require bitsyntax) - -(require "dump-bytes.rkt") -(require "configuration.rkt") -(require "checksum.rkt") - -(require/activate syndicate/drivers/timer) -(require/activate "ethernet.rkt") -(require/activate "arp.rkt") - -(message-struct ip-packet - (source-interface ;; string for an ethernet interface, or #f for local interfaces - source - destination - protocol - options - body - ;; TODO: more fields - )) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (ip-address->hostname bs) - (bit-string-case bs - ([ a b c d ] (format "~a.~a.~a.~a" a b c d)))) - -(define (ip-string->ip-address str) - (list->bytes (map string->number (string-split str ".")))) - -(define (apply-netmask addr netmask) - (bit-string-case addr - ([ (n :: integer bytes 4) ] - (bit-string ((bitwise-and n (arithmetic-shift #x-100000000 (- netmask))) - :: integer bytes 4))))) - -(define (ip-address-in-subnet? addr network netmask) - (equal? (apply-netmask network netmask) - (apply-netmask addr netmask))) - -(define broadcast-ip-address (bytes 255 255 255 255)) - -(define (query-local-ip-addresses) - (query-set local-ips (host-route $addr _ _) addr)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (spawn-ip-driver) - (spawn #:name 'ip-driver - (during/spawn (host-route $my-address $netmask $interface-name) - (assert (route-up (host-route my-address netmask interface-name))) - (do-host-route my-address netmask interface-name)) - (during/spawn (gateway-route $network $netmask $gateway-addr $interface-name) - (assert (route-up (gateway-route network netmask gateway-addr interface-name))) - (do-gateway-route network netmask gateway-addr interface-name)) - (during/spawn (net-route $network-addr $netmask $link) - (assert (route-up (net-route network-addr netmask link))) - (do-net-route network-addr netmask link)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Local IP route - -(define (do-host-route my-address netmask interface-name) - (let ((network-addr (apply-netmask my-address netmask))) - (do-normal-ip-route (host-route my-address netmask interface-name) - network-addr - netmask - interface-name)) - - (assert (arp-assertion IPv4-ethertype my-address interface-name)) - (on (message (ip-packet _ $peer-address my-address PROTOCOL-ICMP _ $body)) - (bit-string-case body - ([ type code (checksum :: integer bytes 2) (rest :: binary) ] ;; TODO: check cksum - (case type - [(8) ;; ECHO (0 is ECHO-REPLY) - (log-info "Ping of ~a from ~a" - (pretty-bytes my-address) - (pretty-bytes peer-address)) - (define reply-data0 (bit-string 0 - code - (0 :: integer bytes 2) ;; TODO - (rest :: binary))) - (send! (ip-packet #f - my-address - peer-address - PROTOCOL-ICMP - #"" - (ip-checksum 2 reply-data0)))] - [else - (log-info "ICMP ~a/~a (cksum ~a) to ~a from ~a:\n~a" - type - code - checksum - (pretty-bytes my-address) - (pretty-bytes peer-address) - (dump-bytes->string rest))])) - (else #f)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Gateway IP route - -(define (do-gateway-route network netmask gateway-addr interface-name) - (define the-route (gateway-route network netmask gateway-addr interface-name)) - - (field [routes (set)]) - (query-set* routes (host-route $addr $netmask _) (list addr netmask)) - (query-set* routes (gateway-route $addr $netmask _ _) (list addr netmask)) - (query-set* routes (net-route $addr $netmask _) (list addr netmask)) - - (define (covered-by-some-other-route? addr) - (for/or ([r (in-set (routes))]) - (match-define (list net msk) r) - (and (positive? msk) - (ip-address-in-subnet? addr net msk)))) - - (during (ethernet-interface interface-name $gateway-interface-hwaddr) - (field [gateway-hwaddr #f]) - (on (asserted (arp-query IPv4-ethertype gateway-addr interface-name $hwaddr)) - (when (not (gateway-hwaddr)) - (log-info "Discovered gateway ~a at ~a on interface ~a." - (ip-address->hostname gateway-addr) - interface-name - (pretty-bytes hwaddr))) - (gateway-hwaddr hwaddr)) - - (on (message ($ p (ip-packet _ _ _ _ _ _))) - (when (not (gateway-hwaddr)) - (log-warning "Gateway hwaddr for ~a not known, packet dropped." - (ip-address->hostname gateway-addr))) - (when (and (gateway-hwaddr) - (not (equal? (ip-packet-source-interface p) interface-name)) - (not (covered-by-some-other-route? (ip-packet-destination p)))) - (send! (ethernet-packet interface-name - #f - gateway-interface-hwaddr - (gateway-hwaddr) - IPv4-ethertype - (format-ip-packet p))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; General net route - -(define (do-net-route network-addr netmask link) - (do-normal-ip-route (net-route network-addr netmask link) network-addr netmask link)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Normal IP route - -(define (do-normal-ip-route the-route network netmask interface-name) - (assert (arp-interface interface-name)) - (on (message (ethernet-packet interface-name #t _ _ IPv4-ethertype $body)) - (define p (parse-ip-packet interface-name body)) - (when p (send! p))) - (during (ethernet-interface interface-name $interface-hwaddr) - (on (message ($ p (ip-packet _ _ _ _ _ _))) - (define destination (ip-packet-destination p)) - (when (and (not (equal? (ip-packet-source-interface p) interface-name)) - (ip-address-in-subnet? destination network netmask)) - ;; v Use `spawn` instead of `react` to avoid gratuitous packet - ;; reordering. - (spawn (stop-when-timeout 5000 - (log-warning "ARP lookup of ~a failed, packet dropped" - (ip-address->hostname destination))) - (stop-when (asserted (arp-query IPv4-ethertype - destination - interface-name - $destination-hwaddr)) - (send! (ethernet-packet interface-name - #f - interface-hwaddr - destination-hwaddr - IPv4-ethertype - (format-ip-packet p))))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define IPv4-ethertype #x0800) - -(define IP-VERSION 4) -(define IP-MINIMUM-HEADER-LENGTH 5) - -(define PROTOCOL-ICMP 1) - -(define default-ttl 64) - -(define (parse-ip-packet interface-name body) - ;; (log-info "IP ~a got body ~a" (pretty-bytes my-address) (pretty-bytes body)) - (bit-string-case body - ([ (= IP-VERSION :: bits 4) - (header-length :: bits 4) - service-type - (total-length :: bits 16) - (id :: bits 16) - (flags :: bits 3) - (fragment-offset :: bits 13) - ttl - protocol - (header-checksum :: bits 16) ;; TODO: check checksum - (source-ip0 :: binary bits 32) - (destination-ip0 :: binary bits 32) - (rest :: binary) ] - (let* ((source-ip (bit-string->bytes source-ip0)) - (destination-ip (bit-string->bytes destination-ip0)) - (options-length (* 4 (- header-length IP-MINIMUM-HEADER-LENGTH))) - (data-length (- total-length (* 4 header-length)))) - (if (and (>= header-length 5) - (>= (bit-string-byte-count body) (* header-length 4))) - (bit-string-case rest - ([ (opts :: binary bytes options-length) - (data :: binary bytes data-length) - (:: binary) ] ;; Very short ethernet packets have a trailer of zeros - (ip-packet interface-name - (bit-string->bytes source-ip) - (bit-string->bytes destination-ip) - protocol - (bit-string->bytes opts) - (bit-string->bytes data)))) - #f))) - (else #f))) - -(define (format-ip-packet p) - (match-define (ip-packet _ src dst protocol options body) p) - - (define header-length ;; TODO: ensure options is a multiple of 4 bytes - (+ IP-MINIMUM-HEADER-LENGTH (quotient (bit-string-byte-count options) 4))) - - (define header0 (bit-string (IP-VERSION :: bits 4) - (header-length :: bits 4) - 0 ;; TODO: service type - ((+ (* header-length 4) (bit-string-byte-count body)) - :: bits 16) - (0 :: bits 16) ;; TODO: identifier - (0 :: bits 3) ;; TODO: flags - (0 :: bits 13) ;; TODO: fragments - default-ttl - protocol - (0 :: bits 16) - (src :: binary bits 32) - (dst :: binary bits 32) - (options :: binary))) - (define full-packet (bit-string ((ip-checksum 10 header0) :: binary) (body :: binary))) - - full-packet) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(spawn-ip-driver) diff --git a/OLD-syndicate-examples/netstack/main.rkt b/OLD-syndicate-examples/netstack/main.rkt deleted file mode 100644 index 50d7e45..0000000 --- a/OLD-syndicate-examples/netstack/main.rkt +++ /dev/null @@ -1,96 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(require/activate syndicate/drivers/timer) -(require/activate "ethernet.rkt") -(require/activate "arp.rkt") -(require/activate "ip.rkt") -(require/activate "tcp.rkt") -(require/activate "udp.rkt") -(require/activate "demo-config.rkt") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(let () - (local-require racket/format) - - (message-struct speak (who what)) - (assertion-struct present (who)) - - (dataspace #:name 'chat-server-app - (spawn #:name 'chat-server - (during/spawn (inbound (tcp-connection $id (tcp-listener 5999))) - #:name (list 'chat-connection id) - (assert (outbound (tcp-accepted id))) - (let ((me (gensym 'user))) - (assert (present me)) - (on (message (inbound (tcp-in-line id $bs))) - (match bs - [#"/quit" (stop-current-facet)] - [_ (send! (speak me (bytes->string/utf-8 bs)))]))) - (during (present $user) - (on-start (send! (outbound (tcp-out id (string->bytes/utf-8 (~a user " arrived\n")))))) - (on-stop (send! (outbound (tcp-out id (string->bytes/utf-8 (~a user " left\n")))))) - (on (message (speak user $text)) - (send! (outbound - (tcp-out id (string->bytes/utf-8 (~a user " says '" text "'\n"))))))))))) - -(let () - (dataspace #:name 'connection-rejection-test - (spawn #:name 'connection-rejection-main - (local-require racket/exn) - (define peer-host "192.168.1.1") - ;; TODO: ^ this will only reliably "fail" the way we want on my own network... - (define peer-port 9999) - (assert (outbound (tcp-connection 'x (tcp-address peer-host peer-port)))) - (stop-when (asserted (inbound (tcp-rejected 'x $reason))) - (log-info "Connection to ~a:~a rejected:\n~a" peer-host peer-port (exn->string reason))) - (on (asserted (inbound (tcp-accepted 'x))) - (error 'connection-rejection-main - "Unexpected accepted connection???"))))) - -(let ((dst (udp-listener 6667))) - (dataspace #:name 'udp-echo-program-app - (spawn #:name 'udp-echo-program - (on (message (inbound (udp-packet $src dst $body))) - (log-info "Got packet from ~v: ~v" src body) - (send! (outbound - (udp-packet dst src (string->bytes/utf-8 (format "You said: ~a" body))))))))) - -(let () - (dataspace #:name 'webserver-dataspace - (spawn #:name 'webserver-counter - (field [counter 0]) - (on (message 'bump) - (send! `(counter ,(counter))) - (counter (+ (counter) 1)))) - - (define us (tcp-listener 80)) - (spawn #:name 'webserver - (during/spawn (inbound (tcp-connection $them us)) - #:name (list 'webserver-session them) - (log-info "Got connection from ~v" them) - (assert (outbound (tcp-accepted them))) - (on (message (inbound (tcp-in them _)))) ;; ignore input - - (on-start (send! 'bump)) - (on (message `(counter ,$counter)) - (define response - (string->bytes/utf-8 - (format (string-append - "HTTP/1.0 200 OK\r\n" - "Content-Type: text/html\r\n" - "\r\n" - "

Hello world from syndicate-netstack!

\n" - "

This is running on syndicate's own\n" - "\n" - "TCP/IP stack.

\n" - "

There have been ~a requests prior to this one.

\n") - counter))) - (send! (outbound (tcp-out them response))) - (for [(i 4)] - (define buf (make-bytes 1024 (+ #x30 (modulo i 10)))) - (send! (outbound (tcp-out them buf)))) - (stop-facet (current-facet))))))) diff --git a/OLD-syndicate-examples/netstack/port-allocator.rkt b/OLD-syndicate-examples/netstack/port-allocator.rkt deleted file mode 100644 index 19768f8..0000000 --- a/OLD-syndicate-examples/netstack/port-allocator.rkt +++ /dev/null @@ -1,39 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate -;; UDP/TCP port allocator - -(provide spawn-port-allocator - allocate-port! - (struct-out port-allocation-request) - (struct-out port-allocation-reply)) - -(require racket/set) -(require "ip.rkt") - -(struct port-allocation-request (reqid type) #:prefab) -(struct port-allocation-reply (reqid port) #:prefab) - -(define (spawn-port-allocator allocator-type query-used-ports) - (spawn #:name (list 'port-allocator allocator-type) - (define local-ips (query-local-ip-addresses)) - (define used-ports (query-used-ports)) - - (begin/dataflow - (log-info "port-allocator ~v used ports: ~v" allocator-type (used-ports))) - - (on (message (port-allocation-request $reqid allocator-type)) - (define currently-used-ports (used-ports)) - (let randomly-allocate-until-unused () - (define p (+ 1024 (random 64512))) - (if (set-member? currently-used-ports p) - (randomly-allocate-until-unused) - (begin (used-ports (set-add currently-used-ports p)) - (send! (port-allocation-reply reqid p)))))))) - -(define (allocate-port! type) - (define reqid (gensym 'allocate-port!)) - (react/suspend (done) - (stop-when (message (port-allocation-reply reqid $port)) (done port)) - (on-start (send! (port-allocation-request reqid type))))) diff --git a/OLD-syndicate-examples/netstack/tcp.rkt b/OLD-syndicate-examples/netstack/tcp.rkt deleted file mode 100644 index e5e3b69..0000000 --- a/OLD-syndicate-examples/netstack/tcp.rkt +++ /dev/null @@ -1,774 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(provide (struct-out tcp-connection) - (struct-out tcp-accepted) - (struct-out tcp-rejected) - (struct-out tcp-out) - (struct-out tcp-in) - (struct-out tcp-in-line) - - (struct-out tcp-address) - (struct-out tcp-listener) - - spawn-tcp-driver) - -(require racket/set) -(require bitsyntax) - -(require "dump-bytes.rkt") -(require "checksum.rkt") - -(require/activate syndicate/drivers/timer) -(require "ip.rkt") -(require "port-allocator.rkt") - -(module+ test (require rackunit)) - -(define-logger netstack/tcp) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Protocol messages - -(assertion-struct tcp-connection (id spec)) -(assertion-struct tcp-accepted (id)) -(assertion-struct tcp-rejected (id exn)) -(message-struct tcp-out (id bytes)) -(message-struct tcp-in (id bytes)) -(message-struct tcp-in-line (id bytes)) - -(assertion-struct tcp-address (host port)) -(assertion-struct tcp-listener (port)) - -(assertion-struct tcp-quad (remote-ip remote-port local-ip local-port)) - -(message-struct tcp-packet (from-wire? - quad - sequence-number - ack-number - flags - window-size - options - data)) - -;; (tcp-port-allocation Number (U TcpAddress TcpListener)) -(assertion-struct tcp-port-allocation (port handle)) - -(define (tcp-quad->string from-wire? q) - (match-define (tcp-quad ri rp li lp) q) - (if from-wire? - (format "(I) ~a:~a -> ~a:~a" (ip-address->hostname ri) rp (ip-address->hostname li) lp) - (format "(O) ~a:~a -> ~a:~a" (ip-address->hostname li) lp (ip-address->hostname ri) rp))) - -(define (summarize-tcp-packet packet) - (format "~a (seq ~a, ack ~a, flags ~a, window ~a, payload ~a)" - (tcp-quad->string (tcp-packet-from-wire? packet) (tcp-packet-quad packet)) - (tcp-packet-sequence-number packet) - (tcp-packet-ack-number packet) - (tcp-packet-flags packet) - (tcp-packet-window-size packet) - (bit-string-byte-count (tcp-packet-data packet)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Driver startup - -(define PROTOCOL-TCP 6) - -(define (spawn-tcp-driver) - (spawn-port-allocator 'tcp (lambda () (query-set tcp-ports (tcp-port-allocation $p _) p))) - - (spawn #:name 'kernel-tcp-driver - (define local-ips (query-local-ip-addresses)) - - (define/query-set active-state-vectors ($ q (tcp-quad _ _ _ _)) q) - - (define (state-vector-active? statevec) - (set-member? (active-state-vectors) statevec)) - - (define (analyze-incoming-packet src-ip dst-ip body) - (bit-string-case body - ([ (src-port :: integer bytes 2) - (dst-port :: integer bytes 2) - (sequence-number :: integer bytes 4) - (ack-number :: integer bytes 4) - (data-offset :: integer bits 4) - (reserved :: integer bits 3) - (ns :: integer bits 1) - (cwr :: integer bits 1) - (ece :: integer bits 1) - (urg :: integer bits 1) - (ack :: integer bits 1) - (psh :: integer bits 1) - (rst :: integer bits 1) - (syn :: integer bits 1) - (fin :: integer bits 1) - (window-size :: integer bytes 2) - (checksum :: integer bytes 2) ;; TODO: check checksum - (urgent-pointer :: integer bytes 2) - (rest :: binary) ] - (let* ((flags (set)) - (statevec (tcp-quad src-ip src-port dst-ip dst-port)) - (old-active-state-vectors (active-state-vectors)) - (spawn-needed? (and (not (state-vector-active? statevec)) - (zero? rst)))) ;; don't bother spawning if it's a rst - (define-syntax-rule (set-flags! v ...) - (begin (unless (zero? v) (set! flags (set-add flags 'v))) ...)) - (set-flags! ns cwr ece urg ack psh rst syn fin) - (bit-string-case rest - ([ (opts :: binary bytes (- (* data-offset 4) 20)) - (data :: binary) ] - (let ((packet (tcp-packet #t - statevec - sequence-number - ack-number - flags - window-size - (bit-string->bytes opts) - (bit-string->bytes data)))) - (log-netstack/tcp-debug "TCP ~a" (summarize-tcp-packet packet)) - (when spawn-needed? - (log-netstack/tcp-debug " - spawn needed!") - (active-state-vectors (set-add (active-state-vectors) statevec)) - (spawn-state-vector #f (tcp-address (ip-address->hostname src-ip) src-port) statevec)) - (send! packet))) - (else #f)))) - (else #f))) - - (begin/dataflow - (log-netstack/tcp-debug "SCN yielded statevecs ~v and local-ips ~v" - (active-state-vectors) - (local-ips))) - - (define (deliver-outbound-packet p) - (match-define (tcp-packet #f - (tcp-quad dst-ip ;; \__ remote - dst-port ;; / - src-ip ;; \__ local - src-port) ;; / - sequence-number - ack-number - flags - window-size - options - data) - p) - (log-netstack/tcp-debug "TCP ~a" (summarize-tcp-packet p)) - (define (flag-bit sym) (if (set-member? flags sym) 1 0)) - (define payload (bit-string (src-port :: integer bytes 2) - (dst-port :: integer bytes 2) - (sequence-number :: integer bytes 4) - (ack-number :: integer bytes 4) - ((+ 5 (quotient (bit-string-byte-count options) 4)) - :: integer bits 4) ;; TODO: enforce 4-byte alignment - (0 :: integer bits 3) - ((flag-bit 'ns) :: integer bits 1) - ((flag-bit 'cwr) :: integer bits 1) - ((flag-bit 'ece) :: integer bits 1) - ((flag-bit 'urg) :: integer bits 1) - ((flag-bit 'ack) :: integer bits 1) - ((flag-bit 'psh) :: integer bits 1) - ((flag-bit 'rst) :: integer bits 1) - ((flag-bit 'syn) :: integer bits 1) - ((flag-bit 'fin) :: integer bits 1) - (window-size :: integer bytes 2) - (0 :: integer bytes 2) ;; checksum location - (0 :: integer bytes 2) ;; TODO: urgent pointer - (data :: binary))) - (define pseudo-header (bit-string (src-ip :: binary bytes 4) - (dst-ip :: binary bytes 4) - 0 - PROTOCOL-TCP - ((bit-string-byte-count payload) :: integer bytes 2))) - (send! (ip-packet #f src-ip dst-ip PROTOCOL-TCP #"" - (ip-checksum 16 payload #:pseudo-header pseudo-header)))) - - (on (message (ip-packet $source-if $src $dst PROTOCOL-TCP _ $body)) - (when (and source-if ;; source-if == #f iff packet originates locally - (set-member? (local-ips) dst)) - (analyze-incoming-packet src dst body))) - - (on (message ($ p (tcp-packet #f _ _ _ _ _ _ _))) - (deliver-outbound-packet p)) - - (during (observe (tcp-connection _ (tcp-listener $port))) - (assert (tcp-port-allocation port (tcp-listener port)))) - - (on (asserted (tcp-connection $id (tcp-address $remote-host $remote-port))) - (define port (allocate-port! 'tcp)) - ;; TODO: Choose a sensible IP address for the outbound - ;; connection. We don't have enough information to do this - ;; well at the moment, so just pick some available local IP - ;; address. - ;; - ;; Interesting note: In some sense, the right answer is a - ;; *wildcard*. This would give us a form of mobility, where IP - ;; addresses only route to a given bucket-of-state and ONLY the - ;; port number selects a substate therein. That's not how TCP - ;; is defined however so we can't do that. - (define appropriate-ip (set-first (local-ips))) - (define appropriate-host (ip-address->hostname appropriate-ip)) - (define remote-ip (ip-string->ip-address remote-host)) - (define q (tcp-quad remote-ip remote-port appropriate-ip port)) - (active-state-vectors (set-add (active-state-vectors) q)) - (spawn-state-vector #t id q)) - - (during/spawn (observe (tcp-in-line $id _)) - #:name (list 'drivers/tcp 'line-reader id) - (local-require (only-in syndicate/support/bytes bytes-index)) - (field [buffer #""]) - (on (message (tcp-in id $bs)) (buffer (bytes-append (buffer) bs))) - (begin/dataflow - (define newline-pos (bytes-index (buffer) (char->integer #\newline))) - (when newline-pos - (define line (subbytes (buffer) 0 newline-pos)) - (buffer (subbytes (buffer) (+ newline-pos 1))) - (send! (tcp-in-line id line))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Per-connection state vector process - -;;--------------------------------------------------------------------------- -;; From the RFC: -;; -;; Send Sequence Variables -;; -;; SND.UNA - send unacknowledged -;; SND.NXT - send next -;; SND.WND - send window -;; SND.UP - send urgent pointer -;; SND.WL1 - segment sequence number used for last window update -;; SND.WL2 - segment acknowledgment number used for last window -;; update -;; ISS - initial send sequence number -;; -;; Receive Sequence Variables -;; -;; RCV.NXT - receive next -;; RCV.WND - receive window -;; RCV.UP - receive urgent pointer -;; IRS - initial receive sequence number -;; -;; The following diagrams may help to relate some of these variables to -;; the sequence space. -;; -;; Send Sequence Space -;; -;; 1 2 3 4 -;; ----------|----------|----------|---------- -;; SND.UNA SND.NXT SND.UNA -;; +SND.WND -;; -;; 1 - old sequence numbers which have been acknowledged -;; 2 - sequence numbers of unacknowledged data -;; 3 - sequence numbers allowed for new data transmission -;; 4 - future sequence numbers which are not yet allowed -;; -;; Send Sequence Space -;; -;; Figure 4. -;; -;; The send window is the portion of the sequence space labeled 3 in -;; figure 4. -;; -;; Receive Sequence Space -;; -;; 1 2 3 -;; ----------|----------|---------- -;; RCV.NXT RCV.NXT -;; +RCV.WND -;; -;; 1 - old sequence numbers which have been acknowledged -;; 2 - sequence numbers allowed for new reception -;; 3 - future sequence numbers which are not yet allowed -;; -;; Receive Sequence Space -;; -;; Figure 5. -;; -;; The receive window is the portion of the sequence space labeled 2 in -;; figure 5. -;; -;; There are also some variables used frequently in the discussion that -;; take their values from the fields of the current segment. -;; -;; Current Segment Variables -;; -;; SEG.SEQ - segment sequence number -;; SEG.ACK - segment acknowledgment number -;; SEG.LEN - segment length -;; SEG.WND - segment window -;; SEG.UP - segment urgent pointer -;; SEG.PRC - segment precedence value -;; -;;--------------------------------------------------------------------------- - -(struct buffer (data ;; bit-string - seqn ;; names leftmost byte in data - window ;; counts bytes from leftmost byte in data - finished?) ;; boolean: true after FIN - #:transparent) - -;; Regarding acks: -;; -;; - we send an ack number that is (buffer-seqn (inbound)) plus the -;; number of buffered bytes. -;; -;; - acks received allow us to advance (buffer-seqn (outbound)) (that -;; is, SND.UNA) to that point, discarding buffered data to do so. - -;; Regarding windows: -;; -;; - (buffer-window (outbound)) is the size of the peer's receive -;; window. Do not allow more than this many bytes to be -;; unacknowledged on the wire. -;; -;; - (buffer-window (inbound)) is the size of our receive window. The -;; peer should not exceed this; we should ignore data received that -;; extends beyond this. Once we implement flow control locally -;; (ahem) we should move this around, but at present it is fixed. - -;; TODO: Zero receive window probe when we have something to say. - -(define (buffer-push b data) - (struct-copy buffer b [data (bit-string-append (buffer-data b) data)])) - -(define inbound-buffer-limit 65535) -(define maximum-segment-size 536) ;; bytes -(define maximum-segment-lifetime-sec (* 2 60)) ;; two minutes; 2MSL is TIME-WAIT timeout -(define user-timeout-msec (* 5 60 1000)) ;; per RFC 793, this should be per-connection, but I - ;; cheat; RFC 793 says "the present global default is five minutes", which is - ;; reasonable to be getting on with - -(define (seq+ a b) (bitwise-and #xffffffff (+ a b))) - -;; Always positive -(define (seq- larger smaller) - (if (< larger smaller) ;; wraparound has occurred - (+ (- larger smaller) #x100000000) - (- larger smaller))) - -(define (seq> a b) - (not (seq>= b a))) - -(define (seq>= a b) - (< (seq- a b) #x80000000)) - -(define (seq-min a b) (if (seq> a b) b a)) -(define (seq-max a b) (if (seq> a b) a b)) - -(module+ test - (check-equal? (seq+ 41724780 1) 41724781) - (check-equal? (seq+ 0 1) 1) - (check-equal? (seq+ #x80000000 1) #x80000001) - (check-equal? (seq+ #xffffffff 1) #x00000000) - - (check-equal? (seq> 41724780 41724780) #f) - (check-equal? (seq> 41724781 41724780) #t) - (check-equal? (seq> 41724780 41724781) #f) - - (check-equal? (seq> 0 0) #f) - (check-equal? (seq> 1 0) #t) - (check-equal? (seq> 0 1) #f) - - (check-equal? (seq> #x80000000 #x80000000) #f) - (check-equal? (seq> #x80000001 #x80000000) #t) - (check-equal? (seq> #x80000000 #x80000001) #f) - - (check-equal? (seq> #xffffffff #xffffffff) #f) - (check-equal? (seq> #x00000000 #xffffffff) #t) - (check-equal? (seq> #xffffffff #x00000000) #f) - - (check-equal? (seq>= 41724780 41724780) #t) - (check-equal? (seq>= 41724781 41724780) #t) - (check-equal? (seq>= 41724780 41724781) #f) - - (check-equal? (seq>= 0 0) #t) - (check-equal? (seq>= 1 0) #t) - (check-equal? (seq>= 0 1) #f) - - (check-equal? (seq>= #x80000000 #x80000000) #t) - (check-equal? (seq>= #x80000001 #x80000000) #t) - (check-equal? (seq>= #x80000000 #x80000001) #f) - - (check-equal? (seq>= #xffffffff #xffffffff) #t) - (check-equal? (seq>= #x00000000 #xffffffff) #t) - (check-equal? (seq>= #xffffffff #x00000000) #f)) - -(define (spawn-state-vector outbound? connection-id q) - (match-define (tcp-quad remote-ip remote-port local-ip local-port) q) - - (spawn #:name (list 'tcp-state-vector - (ip-address->hostname remote-ip) - remote-port - (ip-address->hostname local-ip) - local-port) - (define root-facet (current-facet)) - - (assert (tcp-port-allocation local-port - (tcp-address (ip-address->hostname remote-ip) remote-port))) - - (define initial-outbound-seqn - ;; Yuck - (inexact->exact (truncate (* #x100000000 (random))))) - - (field [outbound (buffer #"!" initial-outbound-seqn 0 #f)] ;; dummy data at SYN position - [send-next initial-outbound-seqn] ;; SND.NXT - [high-water-mark initial-outbound-seqn] - - [inbound (buffer #"" #f inbound-buffer-limit #f)] - [transmission-needed? #f] - [syn-acked? #f] - [fin-seen? #f] - [unblocked? #f] - - [latest-peer-activity-time (current-inexact-milliseconds)] - ;; ^ the most recent time we heard from our peer - [user-timeout-base-time (current-inexact-milliseconds)] - ;; ^ when the index of the first outbound unacknowledged byte changed - - ;; RFC 6298 - [rtt-estimate #f] ;; milliseconds; "SRTT" - [rtt-mean-deviation #f] ;; milliseconds; "RTTVAR" - [retransmission-timeout 1000] ;; milliseconds - [retransmission-deadline #f] - [rtt-estimate-seqn-target #f] - [rtt-estimate-start-time #f] - ) - - (define (next-expected-seqn) - (define b (inbound)) - (define v (buffer-seqn b)) - (and v (seq+ v (bit-string-byte-count (buffer-data b))))) - - (define (set-inbound-seqn! seqn) - (inbound (struct-copy buffer (inbound) [seqn seqn]))) - - (define (incorporate-segment! data) - (when (not (buffer-finished? (inbound))) - (inbound (buffer-push (inbound) data)))) - - (define (deliver-inbound-locally!) - (define b (inbound)) - (when (not (bit-string-empty? (buffer-data b))) - (define chunk (bit-string->bytes (buffer-data b))) - (send! (tcp-in connection-id chunk)) - (inbound (struct-copy buffer b - [data #""] - [seqn (seq+ (buffer-seqn b) (bytes-length chunk))])))) - - ;; -> Void - (define (check-fin!) - (define b (inbound)) - (when (not (buffer-finished? b)) - (unless (bit-string-empty? (buffer-data b)) ;; assured by deliver-inbound-locally - (error 'check-fin "Nonempty inbound buffer")) - (when (fin-seen?) - (log-netstack/tcp-debug "Closing inbound stream.") - (inbound (struct-copy buffer b - [seqn (seq+ (buffer-seqn b) 1)] ;; reliable: count fin as a byte - [finished? #t])) - (transmission-needed? #t)))) ;; we must send an ack - - (define (connected?) - (and (syn-acked?) ;; the SYN we sent has been acked by the remote peer - (not (buffer-finished? (inbound))))) ;; the remote peer hasn't sent a FIN - - (on (asserted (tcp-accepted connection-id)) - (unblocked? #t)) - - (begin/dataflow - (when (and (connected?) (unblocked?)) - (deliver-inbound-locally!) - (check-fin!))) - - ;; -> Void - (define (arm-retransmission-timer!) - (log-netstack/tcp-debug "Arming retransmission timer (~a ms)" (retransmission-timeout)) - (retransmission-deadline (+ (current-inexact-milliseconds) (retransmission-timeout)))) - - ;; Timestamp -> Void - (define (start-rtt-estimate! now) - (define target (send-next)) - (when (seq>= target (high-water-mark)) - (log-netstack/tcp-debug "Starting RTT estimation; target seqn is ~a" target) - (rtt-estimate-start-time now) - (rtt-estimate-seqn-target target))) - - ;; -> Void - (define (reset-rtt-estimate!) - (rtt-estimate-start-time #f) - (rtt-estimate-seqn-target #f)) - - ;; Timestamp -> Void - (define (finish-rtt-estimate! now) - (define rtt-measurement (- now (rtt-estimate-start-time))) - (reset-rtt-estimate!) - (log-netstack/tcp-debug "RTT measurement: ~a ms" rtt-measurement) - ;; RFC 6298 Section 2. - (cond [(rtt-estimate) => ;; we have a previous estimate, RFC 6298 rule (2.3) - (lambda (prev-estimate) - (rtt-mean-deviation (+ (* 0.75 (rtt-mean-deviation)) - (* 0.25 (abs (- rtt-measurement prev-estimate))))) - (rtt-estimate (+ (* 0.875 prev-estimate) - (* 0.125 rtt-measurement))))] - [else ;; no previous estimate, RFC 6298 rule (2.2) applies - (rtt-estimate rtt-measurement) - (rtt-mean-deviation (/ rtt-measurement 2))]) - (default-retransmission-timeout!) - (log-netstack/tcp-debug "RTT measurement ~a ms; estimate ~a ms; mean deviation ~a ms; RTO ~a ms" - rtt-measurement - (rtt-estimate) - (rtt-mean-deviation) - (retransmission-timeout))) - - (define (default-retransmission-timeout!) - (retransmission-timeout - (max 200 ;; RFC 6298 rule (2.4), but cribbing from Linux's 200ms minimum - (min 60000 ;; (2.5) - (+ (rtt-estimate) (* 4 (rtt-mean-deviation))))))) ;; (2.2), (2.3) - - ;; Boolean SeqNum -> Void - (define (discard-acknowledged-outbound! ack? ackn) - (when ack? - (let* ((b (outbound)) - (base (buffer-seqn b)) - (ackn (seq-min ackn (high-water-mark))) - (ackn (seq-max ackn base)) - (dist (seq- ackn base))) - (user-timeout-base-time (current-inexact-milliseconds)) - (when (positive? dist) - (when (not (syn-acked?)) (syn-acked? #t)) - (log-netstack/tcp-debug "******** ackn ~a; send-next ~a; high-water-mark ~a" - ackn - (send-next) - (high-water-mark)) - (when (seq> ackn (send-next)) (send-next ackn)) - (when (and (rtt-estimate-seqn-target) (seq>= ackn (rtt-estimate-seqn-target))) - (finish-rtt-estimate! (current-inexact-milliseconds))) - - (define remaining-data (bit-string-drop (buffer-data b) (* dist 8))) ;; bit offset! - (outbound (struct-copy buffer b [data remaining-data] [seqn ackn])) - - (default-retransmission-timeout!) - (log-netstack/tcp-debug "Positive distance moved by ack, RTO now ~a" - (retransmission-timeout)) - (arm-retransmission-timer!))))) - - ;; Nat -> Void - (define (update-outbound-window! peer-window) - (log-netstack/tcp-debug "Peer's receive-window is now ~a" peer-window) - (outbound (struct-copy buffer (outbound) [window peer-window]))) - - ;; True iff there is no queued-up data waiting either for - ;; transmission or (if transmitted already) for acknowledgement. - (define (all-output-acknowledged?) - (bit-string-empty? (buffer-data (outbound)))) - - (define (close-outbound-stream!) - (log-netstack/tcp-debug "Closing outbound stream.") - (define b (outbound)) - (when (not (buffer-finished? b)) - (outbound (struct-copy buffer (buffer-push b #"!") ;; dummy FIN byte - [finished? #t])) - (transmission-needed? #t))) ;; the FIN machinery is awkwardly - ;; different from the usual - ;; advance-based decision on - ;; whether to send a packet or not - - ;; SeqNum Boolean Boolean Bytes -> TcpPacket - (define (build-outbound-packet seqn mention-syn? mention-fin? payload) - (define ackn (next-expected-seqn)) - (define window (min 65535 ;; limit of field width - (max 0 ;; can't be negative - (- (buffer-window (inbound)) - (bit-string-byte-count (buffer-data (inbound))))))) - - (define flags (set)) - (when ackn (set! flags (set-add flags 'ack))) - (when mention-syn? (set! flags (set-add flags 'syn))) - (when mention-fin? (set! flags (set-add flags 'fin))) - (tcp-packet #f q seqn (or ackn 0) flags window #"" payload)) - - (define (outbound-data-chunk offset length) - (bit-string-take (bit-string-drop (buffer-data (outbound)) (* offset 8)) (* length 8))) - - ;; Transmit acknowledgements and outbound data. - (begin/dataflow - (define in-flight-count (seq- (send-next) (buffer-seqn (outbound)))) - - (define-values (mention-syn? ;; whether to mention SYN - payload-size ;; how many bytes of payload data to include - mention-fin? ;; whether to mention FIN - advance) ;; how far to advance send-next - (if (syn-acked?) - (let* ((effective-window (max 0 (- (buffer-window (outbound)) in-flight-count))) - (stream-ended? (buffer-finished? (outbound))) - (max-advance (- (bit-string-byte-count (buffer-data (outbound))) in-flight-count)) - (payload-size (min maximum-segment-size effective-window max-advance))) - (if (and stream-ended? ;; there's a FIN enqueued, - (positive? payload-size) ;; we aren't sending nothing at all, - (= payload-size max-advance)) ;; and our payload would cover the FIN - (values #f (- payload-size 1) #t payload-size) - (values #f payload-size #f payload-size))) - (cond [(= in-flight-count 0) (values #t 0 #f 1)] - [(= in-flight-count 1) (values #t 0 #f 0)] - [else (error 'send-outbound! - "Invalid state: send-next had advanced too far before SYN")]))) - - (when (and (or (next-expected-seqn) outbound?) - ;; ^ Talk only either if: we know the peer's seqn, or - ;; we don't, but we're an outbound connection rather - ;; than a listener. - (or (transmission-needed?) - (positive? advance)) - ;; ^ ... and we have something to say. Something to - ;; ack, or something to send. - ) - (define packet-seqn (if mention-syn? (buffer-seqn (outbound)) (send-next))) - (define packet (build-outbound-packet packet-seqn - mention-syn? - mention-fin? - (outbound-data-chunk in-flight-count payload-size))) - (when (positive? advance) - (define new-send-next (seq+ (send-next) advance)) - (send-next new-send-next) - (when (seq> new-send-next (high-water-mark)) - (high-water-mark new-send-next))) - (when (transmission-needed?) - (transmission-needed? #f)) - - ;; (log-netstack/tcp-debug " sending ~v" packet) - (send! packet) - ;; (if (> (random) 0.5) - ;; (begin (log-netstack/tcp-debug "Send ~a" (summarize-tcp-packet packet)) - ;; (send! packet)) - ;; (log-netstack/tcp-debug "Drop ~a" (summarize-tcp-packet packet))) - - (when (or mention-syn? mention-fin? (positive? advance)) - (when (not (retransmission-deadline)) - (arm-retransmission-timer!)) - (when (not (rtt-estimate-start-time)) - (start-rtt-estimate! (current-inexact-milliseconds)))))) - - (begin/dataflow - (when (and (retransmission-deadline) (all-output-acknowledged?)) - (log-netstack/tcp-debug "All output acknowledged; disarming retransmission timer") - (retransmission-deadline #f))) - - (on #:when (retransmission-deadline) (asserted (later-than (retransmission-deadline))) - (send-next (buffer-seqn (outbound))) - (log-netstack/tcp-debug "Retransmission deadline fired, RTO was ~a; reset to ~a" - (retransmission-timeout) - (send-next)) - (update-outbound-window! maximum-segment-size) ;; temporary. Will reopen on next ack - (transmission-needed? #t) - (retransmission-deadline #f) - (reset-rtt-estimate!) ;; give up on current RTT estimation - (retransmission-timeout (min 64000 (* 2 (retransmission-timeout)))) - (log-netstack/tcp-debug " RTO now ~a" (retransmission-timeout))) - - (define (reset! seqn ackn) - (define reset-packet (tcp-packet #f q seqn ackn (set 'ack 'rst) 0 #"" #"")) - (log-netstack/tcp-warning "Reset ~a" (summarize-tcp-packet reset-packet)) - (stop-facet root-facet) - (send! reset-packet)) - - (assert q) ;; Declare that this state vector exists - (on-start (log-netstack/tcp-info "Starting ~a" (tcp-quad->string (not outbound?) q))) - (on-stop (log-netstack/tcp-info "Stopping ~a" (tcp-quad->string (not outbound?) q))) - - (stop-when #:when (and (buffer-finished? (outbound)) - (buffer-finished? (inbound)) - (all-output-acknowledged?)) - (asserted (later-than (+ (latest-peer-activity-time) - (* 2 1000 maximum-segment-lifetime-sec)))) - ;; Everything is cleanly shut down, and we just need to wait a while for unexpected - ;; packets before we release the state vector. - ) - - (stop-when #:when (not (all-output-acknowledged?)) - (asserted (later-than (+ (user-timeout-base-time) user-timeout-msec))) - ;; We've been plaintively retransmitting for user-timeout-msec without hearing anything - ;; back; this is a crude approximation of the real condition for TCP_USER_TIMEOUT, but - ;; it will do for now? TODO - (log-netstack/tcp-warning "TCP_USER_TIMEOUT fired.")) - - (define/query-value listener-listening? - #f (observe (tcp-connection _ (tcp-listener local-port))) #t) - - (define (trigger-ack!) - (transmission-needed? #t)) - - (on (message (tcp-packet #t q $seqn $ackn $flags $window $options $data)) - (define expected (next-expected-seqn)) - (define is-syn? (set-member? flags 'syn)) - (define is-fin? (set-member? flags 'fin)) - (cond - [(set-member? flags 'rst) - (stop-facet root-facet - (when (not (connected?)) ;; --> rejected! - (define e (exn:fail:network - (format "~a: Connection rejected" (tcp-quad->string #f q)) - (current-continuation-marks))) - (react (assert (tcp-rejected connection-id e)) - (on-start (sleep 5) - (stop-current-facet)))))] - [(and (not expected) ;; no syn yet - (or (not is-syn?) ;; and this isn't it - (and (not (listener-listening?)) ;; or it is, but no listener... - (not outbound?)))) ;; ...and we're not an outbound connection - (reset! ackn ;; this is *our* seqn - (seq+ seqn (+ (if is-syn? 1 0) (if is-fin? 1 0))) - ;; ^^ this is what we should acknowledge... - )] - [else - (cond - [(not expected) ;; haven't seen syn yet, but we know this is it - (set-inbound-seqn! (seq+ seqn 1)) - (incorporate-segment! data) - (trigger-ack!)] - [(= expected seqn) - (incorporate-segment! data) - (when (positive? (bit-string-byte-count data)) (trigger-ack!))] - [else - (trigger-ack!)]) - (when is-fin? (fin-seen? #t)) - (discard-acknowledged-outbound! (set-member? flags 'ack) ackn) - (update-outbound-window! window) - (latest-peer-activity-time (current-inexact-milliseconds))])) - - (on (message (tcp-out connection-id $bs)) - ;; (log-netstack/tcp-debug "GOT MORE STUFF TO DELIVER ~v" bs) - - (when (all-output-acknowledged?) - ;; Only move user-timeout-base-time if there wasn't - ;; already some outstanding output. - (user-timeout-base-time (current-inexact-milliseconds))) - - (outbound (buffer-push (outbound) bs))) - - (if outbound? - (begin - (assert #:when (connected?) (tcp-accepted connection-id)) - (on (retracted (tcp-connection connection-id (tcp-address _ _))) - (close-outbound-stream!))) - (begin - (assert #:when (connected?) (tcp-connection connection-id (tcp-listener local-port))) - (on (asserted (tcp-rejected connection-id _)) - ;; In principle, we have the flexibility to delay - ;; replying to SYN until userland decides whether or not - ;; to accept an incoming connection! We don't do that yet - ;; though. - (close-outbound-stream!)) - (on (retracted (tcp-accepted connection-id)) - (close-outbound-stream!)) - (on-start (sleep 5) - (when (not (unblocked?)) - (log-netstack/tcp-error "TCP relay process ~a timed out waiting for peer" q) - (stop-facet root-facet))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(spawn-tcp-driver) diff --git a/OLD-syndicate-examples/netstack/udp.rkt b/OLD-syndicate-examples/netstack/udp.rkt deleted file mode 100644 index 85bca04..0000000 --- a/OLD-syndicate-examples/netstack/udp.rkt +++ /dev/null @@ -1,136 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(provide (struct-out udp-remote-address) - (struct-out udp-handle) - (struct-out udp-listener) - udp-address? - udp-local-address? - (struct-out udp-packet) - spawn-udp-driver) - -(require racket/set) -(require bitsyntax) - -(require "dump-bytes.rkt") -(require "checksum.rkt") -(require "configuration.rkt") -(require/activate "ip.rkt") -(require "port-allocator.rkt") - -;; udp-address/udp-address : "kernel" udp connection state machines -;; udp-handle/udp-address : "user" outbound connections -;; udp-listener/udp-address : "user" inbound connections - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Protocol messages - -(struct udp-remote-address (host port) #:prefab) -(struct udp-handle (id) #:prefab) -(struct udp-listener (port) #:prefab) - -(define (udp-address? x) - (or (udp-remote-address? x) - (udp-local-address? x))) - -(define (udp-local-address? x) - (or (udp-handle? x) - (udp-listener? x))) - -;; USER-level protocol -(struct udp-packet (source destination body) #:prefab) - -;; KERNEL-level protocol -(struct udp-datagram (source-ip source-port destination-ip destination-port body) #:prefab) -(struct udp-port-allocation (port handle) #:prefab) ;; (udp-port-allocation Number UdpLocalAddress) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; User-accessible driver startup - -(define (spawn-udp-driver) - (spawn-port-allocator 'udp (lambda () (query-set udp-ports (udp-port-allocation $p _) p))) - (spawn-kernel-udp-driver) - (spawn #:name 'udp-driver - (on (asserted (observe (udp-packet _ ($ h (udp-listener _)) _))) - (spawn-udp-relay (udp-listener-port h) h)) - (on (asserted (observe (udp-packet _ ($ h (udp-handle _)) _))) - (spawn #:name (list 'udp-transient h) - (on-start (spawn-udp-relay (allocate-port! 'udp) h)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Relaying - -(define (spawn-udp-relay local-port local-user-addr) - (spawn #:name (list 'udp-relay local-port local-user-addr) - (on-start (log-info "Spawning UDP relay ~v / ~v" local-port local-user-addr)) - - (stop-when (retracted (observe (udp-packet _ local-user-addr _)))) - (assert (udp-port-allocation local-port local-user-addr)) - - (during (host-route $ip _ _) - (on (message (udp-datagram $source-ip $source-port ip local-port $bs)) - (send! - (udp-packet (udp-remote-address (ip-address->hostname source-ip) - source-port) - local-user-addr - bs)))) - - (define local-ips (query-local-ip-addresses)) - (on (message (udp-packet local-user-addr (udp-remote-address $other-host $other-port) $bs)) - ;; Choose arbitrary local IP address for outbound packet! - ;; TODO: what can be done? Must I examine the routing table? - (send! (udp-datagram (set-first (local-ips)) - local-port - (ip-string->ip-address other-host) - other-port - bs))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Codec & kernel-level driver - -(define PROTOCOL-UDP 17) - -(define (spawn-kernel-udp-driver) - (spawn #:name 'kernel-udp-driver - (define local-ips (query-local-ip-addresses)) - - (on (message (ip-packet $source-if $src-ip $dst-ip PROTOCOL-UDP _ $body)) - (when (and source-if (set-member? (local-ips) dst-ip)) - (bit-string-case body - ([ (src-port :: integer bytes 2) - (dst-port :: integer bytes 2) - (length :: integer bytes 2) - (checksum :: integer bytes 2) ;; TODO: check checksum - (data :: binary) ] - (bit-string-case data - ([ (payload :: binary bytes (- length 8)) ;; min UDP header size is 8 bytes - (:: binary) ] - (send! (udp-datagram src-ip src-port dst-ip dst-port - (bit-string->bytes payload)))) - (else #f))) - (else #f)))) - - (on (message (udp-datagram $src-ip $src-port $dst-ip $dst-port $bs)) - (when (set-member? (local-ips) src-ip) - (let* ((payload (bit-string (src-port :: integer bytes 2) - (dst-port :: integer bytes 2) - ((+ 8 (bit-string-byte-count bs)) - :: integer bytes 2) - (0 :: integer bytes 2) ;; checksum location - (bs :: binary))) - (pseudo-header (bit-string (src-ip :: binary bytes 4) - (dst-ip :: binary bytes 4) - 0 - PROTOCOL-UDP - ((bit-string-byte-count payload) - :: integer bytes 2))) - (checksummed-payload (ip-checksum #:pseudo-header pseudo-header - 6 payload))) - (send! (ip-packet #f src-ip dst-ip PROTOCOL-UDP #"" - checksummed-payload))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(spawn-udp-driver) diff --git a/OLD-syndicate-examples/private/beautiful-grassland-wallpapers-1920x1080.jpg b/OLD-syndicate-examples/private/beautiful-grassland-wallpapers-1920x1080.jpg deleted file mode 100644 index 5d092fe..0000000 Binary files a/OLD-syndicate-examples/private/beautiful-grassland-wallpapers-1920x1080.jpg and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270302__littlerobotsoundfactory__collect-point-02.wav b/OLD-syndicate-examples/private/sounds/270302__littlerobotsoundfactory__collect-point-02.wav deleted file mode 100644 index 9f44626..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270302__littlerobotsoundfactory__collect-point-02.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270303__littlerobotsoundfactory__collect-point-01.wav b/OLD-syndicate-examples/private/sounds/270303__littlerobotsoundfactory__collect-point-01.wav deleted file mode 100644 index 55206a3..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270303__littlerobotsoundfactory__collect-point-01.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270304__littlerobotsoundfactory__collect-point-00.wav b/OLD-syndicate-examples/private/sounds/270304__littlerobotsoundfactory__collect-point-00.wav deleted file mode 100644 index 6665a50..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270304__littlerobotsoundfactory__collect-point-00.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270305__littlerobotsoundfactory__climb-rope-loop-00.wav b/OLD-syndicate-examples/private/sounds/270305__littlerobotsoundfactory__climb-rope-loop-00.wav deleted file mode 100644 index f8788d4..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270305__littlerobotsoundfactory__climb-rope-loop-00.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270306__littlerobotsoundfactory__explosion-02.wav b/OLD-syndicate-examples/private/sounds/270306__littlerobotsoundfactory__explosion-02.wav deleted file mode 100644 index b5156d9..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270306__littlerobotsoundfactory__explosion-02.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270307__littlerobotsoundfactory__explosion-01.wav b/OLD-syndicate-examples/private/sounds/270307__littlerobotsoundfactory__explosion-01.wav deleted file mode 100644 index 25c94ff..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270307__littlerobotsoundfactory__explosion-01.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270308__littlerobotsoundfactory__explosion-00.wav b/OLD-syndicate-examples/private/sounds/270308__littlerobotsoundfactory__explosion-00.wav deleted file mode 100644 index ce70f04..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270308__littlerobotsoundfactory__explosion-00.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270309__littlerobotsoundfactory__craft-00.wav b/OLD-syndicate-examples/private/sounds/270309__littlerobotsoundfactory__craft-00.wav deleted file mode 100644 index 053e031..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270309__littlerobotsoundfactory__craft-00.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270310__littlerobotsoundfactory__explosion-04.wav b/OLD-syndicate-examples/private/sounds/270310__littlerobotsoundfactory__explosion-04.wav deleted file mode 100644 index fd39145..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270310__littlerobotsoundfactory__explosion-04.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270311__littlerobotsoundfactory__explosion-03.wav b/OLD-syndicate-examples/private/sounds/270311__littlerobotsoundfactory__explosion-03.wav deleted file mode 100644 index c8929c0..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270311__littlerobotsoundfactory__explosion-03.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270315__littlerobotsoundfactory__menu-navigate-03.wav b/OLD-syndicate-examples/private/sounds/270315__littlerobotsoundfactory__menu-navigate-03.wav deleted file mode 100644 index 0b3d4aa..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270315__littlerobotsoundfactory__menu-navigate-03.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270316__littlerobotsoundfactory__open-00.wav b/OLD-syndicate-examples/private/sounds/270316__littlerobotsoundfactory__open-00.wav deleted file mode 100644 index 7c9b2de..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270316__littlerobotsoundfactory__open-00.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270317__littlerobotsoundfactory__jump-01.wav b/OLD-syndicate-examples/private/sounds/270317__littlerobotsoundfactory__jump-01.wav deleted file mode 100644 index b85725a..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270317__littlerobotsoundfactory__jump-01.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270318__littlerobotsoundfactory__jump-02.wav b/OLD-syndicate-examples/private/sounds/270318__littlerobotsoundfactory__jump-02.wav deleted file mode 100644 index fb18bd5..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270318__littlerobotsoundfactory__jump-02.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270319__littlerobotsoundfactory__jingle-win-01.wav b/OLD-syndicate-examples/private/sounds/270319__littlerobotsoundfactory__jingle-win-01.wav deleted file mode 100644 index 4ded27c..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270319__littlerobotsoundfactory__jingle-win-01.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270320__littlerobotsoundfactory__jump-00.wav b/OLD-syndicate-examples/private/sounds/270320__littlerobotsoundfactory__jump-00.wav deleted file mode 100644 index 5badfa2..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270320__littlerobotsoundfactory__jump-00.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270321__littlerobotsoundfactory__menu-navigate-01.wav b/OLD-syndicate-examples/private/sounds/270321__littlerobotsoundfactory__menu-navigate-01.wav deleted file mode 100644 index d05a235..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270321__littlerobotsoundfactory__menu-navigate-01.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270322__littlerobotsoundfactory__menu-navigate-02.wav b/OLD-syndicate-examples/private/sounds/270322__littlerobotsoundfactory__menu-navigate-02.wav deleted file mode 100644 index c043843..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270322__littlerobotsoundfactory__menu-navigate-02.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270323__littlerobotsoundfactory__jump-03.wav b/OLD-syndicate-examples/private/sounds/270323__littlerobotsoundfactory__jump-03.wav deleted file mode 100644 index c8b933b..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270323__littlerobotsoundfactory__jump-03.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270324__littlerobotsoundfactory__menu-navigate-00.wav b/OLD-syndicate-examples/private/sounds/270324__littlerobotsoundfactory__menu-navigate-00.wav deleted file mode 100644 index d36ee07..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270324__littlerobotsoundfactory__menu-navigate-00.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270325__littlerobotsoundfactory__hit-02.wav b/OLD-syndicate-examples/private/sounds/270325__littlerobotsoundfactory__hit-02.wav deleted file mode 100644 index caae3dd..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270325__littlerobotsoundfactory__hit-02.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270326__littlerobotsoundfactory__hit-01.wav b/OLD-syndicate-examples/private/sounds/270326__littlerobotsoundfactory__hit-01.wav deleted file mode 100644 index b5058d8..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270326__littlerobotsoundfactory__hit-01.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270327__littlerobotsoundfactory__hit-00.wav b/OLD-syndicate-examples/private/sounds/270327__littlerobotsoundfactory__hit-00.wav deleted file mode 100644 index 8523333..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270327__littlerobotsoundfactory__hit-00.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270328__littlerobotsoundfactory__hero-death-00.wav b/OLD-syndicate-examples/private/sounds/270328__littlerobotsoundfactory__hero-death-00.wav deleted file mode 100644 index 3ef90e0..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270328__littlerobotsoundfactory__hero-death-00.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270329__littlerobotsoundfactory__jingle-lose-00.wav b/OLD-syndicate-examples/private/sounds/270329__littlerobotsoundfactory__jingle-lose-00.wav deleted file mode 100644 index 1e1a783..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270329__littlerobotsoundfactory__jingle-lose-00.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270330__littlerobotsoundfactory__jingle-achievement-01.wav b/OLD-syndicate-examples/private/sounds/270330__littlerobotsoundfactory__jingle-achievement-01.wav deleted file mode 100644 index 1d2286e..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270330__littlerobotsoundfactory__jingle-achievement-01.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270331__littlerobotsoundfactory__jingle-achievement-00.wav b/OLD-syndicate-examples/private/sounds/270331__littlerobotsoundfactory__jingle-achievement-00.wav deleted file mode 100644 index fd403a4..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270331__littlerobotsoundfactory__jingle-achievement-00.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270332__littlerobotsoundfactory__hit-03.wav b/OLD-syndicate-examples/private/sounds/270332__littlerobotsoundfactory__hit-03.wav deleted file mode 100644 index 230a6eb..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270332__littlerobotsoundfactory__hit-03.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270333__littlerobotsoundfactory__jingle-win-00.wav b/OLD-syndicate-examples/private/sounds/270333__littlerobotsoundfactory__jingle-win-00.wav deleted file mode 100644 index b47fadc..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270333__littlerobotsoundfactory__jingle-win-00.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270334__littlerobotsoundfactory__jingle-lose-01.wav b/OLD-syndicate-examples/private/sounds/270334__littlerobotsoundfactory__jingle-lose-01.wav deleted file mode 100644 index 710906b..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270334__littlerobotsoundfactory__jingle-lose-01.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270335__littlerobotsoundfactory__shoot-03.wav b/OLD-syndicate-examples/private/sounds/270335__littlerobotsoundfactory__shoot-03.wav deleted file mode 100644 index 79674d1..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270335__littlerobotsoundfactory__shoot-03.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270336__littlerobotsoundfactory__shoot-02.wav b/OLD-syndicate-examples/private/sounds/270336__littlerobotsoundfactory__shoot-02.wav deleted file mode 100644 index 62ddbd8..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270336__littlerobotsoundfactory__shoot-02.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270337__littlerobotsoundfactory__pickup-00.wav b/OLD-syndicate-examples/private/sounds/270337__littlerobotsoundfactory__pickup-00.wav deleted file mode 100644 index 52f90c9..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270337__littlerobotsoundfactory__pickup-00.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270338__littlerobotsoundfactory__open-01.wav b/OLD-syndicate-examples/private/sounds/270338__littlerobotsoundfactory__open-01.wav deleted file mode 100644 index f042b89..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270338__littlerobotsoundfactory__open-01.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270339__littlerobotsoundfactory__pickup-02.wav b/OLD-syndicate-examples/private/sounds/270339__littlerobotsoundfactory__pickup-02.wav deleted file mode 100644 index 72a0b40..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270339__littlerobotsoundfactory__pickup-02.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270340__littlerobotsoundfactory__pickup-01.wav b/OLD-syndicate-examples/private/sounds/270340__littlerobotsoundfactory__pickup-01.wav deleted file mode 100644 index d73a67b..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270340__littlerobotsoundfactory__pickup-01.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270341__littlerobotsoundfactory__pickup-04.wav b/OLD-syndicate-examples/private/sounds/270341__littlerobotsoundfactory__pickup-04.wav deleted file mode 100644 index 05a8b5e..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270341__littlerobotsoundfactory__pickup-04.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270342__littlerobotsoundfactory__pickup-03.wav b/OLD-syndicate-examples/private/sounds/270342__littlerobotsoundfactory__pickup-03.wav deleted file mode 100644 index 75764f1..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270342__littlerobotsoundfactory__pickup-03.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270343__littlerobotsoundfactory__shoot-01.wav b/OLD-syndicate-examples/private/sounds/270343__littlerobotsoundfactory__shoot-01.wav deleted file mode 100644 index 360a738..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270343__littlerobotsoundfactory__shoot-01.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/270344__littlerobotsoundfactory__shoot-00.wav b/OLD-syndicate-examples/private/sounds/270344__littlerobotsoundfactory__shoot-00.wav deleted file mode 100644 index a983110..0000000 Binary files a/OLD-syndicate-examples/private/sounds/270344__littlerobotsoundfactory__shoot-00.wav and /dev/null differ diff --git a/OLD-syndicate-examples/private/sounds/_readme_and_license.txt b/OLD-syndicate-examples/private/sounds/_readme_and_license.txt deleted file mode 100644 index 217e251..0000000 --- a/OLD-syndicate-examples/private/sounds/_readme_and_license.txt +++ /dev/null @@ -1,140 +0,0 @@ -Sound pack downloaded from Freesound.org ----------------------------------------- - -This pack of sounds contains sounds by LittleRobotSoundFactory ( https://www.freesound.org/people/LittleRobotSoundFactory/ ) -You can find this pack online at: https://www.freesound.org/people/LittleRobotSoundFactory/packs/16681/ - - -License details ---------------- - -Sampling+: http://creativecommons.org/licenses/sampling+/1.0/ -Creative Commons 0: http://creativecommons.org/publicdomain/zero/1.0/ -Attribution: http://creativecommons.org/licenses/by/3.0/ -Attribution Noncommercial: http://creativecommons.org/licenses/by-nc/3.0/ - - -Sounds in this pack -------------------- - - * 270344__littlerobotsoundfactory__shoot-00.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270344/ - * license: Attribution - * 270343__littlerobotsoundfactory__shoot-01.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270343/ - * license: Attribution - * 270342__littlerobotsoundfactory__pickup-03.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270342/ - * license: Attribution - * 270341__littlerobotsoundfactory__pickup-04.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270341/ - * license: Attribution - * 270340__littlerobotsoundfactory__pickup-01.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270340/ - * license: Attribution - * 270339__littlerobotsoundfactory__pickup-02.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270339/ - * license: Attribution - * 270338__littlerobotsoundfactory__open-01.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270338/ - * license: Attribution - * 270337__littlerobotsoundfactory__pickup-00.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270337/ - * license: Attribution - * 270336__littlerobotsoundfactory__shoot-02.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270336/ - * license: Attribution - * 270335__littlerobotsoundfactory__shoot-03.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270335/ - * license: Attribution - * 270334__littlerobotsoundfactory__jingle-lose-01.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270334/ - * license: Attribution - * 270333__littlerobotsoundfactory__jingle-win-00.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270333/ - * license: Attribution - * 270332__littlerobotsoundfactory__hit-03.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270332/ - * license: Attribution - * 270331__littlerobotsoundfactory__jingle-achievement-00.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270331/ - * license: Attribution - * 270330__littlerobotsoundfactory__jingle-achievement-01.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270330/ - * license: Attribution - * 270329__littlerobotsoundfactory__jingle-lose-00.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270329/ - * license: Attribution - * 270328__littlerobotsoundfactory__hero-death-00.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270328/ - * license: Attribution - * 270327__littlerobotsoundfactory__hit-00.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270327/ - * license: Attribution - * 270326__littlerobotsoundfactory__hit-01.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270326/ - * license: Attribution - * 270325__littlerobotsoundfactory__hit-02.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270325/ - * license: Attribution - * 270324__littlerobotsoundfactory__menu-navigate-00.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270324/ - * license: Attribution - * 270323__littlerobotsoundfactory__jump-03.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270323/ - * license: Attribution - * 270322__littlerobotsoundfactory__menu-navigate-02.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270322/ - * license: Attribution - * 270321__littlerobotsoundfactory__menu-navigate-01.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270321/ - * license: Attribution - * 270320__littlerobotsoundfactory__jump-00.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270320/ - * license: Attribution - * 270319__littlerobotsoundfactory__jingle-win-01.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270319/ - * license: Attribution - * 270318__littlerobotsoundfactory__jump-02.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270318/ - * license: Attribution - * 270317__littlerobotsoundfactory__jump-01.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270317/ - * license: Attribution - * 270316__littlerobotsoundfactory__open-00.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270316/ - * license: Attribution - * 270315__littlerobotsoundfactory__menu-navigate-03.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270315/ - * license: Attribution - * 270311__littlerobotsoundfactory__explosion-03.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270311/ - * license: Attribution - * 270310__littlerobotsoundfactory__explosion-04.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270310/ - * license: Attribution - * 270309__littlerobotsoundfactory__craft-00.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270309/ - * license: Attribution - * 270308__littlerobotsoundfactory__explosion-00.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270308/ - * license: Attribution - * 270307__littlerobotsoundfactory__explosion-01.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270307/ - * license: Attribution - * 270306__littlerobotsoundfactory__explosion-02.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270306/ - * license: Attribution - * 270305__littlerobotsoundfactory__climb-rope-loop-00.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270305/ - * license: Attribution - * 270304__littlerobotsoundfactory__collect-point-00.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270304/ - * license: Attribution - * 270303__littlerobotsoundfactory__collect-point-01.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270303/ - * license: Attribution - * 270302__littlerobotsoundfactory__collect-point-02.wav - * url: https://www.freesound.org/people/LittleRobotSoundFactory/sounds/270302/ - * license: Attribution - diff --git a/OLD-syndicate-examples/santa.rkt b/OLD-syndicate-examples/santa.rkt deleted file mode 100644 index 18affb0..0000000 --- a/OLD-syndicate-examples/santa.rkt +++ /dev/null @@ -1,86 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate -;; Santa Claus Problem -;; https://www.schoolofhaskell.com/school/advanced-haskell/beautiful-concurrency/4-the-santa-claus-problem -;; https://arxiv.org/pdf/1810.09613.pdf - -(require/activate syndicate/drivers/timer) -(require racket/list) -(require racket/set) - -(assertion-struct elf-has-a-problem (id)) -(assertion-struct reindeer-has-returned (id)) - -(assertion-struct problem-resolved (id)) -(assertion-struct deliver-toys ()) - -(define N-ELVES 10) -(define ELF-GROUP-SIZE 3) -(define N-REINDEER 9) - -(define (elf) - (define elf-self (gensym 'elf)) - (spawn* #:name elf-self - (let work-industriously () - (sleep (/ (random 1000) 1000.0)) - (react (assert (elf-has-a-problem elf-self)) - (stop-when (asserted (problem-resolved elf-self)) - (work-industriously)))))) - -(define (reindeer) - (define reindeer-self (gensym 'reindeer)) - (spawn* #:name reindeer-self - (let holiday () - (sleep (/ (random 9000) 1000.0)) - (react (assert (reindeer-has-returned reindeer-self)) - (stop-when (asserted (deliver-toys)) - (react (stop-when (retracted (deliver-toys)) - (holiday)))))))) - -(spawn* #:name 'santa - (define (wait-for-work) - (react (define/query-set stuck-elves (elf-has-a-problem $id) id) - (define/query-set returned-reindeer (reindeer-has-returned $id) id) - (stop-when-true (= (set-count (returned-reindeer)) N-REINDEER) - (harness-reindeer)) - (stop-when-true (>= (set-count (stuck-elves)) ELF-GROUP-SIZE) - (talk-to-elves (take (set->list (stuck-elves)) ELF-GROUP-SIZE))))) - - (define (harness-reindeer) - (react (assert (deliver-toys)) - (stop-when (retracted (reindeer-has-returned _)) - (wait-for-work)))) - - (define (talk-to-elves elves) - (match elves - ['() (wait-for-work)] - [(cons elf remainder) - (react (assert (problem-resolved elf)) - (stop-when (retracted (elf-has-a-problem elf)) - (talk-to-elves remainder)))])) - - (wait-for-work)) - -(for [(i N-ELVES)] (elf)) -(for [(i N-REINDEER)] (reindeer)) - -(spawn #:name 'narrator - (during (elf-has-a-problem $id) - (on-start (printf "~a has a problem!\n" id)) - (on-stop (printf "~a's problem is resolved. ~a returns to work.\n" id id))) - - (on (asserted (reindeer-has-returned $id)) - (printf "~a has returned from holiday and is ready to deliver toys!\n" id)) - - (on (retracted (reindeer-has-returned $id)) - (printf "~a delivers toys with the other reindeer.\n" id) - (react (stop-when (retracted (deliver-toys)) - (printf "~a has been dismissed by Santa, and goes back on holiday.\n" id)))) - - (on (asserted (deliver-toys)) - (printf "Santa does the delivery run!\n")) - - (on (asserted (problem-resolved $id)) - (printf "Santa resolves the problem of ~a.\n" id))) diff --git a/OLD-syndicate-examples/server-chat-client.rkt b/OLD-syndicate-examples/server-chat-client.rkt deleted file mode 100644 index 281d2c5..0000000 --- a/OLD-syndicate-examples/server-chat-client.rkt +++ /dev/null @@ -1,48 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(require/activate syndicate/distributed) -(require/activate syndicate/drivers/external-event) -(require (only-in racket/port read-line-evt)) - -(assertion-struct Present (name)) -(message-struct Says (who what)) - -(define host (make-parameter "localhost")) -(define port (make-parameter 8001)) -(define scope (make-parameter "chat")) -(define initial-username (make-parameter (symbol->string (strong-gensym 'chatter-)))) - -(file-stream-buffer-mode (current-output-port) 'line) - -(module+ main - (require racket/cmdline) - (command-line #:once-each - ["--host" hostname "Server hostname" (host hostname)] - ["--port" portnum "Server port number" (port (string->number portnum))] - ["--scope" scopename "Server scope" (scope scopename)] - ["--nick" nick "User nickname" (initial-username nick)])) - -(spawn #:name 'main - (field [username (initial-username)]) - - (define root-facet (current-facet)) - (define url (server-tcp-connection (host) (port) (scope))) - (during (server-connected url) - (on-start (log-info "Connected to server.")) - (on-stop (log-info "Disconnected from server.")) - - (on (asserted (from-server url (Present $who))) (printf "~a arrived.\n" who)) - (on (retracted (from-server url (Present $who))) (printf "~a departed.\n" who)) - (on (message (from-server url (Says $who $what))) (printf "~a: ~a\n" who what)) - - (assert (to-server url (Present (username)))) - - (define stdin-evt (read-line-evt (current-input-port) 'any)) - (on (message (inbound (external-event stdin-evt (list $line)))) - (match line - [(? eof-object?) (stop-facet root-facet)] - [(pregexp #px"^/nick (.+)$" (list _ newnick)) (username newnick)] - [other (send! (to-server url (Says (username) other)))])))) diff --git a/OLD-syndicate-examples/simple-cross-layer.rkt b/OLD-syndicate-examples/simple-cross-layer.rkt deleted file mode 100644 index 32e9894..0000000 --- a/OLD-syndicate-examples/simple-cross-layer.rkt +++ /dev/null @@ -1,15 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(assertion-struct greeting (text)) - -(spawn #:name "A" (assert (greeting "Hi from outer space!"))) -(spawn #:name "B" (on (asserted (greeting $t)) - (printf "Outer dataspace: ~a\n" t))) - -(dataspace #:name "C" - (spawn #:name "D" (assert (outbound (greeting "Hi from inner!")))) - (spawn #:name "E" (on (asserted (inbound (greeting $t))) - (printf "Inner dataspace: ~a\n" t)))) diff --git a/OLD-syndicate-examples/sqlite.rkt b/OLD-syndicate-examples/sqlite.rkt deleted file mode 100644 index 7e5bc93..0000000 --- a/OLD-syndicate-examples/sqlite.rkt +++ /dev/null @@ -1,39 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(require/activate syndicate/drivers/sqlite) -(require/activate syndicate/drivers/timer) - -(define PATH "t.sqlite") -(define DB (sqlite-db PATH)) - -(spawn* (with-handlers [(exn:fail:filesystem? void)] - (delete-file PATH)) - (react (assert DB)) - - (sqlite-create-table! DB "x" "y" "z") - - (send! (sqlite-insert DB "x" (list 1 "yy") (gensym 'init))) - (send! (sqlite-insert DB "x" (list "yy" "hello") (gensym 'init))) - (send! (sqlite-insert DB "x" (list "yy" "goodbye") (gensym 'init))) - (send! (sqlite-insert DB "x" (list 1 "yy") (gensym 'init))) - - (react - (during (sqlite-row DB "x" (list _ $key)) - (during (sqlite-row DB "x" (list key $value)) - (on-start (printf "+ ~a row in x: ~a\n" key value)) - (on-stop (printf "- ~a row in x: ~a\n" key value)))) - (during (sqlite-row DB "x" $columns) - (on-start (printf "+ row in x: ~a\n" columns)) - (on-stop (printf "- row in x: ~a\n" columns)))) - - (sqlite-insert! DB "x" "a" "b") - (sqlite-insert! DB "x" "a" "c") - (sqlite-insert! DB "x" "yy" "b") - (sqlite-insert! DB "x" "yy" "c") - (sqlite-delete! DB "x" "a" "b") - (sqlite-delete! DB "x" (discard) "b") - (sqlite-delete! DB "x" "a" (discard)) - (sqlite-delete! DB "x" (discard) "c")) diff --git a/OLD-syndicate-examples/stdin-echo.rkt b/OLD-syndicate-examples/stdin-echo.rkt deleted file mode 100644 index 6974954..0000000 --- a/OLD-syndicate-examples/stdin-echo.rkt +++ /dev/null @@ -1,13 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(require/activate syndicate/drivers/external-event) -(require (only-in racket/port read-bytes-line-evt)) - -(spawn (define stdin-evt (read-bytes-line-evt (current-input-port) 'any)) - (on (message (inbound (external-event stdin-evt (list $line)))) - (if (eof-object? line) - (stop-current-facet) - (printf "~a\n" line)))) diff --git a/OLD-syndicate-examples/time.rkt b/OLD-syndicate-examples/time.rkt deleted file mode 100644 index ca70d1c..0000000 --- a/OLD-syndicate-examples/time.rkt +++ /dev/null @@ -1,24 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(require/activate syndicate/drivers/timer) - -(spawn #:name 'plain-timer-demo - (field [count 0]) - (on-start (send! (set-timer 'main-timer 0 'relative))) - (on (message (timer-expired 'main-timer $now)) - (log-info "main-timer expired at ~a" now) - (count (+ (count) 1)) - (when (< (count) 5) - (send! (set-timer 'main-timer 500 'relative))))) - -(spawn #:name 'later-than-demo - (field [deadline (current-inexact-milliseconds)] - [count 0]) - (on (asserted (later-than (deadline))) - (log-info "later-than ticked for deadline ~a" (deadline)) - (count (+ (count) 1)) - (when (< (count) 5) - (deadline (+ (deadline) 500))))) diff --git a/OLD-syndicate-examples/udp-echo.rkt b/OLD-syndicate-examples/udp-echo.rkt deleted file mode 100644 index 3c481e1..0000000 --- a/OLD-syndicate-examples/udp-echo.rkt +++ /dev/null @@ -1,13 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(require/activate syndicate/drivers/udp) - -(spawn (define s (udp-listener 5999)) - (during s - (on (message (udp-packet $c s $body)) - (printf "~a: ~v\n" c body) - (define reply (string->bytes/utf-8 (format "You said: ~a" body))) - (send! (udp-packet s c reply))))) diff --git a/OLD-syndicate-examples/udp-multicast.rkt b/OLD-syndicate-examples/udp-multicast.rkt deleted file mode 100644 index a68012a..0000000 --- a/OLD-syndicate-examples/udp-multicast.rkt +++ /dev/null @@ -1,41 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(require/activate syndicate/drivers/timer) -(require/activate syndicate/drivers/udp) -(require racket/random file/sha1) - -;; IANA offers guidelines for choosing multicast addresses [1]. -;; -;; Reasonable candidates for local experimentation include: -;; - 224.0.1.20, "any private experiment" -;; - 233.252.0.0 - 233.252.0.255, "MCAST-TEST-NET", for examples and documentation (only) -;; -;; For production and semi-production use, registering an address may -;; be an option; failing that, the Administratively Scoped Block -;; (239/8; see RFC 2365) may be used: -;; - 239.255.0.0 - 239.255.255.255, "IPv4 Local Scope" -;; - 239.192.0.0 - 239.195.255.255, "Organization Local Scope" -;; -;; [1] http://www.iana.org/assignments/multicast-addresses/ - -(define group-address "233.252.0.101") ;; falls within MCAST-TEST-NET -(define group-port 5999) ;; make sure your firewall is open to UDP on this port - -(spawn (define me (bytes->hex-string (crypto-random-bytes 8))) - (define h (udp-listener group-port)) - (during h - (assert (udp-multicast-group-member h group-address #f)) - (assert (udp-multicast-loopback h #t)) - - (field [deadline (current-inexact-milliseconds)]) - (on (asserted (later-than (deadline))) - (send! (udp-packet h - (udp-remote-address group-address group-port) - (string->bytes/utf-8 (format "~a ~a" me (deadline))))) - (deadline (+ (deadline) 1000))) - - (on (message (udp-packet $source h $body)) - (printf "~a: ~a\n" source body)))) diff --git a/OLD-syndicate-examples/web-core.rkt b/OLD-syndicate-examples/web-core.rkt deleted file mode 100644 index 483f485..0000000 --- a/OLD-syndicate-examples/web-core.rkt +++ /dev/null @@ -1,87 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(require/activate syndicate/drivers/web) -(require/activate syndicate/drivers/timer) - -(define server (http-server "localhost" 8081 #f)) - -(define (button text link) - `(form ((method "POST") (action ,link)) (button ((type "submit")) ,text))) - -(define (redirect-response id url) - (http-response #:code 303 #:message #"See other" - #:headers `((Location . ,url)) - id (xexpr->bytes/utf-8 `(html (a ((href ,url)) "continue"))))) - -(spawn - - (during (http-request $id $method $resource _ _ _) - (stop-when (asserted ($ details (http-request-peer-details id _ _ _ _))) - (log-info "~a: ~a ~v ~v" id method resource details))) - - (during/spawn (http-request $id 'get (http-resource server '("" ())) _ _ _) - (assert (http-accepted id)) - (assert (http-response id (xexpr->bytes/utf-8 - `(html - (h1 "Hello") - ,(button "Make a new counter" "/newcounter")))))) - - (during/spawn (http-request $id 'post (http-resource server '("newcounter" ())) _ _ _) - (assert (http-accepted id)) - (on-start (define counter-url (spawn-counter)) - (react (assert (redirect-response id counter-url))))) - - (during/spawn (http-request $id 'get (http-resource server '("chunked" ())) _ _ _) - (assert (http-accepted id)) - (assert (http-response id 'chunked #:mime-type #"text/plain")) - (on-start (sleep 1) - (send! (http-response-chunk id #"One\n")) - (sleep 1) - (send! (http-response-chunk id #"Two\n")) - (sleep 1) - (send! (http-response-chunk id #"Three\n")) - (stop-current-facet))) - - (during/spawn (http-request $id 'get (http-resource server '("ws-echo" ())) _ _ _) - (assert (http-accepted id)) - (assert (http-response-websocket id)) - (on (message (websocket-in id $body)) - (log-info "~a sent: ~v" id body) - (send! (websocket-out id (format "You said: ~a" body)))) - (on (message (websocket-in id "quit")) - (stop-current-facet)) - (on-start (log-info "Starting websocket connection ~a" id)) - (on-stop (log-info "Stopping websocket connection ~a" id))) - ) - -(define (spawn-counter) - (define counter-id (symbol->string (gensym 'counter))) - (define counter-url (string-append "/" counter-id)) - (begin0 counter-url - (spawn - #:name counter-id - - (field [counter 0]) - - (during (http-request $id 'get (http-resource server `(,counter-id ())) _ _ _) - (assert (http-accepted id)) - (assert - (http-response id (xexpr->bytes/utf-8 - `(html (h1 "Counter") - (p "The counter is: " ,(number->string (counter))) - ,(button "Increment" (string-append "/" counter-id "/inc")) - ,(button "Decrement" (string-append "/" counter-id "/dec")) - (p "(Return " (a ((href "/")) "home") ")")))))) - - (during (http-request $id 'post (http-resource server `(,counter-id ("inc" ()))) _ _ _) - (assert (http-accepted id)) - (on-start (counter (+ (counter) 1)) - (react (assert (redirect-response id counter-url))))) - - (during (http-request $id 'post (http-resource server `(,counter-id ("dec" ()))) _ _ _) - (assert (http-accepted id)) - (on-start (counter (- (counter) 1)) - (react (assert (redirect-response id counter-url)))))))) diff --git a/OLD-syndicate/dataspace.rkt b/OLD-syndicate/dataspace.rkt deleted file mode 100644 index c0a3901..0000000 --- a/OLD-syndicate/dataspace.rkt +++ /dev/null @@ -1,638 +0,0 @@ -#lang racket/base -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -(provide make-dataspace ;; TODO: how to cleanly provide this? - with-current-facet ;; TODO: shouldn't be provided - with-non-script-context ;; TODO: shouldn't be provided - run-scripts! ;; TODO: how to cleanly provide this? - apply-patch! ;; TODO: DEFINITELY SHOULDN'T BE PROVIDED - needed by relay.rkt - - dataspace? - dataspace-assertions ;; TODO: shouldn't be provided - needed by various tests - dataspace-routing-table ;; TODO: shouldn't be provided - needed by relay.rkt - generate-id! ;; TODO: shouldn't be provided - inline syntax.rkt?? - - actor? - actor-id - actor-name - actor-dataspace ;; TODO: should this be provided? - - facet? - facet-actor - facet-live? - - field-handle ;; TODO: shouldn't be provided - inline syntax.rkt?? - field-handle? - field-handle-name - field-handle-id - field-handle-owner - field-handle-value - - current-actor-crash-logger - - current-actor - current-facet - in-script? ;; TODO: shouldn't be provided - inline syntax.rkt?? - capture-facet-context ;; TODO: shouldn't be provided - inline syntax.rkt?? - suspend-script* ;; TODO: shouldn't be provided - inline syntax.rkt?? - - add-facet! - stop-facet! - add-stop-script! ;; TODO: shouldn't be provided - inline syntax.rkt?? - add-endpoint! - remove-endpoint! - terminate-facet! ;; TODO: shouldn't be provided - inline syntax.rkt?? - schedule-script! ;; TODO: shouldn't be provided - inline syntax.rkt?? - push-script! ;; TODO: shouldn't be provided - inline syntax.rkt?? - ensure-in-script! ;; TODO: shouldn't be provided - inline syntax.rkt?? - - spawn! ;; TODO: should this be provided? - enqueue-send! ;; TODO: should this be provided? - enqueue-deferred-turn! ;; TODO: should this be provided? - adhoc-retract! ;; TODO: should this be provided? - adhoc-assert! ;; TODO: should this be provided? - actor-adhoc-assertions ;; TODO: should this be provided? - ) - -(require syndicate/dataflow) -(require racket/match) -(require racket/set) -(require (only-in racket/exn exn->string)) - -(require "functional-queue.rkt") - -(require "skeleton.rkt") -(require "pattern.rkt") -(require "bag.rkt") -(require "reflection.rkt") - -;; An `ActorID` uniquely identifies an actor in a `Dataspace`. -;; A `FID` is a Facet ID, uniquely identifying a facet in a `Dataspace`. - -;; A `Dataspace` is a ... TODO - -;; An `Action` is one of -;; - `(patch (MutableDeltaof Assertion))` -;; - `(message Assertion)` -;; - `(spawn Any BootProc (Set Assertion))` -;; - `(quit)` -;; - `(deferred-turn (-> Any))` -(struct patch (changes) #:prefab) -(struct message (body) #:prefab) -(struct spawn (name boot-proc initial-assertions) #:prefab) -(struct quit () #:prefab) -(struct deferred-turn (continuation) #:prefab) - -(struct dataspace ([next-id #:mutable] ;; Nat - routing-table ;; Skeleton - ;; v TODO: Caches have to be bags, not sets; once - ;; this change is made, can I avoid keeping a bag - ;; of assertions in the dataspace as a whole? - assertions ;; (MutableBagof Assertion) - dataflow ;; DataflowGraph - [runnable #:mutable] ;; (Listof Actor) - [pending-actions #:mutable] ;; (Queueof ActionGroup) - ) #:transparent) - -(struct actor (id ;; ActorID - dataspace ;; Dataspace - name ;; Any - [root-facet #:mutable] ;; (Option Facet) - [runnable? #:mutable] ;; Boolean - pending-scripts ;; (MutableVectorof (Queueof (-> Any))) - [pending-actions #:mutable] ;; (Queueof Action) - [adhoc-assertions #:mutable] ;; (Bagof Assertion) - [cleanup-changes #:mutable] ;; (Deltaof Assertion) - ) - #:methods gen:custom-write - [(define (write-proc a p mode) - (fprintf p "#" (actor-id a) (actor-name a)))]) - -(struct action-group (actor ;; (U Actor 'meta) - actions ;; (Listof Action) - ) - #:transparent) - -(struct facet (id ;; FID - [live? #:mutable] ;; Boolean - actor ;; Actor - parent ;; (Option Facet) - endpoints ;; (MutableHash EID Endpoint) - [stop-scripts #:mutable] ;; (Listof Script) -- IN REVERSE ORDER - [children #:mutable] ;; (Seteqof Facet) - ) - #:methods gen:custom-write - [(define (write-proc f p mode) - (local-require (only-in racket/string string-join)) - (define (facet-id-chain f) - (if f - (cons (number->string (facet-id f)) (facet-id-chain (facet-parent f))) - '())) - (fprintf p "#" - (actor-id (facet-actor f)) - (actor-name (facet-actor f)) - (string-join (facet-id-chain f) ":")))]) - -(struct endpoint (id ;; EID - [assertion #:mutable] ;; Assertion - [handler #:mutable] ;; (Option SkInterest) - update-fn ;; (-> (Values Assertion (Option SkInterest))) - ) - #:methods gen:custom-write - [(define (write-proc e p mode) - (fprintf p "#" (endpoint-id e)))]) - -;; TODO: the field ownership checks during field-ref/field-set! might -;; be quite expensive. Are they worth it? -(struct field-handle (name ;; Symbol - id ;; Nat - owner ;; Actor - [value #:mutable] ;; Any - ) - #:methods gen:custom-write - [(define (write-proc f port mode) - (fprintf port "#" (field-handle-name f) (field-handle-id f)))] - #:property prop:procedure - (case-lambda - [(f) - (define ac (current-actor)) - (when (not (eq? (field-handle-owner f) ac)) (field-scope-error 'field-ref f)) - (dataflow-record-observation! (dataspace-dataflow (actor-dataspace ac)) f) - (field-handle-value f)] - [(f v) - (define ac (current-actor)) - (when (not (eq? (field-handle-owner f) (current-actor))) (field-scope-error 'field-set! f)) - (when (not (equal? (field-handle-value f) v)) - (dataflow-record-damage! (dataspace-dataflow (actor-dataspace ac)) f) - (set-field-handle-value! f v))])) - -(define (field-scope-error who f) - (error who "Field ~a used out-of-scope; owner = ~a, current = ~a" - f - (field-handle-owner f) - (current-actor))) - -;; Parameterof (Actor Exn -> Void) -(define current-actor-crash-logger - (make-parameter - (lambda (a e) - (log-error "Actor ~a died with exception:\n~a" a (exn->string e))))) - -(define (current-actor) (facet-actor (current-facet))) - -;; Parameterof Facet -(define current-facet (make-parameter #f)) - -;; Parameterof Boolean -(define in-script? (make-parameter #t)) - -;;--------------------------------------------------------------------------- - -;; Script priorities. These are used to ensure that the results of -;; some *side effects* are visible to certain pieces of code. - -(module priorities racket/base - (require (for-syntax racket/base)) - - (define-syntax (define-priority-levels stx) - (let loop ((counter 0) (stx (syntax-case stx () - [(_ level ...) #'(level ...)]))) - (syntax-case stx () - [() - #'(void)] - [(#:count c) - #`(begin (define c #,counter) - (provide c))] - [(this-level more ...) - #`(begin (define this-level #,counter) - (provide this-level) - #,(loop (+ counter 1) #'(more ...)))]))) - - (define-priority-levels ;; highest-priority to lowest-priority - *query-priority-high* - *query-priority* - *query-handler-priority* - *normal-priority* - *gc-priority* - *idle-priority* - #:count priority-count)) - -(require (submod "." priorities)) - -;;--------------------------------------------------------------------------- - -(define (make-dataspace boot-proc) - (dataspace 0 - (make-empty-skeleton) - (make-bag) - (make-dataflow-graph) - '() - (enqueue (make-queue) (action-group 'meta (list (spawn #f boot-proc (set))))))) - -(define (generate-id! ds) - (let ((id (dataspace-next-id ds))) - (set-dataspace-next-id! ds (+ id 1)) - id)) - -(define (add-actor! ds name boot-proc initial-assertions) - (define the-actor-id (generate-id! ds)) - (define filtered-initial-assertions (set-remove initial-assertions (void))) - (define initial-delta (set->bag filtered-initial-assertions +1)) - (define the-actor (actor the-actor-id - ds - name - #f - #f - (make-vector priority-count (make-queue)) - (make-queue) - initial-delta - (bag))) - (apply-patch! ds the-actor initial-delta) - ;; Root facet is a dummy "system" facet that exists to hold one-or-more "user" "root" facets. - (add-facet! #f - the-actor - #f - (lambda () - ;; The "true root", user-visible facet. - (add-facet! #f - the-actor - (current-facet) - (lambda () - (boot-proc))) - (for [(a filtered-initial-assertions)] - (adhoc-retract! the-actor a))))) - -(define-syntax-rule (with-current-facet [f0] body ...) - (let ((f f0)) - ;; (when (not f) - ;; (error 'with-current-facet "Cannot use with-current-facet this way")) - (parameterize ((current-facet f)) - (with-handlers ([(lambda (e) (not (exn:break? e))) - (lambda (e) - (define a (current-actor)) - ((current-actor-crash-logger) a e) - (abandon-queued-work! a) - ;; v Supply #f for `emit-patches?` here - ;; because we are in an uncertain limbo after - ;; discarding previously-queued actions. - ;; Instead of emitting patches to orderly - ;; tear down assertions from endpoints, we - ;; rely on the recorded `cleanup-changes`. - (terminate-actor! a #f e))]) ;; TODO: tracing - (call-with-syndicate-prompt - (lambda () - body ...)) - (void))))) - -(define-syntax-rule (with-non-script-context body ...) - (parameterize ((in-script? #f)) - body ...)) - -(define (capture-facet-context proc) - (let ((f (current-facet))) - ;; (when (not f) - ;; (error 'capture-facet-context "Cannot capture non-facet")) - (lambda args - (with-current-facet [f] - (apply proc args))))) - -(define (pop-next-script! ac) - (define priority-levels (actor-pending-scripts ac)) - (let loop ((level 0)) - (and (< level (vector-length priority-levels)) - (let ((q (vector-ref priority-levels level))) - (if (queue-empty? q) - (loop (+ level 1)) - (let-values (((script q) (dequeue q))) - (vector-set! priority-levels level q) - script)))))) - -(define (run-actor-pending-scripts! ds ac) - (let loop () - (let ((script (pop-next-script! ac))) - (and script - (begin (script) - (refresh-facet-assertions! ds) - (loop)))))) - -(define (refresh-facet-assertions! ds) - (with-non-script-context - (dataflow-repair-damage! (dataspace-dataflow ds) - (lambda (subject-id) - (match-define (list f eid) subject-id) - (when (facet-live? f) ;; TODO: necessary test, or tautological? - (define ac (facet-actor f)) - (with-current-facet [f] - (define ep (hash-ref (facet-endpoints f) eid)) - (match-define (endpoint _ old-assertion old-handler update-fn) ep) - (define-values (new-assertion new-handler) (update-fn)) - (when (not (equal? old-assertion new-assertion)) - (retract! ac old-assertion) - (when old-handler (dataspace-unsubscribe! ds old-handler)) - (set-endpoint-assertion! ep new-assertion) - (set-endpoint-handler! ep new-handler) - (assert! ac new-assertion) - (when new-handler (dataspace-subscribe! ds new-handler))))))))) - -(define (commit-actions! ds ac) - (define pending (queue->list (actor-pending-actions ac))) - ;; (log-info "commit-actions!: ~a actions ~a" ac pending) - (when (pair? pending) - (set-actor-pending-actions! ac (make-queue)) - (set-dataspace-pending-actions! ds (enqueue (dataspace-pending-actions ds) - (action-group ac pending))))) - -(define (run-all-pending-scripts! ds) - (define runnable (dataspace-runnable ds)) - (set-dataspace-runnable! ds '()) - (for [(ac (in-list runnable))] - (run-actor-pending-scripts! ds ac) - (set-actor-runnable?! ac #f) - (commit-actions! ds ac))) - -(define (perform-pending-actions! ds) - (define groups (queue->list (dataspace-pending-actions ds))) - (set-dataspace-pending-actions! ds (make-queue)) - (for [(group (in-list groups))] - (match-define (action-group ac actions) group) - (for [(action (in-list actions))] - ;; (log-info "~a in ~a performing ~a" ac (eq-hash-code ds) action) - (match action - [(patch delta) - (apply-patch! ds ac delta)] - [(message body) - (send-assertion! (dataspace-routing-table ds) body)] - [(spawn name boot-proc initial-assertions) - (add-actor! ds name boot-proc initial-assertions)] - [(quit) - (apply-patch! ds ac (actor-cleanup-changes ac))] - [(deferred-turn k) - (push-script! ac k)]) - (run-all-pending-scripts! ds)))) - -(define (apply-patch! ds ac delta) - (when (not (bag-empty? delta)) - (define ds-assertions (dataspace-assertions ds)) - ;; (log-info "apply-patch! ~a ~v" ac delta) - ;; (for [((a c) (in-bag/count ds-assertions))] (log-info " . ~v = ~v" a c)) - ;; (for [((a c) (in-bag/count delta))] (log-info " → ~v = ~v" a c)) - (define rt (dataspace-routing-table ds)) - (define pending-removals '()) - (define new-cleanup-changes - (for/fold [(cleanup-changes (actor-cleanup-changes ac))] [((a count) (in-bag/count delta))] - (match (bag-change! ds-assertions a count) - ['present->absent (set! pending-removals (cons a pending-removals))] - ['absent->present (add-assertion! rt a)] - ;; 'absent->absent absurd - ['present->present (void)]) ;; i.e. no visible change - (define-values (updated-bag _summary) (bag-change cleanup-changes a (- count))) - updated-bag)) - (for [(a (in-list pending-removals))] - (remove-assertion! rt a)) - (set-actor-cleanup-changes! ac new-cleanup-changes))) - -(define (run-scripts! ds) - (run-all-pending-scripts! ds) - (perform-pending-actions! ds) - ;; TODO: figure out when a dataspace should quit itself. Given the - ;; mutable nature of the implementation, maybe never? It might be - ;; being held elsewhere! - (not (and (null? (dataspace-runnable ds)) - (queue-empty? (dataspace-pending-actions ds))))) - -(define (add-facet! where actor parent boot-proc) - (when (and (not (in-script?)) where) - (error 'add-facet! - "~a: Cannot add facet outside script; are you missing an (on ...)?" - where)) - (define f (facet (generate-id! (actor-dataspace actor)) - #t - actor - parent - (make-hash) - '() - (seteq))) - (if parent - (set-facet-children! parent (set-add (facet-children parent) f)) - (begin - (when (actor-root-facet actor) - ;; This should never happen. We deliberately create an - ;; otherwise-dummy root facet for each actor specifically to - ;; hold user facets, and there should be no way for the user - ;; to stop that root facet explicitly, which means user code - ;; can't start any replacements for it at all, let alone - ;; more than one! - (error 'add-facet! "INTERNAL ERROR: Attempt to add second root facet")) - (set-actor-root-facet! actor f))) - (with-current-facet [f] - (with-non-script-context - (boot-proc))) - (push-script! actor (lambda () - (when (or (and parent (not (facet-live? parent))) (facet-inert? f)) - (terminate-facet! f))))) - -(define (facet-inert? f) - (and (hash-empty? (facet-endpoints f)) - (set-empty? (facet-children f)))) - -(define (schedule-script! #:priority [priority *normal-priority*] ac thunk) - (push-script! #:priority priority ac (capture-facet-context thunk))) - -(define (push-script! #:priority [priority *normal-priority*] ac thunk-with-context) - (when (not (actor-runnable? ac)) - (set-actor-runnable?! ac #t) - (let ((ds (actor-dataspace ac))) - (set-dataspace-runnable! ds (cons ac (dataspace-runnable ds))))) - (define v (actor-pending-scripts ac)) - (vector-set! v priority (enqueue (vector-ref v priority) thunk-with-context))) - -(define (retract-facet-assertions-and-subscriptions! f emit-patches?) - (define ac (facet-actor f)) - (define ds (actor-dataspace ac)) - (push-script! ac (lambda () - (for [((eid ep) (in-hash (facet-endpoints f)))] - (destroy-endpoint! ds ac f ep emit-patches?)) - (hash-clear! (facet-endpoints f))))) - -(define (abandon-queued-work! ac) - (set-actor-pending-actions! ac (make-queue)) - (let ((scripts (actor-pending-scripts ac))) - (for [(i (in-range (vector-length scripts)))] - (vector-set! scripts i (make-queue))))) - -;; Abruptly terminates an entire actor, without running stop-scripts etc. -(define (terminate-actor! the-actor emit-patches? maybe-exn) - (when emit-patches? - (push-script! the-actor (lambda () (for [(a (in-bag (actor-adhoc-assertions the-actor)))] - (retract! the-actor a))))) - (let ((f (actor-root-facet the-actor))) - (when f - (let abort-facet! ((f f)) - (set-facet-live?! f #f) - (for [(child (in-set (facet-children f)))] (abort-facet! child)) - (retract-facet-assertions-and-subscriptions! f emit-patches?)))) - (push-script! the-actor (lambda () - (let ((name (actor-name the-actor))) - (when name - (enqueue-send! the-actor (terminated name maybe-exn)))) - (enqueue-action! the-actor (quit))))) - -;; Cleanly terminates a facet and its children, running stop-scripts etc. -(define (terminate-facet! f) - (when (facet-live? f) - (define ac (facet-actor f)) - (define parent (facet-parent f)) - (if parent - (set-facet-children! parent (set-remove (facet-children parent) f)) - (set-actor-root-facet! ac #f)) - - (set-facet-live?! f #f) - - (for [(child (in-set (facet-children f)))] (terminate-facet! child)) - - ;; Run stop-scripts after terminating children. This means that - ;; children's stop-scripts run before ours. - (push-script! ac (lambda () - (with-current-facet [f] - (for [(script (in-list (reverse (facet-stop-scripts f))))] - (script))))) - - (retract-facet-assertions-and-subscriptions! f #t) - - (push-script! #:priority *gc-priority* ac - (lambda () - (if parent - (when (facet-inert? parent) (terminate-facet! parent)) - (terminate-actor! ac #t #f)))))) - -(define (stop-facet! f stop-script) - (define ac (facet-actor f)) - (with-current-facet [(facet-parent f)] ;; run in parent context wrt terminating facet - (schedule-script! ac (lambda () - (terminate-facet! f) - (schedule-script! ac stop-script))))) - -(define (add-stop-script! f script-proc) - (set-facet-stop-scripts! f (cons script-proc (facet-stop-scripts f)))) - -(define (add-endpoint! f where dynamic? update-fn) - (when (in-script?) - (error 'add-endpoint! - "~a: Cannot add endpoint in script; are you missing a (react ...)?" - where)) - (define ds (actor-dataspace (facet-actor f))) - (define eid (generate-id! ds)) - (define-values (assertion handler) - (parameterize ((current-dataflow-subject-id (if dynamic? (list f eid) #f))) - (call-with-syndicate-prompt update-fn))) - (define ep (endpoint eid assertion handler update-fn)) - (assert! (facet-actor f) assertion) - (when handler (dataspace-subscribe! ds handler)) - (hash-set! (facet-endpoints f) eid ep) - eid) - -(define (remove-endpoint! f eid) - (define eps (facet-endpoints f)) - (define ep (hash-ref eps eid #f)) - (when ep - (define ac (facet-actor f)) - (define ds (actor-dataspace ac)) - (destroy-endpoint! ds ac f ep #t) - (hash-remove! eps eid))) - -(define (destroy-endpoint! ds ac f ep emit-patches?) - (match-define (endpoint eid assertion handler _update-fn) ep) - (dataflow-forget-subject! (dataspace-dataflow ds) (list f eid)) - (when emit-patches? (retract! ac assertion)) - (when handler (dataspace-unsubscribe! ds handler))) - -(define (enqueue-action! ac action) - (set-actor-pending-actions! ac (enqueue (actor-pending-actions ac) action))) - -(define (ensure-patch-action! ac) - (let ((q (actor-pending-actions ac))) - (when (or (queue-empty? q) (not (patch? (queue-last q)))) - (enqueue-action! ac (patch (make-bag))))) - (patch-changes (queue-last (actor-pending-actions ac)))) - -(define (retract! ac assertion) - (when (not (void? assertion)) - (bag-change! (ensure-patch-action! ac) assertion -1))) - -(define (assert! ac assertion) - (when (not (void? assertion)) - (bag-change! (ensure-patch-action! ac) assertion +1))) - -(define (adhoc-retract! ac assertion [count 1]) - (when (not (void? assertion)) - (define-values (new-assertions summary) - (bag-change (actor-adhoc-assertions ac) assertion (- count) #:clamp? #t)) - (set-actor-adhoc-assertions! ac new-assertions) - (match summary - ;; 'absent->present absurd (if the call to `adhoc-retract!` - ;; matches a previous `adhoc-assert!`) - ['present->absent (retract! ac assertion)] - ['present->present (void)] - ['absent->absent (void)]))) ;; can happen if we're exploiting the clamping - -(define (adhoc-assert! ac assertion [count 1]) - (when (not (void? assertion)) - (define-values (new-assertions summary) - (bag-change (actor-adhoc-assertions ac) assertion count)) - (set-actor-adhoc-assertions! ac new-assertions) - (match summary - ;; 'absent->absent and 'present->absent absurd (assuming there - ;; haven't been too many calls to `adhoc-retract!` in the past) - ['absent->present (assert! ac assertion)] - ['present->present (void)]))) - -(define (dataspace-unsubscribe! ds h) - (remove-interest! (dataspace-routing-table ds) h)) - -(define (dataspace-subscribe! ds h) - (add-interest! (dataspace-routing-table ds) h)) - -(define (ensure-in-script! who) - (when (not (in-script?)) - (error who "Attempt to perform action outside script; are you missing an (on ...)?"))) - -(define (enqueue-send! ac body) - (enqueue-action! ac (message body))) - -(define (enqueue-deferred-turn! ac k) - (enqueue-action! ac (deferred-turn (capture-facet-context k)))) - -(define (spawn! ac name boot-proc initial-assertions) - (enqueue-action! ac (spawn name boot-proc initial-assertions))) - -;;--------------------------------------------------------------------------- -;; Script suspend-and-resume. - -(define prompt-tag (make-continuation-prompt-tag 'syndicate)) - -(define (call-with-syndicate-prompt thunk) - (call-with-continuation-prompt thunk prompt-tag)) - -(define (suspend-script* where proc) - (when (not (in-script?)) - (error 'suspend-script - "~a: Cannot suspend script outside script; are you missing an (on ...)?" - where)) - (call-with-composable-continuation - (lambda (k) - (abort-current-continuation - prompt-tag - (lambda () - (define in? (in-script?)) - (define raw-resume-parent - (capture-facet-context - (lambda results - (parameterize ((in-script? in?)) - (apply k results))))) - (define resume-parent - (lambda results - (push-script! (current-actor) - (lambda () (apply raw-resume-parent results))))) - (proc resume-parent)))) - prompt-tag)) diff --git a/OLD-syndicate/distributed.rkt b/OLD-syndicate/distributed.rkt deleted file mode 100644 index 25d6cf9..0000000 --- a/OLD-syndicate/distributed.rkt +++ /dev/null @@ -1,8 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(provide (all-from-out "distributed/main.rkt")) -(require/activate "distributed/main.rkt") -(module+ main (require (submod "distributed/main.rkt" main))) diff --git a/OLD-syndicate/distributed/buffer.rkt b/OLD-syndicate/distributed/buffer.rkt deleted file mode 100644 index 7975079..0000000 --- a/OLD-syndicate/distributed/buffer.rkt +++ /dev/null @@ -1,17 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(provide make-buffer) - -(define (make-buffer) - (field [pending '()]) - (define (push item) - (pending (cons item (pending)))) - (define (drain handler) - (begin/dataflow - (when (pair? (pending)) - (for [(item (in-list (reverse (pending))))] (handler item)) - (pending '())))) - (values push drain)) diff --git a/OLD-syndicate/distributed/client.rkt b/OLD-syndicate/distributed/client.rkt deleted file mode 100644 index c13768c..0000000 --- a/OLD-syndicate/distributed/client.rkt +++ /dev/null @@ -1,113 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(provide generic-client-session-facet) - -(require "wire-protocol.rkt") -(require "internal-protocol.rkt") -(require "protocol.rkt") -(require "turn.rkt") -(require syndicate/term) - -(require/activate "heartbeat.rkt") - -(define-logger syndicate/distributed) - -(spawn #:name 'client-factory - (during (to-server $a _) (assert (server-connection a))) - (during (observe (from-server $a _)) (assert (server-connection a))) - (during (observe (server-connected $a)) (assert (server-connection a)))) - -(struct sub (spec [captures #:mutable]) #:transparent) - -(define (generic-client-session-facet address scope w) - (on-start (log-syndicate/distributed-info "Connected to ~v" address)) - (on-stop (log-syndicate/distributed-info "Disconnected from ~v" address)) - (assert (server-connected address)) - (assert (server-session-connected address)) - - (when (log-level? syndicate/distributed-logger 'debug) - (set! w (let ((w* w)) - (lambda (p) - (log-syndicate/distributed-debug "C OUT ~v ~v" address p) - (w* p))))) - - (define turn (turn-recorder (lambda (items) (w (Turn items))))) - - (define next-ep - (let ((counter 0)) - (lambda () - (begin0 counter - (set! counter (+ counter 1)))))) - - (define pubs (hash)) - (define subs (hash)) - (define matches (hash)) - - (on-start (w (Connect scope))) - (on-stop (for* [(s (in-hash-values matches)) (a (in-hash-values (sub-captures s)))] (retract! a))) - - (define (instantiate s vs) - (instantiate-term->value (from-server address (sub-spec s)) vs)) - - (on (asserted (to-server address $a)) - (define ep (next-ep)) - (extend-turn! turn (Assert ep a)) - (set! pubs (hash-set pubs a ep))) - - (on (retracted (to-server address $a)) - (define ep (hash-ref pubs a)) - (extend-turn! turn (Clear ep)) - (set! pubs (hash-remove pubs a))) - - (on (message (to-server address $a)) - (extend-turn! turn (Message a))) - - (on (asserted (observe (from-server address $spec))) - (define ep (next-ep)) - (extend-turn! turn (Assert ep (observe spec))) - (set! subs (hash-set subs spec ep)) - (set! matches (hash-set matches ep (sub spec (hash))))) - - (on (retracted (observe (from-server address $spec))) - (extend-turn! turn (Clear (hash-ref subs spec))) - (set! subs (hash-remove subs spec))) - - (define reset-heartbeat! (heartbeat (list 'client address scope) - w - (lambda () (stop-current-facet)))) - - (on (message (server-packet address _)) - (reset-heartbeat!)) - - (on (message (server-packet address (Ping))) - (w (Pong))) - - (on (message (server-packet address (Err $detail $context))) - (log-syndicate/distributed-error "Error from ~a: ~v~a" - address - detail - (if context - (format " ~v" context) - "")) - (stop-current-facet)) - - (on (message (server-packet address (Turn $items))) - (for [(item (in-list items))] - (match item - [(Add ep vs) (let* ((s (hash-ref matches ep)) - (a (instantiate s vs))) - (set-sub-captures! s (hash-set (sub-captures s) vs a)) - (assert! a))] - [(Del ep vs) (let* ((s (hash-ref matches ep)) - (a (hash-ref (sub-captures s) vs))) - (retract! a) - (set-sub-captures! s (hash-remove (sub-captures s) vs)))] - [(Msg ep vs) (let* ((s (hash-ref matches ep))) - (send! (instantiate s vs)))] - [(End ep) (let* ((s (hash-ref matches ep #f))) - (when s - (for [(a (in-hash-values (sub-captures s)))] (retract! a)) - (set! matches (hash-remove matches ep))))])))) diff --git a/OLD-syndicate/distributed/client/loopback.rkt b/OLD-syndicate/distributed/client/loopback.rkt deleted file mode 100644 index 303e3cd..0000000 --- a/OLD-syndicate/distributed/client/loopback.rkt +++ /dev/null @@ -1,25 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(require "../client.rkt") -(require "../wire-protocol.rkt") -(require "../internal-protocol.rkt") -(require "../protocol.rkt") - -(require syndicate/protocol/credit) - -(require/activate syndicate/distributed/server) - -(spawn #:name 'loopback-client-factory - (during/spawn (server-connection ($ address (server-loopback-connection $scope))) - #:name address - (assert (server-poa address)) - (on (message (message-server->poa address $p)) (send! (server-packet address p))) - (on-start (react - (stop-when (asserted (observe (message-poa->server address _))) - (react (generic-client-session-facet - address - scope - (lambda (x) (send! (message-poa->server address x)))))))))) diff --git a/OLD-syndicate/distributed/client/tcp.rkt b/OLD-syndicate/distributed/client/tcp.rkt deleted file mode 100644 index c82e72b..0000000 --- a/OLD-syndicate/distributed/client/tcp.rkt +++ /dev/null @@ -1,47 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(require "../client.rkt") -(require "../wire-protocol.rkt") -(require "../internal-protocol.rkt") -(require "../protocol.rkt") -(require syndicate/reassert) - -(require/activate syndicate/drivers/tcp) - -(spawn #:name 'tcp-client-factory - (during/spawn (server-connection ($ address (server-tcp-connection $host $port $scope))) - #:name address - (define id (list (gensym 'client) host port)) - - (reassert-on (tcp-connection id (tcp-address host port)) - (retracted (tcp-accepted id)) - (asserted (tcp-rejected id _)) - (retracted (server-transport-connected address)) - (retracted (server-session-connected address))) - - (during (tcp-accepted id) - (on-start (issue-unbounded-credit! tcp-in id)) - (assert (server-transport-connected address)) - (define accumulate! (packet-accumulator (lambda (p) (send! (server-packet address p))))) - (on (message (tcp-in id $bs)) (accumulate! bs))) - - (during (server-transport-connected address) - ;; If we run generic-client-session-facet in the `tcp-accepted` handler above, then - ;; unfortunately disconnection of the TCP socket on error overtakes the error report - ;; itself, terminating the generic-client-session-facet before it has a chance to - ;; handle the error report. - ;; - ;; Could timing errors like that be something a type system could help us with? The - ;; conversation in `server-packet`s is sort-of "nested" inside the conversation in - ;; `tcp-in`s; a single facet reacting to both conversations (in this instance, to - ;; `server-packets` in an implicit frame, but explicitly to the frame of the - ;; `tcp-in`s, namely `tcp-accepted`) is probably an error. Or rather, any situation - ;; where pending "inner conversation" business could be obliterated by discarding a - ;; facet based on "outer conversation" framing is probably an error. - ;; - (generic-client-session-facet address - scope - (lambda (x) (send! (tcp-out id (encode x)))))))) diff --git a/OLD-syndicate/distributed/federation.rkt b/OLD-syndicate/distributed/federation.rkt deleted file mode 100644 index 35de57a..0000000 --- a/OLD-syndicate/distributed/federation.rkt +++ /dev/null @@ -1,471 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate -;; Relays for federation, both "client" (outbound) and "server" (inbound) ends. - -(require "wire-protocol.rkt") -(require "internal-protocol.rkt") -(require "protocol.rkt") -(require "buffer.rkt") -(require "turn.rkt") - -(require syndicate/term) -(require syndicate/reassert) -(require racket/set) - -(require/activate syndicate/drivers/tcp) - -(define-logger syndicate/federation) - -;; A federated scope (as distinct from a non-federated server scope) -;; communicates via "links" to "peers", which come in three flavours: -;; - inbound links, aka "downlinks" from the POV of this node, which -;; result from incoming TCP/websocket/etc connections -;; - outbound links, aka "uplinks", which reach out to a remote TCP/ -;; websocket/etc server -;; - local links, (usually? always?) just one per scope, which -;; connect the federated scope to its local server scope -;; -;; All links are identified by a link ID, scoped the same as -;; connection IDs in (namely, dataspace-unique). Links -;; are stateful. -;; -;; The link protocol is enacted in special non-federated, local -;; federation-management server scopes, identified by -;; `federation-management-scope` assertions. The code in this module -;; responds to assertions and messages in these scopes. Besides its -;; scoped nature, the protocol is otherwise ordinary. By reusing -;; Syndicate itself for management and operation of federation, we are -;; able to address transport independently of federation. -;; -;; Inbound links are set up by code outside this module in response to -;; the appearance of some new federated peer "downstream" of this one. -;; For example, after establishing a new client-server connection to a -;; federation-management scope, a remote peer may begin using the link -;; protocol. -;; -;; Outbound links are created in response to an assertion of a -;; `federated-uplink` record in a federation-management scope. Each -;; such record contains a triple of a local scope ID, a client -;; transport address (such as `server-tcp-connection` from -;; ), and a remote scope ID. Together, these federate -;; the local and remote scope IDs via a client-server connection to -;; the given address. -;; -;; Local links are a special case of inbound link. They are created -;; automatically whenever there is an active server scope of the same -;; name as a federated scope. -;; -;; Local federation-management scopes must not be federated. -;; TODO: Enforce this? - -;; Subscription IDs (== "endpoint IDs") must be connection-unique AND -;; must correspond one-to-one with a specific subscription spec. That -;; is, a subscription ID is merely connection-local shorthand for its -;; spec, and two subscription IDs within a connection must be `equal?` -;; exactly when their corresponding specs are `equal?`. -;; -;; Local IDs must be scope-unique. They are used as subscription IDs -;; in outbound messages. -;; -;; Each federated scope maintains a bidirectional mapping between -;; subscription IDs (each scoped within its connection ID) and local -;; IDs. One local ID may map to multiple subscription IDs - this is -;; the place where aggregation pops up. - -;; Unlike the client/server protocol, both Actions and Events are -;; BIDIRECTIONAL, travelling in both directions along edges linking -;; peer nodes. - -;;--------------------------------------------------------------------------- -;; Outbound links. (Really, they end up being a kind of "inbound link" -;; too! Ultimately we have just *links*, connected to arbitrary -;; things. For traditional "inbound", it's some remote party that has -;; connected to us; for "local", it's a local server scope; for -;; "outbound", it's a connection to another server that we reached out -;; to.) - -(spawn #:name 'federated-uplink-factory - (during (federation-management-scope $management-scope) - (during/spawn (server-envelope management-scope - ($ link (federated-uplink $local-scope - $peer-addr - $remote-scope))) - #:name link - (during (server-connected peer-addr) - - (assert (server-proposal management-scope (federated-uplink-connected link))) - ;; ^ out to local requester - - (define session-id (strong-gensym 'peer-)) - (assert (server-proposal management-scope (federated-link session-id local-scope))) - (assert (to-server peer-addr (federated-link session-id remote-scope))) - - ;; We have to buffer in both directions, because at startup there's latency - ;; between asserting a federated-link record and it being ready to receive - ;; message-poa->server records. - (define-values (push-in drain-in) (make-buffer)) - (define-values (push-out drain-out) (make-buffer)) - - (on (message (from-server peer-addr (message-server->poa session-id $p))) - (push-in p)) - (on (message (server-envelope management-scope (message-server->poa session-id $p))) - (push-out p)) - - (define (wrap p) (message-poa->server session-id p)) - (during (server-envelope management-scope (federated-link-ready session-id)) - (during (from-server peer-addr (federated-link-ready session-id)) - (drain-in (lambda (p) (send! (server-proposal management-scope (wrap p))))) - (drain-out (lambda (p) (send! (to-server peer-addr (wrap p))))))))))) - -;;--------------------------------------------------------------------------- -;; Local links. - -(spawn #:name 'federated-local-link-factory - - (struct sub (spec [captures #:mutable]) #:transparent) - - (during (federation-management-scope $management-scope) - (during (server-envelope management-scope (federated-link _ $scope)) - (during/spawn (server-active scope) - #:name (list 'local-link management-scope scope) - - (define session-id (gensym 'local-link)) - (assert (server-proposal management-scope (federated-link session-id scope))) - - (define (!! m) - (send! (server-proposal management-scope (message-poa->server session-id m)))) - - (define turn (turn-recorder (lambda (items) (!! (Turn items))))) - - (define remote-endpoints (hash)) - (define local-endpoints (hash)) - (define local-matches (hash)) - - (define (instantiate s vs) - (instantiate-term->value (server-envelope scope (sub-spec s)) vs)) - - (on (asserted (observe (server-envelope scope $spec))) - (define ep (gensym 'ep)) - (extend-turn! turn (Assert ep (observe spec))) - (set! local-endpoints (hash-set local-endpoints spec ep)) - (set! local-matches (hash-set local-matches ep (sub spec (hash))))) - - (on (retracted (observe (server-envelope scope $spec))) - (define ep (hash-ref local-endpoints spec)) - (extend-turn! turn (Clear ep)) - (set! local-endpoints (hash-remove local-endpoints spec))) - - (on (message (server-envelope management-scope - (message-server->poa session-id (Turn $items)))) - (for [(item (in-list items))] - (match item - [(Assert subid (observe spec)) - (when (hash-has-key? remote-endpoints subid) - (error 'local-link "Duplicate endpoint" subid)) - (react - (define ep-facet (current-facet)) - (set! remote-endpoints (hash-set remote-endpoints subid ep-facet)) - (on-stop (set! remote-endpoints (hash-remove remote-endpoints subid))) - (assert (server-envelope scope (observe spec))) - (define ((! ctor) cs) (extend-turn! turn (ctor subid cs))) - (add-observer-endpoint! (lambda () (server-proposal scope spec)) - #:on-add (! Add) - #:on-remove (! Del) - #:on-message (! Msg)))] - [(Clear subid) - (stop-facet (hash-ref remote-endpoints subid) - (extend-turn! turn (End subid)))] - [(Add ep vs) (let* ((s (hash-ref local-matches ep)) - (a (instantiate s vs))) - (set-sub-captures! s (hash-set (sub-captures s) vs a)) - (assert! a))] - [(Del ep vs) (let* ((s (hash-ref local-matches ep)) - (a (hash-ref (sub-captures s) vs))) - (retract! a) - (set-sub-captures! s (hash-remove (sub-captures s) vs)))] - [(Msg ep vs) (let* ((s (hash-ref local-matches ep))) - (send! (instantiate s vs)))] - [(End ep) (let* ((s (hash-ref local-matches ep #f))) - (when s - (for [(a (in-hash-values (sub-captures s)))] (retract! a)) - (set! local-matches (hash-remove local-matches ep))))]))))))) - -;;--------------------------------------------------------------------------- -;; Federated scopes. - -(spawn #:name 'federated-scope-factory - - (struct subscription (id ;; LocalID - spec ;; Assertion - holders ;; (Hash LinkID SubscriptionID) - matches ;; (Hash (Listof Assertion) (Set LinkID)) - ) - #:transparent) - - (during (federation-management-scope $management-scope) - (during/spawn (server-envelope management-scope (federated-link _ $scope)) - #:name (list 'federated-scope management-scope scope) - - ;; Generates a fresh local ID naming a subscription propagated to our peers. - (define make-localid (let ((next 0)) (lambda () (begin0 next (set! next (+ next 1)))))) - - (field [turns (hash)] ;; (Map LinkID Turn) - [specs (hash)] ;; (Hash Spec LocalID) - [subs (hasheq)] ;; (Hash LocalID Subscription) - ) - - (define (send-to-link! peer p) - (extend-turn! (hash-ref (turns) peer) p)) - - (when (log-level? syndicate/federation-logger 'debug) - (begin/dataflow - (log-syndicate/federation-debug "~a turns:" scope) - (for [((peer turn) (in-hash (turns)))] - (log-syndicate/federation-debug " link ~v -> ~v" peer (turn 'debug))) - (log-syndicate/federation-debug "-")) - (begin/dataflow - (log-syndicate/federation-debug "~a specs:" scope) - (for [((spec local) (in-hash (specs)))] - (log-syndicate/federation-debug " spec ~v -> local ~a" spec local)) - (log-syndicate/federation-debug "-")) - (begin/dataflow - (log-syndicate/federation-debug "~a subs:" scope) - (for [((local sub) (in-hash (subs)))] - (match-define (subscription _id spec holders matches) sub) - (log-syndicate/federation-debug " local ~a -> sub spec ~v" local spec) - (when (not (hash-empty? holders)) - (log-syndicate/federation-debug " holders:") - (for [((link ep) (in-hash holders))] - (log-syndicate/federation-debug " link ~a -> ep ~a" link ep))) - (when (not (hash-empty? matches)) - (log-syndicate/federation-debug " matches:") - (for [((captures holders) (in-hash matches))] - (log-syndicate/federation-debug " captures ~v held by ~a" - captures holders)))) - (log-syndicate/federation-debug "-"))) - - (define (call-with-sub localid linkid f #:not-found-ok? [not-found-ok? #t]) - (match (hash-ref (subs) localid #f) - [#f (when (not not-found-ok?) - (log-syndicate/federation-error - "Mention of nonexistent local ID ~v from link ~v. Ignoring." - localid linkid))] - [sub (f sub)])) - - (define (store-sub! sub) - (match-define (subscription localid spec holders matches) sub) - (if (and (hash-empty? holders) (hash-empty? matches)) - (begin (specs (hash-remove (specs) spec)) - (subs (hash-remove (subs) localid))) - (subs (hash-set (subs) localid sub)))) - - (define (unsubscribe! localid linkid) - (call-with-sub - #:not-found-ok? #f - localid linkid - (lambda (sub) - (define new-holders (hash-remove (subscription-holders sub) linkid)) - (store-sub! (struct-copy subscription sub [holders new-holders])) - - ;; The messages we send depend on (hash-count new-holders): - ;; - if >1, there are enough other active subscribers that we don't need to send - ;; any messages. - ;; - if =1, we retract the subscription from that peer (INVARIANT: will not be linkid) - ;; - if =0, we retract the subscription from all peers except linkid - - (match (hash-count new-holders) - [0 (for [((peer turn) (in-hash (turns)))] - (when (not (equal? peer linkid)) - (extend-turn! turn (Clear localid))))] - [1 (for [(peer (in-hash-keys new-holders))] ;; there will only be one, ≠ linkid - (send-to-link! peer (Clear localid)))] - [_ (void)])))) - - (define (remove-match! localid captures linkid) - (call-with-sub - localid linkid - (lambda (sub) - (define old-matches (subscription-matches sub)) - (define old-match-holders (hash-ref old-matches captures set)) - (define new-match-holders (set-remove old-match-holders linkid)) - (define new-matches (if (set-empty? new-match-holders) - (hash-remove old-matches captures) - (hash-set old-matches captures new-match-holders))) - (store-sub! (struct-copy subscription sub [matches new-matches])) - (match (set-count new-match-holders) - [0 (for [((peer peer-subid) (in-hash (subscription-holders sub)))] - (when (not (equal? peer linkid)) - (send-to-link! peer (Del peer-subid captures))))] - [1 (for [(peer (in-set new-match-holders))] ;; only one, ≠ linkid - (define maybe-peer-subid (hash-ref (subscription-holders sub) peer #f)) - (when maybe-peer-subid - (send-to-link! peer (Del maybe-peer-subid captures))))] - [_ (void)])))) - - (during (server-envelope management-scope (federated-link $linkid scope)) - (assert (server-proposal management-scope (federated-link-ready linkid))) - - (define turn (turn-recorder - (lambda (items) - (send! (server-proposal management-scope - (message-server->poa linkid (Turn items))))))) - - (field [link-subs (hash)] ;; (Hash SubscriptionID LocalID) - [link-matches (hash)] ;; (Hash LocalID (Set (Listof Assertion))) - ) - - (define (err! detail [context #f]) - (send! (server-proposal management-scope (message-server->poa linkid - (Err detail context)))) - (reset-turn! turn) - (stop-current-facet)) - - (on-start (log-syndicate/federation-debug "+PEER ~a link ~a" scope linkid) - (turns (hash-set (turns) linkid turn)) - (for ([(spec localid) (in-hash (specs))]) - (when (not (hash-empty? (subscription-holders (hash-ref (subs) localid)))) - (extend-turn! turn (Assert localid (observe spec))))) - (commit-turn! turn)) - - (on-stop (log-syndicate/federation-debug "-PEER ~a link ~a" scope linkid) - (turns (hash-remove (turns) linkid)) - (for [((localid matches) (in-hash (link-matches)))] - (for [(captures (in-set matches))] - (remove-match! localid captures linkid))) - (for ([localid (in-hash-values (link-subs))]) - (unsubscribe! localid linkid)) - (commit-turn! turn)) - - (when (log-level? syndicate/federation-logger 'debug) - (begin/dataflow (log-syndicate/federation-debug "~a ~a link-subs:" scope linkid) - (for [((sub local) (in-hash (link-subs)))] - (log-syndicate/federation-debug " sub ~a -> local ~a" sub local)) - (log-syndicate/federation-debug "-")) - (begin/dataflow (log-syndicate/federation-debug "~a ~a link-matches:" scope linkid) - (for [((local matches) (in-hash (link-matches)))] - (for [(captures (in-set matches))] - (log-syndicate/federation-debug " local ~a captures ~v" - local captures))) - (log-syndicate/federation-debug "-"))) - - (stop-when - (message (server-envelope management-scope - (message-poa->server linkid (Err $detail $context)))) - (log-syndicate/federation-error - "Received Err from peer link ~v: detail ~v; context ~v" - linkid - detail - context) - (reset-turn! turn)) - - (on (message (server-envelope management-scope - (message-poa->server linkid (Turn $items)))) - (for [(item (in-list items))] - (match item - [(Assert subid (observe spec)) - (define known? (hash-has-key? (specs) spec)) - (define localid (if known? (hash-ref (specs) spec) (make-localid))) - (define sub (hash-ref (subs) localid (lambda () (subscription localid - spec - (hash) - (hash))))) - (define holders (subscription-holders sub)) - (cond - [(hash-has-key? holders linkid) - (log-syndicate/federation-error - "Duplicate subscription ~a, ID ~a, from link ~a." - spec subid linkid) - (err! 'duplicate-endpoint item)] - [else - (link-subs (hash-set (link-subs) subid localid)) - (when (not known?) (specs (hash-set (specs) spec localid))) - (subs (hash-set (subs) - localid - (struct-copy subscription sub - [holders (hash-set holders linkid subid)]))) - - ;; If not known, then relay the subscription to all peers except `linkid`. - ;; - ;; If known, then one or more links that aren't this one have previously - ;; subscribed with this spec. If exactly one other link has previously - ;; subscribed, the only subscription that needs sent is to that peer; - ;; otherwise, no subscriptions at all need sent, since everyone has already - ;; been informed of this subscription. - - (cond - [(not known?) - (for [((peer peer-turn) (in-hash (turns)))] - (when (not (equal? peer linkid)) - (extend-turn! peer-turn (Assert localid (observe spec)))))] - [(= (hash-count holders) 1) - (for [(peer (in-hash-keys holders))] ;; there will only be one, ≠ linkid - (send-to-link! peer (Assert localid (observe spec))))] - [else - (void)]) - - ;; Once subscription relaying has taken place, send up matches to the active - ;; link. - (for [((captures match-holders) (in-hash (subscription-matches sub)))] - ;; Compute the number of times someone OTHER THAN this link has asserted - ;; a match to this spec. If it's nonzero, we need to hear about it: - (when (not (set-empty? (set-remove match-holders linkid))) - (extend-turn! turn (Add subid captures)))) - - ])] - [(Clear subid) - (match (hash-ref (link-subs) subid #f) - [#f (log-syndicate/federation-error - "Mention of nonexistent subscription ID ~v from link ~v." - subid linkid) - (err! 'nonexistent-endpoint item)] - [localid - (link-subs (hash-remove (link-subs) subid)) - (unsubscribe! localid linkid)]) - (extend-turn! turn (End subid))] - [(End localid) - (for [(captures (in-set (hash-ref (link-matches) localid set)))] - (remove-match! localid captures linkid)) - (link-matches (hash-remove (link-matches) localid))] - [(Add localid captures) - (define matches (hash-ref (link-matches) localid set)) - (cond - [(set-member? matches captures) - (err! 'duplicate-capture item)] - [else - (link-matches (hash-set (link-matches) localid (set-add matches captures))) - (call-with-sub - localid linkid - (lambda (sub) - (define old-matches (subscription-matches sub)) - (define old-match-holders (hash-ref old-matches captures set)) - (define new-match-holders (set-add old-match-holders linkid)) - (define new-matches (hash-set old-matches captures new-match-holders)) - (store-sub! (struct-copy subscription sub [matches new-matches])) - (match (set-count old-match-holders) - [0 (for [((peer peer-subid) (in-hash (subscription-holders sub)))] - (when (not (equal? peer linkid)) - (send-to-link! peer (Add peer-subid captures))))] - [1 (for [(peer (in-set old-match-holders))] ;; only one, ≠ linkid - (define peer-subid (hash-ref (subscription-holders sub) peer #f)) - (when peer-subid ;; the other holder may not itself subscribe! - (send-to-link! peer (Add peer-subid captures))))] - [_ (void)])))])] - [(Del localid captures) - (define matches (hash-ref (link-matches) localid set)) - (if (not (set-member? matches captures)) - (err! 'nonexistent-capture item) - (let ((new-matches (set-remove matches captures))) - (link-matches (if (set-empty? new-matches) - (hash-remove (link-matches) localid) - (hash-set (link-matches) localid new-matches))) - (remove-match! localid captures linkid)))] - [(Msg localid captures) - (call-with-sub - localid linkid - (lambda (sub) - (for ([(peer peer-subid) (in-hash (subscription-holders sub))]) - (when (not (equal? peer linkid)) - (send-to-link! peer (Msg peer-subid captures))))))] - ))))))) diff --git a/OLD-syndicate/distributed/heartbeat.rkt b/OLD-syndicate/distributed/heartbeat.rkt deleted file mode 100644 index 793df07..0000000 --- a/OLD-syndicate/distributed/heartbeat.rkt +++ /dev/null @@ -1,53 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(provide heartbeat) - -(module+ for-testing - (provide heartbeats-enabled?)) - -(require "wire-protocol.rkt") - -(require/activate syndicate/drivers/timer) - -(define-logger syndicate/distributed) - -(define heartbeats-enabled? (make-parameter #t)) - -;; TODO: move heartbeats to transport level, and use separate transport-activity timeouts from -;; message-activity timeouts. Using message-activity only has problems when messages are large -;; and links are slow. Also, moving to transport level lets us use e.g. WebSocket's ping -;; mechanism rather than a message-level mechanism. -(define (heartbeat who send-message teardown) - (cond - [(heartbeats-enabled?) - (define period (ping-interval)) - (define grace (* 3 period)) - - (log-syndicate/distributed-debug - "Peer ~v heartbeat period ~ams; must not experience silence longer than ~ams" - who period grace) - - (field [next-ping-time 0]) ;; when we are to send the next ping - (field [last-received-traffic (current-inexact-milliseconds)]) ;; when we last heard from the peer - - (define (schedule-next-ping!) - (next-ping-time (+ (current-inexact-milliseconds) period))) - - (on (asserted (later-than (next-ping-time))) - (schedule-next-ping!) - (send-message (Ping))) - - (on (asserted (later-than (+ (last-received-traffic) grace))) - (log-syndicate/distributed-info "Peer ~v heartbeat timeout after ~ams of inactivity" - who grace) - (teardown)) - - (lambda () - (schedule-next-ping!) - (last-received-traffic (current-inexact-milliseconds)))] - [else - (log-syndicate/distributed-debug "Peer ~v heartbeats disabled" who) - void])) diff --git a/OLD-syndicate/distributed/internal-protocol.rkt b/OLD-syndicate/distributed/internal-protocol.rkt deleted file mode 100644 index 9f670d1..0000000 --- a/OLD-syndicate/distributed/internal-protocol.rkt +++ /dev/null @@ -1,38 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate -;; Internal server and federation protocol - -(provide (all-defined-out)) - -;; Client-server internal protocol -;; Received packets from server are relayed via one of these. -(message-struct server-packet (address packet)) -;; Like `server-connected`, but for reflecting `tcp-accepted` to the -;; client end of a client-server connection without reordering wrt -;; `server-packet` messages. Implementation-facing, where -;; `server-connected` is part of the API. -(assertion-struct server-transport-connected (address)) -;; Like `server-connected`, but for reflecting the state of the -;; session to the transport driver. Observation of -;; `server-session-connected` is not creative (of `server-connected`), -;; unlike observation of `server-connected`. -(assertion-struct server-session-connected (address)) - -;; Internal connection protocol -(assertion-struct server-poa (connection-id)) ;; "Point of Attachment" -(assertion-struct server-poa-ready (connection-id)) -(assertion-struct message-poa->server (connection-id body)) -(assertion-struct message-server->poa (connection-id body)) - -;; Internal isolation -- these are isomorphic to `to-server` and `from-server`! -;; (and, for that matter, to `outbound` and `inbound`!) -(assertion-struct server-proposal (scope body)) ;; suggestions (~ actions) -(assertion-struct server-envelope (scope body)) ;; decisions (~ events) - -(assertion-struct server-active (scope)) - -;; Federated links generally -(assertion-struct federated-link (id scope)) -(assertion-struct federated-link-ready (id)) diff --git a/OLD-syndicate/distributed/main.rkt b/OLD-syndicate/distributed/main.rkt deleted file mode 100644 index 1feb509..0000000 --- a/OLD-syndicate/distributed/main.rkt +++ /dev/null @@ -1,96 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(provide (all-from-out "protocol.rkt") - (all-from-out "client.rkt") - (all-from-out "client/tcp.rkt") - (all-from-out "client/loopback.rkt") - (all-from-out "server.rkt") - (all-from-out "server/tcp.rkt") - (all-from-out "server/websocket.rkt")) - -(require "internal-protocol.rkt") -(require "protocol.rkt") - -(require/activate "client.rkt") -(require/activate "client/tcp.rkt") -(require/activate "client/loopback.rkt") - -(require/activate "server.rkt") -(require/activate "server/tcp.rkt") -(require/activate "server/websocket.rkt") - -(require/activate "federation.rkt") - -(module+ main - (require racket/cmdline) - (define tcp-port default-tcp-server-port) - (define http-port default-http-server-port) - (define default-management-scope "local") - (define uplinks '()) - (define management-scope default-management-scope) - (command-line #:once-any - ["--tcp" port - ((format "Listen on plain TCP port (default ~a)" default-tcp-server-port)) - (set! tcp-port (string->number port))] - ["--no-tcp" "Do not listen on any plain TCP port" - (set! tcp-port #f)] - #:once-any - ["--http" port - ((format "Listen on websocket HTTP port (default ~a)" default-http-server-port)) - (set! http-port (string->number port))] - ["--no-http" "Do not listen on any websocket HTTP port" - (set! http-port #f)] - #:multi - [("--management-scope" "-m") scope - ("Set the management scope for future `--uplink`s and, " - "ultimately, for local federation management use. " - (format "(default ~v)" default-management-scope)) - (set! management-scope scope)] - ["--uplink" local-scope host port remote-scope - ("Connect the named local-scope to the named remote-scope" - "via the management scope in the server at host:port") - (define port-number (string->number port)) - (when (not port-number) - (eprintf "Invalid --uplink port number: ~v" port) - (exit 1)) - (set! uplinks (cons (federated-uplink local-scope - (server-tcp-connection host - port-number - management-scope) - remote-scope) - uplinks))]) - (extend-ground-boot! (lambda () - (spawn (assert (federation-management-scope management-scope))) - ;; ^ for inbound as well as outbound links - (when tcp-port (spawn-tcp-server! tcp-port)) - (when http-port (spawn-websocket-server! http-port)) - (when (pair? uplinks) - (spawn (define a (server-loopback-connection management-scope)) - (assert (server-connection a)) - (for [(u uplinks)] - (assert (to-server a u)))))))) - -(define-logger syndicate/distributed) - -(when (log-level? syndicate/distributed-logger 'debug) - (spawn #:name 'client-debug - (on (asserted (server-connection $addr)) - (log-syndicate/distributed-debug "C + ~v" addr)) - (on (retracted (server-connection $addr)) - (log-syndicate/distributed-debug "C - ~v" addr)) - (on (message (server-packet $addr $p)) - (log-syndicate/distributed-debug "C IN ~v ~v" addr p)) - ;; C OUT is covered in client.rkt - ) - (spawn #:name 'server-debug - (on (asserted (server-poa $id)) - (log-syndicate/distributed-debug "S + ~v" id)) - (on (retracted (server-poa $id)) - (log-syndicate/distributed-debug "S - ~v" id)) - (on (message (message-poa->server $id $p)) - (log-syndicate/distributed-debug "S IN ~v ~v" id p)) - (on (message (message-server->poa $id $p)) - (log-syndicate/distributed-debug "S OUT ~v ~v" id p)))) diff --git a/OLD-syndicate/distributed/protocol.rkt b/OLD-syndicate/distributed/protocol.rkt deleted file mode 100644 index 8a41149..0000000 --- a/OLD-syndicate/distributed/protocol.rkt +++ /dev/null @@ -1,27 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(provide (all-defined-out)) - -;; Addressing -(assertion-struct server-tcp-connection (host port scope)) -(assertion-struct server-loopback-connection (scope)) - -(define (standard-localhost-server/tcp [scope "broker"]) - (server-tcp-connection "localhost" 8001 scope)) - -;; Client protocol -(assertion-struct to-server (address assertion)) -(assertion-struct from-server (address assertion)) -(assertion-struct server-connection (address)) -(assertion-struct server-connected (address)) -(message-struct force-server-disconnect (address)) - -;; Federation configuration -;; e.g. (federated-uplink "scope1" (server-tcp-connection "peer.example" 8001 "local") "scope2") -(assertion-struct federated-uplink (local-scope peer remote-scope)) -(assertion-struct federated-uplink-connected (link)) - -(assertion-struct federation-management-scope (name)) diff --git a/OLD-syndicate/distributed/server.rkt b/OLD-syndicate/distributed/server.rkt deleted file mode 100644 index 6f32576..0000000 --- a/OLD-syndicate/distributed/server.rkt +++ /dev/null @@ -1,88 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(require "wire-protocol.rkt") -(require "internal-protocol.rkt") -(require "turn.rkt") - -(require/activate "heartbeat.rkt") - -(spawn #:name 'server-factory - - ;; Previously, we just had server-envelope. Now, we have both - ;; server-envelope and server-proposal. While not everything - ;; decided is (locally) suggested, it is true that everything - ;; suggested is decided (in this implementation at least), - ;; and the following clauses reflect this: - (on (asserted (server-proposal $scope $assertion)) - (assert! (server-envelope scope assertion))) - (on (retracted (server-proposal $scope $assertion)) - (retract! (server-envelope scope assertion))) - (on (message (server-proposal $scope $body)) - (send! (server-envelope scope body))) - (on (asserted (observe (server-envelope $scope $spec))) - (assert! (server-proposal scope (observe spec)))) - (on (retracted (observe (server-envelope $scope $spec))) - (retract! (server-proposal scope (observe spec)))) - - (during/spawn (server-poa $id) - (define root-facet (current-facet)) - (assert (server-poa-ready id)) - (on-start - (match (let-event [(message (message-poa->server id $p))] p) - [(Connect scope) (react (connected id scope root-facet))] - [_ (send! (message-server->poa id (Err 'connection-not-setup #f)))])))) - -(define (connected id scope root-facet) - (define endpoints (hash)) - - (define turn (turn-recorder (lambda (items) (send! (message-server->poa id (Turn items)))))) - - (assert (server-active scope)) - - (define (send-error! detail [context #f]) - (send! (message-server->poa id (Err detail context))) - (reset-turn! turn) - (stop-facet root-facet)) - - (define reset-heartbeat! (heartbeat (list 'server id scope) - (lambda (m) (send! (message-server->poa id m))) - (lambda () (stop-facet root-facet)))) - - (on (message (message-poa->server id $p)) - (reset-heartbeat!) - (match p - [(Turn items) - (for [(item (in-list items))] - (match item - [(Assert ep a) - (if (hash-has-key? endpoints ep) - (send-error! 'duplicate-endpoint item) - (react - (define ep-facet (current-facet)) - (set! endpoints (hash-set endpoints ep ep-facet)) - (on-stop (set! endpoints (hash-remove endpoints ep))) - - (assert (server-proposal scope a)) - - (when (observe? a) - (define ((! ctor) cs) (extend-turn! turn (ctor ep cs))) - (add-observer-endpoint! - (lambda () (server-envelope scope (observe-specification a))) - #:on-add (! Add) - #:on-remove (! Del) - #:on-message (! Msg)))))] - [(Clear ep) - (match (hash-ref endpoints ep #f) - [#f (send-error! 'nonexistent-endpoint item)] - [ep-facet (stop-facet ep-facet (extend-turn! turn (End ep)))])] - [(Message body) - (send! (server-proposal scope body))]))] - [(Ping) - (send! (message-server->poa id (Pong)))] - [(Pong) - (void)] - [_ - (send-error! 'invalid-message p)]))) diff --git a/OLD-syndicate/distributed/server/tcp.rkt b/OLD-syndicate/distributed/server/tcp.rkt deleted file mode 100644 index 629bfcb..0000000 --- a/OLD-syndicate/distributed/server/tcp.rkt +++ /dev/null @@ -1,36 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(provide server-facet/tcp - default-tcp-server-port - spawn-tcp-server!) - -(require "../wire-protocol.rkt") -(require "../internal-protocol.rkt") - -(require/activate syndicate/drivers/tcp) -(require/activate syndicate/distributed/server) - -(define (server-facet/tcp id) - (assert (tcp-accepted id)) - (assert (server-poa id)) - (stop-when (retracted (server-poa-ready id))) - (on-start (issue-credit! #:amount 32768 tcp-in id)) - (define accumulate! (packet-accumulator (lambda (p) (send! (message-poa->server id p))))) - (on (message (tcp-in id $bs)) - (issue-credit! #:amount (bytes-length bs) tcp-in id) - (accumulate! bs)) - (on (message (message-server->poa id $p)) - (send! (tcp-out id (encode p))) - (when (Err? p) (stop-current-facet)))) - -(define default-tcp-server-port 21369) - -(define (spawn-tcp-server! [port default-tcp-server-port]) - (spawn #:name 'tcp-server-listener - (during/spawn (tcp-connection $id (tcp-listener port)) - #:name `(server-poa ,id) - (on-start (issue-credit! (tcp-listener port))) - (server-facet/tcp id)))) diff --git a/OLD-syndicate/distributed/server/websocket.rkt b/OLD-syndicate/distributed/server/websocket.rkt deleted file mode 100644 index 3c1ca01..0000000 --- a/OLD-syndicate/distributed/server/websocket.rkt +++ /dev/null @@ -1,38 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(provide server-facet/websocket - default-http-server-port - spawn-websocket-server!) - -(require "../wire-protocol.rkt") -(require "../internal-protocol.rkt") - -(require syndicate/protocol/credit) - -(require/activate syndicate/drivers/web) -(require/activate syndicate/distributed/server) - -(define (server-facet/websocket id) - (assert (http-accepted id)) - (assert (http-response-websocket id)) - (assert (server-poa id)) - (stop-when (retracted (server-poa-ready id))) - (on (message (websocket-in id $body)) - (define-values (packet remainder) (decode body)) - (when (not (equal? remainder #"")) - (error 'server-facet/websocket "Multiple packets in a single websocket message")) - (send! (message-poa->server id packet))) - (on (message (message-server->poa id $p)) - (send! (websocket-out id (encode p))) - (when (Err? p) (stop-current-facet)))) - -(define default-http-server-port 8000) - -(define (spawn-websocket-server! [port default-http-server-port]) - (spawn #:name 'websocket-server-listener - (during/spawn (http-request $id 'get (http-resource (http-server _ port #f) `("" ())) _ _ _) - #:name `(server-poa ,id) - (server-facet/websocket id)))) diff --git a/OLD-syndicate/distributed/turn.rkt b/OLD-syndicate/distributed/turn.rkt deleted file mode 100644 index ed8f165..0000000 --- a/OLD-syndicate/distributed/turn.rkt +++ /dev/null @@ -1,37 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(provide turn-recorder - extend-turn! - commit-turn! - reset-turn!) - -(require (submod "../dataspace.rkt" priorities)) - -(define (extend-turn! t item) (t 'extend item)) -(define (commit-turn! t) (t 'commit)) -(define (reset-turn! t) (t 'reset)) - -(define (turn-recorder on-commit) - (field [commit-needed #f]) - (define items '()) - (define t - (match-lambda* - [(list 'extend item) - (set! items (cons item items)) - (commit-needed #t)] - [(list 'commit) - (when (commit-needed) - (on-commit (reverse items)) - (reset-turn! t))] - [(list 'reset) - (set! items '()) - (commit-needed #f)] - [(list 'debug) - (reverse items)])) - (begin/dataflow - #:priority *idle-priority* - (commit-turn! t)) - t) diff --git a/OLD-syndicate/distributed/wire-protocol.rkt b/OLD-syndicate/distributed/wire-protocol.rkt deleted file mode 100644 index e81c3ff..0000000 --- a/OLD-syndicate/distributed/wire-protocol.rkt +++ /dev/null @@ -1,72 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(provide (all-defined-out)) - -(require (prefix-in preserves: preserves)) -(require bitsyntax) -(require (only-in net/rfc6455 ws-idle-timeout)) -(require (only-in racket/list index-of)) - -;; Enrolment -(message-struct Connect (scope)) ;; Client --> Server - -;; Transactions -(message-struct Turn (items)) ;; Bidirectional - ;; Items: - ;; Actions; Client --> Server (and Peer --> Peer, except for Message) - (message-struct Assert (endpoint-name assertion)) - (message-struct Clear (endpoint-name)) - (message-struct Message (body)) - ;; Events; Server --> Client (and Peer --> Peer) - (message-struct Add (endpoint-name captures)) - (message-struct Del (endpoint-name captures)) - (message-struct Msg (endpoint-name captures)) - (message-struct End (endpoint-name)) - -;; Errors -(message-struct Err (detail context)) ;; Server --> Client (and Peer --> Peer) - -;; Transport-related; Bidirectional -(message-struct Ping ()) -(message-struct Pong ()) - -;; In peer mode, *actions* and *events* travel in *both* directions, -;; but `Message`s do not appear and (for now) `Assert` is only used to -;; establish `observe`s, i.e. subscriptions. - -(define (decode bs) - (preserves:bytes->preserve bs)) - -(define (encode v) - (preserves:preserve->bytes v)) - -(define (ping-interval) - (* 1000 (min 60 ;; reasonable default? - ;; - ;; TODO: disable the net/rfc6455 ws-idle-timeout, when we can. - ;; - ;; The net/rfc6455 ws-idle-timeout has to be paid attention to here because it - ;; can't be disabled, because the built-in webserver (which net/rfc6455 - ;; interoperates with) has a per-connection timer that also can't be disabled. - ;; - (max (- (ws-idle-timeout) 10) - (* (ws-idle-timeout) 0.8))))) - -(define (packet-accumulator handle-packet!) - (field [buffer #""]) - (begin/dataflow - (define p (open-input-bytes (buffer))) - (let read-more () - (define start-pos (file-position p)) - (match (preserves:read-preserve/binary p #:on-short (lambda () eof)) - [(? eof-object?) - (when (positive? start-pos) - (buffer (subbytes (buffer) start-pos)))] - [packet - (handle-packet! packet) - (read-more)]))) - (lambda (chunk) - (buffer (bytes-append (buffer) chunk)))) diff --git a/OLD-syndicate/drivers/config.rkt b/OLD-syndicate/drivers/config.rkt deleted file mode 100644 index a14fd2d..0000000 --- a/OLD-syndicate/drivers/config.rkt +++ /dev/null @@ -1,41 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate -;; Monitor configuration files. - -(provide (struct-out config) - spawn-configuration - define/query-config - config-ref) - -(define-logger syndicate/drivers/config) - -(require racket/file) -(require/activate syndicate/drivers/filesystem) - -;; (config Any Any) -(assertion-struct config (scope item)) - -(define (spawn-configuration scope path #:hook [hook void]) - (spawn #:name (list 'configuration-monitor scope path) - (hook) - (during (file-content path file->list $items) - (cond - [(not items) - (log-syndicate/drivers/config-warning "config ~s is missing" path)] - [else - (log-syndicate/drivers/config-info "loading config ~s" path) - (for [(item items)] - (log-syndicate/drivers/config-info "config ~s: ~s" path item) - (assert (config scope item)))])))) - -(define-syntax define/query-config - (syntax-rules () - [(_ scope id default) - (define/query-config id scope id default)] - [(_ id scope key default) - (define/query-value id default (config scope (list 'key $val)) val)])) - -(define (config-ref scope key default) - (immediate-query (query-value default (config scope (list key $val)) val))) diff --git a/OLD-syndicate/drivers/external-event.rkt b/OLD-syndicate/drivers/external-event.rkt deleted file mode 100644 index 765bf30..0000000 --- a/OLD-syndicate/drivers/external-event.rkt +++ /dev/null @@ -1,22 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(provide (struct-out external-event)) - -(message-struct external-event (descriptor values)) - -(spawn #:name 'external-event-relay - (during/spawn (observe (inbound (external-event $desc _))) - (define ch (make-channel)) - (thread (lambda () - (let loop () - (sync ch - (handle-evt desc - (lambda results - (ground-send! (inbound (external-event desc results))) - (loop))))))) - (signal-background-activity! +1) - (on-stop (channel-put ch 'quit) - (signal-background-activity! -1)))) diff --git a/OLD-syndicate/drivers/filesystem.rkt b/OLD-syndicate/drivers/filesystem.rkt deleted file mode 100644 index 7e15282..0000000 --- a/OLD-syndicate/drivers/filesystem.rkt +++ /dev/null @@ -1,85 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate -;; Filesystem change monitor driver - -(provide (struct-out file-content) - spawn-filesystem-driver) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(assertion-struct file-content (name reader-proc content)) - -;; Internal driver ground-level protocol -(message-struct file-changed (name)) -(message-struct file-container-changed (parent-path)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (spawn-filesystem-driver) - (spawn #:name 'drivers/filesystem - (during/spawn (observe (file-content $name $reader-proc _)) - #:name (list 'file-content name reader-proc) - (track-file name reader-proc)) - (during (observe (inbound (file-changed $name))) - (monitor-thread name)))) - -(define (read-file name reader-proc) - (and (or (file-exists? name) (directory-exists? name)) - (reader-proc name))) - -(define (path->parent-path name) - (let-values (((parent-path _leaf _syntactically-dir?) - (split-path (path->complete-path name)))) - parent-path)) - -(define (track-file name reader-proc) - (field [content (read-file name reader-proc)]) - (assert (file-content name reader-proc (content))) - (on (message (inbound (file-changed name))) - (content (read-file name reader-proc))) - ;; This horrible hack is required to work around limitations in the - ;; OS's file-change reporting. It seems (?) as if, monitoring both - ;; "a/b" and "a/", that only the event for "a/" will be fired when - ;; "a/b" changes. This manifests as follows: if I monitor "a/b" and - ;; "a/nonexistent", then when "a/b" changes, only "a/nonexistent"'s - ;; event will fire. Therefore, I've kludged in the - ;; `file-container-changed` message, which copes with one level of - ;; directory hierarchy of this problem. - ;; - ;; TODO: Consider whether it will actually be required to listen for - ;; file-container-changed events for ALL recursive parents of the - ;; path of interest up to the root. - ;; - (on (message (inbound (file-container-changed (path->parent-path name)))) - (content (read-file name reader-proc)))) - -(define (monitor-thread name) - (define control-ch (make-channel)) - (thread (lambda () - (define parent-path (path->parent-path name)) - (let loop () - (sync (handle-evt control-ch - (lambda (msg) - ;; (log-info "track-file-changes ~v: ~v" name msg) - (match msg - ['quit (void)]))) - (if (or (file-exists? name) (directory-exists? name)) ;; TODO: TOCTTOU :-( - (handle-evt (filesystem-change-evt name) - (lambda (_dummy) - ;; (log-info "track-file-changes ~v: changed" name) - (ground-send! (inbound (file-changed name))) - (loop))) - (handle-evt (filesystem-change-evt parent-path) - (lambda (_dummy) - ;; (log-info "track-file-changes ~v: directory changed" name) - (ground-send! (inbound (file-container-changed parent-path))) - (loop)))))) - (signal-background-activity! -1))) - (signal-background-activity! +1) - (on-stop (channel-put control-ch 'quit))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(spawn-filesystem-driver) diff --git a/OLD-syndicate/drivers/gl-2d.rkt b/OLD-syndicate/drivers/gl-2d.rkt deleted file mode 100644 index 09a49cd..0000000 --- a/OLD-syndicate/drivers/gl-2d.rkt +++ /dev/null @@ -1,665 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(provide (struct-out window) - (struct-out frame-event) - (struct-out key-event) - (struct-out key-pressed) - (struct-out mouse-event) - (struct-out mouse-state) - (struct-out touching) - (struct-out coordinate-map) - (struct-out scene) - (except-out (struct-out sprite) sprite) - (rename-out [sprite ] [make-sprite sprite]) - (struct-out gl-control) - in-unit-circle? - in-unit-square? - simple-sprite - assert-scene - spawn-keyboard-integrator - spawn-mouse-integrator - spawn-gl-2d-driver) - -(require data/order) -(require data/splay-tree) -(require data/queue) -(require sgl/gl) -(require sgl/gl-vectors) - -(require racket/gui/base) -(require racket/dict) -(require (only-in racket/class - send is-a? make-object class class* inherit this new super-new init - define/public define/override define/augment)) -(require (only-in racket/math sqr)) - -(require (prefix-in image: 2htdp/image)) -(require (prefix-in pict: pict)) - -(require syndicate/drivers/gl-2d/texture) -(require syndicate/drivers/gl-2d/affine) - -(require/activate syndicate/drivers/timer) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Shared state maintained by dataspace. Describes current window dimensions. -(assertion-struct window (width height)) - -;; Message sent by dataspace. Describes render time. -(message-struct frame-event (counter timestamp elapsed-ms target-frame-rate)) - -;; Message sent by dataspace. Describes a key event. Key is a sealed -;; key-event%. `press?` is #t when the key is pressed (or -;; autorepeated!), and #f when it is released. -(message-struct key-event (code press? key)) - -;; Assertion. Indicates that the named key is held down. See role -;; KeyboardIntegrator and spawn-keyboard-integrator. -(assertion-struct key-pressed (code)) - -;; Message sent by dataspace. Describes a mouse event. State is a -;; MouseState. -(message-struct mouse-event (type state)) - -;; Assertion. Indicates that the mouse is in a particular state. See -;; role MouseIntegrator and spawn-mouse-integrator. -(assertion-struct mouse-state (x y left-down? middle-down? right-down?)) - -;; Assertion. Indicates that the mouse is touching a particular touchable. -(assertion-struct touching (id)) - -;; Assertion. Communicates aggregate device-to-user transformation -;; requested as part of sprite instruction sequences. -(assertion-struct coordinate-map (id matrix)) - -;; Shared state maintained by program. Prelude and postlude are to be -;; sealed instruction lists. It is an error to have more than exactly -;; one active such record at a given time. -(assertion-struct scene (prelude postlude)) - -;; A SpriteID is an equal?-comparable dataspace-unique value. - -;; Shared state maintained by program. `id` is a SpriteID, and -;; `parent-id` is an (Option SpriteID); #f in `parent-id` means that -;; this sprite is a child of the root. Z is to be a number, negative -;; toward camera. Instructions to be a sealed instruction list. -(assertion-struct sprite (id parent-id z instructions)) - -;; Message and assertion. -;; -;; When sent as a message with `body` of `'stop`, closes the GL window -;; and terminates the driver. -;; -;; When asserted with `body` of `'fullscreen`, causes the window to be -;; fullscreen; otherwise, it is a normal window. -;; -(assertion-struct gl-control (body)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-syntax-rule (assert-scene prelude postlude) - (assert (scene (seal prelude) (seal postlude)))) - -(define (make-sprite z instructions #:id [id #f] #:parent [parent-id #f]) - (sprite (or id (gensym 'sprite)) parent-id z (seal instructions))) - -(define (in-unit-circle? x y) - (<= (+ (sqr (- x 0.5)) (sqr (- y 0.5))) (sqr 0.5))) - -(define (in-unit-square? x y) - (and (<= 0 x 1) - (<= 0 y 1))) - -(define (simple-sprite z x y w h i - #:parent [parent-id #f] - #:rotation [rotation 0] - #:coordinate-map-id [coordinate-map-id #f] - #:touchable-id [touchable-id #f] - #:touchable-predicate [touchable-predicate in-unit-square?]) - (make-sprite #:id touchable-id - #:parent parent-id - z - `((translate ,x ,y) - ,@(if (zero? rotation) `() `((rotate ,rotation))) - (push-matrix - (scale ,w ,h) - ,@(if touchable-id - `((touchable ,touchable-id ,touchable-predicate)) - `()) - (texture ,i)) - ,@(if coordinate-map-id - `((coordinate-map ,coordinate-map-id)) - `()) - (render-children)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; KeyboardIntegrator. Integrates key-events into key-pressed assertions. -(define (spawn-keyboard-integrator) - (spawn #:name 'gl-2d/keyboard-integratpr - (local-require racket/set) - (define keys-pressed (mutable-set)) - ;; TODO: consider adding set-semantics assert!/retract! API for this kind of thing - (on (message (key-event $code #t _)) - (unless (set-member? keys-pressed code) - (set-add! keys-pressed code) - (assert! (key-pressed code)))) - (on (message (key-event $code #f _)) - (when (set-member? keys-pressed code) - (set-remove! keys-pressed code) - (retract! (key-pressed code)))))) - -;; MouseIntegrator. Integrates mouse-events into mouse-state assertions. -(define (spawn-mouse-integrator) - (spawn #:name 'gl-2d/mouse-integrator - (field [in-bounds? #f] [state #f]) - (assert #:when (in-bounds?) (state)) - (on (message (mouse-event $type $new-state)) - (in-bounds? (not (eq? type 'leave))) - (state new-state)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; A Touchable is one of -;; -;; - (touchable Any TransformationMatrix (Number Number -> Boolean)) -;; Represents a composed device-to-user transformation, plus a -;; predicate on user coordinates, and an ID to use when the -;; predicate answers truthily. -;; -;; - (touchable-map) -;; Represents the location in a sequence of touchables where the -;; aggregate partial device-to-user transformation used when mapping -;; along parent-child relationship edges in the sprite tree should -;; be applied to child sprites. -;; -(struct touchable (id transformation predicate) #:transparent) -(struct touchable-map () #:transparent) - -;; A Children is a (SplayTree Sprite CompiledInstructions), ordered -;; first by sprite-z, then sprite-id hash code, then -;; sprite-instructions hash-code. -;; -;; A ChildMap is a (Hash SpriteID Children), mapping sprite-id to the -;; children of that sprite. - -;; (compiled-instructions (ChildMap SpriteID -> Void) -;; (Listof Touchable) -;; (Listof CoordinateMap) -;; (Listof Resource) -;; (Option TransformationMatrix) -;; TransformationMatrix) -;; A single compiled sprite. The resources and coordinate-maps aren't -;; in any particular order, but the touchables are: the leftmost -;; touchable is the first to check; that is, it is the *topmost* -;; touchable in this sprite. The child-xform, if present, is the -;; transformation needed to map between mouse coordinates and child -;; sprite space; if absent, no (render-children) instruction was found -;; in this sprite's render code. The final-xform is the final -;; transformation after the render instructions have completed. -(struct compiled-instructions - (render-proc touchables coordinate-maps resources child-xform final-xform)) - -(define-namespace-anchor ns-anchor) -(define ns (namespace-anchor->namespace ns-anchor)) - -(define (compile-instructions instrs) - (define touchables '()) - (define coordinate-maps '()) - (define resources '()) - (define child-xform #f) - - (define (instructions->racket-code instrs xform) - (define-values (code-rev new-xform) - (for/fold [(code-rev '()) (xform xform)] [(instr (in-list instrs))] - (define-values (new-code new-xform) (instruction->racket-code instr xform)) - (values (cons new-code code-rev) new-xform))) - (let ((code (reverse code-rev))) - (values (lambda (CHILDMAP SELF-ID) - (for [(p (in-list code))] - (p CHILDMAP SELF-ID))) - new-xform))) - - (define (instruction->racket-code instr xform) - (match instr - [`(rotate ,(? number? deg)) - (values (lambda (CHILDMAP SELF-ID) (glRotated deg 0 0 -1)) - (compose-transformation xform (rotation-transformation (- deg))))] - [`(scale ,(? number? x) ,(? number? y)) - (values (lambda (CHILDMAP SELF-ID) (glScaled x y 1)) - (compose-transformation xform (stretching-transformation x y)))] - [`(translate ,(? number? x) ,(? number? y)) - (values (lambda (CHILDMAP SELF-ID) (glTranslated x y 0)) - (compose-transformation xform (translation-transformation x y)))] - [`(color ,(? color-number? r) ,(? color-number? g) ,(? color-number? b) ,(? color-number? a)) - (values (lambda (CHILDMAP SELF-ID) (glColor4d r g b a)) xform)] - [`(texture ,i) - (define entry (image->texture-cache-entry i)) - (define tex (send entry get-texture)) - (set! resources (cons entry resources)) - (values (lambda (CHILDMAP SELF-ID) (draw-gl-face tex)) xform)] - [`(texture ,i ,l ,t ,w ,h) #:when (andmap number? (list l t w h)) - (define entry (image->texture-cache-entry i)) - (define tex (send entry get-texture)) - (set! resources (cons entry resources)) - (values (lambda (CHILDMAP SELF-ID) (draw-gl-face tex l t w h)) xform)] - [`(touchable ,id ,predicate) - (set! touchables (cons (touchable id xform predicate) touchables)) - (values void xform)] - [`(coordinate-map ,id) - (set! coordinate-maps (cons (coordinate-map id xform) coordinate-maps)) - (values void xform)] - [`(push-matrix ,instr ...) - (define-values (code _new-xform) (instructions->racket-code instr xform)) - (values (lambda (CHILDMAP SELF-ID) - (glPushMatrix) - (code CHILDMAP SELF-ID) - (glPopMatrix)) - xform)] - [`(begin ,instr ...) - (define-values (code new-xform) (instructions->racket-code instr xform)) - (values code new-xform)] - [`(render-children) ;; we assume that there will only be one of these - (set! child-xform xform) - (set! touchables (cons (touchable-map) touchables)) - (values render-sprites! xform)] - [other - (error 'instruction->racket-code "unknown render instruction: ~v" other)])) - - (define-values (render-proc final-transformation) - (instruction->racket-code `(begin ,@instrs) identity-transformation)) - (compiled-instructions render-proc - touchables - coordinate-maps - resources - child-xform - final-transformation)) - -(define empty-instructions (compile-instructions '())) - -(define (compiled-instructions-dispose! i) - (when i - (for [(resource (in-list (compiled-instructions-resources i)))] - (send resource dispose)))) - -(define (color-number? n) - (and (number? n) - (<= 0.0 n 1.0))) - -(define (image->bitmap i) - (cond - [(is-a? i bitmap%) - i] - [(image:image? i) - (define w (max 1 (image:image-width i))) - (define h (max 1 (image:image-height i))) - (define bm (make-object bitmap% w h #f #t)) - (define dc (send bm make-dc)) - (send i draw dc - 0 0 - 0 0 - w h - 0 0 - #f) - bm] - [(pict:pict? i) - (pict:pict->bitmap i)] - [else - (error 'image->bitmap "unsupported image type ~v" i)])) - -(define (image->texture-cache-entry i) - (texture-cache-get i image->bitmap)) - -;; (define (lerp a b v) (+ (* v a) (* (- 1 v) b))) - -(define (draw-gl-face texture [left 0] [top 0] [width 1] [height 1]) - (define bot (+ top height)) - (define right (+ left width)) - (send texture bind-texture) - (glBegin GL_QUADS) - (glNormal3d 0 0 -1) - (glTexCoord2d left top) - (glVertex3d 0 0 0) - (glTexCoord2d right top) - (glVertex3d 1 0 0) - (glTexCoord2d right bot) - (glVertex3d 1 1 0) - (glTexCoord2d left bot) - (glVertex3d 0 1 0) - (glEnd)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define sprite-order - (order 'sprite-order - sprite? - (lambda (a b) (and (equal? (sprite-id a) (sprite-id b)) - (= (sprite-z a) (sprite-z b)) - (eq? (sprite-instructions a) - (sprite-instructions b)))) - (lambda (a b) (or (> (sprite-z a) (sprite-z b)) - (and (= (sprite-z a) (sprite-z b)) - (let ((a-id-code (equal-hash-code (sprite-id a))) - (b-id-code (equal-hash-code (sprite-id b)))) - (or (< a-id-code b-id-code) - (and (= a-id-code b-id-code) - (< (eq-hash-code (sprite-instructions a)) - (eq-hash-code (sprite-instructions b))))))))))) - -(define (remove-sprite! childmap s) - (define sprites (hash-ref childmap (sprite-parent-id s) #f)) - (when sprites - (compiled-instructions-dispose! (splay-tree-ref sprites s #f)) - (splay-tree-remove! sprites s) - (when (dict-empty? sprites) (hash-remove! childmap (sprite-parent-id s))))) - -(define (add-sprite! childmap s) - (define sprites (hash-ref childmap (sprite-parent-id s) - (lambda () - (define ss (make-splay-tree sprite-order)) - (hash-set! childmap (sprite-parent-id s) ss) - ss))) - (define instrs `((color 1 1 1 1) - (push-matrix ,@(seal-contents (sprite-instructions s))))) - (define i (compile-instructions instrs)) - (splay-tree-set! sprites s i)) - -(define (for-each-child-sprite childmap id f) - (define children (hash-ref childmap id #f)) - (let loop ((iter (and children (splay-tree-iterate-first children)))) - (when iter - (define s (splay-tree-iterate-key children iter)) - (define ci (splay-tree-iterate-value children iter)) - (f s ci) - (loop (splay-tree-iterate-next children iter))))) - -(define (render-sprites! childmap self-id) - (for-each-child-sprite childmap self-id - (lambda (s ci) - ((compiled-instructions-render-proc ci) childmap (sprite-id s))))) - -(define (render-scene! prelude childmap postlude) - ((compiled-instructions-render-proc prelude) childmap #f) - (render-sprites! childmap #f) - ((compiled-instructions-render-proc postlude) childmap #f)) - -(define (detect-touch prelude childmap postlude state) - (and state - (let () - (define x (mouse-state-x state)) - (define y (mouse-state-y state)) - (or (detect-touch* childmap #f postlude x y) - (detect-sprites-touch childmap #f x y) - (detect-touch* childmap #f prelude x y))))) - -(define (detect-sprites-touch childmap self-id x y) - (define sprites (hash-ref childmap self-id #f)) - (let loop ((iter (and sprites (splay-tree-iterate-greatest sprites)))) - (and iter - (let ((s (splay-tree-iterate-key sprites iter))) - (define ci (splay-tree-iterate-value sprites iter)) - (or (detect-touch* childmap (sprite-id s) ci x y) - (loop (splay-tree-iterate-greatest/ - -#lang racket/base -;; 2D affine transformation matrices. - -;; These are *active* transformations: they transform vectors to new -;; vectors, rather than coordinate systems to new coordinate systems. - -(provide (struct-out transformation-matrix) - - identity-transformation - translation-transformation - rotation-transformation - stretching-transformation - shearing-transformation - invert-transformation - compose-transformation - - transform-point - transform-vector - untransform-point - untransform-vector) - -(require (only-in racket/math pi)) -(require racket/match) - -(struct transformation-matrix (a b c d tx ty) #:prefab) - -(define identity-transformation - (transformation-matrix 1 0 0 1 0 0)) - -(define (translation-transformation x y) - (transformation-matrix 1 0 0 1 x y)) - -(define (rad deg) (* deg (/ pi 180.0))) - -(define (rotation-transformation theta-d) - (match theta-d - [(or 0 360) identity-transformation] - [(or 90 -270) (transformation-matrix 0 1 -1 0 0 0)] - [180 (transformation-matrix -1 0 0 -1 0 0)] - [(or 270 -90) (transformation-matrix 0 -1 1 0 0 0)] - [_ - (define theta-r (rad theta-d)) - (define c (cos theta-r)) - (define s (sin theta-r)) - (transformation-matrix c s (- s) c 0 0)])) - -(define (stretching-transformation sx [sy sx]) - (transformation-matrix sx 0 0 sy 0 0)) - -(define (shearing-transformation sx sy) - (transformation-matrix 1 sy sx 1 0 0)) - -(define (invert-transformation m) - (define det (determinant m)) - (when (zero? det) (error 'invert-transformation "Zero determinant")) - (define -det (- det)) - (match-define (transformation-matrix a b c d tx ty) m) - (transformation-matrix (/ d det) - (/ b -det) - (/ c -det) - (/ a det) - (/ (- (* c ty) (* d tx)) det) - (/ (- (* b tx) (* a ty)) det))) - -(define (determinant m) - (match-define (transformation-matrix a b c d _ _) m) - (- (* a d) (* b c))) - -(define (compose-transformation* m1 m0) - (match-define (transformation-matrix a b c d tx ty) m1) - (match-define (transformation-matrix e f g h sx sy) m0) - (transformation-matrix (+ (* a e) (* c f)) - (+ (* b e) (* d f)) - (+ (* a g) (* c h)) - (+ (* b g) (* d h)) - (+ (* a sx) (* c sy) tx) - (+ (* b sx) (* d sy) ty))) - -(define compose-transformation - (case-lambda - [() identity-transformation] - [(m) m] - [(m1 m0) (compose-transformation* m1 m0)] - [mtxs (foldr compose-transformation* identity-transformation mtxs)])) - -(define (transform-point m v) - (match-define (transformation-matrix a b c d tx ty) m) - (define x (real-part v)) - (define y (imag-part v)) - (make-rectangular (+ (* a x) (* c y) tx) - (+ (* b x) (* d y) ty))) - -(define (transform-vector m v) - (match-define (transformation-matrix a b c d _ _) m) - (define x (real-part v)) - (define y (imag-part v)) - (make-rectangular (+ (* a x) (* c y)) - (+ (* b x) (* d y)))) - -(define (untransform-point m v) - (transform-point (invert-transformation m) v)) - -(define (untransform-vector m v) - (transform-vector (invert-transformation m) v)) - -(module+ test - (require rackunit) - - (define eps 0.00001) - (define invrt2 (/ (sqrt 2))) - - (define (within-eps a b) (< (magnitude (- a b)) eps)) - - (define-binary-check (check-transformation~? actual expected) - (match-let (((transformation-matrix aa ab ac ad atx aty) actual) - ((transformation-matrix ea eb ec ed etx ety) expected)) - (and (within-eps aa ea) - (within-eps ab eb) - (within-eps ac ec) - (within-eps ad ed) - (within-eps atx etx) - (within-eps aty ety)))) - - (check-= (transform-point (rotation-transformation 0) +i) +i eps) - (check-= (transform-point (rotation-transformation 90) +i) -1 eps) - (check-= (transform-point (rotation-transformation 180) +i) -i eps) - (check-= (transform-point (rotation-transformation 270) +i) 1 eps) - (check-= (transform-point (rotation-transformation -90) +i) 1 eps) - (check-= (transform-point (rotation-transformation 360) +i) +i eps) - - (check-= (transform-point (rotation-transformation 0) 1) 1 eps) - (check-= (transform-point (rotation-transformation 90) 1) +i eps) - (check-= (transform-point (rotation-transformation 180) 1) -1 eps) - (check-= (transform-point (rotation-transformation 270) 1) -i eps) - (check-= (transform-point (rotation-transformation -90) 1) -i eps) - (check-= (transform-point (rotation-transformation 360) 1) 1 eps) - - (check-= (transform-point (rotation-transformation -45) 1) (make-rectangular invrt2 (- invrt2)) eps) - (check-= (transform-point (rotation-transformation 45) 1) (make-rectangular invrt2 invrt2) eps) - (check-= (transform-point (rotation-transformation 135) 1) (make-rectangular (- invrt2) invrt2) eps) - - (check-= (transform-point (stretching-transformation 2) 1) 2 eps) - (check-= (transform-point (stretching-transformation 2) +i) +2i eps) - (check-= (transform-point (stretching-transformation 2) 1+i) 2+2i eps) - - (check-= (transform-point (compose-transformation (translation-transformation 0 2) - (rotation-transformation 45)) - 1) - (make-rectangular invrt2 (+ invrt2 2)) - eps) - - (check-= (transform-point (compose-transformation (rotation-transformation 45) - (translation-transformation 0 2)) - 1) - -0.7071067811865474+2.121320343559643i - eps) - - (check-= (transform-point (invert-transformation - (compose-transformation (rotation-transformation 45) - (translation-transformation 0 2))) - -0.7071067811865474+2.121320343559643i) - 1 - eps) - - (check-transformation~? (compose-transformation (rotation-transformation -90) - (translation-transformation 0 2) - (rotation-transformation 90)) - (translation-transformation 2 0)) - - (check-transformation~? (compose-transformation (rotation-transformation -45) - (translation-transformation 0 (* 2 (sqrt 2))) - (rotation-transformation 45)) - (translation-transformation 2 2)) - - ;; Cairo's drawing model has *device coordinates* and *user - ;; coordinates*. In the Cairo tutorial, we are given the task of - ;; mapping a 1.0x1.0 workspace onto the 100x100 pixel square in the - ;; middle of a 120x120 pixel surface, and shown three different ways - ;; of achieving this: - ;; - ;; - cairo_translate (cr, 10, 10); cairo_scale (cr, 100, 100); - ;; - ;; - cairo_scale (cr, 100, 100); cairo_translate (cr, 0.1, 0.1); - ;; - ;; - cairo_matrix_t mat; cairo_matrix_init (&mat, 100, 0, 0, 100, 10, 10); - ;; cairo_transform (cr, &mat); - ;; - ;; Let's see what those look like here. We'll assume a right-handed - ;; coordinate system for both the workspace and the surface, so we - ;; can judge a correct outcome by seeing that (0,0) on the workspace - ;; should map to (10,10) on the surface, that (1,1) on the workspace - ;; should map to (110,110), and that the other two corners should - ;; map correspondingly. - - (let () - (define (apply-to-inputs m) - (map (lambda (v) (transform-point m v)) - (list 0 1 1+i +i))) - - (define expected-outputs (list 10+10i 110+10i 110+110i 10+110i)) - - (define-binary-check (check-list~? actual expected) - (andmap within-eps actual expected)) - - (check-list~? (apply-to-inputs (compose-transformation (translation-transformation 10 10) - (stretching-transformation 100 100))) - expected-outputs) - (check-list~? (apply-to-inputs (compose-transformation (stretching-transformation 100 100) - (translation-transformation 0.1 0.1))) - expected-outputs) - (check-list~? (apply-to-inputs (transformation-matrix 100 0 0 100 10 10)) - expected-outputs)) - - ;; The Cairo tutorial also makes this note regarding line widths: - ;; "While you're operating under a scale, the width of your line is - ;; multiplied by that scale." That is, in Cairo, you reason about - ;; line widths in user coordinates, just as with everything else. - - (let* ((m (transformation-matrix 100 0 0 100 10 10))) - ;; transform-vector is analogous to Cairo's - ;; "cairo_user_to_device_distance" function. - (check-= (transform-vector m 0.01+0.01i) 1+i eps) - ;; untransform-vector is analogous to Cairo's - ;; "cairo_device_to_user_distance" function. - (check-= (untransform-vector m 1+i) 0.01+0.01i eps)) - - ) diff --git a/OLD-syndicate/drivers/gl-2d/texture.rkt b/OLD-syndicate/drivers/gl-2d/texture.rkt deleted file mode 100644 index 3c01e1d..0000000 --- a/OLD-syndicate/drivers/gl-2d/texture.rkt +++ /dev/null @@ -1,114 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang racket/gui - -(provide texture% - texture-cache-get - flush-texture-cache!) - -(require sgl/gl) -(require sgl/gl-vectors) - -(define texture% - (class object% - (init [(initial-bitmap bitmap)]) - (field [width 0] - [height 0] - [textures #f]) - - (define/public (get-width) width) - (define/public (get-height) height) - - (define/public (bind-texture) - (when (not textures) (error 'bind-texture "Attempt to use disposed texture%")) - (glBindTexture GL_TEXTURE_2D (gl-vector-ref textures 0))) - - (define/public (load-from-bitmap! bitmap) - (when textures (dispose)) - (set! textures (glGenTextures 1)) - (bind-texture) - (define image-data - (let () - (set! width (send bitmap get-width)) - (set! height (send bitmap get-height)) - (define dc (new bitmap-dc% [bitmap bitmap])) - (define pixels (* width height)) - (define vec (make-gl-ubyte-vector (* pixels 4))) - (define data (make-bytes (* pixels 4))) - (send dc get-argb-pixels 0 0 width height data #f #t) ;; premultiplied - (for ((i (in-range pixels))) - (for ((j (in-range 4))) - (gl-vector-set! vec (+ (* i 4) j) (bytes-ref data (+ (* i 4) (- 3 j)))))) - vec)) - (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR) - (glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR) - (glTexImage2D GL_TEXTURE_2D 0 4 width height 0 GL_BGRA GL_UNSIGNED_BYTE image-data)) - - (define/public (dispose) - (when textures - (glDeleteTextures textures) - (set! textures #f))) - - (super-new) - (load-from-bitmap! initial-bitmap))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define texture-cache (make-hasheq)) -(define texture-second-chances (make-hasheq)) -(define last-flush 0) - -(define entry% - (class object% - (init-field key - texture) - (super-new) - (define ref-count 0) - - (define/public (get-texture) - texture) - - (define/public (inc-ref-count!) - (set! ref-count (+ ref-count 1))) - - (define/public (dispose) - (set! ref-count (- ref-count 1)) - (when (zero? ref-count) - ;; (log-info "releasing texture cache entry for ~a" key) - (hash-remove! texture-cache key) - (hash-set! texture-second-chances key this))) - - (define/public (*cleanup) - (send texture dispose)))) - -(define (texture-cache-get key key->bitmap) - (define entry - (hash-ref texture-cache - key - (lambda () - (define t (cond - [(hash-has-key? texture-second-chances key) - ;; (log-info "recycling texture cache entry for ~a" key) - (define t (hash-ref texture-second-chances key)) - (hash-remove! texture-second-chances key) - t] - [else - (define bm (key->bitmap key)) - ;; (log-info "allocating new texture cache entry for ~a" key) - (new entry% [key key] [texture (new texture% [bitmap bm])])])) - (hash-set! texture-cache key t) - t))) - (send entry inc-ref-count!) - entry) - -(define (flush-texture-cache!) - (define now (current-seconds)) - ;; (log-info "~a cache entries, ~a second-chances" - ;; (hash-count texture-cache) - ;; (hash-count texture-second-chances)) - (when (> now (+ last-flush 10)) - ;; (log-info "flushing texture cache (~a entries)" (hash-count texture-second-chances)) - (for [(entry (in-hash-values texture-second-chances))] (send entry *cleanup)) - (hash-clear! texture-second-chances) - (set! last-flush now))) diff --git a/OLD-syndicate/drivers/sqlite.rkt b/OLD-syndicate/drivers/sqlite.rkt deleted file mode 100644 index 7794c09..0000000 --- a/OLD-syndicate/drivers/sqlite.rkt +++ /dev/null @@ -1,170 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate -;; SQLite driver - -(provide (struct-out sqlite-db) - (struct-out sqlite-db-ready) - (struct-out sqlite-row) - (struct-out sqlite-exec) - (struct-out sqlite-create-table) - (struct-out sqlite-insert) - (struct-out sqlite-delete) - sqlite-exec! - sqlite-create-table! - sqlite-insert! - sqlite-delete! - (struct-out discard) ;; from syndicate/pattern - ) - -(require db) -(require racket/set) -(require racket/string) -(require syndicate/pattern) - -(define-logger syndicate/sqlite) - -(struct sqlite-db (path) #:prefab) - -(assertion-struct sqlite-db-ready (db)) - -(assertion-struct sqlite-row (db table columns)) - -(message-struct sqlite-exec (db template arguments id)) -(message-struct sqlite-status (id value)) - -(message-struct sqlite-create-table (db table column-names id)) -(message-struct sqlite-insert (db table columns id)) -(message-struct sqlite-delete (db table columns id)) - -(define (sqlite-call db msg-proc) - (define id (gensym 'exec)) - (react/suspend (k) - (on (message (sqlite-status id $v)) - (if (exn? v) (raise v) (k v))) - (on (asserted (sqlite-db-ready db)) - (send! (msg-proc id))))) - -(define (sqlite-exec! db template . arguments) - (sqlite-call db (lambda (id) (sqlite-exec db template arguments id)))) - -(define (sqlite-create-table! db table . column-names) - (sqlite-call db (lambda (id) (sqlite-create-table db table column-names id)))) - -(define (sqlite-insert! db table . columns) - (sqlite-call db (lambda (id) (sqlite-insert db table columns id)))) - -(define (sqlite-delete! db table . columns) - (sqlite-call db (lambda (id) (sqlite-delete db table columns id)))) - -(define (strip-capture p) - (if (capture? p) - (strip-capture (capture-detail p)) - p)) - -(spawn #:name 'drivers/sqlite - (during/spawn ($ db (sqlite-db $path)) - #:name (list 'drivers/sqlite path) - (define handle (sqlite3-connect #:database path #:mode 'create)) ;; TODO: #:use-place ? - (on-stop (disconnect handle)) - - (assert (sqlite-db-ready db)) - - (on (message (sqlite-exec db $template $arguments $id)) - (with-handlers [(exn:fail? (lambda (e) (send! (sqlite-status id e))))] - (log-syndicate/sqlite-debug "~s ~s" template arguments) - (send! (sqlite-status id (apply query-exec handle template arguments))))) - - (field [known-tables (set)]) - - (on (message (sqlite-create-table db $table $column-names $id)) - (with-handlers [(exn:fail? (lambda (e) (send! (sqlite-status id e))))] - (define template - (format "create table ~a (~a)" table (string-join column-names ", "))) - (define arguments '()) - (table-facet handle known-tables db table column-names) - (log-syndicate/sqlite-debug "~s ~s" template arguments) - (send! (sqlite-status id (apply query-exec handle template arguments))))) - - (on-start - (for [(table (query-list handle - "select distinct name from sqlite_master where type='table'"))] - (define column-names - (map (lambda (r) (vector-ref r 1)) - (query-rows handle (string-append "pragma table_info(" table ")")))) - (table-facet handle known-tables db table column-names))))) - -(define (table-facet handle known-tables db table column-names) - (when (not (set-member? (known-tables) table)) - (known-tables (set-add (known-tables) table)) - (react - (on (message ($ m (sqlite-insert db table $columns $id))) - (with-handlers [(exn:fail? (lambda (e) (send! (sqlite-status id e))))] - (define template (format "insert into ~a values (~a)" - table - (string-join (for/list [(i (in-naturals 1)) (c columns)] - (format "$~a" i)) - ", "))) - (define arguments columns) - (log-syndicate/sqlite-debug "~s ~s" template arguments) - (send! (sqlite-status id (apply query-exec handle template arguments))))) - - (on (message ($ m (sqlite-delete db table $columns $id))) - (with-handlers [(exn:fail? (lambda (e) (send! (sqlite-status id e))))] - (define filters - (for/list [(n column-names) (c columns) #:when (not (discard? c))] - (list n c))) - (define template - (format "delete from ~a~a" - table - (if (null? filters) - "" - (format " where ~a" - (string-join (for/list [(i (in-naturals 1)) (f filters)] - (format "~a = $~a" (car f) i)) - " and "))))) - (define arguments (map cadr filters)) - (log-syndicate/sqlite-debug "~s ~s" template arguments) - (send! (sqlite-status id (apply query-exec handle template arguments))))) - - (define (row-facet columns) - (react (assert (sqlite-row db table columns)) - (on (message (sqlite-delete db table $cs _)) - (when (for/and [(c1 columns) (c2 cs)] (or (discard? c2) (equal? c1 c2))) - (stop-current-facet))))) - - (during/spawn (observe (sqlite-row db table $column-patterns0)) - (define column-patterns - (let ((ps (strip-capture column-patterns0))) - (if (discard? ps) - (for/list [(n column-names)] (discard)) - ps))) - (define filters - (for/list [(n column-names) - (p (map strip-capture column-patterns)) - #:when (not (discard? p))] - (list n p))) - - (define initial-rows - (let () - (define template - (format "select distinct * from ~a~a" - table - (if (null? filters) - "" - (format " where ~a" - (string-join (for/list [(i (in-naturals 1)) (f filters)] - (format "~a = $~a" (car f) i)) - " and "))))) - (define arguments (map cadr filters)) - (log-syndicate/sqlite-debug "~s ~s" template arguments) - (map vector->list (apply query-rows handle template (map cadr filters))))) - - (on-start (for-each row-facet initial-rows)) - (on (message (sqlite-insert db table $columns _)) - (when (for/and [(n column-names) (c columns)] - (match (assoc n filters) - [(list _ v) (equal? c v)] - [#f #t])) - (row-facet columns))))))) diff --git a/OLD-syndicate/drivers/tcp.rkt b/OLD-syndicate/drivers/tcp.rkt deleted file mode 100644 index 3fbd190..0000000 --- a/OLD-syndicate/drivers/tcp.rkt +++ /dev/null @@ -1,208 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate -;; TCP/IP driver interface. -;; -;; TODO: This protocol is overly simplified. -;; a) no facility for separate shutdown of inbound/outbound streams - -(provide (struct-out tcp-connection) - (struct-out tcp-connection-peer) - (struct-out tcp-accepted) - (struct-out tcp-rejected) - (struct-out tcp-out) - (struct-out tcp-in) - (struct-out tcp-in-line) - - (struct-out tcp-address) - (struct-out tcp-listener) - - (all-from-out "../protocol/credit.rkt")) - -(define-logger syndicate/tcp) - -(require racket/exn) -(require (prefix-in tcp: racket/tcp)) -(require (only-in racket/port read-bytes-avail!-evt read-bytes-line-evt)) - -(require racket/unit) -(require net/tcp-sig) -(require net/tcp-unit) - -(require "../support/bytes.rkt") -(require "../protocol/credit.rkt") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Protocol messages - -(assertion-struct tcp-connection (id spec)) -(assertion-struct tcp-connection-peer (id addr)) -(assertion-struct tcp-accepted (id)) -(assertion-struct tcp-rejected (id exn)) -(message-struct tcp-out (id bytes)) -(message-struct tcp-in (id bytes)) -(message-struct tcp-in-line (id bytes)) - -(assertion-struct tcp-address (host port)) -(assertion-struct tcp-listener (port)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Ground-level communication messages - -(message-struct raw-tcp-accepted (local-addr remote-addr cin cout)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Driver - -(spawn #:name 'drivers/tcp - - (during/spawn (observe (tcp-connection _ (tcp-listener $port))) - #:name (list 'drivers/tcp 'listener port) - (run-listener port)) - - (during/spawn (tcp-connection $id (tcp-address $host $port)) - #:name (list 'drivers/tcp 'outbound id host port) - (match (with-handlers ([exn:fail? (lambda (e) (list e))]) - (define-values (cin cout) (tcp:tcp-connect host port)) - (list cin cout)) - [(list e) (assert (tcp-rejected id e))] - [(list cin cout) - (assert (tcp-accepted id)) - (run-connection id cin cout)]))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Listener - -(define (run-listener port) - (define server-addr (tcp-listener port)) - (define listener (tcp:tcp-listen port 128 #t)) - (define control-ch (make-channel)) - - (thread (lambda () - (let loop ((credit 1)) ;; NB. not zero initially! - (sync (handle-evt control-ch - (match-lambda - [(list 'credit 'reset) (loop 0)] - [(list 'credit (? number? amount)) (loop (+ credit amount))] - ['quit (void)])) - (if (zero? credit) - never-evt - (handle-evt (tcp:tcp-accept-evt listener) - (lambda (cin+cout) - (match-define (list cin cout) cin+cout) - (define-values - (local-hostname local-port remote-hostname remote-port) - (tcp:tcp-addresses cin #t)) - (ground-send! - (inbound - (raw-tcp-accepted server-addr - (tcp-address remote-hostname remote-port) - cin - cout))) - (loop (- credit 1))))))) - (tcp:tcp-close listener) - (signal-background-activity! -1))) - (signal-background-activity! +1) - - (on-stop (channel-put control-ch 'quit)) - - (on (message (credit* (list server-addr) $amount)) - (channel-put control-ch (list 'credit amount))) - - (on (message (inbound (raw-tcp-accepted server-addr $remote-addr $cin $cout))) - (define id (seal (list port remote-addr))) - (spawn #:name (list 'drivers/tcp 'inbound id) - (assert (tcp-connection id server-addr)) - (assert (tcp-connection-peer id remote-addr)) - (run-connection id cin cout) - (stop-when (asserted (tcp-rejected id _))) - (stop-when (retracted (tcp-accepted id)))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Connection - -(define (run-connection id cin cout) - (define control-ch (make-channel)) - (thread (lambda () (connection-thread control-ch id cin))) - (signal-background-activity! +1) - - (define (shutdown-connection!) - (when control-ch - (channel-put control-ch 'quit) - (set! control-ch #f)) - (when cout - (close-output-port cout) - (set! cout #f))) - - (on-stop (shutdown-connection!)) - - (on (asserted (observe (credit* (list tcp-out id) _))) - (send! (credit tcp-out id +inf.0))) - - (on (message (credit* (list tcp-in id) $amount)) - (when control-ch (channel-put control-ch (list 'credit amount)))) - - (field [mode 'bytes]) - (begin/dataflow (when control-ch (channel-put control-ch (mode)))) - - (on (message (inbound (tcp-in id $eof-or-bs))) - (if (eof-object? eof-or-bs) - (stop-current-facet) - (send! (match (mode) - ['bytes (tcp-in id eof-or-bs)] - ['lines (tcp-in-line id eof-or-bs)])))) - - (during (observe (tcp-in-line id _)) - (on-start (mode 'lines)) - (on-stop (mode 'bytes))) - - (define-syntax-rule (trap-exns body ...) - (with-handlers ([(lambda (e) (not (exn:break? e))) - (lambda (e) - (shutdown-connection!) - (raise e))]) - body ...)) - - (on (message (tcp-out id $bs)) - (trap-exns - (if (string? bs) - (write-string bs cout) - (write-bytes bs cout)) - (flush-output cout)))) - -(define (connection-thread control-ch id cin) - (let loop ((credit 0) (mode 'bytes)) - (sync (handle-evt control-ch - (match-lambda - [(list 'credit 'reset) (loop 0 mode)] - [(list 'credit (? number? amount)) (loop (+ credit amount) mode)] - ['lines (loop credit 'lines)] - ['bytes (loop credit 'bytes)] - ['quit (void)])) - (if (zero? credit) - never-evt - (handle-evt (match mode - ['bytes (read-bytes-avail-evt (inexact->exact (truncate (min credit 32768))) cin)] - ['lines (read-bytes-line-evt cin 'any)]) - (lambda (eof-or-bs) - (ground-send! (inbound (tcp-in id eof-or-bs))) - (loop (if (eof-object? eof-or-bs) - 0 - (- credit (match mode - ['bytes (bytes-length eof-or-bs)] - ['lines 1]))) - mode)))))) - (close-input-port cin) - (signal-background-activity! -1)) - -(define (read-bytes-avail-evt len input-port) - (guard-evt - (lambda () - (let ([bstr (make-bytes len)]) - (handle-evt - (read-bytes-avail!-evt bstr input-port) - (lambda (v) - (if (number? v) - (if (= v len) bstr (subbytes bstr 0 v)) - v))))))) diff --git a/OLD-syndicate/drivers/timer.rkt b/OLD-syndicate/drivers/timer.rkt deleted file mode 100644 index 5af7eb6..0000000 --- a/OLD-syndicate/drivers/timer.rkt +++ /dev/null @@ -1,119 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate -;; Timer driver. - -;; Uses mutable state internally, but because the scope of the -;; mutation is limited to each timer process alone, it's easy to show -;; correct linear use of the various pointers. - -(provide (struct-out set-timer) - (struct-out timer-expired) - (struct-out later-than) - on-timeout - stop-when-timeout - sleep) - -(define-logger syndicate/drivers/timer) - -(require racket/set) -(require data/heap) - -(message-struct set-timer (label msecs kind)) -(message-struct timer-expired (label msecs)) - -(assertion-struct later-than (msecs)) - -(spawn #:name 'drivers/timer - (define control-ch (make-channel)) - - (thread (lambda () - (struct pending-timer (deadline label) #:transparent) - - (define heap - (make-heap (lambda (t1 t2) (<= (pending-timer-deadline t1) - (pending-timer-deadline t2))))) - - (define timers (make-hash)) - - (define (next-timer) - (and (positive? (heap-count heap)) - (heap-min heap))) - - (define (fire-timers! now) - (define count-fired 0) - (let loop () - (when (positive? (heap-count heap)) - (let ((m (heap-min heap))) - (when (<= (pending-timer-deadline m) now) - (define label (pending-timer-label m)) - (heap-remove-min! heap) - (hash-remove! timers label) - (log-syndicate/drivers/timer-debug "expired timer ~a" label) - (ground-send! (timer-expired label now)) - (set! count-fired (+ count-fired 1)) - (loop))))) - (signal-background-activity! (- count-fired))) - - (define (clear-timer! label) - (match (hash-ref timers label #f) - [#f (void)] - [deadline - (heap-remove! heap (pending-timer deadline label)) - (hash-remove! timers label) - (signal-background-activity! -1)])) - - (define (install-timer! label deadline) - (clear-timer! label) - (heap-add! heap (pending-timer deadline label)) - (hash-set! timers label deadline) - (signal-background-activity! +1)) - - (let loop () - (sync (match (next-timer) - [#f never-evt] - [t (handle-evt (alarm-evt (pending-timer-deadline t)) - (lambda (_dummy) - (define now (current-inexact-milliseconds)) - (fire-timers! now) - (loop)))]) - (handle-evt control-ch - (match-lambda - [(set-timer label _ 'clear) - (clear-timer! label) - (loop)] - [(set-timer label msecs 'relative) - (define deadline (+ (current-inexact-milliseconds) msecs)) - (install-timer! label deadline) - (loop)] - [(set-timer label deadline 'absolute) - (install-timer! label deadline) - (loop)])))))) - - (on (message ($ instruction (set-timer _ _ _))) - (log-syndicate/drivers/timer-debug "received instruction ~a" instruction) - (channel-put control-ch instruction)) - - (during (observe (later-than $msecs)) - (log-syndicate/drivers/timer-debug "observing (later-than ~a) at ~a" - msecs - (current-inexact-milliseconds)) - (define timer-id (gensym 'timestate)) - (on-start (send! (set-timer timer-id msecs 'absolute))) - (on-stop (send! (set-timer timer-id msecs 'clear))) - (on (message (timer-expired timer-id _)) - (react (assert (later-than msecs)))))) - -(define-syntax-rule (on-timeout relative-msecs body ...) - (let ((timer-id (gensym 'timeout))) - (on-start (send! (set-timer timer-id relative-msecs 'relative))) - (on (message (timer-expired timer-id _)) body ...))) - -(define-syntax-rule (stop-when-timeout relative-msecs body ...) - (on-timeout relative-msecs (stop-current-facet body ...))) - -(define (sleep sec) - (define timer-id (gensym 'sleep)) - (until (message (timer-expired timer-id _)) - (on-start (send! (set-timer timer-id (* sec 1000.0) 'relative))))) diff --git a/OLD-syndicate/drivers/udp.rkt b/OLD-syndicate/drivers/udp.rkt deleted file mode 100644 index ef73694..0000000 --- a/OLD-syndicate/drivers/udp.rkt +++ /dev/null @@ -1,101 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(provide (struct-out udp-remote-address) - (struct-out udp-handle) - (struct-out udp-listener) - (struct-out udp-multicast-group-member) - (struct-out udp-multicast-loopback) - udp-address? - udp-local-address? - (struct-out udp-packet)) - -(require (prefix-in udp: racket/udp)) - -;; A UdpAddress is one of -;; -- a (udp-remote-address String Uint16), representing a remote socket -;; -- a (udp-handle Any), representing a local socket on a kernel-assigned port -;; -- a (udp-listener Uint16), representing a local socket on a user-assigned port -;; Note that udp-handle-ids must be chosen carefully: they are scoped -;; to the local dataspace, i.e. shared between processes in that -;; dataspace, so processes must make sure not to accidentally clash in -;; handle ID selection. -(struct udp-remote-address (host port) #:prefab) -(struct udp-handle (id) #:prefab) -(struct udp-listener (port) #:prefab) - -(define (udp-address? x) - (or (udp-remote-address? x) - (udp-local-address? x))) - -(define (udp-local-address? x) - (or (udp-handle? x) - (udp-listener? x))) - -;; A UdpMembership is a (udp-multicast-group-member UdpLocalAddress String String), -;; where the latter two arguments correspond to the last two arguments -;; of `udp-multicast-join-group!`. -(assertion-struct udp-multicast-group-member (local-address group-address interface)) - -;; A UdpLoopback is a (udp-multicast-loopback UdpLocalAddress Boolean). -(assertion-struct udp-multicast-loopback (local-address enabled?)) - -;; A UdpPacket is a (udp-packet UdpAddress UdpAddress Bytes), and -;; represents a packet appearing on our local "subnet" of the full UDP -;; network, complete with source, destination and contents. -(message-struct udp-packet (source destination body)) - -(spawn #:name 'udp-driver - (during/spawn (observe ($ local-addr (udp-listener _))) - #:name local-addr - (udp-main local-addr)) - (during/spawn (observe ($ local-addr (udp-handle _))) - #:name local-addr - (udp-main local-addr))) - -;; UdpLocalAddress -> Void -(define (udp-main local-addr) - (define socket (udp:udp-open-socket #f #f)) - - (match local-addr - [(udp-listener port) (udp:udp-bind! socket #f port #t)] - [(udp-handle _) (udp:udp-bind! socket #f 0)]) ;; kernel-allocated port number - - (define control-ch (make-channel)) - (thread (lambda () (udp-receiver-thread local-addr socket control-ch))) - (signal-background-activity! +1) - (on-stop (channel-put control-ch 'quit)) - - (assert local-addr) - (stop-when (retracted (observe local-addr))) - - (during (udp-multicast-group-member local-addr $group $interface) - (on-start (udp:udp-multicast-join-group! socket group interface)) - (on-stop (udp:udp-multicast-leave-group! socket group interface))) - - (on (asserted (udp-multicast-loopback local-addr $enabled)) - (udp:udp-multicast-set-loopback! socket enabled)) - - (on (message (inbound ($ p (udp-packet _ local-addr _)))) - (send! p)) - - (on (message (udp-packet local-addr (udp-remote-address $h $p) $body)) - (udp:udp-send-to* socket h p body))) - -;; UdpLocalAddress UdpSocket Channel -> Void -(define (udp-receiver-thread local-addr socket control-ch) - (define buffer (make-bytes 65536)) - (let loop () - (sync (handle-evt control-ch (match-lambda ['quit (void)])) - (handle-evt (udp:udp-receive!-evt socket buffer) - (lambda (receive-results) - (match-define (list len source-hostname source-port) receive-results) - (ground-send! - (udp-packet (udp-remote-address source-hostname source-port) - local-addr - (subbytes buffer 0 len))) - (loop))))) - (udp:udp-close socket) - (signal-background-activity! -1)) diff --git a/OLD-syndicate/drivers/web.rkt b/OLD-syndicate/drivers/web.rkt deleted file mode 100644 index 5d3b4ac..0000000 --- a/OLD-syndicate/drivers/web.rkt +++ /dev/null @@ -1,351 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(provide (struct-out http-server) - (struct-out http-resource) - (struct-out http-request) - (struct-out http-accepted) - (except-out (struct-out http-response) http-response) - (rename-out [make-http-response http-response] - [http-response ]) - (except-out (struct-out http-response-websocket) http-response-websocket) - (rename-out [make-http-response-websocket http-response-websocket] - [http-response-websocket ]) - (struct-out http-request-peer-details) - (struct-out http-request-cookie) - (struct-out http-response-chunk) - (struct-out websocket-out) - (struct-out websocket-in) - - xexpr->bytes/utf-8) - -(require racket/async-channel) -(require racket/exn) -(require (only-in racket/list flatten)) -(require (only-in racket/string string-append*)) -(require (only-in racket/bytes bytes-append*)) -(require racket/tcp) - -(require net/rfc6455) -(require net/rfc6455/conn-api) -(require net/rfc6455/dispatcher) -(require net/url) - -(require struct-defaults) - -(require web-server/http/bindings) -(require web-server/http/cookie) -(require web-server/http/cookie-parse) -(require web-server/http/request) -(require web-server/http/request-structs) -(require web-server/http/response) -(require web-server/http/response-structs) -(require web-server/private/connection-manager) -(require (only-in web-server/private/util lowercase-symbol!)) -(require web-server/dispatchers/dispatch) - -(require xml) - -(module+ test (require rackunit)) - -(define-logger syndicate/drivers/web) - -(define (url-path->resource-path up) - (define elements (for/list [(p (in-list up))] - (match-define (path/param path-element params) p) - (list* path-element params))) - (foldr (lambda (e acc) (append e (list acc))) '() elements)) - -(define (build-headers hs) - (for/list ((h (in-list hs))) - (header (string->bytes/utf-8 (symbol->string (car h))) - (string->bytes/utf-8 (cdr h))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; API/Protocol - -(assertion-struct http-server (host port ssl?)) -(assertion-struct http-resource (server path)) - -(assertion-struct http-request (id method resource headers query body)) -(assertion-struct http-accepted (id)) - -(assertion-struct http-response (id code message last-modified-seconds mime-type headers detail)) -;; ^ detail = (U Bytes 'chunked) -(assertion-struct http-response-websocket (id headers)) - -(assertion-struct http-request-peer-details (id local-ip local-port remote-ip remote-port)) -(assertion-struct http-request-cookie (id name value domain path)) - -(message-struct http-response-chunk (id bytes)) - -(message-struct websocket-out (id body)) -(message-struct websocket-in (id body)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Ground messages - -(message-struct web-raw-request (id port connection addresses req control-ch)) -(message-struct web-raw-client-conn (id connection)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define web-server-max-waiting (make-parameter 511)) ;; sockets -(define web-server-connection-manager (make-parameter #f)) -(define web-server-initial-connection-timeout (make-parameter 30)) ;; seconds - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(spawn - #:name 'http-server-factory - - (during (observe (http-request _ _ (http-resource $server _) _ _ _)) - (assert server)) - - (during/spawn (http-server _ $port _) - #:name (list 'http-listener port) - - (define ssl? #f) - (on (asserted (http-server _ port #t)) - (error 'http-listener "SSL service not yet implemented")) ;; TODO - - (define cm (or (web-server-connection-manager) (start-connection-manager))) - - (define listener (tcp-listen port (web-server-max-waiting) #t)) - (define listener-control (make-channel)) - (thread (lambda () - (let loop () - (sync (handle-evt (tcp-accept-evt listener) - (lambda (ports) - (connection-thread port cm ports) - (loop))) - (handle-evt listener-control - (match-lambda - [(list 'quit k-ch) - (tcp-close listener) - (signal-background-activity! -1) - (channel-put k-ch (void))])))))) - (signal-background-activity! +1) - - (on-start (log-syndicate/drivers/web-debug "Starting listener on port ~v" port)) - (on-stop (define k-ch (make-channel)) - (log-syndicate/drivers/web-debug "Stopping listener on port ~v" port) - (channel-put listener-control (list 'quit k-ch)) - (channel-get k-ch) - (log-syndicate/drivers/web-debug "Stopped listener on port ~v" port)) - - (on (message (inbound (web-raw-request $id port $conn $addresses $lowlevel-req $control-ch))) - (spawn #:name (list 'http-request id) - (define root-facet (current-facet)) - - (define method - (string->symbol (string-downcase (bytes->string/latin-1 (request-method lowlevel-req))))) - (define resource (http-resource (req->http-server lowlevel-req port ssl?) - (url-path->resource-path - (url-path (request-uri lowlevel-req))))) - - (assert (http-request id - method - resource - (request-headers lowlevel-req) - (url-query (request-uri lowlevel-req)) - (request-post-data/raw lowlevel-req))) - - (for [(c (request-cookies lowlevel-req))] - (match-define (client-cookie n v d p) c) - (assert (http-request-cookie id n v d p))) - - (match-let ([(list Lip Lport Rip Rport) addresses]) - (assert (http-request-peer-details id Lip Lport Rip Rport))) - - (define (respond! resp) - (match-define (http-response _ c m lms mime-type headers body) resp) - (define hs (build-headers headers)) - (channel-put control-ch - (list 'response - (response/full c m lms mime-type hs (flatten body))))) - - (define (respond/chunked! resp) - (match-define (http-response _ c m lms mime-type headers _) resp) - (define hs (build-headers headers)) - (define stream-ch (make-async-channel)) - (define (output-writer op) - (match (async-channel-get stream-ch) - [#f (void)] - [bss (for [(bs bss)] (write-bytes bs op)) - ;; (flush-output op) ;; seemingly does nothing. TODO - (output-writer op)])) - (react (stop-when (retracted resp)) - (on-stop (async-channel-put stream-ch #f) - (stop-facet root-facet)) - (on (message (http-response-chunk id $chunk)) - (async-channel-put stream-ch (flatten chunk))) - (on-start (channel-put control-ch - (list 'response - (response c m lms mime-type hs output-writer)))))) - - (define (respond/websocket! headers) - (define ws-ch (make-channel)) - (define hs (build-headers headers)) - (react (stop-when (retracted (http-response-websocket id headers))) - (on-start (channel-put control-ch (list 'websocket hs ws-ch))) - (on-stop (channel-put ws-ch 'quit) - (stop-facet root-facet)) - (on (message (websocket-out id $body)) - (define flat (flatten body)) - (define payload (cond [(null? flat) ""] - [(bytes? (car flat)) (bytes-append* flat)] - [(string? (car flat)) (string-append* flat)] - [else (error 'respond/websocket! - "Bad payload: mixed content: ~v" - flat)])) - (channel-put ws-ch (list 'send payload))) - (on (message (inbound (websocket-in id $body))) - (if (eof-object? body) - (stop-current-facet) - (send! (websocket-in id body)))))) - - (field [respondent-exists? #f]) - (on-start (for [(i 3)] (flush!)) ;; TODO: UGHHHH - (when (not (respondent-exists?)) - (stop-facet root-facet - (respond! (make-http-response #:code 404 - #:message #"Not found" - id - (xexpr->bytes/utf-8 - `(html (h1 "Not found")))))))) - - (on (asserted (http-accepted id)) - (respondent-exists? #t) - (react - (stop-when (retracted (http-accepted id)) - (stop-facet root-facet - (respond! (make-http-response #:code 500 - #:message #"Server error" - id - (xexpr->bytes/utf-8 - `(html (h1 "Server error"))))))) - (stop-when (asserted ($ resp (http-response id _ _ _ _ _ $detail))) - (match detail - ['chunked (respond/chunked! resp)] - [_ (stop-facet root-facet (respond! resp))])) - (stop-when (asserted (http-response-websocket id $headers)) - (respond/websocket! headers)))))))) - -(define (req->http-server r port ssl?) - (match (assq 'host (request-headers r)) - [#f - (http-server #f port ssl?)] - [(cons _ (regexp #px"(.*):(\\d+)" (list _ host port))) - (http-server host (string->number port) ssl?)] - [(cons _ host) - (http-server host port ssl?)])) - -(define (connection-thread listen-port cm connection-ports) - (signal-background-activity! +1) - (thread - (lambda () - (match-define (list i o) connection-ports) - ;; Deliberately construct an empty custodian for the connection. Killing the connection - ;; abruptly can cause deadlocks since the connection thread communicates with Syndicate - ;; via synchronous channels. - (define conn - (new-connection cm (web-server-initial-connection-timeout) i o (make-custodian) #f)) - (define addresses - (let-values (((Lip Lport Rip Rport) (tcp-addresses i #t))) - (list Lip Lport Rip Rport))) - (define control-ch (make-channel)) - (let do-request () - (define-values (req should-close?) - (with-handlers ([exn:fail? (lambda (e) (values #f #f))]) - (read-request conn listen-port tcp-addresses))) - (when req - (define id (gensym 'web)) - (ground-send! (inbound (web-raw-request id listen-port conn addresses req control-ch))) - (sync (handle-evt control-ch - (match-lambda - [(list 'websocket reply-headers ws-ch) - (with-handlers ((exn:dispatcher? - (lambda (_e) - (define resp - (response/full 400 - #"Bad request" - (current-seconds) - #"text/plain" - (list) - (list))) - (output-response/method conn - resp - (request-method req)) - (drain-ws-ch! ws-ch)))) - ((make-general-websockets-dispatcher - (websocket-connection-main id ws-ch) - (lambda _args (values reply-headers (void)))) - conn req))] - [(list 'response resp) - (output-response/method conn resp (request-method req)) - (when (not should-close?) - (do-request))]))))) - (with-handlers ([exn:fail? (lambda (e) (values #f #f))]) (close-input-port i)) - (with-handlers ([exn:fail? (lambda (e) (values #f #f))]) (close-output-port o)) - (signal-background-activity! -1)))) - -(define ((websocket-connection-main id ws-ch) wsc _ws-connection-state) - (define quit-seen? #f) - (define (shutdown!) - (ground-send! (inbound (websocket-in id eof))) - (with-handlers ([(lambda (e) #t) - (lambda (e) (log-syndicate/drivers/web-error - "Unexpected ws-close! error: ~a" - (if (exn? e) - (exn->string e) - (format "~v" e))))]) - (ws-close! wsc))) - (with-handlers [(exn:fail:network? (lambda (e) (shutdown!))) - (exn:fail:port-is-closed? (lambda (e) (shutdown!))) - (exn:fail? (lambda (e) - (log-syndicate/drivers/web-error "Unexpected websocket error: ~a" - (exn->string e)) - (shutdown!)))] - (let loop () - (sync (handle-evt (ws-recv-evt wsc #:payload-type 'auto) - (lambda (msg) - (ground-send! (inbound (websocket-in id msg))) - (loop))) - (handle-evt ws-ch (match-lambda - ['quit - (set! quit-seen? #t) - (void)] - [(list 'send m) - (ws-send! wsc m #:payload-type (if (bytes? m) 'binary 'text)) - (loop)])))) - (ws-close! wsc)) - (when (not quit-seen?) - (drain-ws-ch! ws-ch))) - -(define (drain-ws-ch! ws-ch) - (when (not (equal? (channel-get ws-ch) 'quit)) - (drain-ws-ch! ws-ch))) - -;; D-: uck barf -;; TODO: something to fix this :-/ -(define (exn:fail:port-is-closed? e) - (and (exn:fail? e) - (regexp-match #px"port is closed" (exn-message e)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(begin-for-declarations - (define-struct-defaults make-http-response http-response - (#:code [http-response-code 200] - #:message [http-response-message #"OK"] - #:last-modified-seconds [http-response-last-modified-seconds (current-seconds)] - #:mime-type [http-response-mime-type #"text/html"] - #:headers [http-response-headers '()])) - (define-struct-defaults make-http-response-websocket http-response-websocket - (#:headers [http-response-websocket-headers '()]))) - -(define (xexpr->bytes/utf-8 #:preamble [preamble #""] xexpr) - (bytes-append preamble (string->bytes/utf-8 (xexpr->string xexpr)))) diff --git a/OLD-syndicate/functional-queue.rkt b/OLD-syndicate/functional-queue.rkt deleted file mode 100644 index 4b93245..0000000 --- a/OLD-syndicate/functional-queue.rkt +++ /dev/null @@ -1,107 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang racket/base - -(provide make-queue - queue? - enqueue - enqueue-all - queue-prepare-for-dequeue - dequeue - queue-last - list->queue - queue->list - queue-length - queue-empty? - queue-append - queue-append-list - queue-extract - queue-filter - queue-remove - queue-partition) - -(require (only-in racket/list partition)) - -(struct queue (head tail) #:transparent) - -(define (make-queue) - (queue '() '())) - -(define (enqueue q v) - (queue (queue-head q) - (cons v (queue-tail q)))) - -(define (enqueue-all q v) - (queue (queue-head q) - (append (reverse v) (queue-tail q)))) - -(define (queue-prepare-for-dequeue q) - (if (null? (queue-head q)) - (queue (reverse (queue-tail q)) '()) - q)) - -(define (dequeue q) - (let ((q1 (queue-prepare-for-dequeue q))) - (values (car (queue-head q1)) - (queue (cdr (queue-head q1)) (queue-tail q1))))) - -;; PRECONDITION: no `dequeue`s have happened since last `enqueue` or `enqueue-all` -(define (queue-last q) - (car (queue-tail q))) - -(define (list->queue xs) - (queue xs '())) - -(define (queue->list q) - (append (queue-head q) (reverse (queue-tail q)))) - -(define (queue-length q) - (+ (length (queue-head q)) - (length (queue-tail q)))) - -(define (queue-empty? q) - (and (null? (queue-head q)) - (null? (queue-tail q)))) - -(define (queue-append q1 q2) - (queue (append (queue-head q1) - (reverse (queue-tail q1)) - (queue-head q2)) - (queue-tail q2))) - -(define (queue-append-list q1 xs) - (queue (queue-head q1) - (append (reverse xs) (queue-tail q1)))) - -(define (queue-extract q predicate [default-value #f]) - (let search-head ((head (queue-head q)) - (rejected-head-rev '())) - (cond - ((null? head) (let search-tail ((tail (reverse (queue-tail q))) - (rejected-tail-rev '())) - (cond - ((null? tail) (values default-value q)) - ((predicate (car tail)) (values (car tail) - (queue (queue-head q) - (append (reverse (cdr tail)) - rejected-tail-rev)))) - (else (search-tail (cdr tail) (cons (car tail) rejected-tail-rev)))))) - ((predicate (car head)) (values (car head) - (queue (append (reverse rejected-head-rev) - (cdr head)) - (queue-tail q)))) - (else (search-head (cdr head) (cons (car head) rejected-head-rev)))))) - -(define (queue-filter pred q) - (queue (filter pred (queue-head q)) - (filter pred (queue-tail q)))) - -(define (queue-remove item q) - (list->queue (remove item (queue->list q)))) - -(define (queue-partition pred q) - (define-values (head-t head-f) (partition pred (queue-head q))) - (define-values (tail-t tail-f) (partition pred (queue-tail q))) - (values (queue head-t tail-t) - (queue head-f tail-f))) diff --git a/OLD-syndicate/ground.rkt b/OLD-syndicate/ground.rkt deleted file mode 100644 index aa0a0a2..0000000 --- a/OLD-syndicate/ground.rkt +++ /dev/null @@ -1,106 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang racket/base -;; Breaking the infinite tower of nested dataspaces, connecting to Racket at the fracture line. - -(provide current-ground-event-async-channel - ground-send! - ground-assert! - ground-retract! - signal-background-activity! - extend-ground-boot! - run-ground) - -(define-logger syndicate/ground) - -(require racket/async-channel) -(require racket/set) -(require racket/match) -(require racket/list) -(require "dataspace.rkt") -(require "syntax.rkt") - -(define current-ground-event-async-channel (make-parameter #f)) -(define *ground-boot-extensions* '()) - -(define (ground-enqueue! item) - (async-channel-put (current-ground-event-async-channel) item)) - -(define (ground-send! body) - (ground-enqueue! (lambda (ac) (enqueue-send! ac body)))) - -(define (ground-assert! assertion) - (ground-enqueue! (lambda (ac) (adhoc-assert! ac assertion)))) - -(define (ground-retract! assertion) - (ground-enqueue! (lambda (ac) (adhoc-retract! ac assertion)))) - -(define (signal-background-activity! delta) - (ground-enqueue! delta)) - -(define (extend-ground-boot! proc) - (set! *ground-boot-extensions* (cons proc *ground-boot-extensions*))) - -(define (run-ground* boot-proc) - (define ch (make-async-channel)) - (parameterize ((current-ground-event-async-channel ch)) - (define ground-event-relay-actor #f) - (define background-activity-count 0) - - (define (handle-ground-event-item item) - (match item - [(? procedure? proc) - (push-script! ground-event-relay-actor - (lambda () (proc ground-event-relay-actor)))] - [(? number? delta) - (set! background-activity-count (+ background-activity-count delta))])) - - (define (drain-external-events) - (define item (async-channel-try-get ch)) - (when item - (handle-ground-event-item item) - (drain-external-events))) - - (define ground-event-relay-evt - (handle-evt ch (lambda (item) - (handle-ground-event-item item) - (drain-external-events)))) - - (define ds (make-dataspace - (lambda () - (schedule-script! (current-actor) - (lambda () - (spawn #:name 'ground-event-relay - (set! ground-event-relay-actor (current-actor)) - ;; v Adds a dummy endpoint to keep this actor alive - (begin/dataflow (void))))) - (schedule-script! (current-actor) - (lambda () - (boot-proc) - (let ((extensions (reverse *ground-boot-extensions*))) - (set! *ground-boot-extensions* '()) - (for [(p (in-list extensions))] (p)))))))) - - (let loop () - (define work-remaining? (run-scripts! ds)) - (define events-expected? (positive? background-activity-count)) - (log-syndicate/ground-debug "GROUND: ~a; ~a background activities" - (if work-remaining? "busy" "idle") - background-activity-count) - (cond - [events-expected? - (sync ground-event-relay-evt (if work-remaining? (system-idle-evt) never-evt)) - (loop)] - [work-remaining? - (sync ground-event-relay-evt (system-idle-evt)) - (loop)] - [else - (sync (handle-evt ground-event-relay-evt (lambda _ (loop))) (system-idle-evt))])))) - -(define (run-ground boot-proc) - (if (equal? (getenv "SYNDICATE_PROFILE") "ground") - (let () - (local-require profile) - (profile (run-ground* boot-proc))) - (run-ground* boot-proc))) diff --git a/OLD-syndicate/lang.rkt b/OLD-syndicate/lang.rkt deleted file mode 100644 index a9de987..0000000 --- a/OLD-syndicate/lang.rkt +++ /dev/null @@ -1,118 +0,0 @@ -#lang racket/base -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -(provide (rename-out [module-begin #%module-begin]) - activate - require/activate - current-ground-dataspace - current-activated-modules - begin-for-declarations ;; TODO: this seems like a horrible hack - (except-out (all-from-out racket/base) #%module-begin sleep) - (all-from-out racket/match) - (all-from-out "main.rkt") - (for-syntax (all-from-out racket/base))) - -(require racket/match) -(require "main.rkt") -(require (for-syntax racket/base syntax/kerncase)) - -(define-syntax (activate stx) - (syntax-case stx () - [(_ module-path ...) - (syntax/loc stx - (begin - (let () - (local-require (submod module-path syndicate-main)) - (activate!)) - ...))])) - -(define-syntax (require/activate stx) - (syntax-case stx () - [(_ module-path ...) - (syntax/loc stx - (begin - (require module-path ...) - (activate module-path ...)))])) - -(define-syntax-rule (begin-for-declarations decl ...) - (begin decl ...)) - -(define current-ground-dataspace (make-parameter #f)) -(define current-activated-modules (make-parameter #f)) - -(define-syntax (module-begin stx) - (unless (eq? (syntax-local-context) 'module-begin) - (raise-syntax-error #f "allowed only around a module body" stx)) - (syntax-case stx () - [(_ forms ...) - (let () - - (define (accumulate-actions activation-forms final-forms forms) - (cond - [(null? forms) - (define final-stx - #`(#%module-begin - ;---------------------------------------- - ; The final module has three pieces: - ; - a `syndicate-main` submodule, for activation - ; - a `main` submodule, for programs - ; - actual definitions, for everything else. - ; The `main` submodule is split into two pieces, - ; in order to initialise defaults that can then - ; be overridden by the module being compiled. - - (module+ syndicate-main - (provide activate!* activate!) - (define (activate!*) - #,@(reverse activation-forms) - (void)) - (define (activate!) - (when (not (hash-has-key? (current-activated-modules) activate!*)) - (hash-set! (current-activated-modules) activate!* #t) - (activate!*)))) - - (module+ main (current-ground-dataspace run-ground)) - - #,@(reverse final-forms) - - (module+ main - (require (submod ".." syndicate-main)) - (parameterize ((current-activated-modules (make-hasheq))) - ((current-ground-dataspace) activate!))) - - ;---------------------------------------- - )) - ;;(pretty-print (syntax->datum final-stx)) - final-stx] - - [else - (syntax-case (local-expand (car forms) - 'module - (append (list #'module+ - #'begin-for-declarations) - (kernel-form-identifier-list))) () - [(head rest ...) - (cond - [(free-identifier=? #'head #'begin) - (accumulate-actions activation-forms - final-forms - (append (syntax->list #'(rest ...)) (cdr forms)))] - [(ormap (lambda (i) (free-identifier=? #'head i)) - (syntax->list #'(define-values define-syntaxes begin-for-syntax - module module* module+ - #%module-begin - #%require #%provide - begin-for-declarations))) - (accumulate-actions activation-forms - (cons (car forms) final-forms) - (cdr forms))] - [else - (accumulate-action (car forms) activation-forms final-forms (cdr forms))])] - [non-pair-syntax - (accumulate-action (car forms) activation-forms final-forms (cdr forms))])])) - - (define (accumulate-action action activation-forms final-forms remaining-forms) - (accumulate-actions (cons action activation-forms) final-forms remaining-forms)) - - (accumulate-actions '() '() (syntax->list #'(forms ...))))])) diff --git a/OLD-syndicate/mc/mc-chat-client.rkt b/OLD-syndicate/mc/mc-chat-client.rkt deleted file mode 100644 index ba57225..0000000 --- a/OLD-syndicate/mc/mc-chat-client.rkt +++ /dev/null @@ -1,28 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(require/activate "udp-dataspace.rkt") -(require/activate syndicate/drivers/external-event) -(require (only-in racket/port read-bytes-line-evt)) -(require racket/random file/sha1) - -(message-struct speak (who what)) -(assertion-struct present (who)) - -(spawn (define me (bytes->hex-string (crypto-random-bytes 8))) - (define stdin-evt (read-bytes-line-evt (current-input-port) 'any)) - - (assert (mcds-outbound (present me))) - - (on (message (inbound (external-event stdin-evt (list $line)))) - (if (eof-object? line) - (stop-current-facet) - (send! (mcds-outbound (speak me line))))) - - (during (mcds-inbound (present $user)) - (on-start (printf "~a arrived\n" user)) - (on-stop (printf "~a left\n" user)) - (on (message (mcds-inbound (speak user $text))) - (printf "~a says '~a'\n" user text)))) diff --git a/OLD-syndicate/mc/udp-dataspace.rkt b/OLD-syndicate/mc/udp-dataspace.rkt deleted file mode 100644 index 2fa94cd..0000000 --- a/OLD-syndicate/mc/udp-dataspace.rkt +++ /dev/null @@ -1,123 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(provide (struct-out mcds-inbound) - (struct-out mcds-outbound)) - -(require/activate syndicate/drivers/timer) -(require/activate syndicate/drivers/udp) -(require racket/random file/sha1) -(require syndicate/skeleton) -(require syndicate/term) -(require preserves) - -(define-logger mcds) - -(struct mcds-inbound (assertion) #:prefab) -(struct mcds-outbound (assertion) #:prefab) - -(struct mcds-change (peer type assertion) #:transparent) -(struct mcds-demand () #:transparent) - -(struct mcds-relevant (assertion peer) #:transparent) - -(define group-address "239.192.57.49") ;; falls within Organization Local Scope (see RFC 2365) -(define group-port 5999) ;; make sure your firewall is open to UDP on this port -(define group-target (udp-remote-address group-address group-port)) - -(define *assertion-lifetime* 30000) -(define *assertion-refresh* (* 0.9 *assertion-lifetime*)) - -(define (send-packet! h packet) - (send! (udp-packet h group-target (preserve->bytes packet)))) - -(define (packet-statistics h) - (define report-period 10000) - (field [packet-count 0] - [byte-count 0] - [reset-time (+ (current-inexact-milliseconds) report-period)]) - (on (message (udp-packet _ h $body)) - (packet-count (+ (packet-count) 1)) - (byte-count (+ (byte-count) (bytes-length body)))) - (on (asserted (later-than (reset-time))) - (reset-time (+ (reset-time) report-period)) - (log-mcds-info "~a packets, ~a bytes received in ~a ms = ~a Hz, ~a bytes/s" - (packet-count) - (byte-count) - report-period - (/ (packet-count) (/ report-period 1000.0)) - (/ (byte-count) (/ report-period 1000.0))) - (packet-count 0) - (byte-count 0))) - -(spawn (during (observe (mcds-inbound _)) (assert (mcds-demand))) - (during (mcds-outbound _) (assert (mcds-demand))) - - (during/spawn (mcds-demand) - (define me (crypto-random-bytes 8)) - (define h (udp-listener group-port)) - (during h - (assert (udp-multicast-group-member h group-address #f)) - (assert (udp-multicast-loopback h #t)) - - (packet-statistics h) - - (on (message (udp-packet _ h $body)) - (spawn* - ;; (log-mcds-info "received: ~v" body) - (match (bytes->preserve body) - [(list peer type assertion) - ;; (log-mcds-info "~v ~v ~v" peer type assertion) - (send! (mcds-change peer type assertion))]))) - - (on (message (mcds-change $peer '+ $assertion)) - (spawn - (define expiry (+ (current-inexact-milliseconds) *assertion-lifetime*)) - (assert (mcds-inbound assertion)) - - (when (observe? assertion) - (define pattern (observe-specification assertion)) - (define x (mcds-outbound pattern)) - (add-observer-endpoint! - (lambda () x) - #:on-add - (lambda (captured-values) - ;; TODO: flawed?? Needs visibility-restriction, or some other way of - ;; ignoring the opaque placeholders! - (assert! (mcds-relevant (instantiate-term->value pattern - captured-values - #:visibility-restriction-proj - #f) - peer))))) - - (stop-when (message (mcds-change peer '- assertion))) - (stop-when (asserted (later-than expiry))) - (stop-when (retracted (mcds-demand))))) - - (during (observe (mcds-inbound $pattern)) - (assert (mcds-relevant (observe pattern) me)) - (assert (mcds-outbound (observe pattern)))) - - (during (mcds-relevant $assertion _) - (during (mcds-outbound assertion) - (define (refresh!) (send-packet! h (list me '+ assertion))) - (on-start (refresh!)) - (on-stop (send-packet! h (list me '- assertion))) - - (field [deadline (+ (current-inexact-milliseconds) *assertion-refresh*)]) - (on (asserted (later-than (deadline))) - (refresh!) - (deadline (+ (deadline) *assertion-refresh*))) - - (on (asserted (mcds-relevant assertion $peer)) - ;; (log-mcds-info "Peer ~a cares about outbound assertion ~v" peer assertion) - (define soon (+ (current-inexact-milliseconds) 100)) - (when (> (deadline) soon) (deadline soon))))) - - (on (message (mcds-change $peer '! $body)) - (send! (mcds-inbound body))) - - (on (message (mcds-outbound $body)) - (send-packet! h (list me '! body)))))) diff --git a/OLD-syndicate/pattern.rkt b/OLD-syndicate/pattern.rkt deleted file mode 100644 index 2df2f9e..0000000 --- a/OLD-syndicate/pattern.rkt +++ /dev/null @@ -1,242 +0,0 @@ -#lang racket/base -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -(provide (struct-out discard) - (struct-out capture) - - (for-syntax analyse-pattern - instantiate-pattern->pattern - instantiate-pattern->value - desc->key - desc->skeleton-proj - desc->skeleton-stx - desc->capture-proj - desc->capture-names - desc->assertion-stx) - - (all-from-out "pattern-expander.rkt")) - -(require (for-syntax racket/base)) -(require (for-syntax racket/match)) -(require (for-syntax racket/struct-info)) -(require (for-syntax syntax/stx)) -(require "pattern-expander.rkt") - -(struct discard () #:prefab) -(struct capture (detail) #:prefab) - -;;--------------------------------------------------------------------------- -;; ## Analysing patterns -;; -;; Patterns generate several pieces, which work together to form -;; routing tables: -;; -;; - the *assertion* allows observers of observers to function; -;; - the `Skeleton` classifies the shape of the pattern; -;; - two `SkProj`s select constant and variable pieces from a pattern, respectively; and -;; - a `SkKey` specifies constant pieces of a pattern, matched against one of the `SkProj`s. -;; -;; The other `SkProj` generates a second `SkKey` which is used as the -;; input to a handler function. - -(define-for-syntax orig-insp - (variable-reference->module-declaration-inspector (#%variable-reference))) - -(begin-for-syntax - (define (dollar-id? stx) - (and (identifier? stx) - (char=? (string-ref (symbol->string (syntax-e stx)) 0) #\$))) - - (define (undollar stx) - (and (dollar-id? stx) - (datum->syntax stx (string->symbol (substring (symbol->string (syntax-e stx)) 1))))) - - (define (discard-id? stx) - (and (identifier? stx) - (free-identifier=? #'_ stx))) - - (define (id-value stx) - (and (identifier? stx) - (syntax-local-value stx (lambda () #f)))) - - (define (list-id? stx) - (and (identifier? stx) - (free-identifier=? #'list stx))) - - (define (vector-id? stx) - (and (identifier? stx) - (free-identifier=? #'vector stx))) - - (define (analyse-pattern stx) - (define disarmed-stx (syntax-disarm stx orig-insp)) - (syntax-case disarmed-stx ($ quasiquote unquote quote) - [(expander args ...) - (pattern-expander-id? #'expander) - (pattern-expander-transform disarmed-stx - (lambda (result) - (analyse-pattern (syntax-rearm result stx))))] - - ;; Extremely limited support for quasiquoting and quoting - [(quasiquote (unquote p)) (analyse-pattern #'p)] - [(quasiquote (p ...)) (analyse-pattern #'(list (quasiquote p) ...))] - [(quasiquote p) (list 'atom stx)] - [(quote p) (list 'atom stx)] - - [(ctor piece ...) - (struct-info? (id-value #'ctor)) - (list* 'compound - (extract-struct-info (id-value #'ctor)) - (stx-map analyse-pattern #'(piece ...)))] - [(list piece ...) - (list-id? #'list) - (list* 'compound - 'list - (stx-map analyse-pattern #'(piece ...)))] - [(vector piece ...) - (vector-id? #'vector) - (list* 'compound - 'vector - (stx-map analyse-pattern #'(piece ...)))] - [id - (dollar-id? #'id) - (list 'capture (undollar #'id) (list 'discard))] - [($ id p) - (list 'capture #'id (analyse-pattern #'p))] - [id - (discard-id? #'id) - (list 'discard)] - [_ - (list 'atom stx)])) - - (define (instantiate-pattern->pattern stx) - (define disarmed-stx (syntax-disarm stx orig-insp)) - (syntax-case disarmed-stx ($ quasiquote unquote quote) - [(expander args ...) - (pattern-expander-id? #'expander) - (pattern-expander-transform disarmed-stx - (lambda (result) - (instantiate-pattern->pattern (syntax-rearm result stx))))] - - ;; Extremely limited support for quasiquoting and quoting - [(quasiquote (unquote p)) (instantiate-pattern->pattern #'p)] - [(quasiquote (p ...)) (instantiate-pattern->pattern #'(list (quasiquote p) ...))] - [(quasiquote p) stx] - [(quote p) stx] - - [(ctor piece ...) - (struct-info? (id-value #'ctor)) - (quasisyntax/loc stx (ctor #,@(stx-map instantiate-pattern->pattern #'(piece ...))))] - [(list piece ...) - (list-id? #'list) - (quasisyntax/loc stx (list #,@(stx-map instantiate-pattern->pattern #'(piece ...))))] - [(vector piece ...) - (vector-id? #'vector) - (quasisyntax/loc stx (vector #,@(stx-map instantiate-pattern->pattern #'(piece ...))))] - [id - (dollar-id? #'id) - (undollar #'id)] - [($ id p) - #'id] - [id - (discard-id? #'id) - #'id] - [other - #'other])) - - (define (instantiate-pattern->value stx) - (define disarmed-stx (syntax-disarm stx orig-insp)) - (syntax-case disarmed-stx ($ quasiquote unquote quote) - [(expander args ...) - (pattern-expander-id? #'expander) - (pattern-expander-transform disarmed-stx - (lambda (result) - (instantiate-pattern->value (syntax-rearm result stx))))] - - ;; Extremely limited support for quasiquoting and quoting - [(quasiquote (unquote p)) (instantiate-pattern->value #'p)] - [(quasiquote (p ...)) (instantiate-pattern->value #'(list (quasiquote p) ...))] - [(quasiquote p) stx] - [(quote p) stx] - - [(ctor piece ...) - (struct-info? (id-value #'ctor)) - (quasisyntax/loc stx (ctor #,@(stx-map instantiate-pattern->value #'(piece ...))))] - [(list piece ...) - (list-id? #'list) - (quasisyntax/loc stx (list #,@(stx-map instantiate-pattern->value #'(piece ...))))] - [(vector piece ...) - (vector-id? #'vector) - (quasisyntax/loc stx (vector #,@(stx-map instantiate-pattern->value #'(piece ...))))] - [id - (dollar-id? #'id) - (undollar #'id)] - [($ id p) - #'id] - [id - (discard-id? #'id) - #'(discard)] - [other - #'other]))) - -;;--------------------------------------------------------------------------- - -(begin-for-syntax - (define (select-pattern-leaves desc capture-fn atom-fn) - (define (walk-node key-rev desc) - (match desc - [`(compound ,_ ,pieces ...) (walk-edge 0 key-rev pieces)] - [`(capture ,name-stx ,p) (append (capture-fn key-rev name-stx) (walk-node key-rev p))] - [`(discard) (list)] - [`(atom ,v) (atom-fn key-rev v)])) - (define (walk-edge index key-rev pieces) - (match pieces - ['() '()] - [(cons p pieces) (append (walk-node (cons index key-rev) p) - (walk-edge (+ index 1) key-rev pieces))])) - (walk-node '() desc)) - - (define (desc->key desc) - (select-pattern-leaves desc - (lambda (key-rev name-stx) (list)) - (lambda (key-rev atom) (list atom)))) - - (define (desc->skeleton-proj desc) - (select-pattern-leaves desc - (lambda (key-rev name-stx) (list)) - (lambda (key-rev atom) (list (reverse key-rev))))) - - (define (desc->skeleton-stx desc) - (match desc - [`(compound list ,pieces ...) - #`(list 'list #,@(map desc->skeleton-stx pieces))] - [`(compound vector ,pieces ...) - #`(list 'vector #,@(map desc->skeleton-stx pieces))] - [`(compound (,struct-type ,_ctor ,_pred ,_getters ,_setters ,_super) ,pieces ...) - #`(list #,struct-type #,@(map desc->skeleton-stx pieces))] - [`(capture ,_ ,p) (desc->skeleton-stx p)] - [`(discard) #'#f] - [`(atom ,atom-stx) #'#f])) - - (define (desc->capture-proj desc) - (select-pattern-leaves desc - (lambda (key-rev name-stx) (list (reverse key-rev))) - (lambda (key-rev atom) (list)))) - - (define (desc->capture-names desc) - (select-pattern-leaves desc - (lambda (key-rev name-stx) (list name-stx)) - (lambda (key-rev atom) (list)))) - - (define (desc->assertion-stx desc) - (match desc - [`(compound list ,pieces ...) - #`(list #,@(map desc->assertion-stx pieces))] - [`(compound vector ,pieces ...) - #`(vector #,@(map desc->assertion-stx pieces))] - [`(compound (,_struct-type ,ctor ,_pred ,_getters ,_setters ,_super) ,pieces ...) - #`(#,ctor #,@(map desc->assertion-stx pieces))] - [`(capture ,_ ,p) #`(capture #,(desc->assertion-stx p))] - [`(discard) #'(discard)] - [`(atom ,v) v])) - ) diff --git a/OLD-syndicate/protocol/credit.rkt b/OLD-syndicate/protocol/credit.rkt deleted file mode 100644 index f46c9d2..0000000 --- a/OLD-syndicate/protocol/credit.rkt +++ /dev/null @@ -1,75 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate - -(provide (all-defined-out)) - -(require "../functional-queue.rkt") - -(define-logger syndicate/protocol/credit) - -;; (credit* Any (U Number 'reset)) -;; (credit Any ... (U Number 'reset)) -;; -;; Send this message to issue `amount` units of credit (in the context -;; of credit-based flow control) to the given `context`. -;; -;; A `context` may identify any essentially asynchronous stream where -;; either the possibility of overwhelming a consumer exists, or the -;; need for occasionally changing the settings of a producer in an -;; atomic way exists. For example, reading HTTP headers proceeds -;; line-by-line until the body is reached, at which point it proceeds -;; byte-by-byte. -;; -;; The `amount` may either be a number or `'reset`, which should zero -;; out (discard) any available credit. In particular, it may be -;; `+inf.0`, effectively turning credit-based flow control off for the -;; named context. -;; -;; See also https://eighty-twenty.org/2011/05/15/origins-of-ack-and-flow-control. -;; -(message-struct credit* (context amount)) - -(define-match-expander credit - (syntax-rules () [(_ context ... amount) (credit* (list context ...) amount)]) - (syntax-rules () [(_ context ... amount) (credit* (list context ...) amount)])) - -(define (issue-credit! #:amount [amount 1] . context) - (send! (credit* context amount))) - -(define (issue-unbounded-credit! . context) - (send! (credit* context +inf.0))) - -(define (make-flow-controlled-sender . context) - (make-flow-controlled-sender* context)) - -(define (make-flow-controlled-sender* context) - (field [q (make-queue)] - [item-credit 0]) - (when (log-level? syndicate/protocol/credit-logger 'debug) - (begin/dataflow - (log-syndicate/protocol/credit-debug - "context ~a, queue length ~a, credit ~a" - context - (queue-length (q)) - (item-credit)))) - (begin/dataflow - (when (and (positive? (item-credit)) - (not (queue-empty? (q)))) - (define-values (item new-q) (dequeue (q))) - (send! item) - (q new-q) - (item-credit (- (item-credit) 1)))) - (on (message (credit* context $amount)) - (item-credit (if (eq? amount 'reset) 0 (+ (item-credit) amount)))) - (lambda (item) (q (enqueue (q) item)))) - -;; It's quite possible that credit-based flow control is not the right -;; approach for Syndicate. Using assertions that describe the content -;; of a stream more relationally ought to allow "replay" of -;; information in different contexts; though the trade-off is not only -;; reduced performance, but a need to garbage-collect -;; no-longer-interesting portions of the stream; that is, -;; *acknowledgements*. In a reliable-delivery context, it would appear -;; that at least one of acks or flow-control is required! (?!?) diff --git a/OLD-syndicate/protocol/instance.rkt b/OLD-syndicate/protocol/instance.rkt deleted file mode 100644 index c825036..0000000 --- a/OLD-syndicate/protocol/instance.rkt +++ /dev/null @@ -1,16 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang racket/base -;; "Instance" protocol for discriminating among -;; otherwise-indistinguishable entities. - -(provide (struct-out instance)) - -;; (instance Any Any), assertion or message -;; -;; In cases where `spec` can have multiple instantiations, serves to -;; distinguish between them. Each `id` should be unique within its -;; scope. -;; -(struct instance (id spec) #:prefab) diff --git a/OLD-syndicate/reassert.rkt b/OLD-syndicate/reassert.rkt deleted file mode 100644 index 2a4f600..0000000 --- a/OLD-syndicate/reassert.rkt +++ /dev/null @@ -1,38 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate -;; Re-assert an assertion when one of a set of triggering events is seen, after a delay. -;; Building block for building reconnection strategies. - -(provide reassert-on - (struct-out fixed-retry)) - -(require/activate syndicate/drivers/timer) - -(struct fixed-retry (delay-ms) #:transparent - #:property prop:procedure - (lambda (f) (values (fixed-retry-delay-ms f) f))) - -(define-logger syndicate/reassert) - -(define-syntax reassert-on - (syntax-rules () - [(_ assertion #:strategy strategy reset-event ...) - (reassert-on* assertion - #:strategy strategy - (list (lambda (k) (stop-when reset-event (k))) ...))] - [(_ assertion reset-event ...) - (reassert-on assertion #:strategy (fixed-retry 1000) reset-event ...)])) - -(begin-for-declarations - (define (reassert-on* assertion #:strategy strategy event-fns) - (on-start (let reassert ((strategy strategy)) - (react (log-syndicate/reassert-debug "~v: Asserting" assertion) - (assert assertion) - (define (reset) - (log-syndicate/reassert-debug "~v: Resetting with ~v" assertion strategy) - (define-values (delay-ms next-strategy) (strategy)) - (sleep (/ delay-ms 1000.0)) - (reassert next-strategy)) - (for-each (lambda (f) (f reset)) event-fns)))))) diff --git a/OLD-syndicate/reflection.rkt b/OLD-syndicate/reflection.rkt deleted file mode 100644 index fe0629a..0000000 --- a/OLD-syndicate/reflection.rkt +++ /dev/null @@ -1,12 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang racket/base -;; Reflective protocols - -(provide (struct-out terminated)) - -;; (terminated Any (Option Any)) -;; The `actor-name` is the name of the terminated actor. -;; The `reason` is either `#f` or a termination reason, usually an `exn?`. -(struct terminated (actor-name reason) #:transparent) diff --git a/OLD-syndicate/relay.rkt b/OLD-syndicate/relay.rkt deleted file mode 100644 index d10ab01..0000000 --- a/OLD-syndicate/relay.rkt +++ /dev/null @@ -1,157 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang racket/base -;; Cross-layer relaying between adjacent dataspaces -;; TODO: protocol for *clean* shutdown of a dataspace - -;; TODO: Actually elide the need for relays entirely, by allowing an -;; actor to manifest in multiple dataspaces (multiple -;; points-of-attachment), and by placing assertions and subscriptions -;; directly in the dataspace concerned. (Done naively, this would -;; avoid manifesting observed assertions in intermediate nested -;; dataspaces; but then, if anyone cared, they'd be observing the -;; tuples themselves - right?? Oh, maybe observing the observers would -;; be an, er, observable difference.) - -(provide quit-dataspace! - dataspace) - -(require racket/match) -(require racket/set) -(require "assertions.rkt") -(require "dataspace.rkt") -(require "syntax.rkt") -(require "skeleton.rkt") -(require "term.rkt") -(require "bag.rkt") - -(require (for-syntax racket/base)) -(require (for-syntax syntax/parse)) -(require "syntax-classes.rkt") - -(struct *quit-dataspace* () #:transparent) - -;; TODO: inbound^n, outbound^n -- protocol/standard-relay, iow - -(define (quit-dataspace!) - (send! (*quit-dataspace*))) - -(define-syntax (dataspace stx) - (syntax-parse stx - [(_ name:name form ...) - (syntax/loc stx - (let ((ds-name name.N)) - (spawn #:name ds-name - (define outer-facet (current-facet)) - (begin/dataflow (void)) ;; eww. dummy endpoint to keep the root facet alive - (define (schedule-inner!) - (push-script! - (facet-actor outer-facet) - (lambda () - (with-current-facet [outer-facet] - (when (facet-live? outer-facet) - (defer-turn! (lambda () - (when (run-scripts! inner-ds) - (schedule-inner!))))))))) - (define inner-ds (make-dataspace - (lambda () - (schedule-script! - (current-actor) - (lambda () - (spawn #:name (list 'ds-link ds-name) - (boot-relay schedule-inner! - outer-facet)) - (spawn* form ...)))))) - (on-start (schedule-inner!)))))])) - -(define (boot-relay schedule-inner! outer-facet) - (define inbound-endpoints (make-hash)) - (define outbound-endpoints (make-hash)) - - (define inner-facet (current-facet)) - (define inner-actor (current-actor)) - (define inner-ds (actor-dataspace inner-actor)) - - (on (asserted (observe (inbound $x))) - ;; (log-info "~a (asserted (observe (inbound ~v)))" inner-actor x) - (with-current-facet [outer-facet] - (with-non-script-context - (define (make-endpoint) - (define inner-capture-proj - ;; inner-capture-proj accounts for the extra (inbound ...) layer around - ;; assertions - (let ((outer-capture-proj (term->capture-proj x))) - (map (lambda (p) (cons 0 p)) outer-capture-proj))) - (define (rebuild cs) - (instantiate-term->value (inbound x) cs - #:visibility-restriction-proj inner-capture-proj)) - (define ((wrap f) cs) - (f (rebuild cs)) - (schedule-inner!)) - (add-raw-observer-endpoint! - (lambda () x) - #:on-add (wrap (lambda (t) (apply-patch! inner-ds inner-actor (bag t +1)))) - #:on-remove (wrap (lambda (t) (apply-patch! inner-ds inner-actor (bag t -1)))) - #:on-message (wrap (lambda (t) (send-assertion! (dataspace-routing-table inner-ds) t))) - #:cleanup (lambda (cache) - (apply-patch! inner-ds inner-actor (for/bag/count [(cs (in-bag cache))] - (values (rebuild cs) -1))) - (schedule-inner!)))) - (record-endpoint-if-live! outer-facet inbound-endpoints x make-endpoint)))) - - (on (message (*quit-dataspace*)) - (with-current-facet [outer-facet] - (stop-current-facet))) - - (on (retracted (observe (inbound $x))) - ;; (log-info "~a (retracted (observe (inbound ~v)))" inner-actor x) - (with-current-facet [outer-facet] - (with-non-script-context - (remove-endpoint! outer-facet (hash-ref inbound-endpoints x)) - (hash-remove! inbound-endpoints x)))) - - (on (asserted (outbound $x)) - ;; (log-info "~a (asserted (outbound ~v))" inner-actor x) - (with-current-facet [outer-facet] - (with-non-script-context - (record-endpoint-if-live! outer-facet - outbound-endpoints - x - (lambda () - (add-endpoint! outer-facet - "dataspace-relay (outbound ...)" - #t - (lambda () (values x #f)))))))) - - (on (retracted (outbound $x)) - ;; (log-info "~a (retracted (outbound ~v))" inner-actor x) - (with-current-facet [outer-facet] - (with-non-script-context - (remove-endpoint! outer-facet (hash-ref outbound-endpoints x)) - (hash-remove! outbound-endpoints x)))) - - (on (message (outbound $x)) - ;; (log-info "~a (message (outbound ~v))" inner-actor x) - (with-current-facet [outer-facet] - (send! x)))) - -(define (record-endpoint-if-live! f table key ep-adder) - (when (facet-live? f) - ;; - ;; ^ Check that `f` is still alive, because we're (carefully!!) - ;; violating an invariant of `dataspace.rkt` by adding an endpoint - ;; well after the construction of the facet we're in. We may be - ;; executing this handler just after clean shutdown of the facet - ;; by a `quit-dataspace!` request, and in that case we MUST NOT - ;; add any further endpoints because their assertions will not get - ;; removed, because cleanup (as part of `(quit)` processing) has - ;; already been done. - ;; - ;; We don't have to do a similar check before calling - ;; `remove-endpoint!`, because shortly after all (both) calls to - ;; `destroy-endpoint!`, all destroyed endpoints are removed from - ;; the `facet-endpoints` table, ensuring they won't be processed - ;; again. - ;; - (hash-set! table key (ep-adder)))) diff --git a/OLD-syndicate/reload.rkt b/OLD-syndicate/reload.rkt deleted file mode 100644 index 10d4951..0000000 --- a/OLD-syndicate/reload.rkt +++ /dev/null @@ -1,121 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate -;; Crude steps toward reloadable Syndicate modules - -(provide (except-out (struct-out reload-pending) reload-pending) - (rename-out [reload-pending ]) - (rename-out [make-reload-pending reload-pending]) - - stop-when-reloaded - spawn-reloader - spawn-reloader* - reloader-mixin - reloader-mixin*) - -(define-logger syndicate/reload) - -(require file/sha1) -(require (for-syntax racket/base)) -(require racket/rerequire) - -(require/activate syndicate/supervise) -(require/activate syndicate/drivers/filesystem) - -(assertion-struct reloader (pathstr)) -(assertion-struct reload-pending (filename)) - -(define-syntax (make-reload-pending stx) - (syntax-case stx () - [(SELF) - (quasisyntax/loc stx - (reload-pending '#,(path->string (syntax-source #'SELF))))])) - -(define-syntax (stop-when-reloaded stx) - (syntax-case stx () - [(_ body ...) - (quasisyntax/loc stx - (stop-when (asserted (reload-pending '#,(path->string (syntax-source stx)))) - body ...))])) - -(define-syntax (spawn-reloader stx) - (syntax-case stx () - [(_ module-path) - (quasisyntax/loc stx - (spawn-reloader* 'module-path '#,(path->string (syntax-source stx))))])) - -(define (spawn-reloader* module-path loading-module-pathstr) - (match (module-path->path-string module-path) - [#f #f] - [pathstr - (supervise #:name (reloader pathstr) - (stop-when (asserted (reload-pending loading-module-pathstr))) - (reloader-mixin** module-path pathstr)) - #t])) - -(define-syntax-rule (reloader-mixin module-path) - (reloader-mixin* 'module-path)) - -(define (reloader-mixin* module-path) - (define pathstr (module-path->path-string module-path)) - (when (not pathstr) - (error 'reloader-mixin "Cannot deduce source path from module-path ~v" module-path)) - (reloader-mixin** module-path pathstr)) - -(define (module-path->path-string module-path) - (define mpi (module-path-index-join module-path #f)) - (define rpath (module-path-index-resolve mpi)) - (define path (let ((p (resolved-module-path-name rpath))) - (if (pair? p) (car p) p))) - (if (path? path) - (path->string path) - (begin (log-syndicate/reload-error "Could not process module-path ~v" module-path) - #f))) - -(define (file->sha1 p) - (call-with-input-file p sha1)) - -(define (reloader-mixin** module-path pathstr) - (field [reloading? #f]) - (define (reload!) - (when (not (reloading?)) - (reloading? #t) - (react (field [obstacles-cleared? #f] [obstacles-existed? #f]) - (define/query-value obstacles-exist? #f (observe (reload-pending pathstr)) #t - #:on-add (begin (log-syndicate/reload-info "waiting to reload ~v" pathstr) - (obstacles-existed? #t)) - #:on-remove (obstacles-cleared? #t)) - (assert #:when (obstacles-exist?) (reload-pending pathstr)) - (on-start (flush!) - (obstacles-cleared? (not (obstacles-exist?)))) - (stop-when-true (obstacles-cleared?) - (flush!) ;; Wait one turn for effects of newly-cleared obstacles - (log-syndicate/reload-info "(re)loading ~v" pathstr) - (dynamic-rerequire module-path) - (let ((force-reactivation? (obstacles-existed?))) - (when force-reactivation? - (log-syndicate/reload-info "forcing reactivation of ~v" pathstr)) - (spawn* #:name module-path - ((dynamic-require `(submod ,module-path syndicate-main) - (if force-reactivation? 'activate!* 'activate!))))) - (reloading? #f))))) - - (on-start (log-syndicate/reload-debug "reloader ~v starting" pathstr)) - (on-stop (log-syndicate/reload-debug "reloader ~v stopping" pathstr)) - - (field [previous-version 'unknown]) - (define/query-value latest-version 'unknown (file-content pathstr file->sha1 $p) p) - (begin/dataflow - (when (and (not (eq? (latest-version) 'unknown)) - (not (equal? (latest-version) (previous-version)))) - (if (latest-version) - (reload!) - (log-syndicate/reload-warning "Module ~v does not exist" pathstr)) - (previous-version (latest-version))))) - -(module+ main - (require racket/cmdline) - (extend-ground-boot! (lambda () - (define module-path (command-line #:args (module-path) module-path)) - (spawn-reloader* module-path "
")))) diff --git a/OLD-syndicate/supervise.rkt b/OLD-syndicate/supervise.rkt deleted file mode 100644 index dbebff9..0000000 --- a/OLD-syndicate/supervise.rkt +++ /dev/null @@ -1,77 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate -;; Extremely simple single-actor supervision -;; Vastly simplified compared to the available options in OTP - -(provide (struct-out supervisor) - supervise) - -(require racket/exn) - -(require (for-syntax syntax/parse)) -(require "syntax-classes.rkt") -(require "reflection.rkt") - -(require/activate syndicate/drivers/timer) - -(define-logger syndicate/supervise) - -(assertion-struct supervisor (id name)) - -(define-syntax (supervise stx) - (syntax-parse stx - [(_ (~or (~optional (~seq #:name name-expr) #:defaults ([name-expr #'#f]) - #:name "#:name") - (~optional (~seq #:linkage [linkage-expr ...]) #:defaults ([(linkage-expr 1) '()]) - #:name "#:linkage")) - ... - O ...) - (syntax/loc stx - (supervise* name-expr - (lambda () linkage-expr ... (void)) - (lambda () O ...)))])) - -(define (supervise* name0 linkage-thunk root-facet-thunk) - (define id (gensym 'supervisor)) - (define name (or name0 (gensym 'supervisee))) - (spawn #:name (supervisor id name) - #:linkage [(linkage-thunk)] ;; may contain e.g. linkage instructions from during/spawn - - (assert (supervisor id name)) - - (define root-supervisor-facet (current-facet)) - - (define intensity 1) - (define period 5000) ;; milliseconds - (define sleep-time 10) ;; seconds - (field [restarts '()]) - - (define (add-restart!) - (define now (current-inexact-milliseconds)) - (define oldest-to-keep (- now period)) - (restarts (filter (lambda (r) (>= r oldest-to-keep)) (cons now (restarts)))) - (when (> (length (restarts)) intensity) - (log-syndicate/supervise-error - "Supervised process ~s reached max restart intensity. Sleeping for ~a seconds" - name - sleep-time) - (sleep sleep-time))) - - (define (start-supervisee!) - (spawn #:name name - (stop-when (retracted (supervisor id name))) - (root-facet-thunk))) - - (on (message (terminated name $reason)) - (when reason - (log-syndicate/supervise-error "Supervised process ~s died" name) - ;; (log-syndicate/supervise-error - ;; "Supervised process ~s died with exception:\n~a" - ;; name - ;; (if (exn? reason) (exn->string reason) (format "~v" reason))) - (add-restart!) - (start-supervisee!))) - - (on-start (start-supervisee!)))) diff --git a/OLD-syndicate/support/bytes.rkt b/OLD-syndicate/support/bytes.rkt deleted file mode 100644 index 3809423..0000000 --- a/OLD-syndicate/support/bytes.rkt +++ /dev/null @@ -1,14 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang racket/base - -(provide bytes-index) - -;; This should probably be in the standard library. -(define (bytes-index bs b) - (define len (bytes-length bs)) - (let loop ((i 0)) - (cond [(= i len) #f] - [(eqv? (bytes-ref bs i) b) i] - [else (loop (+ i 1))]))) diff --git a/OLD-syndicate/syntax-classes.rkt b/OLD-syndicate/syntax-classes.rkt deleted file mode 100644 index 0617b74..0000000 --- a/OLD-syndicate/syntax-classes.rkt +++ /dev/null @@ -1,28 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang racket/base -;; Common syntax classes. - -(provide (for-syntax assertions - name - snapshot)) - -(require racket/set) - -(require (for-syntax racket/base)) -(require (for-syntax syntax/parse)) -(require (for-syntax syntax/srcloc)) - -(begin-for-syntax - (define-splicing-syntax-class assertions - (pattern (~seq #:assertions [exprs ...])) - (pattern (~seq) #:attr (exprs 1) '())) - - (define-splicing-syntax-class name - (pattern (~seq #:name N)) - (pattern (~seq) #:attr N #'#f)) - - (define-splicing-syntax-class snapshot - (pattern (~seq #:snapshot) #:attr dynamic? #'#f) - (pattern (~seq) #:attr dynamic? #'#t))) diff --git a/OLD-syndicate/syntax.rkt b/OLD-syndicate/syntax.rkt deleted file mode 100644 index 84dc0f7..0000000 --- a/OLD-syndicate/syntax.rkt +++ /dev/null @@ -1,667 +0,0 @@ -#lang racket/base -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones -;;; DSL syntax over the API of dataspace.rkt - -(provide spawn - spawn* - - react - react/suspend - until - - field - assert - stop-facet - stop-current-facet - stop-when - stop-when-true - on-start - on-stop - on - add-raw-observer-endpoint! - add-observer-endpoint! - during - during/spawn - begin/dataflow - define/dataflow - - asserted - retracted - message - - let-event - - query-value - query-set - query-hash - ;; query-hash-set - query-count - query-value* - query-set* - query-hash* - ;; query-hash-set* - query-count* - define/query-value - define/query-set - define/query-hash - ;; define/query-hash-set - define/query-count - immediate-query - - send! - defer-turn! - flush! - assert! - retract! - current-adhoc-assertions - - ;; - - ;; current-action-transformer - ) - -(require (for-syntax racket/base)) -(require (for-syntax syntax/parse)) -(require (for-syntax syntax/srcloc)) -(require "syntax-classes.rkt") - -(require "assertions.rkt") -(require "dataspace.rkt") -(require (submod "dataspace.rkt" priorities)) -(require "event-expander.rkt") -(require "skeleton.rkt") -(require "pattern.rkt") -(require "term.rkt") - -(require racket/match) -(require racket/set) -(require syndicate/dataflow) -(require syndicate/protocol/instance) - -(begin-for-syntax - (define-splicing-syntax-class actor-wrapper - (pattern (~seq #:spawn wrapper)) - (pattern (~seq) #:attr wrapper #'spawn)) - - (define-splicing-syntax-class on-crash-option - (pattern (~seq #:on-crash expr)) - (pattern (~seq) #:attr expr #f)) - - (define-splicing-syntax-class let-option - (pattern (~seq #:let clauses)) - (pattern (~seq) #:attr clauses #'())) - - (define-splicing-syntax-class when-pred - (pattern (~seq #:when Pred)) - (pattern (~seq) #:attr Pred #'#t)) - - (define-splicing-syntax-class priority - (pattern (~seq #:priority level)) - (pattern (~seq) #:attr level #'*normal-priority*))) - -(define-syntax (spawn stx) - (syntax-parse stx - [(_ (~or (~optional (~seq #:name name-expr) #:defaults ([name-expr #'#f]) - #:name "#:name") - (~optional (~seq #:assertions [assertion-exprs ...]) - #:name "#:assertions") - (~optional (~seq #:linkage [linkage-expr ...]) #:defaults ([(linkage-expr 1) '()]) - #:name "#:linkage")) - ... - O ...) - (quasisyntax/loc stx - (spawn** #:name name-expr - #:assertions #,(cond [(attribute assertion-exprs) #'[assertion-exprs ...]] - [else #'[]]) - linkage-expr ... O ...))])) - -(define-syntax (spawn* stx) - (syntax-parse stx - [(_ name:name assertions:assertions script ...) - (quasisyntax/loc stx - (spawn** #:name name.N - #:assertions [assertions.exprs ...] - (on-start script ...)))])) - -(define-syntax (spawn** stx) - (syntax-parse stx - [(_ name:name assertions:assertions script ...) - (quasisyntax/loc stx - (begin - (ensure-in-script! 'spawn!) - (spawn! - (current-actor) - name.N - (lambda () (begin/void-default script ...)) - (set assertions.exprs ...))))])) - -(define-syntax (begin/void-default stx) - (syntax-parse stx - [(_) (syntax/loc stx (void))] - [(_ expr0 expr ...) (syntax/loc stx (begin expr0 expr ...))])) - -(define (react* where boot-proc) - (add-facet! where - (current-actor) - (current-facet) - boot-proc)) - -(define-syntax (react stx) - (syntax-parse stx - [(_ O ...) - (quasisyntax/loc stx - (react* #,(source-location->string stx) - (lambda () (begin/void-default O ...))))])) - -(define-syntax (react/suspend stx) - (syntax-parse stx - [(_ (resume-parent) O ...) - (quasisyntax/loc stx - (suspend-script* #,(source-location->string stx) - (lambda (resume-parent) - (react* #,(source-location->string stx) - (lambda () (begin/void-default O ...))))))])) - -(define-syntax (until stx) - (syntax-parse stx - [(_ E O ...) - (syntax/loc stx - (react/suspend (continue) - (stop-when E (continue (void))) - O ...))])) - -(define (make-field name init) - (let ((ac (current-actor))) - (field-handle name (generate-id! (actor-dataspace ac)) ac init))) - -(define-syntax (define-field stx) - (syntax-parse stx - [(_ id init) - #'(define id (make-field 'id init))])) - -(define-syntax (field stx) - (syntax-parse stx - [(_ [id:id init] ...) - (quasisyntax/loc stx - (begin (define-field id init) - ...))])) - -(define-syntax (assert stx) - (syntax-parse stx - [(_ w:when-pred snapshot:snapshot P) - (quasisyntax/loc stx - (add-endpoint! (current-facet) - #,(source-location->string stx) - snapshot.dynamic? - (lambda () (values (when w.Pred P) #f))))])) - -(define-syntax (stop-facet stx) - (syntax-parse stx - [(_ f-expr script ...) - (quasisyntax/loc stx - (let ((f f-expr)) - (when (not (equal? (facet-actor f) (current-actor))) - (error 'stop-facet "Attempt to stop unrelated facet ~a from actor ~a" f (current-actor))) - (stop-facet! f (lambda () (begin/void-default script ...)))))])) - -(define-syntax-rule (stop-current-facet script ...) - (stop-facet (current-facet) script ...)) - -(define-syntax-rule (stop-when-true condition script ...) - (begin/dataflow - (when condition - (stop-facet (current-facet) script ...)))) - -(define-syntax (on-start stx) - (syntax-parse stx - [(_ script ...) - (quasisyntax/loc stx - (schedule-script! (current-actor) - (lambda () (begin/void-default script ...))))])) - -(define-syntax (on-stop stx) - (syntax-parse stx - [(_ script ...) - (quasisyntax/loc stx - (add-stop-script! (current-facet) - (lambda () (begin/void-default script ...))))])) - -(define-syntax (stop-when stx) - (syntax-parse stx - [(_ w:when-pred E prio:priority script ...) - (analyse-event stx - #'w.Pred - #'E - (syntax/loc stx (stop-current-facet script ...)) - #'prio.level)])) - -(define-syntax (on stx) - (syntax-parse stx - [(_ w:when-pred E prio:priority script ...) - (analyse-event stx - #'w.Pred - #'E - (syntax/loc stx (begin/void-default script ...)) - #'prio.level)])) - -(define (add-raw-observer-endpoint! spec-thunk - #:on-add [on-add void] - #:on-remove [on-remove void] - #:on-message [on-message void] - #:cleanup [cleanup #f]) - (add-endpoint! (current-facet) - "add-observer-endpoint!/add-raw-observer-endpoint!" - #t - (lambda () - (define spec (spec-thunk)) - (if (void? spec) - (values (void) #f) - (values (observe spec) - (term->skeleton-interest - spec - (lambda (op . captured-values) - (match op - ['+ (on-add captured-values)] - ['- (on-remove captured-values)] - ['! (on-message captured-values)])) - #:cleanup cleanup)))))) - -(define (add-observer-endpoint! spec-thunk - #:on-add [on-add void] - #:on-remove [on-remove void] - #:on-message [on-message void] - #:cleanup [cleanup #f]) - (define (scriptify f) - (if (eq? f void) - void - (capture-facet-context - (lambda (captured-values) - (schedule-script! (current-actor) (lambda () (f captured-values))))))) - (add-raw-observer-endpoint! spec-thunk - #:on-add (scriptify on-add) - #:on-remove (scriptify on-remove) - #:on-message (scriptify on-message) - #:cleanup cleanup)) - -(define-syntax (begin/dataflow stx) - (syntax-parse stx - [(_ prio:priority expr ...) - (quasisyntax/loc stx - (let () - (add-endpoint! (current-facet) - #,(source-location->string stx) - #t - (lambda () - (define subject-id (current-dataflow-subject-id)) - (schedule-script! - #:priority prio.level - (current-actor) - (lambda () - (parameterize ((current-dataflow-subject-id subject-id)) - expr ...))) - (values (void) #f)))))])) - -(define-syntax (define/dataflow stx) - (syntax-parse stx - [(_ fieldname expr) - (quasisyntax/loc stx (define/dataflow fieldname expr #:default #f))] - [(_ fieldname expr #:default default-expr) - (quasisyntax/loc stx - (begin - (field [fieldname default-expr]) - (begin/dataflow (fieldname expr))))])) - -(define-syntax (asserted stx) (raise-syntax-error #f "asserted: Used outside event spec" stx)) -(define-syntax (retracted stx) (raise-syntax-error #f "retracted: Used outside event spec" stx)) -(define-syntax (message stx) (raise-syntax-error #f "message: Used outside event spec" stx)) - -(define-syntax (suspend-script stx) - (syntax-parse stx - [(_ proc) - (quasisyntax/loc stx - (suspend-script* #,(source-location->string stx) proc))])) - -(define-syntax (let-event stx) - (syntax-parse stx - [(_ [e ...] body ...) - (syntax/loc stx - ((react/suspend (k) - (on-start (-let-event [e ...] (stop-current-facet (k (lambda () body ...))))))))])) - -(define-syntax (-let-event stx) - (syntax-parse stx - [(_ [] expr) #'expr] - [(_ [e es ...] expr) (quasisyntax/loc #'e (react (stop-when e (-let-event [es ...] expr))))])) - -(define-for-syntax orig-insp - (variable-reference->module-declaration-inspector (#%variable-reference))) - -(define-for-syntax (analyse-event outer-expr-stx - when-pred-stx - armed-event-stx - script-stx - priority-stx) - (define event-stx (syntax-disarm armed-event-stx orig-insp)) - (syntax-parse event-stx - #:literals [message asserted retracted] - [(expander args ...) #:when (event-expander-id? #'expander) - (event-expander-transform event-stx - (lambda (result) - (analyse-event outer-expr-stx - when-pred-stx - (syntax-rearm result event-stx) - script-stx - priority-stx)))] - [(message snapshot:snapshot P) - (define desc (analyse-pattern #'P)) - (quasisyntax/loc outer-expr-stx - (add-endpoint! (current-facet) - #,(source-location->string outer-expr-stx) - snapshot.dynamic? - (lambda () - (if #,when-pred-stx - (values (observe #,(desc->assertion-stx desc)) - (skeleton-interest #,(desc->skeleton-stx desc) - '#,(desc->skeleton-proj desc) - (list #,@(desc->key desc)) - '#,(desc->capture-proj desc) - (capture-facet-context - (lambda (op #,@(desc->capture-names desc)) - (when (eq? op '!) - ;; (log-info "~a ~a ~v" - ;; (current-facet) - ;; op - ;; (list #,@(desc->capture-names desc))) - (schedule-script! - #:priority #,priority-stx - (current-actor) - #,(quasisyntax/loc script-stx - (lambda () - #,script-stx)))))) - #f)) - (values (void) #f)))))] - [(asserted snapshot:snapshot P) - (analyse-asserted/retracted outer-expr-stx - #'snapshot.dynamic? - when-pred-stx - script-stx - #t - #'P - priority-stx)] - [(retracted snapshot:snapshot P) - (analyse-asserted/retracted outer-expr-stx - #'snapshot.dynamic? - when-pred-stx - script-stx - #f - #'P - priority-stx)])) - -(define-for-syntax (analyse-asserted/retracted outer-expr-stx - snapshot-dynamic?-stx - when-pred-stx - script-stx - asserted? - P-stx - priority-stx) - (define desc (analyse-pattern P-stx)) - (quasisyntax/loc outer-expr-stx - (add-endpoint! (current-facet) - #,(source-location->string outer-expr-stx) - #,snapshot-dynamic?-stx - (lambda () - (if #,when-pred-stx - (values (observe #,(desc->assertion-stx desc)) - (skeleton-interest #,(desc->skeleton-stx desc) - '#,(desc->skeleton-proj desc) - (list #,@(desc->key desc)) - '#,(desc->capture-proj desc) - (capture-facet-context - (lambda (op #,@(desc->capture-names desc)) - (when (eq? op #,(if asserted? #''+ #''-)) - ;; (log-info "~a ~a ~v" - ;; (current-facet) - ;; op - ;; (list #,@(desc->capture-names desc))) - (schedule-script! - #:priority #,priority-stx - (current-actor) - #,(quasisyntax/loc script-stx - (lambda () - #,script-stx)))))) - #f)) - (values (void) #f)))))) - -(define-syntax (during stx) - (syntax-parse stx - [(_ P O ...) - (quasisyntax/loc stx - (on (asserted P) - (react (stop-when (retracted #:snapshot #,(instantiate-pattern->pattern #'P))) - O ...)))])) - -(define-syntax (during/spawn stx) - (syntax-parse stx - [(_ P w:actor-wrapper name:name assertions:assertions parent-let:let-option - oncrash:on-crash-option - O ...) - (define Q-stx (instantiate-pattern->pattern #'P)) - (quasisyntax/loc stx - (on (asserted P) - (let* ((id (gensym 'during/spawn)) - (inst (instance id #,(instantiate-pattern->value #'P))) - ;; ^ this is the assertion representing supply - ) - (react (stop-when (asserted inst) - ;; Supply (inst) appeared before demand (p) retracted. - ;; Transition to a state where we monitor demand, but also - ;; express interest in supply: this latter acts as a signal - ;; to the supply that it should stick around. We react to - ;; retraction of supply before retraction of demand by - ;; invoking the on-crash expression, if supplied. Once - ;; demand is retracted, this facet terminates, retracting - ;; its interest in supply, thereby signalling to the supply - ;; that it is no longer wanted. - (react (stop-when (retracted inst) ;; NOT OPTIONAL - #,@(if (attribute oncrash.expr) - #'(oncrash.expr) - #'())) - (stop-when (retracted #:snapshot #,Q-stx)))) - (stop-when (retracted #:snapshot #,Q-stx) - ;; Demand (p) retracted before supply (inst) appeared. We - ;; MUST wait for the supply to fully appear so that we can - ;; reliably tell it to shut down. We must maintain interest - ;; in supply until we see supply, and then terminate, thus - ;; signalling to supply that it is no longer wanted. - (react (stop-when (asserted inst))))) - (let parent-let.clauses - (w.wrapper #:linkage [(assert inst) - (stop-when (retracted (observe inst)))] - #:name name.N - #:assertions [inst - (observe (observe inst)) - assertions.exprs ...] - O ...)))))])) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Queries - -(begin-for-syntax - (define-splicing-syntax-class on-add - (pattern (~optional (~seq #:on-add expr) #:defaults ([expr #f])))) - (define-splicing-syntax-class on-remove - (pattern (~optional (~seq #:on-remove expr) #:defaults ([expr #f])))) - - (define (schedule-query-handler-stxs maybe-expr-stx) - (if maybe-expr-stx - (quasisyntax/loc maybe-expr-stx - ((schedule-script! #:priority *query-handler-priority* - (current-actor) - (lambda () #,maybe-expr-stx)))) - #'()))) - -(define-syntax (query-value stx) - (syntax-parse stx - [(_ field-name absent-expr args ...) - (quasisyntax/loc stx - (let () - (field [field-name absent-expr]) - (query-value* field-name absent-expr args ...)))])) - -(define-syntax (query-value* stx) - (syntax-parse stx - [(_ field-name absent-expr P expr on-add:on-add on-remove:on-remove) - (quasisyntax/loc stx - (let ((F field-name)) - (on (asserted P) #:priority *query-priority* - #,@(schedule-query-handler-stxs (attribute on-add.expr)) - (F expr)) - (on (retracted P) #:priority *query-priority-high* - #,@(schedule-query-handler-stxs (attribute on-remove.expr)) - (F absent-expr)) - F))])) - -(define-syntax (query-set stx) - (syntax-parse stx - [(_ field-name args ...) - (quasisyntax/loc stx - (let () - (field [field-name (set)]) - (query-set* field-name args ...)))])) - -(define-syntax (query-set* stx) - (syntax-parse stx - [(_ field-name P expr on-add:on-add on-remove:on-remove) - (quasisyntax/loc stx - (let ((F field-name)) - (on (asserted P) #:priority *query-priority* - (let ((V expr)) - (when (not (set-member? (F) V)) - #,@(schedule-query-handler-stxs (attribute on-add.expr)) - (F (set-add (F) V))))) - (on (retracted P) #:priority *query-priority-high* - (let ((V expr)) - (when (set-member? (F) V) - #,@(schedule-query-handler-stxs (attribute on-remove.expr)) - (F (set-remove (F) V))))) - F))])) - -(define-syntax (query-hash stx) - (syntax-parse stx - [(_ field-name args ...) - (quasisyntax/loc stx - (let () - (field [field-name (hash)]) - (query-hash* field-name args ...)))])) - -(define-syntax (query-hash* stx) - (syntax-parse stx - [(_ field-name P key-expr value-expr on-add:on-add on-remove:on-remove) - (quasisyntax/loc stx - (let ((F field-name)) - (on (asserted P) #:priority *query-priority* - (let ((key key-expr)) - (when (hash-has-key? (F) key) - (log-warning "query-hash: field ~v with pattern ~v: overwriting existing entry ~v" - 'field-name - 'P - key)) - #,@(schedule-query-handler-stxs (attribute on-add.expr)) - (F (hash-set (F) key value-expr)))) - (on (retracted P) #:priority *query-priority-high* - #,@(schedule-query-handler-stxs (attribute on-remove.expr)) - (F (hash-remove (F) key-expr))) - F))])) - -;; (define-syntax (query-hash-set stx) -;; (syntax-parse stx -;; [(_ field-name args ...) -;; (quasisyntax/loc stx -;; (let () -;; (field [field-name (hash)]) -;; (query-hash-set* field-name args ...)))])) - -;; (define-syntax (query-hash-set* stx) -;; (syntax-parse stx -;; [(_ field-name P key-expr value-expr on-add:on-add on-remove:on-remove) -;; (quasisyntax/loc stx -;; (let ((F field-name)) -;; (on (asserted P) #:priority *query-priority* -;; (let ((K key-expr) (V value-expr)) -;; (when (not (hashset-member? (F) K V)) -;; #,@(schedule-query-handler-stxs (attribute on-add.expr)) -;; (F (hashset-add (F) K V))))) -;; (on (retracted P) #:priority *query-priority-high* -;; (let ((K key-expr) (V value-expr)) -;; (when (hashset-member? (F) K V) -;; #,@(schedule-query-handler-stxs (attribute on-remove.expr)) -;; (F (hashset-remove (F) K V))))) -;; F))])) - -(define-syntax (query-count stx) - (syntax-parse stx - [(_ field-name args ...) - (quasisyntax/loc stx - (let () - (field [field-name (hash)]) - (query-count* field-name args ...)))])) - -(define-syntax (query-count* stx) - (syntax-parse stx - [(_ field-name P expr on-add:on-add on-remove:on-remove) - (quasisyntax/loc stx - (let ((F field-name)) - (on (asserted P) #:priority *query-priority* - (let ((E expr)) - #,@(schedule-query-handler-stxs (attribute on-add.expr)) - (F (hash-set (F) E (+ 1 (hash-ref (F) E 0)))))) - (on (retracted P) #:priority *query-priority-high* - (let ((E expr)) - #,@(schedule-query-handler-stxs (attribute on-remove.expr)) - (let ((F0 (F))) - (F (match (hash-ref F0 E 0) - [0 F0] ;; huh - [1 (hash-remove F0 E)] - [n (hash-set F0 E (- n 1))]))))) - F))])) - -(define-syntax-rule (define/query-value id ae P x ...) (define id (query-value id ae P x ...))) -(define-syntax-rule (define/query-set id P x ...) (define id (query-set id P x ...))) -(define-syntax-rule (define/query-hash id P x ...) (define id (query-hash id P x ...))) -;; (define-syntax-rule (define/query-hash-set id P x ...) (define id (query-hash-set id P x ...))) -(define-syntax-rule (define/query-count id P x ...) (define id (query-count id P x ...))) - -(define-syntax (immediate-query stx) - (syntax-case stx () - [(_ [op args ...] ...) - (with-syntax [((query-result ...) (generate-temporaries #'(op ...)))] - (syntax/loc stx - (react/suspend (k) - (define query-result (op query-result args ...)) ... - (on-start (flush!) (k (query-result) ...)))))])) - -(define (send! m) - (ensure-in-script! 'send!) - (enqueue-send! (current-actor) m)) - -(define (defer-turn! k) - (ensure-in-script! 'defer-turn!) - (enqueue-deferred-turn! (current-actor) k)) - -(define (flush!) - (ensure-in-script! 'flush!) - (define ack (gensym 'flush!)) - (until (message ack) - (on-start (send! ack)))) - -(define (assert! a [count 1]) - (ensure-in-script! 'assert!) - (adhoc-assert! (current-actor) a count)) - -(define (retract! a [count 1]) - (ensure-in-script! 'retract!) - (adhoc-retract! (current-actor) a count)) - -(define (current-adhoc-assertions) - (actor-adhoc-assertions (current-actor))) diff --git a/OLD-syndicate/term.rkt b/OLD-syndicate/term.rkt deleted file mode 100644 index 7dd1c6e..0000000 --- a/OLD-syndicate/term.rkt +++ /dev/null @@ -1,197 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang racket/base -;; Like pattern.rkt, but for dynamic use rather than compile-time use. - -(provide term->skeleton-interest - - term->skeleton - term->skeleton-proj - term->key - term->capture-proj - instantiate-term->value - term-intersect) - -(require racket/match) -(require "support/struct.rkt") -(require "pattern.rkt") -(require "skeleton.rkt") - -(define (term->skeleton-interest x handler #:cleanup [cleanup #f]) - (skeleton-interest (term->skeleton x) - (term->skeleton-proj x) - (term->key x) - (term->capture-proj x) - handler - cleanup)) - -(define (term->skeleton t) - (let walk ((t t)) - (match t - [(capture detail) - (walk detail)] - [(discard) - #f] - [(? non-object-struct?) - (cons (struct->struct-type t) (map walk (cdr (vector->list (struct->vector t)))))] - [(? list?) - (cons 'list (map walk t))] - [(? vector?) - (cons 'vector (map walk (vector->list t)))] - [atom - #f]))) - -(define (select-term-leaves t capture-fn atom-fn) - (define (walk-node key-rev t) - (match t - [(capture detail) - (append (capture-fn key-rev) (walk-node key-rev detail))] - [(discard) - (list)] - [(? non-object-struct?) - (walk-edge 0 key-rev (cdr (vector->list (struct->vector t))))] - [(? list?) - (walk-edge 0 key-rev t)] - [(? vector?) - (walk-edge 0 key-rev (vector->list t))] - [atom - (atom-fn key-rev atom)])) - - (define (walk-edge index key-rev pieces) - (match pieces - ['() '()] - [(cons p pieces) (append (walk-node (cons index key-rev) p) - (walk-edge (+ index 1) key-rev pieces))])) - - (walk-node '() t)) - -(define (term->skeleton-proj t) - (select-term-leaves t - (lambda (key-rev) (list)) - (lambda (key-rev atom) (list (reverse key-rev))))) - -(define (term->key t) - (select-term-leaves t - (lambda (key-rev) (list)) - (lambda (key-rev atom) (list atom)))) - -(define (term->capture-proj t) - (select-term-leaves t - (lambda (key-rev) (list (reverse key-rev))) - (lambda (key-rev atom) (list)))) - -(define (struct-fields t) - (cdr (vector->list (struct->vector t)))) - -(define (struct-map f t) - (apply (struct-type-make-constructor (struct->struct-type t)) - (map f (struct-fields t)))) - -(struct opaque-placeholder ()) -;; ^ not transparent or prefab -- used to frustrate -;; otherwise-potentially-matching constant positions in instantiated -;; terms - -(define (instantiate-term->value t actuals - #:visibility-restriction-proj [vrproj (term->capture-proj t)]) - (define (pop-actual!) - (define v (car actuals)) - (set! actuals (cdr actuals)) - v) - - (define (pop-captures! t) - (match t - [(capture detail) - (pop-actual!) - (pop-captures! detail)] - [(discard) - (void)] - [(? non-object-struct?) - (for-each pop-captures! (struct-fields t))] - [(? list?) - (for-each pop-captures! t)] - [(? vector?) - (for [(tt (in-vector t))] (pop-captures! tt))] - [_ (void)])) - - (define (walk t) - (match t - [(capture detail) - (begin0 (pop-actual!) - (pop-captures! detail))] ;; to consume nested bindings - [(discard) - (opaque-placeholder)] - [(? non-object-struct?) - (struct-map walk t)] - [(? list?) - (map walk t)] - [(? vector?) - (for/vector [(tt t)] (walk tt))] - [other other])) - - (if vrproj - (visibility-restriction vrproj (walk t)) - (walk t))) - -;; Omits captures. -(define (term-intersect t1 t2 ks kf) - (define (walk-lists xs1 xs2 ks) - (let inner ((xs1 xs1) (xs2 xs2) (acc '())) - (match* (xs1 xs2) - [('() '()) - (ks (reverse acc))] - [((cons x1 xs1) (cons x2 xs2)) - (walk x1 x2 (lambda (v) (inner xs1 xs2 (cons v acc))))] - [(_ _) - (kf)]))) - (define (walk t1 t2 ks) - (match* (t1 t2) - [((capture d1) d2) (walk d1 d2 ks)] - [(d1 (capture d2)) (walk d1 d2 ks)] - [((discard) other) (ks other)] - [(other (discard)) (ks other)] - [((? non-object-struct?) (? non-object-struct?)) - (define ty (struct->struct-type t1)) - (if (eq? ty (struct->struct-type t2)) - (walk-lists (struct-fields t1) - (struct-fields t2) - (lambda (vs) (ks (apply (struct-type-make-constructor ty) vs)))) - (kf))] - [('() '()) (ks '())] - [((cons d1 t1) (cons d2 t2)) - (walk d1 d2 (lambda (a) (walk t1 t2 (lambda (d) (ks (cons a d))))))] - [((? vector?) (? vector?)) - (walk-lists (vector->list t1) - (vector->list t2) - (lambda (vs) (ks (list->vector vs))))] - [(_ _) - (if (equal? t1 t2) - (ks t1) - (kf))])) - (walk t1 t2 ks)) - -(module+ test - (require rackunit) - (check-equal? (term-intersect (list 'a 'b 'c) (list 'a 'b 'c) values void) (list 'a 'b 'c)) - (check-equal? (term-intersect (list 'a 'b 'c) (list 'a 'c 'b) values void) (void)) - (check-equal? (term-intersect (list 'a 'b 'c) (list 'a (discard) 'c) values void) (list 'a 'b 'c)) - (check-equal? (term-intersect (list 'a (discard) 'c) (list 'a 'b 'c) values void) (list 'a 'b 'c)) - (check-equal? (term-intersect (list 'a (discard) 'c) (list 'a 'b (discard)) values void) - (list 'a 'b 'c)) - (check-equal? (term-intersect (vector 'a (discard) 'c) (vector 'a 'b (discard)) values void) - (vector 'a 'b 'c)) - (struct X (A B C) #:transparent) - (check-equal? (term-intersect (X 'a (discard) 'c) (X 'a 'b (discard)) values void) (X 'a 'b 'c)) - (check-equal? (term-intersect (X (capture 'a) (discard) 'c) (X 'a 'b (discard)) values void) - (X 'a 'b 'c)) - (check-equal? (term-intersect (capture (X (capture 'a) (discard) 'c)) - (X 'a (capture 'b) (discard)) - values - void) - (X 'a 'b 'c)) - (check-equal? (term-intersect 'a 'b values void) (void)) - (check-equal? (term-intersect 'a 'a values void) 'a) - (check-equal? (term-intersect (cons 1 2) (cons 1 2) values void) (cons 1 2)) - (check-equal? (term-intersect "hi" "hi" values void) "hi") - ) diff --git a/OLD-syndicate/test-implementation.rkt b/OLD-syndicate/test-implementation.rkt deleted file mode 100644 index 28d961a..0000000 --- a/OLD-syndicate/test-implementation.rkt +++ /dev/null @@ -1,224 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang racket -;; Test drivers for Syndicate implementation. - -(provide collected-events - collected-exns - collected-output - collected-lines - final-dataspace - final-assertions - test-run-time - test-gc-time - - asserted? - emitted? - actor-died? - emit! - test-case - it - - no-crashes - expected-output - expected-output? - - run-syndicate-test! - log-test-result! - - (except-out (all-from-out racket) sleep) - (all-from-out "main.rkt")) - -(module reader syntax/module-reader syndicate/test-implementation) - -(require racket/exn) - -(require "bag.rkt") -(require "main.rkt") -(require (only-in "lang.rkt" current-activated-modules)) - -(require (for-syntax racket/base)) -(require (for-syntax syntax/srcloc)) - -(define-logger syndicate/test) - -(define event-accumulator (make-parameter #f)) -(define exn-accumulator (make-parameter #f)) -(define failure-detected? (make-parameter #f)) - -(define collected-events (make-parameter '())) -(define collected-exns (make-parameter '())) -(define collected-output (make-parameter "")) -(define collected-lines (make-parameter '())) -(define final-dataspace (make-parameter #f)) -(define test-run-time (make-parameter 0)) -(define test-gc-time (make-parameter 0)) - -(define (asserted? v) - (bag-member? (dataspace-assertions (final-dataspace)) v)) - -(define (final-assertions) - (bag->set (dataspace-assertions (final-dataspace)))) - -(define (emitted? v) - (member v (collected-events))) - -(define (actor-died? name [substr-or-regex ""]) - (define entry (findf (lambda (e) (equal? name (actor-name (car e)))) (collected-exns))) - (and entry - (let ((message (exn-message (cadr entry)))) - (match substr-or-regex - [(? string? substr) (string-contains? message substr)] - [(? regexp? re) (regexp-match? re message)])))) - -(define (emit! event) - (define b (event-accumulator)) - (set-box! b (cons event (unbox b)))) - -(define-syntax (test-case stx) - (syntax-case stx () - [(_ [body ...] checks ...) - (quasisyntax/loc stx - (run-syndicate-test! - #,(source-location->string stx) - (lambda () body ...) - (list checks ...)))])) - -(define (not-break? e) - (not (exn:break? e))) - -(struct check (location description thunk) #:prefab) - -(define (run-syndicate-test! location-str body-thunk list-of-checks) - (parameterize ((failure-detected? #f)) - (define events-box (box '())) - (define exns-box (box '())) - (define (get-items b) (reverse (unbox b))) - (define op (open-output-string)) - (with-handlers ([not-break? (lambda (e) (log-test-result! location-str #f e))]) - (log-syndicate/test-info "~a--- Running test at ~a~a" - (color YELLOW) - location-str - (color NORMAL)) - (define ds (make-dataspace - (lambda () - (schedule-script! (current-actor) body-thunk)))) - (define-values (_results cpu-ms _wall-ms gc-ms) - (parameterize ((current-output-port op) - (current-actor-crash-logger - (lambda (a e) - (set-box! exns-box (cons (list a e) (unbox exns-box))))) - (current-activated-modules (make-hasheq)) - (event-accumulator events-box)) - (time-apply (lambda () (let loop () (when (run-scripts! ds) (loop)))) - '()))) - (define op-string (get-output-string op)) - (parameterize ((collected-events (get-items events-box)) - (collected-exns (get-items exns-box)) - (collected-output op-string) - (collected-lines (string-split op-string "\n")) - (final-dataspace ds) - (test-run-time cpu-ms) - (test-gc-time gc-ms)) - (for [(check (in-list list-of-checks))] - (with-handlers ([not-break? (lambda (e) (log-test-result! location-str check e))]) - (match check - [(? procedure?) - (log-test-result! location-str check (check))] - [(? check?) - (log-test-result! location-str check ((check-thunk check)))]))))) - (when (failure-detected?) - (log-syndicate/test-debug "Collected events:") - (for [(e (get-items events-box))] - (log-syndicate/test-debug " ~v" e)) - (log-syndicate/test-debug "Collected output:") - (for [(l (string-split (get-output-string op) "\n"))] - (log-syndicate/test-debug " ~a" l)) - (log-syndicate/test-debug "Crashed actors:") - (for [(entry (get-items exns-box))] - (match-define (list a e) entry) - (log-syndicate/test-debug " ~a\n ~a" - a - (string-join (string-split (exn->string e) "\n") - " \n")))))) - -(define-syntax (it stx) - (syntax-case stx () - [(_ description body ...) - (quasisyntax/loc stx - (check #,(source-location->string stx) - description - (lambda () - (and body ...))))])) - -(define no-crashes (it "shouldn't involve any crashing actors" - (null? (collected-exns)))) - -(define-syntax (expected-output stx) - (syntax-case stx () - [(_ list-or-set-of-strings-expr ...) - (quasisyntax/loc stx - (it "should produce correct output" - (expected-output? (collected-lines) - (list list-or-set-of-strings-expr ...))))])) - -(define (take-at-most xs n) - (cond [(zero? n) '()] - [(null? xs) '()] - [else (cons (car xs) (take-at-most (cdr xs) (- n 1)))])) - -(define (expected-output? lines checks) - (match checks - ['() - (null? lines)] - [(cons (? list? expected-lines) rest) - (define actual-lines (take-at-most lines (length expected-lines))) - (and (equal? actual-lines expected-lines) - (expected-output? (drop lines (length expected-lines)) rest))] - [(cons (? set? expected-lines) rest) - (define actual-lines (list->set (take-at-most lines (set-count expected-lines)))) - (and (equal? actual-lines expected-lines) - (expected-output? (drop lines (set-count expected-lines)) rest))])) - -(define RED ";31") -(define BRIGHT-RED ";1;31") -(define GREEN ";32") -(define BRIGHT-GREEN ";1;32") -(define YELLOW ";33") -(define NORMAL "") - -(define (color c) (format "\e[0~am" c)) - -(define (log-test-result! test-loc maybe-check result) - (if (not maybe-check) - (begin - (failure-detected? #t) - (log-syndicate/test-error "~a ✗ Exception running program under test:\n~a~a" - (color BRIGHT-RED) - (exn->string result) - (color NORMAL))) - (let ((description - (match maybe-check - [(? procedure?) (format "~a" maybe-check)] - [(check #f description _thunk) (format "~a" description)] - [(check check-loc description _thunk) (format "~a (~a)" description check-loc)]))) - (match result - [(? exn?) - (failure-detected? #t) - (log-syndicate/test-error "~a ✗ ... ~a:\n~a~a" - (color RED) - description - (exn->string result) - (color NORMAL))] - [#f - (failure-detected? #t) - (log-syndicate/test-error "~a ✗ ... ~a~a" - (color RED) - description - (color NORMAL))] - [_ - (log-syndicate/test-info "~a ✓ ... ~a~a" - (color GREEN) - description - (color NORMAL))])))) diff --git a/OLD-syndicate/test/core/abandon-actions-on-exn.rkt b/OLD-syndicate/test/core/abandon-actions-on-exn.rkt deleted file mode 100644 index 288aaf8..0000000 --- a/OLD-syndicate/test/core/abandon-actions-on-exn.rkt +++ /dev/null @@ -1,30 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate/test-implementation -;; Tests that pending actions are abandoned during a turn in which there is an exception - -(test-case - [(message-struct stage (n)) - - (spawn #:name 'actor0 - (on (message (stage 0)) - (send! (stage 1))) - - (on (message (stage 2)) - (send! (stage 3)) - (error 'test-case "Deliberate error") - (send! (stage 3)))) - - (spawn #:name 'main - (on (message (stage $v)) - (printf "Got message ~v\n" v)) - (on-start - (until (asserted (observe (stage 0)))) - (send! (stage 0)) - (until (message (stage 1))) - (send! (stage 2))))] - (it "should involve one crash" (actor-died? 'actor0 "Deliberate error")) - (expected-output (list "Got message 0" - "Got message 1" - "Got message 2"))) diff --git a/OLD-syndicate/test/core/clean-adhoc-on-termination.rkt b/OLD-syndicate/test/core/clean-adhoc-on-termination.rkt deleted file mode 100644 index 21a83f9..0000000 --- a/OLD-syndicate/test/core/clean-adhoc-on-termination.rkt +++ /dev/null @@ -1,62 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate/test-implementation -;; Tests that adhoc assertions are always removed on termination, even -;; when being relayed across a dataspace boundary. - -(require syndicate/bag) -(require syndicate/pattern) - -(message-struct trigger ()) - -(define (spawn-seen-monitor) - (spawn #:name 'monitor - (on (asserted $x) (printf "Seen: ~v\n" x)))) - -(define (spawn-double-trigger) - ;; Sending the trigger twice is one of the critical factors for this test case - (spawn* #:name 'double-trigger - (until (asserted (observe (trigger)))) - (send! (trigger)) - (send! (trigger)))) - -(define (only-seen-monitor-output?) - (expected-output (list "Seen: '#s(observe #s(capture #s(discard)))"))) - -(define (only-seen-monitor-assertions?) - (lambda () - (define actual-assertions (final-assertions)) - (define expected-assertions (set (observe (capture (discard))))) - (or (equal? actual-assertions expected-assertions) - (error 'only-seen-monitor-assertions? "Actual-assertions ~v <> expected-assertions ~v" - actual-assertions - expected-assertions)))) - -(test-case - [(spawn-seen-monitor) - (dataspace #:name 'middle-dataspace - (spawn-double-trigger) - (dataspace #:name 'inner-dataspace - (spawn #:name 'actor0 - (on (message (inbound (trigger))) (quit-dataspace!)) - (on (message (inbound (trigger))) - (flush!) - (assert! (outbound (outbound 'B)))))))] - no-crashes - (only-seen-monitor-output?) - (only-seen-monitor-assertions?)) - -(test-case - [(spawn-seen-monitor) - (dataspace #:name 'middle-dataspace - (spawn-double-trigger) - (dataspace #:name 'inner-dataspace - (spawn #:name 'actor0 - (on (message (inbound (trigger))) (quit-dataspace!)) - (on (message (inbound (trigger))) - (flush!) - (react (assert (outbound (outbound 'B))))))))] - no-crashes - (only-seen-monitor-output?) - (only-seen-monitor-assertions?)) diff --git a/OLD-syndicate/test/core/complex-pattern.rkt b/OLD-syndicate/test/core/complex-pattern.rkt deleted file mode 100644 index 3eb0141..0000000 --- a/OLD-syndicate/test/core/complex-pattern.rkt +++ /dev/null @@ -1,29 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate/test-implementation - -(test-case - [(message-struct b (v)) - (message-struct c (v)) - (spawn #:name 'respondent - (on (asserted ($ val (list _ (vector _) (b (c _)) (vector _) _))) - ;; ^ exercises a corner-case in `extend-skeleton!` - ;; that exposed why `(update-path path pop-count 0)` - ;; was wrong, and `(update-path path 0 0)` was right. - (send! 'ok)))] - no-crashes) - -;; -;; Trie steps: -;; -;; · -;; - () must be list/5 -;; pop 0, get 1 -;; - (1) must be vector/1 -;; pop 1, get 2 -;; - (2) must be b/1 -;; pop 0, get 0 -;; - (2 0) must be c/1 -;; pop 2, get 3 -;; - (3) must be vector/1 diff --git a/OLD-syndicate/test/core/correct-retraction-on-exn.rkt b/OLD-syndicate/test/core/correct-retraction-on-exn.rkt deleted file mode 100644 index e63cefc..0000000 --- a/OLD-syndicate/test/core/correct-retraction-on-exn.rkt +++ /dev/null @@ -1,47 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate/test-implementation -;; Goal: no matter the circumstances (e.g. exception in a stop -;; script), we will never retract an assertion more or fewer than the -;; correct number of times. - -(test-case - [(spawn #:name 'supply - #:assertions ['marker] - (assert 'marker) ;; NB this is the change wrt the test case immediately below - (error 'test-case "Deliberate error")) - - (spawn (on (asserted 'marker) (printf "marker appeared\n")) - (on (retracted 'marker) (printf "marker disappeared\n")))] - (it "should crash deliberately" (actor-died? 'supply "Deliberate error")) - (expected-output (list "marker appeared" - "marker disappeared"))) - -(test-case - [(spawn #:name 'supply - #:assertions ['marker] - (error 'test-case "Deliberate error")) - - (spawn (on (asserted 'marker) (printf "marker appeared\n")) - (on (retracted 'marker) (printf "marker disappeared\n")))] - (it "should crash deliberately" (actor-died? 'supply "Deliberate error")) - (expected-output (list "marker appeared" - "marker disappeared"))) - -(test-case - ;; Test cleanup after exception in stop script - [(assertion-struct layer (name)) - (spawn #:name 'crasher - (define root-facet (current-facet)) - (assert (layer 'outer)) - (on-start (react (assert (layer 'middle)) - (on-start (flush!) (flush!) (stop-facet root-facet)) - (on-stop (error 'test-case "Deliberate error")) - (on-start (react (assert (layer 'inner))))))) - (spawn (on (retracted (layer $x)) (printf "~a gone\n" x)))] - (it "should crash deliberately" (actor-died? 'crasher "Deliberate error")) - ;; a permutation of these lines is acceptable: - (expected-output (set "middle gone" - "inner gone" - "outer gone"))) diff --git a/OLD-syndicate/test/core/death-during-startup.rkt b/OLD-syndicate/test/core/death-during-startup.rkt deleted file mode 100644 index 2e87ed7..0000000 --- a/OLD-syndicate/test/core/death-during-startup.rkt +++ /dev/null @@ -1,34 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate/test-implementation -;; An error signalled during setup of a new actor's root facet must -;; cause previous actions to be discarded, but must also cause any -;; initial-assertions, including specifically linkage assertions from -;; during/spawn, to be briefly visible. - -(test-case - [(assertion-struct request (id)) - (assertion-struct response (value)) - - (spawn (during/spawn (request $id) - (printf "starting request handler\n") - (assert (response 'the-answer)) ;; must not be visible - (printf "asserted response, shouldn't be visible\n") - (error 'aieee "oh no") - (printf "NOTREACHED\n"))) - - (spawn (stop-when (asserted (observe (request _))) - (printf "service listening\n") - (react - (assert (request 101)) - (stop-when (retracted (observe (request _))) - (printf "whole service vanished\n")) - (stop-when (retracted (observe (request 101))) - (printf "specific instance vanished\n")) - (stop-when (asserted (response $v)) - (printf "response ~v\n" v)))))] - (expected-output (list "service listening" - "starting request handler" - "asserted response, shouldn't be visible" - "specific instance vanished"))) diff --git a/OLD-syndicate/test/core/death-during-turn.rkt b/OLD-syndicate/test/core/death-during-turn.rkt deleted file mode 100644 index d987b19..0000000 --- a/OLD-syndicate/test/core/death-during-turn.rkt +++ /dev/null @@ -1,23 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate/test-implementation -;; An error signalled mid-turn must cause previous actions to be -;; discarded; discarded actions must not be observed by peers. - -(test-case - [(message-struct set-box (new-value)) - (assertion-struct box-state (value)) - - (spawn (field [current-value 0]) - (assert (box-state (current-value))) - (on (message (set-box $new-value)) (current-value new-value)) - (begin/dataflow (when (= (current-value) 3) - (error 'box "aiee")))) - - (spawn (on (asserted (box-state $v)) ;; must not see 3 here. - (printf "~v\n" v) - (send! (set-box (+ v 1)))))] - (expected-output (list "0" - "1" - "2"))) diff --git a/OLD-syndicate/test/core/double-cross-layer.rkt b/OLD-syndicate/test/core/double-cross-layer.rkt deleted file mode 100644 index 24ff9c9..0000000 --- a/OLD-syndicate/test/core/double-cross-layer.rkt +++ /dev/null @@ -1,31 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate/test-implementation - -(test-case - [(assertion-struct greeting (text)) - - (spawn #:name "A" (assert (greeting "Hi from outer space!"))) - (spawn #:name "B" (on (asserted (greeting $t)) - (printf "Outer dataspace: ~a\n" t))) - - (dataspace #:name "C" - (spawn #:name "D" (assert (outbound (greeting "Hi from middle!")))) - (spawn #:name "E" (on (asserted (inbound (greeting $t))) - (printf "Middle dataspace: ~a\n" t))) - - (dataspace #:name "F" - (spawn #:name "G" (assert (outbound (outbound (greeting "Inner!"))))) - (spawn #:name "H" (on (asserted (inbound (inbound (greeting $t)))) - (printf "Inner dataspace: ~a\n" t)))))] - no-crashes - (expected-output (set "Outer dataspace: Hi from outer space!" - "Middle dataspace: Hi from outer space!" - "Inner dataspace: Hi from outer space!" - "Outer dataspace: Hi from middle!" - "Middle dataspace: Hi from middle!" - "Inner dataspace: Hi from middle!" - "Outer dataspace: Inner!" - "Middle dataspace: Inner!" - "Inner dataspace: Inner!"))) diff --git a/OLD-syndicate/test/core/during-criterion-snapshotting.rkt b/OLD-syndicate/test/core/during-criterion-snapshotting.rkt deleted file mode 100644 index f457b07..0000000 --- a/OLD-syndicate/test/core/during-criterion-snapshotting.rkt +++ /dev/null @@ -1,20 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate/test-implementation -;; See .../syndicate/examples/actor/example-during-criterion-shapshotting.rkt - -(test-case - [(struct foo (x y) #:prefab) - (spawn (field [x 123]) - (assert (foo (x) 999)) - (during (foo (x) $v) - (define x0 (x)) - (printf "x=~a v=~a\n" (x) v) - (when (= (x) 123) (x 124)) - (on-stop - (printf "finally for x0=~a x=~a v=~a\n" x0 (x) v))))] - no-crashes - (expected-output (list "x=123 v=999" - "x=124 v=999" - "finally for x0=123 x=124 v=999"))) diff --git a/OLD-syndicate/test/core/nesting-confusion-2.rkt b/OLD-syndicate/test/core/nesting-confusion-2.rkt deleted file mode 100644 index 486270f..0000000 --- a/OLD-syndicate/test/core/nesting-confusion-2.rkt +++ /dev/null @@ -1,82 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate/test-implementation -;; 2018-11-20 Prior to the commit that introduced this test case (and -;; fixed the bug it exposed), matching a constant/literal `(discard)` -;; in an `inbound` pattern would match a visibility-restricted term, -;; so long as the captures were in the right places. After the fix, -;; `instantiate-term->value` replaces `(discard)` in the term with an -;; opaque value that cannot match any other value, meaning that only -;; patterns which completely ignore `discard`ed positions will match. -;; -;; Previously, the test-case marked (B) below yielded the correct -;; output, but (A) yielded the following incorrect output: -;; -;; Added discarded topic: Computering -;; Added discarded topic: Bicycling -;; Added discarded topic: Evil -;; Added discarded topic: Cryptography -;; Added topic: Computering -;; Added topic: Bicycling -;; Added topic: Evil -;; Added topic: Cryptography -;; -;; Now both yield the same output. - -(require (only-in syndicate/pattern discard capture)) - -(assertion-struct researcher (name topic)) - -(define-syntax-rule (correct-topics) - (expected-output (set "Added topic: Bicycling" - "Added topic: Computering" - "Added topic: Cryptography" - "Added topic: Evil"))) - -(test-case ;; (A) - [(spawn #:name 'tony - (assert (researcher "Tony" "Computering")) - (assert (researcher "Tony" "Bicycling"))) - (spawn #:name 'alice - (assert (researcher "Alice" "Cryptography")) - (assert (researcher "Alice" "Bicycling"))) - (spawn #:name 'eve - (assert (researcher "Eve" "Cryptography")) - (assert (researcher "Eve" "Computering")) - (assert (researcher "Eve" "Evil"))) - - (dataspace #:name 'inner-dataspace - (spawn #:name 'all-topics - (during (inbound (researcher _ $topic)) - (on-start (printf "Added topic: ~a\n" topic)) - (on-stop (printf "Removed topic: ~a\n" topic)))) - (spawn #:name 'all-researchers - (during (inbound (researcher (discard) $topic)) - (on-start (printf "Added discarded topic: ~a\n" topic)) - (on-stop (printf "Removed discarded topic: ~a\n" topic)))))] - no-crashes - (correct-topics)) - -(test-case ;; (B) - [(spawn #:name 'tony - (assert (researcher "Tony" "Computering")) - (assert (researcher "Tony" "Bicycling"))) - (spawn #:name 'alice - (assert (researcher "Alice" "Cryptography")) - (assert (researcher "Alice" "Bicycling"))) - (spawn #:name 'eve - (assert (researcher "Eve" "Cryptography")) - (assert (researcher "Eve" "Computering")) - (assert (researcher "Eve" "Evil"))) - - (spawn #:name 'all-topics - (during (researcher _ $topic) - (on-start (printf "Added topic: ~a\n" topic)) - (on-stop (printf "Removed topic: ~a\n" topic)))) - (spawn #:name 'all-researchers - (during (researcher (discard) $topic) - (on-start (printf "Added discarded topic: ~a\n" topic)) - (on-stop (printf "Removed discarded topic: ~a\n" topic))))] - no-crashes - (correct-topics)) diff --git a/OLD-syndicate/test/core/nesting-confusion.rkt b/OLD-syndicate/test/core/nesting-confusion.rkt deleted file mode 100644 index 3ee0977..0000000 --- a/OLD-syndicate/test/core/nesting-confusion.rkt +++ /dev/null @@ -1,145 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate/test-implementation -;; Uhoh! The current (2018-05-02) scheme for relaying between -;; dataspaces instantiates each pattern when a matching assertion -;; appears and then relays the result on via an ordinary assertion. -;; However, this is probably wrong! If one inner observer monitors -;; -;; (inbound (x _ $y)) -;; -;; while another monitors -;; -;; (inbound (x $z _)) -;; -;; then the second one will see a literal `(discard)` for `z`! - -(assertion-struct researcher (name topic)) - -(define no-mention-of-discard - (lambda () - (not (memf (lambda (line) (string-contains? line "#s(discard)")) - (collected-lines))))) - -(define-syntax-rule (correct-topics-and-researchers) - (expected-output (set "Added researcher: Alice" - "Added researcher: Eve" - "Added researcher: Tony" - "Added topic: Bicycling" - "Added topic: Computering" - "Added topic: Cryptography" - "Added topic: Evil"))) - -(test-case - [(spawn #:name 'tony - (assert (researcher "Tony" "Computering")) - (assert (researcher "Tony" "Bicycling"))) - (spawn #:name 'alice - (assert (researcher "Alice" "Cryptography")) - (assert (researcher "Alice" "Bicycling"))) - (spawn #:name 'eve - (assert (researcher "Eve" "Cryptography")) - (assert (researcher "Eve" "Computering")) - (assert (researcher "Eve" "Evil"))) - - (dataspace #:name 'inner-dataspace - (spawn #:name 'all-topics - (during (inbound (researcher _ $topic)) - (on-start (printf "Added topic: ~a\n" topic)) - (on-stop (printf "Removed topic: ~a\n" topic)))) - (spawn #:name 'all-researchers - (during (inbound (researcher $name _)) - (on-start (printf "Added researcher: ~a\n" name)) - (on-stop (printf "Removed researcher: ~a\n" name)))))] - no-crashes - no-mention-of-discard - (correct-topics-and-researchers)) - -(test-case - ;; This one is just like the one above, but doesn't have the - ;; nested dataspace, so the right answers are given. - [(spawn #:name 'tony - (assert (researcher "Tony" "Computering")) - (assert (researcher "Tony" "Bicycling"))) - (spawn #:name 'alice - (assert (researcher "Alice" "Cryptography")) - (assert (researcher "Alice" "Bicycling"))) - (spawn #:name 'eve - (assert (researcher "Eve" "Cryptography")) - (assert (researcher "Eve" "Computering")) - (assert (researcher "Eve" "Evil"))) - - (spawn #:name 'all-topics - (during (researcher _ $topic) - (on-start (printf "Added topic: ~a\n" topic)) - (on-stop (printf "Removed topic: ~a\n" topic)))) - (spawn #:name 'all-researchers - (during (researcher $name _) - (on-start (printf "Added researcher: ~a\n" name)) - (on-stop (printf "Removed researcher: ~a\n" name))))] - no-crashes - no-mention-of-discard - (correct-topics-and-researchers)) - -;;--------------------------------------------------------------------------- - -(assertion-struct claim (detail)) - -(define (asserts-then-retractions) - (and (equal? (length (collected-lines)) 4) - (equal? (list->set (take (collected-lines) 2)) (set "Specific claim asserted" - "Nonspecific claim 123 asserted")) - (equal? (list->set (drop (collected-lines) 2)) (set "Specific claim retracted" - "Nonspecific claim 123 retracted")))) - -(test-case - [(spawn #:name 'claimant - (assert (claim 123)) - (on-start (for [(i 5)] (flush!)) (stop-current-facet))) - (spawn #:name 'monitor - (during (claim 123) - (on-start (printf "Specific claim asserted\n")) - (on-stop (printf "Specific claim retracted\n"))) - (during (claim $detail) - (on-start (printf "Nonspecific claim ~v asserted\n" detail)) - (on-stop (printf "Nonspecific claim ~v retracted\n" detail))))] - no-crashes - asserts-then-retractions) - -(test-case - [(spawn #:name 'claimant - (assert (claim 123)) - (on-start (for [(i 5)] (flush!)) (stop-current-facet))) - (dataspace #:name 'inner-dataspace - (spawn #:name 'monitor - (during (inbound (claim 123)) - (on-start (printf "Specific claim asserted\n")) - (on-stop (printf "Specific claim retracted\n"))) - (during (inbound (claim $detail)) - (on-start (printf "Nonspecific claim ~v asserted\n" detail)) - (on-stop (printf "Nonspecific claim ~v retracted\n" detail)))))] - no-crashes - asserts-then-retractions) - -;;--------------------------------------------------------------------------- - -(test-case - [(dataspace #:name 'inner-dataspace - (spawn #:name 'inner-monitor - (during (inbound (claim $detail)) - (on-start (printf "Inner saw claim asserted\n")) - (on-stop (printf "Inner saw claim retracted\n"))))) - (spawn #:name 'claimant - (assert (claim 123)) - (on-start (printf "Outer claimant started\n")) - (on-stop (printf "Outer claimant stopped\n")) - (on-start (for [(i 5)] (flush!)) - (printf "Stopping outer claimant\n") - (stop-current-facet)))] - no-crashes - (expected-output (list "Outer claimant started" - "Inner saw claim asserted" - "Stopping outer claimant" - "Outer claimant stopped" - "Inner saw claim retracted"))) diff --git a/OLD-syndicate/test/core/partial-retraction.rkt b/OLD-syndicate/test/core/partial-retraction.rkt deleted file mode 100644 index 6560f56..0000000 --- a/OLD-syndicate/test/core/partial-retraction.rkt +++ /dev/null @@ -1,101 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate/test-implementation -;; See .../racket/syndicate/examples/actor/example-partial-retraction.rkt -;; TODO: deal with permissible permutations in the output - -(test-case - [(struct ready (what) #:prefab) - (struct entry (key val) #:prefab) - - (spawn (assert (ready 'listener)) - (on (asserted (entry $key _)) - (printf "key ~v asserted\n" key) - (until (retracted (entry key _)) - (on (asserted (entry key $value)) - (printf "add binding: ~v -> ~v\n" key value)) - (on (retracted (entry key $value)) - (printf "del binding: ~v -> ~v\n" key value))) - (printf "key ~v retracted\n" key))) - - (spawn (assert (ready 'other-listener)) - (during (entry $key _) - (printf "(other-listener) key ~v asserted\n" key) - (on-stop (printf "(other-listener) key ~v retracted\n" key)) - (during (entry key $value) - (printf "(other-listener) ~v ---> ~v\n" key value) - (on-stop (printf "(other-listener) ~v -/-> ~v\n" key value))))) - - (define (pause) - (displayln "pause") - (define token (gensym 'pause)) ;; FIXME:: If we use the same token every time, need epochs! - (until (asserted (ready token)) - (assert (ready token)))) - - (spawn* (until (asserted (ready 'listener))) - (until (asserted (ready 'other-listener))) - (assert! (entry 'a 1)) - (assert! (entry 'a 2)) - (assert! (entry 'b 3)) - (assert! (entry 'c 33)) - (assert! (entry 'a 4)) - (assert! (entry 'a 5)) - (pause) - (retract! (entry 'a 2)) - (retract! (entry 'c 33)) - (assert! (entry 'a 9)) - (pause) - (local-require "../../bag.rkt") - (for [(a (in-bag (current-adhoc-assertions)))] - (match a - [(entry 'a _) (retract! a)] - [_ (void)])) - ;; ^ (retract! (entry 'a ?)) - (pause))] - no-crashes - ;; To properly test this, we need something closer to real - ;; regular-expressions-with-interleave over output lines: - #;(expected-output (list "pause" - "pause") - (set "(other-listener) key 'a asserted" - "(other-listener) key 'c asserted" - "(other-listener) key 'b asserted") - (set "(other-listener) 'a ---> 4" - "(other-listener) 'a ---> 1" - "(other-listener) 'a ---> 2" - "(other-listener) 'a ---> 5" - "(other-listener) 'c ---> 33" - "(other-listener) 'b ---> 3") - (set "key 'a asserted" - "key 'c asserted" - "key 'b asserted") - (set "add binding: 'a -> 4" - "add binding: 'a -> 1" - "add binding: 'a -> 2" - "add binding: 'a -> 5" - "add binding: 'c -> 33" - "add binding: 'b -> 3") - (list "pause") - (set "del binding: 'a -> 2" - "del binding: 'c -> 33" - "add binding: 'a -> 9") - (set "key 'c retracted") - (set "(other-listener) 'a ---> 9" - "(other-listener) 'a -/-> 2" - "(other-listener) 'c -/-> 33" - "(other-listener) key 'c retracted") - (set "del binding: 'a -> 1" - "del binding: 'a -> 9" - "del binding: 'a -> 5" - "del binding: 'a -> 4") - (set "key 'a retracted") - (set "(other-listener) 'a -/-> 1" - "(other-listener) 'a -/-> 9" - "(other-listener) 'a -/-> 5" - "(other-listener) 'a -/-> 4") - (set "(other-listener) key 'a retracted") - (set "del binding: 'b -> 3") - (set "key 'b retracted") - (set "(other-listener) 'b -/-> 3") - (set "(other-listener) key 'b retracted"))) diff --git a/OLD-syndicate/test/core/pending-changes.rkt b/OLD-syndicate/test/core/pending-changes.rkt deleted file mode 100644 index 40ec883..0000000 --- a/OLD-syndicate/test/core/pending-changes.rkt +++ /dev/null @@ -1,111 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate/test-implementation -;; -;; In principle, we might like that actors within a turn should -;; respond to assertions currently in the database *as modified by -;; previous pending actions of the actor*. However, this doesn't -;; currently work. Not only does the syndicate -;; implementation not do this, the old syndicate implementation -;; doesn't do it either, and there's also a theoretical problem: Say -;; we had been asserting `'x`, and within a single turn, we retract it -;; and establish a facet responding to it. Should the new facet react -;; to `'x`? The answer can only be "maybe", because our own assertion -;; of `'x` may not be the only one in the dataspace. Therefore, -;; perhaps it's best just to keep the current situation, or its ideal -;; reflection perhaps, which is: within-turn actions should execute in -;; context of the dataspace state as it was at the beginning of the -;; turn. I'm not 100% sure whether the current implementation actually -;; provides this guarantee, but it must be quite close since it seems -;; to hold for the examples I've tried. -;; -;; This line of thinking is in reaction to an infelicity I noticed -;; while working on the client/server/federation code. The following -;; code, on connection drop, runs through the `boot-connection` loop -;; *twice* instead of just once, because the retraction of -;; `server-connected` hasn't had time to actually be reflected in the -;; dataspace by the time the reaction to `server-connected` is -;; (re)established. The `server-connected` record is withdrawn on the -;; next turn, leading to a second `boot-connection`, and the system -;; stabilises here because `server-connected` is no longer present. -;; -;; (let boot-connection () -;; (define root-facet (current-facet)) -;; (log-info "boot-connection ~v ~a" (current-facet) (facet-live? (current-facet))) -;; -;; (reassert-on (tcp-connection id (tcp-address host port)) -;; (retracted (tcp-accepted id)) -;; (asserted (tcp-rejected id _))) -;; -;; (during (tcp-accepted id) -;; (on-start (log-info "+tcp-accepted ~v ~a" (current-facet) id)) -;; (on-stop (log-info "-tcp-accepted ~v ~a" (current-facet) id)) -;; (assert (server-connected address)) -;; (define accumulate! (packet-accumulator (lambda (p) (send! (server-packet address p))))) -;; (on (message (tcp-in id $bs)) (accumulate! bs))) -;; -;; (during (server-connected address) -;; (on-start (log-info "+server-connected ~v ~a" (current-facet) address)) -;; (on-stop (log-info "-server-connected ~v ~a" (current-facet) address)) -;; ;; (on-start (send! (tcp-out id (encode (Connect scope))))) -;; (generic-client-session-facet address (lambda (x) (send! (tcp-out id (encode x))))) -;; (on-stop (log-info "---- ~v" (current-facet)) -;; (stop-facet root-facet -;; (log-info "!!!! ~v" (current-facet)) -;; (react (boot-connection)))))) -;; -;; The following test case is simplified but analogous to the problem -;; I noticed. Note particularly the `(flush!)` call, which is needed -;; to force the retraction of `'y` through to the dataspace and back -;; to the actor, so that the next `retry` doesn't improperly react to -;; a soon-to-be-retracted assertion of `'y`. - -(test-case - [ - (spawn* (until (asserted (observe 'x))) - (send! 'x)) - - ;; (spawn (on (asserted $anything) (printf "+ ~a\n" anything)) - ;; (on (retracted $anything) (printf "- ~a\n" anything)) - ;; (on (message $anything) (printf "! ~a\n" anything))) - - (spawn (let retry ((n 0)) - (cond [(>= n 10) (printf "Exceeded count\n")] - [else - (define f (current-facet)) - ;; (during 'x (assert 'y)) - (on (message 'x) - (react (assert 'y) - (on (asserted (observe 'go)) - (send! 'go)))) - (during ($ val 'y) - (on-start (printf "+++++ ~a\n" val)) - (on-stop (printf "----- ~a\n" val)) - (on (message 'go) - (printf "going\n") - (stop-current-facet)) - (on-stop - (printf "stopping\n") - (stop-facet f - (printf "calling retry\n") - (flush!) ;; !!!! Crucial! - (react (retry (+ n 1))))))]))) - ] - no-crashes - (expected-output (list "+++++ y" - "going" - "----- y" - ;; - ;; (If we comment out the `(flush!)` above, - ;; the following additional events appear - ;; here, reflecting the unwanted reaction to - ;; the doomed `'y` assertion:) - ;; - ;; "stopping" - ;; "calling retry" - ;; "+++++ y" - ;; "----- y" - ;; - "stopping" - "calling retry"))) diff --git a/OLD-syndicate/test/core/responsibility-transfer-1.rkt b/OLD-syndicate/test/core/responsibility-transfer-1.rkt deleted file mode 100644 index d1b097f..0000000 --- a/OLD-syndicate/test/core/responsibility-transfer-1.rkt +++ /dev/null @@ -1,36 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate/test-implementation -;; See .../syndicate/examples/actor/example-responsibility-transfer-1.rkt - -(test-case - [(spawn #:name 'demand-watcher - (during/spawn 'demand - #:name (gensym 'intermediate-demand-asserter) - (assert 'intermediate-demand))) - - (spawn #:name 'intermediate-demand-watcher - (during/spawn 'intermediate-demand - #:name (gensym 'supply-asserter) - (assert 'supply))) - - (spawn* #:name 'driver - (react (on (asserted 'supply) (displayln "Supply asserted.")) - (on (retracted 'supply) (displayln "Supply retracted."))) - (until (asserted (observe 'demand))) - (displayln "Asserting demand.") - (assert! 'demand) - (until (asserted 'supply)) - (displayln "Glitching demand.") - (retract! 'demand) - (flush!) - (assert! 'demand) - (displayln "Demand now steady."))] - no-crashes - (expected-output (list "Asserting demand." - "Supply asserted." - "Glitching demand." - "Demand now steady." - "Supply retracted." - "Supply asserted."))) diff --git a/OLD-syndicate/test/core/responsibility-transfer-2.rkt b/OLD-syndicate/test/core/responsibility-transfer-2.rkt deleted file mode 100644 index 71a3451..0000000 --- a/OLD-syndicate/test/core/responsibility-transfer-2.rkt +++ /dev/null @@ -1,74 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate/test-implementation -;; Suite of four related tests. -;; See .../syndicate/examples/actor/example-responsibility-transfer-2.rkt - -(test-case - [(spawn #:name 'factory-1 - (on (asserted (list 'X 1)) - (spawn #:name 'service-1 - #:assertions [(observe (list 'X 1))] ;; (A) - (stop-when (retracted (list 'X 1))) ;; (B) - (on (message 'dummy))) - (stop-current-facet))) - (spawn (on (asserted (observe (list 'X $supplier))) - (printf "Supply ~v asserted.\n" supplier) - (assert! (list 'X supplier))) - (on (retracted (observe (list 'X $supplier))) - (printf "Supply ~v retracted.\n" supplier)))] - no-crashes - (expected-output (list "Supply 1 asserted."))) - -(test-case - [(spawn #:name 'factory-1 - (on (asserted (list 'X 1)) - (spawn #:name 'service-1 - ;; #:assertions [(observe (list 'X 1))] ;; (A) - (stop-when (retracted (list 'X 1))) ;; (B) - (on (message 'dummy))) - (stop-current-facet))) - (spawn (on (asserted (observe (list 'X $supplier))) - (printf "Supply ~v asserted.\n" supplier) - (assert! (list 'X supplier))) - (on (retracted (observe (list 'X $supplier))) - (printf "Supply ~v retracted.\n" supplier)))] - no-crashes - (expected-output (list "Supply 1 asserted." - "Supply 1 retracted." - "Supply 1 asserted."))) - -(test-case - [(spawn #:name 'factory-1 - (on (asserted (list 'X 1)) - (spawn #:name 'service-1 - #:assertions [(observe (list 'X 1))] ;; (A) - ;; (stop-when (retracted (list 'X 1))) ;; (B) - (on (message 'dummy))) - (stop-current-facet))) - (spawn (on (asserted (observe (list 'X $supplier))) - (printf "Supply ~v asserted.\n" supplier) - (assert! (list 'X supplier))) - (on (retracted (observe (list 'X $supplier))) - (printf "Supply ~v retracted.\n" supplier)))] - no-crashes - (expected-output (list "Supply 1 asserted." - "Supply 1 retracted."))) - -(test-case - [(spawn #:name 'factory-1 - (on (asserted (list 'X 1)) - (spawn #:name 'service-1 - ;; #:assertions [(observe (list 'X 1))] ;; (A) - ;; (stop-when (retracted (list 'X 1))) ;; (B) - (on (message 'dummy))) - (stop-current-facet))) - (spawn (on (asserted (observe (list 'X $supplier))) - (printf "Supply ~v asserted.\n" supplier) - (assert! (list 'X supplier))) - (on (retracted (observe (list 'X $supplier))) - (printf "Supply ~v retracted.\n" supplier)))] - no-crashes - (expected-output (list "Supply 1 asserted." - "Supply 1 retracted."))) diff --git a/OLD-syndicate/test/core/simple-addition.rkt b/OLD-syndicate/test/core/simple-addition.rkt deleted file mode 100644 index 77b35c8..0000000 --- a/OLD-syndicate/test/core/simple-addition.rkt +++ /dev/null @@ -1,16 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate/test-implementation - -(test-case - [(assertion-struct one-plus (n m)) - (spawn #:name 'add1-server - (during/spawn (observe (one-plus $n _)) - #:name (list 'solving 'one-plus n) - (assert (one-plus n (+ n 1))))) - (spawn #:name 'client-process - (stop-when (asserted (one-plus 3 $value)) - (printf "1 + 3 = ~a\n" value)))] - no-crashes - (expected-output (list "1 + 3 = 4"))) diff --git a/OLD-syndicate/test/core/simple-box-and-client.rkt b/OLD-syndicate/test/core/simple-box-and-client.rkt deleted file mode 100644 index 817efba..0000000 --- a/OLD-syndicate/test/core/simple-box-and-client.rkt +++ /dev/null @@ -1,32 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate/test-implementation -;; Box-and-client - -(test-case - [(message-struct set-box (new-value)) - (assertion-struct box-state (value)) - - (spawn (field [current-value 0]) - (assert (box-state (current-value))) - (stop-when-true (= (current-value) 3) - (displayln "box: terminating")) - (on (message (set-box $new-value)) - (printf "box: taking on new-value ~v\n" new-value) - (current-value new-value))) - - (spawn (stop-when (retracted (observe (set-box _))) - (displayln "client: box has gone")) - (on (asserted (box-state $v)) - (printf "client: learned that box's value is now ~v\n" v) - (send! (set-box (+ v 1)))))] - no-crashes - (expected-output (list "client: learned that box's value is now 0" - "box: taking on new-value 1" - "client: learned that box's value is now 1" - "box: taking on new-value 2" - "client: learned that box's value is now 2" - "box: taking on new-value 3" - "box: terminating" - "client: box has gone"))) diff --git a/OLD-syndicate/test/core/simple-cross-layer.rkt b/OLD-syndicate/test/core/simple-cross-layer.rkt deleted file mode 100644 index ec98190..0000000 --- a/OLD-syndicate/test/core/simple-cross-layer.rkt +++ /dev/null @@ -1,24 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate/test-implementation - -(test-case - [(assertion-struct greeting (text)) - - (spawn #:name "A" (assert (greeting "Hi from outer space!"))) - (spawn #:name "B" (on (asserted (greeting $t)) - (printf "Outer dataspace: ~a\n" t))) - - (dataspace #:name "C" - (spawn #:name "D" (assert (outbound (greeting "Hi from inner!")))) - (spawn #:name "E" (on (asserted (inbound (greeting $t))) - (printf "Inner dataspace: ~a\n" t))))] - no-crashes - ;; There are constraints not expressed here; to properly test this, - ;; we need something closer to real - ;; regular-expressions-with-interleave over output lines. - (expected-output (set "Outer dataspace: Hi from outer space!" - "Inner dataspace: Hi from outer space!" - "Outer dataspace: Hi from inner!" - "Inner dataspace: Hi from inner!"))) diff --git a/OLD-syndicate/test/core/skeleton.rkt b/OLD-syndicate/test/core/skeleton.rkt deleted file mode 100644 index 7c18d30..0000000 --- a/OLD-syndicate/test/core/skeleton.rkt +++ /dev/null @@ -1,113 +0,0 @@ -#lang racket/base -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -(require "../../skeleton.rkt") -(require (submod "../../skeleton.rkt" for-test)) - -(module+ test - (require rackunit) - - (struct a (x y) #:transparent) - (struct b (v) #:transparent) - (struct c (v) #:transparent) - (struct d (x y z) #:transparent) - - (define sk - (make-empty-skeleton/cache - (make-hash (for/list [(x (list (a (b 'bee) (b 'cat)) - (a (b 'foo) (c 'bar)) - (a (b 'foo) (c 'BAR)) - (a (c 'bar) (b 'foo)) - (a (c 'dog) (c 'fox)) - (d (b 'DBX) (b 'DBY) (b 'DBZ)) - (d (c 'DCX) (c 'DCY) (c 'DCZ)) - (b 'zot) - 123))] - (cons x #t))))) - - (define i1 - (skeleton-interest (list struct:a (list struct:b #f) #f) - '((0 0)) - '(foo) - '((1)) - (lambda (op . bindings) - (printf "xAB HANDLER: ~v ~v\n" op bindings)) - (lambda (vars) - (printf "xAB CLEANUP: ~v\n" vars)))) - - (add-interest! sk i1) - - (void (extend-skeleton! sk (list struct:a (list struct:b #f) #f))) - (void (extend-skeleton! sk (list struct:a #f (list struct:c #f)))) - (void (extend-skeleton! sk (list struct:a #f (list struct:c (list struct:b #f))))) - (void (extend-skeleton! sk (list struct:a #f #f))) - (void (extend-skeleton! sk (list struct:c #f))) - (void (extend-skeleton! sk (list struct:b #f))) - (void (extend-skeleton! sk (list struct:d (list struct:b #f) #f (list struct:b #f)))) - (void (extend-skeleton! sk (list struct:d (list struct:b #f) #f (list struct:c #f)))) - (void (extend-skeleton! sk (list struct:d (list struct:c #f) #f (list struct:b #f)))) - (void (extend-skeleton! sk (list struct:d (list struct:c #f) #f (list struct:c #f)))) - (check-eq? sk (extend-skeleton! sk #f)) - - (add-interest! sk - (skeleton-interest (list struct:d (list struct:b #f) #f (list struct:c #f)) - '((2 0)) - '(DCZ) - '(() (0) (0 0) (1)) - (lambda (op . bindings) - (printf "DBC HANDLER: ~v ~v\n" op bindings)) - (lambda (vars) - (printf "DBC CLEANUP: ~v\n" vars)))) - - (remove-assertion! sk (a (b 'foo) (c 'bar))) - (remove-assertion! sk (d (b 'B1) (b 'DBY) (c 'DCZ))) - (add-assertion! sk (d (b 'B1) (b 'DBY) (c 'DCZ))) - (add-assertion! sk (d (b 'BX) (b 'DBY) (c 'DCZ))) - (add-assertion! sk (d (b 'B1) (b 'DBY) (c 'CX))) - (add-assertion! sk (d (b 'B1) (b 'DBY) (c 'DCZ))) - (add-assertion! sk (d (b 'BX) (b 'DBY) (c 'DCZ))) - (add-assertion! sk (d (b 'B1) (b 'DBY) (c 'CX))) - - (add-interest! sk - (skeleton-interest (list struct:d #f (list struct:b #f) #f) - '((1 0)) - '(DBY) - '((0) (2)) - (lambda (op . bindings) - (printf "xDB HANDLER: ~v ~v\n" op bindings)) - (lambda (vars) - (printf "xDB CLEANUP: ~v\n" vars)))) - - (send-assertion! sk (d (b 'BX) (b 'DBY) (c 'DCZ))) - (send-assertion! sk (d (b 'BX) (b 'DBY) (c 'DCZ))) - - (remove-assertion! sk (d (b 'B1) (b 'DBY) (c 'DCZ))) - (remove-assertion! sk (d (b 'BX) (b 'DBY) (c 'DCZ))) - (remove-assertion! sk (d (b 'B1) (b 'DBY) (c 'CX))) - (remove-assertion! sk (d (b 'B1) (b 'DBY) (c 'DCZ))) - (remove-assertion! sk (d (b 'BX) (b 'DBY) (c 'DCZ))) - (remove-assertion! sk (d (b 'B1) (b 'DBY) (c 'CX))) - ;; sk - - (remove-interest! sk i1) - - (check-eq? (path-cmp '() '()) '=) - (check-eq? (path-cmp '(1 1) '(1 1)) '=) - (check-eq? (path-cmp '(2 2) '(2 2)) '=) - (check-eq? (path-cmp '(2 1) '(1 1)) '>) - (check-eq? (path-cmp '(1 1) '(2 1)) '<) - (check-eq? (path-cmp '(2 1) '(1 2)) '>) - (check-eq? (path-cmp '(1 2) '(2 1)) '<) - (check-eq? (path-cmp '(2) '(1 1)) '>) - (check-eq? (path-cmp '(1) '(2 1)) '<) - (check-eq? (path-cmp '(2) '(1 2)) '>) - (check-eq? (path-cmp '(1) '(2 1)) '<) - (check-eq? (path-cmp '(2 1) '(1)) '>) - (check-eq? (path-cmp '(1 1) '(2)) '<) - (check-eq? (path-cmp '(2 1) '(1)) '>) - (check-eq? (path-cmp '(1 2) '(2)) '<) - (check-eq? (path-cmp '(1 2) '(1 2)) '=) - (check-eq? (path-cmp '(1) '(1 2)) '<) - (check-eq? (path-cmp '(1 2) '(1)) '>) - ) diff --git a/OLD-syndicate/test/core/spawn-and-send.rkt b/OLD-syndicate/test/core/spawn-and-send.rkt deleted file mode 100644 index 5541e40..0000000 --- a/OLD-syndicate/test/core/spawn-and-send.rkt +++ /dev/null @@ -1,49 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate/test-implementation -;; Test the "spawn and send" idiom, where event ordering is exploited -;; to ensure a listener is ready by the time a sent message is ready -;; for delivery. -;; -;; I'm still not 100% convinced this is the way things really ought to -;; work. In old-Syndicate, the assertion of interest was exactly the -;; same as installation of a handler-procedure, and the one could not -;; occur before the other. Here, the installation of the handler -;; happens *before* declaration of interest: in particular, no -;; separate `#:assertions` clause is needed to ensure routing of the -;; `(item)` message to the newly spawned `server` process. In -;; old-Syndicate, the spawner of `server` would have to include -;; `(observe (item))` in order for the `(item)` not to be dropped by -;; the `server`. Perhaps this new-Syndicate should include handlers in -;; patches, somehow, so that the declaration-of-interest and -;; installation-of-handler move together? Then the `#:assertions` -;; would really be `#:transient-endpoints` and would include `(assert -;; ...)` and `(on ...)`, which is a bit jolly strange, so perhaps the -;; current behaviour is better after all? - -(test-case - [(message-struct item ()) - (message-struct server-present (how)) - (spawn #:name 'main - (on (message (item)) - (printf "Item received by main\n")) - (during (server-present $how) - (on-start (printf "Server is present: ~a\n" how)) - (on-stop (printf "Server is not present: ~a\n" how))) - (on-start (printf "Spawning server\n") - (spawn #:name 'server - #:assertions [(server-present 'outside)] - (assert (server-present 'inside)) - (on (message (item)) - (printf "Item received by server\n"))) - (printf "Sending item\n") - (send! (item))))] - no-crashes - (expected-output (list "Spawning server" - "Sending item" - "Server is present: outside") - (set "Item received by main" - "Item received by server") - (list "Server is present: inside" - "Server is not present: outside"))) diff --git a/OLD-syndicate/test/core/state-machine.rkt b/OLD-syndicate/test/core/state-machine.rkt deleted file mode 100644 index 900957f..0000000 --- a/OLD-syndicate/test/core/state-machine.rkt +++ /dev/null @@ -1,30 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate/test-implementation - -(test-case - [(message-struct toggle ()) - (spawn* #:name 'flip-flop - (define (even) - (react (stop-when (message (toggle)) (odd)) - (on-start (printf "+even\n")) - (on-stop (printf "-even\n")))) - (define (odd) - (react (stop-when (message (toggle)) (even)) - (on-start (printf "+odd\n")) - (on-stop (printf "-odd\n")))) - (even)) - (spawn* #:name 'main - (until (asserted (observe (toggle)))) - (send! (toggle)) - (send! (toggle)) - (send! (toggle)))] - no-crashes - (expected-output (list "+even" - "-even" - "+odd" - "-odd" - "+even" - "-even" - "+odd"))) diff --git a/OLD-syndicate/test/core/supervise.rkt b/OLD-syndicate/test/core/supervise.rkt deleted file mode 100644 index 2dff143..0000000 --- a/OLD-syndicate/test/core/supervise.rkt +++ /dev/null @@ -1,55 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate/test-implementation -;; Simple tests of supervision functionality. - -(require syndicate/supervise) - -(test-case - [(supervise #:name 'ward - (on-start (printf "Starting ward\n")) - (on-stop (printf "Stopping ward\n")) - (on (message 'crash) - (printf "Crashing\n") - (error 'ward "Eep!")) - (stop-when (message 'quit) - (printf "Bye!\n"))) - - (define (monitor-interest-in thing) - (spawn #:name (list 'monitor-interest-in thing) - (during (observe thing) - (on-start (printf "Interest in ~v appeared\n" thing)) - (on-stop (printf "Interest in ~v disappeared\n" thing))))) - - (monitor-interest-in 'crash) - (monitor-interest-in 'quit) - - (spawn* #:name 'main - (until (asserted (observe 'crash))) - (send! 'crash) - (flush!) - (flush!) - (flush!) - ;; ^ give it time to actually terminate - ;; v then wait for the next instance to appear - (until (asserted (observe 'quit))) - (send! 'quit))] - - (it "should cause ward to produce an exception" - (actor-died? 'ward "Eep!")) - (it "should cause exactly one crash in total" - (= (length (collected-exns)) 1)) - (expected-output (list "Starting ward") - (set "Interest in 'crash appeared" - "Interest in 'quit appeared") - (list "Crashing") - (set "Interest in 'quit disappeared" - "Interest in 'crash disappeared") - (list "Starting ward") - (set "Interest in 'crash appeared" - "Interest in 'quit appeared") - (list "Stopping ward" - "Bye!") - (set "Interest in 'quit disappeared" - "Interest in 'crash disappeared"))) diff --git a/OLD-syndicate/test/distributed/nesting-confusion.rkt b/OLD-syndicate/test/distributed/nesting-confusion.rkt deleted file mode 100644 index 3656ef5..0000000 --- a/OLD-syndicate/test/distributed/nesting-confusion.rkt +++ /dev/null @@ -1,110 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate/test-implementation -;; Analogous to the `core/nesting-confusion.rkt` test case. - -(require (only-in syndicate/lang activate)) -(require syndicate/distributed) -(require syndicate/distributed/internal-protocol) - -(require (submod syndicate/distributed/heartbeat for-testing)) -(heartbeats-enabled? #f) - -(assertion-struct researcher (name topic)) - -(define test-address (server-loopback-connection "test")) - -(define no-mention-of-discard - (lambda () - (not (memf (lambda (line) (string-contains? line "#s(discard)")) - (collected-lines))))) - -(define-syntax-rule (correct-topics-and-researchers) - (expected-output (set "Added researcher: Alice" - "Added researcher: Eve" - "Added researcher: Tony" - "Added topic: Bicycling" - "Added topic: Computering" - "Added topic: Cryptography" - "Added topic: Evil"))) - -(test-case - [(activate syndicate/distributed) - - (spawn #:name 'tony - (assert (server-proposal "test" (researcher "Tony" "Computering"))) - (assert (server-proposal "test" (researcher "Tony" "Bicycling")))) - (spawn #:name 'alice - (assert (server-proposal "test" (researcher "Alice" "Cryptography"))) - (assert (server-proposal "test" (researcher "Alice" "Bicycling")))) - (spawn #:name 'eve - (assert (server-proposal "test" (researcher "Eve" "Cryptography"))) - (assert (server-proposal "test" (researcher "Eve" "Computering"))) - (assert (server-proposal "test" (researcher "Eve" "Evil")))) - - (spawn #:name 'all-topics - (during (server-connected test-address) - (during (from-server test-address (researcher _ $topic)) - (on-start (printf "Added topic: ~a\n" topic)) - (on-stop (printf "Removed topic: ~a\n" topic))))) - (spawn #:name 'all-researchers - (during (server-connected test-address) - (during (from-server test-address (researcher $name _)) - (on-start (printf "Added researcher: ~a\n" name)) - (on-stop (printf "Removed researcher: ~a\n" name)))))] - no-crashes - no-mention-of-discard - (correct-topics-and-researchers)) - -;;--------------------------------------------------------------------------- - -(assertion-struct claim (detail)) - -(define (asserts-then-retractions) - (and (equal? (length (collected-lines)) 4) - (equal? (list->set (take (collected-lines) 2)) (set "Specific claim asserted" - "Nonspecific claim 123 asserted")) - (equal? (list->set (drop (collected-lines) 2)) (set "Specific claim retracted" - "Nonspecific claim 123 retracted")))) - -(test-case - [(activate syndicate/distributed) - - (spawn #:name 'claimant - (assert (server-proposal "test" (claim 123))) - (on-start (for [(i 100)] (flush!)) (stop-current-facet))) - (spawn #:name 'monitor - (during (server-connected test-address) - (during (from-server test-address (claim 123)) - (on-start (printf "Specific claim asserted\n")) - (on-stop (printf "Specific claim retracted\n"))) - (during (from-server test-address (claim $detail)) - (on-start (printf "Nonspecific claim ~v asserted\n" detail)) - (on-stop (printf "Nonspecific claim ~v retracted\n" detail)))))] - no-crashes - asserts-then-retractions) - -;;--------------------------------------------------------------------------- - -(test-case - [(activate syndicate/distributed) - - (spawn #:name 'inner-monitor - (during (server-connected test-address) - (during (from-server test-address (claim $detail)) - (on-start (printf "Inner saw claim asserted\n")) - (on-stop (printf "Inner saw claim retracted\n"))))) - (spawn #:name 'claimant - (assert (server-proposal "test" (claim 123))) - (on-start (printf "Outer claimant started\n")) - (on-stop (printf "Outer claimant stopped\n")) - (on-start (for [(i 100)] (flush!)) - (printf "Stopping outer claimant\n") - (stop-current-facet)))] - no-crashes - (expected-output (list "Outer claimant started" - "Inner saw claim asserted" - "Stopping outer claimant" - "Outer claimant stopped" - "Inner saw claim retracted"))) diff --git a/OLD-syndicate/test/distributed/observation-visibility.rkt b/OLD-syndicate/test/distributed/observation-visibility.rkt deleted file mode 100644 index b36828b..0000000 --- a/OLD-syndicate/test/distributed/observation-visibility.rkt +++ /dev/null @@ -1,37 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate/test-implementation -;; A client observing some part of the server's dataspace should cause -;; creation of an assertion of observation in that server's dataspace. - -(require (only-in syndicate/lang activate)) -(require syndicate/distributed) - -(require (submod syndicate/distributed/heartbeat for-testing)) -(heartbeats-enabled? #f) - -(assertion-struct presence (who)) - -(define test-address (server-loopback-connection "test")) - -(test-case - [(activate syndicate/distributed) - - (spawn #:name 'producer - (during (server-connected test-address) - (assert (to-server test-address (presence 'producer))))) - - (spawn #:name 'consumer - (during (server-connected test-address) - (on (asserted (from-server test-address (presence $who))) - (printf "~a joined\n" who)))) - - (spawn #:name 'metaconsumer - (during (server-connected test-address) - (on (asserted (from-server test-address (observe (presence _)))) - (printf "Someone cares about presence!\n")))) - ] - no-crashes - (expected-output (set "producer joined" - "Someone cares about presence!"))) diff --git a/OLD-syndicate/test/pattern-test.rkt b/OLD-syndicate/test/pattern-test.rkt deleted file mode 100644 index d03d508..0000000 --- a/OLD-syndicate/test/pattern-test.rkt +++ /dev/null @@ -1,71 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang racket - -(module+ test - (require rackunit) - - (require (for-syntax racket/base)) - (require (for-syntax syntax/srcloc)) - (require (for-template "../pattern.rkt")) - (require "../pattern.rkt") - - (struct foo (bar zot) #:prefab) - - (define-syntax (check-analyse-pattern stx) - (syntax-case stx () - [(_ expected-pat actual-stxpat fn) - #`(with-check-info [('real-location #,(source-location->string stx))] - (check-match (fn '#,(analyse-pattern #'actual-stxpat)) expected-pat))] - [(_ expected-pat actual-stxpat) - #'(check-analyse-pattern expected-pat actual-stxpat values)])) - - (check-analyse-pattern `(compound ,_ (atom 123) (atom 234)) (foo 123 234)) - (check-analyse-pattern `(compound ,_ (discard) (atom 234)) (foo _ 234)) - (check-analyse-pattern `(compound ,_ (atom 123) (atom xyzzy)) (foo 123 xyzzy)) - (check-analyse-pattern `(compound ,_ (atom 123) (capture cap (discard))) (foo 123 $cap)) - (check-analyse-pattern `(compound ,_ (atom 123) (capture cap (atom 234))) (foo 123 ($ cap 234))) - - (check-analyse-pattern `(atom (bar 123 234)) (bar 123 234)) - (check-analyse-pattern `(atom (bar 123 $beep)) (bar 123 $beep)) - - (check-analyse-pattern `(compound list (atom 123) (capture q (discard))) (list 123 $q)) - - (define ((s->d f) desc) (syntax->datum (f desc))) - - (check-analyse-pattern '() $cap desc->key) - (check-analyse-pattern '() $cap desc->skeleton-proj) - (check-analyse-pattern '(()) $cap desc->capture-proj) - (check-analyse-pattern '#f $cap (s->d desc->skeleton-stx)) - (check-analyse-pattern '(capture (discard)) $cap (s->d desc->assertion-stx)) - - (check-analyse-pattern '(123) (foo 123 $cap) desc->key) - (check-analyse-pattern '((0)) (foo 123 $cap) desc->skeleton-proj) - (check-analyse-pattern '((1)) (foo 123 $cap) desc->capture-proj) - (check-analyse-pattern '(list struct:foo #f #f) (foo 123 $cap) (s->d desc->skeleton-stx)) - (check-analyse-pattern '(foo 123 (capture (discard))) (foo 123 $cap) (s->d desc->assertion-stx)) - - (check-analyse-pattern '((bar 'beep)) (foo (bar 'beep) $cap) desc->key) - (check-analyse-pattern '((0)) (foo (bar 'beep) $cap) desc->skeleton-proj) - (check-analyse-pattern '((1)) (foo (bar 'beep) $cap) desc->capture-proj) - (check-analyse-pattern '(list struct:foo #f #f) (foo (bar 'beep) $cap) (s->d desc->skeleton-stx)) - (check-analyse-pattern '(foo (bar 'beep) (capture (discard))) - (foo (bar 'beep) $cap) - (s->d desc->assertion-stx)) - - (define-pattern-expander foo123 - (syntax-rules () - [(_ zot) (foo 123 zot)])) - - (define-pattern-expander foo234 - (syntax-rules () - [(_ zot) (foo 234 zot)]) - (syntax-rules () - [(_ zot) (foo 234 zot)])) - - (check-analyse-pattern `(compound ,_ (atom 123) (atom 'zot)) (foo123 'zot)) - (check-analyse-pattern `(compound ,_ (atom 234) (atom 'zot)) (foo234 'zot)) - (check-equal? (foo 234 'zot) (foo234 'zot)) - - ) diff --git a/OLD-syndicate/test/raw-dataspace.rkt b/OLD-syndicate/test/raw-dataspace.rkt deleted file mode 100644 index c60ee10..0000000 --- a/OLD-syndicate/test/raw-dataspace.rkt +++ /dev/null @@ -1,112 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang racket/base - -(require racket/set) -(require "../test-implementation.rkt") -(require "../main.rkt") -(require "../pattern.rkt") -(require "../skeleton.rkt") - -(test-case - [(message-struct set-box (new-value)) - (assertion-struct box-state (value)) - - (spawn! - (current-actor) - 'box - (lambda () - (define current-value (field-handle 'current-value - (generate-id! (actor-dataspace (current-actor))) - (current-actor) - 0)) - (add-endpoint! (current-facet) - 'stop-when-ten - #t - (lambda () - (when (= (current-value) 3) - (stop-facet! (current-facet) - (lambda () - (printf "box: terminating\n")))) - (values (void) #f))) - (add-endpoint! (current-facet) - 'assert-box-state - #t - (lambda () (values (box-state (current-value)) #f))) - (add-endpoint! - (current-facet) - 'on-message-set-box - #t - (lambda () - (values (observe (set-box (capture (discard)))) - (skeleton-interest (list struct:set-box #f) - '() - '() - '((0)) - (capture-facet-context - (lambda (op new-value) - (when (eq? '! op) - (schedule-script! - (current-actor) - (lambda () - (printf "box: taking on new-value ~v\n" - new-value) - (current-value new-value)))))) - #f))))) - (set)) - - (spawn! - (current-actor) - 'client - (lambda () - (add-endpoint! - (current-facet) - 'stop-when-retracted-observe-set-box - #t - (lambda () - (values (observe (observe (set-box (discard)))) - (skeleton-interest (list struct:observe (list struct:set-box #f)) - '() - '() - '() - (capture-facet-context - (lambda (op) - (when (eq? '- op) - (stop-facet! - (current-facet) - (lambda () - (printf "client: box has gone\n")))))) - #f)))) - (add-endpoint! - (current-facet) - 'on-asserted-box-state - #t - (lambda () - (values (observe (box-state (capture (discard)))) - (skeleton-interest (list struct:box-state #f) - '() - '() - '((0)) - (capture-facet-context - (lambda (op v) - (when (eq? '+ op) - (schedule-script! - (current-actor) - (lambda () - (printf - "client: learned that box's value is now ~v\n" - v) - (enqueue-send! (current-actor) - (set-box (+ v 1)))))))) - #f))))) - (set))] - no-crashes - (expected-output (list "client: learned that box's value is now 0" - "box: taking on new-value 1" - "client: learned that box's value is now 1" - "box: taking on new-value 2" - "client: learned that box's value is now 2" - "box: taking on new-value 3" - "box: terminating" - "client: box has gone"))) diff --git a/OLD-syndicate/test/speed/speed-box-and-client.rkt b/OLD-syndicate/test/speed/speed-box-and-client.rkt deleted file mode 100644 index 2b512f4..0000000 --- a/OLD-syndicate/test/speed/speed-box-and-client.rkt +++ /dev/null @@ -1,25 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate/test-implementation - -(let ((N 25000)) - (test-case - ;; Box-and-client speed test - [(message-struct set-box (new-value)) - (assertion-struct box-state (value)) - (spawn (field [current-value 0]) - (assert (box-state (current-value))) - (stop-when-true (= (current-value) N)) - (on (message (set-box $new-value)) - (current-value new-value))) - (spawn (stop-when (retracted (observe (set-box _)))) - (on (asserted (box-state $v)) - (send! (set-box (+ v 1)))))] - no-crashes - (expected-output) - (it "should be reasonably quick" - (log-info "Rough box-and-client speed: ~a cycles in ~a ms = ~a Hz" - N - (test-run-time) - (/ N (/ (test-run-time) 1000.0)))))) diff --git a/OLD-syndicate/test/speed/speed-message-sending.rkt b/OLD-syndicate/test/speed/speed-message-sending.rkt deleted file mode 100644 index c490561..0000000 --- a/OLD-syndicate/test/speed/speed-message-sending.rkt +++ /dev/null @@ -1,19 +0,0 @@ -;;; SPDX-License-Identifier: LGPL-3.0-or-later -;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones - -#lang syndicate/test-implementation -;; Rough message send speed test - -(let ((N 100000)) - (test-case - [(spawn (on (message $v) - (if (= v N) - (stop-current-facet) - (send! (+ v 1)))) - (on-start (send! 0)))] - no-crashes - (it "should be fairly quick" - (log-info "Rough message send speed: ~a msgs in ~a ms = ~a Hz" - N - (test-run-time) - (/ N (/ (test-run-time) 1000.0))))))