(import (chicken tcp) (chicken port) (chicken io) (chicken string) (chicken pathname) (chicken file posix) (chicken time posix) (chicken condition) (chicken process) (chicken process-context) srfi-13 matchable) (define gopher-index-file-name "index") ;;; Server loop ;; We don't actually use worker threads here to handle requests, ;; the server just blocks until the first request is finished. (define (make-server-config root-dir host port) (list root-dir host port)) (define (server-root-dir config) (list-ref config 0)) (define (server-host config) (list-ref config 1)) (define (server-port config) (list-ref config 2)) (define (run-server config) (print "Gopher server listening on port " (server-port config) " ...") (let ((listener (tcp-listen (server-port config)))) (let server-loop () (let-values (((in-port out-port) (tcp-accept listener))) (let* ((line (read-line in-port)) (selector (string-trim-both line))) (let-values (((local-ip remote-ip) (tcp-addresses in-port))) (print "Accepted connection from " remote-ip " on " (seconds->string))) (condition-case (begin (with-output-to-port out-port (lambda () (serve-selector (if (= (string-length selector) 0) "/" selector) config))) (print "... served selector '" selector "'. Closing connection.")) (o (exn) (print-error-message o out-port) (print-error-message o) (print "Error while attempting to serve selector " selector ".")))) (close-input-port in-port) (close-output-port out-port)) (server-loop)) (tcp-close listener))) ;;; Selector type inference (define (has-suffix? selector . suffixes) (if (null? suffixes) #f (if (string-suffix? (car suffixes) selector) #t (apply has-suffix? selector (cdr suffixes))))) (define (infer-selector-type selector) (let ((l (string-downcase selector))) (cond ((or (= (string-length l) 0) (string-suffix? "/" l)) 1) ((has-suffix? l ".txt" ".org" ".md") 0) ((has-suffix? l ".png" ".jpg" ".gif" ".bmp" ".tif" ".tga") 'I) (else 9)))) ;;; Selector retrieval (define (serve-selector selector config) ((case (infer-selector-type selector) ((1) serve-directory) ((0) serve-text-file) (else serve-binary-file)) selector config)) (define (serve-directory path config) (let ((file-name (make-pathname (list (server-root-dir config) path) gopher-index-file-name))) (if (regular-file? file-name) (with-input-from-file file-name (lambda () (let loop ((c (peek-char))) (if (eof-object? c) 'done (begin (if (eq? c #\,) (begin (read-char) (serve-record (read) path config) (read-line)) (serve-info-record (read-line))) (loop (peek-char))))))) (error "Index file not found.")))) (define (serve-text-file path config) (let ((file-name (make-pathname (server-root-dir config) path))) (if (regular-file? file-name) (with-input-from-file file-name (lambda () (for-each (lambda (line) (print line "\r")) (read-lines)))) (error "File not found." file-name)))) (define (serve-binary-file path config) (let ((file-name (make-pathname (server-root-dir config) path))) (if (regular-file? file-name) (with-input-from-file file-name (lambda () (let loop ((b (read-byte))) (if (eof-object? b) 'done (begin (write-byte b) (loop (read-byte))))))) (error "File not found." file-name)))) ;;; Index rendering (define (serve-info-record info-string) (print "i" info-string "\tfake\tfake\t1\r")) (define (serve-record record path config) (match record ((type display-string selector host port) (print type display-string "\t" selector "\t" host "\t" port "\r")) ((type display-string selector host) (serve-record (list type display-string selector host 70) path config)) ((type display-string selector) (serve-record (list type display-string selector (server-host config) (server-port config)) path config)) ((display-string selector) (serve-record (list (infer-selector-type selector) display-string selector) path config)) ((selector) (serve-record (list (infer-selector-type selector) selector) path config)) (else (error "Unknown record type.")))) ;;; main (define (main) (let ((progname (car (argv))) (args (cdr (argv)))) (if (or (< (length args) 2) (equal? (car args) "-h") (equal? (car args) "--help")) (print "Usage:\n" progname " -h/--help\n" progname " gopher-root-dir server-hostname server-port") (let ((root (car args)) (hostname (cadr args)) (port (if (= (length args) 3) (string->number (caddr args)) 70))) (if port (run-server (make-server-config root hostname port)) (error "Invalid port argument." port)))))) ;; (main) (define (test) (run-server (make-server-config "gopher-root" "localhost" 70))) ;; (test)