db-auth.lisp 3.43 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106
(mccme-helpers/packages:file mccme-helpers/db-auth
  :use (mccme-helpers/basic-db
        :iterate
        )
  :export (
           #:login-correct-p
           #:*db-auth-schema*
           #:create-user
           #:create-user-case-insensitive
           #:edit-user
           #:login-to-user-id
    )
  )

(defun login-correct-p (username password &key known-stored-hash)
  #.(sql-on)
  (and 
    username
    password
    (let* (
	   (stored-hash 
	     (or
	       known-stored-hash
	       (with-db (caar (clsql:select [password] :from [account] :where [= [account login] username])))))
	   (match (and password stored-hash (mccme-helpers/password:password-matches-p password stored-hash)))
	   )
      match
      ))

  #.(sql-off))

(defvar *db-auth-schema*)
(setf *db-auth-schema* `(
  (account (
            (login varchar (255) unique)
            (password varchar (512))
            (email varchar (255))
            ))
  ))

  #.(sql-on) 
(defun create-user (username &optional password email &rest args)
  (with-db 
   (clsql:insert-records 
    :into [account]                            
    :av-pairs `(
                (login ,username)
                (password ,(when password 
                                 (mccme-helpers/password:hash-password
                                  "sha512"
                                  username
                                  password)))
                (email ,email)
                ,@(iter (generate x in args) 
                        (collect (list 
                                  (sql-value :attribute 
                                             (next x)) 
                                  (next x))))))))

(defun create-user-case-insensitive (username &rest args)
  (with-db
   (let*
    (
     (lowlevel-ok (ignore-errors (progn (apply 'create-user username args) t)))
     (icase-ok (equal 
                (caar 
                 (clsql:select 
                  [count [id]]
                  :from [account] 
                  :where [= [lower [login]] 
                            (string-downcase username)]))
                1))
     )
    (cond
     ((not lowlevel-ok) nil)
     ((not icase-ok)
      (progn
       (clsql:delete-records :from [account] :where [= [login] username])
       nil))
     (t t)
     )
    )
   ))

(defun login-to-user-id (user)
  (and user
       (caar (clsql:select [id] :from [account] 
                           :where [= [login] user]))
       ))
#.(sql-off)

(defun edit-user (username &optional password email &rest args)
  #.(sql-on) 
  (with-db 
   (clsql:update-records 
    [account]   
    :where [= [login] username]
    :av-pairs `(
                (login ,username)
                ,@(if (and (not (equal password "")) 
			  (not (equal password nil)))  
			(list (list 'password (when password 
                                 (mccme-helpers/password:hash-password
                                  "sha512"
                                  username
                                  password)))))
107 108 109 110 111
                 ,@(cond 
                       ((equal email "")
                        (list (list 'email nil)))
                       ((not (equal email nil))
                        (list (list 'email email))))
112 113 114 115 116 117 118
                ,@(iter (generate x in args) 
                        (collect (list 
                                  (sql-value :attribute 
                                             (next x)) 
                                  (next x)))))))
  #.(sql-off))