("png" "image/png")
("mp3" "audio/mpeg")))
+(define eval-env-file "eval-env.scm")
+(define eval-env (interaction-environment))
+
(define (process-request config request-line)
(let ((uri (uri-normalize-path-segments (absolute-uri request-line))))
(cond
(with-current-working-directory
working-directory
(lambda ()
- (eval expression))))
+ (eval expression eval-env))))
(('shell command)
(with-current-working-directory
working-directory
(define (serve-script config uri)
;; Scripts are responsible for the entire response, including header
- (let ((path (document-path config uri)))
- (apply (eval (with-input-from-file path read))
- (list uri))))
+ (let* ((path (document-path config uri))
+ (proc (eval (with-input-from-file path read) eval-env)))
+ (with-current-working-directory
+ (pathname-directory (document-path config uri))
+ (lambda ()
+ (apply proc (list uri))))))
(define (with-current-working-directory directory thunk)
(let ((old-wd (current-directory))
"Port: '" (config-port config) "'\n"
"Root directory: '" (config-root-dir config) "'\n"
"Cert file: '" (config-certfile config) "'\n"
- "Key file: '" (config-keyfile config) "'\n"
- "\n"
- "Gemini server listening ...")
+ "Key file: '" (config-keyfile config) "'\n")
+ (print* "Dropping privilages ... ")
(drop-privs config)
+ (print "done")
+
+ (print* "Setting up environment ... ")
+ (setup-env config)
+ (print "done")
+
+ (print "\nGemini server listening ...")
(server-loop listener config))
+(define (setup-env config)
+ (with-current-working-directory
+ (config-root-dir config)
+ (lambda ()
+ (if (and (file-exists? eval-env-file) (file-readable? eval-env-file))
+ (with-input-from-file eval-env-file
+ (lambda ()
+ (let loop ((next-expr (read)))
+ (unless (eof-object? next-expr)
+ (eval next-expr eval-env)
+ (loop (read))))))))))
+
(define (drop-privs config)
(let ((uid (config-uid config))
(gid (config-gid config)))
(define (main)
(let* ((progname (pathname-file (car (argv))))
(config (make-config #f #f 1965 #f #f #f #f)))
- (if (null? (cdr (argv)))
+ (if (null? (command-line-arguments))
(print-usage progname)
- (let loop ((args (cdr (argv))))
+ (let loop ((args (command-line-arguments)))
(let ((this-arg (car args))
(rest-args (cdr args)))
(if (string-prefix? "-" this-arg)