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
 ;;
 ;;; Scratchy gopher server
 ;;

-;; Requires Chicken 5.0.0.
+;; Requires Chicken 5

 ;;
 
 ;;; Imports
 
 ;;
 
 ;;; Imports
 

-(import (chicken tcp)
+(import tcp6

         (chicken port)
         (chicken io)
         (chicken string)
         (chicken port)
         (chicken io)
         (chicken string)


@@ -20,7 +20,7 @@
 
 ;;; Global constants
 
 
 ;;; Global constants
 

-(define scratchy-version "1.0.0")
+(define scratchy-version "1.2.1")

 
 (define scratchy-footer
   (conc "\n"
 
 (define scratchy-footer
   (conc "\n"


@@ -42,7 +42,7 @@
 
 (define (run-server config)
   (set-buffering-mode! (current-output-port) #:line)
 
 (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))
     (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)))
 
 (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))
     (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 "|")
          (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))
           (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))
                  (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"
          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)
          "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)
          (config (make-config '() '() 70 #t '() '())))
     (if (null? (cdr (argv)))
         (print-usage progname)