;;;; cl-scopes/lib/auth - authentication services

(defpackage :scopes-auth
  (:use :common-lisp)
  (:local-nicknames (:config :scopes/config)
                    (:core :scopes/core)
                    (:crypt :scopes/util/crypt)
                    (: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 (crypt:digest pw)))

(defmethod print-object ((cred simple-credentials) stream)
  (print-unreadable-object (cred stream :type t)
    (format stream "~s ~s" (name cred) (password cred))))

;;; principal (abstract / generic user object)

(defun principal-meta ()
  (make-instance 'shape:record-meta
                 :head-fields '(:organization :name)
                 :data-fields '(:credentials :full-name :email :role)))

(defclass principal (shape:record) 
  ((shape:meta :initform (principal-meta) :allocation :class)))

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