diff --git a/lib/auth/auth.lisp b/lib/auth/auth.lisp index 37ac06b..272a3b7 100644 --- a/lib/auth/auth.lisp +++ b/lib/auth/auth.lisp @@ -60,6 +60,10 @@ (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) diff --git a/lib/auth/test/test-auth.lisp b/lib/auth/test/test-auth.lisp index 80b5808..01b92c6 100644 --- a/lib/auth/test/test-auth.lisp +++ b/lib/auth/test/test-auth.lisp @@ -33,10 +33,10 @@ (t:show-result)))) (deftest test-login () - (let ((cred '(:name "admin" :password "secret")) - pr1) + (let (cred pr1) + (setf cred '(:name "admin" :password "secret")) (== (auth:login cred) nil) - (setf (getf cred :password) "sc0pes") + (setf cred '(:name "admin" :password "sc0pes")) (setf pr1 (auth:login cred)) (== (shape:head-value pr1 :name) :admin) )) diff --git a/scopes-core.asd b/scopes-core.asd index 7987c34..1f61413 100644 --- a/scopes-core.asd +++ b/scopes-core.asd @@ -7,7 +7,7 @@ :homepage "https://www.cyberconcepts.org" :description "Core packages of the scopes project." :depends-on (:alexandria :cl-dotenv :com.inuoe.jzon - :local-time :log4cl :str) + :flexi-streams :ironclad :local-time :log4cl :qbase64 :str) :components ((:file "config" :depends-on ("util")) (:file "core/core" :depends-on ("core/message" "config" diff --git a/scopes-web.asd b/scopes-web.asd index 3f8400a..53311f0 100644 --- a/scopes-web.asd +++ b/scopes-web.asd @@ -12,8 +12,9 @@ :components ((:file "frontend/cs-hx" :depends-on ("web/dom" "web/response")) (:file "web/client") (:file "web/dom") + (:file "web/jwt") (:file "web/response" :depends-on ("web/dom")) - (:file "web/server" :depends-on ("web/response"))) + (:file "web/server" :depends-on ("web/jwt" "web/response"))) :long-description "scopes/web: Web server and web/API/REST client." :in-order-to ((test-op (test-op "scopes-web/test")))) diff --git a/scratch.lisp b/scratch.lisp index c9fa849..a9e84e7 100644 --- a/scratch.lisp +++ b/scratch.lisp @@ -16,24 +16,3 @@ (defun iter-current (it) (funcall it #'(lambda (p) (car (svref p 0))))) -#+ecl -(defun classes () - (let ((r nil)) - (maphash #'(lambda (k v) - (setf r (cons k r))) si:*class-name-hash-table*) - (sort r #'(lambda (x y) - (string<= (package-name (symbol-package x)) - (package-name (symbol-package y))))))) - -(defun x-make-var (value) - #'(lambda (nv) - (if (null nv) - value - (setf value nv)))) - -(defun x-get-var (vf) - (funcall vf nil)) - -(defun x-put-var (vf value) - (funcall vf value)) - diff --git a/util.lisp b/util.lisp index e1f4e69..9521551 100644 --- a/util.lisp +++ b/util.lisp @@ -2,14 +2,20 @@ (defpackage :scopes/util (:use :common-lisp) + (:local-nicknames (:b64 :qbase64)) + #+sbcl (:import-from :sb-ext #:add-package-local-nickname) (:export #:lg #:lgd #:lgi + #:create-secret #: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 - #:relative-path #:runtime-path #:system-path)) + #:relative-path #:runtime-path #:system-path + #:add-package-local-nickname)) (in-package :scopes/util) +;;;; logging shortcuts + (defmacro lg (level &rest vars) (let ((lm (find-symbol (string level) :log)) (fm (format nil "~{~(~a~): ~~S ~}" vars))) @@ -18,6 +24,11 @@ (defmacro lgd (&rest vars) `(lg :debug ,@vars)) (defmacro lgi (&rest vars) `(lg :info ,@vars)) +;;;; secrets, digests, and other crypto stuff + +(defun create-secret () + (b64:encode-bytes (ironclad:random-data 16))) + ;;;; lists and loops (defun rfill (ll ls) diff --git a/web/jwt.lisp b/web/jwt.lisp index 3376bcc..6fc8371 100644 --- a/web/jwt.lisp +++ b/web/jwt.lisp @@ -1,187 +1,12 @@ ;;;; cl-scopes/web/jwt - JWT creation and validation -;;;; based on: cljwt +;;;; inspired by: cljwt (defpackage :scopes/web/jwt (:use :common-lisp) (:local-nicknames (:alx :alexandria) - (:b64 :cl-base64) + (:b64 :qbase64) (:fxs :flexi-streams) (:ic :ironclad) (:jzon :com.inuoe.jzon)) - (:export #:issue #:decode - #:unsecured-token #:invalid-hmac - #:unsupported-algorithm #:invalid-time #:expired #:not-yet-valid)) - -(in-package :scopes/web/jwt) - -(defconstant *unix-time-base* (encode-universal-time 0 0 0 1 1 1970 0)) - -(defmacro bind-hash-tables (bindings &body body) - `(let ,(loop for binding in bindings collect - (list (car binding) - `(etypecase ,(cadr binding) - (hash-table ,(cadr binding)) - (list (plist-hash-table ,(cadr binding) - :test #'equal))))) - ,@body)) - -(defmacro add-claims (hash &rest claims) - `(progn ,@(loop for (key value) on claims by #'cddr collect - `(when ,value - (setf (gethash ,key ,hash) ,value))))) - -(defun to-unix-time (time) - (when time (- time *unix-time-base*))) - -(defun from-unix-time (time) - (when time (+ time *unix-time-base*))) - -(defun base64-encode (input) - "Takes a string or octets, returns an unpadded URI-encoded Base64 string." - (etypecase input - (string (base64-encode (fxs:string-to-octets input :external-format :utf-8))) - ((simple-array (unsigned-byte 8)) - (with-output-to-string (out) - (with-input-from-string (in (b64:usb8-array-to-base64-string input :uri t)) - (loop for character = (read-char in nil) - while character do - ;; CL-BASE64 always uses padding, which must be removed. - (unless (eq character #\.) - (write-char character out)))))))) - -(defun base64-decode (base-64-string) - "Takes a base64-uri string and return an array of octets" - (b64:base64-string-to-usb8-array - ;; Re-pad the string, or CL-BASE64 will get confused - (concatenate 'string - base-64-string - (make-array (rem (length base-64-string) 4) - :element-type 'character - :initial-element #\.)) - :uri t)) - -(defun issue (claims &key algorithm secret issuer subject audience - expiration not-before issued-at id more-header) - "Encodes and returns a JSON Web Token. Times are in universal-time, -number of seconds from 1900-01-01 00:00:00" - (bind-hash-tables ((claimset claims) - (header more-header)) - ;; Add registered claims to the claims hash table - (add-claims claimset - "iss" issuer - "sub" subject - "aud" audience - "exp" (to-unix-time expiration) - "nbf" (to-unix-time not-before) - "iat" (to-unix-time issued-at) - "jti" id) - ;; Add type and algorithm to the header hash table - (add-claims header - "typ" "JWT" - "alg" (ecase algorithm - (:none "none") - (:hs256 "HS256"))) - ;; Prepare JSON - (let ((header-string (base64-encode - (with-output-to-string (s) - (jzon:stringify header s)))) - (claims-string (base64-encode - (with-output-to-string (s) - (jzon:stringify claimset s))))) - ;; Assemble and, if applicable, sign the JWT - (format nil "~A.~A.~@[~A~]" - header-string - claims-string - (when (eq algorithm :hs256) - (HS256-digest header-string - claims-string - secret)))))) - -(defun HS256-digest (header-string claims-string secret) - "Takes header and claims in Base64, secret as a string or octets, -returns the digest, in Base64" - (base64-encode - (ic:hmac-digest - (ic:update-hmac - (ic:make-hmac (etypecase secret - ((simple-array (unsigned-byte 8)) - secret) - (string - (string-to-octets secret - :external-format :utf-8))) - 'ironclad:SHA256) - (concatenate '(vector (unsigned-byte 8)) - (string-to-octets - header-string) - #(46) ; ASCII period (.) - (string-to-octets - claims-string)))))) - -(defun compare-HS256-digest (header-string claims-string - secret reported-digest) - "Takes header and claims in Base64, secret as a string or octets, and a digest in Base64 to compare with. Signals an error if there is a mismatch." - (let ((computed-digest - (HS256-digest header-string - claims-string - secret))) - (unless (equalp computed-digest - reported-digest) - (cerror "Continue anyway" 'invalid-hmac - :reported-digest reported-digest - :computed-digest computed-digest)))) - -(defun decode (jwt-string &key secret fail-if-unsecured) - "Decodes and verifies a JSON Web Token. Returns two hash tables, -token claims and token header" - (destructuring-bind (header-string claims-string digest-string) - (str:split #\. jwt-string) - (let* ((header-hash (jzon:parse (octets-to-string (base64-decode header-string) - :external-format :utf-8))) - (claims-hash (jzon:parse (octets-to-string (base64-decode claims-string) - :external-format :utf-8))) - (algorithm (gethash "alg" header-hash))) - ;; Verify HMAC - (cond ((equal algorithm "HS256") - (compare-HS256-digest header-string - claims-string - secret - digest-string)) - ((and (or (null algorithm) (equal algorithm "none")) fail-if-unsecured) - (cerror "Continue anyway" 'unsecured-token)) - (t (cerror "Continue anyway" 'unsupported-algorithm - :algorithm algorithm))) - ;; Verify timestamps - (let ((expires (from-unix-time (gethash "exp" claims-hash))) - (not-before (from-unix-time (gethash "nbf" claims-hash))) - (current-time (get-universal-time))) - (when (and expires (> current-time expires)) - (cerror "Continue anyway" 'expired :delta (- current-time expires))) - (when (and not-before (< current-time not-before)) - (cerror "Continue anyway" 'not-yet-valid :delta (- current-time not-before)))) - ;; Return hashes - (values claims-hash header-hash)))) - -;;; Conditions - -(define-condition unsecured-token (error) ()) - -(define-condition invalid-hmac (error) ()) - -(define-condition unsupported-algorithm (error) - ((algorithm :initarg :algorithm :reader algorithm)) - (:report (lambda (condition stream) - (format stream "Algorithm \"~A\" not supported" - (algorithm condition))))) - -(define-condition invalid-time (error) - ((delta :initarg :delta :reader time-delta)) - (:report (lambda (condition stream) - (format stream "Token ~A. ~D seconds off." - (typecase condition - (expired "has expired") - (not-yet-valid "is not yet valid")) - (time-delta condition))))) - -(define-condition expired (invalid-time) ()) - -(define-condition not-yet-valid (invalid-time) ()) + (:export #:issue #:decode)) +