syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Remove old implementation from git

This commit is contained in:
Tony Garnock-Jones 2021-06-22 16:06:03 +02:00
parent b05451972b
commit c8f32f1910
166 changed files with 0 additions and 13075 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
OLD-syndicate-examples/chat-client.rkt
View File

@ -1,37 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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")))))))

32
OLD-syndicate-examples/chat-server-nested-dataspace.rkt
View File

@ -1,32 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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"))))))))))

33
OLD-syndicate-examples/chat-server.rkt
View File

@ -1,33 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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"))))))))

16
OLD-syndicate-examples/echo.rkt
View File

@ -1,16 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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)))))))

34
OLD-syndicate-examples/filesystem.rkt
View File

@ -1,34 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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)))

136
OLD-syndicate-examples/gl-2d-basic.rkt
View File

@ -1,136 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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)

90
OLD-syndicate-examples/gl-2d-clock-face.rkt
View File

@ -1,90 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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)

87
OLD-syndicate-examples/gl-2d-many.rkt
View File

@ -1,87 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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))))

828
OLD-syndicate-examples/gl-2d-platformer.rkt
View File

@ -1,828 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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))

22
OLD-syndicate-examples/gui/README.md
View File

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

665
OLD-syndicate-examples/gui/gui.rkt
View File

@ -1,665 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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-<? datum-order)
#:key layout-item-spec-key)
#:default '())
(define/dataflow table
(if vertical?
(map list (map layout-item-size (ordered-items)))
(list (map layout-item-size (ordered-items)))))
(solve-layout* container-id
table
(lambda (layout)
(for [(item (ordered-items))
(cell (if vertical? (map car layout) (car layout)))]
(assert! (layout-solution container-id
(if vertical?
(vertical-layout (layout-item-spec item))
(horizontal-layout (layout-item-spec item)))
(layout-item-size item)
cell))))))
(define (merge-box-size existing computed)
(match existing
[#f computed]
[(box-size h v)
(box-size (or h (box-size-horizontal computed))
(or v (box-size-vertical computed)))]))
(define (solve-layout* container-id table on-layout)
(during (requested-layout-size container-id $reqsize)
(define/dataflow total-size (merge-box-size reqsize (table-sizing (table))))
(assert (computed-layout-size container-id (total-size)))
(define (total-width) (sizing-ideal (box-size-horizontal (total-size))))
(define (total-height) (sizing-ideal (box-size-vertical (total-size))))
(define/dataflow layout (table-layout (table) 0 0 (total-width) (total-height)) #:default '())
(begin/dataflow
(for [(a (in-bag (current-adhoc-assertions)))]
(match a
[(layout-solution (== container-id) _ _ _) (retract! a)]
[_ (void)]))
(on-layout (layout)))))
(define (solve-tabular-layout container-id)
(define/query-set items
(observe (layout-solution container-id (tabular-layout $row $col) $size _))
(layout-item (cons row col) size))
(define/dataflow items-table
(let* ((specs (map layout-item-spec (set->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 (<sprite> $id 'root $z _))
(heap-add! (widget-heap) (cons id z))
(trigger-dependencies!))
(on (retracted (<sprite> $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)

32
OLD-syndicate-examples/gui/hsv.rkt
View File

@ -1,32 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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))

194
OLD-syndicate-examples/gui/layout/layout.rkt
View File

@ -1,194 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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)))))

11
OLD-syndicate-examples/gui/layout/main.rkt
View File

@ -1,11 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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"))

153
OLD-syndicate-examples/gui/layout/sizing.rkt
View File

@ -1,153 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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)))

BIN
OLD-syndicate-examples/gui/oakura-beach-20081225.jpg
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 483 KiB

BIN
OLD-syndicate-examples/gui/syndicate-gui-snapshot.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 491 KiB

10
OLD-syndicate-examples/ircd/Makefile
View File

@ -1,10 +0,0 @@
all:
run:
raco make main.rkt && racket main.rkt
clean:
rm -rf compiled
client:
irssi --config=irssi-config -n client

34
OLD-syndicate-examples/ircd/channel.rkt
View File

@ -1,34 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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))))

30
OLD-syndicate-examples/ircd/config.rkt
View File

@ -1,30 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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))))))))

9
OLD-syndicate-examples/ircd/dynamic-main.rkt
View File

@ -1,9 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#lang syndicate
(require/activate syndicate/reload)
(spawn-reloader "config.rkt")
(spawn-reloader "session.rkt")
(spawn-reloader "channel.rkt")
(spawn-reloader "greeter.rkt")

24
OLD-syndicate-examples/ircd/greeter.rkt
View File

@ -1,24 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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")))))

