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