X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=scratchy.git;a=blobdiff_plain;f=burrower.scm;h=ed5e98ffaebfc3d65e9e04e4beb25ba46f8624e9;hp=b7b275484f9e35578658abd49eeac6e119d3d7e9;hb=2ee1c7c6da9e093c1722a0009c82dba5c14a0db0;hpb=e232a334082d59cccb129d742ac36e00c6ee60a9

diff --git a/burrower.scm b/burrower.scm
index b7b2754..ed5e98f 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)
@@ -11,15 +15,11 @@
         (chicken condition)
         (chicken process)
         (chicken process-context)
+        (chicken process-context posix)
         srfi-1 srfi-13 matchable)
 
-;; Chicken 4
-;; (use srfi-1 srfi-13 tcp posix matchable)
-
 ;;; Global constants
 
-(define gopher-index-filename "index")
-
 (define burrower-version "1.0.0")
 
 (define burrower-footer
@@ -28,6 +28,8 @@
         "This gopher hole was dug using Burrower v" burrower-version ".\n"
         "Powered by Chicken Scheme!"))
 
+(define gopher-index-filename "index")
+
 ;;; Server loop
 
 ;; We don't yet use worker threads here to handle requests,
@@ -35,37 +37,48 @@
 ;; While we should fix this, it's actually probably okay, as
 ;; we genuinely don't expect a huge flood of gopher traffic. :-(
 
-(define-record config root-dir host port display-footer)
+(define-record config
+  root-dir host port display-footer user group)
 
 (define (run-server config)
   (set-buffering-mode! (current-output-port) #:line)
-  (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))
-               (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 ".")))))
-        (close-input-port in-port)
-        (close-output-port out-port))
-      (server-loop))
-    (tcp-close listener)))
-
+    (print "Gopher server listening on port " (config-port config) " ...")
+    (drop-privs config)
+    (server-loop listener config))
+  (tcp-close listener))
+
+(define (drop-privs config)
+  (let ((uid (config-user config))
+        (gid (config-group config)))
+    (if (not (null? gid)) ; Group first, since only root can switch groups.
+        (set! (current-group-id) gid))
+    (if (not (null? uid))
+        (set! (current-user-id) uid))))
+
+(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 ".")))))
+    (close-input-port in-port)
+    (close-output-port out-port))
+  (server-loop listener config))
 
 ;;; Selector type inference
 
@@ -90,8 +103,7 @@
   (let ((l (string-downcase selector)))
     (cond
      ((or (= (string-length l) 0)
-          (string-suffix? "/" l)
-          (string-contains l ":")) 1)
+          (string-suffix? "/" l)) 1)
      ((has-suffix? l ".txt" ".org" ".md") 0)
      ((has-suffix? l ".png" ".jpg" ".gif" ".bmp" ".tif" ".tga") 'I)
      ((has-suffix? l "?" "%3f") 7)
@@ -105,17 +117,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,19 +140,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))
-               (selector-dir (pathname-directory selector)))
-          (serve-records (with-selector-dir
-                          selector config
-                          (lambda ()
-                            (apply (eval sexp) arguments)))
-                         selector-dir 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)))
@@ -207,6 +205,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
 
@@ -263,7 +275,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
@@ -298,38 +312,49 @@
 (define (print-usage progname)
   (print "Usage:\n"
          progname " -h/--help\n"
-         progname " [-n/--no-footer] gopher-root-dir server-hostname [server-port]\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 -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 creation of the TCP port listener (which often requires root)."))
 
 (define (main)
   (let* ((progname (car (argv)))
-         (args (cdr (argv)))
-         (config (make-config '() '() 70 #t)))
-
-    (if (or (null? args)
-            (equal? (car args) "-h")
-            (equal? (car args) "--help"))
+         (config (make-config '() '() 70 #t '() '())))
+    (if (null? (cdr (argv)))
         (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))))
-          (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-config "gopher-root" "localhost" 70 #t)))
-
-(test)
+        (let loop ((args (cdr (argv))))
+          (let ((this-arg (car args))
+                (rest-args (cdr args)))
+            (if (string-prefix? "-" this-arg)
+                (cond
+                 ((or (equal? this-arg "-h")
+                      (equal? this-arg "--help"))
+                  (print-usage progname))
+                 ((or (equal? this-arg "-n")
+                      (equal? this-arg "--no-footer"))
+                  (config-display-footer-set! config #f)
+                  (loop rest-args))
+                 ((or (equal? this-arg "-u")
+                      (equal? this-arg "--user"))
+                  (config-user-set! config (string->number (car rest-args)))
+                  (loop (cdr rest-args)))
+                 ((or (equal? this-arg "-g")
+                      (equal? this-arg "--group"))
+                  (config-group-set! config (string->number (car rest-args)))
+                  (loop (cdr rest-args)))
+                 (else
+                  (print-usage progname)))
+                (begin
+                  (config-root-dir-set! config (car args))
+                  (config-host-set! config (cadr args))
+                  (if (>= (length rest-args) 2)
+                      (config-port-set! config (string->number (caddr args))))
+                  (run-server config))))))))
+
+(main)
+
+;; (define (test)
+;;   (run-server (make-config "gopher-root" "localhost" 70 #t '() '())))
+
+;; (test)