(module learninng-http-server (make-server server-start! server-join! server-stop!) (import scheme chicken extras ports posix srfi-13) (use socket srfi-18) (define-record *server port ; integer backlog ; integer host ; string listener ; socket thread ; thread ) ; reads up to n characters from input-port (reading stops if the input port ; fails (char-ready? ...), reaches the end-char if supplied, or is at EOF) ; and returns a string (define (readn input-port n #!optional (end-char #f)) (define s (make-string n)) (define len (let chomp ((c 0)) (if (or (= c n) (not (char-ready? input-port)) (eof-object? (peek-char input-port)) (and end-char (char=? (peek-char input-port) end-char))) c (begin (string-set! s c (read-char input-port)) (chomp (+ c 1)))))) (substring/shared s 0 len)) (define (make-exn/type message location) (make-composite-condition (make-property-condition 'exn 'message message 'location location) (make-property-condition 'type))) (define (make-server #!key (port 8080) (backlog 100) (host "::")) (let () (if (not (integer? port)) (abort (make-exn/type "port should be an integer." "make-server"))) (if (not (integer? backlog)) (abort (make-exn/type "backlog should be an integer." "make-server"))) (if (not (string? host)) (abort (make-exn/type "host should be a string." "make-server")))) (make-*server port backlog host #f #f)) ; throws: (exn i/o net) if the listener socket setup fails ; server is of type *server (define (server-start! server) (if (not (*server? server)) (abort (make-exn/type "server should be a *server." "server-start!"))) (let ((listener (socket af/inet6 sock/stream))) (*server-listener-set! server listener) (set! (tcp-no-delay? listener) #t) (set! (ipv6-v6-only? listener) #f) (set! (so-reuse-address? listener) #t) (socket-bind listener (inet-address (*server-host server) (*server-port server))) (socket-listen listener (*server-backlog server)) (define thread (make-thread (lambda () (condition-case (let accept-loop ((conn (socket-accept listener))) (print "here") (let* ((crlf (string #\return #\newline)) (message (sprintf "HTTP/1.1 200 OK\r\nContent-Length:13\r\nConnection:close\r\n\r\nhello, world!")) (handler (lambda () (condition-case (begin (socket-send conn message) (socket-close conn)) [(exn i/o net) (condition-case (socket-close message) [(exn i/o net) (print "nothing else we can do")]) (print "client socket error")]))) (thread (make-thread handler))) (thread-start! thread)) (accept-loop (socket-accept listener))) [(exn i/o net) (condition-case (socket-close listener) [(exn i/o net) (print "nothing else we can do")]) (print "something went wrong")] [(user-interrupt) (socket-close listener)])))) (*server-thread-set! server thread) (thread-start! thread) server)) (define (server-join! server) (if (not (*server? server)) (abort (make-exn/type "server should be a *server." "server-join!"))) (if (not (thread? (*server-thread server))) (abort (make-exn/type "server is not a currently running server." "server-join!"))) (thread-join! (*server-thread server))) (define (server-stop! server) (if (not (*server? server)) (abort (make-exn/type "server should be a *server." "server-stop!"))) (socket-shutdown (*server-listener server) shut/rdwr) (socket-close (*server-listener server))))