aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
-rw-r--r--package.lisp3
-rw-r--r--site/home.lisp12
-rw-r--r--site/login.lisp28
-rw-r--r--site/user-known.lisp13
-rw-r--r--vampire.asd21
-rw-r--r--vampire.lisp8
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)))