From 03415ce108aedef6f0cd57210fe802601a5f0aea Mon Sep 17 00:00:00 2001 From: Tim Vaughan Date: Fri, 31 May 2019 22:00:49 +0200 Subject: [PATCH] Relinquish root privs after securing tcp listener. --- burrower.scm | 129 ++++++++++++++++++++++++++++++--------------------- 1 file changed, 76 insertions(+), 53 deletions(-) diff --git a/burrower.scm b/burrower.scm index 9db8599..feb26cc 100644 --- a/burrower.scm +++ b/burrower.scm @@ -15,12 +15,11 @@ (chicken condition) (chicken process) (chicken process-context) + (chicken process-context posix) srfi-1 srfi-13 matchable) ;;; Global constants -(define gopher-index-filename "index") - (define burrower-version "1.0.0") (define burrower-footer @@ -29,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, @@ -36,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 @@ -301,38 +313,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))))))) + (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))) +;; (run-server (make-config "gopher-root" "localhost" 70 #t '() '()))) ;; (test) -- 2.20.1