2017-08-10 19:17:28 +00:00
|
|
|
#lang syndicate
|
2014-06-16 01:16:14 +00:00
|
|
|
|
2016-07-30 17:02:07 +00:00
|
|
|
(require syndicate/protocol/advertise)
|
2014-06-16 01:16:14 +00:00
|
|
|
|
2016-07-12 22:47:51 +00:00
|
|
|
(require/activate syndicate/drivers/timer)
|
|
|
|
(require/activate "ethernet.rkt")
|
|
|
|
(require/activate "arp.rkt")
|
2016-07-13 01:02:06 +00:00
|
|
|
(require/activate "ip.rkt")
|
|
|
|
(require/activate "tcp.rkt")
|
|
|
|
(require/activate "udp.rkt")
|
2016-07-12 22:47:51 +00:00
|
|
|
(require/activate "demo-config.rkt")
|
2014-06-19 01:24:47 +00:00
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
2016-01-24 03:57:07 +00:00
|
|
|
(let ()
|
2016-07-12 23:21:23 +00:00
|
|
|
(local-require (only-in racket/string string-trim))
|
|
|
|
|
|
|
|
(struct says (who what) #:prefab)
|
|
|
|
(struct present (who) #:prefab)
|
2014-06-17 21:02:32 +00:00
|
|
|
|
|
|
|
(define (spawn-session them us)
|
2017-02-20 17:54:52 +00:00
|
|
|
(spawn (define (send-to-remote fmt . vs)
|
2016-07-30 17:02:07 +00:00
|
|
|
(send! (outbound (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))))
|
2014-06-17 21:02:32 +00:00
|
|
|
|
2016-07-12 23:21:23 +00:00
|
|
|
(define (say who fmt . vs)
|
|
|
|
(unless (equal? who user)
|
|
|
|
(send-to-remote "~a ~a\n" who (apply format fmt vs))))
|
|
|
|
|
|
|
|
(define user (gensym 'user))
|
2016-08-24 20:29:08 +00:00
|
|
|
(on-start (send-to-remote "Welcome, ~a.\n" user))
|
2016-07-12 23:21:23 +00:00
|
|
|
|
2016-08-24 20:29:08 +00:00
|
|
|
(stop-when (retracted (inbound (advertise (tcp-channel them us _)))))
|
2016-07-12 23:21:23 +00:00
|
|
|
|
2016-08-24 20:29:08 +00:00
|
|
|
(assert (present user))
|
|
|
|
(on (asserted (present $who)) (say who "arrived."))
|
|
|
|
(on (retracted (present $who)) (say who "departed."))
|
2016-07-12 23:21:23 +00:00
|
|
|
|
2016-08-24 20:29:08 +00:00
|
|
|
(on (message (says $who $what)) (say who "says: ~a" what))
|
|
|
|
|
|
|
|
(assert (outbound (advertise (tcp-channel us them _))))
|
|
|
|
(on (message (inbound (tcp-channel them us $bs)))
|
|
|
|
(send! (says user (string-trim (bytes->string/utf-8 bs)))))))
|
2016-07-12 23:21:23 +00:00
|
|
|
|
2017-09-25 22:52:29 +00:00
|
|
|
(define us (tcp-listener 5999))
|
2016-09-09 20:48:11 +00:00
|
|
|
(dataspace #:name 'chat-dataspace
|
2017-09-25 22:52:29 +00:00
|
|
|
(spawn #:name 'chat-server
|
|
|
|
(assert (outbound (advertise (observe (tcp-channel _ us _)))))
|
|
|
|
(on (asserted (inbound (advertise (tcp-channel $them us _))))
|
|
|
|
(spawn-session them us)))))
|
2016-07-12 23:21:23 +00:00
|
|
|
|
|
|
|
(let ((dst (udp-listener 6667)))
|
2017-02-20 17:54:52 +00:00
|
|
|
(spawn #:name 'udp-echo-program
|
2016-09-09 20:48:11 +00:00
|
|
|
(on (message (udp-packet $src dst $body))
|
2016-08-24 20:29:08 +00:00
|
|
|
(log-info "Got packet from ~v: ~v" src body)
|
|
|
|
(send! (udp-packet dst src (string->bytes/utf-8 (format "You said: ~a" body)))))))
|
2014-06-19 22:00:37 +00:00
|
|
|
|
2016-01-28 02:51:51 +00:00
|
|
|
(let ()
|
2016-09-09 20:48:11 +00:00
|
|
|
(dataspace #:name 'webserver-dataspace
|
2017-02-20 17:54:52 +00:00
|
|
|
(spawn #:name 'webserver-counter
|
2016-09-09 20:48:11 +00:00
|
|
|
(field [counter 0])
|
2016-08-24 20:29:08 +00:00
|
|
|
(on (message 'bump)
|
|
|
|
(send! `(counter ,(counter)))
|
|
|
|
(counter (+ (counter) 1))))
|
2016-07-12 23:21:23 +00:00
|
|
|
|
2017-09-25 22:52:29 +00:00
|
|
|
(define us (tcp-listener 80))
|
|
|
|
(spawn (assert (outbound (advertise (observe (tcp-channel _ us _)))))
|
|
|
|
(during/spawn (inbound (advertise (tcp-channel ($ them (tcp-address _ _)) us _)))
|
|
|
|
#:name (list 'webserver-session them)
|
|
|
|
(log-info "Got connection from ~v" them)
|
|
|
|
(assert (outbound (advertise (tcp-channel us them _))))
|
|
|
|
(on (message (inbound (tcp-channel them us _)))) ;; ignore input
|
|
|
|
|
|
|
|
(on-start (send! 'bump))
|
|
|
|
(on (message `(counter ,$counter))
|
|
|
|
(define response
|
|
|
|
(string->bytes/utf-8
|
|
|
|
(format (string-append
|
2017-11-15 12:12:26 +00:00
|
|
|
"HTTP/1.0 200 OK\r\n"
|
|
|
|
"Content-Type: text/html\r\n"
|
|
|
|
"\r\n"
|
2017-09-25 22:52:29 +00:00
|
|
|
"<h1>Hello world from syndicate-netstack!</h1>\n"
|
|
|
|
"<p>This is running on syndicate's own\n"
|
|
|
|
"<a href='https://github.com/tonyg/syndicate/'>\n"
|
|
|
|
"TCP/IP stack</a>.</p>\n"
|
|
|
|
"<p>There have been ~a requests prior to this one.</p>\n")
|
|
|
|
counter)))
|
|
|
|
(send! (outbound (tcp-channel us them response)))
|
2017-11-13 15:29:48 +00:00
|
|
|
(for [(i 4)]
|
|
|
|
(define buf (make-bytes 1024 (+ #x30 i)))
|
|
|
|
(send! (outbound (tcp-channel us them buf))))
|
2017-09-25 22:52:29 +00:00
|
|
|
(stop-facet (current-facet-id)))))))
|