web, auth: work in progress: jwt generation
This commit is contained in:
parent
e71544c09f
commit
5fec210f2f
7 changed files with 26 additions and 206 deletions
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
))
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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"))))
|
||||
|
||||
|
|
|
|||
21
scratch.lisp
21
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))
|
||||
|
||||
|
|
|
|||
13
util.lisp
13
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)
|
||||
|
|
|
|||
183
web/jwt.lisp
183
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))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue