diff options
| -rw-r--r-- | package.lisp | 3 | ||||
| -rw-r--r-- | site/home.lisp | 12 | ||||
| -rw-r--r-- | site/login.lisp | 28 | ||||
| -rw-r--r-- | site/user-known.lisp | 13 | ||||
| -rw-r--r-- | vampire.asd | 21 | ||||
| -rw-r--r-- | vampire.lisp | 8 |
6 files changed, 63 insertions, 22 deletions
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))) |