Stelian Ionescu writes:
> The whole point of special variables is to make it oblivious whether
> one is using the global binding or a thread-local binding, so code
> shouldn't be aware of that in general.
Attached is the patch I went with courtesy you and Chun Tian - it works
very nicely, thank you both :)
In summary, the approach I took was:
1. Use a helper to create a handler closure that closes over the
shadowed variables, thereby making the correct values available on all
threads.
2. Add the root path to the request class, conceptually treating
requests as relative to a particular root, and handily avoiding the
same threading + shadowed variable issue with *germinal-root*.
Now I can set a temporary context in my tests with a let form, and the
world is a happier place :)
Happy New Year :)
--
Duncan Bayne
+61 420 817 082 | https://duncan.bayne.id.au/
I usually check my mail every 24 - 48 hours. If there's something
urgent going on, please send me an SMS or call me.
>From da35b586efcbf1bc5b432914f5d6e938296a4ef6 Mon Sep 17 00:00:00 2001
From: Duncan Bayne <dun...@bayne.id.au>
Date: Sat, 1 Jan 2022 11:12:49 +1100
Subject: [PATCH] Honor shadowed config variables
Thanks to Chun Tian and Stelian Ionescu from the usocket-devel list for
one of the approaches - constructing closures with a helper to capture
shadowed variable values for use in the handler thread.
The other case - dealing with *germinal-root* - was accomplished simply
by moving the root path into the request. Perhaps a mixing of concerns?
I don't think so, though, because a request is *for* resources on a
particular root context.
_---~~(~~-_.
_{ ) )
, ) -~~- ( ,-' )_
( `-,_..`., )-- '_,)
( ` _) ( -~( -_ `, }
(_- _ ~_-~~~~`, ,' )
`~ -^( __;-,((()))
~~~~ {_ -_(())
`\ }
{ } Steven James Walker
---
classes.lisp | 4 +++-
server.lisp | 21 +++++++++++++--------
tests/germinal.lisp | 18 +++++-------------
3 files changed, 21 insertions(+), 22 deletions(-)
diff --git a/classes.lisp b/classes.lisp
index 6a5bc0f..9e45549 100644
--- a/classes.lisp
+++ b/classes.lisp
@@ -3,6 +3,7 @@
(defclass request ()
((url :initarg :url :accessor request-url)
+ (root-path :initarg :root-path :accessor request-root-path)
(path-info :initarg :path-info :accessor request-pathinfo)
(params :initarg :params :accessor request-params)
(client-key :initarg :client-key :accessor request-client-key)
@@ -13,13 +14,14 @@
(meta :initarg :meta :accessor response-meta)
(body :initarg :body :accessor response-body :initform "")))
-(defun make-request (url &optional client-key client-address)
+(defun make-request (url root-path &optional client-key client-address)
(let* ((parsed-url (uri url))
(params (car (car (quri:uri-query-params parsed-url)))))
(if (not (uri-path parsed-url))
(setf (uri-path parsed-url) "/" ))
(make-instance 'request :url parsed-url :path-info (uri-path parsed-url)
:params params
+ :root-path root-path
:client-key client-key
:client-address client-address)))
diff --git a/server.lisp b/server.lisp
index e59a159..8957106 100644
--- a/server.lisp
+++ b/server.lisp
@@ -50,7 +50,7 @@
+ssl-op-no-tlsv1+ +ssl-op-no-tlsv1-1+
+ssl-op-no-tlsv1-2+)))
(with-global-context (*germinal-tls-context* :auto-free-p (not background))
- (usocket:socket-server host port #'gemini-handler ()
+ (usocket:socket-server host port (make-gemini-handler *germinal-cert* *germinal-cert-key* *germinal-root*) ()
:multi-threading t
:element-type '(unsigned-byte 8)
:in-new-thread background)))
@@ -97,13 +97,18 @@ route to the request and any positional args from the route."
*germinal-middleware* in order, with serve-route as the last handler."
(funcall (middleware-chain *germinal-middleware*) request))
-(defun gemini-handler (stream)
+(defun make-gemini-handler (cert cert-key root-path)
+ "Create a Gemini request handler for a specified root path, TLS certificate, and TLS key."
+ (lambda (stream) (gemini-handler stream cert cert-key root-path)))
+
+(defun gemini-handler (stream cert cert-key root-path)
"The main Gemini request handler. Sets up TLS and sets up request and response"
(handler-case
(let* ((tls-stream (make-ssl-server-stream stream
- :certificate *germinal-cert*
- :key *germinal-cert-key*))
+ :certificate cert
+ :key cert-key))
(request (make-request (normalize (read-line-crlf tls-stream) :nfc)
+ root-path
(cl+ssl:ssl-stream-x509-certificate tls-stream)
usocket:*remote-host*))
(response (serve-route-with-middleware request)))
@@ -134,11 +139,11 @@ route to the request and any positional args from the route."
"Given a gemini request (string), try to respond by serving a file or directory listing."
(declare (ignore junk))
(handler-case
- (let* ((path (get-path-for-url (request-url request)))
+ (let* ((path (get-path-for-url (request-url request) (request-root-path request)))
(path-kind (osicat:file-kind path :follow-symlinks t)))
(if (or (not (member :other-read (osicat:file-permissions path)))
(path-blocklisted-p path)
- (not (str:starts-with-p *germinal-root* path)))
+ (not (str:starts-with-p (request-root-path request) path)))
(make-response 51 "Not Found") ;; In lieu of a permission-denied status
(cond
((eq :directory path-kind) (gemini-serve-directory path))
@@ -151,11 +156,11 @@ route to the request and any positional args from the route."
(format *error-output* "gemini-serve-file-or-directory error: ~A~%" c)
(make-response 40 "Internal server error"))))
-(defun get-path-for-url (url)
+(defun get-path-for-url (url root-path)
"Get file path based on URL (a quri object)"
(if (uri-userinfo url)
(error 'gemini-error :error-type 59 :error-message "Bad Request"))
- (normpath (join *germinal-root*
+ (normpath (join root-path
(string-left-trim "/" (url-decode (uri-path url))))))
(defun gemini-serve-file (path)
diff --git a/tests/germinal.lisp b/tests/germinal.lisp
index 19535cf..cd528cb 100644
--- a/tests/germinal.lisp
+++ b/tests/germinal.lisp
@@ -11,19 +11,11 @@
(defmacro with-test-server (&body body)
`(progn
- ;; These special variables are being `setq` rather than `let` because the
- ;; usocket server uses its own context to handle new connections; even if
- ;; these variables are shadowed, they *won't* be shadowed in the context
- ;; of the connection handler.
- ;;
- ;; See https://stackoverflow.com/q/70501396/181452
- ;;
- (setq germinal:*germinal-host* "0.0.0.0")
- (setq germinal:*germinal-cert* (concatenate 'string (sb-posix:getcwd) "/tests/fixtures/localhost.crt"))
- (setq germinal:*germinal-cert-key* (concatenate 'string (sb-posix:getcwd) "/tests/fixtures/localhost.key"))
- (setq germinal:*germinal-root* (concatenate 'string (sb-posix:getcwd) "/tests/fixtures/files"))
-
- (let ((server-thread (germinal:start :background t)))
+ (let* ((germinal:*germinal-host* "0.0.0.0")
+ (germinal:*germinal-cert* (concatenate 'string (sb-posix:getcwd) "/tests/fixtures/localhost.crt"))
+ (germinal:*germinal-cert-key* (concatenate 'string (sb-posix:getcwd) "/tests/fixtures/localhost.key"))
+ (germinal:*germinal-root* (concatenate 'string (sb-posix:getcwd) "/tests/fixtures/files"))
+ (server-thread (germinal:start :background t)))
(unwind-protect
(progn
(wait-for-gemini-server)
--
2.30.2
