cco/cl-scopes
3
0
Fork 0
Code Issues 1 Pull requests Releases Wiki Activity Actions

auth: minor simplifications - get rid of login / login-name slot

Browse source
This commit is contained in:
Helmut Merz 2024-08-20 19:28:44 +02:00
parent f6b21f9a43
commit 0766bcf418
3 changed files with 23 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

34
lib/auth/auth.lisp
View file

@ -23,35 +23,41 @@
(let* ((auth (make-instance 'simple-authenticator))
(ctx (core:default-setup cfg 'context :authenticator auth))
(cred (setup-credentials (admin-credentials cfg)))
(admin (make-principal :system :admin cred)))
(setf (gethash (list :system (login-name cred)) (principals auth)) admin)
(admin (make-principal :system cred)))
(setf (gethash (list :system (name cred)) (principals auth)) admin)
ctx))
(defun setup-credentials (inp)
(let ((pw (digest (cadr inp))))
(make-instance 'simple-credentials :login (car inp) :password pw)))
(make-credentials (car inp) (cadr inp)))
;;;; simple / basic auth service implementation
(defclass simple-authenticator ()
((principals :reader principals :initform (make-hash-table :test 'equal))))
;;; credentials
(defclass base-credentials ()
((login :reader login-name :initarg :login)))
((name :reader name :initarg :name)))
(defclass simple-credentials (base-credentials)
((password :reader password :initarg :password)))
(defun make-credentials (name pw &optional (cls 'simple-credentials))
(make-instance cls :name (util:to-keyword name) :password (digest pw)))
(defmethod print-object ((cred simple-credentials) stream)
(print-unreadable-object (cred stream :type t :identity t)
(format stream "~s ~s" (login-name cred) (password cred))))
(format stream "~s ~s" (name cred) (password cred))))
;;; principal (abstract / generic user object)
(defclass principal (shape:record)
((shape:head-fields :initform '(:organization :name :login))
((shape:head-fields :initform '(:organization :name))
(shape:data-fields :initform '(:credentials :full-name :email :role))))
(defun make-principal (org name cred &optional (cls 'principal))
(make-instance cls :head (list org name (login-name cred))
(defun make-principal (org cred &optional (cls 'principal))
(make-instance cls :head (list org (name cred))
:data (list :credentials cred)))
;;;; login entry point
@ -59,10 +65,8 @@
(defun login (inp)
(let* ((srv (core:find-service :auth))
(auth (authenticator srv))
(cred (make-instance 'simple-credentials
:login (getf inp :login)
:password (digest (getf inp :password))))
(prc (gethash (list :system (login-name cred)) (principals auth)))
(cred (make-credentials (getf inp :name) (getf inp :password)))
(prc (gethash (list :system (name cred)) (principals auth)))
(prc-cred (shape:data-value prc :credentials)))
(util:lgi inp cred)
(when (equalp (password cred) (password prc-cred))
@ -71,8 +75,8 @@
;;;; auxiliary functions
(defun digest (pw)
(defun digest (pw &key (scheme :original))
(b64:encode-bytes
(ironclad:digest-sequence
:sha3/256 (flexi-streams:string-to-octets pw :external-format :utf8))
:scheme :uri))
:scheme scheme))

3
lib/auth/scopes-auth.asd
View file

@ -8,7 +8,8 @@
:description "Authentication services"
:depends-on (:scopes
:flexi-streams :ironclad :qbase64)
:components ((:file "auth"))
:components ((:file "auth")
(:file "web" :depends-on ("auth")))
:long-description "scopes framework: authentication services."
;;#.(uiop:read-file-string
;; (uiop:subpathname *load-pathname* "README.md")))

3
lib/auth/test/test-auth.lisp
View file

@ -3,6 +3,7 @@
(defpackage :scopes-auth/test
(:use :common-lisp)
(:local-nicknames (:auth :scopes-auth)
(:web :scopes-auth/web)
(:client :scopes/web/client)
(:config :scopes/config)
(:core :scopes/core)
@ -32,7 +33,7 @@
(t:show-result))))
(deftest test-login ()
(let ((cred '(:login "admin" :password "secret"))
(let ((cred '(:name "admin" :password "secret"))
pr1)
(== (auth:login cred) nil)
(setf (getf cred :password) "sc0pes")