The Lambda Lab
/
projects
/
rags.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
65de389
)
Added support for dropping privs.
author
Tim Vaughan
<plugd@thelambdalab.xyz>
Sun, 24 May 2020 22:10:06 +0000
(
00:10
+0200)
committer
Tim Vaughan
<plugd@thelambdalab.xyz>
Sun, 24 May 2020 22:10:06 +0000
(
00:10
+0200)
rags.scm
patch
|
blob
|
history
diff --git
a/rags.scm
b/rags.scm
index
2f3f8c1
..
69e7ff6
100644
(file)
--- a/
rags.scm
+++ b/
rags.scm
@@
-10,11
+10,12
@@
(chicken time posix)
(chicken process)
(chicken process-context)
(chicken time posix)
(chicken process)
(chicken process-context)
+ (chicken process-context posix)
matchable srfi-13
uri-common tcp6 openssl)
(define-record config
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")
(define file-types
'(("gmi" "text/gemini" "charset=utf-8")
@@
-120,10
+121,11
@@
(signal o)))))
(define (run-server config)
(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)
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"
(print "Host: '" (config-host config) "'\n"
"Port: '" (config-port config) "'\n"
@@
-133,8
+135,18
@@
"\n"
"Gemini server listening ...")
"\n"
"Gemini server listening ...")
+ (drop-privs config)
(server-loop listener 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))))
(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)
(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))))
(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))))
(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"))
(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)))
(loop (cdr rest-args)))
(else
(print-usage progname)))