;;;; 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 :admin cred)))
    (setf (gethash (list :system (login-name cred)) (principals auth)) admin)
    ctx))

(defun setup-credentials (inp)
  (let ((pw (digest (cadr inp))))
    (make-instance 'simple-credentials :login (car inp) :password pw)))

;;;; simple / basic auth service implementation

(defclass simple-authenticator () 
  ((principals :reader principals :initform (make-hash-table :test 'equal))))

(defclass base-credentials ()
  ((login :reader login-name :initarg :login)))

(defclass simple-credentials (base-credentials) 
   ((password :reader password :initarg :password)))

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

(defclass principal (shape:record) 
  ((shape:head-fields :initform '(:organization :name :login))
   (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)) 
                     :data (list :credentials cred)))

;;;; login entry point

(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)))
         (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)
  (b64:encode-bytes
    (ironclad:digest-sequence 
      :sha3/256 (flexi-streams:string-to-octets pw :external-format :utf8))
    :scheme :uri))