diff --git a/Makefile b/Makefile index 6bb5ae4..453263c 100644 --- a/Makefile +++ b/Makefile @@ -1,14 +1,15 @@ bin/geml-server: src/*.lisp mkdir -p bin sbcl --no-userinit --no-sysinit --non-interactive \ - --load ~/quicklisp/setup.lisp \ - --load build.lisp + --load ~/.quicklisp/setup.lisp \ + --load build.lisp clean: -rm bin/geml-server + -rm bin/ install: bin/geml-server - id -u geml &>/dev/null || useradd geml --system + id -u geml &>/dev/null || useradd geml --system -g geml install \ --target-directory /usr/local/bin/ \ --mode 744 \ @@ -27,12 +28,14 @@ install: bin/geml-server --target-directory /etc/geml/ \ --owner geml \ --group geml \ - --mode 644 \ + --mode 664 \ geml.example.ini mkdir -p /var/lib/geml - chown geml:geml -R /var/lib/geml + chown -R geml:geml /var/lib/geml + chmod 770 /var/lib/geml mkdir -p /srv/gmi - chown geml:geml -R /srv/gmi + chown -R geml:geml /srv/gmi + chmod 770 /srv/gmi uninstall: id -u geml &>/dev/null && userdel geml diff --git a/README.md b/README.md index 2679be7..15d2960 100644 --- a/README.md +++ b/README.md @@ -12,6 +12,10 @@ root. root = /srv/gmi ``` +**NOTE**: Until [Server Name Identification](./src/server.lisp) is achieved only +the first domain you configure will work. Certificates will still be generated +for other configured domains they will just be unreachable. + ## Usage To get an executable `bin/geml-server` run `make`. diff --git a/geml.asd b/geml.asd index cf03905..91397d4 100644 --- a/geml.asd +++ b/geml.asd @@ -1,4 +1,5 @@ (in-package #:cl-user) + (asdf:defsystem geml :name "geml" :description "Gemini Server" diff --git a/src/server.lisp b/src/server.lisp index 902a182..15056c1 100644 --- a/src/server.lisp +++ b/src/server.lisp @@ -1,38 +1,32 @@ (in-package #:geml.server) - (defun ensure-cert (certs-dir) (lambda (setting) - (unless (eq (car setting) :global) - (let* ((domain (string-downcase (symbol-name (car setting)))) - (key (concatenate 'string - (namestring certs-dir) - domain ".key")) - (cert (concatenate 'string - (namestring certs-dir) - domain ".crt")) - (missing-cert (or (not (probe-file key)) - (not (probe-file cert)))) - (openssl-cmd (format nil - "openssl req -x509 ~ - -newkey rsa:4096 ~ - -sha256 ~ - -days 36525 -nodes ~ - -subj \"/CN=~a\" ~ - -keyout ~a ~ - -out ~a ~ - -addext \"subjectAltName=DNS:~a\"" - domain - key - cert - domain))) - (cond - (missing-cert - (progn (format t "Creating TLS cert for ~a (~a)~%" - domain openssl-cmd) - (uiop:run-program openssl-cmd))) - (t - (format t "Found TLS cert for ~a~%" domain))) - setting)))) + (let* ((domain (string-downcase (symbol-name (car setting)))) + (key (format nil "~A~A.key" certs-dir domain)) + (cert (format nil "~A~A.crt" certs-dir domain)) + (missing-cert (or (not (probe-file key)) + (not (probe-file cert)))) + (openssl-cmd (format nil + "openssl req -x509 ~ + -newkey rsa:4096 ~ + -sha256 ~ + -days 36525 -nodes ~ + -subj \"/CN=~A\" ~ + -keyout ~A ~ + -out ~A ~ + -addext \"subjectAltName=DNS:~A\"" + domain + key + cert + domain))) + (cond + (missing-cert + (progn (format t "Creating TLS cert for ~A (~A)~%" + domain openssl-cmd) + (uiop:run-program openssl-cmd))) + (t + (format t "Found TLS cert for ~A~%" domain))) + setting))) (defun resolve-index (path) (let ((index "index.gmi") @@ -41,8 +35,8 @@ (has-backslash (position #\/ path :start (- (length path) 1)))) (cond (has-extension path) - (has-backslash (concatenate 'string path index)) - (t (concatenate 'string path "/" index))))) + (has-backslash (format nil "~A~A" path index)) + (t (format nil "~A/~A" path index))))) (defun write-file (filepath conn) (with-open-file (in filepath :element-type '(unsigned-byte 8)) @@ -56,20 +50,21 @@ (let* ((uri (quri:uri (read-line conn))) (domain (quri:uri-domain uri)) (path (quri:uri-path uri)) - (root (cl-ini:ini-value settings - :root - :section (intern (string-upcase domain) - :keyword))) - (filename (probe-file (concatenate 'string - root - (resolve-index path))))) + (root (cl-ini:ini-value + settings + :root + :section (intern (string-upcase domain) :keyword))) + (filename (probe-file (format nil "~A~A" root (resolve-index path))))) (if filename - (progn (format t "Serving gemini://~a~a (~a)~%" domain path filename) + (progn (format t "Serving gemini://~A~A (~A)~%" domain path filename) (write-line "20 text/gemini" conn) (write-file filename conn)) - (format conn "51 ~a does not exist for ~a~%" path domain))) + (format conn "51 ~A does not exist for ~A~%" path domain))) (force-output conn)) +(defun without-global (settings) + (remove (lambda (setting) (eq :global (cdr setting))) settings)) + (defun start-server (settings) (let* ((host (or (cl-ini:ini-value settings :host) "0.0.0.0")) @@ -77,38 +72,28 @@ 1965)) (certs-dir (probe-file (or (cl-ini:ini-value settings :certs-dir) "/var/lib/geml")))) - (mapcar (ensure-cert certs-dir) settings) - (let* ((server (usocket:socket-listen host port))) - (format t "Booted on ~a:~a~%" host port) + (cl+ssl:reload) + (mapcar (ensure-cert certs-dir) (without-global settings)) + (let ((server (usocket:socket-listen host port))) (unwind-protect - (loop - (let* ((tcp-stream (flexi-streams:make-flexi-stream - (usocket:socket-stream - (usocket:socket-accept - server - :element-type '(unsigned-byte 8))) - :external-format '(:utf-8 :eol-style :crlf)))) - (unwind-protect - (progn - ;; TODO parse domain - ;; Unexpected value #xFC at start of UTF-8 sequence. - (format t "TCP#> ~a~%" (read-line tcp-stream)) - ;; TODO upgrade to TLS - ;; (let ((cert (concatenate 'string certs-dir domain ".crt")) - ;; (key (concatenate 'string certs-dir domain ".key"))) - ;; (loop - ;; (let* ((tls-conn (cl+ssl:make-ssl-server-stream - ;; (usocket:socket-stream socket) - ;; :external-format '(:utf-8 :eol-style :crlf) - ;; :certificate cert - ;; :key key))) - ;; (unwind-protect - ;; (handle-request domain path settings) - ;; (close tls-conn))))) - ) - (progn - (format t "Closing TCP connection...~%") - (usocket:socket-close tcp-conn))))) (progn - (format t "Shutting down server...~%") - (usocket:socket-close server)))))) + (format t "Booted on ~A:~A~%" host port) + (loop + ;; TODO Use SNI for virtual domain hosting + ;; I am not capable enough at Common Lisp or OpenSSL to figure that out yet. + ;; * Secion 4: https://gemini.circumlunar.space/docs/specification.gmi + ;; * https://github.com/cl-plus-ssl/cl-plus-ssl#usage + ;; * https://stackoverflow.com/questions/5113333/how-to-implement-server-name-indication-sni + ;; * https://en.wikipedia.org/wiki/Server_Name_Indication + (let* ((domain (string-downcase + (car (first (without-global settings))))) + (tls-conn (cl+ssl:make-ssl-server-stream + (usocket:socket-stream + (usocket:socket-accept server)) + :external-format '(:utf-8 :eol-style :crlf) + :certificate (format nil "~A~A.crt" certs-dir domain) + :key (format nil "~A~A.key" certs-dir domain)))) + (unwind-protect + (handle-request tls-conn settings) + (close tls-conn))))) + (usocket:socket-close server)))))