From 1d5075c23237deec536f62ed5dc06f3845eacf6b Mon Sep 17 00:00:00 2001 From: Niten Date: Wed, 14 Apr 2021 15:43:49 -0500 Subject: [PATCH] 'Initial' checkin --- README.markdown | 9 +++ README.md | 3 - README.org | 5 ++ cl-gemini.asd | 43 ++++++++++++ src/atom-feed.lisp | 130 ++++++++++++++++++++++++++++++++++ src/filesystem.lisp | 136 ++++++++++++++++++++++++++++++++++++ src/gemtext.lisp | 19 +++++ src/main.lisp | 54 +++++++++++++++ src/pipeline.lisp | 165 ++++++++++++++++++++++++++++++++++++++++++++ src/proxy.lisp | 1 + src/request.lisp | 68 ++++++++++++++++++ src/response.lisp | 104 ++++++++++++++++++++++++++++ src/server.lisp | 101 +++++++++++++++++++++++++++ src/stats.lisp | 122 ++++++++++++++++++++++++++++++++ src/user.lisp | 57 +++++++++++++++ tests/main.lisp | 70 +++++++++++++++++++ 16 files changed, 1084 insertions(+), 3 deletions(-) create mode 100644 README.markdown delete mode 100644 README.md create mode 100644 README.org create mode 100644 cl-gemini.asd create mode 100644 src/atom-feed.lisp create mode 100644 src/filesystem.lisp create mode 100644 src/gemtext.lisp create mode 100644 src/main.lisp create mode 100644 src/pipeline.lisp create mode 100644 src/proxy.lisp create mode 100644 src/request.lisp create mode 100644 src/response.lisp create mode 100644 src/server.lisp create mode 100644 src/stats.lisp create mode 100644 src/user.lisp create mode 100644 tests/main.lisp diff --git a/README.markdown b/README.markdown new file mode 100644 index 0000000..412b002 --- /dev/null +++ b/README.markdown @@ -0,0 +1,9 @@ +# Cl-Gemini + +## Usage + +## Installation + +To generate an SSL cert, something like this should work: + +openssl req -new -subj "/CN=*.example.com" -addext "subjectAltName = DNS:example.com, DNS:*.example.com" -x509 -newkey ec -pkeyopt ec_paramgen_curve:prime256v1 -days 1825 -nodes -out cert.pem -keyout key.pem diff --git a/README.md b/README.md deleted file mode 100644 index a1ce790..0000000 --- a/README.md +++ /dev/null @@ -1,3 +0,0 @@ -# cl-gemini - -Gemini server written in Common Lisp \ No newline at end of file diff --git a/README.org b/README.org new file mode 100644 index 0000000..53a6bf2 --- /dev/null +++ b/README.org @@ -0,0 +1,5 @@ +* Cl-Gemini + +** Usage + +** Installation diff --git a/cl-gemini.asd b/cl-gemini.asd new file mode 100644 index 0000000..6bc55a5 --- /dev/null +++ b/cl-gemini.asd @@ -0,0 +1,43 @@ +(defsystem "cl-gemini" + :version "0.1.0" + :author "niten" + :license "" + :depends-on (:alexandria + :arrows + :asdf + :cl+ssl + :cl-ppcre + :file-types + :inferior-shell + :local-time + :osicat + :quri + :uiop + :usocket + :usocket-server + :xml-emitter) + :components ((:module "src" + :components + ((:file "main") + (:file "filesystem") + (:file "gemtext") + (:file "pipeline") + (:file "request") + (:file "response") + (:file "server") + (:file "stats") + (:file "user") + (:file "atom-feed")))) + :description "Minimal Gemini server" + :in-order-to ((test-op (test-op "cl-gemini/tests")))) + +(defsystem "cl-gemini/tests" + :author "" + :license "" + :depends-on ("cl-gemini" + "rove") + :components ((:module "tests" + :components + ((:file "main")))) + :description "Test system for gemini" + :perform (test-op (op c) (symbol-call :rove :run c))) diff --git a/src/atom-feed.lisp b/src/atom-feed.lisp new file mode 100644 index 0000000..ba18b51 --- /dev/null +++ b/src/atom-feed.lisp @@ -0,0 +1,130 @@ +(in-package :cl-gemini) + +(use-package :xml-emitter) +;; (use-package :osicat) + +(defclass gemini-feed () + ((id :initarg :id) + (title :initarg :title) + (link :initarg :link) + (entries :initarg :entries + :initform '()))) + +(defclass gemini-feed-entry () + ((id :initarg :id) + (title :initarg :title) + (link :initarg :link) + (updated :initarg :updated))) + +(defun print-thru (obj) + (format t "~A~%" obj) + obj) + +(defgeneric feed/updated (obj)) +(defmethod feed/updated ((entry gemini-feed-entry)) + (with-slots (updated) entry + updated)) +(defmethod feed/updated ((feed gemini-feed)) + (with-slots (entries) feed + (apply #'local-time:timestamp-maximum + (mapcar #'feed/updated entries)))) + +(defun feed/render-date (date) + (let ((stream (make-string-output-stream))) + (local-time:format-timestring stream date + :timezone local-time:+utc-zone+) + (get-output-stream-string stream))) + +(defgeneric feed/to-string (obj) + (:documentation "Write feed object to provided stream.")) + +(defmethod feed/to-string ((entry gemini-feed-entry)) + (with-slots (id title link updated) entry + (with-simple-tag ("entry") + (simple-tag "id" id) + (simple-tag "title" title) + (simple-tag "updated" (feed/render-date updated)) + (with-tag ("link" `(("href" ,(render-uri link)))))))) + +(defmethod feed/to-string ((feed gemini-feed)) + (with-slots (id title link entries) feed + (let ((out-stream (make-string-output-stream))) + (with-xml-output (out-stream) + (with-tag ("feed" '(("xmlns" "http://www.w3.org/2005/Atom"))) + (simple-tag "id" id) + (simple-tag "title" title) + (simple-tag "updated" + (feed/render-date (feed/updated feed))) + (with-tag ("link" `(("href" ,(render-uri link))))) + + (format nil "~{~A~%~}~%" + (mapcar #'feed/to-string entries)))) + (get-output-stream-string out-stream)))) + +(defun heading-p (line) + (register-groups-bind (title) + ("^#+ (.+)" line) + title)) + +(defun gemini-file-title (path) + (with-open-file (file path) + (do ((line (read-line file nil) + (read-line file nil))) + ((null line)) + (alexandria:when-let ((header (heading-p line))) + (return header))))) + +(defun file-to-blog-entry (uri path) + (let ((title (gemini-file-title path)) + (write-time (osicat-posix:stat-mtime + (osicat-posix:stat path)))) + (make-instance 'gemini-feed-entry + :title title + :updated (local-time:unix-to-timestamp write-time) + :link uri + :id (render-uri uri)))) + +(defun make-blog-feed (base-uri title path) + (let ((gem-files (delete-if-not + #'gemini-file-p + (uiop:directory-files path)))) + (make-instance 'gemini-feed + :id (render-uri base-uri) + :link base-uri + :title title + :entries + (mapcar (lambda (file) + (let ((uri + (merge-uris (namestring (subpathp file path)) + base-uri))) + (file-to-blog-entry uri file))) + gem-files)))) + +(defclass gemini-feed-definition () + ((title :initarg :title :initform (error "must specify feed title")) + (base-uri :initarg :base-uri :initform (error "must specify base-uri")) + (path :initarg :path :initform (error "must specify path")))) + +(defun make-feed (title path base-uri) + (make-instance 'gemini-feed-definition + :title title + :base-uri base-uri + :path path)) + +(defun render-feed (feed) + (with-slots (title base-uri path) feed + (feed/to-string (make-blog-feed base-uri title path)))) + +(defun feed-dispatcher (feeds) + (flet ((remove-xml (name) + (ppcre:split "\.xml$" name))) + (lambda (req) + (let ((feed-name (request/pop-path-element req))) + (if-let ((feed (some-> feed-name + (remove-xml) + (first) + (gethash feeds)))) + (success :mime-type "text/xml" + :body (render-feed feed)) + (error/not-found (format nil "feed not found: ~A" + feed-name))))))) diff --git a/src/filesystem.lisp b/src/filesystem.lisp new file mode 100644 index 0000000..a602f98 --- /dev/null +++ b/src/filesystem.lisp @@ -0,0 +1,136 @@ +(in-package :cl-gemini) + +(defun tee (output) + (format *debug-io* "OUTPUT: ~A~%" output) + (finish-output *debug-io*) + output) + +(define-condition find-file-error (error) + ((text :initarg :text + :reader error/text) + (path :initarg :path + :reader error/path) + (reason :initarg :reason + :reader error/reason) + (reason-string :initarg :reason-string + :reader error/reason-string))) + +(defun to-absolute-file-path (path) + (handler-case + (file-exists-p + (ensure-pathname path + :want-absolute :ignore + :want-existing :ignore + :want-pathname :ignore + :want-physical :ignore + :want-non-wild :ignore + :truename :ignore + :on-error (lambda (string path reason reason-string args) + (declare (ignorable args)) + (error 'find-file-error + :text string + :path path + :reason (string-downcase + (symbol-name reason)) + :reason-string reason-string)))))) + +(define-condition mime-check-error (error) + ((text :initarg :text + :reader text) + (path :initarg :path + :reader mime-check-error/path))) + +(defun external-mime-checker (file-cmd-path) + (lambda (filename) + (multiple-value-bind (out err-out err-code) + (run-program (format nil "~A -i -E ~A" + file-cmd-path + filename) + :output '(:string :stripped t) + :error-output '(:string :stripped t) + :ignore-error-status t) + (if (not (= err-code 0)) + (error 'mime-check-error + :text (or err-out out) + :path filename) + (string-trim '(#\Space #\Tab) + (first (last (split ":" out)))))))) + +(defun internal-mime-checker () + (lambda (filename) + (let ((components (file-types:file-mime filename))) + (format nil "~A/~A" + (first components) + (second components))))) + +(defun mime-checker (&optional file-cmd-path) + (if file-cmd-path + (external-mime-checker file-cmd-path) + (internal-mime-checker))) + +(defun gemini-file-p (path) + (let ((path-string (namestring path))) + (or (scan "\.gemini$" path-string) + (scan "\.gmi$" path-string)))) + +(defun subdirectory-p (possible-parent child) + (do ((current-parent + (pathname-directory-pathname (or (file-exists-p child) + (directory-exists-p child))) + (pathname-parent-directory-pathname current-parent))) + ((or (not current-parent) + (pathname-equal current-parent #P"/"))) + (when (pathname-equal current-parent possible-parent) + (return t)))) + +(defun read-file-into-string (file-path) + (with-string-stream (output) + (with-open-file (input file-path + :direction :input + :external-format '(:utf-8 :replacement "?")) + (uiop:slurp-input-stream output input)))) + +(defun uri-append-file (uri filename) + ;; If there's no trailing slash in a URI, quri will swap the final path + ;; element out for the supplied filename. Need to add a slash in that case + ;; to make it a 'directory'. + (if (scan "/$" (render-uri uri)) + (merge-uris filename uri) + (merge-uris (format nil "~A/" (render-uri uri)) + filename))) + +(defun handler/filesystem (document-root-string + &optional mime-checker) + (let ((document-root (directory-exists-p document-root-string))) + (when (not document-root) + (error "Document root doesn't exist or is not a directory: ~A~%" + document-root-string)) + (lambda (req) + (handler-case + (let ((full-path (file-exists-p + (merge-pathnames* (request/remaining-path req) + document-root)))) + (format t "serving file ~A~%" full-path) + (cond ((not full-path) + (error/not-found + (format nil "~A not found" + (render-uri (request/uri req))))) + + ;; If we're outside of document-root... + ((not (subpathp full-path document-root)) + (error/not-found + (format nil "~A not found" + (render-uri (request/uri req))))) + + (t (let ((mime-type (if (gemini-file-p full-path) + "text/gemini" + (funcall mime-checker full-path)))) + (success :mime-type mime-type + :body (read-file-into-string full-path)))))) + + (mime-check-error () + (error/permanent-failure "unable to determine mime type")) + (find-file-error (e) + (error/not-found (format nil "~A not found: ~A" + (render-uri (request/uri req)) + (error/reason-string e)))))))) diff --git a/src/gemtext.lisp b/src/gemtext.lisp new file mode 100644 index 0000000..f868559 --- /dev/null +++ b/src/gemtext.lisp @@ -0,0 +1,19 @@ +(in-package :cl-gemini) + +(defun gem/doc (title &rest elements) + (format nil "~A~{~A~}" + (gem/header title) + elements)) + +(defun gem/header (text &optional (depth 1)) + (format nil "~%~A ~A~%" + (make-string depth :initial-element #\#) + text)) + +(defun gem/text (&rest text) + (format nil "~{~A~}~%" text)) + +(defun gem/section (title &rest elements) + (format nil "~A~{~A~}" + (gem/header title 2) + elements)) diff --git a/src/main.lisp b/src/main.lisp new file mode 100644 index 0000000..0d50c11 --- /dev/null +++ b/src/main.lisp @@ -0,0 +1,54 @@ +(defpackage cl-gemini + (:use #:cl + #:arrows + #:cl+ssl + #:file-types + #:quri + #:sb-thread + #:xml-emitter) + + (:import-from #:alexandria + #:if-let + #:hash-table-alist) + + (:import-from #:asdf + #:run-program) + + (:import-from #:cl-ppcre + #:create-scanner + #:register-groups-bind + #:split + #:scan) + + (:import-from #:inferior-shell + #:run) + + (:import-from #:sb-bsd-sockets + #:host-ent-name) + + (:import-from #:uiop + #:directory-exists-p + #:ensure-pathname + #:file-exists-p + #:merge-pathnames* + #:pathname-directory-pathname + #:pathname-equal + #:pathname-parent-directory-pathname + #:subpathp) + + (:import-from #:usocket + #:socket-server) + + (:export #:start-gemini-server + #:register-feed)) + +(in-package :cl-gemini) + +(defmacro with-string-stream (streams &rest body) + (when (not (= 1 (length streams))) + (error (format nil "wrong number of elements in ~% ~A~%expected 1, but got ~A" + streams (length streams)))) + (let ((stream (first streams))) + `(let ((,stream (make-string-output-stream))) + ,@body + (get-output-stream-string ,stream)))) diff --git a/src/pipeline.lisp b/src/pipeline.lisp new file mode 100644 index 0000000..2d505ee --- /dev/null +++ b/src/pipeline.lisp @@ -0,0 +1,165 @@ +(in-package :cl-gemini) + +(defun pipeline/tls-wrap-stream (pipeline key cert) + (lambda (stream) + (with-open-stream + (tls-stream (make-ssl-server-stream stream + :key key + :certificate cert + :external-format :utf-8)) + (funcall pipeline tls-stream)))) + +(defun pipeline/write-response-string (pipeline) + (lambda (stream) + (let ((response-string (funcall pipeline stream))) + (write-string response-string stream) + (close stream) + stream))) + +(defun pipeline/response->string (pipeline) + (lambda (req) + (let ((response (funcall pipeline req))) + (with-string-stream (stream) + (response/write response stream))))) + +(defun pipeline/read-header-string (pipeline &key (max-bytes 1024)) + (lambda (stream) + (handler-case + (funcall pipeline (request/read stream max-bytes)) + (input-too-long-error () + (error/bad-request "request too long"))))) + +(defun pipeline/record-outgoing-bytes (pipeline stats) + (lambda (input) + (let ((output-bytes (funcall pipeline input))) + (gemini-stats/record-bytes-out stats (length output-bytes)) + output-bytes))) + +(defun pipeline/record-incoming-bytes (pipeline stats) + (lambda (header) + (gemini-stats/record-bytes-in stats (length header)) + (funcall pipeline header))) + +(defun pipeline/string->request (pipeline) + (lambda (header-str) + (handler-case + (funcall pipeline (request/create header-str)) + (invalid-uri-error () + (error/bad-request + (format nil + "unable to parse uri: ~A" + header-str)))))) + +(defun pipeline/filter-schemes (pipeline valid-schemes) + (lambda (req) + (let ((scheme (request/scheme req))) + (if (not (member scheme valid-schemes)) + (error/proxy-request-refused + (format nil "scheme proxy not supported for scheme: ~A" scheme)) + (funcall pipeline req))))) + +(defun pipeline/filter-hostnames (pipeline hostnames + &key (allow-relative t)) + (lambda (req) + (if (and allow-relative + (not (request/hostname req))) + (funcall pipeline req) + (let ((hostname (request/hostname req))) + (if (not (member hostname hostnames)) + (error/proxy-request-refused + (format nil "invalid host: ~A" + (string-downcase (symbol-name hostname)))) + (funcall pipeline req)))))) + +(defun pipeline/redirect (pipeline redirect-finder) + (lambda (req) + (let ((redirect (funcall redirect-finder req))) + (if redirect + (error/temporary-redirect redirect) + (funcall pipeline req))))) + +(defun pipeline/url-redirect (pipeline redirections) + (pipeline/redirect pipeline + (lambda (req) + (gethash redirections + (request/uri req))))) + +(defun pipeline/path-redirect (pipeline redirections) + (pipeline/redirect pipeline + (lambda (req) + (gethash redirections + (request/path req))))) + +(defun pipeline/dispatch (continue dispatch-path dispatch) + (lambda (req) + (if (string= dispatch-path (request/peek-path-element req)) + (progn (request/pop-path-element req) + (funcall dispatch req)) + (funcall continue req)))) + +(defun pipeline/redirect-root (pipeline path) + (lambda (req) + ;; if theres no supplied path, redirect to some default file. + (if (or (not (request/path req)) + (string= "" (request/path req)) + (string= "/" (request/path req))) + (let ((redirect (copy-uri (request/uri req)))) + (setf (uri-path redirect) path) + (error/permanent-redirect (render-uri redirect))) + (funcall pipeline req)))) + +(defun pipeline/record-stats (pipeline stats) + (lambda (req) + (gemini-stats/record stats req) + (let ((response (funcall pipeline req))) + (gemini-stats/record stats response) + response))) + +(defun pipeline/not-found () + (lambda (req) + (error/not-found + (format nil "uri not found: ~A" + (render-uri (request/uri req)))))) + +(defun pipeline/echo (pipeline) + (lambda (req) + (format t "REQUEST-URI: ~A" (request/uri req)) + (finish-output *standard-output*) + (let ((response (funcall pipeline req)) + (response-text (make-string-output-stream))) + (response/write response response-text) + (finish-output (format t "RESPONSE: ~A" (get-output-stream-string response-text))) + response))) + +(defun pipeline/timer (pipeline timer-name stats) + (lambda (req) + (let ((start-time (get-internal-real-time))) + (let ((response (funcall pipeline req))) + (gemini-stats/record-timing stats + req + response + timer-name + (- (get-internal-real-time) + start-time)) + response)))) + +(defun pipeline/log-request (pipeline) + (lambda (req) + (format t "incoming request: ~A~%" + (render-uri (request/uri req))) + (let ((response (funcall pipeline req))) + (format t "response: ~A~%" + (response/header response)) + response))) + +(defun pipeline/catch-errors (pipeline debug-p) + (lambda (req) + (if debug-p + (handler-case + (funcall pipeline req) + (error (e) + (format *error-output* "error serving ~A: ~A" + (render-uri (request/uri req)) + e) + (error/temporary-failure "an unexpected error occurred"))) + (funcall pipeline req)))) diff --git a/src/proxy.lisp b/src/proxy.lisp new file mode 100644 index 0000000..6564bf3 --- /dev/null +++ b/src/proxy.lisp @@ -0,0 +1 @@ +(in-package :cl-gemini) diff --git a/src/request.lisp b/src/request.lisp new file mode 100644 index 0000000..1c3e27f --- /dev/null +++ b/src/request.lisp @@ -0,0 +1,68 @@ +(in-package :cl-gemini) + +(define-condition input-too-long-error (error) + ((text :initarg :text :reader text) + (input-size :initarg :input-size :reader input-size))) + +(defun read-line-crlf (stream max) + (let ((out-stream (make-string-output-stream))) + (loop + for empty = t then nil + for char = (read-char stream) + for i from 0 + while (and char (not (eql char #\return))) + do + (when (>= i max) + (error 'input-too-long-error :text "input too long." :input-size i)) + (unless (eql char #\newline) + (write-char char out-stream)) + finally + (return + (if empty nil (get-output-stream-string out-stream)))))) + +(defclass gemini-request () + ((uri :initarg :uri + :initform (error "must supply a request uri") + :reader request/uri) + remaining-path)) + +(defun request/read (stream max-bytes) + (read-line-crlf stream max-bytes)) + +(defun request/pop-path-element (req) + (with-slots (remaining-path) req + (pop remaining-path))) + +(defun request/peek-path-element (req) + (with-slots (remaining-path) req + (first remaining-path))) + +(defun string->keyword (string) + (values (intern (string-upcase string) "KEYWORD"))) + +(defun request/scheme (req) + (string->keyword (uri-scheme (request/uri req)))) + +(defun request/hostname (req) + (string->keyword (uri-host (request/uri req)))) + +(defun request/path (req) + (uri-path (request/uri req))) + +(defmethod initialize-instance :after ((request gemini-request) &key) + (with-slots (remaining-path uri) request + (setf remaining-path (rest (split "/" (uri-path uri)))))) + +(define-condition invalid-uri-error (error) + ((text :initarg :test :initform (error "must provide error text")))) + +(defun request/create (uri) + (handler-case + (make-instance 'gemini-request :uri (uri uri)) + (uri-error () (error 'invalid-uri-error + :text (format nil "invalid uri: ~A" + uri))))) + +(defun request/remaining-path (req) + (with-slots (remaining-path) req + (format nil "~{~A~^/~}" remaining-path))) diff --git a/src/response.lisp b/src/response.lisp new file mode 100644 index 0000000..f801e27 --- /dev/null +++ b/src/response.lisp @@ -0,0 +1,104 @@ +(in-package :cl-gemini) + +(defclass gemini-response () + ((status-code :initarg :status-code + :initform (error "must supply status code.") + :reader response/status-code) + (status-message :initarg :status-message + :initform (error "must supply status message.") + :reader response/status-message))) + +(defclass gemini-success (gemini-response) + ((body :initarg :body + :initform (error "must supply response body.") + :reader response/body))) + +(defclass gemini-error (gemini-response) + ()) + +(defmacro make-error (code msg) + `(make-instance 'gemini-error + :status-code ,code + :status-message ,msg)) + +(defmacro opt-msg (common-msg msg) + `(if ,msg + (format nil "~A: ~A" ,common-msg ,msg) + ,common-msg)) + +(defmacro deferror/optional-message (name code) + `(defun ,(intern (concatenate 'string + (string '#:error/) + (string name))) + (&optional msg) + (make-error ,code (opt-msg ,(string name) msg)))) + +(defun request-input (msg) + (make-instance 'gemini-error + :status-code 10 + :status-message msg)) + +(defun success (&key mime-type body) + (make-instance 'gemini-success + :status-code 20 + :status-message mime-type + :body body)) + +(defun success/end-session (&key mime-type body) + (make-instance 'gemini-success + :status-code 21 + :status-message mime-type + :body body)) + +(defun error/temporary-redirect (url) + (make-error 30 url)) + +(defun error/permanent-redirect (url) + (make-error 31 url)) + +(deferror/optional-message temporary-failure 40) +(deferror/optional-message server-unavailable 41) +(deferror/optional-message cgi-error 42) +(deferror/optional-message proxy-error 43) +(deferror/optional-message slow-down 44) +(deferror/optional-message permanent-failure 50) +(deferror/optional-message not-found 51) +(deferror/optional-message gone 52) +(deferror/optional-message proxy-request-refused 53) +(deferror/optional-message bad-request 54) +(deferror/optional-message client-certificate-required 60) +(deferror/optional-message transient-certificate-requested 61) +(deferror/optional-message authorized-certificate-required 62) +(deferror/optional-message certificate-not-accepted 63) +(deferror/optional-message future-certificate-rejected 64) +(deferror/optional-message expired-certificate-rejected 65) + +(defun gemini/write (stream string) + ;; Don't use format, tildes mess with it + (write-string string stream) + (format stream "~A~A" #\return #\newline)) + +(defun response/write-header (response stream) + (gemini/write + stream + (with-string-stream (output) + (write-string (write-to-string (response/status-code response)) output) + (write-string " " output) + (write-string (response/status-message response) output)))) + +(defun response/write-body (response stream) + (gemini/write stream (response/body response))) + +(defun response/header (response) + (with-string-stream (output) + (response/write-header response output))) + +(defgeneric response/write (response stream) + (:documentation "Write response to stream")) + +(defmethod response/write ((response gemini-error) stream) + (response/write-header response stream)) + +(defmethod response/write ((response gemini-success) stream) + (response/write-header response stream) + (response/write-body response stream)) diff --git a/src/server.lisp b/src/server.lisp new file mode 100644 index 0000000..6dd069f --- /dev/null +++ b/src/server.lisp @@ -0,0 +1,101 @@ +(in-package :cl-gemini) + +;; Easier to parse +(defmacro <- (&rest args) + `(-> ,@(reverse args))) + +(defmacro ->* (&rest fns) + `(lambda (obj) + (-> obj + ,@fns))) + +(defvar *feeds* (make-hash-table :test 'equalp)) + +(defun register-feed (&key base-uri name title path) + (when (not (and name title path)) + (error "Must specify :name, :title, and :path for feeds.")) + (if-let ((verified-path (probe-file path))) + (progn (when (pathname-name verified-path) + (error "Supplied pathname is not a directory: ~A" path)) + (setf (gethash name *feeds*) + (make-feed title + verified-path + (uri base-uri)))) + (error (format nil "Path does not exist: ~A" path)))) + +(defun gemini-server-handler (key cert stats document-root textfiles-root debug-p) + (let ((handler + (<- (pipeline/timer "response-time" stats) + ;; stream / ... + (pipeline/tls-wrap-stream key cert) + ;; tls-stream / ... + (pipeline/timer "post-handshake-time" stats) + ;; tls-stream / ... + (pipeline/write-response-string) + ;; tls-stream / string + (pipeline/read-header-string :max-bytes 1024) + ;; string / string + (pipeline/record-incoming-bytes stats) + ;; string / string + (pipeline/record-outgoing-bytes stats) + ;; string / string + (pipeline/response->string) + ;; string / response + (pipeline/string->request) + ;; string / response + (pipeline/catch-errors debug-p) + ;; request / response + (pipeline/record-stats stats) + ;; request / response + (pipeline/log-request) + ;; request / response + (pipeline/filter-schemes '(:GEMINI)) + ;; request / response + (pipeline/redirect-root "/fs/default.gemini") + ;; request / response + (pipeline/timer "handle-time" stats) + ;; request/response + (pipeline/dispatch "stats" (handler/stats stats)) + ;; request / response + (pipeline/dispatch "fs" + (handler/filesystem document-root + (mime-checker "file"))) + ;; request / response + (pipeline/dispatch "user" + (user-dispatcher + :mime-checker (mime-checker "file"))) + ;; request / response + (pipeline/dispatch "feed" (feed-dispatcher *feeds*)) + ;; request / response + (pipeline/dispatch "textfiles" + (handler/filesystem + textfiles-root + (lambda (filename) + (declare (ignorable filename)) + "text/plain"))) + ;; request / response + (pipeline/not-found)))) + (lambda (stream log-stream) + (let ((*standard-output* log-stream)) + (funcall handler stream))))) + +(defun start-gemini-server (ip key cert + &key + document-root + log-stream + textfiles-root + (port 1965) + (stats (make-instance 'gemini-stats)) + (separate-thread nil) + (threaded t) + (debug-p nil)) + (let ((handler (gemini-server-handler key + cert + stats + document-root + textfiles-root + debug-p))) + (socket-server ip port handler (list log-stream) + :reuse-address t + :in-new-thread separate-thread + :multi-threading threaded))) diff --git a/src/stats.lisp b/src/stats.lisp new file mode 100644 index 0000000..f09d8ba --- /dev/null +++ b/src/stats.lisp @@ -0,0 +1,122 @@ +(in-package :cl-gemini) + +(defclass gemini-stats () + ((visits :initform 0 + :reader gemini-stats/visits) + (status-map :initform (make-hash-table) + :reader gemini-stats/status-map) + (request-map :initform (make-hash-table :test 'equal) + :reader gemini-stats/request-map) + (bytes-in :initform 0 + :reader gemini-stats/bytes-in) + (bytes-out :initform 0 + :reader gemini-stats/bytes-out) + (start-time :initform (get-universal-time) + :reader gemini-stats/start-time) + (timers :initform (make-hash-table :test 'equal)))) + +(defgeneric gemini-stats/record (stats object) + (:documentation "record relevent stats from object")) + +(defmacro increment-key (hash-table key) + `(if (gethash ,key ,hash-table) + (incf (gethash ,key ,hash-table)) + (setf (gethash ,key ,hash-table) 1))) + +(defmethod gemini-stats/record ((stats gemini-stats) (req gemini-request)) + (with-slots (visits request-map) stats + (incf visits) + (increment-key request-map + (format nil "~A" (request/path req))))) + +(defmethod gemini-stats/record ((stats gemini-stats) (response gemini-response)) + (with-slots (status-map) stats + (increment-key status-map (response/status-code response)))) + +(defun gemini-stats/record-bytes-in (gemini-stats new-bytes-in) + (with-slots (bytes-in) gemini-stats + (setf bytes-in (+ bytes-in new-bytes-in)))) + +(defun gemini-stats/record-bytes-out (gemini-stats new-bytes-out) + (with-slots (bytes-out) gemini-stats + (setf bytes-out (+ bytes-out new-bytes-out)))) + +(defun stat-printer (stats) + (lambda (stat accessor) + (format nil "~A ~A" + stat + (funcall accessor stats)))) + +(defun gather-statuses (stats) + (with-slots (status-map) stats + (sort (hash-table-alist status-map) + (lambda (a b) + (< (car a) (car b)))))) + +(defun gather-requests (stats) + (with-slots (request-map) stats + (sort (hash-table-alist request-map) + (lambda (a b) + (string< (car a) (car b)))))) + +(defun gather-timings (stats) + (with-slots (timers) stats + (hash-table-alist timers))) + +(defun print-alist (name alist) + (format nil "~{~A~%~}" + (mapcar + (lambda (pair) + (format nil "~A(~A) ~A" + name (car pair) (cdr pair))) + alist))) + +(defun timer-line (name measures) + (let ((avg (/ (reduce #'+ measures) + (length measures)))) + (format nil "~A ~,2f avg ~,2f max ~,2f min~%" + name + avg + (apply #'max measures) + (apply #'min measures)))) + +(defun handler/stats (stats) + (let ((printer (stat-printer stats))) + (lambda (req) + (declare (ignorable req)) + (success :mime-type "text/gemini" + :body (gem/doc + (gem/header "SERVER STATS") + + (gem/section "BASIC" + (gem/text (funcall printer + "total_visits" + #'gemini-stats/visits)) + (gem/text (funcall printer + "bytes_in" + #'gemini-stats/bytes-in)) + (gem/text (funcall printer + "bytes_out" + #'gemini-stats/bytes-out))) + + (gem/section "STATUS" + + (print-alist "status" + (gather-statuses stats))) + + (gem/section "REQUEST" + + (print-alist "request" + (gather-requests stats))) + + (gem/section "TIMING (NS)" + (apply #'gem/text + (mapcar (lambda (pair) + (timer-line (car pair) (cdr pair))) + (gather-timings stats))))))))) + +(defun gemini-stats/record-timing (stats req response name time) + (declare (ignorable req response)) + (with-slots (timers) stats + (setf (gethash name timers) + (cons time (gethash name timers))))) diff --git a/src/user.lisp b/src/user.lisp new file mode 100644 index 0000000..2bb1d70 --- /dev/null +++ b/src/user.lisp @@ -0,0 +1,57 @@ +(in-package :cl-gemini) + +(define-condition server-initialization-error (error) + ((text :initarg :text + :initform "an error occurred while initializing the server"))) + +(defun normalize-username (username) + (string->keyword username)) + +(defun user-entries () + (let ((*standard-output* (make-string-output-stream))) + (run '(getent passwd)) + (split #\newline (get-output-stream-string *standard-output*)))) + +(defun user-line-to-user-homedir (user-line) + (let ((props (split ":" user-line))) + (cons (normalize-username (first props)) + (directory-exists-p (sixth props))))) + +(defun user-home-directories () + (remove-if-not + #'cdr + (mapcar #'user-line-to-user-homedir + (user-entries)))) + +(defun user-gemini-dirs (public-directory) + (remove-if-not + #'cdr + (mapcar + (lambda (pair) + (cons (car pair) + (directory-exists-p + (merge-pathnames* public-directory + (cdr pair))))) + (user-home-directories)))) + +(defun make-user-handlers (pairs mime-checker) + (let ((ht (make-hash-table))) + (dolist (pair pairs) + (setf (gethash (car pair) ht) + (handler/filesystem (cdr pair) + mime-checker))) + ht)) + +(defun user-dispatcher (&key + (public-directory "gemini-public") + mime-checker) + (let ((user-handlers (make-user-handlers + (user-gemini-dirs public-directory) + mime-checker))) + (lambda (req) + (let* ((user (normalize-username (request/pop-path-element req))) + (user-handler (gethash user user-handlers))) + (if (not user-handler) + (error/not-found (format nil "unknown user: ~A" + user)) + (funcall user-handler req)))))) diff --git a/tests/main.lisp b/tests/main.lisp new file mode 100644 index 0000000..cf57346 --- /dev/null +++ b/tests/main.lisp @@ -0,0 +1,70 @@ +(defpackage cl-gemini/tests/main + (:use :cl + :cl-gemini + :rove)) + +(in-package :cl-gemini/tests/main) + +;; NOTE: To run this test file, execute `(asdf:test-system :cl-gemini)' in your Lisp. + +(deftest create-errors + (testing "temporary-redirect" + (ok (= (response/status-code + (error/temporary-redirect "gemini://nowhere")) + 30))) + (testing "permanent-redirect" + (ok (= (response/status-code + (error/permanent-redirect "gemini://nowhere")) + 31))) + (testing "temporary-failure" + (ok (= (response/status-code + (error/temporary-failure)) + 40))) + (testing "permanent-failure" + (ok (= (response/status-code + (error/permanent-failure)) + 50))) + (testing "success-code" + (ok (= (response/status-code + (success "Hello World!")) + 20))) + (testing "success-terminate-code" + (ok (= (response/status-code + (success/end-session "Hello World!")) + 21)))) + +(deftest test-portal + (testing "portal-closed" + (ok (let ((portal (test/portal)) + (err (error/temporary-failure "hi"))) + (progn (response/write portal err) + (test/closed-p portal)))))) + +(deftest check-output + (testing "simple-header" + (ok (let ((portal (test/portal)) + (err (error/temporary-failure))) + (progn (response/write portal err) + (string= (test/output portal) + (format nil "40 TEMPORARY-FAILURE~%")))))) + + (testing "header-with-message" + (ok (let ((portal (test/portal)) + (err (error/temporary-failure "hi"))) + (progn (response/write portal err) + (string= (test/output portal) + (format nil "40 TEMPORARY-FAILURE: hi~%")))))) + + (testing "success-output" + (ok (let ((portal (test/portal)) + (resp (success "Oh hello there!"))) + (progn (response/write portal resp) + (string= (test/output portal) + (format nil "20 SUCCESS~%Oh hello there!~%")))))) + + (testing "success/end-session-output" + (ok (let ((portal (test/portal)) + (resp (success/end-session "Oh hello there!"))) + (progn (response/write portal resp) + (string= (test/output portal) + (format nil "21 SUCCESS-END-OF-CLIENT-CERTIFICATE-SESSION~%Oh hello there!~%")))))))