X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=scratchy.git;a=blobdiff_plain;f=burrower.scm;h=9db8599bd045217aa482d11b3ac0f72c711d363e;hp=36820ea7e624d759f2e7eda8b7998ee078d27935;hb=6948e45263ad950facabbd856c13759c8732fd93;hpb=fbe6d56aeb717aac844150f78d0891d913fa2346

diff --git a/burrower.scm b/burrower.scm
index 36820ea..9db8599 100644
--- a/burrower.scm
+++ b/burrower.scm
@@ -1,6 +1,10 @@
+;;; Burrower gopher server
+;;
+;; Requires Chicken 5.0.0.
+;;
+
 ;;; Imports
 
-;; Chicken 5
 (import (chicken tcp)
         (chicken port)
         (chicken io)
@@ -13,9 +17,6 @@
         (chicken process-context)
         srfi-1 srfi-13 matchable)
 
-;; Chicken 4
-;; (use srfi-1 srfi-13 tcp posix matchable)
-
 ;;; Global constants
 
 (define gopher-index-filename "index")
@@ -105,17 +106,16 @@
   (let* ((selector-list (string-split raw-selector "\t"))
          (selector (car selector-list))
          (arguments (cdr selector-list)))
-    (case (infer-selector-type selector)
-      ((1) (if (string-contains selector ":")
-               (let ((l (string-split selector ":")))
-                 (serve-directory-script (car l) (cdr l)
-                                         config))
-               (serve-directory-file selector config)))
-      ((7) (let ((l (string-split selector "?")))
-             (serve-directory-script (car l) arguments config)))
-      ((0) (serve-text-file selector config))
-      ((h) (serve-url selector config))
-      (else (serve-binary-file selector config)))))
+    (if (string-contains selector ":")
+        (let ((l (string-split selector ":")))
+          (serve-script (car l) (cdr l) config))
+        (case (infer-selector-type selector)
+          ((1) (serve-directory-file selector config))
+          ((7) (let ((l (string-split selector "?")))
+                 (serve-script (car l) arguments config)))
+          ((0) (serve-text-file selector config))
+          ((h) (serve-url selector config))
+          (else (serve-binary-file selector config))))))
 
 (define (legal-filename? filename config)
   (and (string-prefix? (config-root-dir config)
@@ -129,17 +129,6 @@
        (string-suffix? ".scm" filename)
        (file-executable? filename)))
 
-(define (serve-directory-script selector arguments config)
-  (let ((filename (make-pathname (config-root-dir config) selector)))
-    (if (legal-script-filename? filename config)
-        (let ((sexp (with-input-from-file filename read)))
-          (serve-records (with-selector-dir selector config
-                                            (lambda ()
-                                              (apply (eval sexp) arguments)))
-                         selector config)
-         (print ".\r"))
-        (error "No legal index script not found." filename))))
-
 (define (serve-directory-file selector config)
   (let ((filename (make-pathname (list (config-root-dir config) selector)
                                  gopher-index-filename)))
@@ -205,6 +194,20 @@
      "<a href=\"" url "\">" url "</a>\n"
      "</body></html>")))
 
+(define (serve-script selector arguments config)
+  (let ((filename (make-pathname (config-root-dir config) selector)))
+    (if (legal-script-filename? filename config)
+        (let* ((sexp (with-input-from-file filename read))
+               (script-result (with-selector-dir
+                               selector config
+                               (lambda ()
+                                 (apply (eval sexp) arguments)))))
+          (when (pair? script-result)
+            (serve-records script-result
+                           (pathname-directory selector) config)
+            (print ".\r")))
+        (error "No legal index script not found." filename))))
+
 
 ;;; Index rendering
 
@@ -261,7 +264,9 @@
        (let ((string (read-string #f in-port)))
          (if (and (not (eof-object? string))
                   (> (string-length string) 0))
-             (serve-info-records (string-chomp string "\n"))))))))
+             (serve-info-records (string-chomp string "\n")))
+         (close-input-port in-port)
+         (close-output-port out-port))))))
 
 (define (serve-expression expression dir-selector config)
   (with-selector-dir