diff --git a/lib/auth/auth.lisp b/lib/auth/auth.lisp index 272a3b7..0bde7bb 100644 --- a/lib/auth/auth.lisp +++ b/lib/auth/auth.lisp @@ -44,10 +44,11 @@ ((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))) + (make-instance cls :name (util:to-keyword name) + :password (util:digest pw))) (defmethod print-object ((cred simple-credentials) stream) - (print-unreadable-object (cred stream :type t :identity t) + (print-unreadable-object (cred stream :type t) (format stream "~s ~s" (name cred) (password cred)))) ;;; principal (abstract / generic user object) @@ -76,11 +77,3 @@ (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)) diff --git a/shape/shape.lisp b/shape/shape.lisp index 0a1bdfc..690b8db 100644 --- a/shape/shape.lisp +++ b/shape/shape.lisp @@ -21,8 +21,12 @@ (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 " (head rec) (data rec)))) + (print-unreadable-object (rec stream :type t) + (format-fields rec stream 'head 'data))) + +(defun format-fields (item stream &rest fields) + (let ((fm (format nil "~{~(~a~): ~~S ~}" fields))) + (apply #'format stream fm (mapcar #'(lambda (x) (funcall x item)) fields)))) (defun head-value (rec key) (elt (head rec) (position key (head-fields rec)))) diff --git a/util.lisp b/util.lisp index 9521551..8b41c19 100644 --- a/util.lisp +++ b/util.lisp @@ -5,7 +5,7 @@ (:local-nicknames (:b64 :qbase64)) #+sbcl (:import-from :sb-ext #:add-package-local-nickname) (:export #:lg #:lgd #:lgi - #:create-secret + #:create-secret #:digest #:rfill #:rtrim #:loop-plist #:filter-plist #:plist-pairs #:plist-equal #:flatten-str #:to-keyword #:keyword-to-string #:to-integer #:to-string #:absolute-dir #:check-dir #:ensure-dir #:home-path #:path-from-string @@ -29,6 +29,12 @@ (defun create-secret () (b64:encode-bytes (ironclad:random-data 16))) +(defun digest (pw &key (scheme :original) (alg :sha256)) + (b64:encode-bytes + (ironclad:digest-sequence alg + (flexi-streams:string-to-octets pw :external-format :utf8)) + :scheme scheme)) + ;;;; lists and loops (defun rfill (ll ls)