Added optional footer.

diff --git a/burrow.scm b/burrow.scm
index afdee12..31cb2ed 100644 (file)
--- 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)