guile-examples/network-programming/tcp-server.scm

;; ==========
;; TCP SERVER
;; ==========
;; All this server does is echo the client's messages.
(define-module (tcp-server)
  #:export (run-server
            echo-message-handler
            echo-protocol
            make-server-protocol
            shutdown-client-connection))

(use-modules (rnrs bytevectors)
             (networking-lib helpers)
             (ice-9 threads)
             (ice-9 textual-ports)
             (ice-9 binary-ports)
             (json))

#;(define receive-buffer (make-bytevector 1024))

(define (create-server-socket port)
  (let ([sock
         ;; create TCP socket
         (socket PF_INET SOCK_STREAM (protoent:proto (getprotobyname "TCP")))]
        [backlog-of-connection-requests
         ;; allow at maximum n incoming connections waiting to be accepted at the same time
         10])
    (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
    ;; bind to address and port
    ;; accept from any incoming address of AF_INET
    (bind sock (make-socket-address AF_INET INADDR_ANY port))
    ;; make the server listen for incoming connections
    (listen sock backlog-of-connection-requests)
    sock))

;; What to do with a new connection?
(define (handle-new-connection client-connection protocol)
  (let* ([client-details (cdr client-connection)]
         [in-out-sock (car client-connection)])
    (display
     (simple-format #f
                    "INFO: Got new client connection: ~S\n"
                    client-details))
    (display
     (simple-format #f
                    "INFO: Client address: ~S\n"
                    (gethostbyaddr (sockaddr:addr client-details))))
    ;; say hello to the client
    #;(put-string in-out-sock "Hello from server!\n")
    ;; let the protocol handle the rest
    (protocol client-connection)))

(define (echo-message-handler client-connection message)
  "This could be a user supplied procedure."
  (let ([in-out-sock (car client-connection)])
    (display (simple-format #f "RECEIVED: ~s\n" message))
    ;; We need to add a newline character again,
    ;; because get-line removes it from the received message.
    ;; (get-line's line separator or delimiter is the #\newline,
    ;; so it does not think of that as part of the line.)
    (let ([answer-message (string-append message "\n")])
      (put-string in-out-sock (string-append message "\n"))
      (force-output in-out-sock))
    (display (simple-format #f "sent message: ~s\n" message))))

(define (shutdown-client-connection client-connection)
  (display "shutting down connection wit client ...\n")
  (close client-connection)
  (display "connection wit client shut down.\n"))

(define (close-connection in-out-sock)
  (display (simple-format #f "~s\n" "EOF received. Closing connection ..."))
  (close in-out-sock)
  (display (simple-format #f "~s\n" "Connection closed.")))

(define* (run-server port #:key (protocol echo-protocol))
  (define in-out-sock (create-server-socket port))
  (display (simple-format #f "SO_REUSEADDR: ~s\n" (getsockopt in-out-sock SOL_SOCKET SO_REUSEADDR)))

  ;; Make a thread.
  ;; This is done to be able to control the server program from the REPL.
  ;; If it was done in the main thread, the REPL would not accept any new input.
  ;; It would "hand" inside the while true loop.
  (call-with-new-thread
   ;; make-thread wants a thunk, a lambda to run it.
   ;; This is delayed evaluation.
   (λ ()
     (while #t
       ;; Accept new connection in main loop.
       ;; Since accept is blocking the main loop, this should not lead to high CPU usage.
       (let ([client-connection (accept in-out-sock)])
         ;; Handle the interactions with a client in a separate thread.
         ;; This way the server should be able to handle multiple connections.
         ;; (Not the newest way of architecturing the server.)
         (call-with-new-thread
          (λ ()
            ;; Handle the new connection according to a protocol.
            (handle-new-connection client-connection protocol)))))))
  ;; return in-out-sock to be able to close it from REPL
  in-out-sock)

(define* (make-server-protocol #:key
                               (port-reader get-line)
                               (message-handler echo-message-handler)
                               (eof-handler shutdown-client-connection))
  "A protocol is initialized with a new connection. The connection cannot be specified, since it is incomming from the client. It will then handle messages from this connection according to its specification."
  (λ (client-connection)
    (let* ([client-details (cdr client-connection)]
           [in-out-sock (car client-connection)])
      ;; Handle infinitely many messages.
      (while (not (port-closed? in-out-sock))
        ;; Receiving a message is blocking.
        ;; It should not lead to a high CPU usage.
        (let ([received-data (port-reader in-out-sock)])
          (display (simple-format #f "INPROTO: data received: ~s, which is: ~s\n"
                                  received-data
                                  (scm->json-string received-data)))
          (cond [(eof-object? received-data)
                 (eof-handler client-connection)
                 (break)]
                [else
                 (message-handler client-connection received-data)]))))))

(define echo-protocol (make-server-protocol))