From: Tim Vaughan Date: Sun, 24 May 2020 22:10:06 +0000 (+0200) Subject: Added support for dropping privs. X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=2a9ed2e462d2d674248848cd000b29ce50a7c39d;p=rags.git Added support for dropping privs. --- diff --git a/rags.scm b/rags.scm index 2f3f8c1..69e7ff6 100644 --- a/rags.scm +++ b/rags.scm @@ -10,11 +10,12 @@ (chicken time posix) (chicken process) (chicken process-context) + (chicken process-context posix) matchable srfi-13 uri-common tcp6 openssl) (define-record config - root-dir host port certfile keyfile) + root-dir host port certfile keyfile uid gid) (define file-types '(("gmi" "text/gemini" "charset=utf-8") @@ -120,10 +121,11 @@ (signal o))))) (define (run-server config) - (define listener (ssl-listen* hostname: (config-host config) - port: (config-port config) + (set-buffering-mode! (current-output-port) #:line) + (define listener (ssl-listen* port: (config-port config) certificate: (config-certfile config) - private-key: (config-keyfile config))) + private-key: (config-keyfile config) + protocol: 'tlsv12)) (print "Host: '" (config-host config) "'\n" "Port: '" (config-port config) "'\n" @@ -133,8 +135,18 @@ "\n" "Gemini server listening ...") + (drop-privs config) (server-loop listener config)) +(define (drop-privs config) + (let ((uid (config-uid config)) + (gid (config-gid config))) + (if gid ; Group first, since only root can switch groups. + (set! (current-group-id) gid)) + (if uid + (set! (current-user-id) uid)))) + + (define (server-loop listener config) (let-values (((in-port out-port) (ssl-accept listener))) (let-values (((local-ip remote-ip) (tcp-addresses (ssl-port->tcp-port in-port)))) @@ -155,11 +167,15 @@ (define (print-usage progname) - (print "Usage: " progname " [-h] [-p port] server-root-dir hostname certfile keyfile")) + (let ((indent-str (make-string (string-length progname) #\space))) + (print "Usage:\n" + progname " [-h/--help]\n" + progname " [-p/--port PORT] [-u/--user UID] [-g/--group GID]\n" + indent-str " server-root-dir hostname certfile keyfile"))) (define (main) (let* ((progname (pathname-file (car (argv)))) - (config (make-config #f #f 1965 #f #f))) + (config (make-config #f #f 1965 #f #f #f #f))) (if (null? (cdr (argv))) (print-usage progname) (let loop ((args (cdr (argv)))) @@ -172,7 +188,15 @@ (print-usage progname)) ((or (equal? this-arg "-p") (equal? this-arg "--port")) - (config-port-set! config (string->bumber (car rest-args))) + (config-port-set! config (string->number (car rest-args))) + (loop (cdr rest-args))) + ((or (equal? this-arg "-u") + (equal? this-arg "--user")) + (config-uid-set! config (string->number (car rest-args))) + (loop (cdr rest-args))) + ((or (equal? this-arg "-g") + (equal? this-arg "--group")) + (config-gid-set! config (string->number (car rest-args))) (loop (cdr rest-args))) (else (print-usage progname)))