Added IP blacklisting.

diff --git a/scratchy.scm b/scratchy.scm
index 0b81523..46cf8a1 100644 (file)
--- a/scratchy.scm
+++ b/scratchy.scm
@@ -20,7 +20,7 @@
 
 ;;; Global constants
 
-(define scratchy-version "1.2.1")
+(define scratchy-version "1.3.0")
 
 (define scratchy-footer
   (conc "\n"
@@ -38,10 +38,10 @@
 ;; we genuinely don't expect a huge flood of gopher traffic. :-(
 
 (define-record config
-  root-dir host port display-footer user group)
+  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)
@@ -60,25 +60,41 @@
   (let-values (((in-port out-port) (tcp-accept listener)))
     (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-raw (string-trim-both line))
-               (selector (if (= (string-length selector-raw) 0)
-                             "/"
-                             selector-raw)))
-          (condition-case
+             " on " (seconds->string))
+      (condition-case
+          (if (or (null? (config-blacklist config))
+                  (not (member remote-ip
+                               (with-input-from-file
+                                   (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)))
+                (condition-case
+                    (begin
+                      (with-output-to-port out-port
+                        (lambda ()
+                          (serve-selector 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 "."))))
               (begin
+                (print "Connection from blacklisted IP. Closing.")
                 (with-output-to-port out-port
                   (lambda ()
-                    (serve-selector 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)))
+                    (print* "Refusing to serve to IP " remote-ip ".\r\n")
+                    (unless (null? (config-blacklist-resp config))
+                      (for-each (lambda (l) (print* l "\r\n"))
+                                (with-input-from-file
+                                    (config-blacklist-resp config)
+                                  read-lines)))
+                    (print* ".\r\n")))))
+        (o (exn)
+           (print-error-message o))))
     (close-input-port in-port)
     (close-output-port out-port))
   (server-loop listener config))
@@ -313,17 +329,22 @@
 ;;; Main
 
 (define (print-usage progname)
-  (print "Usage:\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.\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)."))
+  (let ((indent-str (make-string (string-length progname) #\space)))
+    (print "Usage:\n"
+           progname " -h/--help\n"
+           progname " [-n/--no-footer] [-u/--user UID] [-g/--group GID]\n"
+           indent-str " [-b/--blacklist FILE] [-r/--blacklist-resp RESPFILE] root-dir hostname [port]\n"
+           "\n"
+           "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).\n"
+           "The -b option can be used to specify a FILE containing a list of IP addresses\n"
+           "to block from the server. If a connection from a blocked address is served,\n"
+           "the response file RESPFILE is served instead, if this is provided.")))
 
 (define (main)
   (let* ((progname (pathname-file (car (argv))))
-         (config (make-config '() '() 70 #t '() '())))
+         (config (make-config '() '() 70 #t '() '() '() '())))
     (if (null? (cdr (argv)))
         (print-usage progname)
         (let loop ((args (cdr (argv))))
@@ -346,6 +367,14 @@
                       (equal? this-arg "--group"))
                   (config-group-set! config (string->number (car rest-args)))
                   (loop (cdr rest-args)))
+                 ((or (equal? this-arg "-b")
+                      (equal? this-arg "--blacklist"))
+                  (config-blacklist-set! config (car rest-args))
+                  (loop (cdr rest-args)))
+                 ((or (equal? this-arg "-r")
+                      (equal? this-arg "--blacklist-resp"))
+                  (config-blacklist-resp-set! config (car rest-args))
+                  (loop (cdr rest-args)))
                  (else
                   (print-usage progname)))
                 (begin
@@ -358,6 +387,6 @@
 (main)
 
 ;; (define (test)
-;;   (run-server (make-config "gopher-root" "localhost" 70 #t '() '())))
+;;   (run-server (make-config "gopher-root" "localhost" 70 #t '() '() '() '())))
 
 ;; (test)