86 lines
2.8 KiB
Common Lisp
86 lines
2.8 KiB
Common Lisp
;;;; cl-scopes/lib/auth - authentication services
|
|
|
|
(defpackage :scopes-auth
|
|
(:use :common-lisp)
|
|
(:local-nicknames (:config :scopes/config)
|
|
(:core :scopes/core)
|
|
(:shape :scopes/shape)
|
|
(:util :scopes/util)
|
|
(:b64 :qbase64))
|
|
(:export #:config #:setup
|
|
#:simple-credentials
|
|
#:login))
|
|
|
|
(in-package :scopes-auth)
|
|
|
|
(defclass config (config:base)
|
|
((admin-credentials :reader admin-credentials :initarg :admin-credentials)))
|
|
|
|
(defclass context (core:context)
|
|
((authenticator :reader authenticator :initarg :authenticator)))
|
|
|
|
(defun setup (cfg)
|
|
(let* ((auth (make-instance 'simple-authenticator))
|
|
(ctx (core:default-setup cfg 'context :authenticator auth))
|
|
(cred (setup-credentials (admin-credentials cfg)))
|
|
(admin (make-principal :system cred)))
|
|
(setf (gethash (list :system (name cred)) (principals auth)) admin)
|
|
ctx))
|
|
|
|
(defun setup-credentials (inp)
|
|
(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 ()
|
|
((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" (name cred) (password cred))))
|
|
|
|
;;; principal (abstract / generic user object)
|
|
|
|
(defclass principal (shape:record)
|
|
((shape:head-fields :initform '(:organization :name))
|
|
(shape:data-fields :initform '(:credentials :full-name :email :role))))
|
|
|
|
(defun make-principal (org cred &optional (cls 'principal))
|
|
(make-instance cls :head (list org (name cred))
|
|
:data (list :credentials cred)))
|
|
|
|
(defgeneric principal-id (prc)
|
|
(:method ((prc principal))
|
|
(head-value :name prc)))
|
|
|
|
;;;; login entry point
|
|
|
|
(defun login (inp)
|
|
(let* ((srv (core:find-service :auth))
|
|
(auth (authenticator srv))
|
|
(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))
|
|
(util:lgi prc)
|
|
prc)))
|
|
|
|
;;;; auxiliary functions
|
|
|
|
(defun digest (pw &key (scheme :original))
|
|
(b64:encode-bytes
|
|
(ironclad:digest-sequence
|
|
:sha3/256 (flexi-streams:string-to-octets pw :external-format :utf8))
|
|
:scheme scheme))
|