3
OLD-syndicate-examples/ircd/ircd-config.rktd
View File

@ -1,3 +0,0 @@
(port 6667)
(motd "Hello, world!")
(channel "#syndicate")

24
OLD-syndicate-examples/ircd/irssi-config
View File

@ -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"; };
};

6
OLD-syndicate-examples/ircd/main.rkt
View File

@ -1,6 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#lang syndicate
(require/activate syndicate/reload)
(spawn-reloader "dynamic-main.rkt")

96
OLD-syndicate-examples/ircd/message.rkt
View File

@ -1,96 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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)
;; <message> ::= [':' <prefix> <SPACE> ] <command> <params> <crlf>
;; <prefix> ::= <servername> | <nick> [ '!' <user> ] [ '@' <host> ]
;; <command> ::= <letter> { <letter> } | <number> <number> <number>
;; <SPACE> ::= ' ' { ' ' }
;; <params> ::= <SPACE> [ ':' <trailing> | <middle> <params> ]
;;
;; <middle> ::= <Any *non-empty* sequence of octets not including SPACE
;; or NUL or CR or LF, the first of which may not be ':'>
;; <trailing> ::= <Any, possibly *empty*, sequence of octets not including
;; NUL or CR or LF>
;;
;; <crlf> ::= CR LF
;; <target> ::= <to> [ "," <target> ]
;; <to> ::= <channel> | <user> '@' <servername> | <nick> | <mask>
;; <channel> ::= ('#' | '&') <chstring>
;; <servername> ::= <host>
;; <host> ::= see RFC 952 [DNS:4] for details on allowed hostnames
;; <nick> ::= <letter> { <letter> | <number> | <special> }
;; <mask> ::= ('#' | '$') <chstring>
;; <chstring> ::= <any 8bit code except SPACE, BELL, NUL, CR, LF and
;; comma (',')>
;; <user> ::= <nonwhite> { <nonwhite> }
;; <letter> ::= 'a' ... 'z' | 'A' ... 'Z'
;; <number> ::= '0' ... '9'
;; <special> ::= '-' | '[' | ']' | '\' | '`' | '^' | '{' | '}'
;; <nonwhite> ::= <any 8bit code except SPACE (0x20), NUL (0x0), CR
;; (0xd), and LF (0xa)>
(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"))

71
OLD-syndicate-examples/ircd/protocol.rkt
View File

@ -1,71 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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]))

238
OLD-syndicate-examples/ircd/session.rkt
View File

@ -1,238 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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)))))

7
OLD-syndicate-examples/netstack/Makefile
View File

@ -1,7 +0,0 @@
all:
run:
raco make main.rkt && racket main.rkt
clean:
find . -name compiled -type d | xargs rm -rf

19
OLD-syndicate-examples/netstack/README.md
View File

@ -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

24
OLD-syndicate-examples/netstack/TODO.md
View File

@ -1,24 +0,0 @@
Ideas on TCP unit testing:
<https://www.snellman.net/blog/archive/2015-07-09-unit-testing-a-tcp-stack/>
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.

192
OLD-syndicate-examples/netstack/arp.rkt
View File

@ -1,192 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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)

55
OLD-syndicate-examples/netstack/checksum.rkt
View File

@ -1,55 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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))

21
OLD-syndicate-examples/netstack/configuration.rkt
View File

@ -1,21 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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

24
OLD-syndicate-examples/netstack/demo-config.rkt
View File

@ -1,24 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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))]))

69
OLD-syndicate-examples/netstack/dump-bytes.rkt
View File

@ -1,69 +0,0 @@
;;; SPDX-License-Identifier: GPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2012-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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))

123
OLD-syndicate-examples/netstack/ethernet.rkt
View File

@ -1,123 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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)

35
OLD-syndicate-examples/netstack/fetchurl.rkt
View File

@ -1,35 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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"))))

262
OLD-syndicate-examples/netstack/ip.rkt
View File

@ -1,262 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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)

96
OLD-syndicate-examples/netstack/main.rkt
View File

@ -1,96 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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"
"<h1>Hello world from syndicate-netstack!</h1>\n"
"<p>This is running on syndicate's own\n"
"<a href='https://git.syndicate-lang.org/syndicate-lang/syndicate-rkt/src/branch/main/syndicate-examples/netstack'>\n"
"TCP/IP stack</a>.</p>\n"
"<p>There have been ~a requests prior to this one.</p>\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)))))))

39
OLD-syndicate-examples/netstack/port-allocator.rkt
View File

@ -1,39 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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)))))

774
OLD-syndicate-examples/netstack/tcp.rkt
View File

@ -1,774 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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)

136
OLD-syndicate-examples/netstack/udp.rkt
View File

@ -1,136 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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)

BIN
OLD-syndicate-examples/private/beautiful-grassland-wallpapers-1920x1080.jpg
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 250 KiB

BIN
OLD-syndicate-examples/private/sounds/270302__littlerobotsoundfactory__collect-point-02.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270303__littlerobotsoundfactory__collect-point-01.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270304__littlerobotsoundfactory__collect-point-00.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270305__littlerobotsoundfactory__climb-rope-loop-00.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270306__littlerobotsoundfactory__explosion-02.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270307__littlerobotsoundfactory__explosion-01.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270308__littlerobotsoundfactory__explosion-00.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270309__littlerobotsoundfactory__craft-00.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270310__littlerobotsoundfactory__explosion-04.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270311__littlerobotsoundfactory__explosion-03.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270315__littlerobotsoundfactory__menu-navigate-03.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270316__littlerobotsoundfactory__open-00.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270317__littlerobotsoundfactory__jump-01.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270318__littlerobotsoundfactory__jump-02.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270319__littlerobotsoundfactory__jingle-win-01.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270320__littlerobotsoundfactory__jump-00.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270321__littlerobotsoundfactory__menu-navigate-01.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270322__littlerobotsoundfactory__menu-navigate-02.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270323__littlerobotsoundfactory__jump-03.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270324__littlerobotsoundfactory__menu-navigate-00.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270325__littlerobotsoundfactory__hit-02.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270326__littlerobotsoundfactory__hit-01.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270327__littlerobotsoundfactory__hit-00.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270328__littlerobotsoundfactory__hero-death-00.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270329__littlerobotsoundfactory__jingle-lose-00.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270330__littlerobotsoundfactory__jingle-achievement-01.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270331__littlerobotsoundfactory__jingle-achievement-00.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270332__littlerobotsoundfactory__hit-03.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270333__littlerobotsoundfactory__jingle-win-00.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270334__littlerobotsoundfactory__jingle-lose-01.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270335__littlerobotsoundfactory__shoot-03.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270336__littlerobotsoundfactory__shoot-02.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270337__littlerobotsoundfactory__pickup-00.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270338__littlerobotsoundfactory__open-01.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270339__littlerobotsoundfactory__pickup-02.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270340__littlerobotsoundfactory__pickup-01.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270341__littlerobotsoundfactory__pickup-04.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270342__littlerobotsoundfactory__pickup-03.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270343__littlerobotsoundfactory__shoot-01.wav
View File

Binary file not shown.

BIN
OLD-syndicate-examples/private/sounds/270344__littlerobotsoundfactory__shoot-00.wav
View File

Binary file not shown.

140
OLD-syndicate-examples/private/sounds/_readme_and_license.txt
View File

@ -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

86
OLD-syndicate-examples/santa.rkt
View File

@ -1,86 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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)))

48
OLD-syndicate-examples/server-chat-client.rkt
View File

@ -1,48 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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)))]))))

15
OLD-syndicate-examples/simple-cross-layer.rkt
View File

@ -1,15 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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))))

39
OLD-syndicate-examples/sqlite.rkt
View File

@ -1,39 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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"))

13
OLD-syndicate-examples/stdin-echo.rkt
View File

@ -1,13 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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))))

24
OLD-syndicate-examples/time.rkt
View File

@ -1,24 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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)))))

13
OLD-syndicate-examples/udp-echo.rkt
View File

@ -1,13 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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)))))

41
OLD-syndicate-examples/udp-multicast.rkt
View File

@ -1,41 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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))))

87
OLD-syndicate-examples/web-core.rkt
View File

@ -1,87 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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))))))))

638
OLD-syndicate/dataspace.rkt
View File

@ -1,638 +0,0 @@
#lang racket/base
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
(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 ~a ~v>" (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 "#<facet ~a ~v ~a>"
(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 ~a>" (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:~a:~a>" (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))

8
OLD-syndicate/distributed.rkt
View File

@ -1,8 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#lang syndicate
(provide (all-from-out "distributed/main.rkt"))
(require/activate "distributed/main.rkt")
(module+ main (require (submod "distributed/main.rkt" main)))

17
OLD-syndicate/distributed/buffer.rkt
View File

@ -1,17 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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))

113
OLD-syndicate/distributed/client.rkt
View File

@ -1,113 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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))))]))))

25
OLD-syndicate/distributed/client/loopback.rkt
View File

@ -1,25 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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))))))))))

47
OLD-syndicate/distributed/client/tcp.rkt
View File

@ -1,47 +0,0 @@
;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
#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))))))))

Some files were not shown because too many files have changed in this diff Show More