56 lines
1.9 KiB
Scheme
56 lines
1.9 KiB
Scheme
(define-module (starvat listener)
|
|
#:use-module (gnutls)
|
|
#:use-module (goblins)
|
|
#:use-module (goblins actor-lib methods)
|
|
#:use-module (goblins actor-lib let-on)
|
|
#:use-module (goblins actor-lib cell)
|
|
#:use-module (web uri)
|
|
#:use-module (ice-9 textual-ports))
|
|
|
|
(define* (get-request port #:optional (acc ""))
|
|
(define next-char (get-char port))
|
|
(if (and (eq? next-char #\return)
|
|
(eq? (lookahead-char port) #\newline))
|
|
acc
|
|
(get-request port (string-append acc (string next-char)))))
|
|
|
|
(define* (^listener bcom port cert key #:key exposed?)
|
|
(define current-port (spawn ^cell port))
|
|
(define listening-socket (spawn ^cell))
|
|
(define credentials (spawn ^cell (make-certificate-credentials)))
|
|
(set-certificate-credentials-x509-key-files!
|
|
($ credentials) cert key x509-certificate-format/pem)
|
|
(define server (spawn ^cell (make-session connection-end/server)))
|
|
(set-session-credentials! ($ server) ($ credentials))
|
|
(set-session-default-priority! ($ server))
|
|
|
|
(methods
|
|
((set-port new-port)
|
|
($ current-port new-port))
|
|
((set-credentials cert key)
|
|
(set-certificate-credentials-x509-key-files!
|
|
($ credentials) cert key x509-certificate-format/pem))
|
|
((init)
|
|
($ listening-socket
|
|
(let ((s (socket PF_INET SOCK_STREAM 0)))
|
|
(setsockopt s SOL_SOCKET SO_REUSEADDR 1)
|
|
(bind s AF_INET INADDR_ANY ($ current-port))
|
|
(fcntl s F_SETFD FD_CLOEXEC)
|
|
(listen s 5)
|
|
s)))
|
|
((listen)
|
|
(let* ((session (make-session connection-end/server))
|
|
(sock (car (accept ($ listening-socket)))))
|
|
(set-session-credentials! session ($ credentials))
|
|
(set-session-default-priority! session)
|
|
(set-session-transport-fd! session
|
|
(fileno sock))
|
|
(set-port-encoding! sock "UTF-8")
|
|
(handshake session)
|
|
(write (get-request (session-record-port session)))
|
|
(put-string (session-record-port session)
|
|
(string-append "41 Server is being written!" "\r\n"))
|
|
(bye session close-request/rdwr)))
|
|
((close)
|
|
(close ($ listening-socket)))))
|