From 8f418400aaa8961cbc892932a7ccc441c299f7ab Mon Sep 17 00:00:00 2001
From: Helmut Merz <helmutm@cy55.de>
Date: Sat, 17 Aug 2024 17:05:03 +0200
Subject: [PATCH] add data-fields and -values to shape:record; use for
 auth:principal

---
 core/core.lisp     |  4 ++--
 lib/auth/auth.lisp | 15 +++++++--------
 shape/shape.lisp   | 17 +++++++++++++++--
 web/server.lisp    |  2 +-
 4 files changed, 25 insertions(+), 13 deletions(-)

diff --git a/core/core.lisp b/core/core.lisp
index 7c1ff5d..b5c8dd5 100644
--- a/core/core.lisp
+++ b/core/core.lisp
@@ -53,8 +53,8 @@
     (default-actions :reader default-actions :initform nil)
     (services :reader services :initform (make-hash-table))))
 
-(defun default-setup (cfg &optional (cls 'context))
-  (make-instance cls :config cfg :name (config:name cfg)))
+(defun default-setup (cfg &optional (cls 'context) &rest args &key &allow-other-keys)
+  (apply #'make-instance cls :config cfg :name (config:name cfg) args))
 
 (defun find-service (name &optional (parent *root*))
   (with-slots (services) parent
diff --git a/lib/auth/auth.lisp b/lib/auth/auth.lisp
index 6420678..98f0035 100644
--- a/lib/auth/auth.lisp
+++ b/lib/auth/auth.lisp
@@ -4,6 +4,7 @@
   (:use :common-lisp)
   (:local-nicknames (:config :scopes/config)
                     (:core :scopes/core)
+                    (:shape :scopes/shape)
                     (:util :scopes/util))
   (:export #:config #:setup
            #:simple-credentials
@@ -15,10 +16,11 @@
   ((admin-credentials :reader admin-credentials :initarg :admin-credentials)))
 
 (defclass context (core:context)
-  ((authenticator :initform (make-instance 'simple-authenticator))))
+  ((authenticator :initarg :authenticator)))
 
 (defun setup (cfg)
-  (let* ((ctx (core:default-setup cfg 'context)))
+  (let* ((auth (make-instance 'simple-authenticator))
+         (ctx (core:default-setup cfg 'context :authenticator auth)))
     ctx))
 
 ;;;; simple / basic auth service implementation
@@ -30,12 +32,9 @@
   ((login-name)
    (password)))
 
-(defclass principal () 
-  ((identifier)
-   (credentials)
-   (full-name)
-   (primary-address)
-   (primary-role)))
+(defclass principal (shape:record) 
+  ((shape:head-fields :initform '(:organization :short-name))
+   (shape:data-fields :initform '(:credentials :full-name :email :role))))
 
 (defun authenticate (cred)
   (make-instance 'principal))
diff --git a/shape/shape.lisp b/shape/shape.lisp
index cc09a36..0a1bdfc 100644
--- a/shape/shape.lisp
+++ b/shape/shape.lisp
@@ -3,20 +3,27 @@
 (defpackage :scopes/shape
   (:use :common-lisp)
   (:local-nicknames (:util :scopes/util))
-  (:export #:record #:head-fields #:head #:head-value #:data
-           #:head-plist))
+  (:export #:record 
+           #:head-fields #:head #:head-value #:head-plist
+           #:data-fields #:data #:data-value))
 
 (in-package :scopes/shape)
 
 (defclass record ()
   ((head-fields :reader head-fields :initarg :head-fields 
                 :initform '(:taskid :username) :allocation :class)
+   (data-fields :reader data-fields :initarg :data-fields 
+                :initform nil :allocation :class)
    (head :reader head :initarg :head)
    (data :accessor data :initarg :data :initform nil)))
 
 (defmethod initialize-instance :after ((rec record) &key head &allow-other-keys)
   (setf (slot-value rec 'head) (util:rfill (head-fields rec) head)))
 
+(defmethod print-object ((rec record) stream)
+  (print-unreadable-object (rec stream :type t :identity t)
+    (format stream "~s <data ~s>" (head rec) (data rec))))
+
 (defun head-value (rec key)
   (elt (head rec) (position key (head-fields rec))))
 
@@ -28,3 +35,9 @@
     (dolist (hf (head-fields rec))
       (setf pl (cons hf (cons (util:keyword-to-string (pop hv)) pl))))
     pl))
+
+(defun data-value (rec key)
+  (getf (data rec) key))
+
+(defun (setf data-value) (val rec key)
+  (setf (getf (data rec) key) val))
diff --git a/web/server.lisp b/web/server.lisp
index 5ad4412..f05fda3 100644
--- a/web/server.lisp
+++ b/web/server.lisp
@@ -29,7 +29,7 @@
   ((listener :accessor listener)))
 
 (defun setup (cfg)
-  (let ((ctx (make-instance 'context :config cfg :name (config:name cfg))))
+  (let ((ctx (core:default-setup cfg 'context)))
     (start ctx)))
 
 ;;;; listener = server process