Skip to content

Instantly share code, notes, and snippets.

@bdeket

bdeket/htdp-with-websocket.rkt

Last active March 26, 2026 03:28
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save bdeket/41b733ae8230a1a47acdfa81f1d1e4a3 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save bdeket/41b733ae8230a1a47acdfa81f1d1e4a3 to your computer and use it in GitHub Desktop.
Download ZIP
Universe/world with webracket
Raw
htdp-with-websocket.rkt
#lang racket/base
(require racket/match
(file "htdp/htdp-lib/2htdp/image.rkt")
(file "htdp/htdp-lib/2htdp/universe.rkt")
(except-in (file "htdp/htdp-lib/2htdp/private/check-aux.rkt") sexp?)
;; ^^ my websocket branch : https://github.com/bdeket/htdp/tree/websocket
net/rfc6455
net/url
net/head
racket/port
racket/fasl)
; ****************************************************************************************************
; * Helper to kill closed pipes/connections
; ****************************************************************************************************
;; set up a thread to close open connections when their thread is stopped
;; kl is #f or a hash in which port numbers are matched with a kill procedure
;; new items to be tracket are passed via thread messaged of the form
;; (U '(serv port box thread) '(clnt port box IN OUT in out))
;; where in and out are the pipe ports for server IN and OUT and client in and out
(define (make-cleaner-thread kl)
(thread (λ ()
(define serv (make-hash))
(define clnt (make-hash))
(let loop ()
(displayln "still running")
(apply
sync
(handle-evt (thread-receive-evt)
(λ (_)
(define msg (thread-receive))
(case (car msg)
[(serv)
(match-define (list _ port box thd) msg)
(cond
[(hash-ref serv port #f)
(thread-send thd #f)]
[else
(displayln (format "adding a custodian for server port ~a" port))
(hash-set! serv port (list box '() '()))
(thread-send thd #t)])]
[(clnt)
(match-define (list _ port box IN OUT in out) msg)
(displayln (format "adding a custodian for client port ~a" port))
(hash-update! serv port (λ (l) (list (car l)
(cons IN (cadr l))
(cons OUT (caddr l)))))
(hash-set! clnt box (list port in out))])))
(append
(for/list ([(port c) (in-hash serv)])
(match-define (list box IN OUT) c)
(handle-evt box
(λ (_)
(displayln (format "shutting down server at port ~a" port))
(hash-remove! serv port)
(when kl ((hash-ref kl port)))
(map close-input-port IN)
(map close-output-port OUT))))
(for/list ([(box c) (in-hash clnt)])
(match-define (list port IN OUT) c)
(handle-evt box
(λ (_)
(displayln (format "shutting down client at port ~a" port))
(hash-remove! clnt box)
(close-input-port IN)
(close-output-port OUT))))))
(loop)))))
; ****************************************************************************************************
; * The messenger to test
; ****************************************************************************************************
(define MSGR
(let ([PROTOCOL 'WEBSOCKET])
(printf "using protocol: ~a\n" PROTOCOL)
(case PROTOCOL
[(TCP) ;; TCP
default-msgr]
[(TCP-fasl) ;; TCP using fasl
(make-tcp-msgr #:protocol (make-protocol s-exp->fasl fasl->s-exp))]
[; *********************************************************************************************
; * channel+pipes
; *********************************************************************************************
(PIPE)
;; messenger can potentially be used with multiple universes
;; so keep track of which chanels belong to which universe+clients
(define ch (make-hash))
(define cleaner-thread (make-cleaner-thread #f))
(msgr exn:fail?
(λ (port)
(define box (make-custodian-box (current-custodian) port))
(thread-send cleaner-thread (list 'serv port box (current-thread)))
(unless (thread-receive) (raise (exn "could not start server")))
(hash-set! ch port (make-channel))
port)
(λ (itm) (hash-ref ch itm))
(λ (register port)
(define-values (send-i send-o) (make-pipe))
(define-values (rcv-i rcv-o) (make-pipe))
(define box (make-custodian-box (current-custodian) (list register port)))
(thread-send cleaner-thread (list 'clnt port box send-i rcv-o rcv-i send-o))
(channel-put (hash-ref ch port) (list send-i rcv-o))
(values rcv-i send-o))
default-protocol)]
[; *********************************************************************************************
; * websockets
; *********************************************************************************************
(WEBSOCKET)
;; messenger can potentially be used with multiple universes
;; so keep track of which chanels belong to which universe+clients
(define kl (make-hash)) ;; port+kill procedure
(define ch (make-hash)) ;; port+channel
(define cleaner-thread (make-cleaner-thread kl))
(ws-idle-timeout +inf.0)
(msgr exn:fail?
(λ (port)
(define box (make-custodian-box (current-custodian) port))
(thread-send cleaner-thread (list 'serv port box (current-thread)))
(define CHNL (make-channel))
(hash-set! ch port CHNL)
(hash-set! kl port (ws-serve #:port port
(λ (c s) (println "newconnectionattempt")
(channel-put CHNL (list (ws-recv-evt c) c)))))
port)
(λ (itm) (hash-ref ch itm))
(λ (register port)
(define c (ws-connect (string->url (format "ws://~a:~a/" register port))))
(values (ws-recv-evt c) c))
(protocol (λ (c msg) (ws-send! c (format "~s" msg) #:payload-type 'text))
(λ (in)
(define ans (if (evt? in) (sync in) in))
(println (list 'incoming: ans))
(if (eof-object? ans)
(raise msgr-eof)
(call-with-input-string ans read)))))]
[else (error "unknown protocol: " PROTOCOL)])))
; ****************************************************************************************************
; * test implementation
; ****************************************************************************************************
(define (create-uni [PORT 4567])
(thread
(λ ()
(universe '()
(on-new (λ (x y) (cons y x)))
(on-msg (λ (x y z)
(match z
[(list sym (? number?) (? number?))
(make-bundle x (map (λ (w) (make-mail w z)) x) '())]
[else
(println "invalid message: ~a" z)])))
(messenger MSGR)
(port PORT)))))
(create-uni)
(define (create-wordl a-name [PORT 4567])
(thread
(λ ()
(big-bang #hash()
(on-receive (λ (x y) (hash-update x (car y) (λ (l) (cons (cdr y) l)) '())))
(on-draw (λ (x) (for*/fold ([S (empty-scene 500 500)])
([(c v) (in-hash x)]
[p (in-list v)])
(place-image (circle 5 'solid c) (car p) (cadr p) S))))
(on-mouse (λ (x y z g) (cond
[(string=? g "button-up")
(println (list 'CLIENT: 'on-click x y z g))
(make-package x (list a-name y z))]
[else x])))
(messenger MSGR)
(port PORT)
(register LOCALHOST)))))
(create-wordl 'blue)(sleep 1)
(create-wordl 'red)(sleep 1)
;(create-wordl 'green)
;; TCP
;; kill server => worlds display: universe disapeared
;; kill world => universe gets !! closed port message
;; ports/channel
;; kill server => worlds display: universe disapeared
;; kill world => universe gets !! closed port message
;;
Raw
webworld.rkt
;#lang racket/base (require racket/string) (define-values (js-document-head js-document-body js-new js-eval js-var js-send js-undefined? js-ref/extern js-global-this js-set-attribute! js-create-element js-set! js-log js-set-canvas-width! js-set-canvas-height! js-append-child! js-canvas-get-context js-undefined js-set-canvas2d-fill-style! js-canvas2d-fill-rect js-canvas2d-fill-arc js-window-clear-interval js-window-set-interval js-window-set-timeout/delay js-ref js-event-prevent-default js-add-event-listener! js-window-window procedure->external) (apply values (build-list 21 void)))
(let ()
(define name (format "webworld~a" (random 1000000)))
(define board-width 500)
(define board-height 500)
(define board-width-f64 (exact->inexact board-width))
(define board-height-f64 (exact->inexact board-height))
(define background-color "#ffffff")
(define body (js-document-body))
(js-set-attribute! body "style" "margin:0;display:flex;justify-content:center;")
(define container (js-create-element "div"))
(js-set-attribute! container "style"
(string-append "display:flex;flex-direction:column;align-items:center;gap:12px;"
"padding:32px 24px;min-height:100vh;box-sizing:border-box;"
"font-family:'Segoe UI',sans-serif;text-align:center;"))
(define title (js-create-element "h1"))
(js-set! title "textContent" (format "~a" name))
(js-set-attribute! title "style" "margin:0;font-size:32px;letter-spacing:4px;")
(define canvas (js-create-element "canvas"))
(js-set-canvas-width! canvas board-width)
(js-set-canvas-height! canvas board-height)
(js-set-attribute! canvas "style"
(string-append "border:2px solid #2ecc71;"
"background:" background-color ";"
"image-rendering:pixelated;"
"width:" (number->string board-width) "px;"
"height:" (number->string board-height) "px;"
"box-shadow:0 18px 36px rgba(0,0,0,0.35);"))
(js-append-child! container title)
(js-append-child! container canvas)
(js-append-child! body container)
(define data '())
(define ctx (js-canvas-get-context canvas "2d" (js-undefined)))
(define (draw!)
(js-set-canvas2d-fill-style! ctx background-color)
(js-canvas2d-fill-rect ctx 0. 0. board-width-f64 board-height-f64)
(for ([itm (in-list data)])
(js-set-canvas2d-fill-style! ctx (car itm))
(js-canvas2d-fill-rect ctx
(- (exact->inexact (cadr itm)) 2.5)
(- (exact->inexact (caddr itm)) 2.5)
5.0 5.0)))
(define (on-mouse event)
(SEND `(purple ,(js-ref event "offsetX") ,(js-ref event "offsetY"))))
(js-add-event-listener! canvas "click" (procedure->external on-mouse))
(define (on-message msg)
(define str (js-ref msg "data"))
;; need to transform "(sym nr nr)" to '(sym nr nr)
(define STR (substring str 1 (- (string-length str) 1)))
(define M (string-split STR " "))
#;(js-log (format "~a ; ~a ; ~a"
(car M) (cadr M) (caddr M)))
;; get message to data
(set! data (cons (list (car M) (string->number (cadr M)) (string->number (caddr M))) data))
(draw!))
(define message-callback (procedure->external on-message))
(define MSGR (js-new (js-var "WebSocket") (vector "ws://localhost:4567/")))
(define (SEND msg)
(define str (if (string? msg)
(string-append msg "\\r\\n")
(format "~s\\r\\n" msg)))
(js-send MSGR "send" (vector str)))
(define (WAITandREGISTER)
(if (not (= 0 (js-ref MSGR "readyState")))
(REGISTER)
(js-eval "setTimeout(WAITandREGISTER,1000)")))
(define registered? #f)
(define (REGISTER)
(unless registered?
(js-log "registering... ")
(js-set! MSGR "onmessage"
(procedure->external
(λ (msg)
(js-log (format "registering: ~a" (js-ref msg "data")))
(set! registered? #t)
(js-set! MSGR "onmessage" message-callback))))
(SEND `(REGISTER ((name ,name))))))
(js-set! (js-global-this) "SEND" (procedure->external SEND))
(js-set! (js-global-this) "REGISTER" (procedure->external REGISTER))
(js-set! (js-global-this) "WAITandREGISTER" (procedure->external WAITandREGISTER))
(cond
[(js-undefined? MSGR)
(js-log "Websocket not created")]
[else
(WAITandREGISTER)])
)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment