58 lines
1.8 KiB
Common Lisp
58 lines
1.8 KiB
Common Lisp
(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))))))
|