syndicate-rkt/syndicate-examples/netstack/main.rkt

97 lines
4.0 KiB
Racket

; SPDX-License-Identifier: LGPL-3.0-or-later
; Copyright (C) 2010-2021 Tony Garnock-Jones <tonygarnockjones@gmail.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)))))))