'Initial' checkin
This commit is contained in:
parent
3c868968fd
commit
1d5075c232
|
|
@ -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
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
* Cl-Gemini
|
||||
|
||||
** Usage
|
||||
|
||||
** Installation
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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)))))))
|
||||
|
|
@ -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))))))))
|
||||
|
|
@ -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))
|
||||
|
|
@ -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))))
|
||||
|
|
@ -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))))
|
||||
|
|
@ -0,0 +1 @@
|
|||
(in-package :cl-gemini)
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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))
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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)))))
|
||||
|
|
@ -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))))))
|
||||
|
|
@ -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<BREAK>~%"))))))
|
||||
|
||||
(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<BREAK>~%"))))))
|
||||
|
||||
(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<BREAK>~%Oh hello there!<BREAK>~%"))))))
|
||||
|
||||
(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<BREAK>~%Oh hello there!<BREAK>~%")))))))
|
||||
Loading…
Reference in New Issue