'Initial' checkin

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))))))