Modified script argument behaviour.

[scratchy.git] / scratchy.scm

diff --git a/scratchy.scm b/scratchy.scm
index df538b4..435fe15 100644 (file)
--- a/scratchy.scm
+++ b/scratchy.scm
@@ -1,11 +1,11 @@
 ;;; Scratchy gopher server
 ;;
-;; Requires Chicken 5.0.0.
+;; Requires Chicken 5
 ;;
 
 ;;; Imports
 
-(import (chicken tcp)
+(import tcp6
         (chicken port)
         (chicken io)
         (chicken string)
@@ -20,7 +20,7 @@
 
 ;;; Global constants
 
-(define scratchy-version "1.0.0")
+(define scratchy-version "1.2.1")
 
 (define scratchy-footer
   (conc "\n"
@@ -42,7 +42,7 @@
 
 (define (run-server config)
   (set-buffering-mode! (current-output-port) #:line)
-  (let ((listener (tcp-listen (config-port config))))
+  (let ((listener (tcp-listen (config-port config) 10 "::")))
     (print "Gopher server listening on port " (config-port config) " ...")
     (drop-privs config)
     (server-loop listener config))
@@ -58,24 +58,27 @@
 
 (define (server-loop listener config)
   (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 ".")))))
+    (let-values (((local-ip remote-ip) (tcp-addresses in-port)))
+      (print "Accepted connection from " remote-ip
+             " on " (seconds->string)))
+    (condition-case
+        (let* ((line (read-line in-port))
+               (selector (string-trim-both line)))
+          (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 "."))))
+      (o (exn)
+         (print-error-message o)))
     (close-input-port in-port)
     (close-output-port out-port))
   (server-loop listener config))
@@ -118,11 +121,11 @@
          (selector (car selector-list))
          (arguments (cdr selector-list)))
     (if (string-contains selector "|")
-        (let ((l (string-split 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 "?")))
+          ((7) (let ((l (string-split selector "?" #t)))
                  (serve-script (car l) arguments config)))
           ((0) (serve-text-file selector config))
           ((h) (serve-url selector config))
@@ -314,12 +317,12 @@
          progname " -h/--help\n"
          progname " [-n/--no-footer] [-u/--user UID] [-g/--group GID] root-dir hostname [port]\n"
          "\n"
-         "The -n option tells the server to not display a directory footer."
-         "The -u and -g can be used to set the UID and GID of the process following"
+         "The -n option tells the server to not display a directory footer.\n"
+         "The -u and -g can be used to set the UID and GID of the process following\n"
          "the creation of the TCP port listener (which often requires root)."))
 
 (define (main)
-  (let* ((progname (car (argv)))
+  (let* ((progname (pathname-file (car (argv))))
          (config (make-config '() '() 70 #t '() '())))
     (if (null? (cdr (argv)))
         (print-usage progname)