;;; Scratchy gopher server
;;
-;; Requires Chicken 5.0.0.
+;; Requires Chicken 5
;;
;;; Imports
;;; Global constants
-(define scratchy-version "1.2.0")
+(define scratchy-version "1.4.1")
(define scratchy-footer
(conc "\n"
;; 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)
(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 (string-trim-both line)))
- (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 (string-trim-both line)))
+ (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 (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)))
+ (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))
;;; 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 "|")))
- (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))))))
+ (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)
(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
(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)
(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
(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))))
(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
(main)
;; (define (test)
-;; (run-server (make-config "gopher-root" "localhost" 70 #t '() '())))
+;; (run-server (make-config "gopher-root" "localhost" 70 #t '() '() '() '())))
;; (test)
The Lambda Lab / projects / scratchy.git / blobdiff