X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=scratchy.git;a=blobdiff_plain;f=scratchy.scm;h=409047d0caeec3ffa143a3b69bfba8616475f202;hp=46cf8a1d8caf2e4b9b5b4de2d33beb5a464b3f87;hb=045c10a05d15f3a19bddfa8be26979e73f150cd0;hpb=8c624d4884a7bf0799472128db32da5e80d7de9f

diff --git a/scratchy.scm b/scratchy.scm
index 46cf8a1..409047d 100644
--- a/scratchy.scm
+++ b/scratchy.scm
@@ -20,7 +20,7 @@
 
 ;;; Global constants
 
-(define scratchy-version "1.3.0")
+(define scratchy-version "1.4.1")
 
 (define scratchy-footer
   (conc "\n"
@@ -41,7 +41,7 @@
   root-dir host port display-footer user group blacklist blacklist-resp)
 
 (define (run-server config)
-  ;; (set-buffering-mode! (current-output-port) #:line)
+  (set-buffering-mode! (current-output-port) #:line)
   (let ((listener (tcp-listen (config-port config) 10 "::")))
     (print "Gopher server listening on port " (config-port config) " ...")
     (drop-privs config)
@@ -68,10 +68,7 @@
                                    (config-blacklist config)
                                  read))))
               (let* ((line (read-line in-port))
-                     (selector-raw (string-trim-both line))
-                     (selector (if (= (string-length selector-raw) 0)
-                                   "/"
-                                   selector-raw)))
+                     (selector (string-trim-both line)))
                 (condition-case
                     (begin
                       (with-output-to-port out-port
@@ -133,19 +130,23 @@
 ;;; Selector retrieval
 
 (define (serve-selector raw-selector config)
-  (let* ((selector-list (string-split raw-selector "\t"))
+  (let* ((selector-list (string-split raw-selector "\t" #t))
          (selector (car selector-list))
          (arguments (cdr selector-list)))
-    (if (string-contains selector "|")
-        (let ((l (string-split selector "|" #t)))
-          (serve-script (car l) (cdr l) config))
-        (case (infer-selector-type selector)
-          ((1) (serve-directory-file selector config))
-          ((7) (let ((l (string-split selector "?" #t)))
-                 (serve-script (car l) arguments config)))
-          ((0) (serve-text-file selector config))
-          ((h) (serve-url selector config))
-          (else (serve-binary-file selector config))))))
+    (cond
+     ((string-contains selector "|")
+      (let ((l (string-split selector "|" #t)))
+        (serve-script (car l) (cdr l) config)))
+     ((legal-filename? (directory-index-filename selector config) config)
+      (serve-directory-file selector config))
+     (else
+      (case (infer-selector-type selector)
+        ((1) (error "Invalid directory selector."))
+        ((7) (let ((l (string-split selector "?" #t)))
+               (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)
@@ -159,9 +160,13 @@
        (string-suffix? ".scm" filename)
        (file-executable? filename)))
 
+(define (directory-index-filename selector config)
+  (make-pathname (list (config-root-dir config)
+                       selector)
+                 gopher-index-filename))
+
 (define (serve-directory-file selector config)
-  (let ((filename (make-pathname (list (config-root-dir config) selector)
-                                 gopher-index-filename)))
+  (let ((filename (directory-index-filename selector config)))
     (if (legal-filename? filename config)
         (begin
           (with-input-from-file filename
@@ -229,7 +234,7 @@
     (if (legal-script-filename? filename config)
         (let* ((sexp (with-input-from-file filename read))
                (script-result (with-selector-dir
-                               selector config
+                               (pathname-directory selector) config
                                (lambda ()
                                  (apply (eval sexp) arguments)))))
           (when (pair? script-result)
@@ -322,8 +327,8 @@
 
 (define (with-selector-dir selector config thunk)
   (with-current-working-directory
-   (make-pathname (config-root-dir config)
-                  (pathname-directory selector)) thunk))
+   (make-pathname (config-root-dir config) selector)
+   thunk))
 
 
 ;;; Main