>From da35b586efcbf1bc5b432914f5d6e938296a4ef6 Mon Sep 17 00:00:00 2001 From: Duncan Bayne 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