auth: minor steps toward setting up default (admin) principal

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

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,27 +16,27 @@
   ((admin-credentials :reader admin-credentials :initarg :admin-credentials)))
 
 (defclass context (core:context)
-  ((authenticator :initform (make-instance 'simple-authenticator))))
+  ((authenticator :reader 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))
+         (cred (admin-credentials cfg)))
+    (setf (gethash :admin (principals auth)) cred)
     ctx))
 
 ;;;; simple / basic auth service implementation
 
 (defclass simple-authenticator () 
-  ((principals)))
+  ((principals :reader principals :initform (make-hash-table))))
 
 (defclass simple-credentials () 
   ((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))
@@ -43,8 +44,10 @@
 ;;;; login entry point
 
 (defun login (cred)
-  (let ((srv (core:find-service :auth)))
-    (util:lgi cred (admin-credentials (core:config srv)))))
+  (let* ((srv (core:find-service :auth))
+         (auth (authenticator srv))
+         (admin (gethash :admin (principals auth))))
+    (util:lgi cred admin)))
 
 ;;;; auxiliary functions
 

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))

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