From 2c37c7eb2d1116c358712faab1bb760bde5bcf72 Mon Sep 17 00:00:00 2001 From: Tim Vaughan Date: Fri, 3 May 2019 23:47:13 +0200 Subject: [PATCH] Added optional footer. --- burrow.scm | 123 ++++++++++++++++++++++++++++++++--------------------- 1 file changed, 74 insertions(+), 49 deletions(-) diff --git a/burrow.scm b/burrow.scm index afdee12..31cb2ed 100644 --- a/burrow.scm +++ b/burrow.scm @@ -12,20 +12,23 @@ (define gopher-index-file-name "index") +(define burrow-version "1.0.0") + +(define burrow-footer + (conc "\n" + "--------------------------------------------------\n" + "Served by Burrow Gopher Server v" burrow-version "\n" + "Powered by Chicken Scheme!")) + ;;; 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-record config root-dir host port display-footer) (define (run-server config) - (print "Gopher server listening on port " (server-port config) " ...") - (let ((listener (tcp-listen (server-port config)))) + (print "Gopher server listening on port " (config-port config) " ...") + (let ((listener (tcp-listen (config-port config)))) (let server-loop () (let-values (((in-port out-port) (tcp-accept listener))) (let* ((line (read-line in-port)) @@ -78,26 +81,29 @@ selector config)) (define (serve-directory path config) - (let ((file-name (make-pathname (list (server-root-dir config) path) + (let ((file-name (make-pathname (list (config-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))))))) + (begin + (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-records (read-line))) + (loop (peek-char))))))) + (if (config-display-footer config) + (serve-info-records burrow-footer))) (error "Index file not found.")))) (define (serve-text-file path config) - (let ((file-name (make-pathname (server-root-dir config) path))) + (let ((file-name (make-pathname (config-root-dir config) path))) (if (regular-file? file-name) (with-input-from-file file-name (lambda () @@ -108,7 +114,7 @@ (error "File not found." file-name)))) (define (serve-binary-file path config) - (let ((file-name (make-pathname (server-root-dir config) path))) + (let ((file-name (make-pathname (config-root-dir config) path))) (if (regular-file? file-name) (with-input-from-file file-name (lambda () @@ -123,14 +129,17 @@ ;;; Index rendering -(define (serve-info-record info-string) - (print* "i") - (for-each (lambda (char) - (print* (if (eq? char #\tab) - " " - char))) - (string->list info-string)) - (print "\tfake\tfake\t1\r")) +(define (serve-info-records string) + (for-each + (lambda (line) + (print* "i") + (for-each (lambda (char) + (print* (if (eq? char #\tab) + " " + char))) + (string->list line)) + (print "\tfake\tfake\t1\r")) + (string-split string "\n" #t))) (define (serve-record record path config) (match record @@ -143,7 +152,7 @@ path config)) ((type display-string selector) (serve-record (list type display-string selector - (server-host config) (server-port config)) + (config-host config) (config-port config)) path config)) ((display-string selector) (serve-record (list (infer-selector-type selector) display-string selector) @@ -155,33 +164,49 @@ (define (serve-shell-command command) (let-values (((in-port out-port id) (process command))) - (for-each serve-info-record (read-lines in-port)))) + (serve-info-records (string-chomp (read-string #f in-port) "\n")))) (define (serve-expression expression) - (for-each serve-info-record - (string-split (conc (eval expression)) "\n"))) + (serve-info-records (conc (eval expression)))) ;;; main +(define (print-usage progname) + (print "Usage:\n" + progname " -h/--help\n" + progname " [-n/--no-footer] gopher-root-dir server-hostname [server-port]\n" + "\n" + "The -n option tells the server to not display a directory footer.")) + (define (main) - (let ((progname (car (argv))) - (args (cdr (argv)))) - (if (or (< (length args) 2) + (let* ((progname (car (argv))) + (args (cdr (argv))) + (config (make-config '() '() 70 #t))) + + (if (or (null? args) (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)))))) + (print-usage progname) + (begin + (if (or (equal? (car args) "-n") + (equal? (car args) "--no-footer")) + (begin + (config-display-footer-set! config #f) + (set! args (cdr args)))) + (print args) + (if (or (< (length args) 2) + (> (length args) 3)) + (print-usage progname) + (begin + (config-root-dir-set! config (car args)) + (config-host-set! config (cadr args)) + (if (= (length args) 3) + (config-port-set! config (string->number (caddr args)))) + (run-server config))))))) ;; (main) (define (test) - (run-server (make-server-config "gopher-root" "localhost" 70))) + (run-server (make-config "gopher-root" "localhost" 70 #t))) ;; (test) -- 2.20.1