Added change password

source/clog-web-dbi.lisp

@@ -20,6 +20,7 @@
   (logout             function)
   (get-profile        function)
   (sign-up            function)
+  (change-password    function)
   (make-token         function)
   (load-content       function)
   (create-base-tables function))
@@ -121,6 +122,54 @@ if one is present and login fails."
 			  :token    ,(make-token))))
 		     (url-replace (location body) next-step)))))))))
 
+;;;;;;;;;;;;;;;;;;;;;
+;; change-password ;;
+;;;;;;;;;;;;;;;;;;;;;
+
+(defun change-password (body sql-connection &key (title "Change Password")
+					      (next-step "/"))
+  (check-type body clog-body)
+  (clog-web-form
+   body title
+   `(("Old Password" "oldpass" :password)
+     ("New Password" "password" :password)
+     ("Retype Password" "repass" :password))
+   (lambda (result)
+     (cond ((not
+	     (equal (form-result result "password")
+		    (form-result result "repass")))
+	    (clog-web-alert body "Password Mismatch"
+			    "The new passwords do match."
+			    :time-out 3
+			    :place-top t))
+	   ((< (length (form-result result "password")) 4)
+	    (clog-web-alert body "Password Missize"
+			    "The new passwords must at least 4 characters."
+			    :time-out 3
+			    :place-top t))
+	   (t
+	    (let ((contents (dbi:fetch-all
+			     (dbi:execute
+			      (dbi:prepare
+			       sql-connection
+			       "select username from users where username=? and password=?")
+			      (list (getf (profile (get-web-site body)) :|username|)
+				    (form-result result "oldpass"))))))
+	      (cond (contents
+		     (dbi:do-sql
+		       sql-connection
+		       (sql-update
+			"users"
+			`(:password ,(form-result result "password"))
+			"username=?")
+		       (list (getf (profile (get-web-site body)) :|username|)))
+		     (url-replace (location body) next-step))
+		    (t
+		     (clog-web-alert body "Old Password"
+				     "Old password is incorrect."
+				     :time-out 3
+				     :place-top t)))))))))
+
 ;;;;;;;;;;;;;;;;
 ;; make-token ;;
 ;;;;;;;;;;;;;;;;

tutorial/32-tutorial.lisp

@@ -30,14 +30,15 @@
 ;; /content in this case on-main. So our about page has no handler set
 ;; but functions as we added to out database.
 
-                      ; Menu         Menu Item   URL        Handler   Actions Auth
-(defparameter *menu* `(("Features" (("Home"     "/")
-				    ("Login"     "/login"   on-login  :login)
-				    ("Signup"    "/signup"  on-signup :signup)
-				    ("Content"   "/content" on-main   :content)
-				    ("Logout"    "/logout"  on-logout :logout)))
-		       ("Admin"    (("User List" "/users"   on-users  :users)))
-		       ("Help"     (("About"     "/content/about"))))
+                      ; Menu         Menu Item         URL        Handler     Actions Auth
+(defparameter *menu* `(("Features" (("Home"            "/")
+				    ("Login"           "/login"   on-login    :login)
+				    ("Signup"          "/signup"  on-signup   :signup)
+				    ("Change Password" "/pass"    on-new-pass :change-password)
+				    ("Content"         "/content" on-main     :content)
+				    ("Logout"          "/logout"  on-logout   :logout)))
+		       ("Admin"    (("User List"       "/users"   on-users    :users)))
+		       ("Help"     (("About"           "/content/about"))))
   "Setup website menu")
 
 (defun start-tutorial ()
@@ -46,6 +47,7 @@
   (add-authorization '(:guest :member) '(:content-show-comments))
   (add-authorization '(:guest)         '(:login :signup))
   (add-authorization '(:member)        '(:logout
+					 :change-password
 				         :content-comment))
   (add-authorization '(:editor)        '(:content-edit))
   (add-authorization '(:admin)         '(:users :content-admin))
@@ -161,3 +163,11 @@
 				   (dolist (user users)
 				     (create-div body :content (getf user :|username|))))))
 			:authorize t))
+
+(defun on-new-pass (body)
+  (init-site body)
+  (create-web-page body
+		   :change-password `(:menu    ,*menu*
+				      :content ,(lambda (body)
+						  (change-password body *sql-connection*)))
+		   :authorize t))