From 9b51a908448c23eff673934f023d247a6c47519d Mon Sep 17 00:00:00 2001
From: Grant Shangreaux <grant@unabridgedsoftware.com>
Date: Fri, 31 May 2024 13:39:05 -0500
Subject: Add: initial login form and authentication

---
 package.lisp         |  3 ++-
 site/home.lisp       | 12 ------------
 site/login.lisp      | 28 +++++++++++++++++++++++++++-
 site/user-known.lisp | 13 +++++++++++++
 vampire.asd          | 21 ++++++++++++++-------
 vampire.lisp         |  8 +++++++-
 6 files changed, 63 insertions(+), 22 deletions(-)
 create mode 100644 site/user-known.lisp

diff --git a/package.lisp b/package.lisp
index e88297e..b069148 100644
--- a/package.lisp
+++ b/package.lisp
@@ -26,4 +26,5 @@
                 #:when-let*
                 #:if-let
                 #:subseq*)
-  (:import-from #:defclass-std #:defclass/std))
+  (:import-from #:defclass-std #:defclass/std)
+  (:import-from #:spinneret #:with-html #:with-html-string))
diff --git a/site/home.lisp b/site/home.lisp
index 97c2a87..b96b52e 100644
--- a/site/home.lisp
+++ b/site/home.lisp
@@ -1,17 +1,5 @@
 (in-package #:vampire)
 
-(defclass user-known ()
-  ((user :accessor user)))
-
-(defmethod wknd:authenticate ((req user-known))
-  (or
-   (do>
-     key :when= (wknd:get-cookie +session-cookie+)
-     session :when= (object-with-key key)
-     :when (typep session 'session)
-     (setf (user req) (user session)))
-   (weekend:endpoint-redirect 'login)))
-
 (defun home-page (user)
   (format nil "hey ~a" (user-name user)))
 
diff --git a/site/login.lisp b/site/login.lisp
index afbd80e..66d20ff 100644
--- a/site/login.lisp
+++ b/site/login.lisp
@@ -1,10 +1,36 @@
 (in-package #:vampire)
 
 (defun login-page ()
-  "login")
+  (with-html-string
+    (:div (:h1 "I vant to suck your blood")
+	  (:form :method "POST" :action "/login"
+		 (:input :placeholder "Name" :name "name")
+		 (:br)
+		 (:input :placeholder "Password" :type "password" :name "password")
+		 (:br)
+		 (:button :type "submit" "Click to Login")))
+    (:a :href "/new-account" "Come to the Dark Side")))
 
 (wknd:defendpoint login
   :get :route "login"
   :returns "text/html"
   :handle (login-page))
 
+(wknd:defendpoint login-user
+  :post :route "login"
+  :parameters
+  (name string)
+  (password string)
+  :properties
+  (user user)
+  :authenticate (authenticate-login-user name password)
+  :handle (wknd:endpoint-redirect 'home))
+
+(defun authenticate-login-user (name password)
+  (do>
+    found-user :when= (user-with-name name)
+    :when (equal (user-pwhash found-user)
+		 (hash-string password (user-pwsalt found-user)))
+    session := (db:with-transaction () (make-instance 'session :user found-user))
+    (wknd:set-cookie +session-cookie+ :value (key session))))
+
diff --git a/site/user-known.lisp b/site/user-known.lisp
new file mode 100644
index 0000000..1c48c9a
--- /dev/null
+++ b/site/user-known.lisp
@@ -0,0 +1,13 @@
+(in-package #:vampire)
+
+(defclass user-known ()
+  ((user :accessor user)))
+
+(defmethod wknd:authenticate ((req user-known))
+  (or
+   (do>
+     key :when= (wknd:get-cookie +session-cookie+)
+     session :when= (object-with-key key)
+     :when (typep session 'session)
+     (setf (user req) (user session)))
+   (weekend:endpoint-redirect 'login)))
diff --git a/vampire.asd b/vampire.asd
index c618e3b..3b82f1c 100644
--- a/vampire.asd
+++ b/vampire.asd
@@ -14,6 +14,8 @@
                #:derrida
                #:ironclad
                #:jonathan
+	       #:lass
+	       #:spinneret
                #:swank
 	       #:zippy
                #:flatbind)
@@ -24,13 +26,18 @@
                (:file "downloader")
                (:file "model")
                (:file "session")
-               ;(:file "navigation")
-               ;(:file "about")
-               ;(:file "new-account")
-               ;(:file "explore")
-               ;(:file "login")
-               ;(:file "home")
-               ;(:file "playlist")
+	       (:module "site/"
+		:serial t
+		:components(
+			    ;;(:file "navigation")
+			    ;;(:file "about")
+			    ;;(:file "new-account")
+			    ;;(:file "explore")
+			    (:file "user-known")
+			    (:file "login")
+			    (:file "home")
+			    ;;(:file "playlist")
+			    ))
                (:file "vampire")
                (:file "run")
                (:file "zipper")
diff --git a/vampire.lisp b/vampire.lisp
index 247ff4d..86ef4fa 100644
--- a/vampire.lisp
+++ b/vampire.lisp
@@ -41,13 +41,19 @@
 (defun when-logged-in? (fn)
   (<?> 'session-user fn 'redirect-to-root))
 
-
+(defvar *server*)
+(setf (documentation '*server* 'variable)
+      "The hunchentoot acceptor instance")
 
 (defun start-vampire (config)
   (setf *config* config)
   (initialize-database config )
   (start-downloader-service config)
 
+  (setf *server* (make-instance 'hunchentoot:easy-acceptor
+				:port (port config)))
+  (hunchentoot:start *server*)
+
   (when (swank-port config)
     (swank:create-server :port (swank-port config) :dont-close t)))
 
-- 
cgit v1.2.3